LCOV - code coverage report
Current view: | top level - utils - spmd_utils.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 122 | 478 | 25.5 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 3 | 12 | 25.0 %

              Line data    Source code
           1             : module spmd_utils
           2             :
           3             : !-----------------------------------------------------------------------
           4             : !
           5             : ! Purpose: This module is responsible for miscellaneous SPMD utilities
           6             : !          and information that are shared between dynamics and
           7             : !          physics packages.
           8             : !
           9             : ! Author:
          10             : !   Original routines:  CMS
          11             : !   Module:             T. Henderson, December 2003
          12             : !   swap routines:      P. Worley
          13             : !   fc routines:        P. Worley
          14             : !   SMP node id logic:  P. Worley
          15             : !
          16             : ! $Id$
          17             : !
          18             : !-----------------------------------------------------------------------
          19             :
          20             : !
          21             : ! Performance bug work around for Gemini interconnect
          22             : !
          23             : #ifdef _NO_MPI_RSEND
          24             : #define mpi_rsend mpi_send
          25             : #define mpi_irsend mpi_isend
          26             : #endif
          27             :
          28             : !-----------------------------------------------------------------------
          29             : !- use statements ------------------------------------------------------
          30             : !-----------------------------------------------------------------------
          31             :    use shr_kind_mod,     only: r8 => shr_kind_r8
          32             :    use cam_abortutils,   only: endrun
          33             :
          34             : #if ( defined SPMD )
          35             :    use mpishorthand, only: mpiint, mpii8, mpichar, mpilog, mpipk,      &
          36             :                            mpic16, mpir8, mpir4, mpicom, mpimax
          37             : #endif
          38             :    use cam_logfile,  only: iulog
          39             :
          40             : !-----------------------------------------------------------------------
          41             : !- module boilerplate --------------------------------------------------
          42             : !-----------------------------------------------------------------------
          43             :    implicit none
          44             :    include 'mpif.h'
          45             :    private                   ! Make the default access private
          46             :    save
          47             : !
          48             : ! Forward from mpishorthand.F with the idea of phasing out use of and removing that file
          49             : !
          50             : #ifndef SPMD
          51             :
          52             :    integer :: mpir8
          53             : #endif
          54             : !
          55             : !  Forward these from mpif.h (or mpi.mod), the idea being that this should
          56             : !  be the only module that uses mpi directly, the rest of cam should use spmd_utils
          57             : !
          58             :    public :: mpi_max_processor_name, mpi_max_error_string, mpi_error,        &
          59             :              mpi_integer, mpi_integer8, mpi_character, mpi_double_precision, &
          60             :              mpi_logical, mpi_real8, mpi_real4, mpi_complex16,               &
          61             :              mpi_packed, mpi_tag_ub, mpi_info_null,                          &
          62             :              mpi_comm_null, mpi_group_null, mpi_undefined,                   &
          63             :              mpi_status_size, mpi_success, mpi_status_ignore,                &
          64             :              mpi_max, mpi_min, mpi_sum, mpi_band, mpir8
          65             : #if ( defined SPMD )
          66             :    public :: mpi_address_kind
          67             : #endif
          68             :
          69             : !-----------------------------------------------------------------------
          70             : ! Public interfaces ----------------------------------------------------
          71             : !-----------------------------------------------------------------------
          72             :    public pair      ! $$$here...  originally from eul|sld/spmd_dyn
          73             :    public ceil2     ! $$$here...  originally from eul|sld/spmd_dyn
          74             :    public spmdinit
          75             :    public spmd_utils_readnl
          76             : #if ( defined SPMD )
          77             :    public swapm
          78             :    public fc_gatherv
          79             :    public fc_gathervr4
          80             :    public fc_gathervint
          81             :    public fc_gathervc
          82             :    public altalltoallv
          83             : #endif
          84             :
          85             : !-----------------------------------------------------------------------
          86             : ! Public communication types--------------------------------------------
          87             : !-----------------------------------------------------------------------
          88             :    type, public :: spmd_col_trans
          89             :       ! spmd_col_trans holds information for setting up a communications pattern
          90             :       integer :: source_task
          91             :       integer :: source_index
          92             :       integer :: dest_task
          93             :       integer :: dest_index
          94             :       integer :: mpi_tag
          95             :    end type spmd_col_trans
          96             :
          97             :    type, public :: column_redist_t
          98             :       ! column_redist_t holds information needed to redistribute columns
          99             :       ! Fields used for both send and receive
         100             :       integer          :: mpi_comm = MPI_COMM_NULL  ! Comm for dest tasks
         101             :       integer          :: recv_iam = -1             ! rank in mpi_comm
         102             :       integer          :: recv_master_id = -1       ! rank of mpi_comm 'master'
         103             :       integer          :: max_nflds = 0             ! max fields at one time
         104             :       integer          :: num_rounds = 0            ! # of field sum blocks
         105             :       integer, pointer :: dest_tasks(:) => NULL()   ! Destination tasks
         106             :       integer, pointer :: col_starts(:) => NULL()   ! Global start col per dest
         107             :       integer, pointer :: num_rflds(:) => NULL()    ! # flds per round
         108             :       ! Data used by receiving tasks
         109             :       integer, pointer :: recv_cnts(:) => NULL()    ! # cols from each PE
         110             :       integer, pointer :: recv_disps(:) => NULL()   ! col offsets from each PE
         111             :       integer, pointer :: recv_reorder(:) => NULL() ! Reordering after receive
         112             :       ! Data used by sending tasks
         113             :       integer          :: strt_nfld = -1            ! first field for this task
         114             :       integer          :: my_nflds = 0              ! # fields for this task
         115             :       integer, pointer :: task_sizes(:) => NULL()   ! # of task cols per dest
         116             :       integer, pointer :: task_indices(:) => NULL() ! Global index for each col
         117             :       integer, pointer :: send_disps(:) => NULL()   ! cols offsets to each PE
         118             :       integer, pointer :: send_reorder(:) => NULL() ! Reordering before send
         119             :    end type column_redist_t
         120             :
         121             : !-----------------------------------------------------------------------
         122             : ! Public data ----------------------------------------------------------
         123             : !-----------------------------------------------------------------------
         124             : ! physics-motivated dynamics decomposition request
         125             :    logical, parameter :: def_mirror = .false.                 ! default
         126             :    logical, public    :: phys_mirror_decomp_req = def_mirror
         127             :                          ! flag indicating whether latitudes and their
         128             :                          ! reflections across the equator should be
         129             :                          ! assigned to consecutive processes
         130             :
         131             : #if (defined SPMD)
         132             :    public :: mpicom
         133             :    public :: mpichar
         134             : #else
         135             :    integer, public              :: mpicom
         136             :    integer, public              :: mpichar
         137             : #endif
         138             :    logical, public              :: masterproc
         139             :    integer, public              :: masterprocid
         140             :    integer, public              :: iam
         141             :    integer, public              :: npes
         142             :    integer, public              :: nsmps
         143             :    integer, allocatable, public :: proc_smp_map(:)
         144             :    ! DEFAULT_MASTERPROC is the value of iam which is assigned masterproc duties
         145             :    integer, parameter           :: DEFAULT_MASTERPROC = 0
         146             :    ! spmd_col_trans_mpi_type is a handle to be used for column reordering
         147             :    integer, public, protected   :: spmd_col_trans_mpi_type
         148             :
         149             : !-----------------------------------------------------------------------
         150             : ! Private data ---------------------------------------------------------
         151             : !-----------------------------------------------------------------------
         152             : ! Swap communication protocol options (reduced set):
         153             : !  3, 5:                  nonblocking send
         154             : !  2, 3, 4, 5:            nonblocking receive
         155             : !  4, 5:                  ready send
         156             :    integer, private, parameter :: min_comm_protocol =  2
         157             :    integer, private, parameter :: max_comm_protocol =  5
         158             :    integer, private, parameter :: def_comm_protocol =  4        ! default
         159             :    integer, public :: swap_comm_protocol = def_comm_protocol
         160             :
         161             : ! Swap communication maximum request count:
         162             : ! = -1,0: do not limit number of outstanding send/receive requests
         163             : !    > 0: do not allow more than swap_comm_maxreq outstanding
         164             : !         nonblocking send requests or nonblocking receive requests
         165             :    integer, private, parameter :: def_comm_maxreq = 128        ! default
         166             :    integer, public :: swap_comm_maxreq = def_comm_maxreq
         167             :
         168             : ! Flow-controlled gather option:
         169             : !   < 0: use MPI_Gather
         170             : !  >= 0: use point-to-point with handshaking messages and
         171             : !        preposting receive requests up to
         172             : !         min(max(1,fc_gather_flow_cntl),max_gather_block_size)
         173             : !        ahead
         174             :    integer, private, parameter :: max_gather_block_size = 64 ! max and default
         175             :    integer, public :: fc_gather_flow_cntl = max_gather_block_size
         176             :
         177             : !-----------------------------------------------------------------------
         178             : ! Subroutines and functions --------------------------------------------
         179             : !-----------------------------------------------------------------------
         180             : contains
         181             :
         182             : !========================================================================
         183             :
         184           0 :    integer function pair(np,p,k)
         185             :
         186             :       integer np,p,k,q
         187           0 :       q = ieor(p,k)
         188           0 :       if(q.gt.np-1) then
         189             :          pair = -1
         190             :       else
         191           0 :          pair = q
         192             :       endif
         193             :       return
         194             :
         195             :    end function pair
         196             :
         197             : !========================================================================
         198             :
         199           0 :   integer function ceil2(n)
         200             :      integer n,p
         201           0 :      p=1
         202           0 :      do while(p.lt.n)
         203           0 :         p=p*2
         204             :      enddo
         205           0 :      ceil2=p
         206             :      return
         207             :   end function ceil2
         208             :
         209             : !========================================================================
         210             :
         211        1536 :   subroutine spmdinit( mpicom_atm )
         212             :     !-----------------------------------------------------------------------
         213             :     !
         214             :     ! Purpose: MPI initialization routine:
         215             :     !
         216             :     ! Method: get number of cpus, processes, tids, etc
         217             :     !         dynamics and physics decompositions are set up later
         218             :     !
         219             :     ! Author: CCM Core Group
         220             :     !
         221             :     !-----------------------------------------------------------------------
         222             :
         223             :     implicit none
         224             :     integer, intent(in) :: mpicom_atm
         225             :
         226             : #if ( defined SPMD )
         227             :     !
         228             :     ! Local workspace
         229             :     !
         230             :     integer i,j,c             ! indices
         231             :     integer npthreads         ! thread status
         232             :     integer ier               ! return error status
         233             :     integer length            ! length of name
         234             :     integer max_len           ! maximum name length
         235        1536 :     integer, allocatable :: lengths(:)! max lengths of names for use in gatherv
         236        1536 :     integer, allocatable :: displs(:) ! offsets for use in gatherv
         237             :     logical done
         238        1536 :     character, allocatable                             :: proc_name(:)  ! processor name, this task
         239        1536 :     character, allocatable                             :: proc_names(:) ! processor names, all tasks
         240             :     character(len=mpi_max_processor_name)              :: tmp_name      ! temporary storage
         241        1536 :     character(len=mpi_max_processor_name), allocatable :: smp_names(:)  ! SMP name
         242             :     logical mpi_running       ! returned value indicates if MPI_INIT has been called
         243             :     ! For creating new MPI type for column info transfer
         244             :     integer                        :: h1, hind
         245             :     integer                        :: ierr
         246             :     integer(kind=MPI_ADDRESS_KIND) :: offsets(6)   ! For new MPI types
         247             :     integer                        :: origtypes(6) ! For new MPI types
         248             :     integer(kind=MPI_ADDRESS_KIND) :: extent       ! For new MPI types
         249             :     type(spmd_col_trans)           :: dummy_loc(2) ! For new MPI types
         250             :     type(spmd_col_trans)           :: col_trans_type_temp
         251             :
         252             :     !---------------------------------------------------------------------------
         253             :     !
         254             :     ! Determine CAM MPI communicator group
         255             :     !
         256        1536 :     mpicom  = mpicom_atm
         257             :     !
         258             :     ! Set mpishorthand variables.  Need to set as variables rather than parameters since
         259             :     ! some MPI implementations set values for MPI tags at run time
         260             :     !
         261        1536 :     mpiint  = mpi_integer
         262        1536 :     mpii8   = mpi_integer8
         263        1536 :     mpichar = mpi_character
         264        1536 :     mpilog  = mpi_logical
         265        1536 :     mpir4   = mpi_real4
         266        1536 :     mpir8   = mpi_real8
         267        1536 :     mpic16  = mpi_complex16
         268        1536 :     mpipk   = mpi_packed
         269        1536 :     mpimax  = mpi_max
         270             :     !
         271             :     ! Get my id
         272             :     !
         273        1536 :     call mpi_comm_rank (mpicom, iam, ier)
         274        1536 :     masterprocid = DEFAULT_MASTERPROC
         275        1536 :     if (iam == DEFAULT_MASTERPROC) then
         276           2 :        masterproc = .true.
         277             :     else
         278        1534 :        masterproc = .false.
         279             :     end if
         280             :     !
         281             :     ! Get number of processors
         282             :     !
         283        1536 :     max_len = mpi_max_processor_name
         284        1536 :     call mpi_comm_size (mpicom, npes, ier)
         285        4608 :     allocate ( displs(npes) )
         286        3072 :     allocate ( lengths(npes) )
         287        3072 :     allocate ( proc_name(max_len) )
         288        3072 :     allocate ( proc_names(max_len*npes) )
         289             :
         290             :     !
         291             :     ! Get processor names and send to root.
         292             :     !
         293        1536 :     call mpi_get_processor_name (tmp_name, length, ier)
         294      196608 :     proc_name(:) = ' '
         295       12288 :     do i = 1, length
         296       12288 :        proc_name(i) = tmp_name(i:i)
         297             :     end do
         298             :
         299   149816832 :     proc_names(:) = ' '
         300     1181184 :     lengths(:) = max_len
         301     1181184 :     do i=1,npes
         302     1181184 :        displs(i) = (i-1)*max_len
         303             :     enddo
         304             :     call fc_gathervc (proc_name,  max_len, mpichar, &
         305             :                       proc_names, lengths, displs, mpichar, &
         306        1536 :                       0, mpicom, flow_cntl=-1)
         307        1536 :     if (masterproc) then
         308           2 :        write(iulog,*) npes, 'pes participating in computation'
         309           2 :        write(iulog,*) '-----------------------------------'
         310           2 :        write(iulog,*) 'TASK#  NAME'
         311         516 :        do i=0,min(npes-1,256)  ! dont print too many of these
         312       65792 :           do c=1,max_len
         313       65792 :              tmp_name(c:c) = proc_names(i*max_len+c)
         314             :           enddo
         315         516 :           write(iulog,'(i3,2x,a)') i,trim(tmp_name)
         316             :        end do
         317           2 :        if(npes-1>256) then
         318           2 :           write(iulog,*) '... list truncated at 256'
         319             :        end if
         320             :     end if
         321             :     !
         322             :     ! Identify SMP nodes and process/SMP mapping.
         323             :     ! (Assume that processor names are SMP node names on SMP clusters.)
         324             :     !
         325        4608 :     allocate ( proc_smp_map(0:npes-1) )
         326        1536 :     if (masterproc) then
         327           6 :        allocate ( smp_names(0:npes-1) )
         328        1538 :        smp_names(:) = ' '
         329        1538 :        proc_smp_map(:) = -1
         330             :        !
         331           2 :        nsmps = 1
         332         256 :        do c=1,max_len
         333         256 :           tmp_name(c:c) = proc_names(c)
         334             :        enddo
         335           2 :        smp_names(0) = trim(tmp_name)
         336           2 :        proc_smp_map(0) = 0
         337             :        !
         338        1536 :        do i=1,npes-1
         339      196352 :           do c=1,max_len
         340      196352 :              tmp_name(c:c) = proc_names(i*max_len+c)
         341             :           enddo
         342             :
         343             :           j = 0
         344             :           done = .false.
         345        6898 :           do while ((.not. done) .and. (j < nsmps))
         346        5364 :              if (smp_names(j) .eq. trim(tmp_name)) then
         347        1524 :                 proc_smp_map(i) = j
         348        1524 :                 done = .true.
         349             :              endif
         350        5364 :              j = j + 1
         351             :           enddo
         352             :
         353        1536 :           if (.not. done) then
         354          10 :              smp_names(nsmps) = trim(tmp_name)
         355          10 :              proc_smp_map(i) = nsmps
         356          10 :              nsmps = nsmps + 1
         357             :           endif
         358             :
         359             :        enddo
         360           2 :        deallocate(smp_names)
         361             :     endif
         362        1536 :     call mpibcast(nsmps, 1, mpiint, 0, mpicom)
         363        1536 :     call mpibcast(proc_smp_map, npes, mpiint, 0, mpicom)
         364             :     !
         365        1536 :     deallocate(displs)
         366        1536 :     deallocate(lengths)
         367        1536 :     deallocate(proc_name)
         368        1536 :     deallocate(proc_names)
         369             :
         370             :      ! Create a type for transferring column information
         371        1536 :      allocate(lengths(6))
         372       10752 :      lengths(:) = 1
         373       10752 :      origtypes(:) = MPI_INTEGER
         374        1536 :      h1 = 0
         375        1536 :      h1 = h1 + 1
         376             :      call MPI_Get_address(dummy_loc(1)%source_task,  offsets(h1), ierr)
         377        1536 :      h1 = h1 + 1
         378        1536 :      call MPI_Get_address(dummy_loc(1)%source_index, offsets(h1), ierr)
         379        1536 :      h1 = h1 + 1
         380        1536 :      call MPI_Get_address(dummy_loc(1)%dest_task,    offsets(h1), ierr)
         381        1536 :      h1 = h1 + 1
         382        1536 :      call MPI_Get_address(dummy_loc(1)%dest_index,   offsets(h1), ierr)
         383        1536 :      h1 = h1 + 1
         384        1536 :      call MPI_Get_address(dummy_loc(1)%mpi_tag,      offsets(h1), ierr)
         385        9216 :      do hind = h1, 1, -1
         386        9216 :         offsets(hind) = offsets(hind) - offsets(1)
         387             :      end do
         388           0 :      call MPI_type_create_struct(h1, lengths(1:h1), offsets(1:h1),            &
         389        1536 :           origtypes(1:h1), col_trans_type_temp, ierr)
         390             :      ! Adjust for padding
         391        1536 :      call MPI_Get_address(dummy_loc(1)%source_task, offsets(1), ierr)
         392        1536 :      call MPI_Get_address(dummy_loc(2)%source_task, offsets(2), ierr)
         393        1536 :      extent = offsets(2) - offsets(1)
         394             :      call MPI_type_create_resized(col_trans_type_temp, 0_MPI_ADDRESS_KIND,    &
         395        1536 :           extent, spmd_col_trans_mpi_type, ierr)
         396        1536 :     call MPI_type_commit(spmd_col_trans_mpi_type, ierr)
         397        1536 :     deallocate(lengths)
         398             :
         399             : #else
         400             :     !
         401             :     ! spmd is not defined
         402             :     !
         403             :     mpicom = mpicom_atm
         404             :     iam = 0
         405             :     masterprocid = 0
         406             :     masterproc = .true.
         407             :     npes = 1
         408             :     nsmps = 1
         409             :     allocate ( proc_smp_map(0:0) )
         410             :     proc_smp_map(:) = -1
         411             :
         412             : #endif
         413             :
         414        9216 :   end subroutine spmdinit
         415             :
         416             : #if (defined SPMD)
         417             : !
         418             : !========================================================================
         419             : !
         420           0 :    subroutine swapm (steps, nprocs, swapids,               &
         421           0 :                      sndbuf, sbuf_siz, sndlths, sdispls,   &
         422           0 :                      rcvbuf, rbuf_siz, rcvlths, rdispls,   &
         423             :                      comm, comm_protocol, comm_maxreq      )
         424             :
         425             : !-----------------------------------------------------------------------
         426             : !
         427             : ! Purpose:
         428             : !   Reduced version of original swapm (for swap of multiple messages
         429             : !   using MPI point-to-point routines), more efficiently implementing a
         430             : !   subset of the swap protocols.
         431             : !
         432             : ! Method:
         433             : ! comm_protocol:
         434             : !  = 3 or 5: use nonblocking send
         435             : !  = 2 or 4: use blocking send
         436             : !  = 4 or 5: use handshaking protocol
         437             : ! comm_maxreq:
         438             : !  =-1,0: do not limit number of outstanding send/receive requests
         439             : !     >0: do not allow more than min(comm_maxreq, steps) outstanding
         440             : !         nonblocking send requests or nonblocking receive requests
         441             : !
         442             : ! Author of original version:  P. Worley
         443             : ! Ported to CAM: P. Worley, December 2003
         444             : ! Simplified version: P. Worley, October, 2008
         445             : !
         446             : !-----------------------------------------------------------------------
         447             :
         448             : !-----------------------------------------------------------------------
         449             :    implicit none
         450             : !---------------------------Input arguments--------------------------
         451             : !
         452             :    integer, intent(in)   :: steps              ! number of swaps to initiate
         453             :    integer, intent(in)   :: nprocs             ! size of communicator
         454             :    integer, intent(in)   :: sbuf_siz           ! size of send buffer
         455             :    integer, intent(in)   :: rbuf_siz           ! size of receive buffer
         456             :    integer, intent(in)   :: swapids(steps)     ! MPI process id of swap partners
         457             :
         458             :    integer, intent(in)   :: sndlths(0:nprocs-1)! length of outgoing message
         459             :    integer, intent(in)   :: sdispls(0:nprocs-1)! offset from beginning of send
         460             :                                                !  buffer where outgoing messages
         461             :                                                !  should be sent from
         462             :    integer, intent(in)   :: rcvlths(0:nprocs-1)! length of incoming messages
         463             :    integer, intent(in)   :: rdispls(0:nprocs-1)! offset from beginning of receive
         464             :                                                !  buffer where incoming messages
         465             :                                                !  should be placed
         466             :    real(r8), intent(in)  :: sndbuf(sbuf_siz)   ! outgoing message buffer
         467             :    real(r8), intent(out) :: rcvbuf(rbuf_siz)   ! incoming message buffer
         468             :
         469             :    integer, intent(in)   :: comm               ! MPI communicator
         470             :    integer, intent(in)   :: comm_protocol      ! swap_comm protocol
         471             :    integer, intent(in)   :: comm_maxreq        ! maximum number of outstanding
         472             :                                                !  nonblocking requests
         473             :
         474             : !
         475             : !---------------------------Local workspace-----------------------------
         476             : !
         477             :    integer :: p                                ! process index
         478             :    integer :: istep                            ! loop index
         479             :    integer :: offset_s                         ! index of message beginning in
         480             :                                                !  send buffer
         481             :    integer :: offset_r                         ! index of message beginning in
         482             :                                                !  receive buffer
         483           0 :    integer :: sndids(steps)                    ! send request ids
         484           0 :    integer :: rcvids(steps)                    ! receive request ids
         485           0 :    integer :: hs_rcvids(steps)                 ! handshake receive request ids
         486             :
         487             :    integer :: maxreq, maxreqh                  ! maximum number of outstanding
         488             :                                                !  nonblocking requests (and half)
         489           0 :    integer :: hs_s, hs_r(steps)                ! handshake variables (send/receive)
         490             :    integer :: rstep                            ! "receive" step index
         491             :
         492             :    logical :: handshake, sendd                 ! protocol option flags
         493             :
         494             :    integer :: ier                              ! return error status
         495             :    integer :: status(MPI_STATUS_SIZE)          ! MPI status
         496             : !
         497             : !-------------------------------------------------------------------------------------
         498             : !
         499           0 :    if (steps .eq. 0) return
         500             :
         501             :    ! identify communication protocol
         502           0 :    if ((comm_protocol < 2) .or. (comm_protocol > 5)) then
         503             :       sendd = .true.
         504             :       handshake = .true.
         505             :    else
         506           0 :       if ((comm_protocol .eq. 4) .or. (comm_protocol .eq. 5)) then
         507             :          handshake = .true.
         508             :       else
         509           0 :          handshake = .false.
         510             :       endif
         511             :
         512           0 :       if ((comm_protocol .eq. 2) .or. (comm_protocol .eq. 4)) then
         513             :          sendd = .true.
         514             :       else
         515           0 :          sendd = .false.
         516             :       endif
         517             :    endif
         518             :
         519             :    ! identify maximum number of outstanding nonblocking requests to permit
         520           0 :    if (steps .eq. 1) then
         521             :       maxreq  = 1
         522             :       maxreqh = 1
         523             :    else
         524           0 :       if (comm_maxreq >= -1) then
         525             :          maxreq = comm_maxreq
         526             :       else
         527           0 :          maxreq = steps
         528             :       endif
         529             :
         530           0 :       if ((maxreq .le. steps) .and. (maxreq > 0)) then
         531           0 :          if (maxreq > 1) then
         532           0 :             maxreqh = maxreq/2
         533             :          else
         534             :             maxreq  = 2
         535             :             maxreqh = 1
         536             :          endif
         537             :       else
         538             :          maxreq  = steps
         539             :          maxreqh = steps
         540             :       endif
         541             :    endif
         542             :
         543             : ! Four protocol options:
         544             : !  (1) handshaking + blocking sends
         545           0 :    if ((handshake) .and. (sendd)) then
         546             :
         547             :       ! Initialize handshake variable
         548           0 :       hs_s = 1
         549             :
         550             :       ! Post initial handshake receive requests
         551           0 :       do istep=1,maxreq
         552           0 :          p = swapids(istep)
         553           0 :          if (sndlths(p) > 0) then
         554             :             call mpi_irecv( hs_r(istep), 1, mpiint, p, iam, comm, &
         555           0 :                             hs_rcvids(istep), ier )
         556             :          endif
         557             :       enddo
         558             :
         559             :       ! Post initial receive requests
         560           0 :       do istep=1,maxreq
         561           0 :          p = swapids(istep)
         562           0 :          if (rcvlths(p) > 0) then
         563           0 :             offset_r = rdispls(p)+1
         564           0 :             call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         565           0 :                             comm, rcvids(istep), ier )
         566           0 :             call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
         567             :          endif
         568             :       enddo
         569             :       rstep = maxreq
         570             :
         571             :       ! Send (and start receiving) data
         572           0 :       do istep=1,steps
         573           0 :          p = swapids(istep)
         574             :
         575             :          ! Submit new rsend request
         576           0 :          if (sndlths(p) > 0) then
         577           0 :             offset_s = sdispls(p)+1
         578             :             call mpi_wait  ( hs_rcvids(istep), MPI_STATUS_IGNORE, ier )
         579           0 :             call mpi_rsend ( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
         580           0 :                              comm, ier )
         581             :          endif
         582             :
         583           0 :          if (istep > maxreqh) then
         584             :
         585             :             ! Wait for oldest irecv request to complete
         586           0 :             p = swapids(istep-maxreqh)
         587           0 :             if (rcvlths(p) > 0) then
         588             :                call mpi_wait( rcvids(istep-maxreqh), status, ier )
         589             :             endif
         590             :
         591           0 :             if (rstep < steps) then
         592           0 :                rstep = rstep + 1
         593           0 :                p = swapids(rstep)
         594             :
         595             :                ! Submit a new handshake irecv request
         596           0 :                if (sndlths(p) > 0) then
         597             :                   call mpi_irecv( hs_r(rstep), 1, mpiint, p, iam, comm, &
         598           0 :                                   hs_rcvids(rstep), ier )
         599             :                endif
         600             :
         601             :                ! Submit a new irecv request
         602           0 :                if (rcvlths(p) > 0) then
         603           0 :                   offset_r = rdispls(p)+1
         604           0 :                   call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         605           0 :                                   comm, rcvids(rstep), ier )
         606           0 :                   call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
         607             :                endif
         608             :             endif
         609             :
         610             :          endif
         611             : !
         612             :       enddo
         613             :
         614             :       ! wait for rest of receive requests to complete
         615           0 :       do istep=steps-maxreqh+1,steps
         616           0 :          p = swapids(istep)
         617           0 :          if (rcvlths(p) > 0) then
         618             :             call mpi_wait( rcvids(istep), status, ier )
         619             :          endif
         620             :       enddo
         621             :
         622             : !  (2) handshaking + nonblocking sends
         623           0 :    elseif ((handshake) .and. (.not. sendd)) then
         624             :
         625             :       ! Initialize handshake variable
         626           0 :       hs_s = 1
         627             :
         628             :       ! Post initial handshake receive requests
         629           0 :       do istep=1,maxreq
         630           0 :          p = swapids(istep)
         631           0 :          if (sndlths(p) > 0) then
         632             :             call mpi_irecv( hs_r(istep), 1, mpiint, p, iam, comm, &
         633           0 :                             hs_rcvids(istep), ier )
         634             :          endif
         635             :       enddo
         636             :
         637             :       ! Post initial receive requests
         638           0 :       do istep=1,maxreq
         639           0 :          p = swapids(istep)
         640           0 :          if (rcvlths(p) > 0) then
         641           0 :             offset_r = rdispls(p)+1
         642           0 :             call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         643           0 :                             comm, rcvids(istep), ier )
         644           0 :             call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
         645             :          endif
         646             :       enddo
         647             :       rstep = maxreq
         648             :
         649             :       ! Send (and start receiving) data
         650           0 :       do istep=1,steps
         651           0 :          p = swapids(istep)
         652             :
         653             :          ! Submit new irsend request
         654           0 :          if (sndlths(p) > 0) then
         655           0 :             offset_s = sdispls(p)+1
         656             :             call mpi_wait  ( hs_rcvids(istep), MPI_STATUS_IGNORE, ier )
         657           0 :             call mpi_irsend( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
         658           0 :                              comm, sndids(istep), ier )
         659             :          endif
         660             :
         661           0 :          if (istep > maxreqh) then
         662             :
         663             :             ! Wait for oldest irecv request to complete
         664           0 :             p = swapids(istep-maxreqh)
         665           0 :             if (rcvlths(p) > 0) then
         666             :                call mpi_wait( rcvids(istep-maxreqh), status, ier )
         667             :             endif
         668             :
         669           0 :             if (rstep < steps) then
         670           0 :                rstep = rstep + 1
         671           0 :                p = swapids(rstep)
         672             :
         673             :                ! Submit a new handshake irecv request
         674           0 :                if (sndlths(p) > 0) then
         675             :                   call mpi_irecv( hs_r(rstep), 1, mpiint, p, iam, comm, &
         676           0 :                                   hs_rcvids(rstep), ier )
         677             :                endif
         678             :
         679             :                ! Submit a new irecv request
         680           0 :                if (rcvlths(p) > 0) then
         681           0 :                   offset_r = rdispls(p)+1
         682           0 :                   call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         683           0 :                                   comm, rcvids(rstep), ier )
         684           0 :                   call mpi_send ( hs_s, 1, mpiint, p, p, comm, ier )
         685             :                endif
         686             :             endif
         687             :
         688             :             ! Wait for outstanding i(r)send request to complete
         689           0 :             p = swapids(istep-maxreqh)
         690           0 :             if (sndlths(p) > 0) then
         691             :                call mpi_wait( sndids(istep-maxreqh), status, ier )
         692             :             endif
         693             :
         694             :          endif
         695             :
         696             :       enddo
         697             :
         698             :       ! wait for rest of send and receive requests to complete
         699           0 :       do istep=steps-maxreqh+1,steps
         700           0 :          p = swapids(istep)
         701           0 :          if (rcvlths(p) > 0) then
         702             :             call mpi_wait( rcvids(istep), status, ier )
         703             :          endif
         704           0 :          if (sndlths(p) > 0) then
         705             :             call mpi_wait( sndids(istep), status, ier )
         706             :          endif
         707             :       enddo
         708             :
         709             : !  (3) no handshaking + blocking sends
         710           0 :    elseif ((.not. handshake) .and. (sendd)) then
         711             :
         712             :       ! Post receive requests
         713           0 :       do istep=1,maxreq
         714           0 :          p = swapids(istep)
         715           0 :          if (rcvlths(p) > 0) then
         716           0 :             offset_r = rdispls(p)+1
         717           0 :             call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         718           0 :                             comm, rcvids(istep), ier )
         719             :          endif
         720             :       enddo
         721             :       rstep = maxreq
         722             :
         723             :       ! Send (and start receiving) data
         724           0 :       do istep=1,steps
         725           0 :          p = swapids(istep)
         726             :
         727             :          ! Submit new send request
         728           0 :          if (sndlths(p) > 0) then
         729           0 :             offset_s = sdispls(p)+1
         730           0 :             call mpi_send( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
         731           0 :                            comm, ier )
         732             :          endif
         733             :
         734           0 :          if (istep > maxreqh) then
         735             :
         736             :             ! Wait for oldest irecv request to complete
         737           0 :             p = swapids(istep-maxreqh)
         738           0 :             if (rcvlths(p) > 0) then
         739             :                call mpi_wait( rcvids(istep-maxreqh), status, ier )
         740             :             endif
         741             :
         742             :             ! Submit a new irecv request
         743           0 :             if (rstep < steps) then
         744           0 :                rstep = rstep + 1
         745           0 :                p = swapids(rstep)
         746           0 :                if (rcvlths(p) > 0) then
         747           0 :                   offset_r = rdispls(p)+1
         748           0 :                   call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         749           0 :                                   comm, rcvids(rstep), ier )
         750             :                endif
         751             :             endif
         752             :
         753             :          endif
         754             :
         755             :       enddo
         756             :
         757             :       ! wait for rest of send and receive requests to complete
         758           0 :       do istep=steps-maxreqh+1,steps
         759           0 :          p = swapids(istep)
         760           0 :          if (rcvlths(p) > 0) then
         761             :             call mpi_wait( rcvids(istep), status, ier )
         762             :          endif
         763             :       enddo
         764             :
         765             : !  (4) no handshaking + nonblocking sends
         766           0 :    elseif ((.not. handshake) .and. (.not. sendd)) then
         767             :
         768             :       ! Post receive requests
         769           0 :       do istep=1,maxreq
         770           0 :          p = swapids(istep)
         771           0 :          if (rcvlths(p) > 0) then
         772           0 :             offset_r = rdispls(p)+1
         773           0 :             call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         774           0 :                             comm, rcvids(istep), ier )
         775             :          endif
         776             :       enddo
         777             :       rstep = maxreq
         778             :
         779             :       ! Send (and start receiving) data
         780           0 :       do istep=1,steps
         781           0 :          p = swapids(istep)
         782             :
         783             :          ! Submit new isend request
         784           0 :          if (sndlths(p) > 0) then
         785           0 :             offset_s = sdispls(p)+1
         786           0 :             call mpi_isend( sndbuf(offset_s), sndlths(p), mpir8, p, iam, &
         787           0 :                             comm, sndids(istep), ier )
         788             :          endif
         789             :
         790           0 :          if (istep > maxreqh) then
         791             :
         792             :             ! Wait for oldest irecv request to complete
         793           0 :             p = swapids(istep-maxreqh)
         794           0 :             if (rcvlths(p) > 0) then
         795             :                call mpi_wait( rcvids(istep-maxreqh), status, ier )
         796             :             endif
         797             :
         798             :             ! Submit a new irecv request
         799           0 :             if (rstep < steps) then
         800           0 :                rstep = rstep + 1
         801           0 :                p = swapids(rstep)
         802           0 :                if (rcvlths(p) > 0) then
         803           0 :                   offset_r = rdispls(p)+1
         804           0 :                   call mpi_irecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, p, &
         805           0 :                                   comm, rcvids(rstep), ier )
         806             :                endif
         807             :             endif
         808             :
         809             :             ! Wait for outstanding i(r)send request to complete
         810           0 :             p = swapids(istep-maxreqh)
         811           0 :             if (sndlths(p) > 0) then
         812             :                call mpi_wait( sndids(istep-maxreqh), status, ier )
         813             :             endif
         814             :
         815             :          endif
         816             :
         817             :       enddo
         818             :
         819             :       ! wait for rest of send and receive requests to complete
         820           0 :       do istep=steps-maxreqh+1,steps
         821           0 :          p = swapids(istep)
         822           0 :          if (rcvlths(p) > 0) then
         823             :             call mpi_wait( rcvids(istep), status, ier )
         824             :          endif
         825           0 :          if (sndlths(p) > 0) then
         826             :             call mpi_wait( sndids(istep), status, ier )
         827             :          endif
         828             :       enddo
         829             :
         830             :    endif
         831             :
         832             :    return
         833             :
         834             :    end subroutine swapm
         835             : !
         836             : !========================================================================
         837             :
         838             : !-----------------------------------------------------------------------
         839             : !
         840             : ! Purpose: gather collective with additional flow control, so as to
         841             : !          be more robust when used with high process counts.
         842             : !          If flow_cntl optional parameter
         843             : !           < 0: use MPI_Gather
         844             : !          >= 0: use point-to-point with handshaking messages and
         845             : !                preposting receive requests up to
         846             : !                 min(max(1,flow_cntl),max_gather_block_size)
         847             : !                ahead if optional flow_cntl parameter is present.
         848             : !                Otherwise, fc_gather_flow_cntl is used in its place.
         849             : !          Default value is 64.
         850             : !
         851             : ! Entry points:
         852             : !      fc_gatherv       functionally equivalent to mpi_gatherv
         853             : !      fc_gathervr4     functionally equivalent to mpi_gatherv for real*4 data
         854             : !      fc_gathervint    functionally equivalent to mpi_gatherv for integer data
         855             : !      fc_gathervc      functionally equivalent to mpi_gatherv for character data
         856             : !
         857             : ! Author: P. Worley
         858             : !-----------------------------------------------------------------------
         859             :
         860             : !
         861             : !========================================================================
         862             : !
         863           0 :    subroutine fc_gatherv (sendbuf, sendcnt, sendtype, &
         864             :                          recvbuf, recvcnts, displs, recvtype, &
         865             :                          root, comm, flow_cntl )
         866             : !
         867             : ! Collects different messages from each process on masterproc
         868             : !
         869             :    use shr_kind_mod,   only: r8 => shr_kind_r8
         870             :    use mpishorthand
         871             :    use cam_abortutils, only: endrun
         872             :    use cam_logfile,    only: iulog
         873             :
         874             : #if defined( WRAP_MPI_TIMING )
         875             :    use perf_mod
         876             : #endif
         877             :
         878             :    implicit none
         879             :
         880             :    real (r8), intent(in)  :: sendbuf(*)
         881             :    real (r8), intent(out) :: recvbuf(*)
         882             :    integer, intent(in) :: displs(*)
         883             :    integer, intent(in) :: sendcnt
         884             :    integer, intent(in) :: sendtype
         885             :    integer, intent(in) :: recvcnts(*)
         886             :    integer, intent(in) :: recvtype
         887             :    integer, intent(in) :: root
         888             :    integer, intent(in) :: comm
         889             :    integer, optional, intent(in) :: flow_cntl
         890             :
         891             :    real (r8) :: signal
         892             :    logical fc_gather         ! use explicit flow control?
         893             :    integer gather_block_size ! number of preposted receive requests
         894             :
         895             :    integer :: mytid, mysize, mtag, p, q, i, count
         896             :    integer :: preposts, head, tail
         897             :    integer :: rcvid(max_gather_block_size)
         898             :    integer :: status(MPI_STATUS_SIZE)
         899             :    integer ier               ! MPI error code
         900             :
         901           0 :    if ( present(flow_cntl) ) then
         902           0 :       if (flow_cntl >= 0) then
         903           0 :          gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
         904             :          fc_gather = .true.
         905             :       else
         906             :          fc_gather = .false.
         907             :       endif
         908             :    else
         909           0 :       if (fc_gather_flow_cntl >= 0) then
         910           0 :          gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
         911             :          fc_gather = .true.
         912             :       else
         913             :          fc_gather = .false.
         914             :       endif
         915             :    endif
         916             :
         917             :    if (fc_gather) then
         918             :
         919             : #if defined( WRAP_MPI_TIMING )
         920             :       call t_startf ('fc_gatherv_r8')
         921             : #endif
         922           0 :       call mpi_comm_rank (comm, mytid, ier)
         923           0 :       call mpi_comm_size (comm, mysize, ier)
         924           0 :       mtag = 0
         925           0 :       if (root .eq. mytid) then
         926             :
         927             : ! prepost gather_block_size irecvs, and start receiving data
         928           0 :          preposts = min(mysize-1, gather_block_size)
         929           0 :          head = 0
         930           0 :          count = 0
         931           0 :          do p=0, mysize-1
         932           0 :             if (p .ne. root) then
         933           0 :                q = p+1
         934           0 :                if (recvcnts(q) > 0) then
         935           0 :                   count = count + 1
         936           0 :                   if (count > preposts) then
         937           0 :                      tail = mod(head,preposts) + 1
         938           0 :                      call mpi_wait (rcvid(tail), status, ier)
         939             :                   end if
         940           0 :                   head = mod(head,preposts) + 1
         941           0 :                   call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
         942           0 :                                    recvtype, p, mtag, comm, rcvid(head), &
         943           0 :                                    ier )
         944           0 :                   call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
         945             :                end if
         946             :             end if
         947             :          end do
         948             :
         949             : ! copy local data
         950           0 :          q = mytid+1
         951           0 :          do i=1,sendcnt
         952           0 :             recvbuf(displs(q)+i) = sendbuf(i)
         953             :          enddo
         954             :
         955             : ! wait for final data
         956           0 :          do i=1,min(count,preposts)
         957           0 :             call mpi_wait (rcvid(i), status, ier)
         958             :          enddo
         959             :
         960             :       else
         961             :
         962           0 :          if (sendcnt > 0) then
         963             :             call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
         964           0 :                             status, ier )
         965             :             call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
         966           0 :                              comm, ier )
         967             :          end if
         968             :
         969             :       endif
         970           0 :       if (ier /= mpi_success) then
         971           0 :          write(iulog,*)'fc_gatherv_r8 failed ier=',ier
         972           0 :          call endrun
         973             :       end if
         974             : #if defined( WRAP_MPI_TIMING )
         975             :       call t_stopf ('fc_gatherv_r8')
         976             : #endif
         977             :
         978             :    else
         979             :
         980             : #if defined( WRAP_MPI_TIMING )
         981             :       call t_startf ('mpi_gatherv')
         982             : #endif
         983             :       call mpi_gatherv (sendbuf, sendcnt, sendtype, &
         984             :                         recvbuf, recvcnts, displs, recvtype, &
         985           0 :                         root, comm, ier)
         986           0 :       if (ier /= mpi_success) then
         987           0 :          write(iulog,*)'mpi_gatherv failed ier=',ier
         988           0 :          call endrun
         989             :       end if
         990             : #if defined( WRAP_MPI_TIMING )
         991             :       call t_stopf ('mpi_gatherv')
         992             : #endif
         993             :
         994             :    endif
         995             :
         996           0 :    return
         997             :    end subroutine fc_gatherv
         998             : !
         999             : !========================================================================
        1000             : !
        1001           0 :    subroutine fc_gathervr4 (sendbuf, sendcnt, sendtype, &
        1002             :                            recvbuf, recvcnts, displs, recvtype, &
        1003             :                            root, comm, flow_cntl )
        1004             : !
        1005             : ! Collects different messages from each process on masterproc
        1006             : !
        1007             :    use shr_kind_mod,   only: r4 => shr_kind_r4, r8 => shr_kind_r8
        1008             :    use mpishorthand
        1009             :    use cam_abortutils, only: endrun
        1010             :    use cam_logfile,    only: iulog
        1011             :
        1012             : #if defined( WRAP_MPI_TIMING )
        1013             :    use perf_mod
        1014             : #endif
        1015             :
        1016             :    implicit none
        1017             :
        1018             :    real (r4), intent(in)  :: sendbuf(*)
        1019             :    real (r4), intent(out) :: recvbuf(*)
        1020             :    integer, intent(in) :: displs(*)
        1021             :    integer, intent(in) :: sendcnt
        1022             :    integer, intent(in) :: sendtype
        1023             :    integer, intent(in) :: recvcnts(*)
        1024             :    integer, intent(in) :: recvtype
        1025             :    integer, intent(in) :: root
        1026             :    integer, intent(in) :: comm
        1027             :    integer, optional, intent(in) :: flow_cntl
        1028             :
        1029             :    real (r8) :: signal
        1030             :    logical fc_gather         ! use explicit flow control?
        1031             :    integer gather_block_size ! number of preposted receive requests
        1032             :
        1033             :    integer :: mytid, mysize, mtag, p, q, i, count
        1034             :    integer :: preposts, head, tail
        1035             :    integer :: rcvid(max_gather_block_size)
        1036             :    integer :: status(MPI_STATUS_SIZE)
        1037             :    integer ier               ! MPI error code
        1038             :
        1039           0 :    if ( present(flow_cntl) ) then
        1040           0 :       if (flow_cntl >= 0) then
        1041           0 :          gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
        1042             :          fc_gather = .true.
        1043             :       else
        1044             :          fc_gather = .false.
        1045             :       endif
        1046             :    else
        1047           0 :       if (fc_gather_flow_cntl >= 0) then
        1048           0 :          gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
        1049             :          fc_gather = .true.
        1050             :       else
        1051             :          fc_gather = .false.
        1052             :       endif
        1053             :    endif
        1054             :
        1055             :    if (fc_gather) then
        1056             :
        1057             : #if defined( WRAP_MPI_TIMING )
        1058             :       call t_startf ('fc_gatherv_r4')
        1059             : #endif
        1060           0 :       call mpi_comm_rank (comm, mytid, ier)
        1061           0 :       call mpi_comm_size (comm, mysize, ier)
        1062           0 :       mtag = 0
        1063           0 :       if (root .eq. mytid) then
        1064             :
        1065             : ! prepost gather_block_size irecvs, and start receiving data
        1066           0 :          preposts = min(mysize-1, gather_block_size)
        1067           0 :          head = 0
        1068           0 :          count = 0
        1069           0 :          do p=0, mysize-1
        1070           0 :             if (p .ne. root) then
        1071           0 :                q = p+1
        1072           0 :                if (recvcnts(q) > 0) then
        1073           0 :                   count = count + 1
        1074           0 :                   if (count > preposts) then
        1075           0 :                      tail = mod(head,preposts) + 1
        1076           0 :                      call mpi_wait (rcvid(tail), status, ier)
        1077             :                   end if
        1078           0 :                   head = mod(head,preposts) + 1
        1079           0 :                   call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
        1080           0 :                                    recvtype, p, mtag, comm, rcvid(head), &
        1081           0 :                                    ier )
        1082           0 :                   call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
        1083             :                end if
        1084             :             end if
        1085             :          end do
        1086             :
        1087             : ! copy local data
        1088           0 :          q = mytid+1
        1089           0 :          do i=1,sendcnt
        1090           0 :             recvbuf(displs(q)+i) = sendbuf(i)
        1091             :          enddo
        1092             :
        1093             : ! wait for final data
        1094           0 :          do i=1,min(count,preposts)
        1095           0 :             call mpi_wait (rcvid(i), status, ier)
        1096             :          enddo
        1097             :
        1098             :       else
        1099             :
        1100           0 :          if (sendcnt > 0) then
        1101             :             call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
        1102           0 :                             status, ier )
        1103             :             call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
        1104           0 :                              comm, ier )
        1105             :           end if
        1106             :
        1107             :       endif
        1108           0 :       if (ier /= mpi_success) then
        1109           0 :          write(iulog,*)'fc_gatherv_r4 failed ier=',ier
        1110           0 :          call endrun
        1111             :       end if
        1112             : #if defined( WRAP_MPI_TIMING )
        1113             :       call t_stopf ('fc_gatherv_r4')
        1114             : #endif
        1115             :
        1116             :    else
        1117             :
        1118             : #if defined( WRAP_MPI_TIMING )
        1119             :       call t_startf ('mpi_gatherv')
        1120             : #endif
        1121             :       call mpi_gatherv (sendbuf, sendcnt, sendtype, &
        1122             :                         recvbuf, recvcnts, displs, recvtype, &
        1123           0 :                         root, comm, ier)
        1124           0 :       if (ier /= mpi_success) then
        1125           0 :          write(iulog,*)'mpi_gatherv failed ier=',ier
        1126           0 :          call endrun
        1127             :       end if
        1128             : #if defined( WRAP_MPI_TIMING )
        1129             :       call t_stopf ('mpi_gatherv')
        1130             : #endif
        1131             :
        1132             :    endif
        1133             :
        1134           0 :    return
        1135             :    end subroutine fc_gathervr4
        1136             : !
        1137             : !========================================================================
        1138             : !
        1139           0 :    subroutine fc_gathervint (sendbuf, sendcnt, sendtype, &
        1140             :                             recvbuf, recvcnts, displs, recvtype, &
        1141             :                             root, comm, flow_cntl )
        1142             : !
        1143             : ! Collects different messages from each process on masterproc
        1144             : !
        1145             :    use shr_kind_mod,   only: r8 => shr_kind_r8
        1146             :    use mpishorthand
        1147             :    use cam_abortutils, only: endrun
        1148             :    use cam_logfile,    only: iulog
        1149             :
        1150             : #if defined( WRAP_MPI_TIMING )
        1151             :    use perf_mod
        1152             : #endif
        1153             :
        1154             :    implicit none
        1155             :
        1156             :    integer, intent(in)  :: sendbuf(*)
        1157             :    integer, intent(out) :: recvbuf(*)
        1158             :    integer, intent(in) :: displs(*)
        1159             :    integer, intent(in) :: sendcnt
        1160             :    integer, intent(in) :: sendtype
        1161             :    integer, intent(in) :: recvcnts(*)
        1162             :    integer, intent(in) :: recvtype
        1163             :    integer, intent(in) :: root
        1164             :    integer, intent(in) :: comm
        1165             :    integer, optional, intent(in) :: flow_cntl
        1166             :
        1167             :    real (r8) :: signal
        1168             :    logical fc_gather         ! use explicit flow control?
        1169             :    integer gather_block_size ! number of preposted receive requests
        1170             :
        1171             :    integer :: mytid, mysize, mtag, p, q, i, count
        1172             :    integer :: preposts, head, tail
        1173             :    integer :: rcvid(max_gather_block_size)
        1174             :    integer :: status(MPI_STATUS_SIZE)
        1175             :    integer ier               ! MPI error code
        1176             :
        1177           0 :    if ( present(flow_cntl) ) then
        1178           0 :       if (flow_cntl >= 0) then
        1179           0 :          gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
        1180             :          fc_gather = .true.
        1181             :       else
        1182             :          fc_gather = .false.
        1183             :       endif
        1184             :    else
        1185           0 :       if (fc_gather_flow_cntl >= 0) then
        1186           0 :          gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
        1187             :          fc_gather = .true.
        1188             :       else
        1189             :          fc_gather = .false.
        1190             :       endif
        1191             :    endif
        1192             :
        1193             :    if (fc_gather) then
        1194             :
        1195             : #if defined( WRAP_MPI_TIMING )
        1196             :       call t_startf ('fc_gatherv_int')
        1197             : #endif
        1198           0 :       call mpi_comm_rank (comm, mytid, ier)
        1199           0 :       call mpi_comm_size (comm, mysize, ier)
        1200           0 :       mtag = 0
        1201           0 :       if (root .eq. mytid) then
        1202             :
        1203             : ! prepost gather_block_size irecvs, and start receiving data
        1204           0 :          preposts = min(mysize-1, gather_block_size)
        1205           0 :          head = 0
        1206           0 :          count = 0
        1207           0 :          do p=0, mysize-1
        1208           0 :             if (p .ne. root) then
        1209           0 :                q = p+1
        1210           0 :                if (recvcnts(q) > 0) then
        1211           0 :                   count = count + 1
        1212           0 :                   if (count > preposts) then
        1213           0 :                      tail = mod(head,preposts) + 1
        1214           0 :                      call mpi_wait (rcvid(tail), status, ier)
        1215             :                   end if
        1216           0 :                   head = mod(head,preposts) + 1
        1217           0 :                   call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
        1218           0 :                                    recvtype, p, mtag, comm, rcvid(head), &
        1219           0 :                                    ier )
        1220           0 :                   call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
        1221             :                end if
        1222             :             end if
        1223             :          end do
        1224             :
        1225             : ! copy local data
        1226           0 :          q = mytid+1
        1227           0 :          do i=1,sendcnt
        1228           0 :             recvbuf(displs(q)+i) = sendbuf(i)
        1229             :          enddo
        1230             :
        1231             : ! wait for final data
        1232           0 :          do i=1,min(count,preposts)
        1233           0 :             call mpi_wait (rcvid(i), status, ier)
        1234             :          enddo
        1235             :
        1236             :       else
        1237             :
        1238           0 :          if (sendcnt > 0) then
        1239             :             call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
        1240           0 :                             status, ier )
        1241             :             call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
        1242           0 :                              comm, ier )
        1243             :           end if
        1244             :
        1245             :       endif
        1246           0 :       if (ier /= mpi_success) then
        1247           0 :          write(iulog,*)'fc_gatherv_int failed ier=',ier
        1248           0 :          call endrun
        1249             :       end if
        1250             : #if defined( WRAP_MPI_TIMING )
        1251             :       call t_stopf ('fc_gatherv_int')
        1252             : #endif
        1253             :
        1254             :    else
        1255             :
        1256             : #if defined( WRAP_MPI_TIMING )
        1257             :       call t_startf ('mpi_gatherv')
        1258             : #endif
        1259             :       call mpi_gatherv (sendbuf, sendcnt, sendtype, &
        1260             :                         recvbuf, recvcnts, displs, recvtype, &
        1261           0 :                         root, comm, ier)
        1262           0 :       if (ier /= mpi_success) then
        1263           0 :          write(iulog,*)'mpi_gatherv failed ier=',ier
        1264           0 :          call endrun
        1265             :       end if
        1266             : #if defined( WRAP_MPI_TIMING )
        1267             :       call t_stopf ('mpi_gatherv')
        1268             : #endif
        1269             :
        1270             :    endif
        1271             :
        1272           0 :    return
        1273             :    end subroutine fc_gathervint
        1274             : !
        1275             : !========================================================================
        1276             : !
        1277        1536 :    subroutine fc_gathervc (sendbuf, sendcnt, sendtype, &
        1278             :                            recvbuf, recvcnts, displs, recvtype, &
        1279             :                            root, comm, flow_cntl )
        1280             : !
        1281             : ! Collects different messages from each process on masterproc
        1282             : !
        1283             :    use shr_kind_mod,   only: r8 => shr_kind_r8
        1284             :    use mpishorthand
        1285             :    use cam_abortutils, only: endrun
        1286             :    use cam_logfile,    only: iulog
        1287             :
        1288             : #if defined( WRAP_MPI_TIMING )
        1289             :    use perf_mod
        1290             : #endif
        1291             :
        1292             :    implicit none
        1293             :
        1294             :    character, intent(in)  :: sendbuf(*)
        1295             :    character, intent(out) :: recvbuf(*)
        1296             :    integer, intent(in) :: displs(*)
        1297             :    integer, intent(in) :: sendcnt
        1298             :    integer, intent(in) :: sendtype
        1299             :    integer, intent(in) :: recvcnts(*)
        1300             :    integer, intent(in) :: recvtype
        1301             :    integer, intent(in) :: root
        1302             :    integer, intent(in) :: comm
        1303             :    integer, optional, intent(in) :: flow_cntl
        1304             :
        1305             :    real (r8) :: signal
        1306             :    logical fc_gather         ! use explicit flow control?
        1307             :    integer gather_block_size ! number of preposted receive requests
        1308             :
        1309             :    integer :: mytid, mysize, mtag, p, q, i, count
        1310             :    integer :: preposts, head, tail
        1311             :    integer :: rcvid(max_gather_block_size)
        1312             :    integer :: status(MPI_STATUS_SIZE)
        1313             :    integer ier               ! MPI error code
        1314             :
        1315        1536 :    if ( present(flow_cntl) ) then
        1316        1536 :       if (flow_cntl >= 0) then
        1317           0 :          gather_block_size = min(max(1,flow_cntl),max_gather_block_size)
        1318             :          fc_gather = .true.
        1319             :       else
        1320             :          fc_gather = .false.
        1321             :       endif
        1322             :    else
        1323           0 :       if (fc_gather_flow_cntl >= 0) then
        1324           0 :          gather_block_size = min(max(1,fc_gather_flow_cntl),max_gather_block_size)
        1325             :          fc_gather = .true.
        1326             :       else
        1327             :          fc_gather = .false.
        1328             :       endif
        1329             :    endif
        1330             :
        1331             :    if (fc_gather) then
        1332             :
        1333             : #if defined( WRAP_MPI_TIMING )
        1334             :       call t_startf ('fc_gatherv_char')
        1335             : #endif
        1336           0 :       call mpi_comm_rank (comm, mytid, ier)
        1337           0 :       call mpi_comm_size (comm, mysize, ier)
        1338           0 :       mtag = 0
        1339           0 :       if (root .eq. mytid) then
        1340             :
        1341             : ! prepost gather_block_size irecvs, and start receiving data
        1342           0 :          preposts = min(mysize-1, gather_block_size)
        1343           0 :          head = 0
        1344           0 :          count = 0
        1345           0 :          do p=0, mysize-1
        1346           0 :             if (p .ne. root) then
        1347           0 :                q = p+1
        1348           0 :                if (recvcnts(q) > 0) then
        1349           0 :                   count = count + 1
        1350           0 :                   if (count > preposts) then
        1351           0 :                      tail = mod(head,preposts) + 1
        1352           0 :                      call mpi_wait (rcvid(tail), status, ier)
        1353             :                   end if
        1354           0 :                   head = mod(head,preposts) + 1
        1355           0 :                   call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), &
        1356           0 :                                    recvtype, p, mtag, comm, rcvid(head), &
        1357           0 :                                    ier )
        1358           0 :                   call mpi_send ( signal, 1, mpir8, p, mtag, comm, ier )
        1359             :                end if
        1360             :             end if
        1361             :          end do
        1362             :
        1363             : ! copy local data
        1364           0 :          q = mytid+1
        1365           0 :          do i=1,sendcnt
        1366           0 :             recvbuf(displs(q)+i) = sendbuf(i)
        1367             :          enddo
        1368             :
        1369             : ! wait for final data
        1370           0 :          do i=1,min(count,preposts)
        1371           0 :             call mpi_wait (rcvid(i), status, ier)
        1372             :          enddo
        1373             :
        1374             :       else
        1375             :
        1376           0 :          if (sendcnt > 0) then
        1377             :             call mpi_recv ( signal, 1, mpir8, root, mtag, comm, &
        1378           0 :                             status, ier )
        1379             :             call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, &
        1380           0 :                              comm, ier )
        1381             :           end if
        1382             :
        1383             :       endif
        1384           0 :       if (ier /= mpi_success) then
        1385           0 :          write(iulog,*)'fc_gatherv_char failed ier=',ier
        1386           0 :          call endrun
        1387             :       end if
        1388             : #if defined( WRAP_MPI_TIMING )
        1389             :       call t_stopf ('fc_gatherv_char')
        1390             : #endif
        1391             :
        1392             :    else
        1393             :
        1394             : #if defined( WRAP_MPI_TIMING )
        1395             :       call t_startf ('mpi_gatherv')
        1396             : #endif
        1397             :       call mpi_gatherv (sendbuf, sendcnt, sendtype, &
        1398             :                         recvbuf, recvcnts, displs, recvtype, &
        1399        1536 :                         root, comm, ier)
        1400        1536 :       if (ier /= mpi_success) then
        1401           0 :          write(iulog,*)'mpi_gatherv failed ier=',ier
        1402           0 :          call endrun
        1403             :       end if
        1404             : #if defined( WRAP_MPI_TIMING )
        1405             :       call t_stopf ('mpi_gatherv')
        1406             : #endif
        1407             :
        1408             :    endif
        1409             :
        1410        1536 :    return
        1411             :    end subroutine fc_gathervc
        1412             : !
        1413             : !========================================================================
        1414             : #endif
        1415             :
        1416             : !-----------------------------------------------------------------------
        1417             : !
        1418             : ! Purpose: implementations of MPI_Alltoall using different messaging
        1419             : !          layers and different communication protocols, controlled
        1420             : !          by option argument:
        1421             : !  0: use mpi_alltoallv
        1422             : !  1: use point-to-point MPI-1 two-sided implementation
        1423             : !  2: use point-to-point MPI-2 one-sided implementation if supported,
        1424             : !       otherwise use MPI-1 implementation
        1425             : !  3: use Co-Array Fortran implementation if supported,
        1426             : !       otherwise use MPI-1 implementation
        1427             : !  otherwise use mpi_sendrecv implementation
        1428             : !
        1429             : ! Entry points:
        1430             : !      altalltoallv
        1431             : !
        1432             : ! Author: P. Worley
        1433             : !-----------------------------------------------------------------------
        1434             :
        1435             : #if (defined SPMD)
        1436             : !****************************************************************
        1437           0 :    subroutine altalltoallv (option, mytid, nprocs, steps, dests, &
        1438           0 :                  sendbuf, sbuf_siz, sendcnts, sdispls, sendtype, &
        1439           0 :                  recvbuf, rbuf_siz, recvcnts, rdispls, recvtype, &
        1440             :                  msgtag, pdispls, desttype, recvwin, comm)
        1441             : !
        1442             : ! All-to-all scatter/gather implemented using Co-Array
        1443             : ! Fortran one-sided commands, MPI-2 one sided commands,
        1444             : ! SWAP module MPI-1 commands, MPI_ALLTOALLV or MPI_SENDRECV.
        1445             : !
        1446             : #if defined( WRAP_MPI_TIMING )
        1447             :    use perf_mod
        1448             : #endif
        1449             :
        1450             :    implicit none
        1451             :
        1452             :    integer, intent(in) :: option               ! 0: mpi_alltoallv
        1453             :                                                ! 1: swap package
        1454             :                                                ! 2: mpi2
        1455             :                                                ! 3: co-array fortran
        1456             :                                        ! otherwise: sendrecv
        1457             :    integer, intent(in) :: mytid
        1458             :    integer, intent(in) :: nprocs
        1459             :    integer, intent(in) :: steps
        1460             :    integer, intent(in) :: dests(steps)
        1461             :    integer, intent(in) :: sbuf_siz
        1462             :    integer, intent(in) :: sendcnts(0:nprocs-1)
        1463             :    integer, intent(in) :: sdispls(0:nprocs-1)
        1464             :    integer, intent(in) :: sendtype
        1465             :    integer, intent(in) :: rbuf_siz
        1466             :    integer, intent(in) :: recvcnts(0:nprocs-1)
        1467             :    integer, intent(in) :: rdispls(0:nprocs-1)
        1468             :    integer, intent(in) :: recvtype
        1469             :    integer, intent(in) :: msgtag
        1470             :    integer, intent(in) :: pdispls(0:nprocs-1)   ! displacement at
        1471             :                                                 !  destination
        1472             :    integer, intent(in) :: desttype
        1473             :    integer, intent(in) :: recvwin
        1474             :    integer, intent(in) :: comm
        1475             :
        1476             : #if (defined CAF)
        1477             :    real (r8), intent(in)  :: sendbuf(sbuf_siz)[*]
        1478             :    real (r8), intent(out) :: recvbuf(rbuf_siz)[*]
        1479             :
        1480             :    integer :: istart, iend, jstart, jend
        1481             : #else
        1482             :    real (r8), intent(in)  :: sendbuf(sbuf_siz)
        1483             :    real (r8), intent(out) :: recvbuf(rbuf_siz)
        1484             : #endif
        1485             :
        1486             :    integer :: loption          ! local copy of option
        1487             :    integer :: dest             ! MPI remote process id
        1488             :    integer :: ier              ! MPI error code
        1489             :    integer :: i                ! loop index
        1490             :    integer :: sndids(steps)    ! nonblocking MPI send request ids
        1491             :    integer :: rcvids(steps)    ! nonblocking MPI recv request ids
        1492             :    integer :: status(MPI_STATUS_SIZE)
        1493             : #if ( defined MPI2)
        1494             :    integer(kind=MPI_ADDRESS_KIND) :: ddispls
        1495             : #endif
        1496             :
        1497             : !-----------------------------------------------------------------------
        1498           0 :    loption = option
        1499             :
        1500             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1501             : !  using MPI library collective MPI_ALLTOALLV
        1502             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1503           0 :    if (loption .eq. 0) then
        1504             :
        1505             : #if defined( WRAP_MPI_TIMING )
        1506             :       call t_startf ('mpi_alltoallv')
        1507             : #endif
        1508             :       call mpi_alltoallv (sendbuf, sendcnts, sdispls, sendtype, &
        1509             :                           recvbuf, recvcnts, rdispls, recvtype, &
        1510           0 :                           comm, ier)
        1511             : !
        1512             : ! test for error
        1513           0 :       if (ier/=mpi_success) then
        1514           0 :          write(iulog,*)'altalltoallv (mpi_alltoallv) failed ier=',ier
        1515           0 :          call endrun
        1516             :       end if
        1517             : #if defined( WRAP_MPI_TIMING )
        1518             :       call t_stopf ('mpi_alltoallv')
        1519             : #endif
        1520             :
        1521             :    else
        1522             :
        1523             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1524             : !  Co-Array Fortran implementation of alltoallv
        1525             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1526           0 :       if (loption .eq. 3) then
        1527             :
        1528             : #if ( defined CAF )
        1529             : #if defined( WRAP_MPI_TIMING )
        1530             :          call t_startf ('caf_alltoallv')
        1531             : #endif
        1532             :          if (this_image() .ne. (mytid+1)) then
        1533             :             call endrun('altalltoallv (caf_alltoallv) failed: MPI id .ne. CAF id')
        1534             :          endif
        1535             :
        1536             :          call sync_images()
        1537             :
        1538             :          do i = 1, steps
        1539             :             dest = dests(i)
        1540             :             if (sendcnts(dest) > 0) then
        1541             :                istart = sdispls(dest)+1
        1542             :                iend   = istart+sendcnts(dest)-1
        1543             :                jstart = pdispls(dest)+1
        1544             :                jend   = jstart+sendcnts(dest)-1
        1545             :                recvbuf(jstart:jend)[dest+1] = sendbuf(istart:iend)
        1546             :             end if
        1547             :          end do
        1548             :
        1549             :          call sync_images()
        1550             : #if defined( WRAP_MPI_TIMING )
        1551             :          call t_stopf ('caf_alltoallv')
        1552             : #endif
        1553             : #else
        1554             :          loption = -1
        1555             : #endif
        1556             :
        1557             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1558             : !  MPI-2 one-sided implementation of alltoallv
        1559             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1560           0 :       elseif (loption .eq. 2) then
        1561             : #ifdef MPI2
        1562             : #if defined( WRAP_MPI_TIMING )
        1563             :          call t_startf ('mpi2_alltoallv')
        1564             : #endif
        1565             :          call mpi_win_fence(0,recvwin,ier)
        1566             :          do i=1, steps
        1567             :             dest = dests(i)
        1568             :             if (sendcnts(dest) > 0) then
        1569             :                ddispls = pdispls(dest)
        1570             :                call mpi_put(sendbuf(sdispls(dest)+1), sendcnts(dest), sendtype, &
        1571             :                             dest, ddispls, sendcnts(dest), desttype, &
        1572             :                             recvwin, ier)
        1573             :             endif
        1574             :          end do
        1575             : !
        1576             : ! wait for completion
        1577             :          call mpi_win_fence(0,recvwin,ier)
        1578             :          if (ier/=mpi_success) then
        1579             :             write(iulog,*)'altalltoallv (mpi2_alltoallv) failed ier=',ier
        1580             :             call endrun
        1581             :          end if
        1582             : #if defined( WRAP_MPI_TIMING )
        1583             :          call t_stopf ('mpi2_alltoallv')
        1584             : #endif
        1585             : #else
        1586             :          loption = -1
        1587             : #endif
        1588             :
        1589             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1590             : !  MPI-1 two-sided implementation of alltoallv
        1591             : !  using SWAP routines
        1592             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1593           0 :       elseif (loption .eq. 1) then
        1594             : #if defined( WRAP_MPI_TIMING )
        1595             :          call t_startf ('swap_alltoallv')
        1596             : #endif
        1597             :
        1598             :          call swapm(steps, nprocs, dests,                      &
        1599             :                     sendbuf, sbuf_siz, sendcnts, sdispls,      &
        1600             :                     recvbuf, rbuf_siz, recvcnts, rdispls,      &
        1601           0 :                     comm, swap_comm_protocol, swap_comm_maxreq )
        1602             : !
        1603             : #if defined( WRAP_MPI_TIMING )
        1604             :          call t_stopf ('swap_alltoallv')
        1605             : #endif
        1606             :
        1607             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1608             : !  Anything else defined to be MPI_SENDRECV implementation
        1609             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1610             :       else
        1611             : !
        1612             :          loption = -1
        1613             : !
        1614             :       endif
        1615             :
        1616             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1617             : !  MPI_SENDRECV implementation of alltoallv
        1618             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1619           0 :       if (loption .eq. -1) then
        1620             : #if defined( WRAP_MPI_TIMING )
        1621             :          call t_startf ('mpi1_alltoallv')
        1622             : #endif
        1623           0 :          do i=1, steps
        1624           0 :             dest = dests(i)
        1625           0 :             call mpi_sendrecv (sendbuf(sdispls(dest)+1), sendcnts(dest), &
        1626             :                                sendtype, dest, msgtag,                   &
        1627           0 :                                recvbuf(rdispls(dest)+1), recvcnts(dest), &
        1628             :                                recvtype, dest, msgtag,                   &
        1629           0 :                                comm, status, ier)
        1630             :          end do
        1631             : !
        1632             : ! test for error
        1633           0 :          if (ier/=mpi_success) then
        1634           0 :             write(iulog,*)'altalltoallv (mpi1_alltoallv) failed ier=',ier
        1635           0 :             call endrun
        1636             :          end if
        1637             :
        1638             : #if defined( WRAP_MPI_TIMING )
        1639             :          call t_stopf ('mpi1_alltoallv')
        1640             : #endif
        1641             :       endif
        1642             :
        1643             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1644             : !  Local copy (if necessary)
        1645             : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        1646           0 :       if (sendcnts(mytid) > 0) then
        1647           0 :          do i=1,sendcnts(iam)
        1648           0 :             recvbuf(rdispls(mytid)+i) = sendbuf(sdispls(mytid)+i)
        1649             :          enddo
        1650             :       endif
        1651             : !
        1652             :    endif
        1653             : !
        1654           0 :    return
        1655             :    end subroutine altalltoallv
        1656             :
        1657             : #endif
        1658             :
        1659        1536 :    subroutine spmd_utils_readnl(nlfile)
        1660             : !-----------------------------------------------------------------------
        1661             : !
        1662             : ! Purpose:
        1663             : !   Read spmd utils namelist to set swap communication protocol options as
        1664             : !   well as the flow control gather options
        1665             : !
        1666             : ! Method:
        1667             : ! spmd_utils_readnl:
        1668             : !
        1669             : ! Author of original version:  J. Truesdale
        1670             : !
        1671             : !-----------------------------------------------------------------------
        1672             :
        1673             : !-----------------------------------------------------------------------
        1674             :      use namelist_utils,  only: find_group_name
        1675             :      use units,           only: getunit, freeunit
        1676             :      use mpishorthand
        1677             :
        1678             :      implicit none
        1679             : !---------------------------Input arguments--------------------------
        1680             : !
        1681             :      character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
        1682             :
        1683             : #if ( defined SPMD )
        1684             : !---------------------------Local variables--------------------------
        1685             : !
        1686             :      integer :: unitn, ierr
        1687             :      character(len=*), parameter :: subname = 'spmd_utils_readnl'
        1688             :
        1689             :      namelist /spmd_utils_nl/ swap_comm_protocol,swap_comm_maxreq,fc_gather_flow_cntl
        1690             :
        1691             : !-----------------------------------------------------------------------------
        1692             :
        1693        1536 :      if (masterproc) then
        1694           2 :         unitn = getunit()
        1695           2 :         open( unitn, file=trim(nlfile), status='old' )
        1696           2 :         call find_group_name(unitn, 'spmd_utils_nl', status=ierr)
        1697           2 :         if (ierr == 0) then
        1698           0 :            read(unitn, spmd_utils_nl, iostat=ierr)
        1699           0 :            if (ierr /= 0) then
        1700           0 :               call endrun(subname // ':: ERROR reading namelist')
        1701             :            end if
        1702           0 :            write(iulog,*) 'Read in spmd_utils_nl namelist from: ', trim(nlfile)
        1703             :         end if
        1704           2 :         close(unitn)
        1705           2 :         call freeunit(unitn)
        1706             :
        1707             :
        1708           2 :         if ((swap_comm_protocol < min_comm_protocol) .or. &
        1709             :              (swap_comm_protocol > max_comm_protocol)) then
        1710             :            write(iulog,*)                                        &
        1711           0 :                 'SPMD_UTILS_READNL:  ERROR:  swap_comm_protocol=', &
        1712           0 :                 swap_comm_protocol, ' is out of range.'
        1713             :            write(iulog,*)                                        &
        1714           0 :                 '  It must be between ', min_comm_protocol,' and ',&
        1715           0 :                 max_comm_protocol
        1716             :            write(iulog,*)                                        &
        1717           0 :                 '  Using default value.'
        1718           0 :            swap_comm_protocol = def_comm_protocol
        1719             :         endif
        1720             :
        1721           2 :         write(iulog,*) 'SPMD SWAP_COMM OPTIONS: '
        1722           2 :         write(iulog,*) '  swap_comm_protocol = ', swap_comm_protocol
        1723           2 :         write(iulog,*) '  swap_comm_maxreq   = ', swap_comm_maxreq
        1724           2 :         write(iulog,*) 'SPMD FLOW CONTROL GATHER OPTION: '
        1725           2 :         write(iulog,*) '  fc_gather_flow_cntl = ', fc_gather_flow_cntl
        1726             :      endif
        1727             :
        1728             :      ! Broadcast namelist variables
        1729        1536 :      call mpibcast (swap_comm_protocol , 1,   mpiint ,  0, mpicom)
        1730        1536 :      call mpibcast (swap_comm_maxreq   , 1,   mpiint ,  0, mpicom)
        1731        1536 :      call mpibcast (fc_gather_flow_cntl, 1,   mpiint ,  0, mpicom)
        1732             : #endif
        1733             :
        1734        1536 :    end subroutine spmd_utils_readnl
        1735             :
        1736           0 :  end module spmd_utils

Generated by: LCOV version 1.14