modomp.f90

Go to the documentation of this file.

! Copyright (C) 2015 J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.

module modomp

use omp_lib

! maximum number of OpenMP threads available
integer maxthd
! maximum number of OpenMP threads for the first nesting level
integer maxthd1
! maximum number of threads available to MKL
integer maxthdmkl
! maximum OpenMP nesting level
integer maxlvl
! number of active OpenMP threads for each nesting level
integer, allocatable, protected :: nathd(:)

interface

integer function mkl_set_num_threads_local(num_threads)
integer, intent(in) :: num_threads
end function

end interface

contains

subroutine omp_init
implicit none
! determine the maximum number of available threads
select case(maxthd)
case(:-1)
! set the number of threads equal to a fraction of the number of processors
  maxthd=omp_get_num_procs()/abs(maxthd)
  if (maxthd < 1) maxthd=1
  call omp_set_num_threads(maxthd)
case(0)
! use the system default number of threads
  maxthd=omp_get_max_threads()
case default
! use the number of threads specified in the input file
  call omp_set_num_threads(maxthd)
end select
! determine the maximum number of threads available at first nesting level
select case(maxthd1)
case(:-1)
  maxthd1=maxthd/abs(maxthd1)
  if (maxthd1 < 1) maxthd1=1
case(0)
  maxthd1=maxthd
case default
  if (maxthd1 > maxthd) maxthd1=maxthd
end select
! switch off dynamic allocation of threads
call omp_set_dynamic(.false.)
! allow nested parallelism (deprecated in OpenMP version 5)
call omp_set_nested(.true.)
! set the maximum nesting level
call omp_set_max_active_levels(maxlvl)
! allocate the number of active threads array
if (allocated(nathd)) deallocate(nathd)
allocate(nathd(0:maxlvl))
! initialise the number of active threads
call omp_reset
end subroutine

subroutine omp_reset
implicit none
! number of active threads at each nesting level
nathd(0)=1
nathd(1:maxlvl)=0
end subroutine

subroutine holdthd(nloop,nthd)
implicit none
! arguments
integer, intent(in) :: nloop
integer, intent(out) :: nthd
! local variables
integer lvl,na,n
! current nesting level
lvl=omp_get_level()
if ((lvl < 0).or.(lvl >= maxlvl)) then
  nthd=1
  return
end if
! determine number of active threads at the current nesting level
na=nathd(lvl)
if (na < 1) na=1
if (na > maxthd) na=maxthd
! number of threads allowed for this loop
nthd=maxthd/na
if (mod(maxthd,na) > 0) nthd=nthd+1
if (lvl == 0) then
  if (nthd > maxthd1) nthd=maxthd1
end if
if (nthd < 1) nthd=1
if (nthd > nloop) nthd=nloop
if (nthd > maxthd) nthd=maxthd
! add to number of active threads in next nesting level
n=nathd(lvl+1)+nthd
if (n < 0) n=0
if (n > maxthd) n=maxthd
!$OMP ATOMIC WRITE
nathd(lvl+1)=n
end subroutine

subroutine freethd(nthd)
implicit none
! arguments
integer, intent(in) :: nthd
! local variables
integer lvl,n
! current nesting level
lvl=omp_get_level()
if ((lvl < 0).or.(lvl >= maxlvl)) return
! subtract from the number of active threads in next nesting level
n=nathd(lvl+1)-nthd
if (n < 0) n=0
if (n > maxthd) n=maxthd
!$OMP ATOMIC WRITE
nathd(lvl+1)=n
end subroutine

end module