mod_parallel.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE mod_parallel
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This module contains all variables used for parallelization         !
!                                                                      !
!=======================================================================
!
      USE mod_kinds
!
      implicit none
 
#ifdef MPI
!
      include 'mpif.h'
#endif
!
      PUBLIC :: allocate_parallel
      PUBLIC :: deallocate_parallel
      PUBLIC :: initialize_parallel
 
#if defined DISTRIBUTE && defined DISJOINTED
      PUBLIC :: split_communicator
      PUBLIC :: assign_communicator
#endif
!
!-----------------------------------------------------------------------
!  Define variables in module.
!-----------------------------------------------------------------------
!
!  Switch to identify master processor. In serial and shared-memory
!  applications it is always true.
!
      logical :: master
!
!  Switch to identify which thread is processing input/output files.
!  In distributed-memory applications, this thread can be the master
!  thread or all threads in case of parallel output. In serial and
!  shared-memory applications it is always true.
!
      logical :: inpthread
      logical :: outthread
 
!$OMP THREADPRIVATE (InpThread, OutThread)
!
!  Number of shared-memory parallel threads or distributed-memory
!  parallel nodes.
!
      integer :: numthreads
#ifndef DISJOINTED
      integer :: forksize
#endif
!
!  First and last tile to process in a tiled application.
!
      integer, allocatable :: first_tile(:)
      integer, allocatable :: last_tile(:)
 
!$OMP THREADPRIVATE (first_tile, last_tile)
 
#if defined ATM_COUPLING && defined MCT_LIB
!
!  Parallel nodes assined to the atmosphere model.
!
      integer :: peatm_frst            ! first atmosphere parallel node
      integer :: peatm_last            ! last  atmosphere parallel node
#endif
#if defined WAV_COUPLING && defined MCT_LIB
!
!  Parallel nodes assined to the wave model.
!
      integer :: pewav_frst            ! first atmosphere parallel node
      integer :: pewav_last            ! last  atmosphere parallel node
#endif
!
!  Parallel nodes assined to the ocean model.
!
      integer :: peocn_frst            ! first ocean parallel node
      integer :: peocn_last            ! last  ocean parallel node
!
!  Parallel threads/nodes counters used in critical parallel regions.
!
      integer :: tile_count = 0
      integer :: block_count = 0
      integer :: thread_count = 0
!
!  Profiling variables as function of parallel thread:
!
!    proc          Parallel process ID.
!    Cstr          Starting time for program region.
!    Cend          Ending time for program region.
!    Csum          Accumulated time for progam region.
!    Ctotal        Total time profiled
!    total_cpu     Total elapsed CPU
!
      integer, allocatable :: proc(:,:,:)
 
      real(r8) :: ctotal, total_cpu, total_model(4)
 
      real(r8), allocatable :: cstr(:,:,:)
      real(r8), allocatable :: cend(:,:,:)
      real(r8), allocatable :: csum(:,:,:)
 
!$OMP THREADPRIVATE (proc)
!$OMP THREADPRIVATE (Cstr, Cend)
 
#if defined DISTRIBUTE && defined PROFILE
!
!  Switch manage time clock in "mp_bcasts". During initialization is
!  set to .FALSE. because the profiling variables cannot be allocated
!  and initialized before the "Ngrids" parameter is known.
!
      logical :: lwclock = .false.
#endif
!
!  Distributed-memory master process.
!
      integer :: mymaster = 0
 
#ifdef DISTRIBUTE
# if defined DISJOINTED        || \
    (defined pio_lib           && \
     (defined asynchronous_pio || defined asynchronous_scorpio))
