!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
module POP_BlocksMod 7,2
!BOP
! !MODULE: POP_BlocksMod
!
! !DESCRIPTION:
! This module contains data types and tools for decomposing a global
! horizontal domain into a set of 2d blocks. It contains a data type
! for describing each block and contains routines for creating and
! querying the block decomposition for a global domain.
!
! !REVISION HISTORY:
! SVN:$Id: POP_BlocksMod.F90 69 2007-10-05 20:51:42Z pwjones $
! 2006-08-14: Phil Jones, John Dennis
! new blocks module with new naming convention
! also generalized the Get and Set routines and added a
! number of active points to block structure for support
! of improvements by John Dennis (NCAR) elsewhere
!
! !USES:
use POP_KindsMod
use POP_ErrorMod
use POP_DomainSizeMod
implicit none
private
save
! !PUBLIC TYPES:
type, public :: POP_block ! block data type
integer (POP_i4) :: &
blockID ,&! global block number
localID ,&! local address of block in current distrib
ib, ie, jb, je ,&! begin,end indices for physical domain
iBlock, jBlock ,&! cartesian i,j position for bloc
nxGlobal, nyGlobal,&! global domain extents
numActivePoints ! number of actual active points in block
logical (POP_logical) :: &
tripole ! flag is true if block is at tripole bndy
integer (POP_i4), dimension(:), pointer :: &
iGlobal, jGlobal ! global domain location for each point
end type
! !PUBLIC MEMBER FUNCTIONS:
public :: POP_BlocksCreate, &
POP_BlocksDestroy, &
POP_BlocksSet, &
POP_BlocksGetBlock, &
POP_BlocksGetNbrID, &
POP_BlocksGetBlockInfo
! !DEFINED PARAMETERS:
integer (POP_i4), parameter, public :: &
POP_haloWidth = 2 ! number of ghost cells around each block
! size of block domain in i,j direction including ghost cells
integer (POP_i4), parameter, public :: &
POP_nxBlock = POP_blockSizeX + 2*POP_haloWidth, &
POP_nyBlock = POP_blockSizeY + 2*POP_haloWidth
! predefined directions for neighbor id routine
integer (POP_i4), parameter, public :: &
POP_blocksNorth = 1, & ! (i ,j+1)
POP_blocksSouth = 2, & ! (i ,j-1)
POP_blocksEast = 3, & ! (i+1,j )
POP_blocksWest = 4, & ! (i-1,j )
POP_blocksNorthEast = 5, & ! (i+1,j+1)
POP_blocksNorthWest = 6, & ! (i-1,j+1)
POP_blocksSouthEast = 7, & ! (i+1,j-1)
POP_blocksSouthWest = 8 ! (i-1,j-1)
integer (POP_i4), parameter, public :: &
POP_blocksNorth2 = 9, & ! (i ,j+2)
POP_blocksSouth2 = 10, & ! (i ,j-2)
POP_blocksEast2 = 11, & ! (i+2,j )
POP_blocksWest2 = 12, & ! (i-2,j )
POP_blocksNorthEast2 = 13, & ! (i+2,j+2)
POP_blocksNorthWest2 = 14, & ! (i-2,j+2)
POP_blocksSouthEast2 = 15, & ! (i+2,j-2)
POP_blocksSouthWest2 = 16 ! (i-2,j-2)
integer (POP_i4), parameter, public :: &
POP_blocksEastNorthEast = 17, & ! (i+2,j+1)
POP_blocksEastSouthEast = 18, & ! (i+2,j-1)
POP_blocksWestNorthWest = 19, & ! (i-2,j+1)
POP_blocksWestSouthWest = 20, & ! (i-2,j-1)
POP_blocksNorthNorthEast = 21, & ! (i+1,j-2)
POP_blocksSouthSouthEast = 22, & ! (i+1,j-2)
POP_blocksNorthNorthWest = 23, & ! (i-1,j+2)
POP_blocksSouthSouthWest = 24 ! (i-1,j-2)
! !PUBLIC DATA MEMBERS:
integer (POP_i4), public :: &
POP_numBlocks, &! total number of blocks in decomposition
POP_numBlocksX, &! tot num blocks in i direction
POP_numBlocksY ! tot num blocks in j direction
!EOP
!BOC
!-----------------------------------------------------------------------
!
! module private data
!
!-----------------------------------------------------------------------
type (POP_block), dimension(:), allocatable :: &
allBlocks ! block information for all blocks in domain
integer (POP_i4), dimension(:,:),allocatable :: &
allBlocksIJ ! block index stored in Cartesian order
! useful for determining block index
! of neighbor blocks
integer (POP_i4), dimension(:,:), allocatable, target :: &
allIGlobal, &! global i index for each point in each block
allJGlobal ! global j index for each point in each block
!EOC
!***********************************************************************
contains
!***********************************************************************
!BOP
! !IROUTINE: POP_BlocksCreate
! !INTERFACE:
subroutine POP_BlocksCreate(nxGlobal, nyGlobal, & 1,9
ewBoundaryType, nsBoundaryType, errorCode)
! !DESCRIPTION:
! This subroutine decomposes the global domain into blocks and
! fills the data structures with all the necessary block information.
!
! !REVISION HISTORY:
! same as module
!
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
nxGlobal, nyGlobal ! global domain size in x,y
character (*), intent(in) :: &
ewBoundaryType, &! type of boundary in logical east-west dir
nsBoundaryType ! type of boundary in logical north-south dir
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!----------------------------------------------------------------------
!
! local variables
!
!----------------------------------------------------------------------
integer (POP_i4) :: &
blockID, &! block id for linear list of blocks
i, j, &! loop indices
iBlock, jBlock, &! block loop indices
is, ie, js, je, &! temp start, end indices
istat ! status flag for allocates
!----------------------------------------------------------------------
!
! compute number of blocks and cartesian decomposition of blocks
! if the requested block size does not divide the global domain
! size evenly, add additional block space to accomodate padding
!
!----------------------------------------------------------------------
errorCode = POP_success
POP_numBlocksX = (nxGlobal-1)/POP_blockSizeX + 1
POP_numBlocksY = (nyGlobal-1)/POP_blockSizeY + 1
POP_numBlocks = POP_numBlocksX*POP_numBlocksY
!----------------------------------------------------------------------
!
! allocate block arrays
!
!----------------------------------------------------------------------
allocate(allBlocks(POP_numBlocks), stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: error allocating allBlocks')
return
endif
allocate(allIGlobal(POP_nxBlock,POP_numBlocks), &
allJGlobal(POP_nyBlock,POP_numBlocks), stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: error allocating ijGlobal')
return
endif
allocate(allBlocksIJ(POP_numBlocksX,POP_numBlocksY), stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: error allocating allBlocksIJ')
return
endif
!----------------------------------------------------------------------
!
! fill block data structures for all blocks in domain
!
!----------------------------------------------------------------------
blockID = 0 ! initialize block ID
do jBlock=1,POP_numBlocksY
!*** determine start, end of global physical domain in j
!*** direction for this row of blocks
js = (jBlock-1)*POP_blockSizeY + 1
je = js + POP_blockSizeY - 1
if (je > nyGlobal) je = nyGlobal ! pad array
if (js > nyGlobal) then
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: Bad block decomp: POP_nyBlock too large?')
return
endif
do iBlock=1,POP_numBlocksX
blockID = blockID + 1 ! increment global block id
!*** determine start, end of global physical domain in i
!*** direction for this row of blocks
is = (iBlock-1)*POP_blockSizeX + 1
ie = is + POP_blockSizeX - 1
if (ie > nxGlobal) ie = nxGlobal
if (is > nxGlobal) then
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: Bad block decomp: POP_nxBlock too large?')
return
endif
allBlocks(blockID)%blockID = blockID
allBlocks(blockID)%iBlock = iBlock
allBlocks(blockID)%jBlock = jBlock
allBlocks(blockID)%nxGlobal = nxGlobal
allBlocks(blockID)%nyGlobal = nyGlobal
if (jBlock == POP_numBlocksY .and. &
nsBoundaryType == 'tripole') then
allBlocks(blockID)%tripole = .true.
else
allBlocks(blockID)%tripole = .false.
endif
!*** set default values for start and end logical indices
!*** for the physical domain. ie,je may be reset later if
!*** domains must be padded
allBlocks(blockID)%ib = POP_haloWidth + 1
allBlocks(blockID)%jb = POP_haloWidth + 1
allBlocks(blockID)%ie = POP_nxBlock - POP_haloWidth
allBlocks(blockID)%je = POP_nyBlock - POP_haloWidth
allBlocksIJ(iBlock,jBlock) = blockID
!*** for each point in this block, determine global indices
do j=1,POP_nyBlock
allJGlobal(j,blockID) = js - POP_haloWidth + j - 1
!*** southern ghost cells
if (allJGlobal(j,blockID) < 1) then
select case (nsBoundaryType)
case ('cyclic')
allJGlobal(j,blockID) = allJGlobal(j,blockID) + nyGlobal
case ('closed')
allJGlobal(j,blockID) = 0
case ('tripole')
allJGlobal(j,blockID) = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: unknown n-s bndy type')
return
end select
endif
!*** padding required
if (allJGlobal(j,blockID) > nyGlobal + POP_haloWidth) then
allJGlobal(j,blockID) = 0 ! padding
!*** northern ghost cells
else if (allJGlobal(j,blockID) > nyGlobal) then
select case (nsBoundaryType)
case ('cyclic')
allJGlobal(j,blockID) = allJGlobal(j,blockID) - nyGlobal
case ('closed')
allJGlobal(j,blockID) = 0
case ('tripole') ! use negative value to flag tripole
allJGlobal(j,blockID) = -allJGlobal(j,blockID)
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: unknown n-s bndy type')
return
end select
!*** set last physical point if padded domain
else if (allJGlobal(j,blockID) == nyGlobal .and. &
j > allBlocks(blockID)%jb .and. &
j < allBlocks(blockID)%je) then
allBlocks(blockID)%je = j ! last physical point in padded domain
endif
end do
allBlocks(blockID)%jGlobal => allJGlobal(:,blockID)
do i=1,POP_nxBlock
allIGlobal(i,blockID) = is - POP_haloWidth + i - 1
!*** western ghost cells
if (allIGlobal(i,blockID) < 1) then
select case (ewBoundaryType)
case ('cyclic')
allIGlobal(i,blockID) = allIGlobal(i,blockID) + nxGlobal
case ('closed')
allIGlobal(i,blockID) = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: unknown e-w bndy type')
return
end select
endif
!*** padded domain - fill padded region with zero
if (allIGlobal(i,blockID) > nxGlobal + POP_haloWidth) then
allIGlobal(i,blockID) = 0
!*** eastern ghost cells
else if (allIGlobal(i,blockID) > nxGlobal) then
select case (ewBoundaryType)
case ('cyclic')
allIGlobal(i,blockID) = allIGlobal(i,blockID) - nxGlobal
case ('closed')
allIGlobal(i,blockID) = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksCreate: unknown e-w bndy type')
return
end select
!*** last physical point in padded domain
else if (allIGlobal(i,blockID) == nxGlobal .and. &
i > allBlocks(blockID)%ib .and. &
i < allBlocks(blockID)%ie) then
allBlocks(blockID)%ie = i
endif
end do
allBlocks(blockID)%iGlobal => allIGlobal(:,blockID)
!*** compute default number of active points
!*** this will normally be reset later once the
!*** physical domain is known and masked points are
!*** eliminated
allBlocks(blockID)%numActivePoints = &
(allBlocks(blockID)%ie - allBlocks(blockID)%ib + 1)* &
(allBlocks(blockID)%je - allBlocks(blockID)%jb + 1)
end do
end do
!EOC
!----------------------------------------------------------------------
end subroutine POP_BlocksCreate
!***********************************************************************
!BOP
! !IROUTINE: POP_BlocksGetBlock
! !INTERFACE:
function POP_BlocksGetBlock(blockID, errorCode) & 33,1
result (outBlock)
! !DESCRIPTION:
! This function returns the block data structure for the block
! associated with the input block id.
!
! !REVISION HISTORY:
! same as module
!
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
blockID ! global block id for requested block info
! !OUTPUT PARAMETERS:
type (POP_block) :: &
outBlock ! block information returned for requested block
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!----------------------------------------------------------------------
!
! check for valid id. if valid, return block info for requested block
!
!----------------------------------------------------------------------
errorCode = POP_Success
if (blockID < 1 .or. blockID > POP_numBlocks) then
call POP_ErrorSet(errorCode, &
'POP_BlocksGetBlock: invalid blockID')
return
endif
outBlock = allBlocks(blockID)
!----------------------------------------------------------------------
!EOC
end function POP_BlocksGetBlock
!***********************************************************************
!BOP
! !IROUTINE: POP_BlocksGetNbrID
! !INTERFACE:
function POP_BlocksGetNbrID(blockID, direction, iBoundary, jBoundary, & 24,43
errorCode) &
result (nbrID)
! !DESCRIPTION:
! This function returns the block id of a neighboring block in a
! requested direction. Supported directions currently include:
! POP\_blocksNorth (i ,j+1)
! POP\_blocksSouth (i ,j-1)
! POP\_blocksEast (i+1,j )
! POP\_blocksWest (i-1,j )
! POP\_blocksNorthEast (i+1,j+1)
! POP\_blocksNorthWest (i-1,j+1)
! POP\_blocksSouthEast (i ,j-1)
! POP\_blocksSouthWest (i-1,j-1)
! POP\_blocksNorth2 (i ,j+2)
! POP\_blocksSouth2 (i ,j-2)
! POP\_blocksEast2 (i+2,j )
! POP\_blocksWest2 (i-2,j )
! POP\_blocksNorthEast2 (i+2,j+2)
! POP\_blocksNorthWest2 (i-2,j+2)
! POP\_blocksSouthEast2 (i+2,j-2)
! POP\_blocksSouthWest2 (i-2,j-2)
! POP\_blocksEastNorthEast (i+2,j+1)
! POP\_blocksEastSouthEast (i+2,j-1)
! POP\_blocksWestNorthWest (i-2,j+1)
! POP\_blocksWestSouthWest (i-2,j-1)
! POP\_blocksNorthNorthEast (i+1,j-2)
! POP\_blocksSouthSouthEast (i+1,j-2)
! POP\_blocksNorthNorthWest (i-1,j+2)
! POP\_blocksSouthSouthWest (i-1,j-2)
!
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
blockID, &! id of block for which neighbor id requested
direction ! direction for which to look for neighbor -
! must be one of the predefined module
! variables for block direction
character (*), intent(in) :: &
iBoundary, &! determines what to do at edges of domain
jBoundary ! options are - closed, cyclic, tripole
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
integer (POP_i4) :: &
nbrID ! block ID of neighbor in requested dir
!EOP
!BOC
!----------------------------------------------------------------------
!
! local variables
!
!----------------------------------------------------------------------
integer (POP_i4) :: &
iBlock, jBlock, &! i,j block location of current block
inbr, jnbr ! i,j block location of neighboring block
!----------------------------------------------------------------------
!
! retrieve info for current block
!
!----------------------------------------------------------------------
errorCode = POP_Success
call POP_BlocksGetBlockInfo(blockID, errorCode, &
iBlock=iBlock, jBlock=jBlock)
if (errorCode /= POP_success) then
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: error getting block info')
return
endif
!----------------------------------------------------------------------
!
! compute i,j block location of neighbor
!
!----------------------------------------------------------------------
select case(direction)
case (POP_blocksNorth)
inbr = iBlock
jnbr = jBlock + 1
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = 1
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 1
jnbr = -jBlock
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksSouth)
inbr = iBlock
jnbr = jBlock - 1
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksEast )
inbr = iBlock + 1
jnbr = jBlock
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = 1
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
case (POP_blocksWest )
jnbr = jBlock
inbr = iBlock - 1
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
case (POP_blocksNorthEast)
inbr = iBlock + 1
jnbr = jBlock + 1
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = 1
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = 1
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock
if (inbr == 0) inbr = POP_numBlocksX
jnbr = -jBlock
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksNorthWest)
inbr = iBlock - 1
jnbr = jBlock + 1
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = 1
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 2
if (inbr > POP_numBlocksX) inbr = 1
jnbr = -jBlock
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksSouthEast )
inbr = iBlock + 1
jnbr = jBlock - 1
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = 1
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksSouthWest )
inbr = iBlock - 1
jnbr = jBlock - 1
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksNorth2)
inbr = iBlock
jnbr = jBlock + 2
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr - POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 1
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksSouth2)
inbr = iBlock
jnbr = jBlock - 2
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksEast2)
inbr = iBlock + 2
jnbr = jBlock
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
case (POP_blocksWest2)
jnbr = jBlock
inbr = iBlock - 2
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
case (POP_blocksNorthEast2)
inbr = iBlock + 2
jnbr = jBlock + 2
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr - POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock - 1
if (inbr == 0) inbr = POP_numBlocksX
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksNorthWest2)
inbr = iBlock - 2
jnbr = jBlock + 2
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = 1
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 3
if (inbr > POP_numBlocksX) inbr = 0
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksSouthEast2)
inbr = iBlock + 2
jnbr = jBlock - 2
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksSouthWest2)
inbr = iBlock - 2
jnbr = jBlock - 2
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksEastNorthEast)
inbr = iBlock + 2
jnbr = jBlock + 1
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr - POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock - 1
if (inbr == 0) inbr = POP_numBlocksX
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksWestNorthWest)
inbr = iBlock - 2
jnbr = jBlock + 1
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr + POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 3
if (inbr > POP_numBlocksX) inbr = 0
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksEastSouthEast)
inbr = iBlock + 2
jnbr = jBlock - 1
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksWestSouthWest)
inbr = iBlock - 2
jnbr = jBlock - 1
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksNorthNorthEast)
inbr = iBlock + 1
jnbr = jBlock + 2
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr - POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock
if (inbr == 0) inbr = POP_numBlocksX
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksNorthNorthWest)
inbr = iBlock - 1
jnbr = jBlock + 2
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr > POP_numBlocksY) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = jnbr - POP_numBlocksY
case ('tripole')
!*** return negative j value to flag tripole
!*** i index of main northern neighbor across the
!*** tripole cut - may also need i+1,i-1 to get
!*** other points if there has been padding or
!*** if the block size does not divide the domain
!*** evenly
inbr = POP_numBlocksX - iBlock + 2
if (inbr > POP_numBlocksX) inbr = 0
jnbr = -(POP_numBlocksY - (jnbr - POP_numBlocksY - 1))
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown north boundary')
end select
endif
case (POP_blocksSouthSouthEast)
inbr = iBlock + 1
jnbr = jBlock - 2
if (inbr > POP_numBlocksX) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = inbr - POP_numBlocksX
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown east boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case (POP_blocksSouthSouthWest)
inbr = iBlock - 1
jnbr = jBlock - 2
if (inbr < 1) then
select case(iBoundary)
case ('closed')
inbr = 0
case ('cyclic')
inbr = POP_numBlocksX + inbr
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown west boundary')
end select
endif
if (jnbr < 1) then
select case(jBoundary)
case ('closed')
jnbr = 0
case ('cyclic')
jnbr = POP_numBlocksY + jnbr
case ('tripole')
jnbr = 0
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown south boundary')
end select
endif
case default
call POP_ErrorSet(errorCode, &
'POP_BlocksGetNbrID: unknown direction')
return
end select
!----------------------------------------------------------------------
!
! now get block id for this neighbor block
!
!----------------------------------------------------------------------
if (inbr > 0 .and. jnbr > 0) then
nbrID = allBlocksIJ(inbr,jnbr)
else if (inbr > 0 .and. jnbr < 0) then ! tripole upper boundary
!*** return negative value to flag tripole
nbrID = -allBlocksIJ(inbr,abs(jnbr))
else
nbrID = 0 ! neighbor outside domain
endif
!----------------------------------------------------------------------
!EOC
end function POP_BlocksGetNbrID
!**********************************************************************
!BOP
! !IROUTINE: POP_BlocksGetBlockInfo
! !INTERFACE:
subroutine POP_BlocksGetBlockInfo(blockID, errorCode, & 4,1
localID, ib, ie, jb, je, &
numActivePoints, &
nxGlobal, nyGlobal, &
tripole, &
iBlock, jBlock, iGlobal, jGlobal)
! !DESCRIPTION:
! This routine returns requested parts of the block data type
! for the block associated with the input block id
!
! !REVISION HISTORY:
! same as module
!
! !INPUT PARAMETERS:
integer (POP_i4), intent(in) :: &
blockID ! global block id for which parameters are requested
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!(optional) parts of block data type to extract if requested
integer (POP_i4), intent(out), optional :: &
localID, &! local id assigned to block in current distrb
ib, ie, jb, je, &! begin,end indices for physical domain
iBlock, jBlock, &! cartesian i,j position for block
nxGlobal, nyGlobal, &! global domain size info
numActivePoints ! number of actual active points in block
logical (POP_logical), intent(out), optional :: &
tripole ! flag is true if block on tripole bndy
integer (POP_i4), dimension(:), pointer, optional :: &
iGlobal, jGlobal ! global domain location for each point
!EOP
!BOC
!----------------------------------------------------------------------
!
! check for valid blockID
!
!----------------------------------------------------------------------
errorCode = POP_Success
if (blockID < 1 .or. blockID > POP_numBlocks) then
call POP_ErrorSet(errorCode, &
'POP_BlocksGetBlockInfo: invalid blockID')
return
endif
!----------------------------------------------------------------------
!
! extract each component of data type if requested
!
!----------------------------------------------------------------------
if (present(numActivePoints)) numActivePoints = &
allBlocks(blockID)%numActivePoints
if (present(localID)) localID = allBlocks(blockID)%localID
if (present(ib )) ib = allBlocks(blockID)%ib
if (present(ie )) ie = allBlocks(blockID)%ie
if (present(jb )) jb = allBlocks(blockID)%jb
if (present(je )) je = allBlocks(blockID)%je
if (present(iBlock )) iBlock = allBlocks(blockID)%iBlock
if (present(jBlock )) jBlock = allBlocks(blockID)%jBlock
if (present(tripole)) tripole = allBlocks(blockID)%tripole
if (present(nxGlobal)) nxGlobal= allBlocks(blockID)%nxGlobal
if (present(nyGlobal)) nyGlobal= allBlocks(blockID)%nyGlobal
if (present(iGlobal)) iGlobal => allBlocks(blockID)%iGlobal
if (present(jGlobal)) jGlobal => allBlocks(blockID)%jGlobal
!----------------------------------------------------------------------
!EOC
end subroutine POP_BlocksGetBlockInfo
!***********************************************************************
!BOP
! !IROUTINE: POP_BlocksSet
! !INTERFACE:
subroutine POP_BlocksSet(blockID, errorCode, &,3
localID, numActivePoints, &
ib, ie, jb, je, iBlock, jBlock, &
nxGlobal, nyGlobal, tripole, &
iGlobal, jGlobal)
! !DESCRIPTION:
! This function sets or resets any parameter of a particular block
! given the block id. Most parameters are set correctly by the
! BlocksCreate routine and should not be routinely reset. The two
! exceptions are the localID (changes with each block distribution)
! and numActivePoints (should be set after details of the physical
! domain and ocean mask are known).
!
! !REVISION HISTORY:
! same as module
!
! !INPUT PARAMETERS:
!*** required argument
integer (POP_i4), intent(in) :: &
blockID ! global block id for block to change
!*** optional arguments for parameters to set
integer (POP_i4), intent(in), optional :: &
localID, &! local address of block in current distrib
numActivePoints, &! number of actual active points in block
ib, ie, jb, je, &! begin,end indices for physical domain
iBlock, jBlock, &! cartesian i,j position for bloc
nxGlobal, nyGlobal ! global domain information
logical (POP_logical), intent(in), optional :: &
tripole ! flag is true if block on tripole bndy
integer (POP_i4), dimension(:), intent(in), optional :: &
iGlobal, jGlobal ! global domain location for each point
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! output error code
!EOP
!BOC
!----------------------------------------------------------------------
!
! local variables
!
!----------------------------------------------------------------------
integer (POP_i4) :: i,j ! dummy loop indices
!----------------------------------------------------------------------
!
! check for valid block id
!
!----------------------------------------------------------------------
errorCode = POP_success
if (blockID < 0 .or. blockID > POP_numBlocks) then
call POP_ErrorSet(errorCode, &
'POP_BlocksSet: invalid block id')
return
endif
!----------------------------------------------------------------------
!
! for each parameter present, reset the value in the main allBlocks
! array containing the block info
!
!----------------------------------------------------------------------
if (present(numActivePoints)) &
allBlocks(blockID)%numActivePoints = numActivePoints
if (present(localID)) allBlocks(blockID)%localID = localID
if (present(ib)) allBlocks(blockID)%ib = ib
if (present(ie)) allBlocks(blockID)%ie = ie
if (present(jb)) allBlocks(blockID)%jb = jb
if (present(je)) allBlocks(blockID)%je = je
if (present(iBlock)) allBlocks(blockID)%iBlock = iBlock
if (present(jBlock)) allBlocks(blockID)%jBlock = jBlock
if (present(tripole)) allBlocks(blockID)%tripole = tripole
if (present(nxGlobal)) allBlocks(blockID)%nxGlobal = nxGlobal
if (present(nyGlobal)) allBlocks(blockID)%nyGlobal = nyGlobal
if (present(iGlobal)) then
if (size(iGlobal) == POP_nxBlock) then
do i=1,POP_nxBlock
allIGlobal(i,blockID) = iGlobal(i)
end do
else
call POP_ErrorSet(errorCode, &
'POP_BlocksSet: iGlobal not correct size')
return
endif
endif
if (present(jGlobal)) then
if (size(jGlobal) == POP_nyBlock) then
do j=1,POP_nyBlock
allIGlobal(j,blockID) = iGlobal(j)
end do
else
call POP_ErrorSet(errorCode, &
'POP_BlocksSet: jGlobal not correct size')
return
endif
endif
!EOC
!----------------------------------------------------------------------
end subroutine POP_BlocksSet
!**********************************************************************
!BOP
! !IROUTINE: POP_BlocksDestroy
! !INTERFACE:
subroutine POP_BlocksDestroy(errorCode),3
! !DESCRIPTION:
! This subroutine deallocates all arrays allocated by this module.
!
! !REVISION HISTORY:
! same as module
!
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!----------------------------------------------------------------------
!
! local variables
!
!----------------------------------------------------------------------
integer (POP_i4) :: istat ! status flag for deallocate
!----------------------------------------------------------------------
!
! deallocate arrays
!
!----------------------------------------------------------------------
errorCode = POP_Success
deallocate(allBlocks, stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksDestroy: error deallocating allBlocks')
return
endif
deallocate(allBlocksIJ, stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksDestroy: error deallocating allBlocksIJ')
return
endif
deallocate(allIGlobal, allJGlobal, stat=istat)
if (istat /= 0) then
call POP_ErrorSet(errorCode, &
'POP_BlocksDestroy: error deallocating ijGlobal')
return
endif
!EOC
!----------------------------------------------------------------------
end subroutine POP_BlocksDestroy
!***********************************************************************
end module POP_BlocksMod
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||