! -*-f90-*-
!***********************************************************************
!* GNU Lesser General Public License
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* FMS is free software: you can redistribute it and/or modify it under
!* the terms of the GNU Lesser General Public License as published by
!* the Free Software Foundation, either version 3 of the License, or (at
!* your option) any later version.
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
!* for more details.
!*
!* You should have received a copy of the GNU Lesser General Public
!* License along with FMS. If not, see .
!***********************************************************************
!
!
!
!
!
subroutine mpp_define_layout2D( global_indices, ndivs, layout )
integer, intent(in) :: global_indices(:) !(/ isg, ieg, jsg, jeg /)
integer, intent(in) :: ndivs !number of divisions to divide global domain
integer, intent(out) :: layout(:)
integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL,"mpp_define_layout2D: size of global_indices should be 4")
if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_layout2D: size of layout should be 2")
isg = global_indices(1)
ieg = global_indices(2)
jsg = global_indices(3)
jeg = global_indices(4)
isz = ieg - isg + 1
jsz = jeg - jsg + 1
!first try to divide ndivs in the domain aspect ratio: if imperfect aspect, reduce idiv till it divides ndivs
idiv = nint( sqrt(float(ndivs*isz)/jsz) )
idiv = max(idiv,1) !for isz=1 line above can give 0
do while( mod(ndivs,idiv).NE.0 )
idiv = idiv - 1
end do !will terminate at idiv=1 if not before
jdiv = ndivs/idiv
layout = (/ idiv, jdiv /)
return
end subroutine mpp_define_layout2D
!############################################################################
!
!
!
!
! NOTE: The following routine may need to revised to improve the capability.
! It is very hard to make it balance for all the situation.
! Hopefully some smart idea will come up someday.
subroutine mpp_define_mosaic_pelist( sizes, pe_start, pe_end, pelist, costpertile)
integer, dimension(:), intent(in) :: sizes
integer, dimension(:), intent(inout) :: pe_start, pe_end
integer, dimension(:), intent(in), optional :: pelist, costpertile
integer, dimension(size(sizes(:))) :: costs
integer, dimension(:), allocatable :: pes
integer :: ntiles, npes, totcosts, avgcost
integer :: ntiles_left, npes_left, pos, n, tile
integer :: cost_on_tile, cost_on_pe, npes_used, errunit
ntiles = size(sizes(:))
if(size(pe_start(:)) .NE. ntiles .OR. size(pe_end(:)) .NE. ntiles ) then
call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
end if
if(present(costpertile)) then
if(size(costpertile(:)) .NE. ntiles ) then
call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
end if
costs = sizes*costpertile
else
costs = sizes
end if
if( PRESENT(pelist) )then
if( .NOT.any(pelist.EQ.mpp_pe()) )then
errunit = stderr()
write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
call mpp_error( FATAL, 'mpp_define_mosaic_pelist: pe must be in pelist.' )
end if
npes = size(pelist(:))
allocate( pes(0:npes-1) )
pes(:) = pelist(:)
else
npes = mpp_npes()
allocate( pes(0:npes-1) )
call mpp_get_current_pelist(pes)
end if
ntiles_left = ntiles
npes_left = npes
pos = pes(0)
do while( ntiles_left > 0 )
if( npes_left == 1 ) then ! all left tiles will on the last processor, imbalance possibly.
do n = 1, ntiles
if(costs(n) > 0) then
pe_start(n) = pos
pe_end(n) = pos
costs(n) = 0
end if
end do
ntiles_left = 0
npes_left = 0
else
totcosts = sum(costs)
avgcost = CEILING(real(totcosts)/npes_left )
tile = minval(maxloc(costs))
cost_on_tile = costs(tile)
pe_start(tile) = pos
ntiles_left = ntiles_left - 1
costs(tile) = 0
totcosts = totcosts - cost_on_tile
if(cost_on_tile .GE. avgcost ) then
npes_used = min(ceiling(real(cost_on_tile)/avgcost), npes_left)
if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
pe_end(tile) = pos + npes_used - 1
npes_left = npes_left - npes_used
pos = pos + npes_used
else
!--- find other tiles to share the pe
pe_end(tile) = pos
cost_on_pe = cost_on_tile
do while(ntiles_left>npes_left) ! make sure all the pes are used.
tile = minval(minloc(costs, costs> 0 ))
cost_on_tile = costs(tile)
cost_on_pe = cost_on_pe + cost_on_tile
if(cost_on_pe > avgcost ) exit
pe_start(tile) = pos
pe_end(tile) = pos
ntiles_left = ntiles_left - 1
costs(tile) = 0
totcosts = totcosts - cost_on_tile
end do
npes_left = npes_left - 1
pos = pos + 1
end if
end if
end do
if(npes_left .NE. 0 ) call mpp_error(FATAL, "mpp_define_mosaic_pelist: the left npes should be zero")
deallocate(pes)
end subroutine mpp_define_mosaic_pelist
!-- The following implementation is different from mpp_compute_extents
!-- The last block might have most points
subroutine mpp_compute_block_extent(isg,ieg,ndivs,ibegin,iend)
integer, intent(in) :: isg, ieg, ndivs
integer, dimension(:), intent(out) :: ibegin, iend
integer :: ndiv, imax, ndmax
integer :: is, ie, n
ie = ieg
do ndiv=ndivs,1,-1
!domain is sized by dividing remaining points by remaining domains
is = ie - CEILING( REAL(ie-isg+1)/ndiv ) + 1
ibegin(ndiv) = is
iend(ndiv) = ie
if( ie.LT.is )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE. isg ) &
call mpp_error( FATAL, 'mpp_compute_block_extent: domain extents do not span space completely.' )
ie = is - 1
end do
end subroutine mpp_compute_block_extent
!#####################################################################
subroutine mpp_compute_extent(isg,ieg,ndivs,ibegin,iend, extent )
integer, intent(in) :: isg, ieg, ndivs
integer, dimension(0:), intent(out) :: ibegin, iend
integer, dimension(0:), intent(in), optional :: extent
integer :: ndiv, imax, ndmax, ndmirror
integer :: is, ie, n
logical :: symmetrize, use_extent
!statement functions
logical :: even, odd
even(n) = (mod(n,2).EQ.0)
odd (n) = (mod(n,2).EQ.1)
use_extent = .false.
if(PRESENT(extent)) then
if( size(extent(:)).NE.ndivs ) &
call mpp_error( FATAL, 'mpp_compute_extent: extent array size must equal number of domain divisions.' )
use_extent = .true.
if(ALL(extent ==0)) use_extent = .false.
endif
is = isg
if(use_extent) then
ibegin(0) = isg
do ndiv = 0, ndivs-2
if(extent(ndiv) .LE. 0) call mpp_error( FATAL, 'mpp_compute_extent: domain extents must be positive definite.' )
iend(ndiv) = ibegin(ndiv) + extent(ndiv) - 1
ibegin(ndiv+1) = iend(ndiv) + 1
enddo
iend(ndivs-1) = ibegin(ndivs-1) + extent(ndivs-1) - 1
if(iend(ndivs-1) .NE. ieg) call mpp_error(FATAL, 'mpp_compute_extent: extent array limits do not match global domain.' )
else
do ndiv=0,ndivs-1
!modified for mirror-symmetry
!original line
! ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1
!problem of dividing nx points into n domains maintaining symmetry
!i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not.
!this will always work for nx even n even or odd
!this will always work for nx odd, n odd
!this will never work for nx odd, n even: for this case we supersede the mirror calculation
! symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(ieg-isg+1,2).EQ.1 )
!nx even n odd fails if n>nx/2
symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
( odd(ndivs) .AND. odd(ieg-isg+1) ) .OR. &
( odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
!mirror domains are stored in the list and retrieved if required.
if( ndiv.EQ.0 )then
!initialize max points and max domains
imax = ieg
ndmax = ndivs
end if
!do bottom half of decomposition, going over the midpoint for odd ndivs
if( ndiv.LT.(ndivs-1)/2+1 )then
!domain is sized by dividing remaining points by remaining domains
ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
ndmirror = (ndivs-1) - ndiv !mirror domain
if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
!mirror extents, the max(,) is to eliminate overlaps
ibegin(ndmirror) = max( isg+ieg-ie, ie+1 )
iend(ndmirror) = max( isg+ieg-is, ie+1 )
imax = ibegin(ndmirror) - 1
ndmax = ndmax - 1
end if
else
if( symmetrize )then
!do top half of decomposition by retrieving saved values
is = ibegin(ndiv)
ie = iend(ndiv)
else
ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
end if
end if
ibegin(ndiv) = is
iend(ndiv) = ie
if( ie.LT.is )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.ieg ) &
call mpp_error( FATAL, 'mpp_compute_extent: domain extents do not span space completely.' )
is = ie + 1
end do
endif
end subroutine mpp_compute_extent
!#####################################################################
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! MPP_DEFINE_DOMAINS: define layout and decomposition !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! >
!
!
!
!
!
!
!
!
!
!routine to divide global array indices among domains, and assign domains to PEs
!domain is of type domain1D
!ARGUMENTS:
! global_indices(2)=(isg,ieg) gives the extent of global domain
! ndivs is number of divisions of domain: even divisions unless extent is present.
! domain is the returned domain1D
! pelist (optional) list of PEs to which domains are to be assigned (default 0...npes-1)
! size of pelist must correspond to number of mask=.TRUE. divisions
! flags define whether compute and data domains are global (undecomposed) and whether global domain has periodic boundaries
! halo (optional) defines halo width (currently the same on both sides)
! extent (optional) array defines width of each division (used for non-uniform domain decomp, for e.g load-balancing)
! maskmap (optional) a division whose maskmap=.FALSE. is not assigned to any domain
! By default we assume decomposition of compute and data domains, non-periodic boundaries, no halo, as close to uniform extents
! as the input parameters permit
subroutine mpp_define_domains1D( global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, &
memory_size, begin_halo, end_halo )
integer, intent(in) :: global_indices(:) !(/ isg, ieg /)
integer, intent(in) :: ndivs
type(domain1D), intent(inout) :: domain !declared inout so that existing links, if any, can be nullified
integer, intent(in), optional :: pelist(0:)
integer, intent(in), optional :: flags, halo
integer, intent(in), optional :: extent(0:)
logical, intent(in), optional :: maskmap(0:)
integer, intent(in), optional :: memory_size
integer, intent(in), optional :: begin_halo, end_halo
logical :: compute_domain_is_global, data_domain_is_global
integer :: ndiv, n, isg, ieg, i
integer, allocatable :: pes(:)
integer :: ibegin(0:ndivs-1), iend(0:ndivs-1)
logical :: mask(0:ndivs-1)
integer :: halosz, halobegin, haloend
integer :: errunit
if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
if(size(global_indices(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains1D: size of global_indices should be 2")
!get global indices
isg = global_indices(1)
ieg = global_indices(2)
if( ndivs.GT.ieg-isg+1 )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
!get the list of PEs on which to assign domains; if pelist is absent use 0..npes-1
if( PRESENT(pelist) )then
if( .NOT.any(pelist.EQ.mpp_pe()) )then
errunit = stderr()
write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
end if
allocate( pes(0:size(pelist(:))-1) )
pes(:) = pelist(:)
else
allocate( pes(0:mpp_npes()-1) )
call mpp_get_current_pelist(pes)
! pes(:) = (/ (i,i=0,mpp_npes()-1) /)
end if
!get number of real domains: 1 mask domain per PE in pes
mask = .TRUE. !default mask
if( PRESENT(maskmap) )then
if( size(maskmap(:)).NE.ndivs ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
mask(:) = maskmap(:)
end if
if( count(mask).NE.size(pes(:)) ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
!get halosize
halosz = 0
if( PRESENT(halo) ) then
halosz = halo
!--- if halo is present, begin_halo and end_halo should not present
if(present(begin_halo) .OR. present(end_halo) ) call mpp_error(FATAL, &
"mpp_domains_define.inc: when halo is present, begin_halo and end_halo should not present")
end if
halobegin = halosz; haloend = halosz
if(present(begin_halo)) halobegin = begin_halo
if(present(end_halo)) haloend = end_halo
halosz = max(halobegin, haloend)
!get flags
compute_domain_is_global = .FALSE.
data_domain_is_global = .FALSE.
domain%cyclic = .FALSE.
domain%goffset = 1
domain%loffset = 1
if( PRESENT(flags) )then
!NEW: obsolete flag global_compute_domain, since ndivs is non-optional and you cannot have global compute and ndivs.NE.1
compute_domain_is_global = ndivs.EQ.1
!if compute domain is global, data domain must also be
data_domain_is_global = BTEST(flags,GLOBAL) .OR. compute_domain_is_global
domain%cyclic = BTEST(flags,CYCLIC) .AND. halosz.NE.0
if(BTEST(flags,CYCLIC)) domain%goffset = 0
end if
!set up links list
allocate( domain%list(0:ndivs-1) )
!set global domain
domain%list(:)%global%begin = isg
domain%list(:)%global%end = ieg
domain%list(:)%global%size = ieg-isg+1
domain%list(:)%global%max_size = ieg-isg+1
domain%list(:)%global%is_global = .TRUE. !always
!get compute domain
if( compute_domain_is_global )then
domain%list(:)%compute%begin = isg
domain%list(:)%compute%end = ieg
domain%list(:)%compute%is_global = .TRUE.
domain%list(:)%pe = pes(:)
domain%pos = 0
else
domain%list(:)%compute%is_global = .FALSE.
n = 0
call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
do ndiv=0,ndivs-1
domain%list(ndiv)%compute%begin = ibegin(ndiv)
domain%list(ndiv)%compute%end = iend(ndiv)
if( mask(ndiv) )then
domain%list(ndiv)%pe = pes(n)
if( mpp_pe().EQ.pes(n) )domain%pos = ndiv
n = n + 1
else
domain%list(ndiv)%pe = NULL_PE
end if
end do
end if
domain%list(:)%compute%size = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
!get data domain
!data domain is at least equal to compute domain
domain%list(:)%data%begin = domain%list(:)%compute%begin
domain%list(:)%data%end = domain%list(:)%compute%end
domain%list(:)%data%is_global = .FALSE.
!apply global flags
if( data_domain_is_global )then
domain%list(:)%data%begin = isg
domain%list(:)%data%end = ieg
domain%list(:)%data%is_global = .TRUE.
end if
!apply margins
domain%list(:)%data%begin = domain%list(:)%data%begin - halobegin
domain%list(:)%data%end = domain%list(:)%data%end + haloend
domain%list(:)%data%size = domain%list(:)%data%end - domain%list(:)%data%begin + 1
!--- define memory domain, if memory_size is not present or memory size is 0, memory domain size
!--- will be the same as data domain size. if momory_size is present, memory_size should greater than
!--- or equal to data size. The begin of memory domain will be always the same as data domain.
domain%list(:)%memory%begin = domain%list(:)%data%begin
domain%list(:)%memory%end = domain%list(:)%data%end
if( present(memory_size) ) then
if(memory_size > 0) then
if( domain%list(domain%pos)%data%size > memory_size ) call mpp_error(FATAL, &
"mpp_domains_define.inc: data domain size is larger than memory domain size on this pe")
domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1
end if
end if
domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1
domain%list(:)%memory%is_global = domain%list(:)%data%is_global
domain%compute = domain%list(domain%pos)%compute
domain%data = domain%list(domain%pos)%data
domain%global = domain%list(domain%pos)%global
domain%memory = domain%list(domain%pos)%memory
domain%compute%max_size = MAXVAL( domain%list(:)%compute%size )
domain%data%max_size = MAXVAL( domain%list(:)%data%size )
domain%global%max_size = domain%global%size
domain%memory%max_size = domain%memory%size
!PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
deallocate( pes )
return
end subroutine mpp_define_domains1D
!################################################################################
!--- define the IO domain.
subroutine mpp_define_io_domain(domain, io_layout)
type(domain2D), intent(inout) :: domain
integer, intent(in ) :: io_layout(2)
integer :: layout(2)
integer :: npes_in_group
type(domain2D), pointer :: io_domain=>NULL()
integer :: i, j, n, m
integer :: ipos, jpos, igroup, jgroup
integer :: ipos_beg, ipos_end, jpos_beg, jpos_end
integer :: whalo, ehalo, shalo, nhalo
integer :: npes_x, npes_y, ndivx, ndivy
integer, allocatable :: posarray(:,:)
if(io_layout(1) * io_layout(2) .LE. 0) then
call mpp_error(NOTE, &
"mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for "//trim(domain%name)// &
" when one or both entry of io_layout is not positive")
return
endif
layout(1) = size(domain%x(1)%list(:))
layout(2) = size(domain%y(1)%list(:))
if(ASSOCIATED(domain%io_domain)) call mpp_error(FATAL, &
"mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
if(mod(layout(1), io_layout(1)) .NE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)//" domain layout(1) must be divided by io_layout(1)")
if(mod(layout(2), io_layout(2)) .NE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)//" domain layout(2) must be divided by io_layout(2)")
if(size(domain%x(:)) > 1) call mpp_error(FATAL, &
"mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
": multiple tile per pe is not supported yet for this routine")
allocate(domain%io_domain)
domain%io_layout = io_layout
io_domain => domain%io_domain
! Find how many processors are in the group with the consideration that some of the region maybe masked out.
npes_x = layout(1)/io_layout(1)
npes_y = layout(2)/io_layout(2)
ipos = mod(domain%x(1)%pos, npes_x)
jpos = mod(domain%y(1)%pos, npes_y)
igroup = domain%x(1)%pos/npes_x
jgroup = domain%y(1)%pos/npes_y
ipos_beg = igroup*npes_x; ipos_end = ipos_beg + npes_x - 1
jpos_beg = jgroup*npes_y; jpos_end = jpos_beg + npes_y - 1
npes_in_group = 0
do j = jpos_beg, jpos_end
do i = ipos_beg, ipos_end
if(domain%pearray(i,j) .NE. NULL_PE) npes_in_group = npes_in_group+1
enddo
enddo
io_domain%whalo = domain%whalo
io_domain%ehalo = domain%ehalo
io_domain%shalo = domain%shalo
io_domain%nhalo = domain%nhalo
io_domain%ntiles = 1
io_domain%pe = domain%pe
io_domain%symmetry = domain%symmetry
allocate(io_domain%list(0:npes_in_group-1))
do i = 0, npes_in_group-1
allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) )
enddo
ndivx = size(domain%pearray,1)
ndivy = size(domain%pearray,2)
allocate(posarray(0:ndivx-1, 0:ndivy-1))
n = domain%tile_root_pe - mpp_root_pe()
posarray = -1
do j = 0,ndivy-1
do i = 0,ndivx-1
if( domain%pearray(i,j) == NULL_PE) cycle
posarray(i,j) = n
n = n + 1
enddo
enddo
n = 0
do j = jpos_beg, jpos_end
do i = ipos_beg, ipos_end
if( domain%pearray(i,j) == NULL_PE) cycle
io_domain%list(n)%pe = domain%pearray(i,j)
m = posarray(i,j)
io_domain%list(n)%x(1)%compute = domain%list(m)%x(1)%compute
io_domain%list(n)%y(1)%compute = domain%list(m)%y(1)%compute
igroup = domain%list(m)%x(1)%pos/npes_x
jgroup = domain%list(m)%y(1)%pos/npes_y
io_domain%list(n)%tile_id(1) = jgroup*io_layout(1) + igroup
n = n + 1
enddo
enddo
deallocate(posarray)
allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) )
n = -1
do j = jpos_beg, jpos_beg+jpos
do i = ipos_beg, ipos_beg+ipos
if(domain%pearray(i,j) .NE. NULL_PE) n = n + 1
enddo
enddo
io_domain%pos = n
io_domain%x(1)%compute = domain%x(1)%compute
io_domain%x(1)%data = domain%x(1)%data
io_domain%x(1)%memory = domain%x(1)%memory
io_domain%y(1)%compute = domain%y(1)%compute
io_domain%y(1)%data = domain%y(1)%data
io_domain%y(1)%memory = domain%y(1)%memory
io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin
io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end
io_domain%x(1)%global%size = io_domain%x(1)%global%end - io_domain%x(1)%global%begin + 1
io_domain%x(1)%global%max_size = io_domain%x(1)%global%size
io_domain%y(1)%global%begin = domain%y(1)%list(jpos_beg)%compute%begin
io_domain%y(1)%global%end = domain%y(1)%list(jpos_end)%compute%end
io_domain%y(1)%global%size = io_domain%y(1)%global%end - io_domain%y(1)%global%begin + 1
io_domain%y(1)%global%max_size = io_domain%y(1)%global%size
io_domain%x(1)%pos = ipos
io_domain%y(1)%pos = jpos
io_domain%tile_id(1) = io_domain%list(n)%tile_id(1)
io_domain%tile_root_pe = io_domain%list(0)%pe
!z1l
!!$ do j = 0, npes_y - 1
!!$ n = j*npes_x + ipos
!!$ io_domain%y(1)%list(j) = io_domain%list(n)%y(1)
!!$ enddo
!!$ do i = 0, npes_x - 1
!!$ n = jpos*npes_x + i
!!$ io_domain%x(1)%list(i) = io_domain%list(n)%x(1)
!!$ enddo
whalo = domain%whalo
ehalo = domain%ehalo
shalo = domain%shalo
nhalo = domain%nhalo
io_domain=>NULL()
end subroutine mpp_define_io_domain
!
!
!
!
!
!
!
!
!
!
!
subroutine mpp_define_domains2D( global_indices, layout, domain, pelist, xflags, yflags, &
xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, &
whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
!define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,jsg:jeg) and assign them to PEs
integer, intent(in) :: global_indices(:) !(/ isg, ieg, jsg, jeg /)
integer, intent(in) :: layout(:)
type(domain2D), intent(inout) :: domain
integer, intent(in), optional :: pelist(0:)
integer, intent(in), optional :: xflags, yflags, xhalo, yhalo
integer, intent(in), optional :: xextent(0:), yextent(0:)
logical, intent(in), optional :: maskmap(0:,0:)
character(len=*), intent(in), optional :: name
logical, intent(in), optional :: symmetry
logical, intent(in), optional :: is_mosaic ! indicate if calling mpp_define_domains from mpp_define_mosaic.
integer, intent(in), optional :: memory_size(:)
integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! halo size for West, East, South and North direction.
! if whalo and ehalo is not present,
! will take the value of xhalo
! if shalo and nhalo is not present,
! will take the value of yhalo
integer, intent(in), optional :: tile_count ! tile number on current pe, default value is 1
! this is for the situation that multiple tiles on one processor.
integer, intent(in), optional :: tile_id ! tile id
logical, intent(in), optional :: complete ! true indicate mpp_define_domain is completed for mosaic definition.
integer, intent(in), optional :: x_cyclic_offset ! offset for x-cyclic boundary condition,
! (0,j) = (ni, mod(j+x_cyclic_offset,nj))
! (ni+1,j) = ( 1, mod(j+nj-x_cyclic_offset,nj) )
integer, intent(in), optional :: y_cyclic_offset ! offset for y-cyclic boundary condition
! (i,0) = (mod(i+y_cyclic_offset,ni), nj))
! (i,nj+1) = (mod(mod(i+ni-y_cyclic_offset,ni), 1) )
integer :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
integer :: whalosz, ehalosz, shalosz, nhalosz
integer :: ipos, jpos, pos, tile, nlist, cur_tile_id
integer :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
integer :: x_offset, y_offset, start_pos, nfold
logical :: from_mosaic, is_complete
logical :: mask(0:layout(1)-1,0:layout(2)-1)
integer, allocatable :: pes(:), pesall(:)
integer :: pearray(0:layout(1)-1,0:layout(2)-1)
integer :: ibegin(0:layout(1)-1), iend(0:layout(1)-1)
integer :: jbegin(0:layout(2)-1), jend(0:layout(2)-1)
character(len=8) :: text
type(overlapSpec), pointer :: update=>NULL()
type(overlapSpec), pointer :: check_T => NULL()
character(len=1) :: position
integer :: msgsize, l, p, is, ie, js, je, from_pe
integer :: outunit
logical :: send(8), recv(8)
outunit = stdout()
if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
if(PRESENT(name)) then
if(len_trim(name) > NAME_LENGTH) call mpp_error(FATAL, &
"mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument name ="//trim(name)// &
" is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
domain%name = name
endif
if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL, &
"mpp_define_domains2D: size of global_indices should be 4 for "//trim(domain%name) )
if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains2D: size of layout should be 2 for "//trim(domain%name) )
ndivx = layout(1); ndivy = layout(2)
isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
from_mosaic = .false.
if(present(is_mosaic)) from_mosaic = is_mosaic
is_complete = .true.
if(present(complete)) is_complete = complete
tile = 1
if(present(tile_count)) tile = tile_count
cur_tile_id = 1
if(present(tile_id)) cur_tile_id = tile_id
if( PRESENT(pelist) )then
allocate( pes(0:size(pelist(:))-1) )
pes = pelist
if(from_mosaic) then
allocate( pesall(0:mpp_npes()-1) )
call mpp_get_current_pelist(pesall)
else
allocate( pesall(0:size(pes(:))-1) )
pesall = pes
end if
else
allocate( pes(0:mpp_npes()-1) )
allocate( pesall(0:mpp_npes()-1) )
call mpp_get_current_pelist(pes)
pesall = pes
end if
!--- at least of one of x_cyclic_offset and y_cyclic_offset must be zero
!--- folded boundary condition is not supported when either x_cyclic_offset or y_cyclic_offset is nonzero.
!--- Since we only implemented Folded-north boundary condition currently, we only consider y-flags.
x_offset = 0; y_offset = 0
if(PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
if(PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
if(x_offset*y_offset .NE. 0) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: At least one of x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
!--- x_cyclic_offset and y_cyclic_offset should no larger than the global grid size.
if(abs(x_offset) > jeg-jsg+1) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset is greater than jeg-jsg+1 for '//trim(domain%name))
if(abs(y_offset) > ieg-isg+1) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset is greater than ieg-isg+1 for '//trim(domain%name))
!--- when there is more than one tile on one processor, all the tile will limited on this processor
if( tile > 1 .AND. size(pes(:)) > 1) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: there are more than one tile on this pe, '// &
'all the tile should be limited on this pe for '//trim(domain%name))
!--- the position of current pe is changed due to mosaic, because pes
!--- is only part of the pelist in mosaic (pesall). We assume the pe
!--- distribution are contious in mosaic.
pos = -1
do n = 0, size(pesall(:))-1
if(pesall(n) == mpp_pe() ) then
pos = n
exit
endif
enddo
if(pos<0) call mpp_error(FATAL, 'MPP_DEFINE_DOMAINS2D: mpp_pe() is not in the pesall list')
domain%symmetry = .FALSE.
if(present(symmetry)) domain%symmetry = symmetry
if(domain%symmetry) then
ishift = 1; jshift = 1
else
ishift = 0; jshift = 0
end if
!--- first compute domain decomposition.
call mpp_compute_extent(isg, ieg, ndivx, ibegin, iend, xextent)
call mpp_compute_extent(jsg, jeg, ndivy, jbegin, jend, yextent)
xhalosz = 0; yhalosz = 0
if(present(xhalo)) xhalosz = xhalo
if(present(yhalo)) yhalosz = yhalo
whalosz = xhalosz; ehalosz = xhalosz
shalosz = yhalosz; nhalosz = yhalosz
if(present(whalo)) whalosz = whalo
if(present(ehalo)) ehalosz = ehalo
if(present(shalo)) shalosz = shalo
if(present(nhalo)) nhalosz = nhalo
!--- configure maskmap
mask = .TRUE.
if( PRESENT(maskmap) )then
if( size(maskmap,1).NE.ndivx .OR. size(maskmap,2).NE.ndivy ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout for '//trim(domain%name) )
mask(:,:) = maskmap(:,:)
end if
!number of unmask domains in layout must equal number of PEs assigned
n = count(mask)
if( n.NE.size(pes(:)) )then
write( text,'(i8)' )n
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for ' // &
'this layout and maskmap. Use '//text//' PEs for this domain decomposition for '//trim(domain%name) )
end if
memory_xsize = 0; memory_ysize = 0
if(present(memory_size)) then
if(size(memory_size(:)) .NE. 2) call mpp_error(FATAL, &
"mpp_define_domains2D: size of memory_size should be 2 for "//trim(domain%name))
memory_xsize = memory_size(1)
memory_ysize = memory_size(2)
end if
!--- set up domain%list.
!--- set up 2-D domain decomposition for T, E, C, N and computing overlapping
!--- when current tile is the last tile in the mosaic.
nlist = size(pesall(:))
if( .NOT. Associated(domain%x) ) then
allocate(domain%tileList(1))
domain%tileList(1)%xbegin = global_indices(1)
domain%tileList(1)%xend = global_indices(2)
domain%tileList(1)%ybegin = global_indices(3)
domain%tileList(1)%yend = global_indices(4)
allocate(domain%x(1), domain%y(1) )
allocate(domain%tile_id(1))
domain%tile_id = cur_tile_id
domain%ntiles = 1
domain%max_ntile_pe = 1
domain%ncontacts = 0
domain%rotated_ninety = .FALSE.
allocate( domain%list(0:nlist-1) )
do i = 0, nlist-1
allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1) )
end do
end if
domain%initialized = .true.
start_pos = 0
do n = 0, nlist-1
if(pesall(n) == pes(0)) then
start_pos = n
exit
endif
enddo
!place on PE array; need flag to assign them to j first and then i
pearray(:,:) = NULL_PE
ipos = NULL_PE; jpos = NULL_PE
n = 0
m = start_pos
do j = 0,ndivy-1
do i = 0,ndivx-1
if( mask(i,j) )then
pearray(i,j) = pes(n)
domain%list(m)%x(tile)%compute%begin = ibegin(i)
domain%list(m)%x(tile)%compute%end = iend(i)
domain%list(m)%y(tile)%compute%begin = jbegin(j)
domain%list(m)%y(tile)%compute%end = jend(j)
domain%list(m)%x(tile)%compute%size = domain%list(m)%x(tile)%compute%end - domain%list(m)%x(tile)%compute%begin + 1
domain%list(m)%y(tile)%compute%size = domain%list(m)%y(tile)%compute%end - domain%list(m)%y(tile)%compute%begin + 1
domain%list(m)%tile_id(tile) = cur_tile_id
domain%list(m)%x(tile)%pos = i
domain%list(m)%y(tile)%pos = j
domain%list(m)%tile_root_pe = pes(0)
domain%list(m)%pe = pesall(m)
if( pes(n).EQ.mpp_pe() )then
ipos = i
jpos = j
end if
n = n + 1
m = m + 1
end if
end do
end do
!Considering mosaic, the following will only be done on the pe in the pelist
!when there is only one tile, all the current pe will be in the pelist.
if( ANY(pes == mpp_pe()) ) then
domain%io_layout = layout
domain%tile_root_pe = pes(0)
if( ipos.EQ.NULL_PE .OR. jpos.EQ.NULL_PE ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: pelist must include this PE for '//trim(domain%name) )
if( debug ) then
errunit = stderr()
write( errunit, * )'pe, tile, ipos, jpos=', mpp_pe(), tile, ipos, jpos, ' pearray(:,jpos)=', &
pearray(:,jpos), ' pearray(ipos,:)=', pearray(ipos,:)
endif
!--- when tile is not equal to 1, the layout for that tile always ( 1, 1), so no need for pearray in domain
if( tile == 1 ) then
allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
domain%pearray = pearray
end if
domain%pe = mpp_pe()
domain%pos = pos
domain_cnt = domain_cnt + INT(1,KIND=LONG_KIND)
domain%id = domain_cnt*DOMAIN_ID_BASE ! Must be LONG_KIND arithmetic
!do domain decomposition using 1D versions in X and Y,
call mpp_define_domains( global_indices(1:2), ndivx, domain%x(tile), &
pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
call mpp_define_domains( global_indices(3:4), ndivy, domain%y(tile), &
pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
if( domain%x(tile)%list(ipos)%pe.NE.domain%y(tile)%list(jpos)%pe ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pe.NE.domain%y%list(jpos)%pe.' )
!--- when x_cyclic_offset or y_cyclic_offset is set, no cross domain is allowed
if(x_offset .NE. 0 .OR. y_offset .NE. 0) then
if(whalosz .GT. domain%x(tile)%compute%size .OR. ehalosz .GT. domain%x(tile)%compute%size ) &
call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
"whalo and ehalo must be no larger than the x-direction computation domain size")
if(shalosz .GT. domain%y(tile)%compute%size .OR. nhalosz .GT. domain%y(tile)%compute%size ) &
call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
"shalo and nhalo must be no larger than the y-direction computation domain size")
endif
!--- restrict the halo size is no larger than global domain size.
if(whalosz .GT. domain%x(tile)%global%size) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: whalo is greather global domain size")
if(ehalosz .GT. domain%x(tile)%global%size) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: ehalo is greather global domain size")
if(shalosz .GT. domain%x(tile)%global%size) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: shalo is greather global domain size")
if(nhalosz .GT. domain%x(tile)%global%size) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: nhalo is greather global domain size")
!set up fold, when the boundary is folded, there is only one tile.
domain%fold = 0
nfold = 0
if( PRESENT(xflags) )then
if( BTEST(xflags,WEST) ) then
!--- make sure no cross-domain in y-direction
if(domain%x(tile)%data%begin .LE. domain%x(tile)%global%begin .AND. &
domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then
call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded')
endif
if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded west and cyclic for '//trim(domain%name) )
domain%fold = domain%fold + FOLD_WEST_EDGE
nfold = nfold+1
endif
if( BTEST(xflags,EAST) ) then
!--- make sure no cross-domain in y-direction
if(domain%x(tile)%data%end .GE. domain%x(tile)%global%end .AND. &
domain%x(tile)%compute%end < domain%x(tile)%global%end ) then
call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded')
endif
if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded east and cyclic for '//trim(domain%name) )
domain%fold = domain%fold + FOLD_EAST_EDGE
nfold = nfold+1
endif
endif
if( PRESENT(yflags) )then
if( BTEST(yflags,SOUTH) ) then
!--- make sure no cross-domain in y-direction
if(domain%y(tile)%data%begin .LE. domain%y(tile)%global%begin .AND. &
domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then
call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded')
endif
if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded north and cyclic for '//trim(domain%name))
domain%fold = domain%fold + FOLD_SOUTH_EDGE
nfold = nfold+1
endif
if( BTEST(yflags,NORTH) ) then
!--- when the halo size is big and halo region is crossing neighbor domain, we
!--- restrict the halo size is less than half of the global size.
if(whalosz .GT. domain%x(tile)%compute%size .AND. whalosz .GE. domain%x(tile)%global%size/2 ) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, whalo .GT. compute domain size "// &
"and whalo .GE. half of global domain size")
if(ehalosz .GT. domain%x(tile)%compute%size .AND. ehalosz .GE. domain%x(tile)%global%size/2 ) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, ehalo is .GT. compute domain size "// &
"and ehalo .GE. half of global domain size")
if(shalosz .GT. domain%y(tile)%compute%size .AND. shalosz .GE. domain%x(tile)%global%size/2 ) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, shalo .GT. compute domain size "// &
"and shalo .GE. half of global domain size")
if(nhalosz .GT. domain%y(tile)%compute%size .AND. nhalosz .GE. domain%x(tile)%global%size/2 ) &
call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, nhalo .GT. compute domain size "// &
"and nhalo .GE. half of global domain size")
if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded south and cyclic for '//trim(domain%name) )
domain%fold = domain%fold + FOLD_NORTH_EDGE
nfold = nfold+1
endif
endif
if(nfold > 1) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: number of folded edge is greater than 1 for '//trim(domain%name) )
if(nfold == 1) then
if( x_offset .NE. 0 .OR. y_offset .NE. 0) call mpp_error(FATAL, &
'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition, '// &
'x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
endif
if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,NORTH) )then
if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
if( modulo(domain%x(tile)%global%size,2).NE.0 ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in X must be even ' // &
'when there is a fold in Y for '//trim(domain%name) )
!check if folded domain boundaries line up in X: compute domains lining up is a sufficient condition for symmetry
n = ndivx - 1
do i = 0,n/2
if( domain%x(tile)%list(i)%compute%size.NE.domain%x(tile)%list(n-i)%compute%size ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries ' // &
'must line up (mirror-symmetric extents) for '//trim(domain%name) )
end do
end if
if( BTEST(domain%fold,WEST) .OR. BTEST(domain%fold,EAST) )then
if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
if( modulo(domain%y(tile)%global%size,2).NE.0 ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in Y must be even '//&
'when there is a fold in X for '//trim(domain%name) )
!check if folded domain boundaries line up in Y: compute domains lining up is a sufficient condition for symmetry
n = ndivy - 1
do i = 0,n/2
if( domain%y(tile)%list(i)%compute%size.NE.domain%y(tile)%list(n-i)%compute%size ) &
call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must '//&
'line up (mirror-symmetric extents) for '//trim(domain%name) )
end do
end if
!set up domain%list
if( mpp_pe().EQ.pes(0) .AND. PRESENT(name) )then
logunit = stdlog()
write( logunit, '(/a,i5,a,i5)' )trim(name)//' domain decomposition: ', ndivx, ' X', ndivy
write( logunit, '(3x,a)' )'pe, is, ie, js, je, isd, ied, jsd, jed'
end if
end if ! if( ANY(pes == mpp_pe()) )
if(is_complete) then
domain%whalo = whalosz; domain%ehalo = ehalosz
domain%shalo = shalosz; domain%nhalo = nhalosz
allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
domain%update_T%next => NULL()
domain%update_E%next => NULL()
domain%update_C%next => NULL()
domain%update_N%next => NULL()
allocate(domain%check_E, domain%check_C, domain%check_N )
domain%update_T%nsend = 0
domain%update_T%nrecv = 0
domain%update_C%nsend = 0
domain%update_C%nrecv = 0
domain%update_E%nsend = 0
domain%update_E%nrecv = 0
domain%update_N%nsend = 0
domain%update_N%nrecv = 0
if( BTEST(domain%fold,SOUTH) ) then
call compute_overlaps_fold_south(domain, CENTER, 0, 0)
call compute_overlaps_fold_south(domain, CORNER, ishift, jshift)
call compute_overlaps_fold_south(domain, EAST, ishift, 0)
call compute_overlaps_fold_south(domain, NORTH, 0, jshift)
else if( BTEST(domain%fold,WEST) ) then
call compute_overlaps_fold_west(domain, CENTER, 0, 0)
call compute_overlaps_fold_west(domain, CORNER, ishift, jshift)
call compute_overlaps_fold_west(domain, EAST, ishift, 0)
call compute_overlaps_fold_west(domain, NORTH, 0, jshift)
else if( BTEST(domain%fold,EAST) ) then
call compute_overlaps_fold_east(domain, CENTER, 0, 0)
call compute_overlaps_fold_east(domain, CORNER, ishift, jshift)
call compute_overlaps_fold_east(domain, EAST, ishift, 0)
call compute_overlaps_fold_east(domain, NORTH, 0, jshift)
else
call compute_overlaps(domain, CENTER, domain%update_T, check_T, 0, 0, x_offset, y_offset, &
domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
call compute_overlaps(domain, CORNER, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
call compute_overlaps(domain, EAST, domain%update_E, domain%check_E, ishift, 0, x_offset, y_offset, &
domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
call compute_overlaps(domain, NORTH, domain%update_N, domain%check_N, 0, jshift, x_offset, y_offset, &
domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
endif
call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_domains")
call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_domains")
call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_domains")
call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_domains")
!--- when ncontacts is nonzero, set_check_overlap will be called in mpp_define
if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
call set_check_overlap( domain, CORNER )
call set_check_overlap( domain, EAST )
call set_check_overlap( domain, NORTH )
allocate(domain%bound_E, domain%bound_C, domain%bound_N )
call set_bound_overlap( domain, CORNER )
call set_bound_overlap( domain, EAST )
call set_bound_overlap( domain, NORTH )
end if
call set_domain_comm_inf(domain%update_T)
call set_domain_comm_inf(domain%update_E)
call set_domain_comm_inf(domain%update_C)
call set_domain_comm_inf(domain%update_N)
end if
!--- check the send and recv size are matching.
!--- or ntiles>1 mosaic,
!--- the check will be done in mpp_define_mosaic
if(debug_message_passing .and. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
send = .true.
recv = .true.
call check_message_size(domain, domain%update_T, send, recv, 'T')
call check_message_size(domain, domain%update_E, send, recv, 'E')
call check_message_size(domain, domain%update_C, send, recv, 'C')
call check_message_size(domain, domain%update_N, send, recv, 'N')
endif
!print out decomposition, this didn't consider maskmap.
if( mpp_pe() .EQ. pes(0) .AND. PRESENT(name) )then
write(*,*) trim(name)//' domain decomposition'
write(*,'(a,i4,a,i4,a,i4,a,i4)')'whalo = ', whalosz, ", ehalo = ", ehalosz, ", shalo = ", shalosz, ", nhalo = ", nhalosz
write (*,110) (domain%x(1)%list(i)%compute%size, i= 0, layout(1)-1)
write (*,120) (domain%y(1)%list(i)%compute%size, i= 0, layout(2)-1)
110 format (' X-AXIS = ',24i4,/,(11x,24i4))
120 format (' Y-AXIS = ',24i4,/,(11x,24i4))
endif
deallocate( pes, pesall)
return
end subroutine mpp_define_domains2D
!#####################################################################
subroutine check_message_size(domain, update, send, recv, position)
type(domain2d), intent(in) :: domain
type(overlapSpec), intent(in) :: update
logical, intent(in) :: send(:)
logical, intent(in) :: recv(:)
character, intent(in) :: position
integer, dimension(0:size(domain%list(:))-1) :: msg1, msg2, msg3
integer :: m, n, l, dir, is, ie, js, je, from_pe, msgsize
integer :: nlist
nlist = size(domain%list(:))
msg1 = 0
msg2 = 0
do m = 1, update%nrecv
msgsize = 0
do n = 1, update%recv(m)%count
dir = update%recv(m)%dir(n)
if( recv(dir) ) then
is = update%recv(m)%is(n); ie = update%recv(m)%ie(n)
js = update%recv(m)%js(n); je = update%recv(m)%je(n)
msgsize = msgsize + (ie-is+1)*(je-js+1)
endif
end do
from_pe = update%recv(m)%pe
l = from_pe-mpp_root_pe()
call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1)
msg2(l) = msgsize
enddo
do m = 1, update%nsend
msgsize = 0
do n = 1, update%send(m)%count
dir = update%send(m)%dir(n)
if(send(dir))then
is = update%send(m)%is(n); ie = update%send(m)%ie(n)
js = update%send(m)%js(n); je = update%send(m)%je(n)
msgsize = msgsize + (ie-is+1)*(je-js+1)
endif
end do
l = update%send(m)%pe-mpp_root_pe()
msg3(l) = msgsize
call mpp_send( msg3(l), plen=1, to_pe=update%send(m)%pe, tag=COMM_TAG_1)
enddo
call mpp_sync_self(check=EVENT_RECV)
do m = 0, nlist-1
if(msg1(m) .NE. msg2(m)) then
print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",at position=",position,",from pe=", &
domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
call mpp_error(FATAL, "mpp_define_domains2D: mismatch on send and recv size")
endif
enddo
call mpp_sync_self()
end subroutine check_message_size
!#####################################################################
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! MPP_define_mosaic: define mosaic domain !
! NOTE: xflags and yflags is not in mpp_define_mosaic, because such relation !
! are already defined in the mosaic relation. !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!??? do we need optional argument xextent and yextent
!??? how to specify pelist, we may use two dimensional variable pelist to represent.
!z1l: We assume the tilelist are in always limited to 1, 2, ... num_tile. If we want
! to remove this limitation, we need to add one more argument tilelist.
subroutine mpp_define_mosaic( global_indices, layout, domain, num_tile, num_contact, tile1, tile2, &
istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, &
maskmap, name, memory_size, symmetry, xflags, yflags, tile_id )
integer, intent(in) :: global_indices(:,:) ! The size of first indice is 4, (/ isg, ieg, jsg, jeg /)
! The size of second indice is number of tiles in mosaic.
integer, intent(in) :: layout(:,:)
type(domain2D), intent(inout) :: domain
integer, intent(in) :: num_tile ! number of tiles in the mosaic
integer, intent(in) :: num_contact ! number of contact region between tiles.
integer, intent(in) :: tile1(:), tile2(:) ! tile number
integer, intent(in) :: istart1(:), iend1(:) ! i-index in tile_1 of contact region
integer, intent(in) :: jstart1(:), jend1(:) ! j-index in tile_1 of contact region
integer, intent(in) :: istart2(:), iend2(:) ! i-index in tile_2 of contact region
integer, intent(in) :: jstart2(:), jend2(:) ! j-index in tile_2 of contact region
integer, intent(in) :: pe_start(:) ! start pe of the pelist used in each tile
integer, intent(in) :: pe_end(:) ! end pe of the pelist used in each tile
integer, intent(in), optional :: pelist(:) ! list of processors used in mosaic
integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
integer, intent(in), optional :: xextent(:,:), yextent(:,:)
logical, intent(in), optional :: maskmap(:,:,:)
character(len=*), intent(in), optional :: name
integer, intent(in), optional :: memory_size(2)
logical, intent(in), optional :: symmetry
integer, intent(in), optional :: xflags, yflags
integer, intent(in), optional :: tile_id(:) ! tile_id of each tile in the mosaic
integer :: n, m, ndivx, ndivy, nc, nlist, nt, pos, n1, n2
integer :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz, t1, t2, tile
integer :: flags_x, flags_y
logical, allocatable :: mask(:,:)
integer, allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
integer, allocatable :: tile_id_local(:)
logical :: is_symmetry
integer, allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
integer, allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:)
real, allocatable :: refine1(:), refine2(:)
type(overlapSpec), pointer :: update=>NULL()
character(len=1) :: position
integer :: msgsize, l, p, is, ie, js, je, from_pe
integer, allocatable :: msg1(:), msg2(:), msg3(:)
integer :: outunit
logical :: send(8), recv(8)
outunit = stdout()
mosaic_defined = .true.
!--- the size of first indice of global_indices must be 4.
if(size(global_indices, 1) .NE. 4) call mpp_error(FATAL, &
'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
!--- the size of second indice of global_indices must be num_tile
if(size(global_indices, 2) .NE. num_tile) call mpp_error(FATAL, &
'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
!--- the size of first indice of layout must be 2. The second dimension size of layout must equal num_tile.
if(size(layout, 1) .NE. 2) call mpp_error(FATAL, &
'mpp_domains_define.inc: The size of first dimension of layout is not 2')
if(size(layout,2) .NE. num_tile) call mpp_error(FATAL, &
'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
!--- setup pelist for the mosaic ---------------------
nlist = mpp_npes()
allocate(pes(0:nlist-1))
if(present(pelist)) then
if( nlist .NE. size(pelist(:))) call mpp_error(FATAL, &
'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
pes = pelist
else
call mpp_get_current_pelist(pes)
end if
!--- pelist should be monotonic increasing by 1.
do n = 1, nlist-1
if(pes(n) - pes(n-1) .NE. 1) call mpp_error(FATAL, &
'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
end do
is_symmetry = .FALSE.
if(present(symmetry)) is_symmetry = symmetry
if(size(pe_start(:)) .NE. num_tile .OR. size(pe_end(:)) .NE. num_tile ) call mpp_error(FATAL, &
'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
!--- make sure pe_start and pe_end is in the pelist.
if( ANY( pe_start < pes(0) ) ) call mpp_error(FATAL, 'mpp_domains_define.inc: not all the pe_start are in the pelist')
if( ANY( pe_end > pes(nlist-1)) ) call mpp_error(FATAL, 'mpp_domains_define.inc: not all the pe_end are in the pelist')
!--- calculate number of tiles on each pe.
allocate( ntile_per_pe(0:nlist-1) )
ntile_per_pe = 0
do n = 1, num_tile
do m = pe_start(n) - mpp_root_pe(), pe_end(n) - mpp_root_pe()
ntile_per_pe(m) = ntile_per_pe(m) + 1
end do
end do
if(ANY(ntile_per_pe == 0)) call mpp_error(FATAL, &
'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
!--- check the size comformable of xextent and yextent
if( PRESENT(xextent) ) then
if(size(xextent,1) .GT. maxval(layout(1,:)) ) call mpp_error(FATAL, &
'mpp_domains_define.inc: size mismatch between xextent and layout')
if(size(xextent,2) .NE. num_tile) call mpp_error(FATAL, &
'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
end if
if( PRESENT(yextent) ) then
if(size(yextent,1) .GT. maxval(layout(2,:)) ) call mpp_error(FATAL, &
'mpp_domains_define.inc: size mismatch between yextent and layout')
if(size(yextent,2) .NE. num_tile) call mpp_error(FATAL, &
'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
end if
!--- check the size comformable of maskmap
!--- since the layout is different between tiles, so the actual size of maskmap for each tile is
!--- not diffrent. When define maskmap for multiple tiles, user can choose the maximum value
!--- of layout of all tiles to the first and second dimension of maskmap.
if(present(maskmap)) then
if(size(maskmap,1) .GT. maxval(layout(1,:)) .or. size(maskmap,2) .GT. maxval(layout(2,:))) &
call mpp_error(FATAL, 'mpp_domains_define.inc: size mismatch between maskmap and layout')
if(size(maskmap,3) .NE. num_tile) call mpp_error(FATAL, &
'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
end if
allocate(domain%tileList(num_tile))
do n = 1, num_tile
domain%tileList(n)%xbegin = global_indices(1,n)
domain%tileList(n)%xend = global_indices(2,n)
domain%tileList(n)%ybegin = global_indices(3,n)
domain%tileList(n)%yend = global_indices(4,n)
enddo
!--- define some mosaic information in domain type
nt = ntile_per_pe(mpp_pe()-mpp_root_pe())
allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) )
allocate(domain%list(0:nlist-1))
do n = 0, nlist-1
nt = ntile_per_pe(n)
allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt) )
end do
pe = mpp_pe()
pos = 0
if( PRESENT(tile_id) ) then
if(size(tile_id(:)) .NE. num_tile) then
call mpp_error(FATAL, "mpp_domains_define.inc: size(tile_id) .NE. num_tile")
endif
endif
allocate(tile_id_local(num_tile))
!These directives are a work-around for a bug in the CCE compiler, which
!causes a segmentation fault when the compiler attempts to vectorize a
!loop containing an optional argument (when -g is included).
!DIR$ NOVECTOR
do n = 1, num_tile
if(PRESENT(tile_id)) then
tile_id_local(n) = tile_id(n)
else
tile_id_local(n) = n
endif
enddo
!DIR$ VECTOR
do n = 1, num_tile
if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n)) then
pos = pos + 1
domain%tile_id(pos) = tile_id_local(n)
end if
end do
domain%initialized = .true.
domain%rotated_ninety = .FALSE.
domain%ntiles = num_tile
domain%max_ntile_pe = maxval(ntile_per_pe)
domain%ncontacts = num_contact
deallocate(ntile_per_pe)
!---call mpp_define_domain to define domain decomposition for each tile.
allocate(tile_count(pes(0):pes(0)+nlist-1))
tile_count = 0 ! tile number on current pe
do n = 1, num_tile
allocate(mask(layout(1,n), layout(2,n)))
allocate(pelist_tile(pe_start(n):pe_end(n)) )
tile_count(pe_start(n)) = tile_count(pe_start(n)) + 1
do m = pe_start(n), pe_end(n)
pelist_tile(m) = m
end do
mask = .TRUE.
if(present(maskmap)) mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
ndivx = layout(1,n); ndivy = layout(2,n)
allocate(xext(ndivx), yext(ndivy))
xext = 0; yext = 0
if(present(xextent)) xext = xextent(1:ndivx,n)
if(present(yextent)) yext = yextent(1:ndivy,n)
! when num_tile is one, we assume only folded_north and cyclic_x, cyclic_y boundary condition is the possible
! z1l: when we decide to support multiple-tile tripolar grid, we will redesign the following part.
if(num_tile == 1) then
flags_x = 0
flags_y = 0
if(PRESENT(xflags)) flags_x = xflags
if(PRESENT(yflags)) flags_y = yflags
do m = 1, num_contact
if(istart1(m) == iend1(m) ) then ! x-direction contact, possible cyclic, folded-west or folded-east
if(istart2(m) .NE. iend2(m) ) call mpp_error(FATAL, &
"mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
if(istart1(m) == istart2(m) ) then ! folded west or folded east
if(istart1(m) == global_indices(1,n) ) then
if(.NOT. BTEST(flags_x,WEST) ) flags_x = flags_x + FOLD_WEST_EDGE
else if(istart1(m) == global_indices(2,n) ) then
if(.NOT. BTEST(flags_x,EAST) ) flags_x = flags_x + FOLD_EAST_EDGE
else
call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
"istart1 should equal global_indices(1) or global_indices(2)")
endif
else
if(.NOT. BTEST(flags_x,CYCLIC)) flags_x = flags_x + CYCLIC_GLOBAL_DOMAIN
endif
else if( jstart1(m) == jend1(m) ) then ! y-direction contact, cyclic, folded-south or folded-north
if(jstart2(m) .NE. jend2(m) ) call mpp_error(FATAL, &
"mpp_domains_define: for one tile mosaic, when jstart1=jend1, jstart2 must equal jend2")
if(jstart1(m) == jstart2(m) ) then ! folded south or folded north
if(jstart1(m) == global_indices(3,n) ) then
if(.NOT. BTEST(flags_y,SOUTH) ) flags_y = flags_y + FOLD_SOUTH_EDGE
else if(jstart1(m) == global_indices(4,n) ) then
if(.NOT. BTEST(flags_y,NORTH) ) flags_y = flags_y + FOLD_NORTH_EDGE
else
call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
"istart1 should equal global_indices(1) or global_indices(2)")
endif
else
if(.NOT. BTEST(flags_y,CYCLIC)) flags_y = flags_y + CYCLIC_GLOBAL_DOMAIN
end if
else
call mpp_error(FATAL, &
"mpp_domains_define: for one tile mosaic, invalid boundary contact")
end if
end do
call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, xflags = flags_x, &
yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
xextent=xext, yextent=yext, maskmap=mask, name=name, symmetry=is_symmetry, &
memory_size = memory_size, is_mosaic = .true., tile_id=tile_id_local(n))
else
call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, &
whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
maskmap=mask, name=name, symmetry=is_symmetry, memory_size = memory_size, &
is_mosaic = .true., tile_count = tile_count(pe_start(n)), tile_id=tile_id_local(n), &
complete = n==num_tile)
end if
deallocate(mask, xext, yext, pelist_tile)
end do
deallocate(pes, tile_count)
if(num_contact == 0 .OR. num_tile == 1) return
!--- loop through each contact region and find the contact for each tile ( including alignment )
!--- we assume the tiles list is continuous and starting from 1.
allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
allocate(isgList(num_tile), iegList(num_tile), jsgList(num_tile), jegList(num_tile) )
allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
!--- get the global domain for each tile
do n = 1, num_tile
isgList(n) = domain%tileList(n)%xbegin; iegList(n) = domain%tileList(n)%xend
jsgList(n) = domain%tileList(n)%ybegin; jegList(n) = domain%tileList(n)%yend
end do
!--- transfer the contact index to domain index.
nc = 0
do n = 1, num_contact
t1 = tile1(n)
t2 = tile2(n)
is1(n) = istart1(n) + isgList(t1) - 1; ie1(n) = iend1(n) + isgList(t1) - 1
js1(n) = jstart1(n) + jsgList(t1) - 1; je1(n) = jend1(n) + jsgList(t1) - 1
is2(n) = istart2(n) + isgList(t2) - 1; ie2(n) = iend2(n) + isgList(t2) - 1
js2(n) = jstart2(n) + jsgList(t2) - 1; je2(n) = jend2(n) + jsgList(t2) - 1
call check_alignment( is1(n), ie1(n), js1(n), je1(n), isgList(t1), iegList(t1), jsgList(t1), jegList(t1), align1(n))
call check_alignment( is2(n), ie2(n), js2(n), je2(n), isgList(t2), iegList(t2), jsgList(t2), jegList(t2), align2(n))
if( (align1(n) == WEST .or. align1(n) == EAST ) .NEQV. (align2(n) == WEST .or. align2(n) == EAST ) )&
domain%rotated_ninety=.true.
end do
!--- calculate the refinement ratio between tiles
do n = 1, num_contact
n1 = max(abs(iend1(n) - istart1(n)), abs(jend1(n) - jstart1(n)) ) + 1
n2 = max(abs(iend2(n) - istart2(n)), abs(jend2(n) - jstart2(n)) ) + 1
refine1(n) = real(n2)/n1
refine2(n) = real(n1)/n2
end do
whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
if(present(whalo)) whalosz = whalo
if(present(ehalo)) ehalosz = ehalo
if(present(shalo)) shalosz = shalo
if(present(nhalo)) nhalosz = nhalo
xhalosz = max(whalosz, ehalosz)
yhalosz = max(shalosz, nhalosz)
!--- computing the overlap for the contact region with halo size xhalosz and yhalosz
call define_contact_point( domain, CENTER, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
is1, ie1, js1, je1, is2, ie2, js2, je2, isgList, iegList, jsgList, jegList )
call set_contact_point( domain, CORNER )
call set_contact_point( domain, EAST )
call set_contact_point( domain, NORTH )
call set_domain_comm_inf(domain%update_T)
call set_domain_comm_inf(domain%update_E)
call set_domain_comm_inf(domain%update_C)
call set_domain_comm_inf(domain%update_N)
!--- goffset setting is needed for exact global sum
do m = 1, size(domain%tile_id(:))
tile = domain%tile_id(m)
do n = 1, num_contact
if( tile1(n) == tile ) then
if(align1(n) == EAST ) domain%x(m)%goffset = 0
if(align1(n) == NORTH) domain%y(m)%goffset = 0
end if
if( tile2(n) == tile ) then
if(align2(n) == EAST ) domain%x(m)%goffset = 0
if(align2(n) == NORTH) domain%y(m)%goffset = 0
end if
end do
end do
call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_mosaic")
call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_mosaic")
call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_mosaic")
call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_mosaic")
!--- set the overlapping for boundary check if domain is symmetry
if(debug_update_level .NE. NO_CHECK) then
call set_check_overlap( domain, CORNER )
call set_check_overlap( domain, EAST )
call set_check_overlap( domain, NORTH )
endif
if(domain%symmetry) then
allocate(domain%bound_E, domain%bound_C, domain%bound_N )
call set_bound_overlap( domain, CORNER )
call set_bound_overlap( domain, EAST )
call set_bound_overlap( domain, NORTH )
call check_overlap_pe_order(domain, domain%bound_C, trim(domain%name)//" bound_C")
call check_overlap_pe_order(domain, domain%bound_E, trim(domain%name)//" bound_E")
call check_overlap_pe_order(domain, domain%bound_N, trim(domain%name)//" bound_N")
end if
!--- check the send and recv size are matching.
!--- currently only check T and C-cell. For ntiles>1 mosaic,
!--- the check will be done in mpp_define_mosaic
if(debug_message_passing) then
send = .true.
recv = .true.
call check_message_size(domain, domain%update_T, send, recv, 'T')
call check_message_size(domain, domain%update_C, send, recv, 'C')
call check_message_size(domain, domain%update_E, send, recv, 'E')
call check_message_size(domain, domain%update_N, send, recv, 'N')
endif
!--- release memory
deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2 )
deallocate(isgList, iegList, jsgList, jegList, refine1, refine2 )
end subroutine mpp_define_mosaic
!#####################################################################
logical function mpp_mosaic_defined()
! Accessor function for value of mosaic_defined
mpp_mosaic_defined = mosaic_defined
end function mpp_mosaic_defined
!#####################################################################
subroutine compute_overlaps( domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
whalo, ehalo, shalo, nhalo )
!computes remote domain overlaps
!assumes only one in each direction
!will calculate the overlapping for T,E,C,N-cell seperately.
type(domain2D), intent(inout) :: domain
type(overlapSpec), intent(inout), pointer :: update
type(overlapSpec), intent(inout), pointer :: check
integer, intent(in) :: position, ishift, jshift
integer, intent(in) :: x_cyclic_offset, y_cyclic_offset
integer, intent(in) :: whalo, ehalo, shalo, nhalo
integer :: i, m, n, nlist, tMe, tNbr, dir
integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
integer :: isg, ieg, jsg, jeg, ioff, joff
integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
integer :: ism, iem, jsm, jem
integer :: is2, ie2, js2, je2
integer :: is3, ie3, js3, je3
integer :: isd3, ied3, jsd3, jed3
integer :: isd2, ied2, jsd2, jed2
logical :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
type(overlap_type) :: overlap
type(overlap_type), pointer :: overlapList(:)=>NULL()
type(overlap_type), pointer :: checkList(:)=>NULL()
integer :: nsend, nrecv
integer :: nsend_check, nrecv_check
integer :: unit
logical :: set_check
!--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
!--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
!--- In this case the overlapping exist only for tMe=1 and tNbr=1
if(size(domain%x(:)) > 1) return
!--- if there is no halo, no need to compute overlaps.
if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0) return
!--- when there is only one tile, n will equal to np
nlist = size(domain%list(:))
set_check = .false.
if(ASSOCIATED(check)) set_check = .true.
allocate(overlapList(MAXLIST) )
if(set_check) allocate(checkList(MAXLIST) )
!--- overlap is used to store the overlapping temporarily.
call allocate_update_overlap( overlap, MAXOVERLAP)
!send
call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
update%xbegin = ism; update%xend = iem
update%ybegin = jsm; update%yend = jem
if(set_check) then
check%xbegin = ism; check%xend = iem
check%ybegin = jsm; check%yend = jem
endif
update%whalo = whalo; update%ehalo = ehalo
update%shalo = shalo; update%nhalo = nhalo
ioff = ni - ishift
joff = nj - jshift
middle = (isg+ieg)/2+1
tMe = 1; tNbr = 1
folded_north = BTEST(domain%fold,NORTH)
if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,EAST) .OR. BTEST(domain%fold,WEST) ) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition " // &
"is not supported, please use other version of compute_overlaps for "//trim(domain%name))
endif
nsend = 0
nsend_check = 0
do list = 0,nlist-1
m = mod( domain%pos+list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
!to_pe's eastern halo
dir = 1
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
!--- to make sure the consistence between pes
if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
.AND. ( jsc == je .or. jec == js ) ) then
!--- do nothing, this point will come from other pe
else
!--- when the north face is folded, the east halo point at right side domain will be folded.
!--- the position should be on CORNER or NORTH
if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
else
if( ie.GT.ieg ) then
if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
is = is-ioff; ie = ie-ioff
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
endif
endif
end if
!to_pe's SE halo
dir = 2
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
!--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
!--- the other part is both are zero.
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if(je .LT. jsg) then ! js .LT. jsg
if( domain%y(tMe)%cyclic ) then
js = js + joff; je = je + joff
endif
else if(js .Lt. jsg) then ! split into two parts
if( domain%y(tMe)%cyclic ) then
js2 = js + joff; je2 = jsg-1+joff
js = jsg;
endif
endif
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
else
if( ie.GT.ieg )then
if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
is = is-ioff; ie = ie-ioff
need_adjust_1 = .false.
if(jsg .GT. js) then
if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
end if
end if
else
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
need_adjust_3 = .false.
end if
end if
end if
if( need_adjust_3 .AND. jsg.GT.js )then
if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
if(need_adjust_1 .AND. ie.LE.ieg) then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
end if
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
endif
!to_pe's southern halo
dir = 3
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
js2 = 0; je2 = -1
if( jsg.GT.je )then ! jsg .GT. js
if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
end if
else if (jsg .GT. js) then ! split into two parts
if( domain%y(tMe)%cyclic) then
js2 = js + joff; je2 = jsg-1+joff
js = jsg
endif
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
!to_pe's SW halo
dir = 4
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if(je .LT. jsg) then ! js .LT. jsg
if( domain%y(tMe)%cyclic ) then
js = js + joff; je = je + joff
endif
else if(js .Lt. jsg) then ! split into two parts
if( domain%y(tMe)%cyclic ) then
js2 = js + joff; je2 = jsg-1+joff
js = jsg;
endif
endif
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
else
if( isg.GT.is )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
is = is+ioff; ie = ie+ioff
need_adjust_1 = .false.
if(jsg .GT. js) then
if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
end if
end if
else
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
need_adjust_3 = .false.
end if
end if
end if
if( need_adjust_3 .AND. jsg.GT.js )then
if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
if(need_adjust_1 .AND. isg.LE.is )then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
end if
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
endif
!to_pe's western halo
dir = 5
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
!--- when the north face is folded, some point at j=nj will be folded.
!--- the position should be on CORNER or NORTH
if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
else
if( isg.GT.is )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
is = is+ioff; ie = ie+ioff
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
endif
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
end if
end if
!to_pe's NW halo
dir = 6
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
is3 = 0; ie3 = -1; js3 = 0; je3 = -1
folded = .FALSE.
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if(js .GT. jeg) then ! je > jeg
if( domain%y(tMe)%cyclic ) then
js = js-joff; je = je-joff
else if(folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
endif
else if(je .GT. jeg) then ! split into two parts
if( domain%y(tMe)%cyclic ) then
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1-joff; je = je -joff
else if(folded_north) then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
if( is .GT. ieg) then
is = is - ioff; ie = ie - ioff
else if( ie .GT. ieg ) then
is3 = is; ie3 = ieg; js3 = js; je3 = je
is = ieg+1-ioff; ie = ie - ioff
endif
endif
endif
if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
endif
if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
if(ie2 .GE. is2) then
if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
endif
endif
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( isg.GT.is )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
is = is+ioff; ie = ie+ioff
need_adjust_1 = .false.
if(je .GT. jeg) then
if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
js = js-joff; je = je-joff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
end if
end if
else
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
need_adjust_3 = .false.
end if
end if
end if
folded = .FALSE.
if( need_adjust_3 .AND. je.GT.jeg )then
if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
js = js-joff; je = je-joff
if( need_adjust_1 .AND. isg.LE.is)then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
end if
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir)
endif
!to_pe's northern halo
dir = 7
folded = .FALSE.
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
!--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
!--- no need to send, because the data on that point will come from other pe.
!--- come from two pe ( there will be only one point on one pe. ).
if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
.AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) ) then
!--- do nothing, this point will come from other pe
else
js2 = -1; je2 = 0
if( js .GT. jeg) then ! je .GT. jeg
if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
js = js-joff; je = je-joff
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
else if( je.GT.jeg )then ! split into two parts
if( domain%y(tMe)%cyclic)then !try cyclic offset
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1-joff; je = je - joff
else if( folded_north )then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1;
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
else
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, domain%symmetry)
endif
else
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
endif
if(ie2 .GE. is2) then
if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
else
call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
endif
endif
end if
!--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
! is = is + ioff
! call insert_update_overlap( overlap, domain%list(m)%pe, &
! is, is, js, je, isc, iec, jsc, jec, dir, folded)
!??? if(je2 .GE. js2)call insert_update_overlap( overlap, domain%list(m)%pe, &
! is, is, js2, je2, isc, iec, jsc, jec, dir, folded)
endif
!--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
!--- for folded-north-edge, only need to consider to_pe's north(7) direction
!--- only position at NORTH and CORNER need to be considered
if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
.AND. domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 ) then
if( domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .GE. jeg .AND. isc .LE. middle)then
js = jeg; je = jeg
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
is = max(is, middle)
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
endif
if(debug_update_level .NE. NO_CHECK .AND. set_check) then
je = domain%list(m)%y(tNbr)%compute%end+jshift;
if(je == jeg) then
is = max(is, isc); ie = min(ie, iec)
js = max(js, jsc); je = min(je, jec)
if(ie.GE.is .AND. je.GE.js )then
nsend_check = nsend_check+1
if(nsend_check > size(checkList(:)) ) then
call expand_check_overlap_list(checkList, nlist)
endif
call allocate_check_overlap(checkList(nsend_check), 1)
call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
end if
end if
endif
endif
!to_pe's NE halo
dir = 8
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
is2 = 0; ie2=-1; js2=0; je2=-1
is3 = 0; ie3 = -1; js3 = 0; je3 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
folded = .FALSE.
if(js .GT. jeg) then ! je > jeg
if( domain%y(tMe)%cyclic ) then
js = js-joff; je = je-joff
else if(folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
endif
else if(je .GT. jeg) then ! split into two parts
if( domain%y(tMe)%cyclic ) then
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1-joff; je = je -joff
else if(folded_north) then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = jeg
js = jeg+1
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
if( ie .LT. isg )then
is = is+ioff; ie = ie+ioff
else if( is .LT. isg) then
is3 = isg; ie3 = ie; js3 = js; je3 = je
is = is+ioff; ie = isg-1+ioff;
endif
endif
endif
if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
endif
if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
if(ie2 .GE. is2) then
if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
endif
endif
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( ie.GT.ieg )then
if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
is = is-ioff; ie = ie-ioff
need_adjust_1 = .false.
if(je .GT. jeg) then
if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
js = js-joff; je = je-joff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
end if
end if
else
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
need_adjust_3 = .false.
end if
end if
end if
folded = .false.
if( need_adjust_3 .AND. je.GT.jeg )then
if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
js = js-joff; je = je-joff
if( need_adjust_1 .AND. ie.LE.ieg)then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
end if
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir)
endif
endif
!--- copy the overlapping information
if( overlap%count > 0) then
nsend = nsend + 1
if(nsend > size(overlapList(:)) ) then
call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for send is expanded')
call expand_update_overlap_list(overlapList, nlist)
endif
call add_update_overlap( overlapList(nsend), overlap)
call init_overlap_type(overlap)
endif
end do ! end of send set up.
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nsend
write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if(nsend >0) call flush(unit)
endif
! copy the overlapping information into domain data structure
if(nsend>0) then
allocate(update%send(nsend))
update%nsend = nsend
do m = 1, nsend
call add_update_overlap( update%send(m), overlapList(m) )
enddo
endif
if(nsend_check>0) then
check%nsend = nsend_check
allocate(check%send(nsend_check))
do m = 1, nsend_check
call add_check_overlap( check%send(m), checkList(m) )
enddo
endif
do m = 1,size(overlapList(:))
call deallocate_overlap_type(overlapList(m))
enddo
if(debug_update_level .NE. NO_CHECK .AND. set_check) then
do m = 1,size(checkList(:))
call deallocate_overlap_type(checkList(m))
enddo
endif
isgd = isg - domain%whalo
iegd = ieg + domain%ehalo
jsgd = jsg - domain%shalo
jegd = jeg + domain%nhalo
! begin setting up recv
nrecv = 0
nrecv_check = 0
do list = 0,nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
!recv_e
dir = 1
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
.AND. ( jsd == je .or. jed == js ) ) then
! --- do nothing, this point will come from other pe
else
!--- when the north face is folded, the east halo point at right side domain will be folded.
!--- the position should be on CORNER or NORTH
if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle)
else
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
else
if( ied.GT.ieg )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
is = is+ioff; ie = ie+ioff
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
endif
endif
endif
!recv_se
dir = 2
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
!--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
!--- the other part is both are zero.
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if(jed .LT. jsg) then ! then jsd < jsg
if( domain%y(tMe)%cyclic ) then
js = js-joff; je = je-joff
endif
else if(jsd .LT. jsg) then !split into two parts
if( domain%y(tMe)%cyclic ) then
js2 = js-joff; je2 = je-joff
endif
endif
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
if(je2 .GE. js2) call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( jsd.LT.jsg )then
if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
js = js-joff; je = je-joff
need_adjust_1 = .false.
if( ied.GT.ieg )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
is = is+ioff; ie = ie+ioff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsgd, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, iegd, ni)
end if
end if
else
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
need_adjust_3 = .false.
end if
end if
end if
if( need_adjust_3 .AND. ied.GT.ieg )then
if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
is = is+ioff; ie = ie+ioff
if( need_adjust_1 .AND. jsd.GE.jsg )then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
end if
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
endif
!recv_s
dir = 3
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
js2 = 0; je2 = -1
if( jed .LT. jsg) then ! jsd < jsg
if( domain%y(tMe)%cyclic ) then
js = js-joff; je = je-joff
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
endif
else if( jsd.LT.jsg )then ! split into two parts
if( domain%y(tMe)%cyclic)then !try cyclic offset
js2 = js-joff; je2 = je-joff
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
!recv_sw
dir = 4
isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
if( ied.LT.isg )then ! isd < isg
if( domain%x(tMe)%cyclic ) then
is = is-ioff; ie = ie-ioff
endif
else if (isd.LT.isg )then ! split into two parts
if( domain%x(tMe)%cyclic ) then
is2 = is-ioff; ie2 = ie-ioff
endif
endif
if( jed.LT.jsg )then ! jsd < jsg
if( domain%y(tMe)%cyclic ) then
js = js-joff; je = je-joff
endif
else if( jsd.LT.jsg )then ! split into two parts
if( domain%y(tMe)%cyclic ) then
js2 = js-joff; je2 = je-joff
endif
endif
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( jsd.LT.jsg )then
if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
js = js-joff; je = je-joff
need_adjust_1 = .false.
if( isd.LT.isg )then
if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
is = is-ioff; ie = ie-ioff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsgd, jeg, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isgd, ieg, ni)
end if
end if
else
call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
need_adjust_3 = .false.
end if
end if
end if
if( need_adjust_3 .AND. isd.LT.isg )then
if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
is = is-ioff; ie = ie-ioff
if(need_adjust_1 .AND. jsd.GE.jsg) then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
end if
end if
end if
endif
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
if(ie2 .GE. is2)call fill_overlap(overlap, domain, m, is2, ie2, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
if(je2 .GE. js2)call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
if(ie2 .GE. is2 .AND. je2 .GE. js2)call fill_overlap(overlap, domain, m, is2, ie2, js2, je2, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
!recv_w
dir = 5
isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
!--- when the north face is folded, some point at j=nj will be folded.
!--- the position should be on CORNER or NORTH
if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle)
else
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
else
if( isd.LT.isg )then
if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
is = is-ioff; ie = ie-ioff
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
endif
endif
!recv_nw
dir = 6
folded = .false.
isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
is=isc; ie=iec; js=jsc; je=jec
is2 = 0; ie2 = -1; js2 = 0; je2 = -1
is3 = 0; ie3 = -1; js3 = 0; je3 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
js2 = -1; je2 = 0
if( jsd .GT. jeg ) then ! jed > jeg
if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
js = js+joff; je = je+joff
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
else if( jed.GT.jeg )then ! split into two parts
if( domain%y(tMe)%cyclic)then !try cyclic offset
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
js = js + joff; je = je + joff
jsd = jeg+1
else if( folded_north )then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
jsd = jeg+1
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
if(isd < isg .and. ied .GE. isg .and. domain%symmetry) then
isd3 = isd; ied3 = isg-1
jsd3 = jsd; jed3 = jed
is3 = is-ioff; ie3=ie-ioff
js3 = js; je3 = je
isd = isg;
endif
end if
endif
if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
endif
if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
if(ie2 .GE. is2) then
if( jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
endif
endif
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( jed.GT.jeg )then
if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
js = js+joff; je = je+joff
need_adjust_1 = .false.
if( isd.LT.isg )then
if( domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
is = is-ioff; ie = ie-ioff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jegd, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isgd, ieg, ni)
end if
end if
else
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
need_adjust_3 = .false.
end if
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
if( need_adjust_3 .AND. isd.LT.isg )then
if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
is = is-ioff; ie = ie-ioff
if( need_adjust_1 .AND. jed.LE.jeg )then
call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
end if
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
endif
!--- when north edge is folded, is will be less than isg when position is EAST and CORNER
if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
is = is + ioff
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, is, js, je, isd, ied, jsd, jed, dir, folded )
endif
!recv_n
dir = 7
folded = .false.
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
is=isc; ie=iec; js=jsc; je=jec
!--- when domain symmetry and position is EAST or CORNER, the point at i=isd will
!--- come from two pe ( there will be only one point on one pe. ).
if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
.AND. (isd == ie .or. ied == is ) .AND. (.not. folded_north) ) then
!--- do nothing, this point will come from other pe
else
js2 = -1; je2 = 0
if( jsd .GT. jeg ) then ! jed > jeg
if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
js = js+joff; je = je+joff
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
else if( jed.GT.jeg )then ! split into two parts
if( domain%y(tMe)%cyclic)then !try cyclic offset
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
js = js + joff; je = je + joff
jsd = jeg+1
else if( folded_north )then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
jsd = jeg+1
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0) then
if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
else
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
endif
else
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
endif
if(ie2 .GE. is2) then
if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
else
call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
endif
endif
endif
!--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
! is = is + ioff
! call insert_update_overlap( overlap, domain%list(m)%pe, &
! is, is, js, je, isd, ied, jsd, jed, dir, folded)
endif
!--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
!--- for folded-north-edge, only need to consider to_pe's north(7) direction
!--- only position at NORTH and CORNER need to be considered
if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
.AND. domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2) then
if( jed .GE. jeg .AND. ied .GE. middle)then
jsd = jeg; jed = jeg
is=isc; ie=iec; js = jsc; je = jec
isd = max(isd, middle)
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
endif
if(debug_update_level .NE. NO_CHECK .AND. set_check) then
jsd = domain%y(tMe)%compute%end+jshift; jed = jsd
if(jed == jeg) then
is = max(is, isd); ie = min(ie, ied)
js = max(js, jsd); je = min(je, jed)
if(ie.GE.is .AND. je.GE.js )then
nrecv_check = nrecv_check+1
if(nrecv_check > size(checkList(:)) ) then
call expand_check_overlap_list(checkList, nlist)
endif
call allocate_check_overlap(checkList(nrecv_check), 1)
call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
end if
end if
endif
endif
!recv_ne
dir = 8
folded = .false.
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
is=isc; ie=iec; js=jsc; je=jec
is2 = 0; ie2=-1; js2=0; je2=-1
is3 = 0; ie3 = -1; js3 = 0; je3 = -1
if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
js2 = -1; je2 = 0
if( jsd .GT. jeg ) then ! jed > jeg
if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
js = js+joff; je = je+joff
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
else if( jed.GT.jeg )then ! split into two parts
if( domain%y(tMe)%cyclic)then !try cyclic offset
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
js = js + joff; je = je + joff
jsd = jeg+1
else if( folded_north )then
folded = .TRUE.
is2 = is; ie2 = ie; js2 = js; je2 = je
isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
jsd = jeg+1
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
if(ied > ieg .and. isd .LE. ieg .and. domain%symmetry) then
isd3 = ieg+1; ied3 = ied
jsd3 = jsd; jed3 = jed
is3 = is+ioff; ie3=ie+ioff
js3 = js; je3 = je
ied = ieg;
endif
end if
endif
if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
endif
if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
if(ie2 .GE. is2) then
if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
.AND. (position == CORNER .OR. position == NORTH)) then
call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ishift, position, ioff, middle)
else
call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
endif
endif
else
need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
if( jed.GT.jeg )then
if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
js = js+joff; je = je+joff
need_adjust_1 = .false.
if( ied.GT.ieg )then
if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
is = is+ioff; ie = ie+ioff
need_adjust_2 = .false.
if(x_cyclic_offset .NE. 0) then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jegd, nj)
else if(y_cyclic_offset .NE. 0) then
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, iegd, ni)
end if
end if
else
call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
need_adjust_3 = .false.
end if
else if( folded_north )then
folded = .TRUE.
call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
end if
end if
if( need_adjust_3 .AND. ied.GT.ieg )then
if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
is = is+ioff; ie = ie+ioff
if( need_adjust_1 .AND. jed.LE.jeg)then
call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
end if
end if
end if
call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, jsg, jeg, dir)
endif
endif
!--- copy the overlapping information
if( overlap%count > 0) then
nrecv = nrecv + 1
if(nrecv > size(overlapList(:)) )then
call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for recv is expanded')
call expand_update_overlap_list(overlapList, nlist)
endif
call add_update_overlap( overlapList(nrecv), overlap)
call init_overlap_type(overlap)
endif
enddo ! end of recv do loop
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nrecv
write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if(nrecv >0) call flush(unit)
endif
! copy the overlapping information into domain
if(nrecv>0) then
allocate(update%recv(nrecv))
update%nrecv = nrecv
do m = 1, nrecv
call add_update_overlap( update%recv(m), overlapList(m) )
do n = 1, update%recv(m)%count
if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
endif
enddo
enddo
endif
if(nrecv_check>0) then
check%nrecv = nrecv_check
allocate(check%recv(nrecv_check))
do m = 1, nrecv_check
call add_check_overlap( check%recv(m), checkList(m) )
enddo
endif
call deallocate_overlap_type(overlap)
do m = 1,size(overlapList(:))
call deallocate_overlap_type(overlapList(m))
enddo
if(debug_update_level .NE. NO_CHECK .AND. set_check) then
do m = 1,size(checkList(:))
call deallocate_overlap_type(checkList(m))
enddo
endif
deallocate(overlapList)
if(set_check) deallocate(checkList)
domain%initialized = .true.
end subroutine compute_overlaps
subroutine fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
type(overlap_type), intent(inout) :: overlap
type(domain2d), intent(inout) :: domain
integer, intent(in ) :: m, is, ie, js, je
integer, intent(in ) :: isc, iec, jsc, jec
integer, intent(in ) :: isg, ieg, dir, ioff
logical, intent(in ) :: is_cyclic
logical, optional, intent(in ) :: folded, symmetry
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
if(is_cyclic) then
if(ie .GT. ieg) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is-ioff, ie-ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
else if( is .LT. isg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is+ioff, ie+ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
endif
endif
end subroutine fill_overlap_send_nofold
!##################################################################################
subroutine fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, dir, ishift, position, ioff, middle, symmetry)
type(overlap_type), intent(inout) :: overlap
type(domain2d), intent(inout) :: domain
integer, intent(in ) :: m, is, ie, js, je
integer, intent(in ) :: isc, iec, jsc, jec
integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
logical, optional, intent(in ) :: symmetry
integer :: is1, ie1, is2, ie2, i
!--- consider at j = jeg for west edge.
!--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
if(position == CORNER .AND. .NOT. domain%symmetry .AND. is .LE. isg-1 .AND. ie .GE. isg-1) then
call insert_update_overlap(overlap, domain%list(m)%pe, &
isg-1+ioff, isg-1+ioff, je, je, isc, iec, jsc, jec, dir, .true.)
end if
is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
!--- east edge
if( is > ieg ) then
is2 = is-ioff; ie2 = ie-ioff
else if( ie > ieg ) then ! split into two parts
is1 = is; ie1 = ieg
is2 = ieg+1-ioff; ie2 = ie-ioff
else if( is .GE. middle ) then
is1 = is; ie1 = ie
else if( ie .GE. middle ) then ! split into two parts
is1 = middle; ie1 = ie
is2 = is; ie2 = middle-1
else if( ie < isg ) then ! west boundary
is1 = is+ieg-isg+1-ishift; ie1 = ie+ieg-isg+1-ishift
else if( is < isg ) then ! split into two parts
is1 = is+ieg-isg+1-ishift; ie1 = isg-1+ieg-isg+1-ishift
is2 = isg; ie2 = ie
else
is2 = is; ie2 = ie
endif
if( ie1 .GE. is1) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is1, ie1, js, je-1, isc, iec, jsc, jec, dir, symmetry=symmetry)
select case (position)
case(NORTH)
i=is1; is1 = isg+ieg-ie1; ie1 = isg+ieg-i
case(CORNER)
i=is1; is1 = isg+ieg-ie1-1+ishift; ie1 = isg+ieg-i-1+ishift
end select
call insert_update_overlap( overlap, domain%list(m)%pe, &
is1, ie1, je, je, isc, iec, jsc, jec, dir, .true., symmetry=symmetry)
endif
if(ie2 .GE. is2) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is2, ie2, js, je, isc, iec, jsc, jec, dir)
endif
end subroutine fill_overlap_send_fold
!#############################################################################
subroutine fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
type(overlap_type), intent(inout) :: overlap
type(domain2d), intent(inout) :: domain
integer, intent(in ) :: m, is, ie, js, je
integer, intent(in ) :: isd, ied, jsd, jed
integer, intent(in ) :: isg, ieg, dir, ioff
logical, intent(in ) :: is_cyclic
logical, optional, intent(in ) :: folded, symmetry
integer :: is1, ie1, is2, ie2
integer :: isd1, ied1, isd2, ied2
is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
isd1=isd; ied1=ied
isd2=isd; ied2=ied
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
if(is_cyclic) then
if(ied .GT. ieg) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
else if( isd .LT. isg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
else if ( is .LT. isg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
else if ( ie .GT. ieg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
endif
endif
end subroutine fill_overlap_recv_nofold
!#################################################################################
subroutine fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
isg, ieg, dir, ishift, position, ioff, middle, symmetry)
type(overlap_type), intent(inout) :: overlap
type(domain2d), intent(inout) :: domain
integer, intent(in ) :: m, is, ie, js, je
integer, intent(in ) :: isd, ied, jsd, jed
integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
logical, optional, intent(in ) :: symmetry
integer :: is1, ie1, is2, ie2, is3, ie3
integer :: isd1, ied1, isd2, ied2
!--- consider at j = jeg for west edge.
!--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
if( position == CORNER .AND. .NOT. domain%symmetry .AND. isd .LE. isg-1 .AND. ied .GE. isg-1 ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is-ioff, ie-ioff, js, je, isg-1, isg-1, jed, jed, dir, .true.)
end if
is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
isd1=isd; ied1=ied
isd2=isd; ied2=ied
select case (position)
case(NORTH)
is3 = isg+ieg-ie; ie3 = isg+ieg-is
case(CORNER)
is3 = isg+ieg-ie-1+ishift; ie3 = isg+ieg-is-1+ishift
end select
if(isd .GT. ieg) then ! east
is2 = is + ioff; ie2 = ie + ioff;
else if(ied .GT. ieg) then ! split into two parts
is1 = is; ie1 = ie;
isd1 = isd; ied1 = ieg;
is2 = is + ioff; ie2 = ie + ioff
isd2 = ieg + 1; ied2 = ied
else if(isd .GE. middle) then
is1 = is; ie1 = ie
else if(ied .GE. middle) then ! split into two parts
is1 = is; ie1 = ie
isd1 = middle; ied1 = ied
is2 = is; ie2 = ie
isd2 = isd; ied2 = middle-1
else if(ied .LT. isg) then
is1 = is - ioff; ie1 = ie - ioff;
is3 = is3 - ioff; ie3 = ie3 - ioff;
else if(isd .LT. isg) then ! split into two parts
is1 = is - ioff; ie1 = ie - ioff;
is3 = is3 - ioff; ie3 = ie3 - ioff;
isd1 = isd; ied1 = isg-1
is2 = is; ie2 = ie
isd2 = isg; ied2 = ied
else
is2 = is ; ie2 =ie
isd2 = isd; ied2 = ied
endif
if( ie1 .GE. is1) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is1, ie1, js, je, isd1, ied1, jsd, jed-1, dir, symmetry=symmetry)
call insert_update_overlap( overlap, domain%list(m)%pe, &
is3, ie3, js, je, isd1, ied1, jed, jed, dir, .true., symmetry=symmetry)
endif
if(ie2 .GE. is2) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is2, ie2, js, je, isd2, ied2, jsd, jed, dir)
endif
end subroutine fill_overlap_recv_fold
!#####################################################################################
subroutine fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
isg, ieg, jsg, jeg, dir, reverse, symmetry)
type(overlap_type), intent(inout) :: overlap
type(domain2d), intent(inout) :: domain
integer, intent(in ) :: m, is, ie, js, je
integer, intent(in ) :: isc, iec, jsc, jec
integer, intent(in ) :: isg, ieg, jsg, jeg
integer, intent(in ) :: dir
logical, optional, intent(in ) :: reverse, symmetry
if(js > je) then ! seperate into two regions due to x_cyclic_offset is nonzero, the two region are
! (js, jeg) and (jsg, je).
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, jsg, je, isc, iec, jsc, jec, dir, reverse, symmetry)
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, jeg, isc, iec, jsc, jec, dir, reverse, symmetry)
else if(is > ie) then ! seperate into two regions due to y_cyclic_offset is nonzero, the two region are
! (is, ieg) and (isg, ie).
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ieg, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
call insert_update_overlap( overlap, domain%list(m)%pe, &
isg, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
end if
end subroutine fill_overlap
!####################################################################################
subroutine compute_overlaps_fold_south( domain, position, ishift, jshift)
!computes remote domain overlaps
!assumes only one in each direction
!will calculate the overlapping for T,E,C,N-cell seperately.
type(domain2D), intent(inout) :: domain
integer, intent(in) :: position, ishift, jshift
integer :: i, m, n, nlist, tMe, tNbr, dir
integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
integer :: isg, ieg, jsg, jeg, ioff, joff
integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
logical :: folded
type(overlap_type) :: overlap
type(overlapSpec), pointer :: update=>NULL()
type(overlap_type), pointer :: overlapList(:)=>NULL()
type(overlap_type), pointer :: checkList(:)=>NULL()
type(overlapSpec), pointer :: check =>NULL()
integer :: nsend, nrecv
integer :: nsend_check, nrecv_check
integer :: unit
!--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
!--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
!--- In this case the overlapping exist only for tMe=1 and tNbr=1
if(size(domain%x(:)) > 1) return
!--- if there is no halo, no need to compute overlaps.
if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
!--- when there is only one tile, n will equal to np
nlist = size(domain%list(:))
select case(position)
case (CENTER)
update => domain%update_T
check => NULL()
case (CORNER)
update => domain%update_C
check => domain%check_C
case (EAST)
update => domain%update_E
check => domain%check_E
case (NORTH)
update => domain%update_N
check => domain%check_N
case default
call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, CORNER or NORTH")
end select
allocate(overlapList(MAXLIST) )
allocate(checkList(MAXLIST) )
!--- overlap is used to store the overlapping temporarily.
call allocate_update_overlap( overlap, MAXOVERLAP)
!send
call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
update%xbegin = ism; update%xend = iem
update%ybegin = jsm; update%yend = jem
if(ASSOCIATED(check)) then
check%xbegin = ism; check%xend = iem
check%ybegin = jsm; check%yend = jem
endif
update%whalo = domain%whalo; update%ehalo = domain%ehalo
update%shalo = domain%shalo; update%nhalo = domain%nhalo
whalo = domain%whalo; ehalo = domain%ehalo
shalo = domain%shalo; nhalo = domain%nhalo
ioff = ni - ishift
joff = nj - jshift
middle = (isg+ieg)/2+1
tMe = 1; tNbr = 1
if(.NOT. BTEST(domain%fold,SOUTH)) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
"boundary condition in y-direction should be folded-south for "//trim(domain%name))
endif
if(.NOT. domain%x(tMe)%cyclic) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
"boundary condition in x-direction should be cyclic for "//trim(domain%name))
endif
if(.not. domain%symmetry) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
"when south boundary is folded, the domain must be symmetry for "//trim(domain%name))
endif
nsend = 0
nsend_check = 0
do list = 0,nlist-1
m = mod( domain%pos+list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
!to_pe's eastern halo
dir = 1
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
!--- to make sure the consistence between pes
if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
!--- do nothing, this point will come from other pe
else
if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
is = is-ioff; ie = ie-ioff
end if
!--- when the south face is folded, the east halo point at right side domain will be folded.
!--- the position should be on CORNER or NORTH
if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
.AND. is .GE. middle .AND. domain%list(m)%x(tNbr)%compute%end+ehalo+jshift .LE. ieg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js+1, je, isc, iec, jsc, jec, dir)
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
je = js
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
end if
!to_pe's SE halo
dir = 2
folded = .false.
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
is = is-ioff; ie = ie-ioff
end if
if( js.LT.jsg )then
folded = .TRUE.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!to_pe's southern halo
dir = 3
folded = .FALSE.
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
folded = .FALSE.
if( js.LT.jsg )then
folded = .TRUE.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
!--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
!--- no need to send, because the data on that point will come from other pe.
!--- come from two pe ( there will be only one point on one pe. ).
if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
!--- do nothing, this point will come from other pe
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
endif
!--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
if(is .LT. isg) then
is = is + ioff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, is, js, je, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's SW halo
dir = 4
folded = .false.
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( isg.GT.is .AND. ie.LT.isc )then !cyclic offset
is = is+ioff; ie = ie+ioff
end if
if( js.LT.jsg )then
folded = .TRUE.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!--- when south edge is folded, is will be less than isg when position is EAST and CORNER
if(is .LT. isg) then
is = is + ioff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, is, js, je, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's western halo
dir = 5
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
!--- to make sure the consistence between pes
if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
!--- do nothing, this point will come from other pe
else
if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
is = is+ioff; ie = ie+ioff
end if
!--- when the south face is folded, some point at j=nj will be folded.
!--- the position should be on CORNER or NORTH
if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
.AND. ( domain%list(m)%x(tNbr)%compute%begin == isg .OR. domain%list(m)%x(tNbr)%compute%begin-1 .GE. middle)) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js+1, je, isc, iec, jsc, jec, dir)
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin; je = js
if ( domain%list(m)%x(tNbr)%compute%begin == isg ) then
select case (position)
case(NORTH)
i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
case(CORNER)
i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
end select
if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
'mpp_domains_define.inc(compute_overlaps_fold_south): west edge ubound error send.' )
else
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
endif
!to_pe's NW halo
dir = 6
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
is = is+ioff; ie = ie+ioff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!to_pe's northern halo
dir = 7
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
!to_pe's NE halo
dir = 8
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( ie.GT.ieg .AND. iec.LT.is )then !cyclic offset
is = is-ioff; ie = ie-ioff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!--- Now calculate the overlapping for fold-edge.
!--- only position at NORTH and CORNER need to be considered
if( ( position == NORTH .OR. position == CORNER) ) then
if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold is within domain
dir = 3
!--- calculate the overlapping for sending
if( domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 )then
js = domain%list(m)%y(tNbr)%compute%begin; je = js
if( js == jsg )then ! fold is within domain.
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
select case (position)
case(NORTH)
is = max(is, middle)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
is = max(is, middle)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
is = max(is, isc); ie = min(ie, iec)
js = max(js, jsc); je = min(je, jec)
if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
nsend_check = nsend_check+1
call allocate_check_overlap(checkList(nsend_check), 1)
call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
end if
end if
end if
end if
end if
end if
!--- copy the overlapping information
if( overlap%count > 0) then
nsend = nsend + 1
if(nsend > size(overlapList(:)) ) then
call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for send is expanded')
call expand_update_overlap_list(overlapList, nlist)
endif
call add_update_overlap(overlapList(nsend), overlap)
call init_overlap_type(overlap)
endif
end do ! end of send set up.
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nsend
write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if( nsend > 0) call flush(unit)
endif
! copy the overlapping information into domain data structure
if(nsend>0) then
allocate(update%send(nsend))
update%nsend = nsend
do m = 1, nsend
call add_update_overlap( update%send(m), overlapList(m) )
enddo
endif
if(nsend_check>0) then
allocate(check%send(nsend_check))
check%nsend = nsend_check
do m = 1, nsend_check
call add_check_overlap( check%send(m), checkList(m) )
enddo
endif
do m = 1,size(overlapList(:))
call deallocate_overlap_type(overlapList(m))
enddo
if(debug_update_level .NE. NO_CHECK) then
do m = 1,size(checkList(:))
call deallocate_overlap_type(checkList(m))
enddo
endif
isgd = isg - domain%whalo
iegd = ieg + domain%ehalo
jsgd = jsg - domain%shalo
jegd = jeg + domain%nhalo
! begin setting up recv
nrecv = 0
nrecv_check = 0
do list = 0,nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
!recv_e
dir = 1
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
! --- do nothing, this point will come from other pe
else
if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
is = is+ioff; ie = ie+ioff
end if
!--- when the south face is folded, the east halo point at right side domain will be folded.
!--- the position should be on CORNER or NORTH
if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
.AND. isd .GE. middle .AND. ied .LE. ieg ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd+1, jed, dir)
is=isc; ie=iec; js=jsc; je=jec
jed = jsd
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
end if
end if
!recv_se
dir = 2
folded = .false.
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( jsd.LT.jsg )then
folded = .true.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
is = is+ioff; ie = ie+ioff
endif
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, folded)
!recv_s
dir = 3
folded = .false.
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( jsd.LT.jsg )then
folded = .true.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
if( (position == EAST .OR. position == CORNER ) .AND. (isd == ie .or. ied == is ) ) then
!--- do nothing, this point will come from other pe
else
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
end if
!--- when south edge is folded, is will be less than isg when position is EAST and CORNER
if(is .LT. isg ) then
is = is + ioff
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, is, js, je, isd, ied, jsd, jed, dir, folded)
endif
!recv_sw
dir = 4
folded = .false.
isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( jsd.LT.jsg )then
folded = .true.
call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
end if
if( isd.LT.isg .AND. is.GT.ied ) then ! cyclic offset
is = is-ioff; ie = ie-ioff
end if
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, folded)
!--- when southth edge is folded, is will be less than isg when position is EAST and CORNER
if(is .LT. isg ) then
is = is + ioff
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, is, js, je, isd, ied, jsd, jed, dir, folded )
endif
!recv_w
dir = 5
isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
! --- do nothing, this point will come from other pe
else
if( isd.LT.isg .AND. is.GT.ied )then ! cyclic offset
is = is-ioff; ie = ie-ioff
end if
!--- when the south face is folded, some point at j=nj will be folded.
!--- the position should be on CORNER or NORTH
if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
.AND. ( isd < isg .OR. ied .GE. middle ) ) then
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd+1, jed, dir)
is=isc; ie=iec; js=jsc; je=jec
if(isd < isg) then
select case (position)
case(NORTH)
i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
case(CORNER)
ied = ied -1 + ishift
i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
end select
if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
'mpp_domains_define.inc(compute_overlaps): west edge ubound error recv.' )
else
select case (position)
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
end if
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jsd, dir, .TRUE.)
else
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
end if
endif
!recv_nw
dir = 6
isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset
is = is-ioff; ie = ie-ioff
endif
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir)
!recv_n
dir = 7
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
is=isc; ie=iec; js=jsc; je=jec
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
!recv_ne
dir = 8
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset
is = is+ioff; ie = ie+ioff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir)
!--- Now calculate the overlapping for fold-edge.
!--- for folded-south-edge, only need to consider to_pe's south(3) direction
!--- only position at NORTH and CORNER need to be considered
if( ( position == NORTH .OR. position == CORNER) ) then
if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold is within domain
dir = 3
!--- calculating overlapping for receving on north
if( domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2 )then
jsd = domain%y(tMe)%compute%begin; jed = jsd
if( jsd == jsg )then ! fold is within domain.
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
is=isc; ie=iec; js = jsc; je = jec
select case (position)
case(NORTH)
isd = max(isd, middle)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
case(CORNER)
isd = max(isd, middle)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
is = max(is, isd); ie = min(ie, ied)
js = max(js, jsd); je = min(je, jed)
if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
nrecv_check = nrecv_check+1
call allocate_check_overlap(checkList(nrecv_check), 1)
call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
endif
endif
endif
endif
endif
endif
!--- copy the overlapping information
if( overlap%count > 0) then
nrecv = nrecv + 1
if(nrecv > size(overlapList(:)) )then
call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for recv is expanded')
call expand_update_overlap_list(overlapList, nlist)
endif
call add_update_overlap( overlapList(nrecv), overlap)
call init_overlap_type(overlap)
endif
enddo ! end of recv do loop
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nrecv
write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if(nrecv >0) call flush(unit)
endif
! copy the overlapping information into domain
if(nrecv>0) then
update%nrecv = nrecv
allocate(update%recv(nrecv))
do m = 1, nrecv
call add_update_overlap( update%recv(m), overlapList(m) )
do n = 1, update%recv(m)%count
if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
endif
enddo
enddo
endif
if(nrecv_check>0) then
check%nrecv = nrecv_check
allocate(check%recv(nrecv_check))
do m = 1, nrecv_check
call add_check_overlap( check%recv(m), checkList(m) )
enddo
endif
call deallocate_overlap_type(overlap)
do m = 1,size(overlapList(:))
call deallocate_overlap_type(overlapList(m))
enddo
if(debug_update_level .NE. NO_CHECK) then
do m = 1,size(checkList(:))
call deallocate_overlap_type(checkList(m))
enddo
endif
deallocate(overlapList)
deallocate(checkList)
update => NULL()
check=>NULL()
domain%initialized = .true.
end subroutine compute_overlaps_fold_south
!####################################################################################
subroutine compute_overlaps_fold_west( domain, position, ishift, jshift)
!computes remote domain overlaps
!assumes only one in each direction
!will calculate the overlapping for T,E,C,N-cell seperately.
type(domain2D), intent(inout) :: domain
integer, intent(in) :: position, ishift, jshift
integer :: j, m, n, nlist, tMe, tNbr, dir
integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
integer :: isg, ieg, jsg, jeg, ioff, joff
integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
logical :: folded
type(overlap_type) :: overlap
type(overlapSpec), pointer :: update=>NULL()
type(overlap_type) :: overlapList(MAXLIST)
type(overlap_type) :: checkList(MAXLIST)
type(overlapSpec), pointer :: check =>NULL()
integer :: nsend, nrecv
integer :: nsend_check, nrecv_check
integer :: unit
!--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
!--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
!--- In this case the overlapping exist only for tMe=1 and tNbr=1
if(size(domain%x(:)) > 1) return
!--- if there is no halo, no need to compute overlaps.
if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
!--- when there is only one tile, n will equal to np
nlist = size(domain%list(:))
select case(position)
case (CENTER)
update => domain%update_T
check => NULL()
case (CORNER)
update => domain%update_C
check => domain%check_C
case (EAST)
update => domain%update_E
check => domain%check_E
case (NORTH)
update => domain%update_N
check => domain%check_N
case default
call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_fold_west): the value of position should be CENTER, EAST, CORNER or NORTH")
end select
!--- overlap is used to store the overlapping temporarily.
call allocate_update_overlap( overlap, MAXOVERLAP)
!send
call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
update%xbegin = ism; update%xend = iem
update%ybegin = jsm; update%yend = jem
if(ASSOCIATED(check)) then
check%xbegin = ism; check%xend = iem
check%ybegin = jsm; check%yend = jem
endif
update%whalo = domain%whalo; update%ehalo = domain%ehalo
update%shalo = domain%shalo; update%nhalo = domain%nhalo
whalo = domain%whalo; ehalo = domain%ehalo
shalo = domain%shalo; nhalo = domain%nhalo
ioff = ni - ishift
joff = nj - jshift
middle = (jsg+jeg)/2+1
tMe = 1; tNbr = 1
if(.NOT. BTEST(domain%fold,WEST)) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
"boundary condition in y-direction should be folded-west for "//trim(domain%name))
endif
if(.NOT. domain%y(tMe)%cyclic) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
"boundary condition in y-direction should be cyclic for "//trim(domain%name))
endif
if(.not. domain%symmetry) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
"when west boundary is folded, the domain must be symmetry for "//trim(domain%name))
endif
nsend = 0
nsend_check = 0
do list = 0,nlist-1
m = mod( domain%pos+list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
!to_pe's eastern halo
dir = 1
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
!to_pe's SE halo
dir = 2
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
js = js+joff; je = je+joff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!to_pe's southern halo
dir = 3
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
!--- to make sure the consistence between pes
if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
!--- do nothing, this point will come from other pe
else
if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
js = js+joff; je = je+joff
endif
!--- when the west face is folded, the south halo points at
!--- the position should be on CORNER or EAST
if( is == isg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle)) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is+1, ie, js, je, isc, iec, jsc, jec, dir)
is = domain%list(m)%x(tNbr)%compute%begin; ie = is
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
select case (position)
case(EAST)
j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
case(CORNER)
j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
end select
if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error send.' )
else
select case (position)
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
endif
!to_pe's SW halo
dir = 4
folded = .false.
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( jsg.GT.js .AND. je.LT.jsc )then !cyclic offset
js = js+joff; je = je+joff
end if
if( is.LT.isg )then
folded = .TRUE.
call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!--- when south edge is folded, js will be less than jsg when position is EAST and CORNER
if(js .LT. jsg) then
js = js + joff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, js, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's western halo
dir = 5
folded = .FALSE.
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
if( isg.GT.is )then
folded = .true.
call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
end if
!--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
!--- no need to send, because the data on that point will come from other pe.
!--- come from two pe ( there will be only one point on one pe. ).
if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
!--- do nothing, this point will come from other pe
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
endif
!--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
if(js .LT. jsg) then
js = js + ioff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, js, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's NW halo
dir = 6
folded = .false.
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
js = js-joff; je = je-joff
end if
if( is.LT.isg )then
folded = .TRUE.
call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!to_pe's northern halo
dir = 7
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
!--- to make sure the consistence between pes
if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
!--- do nothing, this point will come from other pe
else
if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
js = js-joff; je = je-joff
endif
!--- when the west face is folded, the south halo points at
!--- the position should be on CORNER or EAST
if( is == isg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is+1, ie, js, je, isc, iec, jsc, jec, dir)
is = domain%list(m)%x(tNbr)%compute%begin; ie = is
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
select case (position)
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
endif
!to_pe's NE halo
dir = 8
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
js = js-joff; je = je-joff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!--- Now calculate the overlapping for fold-edge.
!--- only position at EAST and CORNER need to be considered
if( ( position == EAST .OR. position == CORNER) ) then
if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
dir = 5
!--- calculate the overlapping for sending
if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
is = domain%list(m)%x(tNbr)%compute%begin; ie = is
if( is == isg )then ! fold is within domain.
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
select case (position)
case(EAST)
js = max(js, middle)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
js = max(js, middle)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
is = max(is, isc); ie = min(ie, iec)
js = max(js, jsc); je = min(je, jec)
if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
nsend_check = nsend_check+1
call allocate_check_overlap(checkList(nsend_check), 1)
call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
end if
end if
end if
end if
end if
end if
!--- copy the overlapping information
if( overlap%count > 0) then
nsend = nsend + 1
if(nsend > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_west): nsend is greater than MAXLIST, increase MAXLIST")
call add_update_overlap(overlapList(nsend), overlap)
call init_overlap_type(overlap)
endif
end do ! end of send set up.
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nsend
write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if(nsend >0) call flush(unit)
endif
! copy the overlapping information into domain data structure
if(nsend>0) then
update%nsend = nsend
allocate(update%send(nsend))
do m = 1, nsend
call add_update_overlap( update%send(m), overlapList(m) )
enddo
endif
if(nsend_check>0) then
check%nsend = nsend_check
allocate(check%send(nsend_check))
do m = 1, nsend_check
call add_check_overlap( check%send(m), checkList(m) )
enddo
endif
do m = 1, MAXLIST
call deallocate_overlap_type(overlapList(m))
if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
enddo
isgd = isg - domain%whalo
iegd = ieg + domain%ehalo
jsgd = jsg - domain%shalo
jegd = jeg + domain%nhalo
! begin setting up recv
nrecv = 0
nrecv_check = 0
do list = 0,nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
!recv_e
dir = 1
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
!recv_se
dir = 2
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
js = js-joff; je = je-joff
end if
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir)
!recv_s
dir = 3
folded = .false.
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
!--- do nothing, this point will come from other pe
else
if( jsd.LT.jsg .AND. js .GT. jed)then
js = js-joff; je = je-joff
end if
!--- when the west face is folded, the south halo points at
!--- the position should be on CORNER or EAST
if( isd == isg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd+1, ied, jsd, jed, dir)
is=isc; ie=iec; js=jsc; je=jec
if(jsd 0) then
nrecv = nrecv + 1
if(nrecv > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_west): nrecv is greater than MAXLIST, increase MAXLIST")
call add_update_overlap( overlapList(nrecv), overlap)
call init_overlap_type(overlap)
endif
enddo ! end of recv do loop
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do m =1,nrecv
write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
do n = 1, overlapList(m)%count
write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
overlapList(m)%dir(n), overlapList(m)%rotation(n)
enddo
enddo
if(nrecv >0) call flush(unit)
endif
! copy the overlapping information into domain
if(nrecv>0) then
update%nrecv = nrecv
allocate(update%recv(nrecv))
do m = 1, nrecv
call add_update_overlap( update%recv(m), overlapList(m) )
do n = 1, update%recv(m)%count
if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
endif
enddo
enddo
endif
if(nrecv_check>0) then
check%nrecv = nrecv_check
allocate(check%recv(nrecv_check))
do m = 1, nrecv_check
call add_check_overlap( check%recv(m), checkList(m) )
enddo
endif
call deallocate_overlap_type(overlap)
do m = 1, MAXLIST
call deallocate_overlap_type(overlapList(m))
if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
enddo
update=>NULL()
check=>NULL()
domain%initialized = .true.
end subroutine compute_overlaps_fold_west
!###############################################################################
subroutine compute_overlaps_fold_east( domain, position, ishift, jshift )
!computes remote domain overlaps
!assumes only one in each direction
!will calculate the overlapping for T,E,C,N-cell seperately.
!here assume fold-east and y-cyclic boundary condition
type(domain2D), intent(inout) :: domain
integer, intent(in) :: position, ishift, jshift
integer :: j, m, n, nlist, tMe, tNbr, dir
integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd
integer :: jed, isg, ieg, jsg, jeg, ioff, joff
integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
logical :: folded
type(overlap_type) :: overlap
type(overlapSpec), pointer :: update=>NULL()
type(overlap_type) :: overlapList(MAXLIST)
type(overlap_type) :: checkList(MAXLIST)
type(overlapSpec), pointer :: check =>NULL()
integer :: nsend, nrecv
integer :: nsend_check, nrecv_check
!--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
!--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
!--- In this case the overlapping exist only for tMe=1 and tNbr=1
if(size(domain%x(:)) > 1) return
!--- if there is no halo, no need to compute overlaps.
if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
!--- when there is only one tile, n will equal to np
nlist = size(domain%list(:))
select case(position)
case (CENTER)
update => domain%update_T
case (CORNER)
update => domain%update_C
check => domain%check_C
case (EAST)
update => domain%update_E
check => domain%check_E
case (NORTH)
update => domain%update_N
check => domain%check_N
case default
call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_fold_east): the value of position should be CENTER, EAST, CORNER or NORTH")
end select
!--- overlap is used to store the overlapping temporarily.
call allocate_update_overlap( overlap, MAXOVERLAP)
!send
call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
update%xbegin = ism; update%xend = iem
update%ybegin = jsm; update%yend = jem
if(ASSOCIATED(check)) then
check%xbegin = ism; check%xend = iem
check%ybegin = jsm; check%yend = jem
endif
update%whalo = domain%whalo; update%ehalo = domain%ehalo
update%shalo = domain%shalo; update%nhalo = domain%nhalo
whalo = domain%whalo; ehalo = domain%ehalo
shalo = domain%shalo; nhalo = domain%nhalo
ioff = ni - ishift
joff = nj - jshift
middle = (jsg+jeg)/2+1
tMe = 1; tNbr = 1
if(.NOT. BTEST(domain%fold,EAST)) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
"boundary condition in y-direction should be folded-east for "//trim(domain%name))
endif
if(.NOT. domain%y(tMe)%cyclic) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
"boundary condition in y-direction should be cyclic for "//trim(domain%name))
endif
if(.not. domain%symmetry) then
call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
"when east boundary is folded, the domain must be symmetry for "//trim(domain%name))
endif
nsend = 0
nsend_check = 0
do list = 0,nlist-1
m = mod( domain%pos+list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
!to_pe's eastern halo
dir = 1
folded = .false.
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
if( ie.GT.ieg )then
folded = .true.
call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
end if
!--- when domain symmetry and position is EAST or CORNER, the point when jsc == je,
!--- no need to send, because the data on that point will come from other pe.
!--- come from two pe ( there will be only one point on one pe. ).
if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
!--- do nothing, this point will come from other pe
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
endif
!--- when east edge is folded, js .LT. jsg
if(js .LT. jsg) then
js = js + ioff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, js, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's SE halo
dir = 2
folded = .FALSE.
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( jsg.GT.js .AND. je.LT.jsc )then !try cyclic offset
js = js+joff; je = je+joff
end if
if( ie.GT.ieg )then
folded = .TRUE.
call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!--- when east edge is folded,
if(js .LT. jsg) then
js = js + joff
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, js, isc, iec, jsc, jec, dir, folded)
endif
!to_pe's southern halo
dir = 3
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
!--- to make sure the consistence between pes
if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
!--- do nothing, this point will come from other pe
else
if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
js = js+joff; je = je+joff
endif
!--- when the east face is folded, the south halo points at
!--- the position should be on CORNER or EAST
if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. &
domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle ) ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie-1, js, je, isc, iec, jsc, jec, dir)
!--- consider at i = ieg for east edge.
!--- when the data is at corner and not symmetry, j = jsg -1 will get from cyclic condition
if(position == CORNER .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tNbr)%compute%begin == jsg) then
call insert_update_overlap(overlap, domain%list(m)%pe, &
ie, ie, je, je, isc, iec, jsc, jec, dir, .true.)
end if
ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
select case (position)
case(EAST)
j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
case(CORNER)
j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
end select
if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
'mpp_domains_define.inc(compute_overlaps_fold_east: south edge ubound error send.' )
else
select case (position)
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
endif
!to_pe's SW halo
dir = 4
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
js = js+joff; je = je+joff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!to_pe's western halo
dir = 5
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
!to_pe's NW halo
dir = 6
is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
js = js-joff; je = je-joff
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir)
!to_pe's northern halo
dir = 7
folded = .FALSE.
is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
!--- to make sure the consistence between pes
if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
!--- do nothing, this point will come from other pe
else
if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
js = js-joff; je = je-joff
endif
!--- when the east face is folded, the north halo points at
!--- the position should be on CORNER or EAST
if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie-1, js, je, isc, iec, jsc, jec, dir)
ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
select case (position)
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
else
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
end if
endif
!to_pe's NE halo
dir = 8
folded = .false.
is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
js = js-joff; je = je-joff
end if
if( ie.GT.ieg )then
folded = .TRUE.
call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
end if
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, folded)
!--- Now calculate the overlapping for fold-edge.
!--- only position at EAST and CORNER need to be considered
if( ( position == EAST .OR. position == CORNER) ) then
if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
dir = 1
!--- calculate the overlapping for sending
if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
if( ie == ieg )then ! fold is within domain.
js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
select case (position)
case(EAST)
js = max(js, middle)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
case(CORNER)
js = max(js, middle)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
end select
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
is = max(is, isc); ie = min(ie, iec)
js = max(js, jsc); je = min(je, jec)
if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
nsend_check = nsend_check+1
call allocate_check_overlap(checkList(nsend_check), 1)
call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
tMe, 1, ONE_HUNDRED_EIGHTY, is, ie, js, je)
end if
end if
end if
end if
end if
end if
!--- copy the overlapping information
if( overlap%count > 0) then
nsend = nsend + 1
if(nsend > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_east): nsend is greater than MAXLIST, increase MAXLIST")
call add_update_overlap(overlapList(nsend), overlap)
call init_overlap_type(overlap)
endif
end do ! end of send set up.
! copy the overlapping information into domain data structure
if(nsend>0) then
update%nsend = nsend
allocate(update%send(nsend))
do m = 1, nsend
call add_update_overlap( update%send(m), overlapList(m) )
enddo
endif
if(nsend_check>0) then
check%nsend = nsend_check
allocate(check%send(nsend_check))
do m = 1, nsend_check
call add_check_overlap( check%send(m), checkList(m) )
enddo
endif
do m = 1, MAXLIST
call deallocate_overlap_type(overlapList(m))
if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
enddo
isgd = isg - domain%whalo
iegd = ieg + domain%ehalo
jsgd = jsg - domain%shalo
jegd = jeg + domain%nhalo
! begin setting up recv
nrecv = 0
nrecv_check = 0
do list = 0,nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
!recv_e
dir = 1
folded = .false.
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
is=isc; ie=iec; js=jsc; je=jec
if( ied.GT.ieg )then
folded = .true.
call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
end if
if( (position == EAST .OR. position == CORNER ) .AND. (jsd == je .or. jed == js ) ) then
!--- do nothing, this point will come from other pe
else
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
end if
!--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
if(js .LT. jsg ) then
js = js + joff
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, js, isd, ied, jsd, jed, dir, folded)
endif
!recv_se
dir = 2
folded = .false.
isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( ied.GT.ieg )then
folded = .true.
call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
end if
if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
js = js-joff; je = je-joff
end if
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied, jsd, jed, dir, folded)
!--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
if(js .LT. jsg ) then
js = js + joff
call insert_update_overlap(overlap, domain%list(m)%pe, &
is, ie, js, js, isd, ied, jsd, jed, dir, folded )
endif
!recv_s
dir = 3
folded = .false.
isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
is=isc; ie=iec; js=jsc; je=jec
if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
!--- do nothing, this point will come from other pe
else
if( jsd.LT.jsg .AND. js .GT. jed)then
js = js-joff; je = je-joff
end if
!--- when the east face is folded, the south halo points at
!--- the position should be on CORNER or EAST
if( ied == ieg .AND. (position == CORNER .OR. position == EAST) &
.AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
call insert_update_overlap( overlap, domain%list(m)%pe, &
is, ie, js, je, isd, ied-1, jsd, jed, dir)
is=isc; ie=iec; js=jsc; je=jec
if(jsd 0) then
nrecv = nrecv + 1
if(nrecv > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(compute_overlaps_east): nrecv is greater than MAXLIST, increase MAXLIST")
call add_update_overlap( overlapList(nrecv), overlap)
call init_overlap_type(overlap)
endif
enddo ! end of recv do loop
! copy the overlapping information into domain
if(nrecv>0) then
update%nrecv = nrecv
allocate(update%recv(nrecv))
do m = 1, nrecv
call add_update_overlap( update%recv(m), overlapList(m) )
do n = 1, update%recv(m)%count
if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
endif
enddo
enddo
endif
if(nrecv_check>0) then
check%nrecv = nrecv_check
allocate(check%recv(nrecv_check))
do m = 1, nrecv_check
call add_check_overlap( check%recv(m), checkList(m) )
enddo
endif
call deallocate_overlap_type(overlap)
do m = 1, MAXLIST
call deallocate_overlap_type(overlapList(m))
if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
enddo
update=>NULL()
check=>NULL()
domain%initialized = .true.
end subroutine compute_overlaps_fold_east
!#####################################################################################
subroutine get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
integer, intent(in) :: jsg, jeg, isg, jshift, position
integer, intent(inout) :: is, ie, js, je
integer :: i, j
select case(position)
case(CENTER)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
i=is; is = 2*isg-ie; ie = 2*isg-i
case(NORTH)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
i=is; is = 2*isg-ie; ie = 2*isg-i
end select
end subroutine get_fold_index_west
!#####################################################################################
subroutine get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
integer, intent(in) :: jsg, jeg, ieg, jshift, position
integer, intent(inout) :: is, ie, js, je
integer :: i, j
select case(position)
case(CENTER)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
case(EAST)
j=js; js = jsg+jeg-je; je = jsg+jeg-j
i=is; is = 2*ieg-ie; ie = 2*ieg-i
case(NORTH)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
case(CORNER)
j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
i=is; is = 2*ieg-ie; ie = 2*ieg-i
end select
end subroutine get_fold_index_east
!#####################################################################################
subroutine get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
integer, intent(in) :: isg, ieg, jsg, ishift, position
integer, intent(inout) :: is, ie, js, je
integer :: i, j
select case(position)
case(CENTER)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
case(EAST)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
j=js; js = 2*jsg-je; je = 2*jsg-j
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
j=js; js = 2*jsg-je; je = 2*jsg-j
end select
end subroutine get_fold_index_south
!#####################################################################################
subroutine get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
integer, intent(in) :: isg, ieg, jeg, ishift, position
integer, intent(inout) :: is, ie, js, je
integer :: i, j
select case(position)
case(CENTER)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
case(EAST)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
case(NORTH)
i=is; is = isg+ieg-ie; ie = isg+ieg-i
j=js; js = 2*jeg-je; je = 2*jeg-j
case(CORNER)
i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
j=js; js = 2*jeg-je; je = 2*jeg-j
end select
end subroutine get_fold_index_north
!#####################################################################################
! add offset to the index
subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
integer, intent(inout) :: lstart, lend
integer, intent(in ) :: offset, gstart, gend, gsize
lstart = lstart + offset
if(lstart > gend) lstart = lstart - gsize
if(lstart < gstart) lstart = lstart + gsize
lend = lend + offset
if(lend > gend) lend = lend - gsize
if(lend < gstart) lend = lend + gsize
return
end subroutine apply_cyclic_offset
!###################################################################################
! this routine setup the overlapping for mpp_update_domains for arbitrary halo update.
! should be the halo size defined in mpp_define_domains.
! xhalo_out, yhalo_out should not be exactly the same as xhalo_in, yhalo_in
! currently we didn't consider about tripolar grid situation, because in the folded north
! region, the overlapping is specified through list of points, not through rectangular.
! But will return back to solve this problem in the future.
subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
type(domain2d), intent(in) :: domain
type(overlapSpec), intent(in) :: overlap_in
type(overlapSpec), intent(inout) :: overlap_out
integer, intent(in) :: whalo_out, ehalo_out, shalo_out, nhalo_out
integer :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation
integer :: whalo_in, ehalo_in, shalo_in, nhalo_in
integer :: dir
type(overlap_type) :: overlap
type(overlap_type), allocatable :: send(:), recv(:)
type(overlap_type), pointer :: ptrIn => NULL()
integer :: nsend, nrecv, nsend_in, nrecv_in
if( domain%fold .NE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_overlaps): folded domain is not implemented for arbitrary halo update, contact developer")
whalo_in = domain%whalo
ehalo_in = domain%ehalo
shalo_in = domain%shalo
nhalo_in = domain%nhalo
if( .NOT. domain%initialized) call mpp_error(FATAL, &
"mpp_domains_define.inc: domain is not defined yet")
nlist = size(domain%list(:))
isoff = whalo_in - abs(whalo_out)
ieoff = ehalo_in - abs(ehalo_out)
jsoff = shalo_in - abs(shalo_out)
jeoff = nhalo_in - abs(nhalo_out)
nsend = 0
nsend_in = overlap_in%nsend
nrecv_in = overlap_in%nrecv
if(nsend_in>0) allocate(send(nsend_in))
if(nrecv_in>0) allocate(recv(nrecv_in))
call allocate_update_overlap(overlap, MAXOVERLAP)
overlap_out%whalo = whalo_out
overlap_out%ehalo = ehalo_out
overlap_out%shalo = shalo_out
overlap_out%nhalo = nhalo_out
overlap_out%xbegin = overlap_in%xbegin
overlap_out%xend = overlap_in%xend
overlap_out%ybegin = overlap_in%ybegin
overlap_out%yend = overlap_in%yend
!--- setting up overlap.
do m = 1, nsend_in
ptrIn => overlap_in%send(m)
if(ptrIn%count .LE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_overlaps): number of overlap for send should be a positive number for"//trim(domain%name) )
do n = 1, ptrIn%count
dir = ptrIn%dir(n)
rotation = ptrIn%rotation(n)
select case(dir)
case(1) ! to_pe's eastern halo
if(ehalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir, rotation)
else if(ehalo_out<0) then
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir, rotation)
end if
case(2) ! to_pe's southeast halo
if(ehalo_out>0 .AND. shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation)
else if(ehalo_out<0 .AND. shalo_out < 0) then ! three parts: southeast, south and east.
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation)
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation)
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation)
end if
case(3) ! to_pe's southern halo
if(shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir, rotation)
else if(shalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir, rotation)
end if
case(4) ! to_pe's southwest halo
if(whalo_out>0 .AND. shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir, rotation)
else if(whalo_out<0 .AND. shalo_out < 0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation)
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation)
call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation)
end if
case(5) ! to_pe's western halo
if(whalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir, rotation)
else if(whalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir, rotation)
end if
case(6) ! to_pe's northwest halo
if(whalo_out>0 .AND. nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir, rotation)
else if(whalo_out<0 .AND. nhalo_out < 0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation)
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation)
call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation)
end if
case(7) ! to_pe's northern halo
if(nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir, rotation)
else if(nhalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir, rotation)
end if
case(8) ! to_pe's northeast halo
if(ehalo_out>0 .AND. nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation)
else if(ehalo_out<0 .AND. nhalo_out < 0) then
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation)
call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation)
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation)
end if
end select
end do ! do n = 1, ptrIn%count
if(overlap%count>0) then
nsend = nsend+1
call add_update_overlap(send(nsend), overlap)
call init_overlap_type(overlap)
endif
end do ! end do list = 0, nlist-1
if(nsend>0) then
overlap_out%nsend = nsend
allocate(overlap_out%send(nsend));
do n = 1, nsend
call add_update_overlap(overlap_out%send(n), send(n) )
enddo
else
overlap_out%nsend = 0
endif
!--------------------------------------------------
! recving
!---------------------------------------------------
overlap%count = 0
nrecv = 0
do m = 1, nrecv_in
ptrIn => overlap_in%recv(m)
if(ptrIn%count .LE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number")
overlap%count = 0
do n = 1, ptrIn%count
dir = ptrIn%dir(n)
rotation = ptrIn%rotation(n)
select case(dir)
case(1) ! eastern halo
if(ehalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir)
else if(ehalo_out<0) then
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir)
end if
case(2) ! southeast halo
if(ehalo_out>0 .AND. shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir)
else if(ehalo_out<0 .AND. shalo_out < 0) then
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir)
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1)
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1)
end if
case(3) ! southern halo
if(shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir)
else if(shalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir)
end if
case(4) ! southwest halo
if(whalo_out>0 .AND. shalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir)
else if(whalo_out<0 .AND. shalo_out < 0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir)
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1)
call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1)
end if
case(5) ! western halo
if(whalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir)
else if(whalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir)
end if
case(6) ! northwest halo
if(whalo_out>0 .AND. nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir)
else if(whalo_out<0 .AND. nhalo_out < 0) then
call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir)
call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1)
call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1)
end if
case(7) ! northern halo
if(nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir)
else if(nhalo_out<0) then
call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir)
end if
case(8) ! northeast halo
if(ehalo_out>0 .AND. nhalo_out > 0) then
call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir)
else if(ehalo_out<0 .AND. nhalo_out < 0) then
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir)
call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1)
call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1)
end if
end select
end do ! do n = 1, ptrIn%count
if(overlap%count>0) then
nrecv = nrecv+1
call add_update_overlap(recv(nrecv), overlap)
call init_overlap_type(overlap)
endif
end do ! end do list = 0, nlist-1
if(nrecv>0) then
overlap_out%nrecv = nrecv
allocate(overlap_out%recv(nrecv));
do n = 1, nrecv
call add_update_overlap(overlap_out%recv(n), recv(n) )
enddo
else
overlap_out%nrecv = 0
endif
call deallocate_overlap_type(overlap)
do n = 1, nsend_in
call deallocate_overlap_type(send(n))
enddo
do n = 1, nrecv_in
call deallocate_overlap_type(recv(n))
enddo
if(allocated(send)) deallocate(send)
if(allocated(recv)) deallocate(recv)
ptrIn => NULL()
call set_domain_comm_inf(overlap_out)
end subroutine set_overlaps
!##############################################################################
subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation)
type(overlap_type), intent(in) :: overlap_in
type(overlap_type), intent(inout) :: overlap_out
integer, intent(in) :: isoff, jsoff, ieoff, jeoff
integer, intent(in) :: index
integer, intent(in) :: dir
integer, optional, intent(in) :: rotation
integer :: rotate
integer :: count
if( overlap_out%pe == NULL_PE ) then
overlap_out%pe = overlap_in%pe
else
if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out")
endif
if(isoff .NE. 0 .and. ieoff .NE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero")
if(jsoff .NE. 0 .and. jeoff .NE. 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero")
overlap_out%count = overlap_out%count + 1
count = overlap_out%count
if(count > MAXOVERLAP) call mpp_error(FATAL, &
"set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
rotate = ZERO
if(present(rotation)) rotate = rotation
overlap_out%rotation (count) = overlap_in%rotation(index)
overlap_out%dir (count) = dir
overlap_out%tileMe (count) = overlap_in%tileMe(index)
overlap_out%tileNbr (count) = overlap_in%tileNbr(index)
select case(rotate)
case(ZERO)
overlap_out%is(count) = overlap_in%is(index) + isoff
overlap_out%ie(count) = overlap_in%ie(index) + ieoff
overlap_out%js(count) = overlap_in%js(index) + jsoff
overlap_out%je(count) = overlap_in%je(index) + jeoff
case(NINETY)
overlap_out%is(count) = overlap_in%is(index) - jeoff
overlap_out%ie(count) = overlap_in%ie(index) - jsoff
overlap_out%js(count) = overlap_in%js(index) + isoff
overlap_out%je(count) = overlap_in%je(index) + ieoff
case(MINUS_NINETY)
overlap_out%is(count) = overlap_in%is(index) + jsoff
overlap_out%ie(count) = overlap_in%ie(index) + jeoff
overlap_out%js(count) = overlap_in%js(index) - ieoff
overlap_out%je(count) = overlap_in%je(index) - isoff
case default
call mpp_error(FATAL, "mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY")
end select
end subroutine set_single_overlap
!###################################################################################
!--- compute the overlapping between tiles for the T-cell.
subroutine define_contact_point( domain, position, num_contact, tile1, tile2, align1, align2, &
refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
isgList, iegList, jsgList, jegList )
type(domain2D), intent(inout) :: domain
integer, intent(in) :: position
integer, intent(in) :: num_contact ! number of contact regions
integer, dimension(:), intent(in) :: tile1, tile2 ! tile number
integer, dimension(:), intent(in) :: align1, align2 ! align direction of contact region
real, dimension(:), intent(in) :: refine1, refine2 ! refinement between tiles
integer, dimension(:), intent(in) :: istart1, iend1 ! i-index in tile_1 of contact region
integer, dimension(:), intent(in) :: jstart1, jend1 ! j-index in tile_1 of contact region
integer, dimension(:), intent(in) :: istart2, iend2 ! i-index in tile_2 of contact region
integer, dimension(:), intent(in) :: jstart2, jend2 ! j-index in tile_2 of contact region
integer, dimension(:), intent(in) :: isgList, iegList ! i-global domain of each tile
integer, dimension(:), intent(in) :: jsgList, jegList ! j-global domain of each tile
integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2
integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2
integer :: is, ie, js, je, ioff, joff, isoff, ieoff, jsoff, jeoff
integer :: ntiles, max_contact
integer :: nlist, list, m, n, l, count, numS, numR
integer :: whalo, ehalo, shalo, nhalo
integer :: t1, t2, tt, pos
integer :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir
integer :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem
integer :: dirlist(8)
!--- is2Send and is1Send will figure out the overlapping for sending from current pe.
!--- is1Recv and iscREcv will figure out the overlapping for recving onto current pe.
integer, dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send
integer, dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send
integer, dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv
integer, dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv
integer, dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send
real, dimension(4*num_contact) :: refineRecv, refineSend
integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
integer :: nsend, nrecv, nsend2, nrecv2
type(contact_type), dimension(domain%ntiles) :: eCont, wCont, sCont, nCont
type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
integer :: unit
if( position .NE. CENTER ) call mpp_error(FATAL, "mpp_domains_define.inc: " //&
"routine define_contact_point can only be used to calculate overlapping for cell center.")
ntiles = domain%ntiles
eCont(:)%ncontact = 0
do n = 1, ntiles
eCont(n)%ncontact = 0; sCont(n)%ncontact = 0; wCont(n)%ncontact = 0; nCont(n)%ncontact = 0;
allocate(eCont(n)%tile(num_contact), wCont(n)%tile(num_contact) )
allocate(nCont(n)%tile(num_contact), sCont(n)%tile(num_contact) )
allocate(eCont(n)%align1(num_contact), eCont(n)%align2(num_contact) )
allocate(wCont(n)%align1(num_contact), wCont(n)%align2(num_contact) )
allocate(sCont(n)%align1(num_contact), sCont(n)%align2(num_contact) )
allocate(nCont(n)%align1(num_contact), nCont(n)%align2(num_contact) )
allocate(eCont(n)%refine1(num_contact), eCont(n)%refine2(num_contact) )
allocate(wCont(n)%refine1(num_contact), wCont(n)%refine2(num_contact) )
allocate(sCont(n)%refine1(num_contact), sCont(n)%refine2(num_contact) )
allocate(nCont(n)%refine1(num_contact), nCont(n)%refine2(num_contact) )
allocate(eCont(n)%is1(num_contact), eCont(n)%ie1(num_contact), eCont(n)%js1(num_contact), eCont(n)%je1(num_contact))
allocate(eCont(n)%is2(num_contact), eCont(n)%ie2(num_contact), eCont(n)%js2(num_contact), eCont(n)%je2(num_contact))
allocate(wCont(n)%is1(num_contact), wCont(n)%ie1(num_contact), wCont(n)%js1(num_contact), wCont(n)%je1(num_contact))
allocate(wCont(n)%is2(num_contact), wCont(n)%ie2(num_contact), wCont(n)%js2(num_contact), wCont(n)%je2(num_contact))
allocate(sCont(n)%is1(num_contact), sCont(n)%ie1(num_contact), sCont(n)%js1(num_contact), sCont(n)%je1(num_contact))
allocate(sCont(n)%is2(num_contact), sCont(n)%ie2(num_contact), sCont(n)%js2(num_contact), sCont(n)%je2(num_contact))
allocate(nCont(n)%is1(num_contact), nCont(n)%ie1(num_contact), nCont(n)%js1(num_contact), nCont(n)%je1(num_contact))
allocate(nCont(n)%is2(num_contact), nCont(n)%ie2(num_contact), nCont(n)%js2(num_contact), nCont(n)%je2(num_contact))
end do
!--- set up the east, south, west and north contact for each tile.
do n = 1, num_contact
t1 = tile1(n)
t2 = tile2(n)
select case(align1(n))
case (EAST)
call fill_contact( eCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
case (WEST)
call fill_contact( wCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
case (SOUTH)
call fill_contact( sCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
case (NORTH)
call fill_contact( nCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
end select
select case(align2(n))
case (EAST)
call fill_contact( eCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
case (WEST)
call fill_contact( wCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
case (SOUTH)
call fill_contact( sCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
case (NORTH)
call fill_contact( nCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
end select
end do
!--- the tile number of current pe, halo size
whalo = domain%whalo
ehalo = domain%ehalo
shalo = domain%shalo
nhalo = domain%nhalo
!--- find if there is an extra point in x and y direction depending on position
nlist = size(domain%list(:))
max_contact = 4*num_contact ! should be enough
ntileMe = size(domain%x(:))
refineSend = 1; refineRecv = 1
!--------------------------------------------------------------------------------------------------
! loop over each tile on current domain to set up the overlapping for each tile
!--------------------------------------------------------------------------------------------------
!--- first check the overlap within the tiles.
do n = 1, domain%update_T%nsend
pos = domain%update_T%send(n)%pe - mpp_root_pe()
call add_update_overlap(overlapSend(pos), domain%update_T%send(n) )
enddo
do n = 1, domain%update_T%nrecv
pos = domain%update_T%recv(n)%pe - mpp_root_pe()
call add_update_overlap(overlapRecv(pos), domain%update_T%recv(n) )
enddo
call mpp_get_memory_domain(domain, ism, iem, jsm, jem)
domain%update_T%xbegin = ism; domain%update_T%xend = iem
domain%update_T%ybegin = jsm; domain%update_T%yend = jem
domain%update_T%whalo = whalo; domain%update_T%ehalo = ehalo
domain%update_T%shalo = shalo; domain%update_T%nhalo = nhalo
do tMe = 1, ntileMe
tileMe = domain%tile_id(tMe)
rotateSend = ZERO; rotateRecv = ZERO
!--- loop over all the contact region to figure out the index for overlapping region.
count = 0
do n = 1, eCont(tileMe)%ncontact ! east contact
count = count+1
tileRecv(count) = eCont(tileMe)%tile(n); tileSend(count) = eCont(tileMe)%tile(n)
align1Recv(count) = eCont(tileMe)%align1(n); align2Recv(count) = eCont(tileMe)%align2(n)
align1Send(count) = eCont(tileMe)%align1(n); align2Send(count) = eCont(tileMe)%align2(n)
refineSend(count) = eCont(tileMe)%refine2(n); refineRecv(count) = eCont(tileMe)%refine1(n)
is1Recv(count) = eCont(tileMe)%is1(n) + 1; ie1Recv(count) = is1Recv(count) + ehalo - 1
js1Recv(count) = eCont(tileMe)%js1(n); je1Recv(count) = eCont(tileMe)%je1(n)
select case(eCont(tileMe)%align2(n))
case ( WEST ) ! w <-> e
is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = is2Recv(count) + ehalo - 1
js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = eCont(tileMe)%je2(n)
ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - whalo + 1
js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n)
ie2Send(count) = eCont(tileMe)%is2(n) - 1; is2Send(count) = ie2Send(count) - whalo + 1
js2Send(count) = eCont(tileMe)%js2(n); je2Send(count) = eCont(tileMe)%je2(n)
case ( SOUTH ) ! s <-> e
rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY
js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + ehalo -1
is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = eCont(tileMe)%ie2(n)
ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - shalo + 1
js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n)
is2Send(count) = eCont(tileMe)%is2(n); ie2Send(count) = eCont(tileMe)%ie2(n)
je2Send(count) = eCont(tileMe)%js2(n) - 1; js2Send(count) = je2Send(count) - shalo + 1
end select
end do
do n = 1, sCont(tileMe)%ncontact ! south contact
count = count+1
tileRecv(count) = sCont(tileMe)%tile(n); tileSend(count) = sCont(tileMe)%tile(n)
align1Recv(count) = sCont(tileMe)%align1(n); align2Recv(count) = sCont(tileMe)%align2(n);
align1Send(count) = sCont(tileMe)%align1(n); align2Send(count) = sCont(tileMe)%align2(n);
refineSend(count) = sCont(tileMe)%refine2(n); refineRecv(count) = sCont(tileMe)%refine1(n)
is1Recv(count) = sCont(tileMe)%is1(n); ie1Recv(count) = sCont(tileMe)%ie1(n)
je1Recv(count) = sCont(tileMe)%js1(n) - 1; js1Recv(count) = je1Recv(count) - shalo + 1
select case(sCont(tileMe)%align2(n))
case ( NORTH ) ! n <-> s
is2Recv(count) = sCont(tileMe)%is2(n); ie2Recv(count) = sCont(tileMe)%ie2(n)
je2Recv(count) = sCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - shalo + 1
is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n)
js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + nhalo -1
is2Send(count) = sCont(tileMe)%is2(n); ie2Send(count) = sCont(tileMe)%ie2(n)
js2Send(count) = sCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
case ( EAST ) ! e <-> s
rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY
ie2Recv(count) = sCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - shalo + 1
js2Recv(count) = sCont(tileMe)%js2(n); je2Recv(count) = sCont(tileMe)%je2(n)
is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n)
js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + ehalo - 1
is2Send(count) = sCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
js2Send(count) = sCont(tileMe)%js2(n); je2Send(count) = sCont(tileMe)%je2(n)
end select
end do
do n = 1, wCont(tileMe)%ncontact ! west contact
count = count+1
tileRecv(count) = wCont(tileMe)%tile(n); tileSend(count) = wCont(tileMe)%tile(n)
align1Recv(count) = wCont(tileMe)%align1(n); align2Recv(count) = wCont(tileMe)%align2(n);
align1Send(count) = wCont(tileMe)%align1(n); align2Send(count) = wCont(tileMe)%align2(n);
refineSend(count) = wCont(tileMe)%refine2(n); refineRecv(count) = wCont(tileMe)%refine1(n)
ie1Recv(count) = wCont(tileMe)%is1(n) - 1; is1Recv(count) = ie1Recv(count) - whalo + 1
js1Recv(count) = wCont(tileMe)%js1(n); je1Recv(count) = wCont(tileMe)%je1(n)
select case(wCont(tileMe)%align2(n))
case ( EAST ) ! e <-> w
ie2Recv(count) = wCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - whalo + 1
js2Recv(count) = wCont(tileMe)%js2(n); je2Recv(count) = wCont(tileMe)%je2(n)
is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + ehalo - 1
js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n)
is2Send(count) = wCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
js2Send(count) = wCont(tileMe)%js2(n); je2Send(count) = wCont(tileMe)%je2(n)
case ( NORTH ) ! n <-> w
rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY
je2Recv(count) = wCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - whalo + 1
is2Recv(count) = wCont(tileMe)%is2(n); ie2Recv(count) = wCont(tileMe)%ie2(n)
is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + nhalo - 1
js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n)
js2Send(count) = wCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
is2Send(count) = wCont(tileMe)%is2(n); ie2Send(count) = wCont(tileMe)%ie2(n)
end select
end do
do n = 1, nCont(tileMe)%ncontact ! north contact
count = count+1
tileRecv(count) = nCont(tileMe)%tile(n); tileSend(count) = nCont(tileMe)%tile(n)
align1Recv(count) = nCont(tileMe)%align1(n); align2Recv(count) = nCont(tileMe)%align2(n);
align1Send(count) = nCont(tileMe)%align1(n); align2Send(count) = nCont(tileMe)%align2(n);
refineSend(count) = nCont(tileMe)%refine2(n); refineRecv(count) = nCont(tileMe)%refine1(n)
is1Recv(count) = nCont(tileMe)%is1(n); ie1Recv(count) = nCont(tileMe)%ie1(n)
js1Recv(count) = nCont(tileMe)%je1(n)+1; je1Recv(count) = js1Recv(count) + nhalo - 1
select case(nCont(tileMe)%align2(n))
case ( SOUTH ) ! s <-> n
is2Recv(count) = nCont(tileMe)%is2(n); ie2Recv(count) = nCont(tileMe)%ie2(n)
js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + nhalo - 1
is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n)
je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - shalo + 1
is2Send(count) = nCont(tileMe)%is2(n); ie2Send(count) = nCont(tileMe)%ie2(n)
je2Send(count) = nCont(tileMe)%js2(n)-1; js2Send(count) = je2Send(count) - shalo + 1
case ( WEST ) ! w <-> n
rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY
is2Recv(count) = nCont(tileMe)%ie2(n); ie2Recv(count) = is2Recv(count) + nhalo - 1
js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = nCont(tileMe)%je2(n)
is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n)
je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - whalo + 1
ie2Send(count) = nCont(tileMe)%is2(n)-1; is2Send(count) = ie2Send(count) - whalo + 1
js2Send(count) = nCont(tileMe)%js2(n); je2Send(count) = nCont(tileMe)%je2(n)
end select
end do
numS = count
numR = count
!--- figure out the index for corner overlapping,
!--- fill_corner_contact will be updated to deal with the situation that there are multiple tiles on
!--- each side of six sides of cubic grid.
if(.NOT. domain%rotated_ninety) then
call fill_corner_contact(eCont, sCont, wCont, nCont, isgList, iegList, jsgList, jegList, numR, numS, &
tileRecv, tileSend, is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, &
js2Recv, je2Recv, is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, &
js2Send, je2Send, align1Recv, align2Recv, align1Send, align2Send, &
whalo, ehalo, shalo, nhalo, tileMe )
end if
isc = domain%x(tMe)%compute%begin; iec = domain%x(tMe)%compute%end
jsc = domain%y(tMe)%compute%begin; jec = domain%y(tMe)%compute%end
!--- compute the overlapping for send.
do n = 1, numS
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
ntileNbr = size(domain%list(m)%x(:))
do tNbr = 1, ntileNbr
if( domain%list(m)%tile_id(tNbr) .NE. tileSend(n) ) cycle
isc1 = max(isc, is1Send(n)); iec1 = min(iec, ie1Send(n))
jsc1 = max(jsc, js1Send(n)); jec1 = min(jec, je1Send(n))
if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle
!--- loop over 8 direction to get the overlapping starting from east with clockwise.
do dir = 1, 8
!--- get the to_pe's data domain.
select case ( dir )
case ( 1 ) ! eastern halo
if( align2Send(n) .NE. EAST ) cycle
isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
case ( 2 ) ! southeast halo
isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
case ( 3 ) ! southern halo
if( align2Send(n) .NE. SOUTH ) cycle
isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
case ( 4 ) ! southwest halo
isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
case ( 5 ) ! western halo
if( align2Send(n) .NE. WEST ) cycle
isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
case ( 6 ) ! northwest halo
isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
case ( 7 ) ! northern halo
if( align2Send(n) .NE. NORTH ) cycle
isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
case ( 8 ) ! northeast halo
isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
end select
isd = max(isd, is2Send(n)); ied = min(ied, ie2Send(n))
jsd = max(jsd, js2Send(n)); jed = min(jed, je2Send(n))
if( isd > ied .OR. jsd > jed ) cycle
ioff = 0; joff = 0
nxd = ied - isd + 1
nyd = jed - jsd + 1
select case ( align2Send(n) )
case ( WEST, EAST )
ioff = isd - is2Send(n)
joff = jsd - js2Send(n)
case ( SOUTH, NORTH )
ioff = isd - is2Send(n)
joff = jsd - js2Send(n)
end select
!--- get the index in current pe.
select case ( rotateSend(n) )
case ( ZERO )
isc2 = is1Send(n) + ioff; iec2 = isc2 + nxd - 1
jsc2 = js1Send(n) + joff; jec2 = jsc2 + nyd - 1
case ( NINETY ) ! N -> W or S -> E
iec2 = ie1Send(n) - joff; isc2 = iec2 - nyd + 1
jsc2 = js1Send(n) + ioff; jec2 = jsc2 + nxd - 1
case ( MINUS_NINETY ) ! W -> N or E -> S
isc2 = is1Send(n) + joff; iec2 = isc2 + nyd - 1
jec2 = je1Send(n) - ioff; jsc2 = jec2 - nxd + 1
end select
is = max(isc1,isc2); ie = min(iec1,iec2)
js = max(jsc1,jsc2); je = min(jec1,jec2)
if(ie.GE.is .AND. je.GE.js )then
if(.not. associated(overlapSend(m)%tileMe)) call allocate_update_overlap(overlapSend(m), MAXOVERLAP)
call insert_overlap_type(overlapSend(m), domain%list(m)%pe, tMe, tNbr, &
is, ie, js, je, dir, rotateSend(n), .true. )
endif
end do ! end do dir = 1, 8
end do ! end do tNbr = 1, ntileNbr
end do ! end do list = 0, nlist-1
end do ! end do n = 1, numS
!--- compute the overlapping for recv.
do n = 1, numR
do list = 0, nlist-1
m = mod( domain%pos+nlist-list, nlist )
ntileNbr = size(domain%list(m)%x(:))
do tNbr = 1, ntileNbr
if( domain%list(m)%tile_id(tNbr) .NE. tileRecv(n) ) cycle
isc = domain%list(m)%x(tNbr)%compute%begin; iec = domain%list(m)%x(tNbr)%compute%end
jsc = domain%list(m)%y(tNbr)%compute%begin; jec = domain%list(m)%y(tNbr)%compute%end
isc = max(isc, is2Recv(n)); iec = min(iec, ie2Recv(n))
jsc = max(jsc, js2Recv(n)); jec = min(jec, je2Recv(n))
if( isc > iec .OR. jsc > jec ) cycle
!--- find the offset for this overlapping.
ioff = 0; joff = 0
nxc = iec - isc + 1; nyc = jec - jsc + 1
select case ( align2Recv(n) )
case ( WEST, EAST )
if(align2Recv(n) == WEST) then
ioff = isc - is2Recv(n)
else
ioff = ie2Recv(n) - iec
endif
joff = jsc - js2Recv(n)
case ( NORTH, SOUTH )
ioff = isc - is2Recv(n)
if(align2Recv(n) == SOUTH) then
joff = jsc - js2Recv(n)
else
joff = je2Recv(n) - jec
endif
end select
!--- get the index in current pe.
select case ( rotateRecv(n) )
case ( ZERO )
isd1 = is1Recv(n) + ioff; ied1 = isd1 + nxc - 1
jsd1 = js1Recv(n) + joff; jed1 = jsd1 + nyc - 1
if( align1Recv(n) == WEST ) then
ied1 = ie1Recv(n)-ioff; isd1 = ied1 - nxc + 1
endif
if( align1Recv(n) == SOUTH ) then
jed1 = je1Recv(n)-joff; jsd1 = jed1 - nyc + 1
endif
case ( NINETY ) ! N -> W or S -> E
if( align1Recv(n) == WEST ) then
ied1 = ie1Recv(n)-joff; isd1 = ied1 - nyc + 1
else
isd1 = is1Recv(n)+joff; ied1 = isd1 + nyc - 1
endif
jed1 = je1Recv(n) - ioff; jsd1 = jed1 - nxc + 1
case ( MINUS_NINETY ) ! W -> N or E -> S
ied1 = ie1Recv(n) - joff; isd1 = ied1 - nyc + 1
if( align1Recv(n) == SOUTH ) then
jed1 = je1Recv(n)-ioff; jsd1 = jed1 - nxc + 1
else
jsd1 = js1Recv(n)+ioff; jed1 = jsd1 + nxc - 1
endif
end select
!--- loop over 8 direction to get the overlapping starting from east with clockwise.
do dir = 1, 8
select case ( dir )
case ( 1 ) ! eastern halo
if( align1Recv(n) .NE. EAST ) cycle
isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
case ( 2 ) ! southeast halo
isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
case ( 3 ) ! southern halo
if( align1Recv(n) .NE. SOUTH ) cycle
isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
case ( 4 ) ! southwest halo
isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
case ( 5 ) ! western halo
if( align1Recv(n) .NE. WEST ) cycle
isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
case ( 6 ) ! northwest halo
isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
case ( 7 ) ! northern halo
if( align1Recv(n) .NE. NORTH ) cycle
isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
case ( 8 ) ! northeast halo
isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
end select
is = max(isd1,isd2); ie = min(ied1,ied2)
js = max(jsd1,jsd2); je = min(jed1,jed2)
if(ie.GE.is .AND. je.GE.js )then
if(.not. associated(overlapRecv(m)%tileMe)) call allocate_update_overlap(overlapRecv(m), MAXOVERLAP)
call insert_overlap_type(overlapRecv(m), domain%list(m)%pe, tMe, tNbr, &
is, ie, js, je, dir, rotateRecv(n), .true.)
count = overlapRecv(m)%count
endif
end do ! end do dir = 1, 8
end do ! end do tNbr = 1, ntileNbr
end do ! end do list = 0, nlist-1
end do ! end do n = 1, numR
end do ! end do tMe = 1, ntileMe
!--- copy the overlapping information into domain data
nsend = 0; nsend2 = 0
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapSend(m)%count>0) nsend = nsend + 1
enddo
if(debug_message_passing) then
!--- write out send information
unit = mpp_pe() + 1000
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapSend(m)%count==0) cycle
write(unit, *) "********to_pe = " ,overlapSend(m)%pe, " count = ",overlapSend(m)%count
do n = 1, overlapSend(m)%count
write(unit, *) overlapSend(m)%is(n), overlapSend(m)%ie(n), overlapSend(m)%js(n), overlapSend(m)%je(n), &
overlapSend(m)%dir(n), overlapSend(m)%rotation(n)
enddo
enddo
if(nsend >0) call flush(unit)
endif
dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
! copy the overlap information into domain.
if(nsend >0) then
if(associated(domain%update_T%send)) then
do m = 1, domain%update_T%nsend
call deallocate_overlap_type(domain%update_T%send(m))
enddo
deallocate(domain%update_T%send)
endif
domain%update_T%nsend = nsend
allocate(domain%update_T%send(nsend))
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
ntileNbr = size(domain%list(m)%x(:))
!--- for the send, the list should be in tileNbr order and dir order to be consistent with Recv
if(overlapSend(m)%count > 0) then
nsend2 = nsend2+1
if(nsend2>nsend) call mpp_error(FATAL, &
"mpp_domains_define.inc(define_contact_point): nsend2 is greater than nsend")
call allocate_update_overlap(domain%update_T%send(nsend2), overlapSend(m)%count)
do tNbr = 1, ntileNbr
do tt = 1, ntileMe
if(domain%list(m)%pe == domain%pe) then ! own processor
tMe = tNbr+tt-1
if(tMe > ntileMe) tMe = tMe - ntileMe
else
tMe = tt
end if
do n = 1, 8 ! loop over 8 direction
do l = 1, overlapSend(m)%count
if(overlapSend(m)%tileMe(l) .NE. tMe) cycle
if(overlapSend(m)%tileNbr(l) .NE. tNbr) cycle
if(overlapSend(m)%dir(l) .NE. dirlist(n) ) cycle
call insert_overlap_type(domain%update_T%send(nsend2), overlapSend(m)%pe, &
overlapSend(m)%tileMe(l), overlapSend(m)%tileNbr(l), overlapSend(m)%is(l), overlapSend(m)%ie(l), &
overlapSend(m)%js(l), overlapSend(m)%je(l), overlapSend(m)%dir(l), overlapSend(m)%rotation(l), &
overlapSend(m)%from_contact(l) )
end do
end do
end do
end do
end if
enddo
endif
if(nsend2 .NE. nsend) call mpp_error(FATAL, &
"mpp_domains_define.inc(define_contact_point): nsend2 does not equal to nsend")
nrecv = 0; nrecv2 = 0
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapRecv(m)%count>0) nrecv = nrecv + 1
enddo
if(debug_message_passing) then
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapRecv(m)%count==0) cycle
write(unit, *) "********from_pe = " ,overlapRecv(m)%pe, " count = ",overlapRecv(m)%count
do n = 1, overlapRecv(m)%count
write(unit, *) overlapRecv(m)%is(n), overlapRecv(m)%ie(n), overlapRecv(m)%js(n), overlapRecv(m)%je(n), &
overlapRecv(m)%dir(n), overlapRecv(m)%rotation(n)
enddo
enddo
if(nrecv >0) call flush(unit)
endif
if(nrecv >0) then
if(associated(domain%update_T%recv)) then
do m = 1, domain%update_T%nrecv
call deallocate_overlap_type(domain%update_T%recv(m))
enddo
deallocate(domain%update_T%recv)
endif
domain%update_T%nrecv = nrecv
allocate(domain%update_T%recv(nrecv))
do list = 0, nlist-1
m = mod( domain%pos+nlist-list, nlist )
ntileNbr = size(domain%list(m)%x(:))
if(overlapRecv(m)%count > 0) then
nrecv2 = nrecv2 + 1
if(nrecv2>nrecv) call mpp_error(FATAL, &
"mpp_domains_define.inc(define_contact_point): nrecv2 is greater than nrecv")
call allocate_update_overlap(domain%update_T%recv(nrecv2), overlapRecv(m)%count)
do tMe = 1, ntileMe
do tt = 1, ntileNbr
!--- make sure the same order tile for different pe count
if(domain%list(m)%pe == domain%pe) then ! own processor
tNbr = tMe+tt-1
if(tNbr>ntileNbr) tNbr = tNbr - ntileNbr
else
tNbr = tt
end if
do n = 1, 8 ! loop over 8 direction
do l = 1, overlapRecv(m)%count
if(overlapRecv(m)%tileMe(l) .NE. tMe) cycle
if(overlapRecv(m)%tileNbr(l) .NE. tNbr) cycle
if(overlapRecv(m)%dir(l) .NE. dirlist(n) ) cycle
call insert_overlap_type(domain%update_T%recv(nrecv2), overlapRecv(m)%pe, &
overlapRecv(m)%tileMe(l), overlapRecv(m)%tileNbr(l), overlapRecv(m)%is(l), overlapRecv(m)%ie(l), &
overlapRecv(m)%js(l), overlapRecv(m)%je(l), overlapRecv(m)%dir(l), overlapRecv(m)%rotation(l), &
overlapRecv(m)%from_contact(l))
count = domain%update_T%recv(nrecv2)%count
end do
end do
end do
end do
end if
end do
endif
if(nrecv2 .NE. nrecv) call mpp_error(FATAL, &
"mpp_domains_define.inc(define_contact_point): nrecv2 does not equal to nrecv")
do m = 0,nlist-1
call deallocate_overlap_type(overlapSend(m))
call deallocate_overlap_type(overlapRecv(m))
enddo
!--- release memory
do n = 1, ntiles
deallocate(eCont(n)%tile, wCont(n)%tile, sCont(n)%tile, nCont(n)%tile )
deallocate(eCont(n)%align1, wCont(n)%align1, sCont(n)%align1, nCont(n)%align1)
deallocate(eCont(n)%align2, wCont(n)%align2, sCont(n)%align2, nCont(n)%align2)
deallocate(eCont(n)%refine1, wCont(n)%refine1, sCont(n)%refine1, nCont(n)%refine1)
deallocate(eCont(n)%refine2, wCont(n)%refine2, sCont(n)%refine2, nCont(n)%refine2)
deallocate(eCont(n)%is1, eCont(n)%ie1, eCont(n)%js1, eCont(n)%je1 )
deallocate(eCont(n)%is2, eCont(n)%ie2, eCont(n)%js2, eCont(n)%je2 )
deallocate(wCont(n)%is1, wCont(n)%ie1, wCont(n)%js1, wCont(n)%je1 )
deallocate(wCont(n)%is2, wCont(n)%ie2, wCont(n)%js2, wCont(n)%je2 )
deallocate(sCont(n)%is1, sCont(n)%ie1, sCont(n)%js1, sCont(n)%je1 )
deallocate(sCont(n)%is2, sCont(n)%ie2, sCont(n)%js2, sCont(n)%je2 )
deallocate(nCont(n)%is1, nCont(n)%ie1, nCont(n)%js1, nCont(n)%je1 )
deallocate(nCont(n)%is2, nCont(n)%ie2, nCont(n)%js2, nCont(n)%je2 )
end do
domain%initialized = .true.
end subroutine define_contact_point
!##############################################################################
!--- always fill the contact according to index order.
subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
type(contact_type), intent(inout) :: Contact
integer, intent(in) :: tile
integer, intent(in) :: is1, ie1, js1, je1
integer, intent(in) :: is2, ie2, js2, je2
integer, intent(in) :: align1, align2
real, intent(in) :: refine1, refine2
integer :: pos, n
do pos = 1, Contact%ncontact
select case(align1)
case(WEST, EAST)
if( js1 < Contact%js1(pos) ) exit
case(SOUTH, NORTH)
if( is1 < Contact%is1(pos) ) exit
end select
end do
Contact%ncontact = Contact%ncontact + 1
do n = Contact%ncontact, pos+1, -1 ! shift the data if needed.
Contact%tile(n) = Contact%tile(n-1)
Contact%align1(n) = Contact%align1(n-1)
Contact%align2(n) = Contact%align2(n-1)
Contact%is1(n) = Contact%is1(n-1); Contact%ie1(n) = Contact%ie1(n-1)
Contact%js1(n) = Contact%js1(n-1); Contact%je1(n) = Contact%je1(n-1)
Contact%is2(n) = Contact%is2(n-1); Contact%ie2(n) = Contact%ie2(n-1)
Contact%js2(n) = Contact%js2(n-1); Contact%je2(n) = Contact%je2(n-1)
end do
Contact%tile(pos) = tile
Contact%align1(pos) = align1
Contact%align2(pos) = align2
Contact%refine1(pos) = refine1
Contact%refine2(pos) = refine2
Contact%is1(pos) = is1; Contact%ie1(pos) = ie1
Contact%js1(pos) = js1; Contact%je1(pos) = je1
Contact%is2(pos) = is2; Contact%ie2(pos) = ie2
Contact%js2(pos) = js2; Contact%je2(pos) = je2
end subroutine fill_contact
!############################################################################
! this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
subroutine set_contact_point(domain, position)
type(domain2d), intent(inout) :: domain
integer, intent(in) :: position
integer :: ishift, jshift, nlist, list, m, n
integer :: ntileMe, tMe, dir, count, pos, nsend, nrecv
integer :: isoff1, ieoff1, isoff2, ieoff2, jsoff1, jeoff1, jsoff2, jeoff2
type(overlap_type), pointer :: ptrIn => NULL()
type(overlapSpec), pointer :: update_in => NULL()
type(overlapSpec), pointer :: update_out => NULL()
type(overlap_type) :: overlapList(0:size(domain%list(:))-1)
type(overlap_type) :: overlap
call mpp_get_domain_shift(domain, ishift, jshift, position)
update_in => domain%update_T
select case(position)
case (CORNER)
update_out => domain%update_C
case (EAST)
update_out => domain%update_E
case (NORTH)
update_out => domain%update_N
case default
call mpp_error(FATAL, "mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
end select
update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
update_out%whalo = update_in%whalo; update_out%ehalo = update_in%ehalo
update_out%shalo = update_in%shalo; update_out%nhalo = update_in%nhalo
nlist = size(domain%list(:))
ntileMe = size(domain%x(:))
call allocate_update_overlap(overlap, MAXOVERLAP)
do m = 0, nlist-1
call init_overlap_type(overlapList(m))
enddo
!--- first copy the send information in update_out to send
nsend = update_out%nsend
do m = 1, nsend
pos = update_out%send(m)%pe - mpp_root_pe()
call add_update_overlap(overlapList(pos), update_out%send(m))
call deallocate_overlap_type(update_out%send(m))
enddo
if(ASSOCIATED(update_out%send) )deallocate(update_out%send)
!--- loop over the list of overlapping.
nsend = update_in%nsend
do m = 1, nsend
ptrIn => update_in%send(m)
pos = PtrIn%pe - mpp_root_pe()
do n = 1, ptrIn%count
dir = ptrIn%dir(n)
! only set overlapping between tiles for send ( ptrOut%overlap(1) is false )
if(ptrIn%from_contact(n)) then
select case ( dir )
case ( 1 ) ! to_pe's eastern halo
select case(ptrIn%rotation(n))
case (ZERO) ! W -> E
isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
case (NINETY) ! S -> E
isoff1 = 0; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
end select
case ( 2 ) ! to_pe's south-eastearn halo
select case(ptrIn%rotation(n))
case (ZERO)
isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
case (NINETY)
isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
case (MINUS_NINETY)
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
end select
case ( 3 ) ! to_pe's southern halo
select case(ptrIn%rotation(n))
case (ZERO) ! N -> S
isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
case (MiNUS_NINETY) ! E -> S
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = ishift
end select
case ( 4 ) ! to_pe's south-westearn halo
select case(ptrIn%rotation(n))
case (ZERO)
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
case (NINETY)
isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
case (MINUS_NINETY)
isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
end select
case ( 5 ) ! to_pe's western halo
select case(ptrIn%rotation(n))
case (ZERO) ! E -> W
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
case (NINETY) ! N -> W
isoff1 = 0; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
end select
case ( 6 ) ! to_pe's north-westearn halo
select case(ptrIn%rotation(n))
case (ZERO)
isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
case (NINETY)
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
case (MINUS_NINETY)
isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
end select
case ( 7 ) ! to_pe's northern halo
select case(ptrIn%rotation(n))
case (ZERO) ! S -> N
isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
case (MINUS_NINETY) ! W -> N
isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = ishift
end select
case ( 8 ) ! to_pe's north-eastearn halo
select case(ptrIn%rotation(n))
case (ZERO)
isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
case (NINETY)
isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
case (MINUS_NINETY)
isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
end select
end select
call insert_overlap_type(overlap, PtrIn%pe, PtrIn%tileMe(n), PtrIn%tileNbr(n), &
Ptrin%is(n) + isoff1, Ptrin%ie(n) + ieoff1, Ptrin%js(n) + jsoff1, &
Ptrin%je(n) + jeoff1, PtrIn%dir(n), PtrIn%rotation(n), PtrIn%from_contact(n))
end if
end do ! do n = 1, prtIn%count
if(overlap%count > 0) then
call add_update_overlap(overlapList(pos), overlap)
call init_overlap_type(overlap)
endif
end do ! do list = 0, nlist-1
nsend = 0
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapList(m)%count>0) nsend = nsend+1
enddo
update_out%nsend = nsend
if(nsend>0) then
allocate(update_out%send(nsend))
pos = 0
do list = 0, nlist-1
m = mod( domain%pos+list, nlist )
if(overlapList(m)%count>0) then
pos = pos+1
if(pos>nsend) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_contact_point): pos should be no larger than nsend")
call add_update_overlap(update_out%send(pos), overlapList(m))
call deallocate_overlap_type(overlapList(m))
endif
enddo
if(pos .NE. nsend) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_contact_point): pos should equal to nsend")
endif
!--- first copy the recv information in update_out to recv
nrecv = update_out%nrecv
do m = 1, nrecv
pos = update_out%recv(m)%pe - mpp_root_pe()
call add_update_overlap(overlapList(pos), update_out%recv(m))
call deallocate_overlap_type(update_out%recv(m))
enddo
if(ASSOCIATED(update_out%recv) )deallocate(update_out%recv)
!--- loop over the list of overlapping.
nrecv = update_in%nrecv
do m=1,nrecv
ptrIn => update_in%recv(m)
pos = PtrIn%pe - mpp_root_pe()
do n = 1, ptrIn%count
dir = ptrIn%dir(n)
! only set overlapping between tiles for recv ( ptrOut%overlap(1) is false )
if(ptrIn%from_contact(n)) then
select case ( dir )
case ( 1 ) ! E
isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
case ( 2 ) ! SE
isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
case ( 3 ) ! S
isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
case ( 4 ) ! SW
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
case ( 5 ) ! W
isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
case ( 6 ) ! NW
isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
case ( 7 ) ! N
isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
case ( 8 ) ! NE
isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
end select
call insert_overlap_type(overlap, PtrIn%pe, PtrIn%tileMe(n), PtrIn%tileNbr(n), &
Ptrin%is(n) + isoff1, Ptrin%ie(n) + ieoff1, Ptrin%js(n) + jsoff1, &
Ptrin%je(n) + jeoff1, PtrIn%dir(n), PtrIn%rotation(n), PtrIn%from_contact(n))
count = overlap%count
end if
end do ! do n = 1, ptrIn%count
if(overlap%count > 0) then
call add_update_overlap(overlapList(pos), overlap)
call init_overlap_type(overlap)
endif
do tMe = 1, size(domain%x(:))
do n = 1, overlap%count
if(overlap%tileMe(n) == tMe) then
if(overlap%dir(n) == 1 ) domain%x(tMe)%loffset = 0
if(overlap%dir(n) == 7 ) domain%y(tMe)%loffset = 0
end if
end do
end do
end do ! do list = 0, nlist-1
nrecv = 0
do list = 0, nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(overlapList(m)%count>0) nrecv = nrecv+1
enddo
update_out%nrecv = nrecv
if(nrecv>0) then
allocate(update_out%recv(nrecv))
pos = 0
do list = 0, nlist-1
m = mod( domain%pos+nlist-list, nlist )
if(overlapList(m)%count>0) then
pos = pos+1
if(pos>nrecv) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_contact_point): pos should be no larger than nrecv")
call add_update_overlap(update_out%recv(pos), overlapList(m))
call deallocate_overlap_type(overlapList(m))
endif
enddo
if(pos .NE. nrecv) call mpp_error(FATAL, &
"mpp_domains_define.inc(set_contact_point): pos should equal to nrecv")
endif
call deallocate_overlap_type(overlap)
end subroutine set_contact_point
!--- set up the overlapping for boundary check if the domain is symmetry. The check will be
!--- done on current pe for east boundary for E-cell, north boundary for N-cell,
!--- East and North boundary for C-cell
subroutine set_check_overlap( domain, position )
type(domain2d), intent(in) :: domain
integer, intent(in) :: position
integer :: nlist, m, n
integer, parameter :: MAXCOUNT = 100
integer :: is, ie, js, je
integer :: nsend, nrecv, pos, maxsize, rotation
type(overlap_type) :: overlap
type(overlapSpec), pointer :: update => NULL()
type(overlapSpec), pointer :: check => NULL()
select case(position)
case (CORNER)
update => domain%update_C
check => domain%check_C
case (EAST)
update => domain%update_E
check => domain%check_E
case (NORTH)
update => domain%update_N
check => domain%check_N
case default
call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
end select
check%xbegin = update%xbegin; check%xend = update%xend
check%ybegin = update%ybegin; check%yend = update%yend
check%nsend = 0
check%nrecv = 0
if( .NOT. domain%symmetry ) return
nsend = 0
maxsize = 0
do m = 1, update%nsend
do n = 1, update%send(m)%count
if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
if( ( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) .OR. &
( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) ) then
maxsize = max(maxsize, update%send(m)%count)
nsend = nsend + 1
exit
endif
enddo
enddo
if(nsend>0) then
allocate(check%send(nsend))
call allocate_check_overlap(overlap, maxsize)
endif
nlist = size(domain%list(:))
!--- loop over the list of domains to find the boundary overlap for send
pos = 0
do m = 1, update%nsend
do n = 1, update%send(m)%count
if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
! comparing east direction on currently pe
if( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) then
rotation = update%send(m)%rotation(n)
select case( rotation )
case( ZERO ) ! W -> E
is = update%send(m)%is(n) - 1
ie = is
js = update%send(m)%js(n)
je = update%send(m)%je(n)
case( NINETY ) ! S -> E
is = update%send(m)%is(n)
ie = update%send(m)%ie(n)
js = update%send(m)%js(n) - 1
je = js
end select
call insert_check_overlap(overlap, update%send(m)%pe, &
update%send(m)%tileMe(n), 1, rotation, is, ie, js, je)
end if
! comparing north direction on currently pe
if( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) then
rotation = update%send(m)%rotation(n)
select case( rotation )
case( ZERO ) ! S->N
is = update%send(m)%is(n)
ie = update%send(m)%ie(n)
js = update%send(m)%js(n) - 1
je = js
case( MINUS_NINETY ) ! W->N
is = update%send(m)%is(n) - 1
ie = is
js = update%send(m)%js(n)
je = update%send(m)%je(n)
end select
call insert_check_overlap(overlap, update%send(m)%pe, &
update%send(m)%tileMe(n), 4, rotation, is, ie, js, je)
end if
end do ! do n =1, update%send(m)%count
if(overlap%count>0) then
pos = pos+1
if(pos>nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
call add_check_overlap(check%send(pos), overlap)
call init_overlap_type(overlap)
endif
end do ! end do list = 0, nlist
if(pos .NE. nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
nrecv = 0
maxsize = 0
do m = 1, update%nrecv
do n = 1, update%recv(m)%count
if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
if( ( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) .OR. &
( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) ) then
maxsize = max(maxsize, update%recv(m)%count)
nrecv = nrecv + 1
exit
endif
enddo
enddo
if(nsend>0) call deallocate_overlap_type(overlap)
if(nrecv>0) then
allocate(check%recv(nrecv))
call allocate_check_overlap(overlap, maxsize)
endif
pos = 0
do m = 1, update%nrecv
do n = 1, update%recv(m)%count
if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
if( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) then
is = update%recv(m)%is(n) - 1
ie = is
js = update%recv(m)%js(n)
je = update%recv(m)%je(n)
call insert_check_overlap(overlap, update%recv(m)%pe, &
update%recv(m)%tileMe(n), 1, update%recv(m)%rotation(n), is, ie, js, je)
end if
if( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) then
is = update%recv(m)%is(n)
ie = update%recv(m)%ie(n)
js = update%recv(m)%js(n) - 1
je = js
call insert_check_overlap(overlap, update%recv(m)%pe, &
update%recv(m)%tileMe(n), 3, update%recv(m)%rotation(n), is, ie, js, je)
end if
end do ! n = 1, overlap%count
if(overlap%count>0) then
pos = pos+1
if(pos>nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
call add_check_overlap(check%recv(pos), overlap)
call init_overlap_type(overlap)
endif
end do ! end do list = 0, nlist
if(pos .NE. nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
if(nrecv>0) call deallocate_overlap_type(overlap)
end subroutine set_check_overlap
!#############################################################################
!--- set up the overlapping for boundary if the domain is symmetry.
subroutine set_bound_overlap( domain, position )
type(domain2d), intent(inout) :: domain
integer, intent(in) :: position
integer :: m, n, l, count, dr, tMe, i
integer, parameter :: MAXCOUNT = 100
integer, dimension(MAXCOUNT) :: dir, rotation, is, ie, js, je, tileMe, index
integer, dimension(size(domain%x(:)), 4) :: nrecvl
integer, dimension(size(domain%x(:)), 4, MAXCOUNT) :: isl, iel, jsl, jel
type(overlap_type), pointer :: overlap => NULL()
type(overlapSpec), pointer :: update => NULL()
type(overlapSpec), pointer :: bound => NULL()
integer :: nlist_send, nlist_recv, ishift, jshift
integer :: ism, iem, jsm, jem, nsend, nrecv
integer :: isg, ieg, jsg, jeg, nlist, list
! integer :: isc1, iec1, jsc1, jec1
! integer :: isc2, iec2, jsc2, jec2
integer :: isd, ied, jsd, jed
integer :: npes_x, npes_y, ipos, jpos, inbr, jnbr
integer :: isc, iec, jsc, jec, my_pe
integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
integer :: is_south1, ie_south1, js_south1, je_south1
integer :: is_south2, ie_south2, js_south2, je_south2
integer :: is_west0, ie_west0, js_west0, je_west0
integer :: is_west1, ie_west1, js_west1, je_west1
integer :: is_west2, ie_west2, js_west2, je_west2
logical :: x_cyclic, y_cyclic, folded_north
is_south1=0; ie_south1=0; js_south1=0; je_south1=0
is_south2=0; ie_south2=0; js_south2=0; je_south2=0
is_west0=0; ie_west0=0; js_west0=0; je_west0=0
is_west1=0; ie_west1=0; js_west1=0; je_west1=0
is_west2=0; ie_west2=0; js_west2=0; je_west2=0
if( position == CENTER .OR. .NOT. domain%symmetry ) return
call mpp_get_domain_shift(domain, ishift, jshift, position)
call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
select case(position)
case (CORNER)
update => domain%update_C
bound => domain%bound_C
case (EAST)
update => domain%update_E
bound => domain%bound_E
case (NORTH)
update => domain%update_N
bound => domain%bound_N
case default
call mpp_error( FATAL, "mpp_domains_mod(set_bound_overlap): invalid option of position")
end select
bound%xbegin = ism; bound%xend = iem + ishift
bound%ybegin = jsm; bound%yend = jem + jshift
nlist_send = max(update%nsend,4)
nlist_recv = max(update%nrecv,4)
bound%nsend = nlist_send
bound%nrecv = nlist_recv
if(nlist_send >0) then
allocate(bound%send(nlist_send))
bound%send(:)%count = 0
endif
if(nlist_recv >0) then
allocate(bound%recv(nlist_recv))
bound%recv(:)%count = 0
endif
!--- loop over the list of domains to find the boundary overlap for send
nlist = size(domain%list(:))
npes_x = size(domain%x(1)%list(:))
npes_y = size(domain%y(1)%list(:))
x_cyclic = domain%x(1)%cyclic
y_cyclic = domain%y(1)%cyclic
folded_north = BTEST(domain%fold,NORTH)
ipos = domain%x(1)%pos
jpos = domain%y(1)%pos
isc = domain%x(1)%compute%begin; iec = domain%x(1)%compute%end
jsc = domain%y(1)%compute%begin; jec = domain%y(1)%compute%end
nsend = 0
if(domain%ntiles == 1) then ! use neighbor processor to configure send and recv
! currently only set up for west and south boundary
! south boundary for send
pe_south1 = NULL_PE; pe_south2 = NULL_PE
if( position == NORTH .OR. position == CORNER ) then
inbr = ipos; jnbr = jpos + 1
if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_south1 = domain%pearray(inbr,jnbr)
is_south1 = isc + ishift; ie_south1 = iec+ishift
js_south1 = jec + jshift; je_south1 = js_south1
endif
endif
!--- send to the southwest processor when position is NORTH
if( position == CORNER ) then
inbr = ipos + 1; jnbr = jpos + 1
if( inbr == npes_x .AND. x_cyclic) inbr = 0
if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_south2 = domain%pearray(inbr,jnbr)
is_south2 = iec + ishift; ie_south2 = is_south2
js_south2 = jec + jshift; je_south2 = js_south2
endif
endif
!---west boundary for send
pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
if( position == EAST ) then
inbr = ipos+1; jnbr = jpos
if( inbr == npes_x .AND. x_cyclic) inbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = iec + ishift; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec + jshift
endif
else if ( position == CORNER ) then ! possible split into two parts.
!--- on the fold.
if( folded_north .AND. jec == jeg .AND. ipos .LT. (npes_x-1)/2 ) then
inbr = npes_x - ipos - 1; jnbr = jpos
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west0 = domain%pearray(inbr,jnbr)
is_west0 = iec+ishift; ie_west0 = is_west0
js_west0 = jec+jshift; je_west0 = js_west0
endif
endif
if( folded_north .AND. jec == jeg .AND. ipos .GE. npes_x/2 .AND. ipos .LT. (npes_x-1) ) then
inbr = ipos+1; jnbr = jpos
if( inbr == npes_x .AND. x_cyclic) inbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = iec + ishift; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec
endif
else
inbr = ipos+1; jnbr = jpos
if( inbr == npes_x .AND. x_cyclic) inbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = iec + ishift; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec + jshift
endif
endif
endif
!--- send to the southwest processor when position is NORTH
if( position == CORNER ) then
inbr = ipos + 1; jnbr = jpos + 1
if( inbr == npes_x .AND. x_cyclic) inbr = 0
if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west2 = domain%pearray(inbr,jnbr)
is_west2 = iec + ishift; ie_west2 = is_west2
js_west2 = jec + jshift; je_west2 = js_west2
endif
endif
!write(1000+mpp_pe(),*)"send south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
!write(1000+mpp_pe(),*)"send south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
!write(1000+mpp_pe(),*)"send west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
!write(1000+mpp_pe(),*)"send west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
!write(1000+mpp_pe(),*)"send west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
do list = 0,nlist-1
m = mod( domain%pos+list, nlist )
count = 0
my_pe = domain%list(m)%pe
if(my_pe == pe_south1) then
count = count + 1
is(count) = is_south1; ie(count) = ie_south1
js(count) = js_south1; je(count) = je_south1
dir(count) = 2
rotation(count) = ZERO
endif
if(my_pe == pe_south2) then
count = count + 1
is(count) = is_south2; ie(count) = ie_south2
js(count) = js_south2; je(count) = je_south2
dir(count) = 2
rotation(count) = ZERO
endif
if(my_pe == pe_west0) then
count = count + 1
is(count) = is_west0; ie(count) = ie_west0
js(count) = js_west0; je(count) = je_west0
dir(count) = 3
rotation(count) = ONE_HUNDRED_EIGHTY
endif
if(my_pe == pe_west1) then
count = count + 1
is(count) = is_west1; ie(count) = ie_west1
js(count) = js_west1; je(count) = je_west1
dir(count) = 3
rotation(count) = ZERO
endif
if(my_pe == pe_west2) then
count = count + 1
is(count) = is_west2; ie(count) = ie_west2
js(count) = js_west2; je(count) = je_west2
dir(count) = 3
rotation(count) = ZERO
endif
if(count >0) then
nsend = nsend + 1
if(nsend > nlist_send) call mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send")
bound%send(nsend)%count = count
bound%send(nsend)%pe = my_pe
allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
allocate(bound%send(nsend)%tileMe(count))
bound%send(nsend)%is(:) = is(1:count)
bound%send(nsend)%ie(:) = ie(1:count)
bound%send(nsend)%js(:) = js(1:count)
bound%send(nsend)%je(:) = je(1:count)
bound%send(nsend)%dir(:) = dir(1:count)
bound%send(nsend)%tileMe(:) = 1
bound%send(nsend)%rotation(:) = rotation(1:count)
!write(1000+mpp_pe(),*) "send:", count, my_pe
!do i = 1, count
! write(1000+mpp_pe(),*) "send index:", is(i), ie(i), js(i), je(i), dir(i), rotation(i)
!enddo
endif
enddo
else
!--- The following did not consider wide halo case.
do m = 1, update%nsend
overlap => update%send(m)
if( overlap%count == 0 ) cycle
count = 0
do n = 1, overlap%count
!--- currently not support folded-north
if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
count=count+1
dir(count) = 1
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
select case( rotation(count) )
case( ZERO ) ! W -> E
is(count) = overlap%is(n) - 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
case( NINETY ) ! S -> E
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%js(n) - 1
je(count) = js(count)
end select
end if
if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3 ) then ! south
count=count+1
dir(count) = 2
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
select case( rotation(count) )
case( ZERO ) ! N->S
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%je(n) + 1
je(count) = js(count)
case( MINUS_NINETY ) ! E->S
is(count) = overlap%ie(n) + 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
end select
end if
if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5 ) then ! west
count=count+1
dir(count) = 3
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
select case( rotation(count) )
case( ZERO ) ! E->W
is(count) = overlap%ie(n) + 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
case( NINETY ) ! N->W
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%je(n) + 1
je(count) = js(count)
end select
end if
if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7 ) then ! north
count=count+1
dir(count) = 4
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
select case( rotation(count) )
case( ZERO ) ! S->N
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%js(n) - 1
je(count) = js(count)
case( MINUS_NINETY ) ! W->N
is(count) = overlap%is(n) - 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
end select
end if
end do ! do n =1, overlap%count
if(count>0) then
nsend = nsend + 1
bound%send(nsend)%count = count
bound%send(nsend)%pe = overlap%pe
allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
allocate(bound%send(nsend)%tileMe(count))
bound%send(nsend)%is(:) = is(1:count)
bound%send(nsend)%ie(:) = ie(1:count)
bound%send(nsend)%js(:) = js(1:count)
bound%send(nsend)%je(:) = je(1:count)
bound%send(nsend)%dir(:) = dir(1:count)
bound%send(nsend)%tileMe(:) = tileMe(1:count)
bound%send(nsend)%rotation(:) = rotation(1:count)
end if
end do ! end do list = 0, nlist
endif
!--- loop over the list of domains to find the boundary overlap for recv
bound%nsend = nsend
nrecvl(:,:) = 0
nrecv = 0
!--- will computing overlap for tripolar grid.
if( domain%ntiles == 1 ) then
! currently only set up for west and south boundary
! south boundary for recv
pe_south1 = NULL_PE; pe_south2 = NULL_PE
if( position == NORTH .OR. position == CORNER ) then
inbr = ipos; jnbr = jpos - 1
if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_south1 = domain%pearray(inbr,jnbr)
is_south1 = isc + ishift; ie_south1 = iec+ishift
js_south1 = jsc; je_south1 = js_south1
endif
endif
!--- south boudary for recv: the southwest point when position is NORTH
if( position == CORNER ) then
inbr = ipos - 1; jnbr = jpos - 1
if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_south2 = domain%pearray(inbr,jnbr)
is_south2 = isc; ie_south2 = is_south2
js_south2 = jsc; je_south2 = js_south2
endif
endif
!---west boundary for recv
pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
if( position == EAST ) then
inbr = ipos-1; jnbr = jpos
if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = isc; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec + jshift
endif
else if ( position == CORNER ) then ! possible split into two parts.
!--- on the fold.
if( folded_north .AND. jec == jeg .AND. ipos .GT. npes_x/2 ) then
inbr = npes_x - ipos - 1; jnbr = jpos
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west0 = domain%pearray(inbr,jnbr)
is_west0 = isc; ie_west0 = is_west0
js_west0 = jec+jshift; je_west0 = js_west0
endif
inbr = ipos-1; jnbr = jpos
if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = isc; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec
endif
else
inbr = ipos-1; jnbr = jpos
if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west1 = domain%pearray(inbr,jnbr)
is_west1 = isc; ie_west1 = is_west1
js_west1 = jsc + jshift; je_west1 = jec+jshift
endif
endif
endif
!--- west boundary for recv: the southwest point when position is CORNER
if( position == CORNER ) then
inbr = ipos - 1; jnbr = jpos - 1
if( inbr == -1 .AND. x_cyclic) inbr = npes_x - 1
if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y - 1
if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
pe_west2 = domain%pearray(inbr,jnbr)
is_west2 = isc; ie_west2 = is_west2
js_west2 = jsc; je_west2 = js_west2
endif
endif
!write(1000+mpp_pe(),*)"recv south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
!write(1000+mpp_pe(),*)"recv south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
!write(1000+mpp_pe(),*)"recv west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
!write(1000+mpp_pe(),*)"recv west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
!write(1000+mpp_pe(),*)"recv west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
tMe = 1
do list = 0,nlist-1
m = mod( domain%pos+nlist-list, nlist )
count = 0
my_pe = domain%list(m)%pe
if(my_pe == pe_south1) then
count = count + 1
is(count) = is_south1; ie(count) = ie_south1
js(count) = js_south1; je(count) = je_south1
dir(count) = 2
rotation(count) = ZERO
index(count) = 1 + ishift
endif
if(my_pe == pe_south2) then
count = count + 1
is(count) = is_south2; ie(count) = ie_south2
js(count) = js_south2; je(count) = je_south2
dir(count) = 2
rotation(count) = ZERO
index(count) = 1
endif
if(my_pe == pe_west0) then
count = count + 1
is(count) = is_west0; ie(count) = ie_west0
js(count) = js_west0; je(count) = je_west0
dir(count) = 3
rotation(count) = ONE_HUNDRED_EIGHTY
index(count) = jec-jsc+1+jshift
endif
if(my_pe == pe_west1) then
count = count + 1
is(count) = is_west1; ie(count) = ie_west1
js(count) = js_west1; je(count) = je_west1
dir(count) = 3
rotation(count) = ZERO
index(count) = 1 + jshift
endif
if(my_pe == pe_west2) then
count = count + 1
is(count) = is_west2; ie(count) = ie_west2
js(count) = js_west2; je(count) = je_west2
dir(count) = 3
rotation(count) = ZERO
index(count) = 1
endif
if(count >0) then
nrecv = nrecv + 1
if(nrecv > nlist_recv) call mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv")
bound%recv(nrecv)%count = count
bound%recv(nrecv)%pe = my_pe
allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
bound%recv(nrecv)%is(:) = is(1:count)
bound%recv(nrecv)%ie(:) = ie(1:count)
bound%recv(nrecv)%js(:) = js(1:count)
bound%recv(nrecv)%je(:) = je(1:count)
bound%recv(nrecv)%dir(:) = dir(1:count)
bound%recv(nrecv)%tileMe(:) = 1
bound%recv(nrecv)%rotation(:) = rotation(1:count)
bound%recv(nrecv)%index(:) = index(1:count)
!write(1000+mpp_pe(),*) "recv:", count, my_pe
!do i = 1, count
! write(1000+mpp_pe(),*) "recv index:", is(i), ie(i), js(i), je(i), dir(i), rotation(i)
!enddo
endif
enddo
else
do m = 1, update%nrecv
overlap => update%recv(m)
if( overlap%count == 0 ) cycle
count = 0
do n = 1, overlap%count
!--- currently not support folded-north
if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
count=count+1
dir(count) = 1
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
is(count) = overlap%is(n) - 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
tMe = tileMe(count)
nrecvl(tMe, 1) = nrecvl(tMe,1) + 1
isl (tMe,1,nrecvl(tMe, 1)) = is (count)
iel (tMe,1,nrecvl(tMe, 1)) = ie (count)
jsl (tMe,1,nrecvl(tMe, 1)) = js (count)
jel (tMe,1,nrecvl(tMe, 1)) = je (count)
end if
if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3) then ! south
count=count+1
dir(count) = 2
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%je(n) + 1
je(count) = js(count)
tMe = tileMe(count)
nrecvl(tMe, 2) = nrecvl(tMe,2) + 1
isl (tMe,2,nrecvl(tMe, 2)) = is (count)
iel (tMe,2,nrecvl(tMe, 2)) = ie (count)
jsl (tMe,2,nrecvl(tMe, 2)) = js (count)
jel (tMe,2,nrecvl(tMe, 2)) = je (count)
end if
if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5) then ! west
count=count+1
dir(count) = 3
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
is(count) = overlap%ie(n) + 1
ie(count) = is(count)
js(count) = overlap%js(n)
je(count) = overlap%je(n)
tMe = tileMe(count)
nrecvl(tMe, 3) = nrecvl(tMe,3) + 1
isl (tMe,3,nrecvl(tMe, 3)) = is (count)
iel (tMe,3,nrecvl(tMe, 3)) = ie (count)
jsl (tMe,3,nrecvl(tMe, 3)) = js (count)
jel (tMe,3,nrecvl(tMe, 3)) = je (count)
end if
if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7) then ! north
count=count+1
dir(count) = 4
rotation(count) = overlap%rotation(n)
tileMe(count) = overlap%tileMe(n)
is(count) = overlap%is(n)
ie(count) = overlap%ie(n)
js(count) = overlap%js(n) - 1
je(count) = js(count)
tMe = tileMe(count)
nrecvl(tMe, 4) = nrecvl(tMe,4) + 1
isl (tMe,4,nrecvl(tMe, 4)) = is (count)
iel (tMe,4,nrecvl(tMe, 4)) = ie (count)
jsl (tMe,4,nrecvl(tMe, 4)) = js (count)
jel (tMe,4,nrecvl(tMe, 4)) = je (count)
end if
end do ! do n = 1, overlap%count
if(count>0) then
nrecv = nrecv + 1
bound%recv(nrecv)%count = count
bound%recv(nrecv)%pe = overlap%pe
allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
bound%recv(nrecv)%is(:) = is(1:count)
bound%recv(nrecv)%ie(:) = ie(1:count)
bound%recv(nrecv)%js(:) = js(1:count)
bound%recv(nrecv)%je(:) = je(1:count)
bound%recv(nrecv)%dir(:) = dir(1:count)
bound%recv(nrecv)%tileMe(:) = tileMe(1:count)
bound%recv(nrecv)%rotation(:) = rotation(1:count)
end if
end do ! end do list = 0, nlist
!--- find the boundary index for each contact within the east boundary
do m = 1, nrecv
do n = 1, bound%recv(m)%count
tMe = bound%recv(m)%tileMe(n)
dr = bound%recv(m)%dir(n)
bound%recv(m)%index(n) = 1
do l = 1, nrecvl(tMe,dr)
if(dr == 1 .OR. dr == 3) then ! EAST, WEST
if( bound%recv(m)%js(n) > jsl(tMe, dr, l) ) then
if( bound%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) then
bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l))+1, &
abs(iel(tMe, dr, l)-isl(tMe, dr, l))+1)
else
bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - jshift
endif
end if
else ! South, North
if( bound%recv(m)%is(n) > isl(tMe, dr, l) ) then
bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - ishift
end if
end if
end do
end do
end do
endif
bound%nrecv = nrecv
end subroutine set_bound_overlap
!#############################################################################
subroutine fill_corner_contact(eCont, sCont, wCont, nCont, isg, ieg, jsg, jeg, numR, numS, tileRecv, tileSend, &
is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv, &
is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send, &
align1Recv, align2Recv, align1Send, align2Send, &
whalo, ehalo, shalo, nhalo, tileMe)
type(contact_type), dimension(:), intent(in) :: eCont, sCont, wCont, nCont
integer, dimension(:), intent(in) :: isg, ieg, jsg, jeg
integer, intent(inout) :: numR, numS
integer, dimension(:), intent(inout) :: tileRecv, tileSend
integer, dimension(:), intent(inout) :: is1Recv, ie1Recv, js1Recv, je1Recv
integer, dimension(:), intent(inout) :: is2Recv, ie2Recv, js2Recv, je2Recv
integer, dimension(:), intent(inout) :: is1Send, ie1Send, js1Send, je1Send
integer, dimension(:), intent(inout) :: is2Send, ie2Send, js2Send, je2Send
integer, dimension(:), intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
integer, intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
integer :: is1, ie1, js1, je1, is2, ie2, js2, je2
integer :: tn, tc, n, m
logical :: found_corner
found_corner = .false.
!--- southeast for recving
if(eCont(tileMe)%ncontact > 0) then
if(eCont(tileMe)%js1(1) == jsg(tileMe) ) then
tn = eCont(tileMe)%tile(1)
if(econt(tileMe)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
if( econt(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
found_corner = .true.; tc = tn
is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
is2 = eCont(tileMe)%is2(1); je2 = eCont(tileMe)%js2(1) - 1
else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
if(sCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
found_corner = .true.; tc = sCont(tn)%tile(1)
is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
is2 = sCont(tn)%is2(1); je2 = sCont(tn)%je2(1)
end if
end if
end if
end if
if( .not. found_corner ) then ! not found,
n = sCont(tileMe)%ncontact
if( n > 0) then
if( sCont(tileMe)%ie1(n) == ieg(tileMe)) then
tn = sCont(tileMe)%tile(n)
if(scont(tileMe)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
if(ieg(tn) - scont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southeast tile for recv 2 is not tiled properly")
found_corner = .true.; tc = tn
is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
is2 = sCont(tileMe)%ie2(n) + 1; je2 = sCont(tileMe)%je2(n)
else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
m = eCont(tn)%ncontact
if(eCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
found_corner = .true.; tc = eCont(tn)%tile(m)
is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
is2 = eCont(tn)%is2(m); je2 = eCont(tn)%je2(m)
end if
end if
end if
end if
end if
if(found_corner) then
numR = numR + 1
tileRecv(numR) = tc; align1Recv(numR) = SOUTH_EAST; align2Recv(numR) = NORTH_WEST
is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
end if
!--- southwest for recving
found_corner = .false.
if(wCont(tileMe)%ncontact > 0) then
if(wCont(tileMe)%js1(1) == jsg(tileMe) ) then
tn = wCont(tileMe)%tile(1)
if(wcont(tileMe)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
if( wcont(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
found_corner = .true.; tc = tn
ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
ie2 = wCont(tileMe)%is2(1); je2 = wCont(tileMe)%js2(1) - 1
else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
n = sCont(tn)%ncontact
if(sCont(tn)%ie1(n) == ieg(tn)) then ! corner is nc.
found_corner = .true.; tc = sCont(tn)%tile(n)
ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
ie2 = sCont(tn)%ie2(1); je2 = sCont(tn)%je2(1)
end if
end if
end if
end if
if( .not. found_corner ) then ! not found,
n = sCont(tileMe)%ncontact
if( n > 0) then
if( sCont(tileMe)%is1(1) == isg(tileMe)) then
tn = sCont(tileMe)%tile(1)
if(sCont(tileMe)%is2(1) > isg(tn) ) then ! the corner tile is tn.
if( scont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
found_corner = .true.; tc = tn
ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
ie2 = sCont(tileMe)%is2(1) - 1; je2 = sCont(tileMe)%js2(1)
else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
m = wCont(tn)%ncontact
if(wCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
found_corner = .true.; tc = wCont(tn)%tile(m)
ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
ie2 = wCont(tn)%ie2(m); je2 = wCont(tn)%je2(m)
end if
end if
end if
end if
end if
if(found_corner) then
numR = numR + 1
tileRecv(numR) = tc; align1Recv(numR) = SOUTH_WEST; align2Recv(numR) = NORTH_EAST
is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
end if
!--- northwest for recving
found_corner = .false.
n = wCont(tileMe)%ncontact
if( n > 0) then
if(wCont(tileMe)%je1(n) == jeg(tileMe) ) then
tn = wCont(tileMe)%tile(n)
if(wcont(tileMe)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
if( jeg(tn) - wcont(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northwest tile for recv 1 is not tiled properly")
found_corner = .true.; tc = tn
ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
ie2 = wCont(tileMe)%is2(n); js2 = wCont(tileMe)%je2(n) + 1
else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
m = nCont(tn)%ncontact
if(nCont(tn)%ie1(m) == ieg(tn)) then ! corner is nc.
found_corner = .true.; tc = nCont(tn)%tile(m)
ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
ie2 = nCont(tn)%ie2(m); js2 = nCont(tn)%js2(m)
end if
endif
endif
end if
if( .not. found_corner ) then ! not found,
if( nCont(tileMe)%ncontact > 0) then
if( nCont(tileMe)%is1(1) == isg(tileMe)) then
tn = nCont(tileMe)%tile(1)
if(nCont(tileMe)%is2(1) > isg(tn) ) then ! the corner tile is tn.
if( ncont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northwest tile for recv 2 is not tiled properly")
found_corner = .true.; tc = tn
ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
ie2 = nCont(tileMe)%is2(1) - 1; js2 = nCont(tileMe)%js2(1)
else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
if(wCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
found_corner = .true.; tc = wCont(tn)%tile(1)
ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
ie2 = wCont(tn)%ie2(1); js2 = wCont(tn)%js2(1)
end if
end if
end if
end if
end if
if(found_corner) then
numR = numR + 1
tileRecv(numR) = tc; align1Recv(numR) =NORTH_WEST; align2Recv(numR) = SOUTH_EAST
is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
end if
!--- northeast for recving
found_corner = .false.
n = eCont(tileMe)%ncontact
if( n > 0) then
if(eCont(tileMe)%je1(n) == jeg(tileMe) ) then
tn = eCont(tileMe)%tile(n)
if(econt(tileMe)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
if( jeg(tn) - econt(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northeast tile for recv 1 is not tiled properly")
found_corner = .true.; tc = tn
is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
is2 = eCont(tileMe)%is2(1); js2 = eCont(tileMe)%je2(1) + 1
else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
if(nCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
found_corner = .true.; tc = nCont(tn)%tile(1)
is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
is2 = nCont(tn)%is2(1); js2 = nCont(tn)%js2(1)
end if
end if
end if
end if
if( .not. found_corner ) then ! not found,
n = nCont(tileMe)%ncontact
if( n > 0) then
if( nCont(tileMe)%ie1(n) == ieg(tileMe)) then
tn = nCont(tileMe)%tile(n)
if(nCont(tileMe)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
if(ieg(tn) - sCont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northeast tile for recv 2 is not tiled properly")
found_corner = .true.; tc = tn
is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
is2 = sCont(tileMe)%ie2(n) + 1; js2 = sCont(tileMe)%js2(n)
else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
if(eCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
found_corner = .true.; tc = eCont(tn)%tile(1)
is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
is2 = eCont(tn)%is2(m); js2 = eCont(tn)%js2(m)
end if
end if
end if
end if
end if
if(found_corner) then
numR = numR + 1
tileRecv(numR) = tc; align1Recv(numR) =NORTH_EAST; align2Recv(numR) = SOUTH_WEST
is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
end if
!--- to_pe's southeast for sending
do n = 1, wCont(tileMe)%ncontact
tn = wCont(tileMe)%tile(n)
if(wCont(tileMe)%js2(n) == jsg(tn) ) then
if(wcont(tileMe)%js1(n) > jsg(tileMe) ) then ! send to tile tn.
if( wcont(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southeast tile for send 1 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
is1Send(numS) = wCont(tileMe)%is1(n); ie1Send(numS) = is1Send(numS) + ehalo - 1
je1Send(numS) = wCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
je2Send(numS) = wCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
end if
end do
do n = 1, nCont(tileMe)%ncontact
tn = nCont(tileMe)%tile(n)
if(nCont(tileMe)%ie2(n) == ieg(tn) ) then
if(nCont(tileMe)%ie1(n) < ieg(tileMe) ) then ! send to tile tn.
if( ieg(tileMe) - nCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
is1Send(numS) = nCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
je1Send(numS) = nCont(tileMe)%je1(n) ; js1Send(numS) = je1Send(numS) - shalo + 1
is2Send(numS) = nCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
je2Send(numS) = nCont(tileMe)%je2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
end if
end do
!--- found the corner overlap that is not specified through contact line.
n = wCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = wCont(tileMe)%tile(n)
if( wCont(tileMe)%je1(n) == jeg(tileMe) .AND. wCont(tileMe)%je2(n) == jeg(tn) ) then
m = nCont(tn)%ncontact
if(m >0) then
tc = nCont(tn)%tile(m)
if( nCont(tn)%ie1(m) == ieg(tn) .AND. nCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
end if
end if
end if
if( .not. found_corner ) then ! not found, then starting from north contact
if( nCont(tileMe)%ncontact > 0) then
tn = nCont(tileMe)%tile(1)
if( nCont(tileMe)%is1(1) == isg(tileMe) .AND. nCont(tileMe)%is2(1) == isg(tn) ) then
if(wCont(tn)%ncontact >0) then
tc = wCont(tn)%tile(1)
if( wCont(tn)%js1(1) == jsg(tn) .AND. wCont(tn)%js2(1) == jsg(tc) ) found_corner = .true.
end if
end if
end if
end if
if(found_corner) then
numS = numS+1; tileSend(numS) = tc
align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
!--- to_pe's southwest for sending
do n = 1, eCont(tileMe)%ncontact
tn = eCont(tileMe)%tile(n)
if(eCont(tileMe)%js2(n) == jsg(tn) ) then
if(econt(tileMe)%js1(n) > jsg(tileMe) ) then ! send to tile tn.
if( econt(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southwest tile for send 1 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
ie1Send(numS) = eCont(tileMe)%ie1(n); is1Send(numS) = ie1Send(numS) - whalo + 1
je1Send(numS) = eCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
je2Send(numS) = eCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
end if
end do
do n = 1, nCont(tileMe)%ncontact
tn = nCont(tileMe)%tile(n)
if(nCont(tileMe)%is2(n) == isg(tn) ) then
if(ncont(tileMe)%is1(n) > isg(tileMe) ) then ! send to tile tn.
if( ncont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
ie1Send(numS) = nCont(tileMe)%je1(n) ; js1Send(numS) = je1Send(numS) - shalo + 1
ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = je2Send(numS) - whalo + 1
je2Send(numS) = nCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
end if
end do
!--- found the corner overlap that is not specified through contact line.
n = eCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = eCont(tileMe)%tile(n)
if( eCont(tileMe)%je1(n) == jeg(tileMe) .AND. eCont(tileMe)%je2(n) == jeg(tn) ) then
if(nCont(tn)%ncontact >0) then
tc = nCont(tn)%tile(1)
if( nCont(tn)%is1(1) == isg(tn) .AND. nCont(tn)%is2(n) == isg(tc) ) found_corner = .true.
end if
end if
end if
if( .not. found_corner ) then ! not found, then starting from north contact
n = nCont(tileMe)%ncontact
if( n > 0) then
tn = nCont(tileMe)%tile(n)
if( nCont(tileMe)%ie1(n) == ieg(tileMe) .AND. nCont(tileMe)%ie2(n) == ieg(tn) ) then
if(eCont(tn)%ncontact >0) then
tc = eCont(tn)%tile(1)
if( eCont(tn)%js1(1) == jsg(tn) .AND. eCont(tn)%js2(n) == jsg(tc) ) found_corner = .true.
end if
end if
end if
end if
if(found_corner) then
numS = numS+1; tileSend(numS) = tc
align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
end if
!--- to_pe's northwest for sending
do n = 1, eCont(tileMe)%ncontact
tn = eCont(tileMe)%tile(n)
if(eCont(tileMe)%je2(n) == jeg(tn) ) then
if(econt(tileMe)%je1(n) < jeg(tileMe) ) then ! send to tile tn.
if( jeg(tileMe) - econt(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northwest tile for send 1 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
ie1Send(numS) = eCont(tileMe)%ie1(n) ; is1Send(numS) = ie1Send(numS) - whalo + 1
js1Send(numS) = eCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
js2Send(numS) = eCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
end if
end do
do n = 1, sCont(tileMe)%ncontact
tn = sCont(tileMe)%tile(n)
if(sCont(tileMe)%is2(n) == isg(tn) ) then
if(scont(tileMe)%is1(n) > isg(tileMe) ) then ! send to tile tn.
if( scont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
js1Send(numS) = nCont(tileMe)%je1(n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
js2Send(numS) = nCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
end if
end do
!--- found the corner overlap that is not specified through contact line.
n = eCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = eCont(tileMe)%tile(1)
if( eCont(tileMe)%js1(1) == jsg(tileMe) .AND. eCont(tileMe)%js2(1) == jsg(tn) ) then
if(sCont(tn)%ncontact >0) then
tc = sCont(tn)%tile(1)
if( sCont(tn)%is1(1) == isg(tn) .AND. sCont(tn)%is2(1) == isg(tc) ) found_corner = .true.
end if
end if
end if
if( .not. found_corner ) then ! not found, then starting from north contact
n = sCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = sCont(tileMe)%tile(n)
if( sCont(tileMe)%ie1(n) == ieg(tileMe) .AND. sCont(tileMe)%ie2(n) == ieg(tn) ) then
if(eCont(tn)%ncontact >0) then
tc = eCont(tn)%tile(n)
if( eCont(tn)%je1(n) == jeg(tn) .AND. eCont(tn)%je2(n) == jeg(tc) ) found_corner = .true.
end if
end if
end if
end if
if(found_corner) then
numS = numS+1; tileSend(numS) = tc
align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
!--- to_pe's northeast for sending
do n = 1, wCont(tileMe)%ncontact
tn = wCont(tileMe)%tile(n)
if(wCont(tileMe)%je2(n) == jeg(tn) ) then
if(wcont(tileMe)%je1(n) < jeg(tileMe) ) then ! send to tile tn.
if( jeg(tileMe) - wcont(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: northeast tile for send 1 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
is1Send(numS) = wCont(tileMe)%is1(n) ; ie1Send(numS) = is1Send(numS) + ehalo - 1
js1Send(numS) = wCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
js2Send(numS) = wCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
end if
end do
do n = 1, sCont(tileMe)%ncontact
tn = sCont(tileMe)%tile(n)
if(sCont(tileMe)%ie2(n) == ieg(tn) ) then
if(sCont(tileMe)%ie1(n) < ieg(tileMe) ) then ! send to tile tn.
if( ieg(tileMe) - sCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
"mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
numS = numS+1; tileSend(numS) = tn
align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
is1Send(numS) = sCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
js1Send(numS) = sCont(tileMe)%js1(n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
is2Send(numS) = sCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is1Send(numS) + ehalo - 1
js2Send(numS) = sCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
end if
end do
!--- found the corner overlap that is not specified through contact line.
n = wCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = wCont(tileMe)%tile(1)
if( wCont(tileMe)%js1(n) == jsg(tileMe) .AND. wCont(tileMe)%js2(n) == jsg(tn) ) then
m = sCont(tn)%ncontact
if(m >0) then
tc = sCont(tn)%tile(m)
if( sCont(tn)%ie1(m) == ieg(tn) .AND. sCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
end if
end if
end if
if( .not. found_corner ) then ! not found, then starting from north contact
n = sCont(tileMe)%ncontact
found_corner = .false.
if( n > 0) then
tn = sCont(tileMe)%tile(1)
if( sCont(tileMe)%is1(1) == isg(tileMe) .AND. sCont(tileMe)%is2(1) == isg(tn) ) then
m = wCont(tn)%ncontact
if( m > 0 ) then
tc = wCont(tn)%tile(m)
if( wCont(tn)%je1(m) == jeg(tn) .AND. wCont(tn)%je2(m) == jeg(tc) ) found_corner = .true.
end if
end if
end if
end if
if(found_corner) then
numS = numS+1; tileSend(numS) = tc
align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
end if
end subroutine fill_corner_contact
!--- find the alignment direction, check if index is reversed, if reversed, exchange index.
subroutine check_alignment( is, ie, js, je, isg, ieg, jsg, jeg, alignment )
integer, intent(inout) :: is, ie, js, je, isg, ieg, jsg, jeg
integer, intent(out) :: alignment
integer :: i, j
if ( is == ie ) then ! x-alignment
if ( is == isg ) then
alignment = WEST
else if ( is == ieg ) then
alignment = EAST
else
call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the x-boundary of the tile')
end if
if ( js > je ) then
j = js; js = je; je = j
end if
else if ( js == je ) then ! y-alignment
if ( js == jsg ) then
alignment = SOUTH
else if ( js == jeg ) then
alignment = NORTH
else
call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the y-boundary of the tile')
end if
if ( is > ie ) then
i = is; is = ie; ie = i
end if
else
call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region should be line contact' )
end if
end subroutine check_alignment
!#####################################################################
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! MPP_MODIFY_DOMAIN: modify extent of domain !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
!
!
!
!
subroutine mpp_modify_domain1D(domain_in,domain_out,cbegin,cend,gbegin,gend, hbegin, hend)
!
type(domain1D), intent(in) :: domain_in
type(domain1D), intent(inout) :: domain_out
integer, intent(in), optional :: hbegin, hend ! halo size
integer, intent(in), optional :: cbegin, cend ! extent of compute_domain
integer, intent(in), optional :: gbegin, gend ! extent of global domain
integer :: ndivs, global_indices(2) !(/ isg, ieg /)
integer :: flag
! get the global indices of the input domain
global_indices(1) = domain_in%global%begin; global_indices(2) = domain_in%global%end
! get the layout
ndivs = size(domain_in%list(:))
! get the flag
flag = 0
if(domain_in%cyclic) flag = flag + CYCLIC_GLOBAL_DOMAIN
if(domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN
call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, &
flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size )
if(present(cbegin)) domain_out%compute%begin = cbegin
if(present(cend)) domain_out%compute%end = cend
domain_out%compute%size = domain_out%compute%end - domain_out%compute%begin + 1
if(present(gbegin)) domain_out%global%begin = gbegin
if(present(gend)) domain_out%global%end = gend
domain_out%global%size = domain_out%global%end - domain_out%global%begin + 1
end subroutine mpp_modify_domain1D
!
!#######################################################################
!----------------------------------------------------------------------------------
!
!
!
!
!
!
!
!
!
!
subroutine mpp_modify_domain2D(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, shalo, nhalo)
!
type(domain2D), intent(in) :: domain_in
type(domain2D), intent(inout) :: domain_out
integer, intent(in), optional :: isc, iec, jsc, jec
integer, intent(in), optional :: isg, ieg, jsg, jeg
integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
integer :: global_indices(4), layout(2)
integer :: xflag, yflag, nlist, i
if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) then
! get the global indices of the input domain
global_indices(1) = domain_in%x(1)%global%begin; global_indices(2) = domain_in%x(1)%global%end
global_indices(3) = domain_in%y(1)%global%begin; global_indices(4) = domain_in%y(1)%global%end
! get the layout
layout(1) = size(domain_in%x(1)%list(:)); layout(2) = size(domain_in%y(1)%list(:))
! get the flag
xflag = 0; yflag = 0
if(domain_in%x(1)%cyclic) xflag = xflag + CYCLIC_GLOBAL_DOMAIN
if(domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN
if(domain_in%y(1)%cyclic) yflag = yflag + CYCLIC_GLOBAL_DOMAIN
if(domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN
call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, &
xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, &
shalo = shalo, nhalo = nhalo, &
xextent = domain_in%x(1)%list(:)%compute%size, &
yextent = domain_in%y(1)%list(:)%compute%size, &
symmetry=domain_in%symmetry, &
maskmap = domain_in%pearray .NE. NULL_PE )
domain_out%ntiles = domain_in%ntiles
domain_out%tile_id = domain_in%tile_id
else
call mpp_define_null_domain(domain_out)
nlist = size(domain_in%list(:))
allocate(domain_out%list(0:nlist-1) )
do i = 0, nlist-1
allocate(domain_out%list(i)%tile_id(1))
domain_out%list(i)%tile_id(1) = 1
enddo
call mpp_modify_domain(domain_in%x(1), domain_out%x(1), isc, iec, isg, ieg)
call mpp_modify_domain(domain_in%y(1), domain_out%y(1), jsc, jec, jsg, jeg)
domain_out%ntiles = domain_in%ntiles
domain_out%tile_id = domain_in%tile_id
endif
end subroutine mpp_modify_domain2D
!
!#####################################################################
subroutine mpp_define_null_domain1D(domain)
type(domain1D), intent(inout) :: domain
domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0
domain%data%begin = -1; domain%data%end = -1; domain%data%size = 0
domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
domain%pe = NULL_PE
end subroutine mpp_define_null_domain1D
!#####################################################################
subroutine mpp_define_null_domain2D(domain)
type(domain2D), intent(inout) :: domain
allocate(domain%x(1), domain%y(1), domain%tile_id(1))
call mpp_define_null_domain(domain%x(1))
call mpp_define_null_domain(domain%y(1))
domain%pe = NULL_PE
domain%tile_id(1) = 1
domain%ntiles = 1
domain%max_ntile_pe = 1
domain%ncontacts = 0
end subroutine mpp_define_null_domain2D
!####################################################################
subroutine mpp_deallocate_domain1D(domain)
type(domain1D), intent(inout) :: domain
if(ASSOCIATED(domain%list)) deallocate(domain%list)
end subroutine mpp_deallocate_domain1D
!####################################################################
subroutine mpp_deallocate_domain2D(domain)
type(domain2D), intent(inout) :: domain
call deallocate_domain2D_local(domain)
if(ASSOCIATED(domain%io_domain) ) then
call deallocate_domain2D_local(domain%io_domain)
deallocate(domain%io_domain)
endif
end subroutine mpp_deallocate_domain2D
!##################################################################
subroutine deallocate_domain2D_local(domain)
type(domain2D), intent(inout) :: domain
integer :: i, ntileMe
ntileMe = size(domain%x(:))
if(ASSOCIATED(domain%pearray))deallocate(domain%pearray)
do i = 1, ntileMe
call mpp_deallocate_domain1D(domain%x(i))
call mpp_deallocate_domain1D(domain%y(i))
enddo
deallocate(domain%x, domain%y, domain%tile_id)
if(ASSOCIATED(domain%list)) then
do i = 0, size(domain%list(:))-1
deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id)
enddo
deallocate(domain%list)
endif
if(ASSOCIATED(domain%check_C)) call deallocate_overlapSpec(domain%check_C)
if(ASSOCIATED(domain%check_E)) call deallocate_overlapSpec(domain%check_E)
if(ASSOCIATED(domain%check_N)) call deallocate_overlapSpec(domain%check_N)
if(ASSOCIATED(domain%bound_C)) call deallocate_overlapSpec(domain%bound_C)
if(ASSOCIATED(domain%bound_E)) call deallocate_overlapSpec(domain%bound_E)
if(ASSOCIATED(domain%bound_N)) call deallocate_overlapSpec(domain%bound_N)
if(ASSOCIATED(domain%update_T)) call deallocate_overlapSpec(domain%update_T)
if(ASSOCIATED(domain%update_E)) call deallocate_overlapSpec(domain%update_E)
if(ASSOCIATED(domain%update_C)) call deallocate_overlapSpec(domain%update_C)
if(ASSOCIATED(domain%update_N)) call deallocate_overlapSpec(domain%update_N)
end subroutine deallocate_domain2D_local
!####################################################################
subroutine allocate_check_overlap(overlap, count)
type(overlap_type), intent(inout) :: overlap
integer, intent(in ) :: count
overlap%count = 0
overlap%pe = NULL_PE
if(associated(overlap%tileMe)) call mpp_error(FATAL, &
"allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
if(count < 1) call mpp_error(FATAL, &
"allocate_check_overlap(mpp_domains_define): count should be a positive integer")
allocate(overlap%tileMe (count), overlap%dir(count) )
allocate(overlap%is (count), overlap%ie (count) )
allocate(overlap%js (count), overlap%je (count) )
allocate(overlap%rotation(count) )
overlap%rotation = ZERO
end subroutine allocate_check_overlap
!#######################################################################
subroutine insert_check_overlap(overlap, pe, tileMe, dir, rotation, is, ie, js, je)
type(overlap_type), intent(inout) :: overlap
integer, intent(in ) :: pe
integer, intent(in ) :: tileMe, dir, rotation
integer, intent(in ) :: is, ie, js, je
integer :: count
overlap%count = overlap%count + 1
count = overlap%count
if(.NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
if(count > size(overlap%tileMe(:)) ) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
if( overlap%pe == NULL_PE ) then
overlap%pe = pe
else
if(overlap%pe .NE. pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
endif
overlap%tileMe (count) = tileMe
overlap%dir (count) = dir
overlap%rotation(count) = rotation
overlap%is (count) = is
overlap%ie (count) = ie
overlap%js (count) = js
overlap%je (count) = je
end subroutine insert_check_overlap
!#######################################################################
!--- this routine add the overlap_in into overlap_out
subroutine add_check_overlap( overlap_out, overlap_in)
type(overlap_type), intent(inout) :: overlap_out
type(overlap_type), intent(in ) :: overlap_in
type(overlap_type) :: overlap
integer :: count, count_in, count_out
! if overlap_out%count == 0, then just copy overlap_in to overlap_out
count_in = overlap_in %count
count_out = overlap_out%count
count = count_in+count_out
if(count_in == 0) call mpp_error(FATAL, &
"add_check_overlap(mpp_domains_define): overlap_in%count is zero")
if(count_out == 0) then
if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
"add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
call allocate_check_overlap(overlap_out, count_in)
overlap_out%pe = overlap_in%pe
else ! need to expand the dimension size of overlap
call allocate_check_overlap(overlap, count_out)
if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
overlap%is (1:count_out) = overlap_out%is (1:count_out)
overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
overlap%js (1:count_out) = overlap_out%js (1:count_out)
overlap%je (1:count_out) = overlap_out%je (1:count_out)
overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
call deallocate_overlap_type(overlap_out)
call allocate_check_overlap(overlap_out, count)
overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
overlap_out%is (1:count_out) = overlap%is (1:count_out)
overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
overlap_out%js (1:count_out) = overlap%js (1:count_out)
overlap_out%je (1:count_out) = overlap%je (1:count_out)
overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
call deallocate_overlap_type(overlap)
end if
overlap_out%count = count
overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
end subroutine add_check_overlap
!####################################################################
subroutine init_overlap_type(overlap)
type(overlap_type), intent(inout) :: overlap
overlap%count = 0
overlap%pe = NULL_PE
end subroutine init_overlap_type
!####################################################################
subroutine allocate_update_overlap( overlap, count)
type(overlap_type), intent(inout) :: overlap
integer, intent(in ) :: count
overlap%count = 0
overlap%pe = NULL_PE
if(associated(overlap%tileMe)) call mpp_error(FATAL, &
"allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
if(count < 1) call mpp_error(FATAL, &
"allocate_update_overlap(mpp_domains_define): count should be a positive integer")
allocate(overlap%tileMe (count), overlap%tileNbr (count) )
allocate(overlap%is (count), overlap%ie (count) )
allocate(overlap%js (count), overlap%je (count) )
allocate(overlap%dir (count), overlap%rotation(count) )
allocate(overlap%from_contact(count), overlap%msgsize (count) )
overlap%rotation = ZERO
overlap%from_contact = .FALSE.
end subroutine allocate_update_overlap
!#####################################################################################
subroutine insert_update_overlap(overlap, pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir, reverse, symmetry)
type(overlap_type), intent(inout) :: overlap
integer, intent(in ) :: pe
integer, intent(in ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
integer, intent(in ) :: dir
logical, optional, intent(in ) :: reverse, symmetry
logical :: is_reverse, is_symmetry, is_overlapped
integer :: is, ie, js, je, count
is_reverse = .FALSE.
if(PRESENT(reverse)) is_reverse = reverse
is_symmetry = .FALSE.
if(PRESENT(symmetry)) is_symmetry = symmetry
is = max(is1,is2); ie = min(ie1,ie2)
js = max(js1,js2); je = min(je1,je2)
is_overlapped = .false.
!--- to avoid unnecessary ( duplicate overlap ) for symmetry domain
if(is_symmetry .AND. (dir == 1 .OR. dir == 5)) then ! x-direction
if( ie .GE. is .AND. je .GT. js ) is_overlapped = .true.
else if(is_symmetry .AND. (dir == 3 .OR. dir == 7)) then ! y-direction
if( ie .GT. is .AND. je .GE. js ) is_overlapped = .true.
else if(ie.GE.is .AND. je.GE.js )then
is_overlapped = .true.
endif
if(is_overlapped) then
if( overlap%count == 0 ) then
overlap%pe = pe
else
if(overlap%pe .NE. pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
endif
overlap%count = overlap%count+1
count = overlap%count
if(count > MAXOVERLAP) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_update_overlap): number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
overlap%is(count) = is
overlap%ie(count) = ie
overlap%js(count) = js
overlap%je(count) = je
overlap%tileMe (count) = 1
overlap%tileNbr(count) = 1
overlap%dir(count) = dir
if(is_reverse) then
overlap%rotation(count) = ONE_HUNDRED_EIGHTY
else
overlap%rotation(count) = ZERO
end if
end if
end subroutine insert_update_overlap
!#####################################################################################
subroutine insert_overlap_type(overlap, pe, tileMe, tileNbr, is, ie, js, je, dir, &
rotation, from_contact)
type(overlap_type), intent(inout) :: overlap
integer, intent(in ) :: tileMe, tileNbr, pe
integer, intent(in ) :: is, ie, js, je
integer, intent(in ) :: dir, rotation
logical, intent(in ) :: from_contact
integer :: count
if( overlap%count == 0 ) then
overlap%pe = pe
else
if(overlap%pe .NE. pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
endif
overlap%count = overlap%count+1
count = overlap%count
if(count > MAXOVERLAP) call mpp_error(FATAL, &
"mpp_domains_define.inc(insert_overlap_type): number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
overlap%tileMe (count) = tileMe
overlap%tileNbr (count) = tileNbr
overlap%is (count) = is
overlap%ie (count) = ie
overlap%js (count) = js
overlap%je (count) = je
overlap%dir (count) = dir
overlap%rotation (count) = rotation
overlap%from_contact(count) = from_contact
overlap%msgsize (count) = (ie-is+1)*(je-js+1)
end subroutine insert_overlap_type
!#######################################################################
subroutine deallocate_overlap_type( overlap)
type(overlap_type), intent(inout) :: overlap
if(overlap%count == 0) then
if( .NOT. associated(overlap%tileMe)) return
else
if( .NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
"deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
endif
if(ASSOCIATED(overlap%tileMe)) deallocate(overlap%tileMe)
if(ASSOCIATED(overlap%tileNbr)) deallocate(overlap%tileNbr)
if(ASSOCIATED(overlap%is)) deallocate(overlap%is)
if(ASSOCIATED(overlap%ie)) deallocate(overlap%ie)
if(ASSOCIATED(overlap%js)) deallocate(overlap%js)
if(ASSOCIATED(overlap%je)) deallocate(overlap%je)
if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir)
if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation)
if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact)
if(ASSOCIATED(overlap%msgsize)) deallocate(overlap%msgsize)
overlap%count = 0
end subroutine deallocate_overlap_type
!#######################################################################
subroutine deallocate_overlapSpec(overlap)
type(overlapSpec), intent(inout) :: overlap
integer :: n
if(ASSOCIATED(overlap%send)) then
do n = 1, size(overlap%send(:))
call deallocate_overlap_type(overlap%send(n))
enddo
deallocate(overlap%send)
endif
if(ASSOCIATED(overlap%recv)) then
do n = 1, size(overlap%recv(:))
call deallocate_overlap_type(overlap%recv(n))
enddo
deallocate(overlap%recv)
endif
end subroutine deallocate_overlapSpec
!#######################################################################
!--- this routine add the overlap_in into overlap_out
subroutine add_update_overlap( overlap_out, overlap_in)
type(overlap_type), intent(inout) :: overlap_out
type(overlap_type), intent(in ) :: overlap_in
type(overlap_type) :: overlap
integer :: count, count_in, count_out, n
! if overlap_out%count == 0, then just copy overlap_in to overlap_out
count_in = overlap_in %count
count_out = overlap_out%count
count = count_in+count_out
if(count_in == 0) call mpp_error(FATAL, &
"mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
if(count_out == 0) then
if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
"mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
call allocate_update_overlap(overlap_out, count_in)
overlap_out%pe = overlap_in%pe
else ! need to expand the dimension size of overlap
if(overlap_in%pe .NE. overlap_out%pe) call mpp_error(FATAL, &
"mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
call allocate_update_overlap(overlap, count_out)
overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
overlap%tileNbr (1:count_out) = overlap_out%tileNbr (1:count_out)
overlap%is (1:count_out) = overlap_out%is (1:count_out)
overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
overlap%js (1:count_out) = overlap_out%js (1:count_out)
overlap%je (1:count_out) = overlap_out%je (1:count_out)
overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
call deallocate_overlap_type(overlap_out)
call allocate_update_overlap(overlap_out, count)
overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
overlap_out%tileNbr (1:count_out) = overlap%tileNbr (1:count_out)
overlap_out%is (1:count_out) = overlap%is (1:count_out)
overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
overlap_out%js (1:count_out) = overlap%js (1:count_out)
overlap_out%je (1:count_out) = overlap%je (1:count_out)
overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
overlap_out%index (1:count_out) = overlap%index (1:count_out)
overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
overlap_out%msgsize (1:count_out) = overlap%msgsize (1:count_out)
call deallocate_overlap_type(overlap)
end if
overlap_out%count = count
overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
overlap_out%tileNbr (count_out+1:count) = overlap_in%tileNbr (1:count_in)
overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
do n = count_out+1, count
overlap_out%msgsize(n) = (overlap_out%ie(n)-overlap_out%is(n)+1)*(overlap_out%je(n)-overlap_out%js(n)+1)
enddo
end subroutine add_update_overlap
!##############################################################################
subroutine expand_update_overlap_list(overlapList, npes)
type(overlap_type), pointer :: overlapList(:)
integer, intent(in ) :: npes
type(overlap_type), pointer,save :: newlist(:) => NULL()
integer :: nlist_old, nlist, m
nlist_old = size(overlaplist(:))
if(nlist_old .GE. npes) call mpp_error(FATAL, &
'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
nlist = min(npes, 2*nlist_old)
allocate(newlist(nlist))
do m = 1, nlist_old
call add_update_overlap(newlist(m), overlaplist(m))
call deallocate_overlap_type(overlapList(m))
enddo
deallocate(overlapList)
overlaplist => newlist
newlist => NULL()
return
end subroutine expand_update_overlap_list
!##################################################################################
subroutine expand_check_overlap_list(overlaplist, npes)
type(overlap_type), pointer :: overlaplist(:)
integer, intent(in) :: npes
type(overlap_type), pointer,save :: newlist(:) => NULL()
integer :: nlist_old, nlist, m
nlist_old = size(overlaplist(:))
if(nlist_old .GE. npes) call mpp_error(FATAL, &
'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
nlist = min(npes, 2*nlist_old)
allocate(newlist(nlist))
do m = 1,size(overlaplist(:))
call add_check_overlap(newlist(m), overlaplist(m))
call deallocate_overlap_type(overlapList(m))
enddo
deallocate(overlapList)
overlaplist => newlist
return
end subroutine expand_check_overlap_list
!###############################################################################
subroutine check_overlap_pe_order(domain, overlap, name)
type(domain2d), intent(in) :: domain
type(overlapSpec), intent(in) :: overlap
character(len=*), intent(in) :: name
integer :: m
integer :: pe1, pe2
!---make sure overlap%nsend and overlap%nrecv is no larger than MAXLIST
if( overlap%nsend > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
if( overlap%nrecv > MAXLIST) call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
do m = 2, overlap%nsend
pe1 = overlap%send(m-1)%pe
pe2 = overlap%send(m)%pe
!-- when p1 == domain%pe, pe2 could be any value except domain%pe
if( pe2 == domain%pe ) then
print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
if( pe2 < pe1 ) then
print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
endif
else if ( pe2 > domain%pe .AND. pe1 < domain%pe ) then
print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
endif
enddo
do m = 2, overlap%nrecv
pe1 = overlap%recv(m-1)%pe
pe2 = overlap%recv(m)%pe
!-- when p1 == domain%pe, pe2 could be any value except domain%pe
if( pe2 == domain%pe ) then
print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
if( pe2 > pe1 ) then
print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
endif
else if ( pe2 < domain%pe .AND. pe1 > domain%pe ) then
print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
call mpp_error(FATAL, &
"mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
endif
enddo
end subroutine check_overlap_pe_order
!###############################################################################
subroutine set_domain_comm_inf(update)
type(overlapSpec), intent(inout) :: update
integer :: m, totsize, n
! first set the send and recv size
update%sendsize = 0
update%recvsize = 0
do m = 1, update%nrecv
totsize = 0
do n = 1, update%recv(m)%count
totsize = totsize + update%recv(m)%msgsize(n)
enddo
update%recv(m)%totsize = totsize
if(m==1) then
update%recv(m)%start_pos = 0
else
update%recv(m)%start_pos = update%recv(m-1)%start_pos + update%recv(m-1)%totsize
endif
update%recvsize = update%recvsize + totsize
enddo
do m = 1, update%nsend
totsize = 0
do n = 1, update%send(m)%count
totsize = totsize + update%send(m)%msgsize(n)
enddo
update%send(m)%totsize = totsize
if(m==1) then
update%send(m)%start_pos = 0
else
update%send(m)%start_pos = update%send(m-1)%start_pos + update%send(m-1)%totsize
endif
update%sendsize = update%sendsize + totsize
enddo
return
end subroutine set_domain_comm_inf