!
!  Split communicator parameters.
!
#  if defined DISJOINTED
      logical :: fullmaster     ! full communicator master process
 
      integer :: forkcolor = -1 ! Fork split criteria: FullRank/ForkSize
      integer :: forkkey        ! Fork split rank ordering: FullRank
      integer :: forksize       ! number of processes in FORK_COMM_WORLD
      integer :: fullsize       ! number of precesses in FULL_COMM_WORLD
      integer :: nsubgroups     ! number of disjointed subgroups
      integer :: taskcolor = -1 ! Task split criteria: FullRank/TaskSize
      integer :: taskkey        ! Task split rank ordering: FullRank
      integer :: tasksize       ! number of processes in TASK_COMM_WORLD
#  endif
#  if defined PIO_LIB          && \
     (defined asynchronous_pio || defined asynchronous_scorpio)
      integer :: peerrank       ! process rank in PEER_COMM_WORLD
      integer :: peersize       ! number of processes in PEER_COMM_WORLD
#  endif
# endif
#endif
!
!  Rank of the parallel local process.
!
      integer :: fullrank = 0
      integer :: taskrank = 0
      integer :: myrank = 0
      integer :: mythread = 0
 
!$OMP THREADPRIVATE (MyThread)
 
#ifdef DISTRIBUTE
# ifdef MPI
!
!  Distributed-memory group communicator handles.
!
#  if defined PIO_LIB          && defined DISTRIBUTE           && \
     (defined asynchronous_pio || defined asynchronous_scorpio)
      integer :: peer_comm_world            ! PIO full communicator
      integer :: inter_comm_world           ! PIO inter-communicator
      integer :: io_comm_world              ! I/O dedicated communicator
#  endif
#  ifdef DISJOINTED
      integer :: full_comm_world            ! full communicator
      integer :: fork_comm_world            ! fork communicator
      integer :: task_comm_world            ! task communicator
#  endif
      integer :: ocn_comm_world             ! internal ROMS communicator
!
!  Set mpi_info opaque object handle.
!
      integer :: mp_info = mpi_info_null
# endif
!
!  Type of message-passage floating point bindings.
!
# ifdef DOUBLE_PRECISION
#  ifdef MPI
      integer, parameter :: mp_float = mpi_double_precision
!!    integer, parameter :: MP_FLOAT = MPI_REAL8
#  endif
# else
#  ifdef MPI
      integer, parameter :: mp_float = mpi_real
!!    integer, parameter :: MP_FLOAT = MPI_REAL4
#  endif
# endif
# ifdef MPI
      integer, parameter :: mp_double = mpi_double_precision
# endif
#endif
!
      CONTAINS
!
      SUBROUTINE allocate_parallel (Ngrids)
!
!=======================================================================
!                                                                      !
!  This routine allocates several variables in the module that depend  !
!  on the number of nested grids.                                      !
!                                                                      !
!=======================================================================
!
      USE mod_strings, ONLY: nregion
!
!  Imported variable declarations.
!
      integer, intent(in) :: ngrids
!
!-----------------------------------------------------------------------
!  Allocate and initialize module variables.
!-----------------------------------------------------------------------
!
!$OMP PARALLEL
!  First and last tile to process in a tiled application.
!
      IF (.not.allocated(first_tile)) THEN
        allocate ( first_tile(ngrids) )
      END IF
      IF (.not.allocated(last_tile)) THEN
        allocate ( last_tile(ngrids) )
      END IF
!
!  Time profiling variables.
!
      IF (.not.allocated(proc)) THEN
        allocate ( proc(0:1,4,ngrids) )
        proc(0:1,1:4,1:ngrids)=0
      END IF
 
      IF (.not.allocated(cstr)) THEN
        allocate ( cstr(0:nregion,4,ngrids) )
        cstr(0:nregion,1:4,1:ngrids)=0.0_r8
      END IF
 
      IF (.not.allocated(cend)) THEN
        allocate ( cend(0:nregion,4,ngrids) )
        cend(0:nregion,1:4,1:ngrids)=0.0_r8
      END IF
!$OMP END PARALLEL
 
      IF (.not.allocated(csum)) THEN
        allocate ( csum(0:nregion,4,ngrids) )
        csum(0:nregion,1:4,1:ngrids)=0.0_r8
      END IF
