mpp/include/mpp_domains_define.inc

   1 ! -*-f90-*-
   2
   3
   4 !***********************************************************************
   5 !*                   GNU Lesser General Public License
   6 !*
   7 !* This file is part of the GFDL Flexible Modeling System (FMS).
   8 !*
   9 !* FMS is free software: you can redistribute it and/or modify it under
  10 !* the terms of the GNU Lesser General Public License as published by
  11 !* the Free Software Foundation, either version 3 of the License, or (at
  12 !* your option) any later version.
  13 !*
  14 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  15 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 !* for more details.
  18 !*
  19 !* You should have received a copy of the GNU Lesser General Public
  20 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  21 !***********************************************************************
  22
  23 !> @file
  24 !> @ingroup mpp_domains_mod
  25 !> @brief Various routines handling domains in @ref mpp_domains_mod
  26
  27   ! <SUBROUTINE NAME="mpp_define_layout2D" INTERFACE="mpp_define_layout">
  28   !  <IN NAME="global_indices" TYPE="integer" DIM="(4)"></IN>
  29   !  <IN NAME="ndivs" TYPE="integer"></IN>
  30   !  <OUT NAME="layout" TYPE="integer" DIM="(2)"></OUT>
  31   ! </SUBROUTINE>
  32   !> @brief Instantiates a layout with the given indices and divisions
  33   subroutine mpp_define_layout2D( global_indices, ndivs, layout )
  34     integer, intent(in) :: global_indices(:) !< (/ isg, ieg, jsg, jeg /); Defines the global domain.
  35     integer, intent(in) :: ndivs !< number of divisions to divide global domain
  36     integer, intent(out) :: layout(:)
  37
  38     integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
  39
  40     if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL,"mpp_define_layout2D: size of global_indices should be 4")
  41     if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_layout2D: size of layout should be 2")
  42
  43     isg = global_indices(1)
  44     ieg = global_indices(2)
  45     jsg = global_indices(3)
  46     jeg = global_indices(4)
  47
  48     isz = ieg - isg + 1
  49     jsz = jeg - jsg + 1
  50     !first try to divide ndivs in the domain aspect ratio: if imperfect aspect, reduce idiv till it divides ndivs
  51     idiv = nint( sqrt(float(ndivs*isz)/jsz) )
  52     idiv = max(idiv,1) !for isz=1 line above can give 0
  53     do while( mod(ndivs,idiv).NE.0 )
  54        idiv = idiv - 1
  55     end do                 !will terminate at idiv=1 if not before
  56     jdiv = ndivs/idiv
  57
  58     layout = (/ idiv, jdiv /)
  59     return
  60   end subroutine mpp_define_layout2D
  61
  62   !############################################################################
  63   ! <SUBROUTINE NAME="mpp_define_mosaic_pelist">
  64   !  <IN NAME="global_indices" TYPE="integer" DIM="(4)"></IN>
  65   !  <IN NAME="pelist" TYPE="integer" DIM="(0:)">  </IN>
  66   ! </SUBROUTINE>
  67   ! NOTE: The following routine may need to revised to improve the capability.
  68   !  It is very hard to make it balance for all the situation.
  69   !  Hopefully some smart idea will come up someday.
  70   subroutine mpp_define_mosaic_pelist( sizes, pe_start, pe_end, pelist, costpertile)
  71     integer, dimension(:), intent(in)           :: sizes
  72     integer, dimension(:), intent(inout)        :: pe_start, pe_end
  73     integer, dimension(:), intent(in), optional :: pelist, costpertile
  74     integer, dimension(size(sizes(:)))          :: costs
  75     integer, dimension(:), allocatable          :: pes
  76     integer                                     :: ntiles, npes, totcosts, avgcost
  77     integer                                     :: ntiles_left, npes_left, pos, n, tile
  78     integer                                     :: cost_on_tile, cost_on_pe, npes_used, errunit
  79
  80     ntiles = size(sizes(:))
  81     if(size(pe_start(:)) .NE. ntiles .OR. size(pe_end(:)) .NE. ntiles ) then
  82        call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
  83     end if
  84
  85     if(present(costpertile)) then
  86        if(size(costpertile(:)) .NE. ntiles ) then
  87           call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
  88        end if
  89        costs = sizes*costpertile
  90     else
  91        costs = sizes
  92     end if
  93
  94     if( PRESENT(pelist) )then
  95        if( .NOT.any(pelist.EQ.mpp_pe()) )then
  96           errunit = stderr()
  97           write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
  98           call mpp_error( FATAL, 'mpp_define_mosaic_pelist: pe must be in pelist.' )
  99        end if
 100        npes = size(pelist(:))
 101        allocate( pes(0:npes-1) )
 102        pes(:) = pelist(:)
 103     else
 104        npes = mpp_npes()
 105        allocate( pes(0:npes-1) )
 106        call mpp_get_current_pelist(pes)
 107     end if
 108
 109     ntiles_left = ntiles
 110     npes_left = npes
 111     pos = pes(0)
 112
 113     do while( ntiles_left > 0 )
 114        if( npes_left == 1 ) then ! all left tiles will on the last processor, imbalance possibly.
 115           do n = 1, ntiles
 116              if(costs(n) > 0) then
 117                 pe_start(n) = pos
 118                 pe_end(n) = pos
 119                 costs(n)  = 0
 120              end if
 121           end do
 122           ntiles_left = 0
 123           npes_left = 0
 124        else
 125           totcosts = sum(costs)
 126           avgcost  = CEILING(real(totcosts)/npes_left )
 127           tile = minval(maxloc(costs))
 128           cost_on_tile = costs(tile)
 129           pe_start(tile) = pos
 130           ntiles_left = ntiles_left - 1
 131           costs(tile) = 0
 132           totcosts = totcosts - cost_on_tile
 133           if(cost_on_tile .GE. avgcost ) then
 134              npes_used = min(ceiling(real(cost_on_tile)/avgcost), npes_left)
 135              if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
 136              pe_end(tile) = pos + npes_used - 1
 137              npes_left = npes_left - npes_used
 138              pos = pos + npes_used
 139           else
 140              !--- find other tiles to share the pe
 141              pe_end(tile) = pos
 142              cost_on_pe = cost_on_tile
 143              do while(ntiles_left>npes_left)  ! make sure all the pes are used.
 144                 tile = minval(minloc(costs, costs> 0 ))
 145                 cost_on_tile = costs(tile)
 146                 cost_on_pe = cost_on_pe + cost_on_tile
 147                 if(cost_on_pe > avgcost ) exit
 148                 pe_start(tile) = pos
 149                 pe_end(tile) = pos
 150                 ntiles_left = ntiles_left - 1
 151                 costs(tile) = 0
 152                 totcosts = totcosts - cost_on_tile
 153              end do
 154              npes_left = npes_left - 1
 155              pos = pos + 1
 156           end if
 157        end if
 158     end do
 159
 160     if(npes_left .NE. 0 ) call mpp_error(FATAL, "mpp_define_mosaic_pelist: the left npes should be zero")
 161     deallocate(pes)
 162
 163   end subroutine mpp_define_mosaic_pelist
 164
 165   !-- The following implementation is different from mpp_compute_extents
 166   !-- The last block might have most points
 167   subroutine mpp_compute_block_extent(isg,ieg,ndivs,ibegin,iend)
 168     integer,                 intent(in) :: isg, ieg, ndivs
 169     integer, dimension(:), intent(out)  :: ibegin, iend
 170
 171     integer :: ndiv
 172     integer :: is, ie
 173
 174     ie = ieg
 175     do ndiv=ndivs,1,-1
 176       !domain is sized by dividing remaining points by remaining domains
 177       is = ie - CEILING( REAL(ie-isg+1)/ndiv ) + 1
 178       ibegin(ndiv) = is
 179       iend(ndiv) = ie
 180
 181       if( ie.LT.is )call mpp_error( FATAL,  &
 182           'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
 183       if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE. isg ) &
 184           call mpp_error( FATAL, 'mpp_compute_block_extent: domain extents do not span space completely.' )
 185       ie = is - 1
 186      end do
 187
 188   end subroutine mpp_compute_block_extent
 189
 190
 191   !#####################################################################
 192   subroutine mpp_compute_extent(isg,ieg,ndivs,ibegin,iend, extent )
 193     integer,                 intent(in)          :: isg, ieg, ndivs
 194     integer, dimension(0:), intent(out)          :: ibegin, iend
 195     integer, dimension(0:), intent(in), optional :: extent
 196
 197     integer :: ndiv, imax, ndmax, ndmirror
 198     integer :: is, ie, n
 199     logical :: symmetrize, use_extent
 200     !statement functions
 201     logical :: even, odd
 202     even(n) = (mod(n,2).EQ.0)
 203     odd (n) = (mod(n,2).EQ.1)
 204
 205     use_extent = .false.
 206     if(PRESENT(extent)) then
 207        if( size(extent(:)).NE.ndivs ) &
 208             call mpp_error( FATAL, 'mpp_compute_extent: extent array size must equal number of domain divisions.' )
 209        use_extent = .true.
 210        if(ALL(extent ==0)) use_extent = .false.
 211     endif
 212
 213     is = isg
 214     if(use_extent) then
 215        ibegin(0) = isg
 216        do ndiv = 0, ndivs-2
 217           if(extent(ndiv) .LE. 0) call mpp_error( FATAL, &
 218              &  'mpp_compute_extent: domain extents must be positive definite.' )
 219           iend(ndiv) = ibegin(ndiv) + extent(ndiv) - 1
 220           ibegin(ndiv+1) = iend(ndiv) + 1
 221        enddo
 222        iend(ndivs-1) = ibegin(ndivs-1) + extent(ndivs-1) - 1
 223        if(iend(ndivs-1) .NE. ieg) call mpp_error(FATAL, &
 224           &  'mpp_compute_extent: extent array limits do not match global domain.' )
 225     else
 226        do ndiv=0,ndivs-1
 227           !modified for mirror-symmetry
 228           !original line
 229           !                 ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1
 230
 231           !problem of dividing nx points into n domains maintaining symmetry
 232           !i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not.
 233           !this will always work for nx even n even or odd
 234           !this will always work for nx odd, n odd
 235           !this will never  work for nx odd, n even: for this case we supersede the mirror calculation
 236           !                 symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(ieg-isg+1,2).EQ.1 )
 237           !nx even n odd fails if n>nx/2
 238           symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
 239                (  odd(ndivs) .AND.  odd(ieg-isg+1) ) .OR. &
 240                (  odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
 241
 242           !mirror domains are stored in the list and retrieved if required.
 243           if( ndiv.EQ.0 )then
 244              !initialize max points and max domains
 245              imax = ieg
 246              ndmax = ndivs
 247           end if
 248           !do bottom half of decomposition, going over the midpoint for odd ndivs
 249           if( ndiv.LT.(ndivs-1)/2+1 )then
 250              !domain is sized by dividing remaining points by remaining domains
 251              ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
 252              ndmirror = (ndivs-1) - ndiv !mirror domain
 253              if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
 254                 !mirror extents, the max(,) is to eliminate overlaps
 255                 ibegin(ndmirror) = max( isg+ieg-ie, ie+1 )
 256                 iend(ndmirror)   = max( isg+ieg-is, ie+1 )
 257                 imax = ibegin(ndmirror) - 1
 258                 ndmax = ndmax - 1
 259              end if
 260           else
 261              if( symmetrize )then
 262                 !do top half of decomposition by retrieving saved values
 263                 is = ibegin(ndiv)
 264                 ie = iend(ndiv)
 265              else
 266                 ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
 267              end if
 268           end if
 269           ibegin(ndiv) = is
 270           iend(ndiv) = ie
 271           if( ie.LT.is )call mpp_error( FATAL,  &
 272                'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
 273           if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.ieg ) &
 274                call mpp_error( FATAL, 'mpp_compute_extent: domain extents do not span space completely.' )
 275           is = ie + 1
 276        end do
 277     endif
 278
 279
 280   end subroutine mpp_compute_extent
 281
 282   !#####################################################################
 283
 284 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 285   !                                                                             !
 286   !>@brief MPP_DEFINE_DOMAINS: define layout and decomposition                  !
 287   !                                                                             !
 288 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 289
 290   !> @brief MPP_DEFINE_DOMAINS: define layout and decomposition                  !
 291   !!
 292   !> Routine to divide global array indices among domains, and assign domains to PEs
 293   subroutine mpp_define_domains1D( global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, &
 294                                    memory_size, begin_halo, end_halo )
 295     integer,           intent(in) :: global_indices(:) !< (/ isg, ieg /) gives the extent of global domain
 296     integer,           intent(in) :: ndivs !< number of divisions of domain: even divisions unless extent is present.
 297     type(domain1D), intent(inout) :: domain !< the returned domain1D; declared inout so that
 298                                             !! existing links, if any, can be nullified
 299     integer, intent(in), optional :: pelist(0:) !< list of PEs to which domains are to be assigned
 300                                                 !! (default 0...npes-1); size of pelist must
 301                                                 !! correspond to number of mask=.TRUE. divisions
 302     integer, intent(in), optional :: flags, halo !< flags define whether compute and data domains
 303                                                  !! are global (undecomposed) and whether the global
 304                                                  !! domain has periodic boundaries.
 305                                                  !! halo defines halo width (currently the same on both sides)
 306     integer, intent(in), optional :: extent(0:) !< array extent; defines width of each division
 307                                                 !! (used for non-uniform domain decomp, for e.g load-balancing)
 308     logical, intent(in), optional :: maskmap(0:) !< a division whose maskmap=.FALSE. is not
 309                                                  !! assigned to any domain. By default we assume
 310                                                  !! decomposition of compute and data domains, non-periodic boundaries,
 311                                                  !! no halo, as close to uniform extents as the
 312                                                  !! input parameters permit
 313     integer, intent(in), optional :: memory_size
 314     integer, intent(in), optional :: begin_halo, end_halo
 315
 316     logical              :: compute_domain_is_global, data_domain_is_global
 317     integer              :: ndiv, n, isg, ieg
 318     integer, allocatable :: pes(:)
 319     integer              :: ibegin(0:ndivs-1), iend(0:ndivs-1)
 320     logical              :: mask(0:ndivs-1)
 321     integer              :: halosz, halobegin, haloend
 322     integer              :: errunit
 323
 324     if( .NOT.module_is_initialized )call mpp_error( FATAL, &
 325        &  'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
 326     if(size(global_indices(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains1D: size of global_indices should be 2")
 327     !get global indices
 328     isg = global_indices(1)
 329     ieg = global_indices(2)
 330     if( ndivs.GT.ieg-isg+1 )call mpp_error( FATAL, &
 331        &  'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
 332     !get the list of PEs on which to assign domains; if pelist is absent use 0..npes-1
 333     if( PRESENT(pelist) )then
 334        if( .NOT.any(pelist.EQ.mpp_pe()) )then
 335           errunit = stderr()
 336           write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
 337           call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
 338        end if
 339        allocate( pes(0:size(pelist(:))-1) )
 340        pes(:) = pelist(:)
 341     else
 342        allocate( pes(0:mpp_npes()-1) )
 343        call mpp_get_current_pelist(pes)
 344 !       pes(:) = (/ (i,i=0,mpp_npes()-1) /)
 345     end if
 346
 347     !get number of real domains: 1 mask domain per PE in pes
 348     mask = .TRUE.                 !default mask
 349     if( PRESENT(maskmap) )then
 350        if( size(maskmap(:)).NE.ndivs ) &
 351             call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
 352        mask(:) = maskmap(:)
 353     end if
 354     if( count(mask).NE.size(pes(:)) ) &
 355          call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
 356
 357     !get halosize
 358     halosz = 0
 359     if( PRESENT(halo) ) then
 360        halosz = halo
 361        !--- if halo is present, begin_halo and end_halo should not present
 362        if(present(begin_halo) .OR. present(end_halo) ) call mpp_error(FATAL, &
 363             "mpp_domains_define.inc: when halo is present, begin_halo and end_halo should not present")
 364     end if
 365     halobegin = halosz; haloend = halosz
 366     if(present(begin_halo)) halobegin = begin_halo
 367     if(present(end_halo))   haloend   = end_halo
 368     halosz = max(halobegin, haloend)
 369     !get flags
 370     compute_domain_is_global = .FALSE.
 371     data_domain_is_global    = .FALSE.
 372     domain%cyclic = .FALSE.
 373     domain%goffset = 1
 374     domain%loffset = 1
 375     if( PRESENT(flags) )then
 376        !NEW: obsolete flag global_compute_domain, since ndivs is non-optional and you cannot
 377        !have global compute and ndivs.NE.1
 378        compute_domain_is_global = ndivs.EQ.1
 379        !if compute domain is global, data domain must also be
 380        data_domain_is_global    = BTEST(flags,GLOBAL) .OR. compute_domain_is_global
 381        domain%cyclic  = BTEST(flags,CYCLIC) .AND. halosz.NE.0
 382        if(BTEST(flags,CYCLIC)) domain%goffset = 0
 383     end if
 384
 385     !set up links list
 386     allocate( domain%list(0:ndivs-1) )
 387
 388     !set global domain
 389     domain%list(:)%global%begin     = isg
 390     domain%list(:)%global%end       = ieg
 391     domain%list(:)%global%size      = ieg-isg+1
 392     domain%list(:)%global%max_size  = ieg-isg+1
 393     domain%list(:)%global%is_global = .TRUE. !always
 394
 395     !get compute domain
 396     if( compute_domain_is_global )then
 397        domain%list(:)%compute%begin = isg
 398        domain%list(:)%compute%end   = ieg
 399        domain%list(:)%compute%is_global = .TRUE.
 400        domain%list(:)%pe = pes(:)
 401        domain%pos = 0
 402     else
 403        domain%list(:)%compute%is_global = .FALSE.
 404        n = 0
 405        call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
 406        do ndiv=0,ndivs-1
 407           domain%list(ndiv)%compute%begin = ibegin(ndiv)
 408           domain%list(ndiv)%compute%end   = iend(ndiv)
 409           if( mask(ndiv) )then
 410              domain%list(ndiv)%pe = pes(n)
 411              if( mpp_pe().EQ.pes(n) )domain%pos = ndiv
 412              n = n + 1
 413           else
 414              domain%list(ndiv)%pe = NULL_PE
 415           end if
 416        end do
 417     end if
 418
 419     domain%list(:)%compute%size  = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
 420
 421     !get data domain
 422     !data domain is at least equal to compute domain
 423     domain%list(:)%data%begin = domain%list(:)%compute%begin
 424     domain%list(:)%data%end   = domain%list(:)%compute%end
 425     domain%list(:)%data%is_global = .FALSE.
 426     !apply global flags
 427     if( data_domain_is_global )then
 428        domain%list(:)%data%begin  = isg
 429        domain%list(:)%data%end    = ieg
 430        domain%list(:)%data%is_global = .TRUE.
 431     end if
 432     !apply margins
 433     domain%list(:)%data%begin = domain%list(:)%data%begin - halobegin
 434     domain%list(:)%data%end   = domain%list(:)%data%end   + haloend
 435     domain%list(:)%data%size  = domain%list(:)%data%end - domain%list(:)%data%begin + 1
 436
 437     !--- define memory domain, if memory_size is not present or memory size is 0, memory domain size
 438     !--- will be the same as data domain size. if momory_size is present, memory_size should greater than
 439     !--- or equal to data size. The begin of memory domain will be always the same as data domain.
 440     domain%list(:)%memory%begin = domain%list(:)%data%begin
 441     domain%list(:)%memory%end   = domain%list(:)%data%end
 442     if( present(memory_size) ) then
 443        if(memory_size > 0) then
 444           if( domain%list(domain%pos)%data%size > memory_size ) call mpp_error(FATAL, &
 445                "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe")
 446           domain%list(:)%memory%end   = domain%list(:)%memory%begin + memory_size - 1
 447        end if
 448     end if
 449     domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1
 450     domain%list(:)%memory%is_global = domain%list(:)%data%is_global
 451
 452     domain%compute = domain%list(domain%pos)%compute
 453     domain%data    = domain%list(domain%pos)%data
 454     domain%global  = domain%list(domain%pos)%global
 455     domain%memory  = domain%list(domain%pos)%memory
 456     domain%compute%max_size = MAXVAL( domain%list(:)%compute%size )
 457     domain%data%max_size    = MAXVAL( domain%list(:)%data%size )
 458     domain%global%max_size  = domain%global%size
 459     domain%memory%max_size  = domain%memory%size
 460
 461     !PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
 462     deallocate( pes )
 463     return
 464
 465   end subroutine mpp_define_domains1D
 466
 467   !################################################################################
 468   !> define the IO domain.
 469   subroutine mpp_define_io_domain(domain, io_layout)
 470     type(domain2D), intent(inout) :: domain
 471     integer,        intent(in   ) :: io_layout(2)
 472     integer                       :: layout(2)
 473     integer                       :: npes_in_group
 474     type(domain2D), pointer       :: io_domain=>NULL()
 475     integer                       :: i, j, n, m
 476     integer                       :: ipos, jpos, igroup, jgroup
 477     integer                       :: ipos_beg, ipos_end, jpos_beg, jpos_end
 478     integer                       :: whalo, ehalo, shalo, nhalo
 479     integer                       :: npes_x, npes_y, ndivx, ndivy
 480     integer, allocatable          :: posarray(:,:)
 481
 482     if(io_layout(1) * io_layout(2) .LE. 0) then
 483        call mpp_error(NOTE,  &
 484          "mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for "//trim(domain%name)// &
 485          " when one or both entry of io_layout is not positive")
 486        return
 487     endif
 488
 489     layout(1) = size(domain%x(1)%list(:))
 490     layout(2) = size(domain%y(1)%list(:))
 491
 492     if(ASSOCIATED(domain%io_domain)) call mpp_error(FATAL, &
 493        "mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
 494
 495     if(mod(layout(1), io_layout(1)) .NE. 0) call mpp_error(FATAL, &
 496        "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
 497                              & " domain layout(1) must be divided by io_layout(1)")
 498     if(mod(layout(2), io_layout(2)) .NE. 0) call mpp_error(FATAL, &
 499        "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
 500                              & " domain layout(2) must be divided by io_layout(2)")
 501     if(size(domain%x(:)) > 1) call mpp_error(FATAL, &
 502        "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
 503        ": multiple tile per pe is not supported yet for this routine")
 504
 505     allocate(domain%io_domain)
 506     domain%io_layout = io_layout
 507     io_domain => domain%io_domain
 508     ! Find how many processors are in the group with the consideration that some of the region maybe masked out.
 509     npes_x = layout(1)/io_layout(1)
 510     npes_y = layout(2)/io_layout(2)
 511     ipos = mod(domain%x(1)%pos, npes_x)
 512     jpos = mod(domain%y(1)%pos, npes_y)
 513     igroup  = domain%x(1)%pos/npes_x
 514     jgroup  = domain%y(1)%pos/npes_y
 515     ipos_beg = igroup*npes_x; ipos_end = ipos_beg + npes_x - 1
 516     jpos_beg = jgroup*npes_y; jpos_end = jpos_beg + npes_y - 1
 517     npes_in_group = 0
 518     do j = jpos_beg, jpos_end
 519        do i = ipos_beg, ipos_end
 520           if(domain%pearray(i,j) .NE. NULL_PE) npes_in_group = npes_in_group+1
 521        enddo
 522     enddo
 523
 524     io_domain%whalo    = domain%whalo
 525     io_domain%ehalo    = domain%ehalo
 526     io_domain%shalo    = domain%shalo
 527     io_domain%nhalo    = domain%nhalo
 528     io_domain%ntiles   = 1
 529     io_domain%pe       = domain%pe
 530     io_domain%symmetry = domain%symmetry
 531     allocate(io_domain%list(0:npes_in_group-1))
 532     do i = 0, npes_in_group-1
 533        allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) )
 534     enddo
 535
 536     ndivx = size(domain%pearray,1)
 537     ndivy = size(domain%pearray,2)
 538     allocate(posarray(0:ndivx-1, 0:ndivy-1))
 539     n = domain%tile_root_pe - mpp_root_pe()
 540     posarray = -1
 541     do j = 0,ndivy-1
 542        do i = 0,ndivx-1
 543           if( domain%pearray(i,j) == NULL_PE) cycle
 544           posarray(i,j) = n
 545           n = n + 1
 546        enddo
 547     enddo
 548
 549     n = 0
 550     do j = jpos_beg, jpos_end
 551        do i = ipos_beg, ipos_end
 552           if( domain%pearray(i,j) == NULL_PE) cycle
 553           io_domain%list(n)%pe = domain%pearray(i,j)
 554           m = posarray(i,j)
 555           io_domain%list(n)%x(1)%compute = domain%list(m)%x(1)%compute
 556           io_domain%list(n)%y(1)%compute = domain%list(m)%y(1)%compute
 557           igroup                         = domain%list(m)%x(1)%pos/npes_x
 558           jgroup                         = domain%list(m)%y(1)%pos/npes_y
 559           io_domain%list(n)%tile_id(1)   = jgroup*io_layout(1) + igroup
 560           n = n + 1
 561        enddo
 562     enddo
 563     deallocate(posarray)
 564
 565     allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
 566     allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) )
 567     n = -1
 568     do j = jpos_beg, jpos_beg+jpos
 569        do i = ipos_beg, ipos_beg+ipos
 570           if(domain%pearray(i,j) .NE. NULL_PE) n = n + 1
 571        enddo
 572     enddo
 573     io_domain%pos          = n
 574     io_domain%x(1)%compute = domain%x(1)%compute
 575     io_domain%x(1)%data    = domain%x(1)%data
 576     io_domain%x(1)%memory  = domain%x(1)%memory
 577     io_domain%y(1)%compute = domain%y(1)%compute
 578     io_domain%y(1)%data    = domain%y(1)%data
 579     io_domain%y(1)%memory  = domain%y(1)%memory
 580     io_domain%x(1)%global%begin     = domain%x(1)%list(ipos_beg)%compute%begin
 581     io_domain%x(1)%global%end       = domain%x(1)%list(ipos_end)%compute%end
 582     io_domain%x(1)%global%size      = io_domain%x(1)%global%end - io_domain%x(1)%global%begin + 1
 583     io_domain%x(1)%global%max_size  = io_domain%x(1)%global%size
 584     io_domain%y(1)%global%begin     = domain%y(1)%list(jpos_beg)%compute%begin
 585     io_domain%y(1)%global%end       = domain%y(1)%list(jpos_end)%compute%end
 586     io_domain%y(1)%global%size      = io_domain%y(1)%global%end - io_domain%y(1)%global%begin + 1
 587     io_domain%y(1)%global%max_size  = io_domain%y(1)%global%size
 588     io_domain%x(1)%pos     = ipos
 589     io_domain%y(1)%pos     = jpos
 590     io_domain%tile_id(1)   = io_domain%list(n)%tile_id(1)
 591     io_domain%tile_root_pe = io_domain%list(0)%pe
 592
 593     !z1l
 594 !!$    do j = 0, npes_y - 1
 595 !!$       n = j*npes_x + ipos
 596 !!$       io_domain%y(1)%list(j) = io_domain%list(n)%y(1)
 597 !!$    enddo
 598 !!$    do i = 0, npes_x - 1
 599 !!$       n = jpos*npes_x + i
 600 !!$       io_domain%x(1)%list(i) = io_domain%list(n)%x(1)
 601 !!$    enddo
 602
 603     whalo = domain%whalo
 604     ehalo = domain%ehalo
 605     shalo = domain%shalo
 606     nhalo = domain%nhalo
 607
 608     io_domain=>NULL()
 609
 610
 611   end subroutine mpp_define_io_domain
 612
 613   ! <SUBROUTINE NAME="mpp_define_domains2D" INTERFACE="mpp_define_domains">
 614   !  <IN NAME="global_indices" TYPE="integer" DIM="(4)"> </IN>
 615   !  <IN NAME="layout" TYPE="integer" DIM="(2)"></IN>
 616   !  <INOUT NAME="domain" TYPE="type(domain2D)"></INOUT>
 617   !  <IN NAME="pelist" TYPE="integer" DIM="(0:)"></IN>
 618   !  <IN NAME="xflags, yflags" TYPE="integer"></IN>
 619   !  <IN NAME="xhalo, yhalo" TYPE="integer"></IN>
 620   !  <IN NAME="xextent, yextent" TYPE="integer" DIM="(0:)"></IN>
 621   !  <IN NAME="maskmap" TYPE="logical" DIM="(:,:)"></IN>
 622   !  <IN NAME="name" TYPE="character(len=*)"></IN>
 623   ! </SUBROUTINE>
 624   subroutine mpp_define_domains2D( global_indices, layout, domain, pelist, xflags, yflags,    &
 625          xhalo, yhalo, xextent, yextent, maskmap, name, symmetry,  memory_size,               &
 626          whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
 627     !define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,jsg:jeg)
 628     !and assign them to PEs
 629     integer,          intent(in)           :: global_indices(:) !<(/ isg, ieg, jsg, jeg /)
 630     integer,          intent(in)           :: layout(:)
 631     type(domain2D),   intent(inout)        :: domain
 632     integer,          intent(in), optional :: pelist(0:)
 633     integer,          intent(in), optional :: xflags, yflags, xhalo, yhalo
 634     integer,          intent(in), optional :: xextent(0:), yextent(0:)
 635     logical,          intent(in), optional :: maskmap(0:,0:)
 636     character(len=*), intent(in), optional :: name
 637     logical,          intent(in), optional :: symmetry
 638     logical,          intent(in), optional :: is_mosaic                  !< indicate if calling mpp_define_domains
 639                                                                          !! from mpp_define_mosaic.
 640     integer,          intent(in), optional :: memory_size(:)
 641     integer,          intent(in), optional :: whalo, ehalo, shalo, nhalo !< halo size for West, East,
 642                                                                          !! South and North direction.
 643                                                                          !! if whalo and ehalo is not present,
 644                                                                          !! will take the value of xhalo
 645                                                                          !! if shalo and nhalo is not present,
 646                                                                          !! will take the value of yhalo
 647     integer, intent(in),          optional :: tile_count                 !< tile number on current pe,
 648                                                                          !! default value is 1.
 649                                                                          !! this is for the situation that
 650                                                                          !! multiple tiles on one processor
 651     integer, intent(in),          optional :: tile_id                    !< tile id
 652     logical, intent(in),          optional :: complete                   !< true indicate mpp_define_domain
 653                                                                          !! is completed for mosaic definition.
 654     integer, intent(in),          optional :: x_cyclic_offset            !< offset for x-cyclic boundary condition,
 655                                                                          !! (0,j) = (ni, mod(j+x_cyclic_offset,nj))
 656                                                                          !! (ni+1, j)=(1 ,mod(j+nj-x_cyclic_offset,nj))
 657     integer, intent(in),          optional :: y_cyclic_offset            !< offset for y-cyclic boundary condition
 658                                                                          !!(i,0)    = (mod(i+y_cyclic_offset,ni), nj))
 659                                                                          !!(i,nj+1) =(mod(mod(i+ni-y_cyclic_offset,ni),
 660                                                                          !! 1) )
 661
 662     integer              :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
 663     integer              :: whalosz, ehalosz, shalosz, nhalosz
 664     integer              :: ipos, jpos, pos, tile, nlist, cur_tile_id
 665     integer              :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
 666     integer              :: x_offset, y_offset, start_pos, nfold
 667     logical              :: from_mosaic, is_complete
 668     logical              :: mask(0:layout(1)-1,0:layout(2)-1)
 669     integer, allocatable :: pes(:), pesall(:)
 670     integer              :: pearray(0:layout(1)-1,0:layout(2)-1)
 671     integer              :: ibegin(0:layout(1)-1), iend(0:layout(1)-1)
 672     integer              :: jbegin(0:layout(2)-1), jend(0:layout(2)-1)
 673     character(len=8)     :: text
 674     type(overlapSpec), pointer :: check_T => NULL()
 675     integer              :: outunit
 676     logical              :: send(8), recv(8)
 677
 678     outunit = stdout()
 679     if( .NOT.module_is_initialized )call mpp_error( FATAL, &
 680        &  'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
 681     if(PRESENT(name)) then
 682        if(len_trim(name) > NAME_LENGTH) call mpp_error(FATAL,  &
 683             "mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument name ="//trim(name)// &
 684             " is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
 685        domain%name = name
 686     endif
 687     if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL,   &
 688        "mpp_define_domains2D: size of global_indices should be 4 for "//trim(domain%name) )
 689     if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains2D: size of layout should be 2 for "// &
 690        & trim(domain%name) )
 691
 692     ndivx = layout(1); ndivy = layout(2)
 693     isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
 694
 695     from_mosaic = .false.
 696     if(present(is_mosaic)) from_mosaic = is_mosaic
 697     is_complete = .true.
 698     if(present(complete)) is_complete = complete
 699     tile = 1
 700     if(present(tile_count)) tile = tile_count
 701     cur_tile_id = 1
 702     if(present(tile_id)) cur_tile_id = tile_id
 703
 704     if( PRESENT(pelist) )then
 705        allocate( pes(0:size(pelist(:))-1) )
 706        pes = pelist
 707        if(from_mosaic) then
 708           allocate( pesall(0:mpp_npes()-1) )
 709           call mpp_get_current_pelist(pesall)
 710        else
 711           allocate( pesall(0:size(pes(:))-1) )
 712           pesall = pes
 713        end if
 714     else
 715        allocate( pes(0:mpp_npes()-1) )
 716        allocate( pesall(0:mpp_npes()-1) )
 717        call mpp_get_current_pelist(pes)
 718        pesall = pes
 719     end if
 720
 721     !--- at least of one of x_cyclic_offset and y_cyclic_offset must be zero
 722     !--- folded boundary condition is not supported when either x_cyclic_offset or  y_cyclic_offset is nonzero.
 723     !--- Since we only implemented Folded-north boundary condition currently, we only consider y-flags.
 724     x_offset = 0; y_offset = 0
 725     if(PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
 726     if(PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
 727     if(x_offset*y_offset .NE. 0) call mpp_error(FATAL, &
 728        'MPP_DEFINE_DOMAINS2D: At least one of x_cyclic_offset and y_cyclic_offset must be zero for '// &
 729        & trim(domain%name))
 730
 731     !--- x_cyclic_offset and y_cyclic_offset should no larger than the global grid size.
 732     if(abs(x_offset) > jeg-jsg+1) call mpp_error(FATAL, &
 733          'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset is greater than jeg-jsg+1 for '//trim(domain%name))
 734     if(abs(y_offset) > ieg-isg+1) call mpp_error(FATAL, &
 735          'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset is greater than ieg-isg+1 for '//trim(domain%name))
 736
 737     !--- when there is more than one tile on one processor, all the tile will limited on this processor
 738     if( tile > 1 .AND. size(pes(:)) > 1) call mpp_error(FATAL, &
 739          'MPP_DEFINE_DOMAINS2D: there are more than one tile on this pe, '// &
 740          'all the tile should be limited on this pe for '//trim(domain%name))
 741
 742     !--- the position of current pe is changed due to mosaic, because  pes
 743     !--- is only part of the pelist in mosaic (pesall). We assume the pe
 744     !--- distribution are contious in mosaic.
 745     pos = -1
 746     do n = 0, size(pesall(:))-1
 747        if(pesall(n) == mpp_pe() ) then
 748           pos = n
 749           exit
 750        endif
 751     enddo
 752     if(pos<0) call  mpp_error(FATAL, 'MPP_DEFINE_DOMAINS2D: mpp_pe() is not in the pesall list')
 753
 754     domain%symmetry = .FALSE.
 755     if(present(symmetry)) domain%symmetry = symmetry
 756     if(domain%symmetry) then
 757        ishift = 1; jshift = 1
 758     else
 759        ishift = 0; jshift = 0
 760     end if
 761
 762     !--- first compute domain decomposition.
 763     call mpp_compute_extent(isg, ieg, ndivx, ibegin, iend, xextent)
 764     call mpp_compute_extent(jsg, jeg, ndivy, jbegin, jend, yextent)
 765
 766     xhalosz = 0; yhalosz = 0
 767     if(present(xhalo)) xhalosz = xhalo
 768     if(present(yhalo)) yhalosz = yhalo
 769     whalosz = xhalosz; ehalosz = xhalosz
 770     shalosz = yhalosz; nhalosz = yhalosz
 771     if(present(whalo)) whalosz = whalo
 772     if(present(ehalo)) ehalosz = ehalo
 773     if(present(shalo)) shalosz = shalo
 774     if(present(nhalo)) nhalosz = nhalo
 775
 776     !--- configure maskmap
 777     mask = .TRUE.
 778     if( PRESENT(maskmap) )then
 779        if( size(maskmap,1).NE.ndivx .OR. size(maskmap,2).NE.ndivy ) &
 780             call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout for '// &
 781                            & trim(domain%name) )
 782        mask(:,:) = maskmap(:,:)
 783     end if
 784     !number of unmask domains in layout must equal number of PEs assigned
 785     n = count(mask)
 786     if( n.NE.size(pes(:)) )then
 787        write( text,'(i8)' )n
 788        call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for ' // &
 789             'this layout and maskmap. Use '//text//' PEs for this domain decomposition for '//trim(domain%name) )
 790     end if
 791
 792     memory_xsize = 0; memory_ysize = 0
 793     if(present(memory_size)) then
 794        if(size(memory_size(:)) .NE. 2) call mpp_error(FATAL,  &
 795              "mpp_define_domains2D: size of memory_size should be 2 for "//trim(domain%name))
 796        memory_xsize = memory_size(1)
 797        memory_ysize = memory_size(2)
 798     end if
 799
 800     !--- set up domain%list.
 801     !--- set up 2-D domain decomposition for T, E, C, N and computing overlapping
 802     !--- when current tile is the last tile in the mosaic.
 803     nlist = size(pesall(:))
 804     if( .NOT. Associated(domain%x) ) then
 805        allocate(domain%tileList(1))
 806        domain%tileList(1)%xbegin = global_indices(1)
 807        domain%tileList(1)%xend   = global_indices(2)
 808        domain%tileList(1)%ybegin = global_indices(3)
 809        domain%tileList(1)%yend   = global_indices(4)
 810        allocate(domain%x(1), domain%y(1) )
 811        allocate(domain%tile_id(1))
 812        allocate(domain%tile_id_all(1))
 813        domain%tile_id        = cur_tile_id
 814        domain%tile_id_all    = cur_tile_id
 815        domain%ntiles         = 1
 816        domain%max_ntile_pe   = 1
 817        domain%ncontacts      = 0
 818        domain%rotated_ninety = .FALSE.
 819        allocate( domain%list(0:nlist-1) )
 820        do i = 0, nlist-1
 821           allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1) )
 822        end do
 823     end if
 824
 825     domain%initialized = .true.
 826
 827     start_pos = 0
 828     do n = 0, nlist-1
 829        if(pesall(n) == pes(0)) then
 830           start_pos = n
 831           exit
 832        endif
 833     enddo
 834
 835     !place on PE array; need flag to assign them to j first and then i
 836     pearray(:,:) = NULL_PE
 837     ipos = NULL_PE; jpos = NULL_PE
 838     n = 0
 839     m = start_pos
 840     do j = 0,ndivy-1
 841        do i = 0,ndivx-1
 842           if( mask(i,j) )then
 843              pearray(i,j) = pes(n)
 844              domain%list(m)%x(tile)%compute%begin = ibegin(i)
 845              domain%list(m)%x(tile)%compute%end   = iend(i)
 846              domain%list(m)%y(tile)%compute%begin = jbegin(j)
 847              domain%list(m)%y(tile)%compute%end   = jend(j)
 848              domain%list(m)%x(tile)%compute%size  = domain%list(m)%x(tile)%compute%end &
 849                                                   & - domain%list(m)%x(tile)%compute%begin + 1
 850              domain%list(m)%y(tile)%compute%size  = domain%list(m)%y(tile)%compute%end &
 851                                                   & - domain%list(m)%y(tile)%compute%begin + 1
 852              domain%list(m)%tile_id(tile)         = cur_tile_id
 853              domain%list(m)%x(tile)%pos           = i
 854              domain%list(m)%y(tile)%pos           = j
 855              domain%list(m)%tile_root_pe          = pes(0)
 856              domain%list(m)%pe                    = pesall(m)
 857
 858              if( pes(n).EQ.mpp_pe() )then
 859                 ipos = i
 860                 jpos = j
 861              end if
 862              n = n + 1
 863              m = m + 1
 864           end if
 865        end do
 866     end do
 867
 868     !Considering mosaic, the following will only be done on the pe in the pelist
 869     !when there is only one tile, all the current pe will be in the pelist.
 870     if( ANY(pes == mpp_pe()) ) then
 871        domain%io_layout = layout
 872        domain%tile_root_pe  = pes(0)
 873        if( ipos.EQ.NULL_PE .OR. jpos.EQ.NULL_PE ) &
 874             call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: pelist must include this PE for '//trim(domain%name) )
 875        if( debug ) then
 876          errunit = stderr()
 877          write( errunit, * )'pe, tile, ipos, jpos=', mpp_pe(), tile, ipos, jpos, ' pearray(:,jpos)=', &
 878                   pearray(:,jpos), ' pearray(ipos,:)=', pearray(ipos,:)
 879        endif
 880
 881        !--- when tile is not equal to 1, the layout for that tile always ( 1, 1), so no need for pearray in domain
 882        if( tile == 1 ) then
 883           allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
 884           domain%pearray = pearray
 885        end if
 886
 887        domain%pe  = mpp_pe()
 888        domain%pos  = pos
 889        domain_cnt = domain_cnt + INT(1,KIND=i8_kind)
 890        domain%id = domain_cnt*DOMAIN_ID_BASE  ! Must be i8_kind arithmetic
 891
 892        !do domain decomposition using 1D versions in X and Y,
 893        call mpp_define_domains( global_indices(1:2), ndivx, domain%x(tile), &
 894             pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
 895        call mpp_define_domains( global_indices(3:4), ndivy, domain%y(tile), &
 896             pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
 897        if( domain%x(tile)%list(ipos)%pe.NE.domain%y(tile)%list(jpos)%pe ) &
 898             call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pe.NE.domain%y%list(jpos)%pe.' )
 899
 900        !--- when x_cyclic_offset or y_cyclic_offset is set, no cross domain is allowed
 901        if(x_offset .NE. 0 .OR. y_offset .NE. 0) then
 902           if(whalosz .GT. domain%x(tile)%compute%size .OR. ehalosz .GT. domain%x(tile)%compute%size ) &
 903               call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
 904                  "whalo and ehalo must be no larger than the x-direction computation domain size")
 905           if(shalosz .GT. domain%y(tile)%compute%size .OR. nhalosz .GT. domain%y(tile)%compute%size ) &
 906               call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
 907                  "shalo and nhalo must be no larger than the y-direction computation domain size")
 908        endif
 909
 910        !--- restrict the halo size is no larger than global domain size.
 911        if(whalosz .GT. domain%x(tile)%global%size) &
 912            call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: whalo is greather global domain size")
 913        if(ehalosz .GT. domain%x(tile)%global%size) &
 914            call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: ehalo is greather global domain size")
 915        if(shalosz .GT. domain%x(tile)%global%size) &
 916            call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: shalo is greather global domain size")
 917        if(nhalosz .GT. domain%x(tile)%global%size) &
 918            call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: nhalo is greather global domain size")
 919
 920        !set up fold, when the boundary is folded, there is only one tile.
 921        domain%fold = 0
 922        nfold = 0
 923        if( PRESENT(xflags) )then
 924           if( BTEST(xflags,WEST) ) then
 925              !--- make sure no cross-domain in y-direction
 926              if(domain%x(tile)%data%begin .LE. domain%x(tile)%global%begin .AND. &
 927                 domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then
 928                 call mpp_error(FATAL, &
 929                  'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded')
 930              endif
 931              if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
 932                    'MPP_DEFINE_DOMAINS: an axis cannot be both folded west and cyclic for '//trim(domain%name) )
 933              domain%fold = domain%fold + FOLD_WEST_EDGE
 934              nfold = nfold+1
 935           endif
 936           if( BTEST(xflags,EAST) ) then
 937              !--- make sure no cross-domain in y-direction
 938              if(domain%x(tile)%data%end .GE. domain%x(tile)%global%end .AND. &
 939                 domain%x(tile)%compute%end < domain%x(tile)%global%end ) then
 940                 call mpp_error(FATAL, &
 941                  'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded')
 942              endif
 943              if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
 944                   'MPP_DEFINE_DOMAINS: an axis cannot be both folded east and cyclic for '//trim(domain%name) )
 945              domain%fold = domain%fold + FOLD_EAST_EDGE
 946              nfold = nfold+1
 947           endif
 948        endif
 949        if( PRESENT(yflags) )then
 950           if( BTEST(yflags,SOUTH) ) then
 951              !--- make sure no cross-domain in y-direction
 952              if(domain%y(tile)%data%begin .LE. domain%y(tile)%global%begin .AND. &
 953                 domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then
 954                 call mpp_error(FATAL, &
 955                  'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded')
 956              endif
 957              if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
 958                  'MPP_DEFINE_DOMAINS: an axis cannot be both folded north and cyclic for '//trim(domain%name))
 959              domain%fold = domain%fold + FOLD_SOUTH_EDGE
 960              nfold = nfold+1
 961           endif
 962           if( BTEST(yflags,NORTH) ) then
 963              !--- when the halo size is big and halo region is crossing neighbor domain, we
 964              !--- restrict the halo size is less than half of the global size.
 965              if(whalosz .GT. domain%x(tile)%compute%size .AND. whalosz .GE. domain%x(tile)%global%size/2 ) &
 966                   call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, whalo .GT. compute domain size "// &
 967                   "and whalo .GE. half of global domain size")
 968              if(ehalosz .GT. domain%x(tile)%compute%size .AND. ehalosz .GE. domain%x(tile)%global%size/2 ) &
 969                   call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, ehalo is .GT. compute domain size "// &
 970                   "and ehalo .GE. half of global domain size")
 971              if(shalosz .GT. domain%y(tile)%compute%size .AND. shalosz .GE. domain%x(tile)%global%size/2 ) &
 972                   call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, shalo .GT. compute domain size "// &
 973                   "and shalo .GE. half of global domain size")
 974              if(nhalosz .GT. domain%y(tile)%compute%size .AND. nhalosz .GE. domain%x(tile)%global%size/2 ) &
 975                   call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, nhalo .GT. compute domain size "// &
 976                   "and nhalo .GE. half of global domain size")
 977
 978
 979              if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
 980                 'MPP_DEFINE_DOMAINS: an axis cannot be both folded south and cyclic for '//trim(domain%name) )
 981              domain%fold = domain%fold + FOLD_NORTH_EDGE
 982              nfold = nfold+1
 983           endif
 984        endif
 985        if(nfold > 1) call mpp_error(FATAL, &
 986            'MPP_DEFINE_DOMAINS2D: number of folded edge is greater than 1 for '//trim(domain%name) )
 987
 988        if(nfold == 1) then
 989            if( x_offset .NE. 0 .OR. y_offset .NE. 0) call mpp_error(FATAL, &
 990                'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition,  '//&
 991                'x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
 992        endif
 993        if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,NORTH) )then
 994           if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
 995               'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
 996           if( modulo(domain%x(tile)%global%size,2).NE.0 ) &
 997                call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in X must be even ' // &
 998                   'when there is a fold in Y for '//trim(domain%name) )
 999           !check if folded domain boundaries line up in X: compute domains lining up is a sufficient
1000           !condition for symmetry
1001           n = ndivx - 1
1002           do i = 0,n/2
1003              if( domain%x(tile)%list(i)%compute%size.NE.domain%x(tile)%list(n-i)%compute%size ) &
1004                   call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries ' // &
1005                                          'must line up (mirror-symmetric extents) for '//trim(domain%name) )
1006           end do
1007        end if
1008        if( BTEST(domain%fold,WEST) .OR. BTEST(domain%fold,EAST) )then
1009           if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
1010              'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
1011           if( modulo(domain%y(tile)%global%size,2).NE.0 ) &
1012                call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in Y must be even '//&
1013                    'when there is a fold in X for '//trim(domain%name) )
1014           !check if folded domain boundaries line up in Y: compute domains lining up is a sufficient
1015           !condition for symmetry
1016           n = ndivy - 1
1017           do i = 0,n/2
1018              if( domain%y(tile)%list(i)%compute%size.NE.domain%y(tile)%list(n-i)%compute%size ) &
1019                   call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must '//&
1020                         'line up (mirror-symmetric extents) for '//trim(domain%name) )
1021           end do
1022        end if
1023
1024        !set up domain%list
1025        if( mpp_pe().EQ.pes(0) .AND. PRESENT(name) )then
1026           logunit = stdlog()
1027           write( logunit, '(/a,i5,a,i5)' )trim(name)//' domain decomposition: ', ndivx, ' X', ndivy
1028           write( logunit, '(3x,a)' )'pe,   is,  ie,  js,  je,    isd, ied, jsd, jed'
1029        end if
1030     end if   !     if( ANY(pes == mpp_pe()) )
1031
1032     if(is_complete) then
1033        domain%whalo = whalosz; domain%ehalo = ehalosz
1034        domain%shalo = shalosz; domain%nhalo = nhalosz
1035        allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
1036        domain%update_T%next => NULL()
1037        domain%update_E%next => NULL()
1038        domain%update_C%next => NULL()
1039        domain%update_N%next => NULL()
1040        allocate(domain%check_E,  domain%check_C,  domain%check_N )
1041        domain%update_T%nsend = 0
1042        domain%update_T%nrecv = 0
1043        domain%update_C%nsend = 0
1044        domain%update_C%nrecv = 0
1045        domain%update_E%nsend = 0
1046        domain%update_E%nrecv = 0
1047        domain%update_N%nsend = 0
1048        domain%update_N%nrecv = 0
1049
1050        if( BTEST(domain%fold,SOUTH) ) then
1051           call compute_overlaps_fold_south(domain, CENTER,      0,      0)
1052           call compute_overlaps_fold_south(domain, CORNER, ishift, jshift)
1053           call compute_overlaps_fold_south(domain, EAST,   ishift,      0)
1054           call compute_overlaps_fold_south(domain, NORTH,  0,      jshift)
1055        else if( BTEST(domain%fold,WEST) ) then
1056           call compute_overlaps_fold_west(domain, CENTER,      0,      0)
1057           call compute_overlaps_fold_west(domain, CORNER, ishift, jshift)
1058           call compute_overlaps_fold_west(domain, EAST,   ishift,      0)
1059           call compute_overlaps_fold_west(domain, NORTH,       0, jshift)
1060        else if( BTEST(domain%fold,EAST) ) then
1061           call compute_overlaps_fold_east(domain, CENTER,      0,      0)
1062           call compute_overlaps_fold_east(domain, CORNER, ishift, jshift)
1063           call compute_overlaps_fold_east(domain, EAST,   ishift,      0)
1064           call compute_overlaps_fold_east(domain, NORTH,       0, jshift)
1065        else
1066           call compute_overlaps(domain, CENTER, domain%update_T, check_T,             0,      0, x_offset, y_offset, &
1067                                 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1068           call compute_overlaps(domain, CORNER, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
1069                                 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1070           call compute_overlaps(domain, EAST,   domain%update_E, domain%check_E,  ishift,     0, x_offset, y_offset, &
1071                                 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1072           call compute_overlaps(domain, NORTH,  domain%update_N, domain%check_N,      0, jshift, x_offset, y_offset, &
1073                                 domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1074        endif
1075        call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_domains")
1076        call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_domains")
1077        call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_domains")
1078        call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_domains")
1079
1080
1081        !--- when ncontacts is nonzero, set_check_overlap will be called in mpp_define
1082        if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1083           call set_check_overlap( domain, CORNER )
1084           call set_check_overlap( domain, EAST   )
1085           call set_check_overlap( domain, NORTH  )
1086           allocate(domain%bound_E,  domain%bound_C,  domain%bound_N )
1087           call set_bound_overlap( domain, CORNER )
1088           call set_bound_overlap( domain, EAST   )
1089           call set_bound_overlap( domain, NORTH  )
1090        end if
1091        call set_domain_comm_inf(domain%update_T)
1092        call set_domain_comm_inf(domain%update_E)
1093        call set_domain_comm_inf(domain%update_C)
1094        call set_domain_comm_inf(domain%update_N)
1095     end if
1096
1097     !--- check the send and recv size are matching.
1098     !--- or ntiles>1 mosaic,
1099     !--- the check will be done in mpp_define_mosaic
1100     if(debug_message_passing .and. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1101        send = .true.
1102        recv = .true.
1103        call check_message_size(domain, domain%update_T, send, recv, 'T')
1104        call check_message_size(domain, domain%update_E, send, recv, 'E')
1105        call check_message_size(domain, domain%update_C, send, recv, 'C')
1106        call check_message_size(domain, domain%update_N, send, recv, 'N')
1107     endif
1108
1109
1110     !print out decomposition, this didn't consider maskmap.
1111     if( mpp_pe() .EQ. pes(0) .AND. PRESENT(name) )then
1112        write(*,*) trim(name)//' domain decomposition'
1113        write(*,'(a,i4,a,i4,a,i4,a,i4)')'whalo = ', whalosz, ", ehalo = ", ehalosz, ", shalo = ", shalosz, &
1114                                      & ", nhalo = ", nhalosz
1115        write (*,110) (domain%x(1)%list(i)%compute%size, i= 0, layout(1)-1)
1116        write (*,120) (domain%y(1)%list(i)%compute%size, i= 0, layout(2)-1)
1117 110    format ('  X-AXIS = ',24i4,/,(11x,24i4))
1118 120    format ('  Y-AXIS = ',24i4,/,(11x,24i4))
1119     endif
1120
1121     deallocate( pes, pesall)
1122
1123
1124   return
1125 end subroutine mpp_define_domains2D
1126
1127
1128 !#####################################################################
1129 subroutine check_message_size(domain, update, send, recv, position)
1130   type(domain2d),       intent(in) :: domain
1131   type(overlapSpec),    intent(in) :: update
1132   logical,              intent(in) :: send(:)
1133   logical,              intent(in) :: recv(:)
1134   character,            intent(in) :: position
1135
1136   integer, dimension(0:size(domain%list(:))-1) :: msg1, msg2, msg3
1137   integer :: m, n, l, dir, is, ie, js, je, from_pe, msgsize
1138   integer :: nlist
1139
1140   nlist = size(domain%list(:))
1141
1142
1143   msg1 = 0
1144   msg2 = 0
1145   do m = 1, update%nrecv
1146      msgsize = 0
1147      do n = 1, update%recv(m)%count
1148         dir = update%recv(m)%dir(n)
1149         if( recv(dir) ) then
1150            is = update%recv(m)%is(n); ie = update%recv(m)%ie(n)
1151            js = update%recv(m)%js(n); je = update%recv(m)%je(n)
1152            msgsize = msgsize + (ie-is+1)*(je-js+1)
1153         endif
1154      end do
1155      from_pe = update%recv(m)%pe
1156      l = from_pe-mpp_root_pe()
1157      call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1)
1158      msg2(l) = msgsize
1159   enddo
1160
1161   do m = 1, update%nsend
1162      msgsize = 0
1163      do n = 1, update%send(m)%count
1164         dir = update%send(m)%dir(n)
1165         if(send(dir))then
1166            is = update%send(m)%is(n); ie = update%send(m)%ie(n)
1167            js = update%send(m)%js(n); je = update%send(m)%je(n)
1168            msgsize = msgsize + (ie-is+1)*(je-js+1)
1169         endif
1170      end do
1171      l = update%send(m)%pe-mpp_root_pe()
1172      msg3(l) = msgsize
1173      call mpp_send( msg3(l), plen=1, to_pe=update%send(m)%pe, tag=COMM_TAG_1)
1174   enddo
1175   call mpp_sync_self(check=EVENT_RECV)
1176
1177   do m = 0, nlist-1
1178      if(msg1(m) .NE. msg2(m)) then
1179         print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",at position=",position,",from pe=", &
1180              domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
1181         call mpp_error(FATAL, "mpp_define_domains2D: mismatch on send and recv size")
1182      endif
1183   enddo
1184   call mpp_sync_self()
1185
1186
1187 end subroutine check_message_size
1188
1189   !#####################################################################
1190 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1191 !                                                                             !
1192 !              MPP_define_mosaic: define mosaic domain                        !
1193 !  NOTE: xflags and yflags is not in mpp_define_mosaic, because such relation !
1194 !        are already defined in the mosaic relation.                          !
1195 !                                                                             !
1196 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1197 !??? do we need optional argument xextent and yextent
1198 !??? how to specify pelist, we may use two dimensional variable pelist to represent.
1199 !z1l: We assume the tilelist are in always limited to 1, 2, ... num_tile. If we want
1200 !     to remove this limitation, we need to add one more argument tilelist.
1201   subroutine mpp_define_mosaic( global_indices, layout, domain, num_tile, num_contact, tile1, tile2,      &
1202                                 istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
1203                                 pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent,             &
1204                                 maskmap, name, memory_size, symmetry, xflags, yflags, tile_id )
1205     integer,          intent(in)           :: global_indices(:,:)  ! The size of first indice is 4,
1206                                                                    !! (/ isg, ieg, jsg, jeg /)
1207                                                                    ! The size of second indice
1208                                                                    ! is number of tiles in mosaic.
1209     integer,          intent(in)           :: layout(:,:)
1210     type(domain2D),   intent(inout)        :: domain
1211     integer,          intent(in)           :: num_tile             ! number of tiles in the mosaic
1212     integer,          intent(in)           :: num_contact          ! number of contact region between tiles.
1213     integer,          intent(in)           :: tile1(:), tile2(:)   ! tile number
1214     integer,          intent(in)           :: istart1(:), iend1(:) ! i-index in tile_1 of contact region
1215     integer,          intent(in)           :: jstart1(:), jend1(:) ! j-index in tile_1 of contact region
1216     integer,          intent(in)           :: istart2(:), iend2(:) ! i-index in tile_2 of contact region
1217     integer,          intent(in)           :: jstart2(:), jend2(:) ! j-index in tile_2 of contact region
1218     integer,          intent(in)           :: pe_start(:)          ! start pe of the pelist used in each tile
1219     integer,          intent(in)           :: pe_end(:)            ! end pe of the pelist used in each tile
1220     integer,          intent(in), optional :: pelist(:)            ! list of processors used in mosaic
1221     integer,          intent(in), optional :: whalo, ehalo, shalo, nhalo
1222     integer,          intent(in), optional :: xextent(:,:), yextent(:,:)
1223     logical,          intent(in), optional :: maskmap(:,:,:)
1224     character(len=*), intent(in), optional :: name
1225     integer,          intent(in), optional :: memory_size(2)
1226     logical,          intent(in), optional :: symmetry
1227     integer,          intent(in), optional :: xflags, yflags
1228     integer,          intent(in), optional :: tile_id(:)           ! tile_id of each tile in the mosaic
1229
1230     integer              :: n, m, ndivx, ndivy, nc, nlist, nt, pos, n1, n2
1231     integer              :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz, t1, t2, tile
1232     integer              :: flags_x, flags_y
1233     logical, allocatable :: mask(:,:)
1234     integer, allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
1235     integer, allocatable :: tile_id_local(:)
1236     logical              :: is_symmetry
1237     integer, allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
1238     integer, allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:)
1239     real,    allocatable :: refine1(:), refine2(:)
1240     integer              :: outunit
1241     logical              :: send(8), recv(8)
1242
1243     outunit = stdout()
1244     mosaic_defined = .true.
1245     !--- the size of first indice of global_indices must be 4.
1246     if(size(global_indices, 1) .NE. 4) call mpp_error(FATAL, &
1247          'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
1248     !--- the size of second indice of global_indices must be num_tile
1249     if(size(global_indices, 2) .NE. num_tile) call mpp_error(FATAL, &
1250          'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
1251     !--- the size of first indice of layout must be 2. The second dimension size of layout must equal num_tile.
1252     if(size(layout, 1) .NE. 2) call mpp_error(FATAL, &
1253          'mpp_domains_define.inc: The size of first dimension of layout is not 2')
1254     if(size(layout,2) .NE. num_tile)  call mpp_error(FATAL, &
1255          'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
1256
1257     !--- setup pelist for the mosaic ---------------------
1258     nlist = mpp_npes()
1259     allocate(pes(0:nlist-1))
1260     if(present(pelist)) then
1261        if( nlist .NE. size(pelist(:))) call mpp_error(FATAL, &
1262             'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
1263        pes = pelist
1264     else
1265        call mpp_get_current_pelist(pes)
1266     end if
1267     !--- pelist should be monotonic increasing by 1.
1268     do n = 1, nlist-1
1269        if(pes(n) - pes(n-1) .NE. 1) call mpp_error(FATAL, &
1270            'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
1271     end do
1272
1273     is_symmetry        = .FALSE.
1274     if(present(symmetry)) is_symmetry = symmetry
1275
1276     if(size(pe_start(:)) .NE. num_tile .OR. size(pe_end(:)) .NE. num_tile ) call mpp_error(FATAL, &
1277          'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
1278     !--- make sure pe_start and pe_end is in the pelist.
1279     if( ANY( pe_start < pes(0) ) ) call mpp_error(FATAL, &
1280        &  'mpp_domains_define.inc: not all the pe_start are in the pelist')
1281     if( ANY( pe_end > pes(nlist-1)) ) call mpp_error(FATAL, &
1282        &  'mpp_domains_define.inc: not all the pe_end are in the pelist')
1283
1284     !--- calculate number of tiles on each pe.
1285     allocate( ntile_per_pe(0:nlist-1) )
1286     ntile_per_pe = 0
1287     do n = 1, num_tile
1288        do m = pe_start(n) - mpp_root_pe(), pe_end(n) - mpp_root_pe()
1289           ntile_per_pe(m) = ntile_per_pe(m) + 1
1290        end do
1291     end do
1292     if(ANY(ntile_per_pe == 0)) call mpp_error(FATAL, &
1293          'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
1294
1295     !--- check the size comformable of xextent and yextent
1296     if( PRESENT(xextent) ) then
1297        if(size(xextent,1) .GT. maxval(layout(1,:)) ) call mpp_error(FATAL, &
1298             'mpp_domains_define.inc: size mismatch between xextent and layout')
1299        if(size(xextent,2) .NE. num_tile) call mpp_error(FATAL, &
1300             'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
1301     end if
1302     if( PRESENT(yextent) ) then
1303        if(size(yextent,1) .GT. maxval(layout(2,:)) ) call mpp_error(FATAL, &
1304             'mpp_domains_define.inc: size mismatch between yextent and layout')
1305        if(size(yextent,2) .NE. num_tile) call mpp_error(FATAL, &
1306             'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
1307     end if
1308
1309     !--- check the size comformable of maskmap
1310     !--- since the layout is different between tiles, so the actual size of maskmap for each tile is
1311     !--- not diffrent. When define maskmap for multiple tiles, user can choose the maximum value
1312     !--- of layout of all tiles to the first and second dimension of maskmap.
1313     if(present(maskmap)) then
1314        if(size(maskmap,1) .GT. maxval(layout(1,:)) .or. size(maskmap,2) .GT. maxval(layout(2,:))) &
1315             call mpp_error(FATAL, 'mpp_domains_define.inc: size mismatch between maskmap and layout')
1316        if(size(maskmap,3) .NE. num_tile) call mpp_error(FATAL, &
1317             'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
1318     end if
1319
1320     allocate(domain%tileList(num_tile))
1321     do n = 1, num_tile
1322        domain%tileList(n)%xbegin = global_indices(1,n)
1323        domain%tileList(n)%xend   = global_indices(2,n)
1324        domain%tileList(n)%ybegin = global_indices(3,n)
1325        domain%tileList(n)%yend   = global_indices(4,n)
1326     enddo
1327     !--- define some mosaic information in domain type
1328     nt = ntile_per_pe(mpp_pe()-mpp_root_pe())
1329     allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) )
1330     allocate(domain%list(0:nlist-1))
1331
1332     do n = 0, nlist-1
1333        nt = ntile_per_pe(n)
1334        allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt) )
1335     end do
1336
1337     pe = mpp_pe()
1338     pos = 0
1339     if( PRESENT(tile_id) ) then
1340        if(size(tile_id(:)) .NE. num_tile) then
1341           call mpp_error(FATAL, "mpp_domains_define.inc: size(tile_id) .NE. num_tile")
1342        endif
1343     endif
1344     allocate(tile_id_local(num_tile))
1345
1346 !These directives are a work-around for a bug in the CCE compiler, which
1347 !causes a segmentation fault when the compiler attempts to vectorize a
1348 !loop containing an optional argument (when -g is included).
1349
1350 !DIR$ NOVECTOR
1351     do n = 1, num_tile
1352        if(PRESENT(tile_id)) then
1353           tile_id_local(n) = tile_id(n)
1354        else
1355           tile_id_local(n) = n
1356        endif
1357     enddo
1358 !DIR$ VECTOR
1359
1360     do n = 1, num_tile
1361        if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n)) then
1362           pos = pos + 1
1363           domain%tile_id(pos) = tile_id_local(n)
1364        end if
1365     end do
1366
1367     allocate(domain%tile_id_all(num_tile))
1368     domain%tile_id_all(:) = tile_id_local(:)
1369
1370     domain%initialized    = .true.
1371     domain%rotated_ninety = .FALSE.
1372     domain%ntiles         = num_tile
1373     domain%max_ntile_pe   = maxval(ntile_per_pe)
1374     domain%ncontacts      = num_contact
1375
1376     deallocate(ntile_per_pe)
1377     !---call mpp_define_domain to define domain decomposition for each tile.
1378     allocate(tile_count(pes(0):pes(0)+nlist-1))
1379     tile_count = 0  ! tile number on current pe
1380
1381     do n = 1, num_tile
1382        allocate(mask(layout(1,n), layout(2,n)))
1383        allocate(pelist_tile(pe_start(n):pe_end(n)) )
1384        tile_count(pe_start(n)) = tile_count(pe_start(n)) + 1
1385        do m = pe_start(n), pe_end(n)
1386           pelist_tile(m) = m
1387        end do
1388        mask = .TRUE.
1389        if(present(maskmap))  mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
1390        ndivx = layout(1,n); ndivy = layout(2,n)
1391        allocate(xext(ndivx), yext(ndivy))
1392        xext = 0; yext = 0
1393        if(present(xextent)) xext = xextent(1:ndivx,n)
1394        if(present(yextent)) yext = yextent(1:ndivy,n)
1395        ! when num_tile is one, we assume only folded_north and cyclic_x, cyclic_y boundary condition is the possible
1396        ! z1l: when we decide to support multiple-tile tripolar grid, we will redesign the following part.
1397        if(num_tile == 1) then
1398           flags_x = 0
1399           flags_y = 0
1400           if(PRESENT(xflags)) flags_x = xflags
1401           if(PRESENT(yflags)) flags_y = yflags
1402           do m = 1, num_contact
1403              if(istart1(m) == iend1(m) ) then  ! x-direction contact, possible cyclic, folded-west or folded-east
1404                 if(istart2(m) .NE. iend2(m) ) call mpp_error(FATAL,  &
1405                    "mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
1406                 if(istart1(m) == istart2(m) ) then ! folded west or folded east
1407                    if(istart1(m) == global_indices(1,n) ) then
1408                       if(.NOT. BTEST(flags_x,WEST) )  flags_x = flags_x + FOLD_WEST_EDGE
1409                    else if(istart1(m) == global_indices(2,n) ) then
1410                       if(.NOT. BTEST(flags_x,EAST) )  flags_x = flags_x + FOLD_EAST_EDGE
1411                    else
1412                        call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1413                          "istart1 should equal global_indices(1) or global_indices(2)")
1414                    endif
1415                 else
1416                 if(.NOT. BTEST(flags_x,CYCLIC))  flags_x = flags_x + CYCLIC_GLOBAL_DOMAIN
1417                 endif
1418              else if( jstart1(m) == jend1(m) ) then  ! y-direction contact, cyclic, folded-south or folded-north
1419                 if(jstart2(m) .NE. jend2(m) ) call mpp_error(FATAL,  &
1420                    "mpp_domains_define: for one tile mosaic, when jstart1=jend1, jstart2 must equal jend2")
1421                 if(jstart1(m) == jstart2(m) ) then ! folded south or folded north
1422                    if(jstart1(m) == global_indices(3,n) ) then
1423                       if(.NOT. BTEST(flags_y,SOUTH) )  flags_y = flags_y + FOLD_SOUTH_EDGE
1424                    else if(jstart1(m) == global_indices(4,n) ) then
1425                    if(.NOT. BTEST(flags_y,NORTH) )  flags_y = flags_y + FOLD_NORTH_EDGE
1426                 else
1427                        call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1428                          "istart1 should equal global_indices(1) or global_indices(2)")
1429                    endif
1430                 else
1431                    if(.NOT. BTEST(flags_y,CYCLIC))  flags_y = flags_y + CYCLIC_GLOBAL_DOMAIN
1432                 end if
1433              else
1434                call mpp_error(FATAL,  &
1435                    "mpp_domains_define: for one tile mosaic, invalid boundary contact")
1436              end if
1437           end do
1438           call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, xflags = flags_x, &
1439                                   yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,           &
1440                                   xextent=xext, yextent=yext, maskmap=mask, name=name, symmetry=is_symmetry,      &
1441                                   memory_size = memory_size, is_mosaic = .true., tile_id=tile_id_local(n))
1442        else
1443           call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile,                   &
1444                                   whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
1445                                   maskmap=mask, name=name, symmetry=is_symmetry, memory_size = memory_size,       &
1446                                   is_mosaic = .true., tile_count = tile_count(pe_start(n)), tile_id=tile_id_local(n), &
1447                                   complete = n==num_tile)
1448        end if
1449        deallocate(mask, xext, yext, pelist_tile)
1450     end do
1451
1452     deallocate(pes, tile_count)
1453
1454     if(num_contact == 0 .OR. num_tile == 1) return
1455
1456     !--- loop through each contact region and find the contact for each tile ( including alignment )
1457     !--- we assume the tiles list is continuous and starting from 1.
1458     allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
1459     allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
1460     allocate(isgList(num_tile), iegList(num_tile), jsgList(num_tile), jegList(num_tile) )
1461     allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
1462     !--- get the global domain for each tile
1463     do n = 1, num_tile
1464        isgList(n) = domain%tileList(n)%xbegin; iegList(n) = domain%tileList(n)%xend
1465        jsgList(n) = domain%tileList(n)%ybegin; jegList(n) = domain%tileList(n)%yend
1466     end do
1467
1468     !--- transfer the contact index to domain index.
1469     nc = 0
1470     do n = 1, num_contact
1471        t1 = tile1(n)
1472        t2 = tile2(n)
1473        is1(n) = istart1(n) + isgList(t1) - 1; ie1(n) = iend1(n) + isgList(t1) - 1
1474        js1(n) = jstart1(n) + jsgList(t1) - 1; je1(n) = jend1(n) + jsgList(t1) - 1
1475        is2(n) = istart2(n) + isgList(t2) - 1; ie2(n) = iend2(n) + isgList(t2) - 1
1476        js2(n) = jstart2(n) + jsgList(t2) - 1; je2(n) = jend2(n) + jsgList(t2) - 1
1477        call check_alignment( is1(n), ie1(n), js1(n), je1(n), isgList(t1), iegList(t1), jsgList(t1), &
1478                            &  jegList(t1), align1(n))
1479        call check_alignment( is2(n), ie2(n), js2(n), je2(n), isgList(t2), iegList(t2), jsgList(t2), &
1480                            &  jegList(t2), align2(n))
1481        if( (align1(n) == WEST .or. align1(n) == EAST ) .NEQV. (align2(n) == WEST .or. align2(n) == EAST ) )&
1482              domain%rotated_ninety=.true.
1483     end do
1484
1485     !--- calculate the refinement ratio between tiles
1486     do n = 1, num_contact
1487        n1 = max(abs(iend1(n) - istart1(n)), abs(jend1(n) - jstart1(n)) ) + 1
1488        n2 = max(abs(iend2(n) - istart2(n)), abs(jend2(n) - jstart2(n)) ) + 1
1489        refine1(n) = real(n2)/n1
1490        refine2(n) = real(n1)/n2
1491     end do
1492
1493     whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
1494     if(present(whalo)) whalosz = whalo
1495     if(present(ehalo)) ehalosz = ehalo
1496     if(present(shalo)) shalosz = shalo
1497     if(present(nhalo)) nhalosz = nhalo
1498     xhalosz = max(whalosz, ehalosz)
1499     yhalosz = max(shalosz, nhalosz)
1500
1501     !--- computing the overlap for the contact region with halo size xhalosz and yhalosz
1502     call define_contact_point( domain, CENTER, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
1503                                is1, ie1, js1, je1, is2, ie2, js2, je2, isgList, iegList, jsgList, jegList )
1504
1505     call set_contact_point( domain, CORNER )
1506     call set_contact_point( domain, EAST   )
1507     call set_contact_point( domain, NORTH  )
1508
1509     call set_domain_comm_inf(domain%update_T)
1510     call set_domain_comm_inf(domain%update_E)
1511     call set_domain_comm_inf(domain%update_C)
1512     call set_domain_comm_inf(domain%update_N)
1513
1514
1515     !--- goffset setting is needed for exact global sum
1516     do m = 1, size(domain%tile_id(:))
1517        tile = domain%tile_id(m)
1518        do n = 1, num_contact
1519           if( tile1(n) == tile ) then
1520              if(align1(n) == EAST ) domain%x(m)%goffset = 0
1521              if(align1(n) == NORTH) domain%y(m)%goffset = 0
1522           end if
1523           if( tile2(n) == tile ) then
1524              if(align2(n) == EAST ) domain%x(m)%goffset = 0
1525              if(align2(n) == NORTH) domain%y(m)%goffset = 0
1526           end if
1527        end do
1528     end do
1529     call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_mosaic")
1530     call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_mosaic")
1531     call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_mosaic")
1532     call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_mosaic")
1533
1534     !--- set the overlapping for boundary check if domain is symmetry
1535     if(debug_update_level .NE. NO_CHECK) then
1536        call set_check_overlap( domain, CORNER )
1537        call set_check_overlap( domain, EAST   )
1538        call set_check_overlap( domain, NORTH  )
1539     endif
1540     if(domain%symmetry) then
1541        allocate(domain%bound_E,  domain%bound_C,  domain%bound_N )
1542        call set_bound_overlap( domain, CORNER )
1543        call set_bound_overlap( domain, EAST   )
1544        call set_bound_overlap( domain, NORTH  )
1545        call check_overlap_pe_order(domain, domain%bound_C, trim(domain%name)//" bound_C")
1546        call check_overlap_pe_order(domain, domain%bound_E, trim(domain%name)//" bound_E")
1547        call check_overlap_pe_order(domain, domain%bound_N, trim(domain%name)//" bound_N")
1548     end if
1549
1550     !--- check the send and recv size are matching.
1551     !--- currently only check T and C-cell. For ntiles>1 mosaic,
1552     !--- the check will be done in mpp_define_mosaic
1553     if(debug_message_passing) then
1554        send = .true.
1555        recv = .true.
1556        call check_message_size(domain, domain%update_T, send, recv, 'T')
1557        call check_message_size(domain, domain%update_C, send, recv, 'C')
1558        call check_message_size(domain, domain%update_E, send, recv, 'E')
1559        call check_message_size(domain, domain%update_N, send, recv, 'N')
1560     endif
1561
1562
1563     !--- release memory
1564     deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2  )
1565     deallocate(isgList, iegList, jsgList, jegList, refine1, refine2 )
1566
1567
1568   end subroutine mpp_define_mosaic
1569
1570 !#####################################################################
1571   logical function mpp_mosaic_defined()
1572   ! Accessor function for value of mosaic_defined
1573     mpp_mosaic_defined = mosaic_defined
1574   end function mpp_mosaic_defined
1575 !#####################################################################
1576
1577   subroutine compute_overlaps( domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
1578                                whalo, ehalo, shalo, nhalo )
1579     !computes remote domain overlaps
1580     !assumes only one in each direction
1581     !will calculate the overlapping for T,E,C,N-cell seperately.
1582     type(domain2D), intent(inout) :: domain
1583     type(overlapSpec), intent(inout), pointer :: update
1584     type(overlapSpec), intent(inout), pointer :: check
1585     integer, intent(in)           :: position, ishift, jshift
1586     integer, intent(in)           :: x_cyclic_offset, y_cyclic_offset
1587     integer, intent(in)           :: whalo, ehalo, shalo, nhalo
1588
1589     integer                          :: i, m, n, nlist, tMe, tNbr, dir
1590     integer                          :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
1591     integer                          :: isg, ieg, jsg, jeg, ioff, joff
1592     integer                          :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
1593     integer                          :: ism, iem, jsm, jem
1594     integer                          :: is2, ie2, js2, je2
1595     integer                          :: is3, ie3, js3, je3
1596     integer                          :: isd3, ied3, jsd3, jed3
1597     integer                          :: isd2, ied2, jsd2, jed2
1598     logical                          :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
1599     type(overlap_type)               :: overlap
1600     type(overlap_type),  pointer     :: overlapList(:)=>NULL()
1601     type(overlap_type),  pointer     :: checkList(:)=>NULL()
1602     integer                          :: nsend, nrecv
1603     integer                          :: nsend_check, nrecv_check
1604     integer                          :: unit
1605     logical                          :: set_check
1606
1607     !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
1608     !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
1609     !--- In this case the overlapping exist only for tMe=1 and tNbr=1
1610     if(size(domain%x(:)) > 1) return
1611
1612     !--- if there is no halo, no need to compute overlaps.
1613     if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0) return
1614
1615     !--- when there is only one tile, n will equal to np
1616     nlist = size(domain%list(:))
1617     set_check = .false.
1618     if(ASSOCIATED(check)) set_check = .true.
1619     allocate(overlapList(MAXLIST) )
1620     if(set_check) allocate(checkList(MAXLIST)   )
1621
1622     !--- overlap is used to store the overlapping temporarily.
1623     call allocate_update_overlap( overlap, MAXOVERLAP)
1624     !send
1625     call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
1626     call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
1627     call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
1628
1629     update%xbegin = ism; update%xend = iem
1630     update%ybegin = jsm; update%yend = jem
1631     if(set_check) then
1632        check%xbegin  = ism; check%xend  = iem
1633        check%ybegin  = jsm; check%yend  = jem
1634     endif
1635     update%whalo  = whalo; update%ehalo = ehalo
1636     update%shalo  = shalo; update%nhalo = nhalo
1637
1638     ioff = ni - ishift
1639     joff = nj - jshift
1640     middle = (isg+ieg)/2+1
1641     tMe = 1; tNbr = 1
1642     folded_north = BTEST(domain%fold,NORTH)
1643     if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,EAST) .OR. BTEST(domain%fold,WEST) ) then
1644        call mpp_error(FATAL,"mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition "&
1645             &//"is not supported, please use other version of compute_overlaps for "//trim(domain%name))
1646     endif
1647
1648     nsend = 0
1649     nsend_check = 0
1650
1651     do list = 0,nlist-1
1652        m = mod( domain%pos+list, nlist )
1653        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
1654           !to_pe's eastern halo
1655           dir = 1
1656           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
1657           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
1658           !--- to make sure the consistence between pes
1659           if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
1660                .AND. ( jsc == je .or. jec == js ) ) then
1661              !--- do nothing, this point will come from other pe
1662           else
1663              !--- when the north face is folded, the east halo point at right side domain will be folded.
1664              !--- the position should be on CORNER or NORTH
1665              if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
1666                 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1667                                     isg, ieg, dir, ishift, position, ioff, middle)
1668              else
1669                 if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1670                    call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1671                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1672                 else
1673                    if( ie.GT.ieg ) then
1674                       if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
1675                          is = is-ioff; ie = ie-ioff
1676                          call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1677                       end if
1678                    end if
1679                    call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1680                         isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1681                 endif
1682              endif
1683           end if
1684
1685           !to_pe's SE halo
1686           dir = 2
1687           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
1688           js = domain%list(m)%y(tNbr)%compute%begin-shalo;  je = domain%list(m)%y(tNbr)%compute%begin-1
1689           need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1690           !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
1691           !--- the other part is both are zero.
1692           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1693           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1694              if(je .LT. jsg) then ! js .LT. jsg
1695                 if( domain%y(tMe)%cyclic ) then
1696                    js = js + joff; je = je + joff
1697                 endif
1698              else if(js .Lt. jsg) then ! split into two parts
1699                 if( domain%y(tMe)%cyclic ) then
1700                    js2 = js + joff; je2 = jsg-1+joff
1701                    js = jsg;
1702                 endif
1703              endif
1704              call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1705                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1706              if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1707                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1708           else
1709              if( ie.GT.ieg )then
1710                 if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
1711                    is = is-ioff; ie = ie-ioff
1712                    need_adjust_1 = .false.
1713                    if(jsg .GT. js) then
1714                       if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1715                          js = js+joff; je = je+joff
1716                          need_adjust_2 = .false.
1717                          if(x_cyclic_offset .NE. 0) then
1718                             call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1719                          else if(y_cyclic_offset .NE. 0) then
1720                             call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1721                          end if
1722                       end if
1723                    else
1724                       call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1725                       need_adjust_3 = .false.
1726                    end if
1727                 end if
1728              end if
1729              if( need_adjust_3 .AND. jsg.GT.js )then
1730                 if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1731                    js = js+joff; je = je+joff
1732                    if(need_adjust_1 .AND. ie.LE.ieg) then
1733                       call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1734                    end if
1735                 end if
1736              end if
1737              call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1738           endif
1739
1740           !to_pe's southern halo
1741           dir = 3
1742           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
1743           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
1744           js2 = 0; je2 = -1
1745           if( jsg.GT.je )then ! jsg .GT. js
1746              if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1747                 js = js+joff; je = je+joff
1748                 call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1749              end if
1750           else if (jsg .GT. js) then ! split into two parts
1751              if( domain%y(tMe)%cyclic) then
1752                 js2 = js + joff; je2 = jsg-1+joff
1753                 js = jsg
1754              endif
1755           end if
1756
1757           call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1758                                     isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1759           if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1760                                     isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1761
1762           !to_pe's SW halo
1763           dir = 4
1764           is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
1765           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
1766           need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1767           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1768           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1769              if(je .LT. jsg) then ! js .LT. jsg
1770                 if( domain%y(tMe)%cyclic ) then
1771                    js = js + joff; je = je + joff
1772                 endif
1773              else if(js .Lt. jsg) then ! split into two parts
1774                 if( domain%y(tMe)%cyclic ) then
1775                    js2 = js + joff; je2 = jsg-1+joff
1776                    js = jsg;
1777                 endif
1778              endif
1779              call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1780                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1781              if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1782                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1783           else
1784              if( isg.GT.is )then
1785                 if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1786                    is = is+ioff; ie = ie+ioff
1787                    need_adjust_1 = .false.
1788                    if(jsg .GT. js) then
1789                       if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1790                          js = js+joff; je = je+joff
1791                          need_adjust_2 = .false.
1792                          if(x_cyclic_offset .NE. 0) then
1793                             call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1794                          else if(y_cyclic_offset .NE. 0) then
1795                             call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1796                          end if
1797                       end if
1798                    else
1799                       call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1800                       need_adjust_3 = .false.
1801                    end if
1802                 end if
1803              end if
1804              if( need_adjust_3 .AND. jsg.GT.js )then
1805                 if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1806                    js = js+joff; je = je+joff
1807                    if(need_adjust_1 .AND. isg.LE.is  )then
1808                       call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1809                    end if
1810                 end if
1811              end if
1812              call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1813           endif
1814
1815           !to_pe's western halo
1816           dir = 5
1817           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
1818           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
1819
1820           !--- when the north face is folded, some point at j=nj will be folded.
1821           !--- the position should be on CORNER or NORTH
1822           if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1823              call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1824                                     isg, ieg, dir, ishift, position, ioff, middle)
1825           else
1826              if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1827                 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1828                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1829              else
1830                 if( isg.GT.is )then
1831                    if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1832                       is = is+ioff; ie = ie+ioff
1833                       call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1834                    endif
1835                 end if
1836                 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1837                      isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1838              end if
1839           end if
1840
1841           !to_pe's NW halo
1842           dir = 6
1843           is = domain%list(m)%x(tNbr)%compute%begin-whalo;  ie = domain%list(m)%x(tNbr)%compute%begin-1
1844           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
1845           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1846           is3 = 0; ie3 = -1; js3 = 0; je3 = -1
1847           folded = .FALSE.
1848           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1849              if(js .GT. jeg) then ! je > jeg
1850                 if( domain%y(tMe)%cyclic ) then
1851                    js = js-joff; je = je-joff
1852                 else if(folded_north )then
1853                    folded = .TRUE.
1854                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1855                 endif
1856              else if(je .GT. jeg) then ! split into two parts
1857                 if( domain%y(tMe)%cyclic ) then
1858                    is2 = is; ie2 = ie; js2 = js; je2 = jeg
1859                    js = jeg+1-joff; je = je -joff
1860                 else if(folded_north) then
1861                    folded = .TRUE.
1862                    is2 = is; ie2 = ie; js2 = js; je2 = jeg
1863                    js  = jeg+1
1864                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1865                    if( is .GT. ieg) then
1866                      is = is - ioff; ie = ie - ioff
1867                    else if( ie .GT. ieg ) then
1868                      is3 = is; ie3 = ieg; js3 = js; je3 = je
1869                      is = ieg+1-ioff; ie = ie - ioff
1870                    endif
1871                 endif
1872              endif
1873
1874              if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1875                 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1876                                     isg, ieg, dir, ishift, position, ioff, middle)
1877              else
1878                 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1879                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
1880              endif
1881              if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
1882                                     isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
1883              if(ie2 .GE. is2) then
1884                 if(je2 == jeg .AND. jec == jeg .AND. folded_north.AND.(position == CORNER .OR. position == NORTH))then
1885                    call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1886                                     isg, ieg, dir, ishift, position, ioff, middle)
1887                 else
1888                    call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1889                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1890                 endif
1891              endif
1892           else
1893              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1894              if( isg.GT.is )then
1895                 if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1896                    is = is+ioff; ie = ie+ioff
1897                    need_adjust_1 = .false.
1898                    if(je .GT. jeg) then
1899                       if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1900                          js = js-joff; je = je-joff
1901                          need_adjust_2 = .false.
1902                          if(x_cyclic_offset .NE. 0) then
1903                             call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1904                          else if(y_cyclic_offset .NE. 0) then
1905                             call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1906                          end if
1907                       end if
1908                    else
1909                       call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1910                       need_adjust_3 = .false.
1911                    end if
1912                 end if
1913              end if
1914              folded = .FALSE.
1915              if( need_adjust_3 .AND. je.GT.jeg )then
1916                 if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1917                    js = js-joff; je = je-joff
1918                    if( need_adjust_1  .AND. isg.LE.is)then
1919                       call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1920                    end if
1921                 else if( folded_north )then
1922                    folded = .TRUE.
1923                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1924                 end if
1925              end if
1926              call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1927                   isg, ieg, jsg, jeg, dir)
1928           endif
1929
1930
1931           !to_pe's northern halo
1932           dir = 7
1933           folded = .FALSE.
1934           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
1935           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
1936
1937           !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
1938           !--- no need to send, because the data on that point will come from other pe.
1939           !--- come from two pe ( there will be only one point on one pe. ).
1940           if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
1941                .AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) ) then
1942              !--- do nothing, this point will come from other pe
1943           else
1944              js2 = -1; je2 = 0
1945              if( js .GT. jeg) then ! je .GT. jeg
1946                 if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1947                    js = js-joff; je = je-joff
1948                    call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1949                 else if( folded_north )then
1950                    folded = .TRUE.
1951                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1952                 end if
1953              else if( je.GT.jeg )then ! split into two parts
1954                 if( domain%y(tMe)%cyclic)then !try cyclic offset
1955                    is2 = is; ie2 = ie; js2 = js;         je2 = jeg
1956                    js = jeg+1-joff; je = je - joff
1957                 else if( folded_north )then
1958                    folded = .TRUE.
1959                    is2 = is; ie2 = ie; js2 = js; je2 = jeg
1960                    js  = jeg+1;
1961                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1962                 end if
1963              end if
1964              if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1965                 if( je == jeg .AND. jec == jeg .AND. folded_north .AND.(position == CORNER .OR. position == NORTH))then
1966                    call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1967                         isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1968                 else
1969                    call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1970                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, domain%symmetry)
1971                 endif
1972              else
1973                 call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1974                   isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1975              endif
1976
1977              if(ie2 .GE. is2) then
1978                 if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == CORNER .OR. position == NORTH))then
1979                    call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1980                                     isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1981                 else
1982                    call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1983                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1984                 endif
1985              endif
1986           end if
1987
1988           !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
1989           if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
1990 !             is = is + ioff
1991 !             call insert_update_overlap( overlap, domain%list(m)%pe, &
1992 !                                         is, is, js, je, isc, iec, jsc, jec, dir, folded)
1993 !???             if(je2 .GE. js2)call insert_update_overlap( overlap, domain%list(m)%pe, &
1994 !                                         is, is, js2, je2, isc, iec, jsc, jec, dir, folded)
1995           endif
1996
1997           !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
1998           !--- for folded-north-edge, only need to consider to_pe's north(7) direction
1999           !--- only position at NORTH and CORNER need to be considered
2000           if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
2001               .AND. domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 ) then
2002              if( domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .GE. jeg .AND. isc .LE. middle)then
2003                 js = jeg; je = jeg
2004                 is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
2005                 is = max(is, middle)
2006                 select case (position)
2007                 case(NORTH)
2008                    i=is; is = isg+ieg-ie; ie = isg+ieg-i
2009                 case(CORNER)
2010                    i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2011                 end select
2012                 call insert_update_overlap(overlap, domain%list(m)%pe, &
2013                      is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
2014              endif
2015              if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2016                 je = domain%list(m)%y(tNbr)%compute%end+jshift;
2017                 if(je == jeg) then
2018                    is = max(is, isc); ie = min(ie, iec)
2019                    js = max(js, jsc); je = min(je, jec)
2020                    if(ie.GE.is .AND. je.GE.js )then
2021                       nsend_check = nsend_check+1
2022                       if(nsend_check > size(checkList(:)) ) then
2023                          call expand_check_overlap_list(checkList, nlist)
2024                       endif
2025                       call allocate_check_overlap(checkList(nsend_check), 1)
2026                       call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
2027                            tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
2028                    end if
2029                 end if
2030              endif
2031           endif
2032
2033           !to_pe's NE halo
2034           dir = 8
2035           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
2036           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
2037           is2 = 0; ie2=-1; js2=0; je2=-1
2038           is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2039           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2040              folded = .FALSE.
2041              if(js .GT. jeg) then ! je > jeg
2042                 if( domain%y(tMe)%cyclic ) then
2043                    js = js-joff; je = je-joff
2044                 else if(folded_north )then
2045                    folded = .TRUE.
2046                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2047                 endif
2048              else if(je .GT. jeg) then ! split into two parts
2049                 if( domain%y(tMe)%cyclic ) then
2050                    is2 = is; ie2 = ie; js2 = js; je2 = jeg
2051                    js = jeg+1-joff; je = je -joff
2052                 else if(folded_north) then
2053                    folded = .TRUE.
2054                    is2 = is; ie2 = ie; js2 = js; je2 = jeg
2055                    js  = jeg+1
2056                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2057
2058                    if( ie .LT. isg )then
2059                       is = is+ioff; ie = ie+ioff
2060                    else if( is .LT. isg) then
2061                       is3 = isg; ie3 = ie; js3 = js; je3 = je
2062                       is = is+ioff; ie = isg-1+ioff;
2063                    endif
2064                 endif
2065              endif
2066              if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
2067                 call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2068                      isg, ieg, dir, ishift, position, ioff, middle)
2069              else
2070                 call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2071                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2072              endif
2073              if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
2074                                     isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2075              if(ie2 .GE. is2) then
2076                 if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == CORNER .OR. position == NORTH))then
2077                    call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2078                                     isg, ieg, dir, ishift, position, ioff, middle)
2079                 else
2080                    call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2081                                     isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2082                 endif
2083              endif
2084           else
2085              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2086              if( ie.GT.ieg )then
2087                 if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
2088                    is = is-ioff; ie = ie-ioff
2089                    need_adjust_1 = .false.
2090                    if(je .GT. jeg) then
2091                       if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
2092                          js = js-joff; je = je-joff
2093                          need_adjust_2 = .false.
2094                          if(x_cyclic_offset .NE. 0) then
2095                             call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2096                          else if(y_cyclic_offset .NE. 0) then
2097                             call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2098                          end if
2099                       end if
2100                    else
2101                       call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2102                       need_adjust_3 = .false.
2103                    end if
2104                 end if
2105              end if
2106              folded = .false.
2107              if( need_adjust_3 .AND. je.GT.jeg )then
2108                 if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
2109                    js = js-joff; je = je-joff
2110                    if( need_adjust_1 .AND. ie.LE.ieg)then
2111                       call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2112                    end if
2113                 else if( folded_north )then
2114                    folded = .TRUE.
2115                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2116                 end if
2117              end if
2118              call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2119                   isg, ieg, jsg, jeg, dir)
2120           endif
2121        endif
2122
2123        !--- copy the overlapping information
2124        if( overlap%count > 0) then
2125          nsend = nsend + 1
2126          if(nsend > size(overlapList(:)) ) then
2127             call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for send is expanded')
2128             call expand_update_overlap_list(overlapList, nlist)
2129          endif
2130          call add_update_overlap( overlapList(nsend), overlap)
2131          call init_overlap_type(overlap)
2132        endif
2133     end do  ! end of send set up.
2134
2135     if(debug_message_passing) then
2136        !--- write out send information
2137        unit = mpp_pe() + 1000
2138        do m =1,nsend
2139           write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
2140           do n = 1, overlapList(m)%count
2141              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
2142                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
2143           enddo
2144        enddo
2145        if(nsend >0) flush(unit)
2146     endif
2147
2148     ! copy the overlapping information into domain data structure
2149     if(nsend>0) then
2150        allocate(update%send(nsend))
2151        update%nsend = nsend
2152        do m = 1, nsend
2153           call add_update_overlap( update%send(m), overlapList(m) )
2154        enddo
2155     endif
2156
2157     if(nsend_check>0) then
2158        check%nsend = nsend_check
2159        allocate(check%send(nsend_check))
2160        do m = 1, nsend_check
2161           call add_check_overlap( check%send(m), checkList(m) )
2162        enddo
2163     endif
2164
2165     do m = 1,size(overlapList(:))
2166        call deallocate_overlap_type(overlapList(m))
2167     enddo
2168
2169     if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2170        do m = 1,size(checkList(:))
2171           call deallocate_overlap_type(checkList(m))
2172        enddo
2173     endif
2174
2175     isgd = isg - domain%whalo
2176     iegd = ieg + domain%ehalo
2177     jsgd = jsg - domain%shalo
2178     jegd = jeg + domain%nhalo
2179
2180     ! begin setting up recv
2181     nrecv = 0
2182     nrecv_check = 0
2183     do list = 0,nlist-1
2184        m = mod( domain%pos+nlist-list, nlist )
2185        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
2186           isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
2187           jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
2188           !recv_e
2189           dir = 1
2190           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2191           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
2192           is=isc; ie=iec; js=jsc; je=jec
2193           if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
2194                .AND. ( jsd == je .or. jed == js ) ) then
2195              ! --- do nothing, this point will come from other pe
2196           else
2197              !--- when the north face is folded, the east halo point at right side domain will be folded.
2198              !--- the position should be on CORNER or NORTH
2199              if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2200                 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2201                      isg, ieg, dir, ishift, position, ioff, middle)
2202              else
2203                 if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2204                    call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2205                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2206                 else
2207                    if( ied.GT.ieg )then
2208                       if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2209                          is = is+ioff; ie = ie+ioff
2210                          call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2211                       end if
2212                    end if
2213                    call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2214                       isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2215                 endif
2216              endif
2217           endif
2218
2219           !recv_se
2220           dir = 2
2221           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2222           jsd = domain%y(tMe)%compute%begin-shalo;    jed = domain%y(tMe)%compute%begin-1
2223           is=isc; ie=iec; js=jsc; je=jec
2224           !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
2225           !--- the other part is both are zero.
2226           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2227           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2228              if(jed .LT. jsg) then ! then jsd < jsg
2229                 if( domain%y(tMe)%cyclic ) then
2230                    js = js-joff; je = je-joff
2231                 endif
2232              else if(jsd .LT. jsg) then !split into two parts
2233                 if( domain%y(tMe)%cyclic ) then
2234                    js2 = js-joff; je2 = je-joff
2235                 endif
2236              endif
2237              call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2238                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2239              if(je2 .GE. js2) call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2240                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2241           else
2242              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2243              if( jsd.LT.jsg )then
2244                 if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
2245                    js = js-joff; je = je-joff
2246                    need_adjust_1 = .false.
2247                    if( ied.GT.ieg )then
2248                       if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2249                          is = is+ioff; ie = ie+ioff
2250                          need_adjust_2 = .false.
2251                          if(x_cyclic_offset .NE. 0) then
2252                             call apply_cyclic_offset(js, je, x_cyclic_offset, jsgd, jeg, nj)
2253                          else if(y_cyclic_offset .NE. 0) then
2254                             call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, iegd, ni)
2255                          end if
2256                       end if
2257                    else
2258                       call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2259                       need_adjust_3 = .false.
2260                    end if
2261                 end if
2262              end if
2263              if( need_adjust_3 .AND. ied.GT.ieg )then
2264                 if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2265                    is = is+ioff; ie = ie+ioff
2266                    if( need_adjust_1 .AND. jsd.GE.jsg )then
2267                       call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2268                    end if
2269                 end if
2270              end if
2271              call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2272                  isg, ieg, jsg, jeg, dir)
2273           endif
2274
2275           !recv_s
2276           dir = 3
2277           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
2278           jsd = domain%y(tMe)%compute%begin-shalo;    jed = domain%y(tMe)%compute%begin-1
2279           is=isc; ie=iec; js=jsc; je=jec
2280           js2 = 0; je2 = -1
2281           if( jed .LT. jsg) then ! jsd < jsg
2282              if( domain%y(tMe)%cyclic ) then
2283                 js = js-joff; je = je-joff
2284                 call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2285              endif
2286           else if( jsd.LT.jsg )then ! split into two parts
2287              if( domain%y(tMe)%cyclic)then !try cyclic offset
2288                 js2 = js-joff; je2 = je-joff
2289              end if
2290           end if
2291           call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2292                isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2293           if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2294                isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2295
2296           !recv_sw
2297           dir = 4
2298           isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
2299           jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
2300           is=isc; ie=iec; js=jsc; je=jec
2301           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2302           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2303              if( ied.LT.isg )then ! isd < isg
2304                 if( domain%x(tMe)%cyclic ) then
2305                    is = is-ioff; ie = ie-ioff
2306                 endif
2307              else if (isd.LT.isg )then ! split into two parts
2308                 if( domain%x(tMe)%cyclic ) then
2309                    is2 = is-ioff; ie2 = ie-ioff
2310                 endif
2311              endif
2312              if( jed.LT.jsg )then  ! jsd < jsg
2313                 if( domain%y(tMe)%cyclic ) then
2314                    js = js-joff; je = je-joff
2315                 endif
2316              else if( jsd.LT.jsg )then ! split into two parts
2317                 if( domain%y(tMe)%cyclic ) then
2318                    js2 = js-joff; je2 = je-joff
2319                 endif
2320              endif
2321           else
2322              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2323              if( jsd.LT.jsg )then
2324                 if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
2325                    js = js-joff; je = je-joff
2326                    need_adjust_1 = .false.
2327                    if( isd.LT.isg )then
2328                       if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2329                          is = is-ioff; ie = ie-ioff
2330                          need_adjust_2 = .false.
2331                          if(x_cyclic_offset .NE. 0) then
2332                             call apply_cyclic_offset(js, je, -x_cyclic_offset, jsgd, jeg, nj)
2333                          else if(y_cyclic_offset .NE. 0) then
2334                             call apply_cyclic_offset(is, ie, -y_cyclic_offset, isgd, ieg, ni)
2335                          end if
2336                       end if
2337                    else
2338                       call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2339                       need_adjust_3 = .false.
2340                    end if
2341                 end if
2342              end if
2343              if( need_adjust_3 .AND. isd.LT.isg )then
2344                 if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2345                    is = is-ioff; ie = ie-ioff
2346                    if(need_adjust_1 .AND. jsd.GE.jsg) then
2347                       call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2348                    end if
2349                 end if
2350              end if
2351           endif
2352           call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2353                isg, ieg, jsg, jeg, dir)
2354
2355           if(ie2 .GE. is2)call fill_overlap(overlap, domain, m, is2, ie2, js, je, isd, ied, jsd, jed, &
2356                isg, ieg, jsg, jeg, dir)
2357           if(je2 .GE. js2)call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2358                isg, ieg, jsg, jeg, dir)
2359
2360           if(ie2 .GE. is2 .AND. je2 .GE. js2)call fill_overlap(overlap, domain, m, is2, ie2, js2, je2, isd, ied, jsd, &
2361                & jed, isg, ieg, jsg, jeg, dir)
2362
2363
2364           !recv_w
2365           dir = 5
2366           isd = domain%x(tMe)%compute%begin-whalo;    ied = domain%x(tMe)%compute%begin-1
2367           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
2368           is=isc; ie=iec; js=jsc; je=jec
2369
2370           !--- when the north face is folded, some point at j=nj will be folded.
2371           !--- the position should be on CORNER or NORTH
2372           if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2373              call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2374                   isg, ieg, dir, ishift, position, ioff, middle)
2375           else
2376              if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2377                 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2378                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
2379              else
2380                 if( isd.LT.isg )then
2381                    if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2382                       is = is-ioff; ie = ie-ioff
2383                       call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2384                    end if
2385                 end if
2386                 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2387                      isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2388              endif
2389           endif
2390
2391           !recv_nw
2392           dir = 6
2393           folded = .false.
2394           isd = domain%x(tMe)%compute%begin-whalo;    ied = domain%x(tMe)%compute%begin-1
2395           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2396           is=isc; ie=iec; js=jsc; je=jec
2397           is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2398           is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2399           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2400              js2 = -1; je2 = 0
2401              if( jsd .GT. jeg ) then ! jed > jeg
2402                 if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2403                    js = js+joff; je = je+joff
2404                    call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2405                 else if( folded_north )then
2406                    folded = .TRUE.
2407                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2408                 end if
2409              else if( jed.GT.jeg )then ! split into two parts
2410                 if( domain%y(tMe)%cyclic)then !try cyclic offset
2411                    is2 = is; ie2 = ie; js2 = js; je2 = je
2412                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2413                    js = js + joff; je = je + joff
2414                    jsd = jeg+1
2415                 else if( folded_north )then
2416                    folded = .TRUE.
2417                    is2 = is; ie2 = ie; js2 = js; je2 = je
2418                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2419                    jsd = jeg+1
2420                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2421                    if(isd < isg .and. ied .GE. isg .and. domain%symmetry) then
2422                       isd3 = isd; ied3 = isg-1
2423                       jsd3 = jsd; jed3 = jed
2424                       is3 = is-ioff; ie3=ie-ioff
2425                       js3 = js; je3 = je
2426                       isd = isg;
2427                    endif
2428                 end if
2429              endif
2430
2431              if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2432                   .AND. (position == CORNER .OR. position == NORTH)) then
2433                 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2434                      isg, ieg, dir, ishift, position, ioff, middle)
2435              else
2436                 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2437                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2438              endif
2439
2440              if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2441                      & jed3, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2442
2443              if(ie2 .GE. is2) then
2444                 if( jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2445                     .AND. (position == CORNER .OR. position == NORTH)) then
2446                    call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2447                         isg, ieg, dir, ishift, position, ioff, middle)
2448                 else
2449                    call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2450                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2451                 endif
2452              endif
2453           else
2454              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2455              if( jed.GT.jeg )then
2456                 if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2457                    js = js+joff; je = je+joff
2458                    need_adjust_1 = .false.
2459                    if( isd.LT.isg )then
2460                       if( domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
2461                          is = is-ioff; ie = ie-ioff
2462                          need_adjust_2 = .false.
2463                          if(x_cyclic_offset .NE. 0) then
2464                             call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jegd, nj)
2465                          else if(y_cyclic_offset .NE. 0) then
2466                             call apply_cyclic_offset(is, ie, y_cyclic_offset, isgd, ieg, ni)
2467                          end if
2468                       end if
2469                    else
2470                       call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2471                       need_adjust_3 = .false.
2472                    end if
2473                 else if( folded_north )then
2474                    folded = .TRUE.
2475                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2476                 end if
2477              end if
2478              if( need_adjust_3 .AND. isd.LT.isg )then
2479                 if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
2480                    is = is-ioff; ie = ie-ioff
2481                    if( need_adjust_1 .AND. jed.LE.jeg )then
2482                       call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2483                    end if
2484                 end if
2485              end if
2486              call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2487                   isg, ieg, jsg, jeg, dir)
2488           endif
2489
2490           !--- when north edge is folded, is will be less than isg when position is EAST and CORNER
2491           if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
2492              is = is + ioff
2493              call insert_update_overlap(overlap, domain%list(m)%pe, &
2494                                         is, is, js, je, isd, ied, jsd, jed, dir, folded )
2495           endif
2496
2497           !recv_n
2498           dir = 7
2499           folded = .false.
2500           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
2501           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2502           is=isc; ie=iec; js=jsc; je=jec
2503
2504           !--- when domain symmetry and position is EAST or CORNER, the point at i=isd will
2505           !--- come from two pe ( there will be only one point on one pe. ).
2506           if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
2507                .AND. (isd == ie .or. ied == is ) .AND. (.not. folded_north) ) then
2508              !--- do nothing, this point will come from other pe
2509           else
2510              js2 = -1; je2 = 0
2511              if( jsd .GT. jeg ) then ! jed > jeg
2512                 if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2513                    js = js+joff; je = je+joff
2514                    call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2515                 else if( folded_north )then
2516                    folded = .TRUE.
2517                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2518                 end if
2519              else if( jed.GT.jeg )then ! split into two parts
2520                 if( domain%y(tMe)%cyclic)then !try cyclic offset
2521                    is2 = is; ie2 = ie; js2 = js; je2 = je
2522                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2523                    js = js + joff; je = je + joff
2524                    jsd = jeg+1
2525                 else if( folded_north )then
2526                    folded = .TRUE.
2527                    is2 = is; ie2 = ie; js2 = js; je2 = je
2528                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2529                    jsd = jeg+1
2530                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2531                 end if
2532              end if
2533              if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0) then
2534                 if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2535                      .AND. (position == CORNER .OR. position == NORTH)) then
2536                    call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2537                         isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2538                 else
2539                    call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2540                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
2541                 endif
2542              else
2543                 call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2544                      isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2545              endif
2546              if(ie2 .GE. is2) then
2547                 if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2548                    .AND. (position == CORNER .OR. position == NORTH)) then
2549                    call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2550                         isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2551                 else
2552                    call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2553                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
2554                 endif
2555              endif
2556           endif
2557
2558           !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
2559           if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
2560 !             is = is + ioff
2561 !             call insert_update_overlap( overlap, domain%list(m)%pe, &
2562 !                  is, is, js, je, isd, ied, jsd, jed, dir, folded)
2563           endif
2564
2565           !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
2566           !--- for folded-north-edge, only need to consider to_pe's north(7) direction
2567           !--- only position at NORTH and CORNER need to be considered
2568
2569           if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
2570                .AND. domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2) then
2571              if( jed .GE. jeg .AND. ied .GE. middle)then
2572                 jsd = jeg; jed = jeg
2573                 is=isc; ie=iec; js = jsc; je = jec
2574                 isd = max(isd, middle)
2575                 select case (position)
2576                 case(NORTH)
2577                    i=is; is = isg+ieg-ie; ie = isg+ieg-i
2578                 case(CORNER)
2579                    i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2580                 end select
2581                 call insert_update_overlap(overlap, domain%list(m)%pe, &
2582                      is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
2583              endif
2584              if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2585                 jsd = domain%y(tMe)%compute%end+jshift;   jed = jsd
2586                 if(jed == jeg) then
2587                    is = max(is, isd); ie = min(ie, ied)
2588                    js = max(js, jsd); je = min(je, jed)
2589                    if(ie.GE.is .AND. je.GE.js )then
2590                       nrecv_check = nrecv_check+1
2591                       if(nrecv_check > size(checkList(:)) ) then
2592                          call expand_check_overlap_list(checkList, nlist)
2593                       endif
2594                       call allocate_check_overlap(checkList(nrecv_check), 1)
2595                       call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
2596                            tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
2597                    end if
2598                 end if
2599              endif
2600
2601           endif
2602
2603           !recv_ne
2604           dir = 8
2605           folded = .false.
2606           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2607           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2608           is=isc; ie=iec; js=jsc; je=jec
2609           is2 = 0; ie2=-1; js2=0; je2=-1
2610           is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2611           if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2612              js2 = -1; je2 = 0
2613              if( jsd .GT. jeg ) then ! jed > jeg
2614                 if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2615                    js = js+joff; je = je+joff
2616                    call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2617                 else if( folded_north )then
2618                    folded = .TRUE.
2619                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2620                 end if
2621              else if( jed.GT.jeg )then ! split into two parts
2622                 if( domain%y(tMe)%cyclic)then !try cyclic offset
2623                    is2 = is; ie2 = ie; js2 = js; je2 = je
2624                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2625                    js = js + joff; je = je + joff
2626                    jsd = jeg+1
2627                 else if( folded_north )then
2628                    folded = .TRUE.
2629                    is2 = is; ie2 = ie; js2 = js; je2 = je
2630                    isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2631                    jsd = jeg+1
2632                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2633                    if(ied > ieg .and. isd .LE. ieg .and. domain%symmetry) then
2634                       isd3 = ieg+1; ied3 = ied
2635                       jsd3 = jsd; jed3 = jed
2636                       is3 = is+ioff; ie3=ie+ioff
2637                       js3 = js; je3 = je
2638                       ied = ieg;
2639                    endif
2640                 end if
2641              endif
2642              if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2643                   .AND. (position == CORNER .OR. position == NORTH)) then
2644                 call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2645                      isg, ieg, dir, ishift, position, ioff, middle)
2646              else
2647                 call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2648                      isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2649              endif
2650              if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2651                      & jed3, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2652              if(ie2 .GE. is2) then
2653                 if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2654                      .AND. (position == CORNER .OR. position == NORTH)) then
2655                    call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2656                         isg, ieg, dir, ishift, position, ioff, middle)
2657                 else
2658                    call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2659                         isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2660                 endif
2661              endif
2662           else
2663              need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2664              if( jed.GT.jeg )then
2665                 if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2666                    js = js+joff; je = je+joff
2667                    need_adjust_1 = .false.
2668                    if( ied.GT.ieg )then
2669                       if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2670                          is = is+ioff; ie = ie+ioff
2671                          need_adjust_2 = .false.
2672                          if(x_cyclic_offset .NE. 0) then
2673                             call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jegd, nj)
2674                          else if(y_cyclic_offset .NE. 0) then
2675                             call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, iegd, ni)
2676                          end if
2677                       end if
2678                    else
2679                       call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2680                       need_adjust_3 = .false.
2681                    end if
2682                 else if( folded_north )then
2683                    folded = .TRUE.
2684                    call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2685                 end if
2686              end if
2687              if(  need_adjust_3 .AND. ied.GT.ieg )then
2688                 if(  need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2689                    is = is+ioff; ie = ie+ioff
2690                    if( need_adjust_1 .AND. jed.LE.jeg)then
2691                       call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2692                    end if
2693                 end if
2694              end if
2695              call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2696                   isg, ieg, jsg, jeg, dir)
2697           endif
2698        endif
2699
2700        !--- copy the overlapping information
2701        if( overlap%count > 0) then
2702           nrecv = nrecv + 1
2703           if(nrecv > size(overlapList(:)) )then
2704             call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for recv is expanded')
2705             call expand_update_overlap_list(overlapList, nlist)
2706           endif
2707           call add_update_overlap( overlapList(nrecv), overlap)
2708           call init_overlap_type(overlap)
2709        endif
2710     enddo ! end of recv do loop
2711
2712     if(debug_message_passing) then
2713        !--- write out send information
2714        unit = mpp_pe() + 1000
2715        do m =1,nrecv
2716           write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
2717           do n = 1, overlapList(m)%count
2718              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
2719                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
2720           enddo
2721        enddo
2722        if(nrecv >0) flush(unit)
2723     endif
2724
2725     ! copy the overlapping information into domain
2726     if(nrecv>0) then
2727        allocate(update%recv(nrecv))
2728        update%nrecv = nrecv
2729        do m = 1, nrecv
2730           call add_update_overlap( update%recv(m), overlapList(m) )
2731           do n = 1, update%recv(m)%count
2732              if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
2733                 if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
2734                 if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
2735              endif
2736           enddo
2737        enddo
2738     endif
2739
2740     if(nrecv_check>0) then
2741        check%nrecv = nrecv_check
2742        allocate(check%recv(nrecv_check))
2743        do m = 1, nrecv_check
2744           call add_check_overlap( check%recv(m), checkList(m) )
2745        enddo
2746     endif
2747
2748     call deallocate_overlap_type(overlap)
2749     do m = 1,size(overlapList(:))
2750        call deallocate_overlap_type(overlapList(m))
2751     enddo
2752
2753     if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2754        do m = 1,size(checkList(:))
2755           call deallocate_overlap_type(checkList(m))
2756        enddo
2757     endif
2758
2759     deallocate(overlapList)
2760     if(set_check) deallocate(checkList)
2761     domain%initialized = .true.
2762
2763   end subroutine compute_overlaps
2764
2765
2766   subroutine fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2767                                     isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2768     type(overlap_type), intent(inout) :: overlap
2769     type(domain2d),     intent(inout) :: domain
2770     integer,            intent(in   ) :: m, is, ie, js, je
2771     integer,            intent(in   ) :: isc, iec, jsc, jec
2772     integer,            intent(in   ) :: isg, ieg, dir, ioff
2773     logical,            intent(in   ) :: is_cyclic
2774     logical, optional,  intent(in   ) :: folded, symmetry
2775
2776     call insert_update_overlap( overlap, domain%list(m)%pe,              &
2777             is, ie, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2778     if(is_cyclic) then
2779        if(ie .GT. ieg) then
2780           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2781                is-ioff, ie-ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2782        else if( is .LT. isg ) then
2783           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2784                is+ioff, ie+ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2785        endif
2786     endif
2787
2788   end subroutine fill_overlap_send_nofold
2789   !##################################################################################
2790   subroutine fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2791                                     isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2792     type(overlap_type), intent(inout) :: overlap
2793     type(domain2d),     intent(inout) :: domain
2794     integer,            intent(in   ) :: m, is, ie, js, je
2795     integer,            intent(in   ) :: isc, iec, jsc, jec
2796     integer,            intent(in   ) :: isg, ieg, dir, ishift, position, ioff, middle
2797     logical, optional,  intent(in   ) :: symmetry
2798     integer                           :: is1, ie1, is2, ie2, i
2799
2800     !--- consider at j = jeg for west edge.
2801     !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2802     if(position == CORNER .AND. .NOT. domain%symmetry .AND. is .LE. isg-1 .AND. ie .GE. isg-1) then
2803        call insert_update_overlap(overlap, domain%list(m)%pe, &
2804             isg-1+ioff, isg-1+ioff, je, je, isc, iec, jsc, jec, dir, .true.)
2805     end if
2806
2807     is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2808     !--- east edge
2809     if( is > ieg ) then
2810        is2 = is-ioff; ie2 = ie-ioff
2811     else if( ie > ieg ) then ! split into two parts
2812        is1 = is; ie1 = ieg
2813        is2 = ieg+1-ioff; ie2 = ie-ioff
2814     else if( is .GE. middle ) then
2815        is1 = is; ie1 = ie
2816     else if( ie .GE. middle ) then ! split into two parts
2817        is1 = middle; ie1 = ie
2818        is2 = is;     ie2 = middle-1
2819     else if( ie < isg ) then ! west boundary
2820        is1 = is+ieg-isg+1-ishift; ie1 = ie+ieg-isg+1-ishift
2821     else if( is < isg ) then ! split into two parts
2822        is1 = is+ieg-isg+1-ishift; ie1 = isg-1+ieg-isg+1-ishift
2823        is2 = isg; ie2 = ie
2824     else
2825        is2 = is; ie2 = ie
2826     endif
2827
2828     if( ie1 .GE. is1) then
2829        call insert_update_overlap( overlap, domain%list(m)%pe,              &
2830             is1, ie1, js, je-1, isc, iec, jsc, jec, dir, symmetry=symmetry)
2831
2832        select case (position)
2833        case(NORTH)
2834           i=is1; is1 = isg+ieg-ie1; ie1 = isg+ieg-i
2835        case(CORNER)
2836           i=is1; is1 = isg+ieg-ie1-1+ishift; ie1 = isg+ieg-i-1+ishift
2837        end select
2838        call insert_update_overlap( overlap, domain%list(m)%pe, &
2839             is1, ie1, je, je, isc, iec, jsc, jec, dir, .true., symmetry=symmetry)
2840     endif
2841
2842     if(ie2 .GE. is2) then
2843        call insert_update_overlap( overlap, domain%list(m)%pe,              &
2844             is2, ie2, js, je, isc, iec, jsc, jec, dir)
2845     endif
2846
2847   end subroutine fill_overlap_send_fold
2848
2849
2850   !#############################################################################
2851   subroutine fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2852                                     isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2853     type(overlap_type), intent(inout) :: overlap
2854     type(domain2d),     intent(inout) :: domain
2855     integer,            intent(in   ) :: m, is, ie, js, je
2856     integer,            intent(in   ) :: isd, ied, jsd, jed
2857     integer,            intent(in   ) :: isg, ieg, dir, ioff
2858     logical,            intent(in   ) :: is_cyclic
2859     logical, optional,  intent(in   ) :: folded, symmetry
2860     integer                           :: is1, ie1, is2, ie2
2861     integer                           :: isd1, ied1, isd2, ied2
2862
2863     is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2864     isd1=isd; ied1=ied
2865     isd2=isd; ied2=ied
2866
2867     call insert_update_overlap( overlap, domain%list(m)%pe,              &
2868             is, ie, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2869     if(is_cyclic) then
2870        if(ied .GT. ieg) then
2871           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2872                is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2873        else if( isd .LT. isg ) then
2874           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2875                is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2876        else if ( is .LT. isg ) then
2877           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2878                is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2879        else if ( ie .GT. ieg ) then
2880           call insert_update_overlap( overlap, domain%list(m)%pe,              &
2881                is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2882        endif
2883     endif
2884
2885   end subroutine fill_overlap_recv_nofold
2886   !#################################################################################
2887   subroutine fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2888                                     isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2889     type(overlap_type), intent(inout) :: overlap
2890     type(domain2d),     intent(inout) :: domain
2891     integer,            intent(in   ) :: m, is, ie, js, je
2892     integer,            intent(in   ) :: isd, ied, jsd, jed
2893     integer,            intent(in   ) :: isg, ieg, dir, ishift, position, ioff, middle
2894     logical, optional,  intent(in   ) :: symmetry
2895     integer                           :: is1, ie1, is2, ie2, is3, ie3
2896     integer                           :: isd1, ied1, isd2, ied2
2897
2898     !--- consider at j = jeg for west edge.
2899     !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2900     if( position == CORNER .AND. .NOT. domain%symmetry .AND. isd .LE. isg-1 .AND. ied .GE. isg-1 ) then
2901        call insert_update_overlap( overlap, domain%list(m)%pe, &
2902             is-ioff, ie-ioff, js, je, isg-1, isg-1, jed, jed, dir, .true.)
2903     end if
2904
2905     is1 = 0;  ie1 = -1; is2 = 0;  ie2 = -1
2906     isd1=isd; ied1=ied
2907     isd2=isd; ied2=ied
2908     select case (position)
2909     case(NORTH)
2910        is3 = isg+ieg-ie; ie3 = isg+ieg-is
2911     case(CORNER)
2912        is3 = isg+ieg-ie-1+ishift; ie3 = isg+ieg-is-1+ishift
2913     end select
2914
2915     if(isd .GT. ieg) then ! east
2916        is2 = is + ioff; ie2 = ie + ioff;
2917     else if(ied .GT. ieg) then ! split into two parts
2918        is1 = is; ie1 = ie;
2919        isd1 = isd; ied1 = ieg;
2920        is2 = is + ioff; ie2 = ie + ioff
2921        isd2 = ieg + 1; ied2 = ied
2922     else if(isd .GE. middle) then
2923        is1 = is; ie1 = ie
2924     else if(ied .GE. middle) then ! split into two parts
2925        is1 = is; ie1 = ie
2926        isd1 = middle; ied1 = ied
2927        is2 = is; ie2 = ie
2928        isd2 = isd; ied2 = middle-1
2929     else if(ied .LT. isg) then
2930        is1 = is - ioff; ie1 = ie - ioff;
2931        is3 = is3 - ioff; ie3 = ie3 - ioff;
2932     else if(isd .LT. isg) then ! split into two parts
2933        is1 = is - ioff; ie1 = ie - ioff;
2934        is3 = is3 - ioff; ie3 = ie3 - ioff;
2935        isd1 = isd; ied1 = isg-1
2936        is2 = is;        ie2 = ie
2937        isd2 = isg;      ied2 = ied
2938    else
2939        is2 = is  ; ie2 =ie
2940        isd2 = isd; ied2 = ied
2941    endif
2942
2943    if( ie1 .GE. is1) then
2944       call insert_update_overlap( overlap, domain%list(m)%pe,              &
2945            is1, ie1, js, je, isd1, ied1, jsd, jed-1, dir, symmetry=symmetry)
2946
2947       call insert_update_overlap( overlap, domain%list(m)%pe, &
2948            is3, ie3, js, je, isd1, ied1, jed, jed, dir, .true., symmetry=symmetry)
2949    endif
2950
2951    if(ie2 .GE. is2) then
2952       call insert_update_overlap( overlap, domain%list(m)%pe,              &
2953            is2, ie2, js, je, isd2, ied2, jsd, jed, dir)
2954    endif
2955
2956   end subroutine fill_overlap_recv_fold
2957
2958 !#####################################################################################
2959   subroutine fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2960                                   isg, ieg, jsg, jeg, dir, reverse, symmetry)
2961     type(overlap_type), intent(inout) :: overlap
2962     type(domain2d),     intent(inout) :: domain
2963     integer,            intent(in   ) :: m, is, ie, js, je
2964     integer,            intent(in   ) :: isc, iec, jsc, jec
2965     integer,            intent(in   ) :: isg, ieg, jsg, jeg
2966     integer,            intent(in   ) :: dir
2967     logical, optional,  intent(in   ) :: reverse, symmetry
2968
2969     if(js > je) then ! seperate into two regions due to x_cyclic_offset is nonzero, the two region are
2970        ! (js, jeg) and (jsg, je).
2971        call insert_update_overlap( overlap, domain%list(m)%pe, &
2972             is, ie, jsg, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2973        call insert_update_overlap( overlap, domain%list(m)%pe, &
2974             is, ie, js, jeg, isc, iec, jsc, jec, dir, reverse, symmetry)
2975     else if(is > ie) then ! seperate into two regions due to y_cyclic_offset is nonzero, the two region are
2976        ! (is, ieg) and (isg, ie).
2977        call insert_update_overlap( overlap, domain%list(m)%pe, &
2978             is, ieg, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2979        call insert_update_overlap( overlap, domain%list(m)%pe, &
2980             isg, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2981     else
2982        call insert_update_overlap( overlap, domain%list(m)%pe, &
2983             is, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2984     end if
2985
2986
2987   end subroutine fill_overlap
2988
2989   !####################################################################################
2990   subroutine compute_overlaps_fold_south( domain, position, ishift, jshift)
2991     !computes remote domain overlaps
2992     !assumes only one in each direction
2993     !will calculate the overlapping for T,E,C,N-cell seperately.
2994     type(domain2D), intent(inout) :: domain
2995     integer, intent(in)           :: position, ishift, jshift
2996
2997     integer                          :: i, m, n, nlist, tMe, tNbr, dir
2998     integer                          :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
2999     integer                          :: isg, ieg, jsg, jeg, ioff, joff
3000     integer                          :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3001     integer                          :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3002     logical                          :: folded
3003     type(overlap_type)               :: overlap
3004     type(overlapSpec),   pointer     :: update=>NULL()
3005     type(overlap_type),  pointer     :: overlapList(:)=>NULL()
3006     type(overlap_type),  pointer     :: checkList(:)=>NULL()
3007     type(overlapSpec),   pointer     :: check =>NULL()
3008     integer                          :: nsend, nrecv
3009     integer                          :: nsend_check, nrecv_check
3010     integer                          :: unit
3011
3012     !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
3013     !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
3014     !--- In this case the overlapping exist only for tMe=1 and tNbr=1
3015     if(size(domain%x(:)) > 1) return
3016
3017     !--- if there is no halo, no need to compute overlaps.
3018     if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3019
3020     !--- when there is only one tile, n will equal to np
3021     nlist = size(domain%list(:))
3022
3023     select case(position)
3024     case (CENTER)
3025        update => domain%update_T
3026        check  => NULL()
3027     case (CORNER)
3028        update => domain%update_C
3029        check  => domain%check_C
3030     case (EAST)
3031        update => domain%update_E
3032        check  => domain%check_E
3033     case (NORTH)
3034        update => domain%update_N
3035        check  => domain%check_N
3036     case default
3037        call mpp_error(FATAL, &
3038         "mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, &
3039                                &  CORNER or NORTH")
3040     end select
3041
3042     allocate(overlapList(MAXLIST) )
3043     allocate(checkList(MAXLIST)   )
3044
3045     !--- overlap is used to store the overlapping temporarily.
3046     call allocate_update_overlap( overlap, MAXOVERLAP)
3047
3048     !send
3049     call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position  )
3050     call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position  ) !cyclic offsets
3051     call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3052     update%xbegin = ism; update%xend = iem
3053     update%ybegin = jsm; update%yend = jem
3054     if(ASSOCIATED(check)) then
3055        check%xbegin  = ism; check%xend  = iem
3056        check%ybegin  = jsm; check%yend  = jem
3057     endif
3058     update%whalo  = domain%whalo; update%ehalo = domain%ehalo
3059     update%shalo  = domain%shalo; update%nhalo = domain%nhalo
3060     whalo         = domain%whalo; ehalo        = domain%ehalo
3061     shalo         = domain%shalo; nhalo        = domain%nhalo
3062
3063
3064     ioff = ni - ishift
3065     joff = nj - jshift
3066     middle = (isg+ieg)/2+1
3067     tMe = 1; tNbr = 1
3068
3069     if(.NOT. BTEST(domain%fold,SOUTH)) then
3070        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3071             "boundary condition in y-direction should be folded-south for "//trim(domain%name))
3072     endif
3073     if(.NOT. domain%x(tMe)%cyclic) then
3074        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3075             "boundary condition in x-direction should be cyclic for "//trim(domain%name))
3076     endif
3077
3078     if(.not. domain%symmetry) then
3079        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3080             "when south boundary is folded, the domain must be symmetry for "//trim(domain%name))
3081     endif
3082
3083     nsend = 0
3084     nsend_check = 0
3085     do list = 0,nlist-1
3086        m = mod( domain%pos+list, nlist )
3087        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
3088           !to_pe's eastern halo
3089           dir = 1
3090           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3091           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3092           !--- to make sure the consistence between pes
3093           if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3094              !--- do nothing, this point will come from other pe
3095           else
3096              if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3097                 is = is-ioff; ie = ie-ioff
3098              end if
3099              !--- when the south face is folded, the east halo point at right side domain will be folded.
3100              !--- the position should be on CORNER or NORTH
3101              if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
3102                   .AND. is .GE. middle .AND. domain%list(m)%x(tNbr)%compute%end+ehalo+jshift .LE. ieg ) then
3103                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3104                                             is, ie, js+1, je, isc, iec, jsc, jec, dir)
3105                 is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3106                 je = js
3107                 select case (position)
3108                 case(NORTH)
3109                    i=is; is = isg+ieg-ie; ie = isg+ieg-i
3110                 case(CORNER)
3111                    i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3112                 end select
3113                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3114                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3115              else
3116                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3117                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3118              end if
3119           end if
3120
3121           !to_pe's SE halo
3122           dir = 2
3123           folded = .false.
3124           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3125           js = domain%list(m)%y(tNbr)%compute%begin-shalo;    je = domain%list(m)%y(tNbr)%compute%begin-1
3126           if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3127              is = is-ioff; ie = ie-ioff
3128           end if
3129           if( js.LT.jsg )then
3130              folded = .TRUE.
3131              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3132           end if
3133
3134           call insert_update_overlap( overlap, domain%list(m)%pe, &
3135                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3136
3137           !to_pe's southern halo
3138           dir = 3
3139           folded = .FALSE.
3140           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3141           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3142           folded = .FALSE.
3143           if( js.LT.jsg )then
3144              folded = .TRUE.
3145              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3146           end if
3147           !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3148           !--- no need to send, because the data on that point will come from other pe.
3149           !--- come from two pe ( there will be only one point on one pe. ).
3150           if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3151              !--- do nothing, this point will come from other pe
3152           else
3153              call insert_update_overlap( overlap, domain%list(m)%pe, &
3154                                          is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3155           endif
3156           !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3157           if(is .LT. isg) then
3158              is = is + ioff
3159              call insert_update_overlap( overlap, domain%list(m)%pe, &
3160                                          is, is, js, je, isc, iec, jsc, jec, dir, folded)
3161           endif
3162
3163           !to_pe's SW halo
3164           dir = 4
3165           folded = .false.
3166           is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3167           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3168           if( isg.GT.is .AND. ie.LT.isc )then !cyclic offset
3169              is = is+ioff; ie = ie+ioff
3170           end if
3171           if( js.LT.jsg )then
3172              folded = .TRUE.
3173              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3174           end if
3175           call insert_update_overlap( overlap, domain%list(m)%pe, &
3176                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3177           !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3178           if(is .LT. isg) then
3179              is = is + ioff
3180              call insert_update_overlap( overlap, domain%list(m)%pe, &
3181                                          is, is, js, je, isc, iec, jsc, jec, dir, folded)
3182           endif
3183
3184           !to_pe's western halo
3185           dir = 5
3186           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
3187           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3188
3189           !--- to make sure the consistence between pes
3190           if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3191              !--- do nothing, this point will come from other pe
3192           else
3193              if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
3194                 is = is+ioff; ie = ie+ioff
3195              end if
3196              !--- when the south face is folded, some point at j=nj will be folded.
3197              !--- the position should be on CORNER or NORTH
3198              if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
3199                   .AND. ( domain%list(m)%x(tNbr)%compute%begin == isg .OR. &
3200                         & domain%list(m)%x(tNbr)%compute%begin-1 .GE. middle)) then
3201                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3202                                             is, ie, js+1, je, isc, iec, jsc, jec, dir)
3203                 is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
3204                 js = domain%list(m)%y(tNbr)%compute%begin;   je = js
3205                 if ( domain%list(m)%x(tNbr)%compute%begin == isg ) then
3206                    select case (position)
3207                    case(NORTH)
3208                       i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3209                    case(CORNER)
3210                       i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3211                    end select
3212                    if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
3213                         'mpp_domains_define.inc(compute_overlaps_fold_south): west edge ubound error send.' )
3214                 else
3215                    select case (position)
3216                    case(NORTH)
3217                       i=is; is = isg+ieg-ie; ie = isg+ieg-i
3218                    case(CORNER)
3219                       i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3220                    end select
3221                 end if
3222                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3223                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3224              else
3225                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3226                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3227              end if
3228           endif
3229
3230           !to_pe's NW halo
3231           dir = 6
3232           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
3233           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3234           if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
3235              is = is+ioff; ie = ie+ioff
3236           end if
3237           call insert_update_overlap( overlap, domain%list(m)%pe, &
3238                                       is, ie, js, je, isc, iec, jsc, jec, dir)
3239
3240           !to_pe's northern halo
3241           dir = 7
3242           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3243           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3244           call insert_update_overlap( overlap, domain%list(m)%pe, &
3245                                       is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3246
3247           !to_pe's NE halo
3248           dir = 8
3249           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3250           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3251           if( ie.GT.ieg .AND. iec.LT.is )then !cyclic offset
3252              is = is-ioff; ie = ie-ioff
3253           end if
3254           call insert_update_overlap( overlap, domain%list(m)%pe, &
3255                                       is, ie, js, je, isc, iec, jsc, jec, dir)
3256
3257           !--- Now calculate the overlapping for fold-edge.
3258           !--- only position at NORTH and CORNER need to be considered
3259           if( ( position == NORTH .OR. position == CORNER) ) then
3260              if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold
3261                                                                                                     !! is within domain
3262                 dir = 3
3263                 !--- calculate the overlapping for sending
3264                 if( domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 )then
3265                    js = domain%list(m)%y(tNbr)%compute%begin;   je = js
3266                    if( js == jsg )then   ! fold is within domain.
3267                       is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3268                       select case (position)
3269                       case(NORTH)
3270                          is = max(is, middle)
3271                          i=is; is = isg+ieg-ie; ie = isg+ieg-i
3272                       case(CORNER)
3273                          is = max(is, middle)
3274                          i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3275                       end select
3276                       call insert_update_overlap(overlap, domain%list(m)%pe, &
3277                                                  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3278                       is = max(is, isc); ie = min(ie, iec)
3279                       js = max(js, jsc); je = min(je, jec)
3280                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3281                          nsend_check = nsend_check+1
3282                          call allocate_check_overlap(checkList(nsend_check), 1)
3283                          call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
3284                                                    tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3285                       end if
3286                    end if
3287                 end if
3288              end if
3289           end if
3290        end if
3291        !--- copy the overlapping information
3292        if( overlap%count > 0) then
3293          nsend = nsend + 1
3294          if(nsend > size(overlapList(:)) ) then
3295             call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for send is expanded')
3296             call expand_update_overlap_list(overlapList, nlist)
3297          endif
3298          call add_update_overlap(overlapList(nsend), overlap)
3299          call init_overlap_type(overlap)
3300        endif
3301     end do  ! end of send set up.
3302
3303     if(debug_message_passing) then
3304        !--- write out send information
3305        unit = mpp_pe() + 1000
3306        do m =1,nsend
3307           write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3308           do n = 1, overlapList(m)%count
3309              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3310                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
3311           enddo
3312        enddo
3313        if( nsend > 0) flush(unit)
3314     endif
3315
3316     ! copy the overlapping information into domain data structure
3317     if(nsend>0) then
3318        allocate(update%send(nsend))
3319        update%nsend = nsend
3320        do m = 1, nsend
3321           call add_update_overlap( update%send(m), overlapList(m) )
3322        enddo
3323     endif
3324
3325     if(nsend_check>0) then
3326        allocate(check%send(nsend_check))
3327        check%nsend = nsend_check
3328        do m = 1, nsend_check
3329           call add_check_overlap( check%send(m), checkList(m) )
3330        enddo
3331     endif
3332
3333     do m = 1,size(overlapList(:))
3334        call deallocate_overlap_type(overlapList(m))
3335     enddo
3336
3337     if(debug_update_level .NE. NO_CHECK) then
3338        do m = 1,size(checkList(:))
3339           call deallocate_overlap_type(checkList(m))
3340        enddo
3341     endif
3342
3343     isgd = isg - domain%whalo
3344     iegd = ieg + domain%ehalo
3345     jsgd = jsg - domain%shalo
3346     jegd = jeg + domain%nhalo
3347
3348     ! begin setting up recv
3349     nrecv = 0
3350     nrecv_check = 0
3351     do list = 0,nlist-1
3352        m = mod( domain%pos+nlist-list, nlist )
3353        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
3354           isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3355           jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3356           !recv_e
3357           dir = 1
3358           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3359           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3360           is=isc; ie=iec; js=jsc; je=jec
3361           if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
3362              ! --- do nothing, this point will come from other pe
3363           else
3364              if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3365                 is = is+ioff; ie = ie+ioff
3366              end if
3367
3368              !--- when the south face is folded, the east halo point at right side domain will be folded.
3369              !--- the position should be on CORNER or NORTH
3370              if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
3371                   .AND. isd .GE. middle .AND. ied .LE. ieg ) then
3372                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3373                                             is, ie, js, je, isd, ied, jsd+1, jed, dir)
3374                 is=isc; ie=iec; js=jsc; je=jec
3375                 jed = jsd
3376                 select case (position)
3377                 case(NORTH)
3378                    i=is; is = isg+ieg-ie; ie = isg+ieg-i
3379                 case(CORNER)
3380                    i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3381                 end select
3382                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3383                                             is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
3384              else
3385                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3386                                             is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3387              end if
3388           end if
3389
3390           !recv_se
3391           dir = 2
3392           folded = .false.
3393           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3394           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
3395           is=isc; ie=iec; js=jsc; je=jec
3396           if( jsd.LT.jsg )then
3397              folded = .true.
3398              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3399           end if
3400           if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3401              is = is+ioff; ie = ie+ioff
3402           endif
3403           call insert_update_overlap(overlap, domain%list(m)%pe, &
3404                                      is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3405
3406           !recv_s
3407           dir = 3
3408           folded = .false.
3409           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3410           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
3411           is=isc; ie=iec; js=jsc; je=jec
3412           if( jsd.LT.jsg )then
3413              folded = .true.
3414              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3415           end if
3416           if( (position == EAST .OR. position == CORNER ) .AND. (isd == ie .or. ied == is ) ) then
3417              !--- do nothing, this point will come from other pe
3418           else
3419              call insert_update_overlap(overlap, domain%list(m)%pe, &
3420                                         is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
3421           end if
3422           !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3423           if(is .LT. isg ) then
3424              is = is + ioff
3425              call insert_update_overlap(overlap, domain%list(m)%pe, &
3426                                         is, is, js, je, isd, ied, jsd, jed, dir, folded)
3427           endif
3428
3429           !recv_sw
3430           dir = 4
3431           folded = .false.
3432           isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
3433           jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3434           is=isc; ie=iec; js=jsc; je=jec
3435           if( jsd.LT.jsg )then
3436              folded = .true.
3437              call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3438           end if
3439           if( isd.LT.isg .AND. is.GT.ied ) then ! cyclic offset
3440              is = is-ioff; ie = ie-ioff
3441           end if
3442           call insert_update_overlap(overlap, domain%list(m)%pe, &
3443                                      is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3444           !--- when southth edge is folded, is will be less than isg when position is EAST and CORNER
3445           if(is .LT. isg ) then
3446              is = is + ioff
3447              call insert_update_overlap(overlap, domain%list(m)%pe, &
3448                                         is, is, js, je, isd, ied, jsd, jed, dir, folded )
3449           endif
3450
3451           !recv_w
3452           dir = 5
3453           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
3454           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3455           is=isc; ie=iec; js=jsc; je=jec
3456           if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
3457              ! --- do nothing, this point will come from other pe
3458           else
3459              if( isd.LT.isg .AND. is.GT.ied )then ! cyclic offset
3460                 is = is-ioff; ie = ie-ioff
3461              end if
3462              !--- when the south face is folded, some point at j=nj will be folded.
3463              !--- the position should be on CORNER or NORTH
3464              if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
3465                   .AND. ( isd < isg  .OR. ied .GE. middle ) )  then
3466                 call insert_update_overlap(overlap, domain%list(m)%pe, &
3467                                            is, ie, js, je, isd, ied, jsd+1, jed, dir)
3468                 is=isc; ie=iec; js=jsc; je=jec
3469                 if(isd < isg) then
3470                    select case (position)
3471                    case(NORTH)
3472                       i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3473                    case(CORNER)
3474                       ied = ied -1 + ishift
3475                       i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3476                    end select
3477                    if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
3478                         'mpp_domains_define.inc(compute_overlaps): west edge ubound error recv.' )
3479                 else
3480                    select case (position)
3481                    case(NORTH)
3482                       i=is; is = isg+ieg-ie; ie = isg+ieg-i
3483                    case(CORNER)
3484                       i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3485                    end select
3486                 end if
3487                 call insert_update_overlap(overlap, domain%list(m)%pe, &
3488                                            is, ie, js, je, isd, ied, jsd, jsd, dir, .TRUE.)
3489              else
3490                 call insert_update_overlap(overlap, domain%list(m)%pe, &
3491                                            is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3492              end if
3493           endif
3494
3495           !recv_nw
3496           dir = 6
3497           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
3498           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3499           is=isc; ie=iec; js=jsc; je=jec
3500           if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset
3501              is = is-ioff; ie = ie-ioff
3502           endif
3503
3504           call insert_update_overlap( overlap, domain%list(m)%pe, &
3505                                       is, ie, js, je, isd, ied, jsd, jed, dir)
3506
3507           !recv_n
3508           dir = 7
3509           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3510           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3511           is=isc; ie=iec; js=jsc; je=jec
3512           call insert_update_overlap( overlap, domain%list(m)%pe, &
3513                                       is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3514
3515           !recv_ne
3516           dir = 8
3517           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3518           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3519           is=isc; ie=iec; js=jsc; je=jec
3520           if(  ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset
3521              is = is+ioff; ie = ie+ioff
3522           end if
3523           call insert_update_overlap( overlap, domain%list(m)%pe, &
3524                                       is, ie, js, je, isd, ied, jsd, jed, dir)
3525
3526           !--- Now calculate the overlapping for fold-edge.
3527           !--- for folded-south-edge, only need to consider to_pe's south(3) direction
3528           !--- only position at NORTH and CORNER need to be considered
3529           if( ( position == NORTH .OR. position == CORNER) ) then
3530              if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold
3531                                                                                                     !! is within domain
3532                 dir = 3
3533                 !--- calculating overlapping for receving on north
3534                 if( domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2 )then
3535                    jsd = domain%y(tMe)%compute%begin;   jed = jsd
3536                    if( jsd == jsg )then   ! fold is within domain.
3537                       isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3538                       is=isc; ie=iec; js = jsc; je = jec
3539                       select case (position)
3540                       case(NORTH)
3541                          isd = max(isd, middle)
3542                          i=is; is = isg+ieg-ie; ie = isg+ieg-i
3543                       case(CORNER)
3544                          isd = max(isd, middle)
3545                          i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3546                       end select
3547                       call insert_update_overlap(overlap, domain%list(m)%pe, &
3548                                                  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
3549                       is = max(is, isd); ie = min(ie, ied)
3550                       js = max(js, jsd); je = min(je, jed)
3551                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3552                          nrecv_check = nrecv_check+1
3553                          call allocate_check_overlap(checkList(nrecv_check), 1)
3554                          call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
3555                                                    tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3556                       endif
3557                    endif
3558                 endif
3559              endif
3560           endif
3561        endif
3562        !--- copy the overlapping information
3563        if( overlap%count > 0) then
3564           nrecv = nrecv + 1
3565           if(nrecv > size(overlapList(:)) )then
3566             call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for recv is expanded')
3567             call expand_update_overlap_list(overlapList, nlist)
3568           endif
3569           call add_update_overlap( overlapList(nrecv), overlap)
3570           call init_overlap_type(overlap)
3571        endif
3572     enddo ! end of recv do loop
3573
3574     if(debug_message_passing) then
3575        !--- write out send information
3576        unit = mpp_pe() + 1000
3577        do m =1,nrecv
3578           write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3579           do n = 1, overlapList(m)%count
3580              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3581                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
3582           enddo
3583        enddo
3584        if(nrecv >0) flush(unit)
3585     endif
3586
3587     ! copy the overlapping information into domain
3588     if(nrecv>0) then
3589        update%nrecv = nrecv
3590        allocate(update%recv(nrecv))
3591        do m = 1, nrecv
3592           call add_update_overlap( update%recv(m), overlapList(m) )
3593           do n = 1, update%recv(m)%count
3594              if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
3595                 if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
3596                 if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
3597              endif
3598           enddo
3599        enddo
3600     endif
3601
3602     if(nrecv_check>0) then
3603        check%nrecv = nrecv_check
3604        allocate(check%recv(nrecv_check))
3605        do m = 1, nrecv_check
3606           call add_check_overlap( check%recv(m), checkList(m) )
3607        enddo
3608     endif
3609
3610     call deallocate_overlap_type(overlap)
3611
3612     do m = 1,size(overlapList(:))
3613        call deallocate_overlap_type(overlapList(m))
3614     enddo
3615
3616     if(debug_update_level .NE. NO_CHECK) then
3617        do m = 1,size(checkList(:))
3618           call deallocate_overlap_type(checkList(m))
3619        enddo
3620     endif
3621
3622     deallocate(overlapList)
3623     deallocate(checkList)
3624     update => NULL()
3625     check=>NULL()
3626     domain%initialized = .true.
3627
3628   end subroutine compute_overlaps_fold_south
3629
3630   !####################################################################################
3631   subroutine compute_overlaps_fold_west( domain, position, ishift, jshift)
3632     !computes remote domain overlaps
3633     !assumes only one in each direction
3634     !will calculate the overlapping for T,E,C,N-cell seperately.
3635     type(domain2D), intent(inout) :: domain
3636     integer, intent(in)           :: position, ishift, jshift
3637
3638     integer                          :: j, m, n, nlist, tMe, tNbr, dir
3639     integer                          :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3640     integer                          :: isg, ieg, jsg, jeg, ioff, joff
3641     integer                          :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3642     integer                          :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3643     logical                          :: folded
3644     type(overlap_type)               :: overlap
3645     type(overlapSpec),   pointer     :: update=>NULL()
3646     type(overlap_type)               :: overlapList(MAXLIST)
3647     type(overlap_type)               :: checkList(MAXLIST)
3648     type(overlapSpec),   pointer     :: check =>NULL()
3649     integer                          :: nsend, nrecv
3650     integer                          :: nsend_check, nrecv_check
3651     integer                          :: unit
3652
3653     !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
3654     !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
3655     !--- In this case the overlapping exist only for tMe=1 and tNbr=1
3656     if(size(domain%x(:)) > 1) return
3657
3658     !--- if there is no halo, no need to compute overlaps.
3659     if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3660
3661     !--- when there is only one tile, n will equal to np
3662     nlist = size(domain%list(:))
3663
3664     select case(position)
3665     case (CENTER)
3666        update => domain%update_T
3667        check  => NULL()
3668     case (CORNER)
3669        update => domain%update_C
3670        check  => domain%check_C
3671     case (EAST)
3672        update => domain%update_E
3673        check  => domain%check_E
3674     case (NORTH)
3675        update => domain%update_N
3676        check  => domain%check_N
3677     case default
3678        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west):"//&
3679                            & " the value of position should be CENTER, EAST, CORNER or NORTH")
3680     end select
3681
3682     !--- overlap is used to store the overlapping temporarily.
3683     call allocate_update_overlap( overlap, MAXOVERLAP)
3684
3685     !send
3686     call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3687     call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
3688     call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3689     update%xbegin = ism; update%xend = iem
3690     update%ybegin = jsm; update%yend = jem
3691     if(ASSOCIATED(check)) then
3692        check%xbegin  = ism; check%xend  = iem
3693        check%ybegin  = jsm; check%yend  = jem
3694     endif
3695     update%whalo  = domain%whalo; update%ehalo = domain%ehalo
3696     update%shalo  = domain%shalo; update%nhalo = domain%nhalo
3697     whalo         = domain%whalo; ehalo        = domain%ehalo
3698     shalo         = domain%shalo; nhalo        = domain%nhalo
3699
3700     ioff = ni - ishift
3701     joff = nj - jshift
3702     middle = (jsg+jeg)/2+1
3703     tMe = 1; tNbr = 1
3704
3705     if(.NOT. BTEST(domain%fold,WEST)) then
3706        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3707             "boundary condition in y-direction should be folded-west for "//trim(domain%name))
3708     endif
3709     if(.NOT. domain%y(tMe)%cyclic) then
3710        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3711             "boundary condition in y-direction should be cyclic for "//trim(domain%name))
3712     endif
3713
3714     if(.not. domain%symmetry) then
3715        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3716             "when west boundary is folded, the domain must be symmetry for "//trim(domain%name))
3717     endif
3718
3719     nsend = 0
3720     nsend_check = 0
3721     do list = 0,nlist-1
3722        m = mod( domain%pos+list, nlist )
3723        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
3724           !to_pe's eastern halo
3725           dir = 1
3726           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3727           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3728           call insert_update_overlap( overlap, domain%list(m)%pe, &
3729                                       is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3730
3731           !to_pe's SE halo
3732           dir = 2
3733           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3734           js = domain%list(m)%y(tNbr)%compute%begin-shalo;    je = domain%list(m)%y(tNbr)%compute%begin-1
3735           if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
3736              js = js+joff; je = je+joff
3737           end if
3738
3739           call insert_update_overlap( overlap, domain%list(m)%pe, &
3740                                        is, ie, js, je, isc, iec, jsc, jec, dir)
3741
3742           !to_pe's southern halo
3743           dir = 3
3744           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3745           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3746           !--- to make sure the consistence between pes
3747           if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3748              !--- do nothing, this point will come from other pe
3749           else
3750              if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
3751                 js = js+joff; je = je+joff
3752              endif
3753
3754              !--- when the west face is folded, the south halo points at
3755              !--- the position should be on CORNER or EAST
3756              if( is == isg .AND. (position == CORNER .OR. position == EAST) &
3757                   .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. &
3758                   & domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle)) then
3759                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3760                                             is+1, ie, js, je, isc, iec, jsc, jec, dir)
3761                 is = domain%list(m)%x(tNbr)%compute%begin; ie = is
3762                 js = domain%list(m)%y(tNbr)%compute%begin-shalo;    je = domain%list(m)%y(tNbr)%compute%begin-1
3763                 if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
3764                    select case (position)
3765                    case(EAST)
3766                       j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
3767                    case(CORNER)
3768                       j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
3769                    end select
3770                    if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
3771                         'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error send.' )
3772                 else
3773                    select case (position)
3774                    case(EAST)
3775                       j=js; js = jsg+jeg-je; je = jsg+jeg-j
3776                    case(CORNER)
3777                       j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3778                    end select
3779                 end if
3780                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3781                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3782              else
3783                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3784                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3785              end if
3786           endif
3787
3788           !to_pe's SW halo
3789           dir = 4
3790           folded = .false.
3791           is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3792           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3793           if( jsg.GT.js .AND. je.LT.jsc )then !cyclic offset
3794              js = js+joff; je = je+joff
3795           end if
3796           if( is.LT.isg )then
3797              folded = .TRUE.
3798              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3799           end if
3800           call insert_update_overlap( overlap, domain%list(m)%pe, &
3801                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3802           !--- when south edge is folded, js will be less than jsg when position is EAST and CORNER
3803           if(js .LT. jsg) then
3804              js = js + joff
3805              call insert_update_overlap( overlap, domain%list(m)%pe, &
3806                                          is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3807           endif
3808
3809           !to_pe's western halo
3810           dir = 5
3811           folded = .FALSE.
3812           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
3813           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3814           if( isg.GT.is )then
3815              folded = .true.
3816              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3817           end if
3818           !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3819           !--- no need to send, because the data on that point will come from other pe.
3820           !--- come from two pe ( there will be only one point on one pe. ).
3821           if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3822              !--- do nothing, this point will come from other pe
3823           else
3824              call insert_update_overlap( overlap, domain%list(m)%pe, &
3825                                          is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3826           endif
3827           !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3828           if(js .LT. jsg) then
3829              js = js + ioff
3830              call insert_update_overlap( overlap, domain%list(m)%pe, &
3831                                          is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3832           endif
3833
3834           !to_pe's NW halo
3835           dir = 6
3836           folded = .false.
3837           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
3838           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3839           if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
3840              js = js-joff; je = je-joff
3841           end if
3842           if( is.LT.isg )then
3843              folded = .TRUE.
3844              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3845           end if
3846
3847           call insert_update_overlap( overlap, domain%list(m)%pe, &
3848                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3849
3850           !to_pe's northern halo
3851           dir = 7
3852           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3853           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3854           !--- to make sure the consistence between pes
3855           if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3856              !--- do nothing, this point will come from other pe
3857           else
3858              if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
3859                 js = js-joff; je = je-joff
3860              endif
3861              !--- when the west face is folded, the south halo points at
3862              !--- the position should be on CORNER or EAST
3863              if( is == isg .AND. (position == CORNER .OR. position == EAST) &
3864                   .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
3865                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3866                                             is+1, ie, js, je, isc, iec, jsc, jec, dir)
3867                 is = domain%list(m)%x(tNbr)%compute%begin; ie = is
3868                 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3869                 select case (position)
3870                 case(EAST)
3871                    j=js; js = jsg+jeg-je; je = jsg+jeg-j
3872                 case(CORNER)
3873                    j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3874                 end select
3875                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3876                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3877              else
3878                 call insert_update_overlap( overlap, domain%list(m)%pe, &
3879                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3880              end if
3881           endif
3882
3883           !to_pe's NE halo
3884           dir = 8
3885           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3886           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3887           if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
3888              js = js-joff; je = je-joff
3889           end if
3890           call insert_update_overlap( overlap, domain%list(m)%pe, &
3891                                       is, ie, js, je, isc, iec, jsc, jec, dir)
3892
3893           !--- Now calculate the overlapping for fold-edge.
3894           !--- only position at EAST and CORNER need to be considered
3895           if( ( position == EAST .OR. position == CORNER) ) then
3896              if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold
3897                                                                                                     !! is within domain
3898                 dir = 5
3899                 !--- calculate the overlapping for sending
3900                 if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
3901                    is = domain%list(m)%x(tNbr)%compute%begin;   ie = is
3902                    if( is == isg )then   ! fold is within domain.
3903                       js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3904                       select case (position)
3905                       case(EAST)
3906                          js = max(js, middle)
3907                          j=js; js = jsg+jeg-je; je = jsg+jeg-j
3908                       case(CORNER)
3909                          js = max(js, middle)
3910                          j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3911                       end select
3912                       call insert_update_overlap(overlap, domain%list(m)%pe, &
3913                                                  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3914                       is = max(is, isc); ie = min(ie, iec)
3915                       js = max(js, jsc); je = min(je, jec)
3916                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3917                          nsend_check = nsend_check+1
3918                          call allocate_check_overlap(checkList(nsend_check), 1)
3919                          call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
3920                                                    tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3921                       end if
3922                    end if
3923                 end if
3924              end if
3925           end if
3926        end if
3927        !--- copy the overlapping information
3928        if( overlap%count > 0) then
3929          nsend = nsend + 1
3930          if(nsend > MAXLIST) call mpp_error(FATAL,  &
3931              "mpp_domains_define.inc(compute_overlaps_west): nsend is greater than MAXLIST, increase MAXLIST")
3932          call add_update_overlap(overlapList(nsend), overlap)
3933          call init_overlap_type(overlap)
3934        endif
3935     end do  ! end of send set up.
3936
3937     if(debug_message_passing) then
3938        !--- write out send information
3939        unit = mpp_pe() + 1000
3940        do m =1,nsend
3941           write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3942           do n = 1, overlapList(m)%count
3943              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3944                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
3945           enddo
3946        enddo
3947        if(nsend >0) flush(unit)
3948     endif
3949
3950    ! copy the overlapping information into domain data structure
3951     if(nsend>0) then
3952        update%nsend = nsend
3953        allocate(update%send(nsend))
3954        do m = 1, nsend
3955           call add_update_overlap( update%send(m), overlapList(m) )
3956        enddo
3957     endif
3958
3959     if(nsend_check>0) then
3960        check%nsend = nsend_check
3961        allocate(check%send(nsend_check))
3962        do m = 1, nsend_check
3963           call add_check_overlap( check%send(m), checkList(m) )
3964        enddo
3965     endif
3966
3967     do m = 1, MAXLIST
3968        call deallocate_overlap_type(overlapList(m))
3969        if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
3970     enddo
3971
3972     isgd = isg - domain%whalo
3973     iegd = ieg + domain%ehalo
3974     jsgd = jsg - domain%shalo
3975     jegd = jeg + domain%nhalo
3976
3977     ! begin setting up recv
3978     nrecv = 0
3979     nrecv_check = 0
3980     do list = 0,nlist-1
3981        m = mod( domain%pos+nlist-list, nlist )
3982        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
3983           isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3984           jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3985           !recv_e
3986           dir = 1
3987           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3988           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3989           is=isc; ie=iec; js=jsc; je=jec
3990           call insert_update_overlap( overlap, domain%list(m)%pe, &
3991                                       is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3992
3993           !recv_se
3994           dir = 2
3995           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3996           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
3997           is=isc; ie=iec; js=jsc; je=jec
3998           if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
3999              js = js-joff; je = je-joff
4000           end if
4001           call insert_update_overlap(overlap, domain%list(m)%pe, &
4002                                      is, ie, js, je, isd, ied, jsd, jed, dir)
4003
4004           !recv_s
4005           dir = 3
4006           folded = .false.
4007           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4008           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
4009           is=isc; ie=iec; js=jsc; je=jec
4010
4011           if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4012              !--- do nothing, this point will come from other pe
4013           else
4014              if( jsd.LT.jsg .AND. js .GT. jed)then
4015                 js = js-joff; je = je-joff
4016              end if
4017              !--- when the west face is folded, the south halo points at
4018              !--- the position should be on CORNER or EAST
4019              if( isd == isg .AND. (position == CORNER .OR. position == EAST) &
4020                   .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
4021                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4022                                             is, ie, js, je, isd+1, ied, jsd, jed, dir)
4023                 is=isc; ie=iec; js=jsc; je=jec
4024                 if(jsd<jsg) then
4025                    select case (position)
4026                    case(EAST)
4027                       j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4028                    case(CORNER)
4029                       j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4030                    end select
4031                    if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4032                         'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4033                 else
4034                    select case (position)
4035                    case(EAST)
4036                       j=js; js = jsg+jeg-je; je = jsg+jeg-j
4037                    case(CORNER)
4038                       j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4039                    end select
4040                 end if
4041                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4042                                             is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4043              else
4044                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4045                                             is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4046              end if
4047           endif
4048
4049           !recv_sw
4050           dir = 4
4051           folded = .false.
4052           isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4053           jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4054           is=isc; ie=iec; js=jsc; je=jec
4055           if( isd.LT.isg )then
4056              folded = .true.
4057              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4058           end if
4059           if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4060              js = js-joff; je = je-joff
4061           end if
4062           call insert_update_overlap(overlap, domain%list(m)%pe, &
4063                                      is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4064           !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4065           if(js .LT. jsg ) then
4066              js = js + joff
4067              call insert_update_overlap(overlap, domain%list(m)%pe, &
4068                                         is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4069           endif
4070
4071           !recv_w
4072           dir = 5
4073           folded = .false.
4074           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
4075           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4076           is=isc; ie=iec; js=jsc; je=jec
4077           if( isd.LT.isg )then
4078              folded = .true.
4079              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4080           end if
4081           if( (position == EAST .OR. position == CORNER ) .AND. (jsd == je .or. jed == js ) ) then
4082              !--- do nothing, this point will come from other pe
4083           else
4084              call insert_update_overlap(overlap, domain%list(m)%pe, &
4085                                         is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4086           end if
4087           !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4088           if(js .LT. jsg ) then
4089              js = js + joff
4090              call insert_update_overlap(overlap, domain%list(m)%pe, &
4091                                         is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4092           endif
4093
4094           !recv_nw
4095           dir = 6
4096           folded = .false.
4097           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
4098           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4099           is=isc; ie=iec; js=jsc; je=jec
4100           if( isd.LT.isg) then
4101              folded = .true.
4102              call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4103           end if
4104           if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4105              js = js+joff; je = je+joff
4106           endif
4107
4108           call insert_update_overlap( overlap, domain%list(m)%pe, &
4109                                       is, ie, js, je, isd, ied, jsd, jed, dir)
4110
4111           !recv_n
4112           dir = 7
4113           folded = .false.
4114           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4115           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4116           is=isc; ie=iec; js=jsc; je=jec
4117           if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4118              !--- do nothing, this point will come from other pe
4119           else
4120              if( jed.GT.jeg .AND. je.LT.jsd)then
4121                 js = js+joff; je = je+joff
4122              end if
4123              !--- when the west face is folded, the south halo points at
4124              !--- the position should be on CORNER or EAST
4125              if( isd == isg .AND. (position == CORNER .OR. position == EAST) &
4126                   .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4127                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4128                                             is, ie, js, je, isd+1, ied, jsd, jed, dir)
4129                 is=isc; ie=iec; js=jsc; je=jec
4130                 select case (position)
4131                 case(EAST)
4132                    j=js; js = jsg+jeg-je; je = jsg+jeg-j
4133                 case(CORNER)
4134                    j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4135                 end select
4136                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4137                                             is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4138              else
4139                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4140                                             is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4141              end if
4142           endif
4143
4144           !recv_ne
4145           dir = 8
4146           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4147           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4148           is=isc; ie=iec; js=jsc; je=jec
4149           if(  jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4150              js = js+joff; je = je+joff
4151           end if
4152           call insert_update_overlap( overlap, domain%list(m)%pe, &
4153                                       is, ie, js, je, isd, ied, jsd, jed, dir)
4154
4155           !--- Now calculate the overlapping for fold-edge.
4156           !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4157           !--- only position at EAST and CORNER need to be considered
4158           if( ( position == EAST .OR. position == CORNER) ) then
4159              if( domain%x(tMe)%data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold
4160                                                                                                     !! is within domain
4161                 dir = 5
4162                 !--- calculating overlapping for receving on north
4163                 if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then
4164                    isd = domain%x(tMe)%compute%begin;   ied = isd
4165                    if( isd == isg )then   ! fold is within domain.
4166                       jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4167                       is=isc; ie=iec; js = jsc; je = jec
4168                       select case (position)
4169                       case(EAST)
4170                          jsd = max(jsd, middle)
4171                          j=js; js = jsg+jeg-je; je = jsg+jeg-j
4172                       case(CORNER)
4173                          jsd = max(jsd, middle)
4174                          j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4175                       end select
4176                       call insert_update_overlap(overlap, domain%list(m)%pe, &
4177                                                  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
4178                       is = max(is, isd); ie = min(ie, ied)
4179                       js = max(js, jsd); je = min(je, jed)
4180                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4181                          nrecv_check = nrecv_check+1
4182                          call allocate_check_overlap(checkList(nrecv_check), 1)
4183                          call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
4184                                                    tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4185                       endif
4186                    endif
4187                 endif
4188              endif
4189           endif
4190        endif
4191        !--- copy the overlapping information
4192        if( overlap%count > 0) then
4193           nrecv = nrecv + 1
4194          if(nrecv > MAXLIST) call mpp_error(FATAL,  &
4195              "mpp_domains_define.inc(compute_overlaps_west): nrecv is greater than MAXLIST, increase MAXLIST")
4196           call add_update_overlap( overlapList(nrecv), overlap)
4197           call init_overlap_type(overlap)
4198        endif
4199     enddo ! end of recv do loop
4200
4201     if(debug_message_passing) then
4202        !--- write out send information
4203        unit = mpp_pe() + 1000
4204        do m =1,nrecv
4205           write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
4206           do n = 1, overlapList(m)%count
4207              write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
4208                   overlapList(m)%dir(n), overlapList(m)%rotation(n)
4209           enddo
4210        enddo
4211        if(nrecv >0) flush(unit)
4212     endif
4213
4214     ! copy the overlapping information into domain
4215     if(nrecv>0) then
4216        update%nrecv = nrecv
4217        allocate(update%recv(nrecv))
4218        do m = 1, nrecv
4219           call add_update_overlap( update%recv(m), overlapList(m) )
4220           do n = 1, update%recv(m)%count
4221              if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
4222                 if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
4223                 if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
4224              endif
4225           enddo
4226        enddo
4227     endif
4228
4229     if(nrecv_check>0) then
4230        check%nrecv = nrecv_check
4231        allocate(check%recv(nrecv_check))
4232        do m = 1, nrecv_check
4233           call add_check_overlap( check%recv(m), checkList(m) )
4234        enddo
4235     endif
4236
4237     call deallocate_overlap_type(overlap)
4238     do m = 1, MAXLIST
4239        call deallocate_overlap_type(overlapList(m))
4240        if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4241     enddo
4242
4243     update=>NULL()
4244     check=>NULL()
4245     domain%initialized = .true.
4246
4247   end subroutine compute_overlaps_fold_west
4248
4249   !###############################################################################
4250   subroutine compute_overlaps_fold_east( domain, position, ishift, jshift )
4251     !computes remote domain overlaps
4252     !assumes only one in each direction
4253     !will calculate the overlapping for T,E,C,N-cell seperately.
4254     !here assume fold-east and y-cyclic boundary condition
4255     type(domain2D), intent(inout) :: domain
4256     integer, intent(in)           :: position, ishift, jshift
4257
4258     integer                          :: j, m, n, nlist, tMe, tNbr, dir
4259     integer                          :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd
4260     integer                          :: jed, isg, ieg, jsg, jeg, ioff, joff
4261     integer                          :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
4262     integer                          :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
4263     logical                          :: folded
4264     type(overlap_type)               :: overlap
4265     type(overlapSpec),   pointer     :: update=>NULL()
4266     type(overlap_type)               :: overlapList(MAXLIST)
4267     type(overlap_type)               :: checkList(MAXLIST)
4268     type(overlapSpec),   pointer     :: check =>NULL()
4269     integer                          :: nsend, nrecv
4270     integer                          :: nsend_check, nrecv_check
4271
4272     !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
4273     !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
4274     !--- In this case the overlapping exist only for tMe=1 and tNbr=1
4275     if(size(domain%x(:)) > 1) return
4276
4277     !--- if there is no halo, no need to compute overlaps.
4278     if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
4279
4280     !--- when there is only one tile, n will equal to np
4281     nlist = size(domain%list(:))
4282
4283     select case(position)
4284     case (CENTER)
4285        update => domain%update_T
4286     case (CORNER)
4287        update => domain%update_C
4288        check  => domain%check_C
4289     case (EAST)
4290        update => domain%update_E
4291        check  => domain%check_E
4292     case (NORTH)
4293        update => domain%update_N
4294        check  => domain%check_N
4295     case default
4296        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east):"// &
4297                            & " the value of position should be CENTER, EAST, CORNER or NORTH")
4298     end select
4299
4300     !--- overlap is used to store the overlapping temporarily.
4301     call allocate_update_overlap( overlap, MAXOVERLAP)
4302
4303     !send
4304     call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
4305     call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
4306     call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
4307     update%xbegin = ism; update%xend = iem
4308     update%ybegin = jsm; update%yend = jem
4309     if(ASSOCIATED(check)) then
4310        check%xbegin  = ism; check%xend  = iem
4311        check%ybegin  = jsm; check%yend  = jem
4312     endif
4313     update%whalo  = domain%whalo; update%ehalo = domain%ehalo
4314     update%shalo  = domain%shalo; update%nhalo = domain%nhalo
4315     whalo         = domain%whalo; ehalo        = domain%ehalo
4316     shalo         = domain%shalo; nhalo        = domain%nhalo
4317
4318     ioff = ni - ishift
4319     joff = nj - jshift
4320     middle = (jsg+jeg)/2+1
4321     tMe = 1; tNbr = 1
4322
4323     if(.NOT. BTEST(domain%fold,EAST)) then
4324        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4325             "boundary condition in y-direction should be folded-east for "//trim(domain%name))
4326     endif
4327     if(.NOT. domain%y(tMe)%cyclic) then
4328        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4329             "boundary condition in y-direction should be cyclic for "//trim(domain%name))
4330     endif
4331     if(.not. domain%symmetry) then
4332        call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4333             "when east boundary is folded, the domain must be symmetry for "//trim(domain%name))
4334     endif
4335
4336     nsend = 0
4337     nsend_check = 0
4338     do list = 0,nlist-1
4339        m = mod( domain%pos+list, nlist )
4340        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
4341           !to_pe's eastern halo
4342           dir = 1
4343           folded = .false.
4344           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4345           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4346           if( ie.GT.ieg )then
4347              folded = .true.
4348              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4349           end if
4350           !--- when domain symmetry and position is EAST or CORNER, the point when jsc == je,
4351           !--- no need to send, because the data on that point will come from other pe.
4352           !--- come from two pe ( there will be only one point on one pe. ).
4353           if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
4354              !--- do nothing, this point will come from other pe
4355           else
4356              call insert_update_overlap( overlap, domain%list(m)%pe, &
4357                                          is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
4358           endif
4359           !--- when east edge is folded, js .LT. jsg
4360           if(js .LT. jsg) then
4361              js = js + ioff
4362              call insert_update_overlap( overlap, domain%list(m)%pe, &
4363                                          is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4364           endif
4365
4366           !to_pe's SE halo
4367           dir = 2
4368           folded = .FALSE.
4369           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4370           js = domain%list(m)%y(tNbr)%compute%begin-shalo;    je = domain%list(m)%y(tNbr)%compute%begin-1
4371           if( jsg.GT.js .AND. je.LT.jsc )then !try cyclic offset
4372              js = js+joff; je = je+joff
4373           end if
4374
4375           if( ie.GT.ieg )then
4376              folded = .TRUE.
4377              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4378           end if
4379
4380           call insert_update_overlap( overlap, domain%list(m)%pe, &
4381                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4382           !--- when east edge is folded,
4383           if(js .LT. jsg) then
4384              js = js + joff
4385              call insert_update_overlap( overlap, domain%list(m)%pe, &
4386                                          is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4387           endif
4388
4389           !to_pe's southern halo
4390           dir = 3
4391           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
4392           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4393           !--- to make sure the consistence between pes
4394           if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
4395              !--- do nothing, this point will come from other pe
4396           else
4397              if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
4398                 js = js+joff; je = je+joff
4399              endif
4400              !--- when the east face is folded, the south halo points at
4401              !--- the position should be on CORNER or EAST
4402              if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
4403                   .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. &
4404                         domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle  ) ) then
4405                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4406                                             is, ie-1, js, je, isc, iec, jsc, jec, dir)
4407                 !--- consider at i = ieg for east edge.
4408                 !--- when the data is at corner and not symmetry, j = jsg -1 will get from cyclic condition
4409                 if(position == CORNER .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tNbr)%compute%begin==jsg)then
4410                    call insert_update_overlap(overlap, domain%list(m)%pe, &
4411                                               ie, ie, je, je, isc, iec, jsc, jec, dir, .true.)
4412                 end if
4413
4414                 ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
4415                 js = domain%list(m)%y(tNbr)%compute%begin-shalo;  je = domain%list(m)%y(tNbr)%compute%begin-1
4416                 if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
4417                    select case (position)
4418                    case(EAST)
4419                       j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4420                    case(CORNER)
4421                       j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4422                    end select
4423                    if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4424                         'mpp_domains_define.inc(compute_overlaps_fold_east: south edge ubound error send.' )
4425                 else
4426                    select case (position)
4427                    case(EAST)
4428                       j=js; js = jsg+jeg-je; je = jsg+jeg-j
4429                    case(CORNER)
4430                       j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4431                    end select
4432                 end if
4433                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4434                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4435              else
4436                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4437                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4438              end if
4439           endif
4440
4441           !to_pe's SW halo
4442           dir = 4
4443           is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
4444           js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4445           if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
4446              js = js+joff; je = je+joff
4447           end if
4448           call insert_update_overlap( overlap, domain%list(m)%pe, &
4449                                       is, ie, js, je, isc, iec, jsc, jec, dir)
4450
4451           !to_pe's western halo
4452           dir = 5
4453           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
4454           js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4455           call insert_update_overlap( overlap, domain%list(m)%pe, &
4456                                       is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4457
4458           !to_pe's NW halo
4459           dir = 6
4460           is = domain%list(m)%x(tNbr)%compute%begin-whalo;    ie = domain%list(m)%x(tNbr)%compute%begin-1
4461           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4462           if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
4463              js = js-joff; je = je-joff
4464           end if
4465           call insert_update_overlap( overlap, domain%list(m)%pe, &
4466                                       is, ie, js, je, isc, iec, jsc, jec, dir)
4467
4468           !to_pe's northern halo
4469           dir = 7
4470           folded = .FALSE.
4471           is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
4472           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4473           !--- to make sure the consistence between pes
4474           if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
4475              !--- do nothing, this point will come from other pe
4476           else
4477              if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
4478                 js = js-joff; je = je-joff
4479              endif
4480              !--- when the east face is folded, the north halo points at
4481              !--- the position should be on CORNER or EAST
4482              if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
4483                   .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
4484                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4485                                             is, ie-1, js, je, isc, iec, jsc, jec, dir)
4486                 ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
4487                 js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4488                 select case (position)
4489                 case(EAST)
4490                    j=js; js = jsg+jeg-je; je = jsg+jeg-j
4491                 case(CORNER)
4492                    j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4493                 end select
4494                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4495                                             is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4496              else
4497                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4498                                             is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4499              end if
4500           endif
4501
4502           !to_pe's NE halo
4503           dir = 8
4504           folded = .false.
4505           is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4506           js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4507           if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
4508              js = js-joff; je = je-joff
4509           end if
4510           if( ie.GT.ieg )then
4511              folded = .TRUE.
4512              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4513           end if
4514
4515           call insert_update_overlap( overlap, domain%list(m)%pe, &
4516                                       is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4517
4518           !--- Now calculate the overlapping for fold-edge.
4519           !--- only position at EAST and CORNER need to be considered
4520           if( ( position == EAST .OR. position == CORNER) ) then
4521              if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold
4522                                                                                                     !! is within domain
4523                 dir = 1
4524                 !--- calculate the overlapping for sending
4525                 if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
4526                    ie = domain%list(m)%x(tNbr)%compute%end+ishift;   is = ie
4527                    if( ie == ieg )then   ! fold is within domain.
4528                       js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4529                       select case (position)
4530                       case(EAST)
4531                          js = max(js, middle)
4532                          j=js; js = jsg+jeg-je; je = jsg+jeg-j
4533                       case(CORNER)
4534                          js = max(js, middle)
4535                          j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4536                       end select
4537                       call insert_update_overlap(overlap, domain%list(m)%pe, &
4538                                                  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4539                       is = max(is, isc); ie = min(ie, iec)
4540                       js = max(js, jsc); je = min(je, jec)
4541                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4542                          nsend_check = nsend_check+1
4543                          call allocate_check_overlap(checkList(nsend_check), 1)
4544                          call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
4545                                                    tMe, 1, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4546                       end if
4547                    end if
4548                 end if
4549              end if
4550           end if
4551        end if
4552        !--- copy the overlapping information
4553        if( overlap%count > 0) then
4554          nsend = nsend + 1
4555          if(nsend > MAXLIST) call mpp_error(FATAL,  &
4556              "mpp_domains_define.inc(compute_overlaps_east): nsend is greater than MAXLIST, increase MAXLIST")
4557          call add_update_overlap(overlapList(nsend), overlap)
4558          call init_overlap_type(overlap)
4559        endif
4560     end do  ! end of send set up.
4561
4562     ! copy the overlapping information into domain data structure
4563     if(nsend>0) then
4564        update%nsend = nsend
4565        allocate(update%send(nsend))
4566        do m = 1, nsend
4567           call add_update_overlap( update%send(m), overlapList(m) )
4568        enddo
4569     endif
4570
4571    if(nsend_check>0) then
4572        check%nsend = nsend_check
4573        allocate(check%send(nsend_check))
4574        do m = 1, nsend_check
4575           call add_check_overlap( check%send(m), checkList(m) )
4576        enddo
4577     endif
4578
4579     do m = 1, MAXLIST
4580        call deallocate_overlap_type(overlapList(m))
4581        if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4582     enddo
4583
4584     isgd = isg - domain%whalo
4585     iegd = ieg + domain%ehalo
4586     jsgd = jsg - domain%shalo
4587     jegd = jeg + domain%nhalo
4588
4589     ! begin setting up recv
4590     nrecv = 0
4591     nrecv_check = 0
4592     do list = 0,nlist-1
4593        m = mod( domain%pos+nlist-list, nlist )
4594        if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then  ! only compute the overlapping within tile.
4595           isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4596           jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4597           !recv_e
4598           dir = 1
4599           folded = .false.
4600           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4601           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4602           is=isc; ie=iec; js=jsc; je=jec
4603           if( ied.GT.ieg )then
4604              folded = .true.
4605              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4606           end if
4607           if( (position == EAST .OR. position == CORNER ) .AND. (jsd == je .or. jed == js ) ) then
4608              !--- do nothing, this point will come from other pe
4609           else
4610              call insert_update_overlap(overlap, domain%list(m)%pe, &
4611                                         is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4612           end if
4613           !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4614           if(js .LT. jsg ) then
4615              js = js + joff
4616              call insert_update_overlap(overlap, domain%list(m)%pe, &
4617                                         is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4618           endif
4619
4620           !recv_se
4621           dir = 2
4622           folded = .false.
4623           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4624           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
4625           is=isc; ie=iec; js=jsc; je=jec
4626           if( ied.GT.ieg )then
4627              folded = .true.
4628              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4629           end if
4630           if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4631              js = js-joff; je = je-joff
4632           end if
4633           call insert_update_overlap(overlap, domain%list(m)%pe, &
4634                                      is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4635           !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4636           if(js .LT. jsg ) then
4637              js = js + joff
4638              call insert_update_overlap(overlap, domain%list(m)%pe, &
4639                                         is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4640           endif
4641
4642           !recv_s
4643           dir = 3
4644           folded = .false.
4645           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4646           jsd = domain%y(tMe)%data%begin;    jed = domain%y(tMe)%compute%begin-1
4647           is=isc; ie=iec; js=jsc; je=jec
4648
4649           if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4650              !--- do nothing, this point will come from other pe
4651           else
4652              if( jsd.LT.jsg .AND. js .GT. jed)then
4653                 js = js-joff; je = je-joff
4654              end if
4655              !--- when the east face is folded, the south halo points at
4656              !--- the position should be on CORNER or EAST
4657              if( ied == ieg .AND. (position == CORNER .OR. position == EAST) &
4658                   .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
4659                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4660                                             is, ie, js, je, isd, ied-1, jsd, jed, dir)
4661                 is=isc; ie=iec; js=jsc; je=jec
4662                 if(jsd<jsg) then
4663                    select case (position)
4664                    case(EAST)
4665                       j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4666                    case(CORNER)
4667                       j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4668                    end select
4669                    if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4670                         'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4671                 else
4672                    select case (position)
4673                    case(EAST)
4674                       j=js; js = jsg+jeg-je; je = jsg+jeg-j
4675                    case(CORNER)
4676                       j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4677                    end select
4678                 end if
4679                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4680                                             is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4681              else
4682                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4683                                             is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4684              end if
4685           endif
4686
4687           !recv_sw
4688           dir = 4
4689           isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4690           jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4691           is=isc; ie=iec; js=jsc; je=jec
4692           if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
4693              js = js-joff; je = je-joff
4694           end if
4695           call insert_update_overlap(overlap, domain%list(m)%pe, &
4696                                      is, ie, js, je, isd, ied, jsd, jed, dir)
4697
4698           !recv_w
4699           dir = 5
4700           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
4701           jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4702           is=isc; ie=iec; js=jsc; je=jec
4703           call insert_update_overlap( overlap, domain%list(m)%pe, &
4704                                       is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4705
4706           !recv_nw
4707           dir = 6
4708           folded = .false.
4709           isd = domain%x(tMe)%data%begin;    ied = domain%x(tMe)%compute%begin-1
4710           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4711           is=isc; ie=iec; js=jsc; je=jec
4712           if(  jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4713              js = js+joff; je = je+joff
4714           end if
4715           call insert_update_overlap( overlap, domain%list(m)%pe, &
4716                                       is, ie, js, je, isd, ied, jsd, jed, dir)
4717
4718           !recv_n
4719           dir = 7
4720           folded = .false.
4721           isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4722           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4723           is=isc; ie=iec; js=jsc; je=jec
4724           if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4725              !--- do nothing, this point will come from other pe
4726           else
4727              if( jed.GT.jeg .AND. je.LT.jsd)then
4728                 js = js+joff; je = je+joff
4729              end if
4730              !--- when the east face is folded, the south halo points at
4731              !--- the position should be on CORNER or EAST
4732              if( ied == ieg .AND. (position == CORNER .OR. position == EAST) &
4733                   .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4734                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4735                                             is, ie, js, je, isd, ied-1, jsd, jed, dir)
4736                 is=isc; ie=iec; js=jsc; je=jec
4737                 select case (position)
4738                 case(EAST)
4739                    j=js; js = jsg+jeg-je; je = jsg+jeg-j
4740                 case(CORNER)
4741                    j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4742                 end select
4743                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4744                                             is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4745              else
4746                 call insert_update_overlap( overlap, domain%list(m)%pe, &
4747                                             is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4748              end if
4749           endif
4750
4751           !recv_ne
4752           dir = 8
4753           folded = .false.
4754           isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4755           jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4756           is=isc; ie=iec; js=jsc; je=jec
4757           if( ied.GT.ieg) then
4758              folded = .true.
4759              call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4760           end if
4761           if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4762              js = js+joff; je = je+joff
4763           endif
4764
4765           call insert_update_overlap( overlap, domain%list(m)%pe, &
4766                                       is, ie, js, je, isd, ied, jsd, jed, dir)
4767           !--- Now calculate the overlapping for fold-edge.
4768           !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4769           !--- only position at EAST and CORNER need to be considered
4770           if( ( position == EAST .OR. position == CORNER) ) then
4771              if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold
4772                                                                                                     !! is within domain
4773                 dir = 1
4774                 !--- calculating overlapping for receving on north
4775                 if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then
4776                    ied = domain%x(tMe)%compute%end+ishift;   isd = ied
4777                    if( ied == ieg )then   ! fold is within domain.
4778                       jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4779                       is=isc; ie=iec; js = jsc; je = jec
4780                       select case (position)
4781                       case(EAST)
4782                          jsd = max(jsd, middle)
4783                          j=js; js = jsg+jeg-je; je = jsg+jeg-j
4784                       case(CORNER)
4785                          jsd = max(jsd, middle)
4786                          j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4787                       end select
4788                       call insert_update_overlap(overlap, domain%list(m)%pe, &
4789                                                  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
4790                       is = max(is, isd); ie = min(ie, ied)
4791                       js = max(js, jsd); je = min(je, jed)
4792                       if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4793                          nrecv_check = nrecv_check+1
4794                          call allocate_check_overlap(checkList(nrecv_check), 1)
4795                          call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
4796                                                    tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4797                       endif
4798                    endif
4799                 endif
4800              endif
4801           endif
4802        endif
4803        !--- copy the overlapping information
4804        if( overlap%count > 0) then
4805           nrecv = nrecv + 1
4806          if(nrecv > MAXLIST) call mpp_error(FATAL,  &
4807              "mpp_domains_define.inc(compute_overlaps_east): nrecv is greater than MAXLIST, increase MAXLIST")
4808           call add_update_overlap( overlapList(nrecv), overlap)
4809           call init_overlap_type(overlap)
4810        endif
4811     enddo ! end of recv do loop
4812
4813     ! copy the overlapping information into domain
4814     if(nrecv>0) then
4815        update%nrecv = nrecv
4816        allocate(update%recv(nrecv))
4817        do m = 1, nrecv
4818           call add_update_overlap( update%recv(m), overlapList(m) )
4819           do n = 1, update%recv(m)%count
4820              if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
4821                 if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
4822                 if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
4823              endif
4824           enddo
4825        enddo
4826     endif
4827
4828     if(nrecv_check>0) then
4829        check%nrecv = nrecv_check
4830        allocate(check%recv(nrecv_check))
4831        do m = 1, nrecv_check
4832           call add_check_overlap( check%recv(m), checkList(m) )
4833        enddo
4834     endif
4835
4836     call deallocate_overlap_type(overlap)
4837     do m = 1, MAXLIST
4838        call deallocate_overlap_type(overlapList(m))
4839        if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4840     enddo
4841
4842     update=>NULL()
4843     check=>NULL()
4844
4845     domain%initialized = .true.
4846
4847   end subroutine compute_overlaps_fold_east
4848
4849   !#####################################################################################
4850   subroutine get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4851     integer,    intent(in) :: jsg, jeg, isg, jshift, position
4852     integer, intent(inout) :: is, ie, js, je
4853     integer                :: i, j
4854
4855     select case(position)
4856     case(CENTER)
4857        j=js; js = jsg+jeg-je; je = jsg+jeg-j
4858        i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4859     case(EAST)
4860        j=js; js = jsg+jeg-je; je = jsg+jeg-j
4861        i=is; is = 2*isg-ie; ie = 2*isg-i
4862     case(NORTH)
4863        j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4864        i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4865     case(CORNER)
4866        j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4867        i=is; is = 2*isg-ie; ie = 2*isg-i
4868     end select
4869
4870   end subroutine get_fold_index_west
4871
4872   !#####################################################################################
4873   subroutine get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4874     integer,    intent(in) :: jsg, jeg, ieg, jshift, position
4875     integer, intent(inout) :: is, ie, js, je
4876     integer                :: i, j
4877
4878     select case(position)
4879     case(CENTER)
4880        j=js; js = jsg+jeg-je; je = jsg+jeg-j
4881        i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4882     case(EAST)
4883        j=js; js = jsg+jeg-je; je = jsg+jeg-j
4884        i=is; is = 2*ieg-ie; ie = 2*ieg-i
4885     case(NORTH)
4886        j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4887        i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4888     case(CORNER)
4889        j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4890        i=is; is = 2*ieg-ie; ie = 2*ieg-i
4891     end select
4892
4893   end subroutine get_fold_index_east
4894
4895   !#####################################################################################
4896   subroutine get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
4897     integer,    intent(in) :: isg, ieg, jsg, ishift, position
4898     integer, intent(inout) :: is, ie, js, je
4899     integer                :: i, j
4900
4901     select case(position)
4902     case(CENTER)
4903        i=is; is = isg+ieg-ie; ie = isg+ieg-i
4904        j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4905     case(EAST)
4906        i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4907        j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4908     case(NORTH)
4909        i=is; is = isg+ieg-ie; ie = isg+ieg-i
4910        j=js; js = 2*jsg-je; je = 2*jsg-j
4911     case(CORNER)
4912        i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4913        j=js; js = 2*jsg-je; je = 2*jsg-j
4914     end select
4915
4916   end subroutine get_fold_index_south
4917   !#####################################################################################
4918   subroutine get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
4919     integer,    intent(in) :: isg, ieg, jeg, ishift, position
4920     integer, intent(inout) :: is, ie, js, je
4921     integer                :: i, j
4922
4923     select case(position)
4924     case(CENTER)
4925        i=is; is = isg+ieg-ie; ie = isg+ieg-i
4926        j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4927     case(EAST)
4928        i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4929        j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4930     case(NORTH)
4931        i=is; is = isg+ieg-ie; ie = isg+ieg-i
4932        j=js; js = 2*jeg-je; je = 2*jeg-j
4933     case(CORNER)
4934        i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4935        j=js; js = 2*jeg-je; je = 2*jeg-j
4936     end select
4937
4938   end subroutine get_fold_index_north
4939
4940
4941   !#####################################################################################
4942   ! add offset to the index
4943   subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
4944     integer, intent(inout) :: lstart, lend
4945     integer, intent(in   ) :: offset, gstart, gend, gsize
4946
4947     lstart = lstart + offset
4948     if(lstart > gend)   lstart = lstart - gsize
4949     if(lstart < gstart) lstart = lstart + gsize
4950     lend = lend + offset
4951     if(lend > gend)     lend   = lend   - gsize
4952     if(lend < gstart)   lend   = lend   + gsize
4953
4954     return
4955
4956   end subroutine apply_cyclic_offset
4957
4958   !###################################################################################
4959   ! this routine setup the overlapping for mpp_update_domains for arbitrary halo update.
4960   ! should be the halo size defined in mpp_define_domains.
4961   ! xhalo_out, yhalo_out should not be exactly the same as xhalo_in, yhalo_in
4962   ! currently we didn't consider about tripolar grid situation, because in the folded north
4963   ! region, the overlapping is specified through list of points, not through rectangular.
4964   ! But will return back to solve this problem in the future.
4965   subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
4966     type(domain2d),    intent(in)    :: domain
4967     type(overlapSpec), intent(in)    :: overlap_in
4968     type(overlapSpec), intent(inout) :: overlap_out
4969     integer,           intent(in)    :: whalo_out, ehalo_out, shalo_out, nhalo_out
4970     integer                          :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation
4971     integer                          :: whalo_in, ehalo_in, shalo_in, nhalo_in
4972     integer                          :: dir
4973     type(overlap_type)               :: overlap
4974     type(overlap_type), allocatable  :: send(:), recv(:)
4975     type(overlap_type), pointer      :: ptrIn  => NULL()
4976     integer                          :: nsend, nrecv, nsend_in, nrecv_in
4977
4978     if( domain%fold .NE. 0) call mpp_error(FATAL, "mpp_domains_define.inc(set_overlaps):"// &
4979                                & " folded domain is not implemented for arbitrary halo update, contact developer")
4980
4981     whalo_in = domain%whalo
4982     ehalo_in = domain%ehalo
4983     shalo_in = domain%shalo
4984     nhalo_in = domain%nhalo
4985
4986     if( .NOT. domain%initialized) call mpp_error(FATAL, &
4987          "mpp_domains_define.inc: domain is not defined yet")
4988
4989     nlist = size(domain%list(:))
4990     isoff = whalo_in - abs(whalo_out)
4991     ieoff = ehalo_in - abs(ehalo_out)
4992     jsoff = shalo_in - abs(shalo_out)
4993     jeoff = nhalo_in - abs(nhalo_out)
4994
4995     nsend = 0
4996     nsend_in = overlap_in%nsend
4997     nrecv_in = overlap_in%nrecv
4998     if(nsend_in>0) allocate(send(nsend_in))
4999     if(nrecv_in>0) allocate(recv(nrecv_in))
5000     call allocate_update_overlap(overlap, MAXOVERLAP)
5001
5002     overlap_out%whalo  = whalo_out
5003     overlap_out%ehalo  = ehalo_out
5004     overlap_out%shalo  = shalo_out
5005     overlap_out%nhalo  = nhalo_out
5006     overlap_out%xbegin = overlap_in%xbegin
5007     overlap_out%xend   = overlap_in%xend
5008     overlap_out%ybegin = overlap_in%ybegin
5009     overlap_out%yend   = overlap_in%yend
5010
5011     !--- setting up overlap.
5012     do m = 1, nsend_in
5013        ptrIn  => overlap_in%send(m)
5014        if(ptrIn%count .LE. 0) call mpp_error(FATAL, "mpp_domains_define.inc(set_overlaps):"// &
5015                               " number of overlap for send should be a positive number for"//trim(domain%name) )
5016        do n = 1, ptrIn%count
5017           dir = ptrIn%dir(n)
5018           rotation = ptrIn%rotation(n)
5019           select case(dir)
5020           case(1) ! to_pe's eastern halo
5021              if(ehalo_out > 0) then
5022                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir, rotation)
5023              else if(ehalo_out<0) then
5024                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir, rotation)
5025              end if
5026           case(2) ! to_pe's southeast halo
5027              if(ehalo_out>0 .AND. shalo_out > 0) then
5028                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation)
5029              else if(ehalo_out<0 .AND. shalo_out < 0) then ! three parts: southeast, south and east.
5030                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation)
5031                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation)
5032                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation)
5033              end if
5034           case(3) ! to_pe's southern halo
5035              if(shalo_out > 0) then
5036                 call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir, rotation)
5037              else if(shalo_out<0) then
5038                 call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir, rotation)
5039              end if
5040           case(4) ! to_pe's southwest halo
5041              if(whalo_out>0 .AND. shalo_out > 0) then
5042                 call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir, rotation)
5043              else if(whalo_out<0 .AND. shalo_out < 0) then
5044                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation)
5045                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation)
5046                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation)
5047              end if
5048           case(5) ! to_pe's western halo
5049              if(whalo_out > 0) then
5050                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir, rotation)
5051              else if(whalo_out<0) then
5052                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir, rotation)
5053              end if
5054           case(6) ! to_pe's northwest halo
5055              if(whalo_out>0 .AND. nhalo_out > 0) then
5056                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir, rotation)
5057              else if(whalo_out<0 .AND. nhalo_out < 0) then
5058                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation)
5059                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation)
5060                 call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation)
5061              end if
5062           case(7) ! to_pe's northern halo
5063              if(nhalo_out > 0) then
5064                 call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir, rotation)
5065              else if(nhalo_out<0) then
5066                 call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir, rotation)
5067              end if
5068           case(8) ! to_pe's northeast halo
5069              if(ehalo_out>0 .AND. nhalo_out > 0) then
5070                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation)
5071              else if(ehalo_out<0 .AND. nhalo_out < 0) then
5072                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation)
5073                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation)
5074                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation)
5075              end if
5076           end select
5077        end do ! do n = 1, ptrIn%count
5078        if(overlap%count>0) then
5079           nsend = nsend+1
5080           call add_update_overlap(send(nsend), overlap)
5081           call init_overlap_type(overlap)
5082        endif
5083     end do ! end do list = 0, nlist-1
5084
5085     if(nsend>0) then
5086        overlap_out%nsend = nsend
5087        allocate(overlap_out%send(nsend));
5088        do n = 1, nsend
5089           call add_update_overlap(overlap_out%send(n), send(n) )
5090        enddo
5091     else
5092        overlap_out%nsend = 0
5093     endif
5094
5095     !--------------------------------------------------
5096     !                     recving
5097     !---------------------------------------------------
5098     overlap%count = 0
5099     nrecv = 0
5100     do m = 1, nrecv_in
5101        ptrIn  => overlap_in%recv(m)
5102        if(ptrIn%count .LE. 0) call mpp_error(FATAL, &
5103           "mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number")
5104        overlap%count = 0
5105        do n = 1, ptrIn%count
5106           dir = ptrIn%dir(n)
5107           rotation = ptrIn%rotation(n)
5108           select case(dir)
5109           case(1) ! eastern halo
5110              if(ehalo_out > 0) then
5111                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir)
5112              else if(ehalo_out<0) then
5113                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir)
5114              end if
5115           case(2) ! southeast halo
5116              if(ehalo_out>0 .AND. shalo_out > 0) then
5117                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir)
5118              else if(ehalo_out<0 .AND. shalo_out < 0) then
5119                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir)
5120                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1)
5121                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1)
5122              end if
5123           case(3) ! southern halo
5124              if(shalo_out > 0) then
5125                 call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir)
5126              else if(shalo_out<0) then
5127                 call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir)
5128              end if
5129           case(4) ! southwest halo
5130              if(whalo_out>0 .AND. shalo_out > 0) then
5131                 call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir)
5132              else if(whalo_out<0 .AND. shalo_out < 0) then
5133                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir)
5134                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1)
5135                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1)
5136              end if
5137           case(5) ! western halo
5138              if(whalo_out > 0) then
5139                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir)
5140              else if(whalo_out<0) then
5141                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir)
5142              end if
5143           case(6) ! northwest halo
5144              if(whalo_out>0 .AND. nhalo_out > 0) then
5145                 call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir)
5146              else if(whalo_out<0 .AND. nhalo_out < 0) then
5147                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir)
5148                 call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1)
5149                 call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1)
5150              end if
5151           case(7) ! northern halo
5152              if(nhalo_out > 0) then
5153                 call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir)
5154              else if(nhalo_out<0) then
5155                 call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir)
5156              end if
5157           case(8) ! northeast halo
5158              if(ehalo_out>0 .AND. nhalo_out > 0) then
5159                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir)
5160              else if(ehalo_out<0 .AND. nhalo_out < 0) then
5161                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir)
5162                 call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1)
5163                 call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1)
5164              end if
5165           end select
5166        end do ! do n = 1, ptrIn%count
5167        if(overlap%count>0) then
5168           nrecv = nrecv+1
5169           call add_update_overlap(recv(nrecv), overlap)
5170           call init_overlap_type(overlap)
5171        endif
5172     end do ! end do list = 0, nlist-1
5173
5174     if(nrecv>0) then
5175        overlap_out%nrecv = nrecv
5176        allocate(overlap_out%recv(nrecv));
5177        do n = 1, nrecv
5178           call add_update_overlap(overlap_out%recv(n), recv(n) )
5179        enddo
5180     else
5181        overlap_out%nrecv = 0
5182     endif
5183
5184     call deallocate_overlap_type(overlap)
5185     do n = 1, nsend_in
5186        call deallocate_overlap_type(send(n))
5187     enddo
5188     do n = 1, nrecv_in
5189        call deallocate_overlap_type(recv(n))
5190     enddo
5191     if(allocated(send)) deallocate(send)
5192     if(allocated(recv)) deallocate(recv)
5193     ptrIn => NULL()
5194
5195     call  set_domain_comm_inf(overlap_out)
5196
5197
5198   end subroutine set_overlaps
5199
5200  !##############################################################################
5201   subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation)
5202     type(overlap_type),    intent(in) :: overlap_in
5203     type(overlap_type), intent(inout) :: overlap_out
5204     integer,               intent(in) :: isoff, jsoff, ieoff, jeoff
5205     integer,               intent(in) :: index
5206     integer,               intent(in) :: dir
5207     integer, optional,     intent(in) :: rotation
5208     integer                           :: rotate
5209     integer                           :: count
5210
5211     if( overlap_out%pe == NULL_PE ) then
5212        overlap_out%pe  = overlap_in%pe
5213     else
5214        if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL,  &
5215             "mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out")
5216     endif
5217
5218     if(isoff .NE. 0 .and. ieoff .NE. 0) call mpp_error(FATAL,  &
5219           "mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero")
5220     if(jsoff .NE. 0 .and. jeoff .NE. 0) call mpp_error(FATAL,  &
5221           "mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero")
5222
5223
5224     overlap_out%count = overlap_out%count + 1
5225     count = overlap_out%count
5226     if(count > MAXOVERLAP) call mpp_error(FATAL, &
5227          "set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
5228     rotate = ZERO
5229     if(present(rotation)) rotate = rotation
5230     overlap_out%rotation  (count) = overlap_in%rotation(index)
5231     overlap_out%dir       (count) = dir
5232     overlap_out%tileMe    (count) = overlap_in%tileMe(index)
5233     overlap_out%tileNbr   (count) = overlap_in%tileNbr(index)
5234
5235     select case(rotate)
5236     case(ZERO)
5237        overlap_out%is(count)      = overlap_in%is(index) + isoff
5238        overlap_out%ie(count)      = overlap_in%ie(index) + ieoff
5239        overlap_out%js(count)      = overlap_in%js(index) + jsoff
5240        overlap_out%je(count)      = overlap_in%je(index) + jeoff
5241     case(NINETY)
5242        overlap_out%is(count)      = overlap_in%is(index) - jeoff
5243        overlap_out%ie(count)      = overlap_in%ie(index) - jsoff
5244        overlap_out%js(count)      = overlap_in%js(index) + isoff
5245        overlap_out%je(count)      = overlap_in%je(index) + ieoff
5246     case(MINUS_NINETY)
5247        overlap_out%is(count)      = overlap_in%is(index) + jsoff
5248        overlap_out%ie(count)      = overlap_in%ie(index) + jeoff
5249        overlap_out%js(count)      = overlap_in%js(index) - ieoff
5250        overlap_out%je(count)      = overlap_in%je(index) - isoff
5251     case default
5252        call mpp_error(FATAL, "mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY")
5253     end select
5254
5255   end subroutine set_single_overlap
5256
5257   !###################################################################################
5258   !--- compute the overlapping between tiles for the T-cell.
5259   subroutine define_contact_point( domain, position, num_contact, tile1, tile2, align1, align2, &
5260        refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2,        &
5261        isgList, iegList, jsgList, jegList )
5262     type(domain2D),     intent(inout) :: domain
5263     integer,               intent(in) :: position
5264     integer,               intent(in) :: num_contact      ! number of contact regions
5265     integer, dimension(:), intent(in) :: tile1, tile2     ! tile number
5266     integer, dimension(:), intent(in) :: align1, align2   ! align direction of contact region
5267     real,    dimension(:), intent(in) :: refine1, refine2 ! refinement between tiles
5268     integer, dimension(:), intent(in) :: istart1, iend1   ! i-index in tile_1 of contact region
5269     integer, dimension(:), intent(in) :: jstart1, jend1   ! j-index in tile_1 of contact region
5270     integer, dimension(:), intent(in) :: istart2, iend2   ! i-index in tile_2 of contact region
5271     integer, dimension(:), intent(in) :: jstart2, jend2   ! j-index in tile_2 of contact region
5272     integer, dimension(:), intent(in) :: isgList, iegList ! i-global domain of each tile
5273     integer, dimension(:), intent(in) :: jsgList, jegList ! j-global domain of each tile
5274
5275     integer              :: isc, iec, jsc, jec, isd, ied, jsd, jed
5276     integer              :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2
5277     integer              :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2
5278     integer              :: is, ie, js, je, ioff, joff
5279     integer              :: ntiles, max_contact
5280     integer              :: nlist, list, m, n, l, count, numS, numR
5281     integer              :: whalo, ehalo, shalo, nhalo
5282     integer              :: t1, t2, tt, pos
5283     integer              :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir
5284     integer              :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem
5285     integer              :: dirlist(8)
5286     !--- is2Send and is1Send will figure out the overlapping for sending from current pe.
5287     !--- is1Recv and iscREcv will figure out the overlapping for recving onto current pe.
5288     integer, dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send
5289     integer, dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send
5290     integer, dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv
5291     integer, dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv
5292     integer, dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send
5293     real,    dimension(4*num_contact) :: refineRecv, refineSend
5294     integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
5295     integer                           :: nsend, nrecv, nsend2, nrecv2
5296     type(contact_type), dimension(domain%ntiles)            :: eCont, wCont, sCont, nCont
5297     type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
5298     integer                                                 :: unit
5299
5300     if( position .NE. CENTER )  call mpp_error(FATAL,  "mpp_domains_define.inc: " //&
5301          "routine define_contact_point can only be used to calculate overlapping for cell center.")
5302
5303     ntiles  = domain%ntiles
5304
5305     eCont(:)%ncontact = 0
5306
5307     do n = 1, ntiles
5308        eCont(n)%ncontact = 0; sCont(n)%ncontact = 0; wCont(n)%ncontact = 0; nCont(n)%ncontact = 0;
5309        allocate(eCont(n)%tile(num_contact), wCont(n)%tile(num_contact) )
5310        allocate(nCont(n)%tile(num_contact), sCont(n)%tile(num_contact) )
5311        allocate(eCont(n)%align1(num_contact), eCont(n)%align2(num_contact) )
5312        allocate(wCont(n)%align1(num_contact), wCont(n)%align2(num_contact) )
5313        allocate(sCont(n)%align1(num_contact), sCont(n)%align2(num_contact) )
5314        allocate(nCont(n)%align1(num_contact), nCont(n)%align2(num_contact) )
5315        allocate(eCont(n)%refine1(num_contact), eCont(n)%refine2(num_contact) )
5316        allocate(wCont(n)%refine1(num_contact), wCont(n)%refine2(num_contact) )
5317        allocate(sCont(n)%refine1(num_contact), sCont(n)%refine2(num_contact) )
5318        allocate(nCont(n)%refine1(num_contact), nCont(n)%refine2(num_contact) )
5319        allocate(eCont(n)%is1(num_contact), eCont(n)%ie1(num_contact), eCont(n)%js1(num_contact), &
5320                &  eCont(n)%je1(num_contact))
5321        allocate(eCont(n)%is2(num_contact), eCont(n)%ie2(num_contact), eCont(n)%js2(num_contact), &
5322                &  eCont(n)%je2(num_contact))
5323        allocate(wCont(n)%is1(num_contact), wCont(n)%ie1(num_contact), wCont(n)%js1(num_contact), &
5324                &  wCont(n)%je1(num_contact))
5325        allocate(wCont(n)%is2(num_contact), wCont(n)%ie2(num_contact), wCont(n)%js2(num_contact), &
5326                &  wCont(n)%je2(num_contact))
5327        allocate(sCont(n)%is1(num_contact), sCont(n)%ie1(num_contact), sCont(n)%js1(num_contact), &
5328                &  sCont(n)%je1(num_contact))
5329        allocate(sCont(n)%is2(num_contact), sCont(n)%ie2(num_contact), sCont(n)%js2(num_contact), &
5330                &  sCont(n)%je2(num_contact))
5331        allocate(nCont(n)%is1(num_contact), nCont(n)%ie1(num_contact), nCont(n)%js1(num_contact), &
5332                &  nCont(n)%je1(num_contact))
5333        allocate(nCont(n)%is2(num_contact), nCont(n)%ie2(num_contact), nCont(n)%js2(num_contact), &
5334                &  nCont(n)%je2(num_contact))
5335     end do
5336
5337     !--- set up the east, south, west and north contact for each tile.
5338     do n = 1, num_contact
5339        t1 = tile1(n)
5340        t2 = tile2(n)
5341        select case(align1(n))
5342        case (EAST)
5343           call fill_contact( eCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5344                jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5345        case (WEST)
5346           call fill_contact( wCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5347                jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5348        case (SOUTH)
5349           call fill_contact( sCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5350                jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5351        case (NORTH)
5352           call fill_contact( nCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5353                jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5354        end select
5355        select case(align2(n))
5356        case (EAST)
5357           call fill_contact( eCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5358                jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5359        case (WEST)
5360           call fill_contact( wCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5361                jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5362        case (SOUTH)
5363           call fill_contact( sCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5364                jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5365        case (NORTH)
5366           call fill_contact( nCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5367                jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5368        end select
5369     end do
5370
5371     !--- the tile number of current pe, halo size
5372     whalo = domain%whalo
5373     ehalo = domain%ehalo
5374     shalo = domain%shalo
5375     nhalo = domain%nhalo
5376
5377     !--- find if there is an extra point in x and y direction depending on position
5378     nlist = size(domain%list(:))
5379
5380     max_contact = 4*num_contact ! should be enough
5381
5382     ntileMe = size(domain%x(:))
5383     refineSend = 1; refineRecv = 1
5384
5385     !--------------------------------------------------------------------------------------------------
5386     !    loop over each tile on current domain to set up the overlapping for each tile
5387     !--------------------------------------------------------------------------------------------------
5388     !--- first check the overlap within the tiles.
5389     do n = 1, domain%update_T%nsend
5390        pos = domain%update_T%send(n)%pe - mpp_root_pe()
5391        call add_update_overlap(overlapSend(pos), domain%update_T%send(n) )
5392     enddo
5393     do n = 1, domain%update_T%nrecv
5394        pos = domain%update_T%recv(n)%pe - mpp_root_pe()
5395        call add_update_overlap(overlapRecv(pos), domain%update_T%recv(n) )
5396     enddo
5397
5398     call mpp_get_memory_domain(domain, ism, iem, jsm, jem)
5399     domain%update_T%xbegin = ism;   domain%update_T%xend  = iem
5400     domain%update_T%ybegin = jsm;   domain%update_T%yend  = jem
5401     domain%update_T%whalo  = whalo; domain%update_T%ehalo = ehalo
5402     domain%update_T%shalo  = shalo; domain%update_T%nhalo = nhalo
5403
5404     do tMe = 1, ntileMe
5405        tileMe = domain%tile_id(tMe)
5406        rotateSend = ZERO; rotateRecv = ZERO
5407
5408        !--- loop over all the contact region to figure out the index for overlapping region.
5409        count = 0
5410        do n = 1, eCont(tileMe)%ncontact  ! east contact
5411           count = count+1
5412           tileRecv(count)   = eCont(tileMe)%tile(n);    tileSend(count)   = eCont(tileMe)%tile(n)
5413           align1Recv(count) = eCont(tileMe)%align1(n);  align2Recv(count) = eCont(tileMe)%align2(n)
5414           align1Send(count) = eCont(tileMe)%align1(n);  align2Send(count) = eCont(tileMe)%align2(n)
5415           refineSend(count) = eCont(tileMe)%refine2(n); refineRecv(count) = eCont(tileMe)%refine1(n)
5416           is1Recv(count)    = eCont(tileMe)%is1(n) + 1; ie1Recv(count)    = is1Recv(count) + ehalo - 1
5417           js1Recv(count)    = eCont(tileMe)%js1(n);     je1Recv(count)    = eCont(tileMe)%je1(n)
5418           select case(eCont(tileMe)%align2(n))
5419           case ( WEST )  ! w <-> e
5420              is2Recv(count) = eCont(tileMe)%is2(n);     ie2Recv(count) = is2Recv(count) + ehalo - 1
5421              js2Recv(count) = eCont(tileMe)%js2(n);     je2Recv(count) = eCont(tileMe)%je2(n)
5422              ie1Send(count) = eCont(tileMe)%is1(n);     is1Send(count) = ie1Send(count) - whalo + 1
5423              js1Send(count) = eCont(tileMe)%js1(n);     je1Send(count) = eCont(tileMe)%je1(n)
5424              ie2Send(count) = eCont(tileMe)%is2(n) - 1; is2Send(count) = ie2Send(count) - whalo + 1
5425              js2Send(count) = eCont(tileMe)%js2(n);     je2Send(count) = eCont(tileMe)%je2(n)
5426           case ( SOUTH ) ! s <-> e
5427              rotateRecv(count) = NINETY;                rotateSend(count) = MINUS_NINETY
5428              js2Recv(count) = eCont(tileMe)%js2(n);     je2Recv(count) = js2Recv(count) + ehalo -1
5429              is2Recv(count) = eCont(tileMe)%is2(n);     ie2Recv(count) = eCont(tileMe)%ie2(n)
5430              ie1Send(count) = eCont(tileMe)%is1(n);     is1Send(count) = ie1Send(count) - shalo + 1
5431              js1Send(count) = eCont(tileMe)%js1(n);     je1Send(count) = eCont(tileMe)%je1(n)
5432              is2Send(count) = eCont(tileMe)%is2(n);     ie2Send(count) = eCont(tileMe)%ie2(n)
5433              je2Send(count) = eCont(tileMe)%js2(n) - 1; js2Send(count) = je2Send(count) - shalo + 1
5434           end select
5435        end do
5436
5437        do n = 1, sCont(tileMe)%ncontact  ! south contact
5438           count = count+1
5439           tileRecv(count)   = sCont(tileMe)%tile(n);    tileSend(count)   = sCont(tileMe)%tile(n)
5440           align1Recv(count) = sCont(tileMe)%align1(n);  align2Recv(count) = sCont(tileMe)%align2(n);
5441           align1Send(count) = sCont(tileMe)%align1(n);  align2Send(count) = sCont(tileMe)%align2(n);
5442           refineSend(count) = sCont(tileMe)%refine2(n); refineRecv(count) = sCont(tileMe)%refine1(n)
5443           is1Recv(count)    = sCont(tileMe)%is1(n);     ie1Recv(count)    = sCont(tileMe)%ie1(n)
5444           je1Recv(count)    = sCont(tileMe)%js1(n) - 1; js1Recv(count)    = je1Recv(count) - shalo + 1
5445           select case(sCont(tileMe)%align2(n))
5446           case ( NORTH ) ! n <-> s
5447              is2Recv(count) = sCont(tileMe)%is2(n);   ie2Recv(count) = sCont(tileMe)%ie2(n)
5448              je2Recv(count) = sCont(tileMe)%je2(n);   js2Recv(count) = je2Recv(count) - shalo + 1
5449              is1Send(count) = sCont(tileMe)%is1(n);   ie1Send(count) = sCont(tileMe)%ie1(n)
5450              js1Send(count) = sCont(tileMe)%js1(n);   je1Send(count) = js1Send(count) + nhalo -1
5451              is2Send(count) = sCont(tileMe)%is2(n);   ie2Send(count) = sCont(tileMe)%ie2(n)
5452              js2Send(count) = sCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
5453           case ( EAST )  ! e <-> s
5454              rotateRecv(count) = MINUS_NINETY;        rotateSend(count) = NINETY
5455              ie2Recv(count) = sCont(tileMe)%ie2(n);   is2Recv(count) = ie2Recv(count) - shalo + 1
5456              js2Recv(count) = sCont(tileMe)%js2(n);   je2Recv(count) = sCont(tileMe)%je2(n)
5457              is1Send(count) = sCont(tileMe)%is1(n);   ie1Send(count) = sCont(tileMe)%ie1(n)
5458              js1Send(count) = sCont(tileMe)%js1(n);   je1Send(count) = js1Send(count) + ehalo - 1
5459              is2Send(count) = sCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
5460              js2Send(count) = sCont(tileMe)%js2(n);   je2Send(count) = sCont(tileMe)%je2(n)
5461           end select
5462        end do
5463
5464        do n = 1, wCont(tileMe)%ncontact  ! west contact
5465           count = count+1
5466           tileRecv(count)   = wCont(tileMe)%tile(n);    tileSend(count)   = wCont(tileMe)%tile(n)
5467           align1Recv(count) = wCont(tileMe)%align1(n);  align2Recv(count) = wCont(tileMe)%align2(n);
5468           align1Send(count) = wCont(tileMe)%align1(n);  align2Send(count) = wCont(tileMe)%align2(n);
5469           refineSend(count) = wCont(tileMe)%refine2(n); refineRecv(count) = wCont(tileMe)%refine1(n)
5470           ie1Recv(count)    = wCont(tileMe)%is1(n) - 1; is1Recv(count)    = ie1Recv(count) - whalo + 1
5471           js1Recv(count)    = wCont(tileMe)%js1(n);     je1Recv(count)    = wCont(tileMe)%je1(n)
5472           select case(wCont(tileMe)%align2(n))
5473           case ( EAST )  ! e <-> w
5474              ie2Recv(count) = wCont(tileMe)%ie2(n);   is2Recv(count) = ie2Recv(count) - whalo + 1
5475              js2Recv(count) = wCont(tileMe)%js2(n);   je2Recv(count) = wCont(tileMe)%je2(n)
5476              is1Send(count) = wCont(tileMe)%is1(n);   ie1Send(count) = is1Send(count) + ehalo - 1
5477              js1Send(count) = wCont(tileMe)%js1(n);   je1Send(count) = wCont(tileMe)%je1(n)
5478              is2Send(count) = wCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
5479              js2Send(count) = wCont(tileMe)%js2(n);   je2Send(count) = wCont(tileMe)%je2(n)
5480           case ( NORTH ) ! n <-> w
5481              rotateRecv(count) = NINETY;              rotateSend(count) = MINUS_NINETY
5482              je2Recv(count) = wCont(tileMe)%je2(n);   js2Recv(count) = je2Recv(count) - whalo + 1
5483              is2Recv(count) = wCont(tileMe)%is2(n);   ie2Recv(count) = wCont(tileMe)%ie2(n)
5484              is1Send(count) = wCont(tileMe)%is1(n);   ie1Send(count) = is1Send(count) + nhalo - 1
5485              js1Send(count) = wCont(tileMe)%js1(n);   je1Send(count) = wCont(tileMe)%je1(n)
5486              js2Send(count) = wCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
5487              is2Send(count) = wCont(tileMe)%is2(n);   ie2Send(count) = wCont(tileMe)%ie2(n)
5488           end select
5489        end do
5490
5491        do n = 1, nCont(tileMe)%ncontact  ! north contact
5492           count = count+1
5493           tileRecv(count)   = nCont(tileMe)%tile(n);   tileSend(count)   = nCont(tileMe)%tile(n)
5494           align1Recv(count) = nCont(tileMe)%align1(n); align2Recv(count) = nCont(tileMe)%align2(n);
5495           align1Send(count) = nCont(tileMe)%align1(n); align2Send(count) = nCont(tileMe)%align2(n);
5496           refineSend(count) = nCont(tileMe)%refine2(n); refineRecv(count) = nCont(tileMe)%refine1(n)
5497           is1Recv(count)    = nCont(tileMe)%is1(n);    ie1Recv(count)    = nCont(tileMe)%ie1(n)
5498           js1Recv(count)    = nCont(tileMe)%je1(n)+1;  je1Recv(count)    = js1Recv(count) + nhalo - 1
5499           select case(nCont(tileMe)%align2(n))
5500           case ( SOUTH ) ! s <-> n
5501              is2Recv(count) = nCont(tileMe)%is2(n);   ie2Recv(count) = nCont(tileMe)%ie2(n)
5502              js2Recv(count) = nCont(tileMe)%js2(n);   je2Recv(count) = js2Recv(count) + nhalo - 1
5503              is1Send(count) = nCont(tileMe)%is1(n);   ie1Send(count) = nCont(tileMe)%ie1(n)
5504              je1Send(count) = nCont(tileMe)%je1(n);   js1Send(count) = je1Send(count) - shalo + 1
5505              is2Send(count) = nCont(tileMe)%is2(n);   ie2Send(count) = nCont(tileMe)%ie2(n)
5506              je2Send(count) = nCont(tileMe)%js2(n)-1; js2Send(count) = je2Send(count) - shalo + 1
5507           case ( WEST )  ! w <-> n
5508              rotateRecv(count) = MINUS_NINETY;        rotateSend(count) = NINETY
5509              is2Recv(count) = nCont(tileMe)%ie2(n);   ie2Recv(count) = is2Recv(count) + nhalo - 1
5510              js2Recv(count) = nCont(tileMe)%js2(n);   je2Recv(count) = nCont(tileMe)%je2(n)
5511              is1Send(count) = nCont(tileMe)%is1(n);   ie1Send(count) = nCont(tileMe)%ie1(n)
5512              je1Send(count) = nCont(tileMe)%je1(n);   js1Send(count) = je1Send(count) - whalo + 1
5513              ie2Send(count) = nCont(tileMe)%is2(n)-1; is2Send(count) = ie2Send(count) - whalo + 1
5514              js2Send(count) = nCont(tileMe)%js2(n);   je2Send(count) = nCont(tileMe)%je2(n)
5515           end select
5516        end do
5517
5518        numS = count
5519        numR = count
5520        !--- figure out the index for corner overlapping,
5521        !--- fill_corner_contact will be updated to deal with the situation that there are multiple tiles on
5522        !--- each side of six sides of cubic grid.
5523        if(.NOT. domain%rotated_ninety)  then
5524           call fill_corner_contact(eCont, sCont, wCont, nCont, isgList, iegList, jsgList, jegList, numR, numS, &
5525                tileRecv, tileSend, is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv,   &
5526                js2Recv, je2Recv, is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send,     &
5527                js2Send, je2Send, align1Recv, align2Recv, align1Send, align2Send,           &
5528                whalo, ehalo, shalo, nhalo, tileMe )
5529        end if
5530
5531        isc = domain%x(tMe)%compute%begin; iec = domain%x(tMe)%compute%end
5532        jsc = domain%y(tMe)%compute%begin; jec = domain%y(tMe)%compute%end
5533
5534        !--- compute the overlapping for send.
5535        do n = 1, numS
5536           do list = 0, nlist-1
5537              m = mod( domain%pos+list, nlist )
5538              ntileNbr = size(domain%list(m)%x(:))
5539              do tNbr = 1, ntileNbr
5540                 if( domain%list(m)%tile_id(tNbr) .NE. tileSend(n) ) cycle
5541                 isc1 = max(isc, is1Send(n)); iec1 = min(iec, ie1Send(n))
5542                 jsc1 = max(jsc, js1Send(n)); jec1 = min(jec, je1Send(n))
5543                 if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle
5544                 !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5545                 do dir = 1, 8
5546                    !--- get the to_pe's data domain.
5547                    select case ( dir )
5548                    case ( 1 )  ! eastern halo
5549                       if( align2Send(n) .NE. EAST ) cycle
5550                       isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5551                       jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
5552                    case ( 2 )  ! southeast halo
5553                       isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5554                       jsd = domain%list(m)%y(tNbr)%compute%begin-shalo;    jed = domain%list(m)%y(tNbr)%compute%begin-1
5555                    case ( 3 )  ! southern halo
5556                       if( align2Send(n) .NE. SOUTH ) cycle
5557                       isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
5558                       jsd = domain%list(m)%y(tNbr)%compute%begin-shalo;    jed = domain%list(m)%y(tNbr)%compute%begin-1
5559                    case ( 4 )  ! southwest halo
5560                       isd = domain%list(m)%x(tNbr)%compute%begin-whalo;    ied = domain%list(m)%x(tNbr)%compute%begin-1
5561                       jsd = domain%list(m)%y(tNbr)%compute%begin-shalo;    jed = domain%list(m)%y(tNbr)%compute%begin-1
5562                    case ( 5 )  ! western halo
5563                       if( align2Send(n) .NE. WEST ) cycle
5564                       isd = domain%list(m)%x(tNbr)%compute%begin-whalo;    ied = domain%list(m)%x(tNbr)%compute%begin-1
5565                       jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
5566                    case ( 6 )  ! northwest halo
5567                       isd = domain%list(m)%x(tNbr)%compute%begin-whalo;    ied = domain%list(m)%x(tNbr)%compute%begin-1
5568                       jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5569                    case ( 7 )  ! northern halo
5570                       if( align2Send(n) .NE. NORTH ) cycle
5571                       isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
5572                       jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5573                    case ( 8 )  ! northeast halo
5574                       isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5575                       jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5576                    end select
5577                    isd = max(isd, is2Send(n)); ied = min(ied, ie2Send(n))
5578                    jsd = max(jsd, js2Send(n)); jed = min(jed, je2Send(n))
5579                    if( isd > ied .OR. jsd > jed ) cycle
5580                    ioff = 0; joff = 0
5581                    nxd = ied - isd + 1
5582                    nyd = jed - jsd + 1
5583                    select case ( align2Send(n) )
5584                    case ( WEST, EAST )
5585                       ioff = isd - is2Send(n)
5586                       joff = jsd - js2Send(n)
5587                    case ( SOUTH, NORTH )
5588                       ioff = isd - is2Send(n)
5589                       joff = jsd - js2Send(n)
5590                    end select
5591
5592                    !--- get the index in current pe.
5593                    select case ( rotateSend(n) )
5594                    case ( ZERO )
5595                       isc2 = is1Send(n) + ioff; iec2 = isc2 + nxd - 1
5596                       jsc2 = js1Send(n) + joff; jec2 = jsc2 + nyd - 1
5597                    case ( NINETY )                     ! N -> W or S -> E
5598                       iec2 = ie1Send(n) - joff; isc2 = iec2 - nyd + 1
5599                       jsc2 = js1Send(n) + ioff; jec2 = jsc2 + nxd - 1
5600                    case ( MINUS_NINETY )               ! W -> N or E -> S
5601                       isc2 = is1Send(n) + joff; iec2 = isc2 + nyd - 1
5602                       jec2 = je1Send(n) - ioff; jsc2 = jec2 - nxd + 1
5603                    end select
5604                    is = max(isc1,isc2); ie = min(iec1,iec2)
5605                    js = max(jsc1,jsc2); je = min(jec1,jec2)
5606                    if(ie.GE.is .AND. je.GE.js )then
5607                       if(.not. associated(overlapSend(m)%tileMe)) call allocate_update_overlap(overlapSend(m), &
5608                         &  MAXOVERLAP)
5609                     call insert_overlap_type(overlapSend(m), domain%list(m)%pe, tMe, tNbr, &
5610                          is, ie, js, je, dir, rotateSend(n), .true. )
5611                    endif
5612                 end do ! end do dir = 1, 8
5613              end do ! end do tNbr = 1, ntileNbr
5614           end do ! end do list = 0, nlist-1
5615        end do ! end do n = 1, numS
5616
5617        !--- compute the overlapping for recv.
5618        do n = 1, numR
5619           do list = 0, nlist-1
5620              m = mod( domain%pos+nlist-list, nlist )
5621              ntileNbr = size(domain%list(m)%x(:))
5622              do tNbr = 1, ntileNbr
5623                 if( domain%list(m)%tile_id(tNbr) .NE. tileRecv(n) ) cycle
5624                 isc = domain%list(m)%x(tNbr)%compute%begin; iec = domain%list(m)%x(tNbr)%compute%end
5625                 jsc = domain%list(m)%y(tNbr)%compute%begin; jec = domain%list(m)%y(tNbr)%compute%end
5626                 isc = max(isc, is2Recv(n)); iec = min(iec, ie2Recv(n))
5627                 jsc = max(jsc, js2Recv(n)); jec = min(jec, je2Recv(n))
5628                 if( isc > iec .OR. jsc > jec ) cycle
5629                 !--- find the offset for this overlapping.
5630                 ioff = 0; joff = 0
5631                 nxc = iec - isc + 1; nyc = jec - jsc + 1
5632                 select case ( align2Recv(n) )
5633                 case ( WEST, EAST )
5634                    if(align2Recv(n) == WEST) then
5635                       ioff = isc - is2Recv(n)
5636                    else
5637                       ioff = ie2Recv(n) - iec
5638                    endif
5639                    joff = jsc - js2Recv(n)
5640                 case ( NORTH, SOUTH )
5641                    ioff = isc - is2Recv(n)
5642                    if(align2Recv(n) == SOUTH) then
5643                       joff = jsc - js2Recv(n)
5644                    else
5645                       joff = je2Recv(n) - jec
5646                    endif
5647                 end select
5648
5649                 !--- get the index in current pe.
5650                 select case ( rotateRecv(n) )
5651                 case ( ZERO )
5652                    isd1 = is1Recv(n) + ioff; ied1 = isd1 + nxc - 1
5653                    jsd1 = js1Recv(n) + joff; jed1 = jsd1 + nyc - 1
5654                    if( align1Recv(n) == WEST ) then
5655                       ied1 = ie1Recv(n)-ioff;   isd1 = ied1 - nxc + 1
5656                    endif
5657                    if( align1Recv(n) == SOUTH ) then
5658                       jed1 = je1Recv(n)-joff;  jsd1 = jed1 - nyc + 1
5659                    endif
5660                 case ( NINETY )                      ! N -> W or S -> E
5661                    if( align1Recv(n) == WEST ) then
5662                       ied1 = ie1Recv(n)-joff;   isd1 = ied1 - nyc + 1
5663                    else
5664                       isd1 = is1Recv(n)+joff;   ied1 = isd1 + nyc - 1
5665                    endif
5666                    jed1 = je1Recv(n) - ioff; jsd1 = jed1 - nxc + 1
5667                 case ( MINUS_NINETY )                ! W -> N or E -> S
5668                    ied1 = ie1Recv(n) - joff; isd1 = ied1 - nyc + 1
5669                    if( align1Recv(n) == SOUTH ) then
5670                       jed1 = je1Recv(n)-ioff;  jsd1 = jed1 - nxc + 1
5671                    else
5672                       jsd1 = js1Recv(n)+ioff;  jed1 = jsd1 + nxc - 1
5673                    endif
5674                 end select
5675
5676                 !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5677                 do dir = 1, 8
5678                    select case ( dir )
5679                    case ( 1 )  ! eastern halo
5680                       if( align1Recv(n) .NE. EAST ) cycle
5681                       isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5682                       jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
5683                    case ( 2 )  ! southeast halo
5684                       isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5685                       jsd2 = domain%y(tMe)%data%begin;    jed2 = domain%y(tMe)%compute%begin-1
5686                    case ( 3 )  ! southern halo
5687                       if( align1Recv(n) .NE. SOUTH ) cycle
5688                       isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
5689                       jsd2 = domain%y(tMe)%data%begin;    jed2 = domain%y(tMe)%compute%begin-1
5690                    case ( 4 )  ! southwest halo
5691                       isd2 = domain%x(tMe)%data%begin;    ied2 = domain%x(tMe)%compute%begin-1
5692                       jsd2 = domain%y(tMe)%data%begin;    jed2 = domain%y(tMe)%compute%begin-1
5693                    case ( 5 )  ! western halo
5694                       if( align1Recv(n) .NE. WEST ) cycle
5695                       isd2 = domain%x(tMe)%data%begin;    ied2 = domain%x(tMe)%compute%begin-1
5696                       jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
5697                    case ( 6 )  ! northwest halo
5698                       isd2 = domain%x(tMe)%data%begin;    ied2 = domain%x(tMe)%compute%begin-1
5699                       jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5700                    case ( 7 )  ! northern halo
5701                       if( align1Recv(n) .NE. NORTH ) cycle
5702                       isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
5703                       jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5704                    case ( 8 )  ! northeast halo
5705                       isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5706                       jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5707                    end select
5708                    is = max(isd1,isd2); ie = min(ied1,ied2)
5709                    js = max(jsd1,jsd2); je = min(jed1,jed2)
5710                    if(ie.GE.is .AND. je.GE.js )then
5711                       if(.not. associated(overlapRecv(m)%tileMe)) call allocate_update_overlap(overlapRecv(m), &
5712                         &  MAXOVERLAP)
5713                     call insert_overlap_type(overlapRecv(m), domain%list(m)%pe, tMe, tNbr, &
5714                          is, ie, js, je, dir, rotateRecv(n), .true.)
5715                       count                              = overlapRecv(m)%count
5716                    endif
5717                 end do ! end do dir = 1, 8
5718              end do ! end do tNbr = 1, ntileNbr
5719           end do ! end do list = 0, nlist-1
5720        end do ! end do n = 1, numR
5721     end do   ! end do tMe = 1, ntileMe
5722
5723     !--- copy the overlapping information into domain data
5724     nsend = 0; nsend2 = 0
5725     do list = 0, nlist-1
5726        m = mod( domain%pos+list, nlist )
5727        if(overlapSend(m)%count>0) nsend = nsend + 1
5728     enddo
5729
5730     if(debug_message_passing) then
5731        !--- write out send information
5732        unit = mpp_pe() + 1000
5733        do list = 0, nlist-1
5734           m = mod( domain%pos+list, nlist )
5735           if(overlapSend(m)%count==0) cycle
5736           write(unit, *) "********to_pe = " ,overlapSend(m)%pe, " count = ",overlapSend(m)%count
5737           do n = 1, overlapSend(m)%count
5738              write(unit, *) overlapSend(m)%is(n), overlapSend(m)%ie(n), overlapSend(m)%js(n), overlapSend(m)%je(n), &
5739                   overlapSend(m)%dir(n), overlapSend(m)%rotation(n)
5740           enddo
5741        enddo
5742        if(nsend >0) flush(unit)
5743     endif
5744
5745     dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
5746     dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
5747
5748     ! copy the overlap information into domain.
5749     if(nsend >0) then
5750        if(associated(domain%update_T%send)) then
5751           do m = 1, domain%update_T%nsend
5752              call deallocate_overlap_type(domain%update_T%send(m))
5753           enddo
5754           deallocate(domain%update_T%send)
5755        endif
5756        domain%update_T%nsend = nsend
5757        allocate(domain%update_T%send(nsend))
5758        do list = 0, nlist-1
5759           m = mod( domain%pos+list, nlist )
5760           ntileNbr = size(domain%list(m)%x(:))
5761           !--- for the send, the list should be in tileNbr order and dir order to be consistent with Recv
5762           if(overlapSend(m)%count > 0) then
5763              nsend2 = nsend2+1
5764              if(nsend2>nsend) call mpp_error(FATAL, &
5765                   "mpp_domains_define.inc(define_contact_point): nsend2 is greater than nsend")
5766              call allocate_update_overlap(domain%update_T%send(nsend2), overlapSend(m)%count)
5767
5768              do tNbr = 1, ntileNbr
5769                 do tt = 1, ntileMe
5770                    if(domain%list(m)%pe == domain%pe) then ! own processor
5771                       tMe = tNbr+tt-1
5772                       if(tMe > ntileMe) tMe = tMe - ntileMe
5773                    else
5774                       tMe = tt
5775                    end if
5776                    do n = 1, 8  ! loop over 8 direction
5777                       do l = 1, overlapSend(m)%count
5778                          if(overlapSend(m)%tileMe(l) .NE. tMe) cycle
5779                          if(overlapSend(m)%tileNbr(l) .NE. tNbr) cycle
5780                          if(overlapSend(m)%dir(l) .NE. dirlist(n) ) cycle
5781                        call insert_overlap_type(domain%update_T%send(nsend2), overlapSend(m)%pe, &
5782                               overlapSend(m)%tileMe(l), overlapSend(m)%tileNbr(l), overlapSend(m)%is(l), &
5783                               overlapSend(m)%ie(l), overlapSend(m)%js(l), overlapSend(m)%je(l), overlapSend(m)%dir(l),&
5784                               overlapSend(m)%rotation(l), overlapSend(m)%from_contact(l)  )
5785                       end do
5786                    end do
5787                 end do
5788              end do
5789           end if
5790        enddo
5791     endif
5792
5793     if(nsend2 .NE. nsend) call mpp_error(FATAL, &
5794          "mpp_domains_define.inc(define_contact_point): nsend2 does not equal to nsend")
5795
5796     nrecv = 0; nrecv2 = 0
5797     do list = 0, nlist-1
5798        m = mod( domain%pos+list, nlist )
5799        if(overlapRecv(m)%count>0) nrecv = nrecv + 1
5800     enddo
5801
5802     if(debug_message_passing) then
5803        do list = 0, nlist-1
5804           m = mod( domain%pos+list, nlist )
5805           if(overlapRecv(m)%count==0) cycle
5806           write(unit, *) "********from_pe = " ,overlapRecv(m)%pe, " count = ",overlapRecv(m)%count
5807           do n = 1, overlapRecv(m)%count
5808              write(unit, *) overlapRecv(m)%is(n), overlapRecv(m)%ie(n), overlapRecv(m)%js(n), overlapRecv(m)%je(n), &
5809                   overlapRecv(m)%dir(n), overlapRecv(m)%rotation(n)
5810           enddo
5811        enddo
5812        if(nrecv >0) flush(unit)
5813     endif
5814
5815     if(nrecv >0) then
5816        if(associated(domain%update_T%recv)) then
5817           do m = 1, domain%update_T%nrecv
5818              call deallocate_overlap_type(domain%update_T%recv(m))
5819           enddo
5820           deallocate(domain%update_T%recv)
5821        endif
5822        domain%update_T%nrecv = nrecv
5823        allocate(domain%update_T%recv(nrecv))
5824
5825        do list = 0, nlist-1
5826           m = mod( domain%pos+nlist-list, nlist )
5827           ntileNbr = size(domain%list(m)%x(:))
5828           if(overlapRecv(m)%count > 0) then
5829              nrecv2 = nrecv2 + 1
5830              if(nrecv2>nrecv) call mpp_error(FATAL, &
5831                    "mpp_domains_define.inc(define_contact_point): nrecv2 is greater than nrecv")
5832              call allocate_update_overlap(domain%update_T%recv(nrecv2), overlapRecv(m)%count)
5833              do tMe = 1, ntileMe
5834                 do tt = 1, ntileNbr
5835                    !--- make sure the same order tile for different pe count
5836                    if(domain%list(m)%pe == domain%pe) then ! own processor
5837                       tNbr = tMe+tt-1
5838                       if(tNbr>ntileNbr) tNbr = tNbr - ntileNbr
5839                    else
5840                       tNbr = tt
5841                    end if
5842                    do n = 1, 8  ! loop over 8 direction
5843                       do l = 1, overlapRecv(m)%count
5844                          if(overlapRecv(m)%tileMe(l) .NE. tMe) cycle
5845                          if(overlapRecv(m)%tileNbr(l) .NE. tNbr) cycle
5846                          if(overlapRecv(m)%dir(l) .NE. dirlist(n) ) cycle
5847                        call insert_overlap_type(domain%update_T%recv(nrecv2), overlapRecv(m)%pe, &
5848                               overlapRecv(m)%tileMe(l), overlapRecv(m)%tileNbr(l), overlapRecv(m)%is(l), &
5849                               overlapRecv(m)%ie(l), overlapRecv(m)%js(l), overlapRecv(m)%je(l), overlapRecv(m)%dir(l),&
5850                               overlapRecv(m)%rotation(l), overlapRecv(m)%from_contact(l))
5851                          count = domain%update_T%recv(nrecv2)%count
5852                       end do
5853                    end do
5854                 end do
5855              end do
5856           end if
5857        end do
5858     endif
5859
5860     if(nrecv2 .NE. nrecv) call mpp_error(FATAL, &
5861     "mpp_domains_define.inc(define_contact_point): nrecv2 does not equal to nrecv")
5862
5863     do m = 0,nlist-1
5864        call deallocate_overlap_type(overlapSend(m))
5865        call deallocate_overlap_type(overlapRecv(m))
5866     enddo
5867     !--- release memory
5868     do n = 1, ntiles
5869        deallocate(eCont(n)%tile, wCont(n)%tile, sCont(n)%tile, nCont(n)%tile )
5870        deallocate(eCont(n)%align1, wCont(n)%align1, sCont(n)%align1, nCont(n)%align1)
5871        deallocate(eCont(n)%align2, wCont(n)%align2, sCont(n)%align2, nCont(n)%align2)
5872        deallocate(eCont(n)%refine1, wCont(n)%refine1, sCont(n)%refine1, nCont(n)%refine1)
5873        deallocate(eCont(n)%refine2, wCont(n)%refine2, sCont(n)%refine2, nCont(n)%refine2)
5874        deallocate(eCont(n)%is1, eCont(n)%ie1, eCont(n)%js1, eCont(n)%je1 )
5875        deallocate(eCont(n)%is2, eCont(n)%ie2, eCont(n)%js2, eCont(n)%je2 )
5876        deallocate(wCont(n)%is1, wCont(n)%ie1, wCont(n)%js1, wCont(n)%je1 )
5877        deallocate(wCont(n)%is2, wCont(n)%ie2, wCont(n)%js2, wCont(n)%je2 )
5878        deallocate(sCont(n)%is1, sCont(n)%ie1, sCont(n)%js1, sCont(n)%je1 )
5879        deallocate(sCont(n)%is2, sCont(n)%ie2, sCont(n)%js2, sCont(n)%je2 )
5880        deallocate(nCont(n)%is1, nCont(n)%ie1, nCont(n)%js1, nCont(n)%je1 )
5881        deallocate(nCont(n)%is2, nCont(n)%ie2, nCont(n)%js2, nCont(n)%je2 )
5882     end do
5883
5884     domain%initialized = .true.
5885
5886
5887   end subroutine define_contact_point
5888
5889 !##############################################################################
5890 !--- always fill the contact according to index order.
5891 subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
5892   type(contact_type), intent(inout) :: Contact
5893   integer,            intent(in)    :: tile
5894   integer,            intent(in)    :: is1, ie1, js1, je1
5895   integer,            intent(in)    :: is2, ie2, js2, je2
5896   integer,            intent(in)    :: align1, align2
5897   real,               intent(in)    :: refine1, refine2
5898   integer                           :: pos, n
5899
5900   do pos = 1, Contact%ncontact
5901      select case(align1)
5902      case(WEST, EAST)
5903         if( js1 < Contact%js1(pos) ) exit
5904      case(SOUTH, NORTH)
5905         if( is1 < Contact%is1(pos) ) exit
5906      end select
5907   end do
5908
5909   Contact%ncontact = Contact%ncontact + 1
5910   do n = Contact%ncontact, pos+1, -1  ! shift the data if needed.
5911      Contact%tile(n)   = Contact%tile(n-1)
5912      Contact%align1(n) = Contact%align1(n-1)
5913      Contact%align2(n) = Contact%align2(n-1)
5914      Contact%is1(n) = Contact%is1(n-1); Contact%ie1(n) = Contact%ie1(n-1)
5915      Contact%js1(n) = Contact%js1(n-1); Contact%je1(n) = Contact%je1(n-1)
5916      Contact%is2(n) = Contact%is2(n-1); Contact%ie2(n) = Contact%ie2(n-1)
5917      Contact%js2(n) = Contact%js2(n-1); Contact%je2(n) = Contact%je2(n-1)
5918   end do
5919
5920   Contact%tile(pos)    = tile
5921   Contact%align1(pos)  = align1
5922   Contact%align2(pos)  = align2
5923   Contact%refine1(pos) = refine1
5924   Contact%refine2(pos) = refine2
5925   Contact%is1(pos) = is1; Contact%ie1(pos) = ie1
5926   Contact%js1(pos) = js1; Contact%je1(pos) = je1
5927   Contact%is2(pos) = is2; Contact%ie2(pos) = ie2
5928   Contact%js2(pos) = js2; Contact%je2(pos) = je2
5929
5930 end subroutine fill_contact
5931
5932 !############################################################################
5933 ! this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
5934 subroutine set_contact_point(domain, position)
5935   type(domain2d), intent(inout) :: domain
5936   integer,           intent(in) :: position
5937
5938   integer                         :: ishift, jshift, nlist, list, m, n
5939   integer                         :: ntileMe, tMe, dir, count, pos, nsend, nrecv
5940   integer                         :: isoff1, ieoff1, jsoff1, jeoff1
5941   type(overlap_type),  pointer    :: ptrIn  => NULL()
5942   type(overlapSpec),   pointer    :: update_in  => NULL()
5943   type(overlapSpec),   pointer    :: update_out => NULL()
5944   type(overlap_type)              :: overlapList(0:size(domain%list(:))-1)
5945   type(overlap_type)              :: overlap
5946
5947   call mpp_get_domain_shift(domain, ishift, jshift, position)
5948   update_in => domain%update_T
5949   select case(position)
5950   case (CORNER)
5951      update_out => domain%update_C
5952   case (EAST)
5953      update_out => domain%update_E
5954   case (NORTH)
5955      update_out => domain%update_N
5956   case default
5957      call mpp_error(FATAL, "mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
5958   end select
5959
5960   update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
5961   update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
5962   update_out%whalo  = update_in%whalo;  update_out%ehalo  = update_in%ehalo
5963   update_out%shalo  = update_in%shalo;  update_out%nhalo  = update_in%nhalo
5964
5965   nlist = size(domain%list(:))
5966   ntileMe = size(domain%x(:))
5967   call allocate_update_overlap(overlap, MAXOVERLAP)
5968   do m = 0, nlist-1
5969      call init_overlap_type(overlapList(m))
5970   enddo
5971
5972   !--- first copy the send information in update_out to send
5973   nsend = update_out%nsend
5974   do m = 1, nsend
5975      pos = update_out%send(m)%pe - mpp_root_pe()
5976      call add_update_overlap(overlapList(pos), update_out%send(m))
5977      call deallocate_overlap_type(update_out%send(m))
5978   enddo
5979   if(ASSOCIATED(update_out%send) )deallocate(update_out%send)
5980
5981   !--- loop over the list of overlapping.
5982   nsend = update_in%nsend
5983   do m = 1, nsend
5984      ptrIn  => update_in%send(m)
5985      pos  = PtrIn%pe - mpp_root_pe()
5986      do n = 1, ptrIn%count
5987         dir = ptrIn%dir(n)
5988         ! only set overlapping between tiles for send ( ptrOut%overlap(1) is false )
5989         if(ptrIn%from_contact(n)) then
5990            select case ( dir )
5991            case ( 1 ) ! to_pe's eastern halo
5992               select case(ptrIn%rotation(n))
5993               case (ZERO)  !  W -> E
5994                  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0;      jeoff1 = jshift
5995               case (NINETY) ! S -> E
5996                  isoff1 = 0;      ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5997               end select
5998            case ( 2 ) ! to_pe's south-eastearn halo
5999               select case(ptrIn%rotation(n))
6000               case (ZERO)
6001                  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0;      jeoff1 = 0
6002               case (NINETY)
6003                  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6004               case (MINUS_NINETY)
6005                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = 0
6006               end select
6007            case ( 3 ) ! to_pe's southern halo
6008               select case(ptrIn%rotation(n))
6009               case (ZERO)  !  N -> S
6010                  isoff1 = 0;      ieoff1 = ishift; jsoff1 = 0;      jeoff1 = 0
6011               case (MiNUS_NINETY) ! E -> S
6012                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = ishift
6013               end select
6014            case ( 4 ) ! to_pe's south-westearn halo
6015               select case(ptrIn%rotation(n))
6016               case (ZERO)
6017                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = 0
6018               case (NINETY)
6019                  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0;      jeoff1 = 0
6020               case (MINUS_NINETY)
6021                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = ishift; jeoff1 = ishift
6022               end select
6023            case ( 5 ) ! to_pe's western halo
6024               select case(ptrIn%rotation(n))
6025               case (ZERO)  !  E -> W
6026                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = jshift
6027               case (NINETY) ! N -> W
6028                  isoff1 = 0;      ieoff1 = jshift; jsoff1 = 0;      jeoff1 = 0
6029               end select
6030            case ( 6 ) ! to_pe's north-westearn halo
6031               select case(ptrIn%rotation(n))
6032               case (ZERO)
6033                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = jshift; jeoff1 = jshift
6034               case (NINETY)
6035                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = 0
6036               case (MINUS_NINETY)
6037                  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6038               end select
6039            case ( 7 ) ! to_pe's northern halo
6040               select case(ptrIn%rotation(n))
6041               case (ZERO)  !  S -> N
6042                  isoff1 = 0;      ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6043               case (MINUS_NINETY) ! W -> N
6044                  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0;      jeoff1 = ishift
6045               end select
6046            case ( 8 ) ! to_pe's north-eastearn halo
6047               select case(ptrIn%rotation(n))
6048               case (ZERO)
6049                  isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6050               case (NINETY)
6051                  isoff1 = 0;      ieoff1 = 0;      jsoff1 = ishift; jeoff1 = ishift
6052               case (MINUS_NINETY)
6053                  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0;      jeoff1 = 0
6054               end select
6055            end select
6056            call insert_overlap_type(overlap, PtrIn%pe, PtrIn%tileMe(n), PtrIn%tileNbr(n), &
6057                                              Ptrin%is(n) + isoff1, Ptrin%ie(n) + ieoff1, Ptrin%js(n) + jsoff1, &
6058                 Ptrin%je(n) + jeoff1, PtrIn%dir(n), PtrIn%rotation(n), PtrIn%from_contact(n))
6059         end if
6060      end do ! do n = 1, prtIn%count
6061      if(overlap%count > 0) then
6062         call add_update_overlap(overlapList(pos), overlap)
6063         call init_overlap_type(overlap)
6064      endif
6065   end do  ! do list = 0, nlist-1
6066
6067   nsend = 0
6068   do list = 0, nlist-1
6069      m = mod( domain%pos+list, nlist )
6070      if(overlapList(m)%count>0) nsend = nsend+1
6071   enddo
6072
6073   update_out%nsend = nsend
6074   if(nsend>0) then
6075      allocate(update_out%send(nsend))
6076      pos = 0
6077      do list = 0, nlist-1
6078         m = mod( domain%pos+list, nlist )
6079         if(overlapList(m)%count>0) then
6080            pos = pos+1
6081            if(pos>nsend) call mpp_error(FATAL, &
6082                 "mpp_domains_define.inc(set_contact_point): pos should be no larger than nsend")
6083            call add_update_overlap(update_out%send(pos), overlapList(m))
6084            call deallocate_overlap_type(overlapList(m))
6085         endif
6086      enddo
6087      if(pos .NE. nsend) call mpp_error(FATAL, &
6088           "mpp_domains_define.inc(set_contact_point): pos should equal to nsend")
6089   endif
6090
6091
6092
6093   !--- first copy the recv information in update_out to recv
6094   nrecv = update_out%nrecv
6095   do m = 1, nrecv
6096      pos = update_out%recv(m)%pe - mpp_root_pe()
6097      call add_update_overlap(overlapList(pos), update_out%recv(m))
6098      call deallocate_overlap_type(update_out%recv(m))
6099   enddo
6100   if(ASSOCIATED(update_out%recv) )deallocate(update_out%recv)
6101
6102   !--- loop over the list of overlapping.
6103   nrecv = update_in%nrecv
6104   do m=1,nrecv
6105      ptrIn  => update_in%recv(m)
6106      pos  = PtrIn%pe - mpp_root_pe()
6107      do n = 1, ptrIn%count
6108         dir = ptrIn%dir(n)
6109         ! only set overlapping between tiles for recv ( ptrOut%overlap(1) is false )
6110         if(ptrIn%from_contact(n)) then
6111            select case ( dir )
6112            case ( 1 ) ! E
6113               isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0;      jeoff1 = jshift
6114            case ( 2 ) ! SE
6115               isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0;      jeoff1 = 0
6116            case ( 3 ) ! S
6117               isoff1 = 0;      ieoff1 = ishift; jsoff1 = 0;      jeoff1 = 0
6118            case ( 4 ) ! SW
6119               isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = 0
6120            case ( 5 ) ! W
6121               isoff1 = 0;      ieoff1 = 0;      jsoff1 = 0;      jeoff1 = jshift
6122            case ( 6 ) ! NW
6123               isoff1 = 0;       ieoff1 = 0;      jsoff1 = jshift; jeoff1 = jshift
6124            case ( 7 ) ! N
6125               isoff1 = 0;      ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6126            case ( 8 ) ! NE
6127               isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6128            end select
6129            call insert_overlap_type(overlap, PtrIn%pe, PtrIn%tileMe(n), PtrIn%tileNbr(n), &
6130                                              Ptrin%is(n) + isoff1, Ptrin%ie(n) + ieoff1, Ptrin%js(n) + jsoff1, &
6131                 Ptrin%je(n) + jeoff1, PtrIn%dir(n), PtrIn%rotation(n), PtrIn%from_contact(n))
6132            count                     = overlap%count
6133         end if
6134      end do ! do n = 1, ptrIn%count
6135      if(overlap%count > 0) then
6136         call add_update_overlap(overlapList(pos), overlap)
6137         call init_overlap_type(overlap)
6138      endif
6139      do tMe = 1, size(domain%x(:))
6140         do n = 1, overlap%count
6141            if(overlap%tileMe(n) == tMe) then
6142               if(overlap%dir(n) == 1 ) domain%x(tMe)%loffset = 0
6143               if(overlap%dir(n) == 7 ) domain%y(tMe)%loffset = 0
6144            end if
6145         end do
6146      end do
6147   end do ! do list = 0, nlist-1
6148
6149   nrecv = 0
6150   do list = 0, nlist-1
6151      m = mod( domain%pos+nlist-list, nlist )
6152      if(overlapList(m)%count>0) nrecv = nrecv+1
6153   enddo
6154
6155   update_out%nrecv = nrecv
6156   if(nrecv>0) then
6157      allocate(update_out%recv(nrecv))
6158      pos = 0
6159      do list = 0, nlist-1
6160         m = mod( domain%pos+nlist-list, nlist )
6161         if(overlapList(m)%count>0) then
6162            pos = pos+1
6163            if(pos>nrecv) call mpp_error(FATAL, &
6164                 "mpp_domains_define.inc(set_contact_point): pos should be no larger than nrecv")
6165            call  add_update_overlap(update_out%recv(pos), overlapList(m))
6166            call deallocate_overlap_type(overlapList(m))
6167         endif
6168      enddo
6169      if(pos .NE. nrecv) call mpp_error(FATAL, &
6170           "mpp_domains_define.inc(set_contact_point): pos should equal to nrecv")
6171   endif
6172
6173   call deallocate_overlap_type(overlap)
6174
6175 end subroutine set_contact_point
6176
6177 !--- set up the overlapping for boundary check if the domain is symmetry. The check will be
6178 !--- done on current pe for east boundary for E-cell, north boundary for N-cell,
6179 !--- East and North boundary for C-cell
6180 subroutine set_check_overlap( domain, position )
6181 type(domain2d),    intent(in) :: domain
6182 integer,           intent(in) :: position
6183 integer                       :: nlist, m, n
6184 integer, parameter            :: MAXCOUNT = 100
6185 integer                       :: is, ie, js, je
6186 integer                       :: nsend, nrecv, pos, maxsize, rotation
6187 type(overlap_type)            :: overlap
6188 type(overlapSpec),   pointer  :: update  => NULL()
6189 type(overlapSpec),   pointer  :: check   => NULL()
6190
6191 select case(position)
6192 case (CORNER)
6193    update => domain%update_C
6194    check  => domain%check_C
6195 case (EAST)
6196    update => domain%update_E
6197    check  => domain%check_E
6198 case (NORTH)
6199    update => domain%update_N
6200    check  => domain%check_N
6201 case default
6202    call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
6203 end select
6204
6205 check%xbegin = update%xbegin; check%xend = update%xend
6206 check%ybegin = update%ybegin; check%yend = update%yend
6207 check%nsend  = 0
6208 check%nrecv  = 0
6209 if( .NOT. domain%symmetry ) return
6210
6211 nsend = 0
6212 maxsize = 0
6213 do m = 1, update%nsend
6214     do n = 1, update%send(m)%count
6215        if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6216        if( ( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) .OR. &
6217             ( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) ) then
6218             maxsize = max(maxsize, update%send(m)%count)
6219             nsend = nsend + 1
6220             exit
6221        endif
6222     enddo
6223 enddo
6224
6225 if(nsend>0) then
6226    allocate(check%send(nsend))
6227    call allocate_check_overlap(overlap, maxsize)
6228 endif
6229
6230
6231 nlist = size(domain%list(:))
6232 !--- loop over the list of domains to find the boundary overlap for send
6233 pos = 0
6234 do m = 1, update%nsend
6235  do n = 1, update%send(m)%count
6236     if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6237     ! comparing east direction on currently pe
6238     if( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) then
6239        rotation = update%send(m)%rotation(n)
6240        select case( rotation )
6241        case( ZERO ) ! W -> E
6242           is = update%send(m)%is(n) - 1
6243           ie = is
6244           js = update%send(m)%js(n)
6245           je = update%send(m)%je(n)
6246        case( NINETY ) ! S -> E
6247           is = update%send(m)%is(n)
6248           ie = update%send(m)%ie(n)
6249           js = update%send(m)%js(n) - 1
6250           je = js
6251        end select
6252        call insert_check_overlap(overlap, update%send(m)%pe, &
6253                                  update%send(m)%tileMe(n), 1, rotation, is, ie, js, je)
6254     end if
6255
6256     ! comparing north direction on currently pe
6257     if( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) then
6258        rotation = update%send(m)%rotation(n)
6259        select case( rotation )
6260        case( ZERO ) ! S->N
6261           is = update%send(m)%is(n)
6262           ie = update%send(m)%ie(n)
6263           js = update%send(m)%js(n) - 1
6264           je = js
6265        case( MINUS_NINETY ) ! W->N
6266           is = update%send(m)%is(n) - 1
6267           ie = is
6268           js = update%send(m)%js(n)
6269           je = update%send(m)%je(n)
6270        end select
6271        call insert_check_overlap(overlap, update%send(m)%pe, &
6272             update%send(m)%tileMe(n), 4, rotation, is, ie, js, je)
6273     end if
6274  end do ! do n =1, update%send(m)%count
6275  if(overlap%count>0) then
6276    pos = pos+1
6277    if(pos>nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6278    call add_check_overlap(check%send(pos), overlap)
6279    call init_overlap_type(overlap)
6280  endif
6281 end do ! end  do list = 0, nlist
6282
6283 if(pos .NE. nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6284
6285 nrecv = 0
6286 maxsize = 0
6287 do m = 1, update%nrecv
6288     do n = 1, update%recv(m)%count
6289        if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6290        if( ( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) .OR. &
6291             ( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) ) then
6292             maxsize = max(maxsize, update%recv(m)%count)
6293             nrecv = nrecv + 1
6294             exit
6295        endif
6296     enddo
6297 enddo
6298
6299 if(nsend>0) call deallocate_overlap_type(overlap)
6300
6301 if(nrecv>0) then
6302    allocate(check%recv(nrecv))
6303    call allocate_check_overlap(overlap, maxsize)
6304 endif
6305
6306 pos = 0
6307 do m = 1, update%nrecv
6308  do n = 1, update%recv(m)%count
6309     if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6310     if( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) then
6311        is = update%recv(m)%is(n) - 1
6312        ie = is
6313        js = update%recv(m)%js(n)
6314        je = update%recv(m)%je(n)
6315        call insert_check_overlap(overlap, update%recv(m)%pe, &
6316                                  update%recv(m)%tileMe(n), 1, update%recv(m)%rotation(n), is, ie, js, je)
6317     end if
6318     if( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) then
6319        is = update%recv(m)%is(n)
6320        ie = update%recv(m)%ie(n)
6321        js = update%recv(m)%js(n) - 1
6322        je = js
6323        call insert_check_overlap(overlap, update%recv(m)%pe, &
6324             update%recv(m)%tileMe(n), 3, update%recv(m)%rotation(n), is, ie, js, je)
6325     end if
6326  end do ! n = 1, overlap%count
6327  if(overlap%count>0) then
6328    pos = pos+1
6329    if(pos>nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6330    call add_check_overlap(check%recv(pos), overlap)
6331    call init_overlap_type(overlap)
6332  endif
6333 end do ! end  do list = 0, nlist
6334
6335 if(pos .NE. nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6336 if(nrecv>0) call deallocate_overlap_type(overlap)
6337
6338 end subroutine set_check_overlap
6339
6340 !#############################################################################
6341 !--- set up the overlapping for boundary if the domain is symmetry.
6342 subroutine set_bound_overlap( domain, position )
6343   type(domain2d), intent(inout) :: domain
6344   integer,        intent(in)    :: position
6345   integer                       :: m, n, l, count, dr, tMe
6346   integer, parameter            :: MAXCOUNT = 100
6347   integer, dimension(MAXCOUNT)  :: dir, rotation, is, ie, js, je, tileMe, index
6348   integer, dimension(size(domain%x(:)), 4)           :: nrecvl
6349   integer, dimension(size(domain%x(:)), 4, MAXCOUNT) :: isl, iel, jsl, jel
6350   type(overlap_type),  pointer   :: overlap => NULL()
6351   type(overlapSpec),   pointer   :: update => NULL()
6352   type(overlapSpec),   pointer   :: bound => NULL()
6353   integer                        :: nlist_send, nlist_recv, ishift, jshift
6354   integer                        :: ism, iem, jsm, jem, nsend, nrecv
6355   integer                        :: isg, ieg, jsg, jeg, nlist, list
6356   integer                        :: npes_x, npes_y, ipos, jpos, inbr, jnbr
6357   integer                        :: isc, iec, jsc, jec, my_pe
6358   integer                        :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
6359   integer                        :: is_south1, ie_south1, js_south1, je_south1
6360   integer                        :: is_south2, ie_south2, js_south2, je_south2
6361   integer                        :: is_west0, ie_west0, js_west0, je_west0
6362   integer                        :: is_west1, ie_west1, js_west1, je_west1
6363   integer                        :: is_west2, ie_west2, js_west2, je_west2
6364   logical                        :: x_cyclic, y_cyclic, folded_north
6365
6366   is_south1=0; ie_south1=0; js_south1=0; je_south1=0
6367   is_south2=0; ie_south2=0; js_south2=0; je_south2=0
6368   is_west0=0; ie_west0=0; js_west0=0; je_west0=0
6369   is_west1=0; ie_west1=0; js_west1=0; je_west1=0
6370   is_west2=0; ie_west2=0; js_west2=0; je_west2=0
6371
6372
6373   if( position == CENTER .OR. .NOT. domain%symmetry ) return
6374   call mpp_get_domain_shift(domain, ishift, jshift, position)
6375   call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
6376   call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
6377
6378   select case(position)
6379   case (CORNER)
6380      update => domain%update_C
6381      bound  => domain%bound_C
6382   case (EAST)
6383      update => domain%update_E
6384      bound  => domain%bound_E
6385   case (NORTH)
6386      update => domain%update_N
6387      bound  => domain%bound_N
6388   case default
6389      call mpp_error( FATAL, "mpp_domains_mod(set_bound_overlap): invalid option of position")
6390   end select
6391
6392   bound%xbegin = ism; bound%xend = iem + ishift
6393   bound%ybegin = jsm; bound%yend = jem + jshift
6394
6395   nlist_send = max(update%nsend,4)
6396   nlist_recv = max(update%nrecv,4)
6397   bound%nsend = nlist_send
6398   bound%nrecv = nlist_recv
6399   if(nlist_send >0) then
6400      allocate(bound%send(nlist_send))
6401      bound%send(:)%count = 0
6402   endif
6403   if(nlist_recv >0) then
6404      allocate(bound%recv(nlist_recv))
6405      bound%recv(:)%count = 0
6406   endif
6407   !--- loop over the list of domains to find the boundary overlap for send
6408   nlist = size(domain%list(:))
6409
6410   npes_x = size(domain%x(1)%list(:))
6411   npes_y = size(domain%y(1)%list(:))
6412   x_cyclic = domain%x(1)%cyclic
6413   y_cyclic = domain%y(1)%cyclic
6414   folded_north = BTEST(domain%fold,NORTH)
6415   ipos = domain%x(1)%pos
6416   jpos = domain%y(1)%pos
6417   isc  = domain%x(1)%compute%begin; iec = domain%x(1)%compute%end
6418   jsc  = domain%y(1)%compute%begin; jec = domain%y(1)%compute%end
6419
6420   nsend = 0
6421   if(domain%ntiles == 1) then  ! use neighbor processor to configure send and recv
6422      ! currently only set up for west and south boundary
6423
6424      ! south boundary for send
6425      pe_south1 = NULL_PE; pe_south2 = NULL_PE
6426      if( position == NORTH .OR. position == CORNER ) then
6427         inbr = ipos; jnbr = jpos + 1
6428         if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6429         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6430            pe_south1 = domain%pearray(inbr,jnbr)
6431            is_south1 = isc + ishift; ie_south1 = iec+ishift
6432            js_south1 = jec + jshift; je_south1 = js_south1
6433         endif
6434      endif
6435      !--- send to the southwest processor when position is NORTH
6436      if( position == CORNER ) then
6437         inbr = ipos + 1; jnbr = jpos + 1
6438         if( inbr == npes_x .AND. x_cyclic) inbr = 0
6439         if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6440         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6441            pe_south2 = domain%pearray(inbr,jnbr)
6442            is_south2 = iec + ishift; ie_south2 = is_south2
6443            js_south2 = jec + jshift; je_south2 = js_south2
6444         endif
6445      endif
6446
6447      !---west boundary for send
6448      pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6449      if( position == EAST ) then
6450         inbr = ipos+1; jnbr = jpos
6451         if( inbr == npes_x .AND. x_cyclic) inbr = 0
6452         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6453            pe_west1 = domain%pearray(inbr,jnbr)
6454            is_west1 = iec + ishift; ie_west1 = is_west1
6455            js_west1 = jsc + jshift; je_west1 = jec + jshift
6456         endif
6457      else if ( position == CORNER ) then  ! possible split into two parts.
6458         !--- on the fold.
6459         if( folded_north .AND. jec == jeg .AND. ipos .LT. (npes_x-1)/2 ) then
6460            inbr = npes_x - ipos - 1; jnbr = jpos
6461            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6462                pe_west0 = domain%pearray(inbr,jnbr)
6463                is_west0 = iec+ishift; ie_west0 = is_west0
6464                js_west0 = jec+jshift; je_west0 = js_west0
6465            endif
6466         endif
6467
6468         if( folded_north .AND. jec == jeg .AND. ipos .GE. npes_x/2 .AND. ipos .LT. (npes_x-1) ) then
6469            inbr = ipos+1; jnbr = jpos
6470            if( inbr == npes_x .AND. x_cyclic) inbr = 0
6471            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6472               pe_west1 = domain%pearray(inbr,jnbr)
6473               is_west1 = iec + ishift; ie_west1 = is_west1
6474               js_west1 = jsc + jshift; je_west1 = jec
6475            endif
6476         else
6477            inbr = ipos+1; jnbr = jpos
6478            if( inbr == npes_x .AND. x_cyclic) inbr = 0
6479            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6480               pe_west1 = domain%pearray(inbr,jnbr)
6481               is_west1 = iec + ishift; ie_west1 = is_west1
6482               js_west1 = jsc + jshift; je_west1 = jec + jshift
6483            endif
6484         endif
6485      endif
6486      !--- send to the southwest processor when position is NORTH
6487      if( position == CORNER ) then
6488         inbr = ipos + 1; jnbr = jpos + 1
6489         if( inbr == npes_x .AND. x_cyclic) inbr = 0
6490         if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6491         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6492            pe_west2 = domain%pearray(inbr,jnbr)
6493            is_west2 = iec + ishift; ie_west2 = is_west2
6494            js_west2 = jec + jshift; je_west2 = js_west2
6495         endif
6496      endif
6497
6498      do list = 0,nlist-1
6499         m = mod( domain%pos+list, nlist )
6500         count = 0
6501         my_pe = domain%list(m)%pe
6502         if(my_pe == pe_south1) then
6503            count = count + 1
6504            is(count) = is_south1; ie(count) = ie_south1
6505            js(count) = js_south1; je(count) = je_south1
6506            dir(count) = 2
6507            rotation(count) = ZERO
6508         endif
6509         if(my_pe == pe_south2) then
6510            count = count + 1
6511            is(count) = is_south2; ie(count) = ie_south2
6512            js(count) = js_south2; je(count) = je_south2
6513            dir(count) = 2
6514            rotation(count) = ZERO
6515         endif
6516
6517         if(my_pe == pe_west0) then
6518            count = count + 1
6519            is(count) = is_west0; ie(count) = ie_west0
6520            js(count) = js_west0; je(count) = je_west0
6521            dir(count) = 3
6522            rotation(count) = ONE_HUNDRED_EIGHTY
6523         endif
6524         if(my_pe == pe_west1) then
6525            count = count + 1
6526            is(count) = is_west1; ie(count) = ie_west1
6527            js(count) = js_west1; je(count) = je_west1
6528            dir(count) = 3
6529            rotation(count) = ZERO
6530         endif
6531         if(my_pe == pe_west2) then
6532            count = count + 1
6533            is(count) = is_west2; ie(count) = ie_west2
6534            js(count) = js_west2; je(count) = je_west2
6535            dir(count) = 3
6536            rotation(count) = ZERO
6537         endif
6538
6539         if(count >0) then
6540            nsend = nsend + 1
6541            if(nsend > nlist_send)  call mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send")
6542            bound%send(nsend)%count = count
6543            bound%send(nsend)%pe    = my_pe
6544            allocate(bound%send(nsend)%is(count),  bound%send(nsend)%ie(count) )
6545            allocate(bound%send(nsend)%js(count),  bound%send(nsend)%je(count) )
6546            allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6547            allocate(bound%send(nsend)%tileMe(count))
6548            bound%send(nsend)%is(:)       = is(1:count)
6549            bound%send(nsend)%ie(:)       = ie(1:count)
6550            bound%send(nsend)%js(:)       = js(1:count)
6551            bound%send(nsend)%je(:)       = je(1:count)
6552            bound%send(nsend)%dir(:)      = dir(1:count)
6553            bound%send(nsend)%tileMe(:)   = 1
6554            bound%send(nsend)%rotation(:) = rotation(1:count)
6555         endif
6556      enddo
6557   else
6558      !--- The following did not consider wide halo case.
6559      do m = 1, update%nsend
6560         overlap => update%send(m)
6561         if( overlap%count == 0 ) cycle
6562         count = 0
6563         do n = 1, overlap%count
6564            !--- currently not support folded-north
6565            if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6566            if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
6567               count=count+1
6568               dir(count) = 1
6569               rotation(count) = overlap%rotation(n)
6570               tileMe(count)   = overlap%tileMe(n)
6571               select case( rotation(count) )
6572               case( ZERO ) ! W -> E
6573                  is(count) = overlap%is(n) - 1
6574                  ie(count) = is(count)
6575                  js(count) = overlap%js(n)
6576                  je(count) = overlap%je(n)
6577               case( NINETY ) ! S -> E
6578                  is(count) = overlap%is(n)
6579                  ie(count) = overlap%ie(n)
6580                  js(count) = overlap%js(n) - 1
6581                  je(count) = js(count)
6582               end select
6583            end if
6584            if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3 ) then ! south
6585               count=count+1
6586               dir(count) = 2
6587               rotation(count) = overlap%rotation(n)
6588               tileMe(count)   = overlap%tileMe(n)
6589               select case( rotation(count) )
6590               case( ZERO ) ! N->S
6591                  is(count) = overlap%is(n)
6592                  ie(count) = overlap%ie(n)
6593                  js(count) = overlap%je(n) + 1
6594                  je(count) = js(count)
6595               case( MINUS_NINETY ) ! E->S
6596                  is(count) = overlap%ie(n) + 1
6597                  ie(count) = is(count)
6598                  js(count) = overlap%js(n)
6599                  je(count) = overlap%je(n)
6600               end select
6601            end if
6602            if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5 ) then ! west
6603               count=count+1
6604               dir(count) = 3
6605               rotation(count) = overlap%rotation(n)
6606               tileMe(count) = overlap%tileMe(n)
6607               select case( rotation(count) )
6608               case( ZERO ) ! E->W
6609                  is(count) = overlap%ie(n) + 1
6610                  ie(count) = is(count)
6611                  js(count) = overlap%js(n)
6612                  je(count) = overlap%je(n)
6613               case( NINETY ) ! N->W
6614                  is(count) = overlap%is(n)
6615                  ie(count) = overlap%ie(n)
6616                  js(count) = overlap%je(n) + 1
6617                  je(count) = js(count)
6618               end select
6619            end if
6620            if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7 ) then ! north
6621               count=count+1
6622               dir(count) = 4
6623               rotation(count) = overlap%rotation(n)
6624               tileMe(count) = overlap%tileMe(n)
6625               select case( rotation(count) )
6626               case( ZERO ) ! S->N
6627                  is(count) = overlap%is(n)
6628                  ie(count) = overlap%ie(n)
6629                  js(count) = overlap%js(n) - 1
6630                  je(count) = js(count)
6631               case( MINUS_NINETY ) ! W->N
6632                  is(count) = overlap%is(n) - 1
6633                  ie(count) = is(count)
6634                  js(count) = overlap%js(n)
6635                  je(count) = overlap%je(n)
6636               end select
6637            end if
6638         end do ! do n =1, overlap%count
6639      if(count>0) then
6640         nsend = nsend + 1
6641         bound%send(nsend)%count = count
6642         bound%send(nsend)%pe    = overlap%pe
6643         allocate(bound%send(nsend)%is(count),  bound%send(nsend)%ie(count) )
6644         allocate(bound%send(nsend)%js(count),  bound%send(nsend)%je(count) )
6645         allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6646         allocate(bound%send(nsend)%tileMe(count))
6647         bound%send(nsend)%is(:)       = is(1:count)
6648         bound%send(nsend)%ie(:)       = ie(1:count)
6649         bound%send(nsend)%js(:)       = js(1:count)
6650         bound%send(nsend)%je(:)       = je(1:count)
6651         bound%send(nsend)%dir(:)      = dir(1:count)
6652         bound%send(nsend)%tileMe(:)   = tileMe(1:count)
6653         bound%send(nsend)%rotation(:) = rotation(1:count)
6654      end if
6655   end do ! end  do list = 0, nlist
6656   endif
6657
6658   !--- loop over the list of domains to find the boundary overlap for recv
6659   bound%nsend = nsend
6660   nrecvl(:,:) = 0
6661   nrecv       = 0
6662
6663   !--- will computing overlap for tripolar grid.
6664   if( domain%ntiles == 1 ) then
6665      ! currently only set up for west and south boundary
6666
6667      ! south boundary for recv
6668      pe_south1 = NULL_PE; pe_south2 = NULL_PE
6669      if( position == NORTH .OR. position == CORNER ) then
6670         inbr = ipos; jnbr = jpos - 1
6671         if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6672         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6673            pe_south1 = domain%pearray(inbr,jnbr)
6674            is_south1 = isc + ishift; ie_south1 = iec+ishift
6675            js_south1 = jsc;          je_south1 = js_south1
6676         endif
6677      endif
6678
6679      !--- south boudary for recv:  the southwest point when position is NORTH
6680      if( position == CORNER ) then
6681         inbr = ipos - 1; jnbr = jpos - 1
6682         if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6683         if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6684         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6685            pe_south2 = domain%pearray(inbr,jnbr)
6686            is_south2 = isc; ie_south2 = is_south2
6687            js_south2 = jsc; je_south2 = js_south2
6688         endif
6689      endif
6690
6691
6692      !---west boundary for recv
6693      pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6694      if( position == EAST ) then
6695         inbr = ipos-1; jnbr = jpos
6696         if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6697         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6698            pe_west1 = domain%pearray(inbr,jnbr)
6699            is_west1 = isc;          ie_west1 = is_west1
6700            js_west1 = jsc + jshift; je_west1 = jec + jshift
6701         endif
6702      else if ( position == CORNER ) then  ! possible split into two parts.
6703         !--- on the fold.
6704         if( folded_north .AND. jec == jeg .AND. ipos .GT. npes_x/2 ) then
6705            inbr = npes_x - ipos - 1; jnbr = jpos
6706            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6707                pe_west0 = domain%pearray(inbr,jnbr)
6708                is_west0 = isc;        ie_west0 = is_west0
6709                js_west0 = jec+jshift; je_west0 = js_west0
6710            endif
6711            inbr = ipos-1; jnbr = jpos
6712            if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6713            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6714               pe_west1 = domain%pearray(inbr,jnbr)
6715               is_west1 = isc;          ie_west1 = is_west1
6716               js_west1 = jsc + jshift; je_west1 = jec
6717            endif
6718         else
6719            inbr = ipos-1; jnbr = jpos
6720            if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6721            if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6722               pe_west1 = domain%pearray(inbr,jnbr)
6723               is_west1 = isc;          ie_west1 = is_west1
6724               js_west1 = jsc + jshift; je_west1 = jec+jshift
6725            endif
6726         endif
6727      endif
6728
6729      !--- west boundary for recv: the southwest point when position is CORNER
6730      if( position == CORNER ) then
6731         inbr = ipos - 1; jnbr = jpos - 1
6732         if( inbr == -1 .AND. x_cyclic) inbr = npes_x - 1
6733         if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y - 1
6734         if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6735            pe_west2 = domain%pearray(inbr,jnbr)
6736            is_west2 = isc; ie_west2 = is_west2
6737            js_west2 = jsc; je_west2 = js_west2
6738         endif
6739      endif
6740
6741      tMe = 1
6742      do list = 0,nlist-1
6743         m = mod( domain%pos+nlist-list, nlist )
6744         count = 0
6745         my_pe = domain%list(m)%pe
6746         if(my_pe == pe_south1) then
6747            count = count + 1
6748            is(count) = is_south1; ie(count) = ie_south1
6749            js(count) = js_south1; je(count) = je_south1
6750            dir(count) = 2
6751            rotation(count) = ZERO
6752            index(count) = 1 + ishift
6753         endif
6754         if(my_pe == pe_south2) then
6755            count = count + 1
6756            is(count) = is_south2; ie(count) = ie_south2
6757            js(count) = js_south2; je(count) = je_south2
6758            dir(count) = 2
6759            rotation(count) = ZERO
6760            index(count) = 1
6761         endif
6762         if(my_pe == pe_west0) then
6763            count = count + 1
6764            is(count) = is_west0; ie(count) = ie_west0
6765            js(count) = js_west0; je(count) = je_west0
6766            dir(count) = 3
6767            rotation(count) = ONE_HUNDRED_EIGHTY
6768            index(count) = jec-jsc+1+jshift
6769         endif
6770         if(my_pe == pe_west1) then
6771            count = count + 1
6772            is(count) = is_west1; ie(count) = ie_west1
6773            js(count) = js_west1; je(count) = je_west1
6774            dir(count) = 3
6775            rotation(count) = ZERO
6776            index(count) = 1 + jshift
6777         endif
6778         if(my_pe == pe_west2) then
6779            count = count + 1
6780            is(count) = is_west2; ie(count) = ie_west2
6781            js(count) = js_west2; je(count) = je_west2
6782            dir(count) = 3
6783            rotation(count) = ZERO
6784            index(count) = 1
6785         endif
6786
6787         if(count >0) then
6788            nrecv = nrecv + 1
6789            if(nrecv > nlist_recv) call mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv")
6790            bound%recv(nrecv)%count = count
6791            bound%recv(nrecv)%pe    = my_pe
6792            allocate(bound%recv(nrecv)%is(count),     bound%recv(nrecv)%ie(count) )
6793            allocate(bound%recv(nrecv)%js(count),     bound%recv(nrecv)%je(count) )
6794            allocate(bound%recv(nrecv)%dir(count),    bound%recv(nrecv)%index(count)  )
6795            allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6796
6797            bound%recv(nrecv)%is(:)       = is(1:count)
6798            bound%recv(nrecv)%ie(:)       = ie(1:count)
6799            bound%recv(nrecv)%js(:)       = js(1:count)
6800            bound%recv(nrecv)%je(:)       = je(1:count)
6801            bound%recv(nrecv)%dir(:)      = dir(1:count)
6802            bound%recv(nrecv)%tileMe(:)   = 1
6803            bound%recv(nrecv)%rotation(:) = rotation(1:count)
6804            bound%recv(nrecv)%index(:)        = index(1:count)
6805         endif
6806      enddo
6807   else
6808      do m = 1, update%nrecv
6809         overlap => update%recv(m)
6810         if( overlap%count == 0 ) cycle
6811         count = 0
6812         do n = 1, overlap%count
6813            !--- currently not support folded-north
6814            if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6815            if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
6816               count=count+1
6817               dir(count) = 1
6818               rotation(count) = overlap%rotation(n)
6819               tileMe(count)   = overlap%tileMe(n)
6820               is(count) = overlap%is(n) - 1
6821               ie(count) = is(count)
6822               js(count) = overlap%js(n)
6823               je(count) = overlap%je(n)
6824               tMe                        = tileMe(count)
6825               nrecvl(tMe, 1) = nrecvl(tMe,1) + 1
6826               isl  (tMe,1,nrecvl(tMe, 1)) = is  (count)
6827               iel  (tMe,1,nrecvl(tMe, 1)) = ie  (count)
6828               jsl  (tMe,1,nrecvl(tMe, 1)) = js  (count)
6829               jel  (tMe,1,nrecvl(tMe, 1)) = je  (count)
6830            end if
6831
6832            if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3) then ! south
6833               count=count+1
6834               dir(count) = 2
6835               rotation(count) = overlap%rotation(n)
6836               tileMe(count)   = overlap%tileMe(n)
6837               is(count) = overlap%is(n)
6838               ie(count) = overlap%ie(n)
6839               js(count) = overlap%je(n) + 1
6840               je(count) = js(count)
6841               tMe                        = tileMe(count)
6842               nrecvl(tMe, 2) = nrecvl(tMe,2) + 1
6843               isl  (tMe,2,nrecvl(tMe, 2)) = is  (count)
6844               iel  (tMe,2,nrecvl(tMe, 2)) = ie  (count)
6845               jsl  (tMe,2,nrecvl(tMe, 2)) = js  (count)
6846               jel  (tMe,2,nrecvl(tMe, 2)) = je  (count)
6847            end if
6848
6849            if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5) then ! west
6850               count=count+1
6851               dir(count) = 3
6852               rotation(count) = overlap%rotation(n)
6853               tileMe(count)   = overlap%tileMe(n)
6854               is(count) = overlap%ie(n) + 1
6855               ie(count) = is(count)
6856               js(count) = overlap%js(n)
6857               je(count) = overlap%je(n)
6858               tMe                        = tileMe(count)
6859               nrecvl(tMe, 3) = nrecvl(tMe,3) + 1
6860               isl  (tMe,3,nrecvl(tMe, 3)) = is  (count)
6861               iel  (tMe,3,nrecvl(tMe, 3)) = ie  (count)
6862               jsl  (tMe,3,nrecvl(tMe, 3)) = js  (count)
6863               jel  (tMe,3,nrecvl(tMe, 3)) = je  (count)
6864            end if
6865
6866            if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7) then ! north
6867               count=count+1
6868               dir(count) = 4
6869               rotation(count) = overlap%rotation(n)
6870               tileMe(count) = overlap%tileMe(n)
6871               is(count) = overlap%is(n)
6872               ie(count) = overlap%ie(n)
6873               js(count) = overlap%js(n) - 1
6874               je(count) = js(count)
6875               tMe                        = tileMe(count)
6876               nrecvl(tMe, 4) = nrecvl(tMe,4) + 1
6877               isl  (tMe,4,nrecvl(tMe, 4)) = is  (count)
6878               iel  (tMe,4,nrecvl(tMe, 4)) = ie  (count)
6879               jsl  (tMe,4,nrecvl(tMe, 4)) = js  (count)
6880               jel  (tMe,4,nrecvl(tMe, 4)) = je  (count)
6881            end if
6882         end do ! do n = 1, overlap%count
6883         if(count>0) then
6884            nrecv = nrecv + 1
6885            bound%recv(nrecv)%count = count
6886            bound%recv(nrecv)%pe    = overlap%pe
6887            allocate(bound%recv(nrecv)%is(count),     bound%recv(nrecv)%ie(count) )
6888            allocate(bound%recv(nrecv)%js(count),     bound%recv(nrecv)%je(count) )
6889            allocate(bound%recv(nrecv)%dir(count),    bound%recv(nrecv)%index(count)  )
6890            allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6891            bound%recv(nrecv)%is(:)       = is(1:count)
6892            bound%recv(nrecv)%ie(:)       = ie(1:count)
6893            bound%recv(nrecv)%js(:)       = js(1:count)
6894            bound%recv(nrecv)%je(:)       = je(1:count)
6895            bound%recv(nrecv)%dir(:)      = dir(1:count)
6896            bound%recv(nrecv)%tileMe(:)   = tileMe(1:count)
6897            bound%recv(nrecv)%rotation(:) = rotation(1:count)
6898         end if
6899      end do ! end  do list = 0, nlist
6900      !--- find the boundary index for each contact within the east boundary
6901      do m = 1, nrecv
6902         do n = 1, bound%recv(m)%count
6903            tMe = bound%recv(m)%tileMe(n)
6904            dr = bound%recv(m)%dir(n)
6905            bound%recv(m)%index(n) = 1
6906            do l = 1, nrecvl(tMe,dr)
6907               if(dr == 1 .OR. dr == 3) then  ! EAST, WEST
6908                  if( bound%recv(m)%js(n) > jsl(tMe, dr, l) ) then
6909                     if( bound%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) then
6910                        bound%recv(m)%index(n) = bound%recv(m)%index(n)                  + &
6911                             max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l))+1, &
6912                             abs(iel(tMe, dr, l)-isl(tMe, dr, l))+1)
6913                     else
6914                        bound%recv(m)%index(n) = bound%recv(m)%index(n)                  + &
6915                             max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6916                             abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - jshift
6917                     endif
6918                  end if
6919               else                             ! South, North
6920                  if( bound%recv(m)%is(n) > isl(tMe, dr, l) ) then
6921                     bound%recv(m)%index(n) = bound%recv(m)%index(n)                  + &
6922                          max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6923                          abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - ishift
6924                  end if
6925               end if
6926            end do
6927         end do
6928      end do
6929
6930   endif
6931   bound%nrecv = nrecv
6932
6933
6934 end subroutine set_bound_overlap
6935
6936
6937 !#############################################################################
6938
6939 subroutine fill_corner_contact(eCont, sCont, wCont, nCont, isg, ieg, jsg, jeg, numR, numS, tileRecv, tileSend, &
6940  is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv,         &
6941  is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send,         &
6942  align1Recv, align2Recv, align1Send, align2Send,                                 &
6943  whalo, ehalo, shalo, nhalo, tileMe)
6944 type(contact_type), dimension(:), intent(in) :: eCont, sCont, wCont, nCont
6945 integer, dimension(:),            intent(in) :: isg, ieg, jsg, jeg
6946 integer,                       intent(inout) :: numR, numS
6947 integer, dimension(:),         intent(inout) :: tileRecv, tileSend
6948 integer, dimension(:),         intent(inout) :: is1Recv, ie1Recv, js1Recv, je1Recv
6949 integer, dimension(:),         intent(inout) :: is2Recv, ie2Recv, js2Recv, je2Recv
6950 integer, dimension(:),         intent(inout) :: is1Send, ie1Send, js1Send, je1Send
6951 integer, dimension(:),         intent(inout) :: is2Send, ie2Send, js2Send, je2Send
6952 integer, dimension(:),         intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
6953 integer,                          intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
6954 integer                                      :: is1, ie1, js1, je1, is2, ie2, js2, je2
6955 integer                                      :: tn, tc, n, m
6956 logical                                      :: found_corner
6957
6958 found_corner = .false.
6959 !--- southeast for recving
6960 if(eCont(tileMe)%ncontact > 0) then
6961  if(eCont(tileMe)%js1(1) == jsg(tileMe) ) then
6962     tn = eCont(tileMe)%tile(1)
6963     if(econt(tileMe)%js2(1) > jsg(tn) ) then  ! the corner tile is tn.
6964        if( econt(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
6965             "mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
6966        found_corner = .true.; tc = tn
6967        is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6968        is2 = eCont(tileMe)%is2(1);     je2 = eCont(tileMe)%js2(1) - 1
6969     else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
6970        if(sCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
6971           found_corner = .true.; tc = sCont(tn)%tile(1)
6972           is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6973           is2 = sCont(tn)%is2(1);         je2 = sCont(tn)%je2(1)
6974        end if
6975     end if
6976  end if
6977 end if
6978 if( .not. found_corner ) then  ! not found,
6979  n = sCont(tileMe)%ncontact
6980  if( n > 0) then
6981     if( sCont(tileMe)%ie1(n) == ieg(tileMe)) then
6982        tn = sCont(tileMe)%tile(n)
6983        if(scont(tileMe)%ie2(n) < ieg(tn) ) then  ! the corner tile is tn.
6984           if(ieg(tn) - scont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
6985                "mpp_domains_define.inc: southeast tile for recv 2 is not tiled properly")
6986           found_corner = .true.; tc = tn
6987           is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
6988           is2 = sCont(tileMe)%ie2(n) + 1; je2 = sCont(tileMe)%je2(n)
6989        else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
6990           m = eCont(tn)%ncontact
6991           if(eCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
6992              found_corner = .true.; tc = eCont(tn)%tile(m)
6993              is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
6994              is2 = eCont(tn)%is2(m);         je2 = eCont(tn)%je2(m)
6995           end if
6996        end if
6997     end if
6998  end if
6999 end if
7000 if(found_corner) then
7001  numR = numR + 1
7002  tileRecv(numR) = tc; align1Recv(numR) = SOUTH_EAST;  align2Recv(numR) = NORTH_WEST
7003  is1Recv(numR) = is1;             ie1Recv(numR) = is1 + ehalo - 1
7004  js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
7005  is2Recv(numR) = is2;             ie2Recv(numR) = is2 + ehalo - 1
7006  js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
7007 end if
7008
7009 !--- southwest for recving
7010 found_corner = .false.
7011 if(wCont(tileMe)%ncontact > 0) then
7012  if(wCont(tileMe)%js1(1) == jsg(tileMe) ) then
7013     tn = wCont(tileMe)%tile(1)
7014     if(wcont(tileMe)%js2(1) > jsg(tn) ) then  ! the corner tile is tn.
7015        if( wcont(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
7016             "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7017        found_corner = .true.; tc = tn
7018        ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7019        ie2 = wCont(tileMe)%is2(1);     je2 = wCont(tileMe)%js2(1) - 1
7020     else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7021        n = sCont(tn)%ncontact
7022        if(sCont(tn)%ie1(n) == ieg(tn)) then ! corner is nc.
7023           found_corner = .true.;  tc = sCont(tn)%tile(n)
7024           ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7025           ie2 = sCont(tn)%ie2(1);         je2 = sCont(tn)%je2(1)
7026        end if
7027     end if
7028  end if
7029 end if
7030 if( .not. found_corner ) then  ! not found,
7031  n = sCont(tileMe)%ncontact
7032  if( n > 0) then
7033     if( sCont(tileMe)%is1(1) == isg(tileMe)) then
7034        tn = sCont(tileMe)%tile(1)
7035        if(sCont(tileMe)%is2(1) > isg(tn) ) then  ! the corner tile is tn.
7036           if( scont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
7037                "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7038           found_corner = .true.; tc = tn
7039           ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7040           ie2 = sCont(tileMe)%is2(1) - 1; je2 = sCont(tileMe)%js2(1)
7041        else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7042           m = wCont(tn)%ncontact
7043           if(wCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
7044              found_corner = .true.; tc = wCont(tn)%tile(m)
7045              ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7046              ie2 = wCont(tn)%ie2(m);         je2 = wCont(tn)%je2(m)
7047           end if
7048        end if
7049     end if
7050  end if
7051 end if
7052 if(found_corner) then
7053  numR = numR + 1
7054  tileRecv(numR) = tc; align1Recv(numR) = SOUTH_WEST; align2Recv(numR) = NORTH_EAST
7055  is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7056  js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
7057  is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7058  js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
7059 end if
7060
7061 !--- northwest for recving
7062 found_corner = .false.
7063 n = wCont(tileMe)%ncontact
7064 if( n > 0) then
7065  if(wCont(tileMe)%je1(n) == jeg(tileMe) ) then
7066     tn = wCont(tileMe)%tile(n)
7067     if(wcont(tileMe)%je2(n) < jeg(tn) ) then  ! the corner tile is tn.
7068        if( jeg(tn) - wcont(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
7069             "mpp_domains_define.inc: northwest tile for recv 1 is not tiled properly")
7070        found_corner = .true.; tc = tn
7071        ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
7072        ie2 = wCont(tileMe)%is2(n);     js2 = wCont(tileMe)%je2(n) + 1
7073     else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7074        m = nCont(tn)%ncontact
7075        if(nCont(tn)%ie1(m) == ieg(tn)) then ! corner is nc.
7076           found_corner = .true.; tc = nCont(tn)%tile(m)
7077           ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
7078           ie2 = nCont(tn)%ie2(m);         js2 = nCont(tn)%js2(m)
7079        end if
7080     endif
7081  endif
7082 end if
7083 if( .not. found_corner ) then  ! not found,
7084  if( nCont(tileMe)%ncontact > 0) then
7085     if( nCont(tileMe)%is1(1) == isg(tileMe)) then
7086        tn = nCont(tileMe)%tile(1)
7087        if(nCont(tileMe)%is2(1) > isg(tn) ) then  ! the corner tile is tn.
7088           if( ncont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
7089                "mpp_domains_define.inc: northwest tile for recv 2 is not tiled properly")
7090           found_corner = .true.; tc = tn
7091           ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7092           ie2 = nCont(tileMe)%is2(1) - 1; js2 = nCont(tileMe)%js2(1)
7093        else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7094           if(wCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7095              found_corner = .true.; tc = wCont(tn)%tile(1)
7096              ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7097              ie2 = wCont(tn)%ie2(1);         js2 = wCont(tn)%js2(1)
7098           end if
7099        end if
7100     end if
7101  end if
7102 end if
7103 if(found_corner) then
7104  numR = numR + 1
7105  tileRecv(numR) = tc; align1Recv(numR) =NORTH_WEST;  align2Recv(numR) = SOUTH_EAST
7106  is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7107  js1Recv(numR) = js1;             je1Recv(numR) = js1 + nhalo - 1
7108  is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7109  js2Recv(numR) = js2;             je2Recv(numR) = js2 + nhalo - 1
7110 end if
7111
7112 !--- northeast for recving
7113 found_corner = .false.
7114 n = eCont(tileMe)%ncontact
7115 if( n > 0) then
7116  if(eCont(tileMe)%je1(n) == jeg(tileMe) ) then
7117     tn = eCont(tileMe)%tile(n)
7118     if(econt(tileMe)%je2(n) < jeg(tn) ) then  ! the corner tile is tn.
7119        if( jeg(tn) - econt(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
7120             "mpp_domains_define.inc: northeast tile for recv 1 is not tiled properly")
7121        found_corner = .true.; tc = tn
7122        is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
7123        is2 = eCont(tileMe)%is2(1);     js2 = eCont(tileMe)%je2(1) + 1
7124     else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7125        if(nCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
7126           found_corner = .true.; tc = nCont(tn)%tile(1)
7127           is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
7128           is2 = nCont(tn)%is2(1);         js2 = nCont(tn)%js2(1)
7129        end if
7130     end if
7131  end if
7132 end if
7133 if( .not. found_corner ) then  ! not found,
7134  n = nCont(tileMe)%ncontact
7135  if( n > 0) then
7136     if( nCont(tileMe)%ie1(n) == ieg(tileMe)) then
7137        tn = nCont(tileMe)%tile(n)
7138        if(nCont(tileMe)%ie2(n) < ieg(tn) ) then  ! the corner tile is tn.
7139           if(ieg(tn) - sCont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
7140                "mpp_domains_define.inc: northeast tile for recv 2 is not tiled properly")
7141           found_corner = .true.; tc = tn
7142           is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
7143           is2 = sCont(tileMe)%ie2(n) + 1; js2 = sCont(tileMe)%js2(n)
7144        else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
7145           if(eCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7146              found_corner = .true.; tc = eCont(tn)%tile(1)
7147              is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
7148              is2 = eCont(tn)%is2(m);         js2 = eCont(tn)%js2(m)
7149           end if
7150        end if
7151     end if
7152  end if
7153 end if
7154 if(found_corner) then
7155  numR = numR + 1
7156  tileRecv(numR) = tc; align1Recv(numR) =NORTH_EAST;  align2Recv(numR) = SOUTH_WEST
7157  is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
7158  js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
7159  is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
7160  js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
7161 end if
7162
7163 !--- to_pe's southeast for sending
7164 do n = 1, wCont(tileMe)%ncontact
7165  tn = wCont(tileMe)%tile(n)
7166  if(wCont(tileMe)%js2(n) == jsg(tn) ) then
7167     if(wcont(tileMe)%js1(n) > jsg(tileMe) ) then  ! send to  tile tn.
7168        if( wcont(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
7169             "mpp_domains_define.inc: southeast tile for send 1 is not tiled properly")
7170        numS = numS+1; tileSend(numS) = tn
7171        align1Send(numS) = NORTH_WEST;  align2Send(numS) = SOUTH_EAST
7172        is1Send(numS) = wCont(tileMe)%is1(n);     ie1Send(numS) = is1Send(numS) + ehalo - 1
7173        je1Send(numS) = wCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7174        is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7175        je2Send(numS) = wCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7176     end if
7177  end if
7178 end do
7179 do n = 1, nCont(tileMe)%ncontact
7180  tn = nCont(tileMe)%tile(n)
7181  if(nCont(tileMe)%ie2(n) == ieg(tn) ) then
7182     if(nCont(tileMe)%ie1(n) < ieg(tileMe) ) then  ! send to  tile tn.
7183        if( ieg(tileMe) - nCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
7184             "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7185        numS = numS+1; tileSend(numS) = tn
7186        align1Send(numS) = NORTH_WEST;  align2Send(numS) = SOUTH_EAST
7187        is1Send(numS) = nCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7188        je1Send(numS) = nCont(tileMe)%je1(n)    ; js1Send(numS) = je1Send(numS) - shalo + 1
7189        is2Send(numS) = nCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7190        je2Send(numS) = nCont(tileMe)%je2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7191     end if
7192  end if
7193 end do
7194
7195 !--- found the corner overlap that is not specified through contact line.
7196 n = wCont(tileMe)%ncontact
7197 found_corner = .false.
7198 if( n > 0) then
7199  tn = wCont(tileMe)%tile(n)
7200  if( wCont(tileMe)%je1(n) == jeg(tileMe) .AND. wCont(tileMe)%je2(n) == jeg(tn) ) then
7201     m = nCont(tn)%ncontact
7202     if(m >0) then
7203        tc = nCont(tn)%tile(m)
7204        if( nCont(tn)%ie1(m) == ieg(tn) .AND. nCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7205     end if
7206  end if
7207 end if
7208 if( .not. found_corner ) then  ! not found, then starting from north contact
7209  if( nCont(tileMe)%ncontact > 0) then
7210     tn = nCont(tileMe)%tile(1)
7211     if( nCont(tileMe)%is1(1) == isg(tileMe) .AND. nCont(tileMe)%is2(1) == isg(tn) ) then
7212        if(wCont(tn)%ncontact >0) then
7213           tc = wCont(tn)%tile(1)
7214           if( wCont(tn)%js1(1) == jsg(tn) .AND. wCont(tn)%js2(1) == jsg(tc) ) found_corner = .true.
7215        end if
7216     end if
7217  end if
7218 end if
7219
7220 if(found_corner) then
7221  numS = numS+1; tileSend(numS) = tc
7222  align1Send(numS) = NORTH_WEST;  align2Send(numS) = SOUTH_EAST
7223  is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7224  je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7225  is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7226  je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7227 end if
7228
7229 !--- to_pe's southwest for sending
7230 do n = 1, eCont(tileMe)%ncontact
7231  tn = eCont(tileMe)%tile(n)
7232  if(eCont(tileMe)%js2(n) == jsg(tn) ) then
7233     if(econt(tileMe)%js1(n) > jsg(tileMe) ) then  ! send to  tile tn.
7234        if( econt(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
7235             "mpp_domains_define.inc: southwest tile for send 1 is not tiled properly")
7236        numS = numS+1; tileSend(numS) = tn
7237        align1Send(numS) = NORTH_EAST;  align2Send(numS) = SOUTH_WEST
7238        ie1Send(numS) = eCont(tileMe)%ie1(n);     is1Send(numS) = ie1Send(numS) - whalo + 1
7239        je1Send(numS) = eCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7240        ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7241        je2Send(numS) = eCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7242     end if
7243  end if
7244 end do
7245 do n = 1, nCont(tileMe)%ncontact
7246  tn = nCont(tileMe)%tile(n)
7247  if(nCont(tileMe)%is2(n) == isg(tn) ) then
7248     if(ncont(tileMe)%is1(n) > isg(tileMe) ) then  ! send to  tile tn.
7249        if( ncont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
7250             "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7251        numS = numS+1; tileSend(numS) = tn
7252        align1Send(numS) = NORTH_EAST;  align2Send(numS) = SOUTH_WEST
7253        ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7254        ie1Send(numS) = nCont(tileMe)%je1(n)    ; js1Send(numS) = je1Send(numS) - shalo + 1
7255        ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = je2Send(numS) - whalo + 1
7256        je2Send(numS) = nCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7257     end if
7258  end if
7259 end do
7260
7261 !--- found the corner overlap that is not specified through contact line.
7262 n = eCont(tileMe)%ncontact
7263 found_corner = .false.
7264 if( n > 0) then
7265  tn = eCont(tileMe)%tile(n)
7266  if( eCont(tileMe)%je1(n) == jeg(tileMe) .AND. eCont(tileMe)%je2(n) == jeg(tn) ) then
7267     if(nCont(tn)%ncontact >0) then
7268        tc = nCont(tn)%tile(1)
7269        if( nCont(tn)%is1(1) == isg(tn) .AND. nCont(tn)%is2(n) == isg(tc) ) found_corner = .true.
7270     end if
7271  end if
7272 end if
7273 if( .not. found_corner ) then  ! not found, then starting from north contact
7274  n = nCont(tileMe)%ncontact
7275  if( n > 0) then
7276     tn = nCont(tileMe)%tile(n)
7277     if( nCont(tileMe)%ie1(n) == ieg(tileMe) .AND. nCont(tileMe)%ie2(n) == ieg(tn) ) then
7278        if(eCont(tn)%ncontact >0) then
7279           tc = eCont(tn)%tile(1)
7280           if( eCont(tn)%js1(1) == jsg(tn) .AND. eCont(tn)%js2(n) == jsg(tc) ) found_corner = .true.
7281        end if
7282     end if
7283  end if
7284 end if
7285
7286 if(found_corner) then
7287  numS = numS+1; tileSend(numS) = tc
7288  align1Send(numS) = NORTH_EAST;  align2Send(numS) = SOUTH_WEST
7289  ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7290  je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7291  ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7292  je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7293 end if
7294
7295 !--- to_pe's northwest for sending
7296 do n = 1, eCont(tileMe)%ncontact
7297  tn = eCont(tileMe)%tile(n)
7298  if(eCont(tileMe)%je2(n) == jeg(tn) ) then
7299     if(econt(tileMe)%je1(n) < jeg(tileMe) ) then  ! send to  tile tn.
7300        if( jeg(tileMe) - econt(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
7301             "mpp_domains_define.inc: northwest tile for send 1 is not tiled properly")
7302        numS = numS+1; tileSend(numS) = tn
7303        align1Send(numS) = SOUTH_EAST;  align2Send(numS) = NORTH_WEST
7304        ie1Send(numS) = eCont(tileMe)%ie1(n)    ; is1Send(numS) = ie1Send(numS) - whalo + 1
7305        js1Send(numS) = eCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7306        ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7307        js2Send(numS) = eCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7308     end if
7309  end if
7310 end do
7311
7312 do n = 1, sCont(tileMe)%ncontact
7313  tn = sCont(tileMe)%tile(n)
7314  if(sCont(tileMe)%is2(n) == isg(tn) ) then
7315     if(scont(tileMe)%is1(n) > isg(tileMe) ) then  ! send to  tile tn.
7316        if( scont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
7317             "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7318        numS = numS+1; tileSend(numS) = tn
7319        align1Send(numS) = SOUTH_EAST;  align2Send(numS) = NORTH_WEST
7320        ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7321        js1Send(numS) = nCont(tileMe)%je1(n)    ; je1Send(numS) = js1Send(numS) + nhalo - 1
7322        ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7323        js2Send(numS) = nCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7324     end if
7325  end if
7326 end do
7327
7328 !--- found the corner overlap that is not specified through contact line.
7329 n = eCont(tileMe)%ncontact
7330 found_corner = .false.
7331 if( n > 0) then
7332  tn = eCont(tileMe)%tile(1)
7333  if( eCont(tileMe)%js1(1) == jsg(tileMe) .AND. eCont(tileMe)%js2(1) == jsg(tn) ) then
7334     if(sCont(tn)%ncontact >0) then
7335        tc = sCont(tn)%tile(1)
7336        if( sCont(tn)%is1(1) == isg(tn) .AND. sCont(tn)%is2(1) == isg(tc) ) found_corner = .true.
7337     end if
7338  end if
7339 end if
7340 if( .not. found_corner ) then  ! not found, then starting from north contact
7341  n = sCont(tileMe)%ncontact
7342  found_corner = .false.
7343  if( n > 0) then
7344     tn = sCont(tileMe)%tile(n)
7345     if( sCont(tileMe)%ie1(n) == ieg(tileMe) .AND. sCont(tileMe)%ie2(n) == ieg(tn) ) then
7346        if(eCont(tn)%ncontact >0) then
7347           tc = eCont(tn)%tile(n)
7348           if( eCont(tn)%je1(n) == jeg(tn) .AND. eCont(tn)%je2(n) == jeg(tc) ) found_corner = .true.
7349        end if
7350     end if
7351  end if
7352 end if
7353
7354 if(found_corner) then
7355  numS = numS+1; tileSend(numS) = tc
7356  align1Send(numS) = SOUTH_EAST;  align2Send(numS) = NORTH_WEST
7357  ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7358  js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7359  ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7360  js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7361 end if
7362
7363 !--- to_pe's northeast for sending
7364 do n = 1, wCont(tileMe)%ncontact
7365  tn = wCont(tileMe)%tile(n)
7366  if(wCont(tileMe)%je2(n) == jeg(tn) ) then
7367     if(wcont(tileMe)%je1(n) < jeg(tileMe) ) then  ! send to  tile tn.
7368        if( jeg(tileMe) - wcont(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
7369             "mpp_domains_define.inc: northeast tile for send 1 is not tiled properly")
7370        numS = numS+1; tileSend(numS) = tn
7371        align1Send(numS) = SOUTH_WEST;  align2Send(numS) = NORTH_EAST
7372        is1Send(numS) = wCont(tileMe)%is1(n)    ; ie1Send(numS) = is1Send(numS) + ehalo - 1
7373        js1Send(numS) = wCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7374        is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7375        js2Send(numS) = wCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7376     end if
7377  end if
7378 end do
7379
7380 do n = 1, sCont(tileMe)%ncontact
7381  tn = sCont(tileMe)%tile(n)
7382  if(sCont(tileMe)%ie2(n) == ieg(tn) ) then
7383     if(sCont(tileMe)%ie1(n) < ieg(tileMe) ) then  ! send to  tile tn.
7384        if( ieg(tileMe) - sCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
7385             "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7386        numS = numS+1; tileSend(numS) = tn
7387        align1Send(numS) = SOUTH_WEST;  align2Send(numS) = NORTH_EAST
7388        is1Send(numS) = sCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7389        js1Send(numS) = sCont(tileMe)%js1(n)    ; je1Send(numS) = js1Send(numS) + nhalo - 1
7390        is2Send(numS) = sCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is1Send(numS) + ehalo - 1
7391        js2Send(numS) = sCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7392     end if
7393  end if
7394 end do
7395
7396 !--- found the corner overlap that is not specified through contact line.
7397 n = wCont(tileMe)%ncontact
7398 found_corner = .false.
7399 if( n > 0) then
7400  tn = wCont(tileMe)%tile(1)
7401  if( wCont(tileMe)%js1(n) == jsg(tileMe) .AND. wCont(tileMe)%js2(n) == jsg(tn) ) then
7402     m = sCont(tn)%ncontact
7403     if(m >0) then
7404        tc = sCont(tn)%tile(m)
7405        if( sCont(tn)%ie1(m) == ieg(tn) .AND. sCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7406     end if
7407  end if
7408 end if
7409 if( .not. found_corner ) then  ! not found, then starting from north contact
7410  n = sCont(tileMe)%ncontact
7411  found_corner = .false.
7412  if( n > 0) then
7413     tn = sCont(tileMe)%tile(1)
7414     if( sCont(tileMe)%is1(1) == isg(tileMe) .AND. sCont(tileMe)%is2(1) == isg(tn) ) then
7415        m = wCont(tn)%ncontact
7416        if( m > 0 ) then
7417           tc = wCont(tn)%tile(m)
7418           if( wCont(tn)%je1(m) == jeg(tn) .AND. wCont(tn)%je2(m) == jeg(tc) ) found_corner = .true.
7419        end if
7420     end if
7421  end if
7422 end if
7423 if(found_corner) then
7424  numS = numS+1; tileSend(numS) = tc
7425  align1Send(numS) = SOUTH_WEST;  align2Send(numS) = NORTH_EAST
7426  is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7427  js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7428  is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7429  js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7430 end if
7431
7432 end subroutine fill_corner_contact
7433
7434 !--- find the alignment direction, check if index is reversed, if reversed, exchange index.
7435 subroutine check_alignment( is, ie, js, je, isg, ieg, jsg, jeg, alignment )
7436 integer, intent(inout) :: is, ie, js, je, isg, ieg, jsg, jeg
7437 integer, intent(out)   :: alignment
7438
7439 integer :: i, j
7440
7441 if ( is == ie ) then      ! x-alignment
7442  if ( is == isg ) then
7443     alignment = WEST
7444  else if ( is == ieg ) then
7445     alignment = EAST
7446  else
7447     call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the x-boundary of the tile')
7448  end if
7449  if ( js > je ) then
7450     j = js; js = je; je = j
7451  end if
7452 else if ( js == je ) then ! y-alignment
7453  if ( js == jsg ) then
7454     alignment = SOUTH
7455  else if ( js == jeg ) then
7456     alignment = NORTH
7457  else
7458     call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the y-boundary of the tile')
7459  end if
7460  if ( is > ie ) then
7461     i = is; is = ie; ie = i
7462  end if
7463 else
7464  call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region should be line contact' )
7465 end if
7466
7467 end subroutine check_alignment
7468 !#####################################################################
7469
7470 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7471 !                                                                             !
7472 !              MPP_MODIFY_DOMAIN: modify extent of domain                     !
7473 !                                                                             !
7474 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7475 ! <SUBROUTINE NAME="mpp_modify_domain1D" INTERFACE="mpp_modify_domain">
7476 !   <IN NAME="domain_in" TYPE="type(domain1D)" > </IN>
7477 !   <IN NAME="hbegin,hend" TYPE="integer,optional" > </IN>
7478 !   <IN NAME="cbegin,cend" TYPE="integer,optional" > </IN>
7479 !   <IN NAME="gbegin,gend" TYPE="integer,optional" > </IN>
7480 !   <INOUT NAME="domain_out" TYPE="type(domain1D)" > </INOUT>
7481
7482 ! <PUBLICROUTINE>
7483 subroutine mpp_modify_domain1D(domain_in,domain_out,cbegin,cend,gbegin,gend, hbegin, hend)
7484   ! </PUBLICROUTINE>
7485 type(domain1D), intent(in)    :: domain_in !< The source domain.
7486 type(domain1D), intent(inout) :: domain_out !< The returned domain.
7487 integer, intent(in), optional :: hbegin, hend !< halo size
7488 integer, intent(in), optional :: cbegin, cend !< Axis specifications associated with the compute
7489                                               !! domain of the returned 1D domain.
7490 integer, intent(in), optional :: gbegin, gend !< Axis specifications associated with the global
7491                                               !! domain of the returned 1D domain.
7492 integer :: ndivs, global_indices(2) !(/ isg, ieg /)
7493 integer                       :: flag
7494 ! get the global indices of the input domain
7495 global_indices(1) = domain_in%global%begin;  global_indices(2) = domain_in%global%end
7496
7497 ! get the layout
7498 ndivs = size(domain_in%list(:))
7499
7500 ! get the flag
7501 flag = 0
7502 if(domain_in%cyclic) flag = flag + CYCLIC_GLOBAL_DOMAIN
7503 if(domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN
7504
7505 call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, &
7506    flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size )
7507
7508 if(present(cbegin)) domain_out%compute%begin = cbegin
7509 if(present(cend))   domain_out%compute%end = cend
7510 domain_out%compute%size = domain_out%compute%end - domain_out%compute%begin + 1
7511 if(present(gbegin)) domain_out%global%begin = gbegin
7512 if(present(gend))   domain_out%global%end = gend
7513 domain_out%global%size = domain_out%global%end - domain_out%global%begin + 1
7514
7515 end subroutine mpp_modify_domain1D
7516 ! </SUBROUTINE>
7517
7518 !#######################################################################
7519 !----------------------------------------------------------------------------------
7520 ! <SUBROUTINE NAME="mpp_modify_domain2D" INTERFACE="mpp_modify_domain">
7521 !   <IN NAME="domain_in" TYPE="type(domain2D)" > </IN>
7522 !   <IN NAME="isc,iec" TYPE="integer,optional" > </IN>
7523 !   <IN NAME="jsc,jec" TYPE="integer,optional" > </IN>
7524 !   <IN NAME="isg,ieg" TYPE="integer,optional" > </IN>
7525 !   <IN NAME="jsg,jeg" TYPE="integer,optional" > </IN>
7526 !   <IN NAME="whalo,ehalo" TYPE="integer,optional" > </IN>
7527 !   <IN NAME="shalo,nhalo" TYPE="integer,optional" > </IN>
7528 !   <INOUT NAME="domain_out" TYPE="type(domain2D)" > </INOUT>
7529
7530 ! <PUBLICROUTINE>
7531 subroutine mpp_modify_domain2D(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, &
7532                               &  shalo, nhalo)
7533   ! </PUBLICROUTINE>
7534 type(domain2D), intent(in)    :: domain_in !< The source domain.
7535 type(domain2D), intent(inout) :: domain_out !< The returned domain.
7536 integer, intent(in), optional :: isc, iec, jsc, jec !< Zonal and meridional axis specifications
7537                                  !! associated with the global domain of the returned 2D domain.
7538 integer, intent(in), optional :: isg, ieg, jsg, jeg !<  Zonal axis specifications associated with
7539                                  !! the global domain of the returned 2D domain.
7540 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo !< halo size in x- and y- directions
7541 integer                       :: global_indices(4), layout(2)
7542 integer                       :: xflag, yflag, nlist, i
7543
7544 if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) then
7545    ! get the global indices of the input domain
7546  global_indices(1) = domain_in%x(1)%global%begin;  global_indices(2) = domain_in%x(1)%global%end
7547  global_indices(3) = domain_in%y(1)%global%begin;  global_indices(4) = domain_in%y(1)%global%end
7548
7549  ! get the layout
7550  layout(1) = size(domain_in%x(1)%list(:)); layout(2) = size(domain_in%y(1)%list(:))
7551
7552  ! get the flag
7553  xflag = 0; yflag = 0
7554  if(domain_in%x(1)%cyclic) xflag = xflag + CYCLIC_GLOBAL_DOMAIN
7555  if(domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN
7556  if(domain_in%y(1)%cyclic) yflag = yflag + CYCLIC_GLOBAL_DOMAIN
7557  if(domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN
7558
7559  call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, &
7560       xflags = xflag, yflags = yflag,  whalo = whalo, ehalo = ehalo,     &
7561       shalo = shalo, nhalo = nhalo,                                      &
7562       xextent = domain_in%x(1)%list(:)%compute%size,                     &
7563       yextent = domain_in%y(1)%list(:)%compute%size,                     &
7564       symmetry=domain_in%symmetry,                                       &
7565       maskmap = domain_in%pearray .NE. NULL_PE )
7566  domain_out%ntiles = domain_in%ntiles
7567  domain_out%tile_id = domain_in%tile_id
7568 else
7569  call mpp_define_null_domain(domain_out)
7570  nlist = size(domain_in%list(:))
7571  allocate(domain_out%list(0:nlist-1) )
7572  do i = 0, nlist-1
7573     allocate(domain_out%list(i)%tile_id(1))
7574     domain_out%list(i)%tile_id(1) = 1
7575  enddo
7576  call mpp_modify_domain(domain_in%x(1), domain_out%x(1), isc, iec, isg, ieg)
7577  call mpp_modify_domain(domain_in%y(1), domain_out%y(1), jsc, jec, jsg, jeg)
7578  domain_out%ntiles = domain_in%ntiles
7579  domain_out%tile_id = domain_in%tile_id
7580 endif
7581
7582 end subroutine mpp_modify_domain2D
7583 ! </SUBROUTINE>
7584
7585 !#####################################################################
7586
7587
7588 subroutine mpp_define_null_domain1D(domain)
7589 type(domain1D), intent(inout) :: domain
7590
7591 domain%global%begin  = -1; domain%global%end  = -1; domain%global%size = 0
7592 domain%data%begin    = -1; domain%data%end    = -1; domain%data%size = 0
7593 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
7594 domain%pe = NULL_PE
7595
7596 end subroutine mpp_define_null_domain1D
7597
7598 !#####################################################################
7599
7600
7601 subroutine mpp_define_null_domain2D(domain)
7602 type(domain2D), intent(inout) :: domain
7603
7604 allocate(domain%x(1), domain%y(1), domain%tile_id(1))
7605 call mpp_define_null_domain(domain%x(1))
7606 call mpp_define_null_domain(domain%y(1))
7607 domain%pe = NULL_PE
7608 domain%tile_id(1)   = 1
7609 domain%ntiles       = 1
7610 domain%max_ntile_pe = 1
7611 domain%ncontacts    = 0
7612
7613 end subroutine mpp_define_null_domain2D
7614
7615 !####################################################################
7616
7617 subroutine mpp_deallocate_domain1D(domain)
7618   type(domain1D), intent(inout) :: domain
7619
7620   if(ASSOCIATED(domain%list)) deallocate(domain%list)
7621
7622 end subroutine mpp_deallocate_domain1D
7623
7624 !####################################################################
7625
7626 subroutine mpp_deallocate_domain2D(domain)
7627   type(domain2D), intent(inout) :: domain
7628
7629   call deallocate_domain2D_local(domain)
7630   if(ASSOCIATED(domain%io_domain) ) then
7631      call deallocate_domain2D_local(domain%io_domain)
7632      deallocate(domain%io_domain)
7633   endif
7634
7635 end subroutine mpp_deallocate_domain2D
7636
7637 !##################################################################
7638
7639 subroutine deallocate_domain2D_local(domain)
7640 type(domain2D), intent(inout) :: domain
7641 integer :: i, ntileMe
7642
7643 ntileMe = size(domain%x(:))
7644
7645 if(ASSOCIATED(domain%pearray))deallocate(domain%pearray)
7646 do i = 1, ntileMe
7647    call mpp_deallocate_domain1D(domain%x(i))
7648    call mpp_deallocate_domain1D(domain%y(i))
7649 enddo
7650 deallocate(domain%x, domain%y, domain%tile_id)
7651
7652 ! TODO: Check if these are always allocated
7653 if(ASSOCIATED(domain%tileList)) deallocate(domain%tileList)
7654 if(ASSOCIATED(domain%tile_id_all)) deallocate(domain%tile_id_all)
7655
7656 if(ASSOCIATED(domain%list)) then
7657  do i = 0, size(domain%list(:))-1
7658     deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id)
7659  enddo
7660  deallocate(domain%list)
7661 endif
7662
7663 if(ASSOCIATED(domain%check_C)) then
7664   call deallocate_overlapSpec(domain%check_C)
7665   deallocate(domain%check_C)
7666 endif
7667
7668 if(ASSOCIATED(domain%check_E)) then
7669   call deallocate_overlapSpec(domain%check_E)
7670   deallocate(domain%check_E)
7671 endif
7672
7673 if(ASSOCIATED(domain%check_N)) then
7674   call deallocate_overlapSpec(domain%check_N)
7675   deallocate(domain%check_N)
7676 endif
7677
7678 if(ASSOCIATED(domain%bound_C)) then
7679   call deallocate_overlapSpec(domain%bound_C)
7680   deallocate(domain%bound_C)
7681 endif
7682
7683 if(ASSOCIATED(domain%bound_E)) then
7684   call deallocate_overlapSpec(domain%bound_E)
7685   deallocate(domain%bound_E)
7686 endif
7687
7688 if(ASSOCIATED(domain%bound_N)) then
7689   call deallocate_overlapSpec(domain%bound_N)
7690   deallocate(domain%bound_N)
7691 endif
7692
7693 if(ASSOCIATED(domain%update_T)) then
7694   call deallocate_overlapSpec(domain%update_T)
7695   deallocate(domain%update_T)
7696 endif
7697
7698 if(ASSOCIATED(domain%update_E)) then
7699   call deallocate_overlapSpec(domain%update_E)
7700   deallocate(domain%update_E)
7701 endif
7702
7703 if(ASSOCIATED(domain%update_C)) then
7704   call deallocate_overlapSpec(domain%update_C)
7705   deallocate(domain%update_C)
7706 endif
7707
7708 if(ASSOCIATED(domain%update_N)) then
7709   call deallocate_overlapSpec(domain%update_N)
7710   deallocate(domain%update_N)
7711 endif
7712
7713 end subroutine deallocate_domain2D_local
7714
7715 !####################################################################
7716
7717 subroutine allocate_check_overlap(overlap, count)
7718   type(overlap_type), intent(inout) :: overlap
7719   integer,            intent(in   ) :: count
7720
7721   overlap%count = 0
7722   overlap%pe    = NULL_PE
7723   if(associated(overlap%tileMe)) call mpp_error(FATAL, &
7724        "allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
7725   if(count < 1)  call mpp_error(FATAL, &
7726        "allocate_check_overlap(mpp_domains_define): count should be a positive integer")
7727   allocate(overlap%tileMe  (count), overlap%dir(count) )
7728   allocate(overlap%is      (count), overlap%ie (count) )
7729   allocate(overlap%js      (count), overlap%je (count) )
7730   allocate(overlap%rotation(count)                     )
7731   overlap%rotation     =  ZERO
7732
7733 end subroutine allocate_check_overlap
7734
7735 !#######################################################################
7736 subroutine insert_check_overlap(overlap, pe, tileMe, dir, rotation, is, ie, js, je)
7737   type(overlap_type), intent(inout) :: overlap
7738   integer,            intent(in   ) :: pe
7739   integer,            intent(in   ) :: tileMe, dir, rotation
7740   integer,            intent(in   ) :: is, ie, js, je
7741   integer                           :: count
7742
7743   overlap%count = overlap%count + 1
7744   count = overlap%count
7745   if(.NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
7746      "mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
7747   if(count > size(overlap%tileMe(:)) ) call mpp_error(FATAL, &
7748      "mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
7749   if( overlap%pe == NULL_PE ) then
7750      overlap%pe = pe
7751   else
7752      if(overlap%pe .NE. pe) call mpp_error(FATAL,  &
7753            "mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
7754   endif
7755   overlap%tileMe  (count) = tileMe
7756   overlap%dir     (count) = dir
7757   overlap%rotation(count) = rotation
7758   overlap%is      (count) = is
7759   overlap%ie      (count) = ie
7760   overlap%js      (count) = js
7761   overlap%je      (count) = je
7762
7763 end subroutine insert_check_overlap
7764
7765 !#######################################################################
7766 !--- this routine add the overlap_in into overlap_out
7767 subroutine add_check_overlap( overlap_out, overlap_in)
7768   type(overlap_type), intent(inout) :: overlap_out
7769   type(overlap_type), intent(in   ) :: overlap_in
7770   type(overlap_type)                :: overlap
7771   integer                          :: count, count_in, count_out
7772
7773   ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
7774   count_in  = overlap_in %count
7775   count_out = overlap_out%count
7776   count     = count_in+count_out
7777   if(count_in == 0) call mpp_error(FATAL, &
7778        "add_check_overlap(mpp_domains_define): overlap_in%count is zero")
7779
7780   if(count_out == 0) then
7781      if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
7782           "add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
7783      call allocate_check_overlap(overlap_out, count_in)
7784      overlap_out%pe  = overlap_in%pe
7785   else  ! need to expand the dimension size of overlap
7786      call allocate_check_overlap(overlap, count_out)
7787      if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, &
7788          "mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
7789      overlap%tileMe      (1:count_out) = overlap_out%tileMe      (1:count_out)
7790      overlap%is          (1:count_out) = overlap_out%is          (1:count_out)
7791      overlap%ie          (1:count_out) = overlap_out%ie          (1:count_out)
7792      overlap%js          (1:count_out) = overlap_out%js          (1:count_out)
7793      overlap%je          (1:count_out) = overlap_out%je          (1:count_out)
7794      overlap%dir         (1:count_out) = overlap_out%dir         (1:count_out)
7795      overlap%rotation    (1:count_out) = overlap_out%rotation    (1:count_out)
7796      call deallocate_overlap_type(overlap_out)
7797      call allocate_check_overlap(overlap_out, count)
7798      overlap_out%tileMe      (1:count_out) = overlap%tileMe      (1:count_out)
7799      overlap_out%is          (1:count_out) = overlap%is          (1:count_out)
7800      overlap_out%ie          (1:count_out) = overlap%ie          (1:count_out)
7801      overlap_out%js          (1:count_out) = overlap%js          (1:count_out)
7802      overlap_out%je          (1:count_out) = overlap%je          (1:count_out)
7803      overlap_out%dir         (1:count_out) = overlap%dir         (1:count_out)
7804      overlap_out%rotation    (1:count_out) = overlap%rotation    (1:count_out)
7805      call deallocate_overlap_type(overlap)
7806   end if
7807   overlap_out%count                           = count
7808   overlap_out%tileMe      (count_out+1:count) = overlap_in%tileMe      (1:count_in)
7809   overlap_out%is          (count_out+1:count) = overlap_in%is          (1:count_in)
7810   overlap_out%ie          (count_out+1:count) = overlap_in%ie          (1:count_in)
7811   overlap_out%js          (count_out+1:count) = overlap_in%js          (1:count_in)
7812   overlap_out%je          (count_out+1:count) = overlap_in%je          (1:count_in)
7813   overlap_out%dir         (count_out+1:count) = overlap_in%dir         (1:count_in)
7814   overlap_out%rotation    (count_out+1:count) = overlap_in%rotation    (1:count_in)
7815
7816 end subroutine add_check_overlap
7817
7818 !####################################################################
7819 subroutine init_overlap_type(overlap)
7820   type(overlap_type), intent(inout) :: overlap
7821
7822   overlap%count = 0
7823   overlap%pe    = NULL_PE
7824
7825 end subroutine init_overlap_type
7826
7827 !####################################################################
7828
7829 subroutine allocate_update_overlap( overlap, count)
7830   type(overlap_type), intent(inout) :: overlap
7831   integer,           intent(in   ) :: count
7832
7833   overlap%count = 0
7834   overlap%pe    = NULL_PE
7835   if(associated(overlap%tileMe)) call mpp_error(FATAL, &
7836        "allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
7837   if(count < 1)  call mpp_error(FATAL, &
7838        "allocate_update_overlap(mpp_domains_define): count should be a positive integer")
7839   allocate(overlap%tileMe      (count), overlap%tileNbr (count) )
7840   allocate(overlap%is          (count), overlap%ie      (count) )
7841   allocate(overlap%js          (count), overlap%je      (count) )
7842   allocate(overlap%dir         (count), overlap%rotation(count) )
7843   allocate(overlap%from_contact(count), overlap%msgsize (count) )
7844   overlap%rotation     =  ZERO
7845   overlap%from_contact = .FALSE.
7846
7847 end subroutine allocate_update_overlap
7848
7849   !#####################################################################################
7850   subroutine insert_update_overlap(overlap, pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir, reverse, symmetry)
7851     type(overlap_type), intent(inout) :: overlap
7852     integer,            intent(in   ) :: pe
7853     integer,            intent(in   ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
7854     integer,            intent(in   ) :: dir
7855     logical, optional,  intent(in   ) :: reverse, symmetry
7856
7857     logical :: is_reverse, is_symmetry, is_overlapped
7858     integer :: is, ie, js, je, count
7859
7860     is_reverse = .FALSE.
7861     if(PRESENT(reverse)) is_reverse = reverse
7862     is_symmetry = .FALSE.
7863     if(PRESENT(symmetry)) is_symmetry = symmetry
7864
7865     is = max(is1,is2); ie = min(ie1,ie2)
7866     js = max(js1,js2); je = min(je1,je2)
7867     is_overlapped = .false.
7868     !--- to avoid unnecessary ( duplicate overlap ) for symmetry domain
7869     if(is_symmetry .AND. (dir == 1 .OR. dir == 5)) then  ! x-direction
7870        if( ie .GE. is .AND. je .GT. js ) is_overlapped = .true.
7871     else if(is_symmetry .AND. (dir == 3 .OR. dir == 7)) then ! y-direction
7872        if( ie .GT. is .AND. je .GE. js ) is_overlapped = .true.
7873     else if(ie.GE.is .AND. je.GE.js )then
7874        is_overlapped = .true.
7875     endif
7876
7877     if(is_overlapped) then
7878      if( overlap%count == 0 ) then
7879           overlap%pe = pe
7880        else
7881           if(overlap%pe .NE. pe) call mpp_error(FATAL,  &
7882                "mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
7883        endif
7884        overlap%count = overlap%count+1
7885        count = overlap%count
7886        if(count > MAXOVERLAP) call mpp_error(FATAL, "mpp_domains_define.inc(insert_update_overlap):"//&
7887                               & " number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7888        overlap%is(count) = is
7889        overlap%ie(count) = ie
7890        overlap%js(count) = js
7891        overlap%je(count) = je
7892        overlap%tileMe (count) = 1
7893        overlap%tileNbr(count) = 1
7894        overlap%dir(count) = dir
7895        if(is_reverse) then
7896           overlap%rotation(count) = ONE_HUNDRED_EIGHTY
7897        else
7898           overlap%rotation(count) = ZERO
7899        end if
7900     end if
7901
7902   end subroutine insert_update_overlap
7903
7904   !#####################################################################################
7905 subroutine insert_overlap_type(overlap, pe, tileMe, tileNbr, is, ie, js, je, dir, &
7906      rotation, from_contact)
7907     type(overlap_type), intent(inout) :: overlap
7908     integer,            intent(in   ) :: tileMe, tileNbr, pe
7909     integer,            intent(in   ) :: is, ie, js, je
7910     integer,            intent(in   ) :: dir, rotation
7911   logical,            intent(in   ) :: from_contact
7912     integer                           :: count
7913
7914   if( overlap%count == 0 ) then
7915        overlap%pe = pe
7916     else
7917        if(overlap%pe .NE. pe) call mpp_error(FATAL,  &
7918           "mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
7919     endif
7920     overlap%count = overlap%count+1
7921     count = overlap%count
7922     if(count > MAXOVERLAP) call mpp_error(FATAL, "mpp_domains_define.inc(insert_overlap_type):"//&
7923                            & " number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7924     overlap%tileMe      (count) = tileMe
7925     overlap%tileNbr     (count) = tileNbr
7926     overlap%is          (count) = is
7927     overlap%ie          (count) = ie
7928     overlap%js          (count) = js
7929     overlap%je          (count) = je
7930     overlap%dir         (count) = dir
7931     overlap%rotation    (count) = rotation
7932     overlap%from_contact(count) = from_contact
7933     overlap%msgsize     (count) = (ie-is+1)*(je-js+1)
7934
7935 end subroutine insert_overlap_type
7936
7937
7938 !#######################################################################
7939 subroutine deallocate_overlap_type( overlap)
7940   type(overlap_type), intent(inout) :: overlap
7941
7942   if(overlap%count == 0) then
7943      if( .NOT. associated(overlap%tileMe)) return
7944   else
7945      if( .NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
7946           "deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
7947   endif
7948   if(ASSOCIATED(overlap%tileMe)) deallocate(overlap%tileMe)
7949   if(ASSOCIATED(overlap%tileNbr)) deallocate(overlap%tileNbr)
7950   if(ASSOCIATED(overlap%is)) deallocate(overlap%is)
7951   if(ASSOCIATED(overlap%ie)) deallocate(overlap%ie)
7952   if(ASSOCIATED(overlap%js)) deallocate(overlap%js)
7953   if(ASSOCIATED(overlap%je)) deallocate(overlap%je)
7954   if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir)
7955   if(ASSOCIATED(overlap%index)) deallocate(overlap%index)
7956   if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation)
7957   if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact)
7958   if(ASSOCIATED(overlap%msgsize)) deallocate(overlap%msgsize)
7959   overlap%count = 0
7960
7961 end subroutine deallocate_overlap_type
7962
7963 !#######################################################################
7964 subroutine deallocate_overlapSpec(overlap)
7965 type(overlapSpec), intent(inout) :: overlap
7966 integer                          :: n
7967
7968    if(ASSOCIATED(overlap%send)) then
7969       do n = 1, size(overlap%send(:))
7970          call deallocate_overlap_type(overlap%send(n))
7971       enddo
7972       deallocate(overlap%send)
7973    endif
7974    if(ASSOCIATED(overlap%recv)) then
7975       do n = 1, size(overlap%recv(:))
7976          call deallocate_overlap_type(overlap%recv(n))
7977       enddo
7978       deallocate(overlap%recv)
7979    endif
7980
7981
7982 end subroutine deallocate_overlapSpec
7983
7984 !#######################################################################
7985 !--- this routine add the overlap_in into overlap_out
7986 subroutine add_update_overlap( overlap_out, overlap_in)
7987   type(overlap_type), intent(inout) :: overlap_out
7988   type(overlap_type), intent(in   ) :: overlap_in
7989   type(overlap_type)                :: overlap
7990   integer                          :: count, count_in, count_out, n
7991
7992   ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
7993   count_in  = overlap_in %count
7994   count_out = overlap_out%count
7995   count     = count_in+count_out
7996   if(count_in == 0) call mpp_error(FATAL, &
7997        "mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
7998
7999   if(count_out == 0) then
8000      if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
8001           "mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
8002      call allocate_update_overlap(overlap_out, count_in)
8003      overlap_out%pe  = overlap_in%pe
8004   else  ! need to expand the dimension size of overlap
8005      if(overlap_in%pe .NE. overlap_out%pe) call mpp_error(FATAL, &
8006           "mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
8007
8008      call allocate_update_overlap(overlap, count_out)
8009      overlap%tileMe      (1:count_out) = overlap_out%tileMe      (1:count_out)
8010      overlap%tileNbr     (1:count_out) = overlap_out%tileNbr     (1:count_out)
8011      overlap%is          (1:count_out) = overlap_out%is          (1:count_out)
8012      overlap%ie          (1:count_out) = overlap_out%ie          (1:count_out)
8013      overlap%js          (1:count_out) = overlap_out%js          (1:count_out)
8014      overlap%je          (1:count_out) = overlap_out%je          (1:count_out)
8015      overlap%dir         (1:count_out) = overlap_out%dir         (1:count_out)
8016      overlap%rotation    (1:count_out) = overlap_out%rotation    (1:count_out)
8017      overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
8018      call deallocate_overlap_type(overlap_out)
8019      call allocate_update_overlap(overlap_out, count)
8020      overlap_out%tileMe      (1:count_out) = overlap%tileMe      (1:count_out)
8021      overlap_out%tileNbr     (1:count_out) = overlap%tileNbr     (1:count_out)
8022      overlap_out%is          (1:count_out) = overlap%is          (1:count_out)
8023      overlap_out%ie          (1:count_out) = overlap%ie          (1:count_out)
8024      overlap_out%js          (1:count_out) = overlap%js          (1:count_out)
8025      overlap_out%je          (1:count_out) = overlap%je          (1:count_out)
8026      overlap_out%dir         (1:count_out) = overlap%dir         (1:count_out)
8027      overlap_out%rotation    (1:count_out) = overlap%rotation    (1:count_out)
8028      overlap_out%index       (1:count_out) = overlap%index       (1:count_out)
8029      overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
8030      overlap_out%msgsize     (1:count_out) = overlap%msgsize     (1:count_out)
8031      call deallocate_overlap_type(overlap)
8032   end if
8033   overlap_out%count                           = count
8034   overlap_out%tileMe      (count_out+1:count) = overlap_in%tileMe      (1:count_in)
8035   overlap_out%tileNbr     (count_out+1:count) = overlap_in%tileNbr     (1:count_in)
8036   overlap_out%is          (count_out+1:count) = overlap_in%is          (1:count_in)
8037   overlap_out%ie          (count_out+1:count) = overlap_in%ie          (1:count_in)
8038   overlap_out%js          (count_out+1:count) = overlap_in%js          (1:count_in)
8039   overlap_out%je          (count_out+1:count) = overlap_in%je          (1:count_in)
8040   overlap_out%dir         (count_out+1:count) = overlap_in%dir         (1:count_in)
8041   overlap_out%rotation    (count_out+1:count) = overlap_in%rotation    (1:count_in)
8042   overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
8043
8044   do n = count_out+1, count
8045      overlap_out%msgsize(n) = (overlap_out%ie(n)-overlap_out%is(n)+1)*(overlap_out%je(n)-overlap_out%js(n)+1)
8046   enddo
8047
8048
8049 end subroutine add_update_overlap
8050
8051 !##############################################################################
8052 subroutine expand_update_overlap_list(overlapList, npes)
8053   type(overlap_type), pointer :: overlapList(:)
8054   integer,      intent(in   ) :: npes
8055   type(overlap_type), pointer,save           :: newlist(:) => NULL()
8056   integer                                    :: nlist_old, nlist, m
8057
8058   nlist_old = size(overlaplist(:))
8059   if(nlist_old .GE. npes) call mpp_error(FATAL, &
8060      'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
8061   nlist = min(npes, 2*nlist_old)
8062   allocate(newlist(nlist))
8063   do m = 1, nlist_old
8064      call add_update_overlap(newlist(m), overlaplist(m))
8065      call deallocate_overlap_type(overlapList(m))
8066   enddo
8067
8068   deallocate(overlapList)
8069   overlaplist => newlist
8070   newlist => NULL()
8071
8072   return
8073
8074 end subroutine expand_update_overlap_list
8075
8076 !##################################################################################
8077 subroutine expand_check_overlap_list(overlaplist, npes)
8078   type(overlap_type), pointer :: overlaplist(:)
8079   integer,         intent(in) :: npes
8080   type(overlap_type), pointer,save           :: newlist(:) => NULL()
8081   integer                                    :: nlist_old, nlist, m
8082
8083   nlist_old = size(overlaplist(:))
8084   if(nlist_old .GE. npes) call mpp_error(FATAL, &
8085      'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
8086   nlist = min(npes, 2*nlist_old)
8087   allocate(newlist(nlist))
8088   do m = 1,size(overlaplist(:))
8089      call add_check_overlap(newlist(m), overlaplist(m))
8090      call deallocate_overlap_type(overlapList(m))
8091   enddo
8092   deallocate(overlapList)
8093   overlaplist => newlist
8094
8095
8096   return
8097
8098 end subroutine expand_check_overlap_list
8099
8100
8101 !###############################################################################
8102 subroutine check_overlap_pe_order(domain, overlap, name)
8103   type(domain2d),    intent(in) :: domain
8104   type(overlapSpec), intent(in) :: overlap
8105   character(len=*),  intent(in) :: name
8106   integer                       :: m
8107   integer                       :: pe1, pe2
8108
8109   !---make sure overlap%nsend and overlap%nrecv is no larger than MAXLIST
8110   if( overlap%nsend > MAXLIST) call mpp_error(FATAL, &
8111              "mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
8112   if( overlap%nrecv > MAXLIST) call mpp_error(FATAL, &
8113              "mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
8114
8115   do m = 2, overlap%nsend
8116      pe1 = overlap%send(m-1)%pe
8117      pe2 = overlap%send(m)%pe
8118      !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8119      if( pe2 == domain%pe ) then
8120         print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8121         call mpp_error(FATAL, &
8122              "mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
8123      else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8124         if( pe2 < pe1 ) then
8125            print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8126            call mpp_error(FATAL, &
8127              "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
8128         endif
8129      else if ( pe2 > domain%pe .AND. pe1 < domain%pe ) then
8130         print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8131         call mpp_error(FATAL, &
8132              "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
8133      endif
8134   enddo
8135
8136
8137   do m = 2, overlap%nrecv
8138      pe1 = overlap%recv(m-1)%pe
8139      pe2 = overlap%recv(m)%pe
8140      !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8141      if( pe2 == domain%pe ) then
8142         print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8143         call mpp_error(FATAL, &
8144              "mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
8145      else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8146         if( pe2 > pe1 ) then
8147            print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8148            call mpp_error(FATAL, &
8149              "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
8150         endif
8151      else if ( pe2 < domain%pe .AND. pe1 > domain%pe ) then
8152         print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8153         call mpp_error(FATAL, &
8154              "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
8155      endif
8156   enddo
8157
8158
8159 end subroutine check_overlap_pe_order
8160
8161
8162 !###############################################################################
8163 subroutine set_domain_comm_inf(update)
8164   type(overlapSpec), intent(inout) :: update
8165
8166   integer :: m, totsize, n
8167
8168
8169      ! first set the send and recv size
8170      update%sendsize = 0
8171      update%recvsize = 0
8172      do m = 1, update%nrecv
8173         totsize = 0
8174         do n = 1, update%recv(m)%count
8175            totsize = totsize + update%recv(m)%msgsize(n)
8176         enddo
8177         update%recv(m)%totsize = totsize
8178         if(m==1) then
8179            update%recv(m)%start_pos = 0
8180         else
8181            update%recv(m)%start_pos = update%recv(m-1)%start_pos + update%recv(m-1)%totsize
8182         endif
8183         update%recvsize = update%recvsize + totsize
8184      enddo
8185
8186      do m = 1, update%nsend
8187         totsize = 0
8188         do n = 1, update%send(m)%count
8189            totsize = totsize + update%send(m)%msgsize(n)
8190         enddo
8191         update%send(m)%totsize = totsize
8192         if(m==1) then
8193            update%send(m)%start_pos = 0
8194         else
8195            update%send(m)%start_pos = update%send(m-1)%start_pos + update%send(m-1)%totsize
8196         endif
8197         update%sendsize = update%sendsize + totsize
8198      enddo
8199
8200   return
8201
8202
8203 end subroutine set_domain_comm_inf