FMS  2025.04
Flexible Modeling System
mpp_domains_define.inc
1 ! -*-f90-*-
2 !***********************************************************************
3 !* Apache License 2.0
4 !*
5 !* This file is part of the GFDL Flexible Modeling System (FMS).
6 !*
7 !* Licensed under the Apache License, Version 2.0 (the "License");
8 !* you may not use this file except in compliance with the License.
9 !* You may obtain a copy of the License at
10 !*
11 !* http://www.apache.org/licenses/LICENSE-2.0
12 !*
13 !* FMS is distributed in the hope that it will be useful, but WITHOUT
14 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
15 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
16 !* PARTICULAR PURPOSE. See the License for the specific language
17 !* governing permissions and limitations under the License.
18 !***********************************************************************
19 
20 !> @file
21 !> @brief Various routines handling domains in @ref mpp_domains_mod
22 
23 !> @addtogroup mpp_domains_mod
24 !> @{
25  !> @brief Instantiates a layout with the given indices and divisions
26  subroutine mpp_define_layout2d( global_indices, ndivs, layout )
27  integer, intent(in) :: global_indices(:) !< (/ isg, ieg, jsg, jeg /); Defines the global domain.
28  integer, intent(in) :: ndivs !< number of divisions to divide global domain
29  integer, intent(out) :: layout(:)
30 
31  integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
32 
33  if(size(global_indices(:)) .NE. 4) call mpp_error(fatal,"mpp_define_layout2D: size of global_indices should be 4")
34  if(size(layout(:)) .NE. 2) call mpp_error(fatal,"mpp_define_layout2D: size of layout should be 2")
35 
36  isg = global_indices(1)
37  ieg = global_indices(2)
38  jsg = global_indices(3)
39  jeg = global_indices(4)
40 
41  isz = ieg - isg + 1
42  jsz = jeg - jsg + 1
43  !first try to divide ndivs in the domain aspect ratio: if imperfect aspect, reduce idiv till it divides ndivs
44  idiv = nint( sqrt(float(ndivs*isz)/jsz) )
45  idiv = max(idiv,1) !for isz=1 line above can give 0
46  do while( mod(ndivs,idiv).NE.0 )
47  idiv = idiv - 1
48  end do !will terminate at idiv=1 if not before
49  jdiv = ndivs/idiv
50 
51  layout = (/ idiv, jdiv /)
52  return
53  end subroutine mpp_define_layout2d
54 
55  !############################################################################
56 
57  !> Defines a pelist for use with mosaic tiles
58  !! @note The following routine may need to revised to improve the capability.
59  !! It is very hard to make it balance for all the situation.
60  !! Hopefully some smart idea will come up someday.
61  subroutine mpp_define_mosaic_pelist( sizes, pe_start, pe_end, pelist, costpertile)
62  integer, dimension(:), intent(in) :: sizes
63  integer, dimension(:), intent(inout) :: pe_start, pe_end
64  integer, dimension(:), intent(in), optional :: pelist, costpertile
65  integer, dimension(size(sizes(:))) :: costs
66  integer, dimension(:), allocatable :: pes
67  integer :: ntiles, npes, totcosts, avgcost
68  integer :: ntiles_left, npes_left, pos, n, tile
69  integer :: cost_on_tile, cost_on_pe, npes_used, errunit
70 
71  ntiles = size(sizes(:))
72  if(size(pe_start(:)) .NE. ntiles .OR. size(pe_end(:)) .NE. ntiles ) then
73  call mpp_error(fatal, "mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
74  end if
75 
76  if(present(costpertile)) then
77  if(size(costpertile(:)) .NE. ntiles ) then
78  call mpp_error(fatal, "mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
79  end if
80  costs = sizes*costpertile
81  else
82  costs = sizes
83  end if
84 
85  if( PRESENT(pelist) )then
86  if( .NOT.any(pelist.EQ.mpp_pe()) )then
87  errunit = stderr()
88  write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
89  call mpp_error( fatal, 'mpp_define_mosaic_pelist: pe must be in pelist.' )
90  end if
91  npes = size(pelist(:))
92  allocate( pes(0:npes-1) )
93  pes(:) = pelist(:)
94  else
95  npes = mpp_npes()
96  allocate( pes(0:npes-1) )
97  call mpp_get_current_pelist(pes)
98  end if
99 
100  ntiles_left = ntiles
101  npes_left = npes
102  pos = pes(0)
103 
104  do while( ntiles_left > 0 )
105  if( npes_left == 1 ) then ! all left tiles will on the last processor, imbalance possibly.
106  do n = 1, ntiles
107  if(costs(n) > 0) then
108  pe_start(n) = pos
109  pe_end(n) = pos
110  costs(n) = 0
111  end if
112  end do
113  ntiles_left = 0
114  npes_left = 0
115  else
116  totcosts = sum(costs)
117  avgcost = ceiling(real(totcosts)/npes_left )
118  tile = minval(maxloc(costs))
119  cost_on_tile = costs(tile)
120  pe_start(tile) = pos
121  ntiles_left = ntiles_left - 1
122  costs(tile) = 0
123  totcosts = totcosts - cost_on_tile
124  if(cost_on_tile .GE. avgcost ) then
125  npes_used = min(ceiling(real(cost_on_tile)/avgcost), npes_left)
126  if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
127  pe_end(tile) = pos + npes_used - 1
128  npes_left = npes_left - npes_used
129  pos = pos + npes_used
130  else
131  !--- find other tiles to share the pe
132  pe_end(tile) = pos
133  cost_on_pe = cost_on_tile
134  do while(ntiles_left>npes_left) ! make sure all the pes are used.
135  tile = minval(minloc(costs, costs> 0 ))
136  cost_on_tile = costs(tile)
137  cost_on_pe = cost_on_pe + cost_on_tile
138  if(cost_on_pe > avgcost ) exit
139  pe_start(tile) = pos
140  pe_end(tile) = pos
141  ntiles_left = ntiles_left - 1
142  costs(tile) = 0
143  totcosts = totcosts - cost_on_tile
144  end do
145  npes_left = npes_left - 1
146  pos = pos + 1
147  end if
148  end if
149  end do
150 
151  if(npes_left .NE. 0 ) call mpp_error(fatal, "mpp_define_mosaic_pelist: the left npes should be zero")
152  deallocate(pes)
153 
154  end subroutine mpp_define_mosaic_pelist
155 
156  !> Computes the extents of a grid block
157  !!
158  !> Tis implementation is different from mpp_compute_extents
159  !! The last block might have most points
160  subroutine mpp_compute_block_extent(isg,ieg,ndivs,ibegin,iend)
161  integer, intent(in) :: isg, ieg, ndivs
162  integer, dimension(:), intent(out) :: ibegin, iend
163 
164  integer :: ndiv
165  integer :: is, ie
166 
167  ie = ieg
168  do ndiv=ndivs,1,-1
169  !domain is sized by dividing remaining points by remaining domains
170  is = ie - ceiling( real(ie-isg+1)/ndiv ) + 1
171  ibegin(ndiv) = is
172  iend(ndiv) = ie
173 
174  if( ie.LT.is )call mpp_error( fatal, &
175  'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
176  if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE. isg ) &
177  call mpp_error( fatal, 'mpp_compute_block_extent: domain extents do not span space completely.' )
178  ie = is - 1
179  end do
180 
181  end subroutine mpp_compute_block_extent
182 
183 
184  !#####################################################################
185  !> Computes extents for a grid decomposition with the given indices and divisions
186  subroutine mpp_compute_extent(isg,ieg,ndivs,ibegin,iend, extent )
187  integer, intent(in) :: isg, ieg, ndivs
188  integer, dimension(0:), intent(out) :: ibegin, iend
189  integer, dimension(0:), intent(in), optional :: extent
190 
191  integer :: ndiv, imax, ndmax, ndmirror
192  integer :: is, ie, n
193  logical :: symmetrize, use_extent
194  !statement functions
195  logical :: even, odd
196  even(n) = (mod(n,2).EQ.0)
197  odd(n) = (mod(n,2).EQ.1)
198 
199  use_extent = .false.
200  if(PRESENT(extent)) then
201  if( size(extent(:)).NE.ndivs ) &
202  call mpp_error( fatal, 'mpp_compute_extent: extent array size must equal number of domain divisions.' )
203  use_extent = .true.
204  if(all(extent ==0)) use_extent = .false.
205  endif
206 
207  is = isg
208  if(use_extent) then
209  ibegin(0) = isg
210  do ndiv = 0, ndivs-2
211  if(extent(ndiv) .LE. 0) call mpp_error( fatal, &
212  & 'mpp_compute_extent: domain extents must be positive definite.' )
213  iend(ndiv) = ibegin(ndiv) + extent(ndiv) - 1
214  ibegin(ndiv+1) = iend(ndiv) + 1
215  enddo
216  iend(ndivs-1) = ibegin(ndivs-1) + extent(ndivs-1) - 1
217  if(iend(ndivs-1) .NE. ieg) call mpp_error(fatal, &
218  & 'mpp_compute_extent: extent array limits do not match global domain.' )
219  else
220  do ndiv=0,ndivs-1
221  !modified for mirror-symmetry
222  !original line
223  ! ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1
224 
225  !problem of dividing nx points into n domains maintaining symmetry
226  !i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not.
227  !this will always work for nx even n even or odd
228  !this will always work for nx odd, n odd
229  !this will never work for nx odd, n even: for this case we supersede the mirror calculation
230  ! symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(ieg-isg+1,2).EQ.1 )
231  !nx even n odd fails if n>nx/2
232  symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
233  ( odd(ndivs) .AND. odd(ieg-isg+1) ) .OR. &
234  ( odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
235 
236  !mirror domains are stored in the list and retrieved if required.
237  if( ndiv.EQ.0 )then
238  !initialize max points and max domains
239  imax = ieg
240  ndmax = ndivs
241  end if
242  !do bottom half of decomposition, going over the midpoint for odd ndivs
243  if( ndiv.LT.(ndivs-1)/2+1 )then
244  !domain is sized by dividing remaining points by remaining domains
245  ie = is + ceiling( real(imax-is+1)/(ndmax-ndiv) ) - 1
246  ndmirror = (ndivs-1) - ndiv !mirror domain
247  if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
248  !mirror extents, the max(,) is to eliminate overlaps
249  ibegin(ndmirror) = max( isg+ieg-ie, ie+1 )
250  iend(ndmirror) = max( isg+ieg-is, ie+1 )
251  imax = ibegin(ndmirror) - 1
252  ndmax = ndmax - 1
253  end if
254  else
255  if( symmetrize )then
256  !do top half of decomposition by retrieving saved values
257  is = ibegin(ndiv)
258  ie = iend(ndiv)
259  else
260  ie = is + ceiling( real(imax-is+1)/(ndmax-ndiv) ) - 1
261  end if
262  end if
263  ibegin(ndiv) = is
264  iend(ndiv) = ie
265  if( ie.LT.is )call mpp_error( fatal, &
266  'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
267  if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.ieg ) &
268  call mpp_error( fatal, 'mpp_compute_extent: domain extents do not span space completely.' )
269  is = ie + 1
270  end do
271  endif
272 
273 
274  end subroutine mpp_compute_extent
275 
276  !#####################################################################
277 
278 
279  !> Define data and computational domains on a 1D set of data (isg:ieg) and assign them to PEs
280  subroutine mpp_define_domains1d( global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, &
281  memory_size, begin_halo, end_halo )
282  integer, intent(in) :: global_indices(:) !< (/ isg, ieg /) gives the extent of global domain
283  integer, intent(in) :: ndivs !< number of divisions of domain: even divisions unless extent is present.
284  type(domain1d), intent(inout) :: domain !< the returned domain1D; declared inout so that
285  !! existing links, if any, can be nullified
286  integer, intent(in), optional :: pelist(0:) !< list of PEs to which domains are to be assigned
287  !! (default 0...npes-1); size of pelist must
288  !! correspond to number of mask=.TRUE. divisions
289  integer, intent(in), optional :: flags, halo !< flags define whether compute and data domains
290  !! are global (undecomposed) and whether the global
291  !! domain has periodic boundaries.
292  !! halo defines halo width (currently the same on both sides)
293  integer, intent(in), optional :: extent(0:) !< array extent; defines width of each division
294  !! (used for non-uniform domain decomp, for e.g load-balancing)
295  logical, intent(in), optional :: maskmap(0:) !< a division whose maskmap=.FALSE. is not
296  !! assigned to any domain. By default we assume
297  !! decomposition of compute and data domains, non-periodic boundaries,
298  !! no halo, as close to uniform extents as the
299  !! input parameters permit
300  integer, intent(in), optional :: memory_size
301  integer, intent(in), optional :: begin_halo, end_halo
302 
303  logical :: compute_domain_is_global, data_domain_is_global
304  integer :: ndiv, n, isg, ieg
305  integer, allocatable :: pes(:)
306  integer :: ibegin(0:ndivs-1), iend(0:ndivs-1)
307  logical :: mask(0:ndivs-1)
308  integer :: halosz, halobegin, haloend
309  integer :: errunit
310 
311  if( .NOT.module_is_initialized )call mpp_error( fatal, &
312  & 'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
313  if(size(global_indices(:)) .NE. 2) call mpp_error(fatal,"mpp_define_domains1D: size of global_indices should be 2")
314  !get global indices
315  isg = global_indices(1)
316  ieg = global_indices(2)
317  if( ndivs.GT.ieg-isg+1 )call mpp_error( fatal, &
318  & 'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
319  !get the list of PEs on which to assign domains; if pelist is absent use 0..npes-1
320  if( PRESENT(pelist) )then
321  if( .NOT.any(pelist.EQ.mpp_pe()) )then
322  errunit = stderr()
323  write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
324  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
325  end if
326  allocate( pes(0:size(pelist(:))-1) )
327  pes(:) = pelist(:)
328  else
329  allocate( pes(0:mpp_npes()-1) )
330  call mpp_get_current_pelist(pes)
331 ! pes(:) = (/ (i,i=0,mpp_npes()-1) /)
332  end if
333 
334  !get number of real domains: 1 mask domain per PE in pes
335  mask = .true. !default mask
336  if( PRESENT(maskmap) )then
337  if( size(maskmap(:)).NE.ndivs ) &
338  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
339  mask(:) = maskmap(:)
340  end if
341  if( count(mask).NE.size(pes(:)) ) &
342  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
343 
344  !get halosize
345  halosz = 0
346  if( PRESENT(halo) ) then
347  halosz = halo
348  !--- if halo is present, begin_halo and end_halo should not present
349  if(present(begin_halo) .OR. present(end_halo) ) call mpp_error(fatal, &
350  "mpp_domains_define.inc: when halo is present, begin_halo and end_halo should not present")
351  end if
352  halobegin = halosz; haloend = halosz
353  if(present(begin_halo)) halobegin = begin_halo
354  if(present(end_halo)) haloend = end_halo
355  halosz = max(halobegin, haloend)
356  !get flags
357  compute_domain_is_global = .false.
358  data_domain_is_global = .false.
359  domain%cyclic = .false.
360  domain%goffset = 1
361  domain%loffset = 1
362  if( PRESENT(flags) )then
363  !NEW: obsolete flag global_compute_domain, since ndivs is non-optional and you cannot
364  !have global compute and ndivs.NE.1
365  compute_domain_is_global = ndivs.EQ.1
366  !if compute domain is global, data domain must also be
367  data_domain_is_global = btest(flags,global) .OR. compute_domain_is_global
368  domain%cyclic = btest(flags,cyclic) .AND. halosz.NE.0
369  if(btest(flags,cyclic)) domain%goffset = 0
370  end if
371 
372  !set up links list
373  allocate( domain%list(0:ndivs-1) )
374 
375  !set global domain
376  domain%list(:)%global%begin = isg
377  domain%list(:)%global%end = ieg
378  domain%list(:)%global%size = ieg-isg+1
379  domain%list(:)%global%max_size = ieg-isg+1
380  domain%list(:)%global%is_global = .true. !always
381 
382  !get compute domain
383  if( compute_domain_is_global )then
384  domain%list(:)%compute%begin = isg
385  domain%list(:)%compute%end = ieg
386  domain%list(:)%compute%is_global = .true.
387  domain%list(:)%pe = pes(:)
388  domain%pos = 0
389  else
390  domain%list(:)%compute%is_global = .false.
391  n = 0
392  call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
393  do ndiv=0,ndivs-1
394  domain%list(ndiv)%compute%begin = ibegin(ndiv)
395  domain%list(ndiv)%compute%end = iend(ndiv)
396  if( mask(ndiv) )then
397  domain%list(ndiv)%pe = pes(n)
398  if( mpp_pe().EQ.pes(n) )domain%pos = ndiv
399  n = n + 1
400  else
401  domain%list(ndiv)%pe = null_pe
402  end if
403  end do
404  end if
405 
406  domain%list(:)%compute%size = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
407 
408  !get data domain
409  !data domain is at least equal to compute domain
410  domain%list(:)%domain_data%begin = domain%list(:)%compute%begin
411  domain%list(:)%domain_data%end = domain%list(:)%compute%end
412  domain%list(:)%domain_data%is_global = .false.
413  !apply global flags
414  if( data_domain_is_global )then
415  domain%list(:)%domain_data%begin = isg
416  domain%list(:)%domain_data%end = ieg
417  domain%list(:)%domain_data%is_global = .true.
418  end if
419  !apply margins
420  domain%list(:)%domain_data%begin = domain%list(:)%domain_data%begin - halobegin
421  domain%list(:)%domain_data%end = domain%list(:)%domain_data%end + haloend
422  domain%list(:)%domain_data%size = domain%list(:)%domain_data%end - domain%list(:)%domain_data%begin + 1
423 
424  !--- define memory domain, if memory_size is not present or memory size is 0, memory domain size
425  !--- will be the same as data domain size. if momory_size is present, memory_size should greater than
426  !--- or equal to data size. The begin of memory domain will be always the same as data domain.
427  domain%list(:)%memory%begin = domain%list(:)%domain_data%begin
428  domain%list(:)%memory%end = domain%list(:)%domain_data%end
429  if( present(memory_size) ) then
430  if(memory_size > 0) then
431  if( domain%list(domain%pos)%domain_data%size > memory_size ) call mpp_error(fatal, &
432  "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe")
433  domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1
434  end if
435  end if
436  domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1
437  domain%list(:)%memory%is_global = domain%list(:)%domain_data%is_global
438 
439  domain%compute = domain%list(domain%pos)%compute
440  domain%domain_data = domain%list(domain%pos)%domain_data
441  domain%global = domain%list(domain%pos)%global
442  domain%memory = domain%list(domain%pos)%memory
443  domain%compute%max_size = maxval( domain%list(:)%compute%size )
444  domain%domain_data%max_size = maxval( domain%list(:)%domain_data%size )
445  domain%global%max_size = domain%global%size
446  domain%memory%max_size = domain%memory%size
447 
448  !PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
449  deallocate( pes )
450  return
451 
452  end subroutine mpp_define_domains1d
453 
454  !################################################################################
455  !> Define the layout for IO pe's for the given domain
456  subroutine mpp_define_io_domain(domain, io_layout)
457  type(domain2d), intent(inout) :: domain !< Input 2D domain
458  integer, intent(in ) :: io_layout(2) !< 2 value io pe layout to define
459  integer :: layout(2)
460  integer :: npes_in_group
461  type(domain2d), pointer :: io_domain=>null()
462  integer :: i, j, n, m
463  integer :: ipos, jpos, igroup, jgroup
464  integer :: ipos_beg, ipos_end, jpos_beg, jpos_end
465  integer :: whalo, ehalo, shalo, nhalo
466  integer :: npes_x, npes_y, ndivx, ndivy
467  integer, allocatable :: posarray(:,:)
468 
469  if(io_layout(1) * io_layout(2) .LE. 0) then
470  call mpp_error(note, &
471  "mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for "//trim(domain%name)// &
472  " when one or both entry of io_layout is not positive")
473  return
474  endif
475 
476  layout(1) = size(domain%x(1)%list(:))
477  layout(2) = size(domain%y(1)%list(:))
478 
479  if(ASSOCIATED(domain%io_domain)) call mpp_error(fatal, &
480  "mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
481 
482  if(mod(layout(1), io_layout(1)) .NE. 0) call mpp_error(fatal, &
483  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
484  & " domain layout(1) must be divided by io_layout(1)")
485  if(mod(layout(2), io_layout(2)) .NE. 0) call mpp_error(fatal, &
486  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
487  & " domain layout(2) must be divided by io_layout(2)")
488  if(size(domain%x(:)) > 1) call mpp_error(fatal, &
489  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
490  ": multiple tile per pe is not supported yet for this routine")
491 
492  if (associated(domain%io_domain)) deallocate(domain%io_domain) !< Check if associated
493  allocate(domain%io_domain)
494  domain%io_layout = io_layout
495  io_domain => domain%io_domain
496  ! Find how many processors are in the group with the consideration that some of the region maybe masked out.
497  npes_x = layout(1)/io_layout(1)
498  npes_y = layout(2)/io_layout(2)
499  ipos = mod(domain%x(1)%pos, npes_x)
500  jpos = mod(domain%y(1)%pos, npes_y)
501  igroup = domain%x(1)%pos/npes_x
502  jgroup = domain%y(1)%pos/npes_y
503  ipos_beg = igroup*npes_x; ipos_end = ipos_beg + npes_x - 1
504  jpos_beg = jgroup*npes_y; jpos_end = jpos_beg + npes_y - 1
505  npes_in_group = 0
506  do j = jpos_beg, jpos_end
507  do i = ipos_beg, ipos_end
508  if(domain%pearray(i,j) .NE. null_pe) npes_in_group = npes_in_group+1
509  enddo
510  enddo
511 
512  io_domain%whalo = domain%whalo
513  io_domain%ehalo = domain%ehalo
514  io_domain%shalo = domain%shalo
515  io_domain%nhalo = domain%nhalo
516  io_domain%ntiles = 1
517  io_domain%pe = domain%pe
518  io_domain%symmetry = domain%symmetry
519  if (associated(io_domain%list)) deallocate(io_domain%list) !< Check if associated
520  allocate(io_domain%list(0:npes_in_group-1))
521  do i = 0, npes_in_group-1
522  allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) )
523  enddo
524 
525  ndivx = size(domain%pearray,1)
526  ndivy = size(domain%pearray,2)
527  allocate(posarray(0:ndivx-1, 0:ndivy-1))
528  n = domain%tile_root_pe - mpp_root_pe()
529  posarray = -1
530  do j = 0,ndivy-1
531  do i = 0,ndivx-1
532  if( domain%pearray(i,j) == null_pe) cycle
533  posarray(i,j) = n
534  n = n + 1
535  enddo
536  enddo
537 
538  n = 0
539  do j = jpos_beg, jpos_end
540  do i = ipos_beg, ipos_end
541  if( domain%pearray(i,j) == null_pe) cycle
542  io_domain%list(n)%pe = domain%pearray(i,j)
543  m = posarray(i,j)
544  io_domain%list(n)%x(1)%compute = domain%list(m)%x(1)%compute
545  io_domain%list(n)%y(1)%compute = domain%list(m)%y(1)%compute
546  igroup = domain%list(m)%x(1)%pos/npes_x
547  jgroup = domain%list(m)%y(1)%pos/npes_y
548  io_domain%list(n)%tile_id(1) = jgroup*io_layout(1) + igroup
549  n = n + 1
550  enddo
551  enddo
552  deallocate(posarray)
553 
554  if (associated(io_domain%x)) deallocate(io_domain%x) !< Check if associated
555  if (associated(io_domain%y)) deallocate(io_domain%y) !< Check if associated
556  if (associated(io_domain%tile_id)) deallocate(io_domain%tile_id) !< Check if associated
557  allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
558  allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) )
559  n = -1
560  do j = jpos_beg, jpos_beg+jpos
561  do i = ipos_beg, ipos_beg+ipos
562  if(domain%pearray(i,j) .NE. null_pe) n = n + 1
563  enddo
564  enddo
565  io_domain%pos = n
566  io_domain%x(1)%compute = domain%x(1)%compute
567  io_domain%x(1)%domain_data = domain%x(1)%domain_data
568  io_domain%x(1)%memory = domain%x(1)%memory
569  io_domain%y(1)%compute = domain%y(1)%compute
570  io_domain%y(1)%domain_data = domain%y(1)%domain_data
571  io_domain%y(1)%memory = domain%y(1)%memory
572  io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin
573  io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end
574  io_domain%x(1)%global%size = io_domain%x(1)%global%end - io_domain%x(1)%global%begin + 1
575  io_domain%x(1)%global%max_size = io_domain%x(1)%global%size
576  io_domain%y(1)%global%begin = domain%y(1)%list(jpos_beg)%compute%begin
577  io_domain%y(1)%global%end = domain%y(1)%list(jpos_end)%compute%end
578  io_domain%y(1)%global%size = io_domain%y(1)%global%end - io_domain%y(1)%global%begin + 1
579  io_domain%y(1)%global%max_size = io_domain%y(1)%global%size
580  io_domain%x(1)%pos = ipos
581  io_domain%y(1)%pos = jpos
582  io_domain%tile_id(1) = io_domain%list(n)%tile_id(1)
583  io_domain%tile_root_pe = io_domain%list(0)%pe
584 
585  !z1l
586 !!$ do j = 0, npes_y - 1
587 !!$ n = j*npes_x + ipos
588 !!$ io_domain%y(1)%list(j) = io_domain%list(n)%y(1)
589 !!$ enddo
590 !!$ do i = 0, npes_x - 1
591 !!$ n = jpos*npes_x + i
592 !!$ io_domain%x(1)%list(i) = io_domain%list(n)%x(1)
593 !!$ enddo
594 
595  whalo = domain%whalo
596  ehalo = domain%ehalo
597  shalo = domain%shalo
598  nhalo = domain%nhalo
599 
600  io_domain=>null()
601 
602 
603  end subroutine mpp_define_io_domain
604 
605  !> Define 2D data and computational domain on global rectilinear cartesian domain
606  !! (isg:ieg,jsg:jeg) and assign them to PEs
607  subroutine mpp_define_domains2d( global_indices, layout, domain, pelist, xflags, yflags, &
608  xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, &
609  whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
610  integer, intent(in) :: global_indices(:) !<(/ isg, ieg, jsg, jeg /)
611  integer, intent(in) :: layout(:) !< pe layout
612  type(domain2d), intent(inout) :: domain !< 2D domain decomposition to define
613  integer, intent(in), optional :: pelist(0:) !< current pelist to run on
614  integer, intent(in), optional :: xflags, yflags !< directional flag
615  integer, intent(in), optional :: xhalo, yhalo !< halo sizes for x and y indices
616  integer, intent(in), optional :: xextent(0:), yextent(0:)
617  logical, intent(in), optional :: maskmap(0:,0:)
618  character(len=*), intent(in), optional :: name
619  logical, intent(in), optional :: symmetry
620  logical, intent(in), optional :: is_mosaic !< indicate if calling mpp_define_domains
621  !! from mpp_define_mosaic.
622  integer, intent(in), optional :: memory_size(:)
623  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo !< halo size for West, East,
624  !! South and North direction.
625  !! if whalo and ehalo is not present,
626  !! will take the value of xhalo
627  !! if shalo and nhalo is not present,
628  !! will take the value of yhalo
629  integer, intent(in), optional :: tile_count !< tile number on current pe,
630  !! default value is 1.
631  !! this is for the situation that
632  !! multiple tiles on one processor
633  integer, intent(in), optional :: tile_id !< tile id
634  logical, intent(in), optional :: complete !< true indicate mpp_define_domain
635  !! is completed for mosaic definition.
636  integer, intent(in), optional :: x_cyclic_offset !< offset for x-cyclic boundary condition,
637  !! (0,j) = (ni, mod(j+x_cyclic_offset,nj))
638  !! (ni+1, j)=(1 ,mod(j+nj-x_cyclic_offset,nj))
639  integer, intent(in), optional :: y_cyclic_offset !< offset for y-cyclic boundary condition
640  !!(i,0) = (mod(i+y_cyclic_offset,ni), nj))
641  !!(i,nj+1) =(mod(mod(i+ni-y_cyclic_offset,ni),
642  !! 1) )
643 
644  integer :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
645  integer :: whalosz, ehalosz, shalosz, nhalosz
646  integer :: ipos, jpos, pos, tile, nlist, cur_tile_id, cur_comm_id
647  integer :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
648  integer :: x_offset, y_offset, start_pos, nfold
649  logical :: from_mosaic, is_complete
650  logical :: mask(0:layout(1)-1,0:layout(2)-1)
651  integer, allocatable :: pes(:), pesall(:)
652  integer :: pearray(0:layout(1)-1,0:layout(2)-1)
653  integer :: ibegin(0:layout(1)-1), iend(0:layout(1)-1)
654  integer :: jbegin(0:layout(2)-1), jend(0:layout(2)-1)
655  character(len=8) :: text
656  type(overlapspec), pointer :: check_T => null()
657  integer :: outunit
658  logical :: send(8), recv(8)
659 
660  outunit = stdout()
661  if( .NOT.module_is_initialized )call mpp_error( fatal, &
662  & 'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
663  if(PRESENT(name)) then
664  if(len_trim(name) > name_length) call mpp_error(fatal, &
665  "mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument name ="//trim(name)// &
666  " is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
667  domain%name = name
668  endif
669  if(size(global_indices(:)) .NE. 4) call mpp_error(fatal, &
670  "mpp_define_domains2D: size of global_indices should be 4 for "//trim(domain%name) )
671  if(size(layout(:)) .NE. 2) call mpp_error(fatal,"mpp_define_domains2D: size of layout should be 2 for "// &
672  & trim(domain%name) )
673 
674  ndivx = layout(1); ndivy = layout(2)
675  isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
676 
677  from_mosaic = .false.
678  if(present(is_mosaic)) from_mosaic = is_mosaic
679  is_complete = .true.
680  if(present(complete)) is_complete = complete
681  tile = 1
682  if(present(tile_count)) tile = tile_count
683  cur_tile_id = 1
684  if(present(tile_id)) cur_tile_id = tile_id
685 
686  cur_comm_id=0
687  if( PRESENT(pelist) )then
688  allocate( pes(0:size(pelist(:))-1) )
689  pes = pelist
690  if(from_mosaic) then
691  allocate( pesall(0:mpp_npes()-1) )
692  call mpp_get_current_pelist(pesall, commid=cur_comm_id)
693  else
694  allocate( pesall(0:size(pes(:))-1) )
695  pesall = pes
696  call mpp_get_current_pelist(pesall, commid=cur_comm_id)
697  end if
698  else
699  allocate( pes(0:mpp_npes()-1) )
700  allocate( pesall(0:mpp_npes()-1) )
701  call mpp_get_current_pelist(pes, commid=cur_comm_id)
702  pesall = pes
703  end if
704 
705  !--- at least of one of x_cyclic_offset and y_cyclic_offset must be zero
706  !--- folded boundary condition is not supported when either x_cyclic_offset or y_cyclic_offset is nonzero.
707  !--- Since we only implemented Folded-north boundary condition currently, we only consider y-flags.
708  x_offset = 0; y_offset = 0
709  if(PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
710  if(PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
711  if(x_offset*y_offset .NE. 0) call mpp_error(fatal, &
712  'MPP_DEFINE_DOMAINS2D: At least one of x_cyclic_offset and y_cyclic_offset must be zero for '// &
713  & trim(domain%name))
714 
715  !--- x_cyclic_offset and y_cyclic_offset should no larger than the global grid size.
716  if(abs(x_offset) > jeg-jsg+1) call mpp_error(fatal, &
717  'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset is greater than jeg-jsg+1 for '//trim(domain%name))
718  if(abs(y_offset) > ieg-isg+1) call mpp_error(fatal, &
719  'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset is greater than ieg-isg+1 for '//trim(domain%name))
720 
721  !--- when there is more than one tile on one processor, all the tile will limited on this processor
722  if( tile > 1 .AND. size(pes(:)) > 1) call mpp_error(fatal, &
723  'MPP_DEFINE_DOMAINS2D: there are more than one tile on this pe, '// &
724  'all the tile should be limited on this pe for '//trim(domain%name))
725 
726  !--- the position of current pe is changed due to mosaic, because pes
727  !--- is only part of the pelist in mosaic (pesall). We assume the pe
728  !--- distribution are contious in mosaic.
729  pos = -1
730  do n = 0, size(pesall(:))-1
731  if(pesall(n) == mpp_pe() ) then
732  pos = n
733  exit
734  endif
735  enddo
736  if(pos<0) call mpp_error(fatal, 'MPP_DEFINE_DOMAINS2D: mpp_pe() is not in the pesall list')
737 
738  domain%symmetry = .false.
739  if(present(symmetry)) domain%symmetry = symmetry
740  if(domain%symmetry) then
741  ishift = 1; jshift = 1
742  else
743  ishift = 0; jshift = 0
744  end if
745 
746  !--- first compute domain decomposition.
747  call mpp_compute_extent(isg, ieg, ndivx, ibegin, iend, xextent)
748  call mpp_compute_extent(jsg, jeg, ndivy, jbegin, jend, yextent)
749 
750  xhalosz = 0; yhalosz = 0
751  if(present(xhalo)) xhalosz = xhalo
752  if(present(yhalo)) yhalosz = yhalo
753  whalosz = xhalosz; ehalosz = xhalosz
754  shalosz = yhalosz; nhalosz = yhalosz
755  if(present(whalo)) whalosz = whalo
756  if(present(ehalo)) ehalosz = ehalo
757  if(present(shalo)) shalosz = shalo
758  if(present(nhalo)) nhalosz = nhalo
759 
760  !--- configure maskmap
761  mask = .true.
762  if( PRESENT(maskmap) )then
763  if( size(maskmap,1).NE.ndivx .OR. size(maskmap,2).NE.ndivy ) &
764  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout for '// &
765  & trim(domain%name) )
766  mask(:,:) = maskmap(:,:)
767  end if
768  !number of unmask domains in layout must equal number of PEs assigned
769  n = count(mask)
770  if( n.NE.size(pes(:)) )then
771  write( text,'(i8)' )n
772  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for ' // &
773  'this layout and maskmap. Use '//text//' PEs for this domain decomposition for '//trim(domain%name) )
774  end if
775 
776  memory_xsize = 0; memory_ysize = 0
777  if(present(memory_size)) then
778  if(size(memory_size(:)) .NE. 2) call mpp_error(fatal, &
779  "mpp_define_domains2D: size of memory_size should be 2 for "//trim(domain%name))
780  memory_xsize = memory_size(1)
781  memory_ysize = memory_size(2)
782  end if
783 
784  !--- set up domain%list.
785  !--- set up 2-D domain decomposition for T, E, C, N and computing overlapping
786  !--- when current tile is the last tile in the mosaic.
787  nlist = size(pesall(:))
788  if( .NOT. Associated(domain%x) ) then
789  allocate(domain%tileList(1))
790  domain%tileList(1)%xbegin = global_indices(1)
791  domain%tileList(1)%xend = global_indices(2)
792  domain%tileList(1)%ybegin = global_indices(3)
793  domain%tileList(1)%yend = global_indices(4)
794  allocate(domain%x(1), domain%y(1) )
795  allocate(domain%tile_id(1))
796  allocate(domain%tile_id_all(1))
797  domain%tile_id = cur_tile_id
798  domain%tile_id_all = cur_tile_id
799  domain%tile_comm_id = cur_comm_id
800  domain%ntiles = 1
801  domain%max_ntile_pe = 1
802  domain%ncontacts = 0
803  domain%rotated_ninety = .false.
804  allocate( domain%list(0:nlist-1) )
805  do i = 0, nlist-1
806  allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1))
807  end do
808  end if
809 
810  domain%initialized = .true.
811 
812  start_pos = 0
813  do n = 0, nlist-1
814  if(pesall(n) == pes(0)) then
815  start_pos = n
816  exit
817  endif
818  enddo
819 
820  !place on PE array; need flag to assign them to j first and then i
821  pearray(:,:) = null_pe
822  ipos = null_pe; jpos = null_pe
823  n = 0
824  m = start_pos
825  do j = 0,ndivy-1
826  do i = 0,ndivx-1
827  if( mask(i,j) )then
828  pearray(i,j) = pes(n)
829  domain%list(m)%x(tile)%compute%begin = ibegin(i)
830  domain%list(m)%x(tile)%compute%end = iend(i)
831  domain%list(m)%y(tile)%compute%begin = jbegin(j)
832  domain%list(m)%y(tile)%compute%end = jend(j)
833  domain%list(m)%x(tile)%compute%size = domain%list(m)%x(tile)%compute%end &
834  & - domain%list(m)%x(tile)%compute%begin + 1
835  domain%list(m)%y(tile)%compute%size = domain%list(m)%y(tile)%compute%end &
836  & - domain%list(m)%y(tile)%compute%begin + 1
837  domain%list(m)%tile_id(tile) = cur_tile_id
838  domain%list(m)%x(tile)%pos = i
839  domain%list(m)%y(tile)%pos = j
840  domain%list(m)%tile_root_pe = pes(0)
841  domain%list(m)%pe = pesall(m)
842 
843  if( pes(n).EQ.mpp_pe() )then
844  ipos = i
845  jpos = j
846  end if
847  n = n + 1
848  m = m + 1
849  end if
850  end do
851  end do
852 
853  !Considering mosaic, the following will only be done on the pe in the pelist
854  !when there is only one tile, all the current pe will be in the pelist.
855  if( any(pes == mpp_pe()) ) then
856  domain%io_layout = layout
857  domain%tile_root_pe = pes(0)
858  domain%comm_id = cur_comm_id
859  if( ipos.EQ.null_pe .OR. jpos.EQ.null_pe ) &
860  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS2D: pelist must include this PE for '//trim(domain%name) )
861  if( debug ) then
862  errunit = stderr()
863  write( errunit, * )'pe, tile, ipos, jpos=', mpp_pe(), tile, ipos, jpos, ' pearray(:,jpos)=', &
864  pearray(:,jpos), ' pearray(ipos,:)=', pearray(ipos,:)
865  endif
866 
867  !--- when tile is not equal to 1, the layout for that tile always ( 1, 1), so no need for pearray in domain
868  if( tile == 1 ) then
869  if (associated(domain%pearray)) deallocate(domain%pearray) !< Check if allocated
870  allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
871  domain%pearray = pearray
872  end if
873 
874  domain%pe = mpp_pe()
875  domain%pos = pos
876  domain_cnt = domain_cnt + int(1,kind=i8_kind)
877  domain%id = domain_cnt*domain_id_base ! Must be i8_kind arithmetic
878 
879  !do domain decomposition using 1D versions in X and Y,
880  call mpp_define_domains( global_indices(1:2), ndivx, domain%x(tile), &
881  pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
882  call mpp_define_domains( global_indices(3:4), ndivy, domain%y(tile), &
883  pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
884  if( domain%x(tile)%list(ipos)%pe.NE.domain%y(tile)%list(jpos)%pe ) &
885  call mpp_error( fatal, .NE.'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pedomain%y%list(jpos)%pe.' )
886 
887  !--- when x_cyclic_offset or y_cyclic_offset is set, no cross domain is allowed
888  if(x_offset .NE. 0 .OR. y_offset .NE. 0) then
889  if(whalosz .GT. domain%x(tile)%compute%size .OR. ehalosz .GT. domain%x(tile)%compute%size ) &
890  call mpp_error(fatal, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
891  "whalo and ehalo must be no larger than the x-direction computation domain size")
892  if(shalosz .GT. domain%y(tile)%compute%size .OR. nhalosz .GT. domain%y(tile)%compute%size ) &
893  call mpp_error(fatal, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
894  "shalo and nhalo must be no larger than the y-direction computation domain size")
895  endif
896 
897  !--- restrict the halo size is no larger than global domain size.
898  if(whalosz .GT. domain%x(tile)%global%size) &
899  call mpp_error(fatal, "MPP_DEFINE_DOMAINS2D: whalo is greather global domain size")
900  if(ehalosz .GT. domain%x(tile)%global%size) &
901  call mpp_error(fatal, "MPP_DEFINE_DOMAINS2D: ehalo is greather global domain size")
902  if(shalosz .GT. domain%x(tile)%global%size) &
903  call mpp_error(fatal, "MPP_DEFINE_DOMAINS2D: shalo is greather global domain size")
904  if(nhalosz .GT. domain%x(tile)%global%size) &
905  call mpp_error(fatal, "MPP_DEFINE_DOMAINS2D: nhalo is greather global domain size")
906 
907  !set up fold, when the boundary is folded, there is only one tile.
908  domain%fold = 0
909  nfold = 0
910  if( PRESENT(xflags) )then
911  if( btest(xflags,west) ) then
912  !--- make sure no cross-domain in y-direction
913  if(domain%x(tile)%domain_data%begin .LE. domain%x(tile)%global%begin .AND. &
914  domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then
915  call mpp_error(fatal, &
916  'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded')
917  endif
918  if( domain%x(tile)%cyclic )call mpp_error( fatal, &
919  'MPP_DEFINE_DOMAINS: an axis cannot be both folded west and cyclic for '//trim(domain%name) )
920  domain%fold = domain%fold + fold_west_edge
921  nfold = nfold+1
922  endif
923  if( btest(xflags,east) ) then
924  !--- make sure no cross-domain in y-direction
925  if(domain%x(tile)%domain_data%end .GE. domain%x(tile)%global%end .AND. &
926  domain%x(tile)%compute%end < domain%x(tile)%global%end ) then
927  call mpp_error(fatal, &
928  'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded')
929  endif
930  if( domain%x(tile)%cyclic )call mpp_error( fatal, &
931  'MPP_DEFINE_DOMAINS: an axis cannot be both folded east and cyclic for '//trim(domain%name) )
932  domain%fold = domain%fold + fold_east_edge
933  nfold = nfold+1
934  endif
935  endif
936  if( PRESENT(yflags) )then
937  if( btest(yflags,south) ) then
938  !--- make sure no cross-domain in y-direction
939  if(domain%y(tile)%domain_data%begin .LE. domain%y(tile)%global%begin .AND. &
940  domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then
941  call mpp_error(fatal, &
942  'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded')
943  endif
944  if( domain%y(tile)%cyclic )call mpp_error( fatal, &
945  'MPP_DEFINE_DOMAINS: an axis cannot be both folded north and cyclic for '//trim(domain%name))
946  domain%fold = domain%fold + fold_south_edge
947  nfold = nfold+1
948  endif
949  if( btest(yflags,north) ) then
950  !--- when the halo size is big and halo region is crossing neighbor domain, we
951  !--- restrict the halo size is less than half of the global size.
952  if(whalosz .GT. domain%x(tile)%compute%size .AND. whalosz .GE. domain%x(tile)%global%size/2 ) &
953  call mpp_error(fatal, .GT."MPP_DEFINE_DOMAINS2D: north is folded, whalo compute domain size "// &
954  .GE."and whalo half of global domain size")
955  if(ehalosz .GT. domain%x(tile)%compute%size .AND. ehalosz .GE. domain%x(tile)%global%size/2 ) &
956  call mpp_error(fatal, .GT."MPP_DEFINE_DOMAINS2D: north is folded, ehalo is compute domain size "// &
957  .GE."and ehalo half of global domain size")
958  if(shalosz .GT. domain%y(tile)%compute%size .AND. shalosz .GE. domain%x(tile)%global%size/2 ) &
959  call mpp_error(fatal, .GT."MPP_DEFINE_DOMAINS2D: north is folded, shalo compute domain size "// &
960  .GE."and shalo half of global domain size")
961  if(nhalosz .GT. domain%y(tile)%compute%size .AND. nhalosz .GE. domain%x(tile)%global%size/2 ) &
962  call mpp_error(fatal, .GT."MPP_DEFINE_DOMAINS2D: north is folded, nhalo compute domain size "// &
963  .GE."and nhalo half of global domain size")
964 
965 
966  if( domain%y(tile)%cyclic )call mpp_error( fatal, &
967  'MPP_DEFINE_DOMAINS: an axis cannot be both folded south and cyclic for '//trim(domain%name) )
968  domain%fold = domain%fold + fold_north_edge
969  nfold = nfold+1
970  endif
971  endif
972  if(nfold > 1) call mpp_error(fatal, &
973  'MPP_DEFINE_DOMAINS2D: number of folded edge is greater than 1 for '//trim(domain%name) )
974 
975  if(nfold == 1) then
976  if( x_offset .NE. 0 .OR. y_offset .NE. 0) call mpp_error(fatal, &
977  'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition, '//&
978  'x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
979  endif
980  if( btest(domain%fold,south) .OR. btest(domain%fold,north) )then
981  if( domain%y(tile)%cyclic )call mpp_error( fatal, &
982  'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
983  if( modulo(domain%x(tile)%global%size,2).NE.0 ) &
984  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS: number of points in X must be even ' // &
985  'when there is a fold in Y for '//trim(domain%name) )
986  !check if folded domain boundaries line up in X: compute domains lining up is a sufficient
987  !condition for symmetry
988  n = ndivx - 1
989  do i = 0,n/2
990  if( domain%x(tile)%list(i)%compute%size.NE.domain%x(tile)%list(n-i)%compute%size ) &
991  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS: Folded domain boundaries ' // &
992  'must line up (mirror-symmetric extents) for '//trim(domain%name) )
993  end do
994  end if
995  if( btest(domain%fold,west) .OR. btest(domain%fold,east) )then
996  if( domain%x(tile)%cyclic )call mpp_error( fatal, &
997  'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
998  if( modulo(domain%y(tile)%global%size,2).NE.0 ) &
999  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS: number of points in Y must be even '//&
1000  'when there is a fold in X for '//trim(domain%name) )
1001  !check if folded domain boundaries line up in Y: compute domains lining up is a sufficient
1002  !condition for symmetry
1003  n = ndivy - 1
1004  do i = 0,n/2
1005  if( domain%y(tile)%list(i)%compute%size.NE.domain%y(tile)%list(n-i)%compute%size ) &
1006  call mpp_error( fatal, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must '//&
1007  'line up (mirror-symmetric extents) for '//trim(domain%name) )
1008  end do
1009  end if
1010 
1011  !set up domain%list
1012  if( mpp_pe().EQ.pes(0) .AND. PRESENT(name) )then
1013  logunit = stdlog()
1014  write( logunit, '(/a,i5,a,i5)' )trim(name)//' domain decomposition: ', ndivx, ' X', ndivy
1015  write( logunit, '(3x,a)' )'pe, is, ie, js, je, isd, ied, jsd, jed'
1016  end if
1017  end if ! if( ANY(pes == mpp_pe()) )
1018 
1019  if(is_complete) then
1020  domain%whalo = whalosz; domain%ehalo = ehalosz
1021  domain%shalo = shalosz; domain%nhalo = nhalosz
1022  if (associated(domain%update_T)) deallocate(domain%update_T) !< Check if associated
1023  if (associated(domain%update_E)) deallocate(domain%update_E) !< Check if associated
1024  if (associated(domain%update_C)) deallocate(domain%update_C) !< Check if associated
1025  if (associated(domain%update_N)) deallocate(domain%update_N) !< Check if associated
1026  allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
1027  domain%update_T%next => null()
1028  domain%update_E%next => null()
1029  domain%update_C%next => null()
1030  domain%update_N%next => null()
1031  if (associated(domain%check_E)) deallocate(domain%check_E) !< Check if associated
1032  if (associated(domain%check_C)) deallocate(domain%check_C) !< Check if associated
1033  if (associated(domain%check_N)) deallocate(domain%check_N) !< Check if associated
1034  allocate(domain%check_E, domain%check_C, domain%check_N )
1035  domain%update_T%nsend = 0
1036  domain%update_T%nrecv = 0
1037  domain%update_C%nsend = 0
1038  domain%update_C%nrecv = 0
1039  domain%update_E%nsend = 0
1040  domain%update_E%nrecv = 0
1041  domain%update_N%nsend = 0
1042  domain%update_N%nrecv = 0
1043 
1044  if( btest(domain%fold,south) ) then
1045  call compute_overlaps_fold_south(domain, center, 0, 0)
1046  call compute_overlaps_fold_south(domain, corner, ishift, jshift)
1047  call compute_overlaps_fold_south(domain, east, ishift, 0)
1048  call compute_overlaps_fold_south(domain, north, 0, jshift)
1049  else if( btest(domain%fold,west) ) then
1050  call compute_overlaps_fold_west(domain, center, 0, 0)
1051  call compute_overlaps_fold_west(domain, corner, ishift, jshift)
1052  call compute_overlaps_fold_west(domain, east, ishift, 0)
1053  call compute_overlaps_fold_west(domain, north, 0, jshift)
1054  else if( btest(domain%fold,east) ) then
1055  call compute_overlaps_fold_east(domain, center, 0, 0)
1056  call compute_overlaps_fold_east(domain, corner, ishift, jshift)
1057  call compute_overlaps_fold_east(domain, east, ishift, 0)
1058  call compute_overlaps_fold_east(domain, north, 0, jshift)
1059  else
1060  call compute_overlaps(domain, center, domain%update_T, check_t, 0, 0, x_offset, y_offset, &
1061  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1062  call compute_overlaps(domain, corner, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
1063  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1064  call compute_overlaps(domain, east, domain%update_E, domain%check_E, ishift, 0, x_offset, y_offset, &
1065  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1066  call compute_overlaps(domain, north, domain%update_N, domain%check_N, 0, jshift, x_offset, y_offset, &
1067  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1068  endif
1069  call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_domains")
1070  call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_domains")
1071  call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_domains")
1072  call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_domains")
1073 
1074 
1075  !--- when ncontacts is nonzero, set_check_overlap will be called in mpp_define
1076  if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1077  call set_check_overlap( domain, corner )
1078  call set_check_overlap( domain, east )
1079  call set_check_overlap( domain, north )
1080  if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated
1081  if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated
1082  if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated
1083  allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1084  call set_bound_overlap( domain, corner )
1085  call set_bound_overlap( domain, east )
1086  call set_bound_overlap( domain, north )
1087  end if
1088  call set_domain_comm_inf(domain%update_T)
1089  call set_domain_comm_inf(domain%update_E)
1090  call set_domain_comm_inf(domain%update_C)
1091  call set_domain_comm_inf(domain%update_N)
1092  end if
1093 
1094  !--- check the send and recv size are matching.
1095  !--- or ntiles>1 mosaic,
1096  !--- the check will be done in mpp_define_mosaic
1097  if(debug_message_passing .and. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1098  send = .true.
1099  recv = .true.
1100  call check_message_size(domain, domain%update_T, send, recv, 'T')
1101  call check_message_size(domain, domain%update_E, send, recv, 'E')
1102  call check_message_size(domain, domain%update_C, send, recv, 'C')
1103  call check_message_size(domain, domain%update_N, send, recv, 'N')
1104  endif
1105 
1106 
1107  !print out decomposition, this didn't consider maskmap.
1108  if( mpp_pe() .EQ. pes(0) .AND. PRESENT(name) )then
1109  write(*,*) trim(name)//' domain decomposition'
1110  write(*,'(a,i4,a,i4,a,i4,a,i4)')'whalo = ', whalosz, ", ehalo = ", ehalosz, ", shalo = ", shalosz, &
1111  & ", nhalo = ", nhalosz
1112  write (*,110) (domain%x(1)%list(i)%compute%size, i= 0, layout(1)-1)
1113  write (*,120) (domain%y(1)%list(i)%compute%size, i= 0, layout(2)-1)
1114 110 format (' X-AXIS = ',24i4,/,(11x,24i4))
1115 120 format (' Y-AXIS = ',24i4,/,(11x,24i4))
1116  endif
1117 
1118  deallocate( pes, pesall)
1119 
1120 
1121  return
1122 end subroutine mpp_define_domains2d
1123 
1124 
1125 !#####################################################################
1126 subroutine check_message_size(domain, update, send, recv, position)
1127  type(domain2d), intent(in) :: domain
1128  type(overlapspec), intent(in) :: update
1129  logical, intent(in) :: send(:)
1130  logical, intent(in) :: recv(:)
1131  character, intent(in) :: position
1132 
1133  integer, dimension(0:size(domain%list(:))-1) :: msg1, msg2, msg3
1134  integer :: m, n, l, dir, is, ie, js, je, from_pe, msgsize
1135  integer :: nlist
1136 
1137  nlist = size(domain%list(:))
1138 
1139 
1140  msg1 = 0
1141  msg2 = 0
1142  do m = 1, update%nrecv
1143  msgsize = 0
1144  do n = 1, update%recv(m)%count
1145  dir = update%recv(m)%dir(n)
1146  if( recv(dir) ) then
1147  is = update%recv(m)%is(n); ie = update%recv(m)%ie(n)
1148  js = update%recv(m)%js(n); je = update%recv(m)%je(n)
1149  msgsize = msgsize + (ie-is+1)*(je-js+1)
1150  endif
1151  end do
1152  from_pe = update%recv(m)%pe
1153  l = from_pe-mpp_root_pe()
1154  call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.false., tag=comm_tag_1)
1155  msg2(l) = msgsize
1156  enddo
1157 
1158  do m = 1, update%nsend
1159  msgsize = 0
1160  do n = 1, update%send(m)%count
1161  dir = update%send(m)%dir(n)
1162  if(send(dir))then
1163  is = update%send(m)%is(n); ie = update%send(m)%ie(n)
1164  js = update%send(m)%js(n); je = update%send(m)%je(n)
1165  msgsize = msgsize + (ie-is+1)*(je-js+1)
1166  endif
1167  end do
1168  l = update%send(m)%pe-mpp_root_pe()
1169  msg3(l) = msgsize
1170  call mpp_send( msg3(l), plen=1, to_pe=update%send(m)%pe, tag=comm_tag_1)
1171  enddo
1172  call mpp_sync_self(check=event_recv)
1173 
1174  do m = 0, nlist-1
1175  if(msg1(m) .NE. msg2(m)) then
1176  print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",at position=",position,",from pe=", &
1177  domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
1178  call mpp_error(fatal, "mpp_define_domains2D: mismatch on send and recv size")
1179  endif
1180  enddo
1181  call mpp_sync_self()
1182 
1183 
1184 end subroutine check_message_size
1185 
1186  !#####################################################################
1187 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1188 ! !
1189 ! MPP_define_mosaic: define mosaic domain !
1190 ! NOTE: xflags and yflags is not in mpp_define_mosaic, because such relation !
1191 ! are already defined in the mosaic relation. !
1192 ! !
1193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1194 !??? do we need optional argument xextent and yextent
1195 !??? how to specify pelist, we may use two dimensional variable pelist to represent.
1196 !z1l: We assume the tilelist are in always limited to 1, 2, ... num_tile. If we want
1197 ! to remove this limitation, we need to add one more argument tilelist.
1198 
1199  !> Defines a domain for mosaic tile grids
1200  subroutine mpp_define_mosaic( global_indices, layout, domain, num_tile, num_contact, tile1, tile2, &
1201  istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
1202  pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, &
1203  maskmap, name, memory_size, symmetry, xflags, yflags, tile_id )
1204  integer, intent(in) :: global_indices(:,:) !>The size of first indice is 4,
1205  !! (/ isg, ieg, jsg, jeg /)
1206  !!The size of second indice
1207  !!is number of tiles in mosaic.
1208  integer, intent(in) :: layout(:,:)
1209  type(domain2d), intent(inout) :: domain
1210  integer, intent(in) :: num_tile !< number of tiles in the mosaic
1211  integer, intent(in) :: num_contact !< number of contact region between tiles.
1212  integer, intent(in) :: tile1(:), tile2(:) !< tile number
1213  integer, intent(in) :: istart1(:), iend1(:) !< i-index in tile_1 of contact region
1214  integer, intent(in) :: jstart1(:), jend1(:) !< j-index in tile_1 of contact region
1215  integer, intent(in) :: istart2(:), iend2(:) !< i-index in tile_2 of contact region
1216  integer, intent(in) :: jstart2(:), jend2(:) !< j-index in tile_2 of contact region
1217  integer, intent(in) :: pe_start(:) !< start pe of the pelist used in each tile
1218  integer, intent(in) :: pe_end(:) !< end pe of the pelist used in each tile
1219  integer, intent(in), optional :: pelist(:) !< list of processors used in mosaic
1220  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1221  integer, intent(in), optional :: xextent(:,:), yextent(:,:)
1222  logical, intent(in), optional :: maskmap(:,:,:)
1223  character(len=*), intent(in), optional :: name
1224  integer, intent(in), optional :: memory_size(2)
1225  logical, intent(in), optional :: symmetry
1226  integer, intent(in), optional :: xflags, yflags
1227  integer, intent(in), optional :: tile_id(:) !< tile_id of each tile in the mosaic
1228 
1229  integer :: n, m, ndivx, ndivy, nc, nlist, nt, pos, n1, n2
1230  integer :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz, t1, t2, tile
1231  integer :: flags_x, flags_y
1232  logical, allocatable :: mask(:,:)
1233  integer, allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
1234  integer, allocatable :: tile_id_local(:)
1235  logical :: is_symmetry
1236  integer, allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
1237  integer, allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:)
1238  real, allocatable :: refine1(:), refine2(:)
1239  integer :: outunit
1240  logical :: send(8), recv(8)
1241 
1242  outunit = stdout()
1243  mosaic_defined = .true.
1244  !--- the size of first indice of global_indices must be 4.
1245  if(size(global_indices, 1) .NE. 4) call mpp_error(fatal, &
1246  'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
1247  !--- the size of second indice of global_indices must be num_tile
1248  if(size(global_indices, 2) .NE. num_tile) call mpp_error(fatal, &
1249  'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
1250  !--- the size of first indice of layout must be 2. The second dimension size of layout must equal num_tile.
1251  if(size(layout, 1) .NE. 2) call mpp_error(fatal, &
1252  'mpp_domains_define.inc: The size of first dimension of layout is not 2')
1253  if(size(layout,2) .NE. num_tile) call mpp_error(fatal, &
1254  'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
1255 
1256  !--- setup pelist for the mosaic ---------------------
1257  nlist = mpp_npes()
1258  allocate(pes(0:nlist-1))
1259  if(present(pelist)) then
1260  if( nlist .NE. size(pelist(:))) call mpp_error(fatal, &
1261  'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
1262  pes = pelist
1263  end if
1264  call mpp_get_current_pelist(pes, commid=domain%comm_id)
1265  !--- pelist should be monotonic increasing by 1.
1266  do n = 1, nlist-1
1267  if(pes(n) - pes(n-1) .NE. 1) call mpp_error(fatal, &
1268  'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
1269  end do
1270 
1271  is_symmetry = .false.
1272  if(present(symmetry)) is_symmetry = symmetry
1273 
1274  if(size(pe_start(:)) .NE. num_tile .OR. size(pe_end(:)) .NE. num_tile ) call mpp_error(fatal, &
1275  'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
1276  !--- make sure pe_start and pe_end is in the pelist.
1277  if( any( pe_start < pes(0) ) ) call mpp_error(fatal, &
1278  & 'mpp_domains_define.inc: not all the pe_start are in the pelist')
1279  if( any( pe_end > pes(nlist-1)) ) call mpp_error(fatal, &
1280  & 'mpp_domains_define.inc: not all the pe_end are in the pelist')
1281 
1282  !--- calculate number of tiles on each pe.
1283  allocate( ntile_per_pe(0:nlist-1) )
1284  ntile_per_pe = 0
1285  do n = 1, num_tile
1286  do m = pe_start(n) - mpp_root_pe(), pe_end(n) - mpp_root_pe()
1287  ntile_per_pe(m) = ntile_per_pe(m) + 1
1288  end do
1289  end do
1290  if(any(ntile_per_pe == 0)) call mpp_error(fatal, &
1291  'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
1292 
1293  !--- check the size comformable of xextent and yextent
1294  if( PRESENT(xextent) ) then
1295  if(size(xextent,1) .GT. maxval(layout(1,:)) ) call mpp_error(fatal, &
1296  'mpp_domains_define.inc: size mismatch between xextent and layout')
1297  if(size(xextent,2) .NE. num_tile) call mpp_error(fatal, &
1298  'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
1299  end if
1300  if( PRESENT(yextent) ) then
1301  if(size(yextent,1) .GT. maxval(layout(2,:)) ) call mpp_error(fatal, &
1302  'mpp_domains_define.inc: size mismatch between yextent and layout')
1303  if(size(yextent,2) .NE. num_tile) call mpp_error(fatal, &
1304  'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
1305  end if
1306 
1307  !--- check the size comformable of maskmap
1308  !--- since the layout is different between tiles, so the actual size of maskmap for each tile is
1309  !--- not diffrent. When define maskmap for multiple tiles, user can choose the maximum value
1310  !--- of layout of all tiles to the first and second dimension of maskmap.
1311  if(present(maskmap)) then
1312  if(size(maskmap,1) .GT. maxval(layout(1,:)) .or. size(maskmap,2) .GT. maxval(layout(2,:))) &
1313  call mpp_error(fatal, 'mpp_domains_define.inc: size mismatch between maskmap and layout')
1314  if(size(maskmap,3) .NE. num_tile) call mpp_error(fatal, &
1315  'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
1316  end if
1317 
1318  if (associated(domain%tileList)) deallocate(domain%tileList) !< Check if associated
1319  allocate(domain%tileList(num_tile))
1320  do n = 1, num_tile
1321  domain%tileList(n)%xbegin = global_indices(1,n)
1322  domain%tileList(n)%xend = global_indices(2,n)
1323  domain%tileList(n)%ybegin = global_indices(3,n)
1324  domain%tileList(n)%yend = global_indices(4,n)
1325  enddo
1326  !--- define some mosaic information in domain type
1327  nt = ntile_per_pe(mpp_pe()-mpp_root_pe())
1328  if (associated(domain%tile_id)) deallocate(domain%tile_id) !< Check if associated
1329  if (associated(domain%x)) deallocate(domain%x) !< Check if associated
1330  if (associated(domain%y)) deallocate(domain%y) !< Check if associated
1331  if (associated(domain%list)) deallocate(domain%list) !< Check if associated
1332  allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) )
1333  allocate(domain%list(0:nlist-1))
1334 
1335  do n = 0, nlist-1
1336  nt = ntile_per_pe(n)
1337  allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt))
1338  end do
1339 
1340  pos = 0
1341  pe = mpp_pe()
1342  if( PRESENT(tile_id) ) then
1343  if(size(tile_id(:)) .NE. num_tile) then
1344  call mpp_error(fatal, .NE."mpp_domains_define.inc: size(tile_id) num_tile")
1345  endif
1346  endif
1347  allocate(tile_id_local(num_tile))
1348 
1349 !These directives are a work-around for a bug in the CCE compiler, which
1350 !causes a segmentation fault when the compiler attempts to vectorize a
1351 !loop containing an optional argument (when -g is included).
1352 
1353 !DIR$ NOVECTOR
1354  do n = 1, num_tile
1355  if(PRESENT(tile_id)) then
1356  tile_id_local(n) = tile_id(n)
1357  else
1358  tile_id_local(n) = n
1359  endif
1360  enddo
1361 !DIR$ VECTOR
1362 
1363  do n = 1, num_tile
1364  if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n)) then
1365  pos = pos + 1
1366  domain%tile_id(pos) = tile_id_local(n)
1367  end if
1368  end do
1369 
1370  if (associated(domain%tile_id_all)) deallocate(domain%tile_id_all) !< Check if associated
1371  allocate(domain%tile_id_all(num_tile))
1372  domain%tile_id_all(:) = tile_id_local(:)
1373 
1374  domain%initialized = .true.
1375  domain%rotated_ninety = .false.
1376  domain%ntiles = num_tile
1377  domain%max_ntile_pe = maxval(ntile_per_pe)
1378  domain%ncontacts = num_contact
1379 
1380  deallocate(ntile_per_pe)
1381  !---call mpp_define_domain to define domain decomposition for each tile.
1382  allocate(tile_count(pes(0):pes(0)+nlist-1))
1383  tile_count = 0 ! tile number on current pe
1384 
1385  domain%tile_comm_id=0
1386  do n = 1, num_tile
1387  allocate(mask(layout(1,n), layout(2,n)))
1388  allocate(pelist_tile(pe_start(n):pe_end(n)) )
1389  tile_count(pe_start(n)) = tile_count(pe_start(n)) + 1
1390  do m = pe_start(n), pe_end(n)
1391  pelist_tile(m) = m
1392  end do
1393  !--- set the tile communicator
1394  if (any(pelist_tile == pe)) then
1395  call mpp_declare_pelist(pelist_tile, commid=domain%tile_comm_id)
1396  endif
1397  mask = .true.
1398  if(present(maskmap)) mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
1399  ndivx = layout(1,n); ndivy = layout(2,n)
1400  allocate(xext(ndivx), yext(ndivy))
1401  xext = 0; yext = 0
1402  if(present(xextent)) xext = xextent(1:ndivx,n)
1403  if(present(yextent)) yext = yextent(1:ndivy,n)
1404  ! when num_tile is one, we assume only folded_north and cyclic_x, cyclic_y boundary condition is the possible
1405  ! z1l: when we decide to support multiple-tile tripolar grid, we will redesign the following part.
1406  if(num_tile == 1) then
1407  flags_x = 0
1408  flags_y = 0
1409  if(PRESENT(xflags)) flags_x = xflags
1410  if(PRESENT(yflags)) flags_y = yflags
1411  do m = 1, num_contact
1412  if(istart1(m) == iend1(m) ) then ! x-direction contact, possible cyclic, folded-west or folded-east
1413  if(istart2(m) .NE. iend2(m) ) call mpp_error(fatal, &
1414  "mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
1415  if(istart1(m) == istart2(m) ) then ! folded west or folded east
1416  if(istart1(m) == global_indices(1,n) ) then
1417  if(.NOT. btest(flags_x,west) ) flags_x = flags_x + fold_west_edge
1418  else if(istart1(m) == global_indices(2,n) ) then
1419  if(.NOT. btest(flags_x,east) ) flags_x = flags_x + fold_east_edge
1420  else
1421  call mpp_error(fatal, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1422  "istart1 should equal global_indices(1) or global_indices(2)")
1423  endif
1424  else
1425  if(.NOT. btest(flags_x,cyclic)) flags_x = flags_x + cyclic_global_domain
1426  endif
1427  else if( jstart1(m) == jend1(m) ) then ! y-direction contact, cyclic, folded-south or folded-north
1428  if(jstart2(m) .NE. jend2(m) ) call mpp_error(fatal, &
1429  "mpp_domains_define: for one tile mosaic, when jstart1=jend1, jstart2 must equal jend2")
1430  if(jstart1(m) == jstart2(m) ) then ! folded south or folded north
1431  if(jstart1(m) == global_indices(3,n) ) then
1432  if(.NOT. btest(flags_y,south) ) flags_y = flags_y + fold_south_edge
1433  else if(jstart1(m) == global_indices(4,n) ) then
1434  if(.NOT. btest(flags_y,north) ) flags_y = flags_y + fold_north_edge
1435  else
1436  call mpp_error(fatal, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1437  "istart1 should equal global_indices(1) or global_indices(2)")
1438  endif
1439  else
1440  if(.NOT. btest(flags_y,cyclic)) flags_y = flags_y + cyclic_global_domain
1441  end if
1442  else
1443  call mpp_error(fatal, &
1444  "mpp_domains_define: for one tile mosaic, invalid boundary contact")
1445  end if
1446  end do
1447  call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, xflags = flags_x, &
1448  yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1449  xextent=xext, yextent=yext, maskmap=mask, name=name, symmetry=is_symmetry, &
1450  memory_size = memory_size, is_mosaic = .true., tile_id=tile_id_local(n))
1451  else
1452  call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, &
1453  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
1454  maskmap=mask, name=name, symmetry=is_symmetry, memory_size = memory_size, &
1455  is_mosaic = .true., tile_count = tile_count(pe_start(n)), tile_id=tile_id_local(n), &
1456  complete = n==num_tile)
1457  end if
1458  deallocate(mask, xext, yext, pelist_tile)
1459  end do
1460 
1461  deallocate(pes, tile_count, tile_id_local)
1462 
1463  if(num_contact == 0 .OR. num_tile == 1) return
1464 
1465  !--- loop through each contact region and find the contact for each tile ( including alignment )
1466  !--- we assume the tiles list is continuous and starting from 1.
1467  allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
1468  allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
1469  allocate(isglist(num_tile), ieglist(num_tile), jsglist(num_tile), jeglist(num_tile) )
1470  allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
1471  !--- get the global domain for each tile
1472  do n = 1, num_tile
1473  isglist(n) = domain%tileList(n)%xbegin; ieglist(n) = domain%tileList(n)%xend
1474  jsglist(n) = domain%tileList(n)%ybegin; jeglist(n) = domain%tileList(n)%yend
1475  end do
1476 
1477  !--- transfer the contact index to domain index.
1478  nc = 0
1479  do n = 1, num_contact
1480  t1 = tile1(n)
1481  t2 = tile2(n)
1482  is1(n) = istart1(n) + isglist(t1) - 1; ie1(n) = iend1(n) + isglist(t1) - 1
1483  js1(n) = jstart1(n) + jsglist(t1) - 1; je1(n) = jend1(n) + jsglist(t1) - 1
1484  is2(n) = istart2(n) + isglist(t2) - 1; ie2(n) = iend2(n) + isglist(t2) - 1
1485  js2(n) = jstart2(n) + jsglist(t2) - 1; je2(n) = jend2(n) + jsglist(t2) - 1
1486  call check_alignment( is1(n), ie1(n), js1(n), je1(n), isglist(t1), ieglist(t1), jsglist(t1), &
1487  & jeglist(t1), align1(n))
1488  call check_alignment( is2(n), ie2(n), js2(n), je2(n), isglist(t2), ieglist(t2), jsglist(t2), &
1489  & jeglist(t2), align2(n))
1490  if( (align1(n) == west .or. align1(n) == east ) .NEQV. (align2(n) == west .or. align2(n) == east ) )&
1491  domain%rotated_ninety=.true.
1492  end do
1493 
1494  !--- calculate the refinement ratio between tiles
1495  do n = 1, num_contact
1496  n1 = max(abs(iend1(n) - istart1(n)), abs(jend1(n) - jstart1(n)) ) + 1
1497  n2 = max(abs(iend2(n) - istart2(n)), abs(jend2(n) - jstart2(n)) ) + 1
1498  refine1(n) = real(n2)/n1
1499  refine2(n) = real(n1)/n2
1500  end do
1501 
1502  whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
1503  if(present(whalo)) whalosz = whalo
1504  if(present(ehalo)) ehalosz = ehalo
1505  if(present(shalo)) shalosz = shalo
1506  if(present(nhalo)) nhalosz = nhalo
1507  xhalosz = max(whalosz, ehalosz)
1508  yhalosz = max(shalosz, nhalosz)
1509 
1510  !--- computing the overlap for the contact region with halo size xhalosz and yhalosz
1511  call define_contact_point( domain, center, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
1512  is1, ie1, js1, je1, is2, ie2, js2, je2, isglist, ieglist, jsglist, jeglist )
1513 
1514  call set_contact_point( domain, corner )
1515  call set_contact_point( domain, east )
1516  call set_contact_point( domain, north )
1517 
1518  call set_domain_comm_inf(domain%update_T)
1519  call set_domain_comm_inf(domain%update_E)
1520  call set_domain_comm_inf(domain%update_C)
1521  call set_domain_comm_inf(domain%update_N)
1522 
1523 
1524  !--- goffset setting is needed for exact global sum
1525  do m = 1, size(domain%tile_id(:))
1526  tile = domain%tile_id(m)
1527  do n = 1, num_contact
1528  if( tile1(n) == tile ) then
1529  if(align1(n) == east ) domain%x(m)%goffset = 0
1530  if(align1(n) == north) domain%y(m)%goffset = 0
1531  end if
1532  if( tile2(n) == tile ) then
1533  if(align2(n) == east ) domain%x(m)%goffset = 0
1534  if(align2(n) == north) domain%y(m)%goffset = 0
1535  end if
1536  end do
1537  end do
1538  call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_mosaic")
1539  call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_mosaic")
1540  call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_mosaic")
1541  call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_mosaic")
1542 
1543  !--- set the overlapping for boundary check if domain is symmetry
1544  if(debug_update_level .NE. no_check) then
1545  call set_check_overlap( domain, corner )
1546  call set_check_overlap( domain, east )
1547  call set_check_overlap( domain, north )
1548  endif
1549  if(domain%symmetry) then
1550  if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated
1551  if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated
1552  if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated
1553  allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1554  call set_bound_overlap( domain, corner )
1555  call set_bound_overlap( domain, east )
1556  call set_bound_overlap( domain, north )
1557  call check_overlap_pe_order(domain, domain%bound_C, trim(domain%name)//" bound_C")
1558  call check_overlap_pe_order(domain, domain%bound_E, trim(domain%name)//" bound_E")
1559  call check_overlap_pe_order(domain, domain%bound_N, trim(domain%name)//" bound_N")
1560  end if
1561 
1562  !--- check the send and recv size are matching.
1563  !--- currently only check T and C-cell. For ntiles>1 mosaic,
1564  !--- the check will be done in mpp_define_mosaic
1565  if(debug_message_passing) then
1566  send = .true.
1567  recv = .true.
1568  call check_message_size(domain, domain%update_T, send, recv, 'T')
1569  call check_message_size(domain, domain%update_C, send, recv, 'C')
1570  call check_message_size(domain, domain%update_E, send, recv, 'E')
1571  call check_message_size(domain, domain%update_N, send, recv, 'N')
1572  endif
1573 
1574 
1575  !--- release memory
1576  deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2 )
1577  deallocate(isglist, ieglist, jsglist, jeglist, refine1, refine2 )
1578 
1579 
1580  end subroutine mpp_define_mosaic
1581 
1582 !#####################################################################
1583  !> Accessor function for value of mosaic_defined
1584  logical function mpp_mosaic_defined()
1585  mpp_mosaic_defined = mosaic_defined
1586  end function mpp_mosaic_defined
1587 !#####################################################################
1588 
1589  !> @brief Computes remote domain overlaps
1590  !!
1591  !> Assumes only one in each direction
1592  !! will calculate the overlapping for T,E,C,N-cell separately.
1593  subroutine compute_overlaps( domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
1594  whalo, ehalo, shalo, nhalo )
1595  type(domain2d), intent(inout) :: domain
1596  type(overlapspec), intent(inout), pointer :: update
1597  type(overlapspec), intent(inout), pointer :: check
1598  integer, intent(in) :: position, ishift, jshift
1599  integer, intent(in) :: x_cyclic_offset, y_cyclic_offset
1600  integer, intent(in) :: whalo, ehalo, shalo, nhalo
1601 
1602  integer :: i, m, n, nlist, tMe, tNbr, dir
1603  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
1604  integer :: isg, ieg, jsg, jeg, ioff, joff
1605  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
1606  integer :: ism, iem, jsm, jem
1607  integer :: is2, ie2, js2, je2
1608  integer :: is3, ie3, js3, je3
1609  integer :: isd3, ied3, jsd3, jed3
1610  integer :: isd2, ied2, jsd2, jed2
1611  logical :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
1612  type(overlap_type) :: overlap
1613  type(overlap_type), pointer :: overlapList(:)=>null()
1614  type(overlap_type), pointer :: checkList(:)=>null()
1615  integer :: nsend, nrecv
1616  integer :: nsend_check, nrecv_check
1617  integer :: iunit
1618  logical :: set_check
1619 
1620  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
1621  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
1622  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
1623  if(size(domain%x(:)) > 1) return
1624 
1625  !--- if there is no halo, no need to compute overlaps.
1626  if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0) return
1627 
1628  !--- when there is only one tile, n will equal to np
1629  nlist = size(domain%list(:))
1630  set_check = .false.
1631  if(ASSOCIATED(check)) set_check = .true.
1632  allocate(overlaplist(maxlist) )
1633  if(set_check) allocate(checklist(maxlist) )
1634 
1635  !--- overlap is used to store the overlapping temporarily.
1636  call allocate_update_overlap( overlap, maxoverlap)
1637  !send
1638  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
1639  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
1640  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
1641 
1642  update%xbegin = ism; update%xend = iem
1643  update%ybegin = jsm; update%yend = jem
1644  if(set_check) then
1645  check%xbegin = ism; check%xend = iem
1646  check%ybegin = jsm; check%yend = jem
1647  endif
1648  update%whalo = whalo; update%ehalo = ehalo
1649  update%shalo = shalo; update%nhalo = nhalo
1650 
1651  ioff = ni - ishift
1652  joff = nj - jshift
1653  middle = (isg+ieg)/2+1
1654  tme = 1; tnbr = 1
1655  folded_north = btest(domain%fold,north)
1656  if( btest(domain%fold,south) .OR. btest(domain%fold,east) .OR. btest(domain%fold,west) ) then
1657  call mpp_error(fatal,"mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition "&
1658  &//"is not supported, please use other version of compute_overlaps for "//trim(domain%name))
1659  endif
1660 
1661  nsend = 0
1662  nsend_check = 0
1663 
1664  do list = 0,nlist-1
1665  m = mod( domain%pos+list, nlist )
1666  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
1667  !to_pe's eastern halo
1668  dir = 1
1669  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
1670  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
1671  !--- to make sure the consistence between pes
1672  if( domain%symmetry .AND. (position == north .OR. position == corner ) &
1673  .AND. ( jsc == je .or. jec == js ) ) then
1674  !--- do nothing, this point will come from other pe
1675  else
1676  !--- when the north face is folded, the east halo point at right side domain will be folded.
1677  !--- the position should be on CORNER or NORTH
1678  if( je == jeg .AND. folded_north .AND. (position == corner .OR. position == north) ) then
1679  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1680  isg, ieg, dir, ishift, position, ioff, middle)
1681  else
1682  if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1683  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1684  isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
1685  else
1686  if( ie.GT.ieg ) then
1687  if( domain%x(tme)%cyclic .AND. iec.LT.is )then !try cyclic offset
1688  is = is-ioff; ie = ie-ioff
1689  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1690  end if
1691  end if
1692  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1693  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1694  endif
1695  endif
1696  end if
1697 
1698  !to_pe's SE halo
1699  dir = 2
1700  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
1701  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1702  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1703  !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
1704  !--- the other part is both are zero.
1705  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1706  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1707  if(je .LT. jsg) then ! js .LT. jsg
1708  if( domain%y(tme)%cyclic ) then
1709  js = js + joff; je = je + joff
1710  endif
1711  else if(js .Lt. jsg) then ! split into two parts
1712  if( domain%y(tme)%cyclic ) then
1713  js2 = js + joff; je2 = jsg-1+joff
1714  js = jsg;
1715  endif
1716  endif
1717  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1718  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1719  if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1720  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1721  else
1722  if( ie.GT.ieg )then
1723  if( domain%x(tme)%cyclic .AND. iec.LT.is )then !try cyclic offset
1724  is = is-ioff; ie = ie-ioff
1725  need_adjust_1 = .false.
1726  if(jsg .GT. js) then
1727  if( domain%y(tme)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1728  js = js+joff; je = je+joff
1729  need_adjust_2 = .false.
1730  if(x_cyclic_offset .NE. 0) then
1731  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1732  else if(y_cyclic_offset .NE. 0) then
1733  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1734  end if
1735  end if
1736  else
1737  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1738  need_adjust_3 = .false.
1739  end if
1740  end if
1741  end if
1742  if( need_adjust_3 .AND. jsg.GT.js )then
1743  if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1744  js = js+joff; je = je+joff
1745  if(need_adjust_1 .AND. ie.LE.ieg) then
1746  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1747  end if
1748  end if
1749  end if
1750  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1751  endif
1752 
1753  !to_pe's southern halo
1754  dir = 3
1755  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
1756  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1757  js2 = 0; je2 = -1
1758  if( jsg.GT.je )then ! jsg .GT. js
1759  if( domain%y(tme)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1760  js = js+joff; je = je+joff
1761  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1762  end if
1763  else if (jsg .GT. js) then ! split into two parts
1764  if( domain%y(tme)%cyclic) then
1765  js2 = js + joff; je2 = jsg-1+joff
1766  js = jsg
1767  endif
1768  end if
1769 
1770  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1771  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1772  if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1773  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1774 
1775  !to_pe's SW halo
1776  dir = 4
1777  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1778  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
1779  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1780  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1781  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1782  if(je .LT. jsg) then ! js .LT. jsg
1783  if( domain%y(tme)%cyclic ) then
1784  js = js + joff; je = je + joff
1785  endif
1786  else if(js .Lt. jsg) then ! split into two parts
1787  if( domain%y(tme)%cyclic ) then
1788  js2 = js + joff; je2 = jsg-1+joff
1789  js = jsg;
1790  endif
1791  endif
1792  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1793  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1794  if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1795  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1796  else
1797  if( isg.GT.is )then
1798  if( domain%x(tme)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1799  is = is+ioff; ie = ie+ioff
1800  need_adjust_1 = .false.
1801  if(jsg .GT. js) then
1802  if( domain%y(tme)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1803  js = js+joff; je = je+joff
1804  need_adjust_2 = .false.
1805  if(x_cyclic_offset .NE. 0) then
1806  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1807  else if(y_cyclic_offset .NE. 0) then
1808  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1809  end if
1810  end if
1811  else
1812  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1813  need_adjust_3 = .false.
1814  end if
1815  end if
1816  end if
1817  if( need_adjust_3 .AND. jsg.GT.js )then
1818  if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1819  js = js+joff; je = je+joff
1820  if(need_adjust_1 .AND. isg.LE.is )then
1821  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1822  end if
1823  end if
1824  end if
1825  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1826  endif
1827 
1828  !to_pe's western halo
1829  dir = 5
1830  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1831  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
1832 
1833  !--- when the north face is folded, some point at j=nj will be folded.
1834  !--- the position should be on CORNER or NORTH
1835  if( je == jeg .AND. folded_north .AND. (position == corner .OR. position == north)) then
1836  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1837  isg, ieg, dir, ishift, position, ioff, middle)
1838  else
1839  if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1840  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1841  isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
1842  else
1843  if( isg.GT.is )then
1844  if( domain%x(tme)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1845  is = is+ioff; ie = ie+ioff
1846  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1847  endif
1848  end if
1849  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1850  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1851  end if
1852  end if
1853 
1854  !to_pe's NW halo
1855  dir = 6
1856  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
1857  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
1858  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1859  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
1860  folded = .false.
1861  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1862  if(js .GT. jeg) then ! je > jeg
1863  if( domain%y(tme)%cyclic ) then
1864  js = js-joff; je = je-joff
1865  else if(folded_north )then
1866  folded = .true.
1867  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1868  endif
1869  else if(je .GT. jeg) then ! split into two parts
1870  if( domain%y(tme)%cyclic ) then
1871  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1872  js = jeg+1-joff; je = je -joff
1873  else if(folded_north) then
1874  folded = .true.
1875  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1876  js = jeg+1
1877  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1878  if( is .GT. ieg) then
1879  is = is - ioff; ie = ie - ioff
1880  else if( ie .GT. ieg ) then
1881  is3 = is; ie3 = ieg; js3 = js; je3 = je
1882  is = ieg+1-ioff; ie = ie - ioff
1883  endif
1884  endif
1885  endif
1886 
1887  if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == corner .OR. position == north)) then
1888  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1889  isg, ieg, dir, ishift, position, ioff, middle)
1890  else
1891  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1892  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
1893  endif
1894  if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
1895  isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
1896  if(ie2 .GE. is2) then
1897  if(je2 == jeg .AND. jec == jeg .AND. folded_north.AND.(position == corner .OR. position == north))then
1898  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1899  isg, ieg, dir, ishift, position, ioff, middle)
1900  else
1901  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1902  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
1903  endif
1904  endif
1905  else
1906  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1907  if( isg.GT.is )then
1908  if( domain%x(tme)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1909  is = is+ioff; ie = ie+ioff
1910  need_adjust_1 = .false.
1911  if(je .GT. jeg) then
1912  if( domain%y(tme)%cyclic .AND. jec.LT.js )then !try cyclic offset
1913  js = js-joff; je = je-joff
1914  need_adjust_2 = .false.
1915  if(x_cyclic_offset .NE. 0) then
1916  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1917  else if(y_cyclic_offset .NE. 0) then
1918  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1919  end if
1920  end if
1921  else
1922  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1923  need_adjust_3 = .false.
1924  end if
1925  end if
1926  end if
1927  folded = .false.
1928  if( need_adjust_3 .AND. je.GT.jeg )then
1929  if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. jec.LT.js )then !try cyclic offset
1930  js = js-joff; je = je-joff
1931  if( need_adjust_1 .AND. isg.LE.is)then
1932  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1933  end if
1934  else if( folded_north )then
1935  folded = .true.
1936  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1937  end if
1938  end if
1939  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1940  isg, ieg, jsg, jeg, dir)
1941  endif
1942 
1943 
1944  !to_pe's northern halo
1945  dir = 7
1946  folded = .false.
1947  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
1948  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
1949 
1950  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
1951  !--- no need to send, because the data on that point will come from other pe.
1952  !--- come from two pe ( there will be only one point on one pe. ).
1953  if( domain%symmetry .AND. (position == east .OR. position == corner ) &
1954  .AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) ) then
1955  !--- do nothing, this point will come from other pe
1956  else
1957  js2 = -1; je2 = 0
1958  if( js .GT. jeg) then ! je .GT. jeg
1959  if( domain%y(tme)%cyclic .AND. jec.LT.js )then !try cyclic offset
1960  js = js-joff; je = je-joff
1961  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1962  else if( folded_north )then
1963  folded = .true.
1964  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1965  end if
1966  else if( je.GT.jeg )then ! split into two parts
1967  if( domain%y(tme)%cyclic)then !try cyclic offset
1968  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1969  js = jeg+1-joff; je = je - joff
1970  else if( folded_north )then
1971  folded = .true.
1972  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1973  js = jeg+1;
1974  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1975  end if
1976  end if
1977  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1978  if( je == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))then
1979  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, 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, is, ie, js, je, isc, iec, jsc, jec, &
1983  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, domain%symmetry)
1984  endif
1985  else
1986  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1987  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1988  endif
1989 
1990  if(ie2 .GE. is2) then
1991  if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))then
1992  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1993  isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1994  else
1995  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1996  isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
1997  endif
1998  endif
1999  end if
2000 
2001  !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
2002  if(is .LT. isg .AND. domain%x(tme)%cyclic) then
2003 ! is = is + ioff
2004 ! call insert_update_overlap( overlap, domain%list(m)%pe, &
2005 ! is, is, js, je, isc, iec, jsc, jec, dir, folded)
2006 !??? if(je2 .GE. js2)call insert_update_overlap( overlap, domain%list(m)%pe, &
2007 ! is, is, js2, je2, isc, iec, jsc, jec, dir, folded)
2008  endif
2009 
2010  !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
2011  !--- for folded-north-edge, only need to consider to_pe's north(7) direction
2012  !--- only position at NORTH and CORNER need to be considered
2013  if( folded_north .AND. (position == north .OR. position == corner) &
2014  .AND. domain%x(tme)%pos .LT. (size(domain%x(tme)%list(:))+1)/2 ) then
2015  if( domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .GE. jeg .AND. isc .LE. middle)then
2016  js = jeg; je = jeg
2017  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
2018  is = max(is, middle)
2019  select case (position)
2020  case(north)
2021  i=is; is = isg+ieg-ie; ie = isg+ieg-i
2022  case(corner)
2023  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2024  end select
2025  call insert_update_overlap(overlap, domain%list(m)%pe, &
2026  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
2027  endif
2028  if(debug_update_level .NE. no_check .AND. set_check) then
2029  je = domain%list(m)%y(tnbr)%compute%end+jshift;
2030  if(je == jeg) then
2031  is = max(is, isc); ie = min(ie, iec)
2032  js = max(js, jsc); je = min(je, jec)
2033  if(ie.GE.is .AND. je.GE.js )then
2034  nsend_check = nsend_check+1
2035  if(nsend_check > size(checklist(:)) ) then
2036  call expand_check_overlap_list(checklist, nlist)
2037  endif
2038  call allocate_check_overlap(checklist(nsend_check), 1)
2039  call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
2040  tme, 4, one_hundred_eighty, is, ie, js, je)
2041  end if
2042  end if
2043  endif
2044  endif
2045 
2046  !to_pe's NE halo
2047  dir = 8
2048  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
2049  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
2050  is2 = 0; ie2=-1; js2=0; je2=-1
2051  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2052  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2053  folded = .false.
2054  if(js .GT. jeg) then ! je > jeg
2055  if( domain%y(tme)%cyclic ) then
2056  js = js-joff; je = je-joff
2057  else if(folded_north )then
2058  folded = .true.
2059  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2060  endif
2061  else if(je .GT. jeg) then ! split into two parts
2062  if( domain%y(tme)%cyclic ) then
2063  is2 = is; ie2 = ie; js2 = js; je2 = jeg
2064  js = jeg+1-joff; je = je -joff
2065  else if(folded_north) then
2066  folded = .true.
2067  is2 = is; ie2 = ie; js2 = js; je2 = jeg
2068  js = jeg+1
2069  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2070 
2071  if( ie .LT. isg )then
2072  is = is+ioff; ie = ie+ioff
2073  else if( is .LT. isg) then
2074  is3 = isg; ie3 = ie; js3 = js; je3 = je
2075  is = is+ioff; ie = isg-1+ioff;
2076  endif
2077  endif
2078  endif
2079  if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == corner .OR. position == north)) then
2080  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2081  isg, ieg, dir, ishift, position, ioff, middle)
2082  else
2083  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2084  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2085  endif
2086  if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
2087  isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2088  if(ie2 .GE. is2) then
2089  if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND.(position == corner .OR. position == north))then
2090  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2091  isg, ieg, dir, ishift, position, ioff, middle)
2092  else
2093  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2094  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2095  endif
2096  endif
2097  else
2098  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2099  if( ie.GT.ieg )then
2100  if( domain%x(tme)%cyclic .AND. iec.LT.is )then !try cyclic offset
2101  is = is-ioff; ie = ie-ioff
2102  need_adjust_1 = .false.
2103  if(je .GT. jeg) then
2104  if( domain%y(tme)%cyclic .AND. jec.LT.js )then !try cyclic offset
2105  js = js-joff; je = je-joff
2106  need_adjust_2 = .false.
2107  if(x_cyclic_offset .NE. 0) then
2108  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2109  else if(y_cyclic_offset .NE. 0) then
2110  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2111  end if
2112  end if
2113  else
2114  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2115  need_adjust_3 = .false.
2116  end if
2117  end if
2118  end if
2119  folded = .false.
2120  if( need_adjust_3 .AND. je.GT.jeg )then
2121  if( need_adjust_2 .AND. domain%y(tme)%cyclic .AND. jec.LT.js )then !try cyclic offset
2122  js = js-joff; je = je-joff
2123  if( need_adjust_1 .AND. ie.LE.ieg)then
2124  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2125  end if
2126  else if( folded_north )then
2127  folded = .true.
2128  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2129  end if
2130  end if
2131  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2132  isg, ieg, jsg, jeg, dir)
2133  endif
2134  endif
2135 
2136  !--- copy the overlapping information
2137  if( overlap%count > 0) then
2138  nsend = nsend + 1
2139  if(nsend > size(overlaplist(:)) ) then
2140  call mpp_error(note, 'mpp_domains_define.inc(compute_overlaps): overlapList for send is expanded')
2141  call expand_update_overlap_list(overlaplist, nlist)
2142  endif
2143  call add_update_overlap( overlaplist(nsend), overlap)
2144  call init_overlap_type(overlap)
2145  endif
2146  end do ! end of send set up.
2147 
2148  if(debug_message_passing) then
2149  !--- write out send information
2150  iunit = mpp_pe() + 1000
2151  do m =1,nsend
2152  write(iunit, *) "********to_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
2153  do n = 1, overlaplist(m)%count
2154  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
2155  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
2156  enddo
2157  enddo
2158  if(nsend >0) flush(iunit)
2159  endif
2160 
2161  ! copy the overlapping information into domain data structure
2162  if(nsend>0) then
2163  if (associated(update%send)) deallocate(update%send) !< Check if associated
2164  allocate(update%send(nsend))
2165  update%nsend = nsend
2166  do m = 1, nsend
2167  call add_update_overlap( update%send(m), overlaplist(m) )
2168  enddo
2169  endif
2170 
2171  if(nsend_check>0) then
2172  check%nsend = nsend_check
2173  if (associated(check%send)) deallocate(check%send) !< Check if associated
2174  allocate(check%send(nsend_check))
2175  do m = 1, nsend_check
2176  call add_check_overlap( check%send(m), checklist(m) )
2177  enddo
2178  endif
2179 
2180  do m = 1,size(overlaplist(:))
2181  call deallocate_overlap_type(overlaplist(m))
2182  enddo
2183 
2184  if(debug_update_level .NE. no_check .AND. set_check) then
2185  do m = 1,size(checklist(:))
2186  call deallocate_overlap_type(checklist(m))
2187  enddo
2188  endif
2189 
2190  isgd = isg - domain%whalo
2191  iegd = ieg + domain%ehalo
2192  jsgd = jsg - domain%shalo
2193  jegd = jeg + domain%nhalo
2194 
2195  ! begin setting up recv
2196  nrecv = 0
2197  nrecv_check = 0
2198  do list = 0,nlist-1
2199  m = mod( domain%pos+nlist-list, nlist )
2200  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
2201  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
2202  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
2203  !recv_e
2204  dir = 1
2205  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2206  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
2207  is=isc; ie=iec; js=jsc; je=jec
2208  if( domain%symmetry .AND. (position == north .OR. position == corner ) &
2209  .AND. ( jsd == je .or. jed == js ) ) then
2210  ! --- do nothing, this point will come from other pe
2211  else
2212  !--- when the north face is folded, the east halo point at right side domain will be folded.
2213  !--- the position should be on CORNER or NORTH
2214  if( jed == jeg .AND. folded_north .AND. (position == corner .OR. position == north) ) then
2215  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2216  isg, ieg, dir, ishift, position, ioff, middle)
2217  else
2218  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2219  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2220  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2221  else
2222  if( ied.GT.ieg )then
2223  if( domain%x(tme)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2224  is = is+ioff; ie = ie+ioff
2225  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2226  end if
2227  end if
2228  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2229  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2230  endif
2231  endif
2232  endif
2233 
2234  !recv_se
2235  dir = 2
2236  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2237  jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2238  is=isc; ie=iec; js=jsc; je=jec
2239  !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
2240  !--- the other part is both are zero.
2241  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2242  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2243  if(jed .LT. jsg) then ! then jsd < jsg
2244  if( domain%y(tme)%cyclic ) then
2245  js = js-joff; je = je-joff
2246  endif
2247  else if(jsd .LT. jsg) then !split into two parts
2248  if( domain%y(tme)%cyclic ) then
2249  js2 = js-joff; je2 = je-joff
2250  endif
2251  endif
2252  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2253  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2254  if(je2 .GE. js2) call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2255  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2256  else
2257  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2258  if( jsd.LT.jsg )then
2259  if( domain%y(tme)%cyclic .AND. js.GT.jed )then !try cyclic offset
2260  js = js-joff; je = je-joff
2261  need_adjust_1 = .false.
2262  if( ied.GT.ieg )then
2263  if( domain%x(tme)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2264  is = is+ioff; ie = ie+ioff
2265  need_adjust_2 = .false.
2266  if(x_cyclic_offset .NE. 0) then
2267  call apply_cyclic_offset(js, je, x_cyclic_offset, jsgd, jeg, nj)
2268  else if(y_cyclic_offset .NE. 0) then
2269  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, iegd, ni)
2270  end if
2271  end if
2272  else
2273  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2274  need_adjust_3 = .false.
2275  end if
2276  end if
2277  end if
2278  if( need_adjust_3 .AND. ied.GT.ieg )then
2279  if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2280  is = is+ioff; ie = ie+ioff
2281  if( need_adjust_1 .AND. jsd.GE.jsg )then
2282  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2283  end if
2284  end if
2285  end if
2286  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2287  isg, ieg, jsg, jeg, dir)
2288  endif
2289 
2290  !recv_s
2291  dir = 3
2292  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
2293  jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2294  is=isc; ie=iec; js=jsc; je=jec
2295  js2 = 0; je2 = -1
2296  if( jed .LT. jsg) then ! jsd < jsg
2297  if( domain%y(tme)%cyclic ) then
2298  js = js-joff; je = je-joff
2299  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2300  endif
2301  else if( jsd.LT.jsg )then ! split into two parts
2302  if( domain%y(tme)%cyclic)then !try cyclic offset
2303  js2 = js-joff; je2 = je-joff
2304  end if
2305  end if
2306  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2307  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2308  if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2309  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2310 
2311  !recv_sw
2312  dir = 4
2313  isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2314  jsd = domain%y(tme)%compute%begin-shalo; jed = domain%y(tme)%compute%begin-1
2315  is=isc; ie=iec; js=jsc; je=jec
2316  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2317  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2318  if( ied.LT.isg )then ! isd < isg
2319  if( domain%x(tme)%cyclic ) then
2320  is = is-ioff; ie = ie-ioff
2321  endif
2322  else if (isd.LT.isg )then ! split into two parts
2323  if( domain%x(tme)%cyclic ) then
2324  is2 = is-ioff; ie2 = ie-ioff
2325  endif
2326  endif
2327  if( jed.LT.jsg )then ! jsd < jsg
2328  if( domain%y(tme)%cyclic ) then
2329  js = js-joff; je = je-joff
2330  endif
2331  else if( jsd.LT.jsg )then ! split into two parts
2332  if( domain%y(tme)%cyclic ) then
2333  js2 = js-joff; je2 = je-joff
2334  endif
2335  endif
2336  else
2337  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2338  if( jsd.LT.jsg )then
2339  if( domain%y(tme)%cyclic .AND. js.GT.jed )then !try cyclic offset
2340  js = js-joff; je = je-joff
2341  need_adjust_1 = .false.
2342  if( isd.LT.isg )then
2343  if( domain%x(tme)%cyclic .AND. is.GT.ied )then !try cyclic offset
2344  is = is-ioff; ie = ie-ioff
2345  need_adjust_2 = .false.
2346  if(x_cyclic_offset .NE. 0) then
2347  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsgd, jeg, nj)
2348  else if(y_cyclic_offset .NE. 0) then
2349  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isgd, ieg, ni)
2350  end if
2351  end if
2352  else
2353  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2354  need_adjust_3 = .false.
2355  end if
2356  end if
2357  end if
2358  if( need_adjust_3 .AND. isd.LT.isg )then
2359  if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. is.GT.ied )then !try cyclic offset
2360  is = is-ioff; ie = ie-ioff
2361  if(need_adjust_1 .AND. jsd.GE.jsg) then
2362  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2363  end if
2364  end if
2365  end if
2366  endif
2367  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2368  isg, ieg, jsg, jeg, dir)
2369 
2370  if(ie2 .GE. is2)call fill_overlap(overlap, domain, m, is2, ie2, js, je, isd, ied, jsd, jed, &
2371  isg, ieg, jsg, jeg, dir)
2372  if(je2 .GE. js2)call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2373  isg, ieg, jsg, jeg, dir)
2374 
2375  if(ie2 .GE. is2 .AND. je2 .GE. js2)call fill_overlap(overlap, domain, m, is2, ie2, js2, je2, isd, ied, jsd, &
2376  & jed, isg, ieg, jsg, jeg, dir)
2377 
2378 
2379  !recv_w
2380  dir = 5
2381  isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2382  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
2383  is=isc; ie=iec; js=jsc; je=jec
2384 
2385  !--- when the north face is folded, some point at j=nj will be folded.
2386  !--- the position should be on CORNER or NORTH
2387  if( jed == jeg .AND. folded_north .AND. (position == corner .OR. position == north) ) then
2388  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2389  isg, ieg, dir, ishift, position, ioff, middle)
2390  else
2391  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2392  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2393  isg, ieg, dir, ioff, domain%x(tme)%cyclic, symmetry=domain%symmetry)
2394  else
2395  if( isd.LT.isg )then
2396  if( domain%x(tme)%cyclic .AND. is.GT.ied )then !try cyclic offset
2397  is = is-ioff; ie = ie-ioff
2398  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2399  end if
2400  end if
2401  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2402  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2403  endif
2404  endif
2405 
2406  !recv_nw
2407  dir = 6
2408  folded = .false.
2409  isd = domain%x(tme)%compute%begin-whalo; ied = domain%x(tme)%compute%begin-1
2410  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2411  is=isc; ie=iec; js=jsc; je=jec
2412  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2413  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2414  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2415  js2 = -1; je2 = 0
2416  if( jsd .GT. jeg ) then ! jed > jeg
2417  if( domain%y(tme)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2418  js = js+joff; je = je+joff
2419  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2420  else if( folded_north )then
2421  folded = .true.
2422  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2423  end if
2424  else if( jed.GT.jeg )then ! split into two parts
2425  if( domain%y(tme)%cyclic)then !try cyclic offset
2426  is2 = is; ie2 = ie; js2 = js; je2 = je
2427  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2428  js = js + joff; je = je + joff
2429  jsd = jeg+1
2430  else if( folded_north )then
2431  folded = .true.
2432  is2 = is; ie2 = ie; js2 = js; je2 = je
2433  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2434  jsd = jeg+1
2435  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2436  if(isd < isg .and. ied .GE. isg .and. domain%symmetry) then
2437  isd3 = isd; ied3 = isg-1
2438  jsd3 = jsd; jed3 = jed
2439  is3 = is-ioff; ie3=ie-ioff
2440  js3 = js; je3 = je
2441  isd = isg;
2442  endif
2443  end if
2444  endif
2445 
2446  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2447  .AND. (position == corner .OR. position == north)) then
2448  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2449  isg, ieg, dir, ishift, position, ioff, middle)
2450  else
2451  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2452  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2453  endif
2454 
2455  if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2456  & jed3, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2457 
2458  if(ie2 .GE. is2) then
2459  if( jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2460  .AND. (position == corner .OR. position == north)) then
2461  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2462  isg, ieg, dir, ishift, position, ioff, middle)
2463  else
2464  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2465  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2466  endif
2467  endif
2468  else
2469  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2470  if( jed.GT.jeg )then
2471  if( domain%y(tme)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2472  js = js+joff; je = je+joff
2473  need_adjust_1 = .false.
2474  if( isd.LT.isg )then
2475  if( domain%x(tme)%cyclic .AND. is.GE.ied )then !try cyclic offset
2476  is = is-ioff; ie = ie-ioff
2477  need_adjust_2 = .false.
2478  if(x_cyclic_offset .NE. 0) then
2479  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jegd, nj)
2480  else if(y_cyclic_offset .NE. 0) then
2481  call apply_cyclic_offset(is, ie, y_cyclic_offset, isgd, ieg, ni)
2482  end if
2483  end if
2484  else
2485  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2486  need_adjust_3 = .false.
2487  end if
2488  else if( folded_north )then
2489  folded = .true.
2490  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2491  end if
2492  end if
2493  if( need_adjust_3 .AND. isd.LT.isg )then
2494  if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. is.GE.ied )then !try cyclic offset
2495  is = is-ioff; ie = ie-ioff
2496  if( need_adjust_1 .AND. jed.LE.jeg )then
2497  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2498  end if
2499  end if
2500  end if
2501  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2502  isg, ieg, jsg, jeg, dir)
2503  endif
2504 
2505  !--- when north edge is folded, is will be less than isg when position is EAST and CORNER
2506  if(is .LT. isg .AND. domain%x(tme)%cyclic) then
2507  is = is + ioff
2508  call insert_update_overlap(overlap, domain%list(m)%pe, &
2509  is, is, js, je, isd, ied, jsd, jed, dir, folded )
2510  endif
2511 
2512  !recv_n
2513  dir = 7
2514  folded = .false.
2515  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
2516  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2517  is=isc; ie=iec; js=jsc; je=jec
2518 
2519  !--- when domain symmetry and position is EAST or CORNER, the point at i=isd will
2520  !--- come from two pe ( there will be only one point on one pe. ).
2521  if( domain%symmetry .AND. (position == east .OR. position == corner ) &
2522  .AND. (isd == ie .or. ied == is ) .AND. (.not. folded_north) ) then
2523  !--- do nothing, this point will come from other pe
2524  else
2525  js2 = -1; je2 = 0
2526  if( jsd .GT. jeg ) then ! jed > jeg
2527  if( domain%y(tme)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2528  js = js+joff; je = je+joff
2529  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2530  else if( folded_north )then
2531  folded = .true.
2532  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2533  end if
2534  else if( jed.GT.jeg )then ! split into two parts
2535  if( domain%y(tme)%cyclic)then !try cyclic offset
2536  is2 = is; ie2 = ie; js2 = js; je2 = je
2537  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2538  js = js + joff; je = je + joff
2539  jsd = jeg+1
2540  else if( folded_north )then
2541  folded = .true.
2542  is2 = is; ie2 = ie; js2 = js; je2 = je
2543  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2544  jsd = jeg+1
2545  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2546  end if
2547  end if
2548  if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0) then
2549  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2550  .AND. (position == corner .OR. position == north)) then
2551  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2552  isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2553  else
2554  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2555  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, symmetry=domain%symmetry)
2556  endif
2557  else
2558  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2559  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2560  endif
2561  if(ie2 .GE. is2) then
2562  if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2563  .AND. (position == corner .OR. position == north)) then
2564  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2565  isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2566  else
2567  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2568  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded, symmetry=domain%symmetry)
2569  endif
2570  endif
2571  endif
2572 
2573  !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
2574  if(is .LT. isg .AND. domain%x(tme)%cyclic) then
2575 ! is = is + ioff
2576 ! call insert_update_overlap( overlap, domain%list(m)%pe, &
2577 ! is, is, js, je, isd, ied, jsd, jed, dir, folded)
2578  endif
2579 
2580  !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
2581  !--- for folded-north-edge, only need to consider to_pe's north(7) direction
2582  !--- only position at NORTH and CORNER need to be considered
2583 
2584  if( folded_north .AND. (position == north .OR. position == corner) &
2585  .AND. domain%x(tme)%pos .GE. size(domain%x(tme)%list(:))/2) then
2586  if( jed .GE. jeg .AND. ied .GE. middle)then
2587  jsd = jeg; jed = jeg
2588  is=isc; ie=iec; js = jsc; je = jec
2589  isd = max(isd, middle)
2590  select case (position)
2591  case(north)
2592  i=is; is = isg+ieg-ie; ie = isg+ieg-i
2593  case(corner)
2594  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2595  end select
2596  call insert_update_overlap(overlap, domain%list(m)%pe, &
2597  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
2598  endif
2599  if(debug_update_level .NE. no_check .AND. set_check) then
2600  jsd = domain%y(tme)%compute%end+jshift; jed = jsd
2601  if(jed == jeg) then
2602  is = max(is, isd); ie = min(ie, ied)
2603  js = max(js, jsd); je = min(je, jed)
2604  if(ie.GE.is .AND. je.GE.js )then
2605  nrecv_check = nrecv_check+1
2606  if(nrecv_check > size(checklist(:)) ) then
2607  call expand_check_overlap_list(checklist, nlist)
2608  endif
2609  call allocate_check_overlap(checklist(nrecv_check), 1)
2610  call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
2611  tme, 4, one_hundred_eighty, is, ie, js, je)
2612  end if
2613  end if
2614  endif
2615 
2616  endif
2617 
2618  !recv_ne
2619  dir = 8
2620  folded = .false.
2621  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%compute%end+ehalo+ishift
2622  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%compute%end+nhalo+jshift
2623  is=isc; ie=iec; js=jsc; je=jec
2624  is2 = 0; ie2=-1; js2=0; je2=-1
2625  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2626  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2627  js2 = -1; je2 = 0
2628  if( jsd .GT. jeg ) then ! jed > jeg
2629  if( domain%y(tme)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2630  js = js+joff; je = je+joff
2631  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2632  else if( folded_north )then
2633  folded = .true.
2634  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2635  end if
2636  else if( jed.GT.jeg )then ! split into two parts
2637  if( domain%y(tme)%cyclic)then !try cyclic offset
2638  is2 = is; ie2 = ie; js2 = js; je2 = je
2639  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2640  js = js + joff; je = je + joff
2641  jsd = jeg+1
2642  else if( folded_north )then
2643  folded = .true.
2644  is2 = is; ie2 = ie; js2 = js; je2 = je
2645  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2646  jsd = jeg+1
2647  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2648  if(ied > ieg .and. isd .LE. ieg .and. domain%symmetry) then
2649  isd3 = ieg+1; ied3 = ied
2650  jsd3 = jsd; jed3 = jed
2651  is3 = is+ioff; ie3=ie+ioff
2652  js3 = js; je3 = je
2653  ied = ieg;
2654  endif
2655  end if
2656  endif
2657  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2658  .AND. (position == corner .OR. position == north)) then
2659  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2660  isg, ieg, dir, ishift, position, ioff, middle)
2661  else
2662  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2663  isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2664  endif
2665  if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, &
2666  & jed3, isg, ieg, dir, ioff, domain%x(tme)%cyclic, folded)
2667  if(ie2 .GE. is2) then
2668  if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2669  .AND. (position == corner .OR. position == north)) then
2670  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2671  isg, ieg, dir, ishift, position, ioff, middle)
2672  else
2673  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2674  isg, ieg, dir, ioff, domain%x(tme)%cyclic)
2675  endif
2676  endif
2677  else
2678  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2679  if( jed.GT.jeg )then
2680  if( domain%y(tme)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2681  js = js+joff; je = je+joff
2682  need_adjust_1 = .false.
2683  if( ied.GT.ieg )then
2684  if( domain%x(tme)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2685  is = is+ioff; ie = ie+ioff
2686  need_adjust_2 = .false.
2687  if(x_cyclic_offset .NE. 0) then
2688  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jegd, nj)
2689  else if(y_cyclic_offset .NE. 0) then
2690  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, iegd, ni)
2691  end if
2692  end if
2693  else
2694  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2695  need_adjust_3 = .false.
2696  end if
2697  else if( folded_north )then
2698  folded = .true.
2699  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2700  end if
2701  end if
2702  if( need_adjust_3 .AND. ied.GT.ieg )then
2703  if( need_adjust_2 .AND. domain%x(tme)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2704  is = is+ioff; ie = ie+ioff
2705  if( need_adjust_1 .AND. jed.LE.jeg)then
2706  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2707  end if
2708  end if
2709  end if
2710  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2711  isg, ieg, jsg, jeg, dir)
2712  endif
2713  endif
2714 
2715  !--- copy the overlapping information
2716  if( overlap%count > 0) then
2717  nrecv = nrecv + 1
2718  if(nrecv > size(overlaplist(:)) )then
2719  call mpp_error(note, 'mpp_domains_define.inc(compute_overlaps): overlapList for recv is expanded')
2720  call expand_update_overlap_list(overlaplist, nlist)
2721  endif
2722  call add_update_overlap( overlaplist(nrecv), overlap)
2723  call init_overlap_type(overlap)
2724  endif
2725  enddo ! end of recv do loop
2726 
2727  if(debug_message_passing) then
2728  !--- write out send information
2729  iunit = mpp_pe() + 1000
2730  do m =1,nrecv
2731  write(iunit, *) "********from_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
2732  do n = 1, overlaplist(m)%count
2733  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
2734  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
2735  enddo
2736  enddo
2737  if(nrecv >0) flush(iunit)
2738  endif
2739 
2740  ! copy the overlapping information into domain
2741  if(nrecv>0) then
2742  if (associated(update%recv)) deallocate(update%recv) !< Check if associated
2743  allocate(update%recv(nrecv))
2744  update%nrecv = nrecv
2745  do m = 1, nrecv
2746  call add_update_overlap( update%recv(m), overlaplist(m) )
2747  do n = 1, update%recv(m)%count
2748  if(update%recv(m)%tileNbr(n) == domain%tile_id(tme)) then
2749  if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
2750  if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
2751  endif
2752  enddo
2753  enddo
2754  endif
2755 
2756  if(nrecv_check>0) then
2757  check%nrecv = nrecv_check
2758  if (associated(check%recv)) deallocate(check%recv) !< Check if associated
2759  allocate(check%recv(nrecv_check))
2760  do m = 1, nrecv_check
2761  call add_check_overlap( check%recv(m), checklist(m) )
2762  enddo
2763  endif
2764 
2765  call deallocate_overlap_type(overlap)
2766  do m = 1,size(overlaplist(:))
2767  call deallocate_overlap_type(overlaplist(m))
2768  enddo
2769 
2770  if(debug_update_level .NE. no_check .AND. set_check) then
2771  do m = 1,size(checklist(:))
2772  call deallocate_overlap_type(checklist(m))
2773  enddo
2774  endif
2775 
2776  deallocate(overlaplist)
2777  if(set_check) deallocate(checklist)
2778  domain%initialized = .true.
2779 
2780  end subroutine compute_overlaps
2781 
2782 
2783  subroutine fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2784  isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2785  type(overlap_type), intent(inout) :: overlap
2786  type(domain2d), intent(inout) :: domain
2787  integer, intent(in ) :: m, is, ie, js, je
2788  integer, intent(in ) :: isc, iec, jsc, jec
2789  integer, intent(in ) :: isg, ieg, dir, ioff
2790  logical, intent(in ) :: is_cyclic
2791  logical, optional, intent(in ) :: folded, symmetry
2792 
2793  call insert_update_overlap( overlap, domain%list(m)%pe, &
2794  is, ie, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2795  if(is_cyclic) then
2796  if(ie .GT. ieg) then
2797  call insert_update_overlap( overlap, domain%list(m)%pe, &
2798  is-ioff, ie-ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2799  else if( is .LT. isg ) then
2800  call insert_update_overlap( overlap, domain%list(m)%pe, &
2801  is+ioff, ie+ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2802  endif
2803  endif
2804 
2805  end subroutine fill_overlap_send_nofold
2806  !##################################################################################
2807  subroutine fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2808  isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2809  type(overlap_type), intent(inout) :: overlap
2810  type(domain2d), intent(inout) :: domain
2811  integer, intent(in ) :: m, is, ie, js, je
2812  integer, intent(in ) :: isc, iec, jsc, jec
2813  integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2814  logical, optional, intent(in ) :: symmetry
2815  integer :: is1, ie1, is2, ie2, i
2816 
2817  !--- consider at j = jeg for west edge.
2818  !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2819  if(position == corner .AND. .NOT. domain%symmetry .AND. is .LE. isg-1 .AND. ie .GE. isg-1) then
2820  call insert_update_overlap(overlap, domain%list(m)%pe, &
2821  isg-1+ioff, isg-1+ioff, je, je, isc, iec, jsc, jec, dir, .true.)
2822  end if
2823 
2824  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2825  !--- east edge
2826  if( is > ieg ) then
2827  is2 = is-ioff; ie2 = ie-ioff
2828  else if( ie > ieg ) then ! split into two parts
2829  is1 = is; ie1 = ieg
2830  is2 = ieg+1-ioff; ie2 = ie-ioff
2831  else if( is .GE. middle ) then
2832  is1 = is; ie1 = ie
2833  else if( ie .GE. middle ) then ! split into two parts
2834  is1 = middle; ie1 = ie
2835  is2 = is; ie2 = middle-1
2836  else if( ie < isg ) then ! west boundary
2837  is1 = is+ieg-isg+1-ishift; ie1 = ie+ieg-isg+1-ishift
2838  else if( is < isg ) then ! split into two parts
2839  is1 = is+ieg-isg+1-ishift; ie1 = isg-1+ieg-isg+1-ishift
2840  is2 = isg; ie2 = ie
2841  else
2842  is2 = is; ie2 = ie
2843  endif
2844 
2845  if( ie1 .GE. is1) then
2846  call insert_update_overlap( overlap, domain%list(m)%pe, &
2847  is1, ie1, js, je-1, isc, iec, jsc, jec, dir, symmetry=symmetry)
2848 
2849  select case (position)
2850  case(north)
2851  i=is1; is1 = isg+ieg-ie1; ie1 = isg+ieg-i
2852  case(corner)
2853  i=is1; is1 = isg+ieg-ie1-1+ishift; ie1 = isg+ieg-i-1+ishift
2854  end select
2855  call insert_update_overlap( overlap, domain%list(m)%pe, &
2856  is1, ie1, je, je, isc, iec, jsc, jec, dir, .true., symmetry=symmetry)
2857  endif
2858 
2859  if(ie2 .GE. is2) then
2860  call insert_update_overlap( overlap, domain%list(m)%pe, &
2861  is2, ie2, js, je, isc, iec, jsc, jec, dir)
2862  endif
2863 
2864  end subroutine fill_overlap_send_fold
2865 
2866 
2867  !#############################################################################
2868  subroutine fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2869  isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2870  type(overlap_type), intent(inout) :: overlap
2871  type(domain2d), intent(inout) :: domain
2872  integer, intent(in ) :: m, is, ie, js, je
2873  integer, intent(in ) :: isd, ied, jsd, jed
2874  integer, intent(in ) :: isg, ieg, dir, ioff
2875  logical, intent(in ) :: is_cyclic
2876  logical, optional, intent(in ) :: folded, symmetry
2877  integer :: is1, ie1, is2, ie2
2878  integer :: isd1, ied1, isd2, ied2
2879 
2880  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2881  isd1=isd; ied1=ied
2882  isd2=isd; ied2=ied
2883 
2884  call insert_update_overlap( overlap, domain%list(m)%pe, &
2885  is, ie, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2886  if(is_cyclic) then
2887  if(ied .GT. ieg) then
2888  call insert_update_overlap( overlap, domain%list(m)%pe, &
2889  is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2890  else if( isd .LT. isg ) then
2891  call insert_update_overlap( overlap, domain%list(m)%pe, &
2892  is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2893  else if ( is .LT. isg ) then
2894  call insert_update_overlap( overlap, domain%list(m)%pe, &
2895  is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2896  else if ( ie .GT. ieg ) then
2897  call insert_update_overlap( overlap, domain%list(m)%pe, &
2898  is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2899  endif
2900  endif
2901 
2902  end subroutine fill_overlap_recv_nofold
2903  !#################################################################################
2904  subroutine fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2905  isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2906  type(overlap_type), intent(inout) :: overlap
2907  type(domain2d), intent(inout) :: domain
2908  integer, intent(in ) :: m, is, ie, js, je
2909  integer, intent(in ) :: isd, ied, jsd, jed
2910  integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2911  logical, optional, intent(in ) :: symmetry
2912  integer :: is1, ie1, is2, ie2, is3, ie3
2913  integer :: isd1, ied1, isd2, ied2
2914 
2915  !--- consider at j = jeg for west edge.
2916  !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2917  if( position == corner .AND. .NOT. domain%symmetry .AND. isd .LE. isg-1 .AND. ied .GE. isg-1 ) then
2918  call insert_update_overlap( overlap, domain%list(m)%pe, &
2919  is-ioff, ie-ioff, js, je, isg-1, isg-1, jed, jed, dir, .true.)
2920  end if
2921 
2922  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2923  isd1=isd; ied1=ied
2924  isd2=isd; ied2=ied
2925  select case (position)
2926  case(north)
2927  is3 = isg+ieg-ie; ie3 = isg+ieg-is
2928  case(corner)
2929  is3 = isg+ieg-ie-1+ishift; ie3 = isg+ieg-is-1+ishift
2930  end select
2931 
2932  if(isd .GT. ieg) then ! east
2933  is2 = is + ioff; ie2 = ie + ioff;
2934  else if(ied .GT. ieg) then ! split into two parts
2935  is1 = is; ie1 = ie;
2936  isd1 = isd; ied1 = ieg;
2937  is2 = is + ioff; ie2 = ie + ioff
2938  isd2 = ieg + 1; ied2 = ied
2939  else if(isd .GE. middle) then
2940  is1 = is; ie1 = ie
2941  else if(ied .GE. middle) then ! split into two parts
2942  is1 = is; ie1 = ie
2943  isd1 = middle; ied1 = ied
2944  is2 = is; ie2 = ie
2945  isd2 = isd; ied2 = middle-1
2946  else if(ied .LT. isg) then
2947  is1 = is - ioff; ie1 = ie - ioff;
2948  is3 = is3 - ioff; ie3 = ie3 - ioff;
2949  else if(isd .LT. isg) then ! split into two parts
2950  is1 = is - ioff; ie1 = ie - ioff;
2951  is3 = is3 - ioff; ie3 = ie3 - ioff;
2952  isd1 = isd; ied1 = isg-1
2953  is2 = is; ie2 = ie
2954  isd2 = isg; ied2 = ied
2955  else
2956  is2 = is ; ie2 =ie
2957  isd2 = isd; ied2 = ied
2958  endif
2959 
2960  if( ie1 .GE. is1) then
2961  call insert_update_overlap( overlap, domain%list(m)%pe, &
2962  is1, ie1, js, je, isd1, ied1, jsd, jed-1, dir, symmetry=symmetry)
2963 
2964  call insert_update_overlap( overlap, domain%list(m)%pe, &
2965  is3, ie3, js, je, isd1, ied1, jed, jed, dir, .true., symmetry=symmetry)
2966  endif
2967 
2968  if(ie2 .GE. is2) then
2969  call insert_update_overlap( overlap, domain%list(m)%pe, &
2970  is2, ie2, js, je, isd2, ied2, jsd, jed, dir)
2971  endif
2972 
2973  end subroutine fill_overlap_recv_fold
2974 
2975 !#####################################################################################
2976  subroutine fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2977  isg, ieg, jsg, jeg, dir, reverse, symmetry)
2978  type(overlap_type), intent(inout) :: overlap
2979  type(domain2d), intent(inout) :: domain
2980  integer, intent(in ) :: m, is, ie, js, je
2981  integer, intent(in ) :: isc, iec, jsc, jec
2982  integer, intent(in ) :: isg, ieg, jsg, jeg
2983  integer, intent(in ) :: dir
2984  logical, optional, intent(in ) :: reverse, symmetry
2985 
2986  if(js > je) then ! separate into two regions due to x_cyclic_offset is nonzero, the two region are
2987  ! (js, jeg) and (jsg, je).
2988  call insert_update_overlap( overlap, domain%list(m)%pe, &
2989  is, ie, jsg, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2990  call insert_update_overlap( overlap, domain%list(m)%pe, &
2991  is, ie, js, jeg, isc, iec, jsc, jec, dir, reverse, symmetry)
2992  else if(is > ie) then ! separate into two regions due to y_cyclic_offset is nonzero, the two region are
2993  ! (is, ieg) and (isg, ie).
2994  call insert_update_overlap( overlap, domain%list(m)%pe, &
2995  is, ieg, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2996  call insert_update_overlap( overlap, domain%list(m)%pe, &
2997  isg, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2998  else
2999  call insert_update_overlap( overlap, domain%list(m)%pe, &
3000  is, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
3001  end if
3002 
3003 
3004  end subroutine fill_overlap
3005 
3006  !####################################################################################
3007  !> Computes remote domain overlaps
3008  !! assumes only one in each direction
3009  !! will calculate the overlapping for T,E,C,N-cell separately.
3010  subroutine compute_overlaps_fold_south( domain, position, ishift, jshift)
3011  type(domain2d), intent(inout) :: domain
3012  integer, intent(in) :: position, ishift, jshift
3013 
3014  integer :: i, m, n, nlist, tMe, tNbr, dir
3015  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3016  integer :: isg, ieg, jsg, jeg, ioff, joff
3017  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3018  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3019  logical :: folded
3020  type(overlap_type) :: overlap
3021  type(overlapspec), pointer :: update=>null()
3022  type(overlap_type), pointer :: overlapList(:)=>null()
3023  type(overlap_type), pointer :: checkList(:)=>null()
3024  type(overlapspec), pointer :: check =>null()
3025  integer :: nsend, nrecv
3026  integer :: nsend_check, nrecv_check
3027  integer :: iunit
3028 
3029  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
3030  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
3031  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
3032  if(size(domain%x(:)) > 1) return
3033 
3034  !--- if there is no halo, no need to compute overlaps.
3035  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3036 
3037  !--- when there is only one tile, n will equal to np
3038  nlist = size(domain%list(:))
3039 
3040  select case(position)
3041  case (center)
3042  update => domain%update_T
3043  check => null()
3044  case (corner)
3045  update => domain%update_C
3046  check => domain%check_C
3047  case (east)
3048  update => domain%update_E
3049  check => domain%check_E
3050  case (north)
3051  update => domain%update_N
3052  check => domain%check_N
3053  case default
3054  call mpp_error(fatal, &
3055  "mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, &
3056  & CORNER or NORTH")
3057  end select
3058 
3059  allocate(overlaplist(maxlist) )
3060  allocate(checklist(maxlist) )
3061 
3062  !--- overlap is used to store the overlapping temporarily.
3063  call allocate_update_overlap( overlap, maxoverlap)
3064 
3065  !send
3066  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3067  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
3068  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3069  update%xbegin = ism; update%xend = iem
3070  update%ybegin = jsm; update%yend = jem
3071  if(ASSOCIATED(check)) then
3072  check%xbegin = ism; check%xend = iem
3073  check%ybegin = jsm; check%yend = jem
3074  endif
3075  update%whalo = domain%whalo; update%ehalo = domain%ehalo
3076  update%shalo = domain%shalo; update%nhalo = domain%nhalo
3077  whalo = domain%whalo; ehalo = domain%ehalo
3078  shalo = domain%shalo; nhalo = domain%nhalo
3079 
3080 
3081  ioff = ni - ishift
3082  joff = nj - jshift
3083  middle = (isg+ieg)/2+1
3084  tme = 1; tnbr = 1
3085 
3086  if(.NOT. btest(domain%fold,south)) then
3087  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3088  "boundary condition in y-direction should be folded-south for "//trim(domain%name))
3089  endif
3090  if(.NOT. domain%x(tme)%cyclic) then
3091  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3092  "boundary condition in x-direction should be cyclic for "//trim(domain%name))
3093  endif
3094 
3095  if(.not. domain%symmetry) then
3096  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3097  "when south boundary is folded, the domain must be symmetry for "//trim(domain%name))
3098  endif
3099 
3100  nsend = 0
3101  nsend_check = 0
3102  do list = 0,nlist-1
3103  m = mod( domain%pos+list, nlist )
3104  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
3105  !to_pe's eastern halo
3106  dir = 1
3107  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3108  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3109  !--- to make sure the consistence between pes
3110  if( (position == north .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) ) then
3111  !--- do nothing, this point will come from other pe
3112  else
3113  if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3114  is = is-ioff; ie = ie-ioff
3115  end if
3116  !--- when the south face is folded, the east halo point at right side domain will be folded.
3117  !--- the position should be on CORNER or NORTH
3118  if( js == jsg .AND. (position == corner .OR. position == north) &
3119  .AND. is .GE. middle .AND. domain%list(m)%x(tnbr)%compute%end+ehalo+jshift .LE. ieg ) then
3120  call insert_update_overlap( overlap, domain%list(m)%pe, &
3121  is, ie, js+1, je, isc, iec, jsc, jec, dir)
3122  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3123  je = js
3124  select case (position)
3125  case(north)
3126  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3127  case(corner)
3128  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3129  end select
3130  call insert_update_overlap( overlap, domain%list(m)%pe, &
3131  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3132  else
3133  call insert_update_overlap( overlap, domain%list(m)%pe, &
3134  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3135  end if
3136  end if
3137 
3138  !to_pe's SE halo
3139  dir = 2
3140  folded = .false.
3141  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3142  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3143  if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3144  is = is-ioff; ie = ie-ioff
3145  end if
3146  if( js.LT.jsg )then
3147  folded = .true.
3148  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3149  end if
3150 
3151  call insert_update_overlap( overlap, domain%list(m)%pe, &
3152  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3153 
3154  !to_pe's southern halo
3155  dir = 3
3156  folded = .false.
3157  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3158  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3159  folded = .false.
3160  if( js.LT.jsg )then
3161  folded = .true.
3162  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3163  end if
3164  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3165  !--- no need to send, because the data on that point will come from other pe.
3166  !--- come from two pe ( there will be only one point on one pe. ).
3167  if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) ) then
3168  !--- do nothing, this point will come from other pe
3169  else
3170  call insert_update_overlap( overlap, domain%list(m)%pe, &
3171  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3172  endif
3173  !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3174  if(is .LT. isg) then
3175  is = is + ioff
3176  call insert_update_overlap( overlap, domain%list(m)%pe, &
3177  is, is, js, je, isc, iec, jsc, jec, dir, folded)
3178  endif
3179 
3180  !to_pe's SW halo
3181  dir = 4
3182  folded = .false.
3183  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3184  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3185  if( isg.GT.is .AND. ie.LT.isc )then !cyclic offset
3186  is = is+ioff; ie = ie+ioff
3187  end if
3188  if( js.LT.jsg )then
3189  folded = .true.
3190  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3191  end if
3192  call insert_update_overlap( overlap, domain%list(m)%pe, &
3193  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3194  !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3195  if(is .LT. isg) then
3196  is = is + ioff
3197  call insert_update_overlap( overlap, domain%list(m)%pe, &
3198  is, is, js, je, isc, iec, jsc, jec, dir, folded)
3199  endif
3200 
3201  !to_pe's western halo
3202  dir = 5
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 = domain%list(m)%y(tnbr)%compute%end+jshift
3205 
3206  !--- to make sure the consistence between pes
3207  if( (position == north .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) ) then
3208  !--- do nothing, this point will come from other pe
3209  else
3210  if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
3211  is = is+ioff; ie = ie+ioff
3212  end if
3213  !--- when the south face is folded, some point at j=nj will be folded.
3214  !--- the position should be on CORNER or NORTH
3215  if( js == jsg .AND. (position == corner .OR. position == north) &
3216  .AND. ( domain%list(m)%x(tnbr)%compute%begin == isg .OR. &
3217  & domain%list(m)%x(tnbr)%compute%begin-1 .GE. middle)) then
3218  call insert_update_overlap( overlap, domain%list(m)%pe, &
3219  is, ie, js+1, je, isc, iec, jsc, jec, dir)
3220  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3221  js = domain%list(m)%y(tnbr)%compute%begin; je = js
3222  if ( domain%list(m)%x(tnbr)%compute%begin == isg ) then
3223  select case (position)
3224  case(north)
3225  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3226  case(corner)
3227  i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3228  end select
3229  if(ie .GT. domain%x(tme)%compute%end+ishift) call mpp_error( fatal, &
3230  'mpp_domains_define.inc(compute_overlaps_fold_south): west edge ubound error send.' )
3231  else
3232  select case (position)
3233  case(north)
3234  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3235  case(corner)
3236  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3237  end select
3238  end if
3239  call insert_update_overlap( overlap, domain%list(m)%pe, &
3240  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3241  else
3242  call insert_update_overlap( overlap, domain%list(m)%pe, &
3243  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3244  end if
3245  endif
3246 
3247  !to_pe's NW halo
3248  dir = 6
3249  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3250  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3251  if( isg.GT.is .AND. ie.LT.isc )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  !to_pe's northern halo
3258  dir = 7
3259  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3260  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3261  call insert_update_overlap( overlap, domain%list(m)%pe, &
3262  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3263 
3264  !to_pe's NE halo
3265  dir = 8
3266  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3267  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3268  if( ie.GT.ieg .AND. iec.LT.is )then !cyclic offset
3269  is = is-ioff; ie = ie-ioff
3270  end if
3271  call insert_update_overlap( overlap, domain%list(m)%pe, &
3272  is, ie, js, je, isc, iec, jsc, jec, dir)
3273 
3274  !--- Now calculate the overlapping for fold-edge.
3275  !--- only position at NORTH and CORNER need to be considered
3276  if( ( position == north .OR. position == corner) ) then
3277  !fold is within domain
3278  if( domain%y(tme)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tme)%domain_data%end+jshift )then
3279  dir = 3
3280  !--- calculate the overlapping for sending
3281  if( domain%x(tme)%pos .LT. (size(domain%x(tme)%list(:))+1)/2 )then
3282  js = domain%list(m)%y(tnbr)%compute%begin; je = js
3283  if( js == jsg )then ! fold is within domain.
3284  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3285  select case (position)
3286  case(north)
3287  is = max(is, middle)
3288  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3289  case(corner)
3290  is = max(is, middle)
3291  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3292  end select
3293  call insert_update_overlap(overlap, domain%list(m)%pe, &
3294  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3295  is = max(is, isc); ie = min(ie, iec)
3296  js = max(js, jsc); je = min(je, jec)
3297  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
3298  nsend_check = nsend_check+1
3299  call allocate_check_overlap(checklist(nsend_check), 1)
3300  call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
3301  tme, 2, one_hundred_eighty, is, ie, js, je)
3302  end if
3303  end if
3304  end if
3305  end if
3306  end if
3307  end if
3308  !--- copy the overlapping information
3309  if( overlap%count > 0) then
3310  nsend = nsend + 1
3311  if(nsend > size(overlaplist(:)) ) then
3312  call mpp_error(note, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for send is expanded')
3313  call expand_update_overlap_list(overlaplist, nlist)
3314  endif
3315  call add_update_overlap(overlaplist(nsend), overlap)
3316  call init_overlap_type(overlap)
3317  endif
3318  end do ! end of send set up.
3319 
3320  if(debug_message_passing) then
3321  !--- write out send information
3322  iunit = mpp_pe() + 1000
3323  do m =1,nsend
3324  write(iunit, *) "********to_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
3325  do n = 1, overlaplist(m)%count
3326  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3327  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3328  enddo
3329  enddo
3330  if( nsend > 0) flush(iunit)
3331  endif
3332 
3333  ! copy the overlapping information into domain data structure
3334  if(nsend>0) then
3335  if (associated(update%send)) deallocate(update%send) !< Check if associated
3336  allocate(update%send(nsend))
3337  update%nsend = nsend
3338  do m = 1, nsend
3339  call add_update_overlap( update%send(m), overlaplist(m) )
3340  enddo
3341  endif
3342 
3343  if(nsend_check>0) then
3344  if (associated(check%send)) deallocate(check%send) !< Check if associated
3345  allocate(check%send(nsend_check))
3346  check%nsend = nsend_check
3347  do m = 1, nsend_check
3348  call add_check_overlap( check%send(m), checklist(m) )
3349  enddo
3350  endif
3351 
3352  do m = 1,size(overlaplist(:))
3353  call deallocate_overlap_type(overlaplist(m))
3354  enddo
3355 
3356  if(debug_update_level .NE. no_check) then
3357  do m = 1,size(checklist(:))
3358  call deallocate_overlap_type(checklist(m))
3359  enddo
3360  endif
3361 
3362  isgd = isg - domain%whalo
3363  iegd = ieg + domain%ehalo
3364  jsgd = jsg - domain%shalo
3365  jegd = jeg + domain%nhalo
3366 
3367  ! begin setting up recv
3368  nrecv = 0
3369  nrecv_check = 0
3370  do list = 0,nlist-1
3371  m = mod( domain%pos+nlist-list, nlist )
3372  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
3373  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3374  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3375  !recv_e
3376  dir = 1
3377  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3378  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
3379  is=isc; ie=iec; js=jsc; je=jec
3380  if( (position == north .OR. position == corner ) .AND. ( jsd == je .or. jed == js ) ) then
3381  ! --- do nothing, this point will come from other pe
3382  else
3383  if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3384  is = is+ioff; ie = ie+ioff
3385  end if
3386 
3387  !--- when the south face is folded, the east halo point at right side domain will be folded.
3388  !--- the position should be on CORNER or NORTH
3389  if( jsd == jsg .AND. (position == corner .OR. position == north) &
3390  .AND. isd .GE. middle .AND. ied .LE. ieg ) then
3391  call insert_update_overlap( overlap, domain%list(m)%pe, &
3392  is, ie, js, je, isd, ied, jsd+1, jed, dir)
3393  is=isc; ie=iec; js=jsc; je=jec
3394  jed = jsd
3395  select case (position)
3396  case(north)
3397  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3398  case(corner)
3399  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3400  end select
3401  call insert_update_overlap( overlap, domain%list(m)%pe, &
3402  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
3403  else
3404  call insert_update_overlap( overlap, domain%list(m)%pe, &
3405  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3406  end if
3407  end if
3408 
3409  !recv_se
3410  dir = 2
3411  folded = .false.
3412  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3413  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3414  is=isc; ie=iec; js=jsc; je=jec
3415  if( jsd.LT.jsg )then
3416  folded = .true.
3417  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3418  end if
3419  if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3420  is = is+ioff; ie = ie+ioff
3421  endif
3422  call insert_update_overlap(overlap, domain%list(m)%pe, &
3423  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3424 
3425  !recv_s
3426  dir = 3
3427  folded = .false.
3428  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3429  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3430  is=isc; ie=iec; js=jsc; je=jec
3431  if( jsd.LT.jsg )then
3432  folded = .true.
3433  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3434  end if
3435  if( (position == east .OR. position == corner ) .AND. (isd == ie .or. ied == is ) ) then
3436  !--- do nothing, this point will come from other pe
3437  else
3438  call insert_update_overlap(overlap, domain%list(m)%pe, &
3439  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
3440  end if
3441  !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3442  if(is .LT. isg ) then
3443  is = is + ioff
3444  call insert_update_overlap(overlap, domain%list(m)%pe, &
3445  is, is, js, je, isd, ied, jsd, jed, dir, folded)
3446  endif
3447 
3448  !recv_sw
3449  dir = 4
3450  folded = .false.
3451  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3452  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
3453  is=isc; ie=iec; js=jsc; je=jec
3454  if( jsd.LT.jsg )then
3455  folded = .true.
3456  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3457  end if
3458  if( isd.LT.isg .AND. is.GT.ied ) then ! cyclic offset
3459  is = is-ioff; ie = ie-ioff
3460  end if
3461  call insert_update_overlap(overlap, domain%list(m)%pe, &
3462  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3463  !--- when southth edge is folded, is will be less than isg when position is EAST and CORNER
3464  if(is .LT. isg ) then
3465  is = is + ioff
3466  call insert_update_overlap(overlap, domain%list(m)%pe, &
3467  is, is, js, je, isd, ied, jsd, jed, dir, folded )
3468  endif
3469 
3470  !recv_w
3471  dir = 5
3472  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3473  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
3474  is=isc; ie=iec; js=jsc; je=jec
3475  if( (position == north .OR. position == corner ) .AND. ( jsd == je .or. jed == js ) ) then
3476  ! --- do nothing, this point will come from other pe
3477  else
3478  if( isd.LT.isg .AND. is.GT.ied )then ! cyclic offset
3479  is = is-ioff; ie = ie-ioff
3480  end if
3481  !--- when the south face is folded, some point at j=nj will be folded.
3482  !--- the position should be on CORNER or NORTH
3483  if( jsd == jsg .AND. (position == corner .OR. position == north) &
3484  .AND. ( isd < isg .OR. ied .GE. middle ) ) then
3485  call insert_update_overlap(overlap, domain%list(m)%pe, &
3486  is, ie, js, je, isd, ied, jsd+1, jed, dir)
3487  is=isc; ie=iec; js=jsc; je=jec
3488  if(isd < isg) then
3489  select case (position)
3490  case(north)
3491  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3492  case(corner)
3493  ied = ied -1 + ishift
3494  i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3495  end select
3496  if(ie .GT. domain%x(tme)%compute%end+ishift) call mpp_error( fatal, &
3497  'mpp_domains_define.inc(compute_overlaps): west edge ubound error recv.' )
3498  else
3499  select case (position)
3500  case(north)
3501  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3502  case(corner)
3503  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3504  end select
3505  end if
3506  call insert_update_overlap(overlap, domain%list(m)%pe, &
3507  is, ie, js, je, isd, ied, jsd, jsd, dir, .true.)
3508  else
3509  call insert_update_overlap(overlap, domain%list(m)%pe, &
3510  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3511  end if
3512  endif
3513 
3514  !recv_nw
3515  dir = 6
3516  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
3517  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3518  is=isc; ie=iec; js=jsc; je=jec
3519  if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset
3520  is = is-ioff; ie = ie-ioff
3521  endif
3522 
3523  call insert_update_overlap( overlap, domain%list(m)%pe, &
3524  is, ie, js, je, isd, ied, jsd, jed, dir)
3525 
3526  !recv_n
3527  dir = 7
3528  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3529  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3530  is=isc; ie=iec; js=jsc; je=jec
3531  call insert_update_overlap( overlap, domain%list(m)%pe, &
3532  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3533 
3534  !recv_ne
3535  dir = 8
3536  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
3537  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
3538  is=isc; ie=iec; js=jsc; je=jec
3539  if( ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset
3540  is = is+ioff; ie = ie+ioff
3541  end if
3542  call insert_update_overlap( overlap, domain%list(m)%pe, &
3543  is, ie, js, je, isd, ied, jsd, jed, dir)
3544 
3545  !--- Now calculate the overlapping for fold-edge.
3546  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
3547  !--- only position at NORTH and CORNER need to be considered
3548  if( ( position == north .OR. position == corner) ) then
3549  !fold is within domain
3550  if( domain%y(tme)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tme)%domain_data%end+jshift )then
3551  dir = 3
3552  !--- calculating overlapping for receving on north
3553  if( domain%x(tme)%pos .GE. size(domain%x(tme)%list(:))/2 )then
3554  jsd = domain%y(tme)%compute%begin; jed = jsd
3555  if( jsd == jsg )then ! fold is within domain.
3556  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
3557  is=isc; ie=iec; js = jsc; je = jec
3558  select case (position)
3559  case(north)
3560  isd = max(isd, middle)
3561  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3562  case(corner)
3563  isd = max(isd, middle)
3564  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3565  end select
3566  call insert_update_overlap(overlap, domain%list(m)%pe, &
3567  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
3568  is = max(is, isd); ie = min(ie, ied)
3569  js = max(js, jsd); je = min(je, jed)
3570  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
3571  nrecv_check = nrecv_check+1
3572  call allocate_check_overlap(checklist(nrecv_check), 1)
3573  call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
3574  tme, 2, one_hundred_eighty, is, ie, js, je)
3575  endif
3576  endif
3577  endif
3578  endif
3579  endif
3580  endif
3581  !--- copy the overlapping information
3582  if( overlap%count > 0) then
3583  nrecv = nrecv + 1
3584  if(nrecv > size(overlaplist(:)) )then
3585  call mpp_error(note, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for recv is expanded')
3586  call expand_update_overlap_list(overlaplist, nlist)
3587  endif
3588  call add_update_overlap( overlaplist(nrecv), overlap)
3589  call init_overlap_type(overlap)
3590  endif
3591  enddo ! end of recv do loop
3592 
3593  if(debug_message_passing) then
3594  !--- write out send information
3595  iunit = mpp_pe() + 1000
3596  do m =1,nrecv
3597  write(iunit, *) "********from_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
3598  do n = 1, overlaplist(m)%count
3599  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3600  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3601  enddo
3602  enddo
3603  if(nrecv >0) flush(iunit)
3604  endif
3605 
3606  ! copy the overlapping information into domain
3607  if(nrecv>0) then
3608  update%nrecv = nrecv
3609  if (associated(update%recv)) deallocate(update%recv) !< Check if associated
3610  allocate(update%recv(nrecv))
3611  do m = 1, nrecv
3612  call add_update_overlap( update%recv(m), overlaplist(m) )
3613  do n = 1, update%recv(m)%count
3614  if(update%recv(m)%tileNbr(n) == domain%tile_id(tme)) then
3615  if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
3616  if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
3617  endif
3618  enddo
3619  enddo
3620  endif
3621 
3622  if(nrecv_check>0) then
3623  check%nrecv = nrecv_check
3624  if (associated(check%recv)) deallocate(check%recv) !< Check if associated
3625  allocate(check%recv(nrecv_check))
3626  do m = 1, nrecv_check
3627  call add_check_overlap( check%recv(m), checklist(m) )
3628  enddo
3629  endif
3630 
3631  call deallocate_overlap_type(overlap)
3632 
3633  do m = 1,size(overlaplist(:))
3634  call deallocate_overlap_type(overlaplist(m))
3635  enddo
3636 
3637  if(debug_update_level .NE. no_check) then
3638  do m = 1,size(checklist(:))
3639  call deallocate_overlap_type(checklist(m))
3640  enddo
3641  endif
3642 
3643  deallocate(overlaplist)
3644  deallocate(checklist)
3645  update => null()
3646  check=>null()
3647  domain%initialized = .true.
3648 
3649  end subroutine compute_overlaps_fold_south
3650 
3651  !####################################################################################
3652  !> Computes remote domain overlaps
3653  !! assumes only one in each direction
3654  !! will calculate the overlapping for T,E,C,N-cell separately.
3655  subroutine compute_overlaps_fold_west( domain, position, ishift, jshift)
3656  type(domain2d), intent(inout) :: domain
3657  integer, intent(in) :: position, ishift, jshift
3658 
3659  integer :: j, m, n, nlist, tMe, tNbr, dir
3660  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3661  integer :: isg, ieg, jsg, jeg, ioff, joff
3662  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3663  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3664  logical :: folded
3665  type(overlap_type) :: overlap
3666  type(overlapspec), pointer :: update=>null()
3667  type(overlap_type) :: overlapList(MAXLIST)
3668  type(overlap_type) :: checkList(MAXLIST)
3669  type(overlapspec), pointer :: check =>null()
3670  integer :: nsend, nrecv
3671  integer :: nsend_check, nrecv_check
3672  integer :: iunit
3673 
3674  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
3675  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
3676  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
3677  if(size(domain%x(:)) > 1) return
3678 
3679  !--- if there is no halo, no need to compute overlaps.
3680  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3681 
3682  !--- when there is only one tile, n will equal to np
3683  nlist = size(domain%list(:))
3684 
3685  select case(position)
3686  case (center)
3687  update => domain%update_T
3688  check => null()
3689  case (corner)
3690  update => domain%update_C
3691  check => domain%check_C
3692  case (east)
3693  update => domain%update_E
3694  check => domain%check_E
3695  case (north)
3696  update => domain%update_N
3697  check => domain%check_N
3698  case default
3699  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_west):"//&
3700  & " the value of position should be CENTER, EAST, CORNER or NORTH")
3701  end select
3702 
3703  !--- overlap is used to store the overlapping temporarily.
3704  call allocate_update_overlap( overlap, maxoverlap)
3705 
3706  !send
3707  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3708  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
3709  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3710  update%xbegin = ism; update%xend = iem
3711  update%ybegin = jsm; update%yend = jem
3712  if(ASSOCIATED(check)) then
3713  check%xbegin = ism; check%xend = iem
3714  check%ybegin = jsm; check%yend = jem
3715  endif
3716  update%whalo = domain%whalo; update%ehalo = domain%ehalo
3717  update%shalo = domain%shalo; update%nhalo = domain%nhalo
3718  whalo = domain%whalo; ehalo = domain%ehalo
3719  shalo = domain%shalo; nhalo = domain%nhalo
3720 
3721  ioff = ni - ishift
3722  joff = nj - jshift
3723  middle = (jsg+jeg)/2+1
3724  tme = 1; tnbr = 1
3725 
3726  if(.NOT. btest(domain%fold,west)) then
3727  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3728  "boundary condition in y-direction should be folded-west for "//trim(domain%name))
3729  endif
3730  if(.NOT. domain%y(tme)%cyclic) then
3731  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3732  "boundary condition in y-direction should be cyclic for "//trim(domain%name))
3733  endif
3734 
3735  if(.not. domain%symmetry) then
3736  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3737  "when west boundary is folded, the domain must be symmetry for "//trim(domain%name))
3738  endif
3739 
3740  nsend = 0
3741  nsend_check = 0
3742  do list = 0,nlist-1
3743  m = mod( domain%pos+list, nlist )
3744  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
3745  !to_pe's eastern halo
3746  dir = 1
3747  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3748  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3749  call insert_update_overlap( overlap, domain%list(m)%pe, &
3750  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3751 
3752  !to_pe's SE halo
3753  dir = 2
3754  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3755  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3756  if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
3757  js = js+joff; je = je+joff
3758  end if
3759 
3760  call insert_update_overlap( overlap, domain%list(m)%pe, &
3761  is, ie, js, je, isc, iec, jsc, jec, dir)
3762 
3763  !to_pe's southern halo
3764  dir = 3
3765  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3766  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3767  !--- to make sure the consistence between pes
3768  if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) ) then
3769  !--- do nothing, this point will come from other pe
3770  else
3771  if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
3772  js = js+joff; je = je+joff
3773  endif
3774 
3775  !--- when the west face is folded, the south halo points at
3776  !--- the position should be on CORNER or EAST
3777  if( is == isg .AND. (position == corner .OR. position == east) &
3778  .AND. ( domain%list(m)%y(tnbr)%compute%begin == jsg .OR. &
3779  & domain%list(m)%y(tnbr)%compute%begin-1 .GE. middle)) then
3780  call insert_update_overlap( overlap, domain%list(m)%pe, &
3781  is+1, ie, js, je, isc, iec, jsc, jec, dir)
3782  is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3783  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3784  if ( domain%list(m)%y(tnbr)%compute%begin == jsg ) then
3785  select case (position)
3786  case(east)
3787  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
3788  case(corner)
3789  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
3790  end select
3791  if(je .GT. domain%y(tme)%compute%end+jshift) call mpp_error( fatal, &
3792  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error send.' )
3793  else
3794  select case (position)
3795  case(east)
3796  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3797  case(corner)
3798  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3799  end select
3800  end if
3801  call insert_update_overlap( overlap, domain%list(m)%pe, &
3802  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3803  else
3804  call insert_update_overlap( overlap, domain%list(m)%pe, &
3805  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3806  end if
3807  endif
3808 
3809  !to_pe's SW halo
3810  dir = 4
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-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
3814  if( jsg.GT.js .AND. je.LT.jsc )then !cyclic offset
3815  js = js+joff; je = je+joff
3816  end if
3817  if( is.LT.isg )then
3818  folded = .true.
3819  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3820  end if
3821  call insert_update_overlap( overlap, domain%list(m)%pe, &
3822  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3823  !--- when south edge is folded, js will be less than jsg when position is EAST and CORNER
3824  if(js .LT. jsg) then
3825  js = js + joff
3826  call insert_update_overlap( overlap, domain%list(m)%pe, &
3827  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3828  endif
3829 
3830  !to_pe's western halo
3831  dir = 5
3832  folded = .false.
3833  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3834  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3835  if( isg.GT.is )then
3836  folded = .true.
3837  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3838  end if
3839  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3840  !--- no need to send, because the data on that point will come from other pe.
3841  !--- come from two pe ( there will be only one point on one pe. ).
3842  if( (position == east .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) ) then
3843  !--- do nothing, this point will come from other pe
3844  else
3845  call insert_update_overlap( overlap, domain%list(m)%pe, &
3846  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3847  endif
3848  !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3849  if(js .LT. jsg) then
3850  js = js + ioff
3851  call insert_update_overlap( overlap, domain%list(m)%pe, &
3852  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3853  endif
3854 
3855  !to_pe's NW halo
3856  dir = 6
3857  folded = .false.
3858  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
3859  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3860  if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
3861  js = js-joff; je = je-joff
3862  end if
3863  if( is.LT.isg )then
3864  folded = .true.
3865  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3866  end if
3867 
3868  call insert_update_overlap( overlap, domain%list(m)%pe, &
3869  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3870 
3871  !to_pe's northern halo
3872  dir = 7
3873  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
3874  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3875  !--- to make sure the consistence between pes
3876  if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) ) then
3877  !--- do nothing, this point will come from other pe
3878  else
3879  if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
3880  js = js-joff; je = je-joff
3881  endif
3882  !--- when the west face is folded, the south halo points at
3883  !--- the position should be on CORNER or EAST
3884  if( is == isg .AND. (position == corner .OR. position == east) &
3885  .AND. ( js .GE. middle .AND. domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
3886  call insert_update_overlap( overlap, domain%list(m)%pe, &
3887  is+1, ie, js, je, isc, iec, jsc, jec, dir)
3888  is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3889  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3890  select case (position)
3891  case(east)
3892  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3893  case(corner)
3894  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3895  end select
3896  call insert_update_overlap( overlap, domain%list(m)%pe, &
3897  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3898  else
3899  call insert_update_overlap( overlap, domain%list(m)%pe, &
3900  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3901  end if
3902  endif
3903 
3904  !to_pe's NE halo
3905  dir = 8
3906  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
3907  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
3908  if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
3909  js = js-joff; je = je-joff
3910  end if
3911  call insert_update_overlap( overlap, domain%list(m)%pe, &
3912  is, ie, js, je, isc, iec, jsc, jec, dir)
3913 
3914  !--- Now calculate the overlapping for fold-edge.
3915  !--- only position at EAST and CORNER need to be considered
3916  if( ( position == east .OR. position == corner) ) then
3917  !fold is within domain
3918  if( domain%x(tme)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tme)%domain_data%end+ishift )then
3919  dir = 5
3920  !--- calculate the overlapping for sending
3921  if( domain%y(tme)%pos .LT. (size(domain%y(tme)%list(:))+1)/2 )then
3922  is = domain%list(m)%x(tnbr)%compute%begin; ie = is
3923  if( is == isg )then ! fold is within domain.
3924  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
3925  select case (position)
3926  case(east)
3927  js = max(js, middle)
3928  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3929  case(corner)
3930  js = max(js, middle)
3931  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3932  end select
3933  call insert_update_overlap(overlap, domain%list(m)%pe, &
3934  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3935  is = max(is, isc); ie = min(ie, iec)
3936  js = max(js, jsc); je = min(je, jec)
3937  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
3938  nsend_check = nsend_check+1
3939  call allocate_check_overlap(checklist(nsend_check), 1)
3940  call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
3941  tme, 3, one_hundred_eighty, is, ie, js, je)
3942  end if
3943  end if
3944  end if
3945  end if
3946  end if
3947  end if
3948  !--- copy the overlapping information
3949  if( overlap%count > 0) then
3950  nsend = nsend + 1
3951  if(nsend > maxlist) call mpp_error(fatal, &
3952  "mpp_domains_define.inc(compute_overlaps_west): nsend is greater than MAXLIST, increase MAXLIST")
3953  call add_update_overlap(overlaplist(nsend), overlap)
3954  call init_overlap_type(overlap)
3955  endif
3956  end do ! end of send set up.
3957 
3958  if(debug_message_passing) then
3959  !--- write out send information
3960  iunit = mpp_pe() + 1000
3961  do m =1,nsend
3962  write(iunit, *) "********to_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
3963  do n = 1, overlaplist(m)%count
3964  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
3965  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
3966  enddo
3967  enddo
3968  if(nsend >0) flush(iunit)
3969  endif
3970 
3971  ! copy the overlapping information into domain data structure
3972  if(nsend>0) then
3973  update%nsend = nsend
3974  if (associated(update%send)) deallocate(update%send) !< Check if associated
3975  allocate(update%send(nsend))
3976  do m = 1, nsend
3977  call add_update_overlap( update%send(m), overlaplist(m) )
3978  enddo
3979  endif
3980 
3981  if(nsend_check>0) then
3982  check%nsend = nsend_check
3983  if (associated(check%send)) deallocate(check%send) !< Check if associated
3984  allocate(check%send(nsend_check))
3985  do m = 1, nsend_check
3986  call add_check_overlap( check%send(m), checklist(m) )
3987  enddo
3988  endif
3989 
3990  do m = 1, maxlist
3991  call deallocate_overlap_type(overlaplist(m))
3992  if(debug_update_level .NE. no_check) call deallocate_overlap_type(checklist(m))
3993  enddo
3994 
3995  isgd = isg - domain%whalo
3996  iegd = ieg + domain%ehalo
3997  jsgd = jsg - domain%shalo
3998  jegd = jeg + domain%nhalo
3999 
4000  ! begin setting up recv
4001  nrecv = 0
4002  nrecv_check = 0
4003  do list = 0,nlist-1
4004  m = mod( domain%pos+nlist-list, nlist )
4005  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
4006  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4007  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4008  !recv_e
4009  dir = 1
4010  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4011  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4012  is=isc; ie=iec; js=jsc; je=jec
4013  call insert_update_overlap( overlap, domain%list(m)%pe, &
4014  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4015 
4016  !recv_se
4017  dir = 2
4018  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4019  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4020  is=isc; ie=iec; js=jsc; je=jec
4021  if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
4022  js = js-joff; je = je-joff
4023  end if
4024  call insert_update_overlap(overlap, domain%list(m)%pe, &
4025  is, ie, js, je, isd, ied, jsd, jed, dir)
4026 
4027  !recv_s
4028  dir = 3
4029  folded = .false.
4030  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4031  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4032  is=isc; ie=iec; js=jsc; je=jec
4033 
4034  if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) ) then
4035  !--- do nothing, this point will come from other pe
4036  else
4037  if( jsd.LT.jsg .AND. js .GT. jed)then
4038  js = js-joff; je = je-joff
4039  end if
4040  !--- when the west face is folded, the south halo points at
4041  !--- the position should be on CORNER or EAST
4042  if( isd == isg .AND. (position == corner .OR. position == east) &
4043  .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
4044  call insert_update_overlap( overlap, domain%list(m)%pe, &
4045  is, ie, js, je, isd+1, ied, jsd, jed, dir)
4046  is=isc; ie=iec; js=jsc; je=jec
4047  if(jsd<jsg) then
4048  select case (position)
4049  case(east)
4050  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4051  case(corner)
4052  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4053  end select
4054  if(je .GT. domain%y(tme)%compute%end+jshift) call mpp_error( fatal, &
4055  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4056  else
4057  select case (position)
4058  case(east)
4059  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4060  case(corner)
4061  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4062  end select
4063  end if
4064  call insert_update_overlap( overlap, domain%list(m)%pe, &
4065  is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4066  else
4067  call insert_update_overlap( overlap, domain%list(m)%pe, &
4068  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4069  end if
4070  endif
4071 
4072  !recv_sw
4073  dir = 4
4074  folded = .false.
4075  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4076  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4077  is=isc; ie=iec; js=jsc; je=jec
4078  if( isd.LT.isg )then
4079  folded = .true.
4080  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4081  end if
4082  if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4083  js = js-joff; je = je-joff
4084  end if
4085  call insert_update_overlap(overlap, domain%list(m)%pe, &
4086  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
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_w
4095  dir = 5
4096  folded = .false.
4097  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4098  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%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( (position == east .OR. position == corner ) .AND. (jsd == je .or. jed == js ) ) then
4105  !--- do nothing, this point will come from other pe
4106  else
4107  call insert_update_overlap(overlap, domain%list(m)%pe, &
4108  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4109  end if
4110  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4111  if(js .LT. jsg ) then
4112  js = js + joff
4113  call insert_update_overlap(overlap, domain%list(m)%pe, &
4114  is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4115  endif
4116 
4117  !recv_nw
4118  dir = 6
4119  folded = .false.
4120  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4121  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4122  is=isc; ie=iec; js=jsc; je=jec
4123  if( isd.LT.isg) then
4124  folded = .true.
4125  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4126  end if
4127  if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4128  js = js+joff; je = je+joff
4129  endif
4130 
4131  call insert_update_overlap( overlap, domain%list(m)%pe, &
4132  is, ie, js, je, isd, ied, jsd, jed, dir)
4133 
4134  !recv_n
4135  dir = 7
4136  folded = .false.
4137  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4138  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4139  is=isc; ie=iec; js=jsc; je=jec
4140  if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) ) then
4141  !--- do nothing, this point will come from other pe
4142  else
4143  if( jed.GT.jeg .AND. je.LT.jsd)then
4144  js = js+joff; je = je+joff
4145  end if
4146  !--- when the west face is folded, the south halo points at
4147  !--- the position should be on CORNER or EAST
4148  if( isd == isg .AND. (position == corner .OR. position == east) &
4149  .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4150  call insert_update_overlap( overlap, domain%list(m)%pe, &
4151  is, ie, js, je, isd+1, ied, jsd, jed, dir)
4152  is=isc; ie=iec; js=jsc; je=jec
4153  select case (position)
4154  case(east)
4155  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4156  case(corner)
4157  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4158  end select
4159  call insert_update_overlap( overlap, domain%list(m)%pe, &
4160  is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4161  else
4162  call insert_update_overlap( overlap, domain%list(m)%pe, &
4163  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4164  end if
4165  endif
4166 
4167  !recv_ne
4168  dir = 8
4169  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4170  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4171  is=isc; ie=iec; js=jsc; je=jec
4172  if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4173  js = js+joff; je = je+joff
4174  end if
4175  call insert_update_overlap( overlap, domain%list(m)%pe, &
4176  is, ie, js, je, isd, ied, jsd, jed, dir)
4177 
4178  !--- Now calculate the overlapping for fold-edge.
4179  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4180  !--- only position at EAST and CORNER need to be considered
4181  if( ( position == east .OR. position == corner) ) then
4182  !fold is within domain
4183  if( domain%x(tme)%domain_data%begin .LE. isg .AND. isg .LE. domain%x(tme)%domain_data%end+ishift )then
4184  dir = 5
4185  !--- calculating overlapping for receving on north
4186  if( domain%y(tme)%pos .GE. size(domain%y(tme)%list(:))/2 )then
4187  isd = domain%x(tme)%compute%begin; ied = isd
4188  if( isd == isg )then ! fold is within domain.
4189  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4190  is=isc; ie=iec; js = jsc; je = jec
4191  select case (position)
4192  case(east)
4193  jsd = max(jsd, middle)
4194  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4195  case(corner)
4196  jsd = max(jsd, middle)
4197  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4198  end select
4199  call insert_update_overlap(overlap, domain%list(m)%pe, &
4200  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
4201  is = max(is, isd); ie = min(ie, ied)
4202  js = max(js, jsd); je = min(je, jed)
4203  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
4204  nrecv_check = nrecv_check+1
4205  call allocate_check_overlap(checklist(nrecv_check), 1)
4206  call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
4207  tme, 3, one_hundred_eighty, is, ie, js, je)
4208  endif
4209  endif
4210  endif
4211  endif
4212  endif
4213  endif
4214  !--- copy the overlapping information
4215  if( overlap%count > 0) then
4216  nrecv = nrecv + 1
4217  if(nrecv > maxlist) call mpp_error(fatal, &
4218  "mpp_domains_define.inc(compute_overlaps_west): nrecv is greater than MAXLIST, increase MAXLIST")
4219  call add_update_overlap( overlaplist(nrecv), overlap)
4220  call init_overlap_type(overlap)
4221  endif
4222  enddo ! end of recv do loop
4223 
4224  if(debug_message_passing) then
4225  !--- write out send information
4226  iunit = mpp_pe() + 1000
4227  do m =1,nrecv
4228  write(iunit, *) "********from_pe = " ,overlaplist(m)%pe, " count = ",overlaplist(m)%count
4229  do n = 1, overlaplist(m)%count
4230  write(iunit, *) overlaplist(m)%is(n), overlaplist(m)%ie(n), overlaplist(m)%js(n), overlaplist(m)%je(n), &
4231  overlaplist(m)%dir(n), overlaplist(m)%rotation(n)
4232  enddo
4233  enddo
4234  if(nrecv >0) flush(iunit)
4235  endif
4236 
4237  ! copy the overlapping information into domain
4238  if(nrecv>0) then
4239  update%nrecv = nrecv
4240  if (associated(update%recv)) deallocate(update%recv) !< Check if associated
4241  allocate(update%recv(nrecv))
4242  do m = 1, nrecv
4243  call add_update_overlap( update%recv(m), overlaplist(m) )
4244  do n = 1, update%recv(m)%count
4245  if(update%recv(m)%tileNbr(n) == domain%tile_id(tme)) then
4246  if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
4247  if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
4248  endif
4249  enddo
4250  enddo
4251  endif
4252 
4253  if(nrecv_check>0) then
4254  check%nrecv = nrecv_check
4255  if (associated(check%recv)) deallocate(check%recv) !< Check if associated
4256  allocate(check%recv(nrecv_check))
4257  do m = 1, nrecv_check
4258  call add_check_overlap( check%recv(m), checklist(m) )
4259  enddo
4260  endif
4261 
4262  call deallocate_overlap_type(overlap)
4263  do m = 1, maxlist
4264  call deallocate_overlap_type(overlaplist(m))
4265  if(debug_update_level .NE. no_check) call deallocate_overlap_type(checklist(m))
4266  enddo
4267 
4268  update=>null()
4269  check=>null()
4270  domain%initialized = .true.
4271 
4272  end subroutine compute_overlaps_fold_west
4273 
4274  !###############################################################################
4275  !> computes remote domain overlaps
4276  !! assumes only one in each direction
4277  !! will calculate the overlapping for T,E,C,N-cell separately.
4278  !! here assume fold-east and y-cyclic boundary condition
4279  subroutine compute_overlaps_fold_east( domain, position, ishift, jshift )
4280  type(domain2d), intent(inout) :: domain
4281  integer, intent(in) :: position, ishift, jshift
4282 
4283  integer :: j, m, n, nlist, tMe, tNbr, dir
4284  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd
4285  integer :: jed, isg, ieg, jsg, jeg, ioff, joff
4286  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
4287  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
4288  logical :: folded
4289  type(overlap_type) :: overlap
4290  type(overlapspec), pointer :: update=>null()
4291  type(overlap_type) :: overlapList(MAXLIST)
4292  type(overlap_type) :: checkList(MAXLIST)
4293  type(overlapspec), pointer :: check =>null()
4294  integer :: nsend, nrecv
4295  integer :: nsend_check, nrecv_check
4296 
4297  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
4298  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
4299  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
4300  if(size(domain%x(:)) > 1) return
4301 
4302  !--- if there is no halo, no need to compute overlaps.
4303  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
4304 
4305  !--- when there is only one tile, n will equal to np
4306  nlist = size(domain%list(:))
4307 
4308  select case(position)
4309  case (center)
4310  update => domain%update_T
4311  case (corner)
4312  update => domain%update_C
4313  check => domain%check_C
4314  case (east)
4315  update => domain%update_E
4316  check => domain%check_E
4317  case (north)
4318  update => domain%update_N
4319  check => domain%check_N
4320  case default
4321  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_east):"// &
4322  & " the value of position should be CENTER, EAST, CORNER or NORTH")
4323  end select
4324 
4325  !--- overlap is used to store the overlapping temporarily.
4326  call allocate_update_overlap( overlap, maxoverlap)
4327 
4328  !send
4329  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
4330  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
4331  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
4332  update%xbegin = ism; update%xend = iem
4333  update%ybegin = jsm; update%yend = jem
4334  if(ASSOCIATED(check)) then
4335  check%xbegin = ism; check%xend = iem
4336  check%ybegin = jsm; check%yend = jem
4337  endif
4338  update%whalo = domain%whalo; update%ehalo = domain%ehalo
4339  update%shalo = domain%shalo; update%nhalo = domain%nhalo
4340  whalo = domain%whalo; ehalo = domain%ehalo
4341  shalo = domain%shalo; nhalo = domain%nhalo
4342 
4343  ioff = ni - ishift
4344  joff = nj - jshift
4345  middle = (jsg+jeg)/2+1
4346  tme = 1; tnbr = 1
4347 
4348  if(.NOT. btest(domain%fold,east)) then
4349  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4350  "boundary condition in y-direction should be folded-east for "//trim(domain%name))
4351  endif
4352  if(.NOT. domain%y(tme)%cyclic) then
4353  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4354  "boundary condition in y-direction should be cyclic for "//trim(domain%name))
4355  endif
4356  if(.not. domain%symmetry) then
4357  call mpp_error(fatal, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4358  "when east boundary is folded, the domain must be symmetry for "//trim(domain%name))
4359  endif
4360 
4361  nsend = 0
4362  nsend_check = 0
4363  do list = 0,nlist-1
4364  m = mod( domain%pos+list, nlist )
4365  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
4366  !to_pe's eastern halo
4367  dir = 1
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; je = domain%list(m)%y(tnbr)%compute%end+jshift
4371  if( ie.GT.ieg )then
4372  folded = .true.
4373  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4374  end if
4375  !--- when domain symmetry and position is EAST or CORNER, the point when jsc == je,
4376  !--- no need to send, because the data on that point will come from other pe.
4377  !--- come from two pe ( there will be only one point on one pe. ).
4378  if( (position == east .OR. position == corner ) .AND. ( jsc == je .or. jec == js ) ) then
4379  !--- do nothing, this point will come from other pe
4380  else
4381  call insert_update_overlap( overlap, domain%list(m)%pe, &
4382  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
4383  endif
4384  !--- when east edge is folded, js .LT. jsg
4385  if(js .LT. jsg) then
4386  js = js + ioff
4387  call insert_update_overlap( overlap, domain%list(m)%pe, &
4388  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4389  endif
4390 
4391  !to_pe's SE halo
4392  dir = 2
4393  folded = .false.
4394  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
4395  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4396  if( jsg.GT.js .AND. je.LT.jsc )then !try cyclic offset
4397  js = js+joff; je = je+joff
4398  end if
4399 
4400  if( ie.GT.ieg )then
4401  folded = .true.
4402  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4403  end if
4404 
4405  call insert_update_overlap( overlap, domain%list(m)%pe, &
4406  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4407  !--- when east edge is folded,
4408  if(js .LT. jsg) then
4409  js = js + joff
4410  call insert_update_overlap( overlap, domain%list(m)%pe, &
4411  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4412  endif
4413 
4414  !to_pe's southern halo
4415  dir = 3
4416  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
4417  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4418  !--- to make sure the consistence between pes
4419  if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) ) then
4420  !--- do nothing, this point will come from other pe
4421  else
4422  if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
4423  js = js+joff; je = je+joff
4424  endif
4425  !--- when the east face is folded, the south halo points at
4426  !--- the position should be on CORNER or EAST
4427  if( ie == ieg .AND. (position == corner .OR. position == east) &
4428  .AND. ( domain%list(m)%y(tnbr)%compute%begin == jsg .OR. &
4429  domain%list(m)%y(tnbr)%compute%begin-1 .GE. middle ) ) then
4430  call insert_update_overlap( overlap, domain%list(m)%pe, &
4431  is, ie-1, js, je, isc, iec, jsc, jec, dir)
4432  !--- consider at i = ieg for east edge.
4433  !--- when the data is at corner and not symmetry, j = jsg -1 will get from cyclic condition
4434  if(position == corner .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tnbr)%compute%begin==jsg)then
4435  call insert_update_overlap(overlap, domain%list(m)%pe, &
4436  ie, ie, je, je, isc, iec, jsc, jec, dir, .true.)
4437  end if
4438 
4439  ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4440  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4441  if ( domain%list(m)%y(tnbr)%compute%begin == jsg ) then
4442  select case (position)
4443  case(east)
4444  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4445  case(corner)
4446  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4447  end select
4448  if(je .GT. domain%y(tme)%compute%end+jshift) call mpp_error( fatal, &
4449  'mpp_domains_define.inc(compute_overlaps_fold_east: south edge ubound error send.' )
4450  else
4451  select case (position)
4452  case(east)
4453  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4454  case(corner)
4455  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4456  end select
4457  end if
4458  call insert_update_overlap( overlap, domain%list(m)%pe, &
4459  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4460  else
4461  call insert_update_overlap( overlap, domain%list(m)%pe, &
4462  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4463  end if
4464  endif
4465 
4466  !to_pe's SW halo
4467  dir = 4
4468  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4469  js = domain%list(m)%y(tnbr)%compute%begin-shalo; je = domain%list(m)%y(tnbr)%compute%begin-1
4470  if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
4471  js = js+joff; je = je+joff
4472  end if
4473  call insert_update_overlap( overlap, domain%list(m)%pe, &
4474  is, ie, js, je, isc, iec, jsc, jec, dir)
4475 
4476  !to_pe's western halo
4477  dir = 5
4478  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4479  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
4480  call insert_update_overlap( overlap, domain%list(m)%pe, &
4481  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4482 
4483  !to_pe's NW halo
4484  dir = 6
4485  is = domain%list(m)%x(tnbr)%compute%begin-whalo; ie = domain%list(m)%x(tnbr)%compute%begin-1
4486  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4487  if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
4488  js = js-joff; je = je-joff
4489  end if
4490  call insert_update_overlap( overlap, domain%list(m)%pe, &
4491  is, ie, js, je, isc, iec, jsc, jec, dir)
4492 
4493  !to_pe's northern halo
4494  dir = 7
4495  folded = .false.
4496  is = domain%list(m)%x(tnbr)%compute%begin; ie = domain%list(m)%x(tnbr)%compute%end+ishift
4497  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4498  !--- to make sure the consistence between pes
4499  if( (position == east .OR. position == corner ) .AND. ( isc == ie .or. iec == is ) ) then
4500  !--- do nothing, this point will come from other pe
4501  else
4502  if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
4503  js = js-joff; je = je-joff
4504  endif
4505  !--- when the east face is folded, the north halo points at
4506  !--- the position should be on CORNER or EAST
4507  if( ie == ieg .AND. (position == corner .OR. position == east) &
4508  .AND. ( js .GE. middle .AND. domain%list(m)%y(tnbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
4509  call insert_update_overlap( overlap, domain%list(m)%pe, &
4510  is, ie-1, js, je, isc, iec, jsc, jec, dir)
4511  ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4512  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4513  select case (position)
4514  case(east)
4515  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4516  case(corner)
4517  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4518  end select
4519  call insert_update_overlap( overlap, domain%list(m)%pe, &
4520  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4521  else
4522  call insert_update_overlap( overlap, domain%list(m)%pe, &
4523  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4524  end if
4525  endif
4526 
4527  !to_pe's NE halo
4528  dir = 8
4529  folded = .false.
4530  is = domain%list(m)%x(tnbr)%compute%end+1+ishift; ie = domain%list(m)%x(tnbr)%compute%end+ehalo+ishift
4531  js = domain%list(m)%y(tnbr)%compute%end+1+jshift; je = domain%list(m)%y(tnbr)%compute%end+nhalo+jshift
4532  if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
4533  js = js-joff; je = je-joff
4534  end if
4535  if( ie.GT.ieg )then
4536  folded = .true.
4537  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4538  end if
4539 
4540  call insert_update_overlap( overlap, domain%list(m)%pe, &
4541  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4542 
4543  !--- Now calculate the overlapping for fold-edge.
4544  !--- only position at EAST and CORNER need to be considered
4545  if( ( position == east .OR. position == corner) ) then
4546  !fold is within domain
4547  if( domain%x(tme)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tme)%domain_data%end+ishift )then
4548  dir = 1
4549  !--- calculate the overlapping for sending
4550  if( domain%y(tme)%pos .LT. (size(domain%y(tme)%list(:))+1)/2 )then
4551  ie = domain%list(m)%x(tnbr)%compute%end+ishift; is = ie
4552  if( ie == ieg )then ! fold is within domain.
4553  js = domain%list(m)%y(tnbr)%compute%begin; je = domain%list(m)%y(tnbr)%compute%end+jshift
4554  select case (position)
4555  case(east)
4556  js = max(js, middle)
4557  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4558  case(corner)
4559  js = max(js, middle)
4560  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4561  end select
4562  call insert_update_overlap(overlap, domain%list(m)%pe, &
4563  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4564  is = max(is, isc); ie = min(ie, iec)
4565  js = max(js, jsc); je = min(je, jec)
4566  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
4567  nsend_check = nsend_check+1
4568  call allocate_check_overlap(checklist(nsend_check), 1)
4569  call insert_check_overlap(checklist(nsend_check), domain%list(m)%pe, &
4570  tme, 1, one_hundred_eighty, is, ie, js, je)
4571  end if
4572  end if
4573  end if
4574  end if
4575  end if
4576  end if
4577  !--- copy the overlapping information
4578  if( overlap%count > 0) then
4579  nsend = nsend + 1
4580  if(nsend > maxlist) call mpp_error(fatal, &
4581  "mpp_domains_define.inc(compute_overlaps_east): nsend is greater than MAXLIST, increase MAXLIST")
4582  call add_update_overlap(overlaplist(nsend), overlap)
4583  call init_overlap_type(overlap)
4584  endif
4585  end do ! end of send set up.
4586 
4587  ! copy the overlapping information into domain data structure
4588  if(nsend>0) then
4589  update%nsend = nsend
4590  if (associated(update%send)) deallocate(update%send) !< Check if associated
4591  allocate(update%send(nsend))
4592  do m = 1, nsend
4593  call add_update_overlap( update%send(m), overlaplist(m) )
4594  enddo
4595  endif
4596 
4597  if(nsend_check>0) then
4598  check%nsend = nsend_check
4599  if (associated(check%send)) deallocate(check%send) !< Check if associated
4600  allocate(check%send(nsend_check))
4601  do m = 1, nsend_check
4602  call add_check_overlap( check%send(m), checklist(m) )
4603  enddo
4604  endif
4605 
4606  do m = 1, maxlist
4607  call deallocate_overlap_type(overlaplist(m))
4608  if(debug_update_level .NE. no_check) call deallocate_overlap_type(checklist(m))
4609  enddo
4610 
4611  isgd = isg - domain%whalo
4612  iegd = ieg + domain%ehalo
4613  jsgd = jsg - domain%shalo
4614  jegd = jeg + domain%nhalo
4615 
4616  ! begin setting up recv
4617  nrecv = 0
4618  nrecv_check = 0
4619  do list = 0,nlist-1
4620  m = mod( domain%pos+nlist-list, nlist )
4621  if(domain%list(m)%tile_id(tnbr) == domain%tile_id(tme) ) then ! only compute the overlapping within tile.
4622  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4623  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4624  !recv_e
4625  dir = 1
4626  folded = .false.
4627  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4628  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4629  is=isc; ie=iec; js=jsc; je=jec
4630  if( ied.GT.ieg )then
4631  folded = .true.
4632  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4633  end if
4634  if( (position == east .OR. position == corner ) .AND. (jsd == je .or. jed == js ) ) then
4635  !--- do nothing, this point will come from other pe
4636  else
4637  call insert_update_overlap(overlap, domain%list(m)%pe, &
4638  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4639  end if
4640  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4641  if(js .LT. jsg ) then
4642  js = js + joff
4643  call insert_update_overlap(overlap, domain%list(m)%pe, &
4644  is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4645  endif
4646 
4647  !recv_se
4648  dir = 2
4649  folded = .false.
4650  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4651  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4652  is=isc; ie=iec; js=jsc; je=jec
4653  if( ied.GT.ieg )then
4654  folded = .true.
4655  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4656  end if
4657  if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4658  js = js-joff; je = je-joff
4659  end if
4660  call insert_update_overlap(overlap, domain%list(m)%pe, &
4661  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4662  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4663  if(js .LT. jsg ) then
4664  js = js + joff
4665  call insert_update_overlap(overlap, domain%list(m)%pe, &
4666  is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4667  endif
4668 
4669  !recv_s
4670  dir = 3
4671  folded = .false.
4672  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4673  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4674  is=isc; ie=iec; js=jsc; je=jec
4675 
4676  if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) ) then
4677  !--- do nothing, this point will come from other pe
4678  else
4679  if( jsd.LT.jsg .AND. js .GT. jed)then
4680  js = js-joff; je = je-joff
4681  end if
4682  !--- when the east face is folded, the south halo points at
4683  !--- the position should be on CORNER or EAST
4684  if( ied == ieg .AND. (position == corner .OR. position == east) &
4685  .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
4686  call insert_update_overlap( overlap, domain%list(m)%pe, &
4687  is, ie, js, je, isd, ied-1, jsd, jed, dir)
4688  is=isc; ie=iec; js=jsc; je=jec
4689  if(jsd<jsg) then
4690  select case (position)
4691  case(east)
4692  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4693  case(corner)
4694  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4695  end select
4696  if(je .GT. domain%y(tme)%compute%end+jshift) call mpp_error( fatal, &
4697  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4698  else
4699  select case (position)
4700  case(east)
4701  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4702  case(corner)
4703  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4704  end select
4705  end if
4706  call insert_update_overlap( overlap, domain%list(m)%pe, &
4707  is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4708  else
4709  call insert_update_overlap( overlap, domain%list(m)%pe, &
4710  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4711  end if
4712  endif
4713 
4714  !recv_sw
4715  dir = 4
4716  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4717  jsd = domain%y(tme)%domain_data%begin; jed = domain%y(tme)%compute%begin-1
4718  is=isc; ie=iec; js=jsc; je=jec
4719  if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
4720  js = js-joff; je = je-joff
4721  end if
4722  call insert_update_overlap(overlap, domain%list(m)%pe, &
4723  is, ie, js, je, isd, ied, jsd, jed, dir)
4724 
4725  !recv_w
4726  dir = 5
4727  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4728  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4729  is=isc; ie=iec; js=jsc; je=jec
4730  call insert_update_overlap( overlap, domain%list(m)%pe, &
4731  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4732 
4733  !recv_nw
4734  dir = 6
4735  folded = .false.
4736  isd = domain%x(tme)%domain_data%begin; ied = domain%x(tme)%compute%begin-1
4737  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4738  is=isc; ie=iec; js=jsc; je=jec
4739  if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4740  js = js+joff; je = je+joff
4741  end if
4742  call insert_update_overlap( overlap, domain%list(m)%pe, &
4743  is, ie, js, je, isd, ied, jsd, jed, dir)
4744 
4745  !recv_n
4746  dir = 7
4747  folded = .false.
4748  isd = domain%x(tme)%compute%begin; ied = domain%x(tme)%compute%end+ishift
4749  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4750  is=isc; ie=iec; js=jsc; je=jec
4751  if( (position == east .OR. position == corner ) .AND. ( isd == ie .or. ied == is ) ) then
4752  !--- do nothing, this point will come from other pe
4753  else
4754  if( jed.GT.jeg .AND. je.LT.jsd)then
4755  js = js+joff; je = je+joff
4756  end if
4757  !--- when the east face is folded, the south halo points at
4758  !--- the position should be on CORNER or EAST
4759  if( ied == ieg .AND. (position == corner .OR. position == east) &
4760  .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4761  call insert_update_overlap( overlap, domain%list(m)%pe, &
4762  is, ie, js, je, isd, ied-1, jsd, jed, dir)
4763  is=isc; ie=iec; js=jsc; je=jec
4764  select case (position)
4765  case(east)
4766  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4767  case(corner)
4768  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4769  end select
4770  call insert_update_overlap( overlap, domain%list(m)%pe, &
4771  is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4772  else
4773  call insert_update_overlap( overlap, domain%list(m)%pe, &
4774  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4775  end if
4776  endif
4777 
4778  !recv_ne
4779  dir = 8
4780  folded = .false.
4781  isd = domain%x(tme)%compute%end+1+ishift; ied = domain%x(tme)%domain_data%end+ishift
4782  jsd = domain%y(tme)%compute%end+1+jshift; jed = domain%y(tme)%domain_data%end+jshift
4783  is=isc; ie=iec; js=jsc; je=jec
4784  if( ied.GT.ieg) then
4785  folded = .true.
4786  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4787  end if
4788  if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4789  js = js+joff; je = je+joff
4790  endif
4791 
4792  call insert_update_overlap( overlap, domain%list(m)%pe, &
4793  is, ie, js, je, isd, ied, jsd, jed, dir)
4794  !--- Now calculate the overlapping for fold-edge.
4795  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4796  !--- only position at EAST and CORNER need to be considered
4797  if( ( position == east .OR. position == corner) ) then
4798  !fold is within domain
4799  if( domain%x(tme)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tme)%domain_data%end+ishift )then
4800  dir = 1
4801  !--- calculating overlapping for receving on north
4802  if( domain%y(tme)%pos .GE. size(domain%y(tme)%list(:))/2 )then
4803  ied = domain%x(tme)%compute%end+ishift; isd = ied
4804  if( ied == ieg )then ! fold is within domain.
4805  jsd = domain%y(tme)%compute%begin; jed = domain%y(tme)%compute%end+jshift
4806  is=isc; ie=iec; js = jsc; je = jec
4807  select case (position)
4808  case(east)
4809  jsd = max(jsd, middle)
4810  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4811  case(corner)
4812  jsd = max(jsd, middle)
4813  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4814  end select
4815  call insert_update_overlap(overlap, domain%list(m)%pe, &
4816  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
4817  is = max(is, isd); ie = min(ie, ied)
4818  js = max(js, jsd); je = min(je, jed)
4819  if(debug_update_level .NE. no_check .AND. ie.GE.is .AND. je.GE.js )then
4820  nrecv_check = nrecv_check+1
4821  call allocate_check_overlap(checklist(nrecv_check), 1)
4822  call insert_check_overlap(checklist(nrecv_check), domain%list(m)%pe, &
4823  tme, 3, one_hundred_eighty, is, ie, js, je)
4824  endif
4825  endif
4826  endif
4827  endif
4828  endif
4829  endif
4830  !--- copy the overlapping information
4831  if( overlap%count > 0) then
4832  nrecv = nrecv + 1
4833  if(nrecv > maxlist) call mpp_error(fatal, &
4834  "mpp_domains_define.inc(compute_overlaps_east): nrecv is greater than MAXLIST, increase MAXLIST")
4835  call add_update_overlap( overlaplist(nrecv), overlap)
4836  call init_overlap_type(overlap)
4837  endif
4838  enddo ! end of recv do loop
4839 
4840  ! copy the overlapping information into domain
4841  if(nrecv>0) then
4842  update%nrecv = nrecv
4843  if (associated(update%recv)) deallocate(update%recv) !< Check if associated
4844  allocate(update%recv(nrecv))
4845  do m = 1, nrecv
4846  call add_update_overlap( update%recv(m), overlaplist(m) )
4847  do n = 1, update%recv(m)%count
4848  if(update%recv(m)%tileNbr(n) == domain%tile_id(tme)) then
4849  if(update%recv(m)%dir(n) == 1) domain%x(tme)%loffset = 0
4850  if(update%recv(m)%dir(n) == 7) domain%y(tme)%loffset = 0
4851  endif
4852  enddo
4853  enddo
4854  endif
4855 
4856  if(nrecv_check>0) then
4857  check%nrecv = nrecv_check
4858  if (associated(check%recv)) deallocate(check%recv) !< Check if associated
4859  allocate(check%recv(nrecv_check))
4860  do m = 1, nrecv_check
4861  call add_check_overlap( check%recv(m), checklist(m) )
4862  enddo
4863  endif
4864 
4865  call deallocate_overlap_type(overlap)
4866  do m = 1, maxlist
4867  call deallocate_overlap_type(overlaplist(m))
4868  if(debug_update_level .NE. no_check) call deallocate_overlap_type(checklist(m))
4869  enddo
4870 
4871  update=>null()
4872  check=>null()
4873 
4874  domain%initialized = .true.
4875 
4876  end subroutine compute_overlaps_fold_east
4877 
4878  !#####################################################################################
4879  subroutine get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4880  integer, intent(in) :: jsg, jeg, isg, jshift, position
4881  integer, intent(inout) :: is, ie, js, je
4882  integer :: i, j
4883 
4884  select case(position)
4885  case(center)
4886  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4887  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4888  case(east)
4889  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4890  i=is; is = 2*isg-ie; ie = 2*isg-i
4891  case(north)
4892  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4893  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4894  case(corner)
4895  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4896  i=is; is = 2*isg-ie; ie = 2*isg-i
4897  end select
4898 
4899  end subroutine get_fold_index_west
4900 
4901  !#####################################################################################
4902  subroutine get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4903  integer, intent(in) :: jsg, jeg, ieg, jshift, position
4904  integer, intent(inout) :: is, ie, js, je
4905  integer :: i, j
4906 
4907  select case(position)
4908  case(center)
4909  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4910  i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4911  case(east)
4912  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4913  i=is; is = 2*ieg-ie; ie = 2*ieg-i
4914  case(north)
4915  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4916  i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4917  case(corner)
4918  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4919  i=is; is = 2*ieg-ie; ie = 2*ieg-i
4920  end select
4921 
4922  end subroutine get_fold_index_east
4923 
4924  !#####################################################################################
4925  subroutine get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
4926  integer, intent(in) :: isg, ieg, jsg, ishift, position
4927  integer, intent(inout) :: is, ie, js, je
4928  integer :: i, j
4929 
4930  select case(position)
4931  case(center)
4932  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4933  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4934  case(east)
4935  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4936  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4937  case(north)
4938  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4939  j=js; js = 2*jsg-je; je = 2*jsg-j
4940  case(corner)
4941  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4942  j=js; js = 2*jsg-je; je = 2*jsg-j
4943  end select
4944 
4945  end subroutine get_fold_index_south
4946  !#####################################################################################
4947  subroutine get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
4948  integer, intent(in) :: isg, ieg, jeg, ishift, position
4949  integer, intent(inout) :: is, ie, js, je
4950  integer :: i, j
4951 
4952  select case(position)
4953  case(center)
4954  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4955  j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4956  case(east)
4957  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4958  j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4959  case(north)
4960  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4961  j=js; js = 2*jeg-je; je = 2*jeg-j
4962  case(corner)
4963  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4964  j=js; js = 2*jeg-je; je = 2*jeg-j
4965  end select
4966 
4967  end subroutine get_fold_index_north
4968 
4969 
4970  !#####################################################################################
4971  !> add offset to the index
4972  subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
4973  integer, intent(inout) :: lstart, lend
4974  integer, intent(in ) :: offset, gstart, gend, gsize
4975 
4976  lstart = lstart + offset
4977  if(lstart > gend) lstart = lstart - gsize
4978  if(lstart < gstart) lstart = lstart + gsize
4979  lend = lend + offset
4980  if(lend > gend) lend = lend - gsize
4981  if(lend < gstart) lend = lend + gsize
4982 
4983  return
4984 
4985  end subroutine apply_cyclic_offset
4986 
4987  !###################################################################################
4988  !> this routine sets up the overlapping for mpp_update_domains for arbitrary halo update.
4989  !! should be the halo size defined in mpp_define_domains.
4990  !! xhalo_out, yhalo_out should not be exactly the same as xhalo_in, yhalo_in
4991  !! currently we didn't consider about tripolar grid situation, because in the folded north
4992  !! region, the overlapping is specified through list of points, not through rectangular.
4993  !! But will return back to solve this problem in the future.
4994  subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
4995  type(domain2d), intent(in) :: domain
4996  type(overlapspec), intent(in) :: overlap_in
4997  type(overlapspec), intent(inout) :: overlap_out
4998  integer, intent(in) :: whalo_out, ehalo_out, shalo_out, nhalo_out
4999  integer :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation
5000  integer :: whalo_in, ehalo_in, shalo_in, nhalo_in
5001  integer :: dir
5002  type(overlap_type) :: overlap
5003  type(overlap_type), allocatable :: send(:), recv(:)
5004  type(overlap_type), pointer :: ptrIn => null()
5005  integer :: nsend, nrecv, nsend_in, nrecv_in
5006 
5007  if( domain%fold .NE. 0) call mpp_error(fatal, "mpp_domains_define.inc(set_overlaps):"// &
5008  & " folded domain is not implemented for arbitrary halo update, contact developer")
5009 
5010  whalo_in = domain%whalo
5011  ehalo_in = domain%ehalo
5012  shalo_in = domain%shalo
5013  nhalo_in = domain%nhalo
5014 
5015  if( .NOT. domain%initialized) call mpp_error(fatal, &
5016  "mpp_domains_define.inc: domain is not defined yet")
5017 
5018  nlist = size(domain%list(:))
5019  isoff = whalo_in - abs(whalo_out)
5020  ieoff = ehalo_in - abs(ehalo_out)
5021  jsoff = shalo_in - abs(shalo_out)
5022  jeoff = nhalo_in - abs(nhalo_out)
5023 
5024  nsend = 0
5025  nsend_in = overlap_in%nsend
5026  nrecv_in = overlap_in%nrecv
5027  if(nsend_in>0) allocate(send(nsend_in))
5028  if(nrecv_in>0) allocate(recv(nrecv_in))
5029  call allocate_update_overlap(overlap, maxoverlap)
5030 
5031  overlap_out%whalo = whalo_out
5032  overlap_out%ehalo = ehalo_out
5033  overlap_out%shalo = shalo_out
5034  overlap_out%nhalo = nhalo_out
5035  overlap_out%xbegin = overlap_in%xbegin
5036  overlap_out%xend = overlap_in%xend
5037  overlap_out%ybegin = overlap_in%ybegin
5038  overlap_out%yend = overlap_in%yend
5039 
5040  !--- setting up overlap.
5041  do m = 1, nsend_in
5042  ptrin => overlap_in%send(m)
5043  if(ptrin%count .LE. 0) call mpp_error(fatal, "mpp_domains_define.inc(set_overlaps):"// &
5044  " number of overlap for send should be a positive number for"//trim(domain%name) )
5045  do n = 1, ptrin%count
5046  dir = ptrin%dir(n)
5047  rotation = ptrin%rotation(n)
5048  select case(dir)
5049  case(1) ! to_pe's eastern halo
5050  if(ehalo_out > 0) then
5051  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, 0, n, dir, rotation)
5052  else if(ehalo_out<0) then
5053  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, 0, n, dir, rotation)
5054  end if
5055  case(2) ! to_pe's southeast halo
5056  if(ehalo_out>0 .AND. shalo_out > 0) then
5057  call set_single_overlap(ptrin, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation)
5058  else if(ehalo_out<0 .AND. shalo_out < 0) then ! three parts: southeast, south and east.
5059  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation)
5060  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation)
5061  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation)
5062  end if
5063  case(3) ! to_pe's southern halo
5064  if(shalo_out > 0) then
5065  call set_single_overlap(ptrin, overlap, 0, 0, jsoff, 0, n, dir, rotation)
5066  else if(shalo_out<0) then
5067  call set_single_overlap(ptrin, overlap, 0, 0, 0, shalo_out, n, dir, rotation)
5068  end if
5069  case(4) ! to_pe's southwest halo
5070  if(whalo_out>0 .AND. shalo_out > 0) then
5071  call set_single_overlap(ptrin, overlap, isoff, 0, jsoff, 0, n, dir, rotation)
5072  else if(whalo_out<0 .AND. shalo_out < 0) then
5073  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation)
5074  call set_single_overlap(ptrin, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation)
5075  call set_single_overlap(ptrin, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation)
5076  end if
5077  case(5) ! to_pe's western halo
5078  if(whalo_out > 0) then
5079  call set_single_overlap(ptrin, overlap, isoff, 0, 0, 0, n, dir, rotation)
5080  else if(whalo_out<0) then
5081  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, 0, n, dir, rotation)
5082  end if
5083  case(6) ! to_pe's northwest halo
5084  if(whalo_out>0 .AND. nhalo_out > 0) then
5085  call set_single_overlap(ptrin, overlap, isoff, 0, 0, -jeoff, n, dir, rotation)
5086  else if(whalo_out<0 .AND. nhalo_out < 0) then
5087  call set_single_overlap(ptrin, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation)
5088  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation)
5089  call set_single_overlap(ptrin, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation)
5090  end if
5091  case(7) ! to_pe's northern halo
5092  if(nhalo_out > 0) then
5093  call set_single_overlap(ptrin, overlap, 0, 0, 0, -jeoff, n, dir, rotation)
5094  else if(nhalo_out<0) then
5095  call set_single_overlap(ptrin, overlap, 0, 0, -nhalo_out, 0, n, dir, rotation)
5096  end if
5097  case(8) ! to_pe's northeast halo
5098  if(ehalo_out>0 .AND. nhalo_out > 0) then
5099  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation)
5100  else if(ehalo_out<0 .AND. nhalo_out < 0) then
5101  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation)
5102  call set_single_overlap(ptrin, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation)
5103  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation)
5104  end if
5105  end select
5106  end do ! do n = 1, ptrIn%count
5107  if(overlap%count>0) then
5108  nsend = nsend+1
5109  call add_update_overlap(send(nsend), overlap)
5110  call init_overlap_type(overlap)
5111  endif
5112  end do ! end do list = 0, nlist-1
5113 
5114  if(nsend>0) then
5115  overlap_out%nsend = nsend
5116  if (associated(overlap_out%send)) deallocate(overlap_out%send) !< Check if associated
5117  allocate(overlap_out%send(nsend));
5118  do n = 1, nsend
5119  call add_update_overlap(overlap_out%send(n), send(n) )
5120  enddo
5121  else
5122  overlap_out%nsend = 0
5123  endif
5124 
5125  !--------------------------------------------------
5126  ! recving
5127  !---------------------------------------------------
5128  overlap%count = 0
5129  nrecv = 0
5130  do m = 1, nrecv_in
5131  ptrin => overlap_in%recv(m)
5132  if(ptrin%count .LE. 0) call mpp_error(fatal, &
5133  "mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number")
5134  overlap%count = 0
5135  do n = 1, ptrin%count
5136  dir = ptrin%dir(n)
5137  rotation = ptrin%rotation(n)
5138  select case(dir)
5139  case(1) ! eastern halo
5140  if(ehalo_out > 0) then
5141  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, 0, n, dir)
5142  else if(ehalo_out<0) then
5143  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, 0, n, dir)
5144  end if
5145  case(2) ! southeast halo
5146  if(ehalo_out>0 .AND. shalo_out > 0) then
5147  call set_single_overlap(ptrin, overlap, 0, -ieoff, jsoff, 0, n, dir)
5148  else if(ehalo_out<0 .AND. shalo_out < 0) then
5149  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, shalo_out, n, dir)
5150  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1)
5151  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, shalo_out, n, dir+1)
5152  end if
5153  case(3) ! southern halo
5154  if(shalo_out > 0) then
5155  call set_single_overlap(ptrin, overlap, 0, 0, jsoff, 0, n, dir)
5156  else if(shalo_out<0) then
5157  call set_single_overlap(ptrin, overlap, 0, 0, 0, shalo_out, n, dir)
5158  end if
5159  case(4) ! southwest halo
5160  if(whalo_out>0 .AND. shalo_out > 0) then
5161  call set_single_overlap(ptrin, overlap, isoff, 0, jsoff, 0, n, dir)
5162  else if(whalo_out<0 .AND. shalo_out < 0) then
5163  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, shalo_out, n, dir)
5164  call set_single_overlap(ptrin, overlap, isoff, 0, 0, shalo_out, n, dir-1)
5165  call set_single_overlap(ptrin, overlap, 0, whalo_out, jsoff, 0, n, dir+1)
5166  end if
5167  case(5) ! western halo
5168  if(whalo_out > 0) then
5169  call set_single_overlap(ptrin, overlap, isoff, 0, 0, 0, n, dir)
5170  else if(whalo_out<0) then
5171  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, 0, n, dir)
5172  end if
5173  case(6) ! northwest halo
5174  if(whalo_out>0 .AND. nhalo_out > 0) then
5175  call set_single_overlap(ptrin, overlap, isoff, 0, 0, -jeoff, n, dir)
5176  else if(whalo_out<0 .AND. nhalo_out < 0) then
5177  call set_single_overlap(ptrin, overlap, 0, whalo_out, -nhalo_out, 0, n, dir)
5178  call set_single_overlap(ptrin, overlap, 0, whalo_out, 0, -jeoff, n, dir-1)
5179  call set_single_overlap(ptrin, overlap, isoff, 0, -nhalo_out, 0, n, dir+1)
5180  end if
5181  case(7) ! northern halo
5182  if(nhalo_out > 0) then
5183  call set_single_overlap(ptrin, overlap, 0, 0, 0, -jeoff, n, dir)
5184  else if(nhalo_out<0) then
5185  call set_single_overlap(ptrin, overlap, 0, 0, -nhalo_out, 0, n, dir)
5186  end if
5187  case(8) ! northeast halo
5188  if(ehalo_out>0 .AND. nhalo_out > 0) then
5189  call set_single_overlap(ptrin, overlap, 0, -ieoff, 0, -jeoff, n, dir)
5190  else if(ehalo_out<0 .AND. nhalo_out < 0) then
5191  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir)
5192  call set_single_overlap(ptrin, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1)
5193  call set_single_overlap(ptrin, overlap, -ehalo_out, 0, 0, -jeoff, n, 1)
5194  end if
5195  end select
5196  end do ! do n = 1, ptrIn%count
5197  if(overlap%count>0) then
5198  nrecv = nrecv+1
5199  call add_update_overlap(recv(nrecv), overlap)
5200  call init_overlap_type(overlap)
5201  endif
5202  end do ! end do list = 0, nlist-1
5203 
5204  if(nrecv>0) then
5205  overlap_out%nrecv = nrecv
5206  if (associated(overlap_out%recv)) deallocate(overlap_out%recv) !< Check if associated
5207  allocate(overlap_out%recv(nrecv));
5208  do n = 1, nrecv
5209  call add_update_overlap(overlap_out%recv(n), recv(n) )
5210  enddo
5211  else
5212  overlap_out%nrecv = 0
5213  endif
5214 
5215  call deallocate_overlap_type(overlap)
5216  do n = 1, nsend_in
5217  call deallocate_overlap_type(send(n))
5218  enddo
5219  do n = 1, nrecv_in
5220  call deallocate_overlap_type(recv(n))
5221  enddo
5222  if(allocated(send)) deallocate(send)
5223  if(allocated(recv)) deallocate(recv)
5224  ptrin => null()
5225 
5226  call set_domain_comm_inf(overlap_out)
5227 
5228 
5229  end subroutine set_overlaps
5230 
5231  !##############################################################################
5232  subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation)
5233  type(overlap_type), intent(in) :: overlap_in
5234  type(overlap_type), intent(inout) :: overlap_out
5235  integer, intent(in) :: isoff, jsoff, ieoff, jeoff
5236  integer, intent(in) :: index
5237  integer, intent(in) :: dir
5238  integer, optional, intent(in) :: rotation
5239  integer :: rotate
5240  integer :: count
5241 
5242  if( overlap_out%pe == null_pe ) then
5243  overlap_out%pe = overlap_in%pe
5244  else
5245  if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(fatal, &
5246  "mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out")
5247  endif
5248 
5249  if(isoff .NE. 0 .and. ieoff .NE. 0) call mpp_error(fatal, &
5250  "mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero")
5251  if(jsoff .NE. 0 .and. jeoff .NE. 0) call mpp_error(fatal, &
5252  "mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero")
5253 
5254 
5255  overlap_out%count = overlap_out%count + 1
5256  count = overlap_out%count
5257  if(count > maxoverlap) call mpp_error(fatal, &
5258  "set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
5259  rotate = zero
5260  if(present(rotation)) rotate = rotation
5261  overlap_out%rotation (count) = overlap_in%rotation(index)
5262  overlap_out%dir (count) = dir
5263  overlap_out%tileMe (count) = overlap_in%tileMe(index)
5264  overlap_out%tileNbr (count) = overlap_in%tileNbr(index)
5265 
5266  select case(rotate)
5267  case(zero)
5268  overlap_out%is(count) = overlap_in%is(index) + isoff
5269  overlap_out%ie(count) = overlap_in%ie(index) + ieoff
5270  overlap_out%js(count) = overlap_in%js(index) + jsoff
5271  overlap_out%je(count) = overlap_in%je(index) + jeoff
5272  case(ninety)
5273  overlap_out%is(count) = overlap_in%is(index) - jeoff
5274  overlap_out%ie(count) = overlap_in%ie(index) - jsoff
5275  overlap_out%js(count) = overlap_in%js(index) + isoff
5276  overlap_out%je(count) = overlap_in%je(index) + ieoff
5277  case(minus_ninety)
5278  overlap_out%is(count) = overlap_in%is(index) + jsoff
5279  overlap_out%ie(count) = overlap_in%ie(index) + jeoff
5280  overlap_out%js(count) = overlap_in%js(index) - ieoff
5281  overlap_out%je(count) = overlap_in%je(index) - isoff
5282  case default
5283  call mpp_error(fatal, "mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY")
5284  end select
5285 
5286  end subroutine set_single_overlap
5287 
5288  !###################################################################################
5289  !> compute the overlapping between tiles for the T-cell.
5290  subroutine define_contact_point( domain, position, num_contact, tile1, tile2, align1, align2, &
5291  refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5292  isgList, iegList, jsgList, jegList )
5293  type(domain2d), intent(inout) :: domain
5294  integer, intent(in) :: position
5295  integer, intent(in) :: num_contact !< number of contact regions
5296  integer, dimension(:), intent(in) :: tile1, tile2 !< tile number
5297  integer, dimension(:), intent(in) :: align1, align2 !< align direction of contact region
5298  real, dimension(:), intent(in) :: refine1, refine2 !< refinement between tiles
5299  integer, dimension(:), intent(in) :: istart1, iend1 !< i-index in tile_1 of contact region
5300  integer, dimension(:), intent(in) :: jstart1, jend1 !< j-index in tile_1 of contact region
5301  integer, dimension(:), intent(in) :: istart2, iend2 !< i-index in tile_2 of contact region
5302  integer, dimension(:), intent(in) :: jstart2, jend2 !< j-index in tile_2 of contact region
5303  integer, dimension(:), intent(in) :: isgList, iegList !< i-global domain of each tile
5304  integer, dimension(:), intent(in) :: jsgList, jegList !< j-global domain of each tile
5305 
5306  integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
5307  integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2
5308  integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2
5309  integer :: is, ie, js, je, ioff, joff
5310  integer :: ntiles, max_contact
5311  integer :: nlist, list, m, n, l, count, numS, numR
5312  integer :: whalo, ehalo, shalo, nhalo
5313  integer :: t1, t2, tt, pos
5314  integer :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir
5315  integer :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem
5316  integer :: dirlist(8)
5317  !--- is2Send and is1Send will figure out the overlapping for sending from current pe.
5318  !--- is1Recv and iscREcv will figure out the overlapping for recving onto current pe.
5319  integer, dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send
5320  integer, dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send
5321  integer, dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv
5322  integer, dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv
5323  integer, dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send
5324  real, dimension(4*num_contact) :: refineRecv, refineSend
5325  integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
5326  integer :: nsend, nrecv, nsend2, nrecv2
5327  type(contact_type), dimension(domain%ntiles) :: eCont, wCont, sCont, nCont
5328  type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
5329  integer :: iunit
5330 
5331  if( position .NE. center ) call mpp_error(fatal, "mpp_domains_define.inc: " //&
5332  "routine define_contact_point can only be used to calculate overlapping for cell center.")
5333 
5334  ntiles = domain%ntiles
5335 
5336  econt(:)%ncontact = 0
5337 
5338  do n = 1, ntiles
5339  econt(n)%ncontact = 0; scont(n)%ncontact = 0; wcont(n)%ncontact = 0; ncont(n)%ncontact = 0;
5340  allocate(econt(n)%tile(num_contact), wcont(n)%tile(num_contact) )
5341  allocate(ncont(n)%tile(num_contact), scont(n)%tile(num_contact) )
5342  allocate(econt(n)%align1(num_contact), econt(n)%align2(num_contact) )
5343  allocate(wcont(n)%align1(num_contact), wcont(n)%align2(num_contact) )
5344  allocate(scont(n)%align1(num_contact), scont(n)%align2(num_contact) )
5345  allocate(ncont(n)%align1(num_contact), ncont(n)%align2(num_contact) )
5346  allocate(econt(n)%refine1(num_contact), econt(n)%refine2(num_contact) )
5347  allocate(wcont(n)%refine1(num_contact), wcont(n)%refine2(num_contact) )
5348  allocate(scont(n)%refine1(num_contact), scont(n)%refine2(num_contact) )
5349  allocate(ncont(n)%refine1(num_contact), ncont(n)%refine2(num_contact) )
5350  allocate(econt(n)%is1(num_contact), econt(n)%ie1(num_contact), econt(n)%js1(num_contact), &
5351  & econt(n)%je1(num_contact))
5352  allocate(econt(n)%is2(num_contact), econt(n)%ie2(num_contact), econt(n)%js2(num_contact), &
5353  & econt(n)%je2(num_contact))
5354  allocate(wcont(n)%is1(num_contact), wcont(n)%ie1(num_contact), wcont(n)%js1(num_contact), &
5355  & wcont(n)%je1(num_contact))
5356  allocate(wcont(n)%is2(num_contact), wcont(n)%ie2(num_contact), wcont(n)%js2(num_contact), &
5357  & wcont(n)%je2(num_contact))
5358  allocate(scont(n)%is1(num_contact), scont(n)%ie1(num_contact), scont(n)%js1(num_contact), &
5359  & scont(n)%je1(num_contact))
5360  allocate(scont(n)%is2(num_contact), scont(n)%ie2(num_contact), scont(n)%js2(num_contact), &
5361  & scont(n)%je2(num_contact))
5362  allocate(ncont(n)%is1(num_contact), ncont(n)%ie1(num_contact), ncont(n)%js1(num_contact), &
5363  & ncont(n)%je1(num_contact))
5364  allocate(ncont(n)%is2(num_contact), ncont(n)%ie2(num_contact), ncont(n)%js2(num_contact), &
5365  & ncont(n)%je2(num_contact))
5366  end do
5367 
5368  !--- set up the east, south, west and north contact for each tile.
5369  do n = 1, num_contact
5370  t1 = tile1(n)
5371  t2 = tile2(n)
5372  select case(align1(n))
5373  case (east)
5374  call fill_contact( econt(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5375  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5376  case (west)
5377  call fill_contact( wcont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5378  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5379  case (south)
5380  call fill_contact( scont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5381  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5382  case (north)
5383  call fill_contact( ncont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5384  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5385  end select
5386  select case(align2(n))
5387  case (east)
5388  call fill_contact( econt(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5389  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5390  case (west)
5391  call fill_contact( wcont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5392  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5393  case (south)
5394  call fill_contact( scont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5395  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5396  case (north)
5397  call fill_contact( ncont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5398  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5399  end select
5400  end do
5401 
5402  !--- the tile number of current pe, halo size
5403  whalo = domain%whalo
5404  ehalo = domain%ehalo
5405  shalo = domain%shalo
5406  nhalo = domain%nhalo
5407 
5408  !--- find if there is an extra point in x and y direction depending on position
5409  nlist = size(domain%list(:))
5410 
5411  max_contact = 4*num_contact ! should be enough
5412 
5413  ntileme = size(domain%x(:))
5414  refinesend = 1; refinerecv = 1
5415 
5416  !--------------------------------------------------------------------------------------------------
5417  ! loop over each tile on current domain to set up the overlapping for each tile
5418  !--------------------------------------------------------------------------------------------------
5419  !--- first check the overlap within the tiles.
5420  do n = 1, domain%update_T%nsend
5421  pos = domain%update_T%send(n)%pe - mpp_root_pe()
5422  call add_update_overlap(overlapsend(pos), domain%update_T%send(n) )
5423  enddo
5424  do n = 1, domain%update_T%nrecv
5425  pos = domain%update_T%recv(n)%pe - mpp_root_pe()
5426  call add_update_overlap(overlaprecv(pos), domain%update_T%recv(n) )
5427  enddo
5428 
5429  call mpp_get_memory_domain(domain, ism, iem, jsm, jem)
5430  domain%update_T%xbegin = ism; domain%update_T%xend = iem
5431  domain%update_T%ybegin = jsm; domain%update_T%yend = jem
5432  domain%update_T%whalo = whalo; domain%update_T%ehalo = ehalo
5433  domain%update_T%shalo = shalo; domain%update_T%nhalo = nhalo
5434 
5435  do tme = 1, ntileme
5436  tileme = domain%tile_id(tme)
5437  rotatesend = zero; rotaterecv = zero
5438 
5439  !--- loop over all the contact region to figure out the index for overlapping region.
5440  count = 0
5441  do n = 1, econt(tileme)%ncontact ! east contact
5442  count = count+1
5443  tilerecv(count) = econt(tileme)%tile(n); tilesend(count) = econt(tileme)%tile(n)
5444  align1recv(count) = econt(tileme)%align1(n); align2recv(count) = econt(tileme)%align2(n)
5445  align1send(count) = econt(tileme)%align1(n); align2send(count) = econt(tileme)%align2(n)
5446  refinesend(count) = econt(tileme)%refine2(n); refinerecv(count) = econt(tileme)%refine1(n)
5447  is1recv(count) = econt(tileme)%is1(n) + 1; ie1recv(count) = is1recv(count) + ehalo - 1
5448  js1recv(count) = econt(tileme)%js1(n); je1recv(count) = econt(tileme)%je1(n)
5449  select case(econt(tileme)%align2(n))
5450  case ( west ) ! w <-> e
5451  is2recv(count) = econt(tileme)%is2(n); ie2recv(count) = is2recv(count) + ehalo - 1
5452  js2recv(count) = econt(tileme)%js2(n); je2recv(count) = econt(tileme)%je2(n)
5453  ie1send(count) = econt(tileme)%is1(n); is1send(count) = ie1send(count) - whalo + 1
5454  js1send(count) = econt(tileme)%js1(n); je1send(count) = econt(tileme)%je1(n)
5455  ie2send(count) = econt(tileme)%is2(n) - 1; is2send(count) = ie2send(count) - whalo + 1
5456  js2send(count) = econt(tileme)%js2(n); je2send(count) = econt(tileme)%je2(n)
5457  case ( south ) ! s <-> e
5458  rotaterecv(count) = ninety; rotatesend(count) = minus_ninety
5459  js2recv(count) = econt(tileme)%js2(n); je2recv(count) = js2recv(count) + ehalo -1
5460  is2recv(count) = econt(tileme)%is2(n); ie2recv(count) = econt(tileme)%ie2(n)
5461  ie1send(count) = econt(tileme)%is1(n); is1send(count) = ie1send(count) - shalo + 1
5462  js1send(count) = econt(tileme)%js1(n); je1send(count) = econt(tileme)%je1(n)
5463  is2send(count) = econt(tileme)%is2(n); ie2send(count) = econt(tileme)%ie2(n)
5464  je2send(count) = econt(tileme)%js2(n) - 1; js2send(count) = je2send(count) - shalo + 1
5465  end select
5466  end do
5467 
5468  do n = 1, scont(tileme)%ncontact ! south contact
5469  count = count+1
5470  tilerecv(count) = scont(tileme)%tile(n); tilesend(count) = scont(tileme)%tile(n)
5471  align1recv(count) = scont(tileme)%align1(n); align2recv(count) = scont(tileme)%align2(n);
5472  align1send(count) = scont(tileme)%align1(n); align2send(count) = scont(tileme)%align2(n);
5473  refinesend(count) = scont(tileme)%refine2(n); refinerecv(count) = scont(tileme)%refine1(n)
5474  is1recv(count) = scont(tileme)%is1(n); ie1recv(count) = scont(tileme)%ie1(n)
5475  je1recv(count) = scont(tileme)%js1(n) - 1; js1recv(count) = je1recv(count) - shalo + 1
5476  select case(scont(tileme)%align2(n))
5477  case ( north ) ! n <-> s
5478  is2recv(count) = scont(tileme)%is2(n); ie2recv(count) = scont(tileme)%ie2(n)
5479  je2recv(count) = scont(tileme)%je2(n); js2recv(count) = je2recv(count) - shalo + 1
5480  is1send(count) = scont(tileme)%is1(n); ie1send(count) = scont(tileme)%ie1(n)
5481  js1send(count) = scont(tileme)%js1(n); je1send(count) = js1send(count) + nhalo -1
5482  is2send(count) = scont(tileme)%is2(n); ie2send(count) = scont(tileme)%ie2(n)
5483  js2send(count) = scont(tileme)%je2(n)+1; je2send(count) = js2send(count) + nhalo - 1
5484  case ( east ) ! e <-> s
5485  rotaterecv(count) = minus_ninety; rotatesend(count) = ninety
5486  ie2recv(count) = scont(tileme)%ie2(n); is2recv(count) = ie2recv(count) - shalo + 1
5487  js2recv(count) = scont(tileme)%js2(n); je2recv(count) = scont(tileme)%je2(n)
5488  is1send(count) = scont(tileme)%is1(n); ie1send(count) = scont(tileme)%ie1(n)
5489  js1send(count) = scont(tileme)%js1(n); je1send(count) = js1send(count) + ehalo - 1
5490  is2send(count) = scont(tileme)%ie2(n)+1; ie2send(count) = is2send(count) + ehalo - 1
5491  js2send(count) = scont(tileme)%js2(n); je2send(count) = scont(tileme)%je2(n)
5492  end select
5493  end do
5494 
5495  do n = 1, wcont(tileme)%ncontact ! west contact
5496  count = count+1
5497  tilerecv(count) = wcont(tileme)%tile(n); tilesend(count) = wcont(tileme)%tile(n)
5498  align1recv(count) = wcont(tileme)%align1(n); align2recv(count) = wcont(tileme)%align2(n);
5499  align1send(count) = wcont(tileme)%align1(n); align2send(count) = wcont(tileme)%align2(n);
5500  refinesend(count) = wcont(tileme)%refine2(n); refinerecv(count) = wcont(tileme)%refine1(n)
5501  ie1recv(count) = wcont(tileme)%is1(n) - 1; is1recv(count) = ie1recv(count) - whalo + 1
5502  js1recv(count) = wcont(tileme)%js1(n); je1recv(count) = wcont(tileme)%je1(n)
5503  select case(wcont(tileme)%align2(n))
5504  case ( east ) ! e <-> w
5505  ie2recv(count) = wcont(tileme)%ie2(n); is2recv(count) = ie2recv(count) - whalo + 1
5506  js2recv(count) = wcont(tileme)%js2(n); je2recv(count) = wcont(tileme)%je2(n)
5507  is1send(count) = wcont(tileme)%is1(n); ie1send(count) = is1send(count) + ehalo - 1
5508  js1send(count) = wcont(tileme)%js1(n); je1send(count) = wcont(tileme)%je1(n)
5509  is2send(count) = wcont(tileme)%ie2(n)+1; ie2send(count) = is2send(count) + ehalo - 1
5510  js2send(count) = wcont(tileme)%js2(n); je2send(count) = wcont(tileme)%je2(n)
5511  case ( north ) ! n <-> w
5512  rotaterecv(count) = ninety; rotatesend(count) = minus_ninety
5513  je2recv(count) = wcont(tileme)%je2(n); js2recv(count) = je2recv(count) - whalo + 1
5514  is2recv(count) = wcont(tileme)%is2(n); ie2recv(count) = wcont(tileme)%ie2(n)
5515  is1send(count) = wcont(tileme)%is1(n); ie1send(count) = is1send(count) + nhalo - 1
5516  js1send(count) = wcont(tileme)%js1(n); je1send(count) = wcont(tileme)%je1(n)
5517  js2send(count) = wcont(tileme)%je2(n)+1; je2send(count) = js2send(count) + nhalo - 1
5518  is2send(count) = wcont(tileme)%is2(n); ie2send(count) = wcont(tileme)%ie2(n)
5519  end select
5520  end do
5521 
5522  do n = 1, ncont(tileme)%ncontact ! north contact
5523  count = count+1
5524  tilerecv(count) = ncont(tileme)%tile(n); tilesend(count) = ncont(tileme)%tile(n)
5525  align1recv(count) = ncont(tileme)%align1(n); align2recv(count) = ncont(tileme)%align2(n);
5526  align1send(count) = ncont(tileme)%align1(n); align2send(count) = ncont(tileme)%align2(n);
5527  refinesend(count) = ncont(tileme)%refine2(n); refinerecv(count) = ncont(tileme)%refine1(n)
5528  is1recv(count) = ncont(tileme)%is1(n); ie1recv(count) = ncont(tileme)%ie1(n)
5529  js1recv(count) = ncont(tileme)%je1(n)+1; je1recv(count) = js1recv(count) + nhalo - 1
5530  select case(ncont(tileme)%align2(n))
5531  case ( south ) ! s <-> n
5532  is2recv(count) = ncont(tileme)%is2(n); ie2recv(count) = ncont(tileme)%ie2(n)
5533  js2recv(count) = ncont(tileme)%js2(n); je2recv(count) = js2recv(count) + nhalo - 1
5534  is1send(count) = ncont(tileme)%is1(n); ie1send(count) = ncont(tileme)%ie1(n)
5535  je1send(count) = ncont(tileme)%je1(n); js1send(count) = je1send(count) - shalo + 1
5536  is2send(count) = ncont(tileme)%is2(n); ie2send(count) = ncont(tileme)%ie2(n)
5537  je2send(count) = ncont(tileme)%js2(n)-1; js2send(count) = je2send(count) - shalo + 1
5538  case ( west ) ! w <-> n
5539  rotaterecv(count) = minus_ninety; rotatesend(count) = ninety
5540  is2recv(count) = ncont(tileme)%ie2(n); ie2recv(count) = is2recv(count) + nhalo - 1
5541  js2recv(count) = ncont(tileme)%js2(n); je2recv(count) = ncont(tileme)%je2(n)
5542  is1send(count) = ncont(tileme)%is1(n); ie1send(count) = ncont(tileme)%ie1(n)
5543  je1send(count) = ncont(tileme)%je1(n); js1send(count) = je1send(count) - whalo + 1
5544  ie2send(count) = ncont(tileme)%is2(n)-1; is2send(count) = ie2send(count) - whalo + 1
5545  js2send(count) = ncont(tileme)%js2(n); je2send(count) = ncont(tileme)%je2(n)
5546  end select
5547  end do
5548 
5549  nums = count
5550  numr = count
5551  !--- figure out the index for corner overlapping,
5552  !--- fill_corner_contact will be updated to deal with the situation that there are multiple tiles on
5553  !--- each side of six sides of cubic grid.
5554  if(.NOT. domain%rotated_ninety) then
5555  call fill_corner_contact(econt, scont, wcont, ncont, isglist, ieglist, jsglist, jeglist, numr, nums, &
5556  tilerecv, tilesend, is1recv, ie1recv, js1recv, je1recv, is2recv, ie2recv, &
5557  js2recv, je2recv, is1send, ie1send, js1send, je1send, is2send, ie2send, &
5558  js2send, je2send, align1recv, align2recv, align1send, align2send, &
5559  whalo, ehalo, shalo, nhalo, tileme )
5560  end if
5561 
5562  isc = domain%x(tme)%compute%begin; iec = domain%x(tme)%compute%end
5563  jsc = domain%y(tme)%compute%begin; jec = domain%y(tme)%compute%end
5564 
5565  !--- compute the overlapping for send.
5566  do n = 1, nums
5567  do list = 0, nlist-1
5568  m = mod( domain%pos+list, nlist )
5569  ntilenbr = size(domain%list(m)%x(:))
5570  do tnbr = 1, ntilenbr
5571  if( domain%list(m)%tile_id(tnbr) .NE. tilesend(n) ) cycle
5572  isc1 = max(isc, is1send(n)); iec1 = min(iec, ie1send(n))
5573  jsc1 = max(jsc, js1send(n)); jec1 = min(jec, je1send(n))
5574  if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle
5575  !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5576  do dir = 1, 8
5577  !--- get the to_pe's data domain.
5578  select case ( dir )
5579  case ( 1 ) ! eastern halo
5580  if( align2send(n) .NE. east ) cycle
5581  isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5582  jsd = domain%list(m)%y(tnbr)%compute%begin; jed = domain%list(m)%y(tnbr)%compute%end
5583  case ( 2 ) ! southeast halo
5584  isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5585  jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5586  case ( 3 ) ! southern halo
5587  if( align2send(n) .NE. south ) cycle
5588  isd = domain%list(m)%x(tnbr)%compute%begin; ied = domain%list(m)%x(tnbr)%compute%end
5589  jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5590  case ( 4 ) ! southwest halo
5591  isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5592  jsd = domain%list(m)%y(tnbr)%compute%begin-shalo; jed = domain%list(m)%y(tnbr)%compute%begin-1
5593  case ( 5 ) ! western halo
5594  if( align2send(n) .NE. west ) cycle
5595  isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5596  jsd = domain%list(m)%y(tnbr)%compute%begin; jed = domain%list(m)%y(tnbr)%compute%end
5597  case ( 6 ) ! northwest halo
5598  isd = domain%list(m)%x(tnbr)%compute%begin-whalo; ied = domain%list(m)%x(tnbr)%compute%begin-1
5599  jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5600  case ( 7 ) ! northern halo
5601  if( align2send(n) .NE. north ) cycle
5602  isd = domain%list(m)%x(tnbr)%compute%begin; ied = domain%list(m)%x(tnbr)%compute%end
5603  jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5604  case ( 8 ) ! northeast halo
5605  isd = domain%list(m)%x(tnbr)%compute%end+1; ied = domain%list(m)%x(tnbr)%compute%end+ehalo
5606  jsd = domain%list(m)%y(tnbr)%compute%end+1; jed = domain%list(m)%y(tnbr)%compute%end+nhalo
5607  end select
5608  isd = max(isd, is2send(n)); ied = min(ied, ie2send(n))
5609  jsd = max(jsd, js2send(n)); jed = min(jed, je2send(n))
5610  if( isd > ied .OR. jsd > jed ) cycle
5611  ioff = 0; joff = 0
5612  nxd = ied - isd + 1
5613  nyd = jed - jsd + 1
5614  select case ( align2send(n) )
5615  case ( west, east )
5616  ioff = isd - is2send(n)
5617  joff = jsd - js2send(n)
5618  case ( south, north )
5619  ioff = isd - is2send(n)
5620  joff = jsd - js2send(n)
5621  end select
5622 
5623  !--- get the index in current pe.
5624  select case ( rotatesend(n) )
5625  case ( zero )
5626  isc2 = is1send(n) + ioff; iec2 = isc2 + nxd - 1
5627  jsc2 = js1send(n) + joff; jec2 = jsc2 + nyd - 1
5628  case ( ninety ) ! N -> W or S -> E
5629  iec2 = ie1send(n) - joff; isc2 = iec2 - nyd + 1
5630  jsc2 = js1send(n) + ioff; jec2 = jsc2 + nxd - 1
5631  case ( minus_ninety ) ! W -> N or E -> S
5632  isc2 = is1send(n) + joff; iec2 = isc2 + nyd - 1
5633  jec2 = je1send(n) - ioff; jsc2 = jec2 - nxd + 1
5634  end select
5635  is = max(isc1,isc2); ie = min(iec1,iec2)
5636  js = max(jsc1,jsc2); je = min(jec1,jec2)
5637  if(ie.GE.is .AND. je.GE.js )then
5638  if(.not. associated(overlapsend(m)%tileMe)) call allocate_update_overlap(overlapsend(m), &
5639  & maxoverlap)
5640  call insert_overlap_type(overlapsend(m), domain%list(m)%pe, tme, tnbr, &
5641  is, ie, js, je, dir, rotatesend(n), .true. )
5642  endif
5643  end do ! end do dir = 1, 8
5644  end do ! end do tNbr = 1, ntileNbr
5645  end do ! end do list = 0, nlist-1
5646  end do ! end do n = 1, numS
5647 
5648  !--- compute the overlapping for recv.
5649  do n = 1, numr
5650  do list = 0, nlist-1
5651  m = mod( domain%pos+nlist-list, nlist )
5652  ntilenbr = size(domain%list(m)%x(:))
5653  do tnbr = 1, ntilenbr
5654  if( domain%list(m)%tile_id(tnbr) .NE. tilerecv(n) ) cycle
5655  isc = domain%list(m)%x(tnbr)%compute%begin; iec = domain%list(m)%x(tnbr)%compute%end
5656  jsc = domain%list(m)%y(tnbr)%compute%begin; jec = domain%list(m)%y(tnbr)%compute%end
5657  isc = max(isc, is2recv(n)); iec = min(iec, ie2recv(n))
5658  jsc = max(jsc, js2recv(n)); jec = min(jec, je2recv(n))
5659  if( isc > iec .OR. jsc > jec ) cycle
5660  !--- find the offset for this overlapping.
5661  ioff = 0; joff = 0
5662  nxc = iec - isc + 1; nyc = jec - jsc + 1
5663  select case ( align2recv(n) )
5664  case ( west, east )
5665  if(align2recv(n) == west) then
5666  ioff = isc - is2recv(n)
5667  else
5668  ioff = ie2recv(n) - iec
5669  endif
5670  joff = jsc - js2recv(n)
5671  case ( north, south )
5672  ioff = isc - is2recv(n)
5673  if(align2recv(n) == south) then
5674  joff = jsc - js2recv(n)
5675  else
5676  joff = je2recv(n) - jec
5677  endif
5678  end select
5679 
5680  !--- get the index in current pe.
5681  select case ( rotaterecv(n) )
5682  case ( zero )
5683  isd1 = is1recv(n) + ioff; ied1 = isd1 + nxc - 1
5684  jsd1 = js1recv(n) + joff; jed1 = jsd1 + nyc - 1
5685  if( align1recv(n) == west ) then
5686  ied1 = ie1recv(n)-ioff; isd1 = ied1 - nxc + 1
5687  endif
5688  if( align1recv(n) == south ) then
5689  jed1 = je1recv(n)-joff; jsd1 = jed1 - nyc + 1
5690  endif
5691  case ( ninety ) ! N -> W or S -> E
5692  if( align1recv(n) == west ) then
5693  ied1 = ie1recv(n)-joff; isd1 = ied1 - nyc + 1
5694  else
5695  isd1 = is1recv(n)+joff; ied1 = isd1 + nyc - 1
5696  endif
5697  jed1 = je1recv(n) - ioff; jsd1 = jed1 - nxc + 1
5698  case ( minus_ninety ) ! W -> N or E -> S
5699  ied1 = ie1recv(n) - joff; isd1 = ied1 - nyc + 1
5700  if( align1recv(n) == south ) then
5701  jed1 = je1recv(n)-ioff; jsd1 = jed1 - nxc + 1
5702  else
5703  jsd1 = js1recv(n)+ioff; jed1 = jsd1 + nxc - 1
5704  endif
5705  end select
5706 
5707  !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5708  do dir = 1, 8
5709  select case ( dir )
5710  case ( 1 ) ! eastern halo
5711  if( align1recv(n) .NE. east ) cycle
5712  isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5713  jsd2 = domain%y(tme)%compute%begin; jed2 = domain%y(tme)%compute%end
5714  case ( 2 ) ! southeast halo
5715  isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5716  jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5717  case ( 3 ) ! southern halo
5718  if( align1recv(n) .NE. south ) cycle
5719  isd2 = domain%x(tme)%compute%begin; ied2 = domain%x(tme)%compute%end
5720  jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5721  case ( 4 ) ! southwest halo
5722  isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5723  jsd2 = domain%y(tme)%domain_data%begin; jed2 = domain%y(tme)%compute%begin-1
5724  case ( 5 ) ! western halo
5725  if( align1recv(n) .NE. west ) cycle
5726  isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5727  jsd2 = domain%y(tme)%compute%begin; jed2 = domain%y(tme)%compute%end
5728  case ( 6 ) ! northwest halo
5729  isd2 = domain%x(tme)%domain_data%begin; ied2 = domain%x(tme)%compute%begin-1
5730  jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5731  case ( 7 ) ! northern halo
5732  if( align1recv(n) .NE. north ) cycle
5733  isd2 = domain%x(tme)%compute%begin; ied2 = domain%x(tme)%compute%end
5734  jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5735  case ( 8 ) ! northeast halo
5736  isd2 = domain%x(tme)%compute%end+1; ied2 = domain%x(tme)%domain_data%end
5737  jsd2 = domain%y(tme)%compute%end+1; jed2 = domain%y(tme)%domain_data%end
5738  end select
5739  is = max(isd1,isd2); ie = min(ied1,ied2)
5740  js = max(jsd1,jsd2); je = min(jed1,jed2)
5741  if(ie.GE.is .AND. je.GE.js )then
5742  if(.not. associated(overlaprecv(m)%tileMe)) call allocate_update_overlap(overlaprecv(m), &
5743  & maxoverlap)
5744  call insert_overlap_type(overlaprecv(m), domain%list(m)%pe, tme, tnbr, &
5745  is, ie, js, je, dir, rotaterecv(n), .true.)
5746  count = overlaprecv(m)%count
5747  endif
5748  end do ! end do dir = 1, 8
5749  end do ! end do tNbr = 1, ntileNbr
5750  end do ! end do list = 0, nlist-1
5751  end do ! end do n = 1, numR
5752  end do ! end do tMe = 1, ntileMe
5753 
5754  !--- copy the overlapping information into domain data
5755  nsend = 0; nsend2 = 0
5756  do list = 0, nlist-1
5757  m = mod( domain%pos+list, nlist )
5758  if(overlapsend(m)%count>0) nsend = nsend + 1
5759  enddo
5760 
5761  if(debug_message_passing) then
5762  !--- write out send information
5763  iunit = mpp_pe() + 1000
5764  do list = 0, nlist-1
5765  m = mod( domain%pos+list, nlist )
5766  if(overlapsend(m)%count==0) cycle
5767  write(iunit, *) "********to_pe = " ,overlapsend(m)%pe, " count = ",overlapsend(m)%count
5768  do n = 1, overlapsend(m)%count
5769  write(iunit, *) overlapsend(m)%is(n), overlapsend(m)%ie(n), overlapsend(m)%js(n), overlapsend(m)%je(n), &
5770  overlapsend(m)%dir(n), overlapsend(m)%rotation(n)
5771  enddo
5772  enddo
5773  if(nsend >0) flush(iunit)
5774  endif
5775 
5776  dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
5777  dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
5778 
5779  ! copy the overlap information into domain.
5780  if(nsend >0) then
5781  if(associated(domain%update_T%send)) then
5782  do m = 1, domain%update_T%nsend
5783  call deallocate_overlap_type(domain%update_T%send(m))
5784  enddo
5785  deallocate(domain%update_T%send)
5786  endif
5787  domain%update_T%nsend = nsend
5788  allocate(domain%update_T%send(nsend))
5789  do list = 0, nlist-1
5790  m = mod( domain%pos+list, nlist )
5791  ntilenbr = size(domain%list(m)%x(:))
5792  !--- for the send, the list should be in tileNbr order and dir order to be consistent with Recv
5793  if(overlapsend(m)%count > 0) then
5794  nsend2 = nsend2+1
5795  if(nsend2>nsend) call mpp_error(fatal, &
5796  "mpp_domains_define.inc(define_contact_point): nsend2 is greater than nsend")
5797  call allocate_update_overlap(domain%update_T%send(nsend2), overlapsend(m)%count)
5798 
5799  do tnbr = 1, ntilenbr
5800  do tt = 1, ntileme
5801  if(domain%list(m)%pe == domain%pe) then ! own processor
5802  tme = tnbr+tt-1
5803  if(tme > ntileme) tme = tme - ntileme
5804  else
5805  tme = tt
5806  end if
5807  do n = 1, 8 ! loop over 8 direction
5808  do l = 1, overlapsend(m)%count
5809  if(overlapsend(m)%tileMe(l) .NE. tme) cycle
5810  if(overlapsend(m)%tileNbr(l) .NE. tnbr) cycle
5811  if(overlapsend(m)%dir(l) .NE. dirlist(n) ) cycle
5812  call insert_overlap_type(domain%update_T%send(nsend2), overlapsend(m)%pe, &
5813  overlapsend(m)%tileMe(l), overlapsend(m)%tileNbr(l), overlapsend(m)%is(l), &
5814  overlapsend(m)%ie(l), overlapsend(m)%js(l), overlapsend(m)%je(l), overlapsend(m)%dir(l),&
5815  overlapsend(m)%rotation(l), overlapsend(m)%from_contact(l) )
5816  end do
5817  end do
5818  end do
5819  end do
5820  end if
5821  enddo
5822  endif
5823 
5824  if(nsend2 .NE. nsend) call mpp_error(fatal, &
5825  "mpp_domains_define.inc(define_contact_point): nsend2 does not equal to nsend")
5826 
5827  nrecv = 0; nrecv2 = 0
5828  do list = 0, nlist-1
5829  m = mod( domain%pos+list, nlist )
5830  if(overlaprecv(m)%count>0) nrecv = nrecv + 1
5831  enddo
5832 
5833  if(debug_message_passing) then
5834  do list = 0, nlist-1
5835  m = mod( domain%pos+list, nlist )
5836  if(overlaprecv(m)%count==0) cycle
5837  write(iunit, *) "********from_pe = " ,overlaprecv(m)%pe, " count = ",overlaprecv(m)%count
5838  do n = 1, overlaprecv(m)%count
5839  write(iunit, *) overlaprecv(m)%is(n), overlaprecv(m)%ie(n), overlaprecv(m)%js(n), overlaprecv(m)%je(n), &
5840  overlaprecv(m)%dir(n), overlaprecv(m)%rotation(n)
5841  enddo
5842  enddo
5843  if(nrecv >0) flush(iunit)
5844  endif
5845 
5846  if(nrecv >0) then
5847  if(associated(domain%update_T%recv)) then
5848  do m = 1, domain%update_T%nrecv
5849  call deallocate_overlap_type(domain%update_T%recv(m))
5850  enddo
5851  deallocate(domain%update_T%recv)
5852  endif
5853  domain%update_T%nrecv = nrecv
5854  allocate(domain%update_T%recv(nrecv))
5855 
5856  do list = 0, nlist-1
5857  m = mod( domain%pos+nlist-list, nlist )
5858  ntilenbr = size(domain%list(m)%x(:))
5859  if(overlaprecv(m)%count > 0) then
5860  nrecv2 = nrecv2 + 1
5861  if(nrecv2>nrecv) call mpp_error(fatal, &
5862  "mpp_domains_define.inc(define_contact_point): nrecv2 is greater than nrecv")
5863  call allocate_update_overlap(domain%update_T%recv(nrecv2), overlaprecv(m)%count)
5864  do tme = 1, ntileme
5865  do tt = 1, ntilenbr
5866  !--- make sure the same order tile for different pe count
5867  if(domain%list(m)%pe == domain%pe) then ! own processor
5868  tnbr = tme+tt-1
5869  if(tnbr>ntilenbr) tnbr = tnbr - ntilenbr
5870  else
5871  tnbr = tt
5872  end if
5873  do n = 1, 8 ! loop over 8 direction
5874  do l = 1, overlaprecv(m)%count
5875  if(overlaprecv(m)%tileMe(l) .NE. tme) cycle
5876  if(overlaprecv(m)%tileNbr(l) .NE. tnbr) cycle
5877  if(overlaprecv(m)%dir(l) .NE. dirlist(n) ) cycle
5878  call insert_overlap_type(domain%update_T%recv(nrecv2), overlaprecv(m)%pe, &
5879  overlaprecv(m)%tileMe(l), overlaprecv(m)%tileNbr(l), overlaprecv(m)%is(l), &
5880  overlaprecv(m)%ie(l), overlaprecv(m)%js(l), overlaprecv(m)%je(l), overlaprecv(m)%dir(l),&
5881  overlaprecv(m)%rotation(l), overlaprecv(m)%from_contact(l))
5882  count = domain%update_T%recv(nrecv2)%count
5883  end do
5884  end do
5885  end do
5886  end do
5887  end if
5888  end do
5889  endif
5890 
5891  if(nrecv2 .NE. nrecv) call mpp_error(fatal, &
5892  "mpp_domains_define.inc(define_contact_point): nrecv2 does not equal to nrecv")
5893 
5894  do m = 0,nlist-1
5895  call deallocate_overlap_type(overlapsend(m))
5896  call deallocate_overlap_type(overlaprecv(m))
5897  enddo
5898  !--- release memory
5899  do n = 1, ntiles
5900  deallocate(econt(n)%tile, wcont(n)%tile, scont(n)%tile, ncont(n)%tile )
5901  deallocate(econt(n)%align1, wcont(n)%align1, scont(n)%align1, ncont(n)%align1)
5902  deallocate(econt(n)%align2, wcont(n)%align2, scont(n)%align2, ncont(n)%align2)
5903  deallocate(econt(n)%refine1, wcont(n)%refine1, scont(n)%refine1, ncont(n)%refine1)
5904  deallocate(econt(n)%refine2, wcont(n)%refine2, scont(n)%refine2, ncont(n)%refine2)
5905  deallocate(econt(n)%is1, econt(n)%ie1, econt(n)%js1, econt(n)%je1 )
5906  deallocate(econt(n)%is2, econt(n)%ie2, econt(n)%js2, econt(n)%je2 )
5907  deallocate(wcont(n)%is1, wcont(n)%ie1, wcont(n)%js1, wcont(n)%je1 )
5908  deallocate(wcont(n)%is2, wcont(n)%ie2, wcont(n)%js2, wcont(n)%je2 )
5909  deallocate(scont(n)%is1, scont(n)%ie1, scont(n)%js1, scont(n)%je1 )
5910  deallocate(scont(n)%is2, scont(n)%ie2, scont(n)%js2, scont(n)%je2 )
5911  deallocate(ncont(n)%is1, ncont(n)%ie1, ncont(n)%js1, ncont(n)%je1 )
5912  deallocate(ncont(n)%is2, ncont(n)%ie2, ncont(n)%js2, ncont(n)%je2 )
5913  end do
5914 
5915  domain%initialized = .true.
5916 
5917 
5918  end subroutine define_contact_point
5919 
5920 !##############################################################################
5921 !> always fill the contact according to index order.
5922 subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
5923  type(contact_type), intent(inout) :: Contact
5924  integer, intent(in) :: tile
5925  integer, intent(in) :: is1, ie1, js1, je1
5926  integer, intent(in) :: is2, ie2, js2, je2
5927  integer, intent(in) :: align1, align2
5928  real, intent(in) :: refine1, refine2
5929  integer :: pos, n
5930 
5931  do pos = 1, contact%ncontact
5932  select case(align1)
5933  case(west, east)
5934  if( js1 < contact%js1(pos) ) exit
5935  case(south, north)
5936  if( is1 < contact%is1(pos) ) exit
5937  end select
5938  end do
5939 
5940  contact%ncontact = contact%ncontact + 1
5941  do n = contact%ncontact, pos+1, -1 ! shift the data if needed.
5942  contact%tile(n) = contact%tile(n-1)
5943  contact%align1(n) = contact%align1(n-1)
5944  contact%align2(n) = contact%align2(n-1)
5945  contact%is1(n) = contact%is1(n-1); contact%ie1(n) = contact%ie1(n-1)
5946  contact%js1(n) = contact%js1(n-1); contact%je1(n) = contact%je1(n-1)
5947  contact%is2(n) = contact%is2(n-1); contact%ie2(n) = contact%ie2(n-1)
5948  contact%js2(n) = contact%js2(n-1); contact%je2(n) = contact%je2(n-1)
5949  end do
5950 
5951  contact%tile(pos) = tile
5952  contact%align1(pos) = align1
5953  contact%align2(pos) = align2
5954  contact%refine1(pos) = refine1
5955  contact%refine2(pos) = refine2
5956  contact%is1(pos) = is1; contact%ie1(pos) = ie1
5957  contact%js1(pos) = js1; contact%je1(pos) = je1
5958  contact%is2(pos) = is2; contact%ie2(pos) = ie2
5959  contact%js2(pos) = js2; contact%je2(pos) = je2
5960 
5961 end subroutine fill_contact
5962 
5963 !############################################################################
5964 !> this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
5965 subroutine set_contact_point(domain, position)
5966  type(domain2d), intent(inout) :: domain
5967  integer, intent(in) :: position
5968 
5969  integer :: ishift, jshift, nlist, list, m, n
5970  integer :: ntileMe, tMe, dir, count, pos, nsend, nrecv
5971  integer :: isoff1, ieoff1, jsoff1, jeoff1
5972  type(overlap_type), pointer :: ptrIn => null()
5973  type(overlapspec), pointer :: update_in => null()
5974  type(overlapspec), pointer :: update_out => null()
5975  type(overlap_type) :: overlapList(0:size(domain%list(:))-1)
5976  type(overlap_type) :: overlap
5977 
5978  call mpp_get_domain_shift(domain, ishift, jshift, position)
5979  update_in => domain%update_T
5980  select case(position)
5981  case (corner)
5982  update_out => domain%update_C
5983  case (east)
5984  update_out => domain%update_E
5985  case (north)
5986  update_out => domain%update_N
5987  case default
5988  call mpp_error(fatal, "mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
5989  end select
5990 
5991  update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
5992  update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
5993  update_out%whalo = update_in%whalo; update_out%ehalo = update_in%ehalo
5994  update_out%shalo = update_in%shalo; update_out%nhalo = update_in%nhalo
5995 
5996  nlist = size(domain%list(:))
5997  ntileme = size(domain%x(:))
5998  call allocate_update_overlap(overlap, maxoverlap)
5999  do m = 0, nlist-1
6000  call init_overlap_type(overlaplist(m))
6001  enddo
6002 
6003  !--- first copy the send information in update_out to send
6004  nsend = update_out%nsend
6005  do m = 1, nsend
6006  pos = update_out%send(m)%pe - mpp_root_pe()
6007  call add_update_overlap(overlaplist(pos), update_out%send(m))
6008  call deallocate_overlap_type(update_out%send(m))
6009  enddo
6010  if(ASSOCIATED(update_out%send) )deallocate(update_out%send)
6011 
6012  !--- loop over the list of overlapping.
6013  nsend = update_in%nsend
6014  do m = 1, nsend
6015  ptrin => update_in%send(m)
6016  pos = ptrin%pe - mpp_root_pe()
6017  do n = 1, ptrin%count
6018  dir = ptrin%dir(n)
6019  ! only set overlapping between tiles for send ( ptrOut%overlap(1) is false )
6020  if(ptrin%from_contact(n)) then
6021  select case ( dir )
6022  case ( 1 ) ! to_pe's eastern halo
6023  select case(ptrin%rotation(n))
6024  case (zero) ! W -> E
6025  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6026  case (ninety) ! S -> E
6027  isoff1 = 0; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6028  end select
6029  case ( 2 ) ! to_pe's south-eastearn halo
6030  select case(ptrin%rotation(n))
6031  case (zero)
6032  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6033  case (ninety)
6034  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6035  case (minus_ninety)
6036  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6037  end select
6038  case ( 3 ) ! to_pe's southern halo
6039  select case(ptrin%rotation(n))
6040  case (zero) ! N -> S
6041  isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6042  case (minus_ninety) ! E -> S
6043  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = ishift
6044  end select
6045  case ( 4 ) ! to_pe's south-westearn halo
6046  select case(ptrin%rotation(n))
6047  case (zero)
6048  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6049  case (ninety)
6050  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6051  case (minus_ninety)
6052  isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6053  end select
6054  case ( 5 ) ! to_pe's western halo
6055  select case(ptrin%rotation(n))
6056  case (zero) ! E -> W
6057  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6058  case (ninety) ! N -> W
6059  isoff1 = 0; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6060  end select
6061  case ( 6 ) ! to_pe's north-westearn halo
6062  select case(ptrin%rotation(n))
6063  case (zero)
6064  isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6065  case (ninety)
6066  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6067  case (minus_ninety)
6068  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
6069  end select
6070  case ( 7 ) ! to_pe's northern halo
6071  select case(ptrin%rotation(n))
6072  case (zero) ! S -> N
6073  isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6074  case (minus_ninety) ! W -> N
6075  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = ishift
6076  end select
6077  case ( 8 ) ! to_pe's north-eastearn halo
6078  select case(ptrin%rotation(n))
6079  case (zero)
6080  isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6081  case (ninety)
6082  isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6083  case (minus_ninety)
6084  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6085  end select
6086  end select
6087  call insert_overlap_type(overlap, ptrin%pe, ptrin%tileMe(n), ptrin%tileNbr(n), &
6088  ptrin%is(n) + isoff1, ptrin%ie(n) + ieoff1, ptrin%js(n) + jsoff1, &
6089  ptrin%je(n) + jeoff1, ptrin%dir(n), ptrin%rotation(n), ptrin%from_contact(n))
6090  end if
6091  end do ! do n = 1, prtIn%count
6092  if(overlap%count > 0) then
6093  call add_update_overlap(overlaplist(pos), overlap)
6094  call init_overlap_type(overlap)
6095  endif
6096  end do ! do list = 0, nlist-1
6097 
6098  nsend = 0
6099  do list = 0, nlist-1
6100  m = mod( domain%pos+list, nlist )
6101  if(overlaplist(m)%count>0) nsend = nsend+1
6102  enddo
6103 
6104  update_out%nsend = nsend
6105  if(nsend>0) then
6106  if (associated(update_out%send)) deallocate(update_out%send) !< Check if associated
6107  allocate(update_out%send(nsend))
6108  pos = 0
6109  do list = 0, nlist-1
6110  m = mod( domain%pos+list, nlist )
6111  if(overlaplist(m)%count>0) then
6112  pos = pos+1
6113  if(pos>nsend) call mpp_error(fatal, &
6114  "mpp_domains_define.inc(set_contact_point): pos should be no larger than nsend")
6115  call add_update_overlap(update_out%send(pos), overlaplist(m))
6116  call deallocate_overlap_type(overlaplist(m))
6117  endif
6118  enddo
6119  if(pos .NE. nsend) call mpp_error(fatal, &
6120  "mpp_domains_define.inc(set_contact_point): pos should equal to nsend")
6121  endif
6122 
6123 
6124 
6125  !--- first copy the recv information in update_out to recv
6126  nrecv = update_out%nrecv
6127  do m = 1, nrecv
6128  pos = update_out%recv(m)%pe - mpp_root_pe()
6129  call add_update_overlap(overlaplist(pos), update_out%recv(m))
6130  call deallocate_overlap_type(update_out%recv(m))
6131  enddo
6132  if(ASSOCIATED(update_out%recv) )deallocate(update_out%recv)
6133 
6134  !--- loop over the list of overlapping.
6135  nrecv = update_in%nrecv
6136  do m=1,nrecv
6137  ptrin => update_in%recv(m)
6138  pos = ptrin%pe - mpp_root_pe()
6139  do n = 1, ptrin%count
6140  dir = ptrin%dir(n)
6141  ! only set overlapping between tiles for recv ( ptrOut%overlap(1) is false )
6142  if(ptrin%from_contact(n)) then
6143  select case ( dir )
6144  case ( 1 ) ! E
6145  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6146  case ( 2 ) ! SE
6147  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6148  case ( 3 ) ! S
6149  isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6150  case ( 4 ) ! SW
6151  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6152  case ( 5 ) ! W
6153  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6154  case ( 6 ) ! NW
6155  isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6156  case ( 7 ) ! N
6157  isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6158  case ( 8 ) ! NE
6159  isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6160  end select
6161  call insert_overlap_type(overlap, ptrin%pe, ptrin%tileMe(n), ptrin%tileNbr(n), &
6162  ptrin%is(n) + isoff1, ptrin%ie(n) + ieoff1, ptrin%js(n) + jsoff1, &
6163  ptrin%je(n) + jeoff1, ptrin%dir(n), ptrin%rotation(n), ptrin%from_contact(n))
6164  count = overlap%count
6165  end if
6166  end do ! do n = 1, ptrIn%count
6167  if(overlap%count > 0) then
6168  call add_update_overlap(overlaplist(pos), overlap)
6169  call init_overlap_type(overlap)
6170  endif
6171  do tme = 1, size(domain%x(:))
6172  do n = 1, overlap%count
6173  if(overlap%tileMe(n) == tme) then
6174  if(overlap%dir(n) == 1 ) domain%x(tme)%loffset = 0
6175  if(overlap%dir(n) == 7 ) domain%y(tme)%loffset = 0
6176  end if
6177  end do
6178  end do
6179  end do ! do list = 0, nlist-1
6180 
6181  nrecv = 0
6182  do list = 0, nlist-1
6183  m = mod( domain%pos+nlist-list, nlist )
6184  if(overlaplist(m)%count>0) nrecv = nrecv+1
6185  enddo
6186 
6187  update_out%nrecv = nrecv
6188  if(nrecv>0) then
6189  if (associated(update_out%recv)) deallocate(update_out%recv) !< Check if associated
6190  allocate(update_out%recv(nrecv))
6191  pos = 0
6192  do list = 0, nlist-1
6193  m = mod( domain%pos+nlist-list, nlist )
6194  if(overlaplist(m)%count>0) then
6195  pos = pos+1
6196  if(pos>nrecv) call mpp_error(fatal, &
6197  "mpp_domains_define.inc(set_contact_point): pos should be no larger than nrecv")
6198  call add_update_overlap(update_out%recv(pos), overlaplist(m))
6199  call deallocate_overlap_type(overlaplist(m))
6200  endif
6201  enddo
6202  if(pos .NE. nrecv) call mpp_error(fatal, &
6203  "mpp_domains_define.inc(set_contact_point): pos should equal to nrecv")
6204  endif
6205 
6206  call deallocate_overlap_type(overlap)
6207 
6208 end subroutine set_contact_point
6209 
6210 !> set up the overlapping for boundary check if the domain is symmetry. The check will be
6211 !! done on current pe for east boundary for E-cell, north boundary for N-cell,
6212 !! East and North boundary for C-cell
6213 subroutine set_check_overlap( domain, position )
6214 type(domain2d), intent(in) :: domain
6215 integer, intent(in) :: position
6216 integer :: nlist, m, n
6217 integer, parameter :: MAXCOUNT = 100
6218 integer :: is, ie, js, je
6219 integer :: nsend, nrecv, pos, maxsize, rotation
6220 type(overlap_type) :: overlap
6221 type(overlapspec), pointer :: update => null()
6222 type(overlapspec), pointer :: check => null()
6223 
6224 select case(position)
6225 case (corner)
6226  update => domain%update_C
6227  check => domain%check_C
6228 case (east)
6229  update => domain%update_E
6230  check => domain%check_E
6231 case (north)
6232  update => domain%update_N
6233  check => domain%check_N
6234 case default
6235  call mpp_error(fatal, "mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
6236 end select
6237 
6238 check%xbegin = update%xbegin; check%xend = update%xend
6239 check%ybegin = update%ybegin; check%yend = update%yend
6240 check%nsend = 0
6241 check%nrecv = 0
6242 if( .NOT. domain%symmetry ) return
6243 
6244 nsend = 0
6245 maxsize = 0
6246 do m = 1, update%nsend
6247  do n = 1, update%send(m)%count
6248  if( update%send(m)%rotation(n) == one_hundred_eighty ) cycle
6249  if( ( (position == east .OR. position == corner) .AND. update%send(m)%dir(n) == 1 ) .OR. &
6250  ( (position == north .OR. position == corner) .AND. update%send(m)%dir(n) == 7 ) ) then
6251  maxsize = max(maxsize, update%send(m)%count)
6252  nsend = nsend + 1
6253  exit
6254  endif
6255  enddo
6256 enddo
6257 
6258 if(nsend>0) then
6259  if (associated(check%send)) deallocate(check%send) !< Check if associated
6260  allocate(check%send(nsend))
6261  call allocate_check_overlap(overlap, maxsize)
6262 endif
6263 
6264 
6265 nlist = size(domain%list(:))
6266 !--- loop over the list of domains to find the boundary overlap for send
6267 pos = 0
6268 do m = 1, update%nsend
6269  do n = 1, update%send(m)%count
6270  if( update%send(m)%rotation(n) == one_hundred_eighty ) cycle
6271  ! comparing east direction on currently pe
6272  if( (position == east .OR. position == corner) .AND. update%send(m)%dir(n) == 1 ) then
6273  rotation = update%send(m)%rotation(n)
6274  select case( rotation )
6275  case( zero ) ! W -> E
6276  is = update%send(m)%is(n) - 1
6277  ie = is
6278  js = update%send(m)%js(n)
6279  je = update%send(m)%je(n)
6280  case( ninety ) ! S -> E
6281  is = update%send(m)%is(n)
6282  ie = update%send(m)%ie(n)
6283  js = update%send(m)%js(n) - 1
6284  je = js
6285  end select
6286  call insert_check_overlap(overlap, update%send(m)%pe, &
6287  update%send(m)%tileMe(n), 1, rotation, is, ie, js, je)
6288  end if
6289 
6290  ! comparing north direction on currently pe
6291  if( (position == north .OR. position == corner) .AND. update%send(m)%dir(n) == 7 ) then
6292  rotation = update%send(m)%rotation(n)
6293  select case( rotation )
6294  case( zero ) ! S->N
6295  is = update%send(m)%is(n)
6296  ie = update%send(m)%ie(n)
6297  js = update%send(m)%js(n) - 1
6298  je = js
6299  case( minus_ninety ) ! W->N
6300  is = update%send(m)%is(n) - 1
6301  ie = is
6302  js = update%send(m)%js(n)
6303  je = update%send(m)%je(n)
6304  end select
6305  call insert_check_overlap(overlap, update%send(m)%pe, &
6306  update%send(m)%tileMe(n), 4, rotation, is, ie, js, je)
6307  end if
6308  end do ! do n =1, update%send(m)%count
6309  if(overlap%count>0) then
6310  pos = pos+1
6311  if(pos>nsend)call mpp_error(fatal, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6312  call add_check_overlap(check%send(pos), overlap)
6313  call init_overlap_type(overlap)
6314  endif
6315 end do ! end do list = 0, nlist
6316 
6317 if(pos .NE. nsend)call mpp_error(fatal, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6318 
6319 nrecv = 0
6320 maxsize = 0
6321 do m = 1, update%nrecv
6322  do n = 1, update%recv(m)%count
6323  if( update%recv(m)%rotation(n) == one_hundred_eighty ) cycle
6324  if( ( (position == east .OR. position == corner) .AND. update%recv(m)%dir(n) == 1 ) .OR. &
6325  ( (position == north .OR. position == corner) .AND. update%recv(m)%dir(n) == 7 ) ) then
6326  maxsize = max(maxsize, update%recv(m)%count)
6327  nrecv = nrecv + 1
6328  exit
6329  endif
6330  enddo
6331 enddo
6332 
6333 if(nsend>0) call deallocate_overlap_type(overlap)
6334 
6335 if(nrecv>0) then
6336  if (associated(check%recv)) deallocate(check%recv) !< Check if associated
6337  allocate(check%recv(nrecv))
6338  call allocate_check_overlap(overlap, maxsize)
6339 endif
6340 
6341 pos = 0
6342 do m = 1, update%nrecv
6343  do n = 1, update%recv(m)%count
6344  if( update%recv(m)%rotation(n) == one_hundred_eighty ) cycle
6345  if( (position == east .OR. position == corner) .AND. update%recv(m)%dir(n) == 1 ) then
6346  is = update%recv(m)%is(n) - 1
6347  ie = is
6348  js = update%recv(m)%js(n)
6349  je = update%recv(m)%je(n)
6350  call insert_check_overlap(overlap, update%recv(m)%pe, &
6351  update%recv(m)%tileMe(n), 1, update%recv(m)%rotation(n), is, ie, js, je)
6352  end if
6353  if( (position == north .OR. position == corner) .AND. update%recv(m)%dir(n) == 7 ) then
6354  is = update%recv(m)%is(n)
6355  ie = update%recv(m)%ie(n)
6356  js = update%recv(m)%js(n) - 1
6357  je = js
6358  call insert_check_overlap(overlap, update%recv(m)%pe, &
6359  update%recv(m)%tileMe(n), 3, update%recv(m)%rotation(n), is, ie, js, je)
6360  end if
6361  end do ! n = 1, overlap%count
6362  if(overlap%count>0) then
6363  pos = pos+1
6364  if(pos>nrecv)call mpp_error(fatal, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6365  call add_check_overlap(check%recv(pos), overlap)
6366  call init_overlap_type(overlap)
6367  endif
6368 end do ! end do list = 0, nlist
6369 
6370 if(pos .NE. nrecv)call mpp_error(fatal, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6371 if(nrecv>0) call deallocate_overlap_type(overlap)
6372 
6373 end subroutine set_check_overlap
6374 
6375 !#############################################################################
6376 !> set up the overlapping for boundary if the domain is symmetry.
6377 subroutine set_bound_overlap( domain, position )
6378  type(domain2d), intent(inout) :: domain
6379  integer, intent(in) :: position
6380  integer :: m, n, l, count, dr, tMe
6381  integer, parameter :: MAXCOUNT = 100
6382  integer, dimension(MAXCOUNT) :: dir, rotation, is, ie, js, je, tileMe, index
6383  integer, dimension(size(domain%x(:)), 4) :: nrecvl
6384  integer, dimension(size(domain%x(:)), 4, MAXCOUNT) :: isl, iel, jsl, jel
6385  type(overlap_type), pointer :: overlap => null()
6386  type(overlapspec), pointer :: update => null()
6387  type(overlapspec), pointer :: bound => null()
6388  integer :: nlist_send, nlist_recv, ishift, jshift
6389  integer :: ism, iem, jsm, jem, nsend, nrecv
6390  integer :: isg, ieg, jsg, jeg, nlist, list
6391  integer :: npes_x, npes_y, ipos, jpos, inbr, jnbr
6392  integer :: isc, iec, jsc, jec, my_pe
6393  integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
6394  integer :: is_south1, ie_south1, js_south1, je_south1
6395  integer :: is_south2, ie_south2, js_south2, je_south2
6396  integer :: is_west0, ie_west0, js_west0, je_west0
6397  integer :: is_west1, ie_west1, js_west1, je_west1
6398  integer :: is_west2, ie_west2, js_west2, je_west2
6399  logical :: x_cyclic, y_cyclic, folded_north
6400 
6401  is_south1=0; ie_south1=0; js_south1=0; je_south1=0
6402  is_south2=0; ie_south2=0; js_south2=0; je_south2=0
6403  is_west0=0; ie_west0=0; js_west0=0; je_west0=0
6404  is_west1=0; ie_west1=0; js_west1=0; je_west1=0
6405  is_west2=0; ie_west2=0; js_west2=0; je_west2=0
6406 
6407 
6408  if( position == center .OR. .NOT. domain%symmetry ) return
6409  call mpp_get_domain_shift(domain, ishift, jshift, position)
6410  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
6411  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
6412 
6413  select case(position)
6414  case (corner)
6415  update => domain%update_C
6416  bound => domain%bound_C
6417  case (east)
6418  update => domain%update_E
6419  bound => domain%bound_E
6420  case (north)
6421  update => domain%update_N
6422  bound => domain%bound_N
6423  case default
6424  call mpp_error( fatal, "mpp_domains_mod(set_bound_overlap): invalid option of position")
6425  end select
6426 
6427  bound%xbegin = ism; bound%xend = iem + ishift
6428  bound%ybegin = jsm; bound%yend = jem + jshift
6429 
6430  nlist_send = max(update%nsend,4)
6431  nlist_recv = max(update%nrecv,4)
6432  bound%nsend = nlist_send
6433  bound%nrecv = nlist_recv
6434  if(nlist_send >0) then
6435  if (associated(bound%send)) deallocate(bound%send) !< Check if associated
6436  allocate(bound%send(nlist_send))
6437  bound%send(:)%count = 0
6438  endif
6439  if(nlist_recv >0) then
6440  if (associated(bound%recv)) deallocate(bound%recv) !< Check if associated
6441  allocate(bound%recv(nlist_recv))
6442  bound%recv(:)%count = 0
6443  endif
6444  !--- loop over the list of domains to find the boundary overlap for send
6445  nlist = size(domain%list(:))
6446 
6447  npes_x = size(domain%x(1)%list(:))
6448  npes_y = size(domain%y(1)%list(:))
6449  x_cyclic = domain%x(1)%cyclic
6450  y_cyclic = domain%y(1)%cyclic
6451  folded_north = btest(domain%fold,north)
6452  ipos = domain%x(1)%pos
6453  jpos = domain%y(1)%pos
6454  isc = domain%x(1)%compute%begin; iec = domain%x(1)%compute%end
6455  jsc = domain%y(1)%compute%begin; jec = domain%y(1)%compute%end
6456 
6457  nsend = 0
6458  if(domain%ntiles == 1) then ! use neighbor processor to configure send and recv
6459  ! currently only set up for west and south boundary
6460 
6461  ! south boundary for send
6462  pe_south1 = null_pe; pe_south2 = null_pe
6463  if( position == north .OR. position == corner ) then
6464  inbr = ipos; jnbr = jpos + 1
6465  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6466  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6467  pe_south1 = domain%pearray(inbr,jnbr)
6468  is_south1 = isc + ishift; ie_south1 = iec+ishift
6469  js_south1 = jec + jshift; je_south1 = js_south1
6470  endif
6471  endif
6472  !--- send to the southwest processor when position is NORTH
6473  if( position == corner ) then
6474  inbr = ipos + 1; jnbr = jpos + 1
6475  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6476  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6477  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6478  pe_south2 = domain%pearray(inbr,jnbr)
6479  is_south2 = iec + ishift; ie_south2 = is_south2
6480  js_south2 = jec + jshift; je_south2 = js_south2
6481  endif
6482  endif
6483 
6484  !---west boundary for send
6485  pe_west0 = null_pe; pe_west1 = null_pe; pe_west2 = null_pe
6486  if( position == east ) then
6487  inbr = ipos+1; jnbr = jpos
6488  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6489  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6490  pe_west1 = domain%pearray(inbr,jnbr)
6491  is_west1 = iec + ishift; ie_west1 = is_west1
6492  js_west1 = jsc + jshift; je_west1 = jec + jshift
6493  endif
6494  else if ( position == corner ) then ! possible split into two parts.
6495  !--- on the fold.
6496  if( folded_north .AND. jec == jeg .AND. ipos .LT. (npes_x-1)/2 ) then
6497  inbr = npes_x - ipos - 1; jnbr = jpos
6498  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6499  pe_west0 = domain%pearray(inbr,jnbr)
6500  is_west0 = iec+ishift; ie_west0 = is_west0
6501  js_west0 = jec+jshift; je_west0 = js_west0
6502  endif
6503  endif
6504 
6505  if( folded_north .AND. jec == jeg .AND. ipos .GE. npes_x/2 .AND. ipos .LT. (npes_x-1) ) then
6506  inbr = ipos+1; jnbr = jpos
6507  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6508  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6509  pe_west1 = domain%pearray(inbr,jnbr)
6510  is_west1 = iec + ishift; ie_west1 = is_west1
6511  js_west1 = jsc + jshift; je_west1 = jec
6512  endif
6513  else
6514  inbr = ipos+1; jnbr = jpos
6515  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6516  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6517  pe_west1 = domain%pearray(inbr,jnbr)
6518  is_west1 = iec + ishift; ie_west1 = is_west1
6519  js_west1 = jsc + jshift; je_west1 = jec + jshift
6520  endif
6521  endif
6522  endif
6523  !--- send to the southwest processor when position is NORTH
6524  if( position == corner ) then
6525  inbr = ipos + 1; jnbr = jpos + 1
6526  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6527  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6528  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6529  pe_west2 = domain%pearray(inbr,jnbr)
6530  is_west2 = iec + ishift; ie_west2 = is_west2
6531  js_west2 = jec + jshift; je_west2 = js_west2
6532  endif
6533  endif
6534 
6535  do list = 0,nlist-1
6536  m = mod( domain%pos+list, nlist )
6537  count = 0
6538  my_pe = domain%list(m)%pe
6539  if(my_pe == pe_south1) then
6540  count = count + 1
6541  is(count) = is_south1; ie(count) = ie_south1
6542  js(count) = js_south1; je(count) = je_south1
6543  dir(count) = 2
6544  rotation(count) = zero
6545  endif
6546  if(my_pe == pe_south2) then
6547  count = count + 1
6548  is(count) = is_south2; ie(count) = ie_south2
6549  js(count) = js_south2; je(count) = je_south2
6550  dir(count) = 2
6551  rotation(count) = zero
6552  endif
6553 
6554  if(my_pe == pe_west0) then
6555  count = count + 1
6556  is(count) = is_west0; ie(count) = ie_west0
6557  js(count) = js_west0; je(count) = je_west0
6558  dir(count) = 3
6559  rotation(count) = one_hundred_eighty
6560  endif
6561  if(my_pe == pe_west1) then
6562  count = count + 1
6563  is(count) = is_west1; ie(count) = ie_west1
6564  js(count) = js_west1; je(count) = je_west1
6565  dir(count) = 3
6566  rotation(count) = zero
6567  endif
6568  if(my_pe == pe_west2) then
6569  count = count + 1
6570  is(count) = is_west2; ie(count) = ie_west2
6571  js(count) = js_west2; je(count) = je_west2
6572  dir(count) = 3
6573  rotation(count) = zero
6574  endif
6575 
6576  if(count >0) then
6577  nsend = nsend + 1
6578  if(nsend > nlist_send) call mpp_error(fatal, "set_bound_overlap: nsend > nlist_send")
6579  bound%send(nsend)%count = count
6580  bound%send(nsend)%pe = my_pe
6581  if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated
6582  if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated
6583  if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated
6584  if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated
6585  if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated
6586  if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated
6587  if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated
6588  allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6589  allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6590  allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6591  allocate(bound%send(nsend)%tileMe(count))
6592  bound%send(nsend)%is(:) = is(1:count)
6593  bound%send(nsend)%ie(:) = ie(1:count)
6594  bound%send(nsend)%js(:) = js(1:count)
6595  bound%send(nsend)%je(:) = je(1:count)
6596  bound%send(nsend)%dir(:) = dir(1:count)
6597  bound%send(nsend)%tileMe(:) = 1
6598  bound%send(nsend)%rotation(:) = rotation(1:count)
6599  endif
6600  enddo
6601  else
6602  !--- The following did not consider wide halo case.
6603  do m = 1, update%nsend
6604  overlap => update%send(m)
6605  if( overlap%count == 0 ) cycle
6606  count = 0
6607  do n = 1, overlap%count
6608  !--- currently not support folded-north
6609  if( overlap%rotation(n) == one_hundred_eighty ) cycle
6610  if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 1) then ! east
6611  count=count+1
6612  dir(count) = 1
6613  rotation(count) = overlap%rotation(n)
6614  tileme(count) = overlap%tileMe(n)
6615  select case( rotation(count) )
6616  case( zero ) ! W -> E
6617  is(count) = overlap%is(n) - 1
6618  ie(count) = is(count)
6619  js(count) = overlap%js(n)
6620  je(count) = overlap%je(n)
6621  case( ninety ) ! S -> E
6622  is(count) = overlap%is(n)
6623  ie(count) = overlap%ie(n)
6624  js(count) = overlap%js(n) - 1
6625  je(count) = js(count)
6626  end select
6627  end if
6628  if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 3 ) then ! south
6629  count=count+1
6630  dir(count) = 2
6631  rotation(count) = overlap%rotation(n)
6632  tileme(count) = overlap%tileMe(n)
6633  select case( rotation(count) )
6634  case( zero ) ! N->S
6635  is(count) = overlap%is(n)
6636  ie(count) = overlap%ie(n)
6637  js(count) = overlap%je(n) + 1
6638  je(count) = js(count)
6639  case( minus_ninety ) ! E->S
6640  is(count) = overlap%ie(n) + 1
6641  ie(count) = is(count)
6642  js(count) = overlap%js(n)
6643  je(count) = overlap%je(n)
6644  end select
6645  end if
6646  if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 5 ) then ! west
6647  count=count+1
6648  dir(count) = 3
6649  rotation(count) = overlap%rotation(n)
6650  tileme(count) = overlap%tileMe(n)
6651  select case( rotation(count) )
6652  case( zero ) ! E->W
6653  is(count) = overlap%ie(n) + 1
6654  ie(count) = is(count)
6655  js(count) = overlap%js(n)
6656  je(count) = overlap%je(n)
6657  case( ninety ) ! N->W
6658  is(count) = overlap%is(n)
6659  ie(count) = overlap%ie(n)
6660  js(count) = overlap%je(n) + 1
6661  je(count) = js(count)
6662  end select
6663  end if
6664  if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 7 ) then ! north
6665  count=count+1
6666  dir(count) = 4
6667  rotation(count) = overlap%rotation(n)
6668  tileme(count) = overlap%tileMe(n)
6669  select case( rotation(count) )
6670  case( zero ) ! S->N
6671  is(count) = overlap%is(n)
6672  ie(count) = overlap%ie(n)
6673  js(count) = overlap%js(n) - 1
6674  je(count) = js(count)
6675  case( minus_ninety ) ! W->N
6676  is(count) = overlap%is(n) - 1
6677  ie(count) = is(count)
6678  js(count) = overlap%js(n)
6679  je(count) = overlap%je(n)
6680  end select
6681  end if
6682  end do ! do n =1, overlap%count
6683  if(count>0) then
6684  nsend = nsend + 1
6685  bound%send(nsend)%count = count
6686  bound%send(nsend)%pe = overlap%pe
6687  if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated
6688  if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated
6689  if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated
6690  if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated
6691  if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated
6692  if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated
6693  if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated
6694  allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6695  allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6696  allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6697  allocate(bound%send(nsend)%tileMe(count))
6698  bound%send(nsend)%is(:) = is(1:count)
6699  bound%send(nsend)%ie(:) = ie(1:count)
6700  bound%send(nsend)%js(:) = js(1:count)
6701  bound%send(nsend)%je(:) = je(1:count)
6702  bound%send(nsend)%dir(:) = dir(1:count)
6703  bound%send(nsend)%tileMe(:) = tileme(1:count)
6704  bound%send(nsend)%rotation(:) = rotation(1:count)
6705  end if
6706  end do ! end do list = 0, nlist
6707  endif
6708 
6709  !--- loop over the list of domains to find the boundary overlap for recv
6710  bound%nsend = nsend
6711  nrecvl(:,:) = 0
6712  nrecv = 0
6713 
6714  !--- will computing overlap for tripolar grid.
6715  if( domain%ntiles == 1 ) then
6716  ! currently only set up for west and south boundary
6717 
6718  ! south boundary for recv
6719  pe_south1 = null_pe; pe_south2 = null_pe
6720  if( position == north .OR. position == corner ) then
6721  inbr = ipos; jnbr = jpos - 1
6722  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6723  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6724  pe_south1 = domain%pearray(inbr,jnbr)
6725  is_south1 = isc + ishift; ie_south1 = iec+ishift
6726  js_south1 = jsc; je_south1 = js_south1
6727  endif
6728  endif
6729 
6730  !--- south boudary for recv: the southwest point when position is NORTH
6731  if( position == corner ) then
6732  inbr = ipos - 1; jnbr = jpos - 1
6733  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6734  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6735  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6736  pe_south2 = domain%pearray(inbr,jnbr)
6737  is_south2 = isc; ie_south2 = is_south2
6738  js_south2 = jsc; je_south2 = js_south2
6739  endif
6740  endif
6741 
6742 
6743  !---west boundary for recv
6744  pe_west0 = null_pe; pe_west1 = null_pe; pe_west2 = null_pe
6745  if( position == east ) then
6746  inbr = ipos-1; jnbr = jpos
6747  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6748  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6749  pe_west1 = domain%pearray(inbr,jnbr)
6750  is_west1 = isc; ie_west1 = is_west1
6751  js_west1 = jsc + jshift; je_west1 = jec + jshift
6752  endif
6753  else if ( position == corner ) then ! possible split into two parts.
6754  !--- on the fold.
6755  if( folded_north .AND. jec == jeg .AND. ipos .GT. npes_x/2 ) then
6756  inbr = npes_x - ipos - 1; jnbr = jpos
6757  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6758  pe_west0 = domain%pearray(inbr,jnbr)
6759  is_west0 = isc; ie_west0 = is_west0
6760  js_west0 = jec+jshift; je_west0 = js_west0
6761  endif
6762  inbr = ipos-1; jnbr = jpos
6763  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6764  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6765  pe_west1 = domain%pearray(inbr,jnbr)
6766  is_west1 = isc; ie_west1 = is_west1
6767  js_west1 = jsc + jshift; je_west1 = jec
6768  endif
6769  else
6770  inbr = ipos-1; jnbr = jpos
6771  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6772  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6773  pe_west1 = domain%pearray(inbr,jnbr)
6774  is_west1 = isc; ie_west1 = is_west1
6775  js_west1 = jsc + jshift; je_west1 = jec+jshift
6776  endif
6777  endif
6778  endif
6779 
6780  !--- west boundary for recv: the southwest point when position is CORNER
6781  if( position == corner ) then
6782  inbr = ipos - 1; jnbr = jpos - 1
6783  if( inbr == -1 .AND. x_cyclic) inbr = npes_x - 1
6784  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y - 1
6785  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6786  pe_west2 = domain%pearray(inbr,jnbr)
6787  is_west2 = isc; ie_west2 = is_west2
6788  js_west2 = jsc; je_west2 = js_west2
6789  endif
6790  endif
6791 
6792  tme = 1
6793  do list = 0,nlist-1
6794  m = mod( domain%pos+nlist-list, nlist )
6795  count = 0
6796  my_pe = domain%list(m)%pe
6797  if(my_pe == pe_south1) then
6798  count = count + 1
6799  is(count) = is_south1; ie(count) = ie_south1
6800  js(count) = js_south1; je(count) = je_south1
6801  dir(count) = 2
6802  rotation(count) = zero
6803  index(count) = 1 + ishift
6804  endif
6805  if(my_pe == pe_south2) then
6806  count = count + 1
6807  is(count) = is_south2; ie(count) = ie_south2
6808  js(count) = js_south2; je(count) = je_south2
6809  dir(count) = 2
6810  rotation(count) = zero
6811  index(count) = 1
6812  endif
6813  if(my_pe == pe_west0) then
6814  count = count + 1
6815  is(count) = is_west0; ie(count) = ie_west0
6816  js(count) = js_west0; je(count) = je_west0
6817  dir(count) = 3
6818  rotation(count) = one_hundred_eighty
6819  index(count) = jec-jsc+1+jshift
6820  endif
6821  if(my_pe == pe_west1) then
6822  count = count + 1
6823  is(count) = is_west1; ie(count) = ie_west1
6824  js(count) = js_west1; je(count) = je_west1
6825  dir(count) = 3
6826  rotation(count) = zero
6827  index(count) = 1 + jshift
6828  endif
6829  if(my_pe == pe_west2) then
6830  count = count + 1
6831  is(count) = is_west2; ie(count) = ie_west2
6832  js(count) = js_west2; je(count) = je_west2
6833  dir(count) = 3
6834  rotation(count) = zero
6835  index(count) = 1
6836  endif
6837 
6838  if(count >0) then
6839  nrecv = nrecv + 1
6840  if(nrecv > nlist_recv) call mpp_error(fatal, "set_bound_overlap: nrecv > nlist_recv")
6841  bound%recv(nrecv)%count = count
6842  bound%recv(nrecv)%pe = my_pe
6843  if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated
6844  if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated
6845  if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated
6846  if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated
6847  if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated
6848  if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated
6849  if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated
6850  if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated
6851  allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6852  allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6853  allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6854  allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6855 
6856  bound%recv(nrecv)%is(:) = is(1:count)
6857  bound%recv(nrecv)%ie(:) = ie(1:count)
6858  bound%recv(nrecv)%js(:) = js(1:count)
6859  bound%recv(nrecv)%je(:) = je(1:count)
6860  bound%recv(nrecv)%dir(:) = dir(1:count)
6861  bound%recv(nrecv)%tileMe(:) = 1
6862  bound%recv(nrecv)%rotation(:) = rotation(1:count)
6863  bound%recv(nrecv)%index(:) = index(1:count)
6864  endif
6865  enddo
6866  else
6867  do m = 1, update%nrecv
6868  overlap => update%recv(m)
6869  if( overlap%count == 0 ) cycle
6870  count = 0
6871  do n = 1, overlap%count
6872  !--- currently not support folded-north
6873  if( overlap%rotation(n) == one_hundred_eighty ) cycle
6874  if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 1) then ! east
6875  count=count+1
6876  dir(count) = 1
6877  rotation(count) = overlap%rotation(n)
6878  tileme(count) = overlap%tileMe(n)
6879  is(count) = overlap%is(n) - 1
6880  ie(count) = is(count)
6881  js(count) = overlap%js(n)
6882  je(count) = overlap%je(n)
6883  tme = tileme(count)
6884  nrecvl(tme, 1) = nrecvl(tme,1) + 1
6885  isl(tme,1,nrecvl(tme, 1)) = is(count)
6886  iel(tme,1,nrecvl(tme, 1)) = ie(count)
6887  jsl(tme,1,nrecvl(tme, 1)) = js(count)
6888  jel(tme,1,nrecvl(tme, 1)) = je(count)
6889  end if
6890 
6891  if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 3) then ! south
6892  count=count+1
6893  dir(count) = 2
6894  rotation(count) = overlap%rotation(n)
6895  tileme(count) = overlap%tileMe(n)
6896  is(count) = overlap%is(n)
6897  ie(count) = overlap%ie(n)
6898  js(count) = overlap%je(n) + 1
6899  je(count) = js(count)
6900  tme = tileme(count)
6901  nrecvl(tme, 2) = nrecvl(tme,2) + 1
6902  isl(tme,2,nrecvl(tme, 2)) = is(count)
6903  iel(tme,2,nrecvl(tme, 2)) = ie(count)
6904  jsl(tme,2,nrecvl(tme, 2)) = js(count)
6905  jel(tme,2,nrecvl(tme, 2)) = je(count)
6906  end if
6907 
6908  if( (position == east .OR. position == corner) .AND. overlap%dir(n) == 5) then ! west
6909  count=count+1
6910  dir(count) = 3
6911  rotation(count) = overlap%rotation(n)
6912  tileme(count) = overlap%tileMe(n)
6913  is(count) = overlap%ie(n) + 1
6914  ie(count) = is(count)
6915  js(count) = overlap%js(n)
6916  je(count) = overlap%je(n)
6917  tme = tileme(count)
6918  nrecvl(tme, 3) = nrecvl(tme,3) + 1
6919  isl(tme,3,nrecvl(tme, 3)) = is(count)
6920  iel(tme,3,nrecvl(tme, 3)) = ie(count)
6921  jsl(tme,3,nrecvl(tme, 3)) = js(count)
6922  jel(tme,3,nrecvl(tme, 3)) = je(count)
6923  end if
6924 
6925  if( (position == north .OR. position == corner) .AND. overlap%dir(n) == 7) then ! north
6926  count=count+1
6927  dir(count) = 4
6928  rotation(count) = overlap%rotation(n)
6929  tileme(count) = overlap%tileMe(n)
6930  is(count) = overlap%is(n)
6931  ie(count) = overlap%ie(n)
6932  js(count) = overlap%js(n) - 1
6933  je(count) = js(count)
6934  tme = tileme(count)
6935  nrecvl(tme, 4) = nrecvl(tme,4) + 1
6936  isl(tme,4,nrecvl(tme, 4)) = is(count)
6937  iel(tme,4,nrecvl(tme, 4)) = ie(count)
6938  jsl(tme,4,nrecvl(tme, 4)) = js(count)
6939  jel(tme,4,nrecvl(tme, 4)) = je(count)
6940  end if
6941  end do ! do n = 1, overlap%count
6942  if(count>0) then
6943  nrecv = nrecv + 1
6944  bound%recv(nrecv)%count = count
6945  bound%recv(nrecv)%pe = overlap%pe
6946  if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated
6947  if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated
6948  if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated
6949  if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated
6950  if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated
6951  if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated
6952  if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated
6953  if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated
6954  allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6955  allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6956  allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6957  allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6958  bound%recv(nrecv)%is(:) = is(1:count)
6959  bound%recv(nrecv)%ie(:) = ie(1:count)
6960  bound%recv(nrecv)%js(:) = js(1:count)
6961  bound%recv(nrecv)%je(:) = je(1:count)
6962  bound%recv(nrecv)%dir(:) = dir(1:count)
6963  bound%recv(nrecv)%tileMe(:) = tileme(1:count)
6964  bound%recv(nrecv)%rotation(:) = rotation(1:count)
6965  end if
6966  end do ! end do list = 0, nlist
6967  !--- find the boundary index for each contact within the east boundary
6968  do m = 1, nrecv
6969  do n = 1, bound%recv(m)%count
6970  tme = bound%recv(m)%tileMe(n)
6971  dr = bound%recv(m)%dir(n)
6972  bound%recv(m)%index(n) = 1
6973  do l = 1, nrecvl(tme,dr)
6974  if(dr == 1 .OR. dr == 3) then ! EAST, WEST
6975  if( bound%recv(m)%js(n) > jsl(tme, dr, l) ) then
6976  if( bound%recv(m)%rotation(n) == one_hundred_eighty ) then
6977  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6978  max(abs(jel(tme, dr, l)-jsl(tme, dr, l))+1, &
6979  abs(iel(tme, dr, l)-isl(tme, dr, l))+1)
6980  else
6981  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6982  max(abs(jel(tme, dr, l)-jsl(tme, dr, l)), &
6983  abs(iel(tme, dr, l)-isl(tme, dr, l))) + 1 - jshift
6984  endif
6985  end if
6986  else ! South, North
6987  if( bound%recv(m)%is(n) > isl(tme, dr, l) ) then
6988  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6989  max(abs(jel(tme, dr, l)-jsl(tme, dr, l)), &
6990  abs(iel(tme, dr, l)-isl(tme, dr, l))) + 1 - ishift
6991  end if
6992  end if
6993  end do
6994  end do
6995  end do
6996 
6997  endif
6998  bound%nrecv = nrecv
6999 
7000 
7001 end subroutine set_bound_overlap
7002 
7003 
7004 !#############################################################################
7005 
7006 subroutine fill_corner_contact(eCont, sCont, wCont, nCont, isg, ieg, jsg, jeg, numR, numS, tileRecv, tileSend, &
7007  is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv, &
7008  is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send, &
7009  align1Recv, align2Recv, align1Send, align2Send, &
7010  whalo, ehalo, shalo, nhalo, tileMe)
7011 type(contact_type), dimension(:), intent(in) :: eCont, sCont, wCont, nCont
7012 integer, dimension(:), intent(in) :: isg, ieg, jsg, jeg
7013 integer, intent(inout) :: numR, numS
7014 integer, dimension(:), intent(inout) :: tileRecv, tileSend
7015 integer, dimension(:), intent(inout) :: is1Recv, ie1Recv, js1Recv, je1Recv
7016 integer, dimension(:), intent(inout) :: is2Recv, ie2Recv, js2Recv, je2Recv
7017 integer, dimension(:), intent(inout) :: is1Send, ie1Send, js1Send, je1Send
7018 integer, dimension(:), intent(inout) :: is2Send, ie2Send, js2Send, je2Send
7019 integer, dimension(:), intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
7020 integer, intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
7021 integer :: is1, ie1, js1, je1, is2, ie2, js2, je2
7022 integer :: tn, tc, n, m
7023 logical :: found_corner
7024 
7025 found_corner = .false.
7026 !--- southeast for recving
7027 if(econt(tileme)%ncontact > 0) then
7028  if(econt(tileme)%js1(1) == jsg(tileme) ) then
7029  tn = econt(tileme)%tile(1)
7030  if(econt(tileme)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
7031  if( econt(tileme)%js2(1) - jsg(tn) < shalo ) call mpp_error(fatal, &
7032  "mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
7033  found_corner = .true.; tc = tn
7034  is1 = econt(tileme)%ie1(1) + 1; je1 = econt(tileme)%js1(1) - 1
7035  is2 = econt(tileme)%is2(1); je2 = econt(tileme)%js2(1) - 1
7036  else if(scont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7037  if(scont(tn)%is1(1) == isg(tn)) then ! corner is nc.
7038  found_corner = .true.; tc = scont(tn)%tile(1)
7039  is1 = econt(tileme)%ie1(1) + 1; je1 = econt(tileme)%js1(1) - 1
7040  is2 = scont(tn)%is2(1); je2 = scont(tn)%je2(1)
7041  end if
7042  end if
7043  end if
7044 end if
7045 if( .not. found_corner ) then ! not found,
7046  n = scont(tileme)%ncontact
7047  if( n > 0) then
7048  if( scont(tileme)%ie1(n) == ieg(tileme)) then
7049  tn = scont(tileme)%tile(n)
7050  if(scont(tileme)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
7051  if(ieg(tn) - scont(tileme)%ie2(n) < ehalo ) call mpp_error(fatal, &
7052  "mpp_domains_define.inc: southeast tile for recv 2 is not tiled properly")
7053  found_corner = .true.; tc = tn
7054  is1 = scont(tileme)%ie1(n) + 1; je1 = scont(tileme)%js1(n) - 1
7055  is2 = scont(tileme)%ie2(n) + 1; je2 = scont(tileme)%je2(n)
7056  else if(econt(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
7057  m = econt(tn)%ncontact
7058  if(econt(tn)%je1(m) == jeg(tn)) then ! corner is nc.
7059  found_corner = .true.; tc = econt(tn)%tile(m)
7060  is1 = scont(tileme)%ie1(n) + 1; je1 = scont(tileme)%js1(n) - 1
7061  is2 = econt(tn)%is2(m); je2 = econt(tn)%je2(m)
7062  end if
7063  end if
7064  end if
7065  end if
7066 end if
7067 if(found_corner) then
7068  numr = numr + 1
7069  tilerecv(numr) = tc; align1recv(numr) = south_east; align2recv(numr) = north_west
7070  is1recv(numr) = is1; ie1recv(numr) = is1 + ehalo - 1
7071  js1recv(numr) = je1 - shalo + 1; je1recv(numr) = je1
7072  is2recv(numr) = is2; ie2recv(numr) = is2 + ehalo - 1
7073  js2recv(numr) = je2 - shalo + 1; je2recv(numr) = je2
7074 end if
7075 
7076 !--- southwest for recving
7077 found_corner = .false.
7078 if(wcont(tileme)%ncontact > 0) then
7079  if(wcont(tileme)%js1(1) == jsg(tileme) ) then
7080  tn = wcont(tileme)%tile(1)
7081  if(wcont(tileme)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
7082  if( wcont(tileme)%js2(1) - jsg(tn) < shalo ) call mpp_error(fatal, &
7083  "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7084  found_corner = .true.; tc = tn
7085  ie1 = wcont(tileme)%is1(1) - 1; je1 = wcont(tileme)%js1(1) - 1
7086  ie2 = wcont(tileme)%is2(1); je2 = wcont(tileme)%js2(1) - 1
7087  else if(scont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7088  n = scont(tn)%ncontact
7089  if(scont(tn)%ie1(n) == ieg(tn)) then ! corner is nc.
7090  found_corner = .true.; tc = scont(tn)%tile(n)
7091  ie1 = wcont(tileme)%is1(1) - 1; je1 = wcont(tileme)%js1(1) - 1
7092  ie2 = scont(tn)%ie2(1); je2 = scont(tn)%je2(1)
7093  end if
7094  end if
7095  end if
7096 end if
7097 if( .not. found_corner ) then ! not found,
7098  n = scont(tileme)%ncontact
7099  if( n > 0) then
7100  if( scont(tileme)%is1(1) == isg(tileme)) then
7101  tn = scont(tileme)%tile(1)
7102  if(scont(tileme)%is2(1) > isg(tn) ) then ! the corner tile is tn.
7103  if( scont(tileme)%is2(1)-isg(tn) < whalo ) call mpp_error(fatal, &
7104  "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7105  found_corner = .true.; tc = tn
7106  ie1 = scont(tileme)%is1(1) - 1; je1 = scont(tileme)%js1(1) - 1
7107  ie2 = scont(tileme)%is2(1) - 1; je2 = scont(tileme)%js2(1)
7108  else if(wcont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7109  m = wcont(tn)%ncontact
7110  if(wcont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
7111  found_corner = .true.; tc = wcont(tn)%tile(m)
7112  ie1 = scont(tileme)%is1(1) - 1; je1 = scont(tileme)%js1(1) - 1
7113  ie2 = wcont(tn)%ie2(m); je2 = wcont(tn)%je2(m)
7114  end if
7115  end if
7116  end if
7117  end if
7118 end if
7119 if(found_corner) then
7120  numr = numr + 1
7121  tilerecv(numr) = tc; align1recv(numr) = south_west; align2recv(numr) = north_east
7122  is1recv(numr) = ie1 - whalo + 1; ie1recv(numr) = ie1
7123  js1recv(numr) = je1 - shalo + 1; je1recv(numr) = je1
7124  is2recv(numr) = ie2 - whalo + 1; ie2recv(numr) = ie2
7125  js2recv(numr) = je2 - shalo + 1; je2recv(numr) = je2
7126 end if
7127 
7128 !--- northwest for recving
7129 found_corner = .false.
7130 n = wcont(tileme)%ncontact
7131 if( n > 0) then
7132  if(wcont(tileme)%je1(n) == jeg(tileme) ) then
7133  tn = wcont(tileme)%tile(n)
7134  if(wcont(tileme)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
7135  if( jeg(tn) - wcont(tileme)%je2(n) < nhalo ) call mpp_error(fatal, &
7136  "mpp_domains_define.inc: northwest tile for recv 1 is not tiled properly")
7137  found_corner = .true.; tc = tn
7138  ie1 = wcont(tileme)%is1(n) - 1; js1 = wcont(tileme)%je1(n) + 1
7139  ie2 = wcont(tileme)%is2(n); js2 = wcont(tileme)%je2(n) + 1
7140  else if(ncont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7141  m = ncont(tn)%ncontact
7142  if(ncont(tn)%ie1(m) == ieg(tn)) then ! corner is nc.
7143  found_corner = .true.; tc = ncont(tn)%tile(m)
7144  ie1 = wcont(tileme)%is1(n) - 1; js1 = wcont(tileme)%je1(n) + 1
7145  ie2 = ncont(tn)%ie2(m); js2 = ncont(tn)%js2(m)
7146  end if
7147  endif
7148  endif
7149 end if
7150 if( .not. found_corner ) then ! not found,
7151  if( ncont(tileme)%ncontact > 0) then
7152  if( ncont(tileme)%is1(1) == isg(tileme)) then
7153  tn = ncont(tileme)%tile(1)
7154  if(ncont(tileme)%is2(1) > isg(tn) ) then ! the corner tile is tn.
7155  if( ncont(tileme)%is2(1)-isg(tn) < whalo ) call mpp_error(fatal, &
7156  "mpp_domains_define.inc: northwest tile for recv 2 is not tiled properly")
7157  found_corner = .true.; tc = tn
7158  ie1 = ncont(tileme)%is1(1) - 1; js1 = ncont(tileme)%je1(1) + 1
7159  ie2 = ncont(tileme)%is2(1) - 1; js2 = ncont(tileme)%js2(1)
7160  else if(wcont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7161  if(wcont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7162  found_corner = .true.; tc = wcont(tn)%tile(1)
7163  ie1 = ncont(tileme)%is1(1) - 1; js1 = ncont(tileme)%je1(1) + 1
7164  ie2 = wcont(tn)%ie2(1); js2 = wcont(tn)%js2(1)
7165  end if
7166  end if
7167  end if
7168  end if
7169 end if
7170 if(found_corner) then
7171  numr = numr + 1
7172  tilerecv(numr) = tc; align1recv(numr) =north_west; align2recv(numr) = south_east
7173  is1recv(numr) = ie1 - whalo + 1; ie1recv(numr) = ie1
7174  js1recv(numr) = js1; je1recv(numr) = js1 + nhalo - 1
7175  is2recv(numr) = ie2 - whalo + 1; ie2recv(numr) = ie2
7176  js2recv(numr) = js2; je2recv(numr) = js2 + nhalo - 1
7177 end if
7178 
7179 !--- northeast for recving
7180 found_corner = .false.
7181 n = econt(tileme)%ncontact
7182 if( n > 0) then
7183  if(econt(tileme)%je1(n) == jeg(tileme) ) then
7184  tn = econt(tileme)%tile(n)
7185  if(econt(tileme)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
7186  if( jeg(tn) - econt(tileme)%je2(n) < nhalo ) call mpp_error(fatal, &
7187  "mpp_domains_define.inc: northeast tile for recv 1 is not tiled properly")
7188  found_corner = .true.; tc = tn
7189  is1 = econt(tileme)%ie1(n) + 1; js1 = econt(tileme)%je1(n) + 1
7190  is2 = econt(tileme)%is2(1); js2 = econt(tileme)%je2(1) + 1
7191  else if(ncont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7192  if(ncont(tn)%is1(1) == isg(tn)) then ! corner is nc.
7193  found_corner = .true.; tc = ncont(tn)%tile(1)
7194  is1 = econt(tileme)%ie1(n) + 1; js1 = econt(tileme)%je1(n) + 1
7195  is2 = ncont(tn)%is2(1); js2 = ncont(tn)%js2(1)
7196  end if
7197  end if
7198  end if
7199 end if
7200 if( .not. found_corner ) then ! not found,
7201  n = ncont(tileme)%ncontact
7202  if( n > 0) then
7203  if( ncont(tileme)%ie1(n) == ieg(tileme)) then
7204  tn = ncont(tileme)%tile(n)
7205  if(ncont(tileme)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
7206  if(ieg(tn) - scont(tileme)%ie2(n) < ehalo ) call mpp_error(fatal, &
7207  "mpp_domains_define.inc: northeast tile for recv 2 is not tiled properly")
7208  found_corner = .true.; tc = tn
7209  is1 = scont(tileme)%ie1(n) + 1; js1 = scont(tileme)%je1(n) + 1
7210  is2 = scont(tileme)%ie2(n) + 1; js2 = scont(tileme)%js2(n)
7211  else if(econt(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
7212  if(econt(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7213  found_corner = .true.; tc = econt(tn)%tile(1)
7214  is1 = scont(tileme)%ie1(n) + 1; js1 = scont(tileme)%je1(n) + 1
7215  is2 = econt(tn)%is2(m); js2 = econt(tn)%js2(m)
7216  end if
7217  end if
7218  end if
7219  end if
7220 end if
7221 if(found_corner) then
7222  numr = numr + 1
7223  tilerecv(numr) = tc; align1recv(numr) =north_east; align2recv(numr) = south_west
7224  is1recv(numr) = is1; ie1recv(numr) = is1 + ehalo - 1
7225  js1recv(numr) = js1; je1recv(numr) = js1 + nhalo - 1
7226  is2recv(numr) = is2; ie2recv(numr) = is2 + ehalo - 1
7227  js2recv(numr) = js2; je2recv(numr) = js2 + nhalo - 1
7228 end if
7229 
7230 !--- to_pe's southeast for sending
7231 do n = 1, wcont(tileme)%ncontact
7232  tn = wcont(tileme)%tile(n)
7233  if(wcont(tileme)%js2(n) == jsg(tn) ) then
7234  if(wcont(tileme)%js1(n) > jsg(tileme) ) then ! send to tile tn.
7235  if( wcont(tileme)%js1(n) - jsg(tileme) < shalo ) call mpp_error(fatal, &
7236  "mpp_domains_define.inc: southeast tile for send 1 is not tiled properly")
7237  nums = nums+1; tilesend(nums) = tn
7238  align1send(nums) = north_west; align2send(nums) = south_east
7239  is1send(nums) = wcont(tileme)%is1(n); ie1send(nums) = is1send(nums) + ehalo - 1
7240  je1send(nums) = wcont(tileme)%js1(n) - 1; js1send(nums) = je1send(nums) - shalo + 1
7241  is2send(nums) = wcont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7242  je2send(nums) = wcont(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7243  end if
7244  end if
7245 end do
7246 do n = 1, ncont(tileme)%ncontact
7247  tn = ncont(tileme)%tile(n)
7248  if(ncont(tileme)%ie2(n) == ieg(tn) ) then
7249  if(ncont(tileme)%ie1(n) < ieg(tileme) ) then ! send to tile tn.
7250  if( ieg(tileme) - ncont(tileme)%ie1(n) < ehalo ) call mpp_error(fatal, &
7251  "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7252  nums = nums+1; tilesend(nums) = tn
7253  align1send(nums) = north_west; align2send(nums) = south_east
7254  is1send(nums) = ncont(tileme)%ie1(n) + 1; ie1send(nums) = is1send(nums) + ehalo - 1
7255  je1send(nums) = ncont(tileme)%je1(n) ; js1send(nums) = je1send(nums) - shalo + 1
7256  is2send(nums) = ncont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7257  je2send(nums) = ncont(tileme)%je2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7258  end if
7259  end if
7260 end do
7261 
7262 !--- found the corner overlap that is not specified through contact line.
7263 n = wcont(tileme)%ncontact
7264 found_corner = .false.
7265 if( n > 0) then
7266  tn = wcont(tileme)%tile(n)
7267  if( wcont(tileme)%je1(n) == jeg(tileme) .AND. wcont(tileme)%je2(n) == jeg(tn) ) then
7268  m = ncont(tn)%ncontact
7269  if(m >0) then
7270  tc = ncont(tn)%tile(m)
7271  if( ncont(tn)%ie1(m) == ieg(tn) .AND. ncont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7272  end if
7273  end if
7274 end if
7275 if( .not. found_corner ) then ! not found, then starting from north contact
7276  if( ncont(tileme)%ncontact > 0) then
7277  tn = ncont(tileme)%tile(1)
7278  if( ncont(tileme)%is1(1) == isg(tileme) .AND. ncont(tileme)%is2(1) == isg(tn) ) then
7279  if(wcont(tn)%ncontact >0) then
7280  tc = wcont(tn)%tile(1)
7281  if( wcont(tn)%js1(1) == jsg(tn) .AND. wcont(tn)%js2(1) == jsg(tc) ) found_corner = .true.
7282  end if
7283  end if
7284  end if
7285 end if
7286 
7287 if(found_corner) then
7288  nums = nums+1; tilesend(nums) = tc
7289  align1send(nums) = north_west; align2send(nums) = south_east
7290  is1send(nums) = isg(tileme); ie1send(nums) = is1send(nums) + ehalo - 1
7291  je1send(nums) = jeg(tileme); js1send(nums) = je1send(nums) - shalo + 1
7292  is2send(nums) = ieg(tc) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7293  je2send(nums) = jsg(tc) - 1; js2send(nums) = je2send(nums) - shalo + 1
7294 end if
7295 
7296 !--- to_pe's southwest for sending
7297 do n = 1, econt(tileme)%ncontact
7298  tn = econt(tileme)%tile(n)
7299  if(econt(tileme)%js2(n) == jsg(tn) ) then
7300  if(econt(tileme)%js1(n) > jsg(tileme) ) then ! send to tile tn.
7301  if( econt(tileme)%js1(n) - jsg(tileme) < shalo ) call mpp_error(fatal, &
7302  "mpp_domains_define.inc: southwest tile for send 1 is not tiled properly")
7303  nums = nums+1; tilesend(nums) = tn
7304  align1send(nums) = north_east; align2send(nums) = south_west
7305  ie1send(nums) = econt(tileme)%ie1(n); is1send(nums) = ie1send(nums) - whalo + 1
7306  je1send(nums) = econt(tileme)%js1(n) - 1; js1send(nums) = je1send(nums) - shalo + 1
7307  ie2send(nums) = econt(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7308  je2send(nums) = econt(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 1
7309  end if
7310  end if
7311 end do
7312 do n = 1, ncont(tileme)%ncontact
7313  tn = ncont(tileme)%tile(n)
7314  if(ncont(tileme)%is2(n) == isg(tn) ) then
7315  if(ncont(tileme)%is1(n) > isg(tileme) ) then ! send to tile tn.
7316  if( ncont(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) = north_east; align2send(nums) = south_west
7320  ie1send(nums) = ncont(tileme)%is1(n) - 1; is1send(nums) = ie1send(nums) - whalo + 1
7321  ie1send(nums) = ncont(tileme)%je1(n) ; js1send(nums) = je1send(nums) - shalo + 1
7322  ie2send(nums) = ncont(tileme)%is2(n) - 1; is2send(nums) = je2send(nums) - whalo + 1
7323  je2send(nums) = ncont(tileme)%js2(n) - 1; js2send(nums) = je2send(nums) - shalo + 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(n)
7333  if( econt(tileme)%je1(n) == jeg(tileme) .AND. econt(tileme)%je2(n) == jeg(tn) ) then
7334  if(ncont(tn)%ncontact >0) then
7335  tc = ncont(tn)%tile(1)
7336  if( ncont(tn)%is1(1) == isg(tn) .AND. ncont(tn)%is2(n) == 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 = ncont(tileme)%ncontact
7342  if( n > 0) then
7343  tn = ncont(tileme)%tile(n)
7344  if( ncont(tileme)%ie1(n) == ieg(tileme) .AND. ncont(tileme)%ie2(n) == ieg(tn) ) then
7345  if(econt(tn)%ncontact >0) then
7346  tc = econt(tn)%tile(1)
7347  if( econt(tn)%js1(1) == jsg(tn) .AND. econt(tn)%js2(n) == jsg(tc) ) found_corner = .true.
7348  end if
7349  end if
7350  end if
7351 end if
7352 
7353 if(found_corner) then
7354  nums = nums+1; tilesend(nums) = tc
7355  align1send(nums) = north_east; align2send(nums) = south_west
7356  ie1send(nums) = ieg(tileme); is1send(nums) = ie1send(nums) - whalo + 1
7357  je1send(nums) = jeg(tileme); js1send(nums) = je1send(nums) - shalo + 1
7358  ie2send(nums) = isg(tc) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7359  je2send(nums) = jsg(tc) - 1; js2send(nums) = je2send(nums) - shalo + 1
7360 end if
7361 
7362 !--- to_pe's northwest for sending
7363 do n = 1, econt(tileme)%ncontact
7364  tn = econt(tileme)%tile(n)
7365  if(econt(tileme)%je2(n) == jeg(tn) ) then
7366  if(econt(tileme)%je1(n) < jeg(tileme) ) then ! send to tile tn.
7367  if( jeg(tileme) - econt(tileme)%je1(n) < nhalo ) call mpp_error(fatal, &
7368  "mpp_domains_define.inc: northwest tile for send 1 is not tiled properly")
7369  nums = nums+1; tilesend(nums) = tn
7370  align1send(nums) = south_east; align2send(nums) = north_west
7371  ie1send(nums) = econt(tileme)%ie1(n) ; is1send(nums) = ie1send(nums) - whalo + 1
7372  js1send(nums) = econt(tileme)%je1(n) + 1; je1send(nums) = js1send(nums) + nhalo - 1
7373  ie2send(nums) = econt(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7374  js2send(nums) = econt(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7375  end if
7376  end if
7377 end do
7378 
7379 do n = 1, scont(tileme)%ncontact
7380  tn = scont(tileme)%tile(n)
7381  if(scont(tileme)%is2(n) == isg(tn) ) then
7382  if(scont(tileme)%is1(n) > isg(tileme) ) then ! send to tile tn.
7383  if( scont(tileme)%is1(n) - isg(tileme) < whalo ) call mpp_error(fatal, &
7384  "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7385  nums = nums+1; tilesend(nums) = tn
7386  align1send(nums) = south_east; align2send(nums) = north_west
7387  ie1send(nums) = ncont(tileme)%is1(n) - 1; is1send(nums) = ie1send(nums) - whalo + 1
7388  js1send(nums) = ncont(tileme)%je1(n) ; je1send(nums) = js1send(nums) + nhalo - 1
7389  ie2send(nums) = ncont(tileme)%is2(n) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7390  js2send(nums) = ncont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7391  end if
7392  end if
7393 end do
7394 
7395 !--- found the corner overlap that is not specified through contact line.
7396 n = econt(tileme)%ncontact
7397 found_corner = .false.
7398 if( n > 0) then
7399  tn = econt(tileme)%tile(1)
7400  if( econt(tileme)%js1(1) == jsg(tileme) .AND. econt(tileme)%js2(1) == jsg(tn) ) then
7401  if(scont(tn)%ncontact >0) then
7402  tc = scont(tn)%tile(1)
7403  if( scont(tn)%is1(1) == isg(tn) .AND. scont(tn)%is2(1) == isg(tc) ) found_corner = .true.
7404  end if
7405  end if
7406 end if
7407 if( .not. found_corner ) then ! not found, then starting from north contact
7408  n = scont(tileme)%ncontact
7409  found_corner = .false.
7410  if( n > 0) then
7411  tn = scont(tileme)%tile(n)
7412  if( scont(tileme)%ie1(n) == ieg(tileme) .AND. scont(tileme)%ie2(n) == ieg(tn) ) then
7413  if(econt(tn)%ncontact >0) then
7414  tc = econt(tn)%tile(n)
7415  if( econt(tn)%je1(n) == jeg(tn) .AND. econt(tn)%je2(n) == jeg(tc) ) found_corner = .true.
7416  end if
7417  end if
7418  end if
7419 end if
7420 
7421 if(found_corner) then
7422  nums = nums+1; tilesend(nums) = tc
7423  align1send(nums) = south_east; align2send(nums) = north_west
7424  ie1send(nums) = ieg(tileme); is1send(nums) = ie1send(nums) - whalo + 1
7425  js1send(nums) = jsg(tileme); je1send(nums) = js1send(nums) + nhalo - 1
7426  ie2send(nums) = isg(tc) - 1; is2send(nums) = ie2send(nums) - whalo + 1
7427  js2send(nums) = jeg(tc) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7428 end if
7429 
7430 !--- to_pe's northeast for sending
7431 do n = 1, wcont(tileme)%ncontact
7432  tn = wcont(tileme)%tile(n)
7433  if(wcont(tileme)%je2(n) == jeg(tn) ) then
7434  if(wcont(tileme)%je1(n) < jeg(tileme) ) then ! send to tile tn.
7435  if( jeg(tileme) - wcont(tileme)%je1(n) < nhalo ) call mpp_error(fatal, &
7436  "mpp_domains_define.inc: northeast tile for send 1 is not tiled properly")
7437  nums = nums+1; tilesend(nums) = tn
7438  align1send(nums) = south_west; align2send(nums) = north_east
7439  is1send(nums) = wcont(tileme)%is1(n) ; ie1send(nums) = is1send(nums) + ehalo - 1
7440  js1send(nums) = wcont(tileme)%je1(n) + 1; je1send(nums) = js1send(nums) + nhalo - 1
7441  is2send(nums) = wcont(tileme)%ie2(n) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7442  js2send(nums) = wcont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7443  end if
7444  end if
7445 end do
7446 
7447 do n = 1, scont(tileme)%ncontact
7448  tn = scont(tileme)%tile(n)
7449  if(scont(tileme)%ie2(n) == ieg(tn) ) then
7450  if(scont(tileme)%ie1(n) < ieg(tileme) ) then ! send to tile tn.
7451  if( ieg(tileme) - scont(tileme)%ie1(n) < ehalo ) call mpp_error(fatal, &
7452  "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7453  nums = nums+1; tilesend(nums) = tn
7454  align1send(nums) = south_west; align2send(nums) = north_east
7455  is1send(nums) = scont(tileme)%ie1(n) + 1; ie1send(nums) = is1send(nums) + ehalo - 1
7456  js1send(nums) = scont(tileme)%js1(n) ; je1send(nums) = js1send(nums) + nhalo - 1
7457  is2send(nums) = scont(tileme)%ie2(n) + 1; ie2send(nums) = is1send(nums) + ehalo - 1
7458  js2send(nums) = scont(tileme)%je2(n) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7459  end if
7460  end if
7461 end do
7462 
7463 !--- found the corner overlap that is not specified through contact line.
7464 n = wcont(tileme)%ncontact
7465 found_corner = .false.
7466 if( n > 0) then
7467  tn = wcont(tileme)%tile(1)
7468  if( wcont(tileme)%js1(n) == jsg(tileme) .AND. wcont(tileme)%js2(n) == jsg(tn) ) then
7469  m = scont(tn)%ncontact
7470  if(m >0) then
7471  tc = scont(tn)%tile(m)
7472  if( scont(tn)%ie1(m) == ieg(tn) .AND. scont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7473  end if
7474  end if
7475 end if
7476 if( .not. found_corner ) then ! not found, then starting from north contact
7477  n = scont(tileme)%ncontact
7478  found_corner = .false.
7479  if( n > 0) then
7480  tn = scont(tileme)%tile(1)
7481  if( scont(tileme)%is1(1) == isg(tileme) .AND. scont(tileme)%is2(1) == isg(tn) ) then
7482  m = wcont(tn)%ncontact
7483  if( m > 0 ) then
7484  tc = wcont(tn)%tile(m)
7485  if( wcont(tn)%je1(m) == jeg(tn) .AND. wcont(tn)%je2(m) == jeg(tc) ) found_corner = .true.
7486  end if
7487  end if
7488  end if
7489 end if
7490 if(found_corner) then
7491  nums = nums+1; tilesend(nums) = tc
7492  align1send(nums) = south_west; align2send(nums) = north_east
7493  is1send(nums) = isg(tileme); ie1send(nums) = is1send(nums) + ehalo - 1
7494  js1send(nums) = jsg(tileme); je1send(nums) = js1send(nums) + nhalo - 1
7495  is2send(nums) = ieg(tc) + 1; ie2send(nums) = is2send(nums) + ehalo - 1
7496  js2send(nums) = jeg(tc) + 1; je2send(nums) = js2send(nums) + nhalo - 1
7497 end if
7498 
7499 end subroutine fill_corner_contact
7500 
7501 !--- find the alignment direction, check if index is reversed, if reversed, exchange index.
7502 subroutine check_alignment( is, ie, js, je, isg, ieg, jsg, jeg, alignment )
7503 integer, intent(inout) :: is, ie, js, je, isg, ieg, jsg, jeg
7504 integer, intent(out) :: alignment
7505 
7506 integer :: i, j
7507 
7508 if ( is == ie ) then ! x-alignment
7509  if ( is == isg ) then
7510  alignment = west
7511  else if ( is == ieg ) then
7512  alignment = east
7513  else
7514  call mpp_error(fatal, 'mpp_domains_define.inc: The contact region is not on the x-boundary of the tile')
7515  end if
7516  if ( js > je ) then
7517  j = js; js = je; je = j
7518  end if
7519 else if ( js == je ) then ! y-alignment
7520  if ( js == jsg ) then
7521  alignment = south
7522  else if ( js == jeg ) then
7523  alignment = north
7524  else
7525  call mpp_error(fatal, 'mpp_domains_define.inc: The contact region is not on the y-boundary of the tile')
7526  end if
7527  if ( is > ie ) then
7528  i = is; is = ie; ie = i
7529  end if
7530 else
7531  call mpp_error(fatal, 'mpp_domains_define.inc: The contact region should be line contact' )
7532 end if
7533 
7534 end subroutine check_alignment
7535 !#####################################################################
7536 
7537 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7538 ! !
7539 ! MPP_MODIFY_DOMAIN: modify extent of domain !
7540 ! !
7541 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7542 
7543 !> @brief Modifies the exents of a domain
7544 subroutine mpp_modify_domain1d(domain_in,domain_out,cbegin,cend,gbegin,gend, hbegin, hend)
7545  ! </PUBLICROUTINE>
7546 type(domain1d), intent(in) :: domain_in !< The source domain.
7547 type(domain1d), intent(inout) :: domain_out !< The returned domain.
7548 integer, intent(in), optional :: hbegin, hend !< halo size
7549 integer, intent(in), optional :: cbegin, cend !< Axis specifications associated with the compute
7550  !! domain of the returned 1D domain.
7551 integer, intent(in), optional :: gbegin, gend !< Axis specifications associated with the global
7552  !! domain of the returned 1D domain.
7553 integer :: ndivs, global_indices(2) !(/ isg, ieg /)
7554 integer :: flag
7555 ! get the global indices of the input domain
7556 global_indices(1) = domain_in%global%begin; global_indices(2) = domain_in%global%end
7557 
7558 ! get the layout
7559 ndivs = size(domain_in%list(:))
7560 
7561 ! get the flag
7562 flag = 0
7563 if(domain_in%cyclic) flag = flag + cyclic_global_domain
7564 if(domain_in%domain_data%is_global) flag = flag + global_data_domain
7565 
7566 call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, &
7567  flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size )
7568 
7569 if(present(cbegin)) domain_out%compute%begin = cbegin
7570 if(present(cend)) domain_out%compute%end = cend
7571 domain_out%compute%size = domain_out%compute%end - domain_out%compute%begin + 1
7572 if(present(gbegin)) domain_out%global%begin = gbegin
7573 if(present(gend)) domain_out%global%end = gend
7574 domain_out%global%size = domain_out%global%end - domain_out%global%begin + 1
7575 
7576 end subroutine mpp_modify_domain1d
7577 
7578 !#######################################################################
7579 
7580 subroutine mpp_modify_domain2d(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, &
7581  & shalo, nhalo)
7582  ! </PUBLICROUTINE>
7583 type(domain2d), intent(in) :: domain_in !< The source domain.
7584 type(domain2d), intent(inout) :: domain_out !< The returned domain.
7585 integer, intent(in), optional :: isc, iec, jsc, jec !< Zonal and meridional axis specifications
7586  !! associated with the global domain of the returned 2D domain.
7587 integer, intent(in), optional :: isg, ieg, jsg, jeg !< Zonal axis specifications associated with
7588  !! the global domain of the returned 2D domain.
7589 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo !< halo size in x- and y- directions
7590 integer :: global_indices(4), layout(2)
7591 integer :: xflag, yflag, nlist, i
7592 
7593 if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) then
7594  ! get the global indices of the input domain
7595  global_indices(1) = domain_in%x(1)%global%begin; global_indices(2) = domain_in%x(1)%global%end
7596  global_indices(3) = domain_in%y(1)%global%begin; global_indices(4) = domain_in%y(1)%global%end
7597 
7598  ! get the layout
7599  layout(1) = size(domain_in%x(1)%list(:)); layout(2) = size(domain_in%y(1)%list(:))
7600 
7601  ! get the flag
7602  xflag = 0; yflag = 0
7603  if(domain_in%x(1)%cyclic) xflag = xflag + cyclic_global_domain
7604  if(domain_in%x(1)%domain_data%is_global) xflag = xflag + global_data_domain
7605  if(domain_in%y(1)%cyclic) yflag = yflag + cyclic_global_domain
7606  if(domain_in%y(1)%domain_data%is_global) yflag = yflag + global_data_domain
7607 
7608  call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, &
7609  xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, &
7610  shalo = shalo, nhalo = nhalo, &
7611  xextent = domain_in%x(1)%list(:)%compute%size, &
7612  yextent = domain_in%y(1)%list(:)%compute%size, &
7613  symmetry=domain_in%symmetry, &
7614  maskmap = domain_in%pearray .NE. null_pe )
7615  domain_out%ntiles = domain_in%ntiles
7616  domain_out%tile_id = domain_in%tile_id
7617 else
7618  call mpp_define_null_domain(domain_out)
7619  nlist = size(domain_in%list(:))
7620  if (associated(domain_out%list)) deallocate(domain_out%list) !< Check if allocated
7621  allocate(domain_out%list(0:nlist-1) )
7622  do i = 0, nlist-1
7623  allocate(domain_out%list(i)%tile_id(1))
7624  domain_out%list(i)%tile_id(1) = 1
7625  enddo
7626  call mpp_modify_domain(domain_in%x(1), domain_out%x(1), isc, iec, isg, ieg)
7627  call mpp_modify_domain(domain_in%y(1), domain_out%y(1), jsc, jec, jsg, jeg)
7628  domain_out%ntiles = domain_in%ntiles
7629  domain_out%tile_id = domain_in%tile_id
7630 endif
7631 
7632 end subroutine mpp_modify_domain2d
7633 ! </SUBROUTINE>
7634 
7635 !#####################################################################
7636 
7637 
7638 subroutine mpp_define_null_domain1d(domain)
7639 type(domain1d), intent(inout) :: domain
7640 
7641 domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0
7642 domain%domain_data%begin = -1; domain%domain_data%end = -1; domain%domain_data%size = 0
7643 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
7644 domain%pe = null_pe
7645 
7646 end subroutine mpp_define_null_domain1d
7647 
7648 !#####################################################################
7649 
7650 
7651 subroutine mpp_define_null_domain2d(domain)
7652 type(domain2d), intent(inout) :: domain
7653 
7654 allocate(domain%x(1), domain%y(1), domain%tile_id(1))
7655 call mpp_define_null_domain(domain%x(1))
7656 call mpp_define_null_domain(domain%y(1))
7657 domain%pe = null_pe
7658 domain%tile_id(1) = 1
7659 domain%ntiles = 1
7660 domain%max_ntile_pe = 1
7661 domain%ncontacts = 0
7662 
7663 end subroutine mpp_define_null_domain2d
7664 
7665 !####################################################################
7666 
7667 subroutine mpp_deallocate_domain1d(domain)
7668  type(domain1d), intent(inout) :: domain
7669 
7670  if(ASSOCIATED(domain%list)) deallocate(domain%list)
7671 
7672 end subroutine mpp_deallocate_domain1d
7673 
7674 !####################################################################
7675 
7676 subroutine mpp_deallocate_domain2d(domain)
7677  type(domain2d), intent(inout) :: domain
7678 
7679  call deallocate_domain2d_local(domain)
7680  if(ASSOCIATED(domain%io_domain) ) then
7681  call deallocate_domain2d_local(domain%io_domain)
7682  deallocate(domain%io_domain)
7683  endif
7684 
7685 end subroutine mpp_deallocate_domain2d
7686 
7687 !##################################################################
7688 
7689 subroutine deallocate_domain2d_local(domain)
7690 type(domain2d), intent(inout) :: domain
7691 integer :: i, ntileMe
7692 
7693 ntileme = size(domain%x(:))
7694 
7695 if(ASSOCIATED(domain%pearray))deallocate(domain%pearray)
7696 do i = 1, ntileme
7697  call mpp_deallocate_domain1d(domain%x(i))
7698  call mpp_deallocate_domain1d(domain%y(i))
7699 enddo
7700 deallocate(domain%x, domain%y, domain%tile_id)
7701 
7702 ! TODO: Check if these are always allocated
7703 if(ASSOCIATED(domain%tileList)) deallocate(domain%tileList)
7704 if(ASSOCIATED(domain%tile_id_all)) deallocate(domain%tile_id_all)
7705 
7706 if(ASSOCIATED(domain%list)) then
7707  do i = 0, size(domain%list(:))-1
7708  deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id)
7709  enddo
7710  deallocate(domain%list)
7711 endif
7712 
7713 if(ASSOCIATED(domain%check_C)) then
7714  call deallocate_overlapspec(domain%check_C)
7715  deallocate(domain%check_C)
7716 endif
7717 
7718 if(ASSOCIATED(domain%check_E)) then
7719  call deallocate_overlapspec(domain%check_E)
7720  deallocate(domain%check_E)
7721 endif
7722 
7723 if(ASSOCIATED(domain%check_N)) then
7724  call deallocate_overlapspec(domain%check_N)
7725  deallocate(domain%check_N)
7726 endif
7727 
7728 if(ASSOCIATED(domain%bound_C)) then
7729  call deallocate_overlapspec(domain%bound_C)
7730  deallocate(domain%bound_C)
7731 endif
7732 
7733 if(ASSOCIATED(domain%bound_E)) then
7734  call deallocate_overlapspec(domain%bound_E)
7735  deallocate(domain%bound_E)
7736 endif
7737 
7738 if(ASSOCIATED(domain%bound_N)) then
7739  call deallocate_overlapspec(domain%bound_N)
7740  deallocate(domain%bound_N)
7741 endif
7742 
7743 if(ASSOCIATED(domain%update_T)) then
7744  call deallocate_overlapspec(domain%update_T)
7745  deallocate(domain%update_T)
7746 endif
7747 
7748 if(ASSOCIATED(domain%update_E)) then
7749  call deallocate_overlapspec(domain%update_E)
7750  deallocate(domain%update_E)
7751 endif
7752 
7753 if(ASSOCIATED(domain%update_C)) then
7754  call deallocate_overlapspec(domain%update_C)
7755  deallocate(domain%update_C)
7756 endif
7757 
7758 if(ASSOCIATED(domain%update_N)) then
7759  call deallocate_overlapspec(domain%update_N)
7760  deallocate(domain%update_N)
7761 endif
7762 
7763 end subroutine deallocate_domain2d_local
7764 
7765 !####################################################################
7766 
7767 subroutine allocate_check_overlap(overlap, count)
7768  type(overlap_type), intent(inout) :: overlap
7769  integer, intent(in ) :: count
7770 
7771  overlap%count = 0
7772  overlap%pe = null_pe
7773  if(associated(overlap%tileMe)) call mpp_error(fatal, &
7774  "allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
7775  if(count < 1) call mpp_error(fatal, &
7776  "allocate_check_overlap(mpp_domains_define): count should be a positive integer")
7777  allocate(overlap%tileMe (count), overlap%dir(count) )
7778  allocate(overlap%is (count), overlap%ie (count) )
7779  allocate(overlap%js (count), overlap%je (count) )
7780  allocate(overlap%rotation(count) )
7781  overlap%rotation = zero
7782 
7783 end subroutine allocate_check_overlap
7784 
7785 !#######################################################################
7786 subroutine insert_check_overlap(overlap, pe, tileMe, dir, rotation, is, ie, js, je)
7787  type(overlap_type), intent(inout) :: overlap
7788  integer, intent(in ) :: pe
7789  integer, intent(in ) :: tileMe, dir, rotation
7790  integer, intent(in ) :: is, ie, js, je
7791  integer :: count
7792 
7793  overlap%count = overlap%count + 1
7794  count = overlap%count
7795  if(.NOT. associated(overlap%tileMe)) call mpp_error(fatal, &
7796  "mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
7797  if(count > size(overlap%tileMe(:)) ) call mpp_error(fatal, &
7798  "mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
7799  if( overlap%pe == null_pe ) then
7800  overlap%pe = pe
7801  else
7802  if(overlap%pe .NE. pe) call mpp_error(fatal, &
7803  "mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
7804  endif
7805  overlap%tileMe (count) = tileme
7806  overlap%dir (count) = dir
7807  overlap%rotation(count) = rotation
7808  overlap%is (count) = is
7809  overlap%ie (count) = ie
7810  overlap%js (count) = js
7811  overlap%je (count) = je
7812 
7813 end subroutine insert_check_overlap
7814 
7815 !#######################################################################
7816 !> this routine adds the overlap_in into overlap_out
7817 subroutine add_check_overlap( overlap_out, overlap_in)
7818  type(overlap_type), intent(inout) :: overlap_out
7819  type(overlap_type), intent(in ) :: overlap_in
7820  type(overlap_type) :: overlap
7821  integer :: count, count_in, count_out
7822 
7823  ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
7824  count_in = overlap_in %count
7825  count_out = overlap_out%count
7826  count = count_in+count_out
7827  if(count_in == 0) call mpp_error(fatal, &
7828  "add_check_overlap(mpp_domains_define): overlap_in%count is zero")
7829 
7830  if(count_out == 0) then
7831  if(associated(overlap_out%tileMe)) call mpp_error(fatal, &
7832  "add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
7833  call allocate_check_overlap(overlap_out, count_in)
7834  overlap_out%pe = overlap_in%pe
7835  else ! need to expand the dimension size of overlap
7836  call allocate_check_overlap(overlap, count_out)
7837  if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(fatal, &
7838  "mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
7839  overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7840  overlap%is (1:count_out) = overlap_out%is (1:count_out)
7841  overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
7842  overlap%js (1:count_out) = overlap_out%js (1:count_out)
7843  overlap%je (1:count_out) = overlap_out%je (1:count_out)
7844  overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7845  overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7846  call deallocate_overlap_type(overlap_out)
7847  call allocate_check_overlap(overlap_out, count)
7848  overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7849  overlap_out%is (1:count_out) = overlap%is (1:count_out)
7850  overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
7851  overlap_out%js (1:count_out) = overlap%js (1:count_out)
7852  overlap_out%je (1:count_out) = overlap%je (1:count_out)
7853  overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7854  overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7855  call deallocate_overlap_type(overlap)
7856  end if
7857  overlap_out%count = count
7858  overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7859  overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
7860  overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
7861  overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
7862  overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
7863  overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7864  overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7865 
7866 end subroutine add_check_overlap
7867 
7868 !####################################################################
7869 subroutine init_overlap_type(overlap)
7870  type(overlap_type), intent(inout) :: overlap
7871 
7872  overlap%count = 0
7873  overlap%pe = null_pe
7874 
7875 end subroutine init_overlap_type
7876 
7877 !####################################################################
7878 
7879 subroutine allocate_update_overlap( overlap, count)
7880  type(overlap_type), intent(inout) :: overlap
7881  integer, intent(in ) :: count
7882 
7883  overlap%count = 0
7884  overlap%pe = null_pe
7885  if(associated(overlap%tileMe)) call mpp_error(fatal, &
7886  "allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
7887  if(count < 1) call mpp_error(fatal, &
7888  "allocate_update_overlap(mpp_domains_define): count should be a positive integer")
7889  allocate(overlap%tileMe (count), overlap%tileNbr (count) )
7890  allocate(overlap%is (count), overlap%ie (count) )
7891  allocate(overlap%js (count), overlap%je (count) )
7892  allocate(overlap%dir (count), overlap%rotation(count) )
7893  allocate(overlap%from_contact(count), overlap%msgsize (count) )
7894  overlap%rotation = zero
7895  overlap%from_contact = .false.
7896 
7897 end subroutine allocate_update_overlap
7898 
7899  !#####################################################################################
7900  subroutine insert_update_overlap(overlap, pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir, reverse, symmetry)
7901  type(overlap_type), intent(inout) :: overlap
7902  integer, intent(in ) :: pe
7903  integer, intent(in ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
7904  integer, intent(in ) :: dir
7905  logical, optional, intent(in ) :: reverse, symmetry
7906 
7907  logical :: is_reverse, is_symmetry, is_overlapped
7908  integer :: is, ie, js, je, count
7909 
7910  is_reverse = .false.
7911  if(PRESENT(reverse)) is_reverse = reverse
7912  is_symmetry = .false.
7913  if(PRESENT(symmetry)) is_symmetry = symmetry
7914 
7915  is = max(is1,is2); ie = min(ie1,ie2)
7916  js = max(js1,js2); je = min(je1,je2)
7917  is_overlapped = .false.
7918  !--- to avoid unnecessary ( duplicate overlap ) for symmetry domain
7919  if(is_symmetry .AND. (dir == 1 .OR. dir == 5)) then ! x-direction
7920  if( ie .GE. is .AND. je .GT. js ) is_overlapped = .true.
7921  else if(is_symmetry .AND. (dir == 3 .OR. dir == 7)) then ! y-direction
7922  if( ie .GT. is .AND. je .GE. js ) is_overlapped = .true.
7923  else if(ie.GE.is .AND. je.GE.js )then
7924  is_overlapped = .true.
7925  endif
7926 
7927  if(is_overlapped) then
7928  if( overlap%count == 0 ) then
7929  overlap%pe = pe
7930  else
7931  if(overlap%pe .NE. pe) call mpp_error(fatal, &
7932  "mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
7933  endif
7934  overlap%count = overlap%count+1
7935  count = overlap%count
7936  if(count > maxoverlap) call mpp_error(fatal, "mpp_domains_define.inc(insert_update_overlap):"//&
7937  & " number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7938  overlap%is(count) = is
7939  overlap%ie(count) = ie
7940  overlap%js(count) = js
7941  overlap%je(count) = je
7942  overlap%tileMe (count) = 1
7943  overlap%tileNbr(count) = 1
7944  overlap%dir(count) = dir
7945  if(is_reverse) then
7946  overlap%rotation(count) = one_hundred_eighty
7947  else
7948  overlap%rotation(count) = zero
7949  end if
7950  end if
7951 
7952  end subroutine insert_update_overlap
7953 
7954  !#####################################################################################
7955 subroutine insert_overlap_type(overlap, pe, tileMe, tileNbr, is, ie, js, je, dir, &
7956  rotation, from_contact)
7957  type(overlap_type), intent(inout) :: overlap
7958  integer, intent(in ) :: tileMe, tileNbr, pe
7959  integer, intent(in ) :: is, ie, js, je
7960  integer, intent(in ) :: dir, rotation
7961  logical, intent(in ) :: from_contact
7962  integer :: count
7963 
7964  if( overlap%count == 0 ) then
7965  overlap%pe = pe
7966  else
7967  if(overlap%pe .NE. pe) call mpp_error(fatal, &
7968  "mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
7969  endif
7970  overlap%count = overlap%count+1
7971  count = overlap%count
7972  if(count > maxoverlap) call mpp_error(fatal, "mpp_domains_define.inc(insert_overlap_type):"//&
7973  & " number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7974  overlap%tileMe (count) = tileme
7975  overlap%tileNbr (count) = tilenbr
7976  overlap%is (count) = is
7977  overlap%ie (count) = ie
7978  overlap%js (count) = js
7979  overlap%je (count) = je
7980  overlap%dir (count) = dir
7981  overlap%rotation (count) = rotation
7982  overlap%from_contact(count) = from_contact
7983  overlap%msgsize (count) = (ie-is+1)*(je-js+1)
7984 
7985 end subroutine insert_overlap_type
7986 
7987 
7988 !#######################################################################
7989 subroutine deallocate_overlap_type( overlap)
7990  type(overlap_type), intent(inout) :: overlap
7991 
7992  if(overlap%count == 0) then
7993  if( .NOT. associated(overlap%tileMe)) return
7994  else
7995  if( .NOT. associated(overlap%tileMe)) call mpp_error(fatal, &
7996  "deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
7997  endif
7998  if(ASSOCIATED(overlap%tileMe)) deallocate(overlap%tileMe)
7999  if(ASSOCIATED(overlap%tileNbr)) deallocate(overlap%tileNbr)
8000  if(ASSOCIATED(overlap%is)) deallocate(overlap%is)
8001  if(ASSOCIATED(overlap%ie)) deallocate(overlap%ie)
8002  if(ASSOCIATED(overlap%js)) deallocate(overlap%js)
8003  if(ASSOCIATED(overlap%je)) deallocate(overlap%je)
8004  if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir)
8005  if(ASSOCIATED(overlap%index)) deallocate(overlap%index)
8006  if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation)
8007  if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact)
8008  if(ASSOCIATED(overlap%msgsize)) deallocate(overlap%msgsize)
8009  overlap%count = 0
8010 
8011 end subroutine deallocate_overlap_type
8012 
8013 !#######################################################################
8014 subroutine deallocate_overlapspec(overlap)
8015 type(overlapspec), intent(inout) :: overlap
8016 integer :: n
8017 
8018  if(ASSOCIATED(overlap%send)) then
8019  do n = 1, size(overlap%send(:))
8020  call deallocate_overlap_type(overlap%send(n))
8021  enddo
8022  deallocate(overlap%send)
8023  endif
8024  if(ASSOCIATED(overlap%recv)) then
8025  do n = 1, size(overlap%recv(:))
8026  call deallocate_overlap_type(overlap%recv(n))
8027  enddo
8028  deallocate(overlap%recv)
8029  endif
8030 
8031 
8032 end subroutine deallocate_overlapspec
8033 
8034 !#######################################################################
8035 !--- this routine add the overlap_in into overlap_out
8036 subroutine add_update_overlap( overlap_out, overlap_in)
8037  type(overlap_type), intent(inout) :: overlap_out
8038  type(overlap_type), intent(in ) :: overlap_in
8039  type(overlap_type) :: overlap
8040  integer :: count, count_in, count_out, n
8041 
8042  ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
8043  count_in = overlap_in %count
8044  count_out = overlap_out%count
8045  count = count_in+count_out
8046  if(count_in == 0) call mpp_error(fatal, &
8047  "mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
8048 
8049  if(count_out == 0) then
8050  if(associated(overlap_out%tileMe)) call mpp_error(fatal, &
8051  "mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
8052  call allocate_update_overlap(overlap_out, count_in)
8053  overlap_out%pe = overlap_in%pe
8054  else ! need to expand the dimension size of overlap
8055  if(overlap_in%pe .NE. overlap_out%pe) call mpp_error(fatal, &
8056  "mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
8057 
8058  call allocate_update_overlap(overlap, count_out)
8059  overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
8060  overlap%tileNbr (1:count_out) = overlap_out%tileNbr (1:count_out)
8061  overlap%is (1:count_out) = overlap_out%is (1:count_out)
8062  overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
8063  overlap%js (1:count_out) = overlap_out%js (1:count_out)
8064  overlap%je (1:count_out) = overlap_out%je (1:count_out)
8065  overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
8066  overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
8067  overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
8068  call deallocate_overlap_type(overlap_out)
8069  call allocate_update_overlap(overlap_out, count)
8070  overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
8071  overlap_out%tileNbr (1:count_out) = overlap%tileNbr (1:count_out)
8072  overlap_out%is (1:count_out) = overlap%is (1:count_out)
8073  overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
8074  overlap_out%js (1:count_out) = overlap%js (1:count_out)
8075  overlap_out%je (1:count_out) = overlap%je (1:count_out)
8076  overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
8077  overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
8078  overlap_out%index (1:count_out) = overlap%index (1:count_out)
8079  overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
8080  overlap_out%msgsize (1:count_out) = overlap%msgsize (1:count_out)
8081  call deallocate_overlap_type(overlap)
8082  end if
8083  overlap_out%count = count
8084  overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
8085  overlap_out%tileNbr (count_out+1:count) = overlap_in%tileNbr (1:count_in)
8086  overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
8087  overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
8088  overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
8089  overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
8090  overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
8091  overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
8092  overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
8093 
8094  do n = count_out+1, count
8095  overlap_out%msgsize(n) = (overlap_out%ie(n)-overlap_out%is(n)+1)*(overlap_out%je(n)-overlap_out%js(n)+1)
8096  enddo
8097 
8098 
8099 end subroutine add_update_overlap
8100 
8101 !##############################################################################
8102 subroutine expand_update_overlap_list(overlapList, npes)
8103  type(overlap_type), pointer :: overlapList(:)
8104  integer, intent(in ) :: npes
8105  type(overlap_type), pointer,save :: newlist(:) => null()
8106  integer :: nlist_old, nlist, m
8107 
8108  nlist_old = size(overlaplist(:))
8109  if(nlist_old .GE. npes) call mpp_error(fatal, &
8110  'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
8111  nlist = min(npes, 2*nlist_old)
8112  allocate(newlist(nlist))
8113  do m = 1, nlist_old
8114  call add_update_overlap(newlist(m), overlaplist(m))
8115  call deallocate_overlap_type(overlaplist(m))
8116  enddo
8117 
8118  deallocate(overlaplist)
8119  overlaplist => newlist
8120  newlist => null()
8121 
8122  return
8123 
8124 end subroutine expand_update_overlap_list
8125 
8126 !##################################################################################
8127 subroutine expand_check_overlap_list(overlaplist, npes)
8128  type(overlap_type), pointer :: overlaplist(:)
8129  integer, intent(in) :: npes
8130  type(overlap_type), pointer,save :: newlist(:) => null()
8131  integer :: nlist_old, nlist, m
8132 
8133  nlist_old = size(overlaplist(:))
8134  if(nlist_old .GE. npes) call mpp_error(fatal, &
8135  'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
8136  nlist = min(npes, 2*nlist_old)
8137  allocate(newlist(nlist))
8138  do m = 1,size(overlaplist(:))
8139  call add_check_overlap(newlist(m), overlaplist(m))
8140  call deallocate_overlap_type(overlaplist(m))
8141  enddo
8142  deallocate(overlaplist)
8143  overlaplist => newlist
8144 
8145 
8146  return
8147 
8148 end subroutine expand_check_overlap_list
8149 
8150 
8151 !###############################################################################
8152 subroutine check_overlap_pe_order(domain, overlap, name)
8153  type(domain2d), intent(in) :: domain
8154  type(overlapspec), intent(in) :: overlap
8155  character(len=*), intent(in) :: name
8156  integer :: m
8157  integer :: pe1, pe2
8158 
8159  !---make sure overlap%nsend and overlap%nrecv is no larger than MAXLIST
8160  if( overlap%nsend > maxlist) call mpp_error(fatal, &
8161  "mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
8162  if( overlap%nrecv > maxlist) call mpp_error(fatal, &
8163  "mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
8164 
8165  do m = 2, overlap%nsend
8166  pe1 = overlap%send(m-1)%pe
8167  pe2 = overlap%send(m)%pe
8168  !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8169  if( pe2 == domain%pe ) then
8170  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8171  call mpp_error(fatal, &
8172  "mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
8173  else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8174  if( pe2 < pe1 ) then
8175  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8176  call mpp_error(fatal, &
8177  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
8178  endif
8179  else if ( pe2 > domain%pe .AND. pe1 < domain%pe ) then
8180  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8181  call mpp_error(fatal, &
8182  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
8183  endif
8184  enddo
8185 
8186 
8187  do m = 2, overlap%nrecv
8188  pe1 = overlap%recv(m-1)%pe
8189  pe2 = overlap%recv(m)%pe
8190  !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8191  if( pe2 == domain%pe ) then
8192  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8193  call mpp_error(fatal, &
8194  "mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
8195  else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8196  if( pe2 > pe1 ) then
8197  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8198  call mpp_error(fatal, &
8199  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
8200  endif
8201  else if ( pe2 < domain%pe .AND. pe1 > domain%pe ) then
8202  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8203  call mpp_error(fatal, &
8204  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
8205  endif
8206  enddo
8207 
8208 
8209 end subroutine check_overlap_pe_order
8210 
8211 
8212 !###############################################################################
8213 subroutine set_domain_comm_inf(update)
8214  type(overlapspec), intent(inout) :: update
8215 
8216  integer :: m, totsize, n
8217 
8218 
8219  ! first set the send and recv size
8220  update%sendsize = 0
8221  update%recvsize = 0
8222  do m = 1, update%nrecv
8223  totsize = 0
8224  do n = 1, update%recv(m)%count
8225  totsize = totsize + update%recv(m)%msgsize(n)
8226  enddo
8227  update%recv(m)%totsize = totsize
8228  if(m==1) then
8229  update%recv(m)%start_pos = 0
8230  else
8231  update%recv(m)%start_pos = update%recv(m-1)%start_pos + update%recv(m-1)%totsize
8232  endif
8233  update%recvsize = update%recvsize + totsize
8234  enddo
8235 
8236  do m = 1, update%nsend
8237  totsize = 0
8238  do n = 1, update%send(m)%count
8239  totsize = totsize + update%send(m)%msgsize(n)
8240  enddo
8241  update%send(m)%totsize = totsize
8242  if(m==1) then
8243  update%send(m)%start_pos = 0
8244  else
8245  update%send(m)%start_pos = update%send(m-1)%start_pos + update%send(m-1)%totsize
8246  endif
8247  update%sendsize = update%sendsize + totsize
8248  enddo
8249 
8250  return
8251 
8252 
8253 end subroutine set_domain_comm_inf
8254 !> @}
subroutine mpp_modify_domain2d(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, shalo, nhalo)
subroutine set_check_overlap(domain, position)
set up the overlapping for boundary check if the domain is symmetry. The check will be done on curren...
subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
add offset to the index
logical function mpp_mosaic_defined()
Accessor function for value of mosaic_defined.
subroutine set_contact_point(domain, position)
this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
subroutine mpp_define_domains1d(global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, memory_size, begin_halo, end_halo)
Define data and computational domains on a 1D set of data (isg:ieg) and assign them to PEs.
subroutine set_bound_overlap(domain, position)
set up the overlapping for boundary if the domain is symmetry.
subroutine define_contact_point(domain, position, num_contact, tile1, tile2, align1, align2, refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, isgList, iegList, jsgList, jegList)
compute the overlapping between tiles for the T-cell.
subroutine mpp_define_mosaic_pelist(sizes, pe_start, pe_end, pelist, costpertile)
Defines a pelist for use with mosaic tiles.
subroutine mpp_define_io_domain(domain, io_layout)
Define the layout for IO pe's for the given domain.
subroutine mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
Computes extents for a grid decomposition with the given indices and divisions.
subroutine mpp_modify_domain1d(domain_in, domain_out, cbegin, cend, gbegin, gend, hbegin, hend)
Modifies the exents of a domain.
subroutine compute_overlaps_fold_west(domain, position, ishift, jshift)
Computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine mpp_define_mosaic(global_indices, layout, domain, num_tile, num_contact, tile1, tile2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, maskmap, name, memory_size, symmetry, xflags, yflags, tile_id)
Defines a domain for mosaic tile grids.
subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2)
always fill the contact according to index order.
subroutine mpp_define_layout2d(global_indices, ndivs, layout)
subroutine add_check_overlap(overlap_out, overlap_in)
this routine adds the overlap_in into overlap_out
subroutine mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend)
Computes the extents of a grid block.
subroutine compute_overlaps(domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, whalo, ehalo, shalo, nhalo)
Computes remote domain overlaps.
subroutine mpp_get_domain_shift(domain, ishift, jshift, position)
Returns the shift value in x and y-direction according to domain position..
subroutine compute_overlaps_fold_east(domain, position, ishift, jshift)
computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine compute_overlaps_fold_south(domain, position, ishift, jshift)
Computes remote domain overlaps assumes only one in each direction will calculate the overlapping for...
subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
this routine sets up the overlapping for mpp_update_domains for arbitrary halo update....
subroutine mpp_define_domains2d(global_indices, layout, domain, pelist, xflags, yflags, xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset)
Define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,...
subroutine mpp_sync_self(pelist, check, request, msg_size, msg_type)
This is to check if current PE's outstanding puts are complete but we can't use shmem_fence because w...
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
Definition: mpp_util.inc:50
subroutine mpp_declare_pelist(pelist, name, commID)
Declare a pelist.
Definition: mpp_util.inc:469
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
Definition: mpp_util.inc:58
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:420
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:406