!
! Initialize other profiling variables.
!
      ctotal=0.0_r8
      total_cpu=0.0_r8
      total_model=0.0_r8
 
#if defined DISTRIBUTE && defined PROFILE
!
! Activate wall clock switch used only in "mp_bcasts". This switch
! is set to .FALSE. during initialization before calling "inp_par.F"
! because the above profiling variables are allocated and initialized
! after the value of "Ngrids" is known.
!
      lwclock=.true.
#endif
 
      RETURN
      END SUBROUTINE allocate_parallel
!
      SUBROUTINE deallocate_parallel
!
!=======================================================================
!                                                                      !
!  This routine deallocates variables in the module.                   !
!                                                                      !
!=======================================================================
!
!-----------------------------------------------------------------------
!  Deallocate variables in module.
!-----------------------------------------------------------------------
!
!$OMP PARALLEL
      IF (allocated(first_tile)) deallocate ( first_tile )
      IF (allocated(last_tile))  deallocate ( last_tile )
!
      IF (allocated(proc))       deallocate ( proc )
      IF (allocated(cstr))       deallocate ( cstr )
      IF (allocated(cend))       deallocate ( cend )
!$OMP END PARALLEL
 
      IF (allocated(csum))       deallocate ( csum )
!
      RETURN
      END SUBROUTINE deallocate_parallel
!
      SUBROUTINE initialize_parallel
!
!=======================================================================
!                                                                      !
!  This routine initializes and spawn distribute-memory nodes.         !
!                                                                      !
!=======================================================================
!
      USE mod_iounits
      USE mod_scalars
!
!  Local variable declarations.
!
      integer :: i
#ifdef DISTRIBUTE
      integer :: myerror
#else
      integer :: my_numthreads, my_threadnum
#endif
 
#if defined _OPENMP
!
!-----------------------------------------------------------------------
!  Initialize shared-memory (OpenMP) configuration.
!-----------------------------------------------------------------------
!
!  Disable dynamic adjustment, by the run-time environment, of the
!  number of threads available to execute parallel regions.
!
      CALL omp_set_dynamic (.false.)
!
!  Inquire number of threads in parallel region.  Set master and I/O
!  switches.
!
      numthreads=my_numthreads()
      IF (my_threadnum().eq.0) THEN
        inpthread=.true.
        outthread=.true.
      ELSE
        inpthread=.false.
        outthread=.false.
      END IF
      master=.true.
 
#elif defined DISTRIBUTE
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Initialize distributed-memory (MPI) configuration.
!-----------------------------------------------------------------------
!
!  Get the number of processes in the group associated with the world
!  communicator.  Here FullRank and MyRank are the same. It is computed
!  for consistency wity concurrent applications.
!
      CALL mpi_comm_size (ocn_comm_world, numthreads, myerror)
      IF (myerror.ne.0) THEN
        WRITE (stdout,10)
  10    FORMAT (/,' ROMS - Unable to inquire number of',                &
     &            ' processors in the group.')
        exit_flag=6
        RETURN
      END IF
      CALL mpi_comm_rank (ocn_comm_world, fullrank, myerror)
      forksize=numthreads
!
!  Identify master, input and output threads.
!
#  ifdef PARALLEL_IO
      master=.false.
      inpthread=.true.
      outthread=.true.
      IF (myrank.eq.mymaster) THEN
        master=.true.
      END IF
#  else
      master=.false.
      inpthread=.false.
      outthread=.false.
      IF (myrank.eq.mymaster) THEN
        master=.true.
        inpthread=.true.
        outthread=.true.
      END IF
#  endif
# endif
#else
!
!-----------------------------------------------------------------------
!  Initialize serial configuration.
!-----------------------------------------------------------------------
!
      numthreads=my_numthreads()
      master=.true.
      inpthread=.true.
      outthread=.true.
#endif
!
      RETURN
      END SUBROUTINE initialize_parallel
 
