!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
!BOP
! !MODULE: POP_HaloMod
module POP_HaloMod 17,11
! !DESCRIPTION:
! This module contains data types and routines for updating halo
! regions (ghost cells) using MPI calls
!
! !REVISION HISTORY:
! SVN:$Id$
! 2007-07-19: Phil Jones, Yoshi Yoshida, John Dennis
! new naming conventions, optimizations during
! initialization, true multi-dimensional updates
! (rather than serial call to two-dimensional updates),
! fixes for non-existent blocks
! 2008-01-30: Phil Jones, Elizabeth Hunke
! fixed some bugs Elizabeth found with one assumption
! of halo width 2, a typo on sw/se nbr, and
! tripole buffers uninitialized
! !USES:
use POP_KindsMod
use POP_ErrorMod
use POP_IOUnitsMod
use POP_CommMod
use POP_BlocksMod
use POP_ReductionsMod
use POP_DistributionMod
use POP_FieldMod
use POP_GridHorzMod
implicit none
private
save
include 'mpif.h'
! !PUBLIC TYPES:
type, public :: POP_halo
integer (POP_i4) :: &
communicator, &! communicator to use for update messages
numMsgSend, &! number of messages to send halo update
numMsgRecv, &! number of messages to recv halo update
numLocalCopies ! num local copies for halo update
integer (POP_i4), dimension(:), pointer :: &
recvTask, &! task from which to recv each msg
sendTask, &! task to which to send each msg
sizeSend, &! size of each sent message
sizeRecv ! size of each recvd message
integer (POP_i4), dimension(:,:), pointer :: &
srcLocalAddr, &! src addresses for each local copy
dstLocalAddr ! dst addresses for each local copy
integer (POP_i4), dimension(:,:,:), pointer :: &
sendAddr, &! src addresses for each sent message
recvAddr ! dst addresses for each recvd message
end type
! !PUBLIC MEMBER FUNCTIONS:
public :: POP_HaloCreate, &
POP_HaloDestroy, &
POP_HaloUpdate, &
POP_HaloPrintStats
interface POP_HaloUpdate ! generic interface 103
module procedure POP_HaloUpdate2DR8
POP_HaloUpdate2DR4, &
POP_HaloUpdate2DI4, &
POP_HaloUpdate3DR8, &
POP_HaloUpdate3DR4, &
POP_HaloUpdate3DI4, &
POP_HaloUpdate4DR8, &
POP_HaloUpdate4DR4, &
POP_HaloUpdate4DI4
end interface
!EOP
!BOC
!-----------------------------------------------------------------------
!
! to prevent frequent allocate-deallocate for 2d halo updates, create
! a static 2d buffer to be allocated once at creation. if future
! creation needs larger buffer, resize during the creation.
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
bufSizeSend, &! max buffer size for send messages
bufSizeRecv ! max buffer size for recv messages
integer (POP_i4), dimension(:,:), allocatable :: &
bufSendI4, &! buffer for use to send in 2D i4 halo updates
bufRecvI4 ! buffer for use to recv in 2D i4 halo updates
real (POP_r4), dimension(:,:), allocatable :: &
bufSendR4, &! buffer for use to send in 2D r4 halo updates
bufRecvR4 ! buffer for use to recv in 2D r4 halo updates
real (POP_r8), dimension(:,:), allocatable :: &
bufSendR8, &! buffer for use to send in 2D r8 halo updates
bufRecvR8 ! buffer for use to recv in 2D r8 halo updates
!-----------------------------------------------------------------------
!
! global buffers for tripole boundary
!
!-----------------------------------------------------------------------
integer (POP_i4), dimension(:,:), allocatable :: &
bufTripoleI4
real (POP_r4), dimension(:,:), allocatable :: &
bufTripoleR4
real (POP_r8), dimension(:,:), allocatable :: &
bufTripoleR8
!EOC
!***********************************************************************
contains
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloCreate
! !INTERFACE:
function POP_HaloCreate(distrb, nsBoundaryType, ewBoundaryType, & 2,183
nxGlobal, errorCode) result(halo)
! !DESCRIPTION:
! This routine creates a halo type with info necessary for
! performing a halo (ghost cell) update. This info is computed
! based on the input block distribution.
!
! !REVISION HISTORY:
! same as module
! !INPUT PARAMETERS:
type (POP_distrb), intent(in) :: &
distrb ! distribution of blocks across procs
character (*), intent(in) :: &
nsBoundaryType, &! type of boundary to use in logical ns dir
ewBoundaryType ! type of boundary to use in logical ew dir
integer (POP_i4), intent(in) :: &
nxGlobal ! global grid extent for tripole grids
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
type (POP_halo) :: &
halo ! a new halo type with info for halo updates
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,l,n,m,&
istat, &! allocate status flag
numProcs, &! num of processors involved
communicator, &! communicator for message passing
iblock, &! block counter
eastBlock, westBlock, &! block id east, west neighbors
northBlock, southBlock, &! block id north, south neighbors
neBlock, nwBlock, &! block id northeast, northwest nbrs
seBlock, swBlock, &! block id southeast, southwest nbrs
srcProc, dstProc, &! source, dest processor locations
srcLocalID, dstLocalID, &! local block index of src,dst blocks
maxTmp, &! temp for global maxval
blockSizeX, &! size of default physical domain in X
blockSizeY, &! size of default physical domain in Y
maxSizeSend, maxSizeRecv, &! max buffer sizes
numMsgSend, numMsgRecv, &! number of messages for this halo
eastMsgSize, westMsgSize, &! nominal sizes for e-w msgs
northMsgSize, southMsgSize, &! nominal sizes for n-s msgs
tripoleMsgSize, &! size for tripole messages
tripoleMsgSizeOut, &! size for tripole messages
cornerMsgSize, msgSize ! nominal size for corner msg
integer (POP_i4), dimension(:), allocatable :: &
sendCount, recvCount ! count number of words to each proc
logical (POP_logical) :: &
resize, &! flag for resizing buffers
tripoleFlag, &! flag for allocating tripole buffers
tripoleBlock ! flag for identifying north tripole blocks
!-----------------------------------------------------------------------
!
! Initialize some useful variables and return if this task not
! in the current distribution.
!
!-----------------------------------------------------------------------
errorCode = POP_Success
call POP_DistributionGet(distrb, errorCode, &
numProcs = numProcs, &
communicator = communicator)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error getting distrb info')
return
endif
if (POP_myTask >= numProcs) return
halo%communicator = communicator
blockSizeX = POP_nxBlock - 2*POP_haloWidth
blockSizeY = POP_nyBlock - 2*POP_haloWidth
eastMsgSize = POP_haloWidth*blockSizeY
westMsgSize = POP_haloWidth*blockSizeY
southMsgSize = POP_haloWidth*blockSizeX
northMsgSize = POP_haloWidth*blockSizeX
cornerMsgSize = POP_haloWidth*POP_haloWidth
tripoleMsgSize = (POP_haloWidth+1)*blockSizeX
tripoleMsgSizeOut = (POP_haloWidth+1)*POP_nxBlock
if (nsBoundaryType == 'tripole') then
tripoleFlag = .true.
!*** allocate tripole message buffers if not already done
if (.not. allocated(bufTripoleR8)) then
allocate (bufTripoleI4(nxGlobal, POP_haloWidth+1), &
bufTripoleR4(nxGlobal, POP_haloWidth+1), &
bufTripoleR8(nxGlobal, POP_haloWidth+1), &
stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error allocating tripole buffers')
return
endif
endif
else
tripoleFlag = .false.
endif
!-----------------------------------------------------------------------
!
! Count the number of messages to send/recv from each processor
! and number of words in each message. These quantities are
! necessary for allocating future arrays.
!
!-----------------------------------------------------------------------
allocate (sendCount(numProcs), recvCount(numProcs), stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error allocating count arrays')
return
endif
sendCount = 0
recvCount = 0
msgCountLoop: do iblock=1,POP_numBlocks
call POP_DistributionGetBlockLoc(distrb, iblock, srcProc, &
srcLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding source block location')
return
endif
!*** find north neighbor block and add to message count
!*** also set tripole block flag for later special cases
northBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorth, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north neighbor block')
return
endif
if (northBlock > 0) then
tripoleBlock = .false.
msgSize = northMsgSize
call POP_DistributionGetBlockLoc(distrb, northBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north block location')
return
endif
else if (northBlock < 0) then ! tripole north row, count block
tripoleBlock = .true.
msgSize = tripoleMsgSize
call POP_DistributionGetBlockLoc(distrb, abs(northBlock), &
dstProc, dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north block location')
return
endif
else
tripoleBlock = .false.
msgSize = northMsgSize
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, msgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing north message')
return
endif
!*** if a tripole boundary block, also create a local
!*** message into and out of tripole buffer
if (tripoleBlock) then
!*** copy out of tripole buffer - includes halo
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, srcProc, &
tripoleMsgSizeOut, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole copy out count')
return
endif
!*** copy in only required if dstProc not same as srcProc
if (dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, srcProc, &
msgSize, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole copy in')
return
endif
endif
endif
!*** find south neighbor block and add to message count
southBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSouth, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding south neighbor block')
return
endif
if (southBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, southBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding south block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, southMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing south message count')
return
endif
!*** find east neighbor block and add to message count
eastBlock = POP_BlocksGetNbrID(iblock, POP_BlocksEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east neighbor block')
return
endif
if (eastBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, eastBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, eastMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing east message count')
return
endif
!*** if a tripole boundary block, non-local east neighbor
!*** needs a chunk of the north boundary, so add a message
!*** for that
if (tripoleBlock .and. dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, tripoleMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole east msg count')
return
endif
endif
!*** find west neighbor block and add to message count
westBlock = POP_BlocksGetNbrID(iblock, POP_BlocksWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west neighbor block')
return
endif
if (westBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, westBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, westMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing west message count')
return
endif
!*** if a tripole boundary block, non-local west neighbor
!*** needs a chunk of the north boundary, so add a message
!*** for that
if (tripoleBlock .and. dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, tripoleMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole west msg count')
return
endif
endif
!*** find northeast neighbor block and add to message count
neBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorthEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northeast neighbor block')
return
endif
if (neBlock > 0) then
msgSize = cornerMsgSize ! normal corner message
call POP_DistributionGetBlockLoc(distrb, neBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northeast block location')
return
endif
else if (neBlock < 0) then ! tripole north row
msgSize = tripoleMsgSize ! tripole needs whole top row of block
call POP_DistributionGetBlockLoc(distrb, abs(neBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northeast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, msgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing northeast message count')
return
endif
!*** find northwest neighbor block and add to message count
nwBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest neighbor block')
return
endif
if (nwBlock > 0) then
msgSize = cornerMsgSize ! normal NE corner update
call POP_DistributionGetBlockLoc(distrb, nwBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest block location')
return
endif
else if (nwBlock < 0) then ! tripole north row, count block
msgSize = tripoleMsgSize ! tripole NE corner update - entire row needed
call POP_DistributionGetBlockLoc(distrb, abs(nwBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, msgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing northwest message count')
return
endif
!*** find southeast neighbor block and add to message count
seBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSoutheast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southeast neighbor block')
return
endif
if (seBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, seBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southeast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, cornerMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing southeast message count')
return
endif
!*** find southwest neighbor block and add to message count
swBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSouthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southwest neighbor block')
return
endif
if (swBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, swBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southwest block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, cornerMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing southwest message count')
return
endif
!*** for tripole grids with padded domain, padding will
!*** prevent tripole buffer from getting all the info
!*** it needs - must extend footprint at top boundary
if (tripoleBlock .and. & !tripole
mod(nxGlobal,blockSizeX) /= 0) then !padding
!*** find east2 neighbor block and add to message count
eastBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksEast2, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east2 neighbor block')
return
endif
if (eastBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, eastBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east2 block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, tripoleMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole east2 msg count')
return
endif
endif
!*** find EastNorthEast neighbor block and add to message count
neBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksEastNorthEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding EastNorthEast neighbor block')
return
endif
if (neBlock < 0) then ! tripole north row
msgSize = tripoleMsgSize ! tripole needs whole top row of block
call POP_DistributionGetBlockLoc(distrb, abs(neBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding EastNorthEast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, msgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing northeast2 message count')
return
endif
endif
!*** find west2 neighbor block and add to message count
westBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksWest2, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west2 neighbor block')
return
endif
if (westBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, westBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west2 block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, tripoleMsgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing tripole west2 msg count')
return
endif
endif
!*** find WestNorthWest neighbor block and add to message count
nwBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksWestNorthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding WestNorthWest neighbor block')
return
endif
if (nwBlock < 0) then ! tripole north row
msgSize = tripoleMsgSize ! tripole needs whole top row of block
call POP_DistributionGetBlockLoc(distrb, abs(nwBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest2 block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloIncrementMsgCount(sendCount, recvCount, &
srcProc, dstProc, msgSize, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error incrementing northwest2 message count')
return
endif
endif
endif
end do msgCountLoop
!-----------------------------------------------------------------------
!
! if messages are received from the same processor, the message is
! actually a local copy - count them and reset to zero
!
!-----------------------------------------------------------------------
halo%numLocalCopies = recvCount(POP_myTask+1)
sendCount(POP_myTask+1) = 0
recvCount(POP_myTask+1) = 0
!-----------------------------------------------------------------------
!
! now count the number of actual messages to be sent and received
!
!-----------------------------------------------------------------------
numMsgSend = count(sendCount /= 0)
numMsgRecv = count(recvCount /= 0)
halo%numMsgSend = numMsgSend
halo%numMsgRecv = numMsgRecv
!-----------------------------------------------------------------------
!
! allocate buffers for 2-d halo updates to save time later
! if the buffers are already allocated by previous create call,
! check to see if they need to be re-sized
!
!-----------------------------------------------------------------------
maxTmp = maxval(sendCount)
maxSizeSend = POP_GlobalMaxval(maxTmp, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error computing size of send buffer')
return
endif
maxTmp = maxval(recvCount)
maxSizeRecv = POP_GlobalMaxval(maxTmp, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error computing size of recv buffer')
return
endif
if (.not. allocated(bufSendR8)) then
bufSizeSend = maxSizeSend
bufSizeRecv = maxSizeRecv
allocate(bufSendI4(bufSizeSend, numMsgSend), &
bufRecvI4(bufSizeRecv, numMsgRecv), &
bufSendR4(bufSizeSend, numMsgSend), &
bufRecvR4(bufSizeRecv, numMsgRecv), &
bufSendR8(bufSizeSend, numMsgSend), &
bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error allocating 2d buffers')
return
endif
else
resize = .false.
if (maxSizeSend > bufSizeSend) then
resize = .true.
bufSizeSend = maxSizeSend
endif
if (maxSizeRecv > bufSizeRecv) then
resize = .true.
bufSizeRecv = maxSizeRecv
endif
if (numMsgSend > size(bufSendR8,dim=2)) resize = .true.
if (numMsgRecv > size(bufRecvR8,dim=2)) resize = .true.
if (resize) then
deallocate(bufSendI4, bufRecvI4, bufSendR4, &
bufRecvR4, bufSendR8, bufRecvR8, stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error deallocating 2d buffers')
return
endif
allocate(bufSendI4(bufSizeSend, numMsgSend), &
bufRecvI4(bufSizeRecv, numMsgRecv), &
bufSendR4(bufSizeSend, numMsgSend), &
bufRecvR4(bufSizeRecv, numMsgRecv), &
bufSendR8(bufSizeSend, numMsgSend), &
bufRecvR8(bufSizeRecv, numMsgRecv), stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error reallocating 2d buffers')
return
endif
endif
endif
!-----------------------------------------------------------------------
!
! allocate arrays for message information and initialize
!
!-----------------------------------------------------------------------
allocate(halo%sendTask(numMsgSend), &
halo%recvTask(numMsgRecv), &
halo%sizeSend(numMsgSend), &
halo%sizeRecv(numMsgRecv), &
halo%sendAddr(3,bufSizeSend,numMsgSend), &
halo%recvAddr(3,bufSizeRecv,numMsgRecv), &
halo%srcLocalAddr(3,halo%numLocalCopies), &
halo%dstLocalAddr(3,halo%numLocalCopies), &
stat = istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error allocating halo message info arrays')
return
endif
halo%sendTask = 0
halo%recvTask = 0
halo%sizeSend = 0
halo%sizeRecv = 0
halo%sendAddr = 0
halo%recvAddr = 0
halo%srcLocalAddr = 0
halo%dstLocalAddr = 0
deallocate(sendCount, recvCount, stat=istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error deallocating count arrays')
return
endif
!-----------------------------------------------------------------------
!
! repeat loop through blocks but this time, determine all the
! required message information for each message or local copy
!
!-----------------------------------------------------------------------
!*** reset halo scalars to use as counters
halo%numMsgSend = 0
halo%numMsgRecv = 0
halo%numLocalCopies = 0
msgConfigLoop: do iblock=1,POP_numBlocks
call POP_DistributionGetBlockLoc(distrb, iblock, srcProc, &
srcLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding source block location')
return
endif
!*** find north neighbor block and set msg info
!*** also set tripole block flag for later special cases
northBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorth, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north neighbor block')
return
endif
if (northBlock > 0) then
tripoleBlock = .false.
call POP_DistributionGetBlockLoc(distrb, northBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north block location')
return
endif
else if (northBlock < 0) then ! tripole north row, count block
tripoleBlock = .true.
call POP_DistributionGetBlockLoc(distrb, abs(northBlock), &
dstProc, dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding north block location')
return
endif
else
tripoleBlock = .false.
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
northBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating north message')
return
endif
!*** if a tripole boundary block, also create a local
!*** message into and out of tripole buffer
if (tripoleBlock) then
!*** copy out of tripole buffer - includes halo
call POP_HaloMsgCreate(halo,-iblock, srcProc, srcLocalID, &
iblock, srcProc, srcLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole copy out of buf')
return
endif
!*** copy in only required if dstProc not same as srcProc
if (dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
-iblock, srcProc, srcLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole copy into buf')
return
endif
endif
endif
!*** find south neighbor block and add to message count
southBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSouth, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding south neighbor block')
return
endif
if (southBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, southBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding south block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
southBlock, dstProc, dstLocalID, &
'south', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating south message')
return
endif
!*** find east neighbor block and add to message count
eastBlock = POP_BlocksGetNbrID(iblock, POP_BlocksEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east neighbor block')
return
endif
if (eastBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, eastBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
eastBlock, dstProc, dstLocalID, &
'east', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating east message')
return
endif
!*** if a tripole boundary block, non-local east neighbor
!*** needs a chunk of the north boundary, so add a message
!*** for that
if (tripoleBlock .and. dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
-eastBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole east msg')
return
endif
endif
!*** find west neighbor block and add to message count
westBlock = POP_BlocksGetNbrID(iblock, POP_BlocksWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west neighbor block')
return
endif
if (westBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, westBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
westBlock, dstProc, dstLocalID, &
'west', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating west message')
return
endif
!*** if a tripole boundary block, non-local west neighbor
!*** needs a chunk of the north boundary, so add a message
!*** for that
if (tripoleBlock .and. dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
-westBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole west msg')
return
endif
endif
!*** find northeast neighbor block and add to message count
neBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorthEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northeast neighbor block')
return
endif
if (neBlock /= 0) then
call POP_DistributionGetBlockLoc(distrb, abs(neBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northeast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
neBlock, dstProc, dstLocalID, &
'northeast', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating northeast message')
return
endif
!*** find northwest neighbor block and add to message count
nwBlock = POP_BlocksGetNbrID(iblock, POP_BlocksNorthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest neighbor block')
return
endif
if (nwBlock /= 0) then
call POP_DistributionGetBlockLoc(distrb, abs(nwBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding northwest block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
nwBlock, dstProc, dstLocalID, &
'northwest', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating northwest message')
return
endif
!*** find southeast neighbor block and add to message count
seBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSoutheast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southeast neighbor block')
return
endif
if (seBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, seBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southeast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
seBlock, dstProc, dstLocalID, &
'southeast', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating southeast message')
return
endif
!*** find southwest neighbor block and add to message count
swBlock = POP_BlocksGetNbrID(iblock, POP_BlocksSouthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southwest neighbor block')
return
endif
if (swBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, swBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding southwest block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
swBlock, dstProc, dstLocalID, &
'southwest', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating southwest message')
return
endif
!*** for tripole grids with padded domain, padding will
!*** prevent tripole buffer from getting all the info
!*** it needs - must extend footprint at top boundary
if (tripoleBlock .and. & !tripole
mod(nxGlobal,blockSizeX) /= 0) then !padding
!*** find east2 neighbor block and add to message count
eastBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksEast2, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east2 neighbor block')
return
endif
if (eastBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, eastBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding east2 block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
-eastBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole east2 msg')
return
endif
endif
!*** find EastNorthEast neighbor block and add to message count
neBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksEastNorthEast, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding EastNorthEast neighbor block')
return
endif
if (neBlock < 0) then ! tripole north row
msgSize = tripoleMsgSize ! tripole needs whole top row of block
call POP_DistributionGetBlockLoc(distrb, abs(neBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding EastNorthEast block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
neBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating EastNorthEast message')
return
endif
endif
!*** find west2 neighbor block and add to message count
westBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksWest2, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west2 neighbor block')
return
endif
if (westBlock > 0) then
call POP_DistributionGetBlockLoc(distrb, westBlock, dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding west2 block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
-westBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating tripole west msg')
return
endif
endif
!*** find WestNorthWest neighbor block and add to message count
nwBlock = POP_BlocksGetNbrID(iBlock, POP_BlocksWestNorthWest, &
ewBoundaryType, nsBoundaryType, &
errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding WestNorthWest neighbor block')
return
endif
if (nwBlock < 0) then ! tripole north row
msgSize = tripoleMsgSize ! tripole needs whole top row of block
call POP_DistributionGetBlockLoc(distrb, abs(nwBlock), dstProc, &
dstLocalID, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error finding WestNorthWest block location')
return
endif
else
dstProc = 0
dstLocalID = 0
endif
if (dstProc /= srcProc) then
call POP_HaloMsgCreate(halo, iblock, srcProc, srcLocalID, &
nwBlock, dstProc, dstLocalID, &
'north', errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloCreate: error creating WestNorthWest message')
return
endif
endif
endif
end do msgConfigLoop
!-----------------------------------------------------------------------
!EOC
end function POP_HaloCreate
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloDestroy
! !INTERFACE:
subroutine POP_HaloDestroy(halo, errorCode),1
! !DESCRIPTION:
! This routine destroys a halo structure by deallocating all memory
! associated with the halo and nullifying pointers.
!
! !REVISION HISTORY:
! same as module
! !INPUT/OUTPUT PARAMETERS:
type (POP_halo), intent(inout) :: &
halo ! boundary structure to be destroyed
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local status flag for deallocate
!
!-----------------------------------------------------------------------
integer (POP_i4) :: istat
!-----------------------------------------------------------------------
!
! reset all scalars
!
!-----------------------------------------------------------------------
errorCode = POP_Success
halo%communicator = 0
halo%numMsgSend = 0
halo%numMsgRecv = 0
halo%numLocalCopies = 0
!-----------------------------------------------------------------------
!
! deallocate all pointers
!
!-----------------------------------------------------------------------
deallocate(halo%recvTask, halo%sendTask, &
halo%sizeSend, halo%sizeRecv, &
halo%srcLocalAddr, halo%dstLocalAddr, &
halo%sendAddr, halo%recvAddr, &
stat = istat)
if (istat > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloDestroy: error deallocating halo')
return
endif
!-----------------------------------------------------------------------
!
! nullify all pointers
!
!-----------------------------------------------------------------------
nullify(halo%recvTask)
nullify(halo%sendTask)
nullify(halo%sizeSend)
nullify(halo%sizeRecv)
nullify(halo%srcLocalAddr)
nullify(halo%dstLocalAddr)
nullify(halo%sendAddr)
nullify(halo%recvAddr)
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloDestroy
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate2DR8
! !INTERFACE:
subroutine POP_HaloUpdate2DR8(array, halo, & 1,4
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 2d horizontal arrays of double precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r8), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r8), dimension(:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r8) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r8
endif
nxGlobal = 0
if (allocated(bufTripoleR8)) then
nxGlobal = size(bufTripoleR8,dim=1)
bufTripoleR8 = fill
endif
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR8: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecvR8(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
bufSendR8(n,nmsg) = array(iSrc,jSrc,srcBlock)
end do
do n=halo%sizeSend(nmsg)+1,bufSizeSend
bufSendR8(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = halo%sizeSend(nmsg)
call MPI_ISEND(bufSendR8(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = &
array(iSrc,jSrc,srcBlock)
else if (dstBlock < 0) then ! tripole copy into buffer
bufTripoleR8(iDst,jDst) = &
array(iSrc,jSrc,srcBlock)
endif
else if (srcBlock == 0) then
array(iDst,jDst,dstBlock) = fill
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = bufRecvR8(n,nmsg)
else if (dstBlock < 0) then !tripole
bufTripoleR8(iDst,jDst) = bufRecvR8(n,nmsg)
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR8: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
!*** swap locations with symmetric points so buffer has
!*** correct values during the copy out
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripoleR8(i ,POP_haloWidth+1)
x2 = bufTripoleR8(iDst,POP_haloWidth+1)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripoleR8(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleR8(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
bufTripoleR8(nxGlobal,POP_haloWidth+1) = isign* &
bufTripoleR8(nxGlobal,POP_haloWidth+1)
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripoleR8(i ,POP_haloWidth+1)
x2 = bufTripoleR8(iDst,POP_haloWidth+1)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripoleR8(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleR8(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR8: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
array(iDst,jDst,dstBlock) = isign*bufTripoleR8(iSrc,jSrc)
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR8: error deallocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate2DR8
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate2DR4
! !INTERFACE:
subroutine POP_HaloUpdate2DR4(array, halo, &,4
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 2d horizontal arrays of single precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r4), dimension(:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r4
endif
nxGlobal = 0
if (allocated(bufTripoleR4)) then
nxGlobal = size(bufTripoleR4,dim=1)
bufTripoleR4 = fill
endif
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecvR4(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
bufSendR4(n,nmsg) = array(iSrc,jSrc,srcBlock)
end do
do n=halo%sizeSend(nmsg)+1,bufSizeSend
bufSendR4(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = halo%sizeSend(nmsg)
call MPI_ISEND(bufSendR4(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = &
array(iSrc,jSrc,srcBlock)
else if (dstBlock < 0) then ! tripole copy into buffer
bufTripoleR4(iDst,jDst) = &
array(iSrc,jSrc,srcBlock)
endif
else if (srcBlock == 0) then
array(iDst,jDst,dstBlock) = fill
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = bufRecvR4(n,nmsg)
else if (dstBlock < 0) then !tripole
bufTripoleR4(iDst,jDst) = bufRecvR4(n,nmsg)
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripoleR4(i ,POP_haloWidth+1)
x2 = bufTripoleR4(iDst,POP_haloWidth+1)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripoleR4(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleR4(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
bufTripoleR4(nxGlobal,POP_haloWidth+1) = isign* &
bufTripoleR4(nxGlobal,POP_haloWidth+1)
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripoleR4(i ,POP_haloWidth+1)
x2 = bufTripoleR4(iDst,POP_haloWidth+1)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripoleR4(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleR4(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
array(iDst,jDst,dstBlock) = isign*bufTripoleR4(iSrc,jSrc)
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DR4: error deallocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate2DR4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate2DI4
! !INTERFACE:
subroutine POP_HaloUpdate2DI4(array, halo, &,4
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 2d horizontal integer arrays.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
integer (POP_i4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
integer (POP_i4), dimension(:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
integer (POP_i4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0_POP_i4
endif
nxGlobal = 0
if (allocated(bufTripoleI4)) then
nxGlobal = size(bufTripoleI4,dim=1)
bufTripoleI4 = fill
endif
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DI4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecvI4(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
bufSendI4(n,nmsg) = array(iSrc,jSrc,srcBlock)
end do
do n=halo%sizeSend(nmsg)+1,bufSizeSend
bufSendI4(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = halo%sizeSend(nmsg)
call MPI_ISEND(bufSendI4(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = &
array(iSrc,jSrc,srcBlock)
else if (dstBlock < 0) then ! tripole copy into buffer
bufTripoleI4(iDst,jDst) = &
array(iSrc,jSrc,srcBlock)
endif
else if (srcBlock == 0) then
array(iDst,jDst,dstBlock) = fill
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
array(iDst,jDst,dstBlock) = bufRecvI4(n,nmsg)
else if (dstBlock < 0) then !tripole
bufTripoleI4(iDst,jDst) = bufRecvI4(n,nmsg)
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DI4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripoleI4(i ,POP_haloWidth+1)
x2 = bufTripoleI4(iDst,POP_haloWidth+1)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripoleI4(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleI4(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
bufTripoleI4(nxGlobal,POP_haloWidth+1) = isign* &
bufTripoleI4(nxGlobal,POP_haloWidth+1)
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripoleI4(i ,POP_haloWidth+1)
x2 = bufTripoleI4(iDst,POP_haloWidth+1)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripoleI4(i ,POP_haloWidth+1) = isign*sign(xavg, x2)
bufTripoleI4(iDst,POP_haloWidth+1) = isign*sign(xavg, x1)
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DI4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
array(iDst,jDst,dstBlock) = isign*bufTripoleI4(iSrc,jSrc)
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate2DI4: error deallocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate2DI4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate3DR8
! !INTERFACE:
subroutine POP_HaloUpdate3DR8(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 3d horizontal arrays of double precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r8), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r8), dimension(:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, &! size of array in 3rd dimension
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r8) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
real (POP_r8), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 3d send,recv buffers
real (POP_r8), dimension(:,:,:), allocatable :: &
bufTripole ! 3d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r8
endif
nxGlobal = 0
if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 3D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
!$OMP PARALLEL DO PRIVATE(nmsg,i,n,iSrc,jSrc,srcBlock,k)
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
end do
end do
do n=i+1,bufSizeSend*nz
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
end do
!$OMP END PARALLEL DO
do nmsg=1,halo%numMsgSend
msgSize = nz*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = &
array(iSrc,jSrc,k,srcBlock)
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do k=1,nz
bufTripole(iDst,jDst,k) = &
array(iSrc,jSrc,k,srcBlock)
end do
endif
else if (srcBlock == 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = fill
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
!$OMP PARALLEL DO PRIVATE(nmsg,i,n,iDst,jDst,dstBlock,k)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do k=1,nz
i = i + 1
array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
end do
else if (dstBlock < 0) then !tripole
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
end do
endif
end do
end do
!$OMP END PARALLEL DO
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k)
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k)
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR8: error deallocating 3d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate3DR8
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate3DR4
! !INTERFACE:
subroutine POP_HaloUpdate3DR4(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 3d horizontal arrays of single precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r4), dimension(:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, &! size of array in 3rd dimension
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
real (POP_r4), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 3d send,recv buffers
real (POP_r4), dimension(:,:,:), allocatable :: &
bufTripole ! 3d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r4
endif
nxGlobal = 0
if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 3D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
end do
end do
do n=i+1,bufSizeSend*nz
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = nz*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = &
array(iSrc,jSrc,k,srcBlock)
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do k=1,nz
bufTripole(iDst,jDst,k) = &
array(iSrc,jSrc,k,srcBlock)
end do
endif
else if (srcBlock == 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = fill
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do k=1,nz
i = i + 1
array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
end do
else if (dstBlock < 0) then !tripole
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
end do
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k)
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k)
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error deallocating 3d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate3DR4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate3DI4
! !INTERFACE:
subroutine POP_HaloUpdate3DI4(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 3d horizontal arrays of double precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
integer (POP_i4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
integer (POP_i4), dimension(:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, &! size of array in 3rd dimension
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
integer (POP_i4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
integer (POP_i4), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 3d send,recv buffers
integer (POP_i4), dimension(:,:,:), allocatable :: &
bufTripole ! 3d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0_POP_i4
endif
nxGlobal = 0
if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 3D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
allocate(bufSend(bufSizeSend*nz, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,srcBlock)
end do
end do
do n=i+1,bufSizeSend*nz
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = nz*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = &
array(iSrc,jSrc,k,srcBlock)
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do k=1,nz
bufTripole(iDst,jDst,k) = &
array(iSrc,jSrc,k,srcBlock)
end do
endif
else if (srcBlock == 0) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = fill
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do k=1,nz
i = i + 1
array(iDst,jDst,k,dstBlock) = bufRecv(i,nmsg)
end do
else if (dstBlock < 0) then !tripole
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k) = bufRecv(i,nmsg)
end do
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k)
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k)
x2 = bufTripole(iDst,POP_haloWidth+1,k)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripole(i ,POP_haloWidth+1,k) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k) = isign*sign(xavg, x1)
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do k=1,nz
array(iDst,jDst,k,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k)
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DI4: error deallocating 3d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate3DI4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate4DR8
! !INTERFACE:
subroutine POP_HaloUpdate4DR8(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 4d horizontal arrays of double precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r8), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r8), dimension(:,:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,l,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, nt, &! size of array in 3rd,4th dimensions
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r8) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
real (POP_r8), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 4d send,recv buffers
real (POP_r8), dimension(:,:,:,:), allocatable :: &
bufTripole ! 4d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r8
endif
nxGlobal = 0
if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 4D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
nt = size(array, dim=4)
allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz, nt), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*nt*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do l=1,nt
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
end do
end do
end do
do n=i+1,bufSizeSend*nz*nt
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = nz*nt*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, POP_mpiR8, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do l=1,nt
do k=1,nz
bufTripole(iDst,jDst,k,l) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
endif
else if (srcBlock == 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = fill
end do
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
i = i + 1
array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
end do
end do
else if (dstBlock < 0) then !tripole
do l=1,nt
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
end do
end do
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k,l) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k,l)
end do
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = 0.5_POP_r8*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k,l)
end do
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR8: error deallocating 4d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate4DR8
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate4DR4
! !INTERFACE:
subroutine POP_HaloUpdate4DR4(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 4d horizontal arrays of single precision.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
real (POP_r4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
real (POP_r4), dimension(:,:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,l,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, nt, &! size of array in 3rd,4th dimensions
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
real (POP_r4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
real (POP_r4), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 4d send,recv buffers
real (POP_r4), dimension(:,:,:,:), allocatable :: &
bufTripole ! 4d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0.0_POP_r4
endif
nxGlobal = 0
if (allocated(bufTripoleR4)) nxGlobal = size(bufTripoleR4,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 4D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
nt = size(array, dim=4)
allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz, nt), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*nt*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do l=1,nt
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
end do
end do
end do
do n=i+1,bufSizeSend*nz*nt
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = nz*nt*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, POP_mpiR4, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do l=1,nt
do k=1,nz
bufTripole(iDst,jDst,k,l) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
endif
else if (srcBlock == 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = fill
end do
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
i = i + 1
array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
end do
end do
else if (dstBlock < 0) then !tripole
do l=1,nt
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
end do
end do
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k,l) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k,l)
end do
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = 0.5_POP_r4*(abs(x1) + abs(x2))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k,l)
end do
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DR4: error deallocating 4d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate4DR4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloUpdate4DI4
! !INTERFACE:
subroutine POP_HaloUpdate4DI4(array, halo, &,7
fieldLoc, fieldKind, errorCode, &
fillValue)
! !DESCRIPTION:
! This routine updates ghost cells for an input array and is a
! member of a group of routines under the generic interface
! POP\_HaloUpdate. This routine is the specific interface
! for 4d horizontal integer arrays.
!
! !REVISION HISTORY:
! same as module
! !USER:
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! precomputed halo structure containing all
! information needed for halo update
character (*), intent(in) :: &
fieldKind, &! id for type of field (scalar, vector, angle)
fieldLoc ! id for location on horizontal grid
! (center, NEcorner, Nface, Eface)
integer (POP_i4), intent(in), optional :: &
fillValue ! optional value to put in ghost cells
! where neighbor points are unknown
! (e.g. eliminated land blocks or
! closed boundaries)
! !INPUT/OUTPUT PARAMETERS:
integer (POP_i4), dimension(:,:,:,:,:), intent(inout) :: &
array ! array containing field for which halo
! needs to be updated
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
i,j,k,l,n,nmsg, &! dummy loop indices
ierr, &! error or status flag for MPI,alloc
msgSize, &! size of an individual message
nxGlobal, &! global domain size in x (tripole)
nz, nt, &! size of array in 3rd,4th dimensions
iSrc,jSrc, &! source addresses for message
iDst,jDst, &! dest addresses for message
srcBlock, &! local block number for source
dstBlock, &! local block number for destination
ioffset, joffset, &! address shifts for tripole
isign ! sign factor for tripole grids
integer (POP_i4), dimension(:), allocatable :: &
sndRequest, &! MPI request ids
rcvRequest ! MPI request ids
integer (POP_i4), dimension(:,:), allocatable :: &
sndStatus, &! MPI status flags
rcvStatus ! MPI status flags
integer (POP_i4) :: &
fill, &! value to use for unknown points
x1,x2,xavg ! scalars for enforcing symmetry at U pts
integer (POP_i4), dimension(:,:), allocatable :: &
bufSend, bufRecv ! 4d send,recv buffers
integer (POP_i4), dimension(:,:,:,:), allocatable :: &
bufTripole ! 4d tripole buffer
!-----------------------------------------------------------------------
!
! initialize error code and fill value
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (present(fillValue)) then
fill = fillValue
else
fill = 0_POP_i4
endif
nxGlobal = 0
if (allocated(bufTripoleI4)) nxGlobal = size(bufTripoleI4,dim=1)
!-----------------------------------------------------------------------
!
! allocate request and status arrays for messages
!
!-----------------------------------------------------------------------
allocate(sndRequest(halo%numMsgSend), &
rcvRequest(halo%numMsgRecv), &
sndStatus(MPI_STATUS_SIZE,halo%numMsgSend), &
rcvStatus(MPI_STATUS_SIZE,halo%numMsgRecv), stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: error allocating req,status arrays')
return
endif
!-----------------------------------------------------------------------
!
! allocate 4D buffers
!
!-----------------------------------------------------------------------
nz = size(array, dim=3)
nt = size(array, dim=4)
allocate(bufSend(bufSizeSend*nz*nt, halo%numMsgSend), &
bufRecv(bufSizeRecv*nz*nt, halo%numMsgRecv), &
stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: error allocating buffers')
return
endif
if (nxGlobal > 0) then
allocate(bufTripole(nxGlobal, POP_haloWidth+1, nz, nt), &
stat=ierr)
bufTripole = fill
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate3DR4: error allocating buffers')
return
endif
endif
!-----------------------------------------------------------------------
!
! post receives
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgRecv
msgSize = nz*nt*halo%sizeRecv(nmsg)
call MPI_IRECV(bufRecv(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%recvTask(nmsg), &
POP_mpitagHalo + halo%recvTask(nmsg), &
halo%communicator, rcvRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! fill send buffer and post sends
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numMsgSend
i=0
do n=1,halo%sizeSend(nmsg)
iSrc = halo%sendAddr(1,n,nmsg)
jSrc = halo%sendAddr(2,n,nmsg)
srcBlock = halo%sendAddr(3,n,nmsg)
do l=1,nt
do k=1,nz
i = i + 1
bufSend(i,nmsg) = array(iSrc,jSrc,k,l,srcBlock)
end do
end do
end do
do n=i+1,bufSizeSend*nz*nt
bufSend(n,nmsg) = fill ! fill remainder of buffer
end do
msgSize = nz*nt*halo%sizeSend(nmsg)
call MPI_ISEND(bufSend(1:msgSize,nmsg), msgSize, MPI_INTEGER, &
halo%sendTask(nmsg), &
POP_mpitagHalo + POP_myTask, &
halo%communicator, sndRequest(nmsg), ierr)
end do
!-----------------------------------------------------------------------
!
! do local copies while waiting for messages to complete
! if srcBlock is zero, that denotes an eliminated land block or a
! closed boundary where ghost cell values are undefined
! if srcBlock is less than zero, the message is a copy out of the
! tripole buffer and will be treated later
!
!-----------------------------------------------------------------------
do nmsg=1,halo%numLocalCopies
iSrc = halo%srcLocalAddr(1,nmsg)
jSrc = halo%srcLocalAddr(2,nmsg)
srcBlock = halo%srcLocalAddr(3,nmsg)
iDst = halo%dstLocalAddr(1,nmsg)
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
if (srcBlock > 0) then
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
else if (dstBlock < 0) then ! tripole copy into buffer
do l=1,nt
do k=1,nz
bufTripole(iDst,jDst,k,l) = &
array(iSrc,jSrc,k,l,srcBlock)
end do
end do
endif
else if (srcBlock == 0) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = fill
end do
end do
endif
end do
!-----------------------------------------------------------------------
!
! wait for receives to finish and then unpack the recv buffer into
! ghost cells
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgRecv, rcvRequest, rcvStatus, ierr)
do nmsg=1,halo%numMsgRecv
i = 0
do n=1,halo%sizeRecv(nmsg)
iDst = halo%recvAddr(1,n,nmsg)
jDst = halo%recvAddr(2,n,nmsg)
dstBlock = halo%recvAddr(3,n,nmsg)
if (dstBlock > 0) then
do l=1,nt
do k=1,nz
i = i + 1
array(iDst,jDst,k,l,dstBlock) = bufRecv(i,nmsg)
end do
end do
else if (dstBlock < 0) then !tripole
do l=1,nt
do k=1,nz
i = i + 1
bufTripole(iDst,jDst,k,l) = bufRecv(i,nmsg)
end do
end do
endif
end do
end do
!-----------------------------------------------------------------------
!
! take care of northern boundary in tripole case
! bufTripole array contains the top haloWidth+1 rows of physical
! domain for entire (global) top row
!
!-----------------------------------------------------------------------
if (nxGlobal > 0) then
select case (fieldKind)
case (POP_fieldKindScalar)
isign = 1
case (POP_fieldKindVector)
isign = -1
case (POP_fieldKindAngle)
isign = -1
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: Unknown field kind')
end select
select case (fieldLoc)
case (POP_gridHorzLocCenter) ! cell center location
ioffset = 0
joffset = 0
case (POP_gridHorzLocNEcorner) ! cell corner location
ioffset = 1
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
bufTripole(nxGlobal,POP_haloWidth+1,k,l) = isign* &
bufTripole(nxGlobal,POP_haloWidth+1,k,l)
end do
end do
case (POP_gridHorzLocEface) ! cell center location
ioffset = 1
joffset = 0
case (POP_gridHorzLocNface) ! cell corner (velocity) location
ioffset = 0
joffset = 1
!*** top row is degenerate, so must enforce symmetry
!*** use average of two degenerate points for value
do l=1,nt
do k=1,nz
do i = 1,nxGlobal/2
iDst = nxGlobal + 1 - i
x1 = bufTripole(i ,POP_haloWidth+1,k,l)
x2 = bufTripole(iDst,POP_haloWidth+1,k,l)
xavg = nint(0.5_POP_r8*(abs(x1) + abs(x2)))
bufTripole(i ,POP_haloWidth+1,k,l) = isign*sign(xavg, x2)
bufTripole(iDst,POP_haloWidth+1,k,l) = isign*sign(xavg, x1)
end do
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: Unknown field location')
end select
!*** copy out of global tripole buffer into local
!*** ghost cells
!*** look through local copies to find the copy out
!*** messages (srcBlock < 0)
do nmsg=1,halo%numLocalCopies
srcBlock = halo%srcLocalAddr(3,nmsg)
if (srcBlock < 0) then
iSrc = halo%srcLocalAddr(1,nmsg) ! tripole buffer addr
jSrc = halo%srcLocalAddr(2,nmsg)
iDst = halo%dstLocalAddr(1,nmsg) ! local block addr
jDst = halo%dstLocalAddr(2,nmsg)
dstBlock = halo%dstLocalAddr(3,nmsg)
!*** correct for offsets
iSrc = iSrc - ioffset
jSrc = jSrc - joffset
if (iSrc == 0) iSrc = nxGlobal
!*** for center and Eface, do not need to replace
!*** top row of physical domain, so jSrc should be
!*** out of range and skipped
!*** otherwise do the copy
if (jSrc <= POP_haloWidth+1) then
do l=1,nt
do k=1,nz
array(iDst,jDst,k,l,dstBlock) = isign* &
bufTripole(iSrc,jSrc,k,l)
end do
end do
endif
endif
end do
endif
!-----------------------------------------------------------------------
!
! wait for sends to complete and deallocate arrays
!
!-----------------------------------------------------------------------
call MPI_WAITALL(halo%numMsgSend, sndRequest, sndStatus, ierr)
deallocate(sndRequest, rcvRequest, sndStatus, rcvStatus, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: error deallocating req,status arrays')
return
endif
deallocate(bufSend, bufRecv, stat=ierr)
if (allocated(bufTripole)) deallocate(bufTripole, stat=ierr)
if (ierr > 0) then
call POP_ErrorSet(errorCode, &
'POP_HaloUpdate4DI4: error deallocating 4d buffers')
return
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloUpdate4DI4
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloIncrementMsgCount
! !INTERFACE:
subroutine POP_HaloIncrementMsgCount(sndCounter, rcvCounter, & 16,1
srcProc, dstProc, msgSize, &
errorCode)
! !DESCRIPTION:
! This is a utility routine to increment the arrays for counting
! whether messages are required. It checks the source and destination
! task to see whether the current task needs to send, receive or
! copy messages to fill halo regions (ghost cells).
! !REVISION HISTORY:
! Same as module.
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
srcProc, &! source processor for communication
dstProc, &! destination processor for communication
msgSize ! number of words for this message
! !INPUT/OUTPUT PARAMETERS:
integer (POP_i4), dimension(:), intent(inout) :: &
sndCounter, &! array for counting messages to be sent
rcvCounter ! array for counting messages to be received
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! error check
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (srcProc < 0 .or. dstProc < 0 .or. &
srcProc > size(sndCounter) .or. &
dstProc > size(rcvCounter)) then
call POP_ErrorSet(errorCode, &
'POP_HaloIncrementMsgCount: invalid processor number')
return
endif
!-----------------------------------------------------------------------
!
! if destination all land or outside closed boundary (dstProc = 0),
! then no send is necessary, so do the rest only for dstProc /= 0
!
!-----------------------------------------------------------------------
if (dstProc == 0) return
!-----------------------------------------------------------------------
!
! if the current processor is the source, must send data
! local copy if dstProc = srcProc
!
!-----------------------------------------------------------------------
if (srcProc == POP_myTask + 1) sndCounter(dstProc) = &
sndCounter(dstProc) + msgSize
!-----------------------------------------------------------------------
!
! if the current processor is the destination, must receive data
! local copy if dstProc = srcProc
!
!-----------------------------------------------------------------------
if (dstProc == POP_myTask + 1) then
if (srcProc > 0) then
!*** the source block has ocean points
!*** count as a receive from srcProc
rcvCounter(srcProc) = rcvCounter(srcProc) + msgSize
else
!*** if the source block has been dropped, create
!*** a local copy to fill halo with a fill value
rcvCounter(dstProc) = rcvCounter(dstProc) + msgSize
endif
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloIncrementMsgCount
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloMsgCreate
! !INTERFACE:
subroutine POP_HaloMsgCreate(halo, srcBlock, srcProc, srcLocalID, & 16,12
dstBlock, dstProc, dstLocalID, &
direction, errorCode)
! !DESCRIPTION:
! This is a utility routine to determine the required address and
! message information for a particular pair of blocks.
! !REVISION HISTORY:
! Same as module.
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
srcBlock, dstBlock, & ! source,destination block id
srcProc, dstProc, & ! source,destination processor location
srcLocalID, dstLocalID ! source,destination local index
character (*), intent(in) :: &
direction ! direction of neighbor block
! (north,south,east,west,
! and NE, NW, SE, SW)
! !INPUT/OUTPUT PARAMETERS:
type (POP_halo), intent(inout) :: &
halo ! data structure containing halo info
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
msgIndx, &! message counter and index into msg array
blockIndx, &! block counter and index into msg array
bufSize, &! size of message buffer
ibSrc, ieSrc, jbSrc, jeSrc, &! phys domain info for source block
ibDst, ieDst, jbDst, jeDst, &! phys domain info for dest block
nxGlobal, &! size of global domain in e-w direction
i,j,n ! dummy loop index
integer (POP_i4), dimension(:), pointer :: &
iGlobal ! global i index for location in tripole
!-----------------------------------------------------------------------
!
! initialize
!
!-----------------------------------------------------------------------
errorCode = POP_Success
if (allocated(bufTripoleR8)) nxGlobal = size(bufTripoleR8,dim=1)
!-----------------------------------------------------------------------
!
! if destination all land or outside closed boundary (dstProc = 0),
! then no send is necessary, so do the rest only for dstProc /= 0
!
!-----------------------------------------------------------------------
if (dstProc == 0) return
!-----------------------------------------------------------------------
!
! get block information if either block is local
!
!-----------------------------------------------------------------------
if (srcProc == POP_myTask+1 .or. dstProc == POP_myTask+1) then
if (srcBlock >= 0 .and. dstBlock >= 0) then
call POP_BlocksGetBlockInfo(srcBlock, errorCode, &
ib=ibSrc, ie=ieSrc, &
jb=jbSrc, je=jeSrc)
else ! tripole - need iGlobal info
call POP_BlocksGetBlockInfo(abs(srcBlock), errorCode, &
ib=ibSrc, ie=ieSrc, &
jb=jbSrc, je=jeSrc, &
iGlobal=iGlobal)
endif
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: error getting source block info')
return
endif
if (dstBlock /= 0) then
call POP_BlocksGetBlockInfo(abs(dstBlock), errorCode, &
ib=ibDst, ie=ieDst, &
jb=jbDst, je=jeDst)
endif
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: error getting dest block info')
return
endif
endif
!-----------------------------------------------------------------------
!
! if both blocks are local, create a local copy to fill halo
!
!-----------------------------------------------------------------------
if (srcProc == POP_myTask+1 .and. &
dstProc == POP_myTask+1) then
!*** compute addresses based on direction
msgIndx = halo%numLocalCopies
if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
msgIndx > size(halo%dstLocalAddr,dim=2)) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: msg count > array size')
return
endif
select case (direction)
case ('east')
!*** copy easternmost physical domain of src
!*** into westernmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ieSrc - POP_haloWidth + i
halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('west')
!*** copy westernmost physical domain of src
!*** into easternmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('north')
!*** copy northern physical domain of src
!*** into southern halo of dst
if (srcBlock > 0 .and. dstBlock > 0) then ! normal north boundary
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jeSrc - POP_haloWidth + j
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
else if (srcBlock > 0 .and. dstBlock < 0) then
!*** tripole grid - copy info into tripole buffer
!*** copy physical domain of top halo+1 rows
!*** into global buffer at src location
!*** perform an error check to make sure the
!*** block has enough points to perform a tripole
!*** update
if (jeSrc - jbSrc + 1 < POP_haloWidth + 1) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: not enough points in block for tripole')
return
endif
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jeSrc-1-POP_haloWidth+j
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = iGlobal(ibSrc + i - 1)
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = -dstLocalID
end do
end do
else if (srcBlock < 0 .and. dstBlock > 0) then
!*** tripole grid - set up for copying out of
!*** tripole buffer into ghost cell domains
!*** include e-w ghost cells
do j=1,POP_haloWidth+1
do i=1,ieSrc+POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = nxGlobal - iGlobal(i) + 1
halo%srcLocalAddr(2,msgIndx) = POP_haloWidth + 3 - j
halo%srcLocalAddr(3,msgIndx) = -srcLocalID
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = jeSrc + j - 1
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
endif
case ('south')
!*** copy southern physical domain of src
!*** into northern halo of dst
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('northeast')
!*** normal northeast boundary - just copy NE corner
!*** of physical domain into SW halo of NE nbr block
if (dstBlock > 0) then
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ieSrc - POP_haloWidth + i
halo%srcLocalAddr(2,msgIndx) = jeSrc - POP_haloWidth + j
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
else
!*** tripole grid - this local copy should already
!*** have taken place for the north boundary
endif
case ('northwest')
!*** normal northeast boundary - just copy NW corner
!*** of physical domain into SE halo of NW nbr block
if (dstBlock > 0) then
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jeSrc - POP_haloWidth + j
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
else
!*** tripole grid - this local copy should already
!*** have taken place for the north boundary
endif
case ('southeast')
!*** copy southeastern corner of src physical domain
!*** into northwestern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ieSrc - POP_haloWidth + i
halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('southwest')
!*** copy southwestern corner of src physical domain
!*** into northeastern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = ibSrc + i - 1
halo%srcLocalAddr(2,msgIndx) = jbSrc + j - 1
halo%srcLocalAddr(3,msgIndx) = srcLocalID
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: unknown direction local copy')
return
end select
halo%numLocalCopies = msgIndx
if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
msgIndx > size(halo%dstLocalAddr,dim=2)) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: msg count > array size')
return
endif
!-----------------------------------------------------------------------
!
! if dest block is local and source block does not exist, create a
! local copy to fill halo with a fill value
!
!-----------------------------------------------------------------------
else if (srcProc == 0 .and. dstProc == POP_myTask+1) then
msgIndx = halo%numLocalCopies
if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
msgIndx > size(halo%dstLocalAddr,dim=2)) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: msg count > array size')
return
endif
!*** compute addresses based on direction
select case (direction)
case ('east')
!*** copy easternmost physical domain of src
!*** into westernmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('west')
!*** copy westernmost physical domain of src
!*** into easternmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = jbDst + j - 1
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('north')
!*** copy northern physical domain of src
!*** into southern halo of dst
if (dstBlock > 0) then ! normal north boundary
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
endif
case ('south')
!*** copy southern physical domain of src
!*** into northern halo of dst
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = ibDst + i - 1
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('northeast')
!*** normal northeast boundary - just copy NE corner
!*** of physical domain into SW halo of NE nbr block
if (dstBlock > 0) then
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
endif
case ('northwest')
!*** normal northeast boundary - just copy NW corner
!*** of physical domain into SE halo of NW nbr block
if (dstBlock > 0) then
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
endif
case ('southeast')
!*** copy southeastern corner of src physical domain
!*** into northwestern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = i
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case ('southwest')
!*** copy southwestern corner of src physical domain
!*** into northeastern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
msgIndx = msgIndx + 1
halo%srcLocalAddr(1,msgIndx) = 0
halo%srcLocalAddr(2,msgIndx) = 0
halo%srcLocalAddr(3,msgIndx) = 0
halo%dstLocalAddr(1,msgIndx) = ieDst + i
halo%dstLocalAddr(2,msgIndx) = jeDst + j
halo%dstLocalAddr(3,msgIndx) = dstLocalID
end do
end do
case default
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: unknown direction local copy')
return
end select
halo%numLocalCopies = msgIndx
if (msgIndx > size(halo%srcLocalAddr,dim=2) .or. &
msgIndx > size(halo%dstLocalAddr,dim=2)) then
call POP_ErrorSet(errorCode, &
'POP_HaloMsgCreate: msg count > array size')
return
endif
!-----------------------------------------------------------------------
!
! if source block local and dest block remote, send a message
!
!-----------------------------------------------------------------------
else if (srcProc == POP_myTask+1 .and. &
dstProc /= POP_myTask+1 .and. dstProc > 0) then
!*** first check to see if a message to this processor has
!*** already been defined
!*** if not, update counters and indices
msgIndx = 0
srchSend: do n=1,halo%numMsgSend
if (halo%sendTask(n) == dstProc - 1) then
msgIndx = n
bufSize = halo%sizeSend(n)
exit srchSend
endif
end do srchSend
if (msgIndx == 0) then
msgIndx = halo%numMsgSend + 1
halo%numMsgSend = msgIndx
halo%sendTask(msgIndx) = dstProc - 1
bufSize = 0
endif
!*** now compute message info based on msg direction
select case (direction)
case ('east')
!*** send easternmost physical domain of src
!*** into westernmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ieSrc - POP_haloWidth + i
halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
case ('west')
!*** copy westernmost physical domain of src
!*** into easternmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
case ('north')
if (dstBlock > 0) then
!*** copy northern physical domain of src
!*** into southern halo of dst
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx) = jeSrc-POP_haloWidth+j
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
else
!*** tripole block - send top three rows of phys domain
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx)=jeSrc-POP_haloWidth+j-1
halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
endif
case ('south')
!*** copy southern physical domain of src
!*** into northern halo of dst
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
case ('northeast')
if (dstBlock > 0) then
!*** normal northeast corner
!*** copy northeast corner of src physical domain
!*** into southwestern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ieSrc-POP_haloWidth+i
halo%sendAddr(2,bufSize,msgIndx) = jeSrc-POP_haloWidth+j
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
else
!*** tripole block - send top three rows of phys domain
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx)=jeSrc-POP_haloWidth+j-1
halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
endif
case ('northwest')
if (dstBlock > 0) then
!*** normal northwest corner
!*** copy northwest corner of src physical domain
!*** into southeastern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx) = jeSrc-POP_haloWidth+j
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
else
!*** tripole block - send top three rows of phys domain
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx)=ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx)=jeSrc-POP_haloWidth+j-1
halo%sendAddr(3,bufSize,msgIndx)=srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
endif
case ('southeast')
!*** copy southeastern corner of src physical domain
!*** into northwestern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ieSrc - POP_haloWidth + i
halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
case ('southwest')
!*** copy southwestern corner of src physical domain
!*** into northeastern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%sendAddr(1,bufSize,msgIndx) = ibSrc + i - 1
halo%sendAddr(2,bufSize,msgIndx) = jbSrc + j - 1
halo%sendAddr(3,bufSize,msgIndx) = srcLocalID
end do
end do
halo%sizeSend(msgIndx) = bufSize
case default
!*** already checked in previous case construct
end select
!-----------------------------------------------------------------------
!
! if source block remote and dest block local, recv a message
!
!-----------------------------------------------------------------------
else if (dstProc == POP_myTask+1 .and. &
srcProc /= POP_myTask+1 .and. srcProc > 0) then
!*** first check to see if a message from this processor has
!*** already been defined
!*** if not, update counters and indices
msgIndx = 0
srchRecv: do n=1,halo%numMsgRecv
if (halo%recvTask(n) == srcProc - 1) then
msgIndx = n
bufSize = halo%sizeRecv(n)
exit srchRecv
endif
end do srchRecv
if (msgIndx == 0) then
msgIndx = halo%numMsgRecv + 1
halo%numMsgRecv = msgIndx
halo%recvTask(msgIndx) = srcProc - 1
bufSize = 0
endif
!*** now compute message info based on msg direction
select case (direction)
case ('east')
!*** send easternmost physical domain of src
!*** into westernmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = i
halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
case ('west')
!*** copy westernmost physical domain of src
!*** into easternmost halo of dst
do j=1,jeSrc-jbSrc+1
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
halo%recvAddr(2,bufSize,msgIndx) = jbDst + j - 1
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
case ('north')
if (dstBlock > 0) then
!*** copy northern physical domain of src
!*** into southern halo of dst
do j=1,POP_haloWidth
do i=1,ieDst-ibDst+1
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
else
!*** tripole block - receive into tripole buffer
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
endif
case ('south')
!*** copy southern physical domain of src
!*** into northern halo of dst
do j=1,POP_haloWidth
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = ibDst + i - 1
halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
case ('northeast')
if (dstBlock > 0) then
!*** normal northeast neighbor
!*** copy northeast physical domain into
!*** into southwest halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = i
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
else
!*** tripole block - receive into tripole buffer
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
endif
case ('northwest')
if (dstBlock > 0) then
!*** normal northwest neighbor
!*** copy northwest physical domain into
!*** into southeast halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
else
!*** tripole block - receive into tripole buffer
do j=1,POP_haloWidth+1
do i=1,ieSrc-ibSrc+1
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = iGlobal(ibSrc + i - 1)
halo%recvAddr(2,bufSize,msgIndx) = j
halo%recvAddr(3,bufSize,msgIndx) = -dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
endif
case ('southeast')
!*** copy southeastern corner of src physical domain
!*** into northwestern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = i
halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
case ('southwest')
!*** copy southwestern corner of src physical domain
!*** into northeastern halo of dst
do j=1,POP_haloWidth
do i=1,POP_haloWidth
bufSize = bufSize + 1
halo%recvAddr(1,bufSize,msgIndx) = ieDst + i
halo%recvAddr(2,bufSize,msgIndx) = jeDst + j
halo%recvAddr(3,bufSize,msgIndx) = dstLocalID
end do
end do
halo%sizeRecv(msgIndx) = bufSize
case default
!*** already checked in previous case construct
end select
!-----------------------------------------------------------------------
!
! if none of the cases above, no message info required for this
! block pair
!
!-----------------------------------------------------------------------
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloMsgCreate
!***********************************************************************
!BOP
! !IROUTINE: POP_HaloPrintStats
! !INTERFACE:
subroutine POP_HaloPrintStats(halo, distrb, errorCode),10
! !DESCRIPTION:
! This routine compiles some message statistics for a given halo
! updates and writes them to stdout. The routine only outputs
! information for 2D halos of type r8. Other statistics can
! be obtained by scaling 2D r8 values accordingly.
!
! !REVISION HISTORY:
! Same as module.
! !INPUT PARAMETERS:
type (POP_halo), intent(in) :: &
halo ! defined halo for which stats requested
type (POP_distrb), intent(in) :: &
distrb ! associated block distribution for halo
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
bytesSend, bytesRecv, &
maxBytesSend, maxBytesRecv, &
minBytesSend, minBytesRecv, &
minNumMsgRecv, maxNumMsgRecv, &
numProcs, n
real (POP_r8) :: &
avgBytesSend, avgBytesRecv
!-----------------------------------------------------------------------
!
! initialize num procs
!
!-----------------------------------------------------------------------
errorCode = POP_Success
call POP_DistributionGet(distrb,errorCode,numProcs = numProcs)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting num procs')
return
endif
!-----------------------------------------------------------------------
!
! determine number of messages received
!
!-----------------------------------------------------------------------
maxNumMsgRecv = POP_GlobalMaxval(halo%numMsgRecv, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting max number of messages')
return
endif
minNumMsgRecv = POP_GlobalMinval(halo%numMsgRecv, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting min number of messages')
return
endif
!-----------------------------------------------------------------------
!
! compute local number of bytes sent or received, then determine
! global statistics
!
!-----------------------------------------------------------------------
bytesSend = 0
do n=1,halo%numMsgSend
bytesSend = bytesSend + 8*halo%sizeSend(n)
end do
bytesRecv = 0
do n=1,halo%numMsgRecv
bytesRecv = bytesRecv + 8*halo%sizeRecv(n)
end do
maxBytesSend = POP_GlobalMaxval(bytesSend, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting max bytes sent')
return
endif
minBytesSend = POP_GlobalMinval(bytesSend, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting min bytes sent')
return
endif
avgBytesSend = POP_GlobalSum(real(bytesSend), distrb, errorCode)/ &
real(numProcs)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting avg bytes sent')
return
endif
maxBytesRecv = POP_GlobalMaxval(bytesRecv, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting max bytes received')
return
endif
minBytesRecv = POP_GlobalMinval(bytesRecv, distrb, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting min bytes received')
return
endif
avgBytesRecv = POP_GlobalSum(real(bytesRecv), distrb, errorCode)/ &
real(numProcs)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'POP_HaloPrintStats: error getting avg bytes received')
return
endif
!-----------------------------------------------------------------------
!
! output data to stdout
!
!-----------------------------------------------------------------------
if (POP_mastertask == POP_mytask) then
write(POP_stdout,'(a30,2(i13))') 'bufSize{Recv,Send} [words] : ',&
bufSizeRecv, bufSizeSend
write(POP_stdout,'(a30,2(i13))') 'num messages: {min,max}: ', &
minNumMsgRecv, maxNumMsgRecv
write(POP_stdout,'(a45,2(i13),2x,e10.3)') &
'Bytes RECV for 2D bndy exch {min,max,avg}: ', &
minBytesRecv, maxBytesRecv, avgBytesRecv
write(POP_stdout,'(a45,2(i13),2x,e10.3)') &
'Bytes SEND for 2D bndy exch {min,max,avg}: ', &
minBytesSend, maxBytesSend, avgBytesSend
endif
!-----------------------------------------------------------------------
!EOC
end subroutine POP_HaloPrintStats
!***********************************************************************
end module POP_HaloMod
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||