#include <misc.h>
#include <params.h>
module swap_comm 8,1
!-----------------------------------------------------------------------
!
! Purpose: swap communication routines used in performance portable
! distributed transpose algorithms.
!
! Entry points:
! swap_comm_init Initialize swap module.
!
! swap_comm_defaultopts Get default runtime options.
! swap_comm_setopts Set runtime options.
!
! swap1 First of three routines that implement swap
! using MPI point-to-point. Depending on
! communication protocol, posts nonblocking
! receive requests and sends ready send
! handshaking messages.
! swap2 Second of three routines that implement swap
! using MPI point-to-point. Sends data and,
! depending on communication protocol, receives
! data.
! swap3 Third of three routines that implement swap
! using MPI point-to-point. Completes all
! outstanding send and receive requests.
! swap1m Same as swap1, but for multiple messages
! swap3m Same as swap3, but for multiple messages.
!
! do_swap1 Logical function that indicates whether
! swap1 needs to be called for the current
! communication protocol.
! do_swap3 Logical function that indicates whether
! swap3 needs to be called for the current
! communication protocol.
! delayed_swap_recv Logical function that indicates whether
! message receives are delayed until swap3
! for the current communication protocol.
!
! Author: P. Worley
!-----------------------------------------------------------------------
#if (defined SPMD)
!-----------------------------------------------------------------------
!- use statements ------------------------------------------------------
!-----------------------------------------------------------------------
use abortutils, only: endrun
use mpishorthand
!-----------------------------------------------------------------------
!- module boilerplate --------------------------------------------------
!-----------------------------------------------------------------------
implicit none
private ! Make the default access private
save
!-----------------------------------------------------------------------
! Public interfaces ----------------------------------------------------
!-----------------------------------------------------------------------
public swap_comm_init
public swap_comm_defaultopts
public swap_comm_setopts
public swap1
public swap2
public swap3
public swap1m
public swap3m
public do_swap1
public do_swap3
public delayed_swap_recv
!-----------------------------------------------------------------------
! Private data ---------------------------------------------------------
!-----------------------------------------------------------------------
! Swap communication order option:
! 0: simple swap: send/recv
! 1: ordered swap: [send/recv]|[recv/send]
! 2: delayed-recv swap: send ... recv
integer, private, parameter :: min_comm_order = 0
integer, private, parameter :: max_comm_order = 2
integer, private, parameter :: def_comm_order = 0 ! default
integer, private :: swap_comm_order = def_comm_order
! Swap communication protocol option:
! 1, 3, 5, 7, 9: nonblocking send
! 2, 3, 4, 5, 8, 9: nonblocking receive
! 4, 5: ready send
! 6 .and. swap_comm_order .eq. 0: sendrecv
! 6 .and. swap_comm_order .eq. 1: explicitly synchronous
! 7, 8, 9, .or. 10: synchronous send
integer, private, parameter :: min0_comm_protocol = 1
integer, private, parameter :: max0_comm_protocol = 9
integer, private, parameter :: min1_comm_protocol = 0
integer, private, parameter :: max1_comm_protocol = 10
integer, private, parameter :: def_comm_protocol = 6 ! default
integer, private :: swap_comm_protocol = def_comm_protocol
! Swap communicators
integer, private :: swap_com = mpi_comm_null
! primary MPI communicator
integer, private :: handshake_com = mpi_comm_null
! MPI communicator for
! handshaking messages
!-----------------------------------------------------------------------
! Subroutines and functions --------------------------------------------
!-----------------------------------------------------------------------
contains
!
!========================================================================
!
subroutine swap_comm_init() 1,2
!-----------------------------------------------------------------------
!
! Purpose: Create communicators to be used in swap communication.
!
! Method:
!
! Author: P. Worley
!-----------------------------------------------------------------------
use mpishorthand, only: mpicom
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments-----------------------------
!
!---------------------------Local workspace-----------------------------
!
integer ier ! return error status
!
!-----------------------------------------------------------------------
!
call mpi_comm_dup(mpicom, swap_com, ier)
if (ier /= mpi_success) then
write(6,*) &
'SWAP_COMM_INIT: ERROR: mpi_comm_dup failed with IER=', ier
call endrun
endif
call mpi_comm_dup(mpicom, handshake_com, ier)
if (ier /= mpi_success) then
write(6,*) &
'SWAP_COMM_INIT: ERROR: mpi_comm_dup failed with IER=', ier
call endrun
endif
!
return
end subroutine swap_comm_init
!
!========================================================================
!
subroutine swap_comm_defaultopts(swap_comm_order_out, & 1
swap_comm_protocol_out )
!-----------------------------------------------------------------------
! Purpose: Return default runtime options
! Author: P. Worley (modelled after Tom Henderson's code)
!-----------------------------------------------------------------------
!------------------------------Arguments--------------------------------
! swap module communication order option
integer, intent(out), optional :: swap_comm_order_out
! swap module communication protocol option
integer, intent(out), optional :: swap_comm_protocol_out
!-----------------------------------------------------------------------
if ( present(swap_comm_order_out) ) then
swap_comm_order_out = def_comm_order
endif
if ( present(swap_comm_protocol_out) ) then
swap_comm_protocol_out = def_comm_protocol
endif
!
return
end subroutine swap_comm_defaultopts
!
!========================================================================
!
subroutine swap_comm_setopts(swap_comm_order_in, & 1,3
swap_comm_protocol_in )
!-----------------------------------------------------------------------
! Purpose: Set runtime options
! Author: P. Worley (modelled after Tom Henderson's code)
!-----------------------------------------------------------------------
!------------------------------Arguments--------------------------------
! swap module communication order option
integer, intent(in), optional :: swap_comm_order_in
! swap module communication protocol option
integer, intent(in), optional :: swap_comm_protocol_in
!-----------------------------------------------------------------------
if ( present(swap_comm_order_in) ) then
swap_comm_order = swap_comm_order_in
if ((swap_comm_order < min_comm_order) .or. &
(swap_comm_order > max_comm_order)) then
write(6,*) &
'SWAP_COMM_SETOPTS: ERROR: swap_comm_order=', &
swap_comm_order, &
' is out of range. It must be between ', &
min_comm_order,' and ',max_comm_order
call endrun
endif
endif
!
if ( present(swap_comm_protocol_in) ) then
swap_comm_protocol = swap_comm_protocol_in
if ((swap_comm_order .eq. 0) .or. &
(swap_comm_order .eq. 2)) then
if ((swap_comm_protocol < min0_comm_protocol) .or. &
(swap_comm_protocol > max0_comm_protocol)) then
write(6,*) &
'SWAP_COMM_SETOPTS: ERROR: swap_comm_protocol=', &
swap_comm_protocol, &
' is out of range. It must be between ', &
min0_comm_protocol,' and ',max0_comm_protocol, &
' when swap_comm_order= ', swap_comm_order
call endrun
endif
else
if ((swap_comm_protocol < min1_comm_protocol) .or. &
(swap_comm_protocol > max1_comm_protocol)) then
write(6,*) &
'SWAP_COMM_SETOPTS: ERROR: swap_comm_protocol=', &
swap_comm_protocol, &
' is out of range. It must be between ', &
min1_comm_protocol,' and ',max1_comm_protocol, &
' when swap_comm_order= ', swap_comm_order
call endrun
endif
endif
endif
!
return
end subroutine swap_comm_setopts
!
!========================================================================
!
subroutine swap1(mtag, swapnode, rcvlth, rcvmsg, rcvid),14
!-----------------------------------------------------------------------
!
! Purpose:
! First of three routines that implement swap using MPI point-to-point
! routines.
!
! Method:
! This subroutine begins a swap operation that will be completed by
! swap2 and swap3. It posts a receive and sends handshaking messages
! when ready sends are used.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Author of original version: P. Worley
! Ported to CAM: P. Worley, December 2003
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use pmgrid, only: iam
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
integer, intent(in) :: mtag ! MPI message tag
integer, intent(in) :: swapnode ! MPI process id of swap partner
integer, intent(in) :: rcvlth ! length of incoming message buffer
integer, intent(out) :: rcvid ! receive request id
real(r8), intent(out) :: rcvmsg(rcvlth) ! incoming message buffer
!
!---------------------------Local workspace-----------------------------
!
real(r8) signal ! ready send signal
!
!-------------------------------------------------------------------------------------
!
signal = 1.0
!
! simple swap: send/recv
if ((swap_comm_order .eq. 0) .or. (swap_comm_order .eq. 2)) then
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! this procotol does not use nonblocking receive.
!
elseif (swap_comm_protocol <= 3) then
!
! post the receive before the send, increasing odds that the
! receive will be posted before the message arrives.
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com, rcvid )
!
else
!
! post the receive before send to allow use of ready send.
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com, rcvid )
call mpisend( signal, 1, mpir8, swapnode, mtag, handshake_com )
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
! these procotols do not use nonblocking receive.
!
else
!
! post the receive before the synchronous send, increasing odds that the
! receive will be posted before the message arrives.
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com, rcvid )
!
endif
!
else
!
write (0,901) swap_comm_order, swap_comm_protocol
901 format(/,' fatal error in subroutine swap1:', &
/,' unknown communication protocol specified',/, &
' swap_comm_order = ',i6, ' swap_comm_protocol = ',i6)
call endrun
!
endif
!
elseif (swap_comm_order .eq. 1) then
! ordered swap:
! if (iam <= swapnode) send/recv
! if (iam >= swapnode) recv/send
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! this procotol does not use nonblocking receive.
!
elseif (swap_comm_protocol <= 3) then
!
! post the receive before the initial send, increasing odds
! that the receive will be posted before the message arrives.
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com, rcvid )
!
else
!
! post the receive before the send to allow use of forcetypes.
if (iam <= swapnode) then
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com, rcvid )
else
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com, rcvid )
call mpisend ( signal, 1, mpir8, swapnode, mtag, handshake_com )
endif
!
endif
!
elseif (swap_comm_protocol <= 10) then
!
if (swap_comm_protocol <= 7) then
!
! these protocols do not use nonblocking receive.
!
elseif (swap_comm_protocol <= 9) then
!
! post the receive before the initial synchronous send, increasing odds
! that the receive will be posted before the message arrives.
call mpiirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com, rcvid )
!
else
!
! this protocol does not use nonblocking receive.
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
!
endif
!
else
!***********************************************************************
! undefined swap option
!***********************************************************************
!
write (0,900) swap_comm_order
900 format(/,' fatal error in subroutine swap1:', &
/,' unknown communication option specified',/, &
' swap_comm_order = ',i6)
call endrun
!
endif
!
return
end subroutine swap1
!
!========================================================================
!
subroutine swap2(mtag, swapnode, sndlth, sndmsg, sndid, & 6,83
rcvlth, rcvmsg, rcvid)
!-----------------------------------------------------------------------
!
! Purpose:
! Second of three routines that implement swap using MPI point-to-point
! routines,
!
! Method:
! This subroutine continues the swap operation begun in swap1. It
! initiates the send and waits for the receive to complete.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Author of original version: P. Worley
! Ported to CAM: P. Worley, December 2003
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use pmgrid, only: iam
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
integer, intent(in) :: mtag ! MPI message tag
integer, intent(in) :: swapnode ! MPI process id of swap partner
integer, intent(in) :: sndlth ! length of outgoing message
integer, intent(out) :: sndid ! send request id
integer, intent(in) :: rcvlth ! length of incoming message buffer
integer, intent(inout):: rcvid ! receive request id
real(r8), intent(in) :: sndmsg(sndlth) ! outgoing message buffer
real(r8), intent(out) :: rcvmsg(rcvlth) ! incoming message buffer
!
!---------------------------Local workspace-----------------------------
!
real(r8) signal ! ready send signal
integer status(MPI_STATUS_SIZE) ! MPI status integer
!
!-------------------------------------------------------------------------------------
!
signal = 1.0
!
if (swap_comm_order .eq. 0) then
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! do not block for the send, enabling overlap of communication with computation
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, sndid )
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
!
elseif (swap_comm_protocol <= 3) then
!
if (swap_comm_protocol .eq. 2) then
! complete outstanding receive
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpiwait( rcvid, status )
else
! also do not block for the send, enabling overlap of communication with computation
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
call mpiwait ( rcvid, status )
endif
!
else
!
if (swap_comm_protocol .eq. 4) then
! complete receive of ready send
call mpirecv ( signal, 1, mpir8, swapnode, mtag, handshake_com )
call mpirsend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpiwait ( rcvid, status )
else
! also do not block for send, enabling overlap of communication with computation.
call mpirecv ( signal, 1, mpir8, swapnode, mtag, handshake_com )
call mpiirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
call mpiwait ( rcvid, status )
endif
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
if (swap_comm_protocol .eq. 6) then
! native sendrecv
call mpisendrecv( sndmsg, sndlth, mpir8, swapnode, mtag, &
rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
else
! do not block for the synchronous send, enabling overlap of
! communication with computation.
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
endif
!
else
!
if (swap_comm_protocol .eq. 8) then
! complete outstanding receive,
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpiwait ( rcvid, status )
else
! also do not block for the synchronous send, enabling overlap of
! communication with computation
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
call mpiwait( rcvid, status )
endif
!
endif
!
else
!
write (0,901) swap_comm_order, swap_comm_protocol
901 format(/,' fatal error in subroutine swap2:', &
/,' unknown communication protocol specified',/, &
' swap_comm_order = ',i6, ' swap_comm_protocol = ',i6)
call endrun
!
endif
!
elseif (swap_comm_order .eq. 1) then
! ordered swap:
! if (iam <= swapnode) send/recv
! if (iam >= swapnode) recv/send
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
if (swap_comm_protocol .eq. 0) then
!
if (iam <= swapnode) then
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
else
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
endif
!
else
!
! do not block for the send, enabling overlap of communication with computation.
if (iam <= swapnode) then
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
else
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
endif
!
endif
!
elseif (swap_comm_protocol <= 3) then
!
if (swap_comm_protocol .eq. 2) then
!
! complete outstanding receive.
if (iam <= swapnode) then
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpiwait( rcvid, status )
else
call mpiwait( rcvid, status )
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
endif
!
else
!
! also do not block for the send, enabling overlap of communication with computation.
if (iam <= swapnode) then
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
call mpiwait ( rcvid, status )
else
call mpiwait ( rcvid, status )
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com, &
sndid )
endif
endif
!
else
!
if (swap_comm_protocol .eq. 4) then
!
! complete forcetype receive.
if (iam <= swapnode) then
call mpirecv ( signal, 1, mpir8, swapnode, mtag, handshake_com )
call mpirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
call mpiwait ( rcvid, status )
else
call mpiwait ( rcvid, status )
call mpirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
endif
!
else
!
! also do not block for the send, enabling overlap of communication with computation.
if (iam <= swapnode) then
call mpirecv ( signal, 1, mpir8, swapnode, mtag, handshake_com )
call mpiirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
call mpiwait ( rcvid, status )
else
call mpiwait ( rcvid, status )
call mpiirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
endif
!
endif
!
elseif (swap_comm_protocol <= 10) then
!
if (swap_comm_protocol <= 7) then
!
if (swap_comm_protocol .eq. 6) then
!
! synchronous ordered swap
if (iam <= swapnode) then
call mpirecv( signal, 1, mpir8, swapnode, mtag, &
handshake_com )
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
else
call mpisend( signal, 1, mpir8, swapnode, mtag, &
handshake_com )
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
endif
!
else
!
! do not block for the synchronous send, enabling overlap of communication
! with computation.
if (iam <= swapnode) then
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid)
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
else
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol .eq. 8) then
!
! complete outstanding receive.
if (iam <= swapnode) then
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
call mpiwait( rcvid, status )
else
call mpiwait ( rcvid, status )
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
endif
!
else
!
! also do not block for the synchronous send, enabling overlap of communication
! with computation.
if (iam <= swapnode) then
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid)
call mpiwait ( rcvid, status )
else
call mpiwait ( rcvid, status )
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid)
endif
!
endif
!
else
! ordered swap using synchronous sends
if (iam <= swapnode) then
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
else
call mpirecv ( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
endif
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
!
endif
!
elseif (swap_comm_order .eq. 2) then
! delayed swap: send ... recv
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! do not block for send, enabling overlap of communication with computation.
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
!
elseif (swap_comm_protocol <= 3) then
!
if (swap_comm_protocol .eq. 2) then
! swap send
call mpisend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
else
! do not block for send, enabling overlap of communication with computation.
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
else
!
if (swap_comm_protocol .eq. 4) then
! use ready send
call mpirecv ( signal, 1, mpir8, swapnode, mtag, handshake_com )
call mpirsend( sndmsg, sndlth, mpir8, swapnode, mtag, swap_com )
else
! do not block for send, enabling overlap of communication with computation.
call mpirecv ( signal, 1, mpir8, swapnode, mtag, &
handshake_com )
call mpiirsend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
if (swap_comm_protocol .eq. 6) then
!
! native swap
call mpisendrecv( sndmsg, sndlth, mpir8, swapnode, mtag, &
rcvmsg, rcvlth, mpir8, swapnode, mtag, &
swap_com )
else
! do not block for send, enabling overlap of communication with computation.
call mpiisend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
else
!
if (swap_comm_protocol .eq. 8) then
! swap send using synchronous send
call mpissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com )
else
! do not block for synchronous send, enabling overlap of communication
! with computation.
call mpiissend( sndmsg, sndlth, mpir8, swapnode, mtag, &
swap_com, sndid )
endif
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
stop
!
endif
!
else
! undefined swap option
!
write (0,900) swap_comm_order
900 format(/,' fatal error in subroutine swap2:', &
/,' unknown communication option specified',/, &
' swap_comm_order = ',i6)
call endrun
!
endif
!
return
end subroutine swap2
!
!========================================================================
!
subroutine swap3(mtag, swapnode, sndid, rcvlth, rcvmsg, rcvid),22
!-----------------------------------------------------------------------
!
! Purpose:
! Third of three routines that implement swap using MPI point-to-point
! routines,
!
! Method:
! This subroutine completes the swap operation begun in swap1 and swap2.
! It waits until the send and receive request made in swap2 have
! completed.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Author of original version: P. Worley
! Ported to CAM: P. Worley, December 2003
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use pmgrid, only: iam
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
integer, intent(in) :: mtag ! MPI message tag
integer, intent(in) :: swapnode ! MPI process id of swap partner
integer, intent(inout):: sndid ! send request id
integer, intent(in) :: rcvlth ! length of incoming message buffer
integer, intent(inout):: rcvid ! receive request id
real(r8), intent(out) :: rcvmsg(rcvlth) ! incoming message buffer
!
!---------------------------Local workspace-----------------------------
!
real(r8) signal ! ready send signal
integer status(MPI_STATUS_SIZE) ! MPI status integer
!
!-------------------------------------------------------------------------------------
!
signal = 1.0
!
if (swap_comm_order .eq. 0) then
! simple swap: send/recv
!
! complete send for nonblocking send protocols.
if ((swap_comm_protocol .eq. 1) .or. (swap_comm_protocol .eq. 3) .or. &
(swap_comm_protocol .eq. 5) .or. (swap_comm_protocol .eq. 7) .or. &
(swap_comm_protocol .eq. 9)) then
call mpiwait( sndid, status )
elseif (swap_comm_protocol .gt. 9) then
write (0,901) swap_comm_order, swap_comm_protocol
901 format(/,' fatal error in subroutine swap3:', &
/,' unknown communication protocol specified',/, &
' swap_comm_order = ',i6, ' swap_comm_protocol = ',i6)
call endrun
endif
!
elseif (swap_comm_order .eq. 1) then
! ordered swap:
! if (iam <= swapnode) send/recv
! if (iam >= swapnode) recv/send
!
! complete send for nonblocking send protocols.
if ((swap_comm_protocol .eq. 1) .or. (swap_comm_protocol .eq. 3) .or. &
(swap_comm_protocol .eq. 5) .or. (swap_comm_protocol .eq. 7) .or. &
(swap_comm_protocol .eq. 9)) then
call mpiwait( sndid, status )
elseif (swap_comm_protocol .gt. 10) then
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
endif
!
elseif (swap_comm_order .eq. 2) then
! delayed-recv swap: recvbegin ... send ... recvend
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
if (swap_comm_protocol .eq. 0) then
! receive message.
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
else
! also complete send.
call mpirecv(rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
call mpiwait( sndid, status )
endif
!
elseif (swap_comm_protocol <= 3) then
!
if (swap_comm_protocol .eq. 2) then
! complete receive.
call mpiwait( rcvid, status )
else
! also complete send.
call mpiwait( rcvid, status )
call mpiwait( sndid, status )
endif
!
else
!
if (swap_comm_protocol .eq. 4) then
! complete receive.
call mpiwait( rcvid, status )
else
! also complete send.
call mpiwait( rcvid, status )
call mpiwait( sndid, status )
endif
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
if (swap_comm_protocol .eq. 6) then
! receive already complete in "native" swap
else
! also complete send.
call mpirecv( rcvmsg, rcvlth, mpir8, swapnode, mtag, swap_com )
call mpiwait( sndid, status )
endif
!
else
!
if (swap_comm_protocol .eq. 8) then
! complete receive.
call mpiwait( rcvid, status )
else
! also complete send.
call mpiwait( rcvid, status )
call mpiwait( sndid, status )
endif
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
!
endif
!
else
! undefined swap option
write (0,900) swap_comm_order
900 format(/,' fatal error in subroutine swap3:', &
/,' unknown communication option specified',/, &
' swap_comm_order = ',i6)
call endrun
!
endif
!
return
end subroutine swap3
!
!========================================================================
!
subroutine swap1m(cnt, mtag, swapnodes, & 6,15
rcvlths, rdispls, bufsiz, rcvbuf, rcvids)
!-----------------------------------------------------------------------
!
! Purpose:
! First of three routines that implement swap using MPI point-to-point
! routines. Variant of swap1 for multiple messages.
!
! Method:
! This subroutine begins a swap operation that will be completed by
! swap2 and swap3. It posts a receive and sends handshaking messages
! when ready sends are used.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Author of original version: P. Worley
! Ported to CAM: P. Worley, December 2003
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use pmgrid, only: iam
use spmd_dyn, only: npes
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
integer, intent(in) :: cnt ! number of swaps to initiate
integer, intent(in) :: mtag ! MPI message tag
integer, intent(in) :: swapnodes(cnt) ! MPI process id of swap partners
integer, intent(in) :: rcvlths(0:npes-1)
! length of incoming messages
integer, intent(in) :: rdispls(0:npes-1)
! offset from beginning of receive
! buffer where incoming messages
! should be placed
integer, intent(in) :: bufsiz ! message buffer size
integer, intent(inout) :: rcvids(cnt) ! receive request ids
real(r8), intent(out) :: rcvbuf(bufsiz) ! buffer for incoming messages
!
!---------------------------Local workspace-----------------------------
!
integer i ! loop index
integer p ! process index
integer offset_r ! index of message beginning in
! receive buffer
real(r8) signal ! ready send signal
!
!-------------------------------------------------------------------------------------
!
signal = 1.0
!
! simple swap: send/recv
if ((swap_comm_order .eq. 0) .or. (swap_comm_order .eq. 2)) then
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! this procotol does not use nonblocking receive.
!
elseif (swap_comm_protocol <= 3) then
!
! post the receive before the send, increasing odds that the
! receive will be posted before the message arrives.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
enddo
!
else
!
! post the receive before send to allow use of ready send.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
call mpisend( signal, 1, mpir8, p, mtag, handshake_com )
enddo
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
! these procotols do not use nonblocking receive.
!
else
!
! post the receive before the synchronous send, increasing odds that the
! receive will be posted before the message arrives.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
enddo
!
endif
!
else
!
write (0,901) swap_comm_order, swap_comm_protocol
901 format(/,' fatal error in subroutine swap1m:', &
/,' unknown communication protocol specified',/, &
' swap_comm_order = ',i6, ' swap_comm_protocol = ',i6)
call endrun
!
endif
!
elseif (swap_comm_order .eq. 1) then
! ordered swap:
! if (iam <= swapnode) send/recv
! if (iam >= swapnode) recv/send
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
! this procotol does not use nonblocking receive.
!
elseif (swap_comm_protocol <= 3) then
!
! post the receive before the initial send, increasing odds
! that the receive will be posted before the message arrives.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
enddo
!
else
!
! post the receive before the send to allow use of forcetypes.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
if (iam <= swapnodes(p)) then
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
else
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
call mpisend( signal, 1, mpir8, p, mtag, handshake_com )
endif
enddo
!
endif
!
elseif (swap_comm_protocol <= 10) then
!
if (swap_comm_protocol <= 7) then
!
! these protocols do not use nonblocking receive.
!
elseif (swap_comm_protocol <= 9) then
!
! post the receive before the initial synchronous send, increasing odds
! that the receive will be posted before the message arrives.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpiirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com, rcvids(i) )
enddo
!
else
!
! this protocol does not use nonblocking receive.
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
!
endif
!
else
!***********************************************************************
! undefined swap option
!***********************************************************************
!
write (0,900) swap_comm_order
900 format(/,' fatal error in subroutine swap1m:', &
/,' unknown communication option specified',/, &
' swap_comm_order = ',i6)
call endrun
!
endif
!
return
end subroutine swap1m
!
!========================================================================
!
subroutine swap3m(cnt, mtag, swapnodes, sndids, & 6,23
rcvlths, rdispls, bufsiz, rcvbuf, rcvids)
!-----------------------------------------------------------------------
!
! Purpose:
! Third of three routines that implement swap using MPI point-to-point
! routines. Variant of swap3 for multiple messages.
!
! Method:
! This subroutine completes swap operations begun in swap1 and swap2.
! It waits until the send and receive request made in swap2 have
! completed.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Author of original version: P. Worley
! Ported to CAM: P. Worley, December 2003
!
!-----------------------------------------------------------------------
use shr_kind_mod, only: r8 => shr_kind_r8
use pmgrid, only: iam
use spmd_dyn, only: npes
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
integer, intent(in) :: cnt ! number of swaps to complete
integer, intent(in) :: mtag ! MPI message tag
integer, intent(in) :: swapnodes(cnt) ! MPI process id of swap partners
integer, intent(inout) :: sndids(cnt) ! send request ids
integer, intent(in) :: rcvlths(0:npes-1)
! length of incoming messages
integer, intent(in) :: rdispls(0:npes-1)
! offset from beginning of receive
! buffer where incoming messages
! should be placed
integer, intent(inout) :: rcvids(cnt) ! receive request ids
integer, intent(in) :: bufsiz ! message buffer size
real(r8), intent(out) :: rcvbuf(bufsiz)
! buffer for incoming messages
!
!---------------------------Local workspace-----------------------------
!
integer i ! loop index
integer p ! process index
integer offset_r ! index of message beginning in
! receive buffer
integer status(MPI_STATUS_SIZE,cnt) ! MPI status integers
real(r8) signal ! ready send signal
!
!-------------------------------------------------------------------------------------
!
signal = 1.0
!
if (swap_comm_order .eq. 0) then
! simple swap: send/recv
!
! complete send for nonblocking send protocols.
if ((swap_comm_protocol .eq. 1) .or. (swap_comm_protocol .eq. 3) .or. &
(swap_comm_protocol .eq. 5) .or. (swap_comm_protocol .eq. 7) .or. &
(swap_comm_protocol .eq. 9)) then
call mpiwaitall ( cnt, sndids, status )
elseif (swap_comm_protocol .gt. 9) then
write (0,901) swap_comm_order, swap_comm_protocol
901 format(/,' fatal error in subroutine swap3m:', &
/,' unknown communication protocol specified',/, &
' swap_comm_order = ',i6, ' swap_comm_protocol = ',i6)
call endrun
endif
!
elseif (swap_comm_order .eq. 1) then
! ordered swap:
! if (iam <= swapnode) send/recv
! if (iam >= swapnode) recv/send
!
! complete send for nonblocking send protocols.
if ((swap_comm_protocol .eq. 1) .or. (swap_comm_protocol .eq. 3) .or. &
(swap_comm_protocol .eq. 5) .or. (swap_comm_protocol .eq. 7) .or. &
(swap_comm_protocol .eq. 9)) then
call mpiwaitall ( cnt, sndids, status )
elseif (swap_comm_protocol .gt. 10) then
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
endif
!
elseif (swap_comm_order .eq. 2) then
! delayed-recv swap: recvbegin ... send ... recvend
!
if (swap_comm_protocol <= 5) then
!
if (swap_comm_protocol <= 1) then
!
if (swap_comm_protocol .eq. 0) then
! receive message.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag,&
swap_com )
enddo
else
! also complete send.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag, &
swap_com )
enddo
call mpiwaitall( cnt, sndids, status )
endif
!
elseif (swap_comm_protocol <= 3) then
!
if (swap_comm_protocol .eq. 2) then
! complete receive.
call mpiwaitall( cnt, rcvids, status )
else
! also complete send.
call mpiwaitall( cnt, rcvids, status )
call mpiwaitall( cnt, sndids, status )
endif
!
else
!
if (swap_comm_protocol .eq. 4) then
! complete receive.
call mpiwaitall( cnt, rcvids, status )
else
! also complete send.
call mpiwaitall( cnt, rcvids, status )
call mpiwaitall( cnt, sndids, status )
endif
!
endif
!
elseif (swap_comm_protocol <= 9) then
!
if (swap_comm_protocol <= 7) then
!
if (swap_comm_protocol .eq. 6) then
! receive already complete in "native" swap
else
! also complete send.
do i=1,cnt
p = swapnodes(i)
offset_r = rdispls(p)+1
call mpirecv( rcvbuf(offset_r), rcvlths(p), mpir8, p, mtag, &
swap_com )
enddo
call mpiwaitall( cnt, sndids, status )
endif
!
else
!
if (swap_comm_protocol .eq. 8) then
! complete receive.
call mpiwaitall( cnt, rcvids, status )
else
! also complete send.
call mpiwaitall( cnt, rcvids, status )
call mpiwaitall( cnt, sndids, status )
endif
!
endif
!
else
!
! protocol error
write (0,901) swap_comm_order, swap_comm_protocol
call endrun
!
endif
!
else
! undefined swap option
write (0,900) swap_comm_order
900 format(/,' fatal error in subroutine swap3m:', &
/,' unknown communication option specified',/, &
' swap_comm_order = ',i6)
call endrun
!
endif
!
return
end subroutine swap3m
!
!========================================================================
!
logical function do_swap1()
!-----------------------------------------------------------------------
!
! Purpose:
! Indicates whether swap1 does anything when called with the current
! communication option and communication protocol.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Method:
!
! Author: P. Worley
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
!-------------------------------------------------------------------------------------
!
do_swap1 = .false.
if ((swap_comm_order >= 0) .and. (swap_comm_order <= 2)) then
if (((swap_comm_protocol >= 2) .and. (swap_comm_protocol <= 5)) .or. &
(((swap_comm_protocol >= 8) .and. (swap_comm_protocol <= 9)))) then
do_swap1 = .true.
endif
endif
!
return
end function do_swap1
!
!========================================================================
!
logical function do_swap3()
!-----------------------------------------------------------------------
!
! Purpose:
! Indicates whether swap3 does anything when called with the current
! communication option and communication protocol.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Method:
!
! Author: P. Worley
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
!-------------------------------------------------------------------------------------
!
do_swap3 = .false.
if ((swap_comm_order >= 0) .and. (swap_comm_order <= 1)) then
if ((swap_comm_protocol >= 1) .and. (swap_comm_protocol <= 9)) then
if (mod(swap_comm_protocol,2) .eq. 1) then
do_swap3 = .true.
endif
endif
elseif (swap_comm_order .eq. 2) then
if (((swap_comm_protocol >= 0) .and. (swap_comm_protocol <= 5)) .or. &
(((swap_comm_protocol >= 7) .and. (swap_comm_protocol <= 9)))) then
do_swap3 = .true.
endif
endif
!
return
end function do_swap3
!
!========================================================================
!
logical function delayed_swap_recv() 4
!-----------------------------------------------------------------------
!
! Purpose:
! Indicates whether message receives occur in swap3 with the current
! communication option and communication protocol.
! if (swap_comm_order .eq. 0) simple swap: send/recv
! if (swap_comm_order .eq. 1) ordered swap: [send/recv]|[recv/send]
! if (swap_comm_order .eq. 2) delayed-recv swap: send ... recv
! if (swap_comm_protocol .eq. 1, 3, 5, 7, .or. 9) nonblocking send
! if (swap_comm_protocol .eq. 2, 3, 4, 5, 8, .or. 9) nonblocking receive
! if (swap_comm_protocol .eq. 4 .or. 5) ready send
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 0) sendrecv
! if (swap_comm_protocol .eq. 6 .and. swap_comm_order .eq. 1) explicitly synchronous
! if (swap_comm_protocol .eq. 7, 8, 9, .or. 10) synchronous send
!
! Method:
!
! Author: P. Worley
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
implicit none
!---------------------------Input arguments--------------------------
!
!-------------------------------------------------------------------------------------
!
delayed_swap_recv = .false.
if (swap_comm_order .eq. 2) then
if (((swap_comm_protocol >= 0) .and. (swap_comm_protocol <= 5)) .or. &
(((swap_comm_protocol >= 7) .and. (swap_comm_protocol <= 9)))) then
delayed_swap_recv = .true.
endif
endif
!
return
end function delayed_swap_recv
#endif
end module swap_comm