#if defined DISTRIBUTE && defined DISJOINTED
!
      SUBROUTINE split_communicator (Nsplit, Ntasks)
!
!=======================================================================
!                                                                      !
!  This routine splits the main distributed-memory communicator object !
!  (OCN_COMM_WORLD saved as FULL_COMM_WORLD) into several disjointed   !
!  subgroups processes with new communicator handle (FORK_COMM_WORLD). !
!  Notice that at entry, the OCN_COMM_WORLD handle is the same object  !
!  as MPI_COMM_WORLD, if no multi-model coupling.                      !
!                                                                      !
!  If Ntask=2, a second split is done. Both tasks (1 and 2) have equal !
!  number processors. Task 1 uses the first half, whereas Task 2 uses  !
!  the second half of all the processes assigned to ROMS. The extra    !
!  communicator handle (TASK_COMM_WORLD) can be used for collective    !
!  operations within each task section.                                !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     Nsplit     Number of disjointed by related subgroups (integer)   !
!     Ntasks     Number of different code sections tasks (integer)     !
!                  Usually, Ntasks=1 or Ntasks=2                       !
!                                                                      !
!  Therefore,                                                          !
!                                                                      !
!     ForkSize        Number of processes assigned for each subgroup:  !
!                       ForkSize = FullSize/(Nplit*Ntasks)             !
!                                                                      !
!     FullSize        Total number of processes assigned to ROMS       !
!                                                                      !
!     TaskSize        Number of processes assigned for each task       !
!                       TaskSize=FullSize/Ntasks                       !
!                                                                      !
!     NsubGroups      Total number of disjointed subgroups             !
!                       NsubGroups=Nsplit*Ntasks                       !
!                                                                      !
!=======================================================================
!
      USE mod_iounits
      USE mod_scalars
!
!  Imported variable declarations
!
      integer, intent(in) :: nsplit, ntasks
!
!  Local variable declarations.
!
      integer :: myerror, mysize
      integer :: i, lstr, serror
