affinity/fms_affinity.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19
  20 !> @defgroup fms_affinity_mod fms_affinity_mod
  21 !> @ingroup affinity
  22 !> @brief Fortran API interfaces to set the thread affinity.
  23 !! API interfaces to allow setting and getting thread affinity.  The routines @ref get_cpuset
  24 !! , @ref set_cpu_affinity , and @ref fms_affinity_get are defined via C routines in affinity.c.
  25 !!
  26 !! @author Rusty Benson
  27
  28 !> @addtogroup fms_affinity_mod
  29 !> @{
  30 module fms_affinity_mod
  31   !--- standard system modules
  32   use, intrinsic :: iso_c_binding, only: c_int, c_bool
  33   use omp_lib
  34
  35   !--- FMS modules
  36   use mpp_mod,    only: input_nml_file, mpp_pe, stdlog
  37   use fms_mod,    only: fms_init, check_nml_error, write_version_number, &
  38                         error_mesg, FATAL, NOTE
  39
  40   !--- default scoping
  41   implicit none
  42   private
  43
  44   interface
  45
  46     !> Interface to get affinity from the current component.
  47     !!
  48     !> Defined in @ref affinity.c.
  49     integer(KIND=c_int) function fms_affinity_get() bind(c, name="get_cpu_affinity")
  50       import c_int
  51     end function fms_affinity_get
  52
  53     !> Private interface to retrieve this groups CPU set and it's size.
  54     !!
  55     !> Defined in @ref affinity.c.
  56     integer(KIND=c_int) function get_cpuset(fsz, output, pe, debug) bind(c, name="get_cpuset")
  57       import c_int, c_bool
  58       integer(KIND=c_int), value, intent(in) :: fsz, pe
  59       integer(KIND=c_int), dimension(*), intent(inout) :: output
  60       logical(KIND=c_bool), value :: debug
  61     end function get_cpuset
  62
  63     !> Private interface to set CPU afinity to a given core.
  64     !!
  65     !> Defined in @ref affinity.c.
  66     integer(KIND=c_int) function set_cpu_affinity(cpu) bind(c, name="set_cpu_affinity")
  67       import c_int
  68       integer(KIND=c_int), value, intent(in) :: cpu
  69     end function set_cpu_affinity
  70   end interface
  71
  72   !--- namelist parameters
  73   logical:: affinity = .true.
  74   logical:: strict = .true.
  75   logical:: debug_affinity = .false.
  76   logical(c_bool):: debug_cpuset = .false.
  77   namelist /fms_affinity_nml/ affinity, strict, debug_affinity, debug_cpuset
  78
  79   public fms_affinity_init, fms_affinity_get, fms_affinity_set
  80
  81   !---- version number
  82   ! Include variable "version" to be written to log file.
  83 #include <file_version.h>
  84
  85   logical :: module_is_initialized = .FALSE.
  86
  87 contains
  88
  89   !> Initialization routine for affinity handling
  90   subroutine fms_affinity_init()
  91     !--- local variables
  92     integer:: io_stat
  93     integer:: ierr
  94     integer:: iunit
  95
  96     !--- return if module is initialized
  97     if (module_is_initialized) return
  98
  99     !--- ensure fms/mpp has been initialized
 100     call fms_init()
 101
 102     !--- read in namelist
 103     read(input_nml_file, fms_affinity_nml, iostat=io_stat)
 104     ierr = check_nml_error(io_stat,'fms_affinity_nml')
 105
 106     !--- output information to logfile
 107     call write_version_number("fms_affinity_mod", version)
 108     iunit = stdlog()
 109     write(iunit,nml=fms_affinity_nml)
 110
 111     module_is_initialized = .TRUE.
 112
 113   end subroutine fms_affinity_init
 114
 115
 116   !> Routine to set affinity for a component
 117   subroutine fms_affinity_set (component, use_hyper_thread, nthreads)
 118     !--- interface variables
 119     character(len=*),  intent(in):: component !< Component name
 120     logical,           intent(in):: use_hyper_thread !< .TRUE. if using hyperthreads
 121     integer,           intent(in):: nthreads !< Number of threads
 122
 123     !--- local declarations for Fortran/C affinity interoperability
 124     integer(c_int):: cpuset_sz
 125     integer(c_int), dimension(:), allocatable:: cpu_set
 126     integer(c_int):: retcode
 127
 128     !--- local variables
 129     character(len=32):: h_name
 130     integer:: MSG_TYPE
 131     integer:: th_num
 132     integer:: indx
 133
 134     if (.not. module_is_initialized) call fms_affinity_init()
 135     if (.not. affinity) return
 136
 137     if (strict) then
 138       MSG_TYPE = FATAL
 139     else
 140       MSG_TYPE = NOTE
 141     endif
 142
 143     h_name = 'generic                         '
 144
 145     !--- allocate storage for cpuset
 146     if (use_hyper_thread) then
 147       cpuset_sz = nthreads
 148     else
 149       cpuset_sz = nthreads * 2
 150     endif
 151     allocate (cpu_set(0:cpuset_sz-1))
 152
 153     !--- get cpuset for this MPI-rank
 154     retcode = get_cpuset(cpuset_sz, cpu_set, mpp_pe(), debug_cpuset)
 155     if (retcode == -1) then
 156       call error_mesg('fms_affinity_set',trim(component)//' cpu_set size > allocated storage',FATAL)
 157     elseif ( (retcode == cpuset_sz/2) .and. (retcode == nthreads) ) then
 158       call error_mesg('fms_affinity_set',trim(component)//' affinity assumes hyper-threading hardware disabled',NOTE)
 159     elseif (retcode < cpuset_sz) then
 160       call error_mesg('fms_affinity_set',trim(component)//' cpu_set size smaller than expected',MSG_TYPE)
 161     endif
 162
 163     !--- set the affinity for the MPI-rank
 164     retcode = set_cpu_affinity(cpu_set(0))
 165     if (retcode == -1) then
 166       call error_mesg('fms_affinity_set',trim(component)//': issue setting cpu affinity', FATAL)
 167     endif
 168
 169     !--- set affinity for threads associated with this MPI-rank
 170 !$OMP PARALLEL NUM_THREADS (nthreads) &
 171 !$OMP&         DEFAULT (none) &
 172 !$OMP&         SHARED (use_hyper_thread, cpuset_sz, component, cpu_set, debug_affinity) &
 173 !$OMP&         PRIVATE (th_num, indx, retcode, h_name)
 174 !$  th_num = omp_get_thread_num()
 175     !--- handle hyper threading case by alternating threads between logical and virtual cores
 176 !$  if (use_hyper_thread) then
 177 !$    if (mod(th_num,2) == 0 ) then
 178 !$      indx = th_num/2
 179 !$    else
 180 !$      indx = (cpuset_sz - 1) - ((cpuset_sz - 1) - th_num)/2
 181 !$    endif
 182 !$  else
 183 !$    indx = th_num
 184 !$  endif
 185 !$  retcode = set_cpu_affinity(cpu_set(indx))
 186 !$  if (retcode == -1) then
 187 !$    call error_mesg('fms_affinity_set',trim(component)//': issue setting cpu affinity', FATAL)
 188 !$  endif
 189     !--- output affinity placement
 190 !$  if (debug_affinity) then
 191 !$    call hostnm(h_name)
 192 !$    print *, 'DEBUG:',mpp_pe(),trim(component),' ',trim(h_name),fms_affinity_get(),th_num
 193 !$  endif
 194 !$OMP END PARALLEL
 195
 196   end subroutine fms_affinity_set
 197 end module fms_affinity_mod