!
      integer, allocatable :: groupranks(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
!
!-----------------------------------------------------------------------
!  Split ROMS communicator into disjointed subgroups, FORK_COMM_WORLD.
!  It is used, for example, for the concurrent time-stepping of the
!  ROMS kernel.
!-----------------------------------------------------------------------
!
!  Save full communicator (starting handle) and inquire about its size
!  and rank.
!
      full_comm_world=ocn_comm_world
      CALL mpi_comm_rank (full_comm_world, fullrank, myerror)
      CALL mpi_comm_size (full_comm_world, fullsize, myerror)
      fullmaster=fullrank.eq.mymaster
!
!  Split the full communicator into sub-communicators based on color and
!  key. It is a collective operation.
!
!  For example, if FullSize=8 and Nsplit=2, we get ForkSize=4 and:
!
!  FullRank:    0    1    2    3    4    5    6    7    FULL_COMM_WORLD
!  ForkColor:   0    0    0    0    1    1    1    1    split criteria
!  ForkKey:     0    1    2    3    4    5    6    7    same as FullRank
!  ForkRank:    0    1    2    3    0    1    2    3    FORK_COMM_WORLD
!
!
!  The color determines in which of the sub-communicators the current
!  process (spawn by FULL_COMM_WORLD) will fall.
!
!  The key argument determines the rank ordering within the split
!  communicator. The process that passes in the smallest value for
!  key will be rank 0, the next smallest will be rank 1, and so on.
!  Here, the key is set to the rank of the full communicator since we
!  want all of the processes in the split communicator to be in the
!  same order that they were in the full communicator.
!
!  The resulting communicator, FORK_COMM_WORLD, has the same handle
!  value (context ID) in all sub-communicators. However, each process
!  only have reference to the sub-communicator that it belongs. It is
!  an opaque object.
!
      nsubgroups=nsplit*ntasks
      IF (mod(fullsize, nsubgroups).ne.0) THEN
        IF (fullmaster) THEN
          WRITE (stdout,10) nsubgroups, fullsize
        END IF
        exit_flag=2
        RETURN
      END IF
      forksize=fullsize/nsubgroups               ! integer operation
      forkcolor=fullrank/forksize                ! integer operation
      forkkey=fullrank
      CALL mpi_comm_split (full_comm_world, forkcolor, forkkey,         &
     &                     fork_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,20) 'MPI_COMM_SPLIT', 'TASK_COMM_WORLD',          &
     &                     fullrank, myerror, trim(string)
        exit_flag=2
        RETURN
      END IF
!
!-----------------------------------------------------------------------
!  If Ntasks=2, split the FULL_COMM_WORLD into disjointed tasks
!  communicators.
!-----------------------------------------------------------------------
!
      IF (ntasks.gt.1) THEN
        tasksize=fullsize/ntasks
        taskcolor=fullrank/tasksize
        taskkey=fullrank
        CALL mpi_comm_split (full_comm_world, taskcolor, taskkey,       &
     &                       task_comm_world, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          WRITE (stdout,20) 'MPI_COMM_SPLIT', 'TASK_COMM_WORLD',        &
     &                      fullrank, myerror, trim(string)
          exit_flag=2
          RETURN
        END IF
        CALL mpi_comm_rank (task_comm_world, taskrank, myerror)
      ELSE
        task_comm_world=full_comm_world
        tasksize=fullsize
        taskrank=fullrank
        taskkey=0
        taskcolor=0
      END IF
!
 10   FORMAT (/,' SPLIT_COMMUNICATOR - illegal configuration, ',        &
     &        'Nsplit * Ntasks = ',i0,/,22x,                            &
     &        'needs to be less, equal, or a multiple of the ',         &
     &        'communicator size, FullSize = ',i0,/,22x,                &
     &        'That is, MOD(FullSise, Nsplit*Ntask)=0')
 20   FORMAT (/,' SPLIT_COMMUNICATOR - error during ',a,                &
     &        ' call, Comm = ',a,', Rank = ',i0,' Error = ',i0,/,22x,a)
!
      RETURN
      END SUBROUTINE split_communicator
!
      SUBROUTINE assign_communicator (choice)
!
!=======================================================================
!                                                                      !
!  This routine selects request distributed memory communicator and    !
!  it associated parameters and control switches.  It assigns the      !
!  requested communicator to the OCN_COMM_WORLD handle.                !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     choice       Requested communicator keyword (string)             !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations.
!
      character (len=*), intent(in) :: choice
!
!  Local variable declarations.
!
      integer :: myerror
!
!-----------------------------------------------------------------------
!  Assing internal ROMS communicator, OCN_COMM_WORLD.
!-----------------------------------------------------------------------
!
!  Set communicator handle and get its size and rank.
!
      SELECT CASE (trim(choice))
        CASE ('FORK', 'SPLIT', 'CONCURRENT')
          ocn_comm_world=fork_comm_world
          CALL mpi_comm_size (ocn_comm_world, numthreads, myerror)
          CALL mpi_comm_rank (ocn_comm_world, myrank, myerror)
          master=myrank.eq.mymaster
        CASE ('FULL')
          ocn_comm_world=full_comm_world
          CALL mpi_comm_size (ocn_comm_world, numthreads, myerror)
          CALL mpi_comm_rank (ocn_comm_world, myrank, myerror)
          master=myrank.eq.mymaster
      END SELECT
      CALL mpi_barrier (ocn_comm_world, myerror)
!
!  Initialize parallel control switches.
!
# ifdef PARALLEL_IO
      inpthread=.true.
      outthread=.true.
# else
      IF (myrank.eq.0) THEN
        inpthread=.true.
        outthread=.true.
      ELSE
        inpthread=.false.
        outthread=.false.
      END IF
# endif
!
      RETURN
      END SUBROUTINE assign_communicator
#endif
 
      END MODULE mod_parallel