FV3 Bundle
mpp_domains_define.inc
Go to the documentation of this file.
1 ! -*-f90-*-
2 
3 
4 !***********************************************************************
5 !* GNU Lesser General Public License
6 !*
7 !* This file is part of the GFDL Flexible Modeling System (FMS).
8 !*
9 !* FMS is free software: you can redistribute it and/or modify it under
10 !* the terms of the GNU Lesser General Public License as published by
11 !* the Free Software Foundation, either version 3 of the License, or (at
12 !* your option) any later version.
13 !*
14 !* FMS is distributed in the hope that it will be useful, but WITHOUT
15 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 !* for more details.
18 !*
19 !* You should have received a copy of the GNU Lesser General Public
20 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
21 !***********************************************************************
22 
23  ! <SUBROUTINE NAME="mpp_define_layout2D" INTERFACE="mpp_define_layout">
24  ! <IN NAME="global_indices" TYPE="integer" DIM="(4)"></IN>
25  ! <IN NAME="ndivs" TYPE="integer"></IN>
26  ! <OUT NAME="layout" TYPE="integer" DIM="(2)"></OUT>
27  ! </SUBROUTINE>
28  subroutine mpp_define_layout2D( global_indices, ndivs, layout )
29  integer, intent(in) :: global_indices(:) !(/ isg, ieg, jsg, jeg /)
30  integer, intent(in) :: ndivs !number of divisions to divide global domain
31  integer, intent(out) :: layout(:)
32 
33  integer :: isg, ieg, jsg, jeg, isz, jsz, idiv, jdiv
34 
35  if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL,"mpp_define_layout2D: size of global_indices should be 4")
36  if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_layout2D: size of layout should be 2")
37 
38  isg = global_indices(1)
39  ieg = global_indices(2)
40  jsg = global_indices(3)
41  jeg = global_indices(4)
42 
43  isz = ieg - isg + 1
44  jsz = jeg - jsg + 1
45  !first try to divide ndivs in the domain aspect ratio: if imperfect aspect, reduce idiv till it divides ndivs
46  idiv = nint( sqrt(float(ndivs*isz)/jsz) )
47  idiv = max(idiv,1) !for isz=1 line above can give 0
48  do while( mod(ndivs,idiv).NE.0 )
49  idiv = idiv - 1
50  end do !will terminate at idiv=1 if not before
51  jdiv = ndivs/idiv
52 
53  layout = (/ idiv, jdiv /)
54  return
55  end subroutine mpp_define_layout2D
56 
57  !############################################################################
58  ! <SUBROUTINE NAME="mpp_define_mosaic_pelist">
59  ! <IN NAME="global_indices" TYPE="integer" DIM="(4)"></IN>
60  ! <IN NAME="pelist" TYPE="integer" DIM="(0:)"> </IN>
61  ! </SUBROUTINE>
62  ! NOTE: The following routine may need to revised to improve the capability.
63  ! It is very hard to make it balance for all the situation.
64  ! Hopefully some smart idea will come up someday.
65  subroutine mpp_define_mosaic_pelist( sizes, pe_start, pe_end, pelist, costpertile)
66  integer, dimension(:), intent(in) :: sizes
67  integer, dimension(:), intent(inout) :: pe_start, pe_end
68  integer, dimension(:), intent(in), optional :: pelist, costpertile
69  integer, dimension(size(sizes(:))) :: costs
70  integer, dimension(:), allocatable :: pes
71  integer :: ntiles, npes, totcosts, avgcost
72  integer :: ntiles_left, npes_left, pos, n, tile
73  integer :: cost_on_tile, cost_on_pe, npes_used, errunit
74 
75  ntiles = size(sizes(:))
76  if(size(pe_start(:)) .NE. ntiles .OR. size(pe_end(:)) .NE. ntiles ) then
77  call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between pe_start/pe_end and sizes")
78  end if
79 
80  if(present(costpertile)) then
81  if(size(costpertile(:)) .NE. ntiles ) then
82  call mpp_error(FATAL, "mpp_define_mosaic_pelist: size mismatch between costpertile and sizes")
83  end if
84  costs = sizes*costpertile
85  else
86  costs = sizes
87  end if
88 
89  if( PRESENT(pelist) )then
90  if( .NOT.any(pelist.EQ.mpp_pe()) )then
91  errunit = stderr()
92  write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
93  call mpp_error( FATAL, 'mpp_define_mosaic_pelist: pe must be in pelist.' )
94  end if
95  npes = size(pelist(:))
96  allocate( pes(0:npes-1) )
97  pes(:) = pelist(:)
98  else
99  npes = mpp_npes()
100  allocate( pes(0:npes-1) )
101  call mpp_get_current_pelist(pes)
102  end if
103 
104  ntiles_left = ntiles
105  npes_left = npes
106  pos = pes(0)
107 
108  do while( ntiles_left > 0 )
109  if( npes_left == 1 ) then ! all left tiles will on the last processor, imbalance possibly.
110  do n = 1, ntiles
111  if(costs(n) > 0) then
112  pe_start(n) = pos
113  pe_end(n) = pos
114  costs(n) = 0
115  end if
116  end do
117  ntiles_left = 0
118  npes_left = 0
119  else
120  totcosts = sum(costs)
121  avgcost = CEILING(real(totcosts)/npes_left )
122  tile = minval(maxloc(costs))
123  cost_on_tile = costs(tile)
124  pe_start(tile) = pos
125  ntiles_left = ntiles_left - 1
126  costs(tile) = 0
127  totcosts = totcosts - cost_on_tile
128  if(cost_on_tile .GE. avgcost ) then
129  npes_used = min(ceiling(real(cost_on_tile)/avgcost), npes_left)
130  if( ntiles_left > 0 .AND. npes_used == npes_left ) npes_used = npes_used - 1
131  pe_end(tile) = pos + npes_used - 1
132  npes_left = npes_left - npes_used
133  pos = pos + npes_used
134  else
135  !--- find other tiles to share the pe
136  pe_end(tile) = pos
137  cost_on_pe = cost_on_tile
138  do while(ntiles_left>npes_left) ! make sure all the pes are used.
139  tile = minval(minloc(costs, costs> 0 ))
140  cost_on_tile = costs(tile)
141  cost_on_pe = cost_on_pe + cost_on_tile
142  if(cost_on_pe > avgcost ) exit
143  pe_start(tile) = pos
144  pe_end(tile) = pos
145  ntiles_left = ntiles_left - 1
146  costs(tile) = 0
147  totcosts = totcosts - cost_on_tile
148  end do
149  npes_left = npes_left - 1
150  pos = pos + 1
151  end if
152  end if
153  end do
154 
155  if(npes_left .NE. 0 ) call mpp_error(FATAL, "mpp_define_mosaic_pelist: the left npes should be zero")
156  deallocate(pes)
157 
158  end subroutine mpp_define_mosaic_pelist
159 
160  !-- The following implementation is different from mpp_compute_extents
161  !-- The last block might have most points
162  subroutine mpp_compute_block_extent(isg,ieg,ndivs,ibegin,iend)
163  integer, intent(in) :: isg, ieg, ndivs
164  integer, dimension(:), intent(out) :: ibegin, iend
165 
166  integer :: ndiv, imax, ndmax
167  integer :: is, ie, n
168 
169  ie = ieg
170  do ndiv=ndivs,1,-1
171  !domain is sized by dividing remaining points by remaining domains
172  is = ie - CEILING( REAL(ie-isg+1)/ndiv ) + 1
173  ibegin(ndiv) = is
174  iend(ndiv) = ie
175 
176  if( ie.LT.is )call mpp_error( FATAL, &
177  'MPP_DEFINE_DOMAINS(mpp_compute_block_extent): domain extents must be positive definite.' )
178  if( ndiv.EQ.1 .AND. ibegin(ndiv) .NE. isg ) &
179  call mpp_error( FATAL, 'mpp_compute_block_extent: domain extents do not span space completely.' )
180  ie = is - 1
181  end do
182 
183  end subroutine mpp_compute_block_extent
184 
185 
186  !#####################################################################
187  subroutine mpp_compute_extent(isg,ieg,ndivs,ibegin,iend, extent )
188  integer, intent(in) :: isg, ieg, ndivs
189  integer, dimension(0:), intent(out) :: ibegin, iend
190  integer, dimension(0:), intent(in), optional :: extent
191 
192  integer :: ndiv, imax, ndmax, ndmirror
193  integer :: is, ie, n
194  logical :: symmetrize, use_extent
195  !statement functions
196  logical :: even, odd
197  even(n) = (mod(n,2).EQ.0)
198  odd (n) = (mod(n,2).EQ.1)
199 
200  use_extent = .false.
201  if(PRESENT(extent)) then
202  if( size(extent(:)).NE.ndivs ) &
203  call mpp_error( FATAL, 'mpp_compute_extent: extent array size must equal number of domain divisions.' )
204  use_extent = .true.
205  if(ALL(extent ==0)) use_extent = .false.
206  endif
207 
208  is = isg
209  if(use_extent) then
210  ibegin(0) = isg
211  do ndiv = 0, ndivs-2
212  if(extent(ndiv) .LE. 0) call mpp_error( FATAL, '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, 'mpp_compute_extent: extent array limits do not match global domain.' )
218  else
219  do ndiv=0,ndivs-1
220  !modified for mirror-symmetry
221  !original line
222  ! ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1
223 
224  !problem of dividing nx points into n domains maintaining symmetry
225  !i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not.
226  !this will always work for nx even n even or odd
227  !this will always work for nx odd, n odd
228  !this will never work for nx odd, n even: for this case we supersede the mirror calculation
229  ! symmetrize = .NOT. ( mod(ndivs,2).EQ.0 .AND. mod(ieg-isg+1,2).EQ.1 )
230  !nx even n odd fails if n>nx/2
231  symmetrize = ( even(ndivs) .AND. even(ieg-isg+1) ) .OR. &
232  ( odd(ndivs) .AND. odd(ieg-isg+1) ) .OR. &
233  ( odd(ndivs) .AND. even(ieg-isg+1) .AND. ndivs.LT.(ieg-isg+1)/2 )
234 
235  !mirror domains are stored in the list and retrieved if required.
236  if( ndiv.EQ.0 )then
237  !initialize max points and max domains
238  imax = ieg
239  ndmax = ndivs
240  end if
241  !do bottom half of decomposition, going over the midpoint for odd ndivs
242  if( ndiv.LT.(ndivs-1)/2+1 )then
243  !domain is sized by dividing remaining points by remaining domains
244  ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
245  ndmirror = (ndivs-1) - ndiv !mirror domain
246  if( ndmirror.GT.ndiv .AND. symmetrize )then !only for domains over the midpoint
247  !mirror extents, the max(,) is to eliminate overlaps
248  ibegin(ndmirror) = max( isg+ieg-ie, ie+1 )
249  iend(ndmirror) = max( isg+ieg-is, ie+1 )
250  imax = ibegin(ndmirror) - 1
251  ndmax = ndmax - 1
252  end if
253  else
254  if( symmetrize )then
255  !do top half of decomposition by retrieving saved values
256  is = ibegin(ndiv)
257  ie = iend(ndiv)
258  else
259  ie = is + CEILING( REAL(imax-is+1)/(ndmax-ndiv) ) - 1
260  end if
261  end if
262  ibegin(ndiv) = is
263  iend(ndiv) = ie
264  if( ie.LT.is )call mpp_error( FATAL, &
265  'MPP_DEFINE_DOMAINS(mpp_compute_extent): domain extents must be positive definite.' )
266  if( ndiv.EQ.ndivs-1 .AND. iend(ndiv).NE.ieg ) &
267  call mpp_error( FATAL, 'mpp_compute_extent: domain extents do not span space completely.' )
268  is = ie + 1
269  end do
270  endif
271 
272 
273  end subroutine mpp_compute_extent
274 
275  !#####################################################################
276 
277 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
278  ! !
279  ! MPP_DEFINE_DOMAINS: define layout and decomposition !
280  ! !
281 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
282 
283  ! <SUBROUTINE NAME="mpp_define_domains1D" INTERFACE="mpp_define_domains">>
284  ! <IN NAME="global_indices" TYPE="integer" DIM="(2)"> </IN>
285  ! <IN NAME="ndivs" TYPE="integer"> </IN>
286  ! <INOUT NAME="domain" TYPE="type(domain1D)"> </INOUT>
287  ! <IN NAME="pelist" TYPE="integer" DIM="(0:)"> </IN>
288  ! <IN NAME="flags" TYPE="integer"> </IN>
289  ! <IN NAME="halo" TYPE="integer"> </IN>
290  ! <IN NAME="extent" TYPE="integer" DIM="(0:)"> </IN>
291  ! <IN NAME="maskmap" TYPE="logical" DIM="(0:)"> </IN>
292  ! </SUBROUTINE>
293  !routine to divide global array indices among domains, and assign domains to PEs
294  !domain is of type domain1D
295  !ARGUMENTS:
296  ! global_indices(2)=(isg,ieg) gives the extent of global domain
297  ! ndivs is number of divisions of domain: even divisions unless extent is present.
298  ! domain is the returned domain1D
299  ! pelist (optional) list of PEs to which domains are to be assigned (default 0...npes-1)
300  ! size of pelist must correspond to number of mask=.TRUE. divisions
301  ! flags define whether compute and data domains are global (undecomposed) and whether global domain has periodic boundaries
302  ! halo (optional) defines halo width (currently the same on both sides)
303  ! extent (optional) array defines width of each division (used for non-uniform domain decomp, for e.g load-balancing)
304  ! maskmap (optional) a division whose maskmap=.FALSE. is not assigned to any domain
305  ! By default we assume decomposition of compute and data domains, non-periodic boundaries, no halo, as close to uniform extents
306  ! as the input parameters permit
307  subroutine mpp_define_domains1D( global_indices, ndivs, domain, pelist, flags, halo, extent, maskmap, &
308  memory_size, begin_halo, end_halo )
309  integer, intent(in) :: global_indices(:) !(/ isg, ieg /)
310  integer, intent(in) :: ndivs
311  type(domain1D), intent(inout) :: domain !declared inout so that existing links, if any, can be nullified
312  integer, intent(in), optional :: pelist(0:)
313  integer, intent(in), optional :: flags, halo
314  integer, intent(in), optional :: extent(0:)
315  logical, intent(in), optional :: maskmap(0:)
316  integer, intent(in), optional :: memory_size
317  integer, intent(in), optional :: begin_halo, end_halo
318 
319  logical :: compute_domain_is_global, data_domain_is_global
320  integer :: ndiv, n, isg, ieg, i
321  integer, allocatable :: pes(:)
322  integer :: ibegin(0:ndivs-1), iend(0:ndivs-1)
323  logical :: mask(0:ndivs-1)
324  integer :: halosz, halobegin, haloend
325  integer :: errunit
326 
327  if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: You must first call mpp_domains_init.' )
328  if(size(global_indices(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains1D: size of global_indices should be 2")
329  !get global indices
330  isg = global_indices(1)
331  ieg = global_indices(2)
332  if( ndivs.GT.ieg-isg+1 )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: more divisions requested than rows available.' )
333  !get the list of PEs on which to assign domains; if pelist is absent use 0..npes-1
334  if( PRESENT(pelist) )then
335  if( .NOT.any(pelist.EQ.mpp_pe()) )then
336  errunit = stderr()
337  write( errunit,* )'pe=', mpp_pe(), ' pelist=', pelist
338  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: pe must be in pelist.' )
339  end if
340  allocate( pes(0:size(pelist(:))-1) )
341  pes(:) = pelist(:)
342  else
343  allocate( pes(0:mpp_npes()-1) )
344  call mpp_get_current_pelist(pes)
345 ! pes(:) = (/ (i,i=0,mpp_npes()-1) /)
346  end if
347 
348  !get number of real domains: 1 mask domain per PE in pes
349  mask = .TRUE. !default mask
350  if( PRESENT(maskmap) )then
351  if( size(maskmap(:)).NE.ndivs ) &
352  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: maskmap array size must equal number of domain divisions.' )
353  mask(:) = maskmap(:)
354  end if
355  if( count(mask).NE.size(pes(:)) ) &
356  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS1D: number of TRUEs in maskmap array must match PE count.' )
357 
358  !get halosize
359  halosz = 0
360  if( PRESENT(halo) ) then
361  halosz = halo
362  !--- if halo is present, begin_halo and end_halo should not present
363  if(present(begin_halo) .OR. present(end_halo) ) call mpp_error(FATAL, &
364  "mpp_domains_define.inc: when halo is present, begin_halo and end_halo should not present")
365  end if
366  halobegin = halosz; haloend = halosz
367  if(present(begin_halo)) halobegin = begin_halo
368  if(present(end_halo)) haloend = end_halo
369  halosz = max(halobegin, haloend)
370  !get flags
371  compute_domain_is_global = .FALSE.
372  data_domain_is_global = .FALSE.
373  domain%cyclic = .FALSE.
374  domain%goffset = 1
375  domain%loffset = 1
376  if( PRESENT(flags) )then
377  !NEW: obsolete flag global_compute_domain, since ndivs is non-optional and you cannot have global compute and ndivs.NE.1
378  compute_domain_is_global = ndivs.EQ.1
379  !if compute domain is global, data domain must also be
380  data_domain_is_global = BTEST(flags,GLOBAL) .OR. compute_domain_is_global
381  domain%cyclic = BTEST(flags,CYCLIC) .AND. halosz.NE.0
382  if(BTEST(flags,CYCLIC)) domain%goffset = 0
383  end if
384 
385  !set up links list
386  allocate( domain%list(0:ndivs-1) )
387 
388  !set global domain
389  domain%list(:)%global%begin = isg
390  domain%list(:)%global%end = ieg
391  domain%list(:)%global%size = ieg-isg+1
392  domain%list(:)%global%max_size = ieg-isg+1
393  domain%list(:)%global%is_global = .TRUE. !always
394 
395  !get compute domain
396  if( compute_domain_is_global )then
397  domain%list(:)%compute%begin = isg
398  domain%list(:)%compute%end = ieg
399  domain%list(:)%compute%is_global = .TRUE.
400  domain%list(:)%pe = pes(:)
401  domain%pos = 0
402  else
403  domain%list(:)%compute%is_global = .FALSE.
404  n = 0
405  call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend, extent)
406  do ndiv=0,ndivs-1
407  domain%list(ndiv)%compute%begin = ibegin(ndiv)
408  domain%list(ndiv)%compute%end = iend(ndiv)
409  if( mask(ndiv) )then
410  domain%list(ndiv)%pe = pes(n)
411  if( mpp_pe().EQ.pes(n) )domain%pos = ndiv
412  n = n + 1
413  else
414  domain%list(ndiv)%pe = NULL_PE
415  end if
416  end do
417  end if
418 
419  domain%list(:)%compute%size = domain%list(:)%compute%end - domain%list(:)%compute%begin + 1
420 
421  !get data domain
422  !data domain is at least equal to compute domain
423  domain%list(:)%data%begin = domain%list(:)%compute%begin
424  domain%list(:)%data%end = domain%list(:)%compute%end
425  domain%list(:)%data%is_global = .FALSE.
426  !apply global flags
427  if( data_domain_is_global )then
428  domain%list(:)%data%begin = isg
429  domain%list(:)%data%end = ieg
430  domain%list(:)%data%is_global = .TRUE.
431  end if
432  !apply margins
433  domain%list(:)%data%begin = domain%list(:)%data%begin - halobegin
434  domain%list(:)%data%end = domain%list(:)%data%end + haloend
435  domain%list(:)%data%size = domain%list(:)%data%end - domain%list(:)%data%begin + 1
436 
437  !--- define memory domain, if memory_size is not present or memory size is 0, memory domain size
438  !--- will be the same as data domain size. if momory_size is present, memory_size should greater than
439  !--- or equal to data size. The begin of memory domain will be always the same as data domain.
440  domain%list(:)%memory%begin = domain%list(:)%data%begin
441  domain%list(:)%memory%end = domain%list(:)%data%end
442  if( present(memory_size) ) then
443  if(memory_size > 0) then
444  if( domain%list(domain%pos)%data%size > memory_size ) call mpp_error(FATAL, &
445  "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe")
446  domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1
447  end if
448  end if
449  domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1
450  domain%list(:)%memory%is_global = domain%list(:)%data%is_global
451 
452  domain%compute = domain%list(domain%pos)%compute
453  domain%data = domain%list(domain%pos)%data
454  domain%global = domain%list(domain%pos)%global
455  domain%memory = domain%list(domain%pos)%memory
456  domain%compute%max_size = MAXVAL( domain%list(:)%compute%size )
457  domain%data%max_size = MAXVAL( domain%list(:)%data%size )
458  domain%global%max_size = domain%global%size
459  domain%memory%max_size = domain%memory%size
460 
461  !PV786667: the deallocate stmts can be removed when fixed (7.3.1.3m)
462  deallocate( pes )
463  return
464 
465  end subroutine mpp_define_domains1D
466 
467  !################################################################################
468  !--- define the IO domain.
469  subroutine mpp_define_io_domain(domain, io_layout)
470  type(domain2D), intent(inout) :: domain
471  integer, intent(in ) :: io_layout(2)
472  integer :: layout(2)
473  integer :: npes_in_group
474  type(domain2D), pointer :: io_domain=>NULL()
475  integer :: i, j, n, m
476  integer :: ipos, jpos, igroup, jgroup
477  integer :: ipos_beg, ipos_end, jpos_beg, jpos_end
478  integer :: whalo, ehalo, shalo, nhalo
479  integer :: npes_x, npes_y, ndivx, ndivy
480  integer, allocatable :: posarray(:,:)
481 
482  if(io_layout(1) * io_layout(2) .LE. 0) then
483  call mpp_error(NOTE, &
484  "mpp_domains_define.inc(mpp_define_io_domain): io domain will not be defined for "//trim(domain%name)// &
485  " when one or both entry of io_layout is not positive")
486  return
487  endif
488 
489  layout(1) = size(domain%x(1)%list(:))
490  layout(2) = size(domain%y(1)%list(:))
491 
492  if(ASSOCIATED(domain%io_domain)) call mpp_error(FATAL, &
493  "mpp_domains_define.inc(mpp_define_io_domain): io_domain is already defined")
494 
495  if(mod(layout(1), io_layout(1)) .NE. 0) call mpp_error(FATAL, &
496  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)//" domain layout(1) must be divided by io_layout(1)")
497  if(mod(layout(2), io_layout(2)) .NE. 0) call mpp_error(FATAL, &
498  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)//" domain layout(2) must be divided by io_layout(2)")
499  if(size(domain%x(:)) > 1) call mpp_error(FATAL, &
500  "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// &
501  ": multiple tile per pe is not supported yet for this routine")
502 
503  allocate(domain%io_domain)
504  domain%io_layout = io_layout
505  io_domain => domain%io_domain
506  ! Find how many processors are in the group with the consideration that some of the region maybe masked out.
507  npes_x = layout(1)/io_layout(1)
508  npes_y = layout(2)/io_layout(2)
509  ipos = mod(domain%x(1)%pos, npes_x)
510  jpos = mod(domain%y(1)%pos, npes_y)
511  igroup = domain%x(1)%pos/npes_x
512  jgroup = domain%y(1)%pos/npes_y
513  ipos_beg = igroup*npes_x; ipos_end = ipos_beg + npes_x - 1
514  jpos_beg = jgroup*npes_y; jpos_end = jpos_beg + npes_y - 1
515  npes_in_group = 0
516  do j = jpos_beg, jpos_end
517  do i = ipos_beg, ipos_end
518  if(domain%pearray(i,j) .NE. NULL_PE) npes_in_group = npes_in_group+1
519  enddo
520  enddo
521 
522  io_domain%whalo = domain%whalo
523  io_domain%ehalo = domain%ehalo
524  io_domain%shalo = domain%shalo
525  io_domain%nhalo = domain%nhalo
526  io_domain%ntiles = 1
527  io_domain%pe = domain%pe
528  io_domain%symmetry = domain%symmetry
529  allocate(io_domain%list(0:npes_in_group-1))
530  do i = 0, npes_in_group-1
531  allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) )
532  enddo
533 
534  ndivx = size(domain%pearray,1)
535  ndivy = size(domain%pearray,2)
536  allocate(posarray(0:ndivx-1, 0:ndivy-1))
537  n = domain%tile_root_pe - mpp_root_pe()
538  posarray = -1
539  do j = 0,ndivy-1
540  do i = 0,ndivx-1
541  if( domain%pearray(i,j) == NULL_PE) cycle
542  posarray(i,j) = n
543  n = n + 1
544  enddo
545  enddo
546 
547  n = 0
548  do j = jpos_beg, jpos_end
549  do i = ipos_beg, ipos_end
550  if( domain%pearray(i,j) == NULL_PE) cycle
551  io_domain%list(n)%pe = domain%pearray(i,j)
552  m = posarray(i,j)
553  io_domain%list(n)%x(1)%compute = domain%list(m)%x(1)%compute
554  io_domain%list(n)%y(1)%compute = domain%list(m)%y(1)%compute
555  igroup = domain%list(m)%x(1)%pos/npes_x
556  jgroup = domain%list(m)%y(1)%pos/npes_y
557  io_domain%list(n)%tile_id(1) = jgroup*io_layout(1) + igroup
558  n = n + 1
559  enddo
560  enddo
561  deallocate(posarray)
562 
563  allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) )
564  allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) )
565  n = -1
566  do j = jpos_beg, jpos_beg+jpos
567  do i = ipos_beg, ipos_beg+ipos
568  if(domain%pearray(i,j) .NE. NULL_PE) n = n + 1
569  enddo
570  enddo
571  io_domain%pos = n
572  io_domain%x(1)%compute = domain%x(1)%compute
573  io_domain%x(1)%data = domain%x(1)%data
574  io_domain%x(1)%memory = domain%x(1)%memory
575  io_domain%y(1)%compute = domain%y(1)%compute
576  io_domain%y(1)%data = domain%y(1)%data
577  io_domain%y(1)%memory = domain%y(1)%memory
578  io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin
579  io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end
580  io_domain%x(1)%global%size = io_domain%x(1)%global%end - io_domain%x(1)%global%begin + 1
581  io_domain%x(1)%global%max_size = io_domain%x(1)%global%size
582  io_domain%y(1)%global%begin = domain%y(1)%list(jpos_beg)%compute%begin
583  io_domain%y(1)%global%end = domain%y(1)%list(jpos_end)%compute%end
584  io_domain%y(1)%global%size = io_domain%y(1)%global%end - io_domain%y(1)%global%begin + 1
585  io_domain%y(1)%global%max_size = io_domain%y(1)%global%size
586  io_domain%x(1)%pos = ipos
587  io_domain%y(1)%pos = jpos
588  io_domain%tile_id(1) = io_domain%list(n)%tile_id(1)
589  io_domain%tile_root_pe = io_domain%list(0)%pe
590 
591  !z1l
592 !!$ do j = 0, npes_y - 1
593 !!$ n = j*npes_x + ipos
594 !!$ io_domain%y(1)%list(j) = io_domain%list(n)%y(1)
595 !!$ enddo
596 !!$ do i = 0, npes_x - 1
597 !!$ n = jpos*npes_x + i
598 !!$ io_domain%x(1)%list(i) = io_domain%list(n)%x(1)
599 !!$ enddo
600 
601  whalo = domain%whalo
602  ehalo = domain%ehalo
603  shalo = domain%shalo
604  nhalo = domain%nhalo
605 
606  io_domain=>NULL()
607 
608 
609  end subroutine mpp_define_io_domain
610 
611  ! <SUBROUTINE NAME="mpp_define_domains2D" INTERFACE="mpp_define_domains">
612  ! <IN NAME="global_indices" TYPE="integer" DIM="(4)"> </IN>
613  ! <IN NAME="layout" TYPE="integer" DIM="(2)"></IN>
614  ! <INOUT NAME="domain" TYPE="type(domain2D)"></INOUT>
615  ! <IN NAME="pelist" TYPE="integer" DIM="(0:)"></IN>
616  ! <IN NAME="xflags, yflags" TYPE="integer"></IN>
617  ! <IN NAME="xhalo, yhalo" TYPE="integer"></IN>
618  ! <IN NAME="xextent, yextent" TYPE="integer" DIM="(0:)"></IN>
619  ! <IN NAME="maskmap" TYPE="logical" DIM="(:,:)"></IN>
620  ! <IN NAME="name" TYPE="character(len=*)"></IN>
621  ! </SUBROUTINE>
622  subroutine mpp_define_domains2D( global_indices, layout, domain, pelist, xflags, yflags, &
623  xhalo, yhalo, xextent, yextent, maskmap, name, symmetry, memory_size, &
624  whalo, ehalo, shalo, nhalo, is_mosaic, tile_count, tile_id, complete, x_cyclic_offset, y_cyclic_offset )
625  !define 2D data and computational domain on global rectilinear cartesian domain (isg:ieg,jsg:jeg) and assign them to PEs
626  integer, intent(in) :: global_indices(:) !(/ isg, ieg, jsg, jeg /)
627  integer, intent(in) :: layout(:)
628  type(domain2D), intent(inout) :: domain
629  integer, intent(in), optional :: pelist(0:)
630  integer, intent(in), optional :: xflags, yflags, xhalo, yhalo
631  integer, intent(in), optional :: xextent(0:), yextent(0:)
632  logical, intent(in), optional :: maskmap(0:,0:)
633  character(len=*), intent(in), optional :: name
634  logical, intent(in), optional :: symmetry
635  logical, intent(in), optional :: is_mosaic ! indicate if calling mpp_define_domains from mpp_define_mosaic.
636  integer, intent(in), optional :: memory_size(:)
637  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! halo size for West, East, South and North direction.
638  ! if whalo and ehalo is not present,
639  ! will take the value of xhalo
640  ! if shalo and nhalo is not present,
641  ! will take the value of yhalo
642  integer, intent(in), optional :: tile_count ! tile number on current pe, default value is 1
643  ! this is for the situation that multiple tiles on one processor.
644  integer, intent(in), optional :: tile_id ! tile id
645  logical, intent(in), optional :: complete ! true indicate mpp_define_domain is completed for mosaic definition.
646  integer, intent(in), optional :: x_cyclic_offset ! offset for x-cyclic boundary condition,
647  ! (0,j) = (ni, mod(j+x_cyclic_offset,nj))
648  ! (ni+1,j) = ( 1, mod(j+nj-x_cyclic_offset,nj) )
649  integer, intent(in), optional :: y_cyclic_offset ! offset for y-cyclic boundary condition
650  ! (i,0) = (mod(i+y_cyclic_offset,ni), nj))
651  ! (i,nj+1) = (mod(mod(i+ni-y_cyclic_offset,ni), 1) )
652 
653  integer :: i, j, m, n, xhalosz, yhalosz, memory_xsize, memory_ysize
654  integer :: whalosz, ehalosz, shalosz, nhalosz
655  integer :: ipos, jpos, pos, tile, nlist, cur_tile_id
656  integer :: ndivx, ndivy, isg, ieg, jsg, jeg, ishift, jshift, errunit, logunit
657  integer :: x_offset, y_offset, start_pos, nfold
658  logical :: from_mosaic, is_complete
659  logical :: mask(0:layout(1)-1,0:layout(2)-1)
660  integer, allocatable :: pes(:), pesall(:)
661  integer :: pearray(0:layout(1)-1,0:layout(2)-1)
662  integer :: ibegin(0:layout(1)-1), iend(0:layout(1)-1)
663  integer :: jbegin(0:layout(2)-1), jend(0:layout(2)-1)
664  character(len=8) :: text
665  type(overlapSpec), pointer :: update=>NULL()
666  type(overlapSpec), pointer :: check_T => NULL()
667  character(len=1) :: position
668  integer :: msgsize, l, p, is, ie, js, je, from_pe
669  integer :: outunit
670  logical :: send(8), recv(8)
671 
672  outunit = stdout()
673  if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: You must first call mpp_domains_init.' )
674  if(PRESENT(name)) then
675  if(len_trim(name) > NAME_LENGTH) call mpp_error(FATAL, &
676  "mpp_domains_define.inc(mpp_define_domains2D): the len_trim of optional argument name ="//trim(name)// &
677  " is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
678  domain%name = name
679  endif
680  if(size(global_indices(:)) .NE. 4) call mpp_error(FATAL, &
681  "mpp_define_domains2D: size of global_indices should be 4 for "//trim(domain%name) )
682  if(size(layout(:)) .NE. 2) call mpp_error(FATAL,"mpp_define_domains2D: size of layout should be 2 for "//trim(domain%name) )
683 
684  ndivx = layout(1); ndivy = layout(2)
685  isg = global_indices(1); ieg = global_indices(2); jsg = global_indices(3); jeg = global_indices(4)
686 
687  from_mosaic = .false.
688  if(present(is_mosaic)) from_mosaic = is_mosaic
689  is_complete = .true.
690  if(present(complete)) is_complete = complete
691  tile = 1
692  if(present(tile_count)) tile = tile_count
693  cur_tile_id = 1
694  if(present(tile_id)) cur_tile_id = tile_id
695 
696  if( PRESENT(pelist) )then
697  allocate( pes(0:size(pelist(:))-1) )
698  pes = pelist
699  if(from_mosaic) then
700  allocate( pesall(0:mpp_npes()-1) )
701  call mpp_get_current_pelist(pesall)
702  else
703  allocate( pesall(0:size(pes(:))-1) )
704  pesall = pes
705  end if
706  else
707  allocate( pes(0:mpp_npes()-1) )
708  allocate( pesall(0:mpp_npes()-1) )
709  call mpp_get_current_pelist(pes)
710  pesall = pes
711  end if
712 
713  !--- at least of one of x_cyclic_offset and y_cyclic_offset must be zero
714  !--- folded boundary condition is not supported when either x_cyclic_offset or y_cyclic_offset is nonzero.
715  !--- Since we only implemented Folded-north boundary condition currently, we only consider y-flags.
716  x_offset = 0; y_offset = 0
717  if(PRESENT(x_cyclic_offset)) x_offset = x_cyclic_offset
718  if(PRESENT(y_cyclic_offset)) y_offset = y_cyclic_offset
719  if(x_offset*y_offset .NE. 0) call mpp_error(FATAL, &
720  'MPP_DEFINE_DOMAINS2D: At least one of x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
721 
722  !--- x_cyclic_offset and y_cyclic_offset should no larger than the global grid size.
723  if(abs(x_offset) > jeg-jsg+1) call mpp_error(FATAL, &
724  'MPP_DEFINE_DOMAINS2D: absolute value of x_cyclic_offset is greater than jeg-jsg+1 for '//trim(domain%name))
725  if(abs(y_offset) > ieg-isg+1) call mpp_error(FATAL, &
726  'MPP_DEFINE_DOMAINS2D: absolute value of y_cyclic_offset is greater than ieg-isg+1 for '//trim(domain%name))
727 
728  !--- when there is more than one tile on one processor, all the tile will limited on this processor
729  if( tile > 1 .AND. size(pes(:)) > 1) call mpp_error(FATAL, &
730  'MPP_DEFINE_DOMAINS2D: there are more than one tile on this pe, '// &
731  'all the tile should be limited on this pe for '//trim(domain%name))
732 
733  !--- the position of current pe is changed due to mosaic, because pes
734  !--- is only part of the pelist in mosaic (pesall). We assume the pe
735  !--- distribution are contious in mosaic.
736  pos = -1
737  do n = 0, size(pesall(:))-1
738  if(pesall(n) == mpp_pe() ) then
739  pos = n
740  exit
741  endif
742  enddo
743  if(pos<0) call mpp_error(FATAL, 'MPP_DEFINE_DOMAINS2D: mpp_pe() is not in the pesall list')
744 
745  domain%symmetry = .FALSE.
746  if(present(symmetry)) domain%symmetry = symmetry
747  if(domain%symmetry) then
748  ishift = 1; jshift = 1
749  else
750  ishift = 0; jshift = 0
751  end if
752 
753  !--- first compute domain decomposition.
754  call mpp_compute_extent(isg, ieg, ndivx, ibegin, iend, xextent)
755  call mpp_compute_extent(jsg, jeg, ndivy, jbegin, jend, yextent)
756 
757  xhalosz = 0; yhalosz = 0
758  if(present(xhalo)) xhalosz = xhalo
759  if(present(yhalo)) yhalosz = yhalo
760  whalosz = xhalosz; ehalosz = xhalosz
761  shalosz = yhalosz; nhalosz = yhalosz
762  if(present(whalo)) whalosz = whalo
763  if(present(ehalo)) ehalosz = ehalo
764  if(present(shalo)) shalosz = shalo
765  if(present(nhalo)) nhalosz = nhalo
766 
767  !--- configure maskmap
768  mask = .TRUE.
769  if( PRESENT(maskmap) )then
770  if( size(maskmap,1).NE.ndivx .OR. size(maskmap,2).NE.ndivy ) &
771  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: maskmap array does not match layout for '//trim(domain%name) )
772  mask(:,:) = maskmap(:,:)
773  end if
774  !number of unmask domains in layout must equal number of PEs assigned
775  n = count(mask)
776  if( n.NE.size(pes(:)) )then
777  write( text,'(i8)' )n
778  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: incorrect number of PEs assigned for ' // &
779  'this layout and maskmap. Use '//text//' PEs for this domain decomposition for '//trim(domain%name) )
780  end if
781 
782  memory_xsize = 0; memory_ysize = 0
783  if(present(memory_size)) then
784  if(size(memory_size(:)) .NE. 2) call mpp_error(FATAL, &
785  "mpp_define_domains2D: size of memory_size should be 2 for "//trim(domain%name))
786  memory_xsize = memory_size(1)
787  memory_ysize = memory_size(2)
788  end if
789 
790  !--- set up domain%list.
791  !--- set up 2-D domain decomposition for T, E, C, N and computing overlapping
792  !--- when current tile is the last tile in the mosaic.
793  nlist = size(pesall(:))
794  if( .NOT. Associated(domain%x) ) then
795  allocate(domain%tileList(1))
796  domain%tileList(1)%xbegin = global_indices(1)
797  domain%tileList(1)%xend = global_indices(2)
798  domain%tileList(1)%ybegin = global_indices(3)
799  domain%tileList(1)%yend = global_indices(4)
800  allocate(domain%x(1), domain%y(1) )
801  allocate(domain%tile_id(1))
802  domain%tile_id = cur_tile_id
803  domain%ntiles = 1
804  domain%max_ntile_pe = 1
805  domain%ncontacts = 0
806  domain%rotated_ninety = .FALSE.
807  allocate( domain%list(0:nlist-1) )
808  do i = 0, nlist-1
809  allocate( domain%list(i)%x(1), domain%list(i)%y(1), domain%list(i)%tile_id(1) )
810  end do
811  end if
812 
813  domain%initialized = .true.
814 
815  start_pos = 0
816  do n = 0, nlist-1
817  if(pesall(n) == pes(0)) then
818  start_pos = n
819  exit
820  endif
821  enddo
822 
823  !place on PE array; need flag to assign them to j first and then i
824  pearray(:,:) = NULL_PE
825  ipos = NULL_PE; jpos = NULL_PE
826  n = 0
827  m = start_pos
828  do j = 0,ndivy-1
829  do i = 0,ndivx-1
830  if( mask(i,j) )then
831  pearray(i,j) = pes(n)
832  domain%list(m)%x(tile)%compute%begin = ibegin(i)
833  domain%list(m)%x(tile)%compute%end = iend(i)
834  domain%list(m)%y(tile)%compute%begin = jbegin(j)
835  domain%list(m)%y(tile)%compute%end = jend(j)
836  domain%list(m)%x(tile)%compute%size = domain%list(m)%x(tile)%compute%end - domain%list(m)%x(tile)%compute%begin + 1
837  domain%list(m)%y(tile)%compute%size = domain%list(m)%y(tile)%compute%end - domain%list(m)%y(tile)%compute%begin + 1
838  domain%list(m)%tile_id(tile) = cur_tile_id
839  domain%list(m)%x(tile)%pos = i
840  domain%list(m)%y(tile)%pos = j
841  domain%list(m)%tile_root_pe = pes(0)
842  domain%list(m)%pe = pesall(m)
843 
844  if( pes(n).EQ.mpp_pe() )then
845  ipos = i
846  jpos = j
847  end if
848  n = n + 1
849  m = m + 1
850  end if
851  end do
852  end do
853 
854  !Considering mosaic, the following will only be done on the pe in the pelist
855  !when there is only one tile, all the current pe will be in the pelist.
856  if( ANY(pes == mpp_pe()) ) then
857  domain%io_layout = layout
858  domain%tile_root_pe = pes(0)
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  allocate( domain%pearray(0:ndivx-1,0:ndivy-1) )
870  domain%pearray = pearray
871  end if
872 
873  domain%pe = mpp_pe()
874  domain%pos = pos
875  domain_cnt = domain_cnt + INT(1,KIND=LONG_KIND)
876  domain%id = domain_cnt*DOMAIN_ID_BASE ! Must be LONG_KIND arithmetic
877 
878  !do domain decomposition using 1D versions in X and Y,
879  call mpp_define_domains( global_indices(1:2), ndivx, domain%x(tile), &
880  pack(pearray(:,jpos),mask(:,jpos)), xflags, xhalo, xextent, mask(:,jpos), memory_xsize, whalo, ehalo )
881  call mpp_define_domains( global_indices(3:4), ndivy, domain%y(tile), &
882  pack(pearray(ipos,:),mask(ipos,:)), yflags, yhalo, yextent, mask(ipos,:), memory_ysize, shalo, nhalo )
883  if( domain%x(tile)%list(ipos)%pe.NE.domain%y(tile)%list(jpos)%pe ) &
884  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS2D: domain%x%list(ipos)%pe.NE.domain%y%list(jpos)%pe.' )
885 
886  !--- when x_cyclic_offset or y_cyclic_offset is set, no cross domain is allowed
887  if(x_offset .NE. 0 .OR. y_offset .NE. 0) then
888  if(whalosz .GT. domain%x(tile)%compute%size .OR. ehalosz .GT. domain%x(tile)%compute%size ) &
889  call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
890  "whalo and ehalo must be no larger than the x-direction computation domain size")
891  if(shalosz .GT. domain%y(tile)%compute%size .OR. nhalosz .GT. domain%y(tile)%compute%size ) &
892  call mpp_error(FATAL, "mpp_define_domains_2d: when x_cyclic_offset/y_cyclic_offset is set, "// &
893  "shalo and nhalo must be no larger than the y-direction computation domain size")
894  endif
895 
896  !--- restrict the halo size is no larger than global domain size.
897  if(whalosz .GT. domain%x(tile)%global%size) &
898  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: whalo is greather global domain size")
899  if(ehalosz .GT. domain%x(tile)%global%size) &
900  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: ehalo is greather global domain size")
901  if(shalosz .GT. domain%x(tile)%global%size) &
902  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: shalo is greather global domain size")
903  if(nhalosz .GT. domain%x(tile)%global%size) &
904  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: nhalo is greather global domain size")
905 
906  !set up fold, when the boundary is folded, there is only one tile.
907  domain%fold = 0
908  nfold = 0
909  if( PRESENT(xflags) )then
910  if( BTEST(xflags,WEST) ) then
911  !--- make sure no cross-domain in y-direction
912  if(domain%x(tile)%data%begin .LE. domain%x(tile)%global%begin .AND. &
913  domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then
914  call mpp_error(FATAL, &
915  'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded')
916  endif
917  if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
918  'MPP_DEFINE_DOMAINS: an axis cannot be both folded west and cyclic for '//trim(domain%name) )
919  domain%fold = domain%fold + FOLD_WEST_EDGE
920  nfold = nfold+1
921  endif
922  if( BTEST(xflags,EAST) ) then
923  !--- make sure no cross-domain in y-direction
924  if(domain%x(tile)%data%end .GE. domain%x(tile)%global%end .AND. &
925  domain%x(tile)%compute%end < domain%x(tile)%global%end ) then
926  call mpp_error(FATAL, &
927  'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded')
928  endif
929  if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
930  'MPP_DEFINE_DOMAINS: an axis cannot be both folded east and cyclic for '//trim(domain%name) )
931  domain%fold = domain%fold + FOLD_EAST_EDGE
932  nfold = nfold+1
933  endif
934  endif
935  if( PRESENT(yflags) )then
936  if( BTEST(yflags,SOUTH) ) then
937  !--- make sure no cross-domain in y-direction
938  if(domain%y(tile)%data%begin .LE. domain%y(tile)%global%begin .AND. &
939  domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then
940  call mpp_error(FATAL, &
941  'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded')
942  endif
943  if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
944  'MPP_DEFINE_DOMAINS: an axis cannot be both folded north and cyclic for '//trim(domain%name))
945  domain%fold = domain%fold + FOLD_SOUTH_EDGE
946  nfold = nfold+1
947  endif
948  if( BTEST(yflags,NORTH) ) then
949  !--- when the halo size is big and halo region is crossing neighbor domain, we
950  !--- restrict the halo size is less than half of the global size.
951  if(whalosz .GT. domain%x(tile)%compute%size .AND. whalosz .GE. domain%x(tile)%global%size/2 ) &
952  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, whalo .GT. compute domain size "// &
953  "and whalo .GE. half of global domain size")
954  if(ehalosz .GT. domain%x(tile)%compute%size .AND. ehalosz .GE. domain%x(tile)%global%size/2 ) &
955  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, ehalo is .GT. compute domain size "// &
956  "and ehalo .GE. half of global domain size")
957  if(shalosz .GT. domain%y(tile)%compute%size .AND. shalosz .GE. domain%x(tile)%global%size/2 ) &
958  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, shalo .GT. compute domain size "// &
959  "and shalo .GE. half of global domain size")
960  if(nhalosz .GT. domain%y(tile)%compute%size .AND. nhalosz .GE. domain%x(tile)%global%size/2 ) &
961  call mpp_error(FATAL, "MPP_DEFINE_DOMAINS2D: north is folded, nhalo .GT. compute domain size "// &
962  "and nhalo .GE. half of global domain size")
963 
964 
965  if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
966  'MPP_DEFINE_DOMAINS: an axis cannot be both folded south and cyclic for '//trim(domain%name) )
967  domain%fold = domain%fold + FOLD_NORTH_EDGE
968  nfold = nfold+1
969  endif
970  endif
971  if(nfold > 1) call mpp_error(FATAL, &
972  'MPP_DEFINE_DOMAINS2D: number of folded edge is greater than 1 for '//trim(domain%name) )
973 
974  if(nfold == 1) then
975  if( x_offset .NE. 0 .OR. y_offset .NE. 0) call mpp_error(FATAL, &
976  'MPP_DEFINE_DOMAINS2D: For the foled_north/folded_south/fold_east/folded_west boundary condition, '// &
977  'x_cyclic_offset and y_cyclic_offset must be zero for '//trim(domain%name))
978  endif
979  if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,NORTH) )then
980  if( domain%y(tile)%cyclic )call mpp_error( FATAL, &
981  'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
982  if( modulo(domain%x(tile)%global%size,2).NE.0 ) &
983  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in X must be even ' // &
984  'when there is a fold in Y for '//trim(domain%name) )
985  !check if folded domain boundaries line up in X: compute domains lining up is a sufficient condition for symmetry
986  n = ndivx - 1
987  do i = 0,n/2
988  if( domain%x(tile)%list(i)%compute%size.NE.domain%x(tile)%list(n-i)%compute%size ) &
989  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries ' // &
990  'must line up (mirror-symmetric extents) for '//trim(domain%name) )
991  end do
992  end if
993  if( BTEST(domain%fold,WEST) .OR. BTEST(domain%fold,EAST) )then
994  if( domain%x(tile)%cyclic )call mpp_error( FATAL, &
995  'MPP_DEFINE_DOMAINS: an axis cannot be both folded and cyclic for '//trim(domain%name) )
996  if( modulo(domain%y(tile)%global%size,2).NE.0 ) &
997  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: number of points in Y must be even '//&
998  'when there is a fold in X for '//trim(domain%name) )
999  !check if folded domain boundaries line up in Y: compute domains lining up is a sufficient condition for symmetry
1000  n = ndivy - 1
1001  do i = 0,n/2
1002  if( domain%y(tile)%list(i)%compute%size.NE.domain%y(tile)%list(n-i)%compute%size ) &
1003  call mpp_error( FATAL, 'MPP_DEFINE_DOMAINS: Folded domain boundaries must '//&
1004  'line up (mirror-symmetric extents) for '//trim(domain%name) )
1005  end do
1006  end if
1007 
1008  !set up domain%list
1009  if( mpp_pe().EQ.pes(0) .AND. PRESENT(name) )then
1010  logunit = stdlog()
1011  write( logunit, '(/a,i5,a,i5)' )trim(name)//' domain decomposition: ', ndivx, ' X', ndivy
1012  write( logunit, '(3x,a)' )'pe, is, ie, js, je, isd, ied, jsd, jed'
1013  end if
1014  end if ! if( ANY(pes == mpp_pe()) )
1015 
1016  if(is_complete) then
1017  domain%whalo = whalosz; domain%ehalo = ehalosz
1018  domain%shalo = shalosz; domain%nhalo = nhalosz
1019  allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N)
1020  domain%update_T%next => NULL()
1021  domain%update_E%next => NULL()
1022  domain%update_C%next => NULL()
1023  domain%update_N%next => NULL()
1024  allocate(domain%check_E, domain%check_C, domain%check_N )
1025  domain%update_T%nsend = 0
1026  domain%update_T%nrecv = 0
1027  domain%update_C%nsend = 0
1028  domain%update_C%nrecv = 0
1029  domain%update_E%nsend = 0
1030  domain%update_E%nrecv = 0
1031  domain%update_N%nsend = 0
1032  domain%update_N%nrecv = 0
1033 
1034  if( BTEST(domain%fold,SOUTH) ) then
1035  call compute_overlaps_fold_south(domain, CENTER, 0, 0)
1036  call compute_overlaps_fold_south(domain, CORNER, ishift, jshift)
1037  call compute_overlaps_fold_south(domain, EAST, ishift, 0)
1038  call compute_overlaps_fold_south(domain, NORTH, 0, jshift)
1039  else if( BTEST(domain%fold,WEST) ) then
1040  call compute_overlaps_fold_west(domain, CENTER, 0, 0)
1041  call compute_overlaps_fold_west(domain, CORNER, ishift, jshift)
1042  call compute_overlaps_fold_west(domain, EAST, ishift, 0)
1043  call compute_overlaps_fold_west(domain, NORTH, 0, jshift)
1044  else if( BTEST(domain%fold,EAST) ) then
1045  call compute_overlaps_fold_east(domain, CENTER, 0, 0)
1046  call compute_overlaps_fold_east(domain, CORNER, ishift, jshift)
1047  call compute_overlaps_fold_east(domain, EAST, ishift, 0)
1048  call compute_overlaps_fold_east(domain, NORTH, 0, jshift)
1049  else
1050  call compute_overlaps(domain, CENTER, domain%update_T, check_T, 0, 0, x_offset, y_offset, &
1051  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1052  call compute_overlaps(domain, CORNER, domain%update_C, domain%check_C, ishift, jshift, x_offset, y_offset, &
1053  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1054  call compute_overlaps(domain, EAST, domain%update_E, domain%check_E, ishift, 0, x_offset, y_offset, &
1055  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1056  call compute_overlaps(domain, NORTH, domain%update_N, domain%check_N, 0, jshift, x_offset, y_offset, &
1057  domain%whalo, domain%ehalo, domain%shalo, domain%nhalo)
1058  endif
1059  call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_domains")
1060  call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_domains")
1061  call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_domains")
1062  call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_domains")
1063 
1064 
1065  !--- when ncontacts is nonzero, set_check_overlap will be called in mpp_define
1066  if(domain%symmetry .AND. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1067  call set_check_overlap( domain, CORNER )
1068  call set_check_overlap( domain, EAST )
1069  call set_check_overlap( domain, NORTH )
1070  allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1071  call set_bound_overlap( domain, CORNER )
1072  call set_bound_overlap( domain, EAST )
1073  call set_bound_overlap( domain, NORTH )
1074  end if
1075  call set_domain_comm_inf(domain%update_T)
1076  call set_domain_comm_inf(domain%update_E)
1077  call set_domain_comm_inf(domain%update_C)
1078  call set_domain_comm_inf(domain%update_N)
1079  end if
1080 
1081  !--- check the send and recv size are matching.
1082  !--- or ntiles>1 mosaic,
1083  !--- the check will be done in mpp_define_mosaic
1084  if(debug_message_passing .and. (domain%ncontacts == 0 .OR. domain%ntiles == 1) ) then
1085  send = .true.
1086  recv = .true.
1087  call check_message_size(domain, domain%update_T, send, recv, 'T')
1088  call check_message_size(domain, domain%update_E, send, recv, 'E')
1089  call check_message_size(domain, domain%update_C, send, recv, 'C')
1090  call check_message_size(domain, domain%update_N, send, recv, 'N')
1091  endif
1092 
1093 
1094  !print out decomposition, this didn't consider maskmap.
1095  if( mpp_pe() .EQ. pes(0) .AND. PRESENT(name) )then
1096  write(*,*) trim(name)//' domain decomposition'
1097  write(*,'(a,i4,a,i4,a,i4,a,i4)')'whalo = ', whalosz, ", ehalo = ", ehalosz, ", shalo = ", shalosz, ", nhalo = ", nhalosz
1098  write (*,110) (domain%x(1)%list(i)%compute%size, i= 0, layout(1)-1)
1099  write (*,120) (domain%y(1)%list(i)%compute%size, i= 0, layout(2)-1)
1100 110 format (' X-AXIS = ',24i4,/,(11x,24i4))
1101 120 format (' Y-AXIS = ',24i4,/,(11x,24i4))
1102  endif
1103 
1104  deallocate( pes, pesall)
1105 
1106 
1107  return
1108 end subroutine mpp_define_domains2D
1109 
1110 
1111 !#####################################################################
1112 subroutine check_message_size(domain, update, send, recv, position)
1113  type(domain2d), intent(in) :: domain
1114  type(overlapSpec), intent(in) :: update
1115  logical, intent(in) :: send(:)
1116  logical, intent(in) :: recv(:)
1117  character, intent(in) :: position
1118 
1119  integer, dimension(0:size(domain%list(:))-1) :: msg1, msg2, msg3
1120  integer :: m, n, l, dir, is, ie, js, je, from_pe, msgsize
1121  integer :: nlist
1122 
1123  nlist = size(domain%list(:))
1124 
1125 
1126  msg1 = 0
1127  msg2 = 0
1128  do m = 1, update%nrecv
1129  msgsize = 0
1130  do n = 1, update%recv(m)%count
1131  dir = update%recv(m)%dir(n)
1132  if( recv(dir) ) then
1133  is = update%recv(m)%is(n); ie = update%recv(m)%ie(n)
1134  js = update%recv(m)%js(n); je = update%recv(m)%je(n)
1135  msgsize = msgsize + (ie-is+1)*(je-js+1)
1136  endif
1137  end do
1138  from_pe = update%recv(m)%pe
1139  l = from_pe-mpp_root_pe()
1140  call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1)
1141  msg2(l) = msgsize
1142  enddo
1143 
1144  do m = 1, update%nsend
1145  msgsize = 0
1146  do n = 1, update%send(m)%count
1147  dir = update%send(m)%dir(n)
1148  if(send(dir))then
1149  is = update%send(m)%is(n); ie = update%send(m)%ie(n)
1150  js = update%send(m)%js(n); je = update%send(m)%je(n)
1151  msgsize = msgsize + (ie-is+1)*(je-js+1)
1152  endif
1153  end do
1154  l = update%send(m)%pe-mpp_root_pe()
1155  msg3(l) = msgsize
1156  call mpp_send( msg3(l), plen=1, to_pe=update%send(m)%pe, tag=COMM_TAG_1)
1157  enddo
1158  call mpp_sync_self(check=EVENT_RECV)
1159 
1160  do m = 0, nlist-1
1161  if(msg1(m) .NE. msg2(m)) then
1162  print*, "My pe = ", mpp_pe(), ",domain name =", trim(domain%name), ",at position=",position,",from pe=", &
1163  domain%list(m)%pe, ":send size = ", msg1(m), ", recv size = ", msg2(m)
1164  call mpp_error(FATAL, "mpp_define_domains2D: mismatch on send and recv size")
1165  endif
1166  enddo
1167  call mpp_sync_self()
1168 
1169 
1170 end subroutine check_message_size
1171 
1172  !#####################################################################
1173 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1174 ! !
1175 ! MPP_define_mosaic: define mosaic domain !
1176 ! NOTE: xflags and yflags is not in mpp_define_mosaic, because such relation !
1177 ! are already defined in the mosaic relation. !
1178 ! !
1179 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1180 !??? do we need optional argument xextent and yextent
1181 !??? how to specify pelist, we may use two dimensional variable pelist to represent.
1182 !z1l: We assume the tilelist are in always limited to 1, 2, ... num_tile. If we want
1183 ! to remove this limitation, we need to add one more argument tilelist.
1184  subroutine mpp_define_mosaic( global_indices, layout, domain, num_tile, num_contact, tile1, tile2, &
1185  istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, pe_start, &
1186  pe_end, pelist, whalo, ehalo, shalo, nhalo, xextent, yextent, &
1187  maskmap, name, memory_size, symmetry, xflags, yflags, tile_id )
1188  integer, intent(in) :: global_indices(:,:) ! The size of first indice is 4, (/ isg, ieg, jsg, jeg /)
1189  ! The size of second indice is number of tiles in mosaic.
1190  integer, intent(in) :: layout(:,:)
1191  type(domain2D), intent(inout) :: domain
1192  integer, intent(in) :: num_tile ! number of tiles in the mosaic
1193  integer, intent(in) :: num_contact ! number of contact region between tiles.
1194  integer, intent(in) :: tile1(:), tile2(:) ! tile number
1195  integer, intent(in) :: istart1(:), iend1(:) ! i-index in tile_1 of contact region
1196  integer, intent(in) :: jstart1(:), jend1(:) ! j-index in tile_1 of contact region
1197  integer, intent(in) :: istart2(:), iend2(:) ! i-index in tile_2 of contact region
1198  integer, intent(in) :: jstart2(:), jend2(:) ! j-index in tile_2 of contact region
1199  integer, intent(in) :: pe_start(:) ! start pe of the pelist used in each tile
1200  integer, intent(in) :: pe_end(:) ! end pe of the pelist used in each tile
1201  integer, intent(in), optional :: pelist(:) ! list of processors used in mosaic
1202  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1203  integer, intent(in), optional :: xextent(:,:), yextent(:,:)
1204  logical, intent(in), optional :: maskmap(:,:,:)
1205  character(len=*), intent(in), optional :: name
1206  integer, intent(in), optional :: memory_size(2)
1207  logical, intent(in), optional :: symmetry
1208  integer, intent(in), optional :: xflags, yflags
1209  integer, intent(in), optional :: tile_id(:) ! tile_id of each tile in the mosaic
1210 
1211  integer :: n, m, ndivx, ndivy, nc, nlist, nt, pos, n1, n2
1212  integer :: whalosz, ehalosz, shalosz, nhalosz, xhalosz, yhalosz, t1, t2, tile
1213  integer :: flags_x, flags_y
1214  logical, allocatable :: mask(:,:)
1215  integer, allocatable :: pes(:), xext(:), yext(:), pelist_tile(:), ntile_per_pe(:), tile_count(:)
1216  integer, allocatable :: tile_id_local(:)
1217  logical :: is_symmetry
1218  integer, allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:)
1219  integer, allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:)
1220  real, allocatable :: refine1(:), refine2(:)
1221  type(overlapSpec), pointer :: update=>NULL()
1222  character(len=1) :: position
1223  integer :: msgsize, l, p, is, ie, js, je, from_pe
1224  integer, allocatable :: msg1(:), msg2(:), msg3(:)
1225  integer :: outunit
1226  logical :: send(8), recv(8)
1227 
1228  outunit = stdout()
1229  mosaic_defined = .true.
1230  !--- the size of first indice of global_indices must be 4.
1231  if(size(global_indices, 1) .NE. 4) call mpp_error(FATAL, &
1232  'mpp_domains_define.inc: The size of first dimension of global_indices is not 4')
1233  !--- the size of second indice of global_indices must be num_tile
1234  if(size(global_indices, 2) .NE. num_tile) call mpp_error(FATAL, &
1235  'mpp_domains_define.inc: The size of second dimension of global_indices is not equal num_tile')
1236  !--- the size of first indice of layout must be 2. The second dimension size of layout must equal num_tile.
1237  if(size(layout, 1) .NE. 2) call mpp_error(FATAL, &
1238  'mpp_domains_define.inc: The size of first dimension of layout is not 2')
1239  if(size(layout,2) .NE. num_tile) call mpp_error(FATAL, &
1240  'mpp_domains_define.inc: The size of second dimension of layout is not equal num_tile')
1241 
1242  !--- setup pelist for the mosaic ---------------------
1243  nlist = mpp_npes()
1244  allocate(pes(0:nlist-1))
1245  if(present(pelist)) then
1246  if( nlist .NE. size(pelist(:))) call mpp_error(FATAL, &
1247  'mpp_domains_define.inc: size of pelist is not equal mpp_npes')
1248  pes = pelist
1249  else
1250  call mpp_get_current_pelist(pes)
1251  end if
1252  !--- pelist should be monotonic increasing by 1.
1253  do n = 1, nlist-1
1254  if(pes(n) - pes(n-1) .NE. 1) call mpp_error(FATAL, &
1255  'mpp_domains_define.inc: pelist is not monotonic increasing by 1')
1256  end do
1257 
1258  is_symmetry = .FALSE.
1259  if(present(symmetry)) is_symmetry = symmetry
1260 
1261  if(size(pe_start(:)) .NE. num_tile .OR. size(pe_end(:)) .NE. num_tile ) call mpp_error(FATAL, &
1262  'mpp_domains_define.inc: size of pe_start and/or pe_end is not equal num_tile')
1263  !--- make sure pe_start and pe_end is in the pelist.
1264  if( ANY( pe_start < pes(0) ) ) call mpp_error(FATAL, 'mpp_domains_define.inc: not all the pe_start are in the pelist')
1265  if( ANY( pe_end > pes(nlist-1)) ) call mpp_error(FATAL, 'mpp_domains_define.inc: not all the pe_end are in the pelist')
1266 
1267  !--- calculate number of tiles on each pe.
1268  allocate( ntile_per_pe(0:nlist-1) )
1269  ntile_per_pe = 0
1270  do n = 1, num_tile
1271  do m = pe_start(n) - mpp_root_pe(), pe_end(n) - mpp_root_pe()
1272  ntile_per_pe(m) = ntile_per_pe(m) + 1
1273  end do
1274  end do
1275  if(ANY(ntile_per_pe == 0)) call mpp_error(FATAL, &
1276  'mpp_domains_define.inc: At least one pe in pelist is not used by any tile in the mosaic')
1277 
1278  !--- check the size comformable of xextent and yextent
1279  if( PRESENT(xextent) ) then
1280  if(size(xextent,1) .GT. maxval(layout(1,:)) ) call mpp_error(FATAL, &
1281  'mpp_domains_define.inc: size mismatch between xextent and layout')
1282  if(size(xextent,2) .NE. num_tile) call mpp_error(FATAL, &
1283  'mpp_domains_define.inc: size of xextent is not eqaul num_tile')
1284  end if
1285  if( PRESENT(yextent) ) then
1286  if(size(yextent,1) .GT. maxval(layout(2,:)) ) call mpp_error(FATAL, &
1287  'mpp_domains_define.inc: size mismatch between yextent and layout')
1288  if(size(yextent,2) .NE. num_tile) call mpp_error(FATAL, &
1289  'mpp_domains_define.inc: size of yextent is not eqaul num_tile')
1290  end if
1291 
1292  !--- check the size comformable of maskmap
1293  !--- since the layout is different between tiles, so the actual size of maskmap for each tile is
1294  !--- not diffrent. When define maskmap for multiple tiles, user can choose the maximum value
1295  !--- of layout of all tiles to the first and second dimension of maskmap.
1296  if(present(maskmap)) then
1297  if(size(maskmap,1) .GT. maxval(layout(1,:)) .or. size(maskmap,2) .GT. maxval(layout(2,:))) &
1298  call mpp_error(FATAL, 'mpp_domains_define.inc: size mismatch between maskmap and layout')
1299  if(size(maskmap,3) .NE. num_tile) call mpp_error(FATAL, &
1300  'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile')
1301  end if
1302 
1303  allocate(domain%tileList(num_tile))
1304  do n = 1, num_tile
1305  domain%tileList(n)%xbegin = global_indices(1,n)
1306  domain%tileList(n)%xend = global_indices(2,n)
1307  domain%tileList(n)%ybegin = global_indices(3,n)
1308  domain%tileList(n)%yend = global_indices(4,n)
1309  enddo
1310  !--- define some mosaic information in domain type
1311  nt = ntile_per_pe(mpp_pe()-mpp_root_pe())
1312  allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) )
1313  allocate(domain%list(0:nlist-1))
1314 
1315  do n = 0, nlist-1
1316  nt = ntile_per_pe(n)
1317  allocate(domain%list(n)%x(nt), domain%list(n)%y(nt), domain%list(n)%tile_id(nt) )
1318  end do
1319 
1320  pe = mpp_pe()
1321  pos = 0
1322  if( PRESENT(tile_id) ) then
1323  if(size(tile_id(:)) .NE. num_tile) then
1324  call mpp_error(FATAL, "mpp_domains_define.inc: size(tile_id) .NE. num_tile")
1325  endif
1326  endif
1327  allocate(tile_id_local(num_tile))
1328 
1329 !These directives are a work-around for a bug in the CCE compiler, which
1330 !causes a segmentation fault when the compiler attempts to vectorize a
1331 !loop containing an optional argument (when -g is included).
1332 
1333 !DIR$ NOVECTOR
1334  do n = 1, num_tile
1335  if(PRESENT(tile_id)) then
1336  tile_id_local(n) = tile_id(n)
1337  else
1338  tile_id_local(n) = n
1339  endif
1340  enddo
1341 !DIR$ VECTOR
1342 
1343  do n = 1, num_tile
1344  if( pe .GE. pe_start(n) .AND. pe .LE. pe_end(n)) then
1345  pos = pos + 1
1346  domain%tile_id(pos) = tile_id_local(n)
1347  end if
1348  end do
1349 
1350  domain%initialized = .true.
1351  domain%rotated_ninety = .FALSE.
1352  domain%ntiles = num_tile
1353  domain%max_ntile_pe = maxval(ntile_per_pe)
1354  domain%ncontacts = num_contact
1355 
1356  deallocate(ntile_per_pe)
1357  !---call mpp_define_domain to define domain decomposition for each tile.
1358  allocate(tile_count(pes(0):pes(0)+nlist-1))
1359  tile_count = 0 ! tile number on current pe
1360 
1361  do n = 1, num_tile
1362  allocate(mask(layout(1,n), layout(2,n)))
1363  allocate(pelist_tile(pe_start(n):pe_end(n)) )
1364  tile_count(pe_start(n)) = tile_count(pe_start(n)) + 1
1365  do m = pe_start(n), pe_end(n)
1366  pelist_tile(m) = m
1367  end do
1368  mask = .TRUE.
1369  if(present(maskmap)) mask = maskmap(1:layout(1,n), 1:layout(2,n), n)
1370  ndivx = layout(1,n); ndivy = layout(2,n)
1371  allocate(xext(ndivx), yext(ndivy))
1372  xext = 0; yext = 0
1373  if(present(xextent)) xext = xextent(1:ndivx,n)
1374  if(present(yextent)) yext = yextent(1:ndivy,n)
1375  ! when num_tile is one, we assume only folded_north and cyclic_x, cyclic_y boundary condition is the possible
1376  ! z1l: when we decide to support multiple-tile tripolar grid, we will redesign the following part.
1377  if(num_tile == 1) then
1378  flags_x = 0
1379  flags_y = 0
1380  if(PRESENT(xflags)) flags_x = xflags
1381  if(PRESENT(yflags)) flags_y = yflags
1382  do m = 1, num_contact
1383  if(istart1(m) == iend1(m) ) then ! x-direction contact, possible cyclic, folded-west or folded-east
1384  if(istart2(m) .NE. iend2(m) ) call mpp_error(FATAL, &
1385  "mpp_domains_define: for one tile mosaic, when istart1=iend1, istart2 must equal iend2")
1386  if(istart1(m) == istart2(m) ) then ! folded west or folded east
1387  if(istart1(m) == global_indices(1,n) ) then
1388  if(.NOT. BTEST(flags_x,WEST) ) flags_x = flags_x + FOLD_WEST_EDGE
1389  else if(istart1(m) == global_indices(2,n) ) then
1390  if(.NOT. BTEST(flags_x,EAST) ) flags_x = flags_x + FOLD_EAST_EDGE
1391  else
1392  call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1393  "istart1 should equal global_indices(1) or global_indices(2)")
1394  endif
1395  else
1396  if(.NOT. BTEST(flags_x,CYCLIC)) flags_x = flags_x + CYCLIC_GLOBAL_DOMAIN
1397  endif
1398  else if( jstart1(m) == jend1(m) ) then ! y-direction contact, cyclic, folded-south or folded-north
1399  if(jstart2(m) .NE. jend2(m) ) call mpp_error(FATAL, &
1400  "mpp_domains_define: for one tile mosaic, when jstart1=jend1, jstart2 must equal jend2")
1401  if(jstart1(m) == jstart2(m) ) then ! folded south or folded north
1402  if(jstart1(m) == global_indices(3,n) ) then
1403  if(.NOT. BTEST(flags_y,SOUTH) ) flags_y = flags_y + FOLD_SOUTH_EDGE
1404  else if(jstart1(m) == global_indices(4,n) ) then
1405  if(.NOT. BTEST(flags_y,NORTH) ) flags_y = flags_y + FOLD_NORTH_EDGE
1406  else
1407  call mpp_error(FATAL, "mpp_domains_define: when istart1=iend1,jstart1=jend1, "//&
1408  "istart1 should equal global_indices(1) or global_indices(2)")
1409  endif
1410  else
1411  if(.NOT. BTEST(flags_y,CYCLIC)) flags_y = flags_y + CYCLIC_GLOBAL_DOMAIN
1412  end if
1413  else
1414  call mpp_error(FATAL, &
1415  "mpp_domains_define: for one tile mosaic, invalid boundary contact")
1416  end if
1417  end do
1418  call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, xflags = flags_x, &
1419  yflags = flags_y, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, &
1420  xextent=xext, yextent=yext, maskmap=mask, name=name, symmetry=is_symmetry, &
1421  memory_size = memory_size, is_mosaic = .true., tile_id=tile_id_local(n))
1422  else
1423  call mpp_define_domains(global_indices(:,n), layout(:,n), domain, pelist=pelist_tile, &
1424  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, xextent=xext, yextent=yext, &
1425  maskmap=mask, name=name, symmetry=is_symmetry, memory_size = memory_size, &
1426  is_mosaic = .true., tile_count = tile_count(pe_start(n)), tile_id=tile_id_local(n), &
1427  complete = n==num_tile)
1428  end if
1429  deallocate(mask, xext, yext, pelist_tile)
1430  end do
1431 
1432  deallocate(pes, tile_count)
1433 
1434  if(num_contact == 0 .OR. num_tile == 1) return
1435 
1436  !--- loop through each contact region and find the contact for each tile ( including alignment )
1437  !--- we assume the tiles list is continuous and starting from 1.
1438  allocate(is1(num_contact), ie1(num_contact), js1(num_contact), je1(num_contact) )
1439  allocate(is2(num_contact), ie2(num_contact), js2(num_contact), je2(num_contact) )
1440  allocate(isgList(num_tile), iegList(num_tile), jsgList(num_tile), jegList(num_tile) )
1441  allocate(align1(num_contact), align2(num_contact), refine1(num_contact), refine2(num_contact))
1442  !--- get the global domain for each tile
1443  do n = 1, num_tile
1444  isgList(n) = domain%tileList(n)%xbegin; iegList(n) = domain%tileList(n)%xend
1445  jsgList(n) = domain%tileList(n)%ybegin; jegList(n) = domain%tileList(n)%yend
1446  end do
1447 
1448  !--- transfer the contact index to domain index.
1449  nc = 0
1450  do n = 1, num_contact
1451  t1 = tile1(n)
1452  t2 = tile2(n)
1453  is1(n) = istart1(n) + isgList(t1) - 1; ie1(n) = iend1(n) + isgList(t1) - 1
1454  js1(n) = jstart1(n) + jsgList(t1) - 1; je1(n) = jend1(n) + jsgList(t1) - 1
1455  is2(n) = istart2(n) + isgList(t2) - 1; ie2(n) = iend2(n) + isgList(t2) - 1
1456  js2(n) = jstart2(n) + jsgList(t2) - 1; je2(n) = jend2(n) + jsgList(t2) - 1
1457  call check_alignment( is1(n), ie1(n), js1(n), je1(n), isgList(t1), iegList(t1), jsgList(t1), jegList(t1), align1(n))
1458  call check_alignment( is2(n), ie2(n), js2(n), je2(n), isgList(t2), iegList(t2), jsgList(t2), jegList(t2), align2(n))
1459  if( (align1(n) == WEST .or. align1(n) == EAST ) .NEQV. (align2(n) == WEST .or. align2(n) == EAST ) )&
1460  domain%rotated_ninety=.true.
1461  end do
1462 
1463  !--- calculate the refinement ratio between tiles
1464  do n = 1, num_contact
1465  n1 = max(abs(iend1(n) - istart1(n)), abs(jend1(n) - jstart1(n)) ) + 1
1466  n2 = max(abs(iend2(n) - istart2(n)), abs(jend2(n) - jstart2(n)) ) + 1
1467  refine1(n) = real(n2)/n1
1468  refine2(n) = real(n1)/n2
1469  end do
1470 
1471  whalosz = 0; ehalosz = 0; shalosz = 0; nhalosz = 0
1472  if(present(whalo)) whalosz = whalo
1473  if(present(ehalo)) ehalosz = ehalo
1474  if(present(shalo)) shalosz = shalo
1475  if(present(nhalo)) nhalosz = nhalo
1476  xhalosz = max(whalosz, ehalosz)
1477  yhalosz = max(shalosz, nhalosz)
1478 
1479  !--- computing the overlap for the contact region with halo size xhalosz and yhalosz
1480  call define_contact_point( domain, CENTER, num_contact, tile1, tile2, align1, align2, refine1, refine2, &
1481  is1, ie1, js1, je1, is2, ie2, js2, je2, isgList, iegList, jsgList, jegList )
1482 
1483  call set_contact_point( domain, CORNER )
1484  call set_contact_point( domain, EAST )
1485  call set_contact_point( domain, NORTH )
1486 
1487  call set_domain_comm_inf(domain%update_T)
1488  call set_domain_comm_inf(domain%update_E)
1489  call set_domain_comm_inf(domain%update_C)
1490  call set_domain_comm_inf(domain%update_N)
1491 
1492 
1493  !--- goffset setting is needed for exact global sum
1494  do m = 1, size(domain%tile_id(:))
1495  tile = domain%tile_id(m)
1496  do n = 1, num_contact
1497  if( tile1(n) == tile ) then
1498  if(align1(n) == EAST ) domain%x(m)%goffset = 0
1499  if(align1(n) == NORTH) domain%y(m)%goffset = 0
1500  end if
1501  if( tile2(n) == tile ) then
1502  if(align2(n) == EAST ) domain%x(m)%goffset = 0
1503  if(align2(n) == NORTH) domain%y(m)%goffset = 0
1504  end if
1505  end do
1506  end do
1507  call check_overlap_pe_order(domain, domain%update_T, trim(domain%name)//" update_T in mpp_define_mosaic")
1508  call check_overlap_pe_order(domain, domain%update_C, trim(domain%name)//" update_C in mpp_define_mosaic")
1509  call check_overlap_pe_order(domain, domain%update_E, trim(domain%name)//" update_E in mpp_define_mosaic")
1510  call check_overlap_pe_order(domain, domain%update_N, trim(domain%name)//" update_N in mpp_define_mosaic")
1511 
1512  !--- set the overlapping for boundary check if domain is symmetry
1513  if(debug_update_level .NE. NO_CHECK) then
1514  call set_check_overlap( domain, CORNER )
1515  call set_check_overlap( domain, EAST )
1516  call set_check_overlap( domain, NORTH )
1517  endif
1518  if(domain%symmetry) then
1519  allocate(domain%bound_E, domain%bound_C, domain%bound_N )
1520  call set_bound_overlap( domain, CORNER )
1521  call set_bound_overlap( domain, EAST )
1522  call set_bound_overlap( domain, NORTH )
1523  call check_overlap_pe_order(domain, domain%bound_C, trim(domain%name)//" bound_C")
1524  call check_overlap_pe_order(domain, domain%bound_E, trim(domain%name)//" bound_E")
1525  call check_overlap_pe_order(domain, domain%bound_N, trim(domain%name)//" bound_N")
1526  end if
1527 
1528  !--- check the send and recv size are matching.
1529  !--- currently only check T and C-cell. For ntiles>1 mosaic,
1530  !--- the check will be done in mpp_define_mosaic
1532  send = .true.
1533  recv = .true.
1534  call check_message_size(domain, domain%update_T, send, recv, 'T')
1535  call check_message_size(domain, domain%update_C, send, recv, 'C')
1536  call check_message_size(domain, domain%update_E, send, recv, 'E')
1537  call check_message_size(domain, domain%update_N, send, recv, 'N')
1538  endif
1539 
1540 
1541  !--- release memory
1542  deallocate(align1, align2, is1, ie1, js1, je1, is2, ie2, js2, je2 )
1543  deallocate(isgList, iegList, jsgList, jegList, refine1, refine2 )
1544 
1545 
1546  end subroutine mpp_define_mosaic
1547 
1548 !#####################################################################
1549  logical function mpp_mosaic_defined()
1550  ! Accessor function for value of mosaic_defined
1551  mpp_mosaic_defined = mosaic_defined
1552  end function mpp_mosaic_defined
1553 !#####################################################################
1554 
1555  subroutine compute_overlaps( domain, position, update, check, ishift, jshift, x_cyclic_offset, y_cyclic_offset, &
1556  whalo, ehalo, shalo, nhalo )
1557  !computes remote domain overlaps
1558  !assumes only one in each direction
1559  !will calculate the overlapping for T,E,C,N-cell seperately.
1560  type(domain2D), intent(inout) :: domain
1561  type(overlapSpec), intent(inout), pointer :: update
1562  type(overlapSpec), intent(inout), pointer :: check
1563  integer, intent(in) :: position, ishift, jshift
1564  integer, intent(in) :: x_cyclic_offset, y_cyclic_offset
1565  integer, intent(in) :: whalo, ehalo, shalo, nhalo
1566 
1567  integer :: i, m, n, nlist, tMe, tNbr, dir
1568  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
1569  integer :: isg, ieg, jsg, jeg, ioff, joff
1570  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
1571  integer :: ism, iem, jsm, jem
1572  integer :: is2, ie2, js2, je2
1573  integer :: is3, ie3, js3, je3
1574  integer :: isd3, ied3, jsd3, jed3
1575  integer :: isd2, ied2, jsd2, jed2
1576  logical :: folded, need_adjust_1, need_adjust_2, need_adjust_3, folded_north
1577  type(overlap_type) :: overlap
1578  type(overlap_type), pointer :: overlapList(:)=>NULL()
1579  type(overlap_type), pointer :: checkList(:)=>NULL()
1580  integer :: nsend, nrecv
1581  integer :: nsend_check, nrecv_check
1582  integer :: unit
1583  logical :: set_check
1584 
1585  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
1586  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
1587  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
1588  if(size(domain%x(:)) > 1) return
1589 
1590  !--- if there is no halo, no need to compute overlaps.
1591  if(whalo==0 .AND. ehalo==0 .AND. shalo==0 .AND. nhalo==0) return
1592 
1593  !--- when there is only one tile, n will equal to np
1594  nlist = size(domain%list(:))
1595  set_check = .false.
1596  if(ASSOCIATED(check)) set_check = .true.
1597  allocate(overlapList(MAXLIST) )
1598  if(set_check) allocate(checkList(MAXLIST) )
1599 
1600  !--- overlap is used to store the overlapping temporarily.
1601  call allocate_update_overlap( overlap, MAXOVERLAP)
1602  !send
1603  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
1604  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
1605  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
1606 
1607  update%xbegin = ism; update%xend = iem
1608  update%ybegin = jsm; update%yend = jem
1609  if(set_check) then
1610  check%xbegin = ism; check%xend = iem
1611  check%ybegin = jsm; check%yend = jem
1612  endif
1613  update%whalo = whalo; update%ehalo = ehalo
1614  update%shalo = shalo; update%nhalo = nhalo
1615 
1616  ioff = ni - ishift
1617  joff = nj - jshift
1618  middle = (isg+ieg)/2+1
1619  tMe = 1; tNbr = 1
1620  folded_north = BTEST(domain%fold,NORTH)
1621  if( BTEST(domain%fold,SOUTH) .OR. BTEST(domain%fold,EAST) .OR. BTEST(domain%fold,WEST) ) then
1622  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps): folded south, east or west boundary condition " // &
1623  "is not supported, please use other version of compute_overlaps for "//trim(domain%name))
1624  endif
1625 
1626  nsend = 0
1627  nsend_check = 0
1628 
1629  do list = 0,nlist-1
1630  m = mod( domain%pos+list, nlist )
1631  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
1632  !to_pe's eastern halo
1633  dir = 1
1634  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
1635  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
1636  !--- to make sure the consistence between pes
1637  if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
1638  .AND. ( jsc == je .or. jec == js ) ) then
1639  !--- do nothing, this point will come from other pe
1640  else
1641  !--- when the north face is folded, the east halo point at right side domain will be folded.
1642  !--- the position should be on CORNER or NORTH
1643  if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
1644  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1645  isg, ieg, dir, ishift, position, ioff, middle)
1646  else
1647  if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1648  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1649  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1650  else
1651  if( ie.GT.ieg ) then
1652  if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
1653  is = is-ioff; ie = ie-ioff
1654  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1655  end if
1656  end if
1657  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1658  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1659  endif
1660  endif
1661  end if
1662 
1663  !to_pe's SE halo
1664  dir = 2
1665  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
1666  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
1667  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1668  !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
1669  !--- the other part is both are zero.
1670  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1671  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1672  if(je .LT. jsg) then ! js .LT. jsg
1673  if( domain%y(tMe)%cyclic ) then
1674  js = js + joff; je = je + joff
1675  endif
1676  else if(js .Lt. jsg) then ! split into two parts
1677  if( domain%y(tMe)%cyclic ) then
1678  js2 = js + joff; je2 = jsg-1+joff
1679  js = jsg;
1680  endif
1681  endif
1682  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1683  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1684  if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1685  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1686  else
1687  if( ie.GT.ieg )then
1688  if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
1689  is = is-ioff; ie = ie-ioff
1690  need_adjust_1 = .false.
1691  if(jsg .GT. js) then
1692  if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1693  js = js+joff; je = je+joff
1694  need_adjust_2 = .false.
1695  if(x_cyclic_offset .NE. 0) then
1696  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1697  else if(y_cyclic_offset .NE. 0) then
1698  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1699  end if
1700  end if
1701  else
1702  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
1703  need_adjust_3 = .false.
1704  end if
1705  end if
1706  end if
1707  if( need_adjust_3 .AND. jsg.GT.js )then
1708  if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1709  js = js+joff; je = je+joff
1710  if(need_adjust_1 .AND. ie.LE.ieg) then
1711  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1712  end if
1713  end if
1714  end if
1715  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1716  endif
1717 
1718  !to_pe's southern halo
1719  dir = 3
1720  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
1721  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
1722  js2 = 0; je2 = -1
1723  if( jsg.GT.je )then ! jsg .GT. js
1724  if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1725  js = js+joff; je = je+joff
1726  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1727  end if
1728  else if (jsg .GT. js) then ! split into two parts
1729  if( domain%y(tMe)%cyclic) then
1730  js2 = js + joff; je2 = jsg-1+joff
1731  js = jsg
1732  endif
1733  end if
1734 
1735  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1736  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1737  if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1738  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1739 
1740  !to_pe's SW halo
1741  dir = 4
1742  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
1743  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
1744  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1745  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1746  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1747  if(je .LT. jsg) then ! js .LT. jsg
1748  if( domain%y(tMe)%cyclic ) then
1749  js = js + joff; je = je + joff
1750  endif
1751  else if(js .Lt. jsg) then ! split into two parts
1752  if( domain%y(tMe)%cyclic ) then
1753  js2 = js + joff; je2 = jsg-1+joff
1754  js = jsg;
1755  endif
1756  endif
1757  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1758  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1759  if(je2 .GE. js2) call fill_overlap_send_nofold(overlap, domain, m, is, ie, js2, je2, isc, iec, jsc, jec, &
1760  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1761  else
1762  if( isg.GT.is )then
1763  if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1764  is = is+ioff; ie = ie+ioff
1765  need_adjust_1 = .false.
1766  if(jsg .GT. js) then
1767  if( domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1768  js = js+joff; je = je+joff
1769  need_adjust_2 = .false.
1770  if(x_cyclic_offset .NE. 0) then
1771  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1772  else if(y_cyclic_offset .NE. 0) then
1773  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1774  end if
1775  end if
1776  else
1777  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1778  need_adjust_3 = .false.
1779  end if
1780  end if
1781  end if
1782  if( need_adjust_3 .AND. jsg.GT.js )then
1783  if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. je.LT.jsc )then !try cyclic offset
1784  js = js+joff; je = je+joff
1785  if(need_adjust_1 .AND. isg.LE.is )then
1786  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
1787  end if
1788  end if
1789  end if
1790  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, isg, ieg, jsg, jeg, dir)
1791  endif
1792 
1793  !to_pe's western halo
1794  dir = 5
1795  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
1796  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
1797 
1798  !--- when the north face is folded, some point at j=nj will be folded.
1799  !--- the position should be on CORNER or NORTH
1800  if( je == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1801  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1802  isg, ieg, dir, ishift, position, ioff, middle)
1803  else
1804  if(x_cyclic_offset ==0 .AND. y_cyclic_offset == 0) then
1805  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1806  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1807  else
1808  if( isg.GT.is )then
1809  if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1810  is = is+ioff; ie = ie+ioff
1811  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1812  endif
1813  end if
1814  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1815  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1816  end if
1817  end if
1818 
1819  !to_pe's NW halo
1820  dir = 6
1821  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
1822  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
1823  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
1824  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
1825  folded = .FALSE.
1826  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1827  if(js .GT. jeg) then ! je > jeg
1828  if( domain%y(tMe)%cyclic ) then
1829  js = js-joff; je = je-joff
1830  else if(folded_north )then
1831  folded = .TRUE.
1832  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1833  endif
1834  else if(je .GT. jeg) then ! split into two parts
1835  if( domain%y(tMe)%cyclic ) then
1836  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1837  js = jeg+1-joff; je = je -joff
1838  else if(folded_north) then
1839  folded = .TRUE.
1840  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1841  js = jeg+1
1842  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1843  if( is .GT. ieg) then
1844  is = is - ioff; ie = ie - ioff
1845  else if( ie .GT. ieg ) then
1846  is3 = is; ie3 = ieg; js3 = js; je3 = je
1847  is = ieg+1-ioff; ie = ie - ioff
1848  endif
1849  endif
1850  endif
1851 
1852  if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1853  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1854  isg, ieg, dir, ishift, position, ioff, middle)
1855  else
1856  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1857  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
1858  endif
1859  if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
1860  isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
1861  if(ie2 .GE. is2) then
1862  if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1863  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1864  isg, ieg, dir, ishift, position, ioff, middle)
1865  else
1866  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1867  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
1868  endif
1869  endif
1870  else
1871  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
1872  if( isg.GT.is )then
1873  if( domain%x(tMe)%cyclic .AND. ie.LT.isc )then !try cyclic offset
1874  is = is+ioff; ie = ie+ioff
1875  need_adjust_1 = .false.
1876  if(je .GT. jeg) then
1877  if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1878  js = js-joff; je = je-joff
1879  need_adjust_2 = .false.
1880  if(x_cyclic_offset .NE. 0) then
1881  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1882  else if(y_cyclic_offset .NE. 0) then
1883  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1884  end if
1885  end if
1886  else
1887  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
1888  need_adjust_3 = .false.
1889  end if
1890  end if
1891  end if
1892  folded = .FALSE.
1893  if( need_adjust_3 .AND. je.GT.jeg )then
1894  if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1895  js = js-joff; je = je-joff
1896  if( need_adjust_1 .AND. isg.LE.is)then
1897  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1898  end if
1899  else if( folded_north )then
1900  folded = .TRUE.
1901  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1902  end if
1903  end if
1904  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1905  isg, ieg, jsg, jeg, dir)
1906  endif
1907 
1908 
1909  !to_pe's northern halo
1910  dir = 7
1911  folded = .FALSE.
1912  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
1913  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
1914 
1915  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
1916  !--- no need to send, because the data on that point will come from other pe.
1917  !--- come from two pe ( there will be only one point on one pe. ).
1918  if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
1919  .AND. ( isc == ie .or. iec == is ) .AND. (.not. folded_north) ) then
1920  !--- do nothing, this point will come from other pe
1921  else
1922  js2 = -1; je2 = 0
1923  if( js .GT. jeg) then ! je .GT. jeg
1924  if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
1925  js = js-joff; je = je-joff
1926  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
1927  else if( folded_north )then
1928  folded = .TRUE.
1929  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1930  end if
1931  else if( je.GT.jeg )then ! split into two parts
1932  if( domain%y(tMe)%cyclic)then !try cyclic offset
1933  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1934  js = jeg+1-joff; je = je - joff
1935  else if( folded_north )then
1936  folded = .TRUE.
1937  is2 = is; ie2 = ie; js2 = js; je2 = jeg
1938  js = jeg+1;
1939  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
1940  end if
1941  end if
1942  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
1943  if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1944  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1945  isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1946  else
1947  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1948  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, domain%symmetry)
1949  endif
1950  else
1951  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
1952  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
1953  endif
1954 
1955  if(ie2 .GE. is2) then
1956  if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
1957  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1958  isg, ieg, dir, ishift, position, ioff, middle, domain%symmetry)
1959  else
1960  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
1961  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
1962  endif
1963  endif
1964  end if
1965 
1966  !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
1967  if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
1968 ! is = is + ioff
1969 ! call insert_update_overlap( overlap, domain%list(m)%pe, &
1970 ! is, is, js, je, isc, iec, jsc, jec, dir, folded)
1971 !??? if(je2 .GE. js2)call insert_update_overlap( overlap, domain%list(m)%pe, &
1972 ! is, is, js2, je2, isc, iec, jsc, jec, dir, folded)
1973  endif
1974 
1975  !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
1976  !--- for folded-north-edge, only need to consider to_pe's north(7) direction
1977  !--- only position at NORTH and CORNER need to be considered
1978  if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
1979  .AND. domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 ) then
1980  if( domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .GE. jeg .AND. isc .LE. middle)then
1981  js = jeg; je = jeg
1982  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
1983  is = max(is, middle)
1984  select case (position)
1985  case(NORTH)
1986  i=is; is = isg+ieg-ie; ie = isg+ieg-i
1987  case(CORNER)
1988  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
1989  end select
1990  call insert_update_overlap(overlap, domain%list(m)%pe, &
1991  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
1992  endif
1993  if(debug_update_level .NE. NO_CHECK .AND. set_check) then
1994  je = domain%list(m)%y(tNbr)%compute%end+jshift;
1995  if(je == jeg) then
1996  is = max(is, isc); ie = min(ie, iec)
1997  js = max(js, jsc); je = min(je, jec)
1998  if(ie.GE.is .AND. je.GE.js )then
1999  nsend_check = nsend_check+1
2000  if(nsend_check > size(checkList(:)) ) then
2001  call expand_check_overlap_list(checkList, nlist)
2002  endif
2003  call allocate_check_overlap(checkList(nsend_check), 1)
2004  call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
2005  tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
2006  end if
2007  end if
2008  endif
2009  endif
2010 
2011  !to_pe's NE halo
2012  dir = 8
2013  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
2014  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
2015  is2 = 0; ie2=-1; js2=0; je2=-1
2016  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2017  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2018  folded = .FALSE.
2019  if(js .GT. jeg) then ! je > jeg
2020  if( domain%y(tMe)%cyclic ) then
2021  js = js-joff; je = je-joff
2022  else if(folded_north )then
2023  folded = .TRUE.
2024  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2025  endif
2026  else if(je .GT. jeg) then ! split into two parts
2027  if( domain%y(tMe)%cyclic ) then
2028  is2 = is; ie2 = ie; js2 = js; je2 = jeg
2029  js = jeg+1-joff; je = je -joff
2030  else if(folded_north) then
2031  folded = .TRUE.
2032  is2 = is; ie2 = ie; js2 = js; je2 = jeg
2033  js = jeg+1
2034  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2035 
2036  if( ie .LT. isg )then
2037  is = is+ioff; ie = ie+ioff
2038  else if( is .LT. isg) then
2039  is3 = isg; ie3 = ie; js3 = js; je3 = je
2040  is = is+ioff; ie = isg-1+ioff;
2041  endif
2042  endif
2043  endif
2044  if( je == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
2045  call fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2046  isg, ieg, dir, ishift, position, ioff, middle)
2047  else
2048  call fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2049  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2050  endif
2051  if(ie3 .GE. is3) call fill_overlap_send_nofold(overlap, domain, m, is3, ie3, js3, je3, &
2052  isc, iec, jsc, jec, isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2053  if(ie2 .GE. is2) then
2054  if(je2 == jeg .AND. jec == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH)) then
2055  call fill_overlap_send_fold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2056  isg, ieg, dir, ishift, position, ioff, middle)
2057  else
2058  call fill_overlap_send_nofold(overlap, domain, m, is2, ie2, js2, je2, isc, iec, jsc, jec, &
2059  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2060  endif
2061  endif
2062  else
2063  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2064  if( ie.GT.ieg )then
2065  if( domain%x(tMe)%cyclic .AND. iec.LT.is )then !try cyclic offset
2066  is = is-ioff; ie = ie-ioff
2067  need_adjust_1 = .false.
2068  if(je .GT. jeg) then
2069  if( domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
2070  js = js-joff; je = je-joff
2071  need_adjust_2 = .false.
2072  if(x_cyclic_offset .NE. 0) then
2073  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2074  else if(y_cyclic_offset .NE. 0) then
2075  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2076  end if
2077  end if
2078  else
2079  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2080  need_adjust_3 = .false.
2081  end if
2082  end if
2083  end if
2084  folded = .false.
2085  if( need_adjust_3 .AND. je.GT.jeg )then
2086  if( need_adjust_2 .AND. domain%y(tMe)%cyclic .AND. jec.LT.js )then !try cyclic offset
2087  js = js-joff; je = je-joff
2088  if( need_adjust_1 .AND. ie.LE.ieg)then
2089  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2090  end if
2091  else if( folded_north )then
2092  folded = .TRUE.
2093  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2094  end if
2095  end if
2096  call fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2097  isg, ieg, jsg, jeg, dir)
2098  endif
2099  endif
2100 
2101  !--- copy the overlapping information
2102  if( overlap%count > 0) then
2103  nsend = nsend + 1
2104  if(nsend > size(overlapList(:)) ) then
2105  call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for send is expanded')
2106  call expand_update_overlap_list(overlapList, nlist)
2107  endif
2108  call add_update_overlap( overlapList(nsend), overlap)
2109  call init_overlap_type(overlap)
2110  endif
2111  end do ! end of send set up.
2112 
2114  !--- write out send information
2115  unit = mpp_pe() + 1000
2116  do m =1,nsend
2117  write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
2118  do n = 1, overlapList(m)%count
2119  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
2120  overlapList(m)%dir(n), overlapList(m)%rotation(n)
2121  enddo
2122  enddo
2123  if(nsend >0) call flush(unit)
2124  endif
2125 
2126  ! copy the overlapping information into domain data structure
2127  if(nsend>0) then
2128  allocate(update%send(nsend))
2129  update%nsend = nsend
2130  do m = 1, nsend
2131  call add_update_overlap( update%send(m), overlapList(m) )
2132  enddo
2133  endif
2134 
2135  if(nsend_check>0) then
2136  check%nsend = nsend_check
2137  allocate(check%send(nsend_check))
2138  do m = 1, nsend_check
2139  call add_check_overlap( check%send(m), checkList(m) )
2140  enddo
2141  endif
2142 
2143  do m = 1,size(overlapList(:))
2144  call deallocate_overlap_type(overlapList(m))
2145  enddo
2146 
2147  if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2148  do m = 1,size(checkList(:))
2149  call deallocate_overlap_type(checkList(m))
2150  enddo
2151  endif
2152 
2153  isgd = isg - domain%whalo
2154  iegd = ieg + domain%ehalo
2155  jsgd = jsg - domain%shalo
2156  jegd = jeg + domain%nhalo
2157 
2158  ! begin setting up recv
2159  nrecv = 0
2160  nrecv_check = 0
2161  do list = 0,nlist-1
2162  m = mod( domain%pos+nlist-list, nlist )
2163  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
2164  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
2165  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
2166  !recv_e
2167  dir = 1
2168  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2169  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
2170  is=isc; ie=iec; js=jsc; je=jec
2171  if( domain%symmetry .AND. (position == NORTH .OR. position == CORNER ) &
2172  .AND. ( jsd == je .or. jed == js ) ) then
2173  ! --- do nothing, this point will come from other pe
2174  else
2175  !--- when the north face is folded, the east halo point at right side domain will be folded.
2176  !--- the position should be on CORNER or NORTH
2177  if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2178  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2179  isg, ieg, dir, ishift, position, ioff, middle)
2180  else
2181  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2182  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2183  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2184  else
2185  if( ied.GT.ieg )then
2186  if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2187  is = is+ioff; ie = ie+ioff
2188  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2189  end if
2190  end if
2191  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2192  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2193  endif
2194  endif
2195  endif
2196 
2197  !recv_se
2198  dir = 2
2199  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2200  jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
2201  is=isc; ie=iec; js=jsc; je=jec
2202  !--- divide into two parts, one part is x_cyclic_offset/y_cyclic_offset is non-zeor,
2203  !--- the other part is both are zero.
2204  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2205  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2206  if(jed .LT. jsg) then ! then jsd < jsg
2207  if( domain%y(tMe)%cyclic ) then
2208  js = js-joff; je = je-joff
2209  endif
2210  else if(jsd .LT. jsg) then !split into two parts
2211  if( domain%y(tMe)%cyclic ) then
2212  js2 = js-joff; je2 = je-joff
2213  endif
2214  endif
2215  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2216  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2217  if(je2 .GE. js2) call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2218  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2219  else
2220  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2221  if( jsd.LT.jsg )then
2222  if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
2223  js = js-joff; je = je-joff
2224  need_adjust_1 = .false.
2225  if( ied.GT.ieg )then
2226  if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2227  is = is+ioff; ie = ie+ioff
2228  need_adjust_2 = .false.
2229  if(x_cyclic_offset .NE. 0) then
2230  call apply_cyclic_offset(js, je, x_cyclic_offset, jsgd, jeg, nj)
2231  else if(y_cyclic_offset .NE. 0) then
2232  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, iegd, ni)
2233  end if
2234  end if
2235  else
2236  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2237  need_adjust_3 = .false.
2238  end if
2239  end if
2240  end if
2241  if( need_adjust_3 .AND. ied.GT.ieg )then
2242  if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2243  is = is+ioff; ie = ie+ioff
2244  if( need_adjust_1 .AND. jsd.GE.jsg )then
2245  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2246  end if
2247  end if
2248  end if
2249  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2250  isg, ieg, jsg, jeg, dir)
2251  endif
2252 
2253  !recv_s
2254  dir = 3
2255  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
2256  jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
2257  is=isc; ie=iec; js=jsc; je=jec
2258  js2 = 0; je2 = -1
2259  if( jed .LT. jsg) then ! jsd < jsg
2260  if( domain%y(tMe)%cyclic ) then
2261  js = js-joff; je = je-joff
2262  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2263  endif
2264  else if( jsd.LT.jsg )then ! split into two parts
2265  if( domain%y(tMe)%cyclic)then !try cyclic offset
2266  js2 = js-joff; je2 = je-joff
2267  end if
2268  end if
2269  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2270  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2271  if(je2 .GE. js2) call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2272  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2273 
2274  !recv_sw
2275  dir = 4
2276  isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
2277  jsd = domain%y(tMe)%compute%begin-shalo; jed = domain%y(tMe)%compute%begin-1
2278  is=isc; ie=iec; js=jsc; je=jec
2279  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2280  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2281  if( ied.LT.isg )then ! isd < isg
2282  if( domain%x(tMe)%cyclic ) then
2283  is = is-ioff; ie = ie-ioff
2284  endif
2285  else if (isd.LT.isg )then ! split into two parts
2286  if( domain%x(tMe)%cyclic ) then
2287  is2 = is-ioff; ie2 = ie-ioff
2288  endif
2289  endif
2290  if( jed.LT.jsg )then ! jsd < jsg
2291  if( domain%y(tMe)%cyclic ) then
2292  js = js-joff; je = je-joff
2293  endif
2294  else if( jsd.LT.jsg )then ! split into two parts
2295  if( domain%y(tMe)%cyclic ) then
2296  js2 = js-joff; je2 = je-joff
2297  endif
2298  endif
2299  else
2300  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2301  if( jsd.LT.jsg )then
2302  if( domain%y(tMe)%cyclic .AND. js.GT.jed )then !try cyclic offset
2303  js = js-joff; je = je-joff
2304  need_adjust_1 = .false.
2305  if( isd.LT.isg )then
2306  if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2307  is = is-ioff; ie = ie-ioff
2308  need_adjust_2 = .false.
2309  if(x_cyclic_offset .NE. 0) then
2310  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsgd, jeg, nj)
2311  else if(y_cyclic_offset .NE. 0) then
2312  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isgd, ieg, ni)
2313  end if
2314  end if
2315  else
2316  call apply_cyclic_offset(is, ie, -y_cyclic_offset, isg, ieg, ni)
2317  need_adjust_3 = .false.
2318  end if
2319  end if
2320  end if
2321  if( need_adjust_3 .AND. isd.LT.isg )then
2322  if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2323  is = is-ioff; ie = ie-ioff
2324  if(need_adjust_1 .AND. jsd.GE.jsg) then
2325  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2326  end if
2327  end if
2328  end if
2329  endif
2330  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2331  isg, ieg, jsg, jeg, dir)
2332 
2333  if(ie2 .GE. is2)call fill_overlap(overlap, domain, m, is2, ie2, js, je, isd, ied, jsd, jed, &
2334  isg, ieg, jsg, jeg, dir)
2335  if(je2 .GE. js2)call fill_overlap(overlap, domain, m, is, ie, js2, je2, isd, ied, jsd, jed, &
2336  isg, ieg, jsg, jeg, dir)
2337 
2338  if(ie2 .GE. is2 .AND. je2 .GE. js2)call fill_overlap(overlap, domain, m, is2, ie2, js2, je2, isd, ied, jsd, jed, &
2339  isg, ieg, jsg, jeg, dir)
2340 
2341 
2342  !recv_w
2343  dir = 5
2344  isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
2345  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
2346  is=isc; ie=iec; js=jsc; je=jec
2347 
2348  !--- when the north face is folded, some point at j=nj will be folded.
2349  !--- the position should be on CORNER or NORTH
2350  if( jed == jeg .AND. folded_north .AND. (position == CORNER .OR. position == NORTH) ) then
2351  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2352  isg, ieg, dir, ishift, position, ioff, middle)
2353  else
2354  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2355  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2356  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, symmetry=domain%symmetry)
2357  else
2358  if( isd.LT.isg )then
2359  if( domain%x(tMe)%cyclic .AND. is.GT.ied )then !try cyclic offset
2360  is = is-ioff; ie = ie-ioff
2361  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2362  end if
2363  end if
2364  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2365  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2366  endif
2367  endif
2368 
2369  !recv_nw
2370  dir = 6
2371  folded = .false.
2372  isd = domain%x(tMe)%compute%begin-whalo; ied = domain%x(tMe)%compute%begin-1
2373  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2374  is=isc; ie=iec; js=jsc; je=jec
2375  is2 = 0; ie2 = -1; js2 = 0; je2 = -1
2376  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2377  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2378  js2 = -1; je2 = 0
2379  if( jsd .GT. jeg ) then ! jed > jeg
2380  if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2381  js = js+joff; je = je+joff
2382  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2383  else if( folded_north )then
2384  folded = .TRUE.
2385  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2386  end if
2387  else if( jed.GT.jeg )then ! split into two parts
2388  if( domain%y(tMe)%cyclic)then !try cyclic offset
2389  is2 = is; ie2 = ie; js2 = js; je2 = je
2390  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2391  js = js + joff; je = je + joff
2392  jsd = jeg+1
2393  else if( folded_north )then
2394  folded = .TRUE.
2395  is2 = is; ie2 = ie; js2 = js; je2 = je
2396  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2397  jsd = jeg+1
2398  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2399  if(isd < isg .and. ied .GE. isg .and. domain%symmetry) then
2400  isd3 = isd; ied3 = isg-1
2401  jsd3 = jsd; jed3 = jed
2402  is3 = is-ioff; ie3=ie-ioff
2403  js3 = js; je3 = je
2404  isd = isg;
2405  endif
2406  end if
2407  endif
2408 
2409  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2410  .AND. (position == CORNER .OR. position == NORTH)) then
2411  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2412  isg, ieg, dir, ishift, position, ioff, middle)
2413  else
2414  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2415  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2416  endif
2417 
2418  if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
2419  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2420 
2421  if(ie2 .GE. is2) then
2422  if( jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2423  .AND. (position == CORNER .OR. position == NORTH)) then
2424  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2425  isg, ieg, dir, ishift, position, ioff, middle)
2426  else
2427  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2428  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2429  endif
2430  endif
2431  else
2432  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2433  if( jed.GT.jeg )then
2434  if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2435  js = js+joff; je = je+joff
2436  need_adjust_1 = .false.
2437  if( isd.LT.isg )then
2438  if( domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
2439  is = is-ioff; ie = ie-ioff
2440  need_adjust_2 = .false.
2441  if(x_cyclic_offset .NE. 0) then
2442  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jegd, nj)
2443  else if(y_cyclic_offset .NE. 0) then
2444  call apply_cyclic_offset(is, ie, y_cyclic_offset, isgd, ieg, ni)
2445  end if
2446  end if
2447  else
2448  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2449  need_adjust_3 = .false.
2450  end if
2451  else if( folded_north )then
2452  folded = .TRUE.
2453  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2454  end if
2455  end if
2456  if( need_adjust_3 .AND. isd.LT.isg )then
2457  if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. is.GE.ied )then !try cyclic offset
2458  is = is-ioff; ie = ie-ioff
2459  if( need_adjust_1 .AND. jed.LE.jeg )then
2460  call apply_cyclic_offset(js, je, -x_cyclic_offset, jsg, jeg, nj)
2461  end if
2462  end if
2463  end if
2464  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2465  isg, ieg, jsg, jeg, dir)
2466  endif
2467 
2468  !--- when north edge is folded, is will be less than isg when position is EAST and CORNER
2469  if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
2470  is = is + ioff
2471  call insert_update_overlap(overlap, domain%list(m)%pe, &
2472  is, is, js, je, isd, ied, jsd, jed, dir, folded )
2473  endif
2474 
2475  !recv_n
2476  dir = 7
2477  folded = .false.
2478  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
2479  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2480  is=isc; ie=iec; js=jsc; je=jec
2481 
2482  !--- when domain symmetry and position is EAST or CORNER, the point at i=isd will
2483  !--- come from two pe ( there will be only one point on one pe. ).
2484  if( domain%symmetry .AND. (position == EAST .OR. position == CORNER ) &
2485  .AND. (isd == ie .or. ied == is ) .AND. (.not. folded_north) ) then
2486  !--- do nothing, this point will come from other pe
2487  else
2488  js2 = -1; je2 = 0
2489  if( jsd .GT. jeg ) then ! jed > jeg
2490  if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2491  js = js+joff; je = je+joff
2492  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2493  else if( folded_north )then
2494  folded = .TRUE.
2495  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2496  end if
2497  else if( jed.GT.jeg )then ! split into two parts
2498  if( domain%y(tMe)%cyclic)then !try cyclic offset
2499  is2 = is; ie2 = ie; js2 = js; je2 = je
2500  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2501  js = js + joff; je = je + joff
2502  jsd = jeg+1
2503  else if( folded_north )then
2504  folded = .TRUE.
2505  is2 = is; ie2 = ie; js2 = js; je2 = je
2506  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2507  jsd = jeg+1
2508  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2509  end if
2510  end if
2511  if(x_cyclic_offset == 0 .and. y_cyclic_offset == 0) then
2512  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2513  .AND. (position == CORNER .OR. position == NORTH)) then
2514  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2515  isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2516  else
2517  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2518  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
2519  endif
2520  else
2521  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2522  isg, ieg, jsg, jeg, dir, symmetry=domain%symmetry)
2523  endif
2524  if(ie2 .GE. is2) then
2525  if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2526  .AND. (position == CORNER .OR. position == NORTH)) then
2527  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2528  isg, ieg, dir, ishift, position, ioff, middle, symmetry=domain%symmetry)
2529  else
2530  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2531  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded, symmetry=domain%symmetry)
2532  endif
2533  endif
2534  endif
2535 
2536  !--- when north edge is folded, ie will be less than isg when position is EAST and CORNER
2537  if(is .LT. isg .AND. domain%x(tMe)%cyclic) then
2538 ! is = is + ioff
2539 ! call insert_update_overlap( overlap, domain%list(m)%pe, &
2540 ! is, is, js, je, isd, ied, jsd, jed, dir, folded)
2541  endif
2542 
2543  !--- Now calculate the overlapping for fold-edge. Currently we only consider about folded-north
2544  !--- for folded-north-edge, only need to consider to_pe's north(7) direction
2545  !--- only position at NORTH and CORNER need to be considered
2546 
2547  if( folded_north .AND. (position == NORTH .OR. position == CORNER) &
2548  .AND. domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2) then
2549  if( jed .GE. jeg .AND. ied .GE. middle)then
2550  jsd = jeg; jed = jeg
2551  is=isc; ie=iec; js = jsc; je = jec
2552  isd = max(isd, middle)
2553  select case (position)
2554  case(NORTH)
2555  i=is; is = isg+ieg-ie; ie = isg+ieg-i
2556  case(CORNER)
2557  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
2558  end select
2559  call insert_update_overlap(overlap, domain%list(m)%pe, &
2560  is, ie, js, je, isd, ied, jsd, jed, dir, .true.)
2561  endif
2562  if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2563  jsd = domain%y(tMe)%compute%end+jshift; jed = jsd
2564  if(jed == jeg) then
2565  is = max(is, isd); ie = min(ie, ied)
2566  js = max(js, jsd); je = min(je, jed)
2567  if(ie.GE.is .AND. je.GE.js )then
2568  nrecv_check = nrecv_check+1
2569  if(nrecv_check > size(checkList(:)) ) then
2570  call expand_check_overlap_list(checkList, nlist)
2571  endif
2572  call allocate_check_overlap(checkList(nrecv_check), 1)
2573  call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
2574  tMe, 4, ONE_HUNDRED_EIGHTY, is, ie, js, je)
2575  end if
2576  end if
2577  endif
2578 
2579  endif
2580 
2581  !recv_ne
2582  dir = 8
2583  folded = .false.
2584  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%compute%end+ehalo+ishift
2585  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%compute%end+nhalo+jshift
2586  is=isc; ie=iec; js=jsc; je=jec
2587  is2 = 0; ie2=-1; js2=0; je2=-1
2588  is3 = 0; ie3 = -1; js3 = 0; je3 = -1
2589  if(x_cyclic_offset == 0 .AND. y_cyclic_offset == 0) then
2590  js2 = -1; je2 = 0
2591  if( jsd .GT. jeg ) then ! jed > jeg
2592  if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2593  js = js+joff; je = je+joff
2594  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2595  else if( folded_north )then
2596  folded = .TRUE.
2597  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2598  end if
2599  else if( jed.GT.jeg )then ! split into two parts
2600  if( domain%y(tMe)%cyclic)then !try cyclic offset
2601  is2 = is; ie2 = ie; js2 = js; je2 = je
2602  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2603  js = js + joff; je = je + joff
2604  jsd = jeg+1
2605  else if( folded_north )then
2606  folded = .TRUE.
2607  is2 = is; ie2 = ie; js2 = js; je2 = je
2608  isd2 = isd; ied2 = ied; jsd2 = jsd; jed2 = jeg
2609  jsd = jeg+1
2610  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2611  if(ied > ieg .and. isd .LE. ieg .and. domain%symmetry) then
2612  isd3 = ieg+1; ied3 = ied
2613  jsd3 = jsd; jed3 = jed
2614  is3 = is+ioff; ie3=ie+ioff
2615  js3 = js; je3 = je
2616  ied = ieg;
2617  endif
2618  end if
2619  endif
2620  if( jeg .GE. js .AND. jeg .LE. je .AND. jed == jeg .AND. folded_north &
2621  .AND. (position == CORNER .OR. position == NORTH)) then
2622  call fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2623  isg, ieg, dir, ishift, position, ioff, middle)
2624  else
2625  call fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2626  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2627  endif
2628  if(ie3 .GE. is3) call fill_overlap_recv_nofold(overlap, domain, m, is3, ie3, js3, je3, isd3, ied3, jsd3, jed3, &
2629  isg, ieg, dir, ioff, domain%x(tMe)%cyclic, folded)
2630  if(ie2 .GE. is2) then
2631  if(jeg .GE. js2 .AND. jeg .LE. je2 .AND. jed2 == jeg .AND. folded_north &
2632  .AND. (position == CORNER .OR. position == NORTH)) then
2633  call fill_overlap_recv_fold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2634  isg, ieg, dir, ishift, position, ioff, middle)
2635  else
2636  call fill_overlap_recv_nofold(overlap, domain, m, is2, ie2, js2, je2, isd2, ied2, jsd2, jed2, &
2637  isg, ieg, dir, ioff, domain%x(tMe)%cyclic)
2638  endif
2639  endif
2640  else
2641  need_adjust_1 = .true.; need_adjust_2 = .true.; need_adjust_3 = .true.
2642  if( jed.GT.jeg )then
2643  if( domain%y(tMe)%cyclic .AND. je.LT.jsd )then !try cyclic offset
2644  js = js+joff; je = je+joff
2645  need_adjust_1 = .false.
2646  if( ied.GT.ieg )then
2647  if( domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2648  is = is+ioff; ie = ie+ioff
2649  need_adjust_2 = .false.
2650  if(x_cyclic_offset .NE. 0) then
2651  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jegd, nj)
2652  else if(y_cyclic_offset .NE. 0) then
2653  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, iegd, ni)
2654  end if
2655  end if
2656  else
2657  call apply_cyclic_offset(is, ie, y_cyclic_offset, isg, ieg, ni)
2658  need_adjust_3 = .false.
2659  end if
2660  else if( folded_north )then
2661  folded = .TRUE.
2662  call get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
2663  end if
2664  end if
2665  if( need_adjust_3 .AND. ied.GT.ieg )then
2666  if( need_adjust_2 .AND. domain%x(tMe)%cyclic .AND. ie.LT.isd )then !try cyclic offset
2667  is = is+ioff; ie = ie+ioff
2668  if( need_adjust_1 .AND. jed.LE.jeg)then
2669  call apply_cyclic_offset(js, je, x_cyclic_offset, jsg, jeg, nj)
2670  end if
2671  end if
2672  end if
2673  call fill_overlap(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2674  isg, ieg, jsg, jeg, dir)
2675  endif
2676  endif
2677 
2678  !--- copy the overlapping information
2679  if( overlap%count > 0) then
2680  nrecv = nrecv + 1
2681  if(nrecv > size(overlapList(:)) )then
2682  call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps): overlapList for recv is expanded')
2683  call expand_update_overlap_list(overlapList, nlist)
2684  endif
2685  call add_update_overlap( overlapList(nrecv), overlap)
2686  call init_overlap_type(overlap)
2687  endif
2688  enddo ! end of recv do loop
2689 
2691  !--- write out send information
2692  unit = mpp_pe() + 1000
2693  do m =1,nrecv
2694  write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
2695  do n = 1, overlapList(m)%count
2696  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
2697  overlapList(m)%dir(n), overlapList(m)%rotation(n)
2698  enddo
2699  enddo
2700  if(nrecv >0) call flush(unit)
2701  endif
2702 
2703  ! copy the overlapping information into domain
2704  if(nrecv>0) then
2705  allocate(update%recv(nrecv))
2706  update%nrecv = nrecv
2707  do m = 1, nrecv
2708  call add_update_overlap( update%recv(m), overlapList(m) )
2709  do n = 1, update%recv(m)%count
2710  if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
2711  if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
2712  if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
2713  endif
2714  enddo
2715  enddo
2716  endif
2717 
2718  if(nrecv_check>0) then
2719  check%nrecv = nrecv_check
2720  allocate(check%recv(nrecv_check))
2721  do m = 1, nrecv_check
2722  call add_check_overlap( check%recv(m), checkList(m) )
2723  enddo
2724  endif
2725 
2726  call deallocate_overlap_type(overlap)
2727  do m = 1,size(overlapList(:))
2728  call deallocate_overlap_type(overlapList(m))
2729  enddo
2730 
2731  if(debug_update_level .NE. NO_CHECK .AND. set_check) then
2732  do m = 1,size(checkList(:))
2733  call deallocate_overlap_type(checkList(m))
2734  enddo
2735  endif
2736 
2737  deallocate(overlapList)
2738  if(set_check) deallocate(checkList)
2739  domain%initialized = .true.
2740 
2741  end subroutine compute_overlaps
2742 
2743 
2744  subroutine fill_overlap_send_nofold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2745  isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2746  type(overlap_type), intent(inout) :: overlap
2747  type(domain2d), intent(inout) :: domain
2748  integer, intent(in ) :: m, is, ie, js, je
2749  integer, intent(in ) :: isc, iec, jsc, jec
2750  integer, intent(in ) :: isg, ieg, dir, ioff
2751  logical, intent(in ) :: is_cyclic
2752  logical, optional, intent(in ) :: folded, symmetry
2753 
2754  call insert_update_overlap( overlap, domain%list(m)%pe, &
2755  is, ie, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2756  if(is_cyclic) then
2757  if(ie .GT. ieg) then
2758  call insert_update_overlap( overlap, domain%list(m)%pe, &
2759  is-ioff, ie-ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2760  else if( is .LT. isg ) then
2761  call insert_update_overlap( overlap, domain%list(m)%pe, &
2762  is+ioff, ie+ioff, js, je, isc, iec, jsc, jec, dir, reverse=folded, symmetry=symmetry)
2763  endif
2764  endif
2765 
2766  end subroutine fill_overlap_send_nofold
2767  !##################################################################################
2768  subroutine fill_overlap_send_fold(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2769  isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2770  type(overlap_type), intent(inout) :: overlap
2771  type(domain2d), intent(inout) :: domain
2772  integer, intent(in ) :: m, is, ie, js, je
2773  integer, intent(in ) :: isc, iec, jsc, jec
2774  integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2775  logical, optional, intent(in ) :: symmetry
2776  integer :: is1, ie1, is2, ie2, i
2777 
2778  !--- consider at j = jeg for west edge.
2779  !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2780  if(position == CORNER .AND. .NOT. domain%symmetry .AND. is .LE. isg-1 .AND. ie .GE. isg-1) then
2781  call insert_update_overlap(overlap, domain%list(m)%pe, &
2782  isg-1+ioff, isg-1+ioff, je, je, isc, iec, jsc, jec, dir, .true.)
2783  end if
2784 
2785  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2786  !--- east edge
2787  if( is > ieg ) then
2788  is2 = is-ioff; ie2 = ie-ioff
2789  else if( ie > ieg ) then ! split into two parts
2790  is1 = is; ie1 = ieg
2791  is2 = ieg+1-ioff; ie2 = ie-ioff
2792  else if( is .GE. middle ) then
2793  is1 = is; ie1 = ie
2794  else if( ie .GE. middle ) then ! split into two parts
2795  is1 = middle; ie1 = ie
2796  is2 = is; ie2 = middle-1
2797  else if( ie < isg ) then ! west boundary
2798  is1 = is+ieg-isg+1-ishift; ie1 = ie+ieg-isg+1-ishift
2799  else if( is < isg ) then ! split into two parts
2800  is1 = is+ieg-isg+1-ishift; ie1 = isg-1+ieg-isg+1-ishift
2801  is2 = isg; ie2 = ie
2802  else
2803  is2 = is; ie2 = ie
2804  endif
2805 
2806  if( ie1 .GE. is1) then
2807  call insert_update_overlap( overlap, domain%list(m)%pe, &
2808  is1, ie1, js, je-1, isc, iec, jsc, jec, dir, symmetry=symmetry)
2809 
2810  select case (position)
2811  case(NORTH)
2812  i=is1; is1 = isg+ieg-ie1; ie1 = isg+ieg-i
2813  case(CORNER)
2814  i=is1; is1 = isg+ieg-ie1-1+ishift; ie1 = isg+ieg-i-1+ishift
2815  end select
2816  call insert_update_overlap( overlap, domain%list(m)%pe, &
2817  is1, ie1, je, je, isc, iec, jsc, jec, dir, .true., symmetry=symmetry)
2818  endif
2819 
2820  if(ie2 .GE. is2) then
2821  call insert_update_overlap( overlap, domain%list(m)%pe, &
2822  is2, ie2, js, je, isc, iec, jsc, jec, dir)
2823  endif
2824 
2825  end subroutine fill_overlap_send_fold
2826 
2827 
2828  !#############################################################################
2829  subroutine fill_overlap_recv_nofold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2830  isg, ieg, dir, ioff, is_cyclic, folded, symmetry)
2831  type(overlap_type), intent(inout) :: overlap
2832  type(domain2d), intent(inout) :: domain
2833  integer, intent(in ) :: m, is, ie, js, je
2834  integer, intent(in ) :: isd, ied, jsd, jed
2835  integer, intent(in ) :: isg, ieg, dir, ioff
2836  logical, intent(in ) :: is_cyclic
2837  logical, optional, intent(in ) :: folded, symmetry
2838  integer :: is1, ie1, is2, ie2
2839  integer :: isd1, ied1, isd2, ied2
2840 
2841  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2842  isd1=isd; ied1=ied
2843  isd2=isd; ied2=ied
2844 
2845  call insert_update_overlap( overlap, domain%list(m)%pe, &
2846  is, ie, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2847  if(is_cyclic) then
2848  if(ied .GT. ieg) then
2849  call insert_update_overlap( overlap, domain%list(m)%pe, &
2850  is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2851  else if( isd .LT. isg ) then
2852  call insert_update_overlap( overlap, domain%list(m)%pe, &
2853  is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2854  else if ( is .LT. isg ) then
2855  call insert_update_overlap( overlap, domain%list(m)%pe, &
2856  is+ioff, ie+ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2857  else if ( ie .GT. ieg ) then
2858  call insert_update_overlap( overlap, domain%list(m)%pe, &
2859  is-ioff, ie-ioff, js, je, isd, ied, jsd, jed, dir, reverse=folded, symmetry=symmetry)
2860  endif
2861  endif
2862 
2863  end subroutine fill_overlap_recv_nofold
2864  !#################################################################################
2865  subroutine fill_overlap_recv_fold(overlap, domain, m, is, ie, js, je, isd, ied, jsd, jed, &
2866  isg, ieg, dir, ishift, position, ioff, middle, symmetry)
2867  type(overlap_type), intent(inout) :: overlap
2868  type(domain2d), intent(inout) :: domain
2869  integer, intent(in ) :: m, is, ie, js, je
2870  integer, intent(in ) :: isd, ied, jsd, jed
2871  integer, intent(in ) :: isg, ieg, dir, ishift, position, ioff, middle
2872  logical, optional, intent(in ) :: symmetry
2873  integer :: is1, ie1, is2, ie2, is3, ie3
2874  integer :: isd1, ied1, isd2, ied2
2875 
2876  !--- consider at j = jeg for west edge.
2877  !--- when the data is at corner and not symmetry, i = isg -1 will get from cyclic condition
2878  if( position == CORNER .AND. .NOT. domain%symmetry .AND. isd .LE. isg-1 .AND. ied .GE. isg-1 ) then
2879  call insert_update_overlap( overlap, domain%list(m)%pe, &
2880  is-ioff, ie-ioff, js, je, isg-1, isg-1, jed, jed, dir, .true.)
2881  end if
2882 
2883  is1 = 0; ie1 = -1; is2 = 0; ie2 = -1
2884  isd1=isd; ied1=ied
2885  isd2=isd; ied2=ied
2886  select case (position)
2887  case(NORTH)
2888  is3 = isg+ieg-ie; ie3 = isg+ieg-is
2889  case(CORNER)
2890  is3 = isg+ieg-ie-1+ishift; ie3 = isg+ieg-is-1+ishift
2891  end select
2892 
2893  if(isd .GT. ieg) then ! east
2894  is2 = is + ioff; ie2 = ie + ioff;
2895  else if(ied .GT. ieg) then ! split into two parts
2896  is1 = is; ie1 = ie;
2897  isd1 = isd; ied1 = ieg;
2898  is2 = is + ioff; ie2 = ie + ioff
2899  isd2 = ieg + 1; ied2 = ied
2900  else if(isd .GE. middle) then
2901  is1 = is; ie1 = ie
2902  else if(ied .GE. middle) then ! split into two parts
2903  is1 = is; ie1 = ie
2904  isd1 = middle; ied1 = ied
2905  is2 = is; ie2 = ie
2906  isd2 = isd; ied2 = middle-1
2907  else if(ied .LT. isg) then
2908  is1 = is - ioff; ie1 = ie - ioff;
2909  is3 = is3 - ioff; ie3 = ie3 - ioff;
2910  else if(isd .LT. isg) then ! split into two parts
2911  is1 = is - ioff; ie1 = ie - ioff;
2912  is3 = is3 - ioff; ie3 = ie3 - ioff;
2913  isd1 = isd; ied1 = isg-1
2914  is2 = is; ie2 = ie
2915  isd2 = isg; ied2 = ied
2916  else
2917  is2 = is ; ie2 =ie
2918  isd2 = isd; ied2 = ied
2919  endif
2920 
2921  if( ie1 .GE. is1) then
2922  call insert_update_overlap( overlap, domain%list(m)%pe, &
2923  is1, ie1, js, je, isd1, ied1, jsd, jed-1, dir, symmetry=symmetry)
2924 
2925  call insert_update_overlap( overlap, domain%list(m)%pe, &
2926  is3, ie3, js, je, isd1, ied1, jed, jed, dir, .true., symmetry=symmetry)
2927  endif
2928 
2929  if(ie2 .GE. is2) then
2930  call insert_update_overlap( overlap, domain%list(m)%pe, &
2931  is2, ie2, js, je, isd2, ied2, jsd, jed, dir)
2932  endif
2933 
2934  end subroutine fill_overlap_recv_fold
2935 
2936 !#####################################################################################
2937  subroutine fill_overlap(overlap, domain, m, is, ie, js, je, isc, iec, jsc, jec, &
2938  isg, ieg, jsg, jeg, dir, reverse, symmetry)
2939  type(overlap_type), intent(inout) :: overlap
2940  type(domain2d), intent(inout) :: domain
2941  integer, intent(in ) :: m, is, ie, js, je
2942  integer, intent(in ) :: isc, iec, jsc, jec
2943  integer, intent(in ) :: isg, ieg, jsg, jeg
2944  integer, intent(in ) :: dir
2945  logical, optional, intent(in ) :: reverse, symmetry
2946 
2947  if(js > je) then ! seperate into two regions due to x_cyclic_offset is nonzero, the two region are
2948  ! (js, jeg) and (jsg, je).
2949  call insert_update_overlap( overlap, domain%list(m)%pe, &
2950  is, ie, jsg, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2951  call insert_update_overlap( overlap, domain%list(m)%pe, &
2952  is, ie, js, jeg, isc, iec, jsc, jec, dir, reverse, symmetry)
2953  else if(is > ie) then ! seperate into two regions due to y_cyclic_offset is nonzero, the two region are
2954  ! (is, ieg) and (isg, ie).
2955  call insert_update_overlap( overlap, domain%list(m)%pe, &
2956  is, ieg, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2957  call insert_update_overlap( overlap, domain%list(m)%pe, &
2958  isg, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2959  else
2960  call insert_update_overlap( overlap, domain%list(m)%pe, &
2961  is, ie, js, je, isc, iec, jsc, jec, dir, reverse, symmetry)
2962  end if
2963 
2964 
2965  end subroutine fill_overlap
2966 
2967  !####################################################################################
2968  subroutine compute_overlaps_fold_south( domain, position, ishift, jshift)
2969  !computes remote domain overlaps
2970  !assumes only one in each direction
2971  !will calculate the overlapping for T,E,C,N-cell seperately.
2972  type(domain2D), intent(inout) :: domain
2973  integer, intent(in) :: position, ishift, jshift
2974 
2975  integer :: i, m, n, nlist, tMe, tNbr, dir
2976  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
2977  integer :: isg, ieg, jsg, jeg, ioff, joff
2978  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
2979  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
2980  logical :: folded
2981  type(overlap_type) :: overlap
2982  type(overlapSpec), pointer :: update=>NULL()
2983  type(overlap_type), pointer :: overlapList(:)=>NULL()
2984  type(overlap_type), pointer :: checkList(:)=>NULL()
2985  type(overlapSpec), pointer :: check =>NULL()
2986  integer :: nsend, nrecv
2987  integer :: nsend_check, nrecv_check
2988  integer :: unit
2989 
2990  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
2991  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
2992  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
2993  if(size(domain%x(:)) > 1) return
2994 
2995  !--- if there is no halo, no need to compute overlaps.
2996  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
2997 
2998  !--- when there is only one tile, n will equal to np
2999  nlist = size(domain%list(:))
3000 
3001  select case(position)
3002  case (CENTER)
3003  update => domain%update_T
3004  check => NULL()
3005  case (CORNER)
3006  update => domain%update_C
3007  check => domain%check_C
3008  case (EAST)
3009  update => domain%update_E
3010  check => domain%check_E
3011  case (NORTH)
3012  update => domain%update_N
3013  check => domain%check_N
3014  case default
3015  call mpp_error(FATAL, &
3016  "mpp_domains_define.inc(compute_overlaps_fold_south): the value of position should be CENTER, EAST, CORNER or NORTH")
3017  end select
3018 
3019  allocate(overlapList(MAXLIST) )
3020  allocate(checkList(MAXLIST) )
3021 
3022  !--- overlap is used to store the overlapping temporarily.
3023  call allocate_update_overlap( overlap, MAXOVERLAP)
3024 
3025  !send
3026  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3027  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
3028  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3029  update%xbegin = ism; update%xend = iem
3030  update%ybegin = jsm; update%yend = jem
3031  if(ASSOCIATED(check)) then
3032  check%xbegin = ism; check%xend = iem
3033  check%ybegin = jsm; check%yend = jem
3034  endif
3035  update%whalo = domain%whalo; update%ehalo = domain%ehalo
3036  update%shalo = domain%shalo; update%nhalo = domain%nhalo
3037  whalo = domain%whalo; ehalo = domain%ehalo
3038  shalo = domain%shalo; nhalo = domain%nhalo
3039 
3040 
3041  ioff = ni - ishift
3042  joff = nj - jshift
3043  middle = (isg+ieg)/2+1
3044  tMe = 1; tNbr = 1
3045 
3046  if(.NOT. BTEST(domain%fold,SOUTH)) then
3047  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3048  "boundary condition in y-direction should be folded-south for "//trim(domain%name))
3049  endif
3050  if(.NOT. domain%x(tMe)%cyclic) then
3051  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3052  "boundary condition in x-direction should be cyclic for "//trim(domain%name))
3053  endif
3054 
3055  if(.not. domain%symmetry) then
3056  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_south): "//&
3057  "when south boundary is folded, the domain must be symmetry for "//trim(domain%name))
3058  endif
3059 
3060  nsend = 0
3061  nsend_check = 0
3062  do list = 0,nlist-1
3063  m = mod( domain%pos+list, nlist )
3064  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
3065  !to_pe's eastern halo
3066  dir = 1
3067  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3068  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3069  !--- to make sure the consistence between pes
3070  if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3071  !--- do nothing, this point will come from other pe
3072  else
3073  if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3074  is = is-ioff; ie = ie-ioff
3075  end if
3076  !--- when the south face is folded, the east halo point at right side domain will be folded.
3077  !--- the position should be on CORNER or NORTH
3078  if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
3079  .AND. is .GE. middle .AND. domain%list(m)%x(tNbr)%compute%end+ehalo+jshift .LE. ieg ) then
3080  call insert_update_overlap( overlap, domain%list(m)%pe, &
3081  is, ie, js+1, je, isc, iec, jsc, jec, dir)
3082  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3083  je = js
3084  select case (position)
3085  case(NORTH)
3086  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3087  case(CORNER)
3088  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3089  end select
3090  call insert_update_overlap( overlap, domain%list(m)%pe, &
3091  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3092  else
3093  call insert_update_overlap( overlap, domain%list(m)%pe, &
3094  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3095  end if
3096  end if
3097 
3098  !to_pe's SE halo
3099  dir = 2
3100  folded = .false.
3101  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3102  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3103  if( ie.GT.ieg .AND. iec.LT.is )then ! cyclic is assumed
3104  is = is-ioff; ie = ie-ioff
3105  end if
3106  if( js.LT.jsg )then
3107  folded = .TRUE.
3108  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3109  end if
3110 
3111  call insert_update_overlap( overlap, domain%list(m)%pe, &
3112  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3113 
3114  !to_pe's southern halo
3115  dir = 3
3116  folded = .FALSE.
3117  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3118  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3119  folded = .FALSE.
3120  if( js.LT.jsg )then
3121  folded = .TRUE.
3122  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3123  end if
3124  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3125  !--- no need to send, because the data on that point will come from other pe.
3126  !--- come from two pe ( there will be only one point on one pe. ).
3127  if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3128  !--- do nothing, this point will come from other pe
3129  else
3130  call insert_update_overlap( overlap, domain%list(m)%pe, &
3131  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3132  endif
3133  !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3134  if(is .LT. isg) then
3135  is = is + ioff
3136  call insert_update_overlap( overlap, domain%list(m)%pe, &
3137  is, is, js, je, isc, iec, jsc, jec, dir, folded)
3138  endif
3139 
3140  !to_pe's SW halo
3141  dir = 4
3142  folded = .false.
3143  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3144  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3145  if( isg.GT.is .AND. ie.LT.isc )then !cyclic offset
3146  is = is+ioff; ie = ie+ioff
3147  end if
3148  if( js.LT.jsg )then
3149  folded = .TRUE.
3150  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3151  end if
3152  call insert_update_overlap( overlap, domain%list(m)%pe, &
3153  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3154  !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3155  if(is .LT. isg) then
3156  is = is + ioff
3157  call insert_update_overlap( overlap, domain%list(m)%pe, &
3158  is, is, js, je, isc, iec, jsc, jec, dir, folded)
3159  endif
3160 
3161  !to_pe's western halo
3162  dir = 5
3163  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3164  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3165 
3166  !--- to make sure the consistence between pes
3167  if( (position == NORTH .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3168  !--- do nothing, this point will come from other pe
3169  else
3170  if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
3171  is = is+ioff; ie = ie+ioff
3172  end if
3173  !--- when the south face is folded, some point at j=nj will be folded.
3174  !--- the position should be on CORNER or NORTH
3175  if( js == jsg .AND. (position == CORNER .OR. position == NORTH) &
3176  .AND. ( domain%list(m)%x(tNbr)%compute%begin == isg .OR. domain%list(m)%x(tNbr)%compute%begin-1 .GE. middle)) then
3177  call insert_update_overlap( overlap, domain%list(m)%pe, &
3178  is, ie, js+1, je, isc, iec, jsc, jec, dir)
3179  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3180  js = domain%list(m)%y(tNbr)%compute%begin; je = js
3181  if ( domain%list(m)%x(tNbr)%compute%begin == isg ) then
3182  select case (position)
3183  case(NORTH)
3184  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3185  case(CORNER)
3186  i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3187  end select
3188  if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
3189  'mpp_domains_define.inc(compute_overlaps_fold_south): west edge ubound error send.' )
3190  else
3191  select case (position)
3192  case(NORTH)
3193  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3194  case(CORNER)
3195  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3196  end select
3197  end if
3198  call insert_update_overlap( overlap, domain%list(m)%pe, &
3199  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3200  else
3201  call insert_update_overlap( overlap, domain%list(m)%pe, &
3202  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3203  end if
3204  endif
3205 
3206  !to_pe's NW halo
3207  dir = 6
3208  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3209  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3210  if( isg.GT.is .AND. ie.LT.isc )then ! cyclic offset
3211  is = is+ioff; ie = ie+ioff
3212  end if
3213  call insert_update_overlap( overlap, domain%list(m)%pe, &
3214  is, ie, js, je, isc, iec, jsc, jec, dir)
3215 
3216  !to_pe's northern halo
3217  dir = 7
3218  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3219  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3220  call insert_update_overlap( overlap, domain%list(m)%pe, &
3221  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3222 
3223  !to_pe's NE halo
3224  dir = 8
3225  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3226  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3227  if( ie.GT.ieg .AND. iec.LT.is )then !cyclic offset
3228  is = is-ioff; ie = ie-ioff
3229  end if
3230  call insert_update_overlap( overlap, domain%list(m)%pe, &
3231  is, ie, js, je, isc, iec, jsc, jec, dir)
3232 
3233  !--- Now calculate the overlapping for fold-edge.
3234  !--- only position at NORTH and CORNER need to be considered
3235  if( ( position == NORTH .OR. position == CORNER) ) then
3236  if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold is within domain
3237  dir = 3
3238  !--- calculate the overlapping for sending
3239  if( domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 )then
3240  js = domain%list(m)%y(tNbr)%compute%begin; je = js
3241  if( js == jsg )then ! fold is within domain.
3242  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3243  select case (position)
3244  case(NORTH)
3245  is = max(is, middle)
3246  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3247  case(CORNER)
3248  is = max(is, middle)
3249  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3250  end select
3251  call insert_update_overlap(overlap, domain%list(m)%pe, &
3252  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3253  is = max(is, isc); ie = min(ie, iec)
3254  js = max(js, jsc); je = min(je, jec)
3255  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3256  nsend_check = nsend_check+1
3257  call allocate_check_overlap(checkList(nsend_check), 1)
3258  call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
3259  tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3260  end if
3261  end if
3262  end if
3263  end if
3264  end if
3265  end if
3266  !--- copy the overlapping information
3267  if( overlap%count > 0) then
3268  nsend = nsend + 1
3269  if(nsend > size(overlapList(:)) ) then
3270  call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for send is expanded')
3271  call expand_update_overlap_list(overlapList, nlist)
3272  endif
3273  call add_update_overlap(overlapList(nsend), overlap)
3274  call init_overlap_type(overlap)
3275  endif
3276  end do ! end of send set up.
3277 
3279  !--- write out send information
3280  unit = mpp_pe() + 1000
3281  do m =1,nsend
3282  write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3283  do n = 1, overlapList(m)%count
3284  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3285  overlapList(m)%dir(n), overlapList(m)%rotation(n)
3286  enddo
3287  enddo
3288  if( nsend > 0) call flush(unit)
3289  endif
3290 
3291  ! copy the overlapping information into domain data structure
3292  if(nsend>0) then
3293  allocate(update%send(nsend))
3294  update%nsend = nsend
3295  do m = 1, nsend
3296  call add_update_overlap( update%send(m), overlapList(m) )
3297  enddo
3298  endif
3299 
3300  if(nsend_check>0) then
3301  allocate(check%send(nsend_check))
3302  check%nsend = nsend_check
3303  do m = 1, nsend_check
3304  call add_check_overlap( check%send(m), checkList(m) )
3305  enddo
3306  endif
3307 
3308  do m = 1,size(overlapList(:))
3309  call deallocate_overlap_type(overlapList(m))
3310  enddo
3311 
3312  if(debug_update_level .NE. NO_CHECK) then
3313  do m = 1,size(checkList(:))
3314  call deallocate_overlap_type(checkList(m))
3315  enddo
3316  endif
3317 
3318  isgd = isg - domain%whalo
3319  iegd = ieg + domain%ehalo
3320  jsgd = jsg - domain%shalo
3321  jegd = jeg + domain%nhalo
3322 
3323  ! begin setting up recv
3324  nrecv = 0
3325  nrecv_check = 0
3326  do list = 0,nlist-1
3327  m = mod( domain%pos+nlist-list, nlist )
3328  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
3329  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3330  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3331  !recv_e
3332  dir = 1
3333  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3334  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3335  is=isc; ie=iec; js=jsc; je=jec
3336  if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
3337  ! --- do nothing, this point will come from other pe
3338  else
3339  if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3340  is = is+ioff; ie = ie+ioff
3341  end if
3342 
3343  !--- when the south face is folded, the east halo point at right side domain will be folded.
3344  !--- the position should be on CORNER or NORTH
3345  if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
3346  .AND. isd .GE. middle .AND. ied .LE. ieg ) then
3347  call insert_update_overlap( overlap, domain%list(m)%pe, &
3348  is, ie, js, je, isd, ied, jsd+1, jed, dir)
3349  is=isc; ie=iec; js=jsc; je=jec
3350  jed = jsd
3351  select case (position)
3352  case(NORTH)
3353  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3354  case(CORNER)
3355  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3356  end select
3357  call insert_update_overlap( overlap, domain%list(m)%pe, &
3358  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
3359  else
3360  call insert_update_overlap( overlap, domain%list(m)%pe, &
3361  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3362  end if
3363  end if
3364 
3365  !recv_se
3366  dir = 2
3367  folded = .false.
3368  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3369  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3370  is=isc; ie=iec; js=jsc; je=jec
3371  if( jsd.LT.jsg )then
3372  folded = .true.
3373  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3374  end if
3375  if( ied.GT.ieg .AND. ie.LT.isd )then !cyclic offset
3376  is = is+ioff; ie = ie+ioff
3377  endif
3378  call insert_update_overlap(overlap, domain%list(m)%pe, &
3379  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3380 
3381  !recv_s
3382  dir = 3
3383  folded = .false.
3384  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3385  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3386  is=isc; ie=iec; js=jsc; je=jec
3387  if( jsd.LT.jsg )then
3388  folded = .true.
3389  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3390  end if
3391  if( (position == EAST .OR. position == CORNER ) .AND. (isd == ie .or. ied == is ) ) then
3392  !--- do nothing, this point will come from other pe
3393  else
3394  call insert_update_overlap(overlap, domain%list(m)%pe, &
3395  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
3396  end if
3397  !--- when south edge is folded, is will be less than isg when position is EAST and CORNER
3398  if(is .LT. isg ) then
3399  is = is + ioff
3400  call insert_update_overlap(overlap, domain%list(m)%pe, &
3401  is, is, js, je, isd, ied, jsd, jed, dir, folded)
3402  endif
3403 
3404  !recv_sw
3405  dir = 4
3406  folded = .false.
3407  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
3408  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3409  is=isc; ie=iec; js=jsc; je=jec
3410  if( jsd.LT.jsg )then
3411  folded = .true.
3412  call get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
3413  end if
3414  if( isd.LT.isg .AND. is.GT.ied ) then ! cyclic offset
3415  is = is-ioff; ie = ie-ioff
3416  end if
3417  call insert_update_overlap(overlap, domain%list(m)%pe, &
3418  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
3419  !--- when southth edge is folded, is will be less than isg when position is EAST and CORNER
3420  if(is .LT. isg ) then
3421  is = is + ioff
3422  call insert_update_overlap(overlap, domain%list(m)%pe, &
3423  is, is, js, je, isd, ied, jsd, jed, dir, folded )
3424  endif
3425 
3426  !recv_w
3427  dir = 5
3428  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
3429  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3430  is=isc; ie=iec; js=jsc; je=jec
3431  if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then
3432  ! --- do nothing, this point will come from other pe
3433  else
3434  if( isd.LT.isg .AND. is.GT.ied )then ! cyclic offset
3435  is = is-ioff; ie = ie-ioff
3436  end if
3437  !--- when the south face is folded, some point at j=nj will be folded.
3438  !--- the position should be on CORNER or NORTH
3439  if( jsd == jsg .AND. (position == CORNER .OR. position == NORTH) &
3440  .AND. ( isd < isg .OR. ied .GE. middle ) ) then
3441  call insert_update_overlap(overlap, domain%list(m)%pe, &
3442  is, ie, js, je, isd, ied, jsd+1, jed, dir)
3443  is=isc; ie=iec; js=jsc; je=jec
3444  if(isd < isg) then
3445  select case (position)
3446  case(NORTH)
3447  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
3448  case(CORNER)
3449  ied = ied -1 + ishift
3450  i=is; is = 2*isg-ie-2+2*ishift; ie = 2*isg-i-2+2*ishift
3451  end select
3452  if(ie .GT. domain%x(tMe)%compute%end+ishift) call mpp_error( FATAL, &
3453  'mpp_domains_define.inc(compute_overlaps): west edge ubound error recv.' )
3454  else
3455  select case (position)
3456  case(NORTH)
3457  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3458  case(CORNER)
3459  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3460  end select
3461  end if
3462  call insert_update_overlap(overlap, domain%list(m)%pe, &
3463  is, ie, js, je, isd, ied, jsd, jsd, dir, .TRUE.)
3464  else
3465  call insert_update_overlap(overlap, domain%list(m)%pe, &
3466  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3467  end if
3468  endif
3469 
3470  !recv_nw
3471  dir = 6
3472  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
3473  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3474  is=isc; ie=iec; js=jsc; je=jec
3475  if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset
3476  is = is-ioff; ie = ie-ioff
3477  endif
3478 
3479  call insert_update_overlap( overlap, domain%list(m)%pe, &
3480  is, ie, js, je, isd, ied, jsd, jed, dir)
3481 
3482  !recv_n
3483  dir = 7
3484  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3485  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3486  is=isc; ie=iec; js=jsc; je=jec
3487  call insert_update_overlap( overlap, domain%list(m)%pe, &
3488  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3489 
3490  !recv_ne
3491  dir = 8
3492  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3493  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
3494  is=isc; ie=iec; js=jsc; je=jec
3495  if( ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset
3496  is = is+ioff; ie = ie+ioff
3497  end if
3498  call insert_update_overlap( overlap, domain%list(m)%pe, &
3499  is, ie, js, je, isd, ied, jsd, jed, dir)
3500 
3501  !--- Now calculate the overlapping for fold-edge.
3502  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
3503  !--- only position at NORTH and CORNER need to be considered
3504  if( ( position == NORTH .OR. position == CORNER) ) then
3505  if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold is within domain
3506  dir = 3
3507  !--- calculating overlapping for receving on north
3508  if( domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2 )then
3509  jsd = domain%y(tMe)%compute%begin; jed = jsd
3510  if( jsd == jsg )then ! fold is within domain.
3511  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3512  is=isc; ie=iec; js = jsc; je = jec
3513  select case (position)
3514  case(NORTH)
3515  isd = max(isd, middle)
3516  i=is; is = isg+ieg-ie; ie = isg+ieg-i
3517  case(CORNER)
3518  isd = max(isd, middle)
3519  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
3520  end select
3521  call insert_update_overlap(overlap, domain%list(m)%pe, &
3522  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
3523  is = max(is, isd); ie = min(ie, ied)
3524  js = max(js, jsd); je = min(je, jed)
3525  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3526  nrecv_check = nrecv_check+1
3527  call allocate_check_overlap(checkList(nrecv_check), 1)
3528  call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
3529  tMe, 2, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3530  endif
3531  endif
3532  endif
3533  endif
3534  endif
3535  endif
3536  !--- copy the overlapping information
3537  if( overlap%count > 0) then
3538  nrecv = nrecv + 1
3539  if(nrecv > size(overlapList(:)) )then
3540  call mpp_error(NOTE, 'mpp_domains_define.inc(compute_overlaps_south): overlapList for recv is expanded')
3541  call expand_update_overlap_list(overlapList, nlist)
3542  endif
3543  call add_update_overlap( overlapList(nrecv), overlap)
3544  call init_overlap_type(overlap)
3545  endif
3546  enddo ! end of recv do loop
3547 
3549  !--- write out send information
3550  unit = mpp_pe() + 1000
3551  do m =1,nrecv
3552  write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3553  do n = 1, overlapList(m)%count
3554  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3555  overlapList(m)%dir(n), overlapList(m)%rotation(n)
3556  enddo
3557  enddo
3558  if(nrecv >0) call flush(unit)
3559  endif
3560 
3561  ! copy the overlapping information into domain
3562  if(nrecv>0) then
3563  update%nrecv = nrecv
3564  allocate(update%recv(nrecv))
3565  do m = 1, nrecv
3566  call add_update_overlap( update%recv(m), overlapList(m) )
3567  do n = 1, update%recv(m)%count
3568  if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
3569  if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
3570  if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
3571  endif
3572  enddo
3573  enddo
3574  endif
3575 
3576  if(nrecv_check>0) then
3577  check%nrecv = nrecv_check
3578  allocate(check%recv(nrecv_check))
3579  do m = 1, nrecv_check
3580  call add_check_overlap( check%recv(m), checkList(m) )
3581  enddo
3582  endif
3583 
3584  call deallocate_overlap_type(overlap)
3585 
3586  do m = 1,size(overlapList(:))
3587  call deallocate_overlap_type(overlapList(m))
3588  enddo
3589 
3590  if(debug_update_level .NE. NO_CHECK) then
3591  do m = 1,size(checkList(:))
3592  call deallocate_overlap_type(checkList(m))
3593  enddo
3594  endif
3595 
3596  deallocate(overlapList)
3597  deallocate(checkList)
3598  update => NULL()
3599  check=>NULL()
3600  domain%initialized = .true.
3601 
3602  end subroutine compute_overlaps_fold_south
3603 
3604  !####################################################################################
3605  subroutine compute_overlaps_fold_west( domain, position, ishift, jshift)
3606  !computes remote domain overlaps
3607  !assumes only one in each direction
3608  !will calculate the overlapping for T,E,C,N-cell seperately.
3609  type(domain2D), intent(inout) :: domain
3610  integer, intent(in) :: position, ishift, jshift
3611 
3612  integer :: j, m, n, nlist, tMe, tNbr, dir
3613  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd, jed
3614  integer :: isg, ieg, jsg, jeg, ioff, joff
3615  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
3616  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
3617  logical :: folded
3618  type(overlap_type) :: overlap
3619  type(overlapSpec), pointer :: update=>NULL()
3620  type(overlap_type) :: overlapList(MAXLIST)
3621  type(overlap_type) :: checkList(MAXLIST)
3622  type(overlapSpec), pointer :: check =>NULL()
3623  integer :: nsend, nrecv
3624  integer :: nsend_check, nrecv_check
3625  integer :: unit
3626 
3627  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
3628  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
3629  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
3630  if(size(domain%x(:)) > 1) return
3631 
3632  !--- if there is no halo, no need to compute overlaps.
3633  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
3634 
3635  !--- when there is only one tile, n will equal to np
3636  nlist = size(domain%list(:))
3637 
3638  select case(position)
3639  case (CENTER)
3640  update => domain%update_T
3641  check => NULL()
3642  case (CORNER)
3643  update => domain%update_C
3644  check => domain%check_C
3645  case (EAST)
3646  update => domain%update_E
3647  check => domain%check_E
3648  case (NORTH)
3649  update => domain%update_N
3650  check => domain%check_N
3651  case default
3652  call mpp_error(FATAL, &
3653  "mpp_domains_define.inc(compute_overlaps_fold_west): the value of position should be CENTER, EAST, CORNER or NORTH")
3654  end select
3655 
3656  !--- overlap is used to store the overlapping temporarily.
3657  call allocate_update_overlap( overlap, MAXOVERLAP)
3658 
3659  !send
3660  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
3661  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
3662  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
3663  update%xbegin = ism; update%xend = iem
3664  update%ybegin = jsm; update%yend = jem
3665  if(ASSOCIATED(check)) then
3666  check%xbegin = ism; check%xend = iem
3667  check%ybegin = jsm; check%yend = jem
3668  endif
3669  update%whalo = domain%whalo; update%ehalo = domain%ehalo
3670  update%shalo = domain%shalo; update%nhalo = domain%nhalo
3671  whalo = domain%whalo; ehalo = domain%ehalo
3672  shalo = domain%shalo; nhalo = domain%nhalo
3673 
3674  ioff = ni - ishift
3675  joff = nj - jshift
3676  middle = (jsg+jeg)/2+1
3677  tMe = 1; tNbr = 1
3678 
3679  if(.NOT. BTEST(domain%fold,WEST)) then
3680  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3681  "boundary condition in y-direction should be folded-west for "//trim(domain%name))
3682  endif
3683  if(.NOT. domain%y(tMe)%cyclic) then
3684  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3685  "boundary condition in y-direction should be cyclic for "//trim(domain%name))
3686  endif
3687 
3688  if(.not. domain%symmetry) then
3689  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_west): "//&
3690  "when west boundary is folded, the domain must be symmetry for "//trim(domain%name))
3691  endif
3692 
3693  nsend = 0
3694  nsend_check = 0
3695  do list = 0,nlist-1
3696  m = mod( domain%pos+list, nlist )
3697  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
3698  !to_pe's eastern halo
3699  dir = 1
3700  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3701  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3702  call insert_update_overlap( overlap, domain%list(m)%pe, &
3703  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3704 
3705  !to_pe's SE halo
3706  dir = 2
3707  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
3708  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3709  if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
3710  js = js+joff; je = je+joff
3711  end if
3712 
3713  call insert_update_overlap( overlap, domain%list(m)%pe, &
3714  is, ie, js, je, isc, iec, jsc, jec, dir)
3715 
3716  !to_pe's southern halo
3717  dir = 3
3718  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3719  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3720  !--- to make sure the consistence between pes
3721  if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3722  !--- do nothing, this point will come from other pe
3723  else
3724  if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
3725  js = js+joff; je = je+joff
3726  endif
3727 
3728  !--- when the west face is folded, the south halo points at
3729  !--- the position should be on CORNER or EAST
3730  if( is == isg .AND. (position == CORNER .OR. position == EAST) &
3731  .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle)) then
3732  call insert_update_overlap( overlap, domain%list(m)%pe, &
3733  is+1, ie, js, je, isc, iec, jsc, jec, dir)
3734  is = domain%list(m)%x(tNbr)%compute%begin; ie = is
3735  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3736  if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
3737  select case (position)
3738  case(EAST)
3739  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
3740  case(CORNER)
3741  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
3742  end select
3743  if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
3744  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error send.' )
3745  else
3746  select case (position)
3747  case(EAST)
3748  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3749  case(CORNER)
3750  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3751  end select
3752  end if
3753  call insert_update_overlap( overlap, domain%list(m)%pe, &
3754  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3755  else
3756  call insert_update_overlap( overlap, domain%list(m)%pe, &
3757  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3758  end if
3759  endif
3760 
3761  !to_pe's SW halo
3762  dir = 4
3763  folded = .false.
3764  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3765  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
3766  if( jsg.GT.js .AND. je.LT.jsc )then !cyclic offset
3767  js = js+joff; je = je+joff
3768  end if
3769  if( is.LT.isg )then
3770  folded = .TRUE.
3771  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3772  end if
3773  call insert_update_overlap( overlap, domain%list(m)%pe, &
3774  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3775  !--- when south edge is folded, js will be less than jsg when position is EAST and CORNER
3776  if(js .LT. jsg) then
3777  js = js + joff
3778  call insert_update_overlap( overlap, domain%list(m)%pe, &
3779  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3780  endif
3781 
3782  !to_pe's western halo
3783  dir = 5
3784  folded = .FALSE.
3785  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3786  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3787  if( isg.GT.is )then
3788  folded = .true.
3789  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3790  end if
3791  !--- when domain symmetry and position is EAST or CORNER, the point when isc == ie,
3792  !--- no need to send, because the data on that point will come from other pe.
3793  !--- come from two pe ( there will be only one point on one pe. ).
3794  if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
3795  !--- do nothing, this point will come from other pe
3796  else
3797  call insert_update_overlap( overlap, domain%list(m)%pe, &
3798  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
3799  endif
3800  !--- when south edge is folded, ie will be less than isg when position is EAST and CORNER
3801  if(js .LT. jsg) then
3802  js = js + ioff
3803  call insert_update_overlap( overlap, domain%list(m)%pe, &
3804  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
3805  endif
3806 
3807  !to_pe's NW halo
3808  dir = 6
3809  folded = .false.
3810  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
3811  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3812  if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
3813  js = js-joff; je = je-joff
3814  end if
3815  if( is.LT.isg )then
3816  folded = .TRUE.
3817  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
3818  end if
3819 
3820  call insert_update_overlap( overlap, domain%list(m)%pe, &
3821  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
3822 
3823  !to_pe's northern halo
3824  dir = 7
3825  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
3826  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3827  !--- to make sure the consistence between pes
3828  if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
3829  !--- do nothing, this point will come from other pe
3830  else
3831  if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
3832  js = js-joff; je = je-joff
3833  endif
3834  !--- when the west face is folded, the south halo points at
3835  !--- the position should be on CORNER or EAST
3836  if( is == isg .AND. (position == CORNER .OR. position == EAST) &
3837  .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
3838  call insert_update_overlap( overlap, domain%list(m)%pe, &
3839  is+1, ie, js, je, isc, iec, jsc, jec, dir)
3840  is = domain%list(m)%x(tNbr)%compute%begin; ie = is
3841  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
3842  select case (position)
3843  case(EAST)
3844  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3845  case(CORNER)
3846  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3847  end select
3848  call insert_update_overlap( overlap, domain%list(m)%pe, &
3849  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3850  else
3851  call insert_update_overlap( overlap, domain%list(m)%pe, &
3852  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
3853  end if
3854  endif
3855 
3856  !to_pe's NE halo
3857  dir = 8
3858  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
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  call insert_update_overlap( overlap, domain%list(m)%pe, &
3864  is, ie, js, je, isc, iec, jsc, jec, dir)
3865 
3866  !--- Now calculate the overlapping for fold-edge.
3867  !--- only position at EAST and CORNER need to be considered
3868  if( ( position == EAST .OR. position == CORNER) ) then
3869  if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
3870  dir = 5
3871  !--- calculate the overlapping for sending
3872  if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
3873  is = domain%list(m)%x(tNbr)%compute%begin; ie = is
3874  if( is == isg )then ! fold is within domain.
3875  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
3876  select case (position)
3877  case(EAST)
3878  js = max(js, middle)
3879  j=js; js = jsg+jeg-je; je = jsg+jeg-j
3880  case(CORNER)
3881  js = max(js, middle)
3882  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
3883  end select
3884  call insert_update_overlap(overlap, domain%list(m)%pe, &
3885  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
3886  is = max(is, isc); ie = min(ie, iec)
3887  js = max(js, jsc); je = min(je, jec)
3888  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
3889  nsend_check = nsend_check+1
3890  call allocate_check_overlap(checkList(nsend_check), 1)
3891  call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
3892  tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
3893  end if
3894  end if
3895  end if
3896  end if
3897  end if
3898  end if
3899  !--- copy the overlapping information
3900  if( overlap%count > 0) then
3901  nsend = nsend + 1
3902  if(nsend > MAXLIST) call mpp_error(FATAL, &
3903  "mpp_domains_define.inc(compute_overlaps_west): nsend is greater than MAXLIST, increase MAXLIST")
3904  call add_update_overlap(overlapList(nsend), overlap)
3905  call init_overlap_type(overlap)
3906  endif
3907  end do ! end of send set up.
3908 
3910  !--- write out send information
3911  unit = mpp_pe() + 1000
3912  do m =1,nsend
3913  write(unit, *) "********to_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
3914  do n = 1, overlapList(m)%count
3915  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
3916  overlapList(m)%dir(n), overlapList(m)%rotation(n)
3917  enddo
3918  enddo
3919  if(nsend >0) call flush(unit)
3920  endif
3921 
3922  ! copy the overlapping information into domain data structure
3923  if(nsend>0) then
3924  update%nsend = nsend
3925  allocate(update%send(nsend))
3926  do m = 1, nsend
3927  call add_update_overlap( update%send(m), overlapList(m) )
3928  enddo
3929  endif
3930 
3931  if(nsend_check>0) then
3932  check%nsend = nsend_check
3933  allocate(check%send(nsend_check))
3934  do m = 1, nsend_check
3935  call add_check_overlap( check%send(m), checkList(m) )
3936  enddo
3937  endif
3938 
3939  do m = 1, MAXLIST
3940  call deallocate_overlap_type(overlapList(m))
3941  if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
3942  enddo
3943 
3944  isgd = isg - domain%whalo
3945  iegd = ieg + domain%ehalo
3946  jsgd = jsg - domain%shalo
3947  jegd = jeg + domain%nhalo
3948 
3949  ! begin setting up recv
3950  nrecv = 0
3951  nrecv_check = 0
3952  do list = 0,nlist-1
3953  m = mod( domain%pos+nlist-list, nlist )
3954  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
3955  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
3956  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
3957  !recv_e
3958  dir = 1
3959  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3960  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
3961  is=isc; ie=iec; js=jsc; je=jec
3962  call insert_update_overlap( overlap, domain%list(m)%pe, &
3963  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
3964 
3965  !recv_se
3966  dir = 2
3967  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
3968  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3969  is=isc; ie=iec; js=jsc; je=jec
3970  if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
3971  js = js-joff; je = je-joff
3972  end if
3973  call insert_update_overlap(overlap, domain%list(m)%pe, &
3974  is, ie, js, je, isd, ied, jsd, jed, dir)
3975 
3976  !recv_s
3977  dir = 3
3978  folded = .false.
3979  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
3980  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
3981  is=isc; ie=iec; js=jsc; je=jec
3982 
3983  if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
3984  !--- do nothing, this point will come from other pe
3985  else
3986  if( jsd.LT.jsg .AND. js .GT. jed)then
3987  js = js-joff; je = je-joff
3988  end if
3989  !--- when the west face is folded, the south halo points at
3990  !--- the position should be on CORNER or EAST
3991  if( isd == isg .AND. (position == CORNER .OR. position == EAST) &
3992  .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
3993  call insert_update_overlap( overlap, domain%list(m)%pe, &
3994  is, ie, js, je, isd+1, ied, jsd, jed, dir)
3995  is=isc; ie=iec; js=jsc; je=jec
3996  if(jsd<jsg) then
3997  select case (position)
3998  case(EAST)
3999  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4000  case(CORNER)
4001  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4002  end select
4003  if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4004  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4005  else
4006  select case (position)
4007  case(EAST)
4008  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4009  case(CORNER)
4010  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4011  end select
4012  end if
4013  call insert_update_overlap( overlap, domain%list(m)%pe, &
4014  is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4015  else
4016  call insert_update_overlap( overlap, domain%list(m)%pe, &
4017  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4018  end if
4019  endif
4020 
4021  !recv_sw
4022  dir = 4
4023  folded = .false.
4024  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4025  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4026  is=isc; ie=iec; js=jsc; je=jec
4027  if( isd.LT.isg )then
4028  folded = .true.
4029  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4030  end if
4031  if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4032  js = js-joff; je = je-joff
4033  end if
4034  call insert_update_overlap(overlap, domain%list(m)%pe, &
4035  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4036  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4037  if(js .LT. jsg ) then
4038  js = js + joff
4039  call insert_update_overlap(overlap, domain%list(m)%pe, &
4040  is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4041  endif
4042 
4043  !recv_w
4044  dir = 5
4045  folded = .false.
4046  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4047  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4048  is=isc; ie=iec; js=jsc; je=jec
4049  if( isd.LT.isg )then
4050  folded = .true.
4051  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4052  end if
4053  if( (position == EAST .OR. position == CORNER ) .AND. (jsd == je .or. jed == js ) ) then
4054  !--- do nothing, this point will come from other pe
4055  else
4056  call insert_update_overlap(overlap, domain%list(m)%pe, &
4057  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4058  end if
4059  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4060  if(js .LT. jsg ) then
4061  js = js + joff
4062  call insert_update_overlap(overlap, domain%list(m)%pe, &
4063  is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4064  endif
4065 
4066  !recv_nw
4067  dir = 6
4068  folded = .false.
4069  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4070  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4071  is=isc; ie=iec; js=jsc; je=jec
4072  if( isd.LT.isg) then
4073  folded = .true.
4074  call get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4075  end if
4076  if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4077  js = js+joff; je = je+joff
4078  endif
4079 
4080  call insert_update_overlap( overlap, domain%list(m)%pe, &
4081  is, ie, js, je, isd, ied, jsd, jed, dir)
4082 
4083  !recv_n
4084  dir = 7
4085  folded = .false.
4086  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4087  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4088  is=isc; ie=iec; js=jsc; je=jec
4089  if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4090  !--- do nothing, this point will come from other pe
4091  else
4092  if( jed.GT.jeg .AND. je.LT.jsd)then
4093  js = js+joff; je = je+joff
4094  end if
4095  !--- when the west face is folded, the south halo points at
4096  !--- the position should be on CORNER or EAST
4097  if( isd == isg .AND. (position == CORNER .OR. position == EAST) &
4098  .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4099  call insert_update_overlap( overlap, domain%list(m)%pe, &
4100  is, ie, js, je, isd+1, ied, jsd, jed, dir)
4101  is=isc; ie=iec; js=jsc; je=jec
4102  select case (position)
4103  case(EAST)
4104  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4105  case(CORNER)
4106  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4107  end select
4108  call insert_update_overlap( overlap, domain%list(m)%pe, &
4109  is, ie, js, je, isd, isd, jsd, jed, dir, .true.)
4110  else
4111  call insert_update_overlap( overlap, domain%list(m)%pe, &
4112  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4113  end if
4114  endif
4115 
4116  !recv_ne
4117  dir = 8
4118  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4119  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4120  is=isc; ie=iec; js=jsc; je=jec
4121  if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4122  js = js+joff; je = je+joff
4123  end if
4124  call insert_update_overlap( overlap, domain%list(m)%pe, &
4125  is, ie, js, je, isd, ied, jsd, jed, dir)
4126 
4127  !--- Now calculate the overlapping for fold-edge.
4128  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4129  !--- only position at EAST and CORNER need to be considered
4130  if( ( position == EAST .OR. position == CORNER) ) then
4131  if( domain%x(tMe)%data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
4132  dir = 5
4133  !--- calculating overlapping for receving on north
4134  if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then
4135  isd = domain%x(tMe)%compute%begin; ied = isd
4136  if( isd == isg )then ! fold is within domain.
4137  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4138  is=isc; ie=iec; js = jsc; je = jec
4139  select case (position)
4140  case(EAST)
4141  jsd = max(jsd, middle)
4142  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4143  case(CORNER)
4144  jsd = max(jsd, middle)
4145  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4146  end select
4147  call insert_update_overlap(overlap, domain%list(m)%pe, &
4148  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
4149  is = max(is, isd); ie = min(ie, ied)
4150  js = max(js, jsd); je = min(je, jed)
4151  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4152  nrecv_check = nrecv_check+1
4153  call allocate_check_overlap(checkList(nrecv_check), 1)
4154  call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
4155  tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4156  endif
4157  endif
4158  endif
4159  endif
4160  endif
4161  endif
4162  !--- copy the overlapping information
4163  if( overlap%count > 0) then
4164  nrecv = nrecv + 1
4165  if(nrecv > MAXLIST) call mpp_error(FATAL, &
4166  "mpp_domains_define.inc(compute_overlaps_west): nrecv is greater than MAXLIST, increase MAXLIST")
4167  call add_update_overlap( overlapList(nrecv), overlap)
4168  call init_overlap_type(overlap)
4169  endif
4170  enddo ! end of recv do loop
4171 
4173  !--- write out send information
4174  unit = mpp_pe() + 1000
4175  do m =1,nrecv
4176  write(unit, *) "********from_pe = " ,overlapList(m)%pe, " count = ",overlapList(m)%count
4177  do n = 1, overlapList(m)%count
4178  write(unit, *) overlapList(m)%is(n), overlapList(m)%ie(n), overlapList(m)%js(n), overlapList(m)%je(n), &
4179  overlapList(m)%dir(n), overlapList(m)%rotation(n)
4180  enddo
4181  enddo
4182  if(nrecv >0) call flush(unit)
4183  endif
4184 
4185  ! copy the overlapping information into domain
4186  if(nrecv>0) then
4187  update%nrecv = nrecv
4188  allocate(update%recv(nrecv))
4189  do m = 1, nrecv
4190  call add_update_overlap( update%recv(m), overlapList(m) )
4191  do n = 1, update%recv(m)%count
4192  if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
4193  if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
4194  if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
4195  endif
4196  enddo
4197  enddo
4198  endif
4199 
4200  if(nrecv_check>0) then
4201  check%nrecv = nrecv_check
4202  allocate(check%recv(nrecv_check))
4203  do m = 1, nrecv_check
4204  call add_check_overlap( check%recv(m), checkList(m) )
4205  enddo
4206  endif
4207 
4208  call deallocate_overlap_type(overlap)
4209  do m = 1, MAXLIST
4210  call deallocate_overlap_type(overlapList(m))
4211  if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4212  enddo
4213 
4214  update=>NULL()
4215  check=>NULL()
4216  domain%initialized = .true.
4217 
4218  end subroutine compute_overlaps_fold_west
4219 
4220  !###############################################################################
4221  subroutine compute_overlaps_fold_east( domain, position, ishift, jshift )
4222  !computes remote domain overlaps
4223  !assumes only one in each direction
4224  !will calculate the overlapping for T,E,C,N-cell seperately.
4225  !here assume fold-east and y-cyclic boundary condition
4226  type(domain2D), intent(inout) :: domain
4227  integer, intent(in) :: position, ishift, jshift
4228 
4229  integer :: j, m, n, nlist, tMe, tNbr, dir
4230  integer :: is, ie, js, je, isc, iec, jsc, jec, isd, ied, jsd
4231  integer :: jed, isg, ieg, jsg, jeg, ioff, joff
4232  integer :: list, middle, ni, nj, isgd, iegd, jsgd, jegd
4233  integer :: ism, iem, jsm, jem, whalo, ehalo, shalo, nhalo
4234  logical :: folded
4235  type(overlap_type) :: overlap
4236  type(overlapSpec), pointer :: update=>NULL()
4237  type(overlap_type) :: overlapList(MAXLIST)
4238  type(overlap_type) :: checkList(MAXLIST)
4239  type(overlapSpec), pointer :: check =>NULL()
4240  integer :: nsend, nrecv
4241  integer :: nsend_check, nrecv_check
4242 
4243  !--- since we restrict that if multiple tiles on one pe, all the tiles are limited to this pe.
4244  !--- In this case, if ntiles on this pe is greater than 1, no overlapping between processor within each tile
4245  !--- In this case the overlapping exist only for tMe=1 and tNbr=1
4246  if(size(domain%x(:)) > 1) return
4247 
4248  !--- if there is no halo, no need to compute overlaps.
4249  if(domain%whalo==0 .AND. domain%ehalo==0 .AND. domain%shalo==0 .AND. domain%nhalo==0) return
4250 
4251  !--- when there is only one tile, n will equal to np
4252  nlist = size(domain%list(:))
4253 
4254  select case(position)
4255  case (CENTER)
4256  update => domain%update_T
4257  case (CORNER)
4258  update => domain%update_C
4259  check => domain%check_C
4260  case (EAST)
4261  update => domain%update_E
4262  check => domain%check_E
4263  case (NORTH)
4264  update => domain%update_N
4265  check => domain%check_N
4266  case default
4267  call mpp_error(FATAL, &
4268  "mpp_domains_define.inc(compute_overlaps_fold_east): the value of position should be CENTER, EAST, CORNER or NORTH")
4269  end select
4270 
4271  !--- overlap is used to store the overlapping temporarily.
4272  call allocate_update_overlap( overlap, MAXOVERLAP)
4273 
4274  !send
4275  call mpp_get_compute_domain( domain, isc, iec, jsc, jec, position=position )
4276  call mpp_get_global_domain ( domain, isg, ieg, jsg, jeg, xsize=ni, ysize=nj, position=position ) !cyclic offsets
4277  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem, position=position )
4278  update%xbegin = ism; update%xend = iem
4279  update%ybegin = jsm; update%yend = jem
4280  if(ASSOCIATED(check)) then
4281  check%xbegin = ism; check%xend = iem
4282  check%ybegin = jsm; check%yend = jem
4283  endif
4284  update%whalo = domain%whalo; update%ehalo = domain%ehalo
4285  update%shalo = domain%shalo; update%nhalo = domain%nhalo
4286  whalo = domain%whalo; ehalo = domain%ehalo
4287  shalo = domain%shalo; nhalo = domain%nhalo
4288 
4289  ioff = ni - ishift
4290  joff = nj - jshift
4291  middle = (jsg+jeg)/2+1
4292  tMe = 1; tNbr = 1
4293 
4294  if(.NOT. BTEST(domain%fold,EAST)) then
4295  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4296  "boundary condition in y-direction should be folded-east for "//trim(domain%name))
4297  endif
4298  if(.NOT. domain%y(tMe)%cyclic) then
4299  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4300  "boundary condition in y-direction should be cyclic for "//trim(domain%name))
4301  endif
4302  if(.not. domain%symmetry) then
4303  call mpp_error(FATAL, "mpp_domains_define.inc(compute_overlaps_fold_east): "//&
4304  "when east boundary is folded, the domain must be symmetry for "//trim(domain%name))
4305  endif
4306 
4307  nsend = 0
4308  nsend_check = 0
4309  do list = 0,nlist-1
4310  m = mod( domain%pos+list, nlist )
4311  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
4312  !to_pe's eastern halo
4313  dir = 1
4314  folded = .false.
4315  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4316  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4317  if( ie.GT.ieg )then
4318  folded = .true.
4319  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4320  end if
4321  !--- when domain symmetry and position is EAST or CORNER, the point when jsc == je,
4322  !--- no need to send, because the data on that point will come from other pe.
4323  !--- come from two pe ( there will be only one point on one pe. ).
4324  if( (position == EAST .OR. position == CORNER ) .AND. ( jsc == je .or. jec == js ) ) then
4325  !--- do nothing, this point will come from other pe
4326  else
4327  call insert_update_overlap( overlap, domain%list(m)%pe, &
4328  is, ie, js, je, isc, iec, jsc, jec, dir, folded, symmetry=domain%symmetry)
4329  endif
4330  !--- when east edge is folded, js .LT. jsg
4331  if(js .LT. jsg) then
4332  js = js + ioff
4333  call insert_update_overlap( overlap, domain%list(m)%pe, &
4334  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4335  endif
4336 
4337  !to_pe's SE halo
4338  dir = 2
4339  folded = .FALSE.
4340  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4341  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4342  if( jsg.GT.js .AND. je.LT.jsc )then !try cyclic offset
4343  js = js+joff; je = je+joff
4344  end if
4345 
4346  if( ie.GT.ieg )then
4347  folded = .TRUE.
4348  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4349  end if
4350 
4351  call insert_update_overlap( overlap, domain%list(m)%pe, &
4352  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4353  !--- when east edge is folded,
4354  if(js .LT. jsg) then
4355  js = js + joff
4356  call insert_update_overlap( overlap, domain%list(m)%pe, &
4357  is, ie, js, js, isc, iec, jsc, jec, dir, folded)
4358  endif
4359 
4360  !to_pe's southern halo
4361  dir = 3
4362  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
4363  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4364  !--- to make sure the consistence between pes
4365  if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
4366  !--- do nothing, this point will come from other pe
4367  else
4368  if( js.LT.jsg .AND. jsc.GT.je) then ! cyclic offset
4369  js = js+joff; je = je+joff
4370  endif
4371  !--- when the east face is folded, the south halo points at
4372  !--- the position should be on CORNER or EAST
4373  if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
4374  .AND. ( domain%list(m)%y(tNbr)%compute%begin == jsg .OR. &
4375  domain%list(m)%y(tNbr)%compute%begin-1 .GE. middle ) ) then
4376  call insert_update_overlap( overlap, domain%list(m)%pe, &
4377  is, ie-1, js, je, isc, iec, jsc, jec, dir)
4378  !--- consider at i = ieg for east edge.
4379  !--- when the data is at corner and not symmetry, j = jsg -1 will get from cyclic condition
4380  if(position == CORNER .AND. .NOT. domain%symmetry .AND. domain%list(m)%y(tNbr)%compute%begin == jsg) then
4381  call insert_update_overlap(overlap, domain%list(m)%pe, &
4382  ie, ie, je, je, isc, iec, jsc, jec, dir, .true.)
4383  end if
4384 
4385  ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
4386  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4387  if ( domain%list(m)%y(tNbr)%compute%begin == jsg ) then
4388  select case (position)
4389  case(EAST)
4390  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4391  case(CORNER)
4392  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4393  end select
4394  if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4395  'mpp_domains_define.inc(compute_overlaps_fold_east: south edge ubound error send.' )
4396  else
4397  select case (position)
4398  case(EAST)
4399  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4400  case(CORNER)
4401  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4402  end select
4403  end if
4404  call insert_update_overlap( overlap, domain%list(m)%pe, &
4405  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4406  else
4407  call insert_update_overlap( overlap, domain%list(m)%pe, &
4408  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4409  end if
4410  endif
4411 
4412  !to_pe's SW halo
4413  dir = 4
4414  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
4415  js = domain%list(m)%y(tNbr)%compute%begin-shalo; je = domain%list(m)%y(tNbr)%compute%begin-1
4416  if( js.LT.jsg .AND. jsc.GT.je )then ! cyclic is assumed
4417  js = js+joff; je = je+joff
4418  end if
4419  call insert_update_overlap( overlap, domain%list(m)%pe, &
4420  is, ie, js, je, isc, iec, jsc, jec, dir)
4421 
4422  !to_pe's western halo
4423  dir = 5
4424  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
4425  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4426  call insert_update_overlap( overlap, domain%list(m)%pe, &
4427  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4428 
4429  !to_pe's NW halo
4430  dir = 6
4431  is = domain%list(m)%x(tNbr)%compute%begin-whalo; ie = domain%list(m)%x(tNbr)%compute%begin-1
4432  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4433  if( je.GT.jeg .AND. jec.LT.js )then !cyclic offset
4434  js = js-joff; je = je-joff
4435  end if
4436  call insert_update_overlap( overlap, domain%list(m)%pe, &
4437  is, ie, js, je, isc, iec, jsc, jec, dir)
4438 
4439  !to_pe's northern halo
4440  dir = 7
4441  folded = .FALSE.
4442  is = domain%list(m)%x(tNbr)%compute%begin; ie = domain%list(m)%x(tNbr)%compute%end+ishift
4443  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4444  !--- to make sure the consistence between pes
4445  if( (position == EAST .OR. position == CORNER ) .AND. ( isc == ie .or. iec == is ) ) then
4446  !--- do nothing, this point will come from other pe
4447  else
4448  if( je.GT.jeg .AND. jec.LT.js) then ! cyclic offset
4449  js = js-joff; je = je-joff
4450  endif
4451  !--- when the east face is folded, the north halo points at
4452  !--- the position should be on CORNER or EAST
4453  if( ie == ieg .AND. (position == CORNER .OR. position == EAST) &
4454  .AND. ( js .GE. middle .AND. domain%list(m)%y(tNbr)%compute%end+nhalo+jshift .LE. jeg ) ) then
4455  call insert_update_overlap( overlap, domain%list(m)%pe, &
4456  is, ie-1, js, je, isc, iec, jsc, jec, dir)
4457  ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
4458  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4459  select case (position)
4460  case(EAST)
4461  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4462  case(CORNER)
4463  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4464  end select
4465  call insert_update_overlap( overlap, domain%list(m)%pe, &
4466  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4467  else
4468  call insert_update_overlap( overlap, domain%list(m)%pe, &
4469  is, ie, js, je, isc, iec, jsc, jec, dir, symmetry=domain%symmetry)
4470  end if
4471  endif
4472 
4473  !to_pe's NE halo
4474  dir = 8
4475  folded = .false.
4476  is = domain%list(m)%x(tNbr)%compute%end+1+ishift; ie = domain%list(m)%x(tNbr)%compute%end+ehalo+ishift
4477  js = domain%list(m)%y(tNbr)%compute%end+1+jshift; je = domain%list(m)%y(tNbr)%compute%end+nhalo+jshift
4478  if( je.GT.jeg .AND. jec.LT.js )then ! cyclic offset
4479  js = js-joff; je = je-joff
4480  end if
4481  if( ie.GT.ieg )then
4482  folded = .TRUE.
4483  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4484  end if
4485 
4486  call insert_update_overlap( overlap, domain%list(m)%pe, &
4487  is, ie, js, je, isc, iec, jsc, jec, dir, folded)
4488 
4489  !--- Now calculate the overlapping for fold-edge.
4490  !--- only position at EAST and CORNER need to be considered
4491  if( ( position == EAST .OR. position == CORNER) ) then
4492  if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
4493  dir = 1
4494  !--- calculate the overlapping for sending
4495  if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then
4496  ie = domain%list(m)%x(tNbr)%compute%end+ishift; is = ie
4497  if( ie == ieg )then ! fold is within domain.
4498  js = domain%list(m)%y(tNbr)%compute%begin; je = domain%list(m)%y(tNbr)%compute%end+jshift
4499  select case (position)
4500  case(EAST)
4501  js = max(js, middle)
4502  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4503  case(CORNER)
4504  js = max(js, middle)
4505  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4506  end select
4507  call insert_update_overlap(overlap, domain%list(m)%pe, &
4508  is, ie, js, je, isc, iec, jsc, jec, dir, .true.)
4509  is = max(is, isc); ie = min(ie, iec)
4510  js = max(js, jsc); je = min(je, jec)
4511  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4512  nsend_check = nsend_check+1
4513  call allocate_check_overlap(checkList(nsend_check), 1)
4514  call insert_check_overlap(checkList(nsend_check), domain%list(m)%pe, &
4515  tMe, 1, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4516  end if
4517  end if
4518  end if
4519  end if
4520  end if
4521  end if
4522  !--- copy the overlapping information
4523  if( overlap%count > 0) then
4524  nsend = nsend + 1
4525  if(nsend > MAXLIST) call mpp_error(FATAL, &
4526  "mpp_domains_define.inc(compute_overlaps_east): nsend is greater than MAXLIST, increase MAXLIST")
4527  call add_update_overlap(overlapList(nsend), overlap)
4528  call init_overlap_type(overlap)
4529  endif
4530  end do ! end of send set up.
4531 
4532  ! copy the overlapping information into domain data structure
4533  if(nsend>0) then
4534  update%nsend = nsend
4535  allocate(update%send(nsend))
4536  do m = 1, nsend
4537  call add_update_overlap( update%send(m), overlapList(m) )
4538  enddo
4539  endif
4540 
4541  if(nsend_check>0) then
4542  check%nsend = nsend_check
4543  allocate(check%send(nsend_check))
4544  do m = 1, nsend_check
4545  call add_check_overlap( check%send(m), checkList(m) )
4546  enddo
4547  endif
4548 
4549  do m = 1, MAXLIST
4550  call deallocate_overlap_type(overlapList(m))
4551  if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4552  enddo
4553 
4554  isgd = isg - domain%whalo
4555  iegd = ieg + domain%ehalo
4556  jsgd = jsg - domain%shalo
4557  jegd = jeg + domain%nhalo
4558 
4559  ! begin setting up recv
4560  nrecv = 0
4561  nrecv_check = 0
4562  do list = 0,nlist-1
4563  m = mod( domain%pos+nlist-list, nlist )
4564  if(domain%list(m)%tile_id(tNbr) == domain%tile_id(tMe) ) then ! only compute the overlapping within tile.
4565  isc = domain%list(m)%x(1)%compute%begin; iec = domain%list(m)%x(1)%compute%end+ishift
4566  jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift
4567  !recv_e
4568  dir = 1
4569  folded = .false.
4570  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4571  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4572  is=isc; ie=iec; js=jsc; je=jec
4573  if( ied.GT.ieg )then
4574  folded = .true.
4575  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4576  end if
4577  if( (position == EAST .OR. position == CORNER ) .AND. (jsd == je .or. jed == js ) ) then
4578  !--- do nothing, this point will come from other pe
4579  else
4580  call insert_update_overlap(overlap, domain%list(m)%pe, &
4581  is, ie, js, je, isd, ied, jsd, jed, dir, folded, symmetry=domain%symmetry)
4582  end if
4583  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4584  if(js .LT. jsg ) then
4585  js = js + joff
4586  call insert_update_overlap(overlap, domain%list(m)%pe, &
4587  is, ie, js, js, isd, ied, jsd, jed, dir, folded)
4588  endif
4589 
4590  !recv_se
4591  dir = 2
4592  folded = .false.
4593  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4594  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4595  is=isc; ie=iec; js=jsc; je=jec
4596  if( ied.GT.ieg )then
4597  folded = .true.
4598  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4599  end if
4600  if( jsd.LT.jsg .AND. js.GT.jed ) then ! cyclic offset
4601  js = js-joff; je = je-joff
4602  end if
4603  call insert_update_overlap(overlap, domain%list(m)%pe, &
4604  is, ie, js, je, isd, ied, jsd, jed, dir, folded)
4605  !--- when west edge is folded, js will be less than jsg when position is EAST and CORNER
4606  if(js .LT. jsg ) then
4607  js = js + joff
4608  call insert_update_overlap(overlap, domain%list(m)%pe, &
4609  is, ie, js, js, isd, ied, jsd, jed, dir, folded )
4610  endif
4611 
4612  !recv_s
4613  dir = 3
4614  folded = .false.
4615  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4616  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4617  is=isc; ie=iec; js=jsc; je=jec
4618 
4619  if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4620  !--- do nothing, this point will come from other pe
4621  else
4622  if( jsd.LT.jsg .AND. js .GT. jed)then
4623  js = js-joff; je = je-joff
4624  end if
4625  !--- when the east face is folded, the south halo points at
4626  !--- the position should be on CORNER or EAST
4627  if( ied == ieg .AND. (position == CORNER .OR. position == EAST) &
4628  .AND. ( jsd < jsg .OR. jed .GE. middle ) ) then
4629  call insert_update_overlap( overlap, domain%list(m)%pe, &
4630  is, ie, js, je, isd, ied-1, jsd, jed, dir)
4631  is=isc; ie=iec; js=jsc; je=jec
4632  if(jsd<jsg) then
4633  select case (position)
4634  case(EAST)
4635  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4636  case(CORNER)
4637  j=js; js = 2*jsg-je-2+2*jshift; je = 2*jsg-j-2+2*jshift
4638  end select
4639  if(je .GT. domain%y(tMe)%compute%end+jshift) call mpp_error( FATAL, &
4640  'mpp_domains_define.inc(compute_overlaps_fold_west: south edge ubound error recv.' )
4641  else
4642  select case (position)
4643  case(EAST)
4644  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4645  case(CORNER)
4646  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4647  end select
4648  end if
4649  call insert_update_overlap( overlap, domain%list(m)%pe, &
4650  is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4651  else
4652  call insert_update_overlap( overlap, domain%list(m)%pe, &
4653  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4654  end if
4655  endif
4656 
4657  !recv_sw
4658  dir = 4
4659  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4660  jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1
4661  is=isc; ie=iec; js=jsc; je=jec
4662  if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed
4663  js = js-joff; je = je-joff
4664  end if
4665  call insert_update_overlap(overlap, domain%list(m)%pe, &
4666  is, ie, js, je, isd, ied, jsd, jed, dir)
4667 
4668  !recv_w
4669  dir = 5
4670  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4671  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4672  is=isc; ie=iec; js=jsc; je=jec
4673  call insert_update_overlap( overlap, domain%list(m)%pe, &
4674  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4675 
4676  !recv_nw
4677  dir = 6
4678  folded = .false.
4679  isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1
4680  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4681  is=isc; ie=iec; js=jsc; je=jec
4682  if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset
4683  js = js+joff; je = je+joff
4684  end if
4685  call insert_update_overlap( overlap, domain%list(m)%pe, &
4686  is, ie, js, je, isd, ied, jsd, jed, dir)
4687 
4688  !recv_n
4689  dir = 7
4690  folded = .false.
4691  isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift
4692  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4693  is=isc; ie=iec; js=jsc; je=jec
4694  if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then
4695  !--- do nothing, this point will come from other pe
4696  else
4697  if( jed.GT.jeg .AND. je.LT.jsd)then
4698  js = js+joff; je = je+joff
4699  end if
4700  !--- when the east face is folded, the south halo points at
4701  !--- the position should be on CORNER or EAST
4702  if( ied == ieg .AND. (position == CORNER .OR. position == EAST) &
4703  .AND. jsd .GE. middle .AND. jed .LE. jeg ) then
4704  call insert_update_overlap( overlap, domain%list(m)%pe, &
4705  is, ie, js, je, isd, ied-1, jsd, jed, dir)
4706  is=isc; ie=iec; js=jsc; je=jec
4707  select case (position)
4708  case(EAST)
4709  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4710  case(CORNER)
4711  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4712  end select
4713  call insert_update_overlap( overlap, domain%list(m)%pe, &
4714  is, ie, js, je, ied, ied, jsd, jed, dir, .true.)
4715  else
4716  call insert_update_overlap( overlap, domain%list(m)%pe, &
4717  is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry)
4718  end if
4719  endif
4720 
4721  !recv_ne
4722  dir = 8
4723  folded = .false.
4724  isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift
4725  jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift
4726  is=isc; ie=iec; js=jsc; je=jec
4727  if( ied.GT.ieg) then
4728  folded = .true.
4729  call get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4730  end if
4731  if( jed.GT.jeg .AND. je.LT.jsd )then !cyclic offset
4732  js = js+joff; je = je+joff
4733  endif
4734 
4735  call insert_update_overlap( overlap, domain%list(m)%pe, &
4736  is, ie, js, je, isd, ied, jsd, jed, dir)
4737  !--- Now calculate the overlapping for fold-edge.
4738  !--- for folded-south-edge, only need to consider to_pe's south(3) direction
4739  !--- only position at EAST and CORNER need to be considered
4740  if( ( position == EAST .OR. position == CORNER) ) then
4741  if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold is within domain
4742  dir = 1
4743  !--- calculating overlapping for receving on north
4744  if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then
4745  ied = domain%x(tMe)%compute%end+ishift; isd = ied
4746  if( ied == ieg )then ! fold is within domain.
4747  jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift
4748  is=isc; ie=iec; js = jsc; je = jec
4749  select case (position)
4750  case(EAST)
4751  jsd = max(jsd, middle)
4752  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4753  case(CORNER)
4754  jsd = max(jsd, middle)
4755  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4756  end select
4757  call insert_update_overlap(overlap, domain%list(m)%pe, &
4758  is, ie, js, je, isd, ied, jsd, jed, dir, .TRUE.)
4759  is = max(is, isd); ie = min(ie, ied)
4760  js = max(js, jsd); je = min(je, jed)
4761  if(debug_update_level .NE. NO_CHECK .AND. ie.GE.is .AND. je.GE.js )then
4762  nrecv_check = nrecv_check+1
4763  call allocate_check_overlap(checkList(nrecv_check), 1)
4764  call insert_check_overlap(checkList(nrecv_check), domain%list(m)%pe, &
4765  tMe, 3, ONE_HUNDRED_EIGHTY, is, ie, js, je)
4766  endif
4767  endif
4768  endif
4769  endif
4770  endif
4771  endif
4772  !--- copy the overlapping information
4773  if( overlap%count > 0) then
4774  nrecv = nrecv + 1
4775  if(nrecv > MAXLIST) call mpp_error(FATAL, &
4776  "mpp_domains_define.inc(compute_overlaps_east): nrecv is greater than MAXLIST, increase MAXLIST")
4777  call add_update_overlap( overlapList(nrecv), overlap)
4778  call init_overlap_type(overlap)
4779  endif
4780  enddo ! end of recv do loop
4781 
4782  ! copy the overlapping information into domain
4783  if(nrecv>0) then
4784  update%nrecv = nrecv
4785  allocate(update%recv(nrecv))
4786  do m = 1, nrecv
4787  call add_update_overlap( update%recv(m), overlapList(m) )
4788  do n = 1, update%recv(m)%count
4789  if(update%recv(m)%tileNbr(n) == domain%tile_id(tMe)) then
4790  if(update%recv(m)%dir(n) == 1) domain%x(tMe)%loffset = 0
4791  if(update%recv(m)%dir(n) == 7) domain%y(tMe)%loffset = 0
4792  endif
4793  enddo
4794  enddo
4795  endif
4796 
4797  if(nrecv_check>0) then
4798  check%nrecv = nrecv_check
4799  allocate(check%recv(nrecv_check))
4800  do m = 1, nrecv_check
4801  call add_check_overlap( check%recv(m), checkList(m) )
4802  enddo
4803  endif
4804 
4805  call deallocate_overlap_type(overlap)
4806  do m = 1, MAXLIST
4807  call deallocate_overlap_type(overlapList(m))
4808  if(debug_update_level .NE. NO_CHECK) call deallocate_overlap_type(checkList(m))
4809  enddo
4810 
4811  update=>NULL()
4812  check=>NULL()
4813 
4814  domain%initialized = .true.
4815 
4816  end subroutine compute_overlaps_fold_east
4817 
4818  !#####################################################################################
4819  subroutine get_fold_index_west(jsg, jeg, isg, jshift, position, is, ie, js, je)
4820  integer, intent(in) :: jsg, jeg, isg, jshift, position
4821  integer, intent(inout) :: is, ie, js, je
4822  integer :: i, j
4823 
4824  select case(position)
4825  case(CENTER)
4826  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4827  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4828  case(EAST)
4829  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4830  i=is; is = 2*isg-ie; ie = 2*isg-i
4831  case(NORTH)
4832  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4833  i=is; is = 2*isg-ie-1; ie = 2*isg-i-1
4834  case(CORNER)
4835  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4836  i=is; is = 2*isg-ie; ie = 2*isg-i
4837  end select
4838 
4839  end subroutine get_fold_index_west
4840 
4841  !#####################################################################################
4842  subroutine get_fold_index_east(jsg, jeg, ieg, jshift, position, is, ie, js, je)
4843  integer, intent(in) :: jsg, jeg, ieg, jshift, position
4844  integer, intent(inout) :: is, ie, js, je
4845  integer :: i, j
4846 
4847  select case(position)
4848  case(CENTER)
4849  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4850  i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4851  case(EAST)
4852  j=js; js = jsg+jeg-je; je = jsg+jeg-j
4853  i=is; is = 2*ieg-ie; ie = 2*ieg-i
4854  case(NORTH)
4855  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4856  i=is; is = 2*ieg-ie+1; ie = 2*ieg-i+1
4857  case(CORNER)
4858  j=js; js = jsg+jeg-je-1+jshift; je = jsg+jeg-j-1+jshift
4859  i=is; is = 2*ieg-ie; ie = 2*ieg-i
4860  end select
4861 
4862  end subroutine get_fold_index_east
4863 
4864  !#####################################################################################
4865  subroutine get_fold_index_south(isg, ieg, jsg, ishift, position, is, ie, js, je)
4866  integer, intent(in) :: isg, ieg, jsg, ishift, position
4867  integer, intent(inout) :: is, ie, js, je
4868  integer :: i, j
4869 
4870  select case(position)
4871  case(CENTER)
4872  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4873  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4874  case(EAST)
4875  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4876  j=js; js = 2*jsg-je-1; je = 2*jsg-j-1
4877  case(NORTH)
4878  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4879  j=js; js = 2*jsg-je; je = 2*jsg-j
4880  case(CORNER)
4881  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4882  j=js; js = 2*jsg-je; je = 2*jsg-j
4883  end select
4884 
4885  end subroutine get_fold_index_south
4886  !#####################################################################################
4887  subroutine get_fold_index_north(isg, ieg, jeg, ishift, position, is, ie, js, je)
4888  integer, intent(in) :: isg, ieg, jeg, ishift, position
4889  integer, intent(inout) :: is, ie, js, je
4890  integer :: i, j
4891 
4892  select case(position)
4893  case(CENTER)
4894  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4895  j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4896  case(EAST)
4897  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4898  j=js; js = 2*jeg-je+1; je = 2*jeg-j+1
4899  case(NORTH)
4900  i=is; is = isg+ieg-ie; ie = isg+ieg-i
4901  j=js; js = 2*jeg-je; je = 2*jeg-j
4902  case(CORNER)
4903  i=is; is = isg+ieg-ie-1+ishift; ie = isg+ieg-i-1+ishift
4904  j=js; js = 2*jeg-je; je = 2*jeg-j
4905  end select
4906 
4907  end subroutine get_fold_index_north
4908 
4909 
4910  !#####################################################################################
4911  ! add offset to the index
4912  subroutine apply_cyclic_offset(lstart, lend, offset, gstart, gend, gsize)
4913  integer, intent(inout) :: lstart, lend
4914  integer, intent(in ) :: offset, gstart, gend, gsize
4915 
4916  lstart = lstart + offset
4917  if(lstart > gend) lstart = lstart - gsize
4918  if(lstart < gstart) lstart = lstart + gsize
4919  lend = lend + offset
4920  if(lend > gend) lend = lend - gsize
4921  if(lend < gstart) lend = lend + gsize
4922 
4923  return
4924 
4925  end subroutine apply_cyclic_offset
4926 
4927  !###################################################################################
4928  ! this routine setup the overlapping for mpp_update_domains for arbitrary halo update.
4929  ! should be the halo size defined in mpp_define_domains.
4930  ! xhalo_out, yhalo_out should not be exactly the same as xhalo_in, yhalo_in
4931  ! currently we didn't consider about tripolar grid situation, because in the folded north
4932  ! region, the overlapping is specified through list of points, not through rectangular.
4933  ! But will return back to solve this problem in the future.
4934  subroutine set_overlaps(domain, overlap_in, overlap_out, whalo_out, ehalo_out, shalo_out, nhalo_out)
4935  type(domain2d), intent(in) :: domain
4936  type(overlapSpec), intent(in) :: overlap_in
4937  type(overlapSpec), intent(inout) :: overlap_out
4938  integer, intent(in) :: whalo_out, ehalo_out, shalo_out, nhalo_out
4939  integer :: nlist, m, n, isoff, ieoff, jsoff, jeoff, rotation
4940  integer :: whalo_in, ehalo_in, shalo_in, nhalo_in
4941  integer :: dir
4942  type(overlap_type) :: overlap
4943  type(overlap_type), allocatable :: send(:), recv(:)
4944  type(overlap_type), pointer :: ptrIn => NULL()
4945  integer :: nsend, nrecv, nsend_in, nrecv_in
4946 
4947  if( domain%fold .NE. 0) call mpp_error(FATAL, &
4948  "mpp_domains_define.inc(set_overlaps): folded domain is not implemented for arbitrary halo update, contact developer")
4949 
4950  whalo_in = domain%whalo
4951  ehalo_in = domain%ehalo
4952  shalo_in = domain%shalo
4953  nhalo_in = domain%nhalo
4954 
4955  if( .NOT. domain%initialized) call mpp_error(FATAL, &
4956  "mpp_domains_define.inc: domain is not defined yet")
4957 
4958  nlist = size(domain%list(:))
4959  isoff = whalo_in - abs(whalo_out)
4960  ieoff = ehalo_in - abs(ehalo_out)
4961  jsoff = shalo_in - abs(shalo_out)
4962  jeoff = nhalo_in - abs(nhalo_out)
4963 
4964  nsend = 0
4965  nsend_in = overlap_in%nsend
4966  nrecv_in = overlap_in%nrecv
4967  if(nsend_in>0) allocate(send(nsend_in))
4968  if(nrecv_in>0) allocate(recv(nrecv_in))
4969  call allocate_update_overlap(overlap, MAXOVERLAP)
4970 
4971  overlap_out%whalo = whalo_out
4972  overlap_out%ehalo = ehalo_out
4973  overlap_out%shalo = shalo_out
4974  overlap_out%nhalo = nhalo_out
4975  overlap_out%xbegin = overlap_in%xbegin
4976  overlap_out%xend = overlap_in%xend
4977  overlap_out%ybegin = overlap_in%ybegin
4978  overlap_out%yend = overlap_in%yend
4979  !--- setting up overlap.
4980  do m = 1, nsend_in
4981  ptrIn => overlap_in%send(m)
4982  if(ptrIn%count .LE. 0) call mpp_error(FATAL, &
4983  "mpp_domains_define.inc(set_overlaps): number of overlap for send should be a positive number for"//trim(domain%name) )
4984  do n = 1, ptrIn%count
4985  dir = ptrIn%dir(n)
4986  rotation = ptrIn%rotation(n)
4987  select case(dir)
4988  case(1) ! to_pe's eastern halo
4989  if(ehalo_out > 0) then
4990  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir, rotation)
4991  else if(ehalo_out<0) then
4992  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir, rotation)
4993  end if
4994  case(2) ! to_pe's southeast halo
4995  if(ehalo_out>0 .AND. shalo_out > 0) then
4996  call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir, rotation)
4997  else if(ehalo_out<0 .AND. shalo_out < 0) then ! three parts: southeast, south and east.
4998  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir, rotation)
4999  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1, rotation)
5000  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1, rotation)
5001  end if
5002  case(3) ! to_pe's southern halo
5003  if(shalo_out > 0) then
5004  call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir, rotation)
5005  else if(shalo_out<0) then
5006  call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir, rotation)
5007  end if
5008  case(4) ! to_pe's southwest halo
5009  if(whalo_out>0 .AND. shalo_out > 0) then
5010  call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir, rotation)
5011  else if(whalo_out<0 .AND. shalo_out < 0) then
5012  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir, rotation)
5013  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1, rotation)
5014  call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1, rotation)
5015  end if
5016  case(5) ! to_pe's western halo
5017  if(whalo_out > 0) then
5018  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir, rotation)
5019  else if(whalo_out<0) then
5020  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir, rotation)
5021  end if
5022  case(6) ! to_pe's northwest halo
5023  if(whalo_out>0 .AND. nhalo_out > 0) then
5024  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir, rotation)
5025  else if(whalo_out<0 .AND. nhalo_out < 0) then
5026  call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir, rotation)
5027  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1, rotation)
5028  call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1, rotation)
5029  end if
5030  case(7) ! to_pe's northern halo
5031  if(nhalo_out > 0) then
5032  call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir, rotation)
5033  else if(nhalo_out<0) then
5034  call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir, rotation)
5035  end if
5036  case(8) ! to_pe's northeast halo
5037  if(ehalo_out>0 .AND. nhalo_out > 0) then
5038  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir, rotation)
5039  else if(ehalo_out<0 .AND. nhalo_out < 0) then
5040  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir, rotation)
5041  call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1, rotation)
5042  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1, rotation)
5043  end if
5044  end select
5045  end do ! do n = 1, ptrIn%count
5046  if(overlap%count>0) then
5047  nsend = nsend+1
5048  call add_update_overlap(send(nsend), overlap)
5049  call init_overlap_type(overlap)
5050  endif
5051  end do ! end do list = 0, nlist-1
5052 
5053  if(nsend>0) then
5054  overlap_out%nsend = nsend
5055  allocate(overlap_out%send(nsend));
5056  do n = 1, nsend
5057  call add_update_overlap(overlap_out%send(n), send(n) )
5058  enddo
5059  else
5060  overlap_out%nsend = 0
5061  endif
5062 
5063  !--------------------------------------------------
5064  ! recving
5065  !---------------------------------------------------
5066  overlap%count = 0
5067  nrecv = 0
5068  do m = 1, nrecv_in
5069  ptrIn => overlap_in%recv(m)
5070  if(ptrIn%count .LE. 0) call mpp_error(FATAL, &
5071  "mpp_domains_define.inc(set_overlaps): number of overlap for recv should be a positive number")
5072  overlap%count = 0
5073  do n = 1, ptrIn%count
5074  dir = ptrIn%dir(n)
5075  rotation = ptrIn%rotation(n)
5076  select case(dir)
5077  case(1) ! eastern halo
5078  if(ehalo_out > 0) then
5079  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, 0, n, dir)
5080  else if(ehalo_out<0) then
5081  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, 0, n, dir)
5082  end if
5083  case(2) ! southeast halo
5084  if(ehalo_out>0 .AND. shalo_out > 0) then
5085  call set_single_overlap(ptrIn, overlap, 0, -ieoff, jsoff, 0, n, dir)
5086  else if(ehalo_out<0 .AND. shalo_out < 0) then
5087  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, shalo_out, n, dir)
5088  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, jsoff, 0, n, dir-1)
5089  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, shalo_out, n, dir+1)
5090  end if
5091  case(3) ! southern halo
5092  if(shalo_out > 0) then
5093  call set_single_overlap(ptrIn, overlap, 0, 0, jsoff, 0, n, dir)
5094  else if(shalo_out<0) then
5095  call set_single_overlap(ptrIn, overlap, 0, 0, 0, shalo_out, n, dir)
5096  end if
5097  case(4) ! southwest halo
5098  if(whalo_out>0 .AND. shalo_out > 0) then
5099  call set_single_overlap(ptrIn, overlap, isoff, 0, jsoff, 0, n, dir)
5100  else if(whalo_out<0 .AND. shalo_out < 0) then
5101  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, shalo_out, n, dir)
5102  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, shalo_out, n, dir-1)
5103  call set_single_overlap(ptrIn, overlap, 0, whalo_out, jsoff, 0, n, dir+1)
5104  end if
5105  case(5) ! western halo
5106  if(whalo_out > 0) then
5107  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, 0, n, dir)
5108  else if(whalo_out<0) then
5109  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, 0, n, dir)
5110  end if
5111  case(6) ! northwest halo
5112  if(whalo_out>0 .AND. nhalo_out > 0) then
5113  call set_single_overlap(ptrIn, overlap, isoff, 0, 0, -jeoff, n, dir)
5114  else if(whalo_out<0 .AND. nhalo_out < 0) then
5115  call set_single_overlap(ptrIn, overlap, 0, whalo_out, -nhalo_out, 0, n, dir)
5116  call set_single_overlap(ptrIn, overlap, 0, whalo_out, 0, -jeoff, n, dir-1)
5117  call set_single_overlap(ptrIn, overlap, isoff, 0, -nhalo_out, 0, n, dir+1)
5118  end if
5119  case(7) ! northern halo
5120  if(nhalo_out > 0) then
5121  call set_single_overlap(ptrIn, overlap, 0, 0, 0, -jeoff, n, dir)
5122  else if(nhalo_out<0) then
5123  call set_single_overlap(ptrIn, overlap, 0, 0, -nhalo_out, 0, n, dir)
5124  end if
5125  case(8) ! northeast halo
5126  if(ehalo_out>0 .AND. nhalo_out > 0) then
5127  call set_single_overlap(ptrIn, overlap, 0, -ieoff, 0, -jeoff, n, dir)
5128  else if(ehalo_out<0 .AND. nhalo_out < 0) then
5129  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, -nhalo_out, 0, n, dir)
5130  call set_single_overlap(ptrIn, overlap, 0, -ieoff, -nhalo_out, 0, n, dir-1)
5131  call set_single_overlap(ptrIn, overlap, -ehalo_out, 0, 0, -jeoff, n, 1)
5132  end if
5133  end select
5134  end do ! do n = 1, ptrIn%count
5135  if(overlap%count>0) then
5136  nrecv = nrecv+1
5137  call add_update_overlap(recv(nrecv), overlap)
5138  call init_overlap_type(overlap)
5139  endif
5140  end do ! end do list = 0, nlist-1
5141  if(nrecv>0) then
5142  overlap_out%nrecv = nrecv
5143  allocate(overlap_out%recv(nrecv));
5144  do n = 1, nrecv
5145  call add_update_overlap(overlap_out%recv(n), recv(n) )
5146  enddo
5147  else
5148  overlap_out%nrecv = 0
5149  endif
5150 
5151  call deallocate_overlap_type(overlap)
5152  do n = 1, nsend_in
5153  call deallocate_overlap_type(send(n))
5154  enddo
5155  do n = 1, nrecv_in
5156  call deallocate_overlap_type(recv(n))
5157  enddo
5158  if(allocated(send)) deallocate(send)
5159  if(allocated(recv)) deallocate(recv)
5160  ptrIn => NULL()
5161 
5162  call set_domain_comm_inf(overlap_out)
5163 
5164 
5165  end subroutine set_overlaps
5166 
5167  !##############################################################################
5168  subroutine set_single_overlap(overlap_in, overlap_out, isoff, ieoff, jsoff, jeoff, index, dir, rotation)
5169  type(overlap_type), intent(in) :: overlap_in
5170  type(overlap_type), intent(inout) :: overlap_out
5171  integer, intent(in) :: isoff, jsoff, ieoff, jeoff
5172  integer, intent(in) :: index
5173  integer, intent(in) :: dir
5174  integer, optional, intent(in) :: rotation
5175  integer :: rotate
5176  integer :: count
5177 
5178  if( overlap_out%pe == NULL_PE ) then
5179  overlap_out%pe = overlap_in%pe
5180  else
5181  if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, &
5182  "mpp_domains_define.inc(set_single_overlap): mismatch of pe between overlap_in and overlap_out")
5183  endif
5184 
5185  if(isoff .NE. 0 .and. ieoff .NE. 0) call mpp_error(FATAL, &
5186  "mpp_domains_define.inc(set_single_overlap): both isoff and ieoff are non-zero")
5187  if(jsoff .NE. 0 .and. jeoff .NE. 0) call mpp_error(FATAL, &
5188  "mpp_domains_define.inc(set_single_overlap): both jsoff and jeoff are non-zero")
5189 
5190 
5191  overlap_out%count = overlap_out%count + 1
5192  count = overlap_out%count
5193  if(count > MAXOVERLAP) call mpp_error(FATAL, &
5194  "set_single_overlap: number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
5195  rotate = ZERO
5196  if(present(rotation)) rotate = rotation
5197  overlap_out%rotation (count) = overlap_in%rotation(index)
5198  overlap_out%dir (count) = dir
5199  overlap_out%tileMe (count) = overlap_in%tileMe(index)
5200  overlap_out%tileNbr (count) = overlap_in%tileNbr(index)
5201 
5202  select case(rotate)
5203  case(ZERO)
5204  overlap_out%is(count) = overlap_in%is(index) + isoff
5205  overlap_out%ie(count) = overlap_in%ie(index) + ieoff
5206  overlap_out%js(count) = overlap_in%js(index) + jsoff
5207  overlap_out%je(count) = overlap_in%je(index) + jeoff
5208  case(NINETY)
5209  overlap_out%is(count) = overlap_in%is(index) - jeoff
5210  overlap_out%ie(count) = overlap_in%ie(index) - jsoff
5211  overlap_out%js(count) = overlap_in%js(index) + isoff
5212  overlap_out%je(count) = overlap_in%je(index) + ieoff
5213  case(MINUS_NINETY)
5214  overlap_out%is(count) = overlap_in%is(index) + jsoff
5215  overlap_out%ie(count) = overlap_in%ie(index) + jeoff
5216  overlap_out%js(count) = overlap_in%js(index) - ieoff
5217  overlap_out%je(count) = overlap_in%je(index) - isoff
5218  case default
5219  call mpp_error(FATAL, "mpp_domains_define.inc: the value of rotation should be ZERO, NINETY or MINUS_NINETY")
5220  end select
5221 
5222 
5223  end subroutine set_single_overlap
5224 
5225  !###################################################################################
5226  !--- compute the overlapping between tiles for the T-cell.
5227  subroutine define_contact_point( domain, position, num_contact, tile1, tile2, align1, align2, &
5228  refine1, refine2, istart1, iend1, jstart1, jend1, istart2, iend2, jstart2, jend2, &
5229  isgList, iegList, jsgList, jegList )
5230  type(domain2D), intent(inout) :: domain
5231  integer, intent(in) :: position
5232  integer, intent(in) :: num_contact ! number of contact regions
5233  integer, dimension(:), intent(in) :: tile1, tile2 ! tile number
5234  integer, dimension(:), intent(in) :: align1, align2 ! align direction of contact region
5235  real, dimension(:), intent(in) :: refine1, refine2 ! refinement between tiles
5236  integer, dimension(:), intent(in) :: istart1, iend1 ! i-index in tile_1 of contact region
5237  integer, dimension(:), intent(in) :: jstart1, jend1 ! j-index in tile_1 of contact region
5238  integer, dimension(:), intent(in) :: istart2, iend2 ! i-index in tile_2 of contact region
5239  integer, dimension(:), intent(in) :: jstart2, jend2 ! j-index in tile_2 of contact region
5240  integer, dimension(:), intent(in) :: isgList, iegList ! i-global domain of each tile
5241  integer, dimension(:), intent(in) :: jsgList, jegList ! j-global domain of each tile
5242 
5243  integer :: isc, iec, jsc, jec, isd, ied, jsd, jed
5244  integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2
5245  integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2
5246  integer :: is, ie, js, je, ioff, joff, isoff, ieoff, jsoff, jeoff
5247  integer :: ntiles, max_contact
5248  integer :: nlist, list, m, n, l, count, numS, numR
5249  integer :: whalo, ehalo, shalo, nhalo
5250  integer :: t1, t2, tt, pos
5251  integer :: ntileMe, ntileNbr, tMe, tNbr, tileMe, dir
5252  integer :: nxd, nyd, nxc, nyc, ism, iem, jsm, jem
5253  integer :: dirlist(8)
5254  !--- is2Send and is1Send will figure out the overlapping for sending from current pe.
5255  !--- is1Recv and iscREcv will figure out the overlapping for recving onto current pe.
5256  integer, dimension(4*num_contact) :: is1Send, ie1Send, js1Send, je1Send
5257  integer, dimension(4*num_contact) :: is2Send, ie2Send, js2Send, je2Send
5258  integer, dimension(4*num_contact) :: is2Recv, ie2Recv, js2Recv, je2Recv
5259  integer, dimension(4*num_contact) :: is1Recv, ie1Recv, js1Recv, je1Recv
5260  integer, dimension(4*num_contact) :: align1Recv, align2Recv, align1Send, align2Send
5261  real, dimension(4*num_contact) :: refineRecv, refineSend
5262  integer, dimension(4*num_contact) :: rotateSend, rotateRecv, tileSend, tileRecv
5263  integer :: nsend, nrecv, nsend2, nrecv2
5264  type(contact_type), dimension(domain%ntiles) :: eCont, wCont, sCont, nCont
5265  type(overlap_type), dimension(0:size(domain%list(:))-1) :: overlapSend, overlapRecv
5266  integer :: unit
5267 
5268  if( position .NE. CENTER ) call mpp_error(FATAL, "mpp_domains_define.inc: " //&
5269  "routine define_contact_point can only be used to calculate overlapping for cell center.")
5270 
5271  ntiles = domain%ntiles
5272 
5273  eCont(:)%ncontact = 0;
5274 
5275  do n = 1, ntiles
5276  eCont(n)%ncontact = 0; sCont(n)%ncontact = 0; wCont(n)%ncontact = 0; nCont(n)%ncontact = 0;
5277  allocate(eCont(n)%tile(num_contact), wCont(n)%tile(num_contact) )
5278  allocate(nCont(n)%tile(num_contact), sCont(n)%tile(num_contact) )
5279  allocate(eCont(n)%align1(num_contact), eCont(n)%align2(num_contact) )
5280  allocate(wCont(n)%align1(num_contact), wCont(n)%align2(num_contact) )
5281  allocate(sCont(n)%align1(num_contact), sCont(n)%align2(num_contact) )
5282  allocate(nCont(n)%align1(num_contact), nCont(n)%align2(num_contact) )
5283  allocate(eCont(n)%refine1(num_contact), eCont(n)%refine2(num_contact) )
5284  allocate(wCont(n)%refine1(num_contact), wCont(n)%refine2(num_contact) )
5285  allocate(sCont(n)%refine1(num_contact), sCont(n)%refine2(num_contact) )
5286  allocate(nCont(n)%refine1(num_contact), nCont(n)%refine2(num_contact) )
5287  allocate(eCont(n)%is1(num_contact), eCont(n)%ie1(num_contact), eCont(n)%js1(num_contact), eCont(n)%je1(num_contact))
5288  allocate(eCont(n)%is2(num_contact), eCont(n)%ie2(num_contact), eCont(n)%js2(num_contact), eCont(n)%je2(num_contact))
5289  allocate(wCont(n)%is1(num_contact), wCont(n)%ie1(num_contact), wCont(n)%js1(num_contact), wCont(n)%je1(num_contact))
5290  allocate(wCont(n)%is2(num_contact), wCont(n)%ie2(num_contact), wCont(n)%js2(num_contact), wCont(n)%je2(num_contact))
5291  allocate(sCont(n)%is1(num_contact), sCont(n)%ie1(num_contact), sCont(n)%js1(num_contact), sCont(n)%je1(num_contact))
5292  allocate(sCont(n)%is2(num_contact), sCont(n)%ie2(num_contact), sCont(n)%js2(num_contact), sCont(n)%je2(num_contact))
5293  allocate(nCont(n)%is1(num_contact), nCont(n)%ie1(num_contact), nCont(n)%js1(num_contact), nCont(n)%je1(num_contact))
5294  allocate(nCont(n)%is2(num_contact), nCont(n)%ie2(num_contact), nCont(n)%js2(num_contact), nCont(n)%je2(num_contact))
5295  end do
5296 
5297  !--- set up the east, south, west and north contact for each tile.
5298  do n = 1, num_contact
5299  t1 = tile1(n)
5300  t2 = tile2(n)
5301  select case(align1(n))
5302  case (EAST)
5303  call fill_contact( eCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5304  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5305  case (WEST)
5306  call fill_contact( wCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5307  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5308  case (SOUTH)
5309  call fill_contact( sCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5310  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5311  case (NORTH)
5312  call fill_contact( nCont(t1), t2, istart1(n), iend1(n), jstart1(n), jend1(n), istart2(n), iend2(n), &
5313  jstart2(n), jend2(n), align1(n), align2(n), refine1(n), refine2(n))
5314  end select
5315  select case(align2(n))
5316  case (EAST)
5317  call fill_contact( eCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5318  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5319  case (WEST)
5320  call fill_contact( wCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5321  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5322  case (SOUTH)
5323  call fill_contact( sCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5324  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5325  case (NORTH)
5326  call fill_contact( nCont(t2), t1, istart2(n), iend2(n), jstart2(n), jend2(n), istart1(n), iend1(n), &
5327  jstart1(n), jend1(n), align2(n), align1(n), refine2(n), refine1(n))
5328  end select
5329  end do
5330 
5331  !--- the tile number of current pe, halo size
5332  whalo = domain%whalo
5333  ehalo = domain%ehalo
5334  shalo = domain%shalo
5335  nhalo = domain%nhalo
5336 
5337  !--- find if there is an extra point in x and y direction depending on position
5338  nlist = size(domain%list(:))
5339 
5340  max_contact = 4*num_contact ! should be enough
5341 
5342  ntileMe = size(domain%x(:))
5343  refineSend = 1; refineRecv = 1
5344 
5345  !--------------------------------------------------------------------------------------------------
5346  ! loop over each tile on current domain to set up the overlapping for each tile
5347  !--------------------------------------------------------------------------------------------------
5348  !--- first check the overlap within the tiles.
5349  do n = 1, domain%update_T%nsend
5350  pos = domain%update_T%send(n)%pe - mpp_root_pe()
5351  call add_update_overlap(overlapSend(pos), domain%update_T%send(n) )
5352  enddo
5353  do n = 1, domain%update_T%nrecv
5354  pos = domain%update_T%recv(n)%pe - mpp_root_pe()
5355  call add_update_overlap(overlapRecv(pos), domain%update_T%recv(n) )
5356  enddo
5357 
5358  call mpp_get_memory_domain(domain, ism, iem, jsm, jem)
5359  domain%update_T%xbegin = ism; domain%update_T%xend = iem
5360  domain%update_T%ybegin = jsm; domain%update_T%yend = jem
5361  domain%update_T%whalo = whalo; domain%update_T%ehalo = ehalo
5362  domain%update_T%shalo = shalo; domain%update_T%nhalo = nhalo
5363 
5364  do tMe = 1, ntileMe
5365  tileMe = domain%tile_id(tMe)
5366  rotateSend = ZERO; rotateRecv = ZERO
5367 
5368  !--- loop over all the contact region to figure out the index for overlapping region.
5369  count = 0
5370  do n = 1, eCont(tileMe)%ncontact ! east contact
5371  count = count+1
5372  tileRecv(count) = eCont(tileMe)%tile(n); tileSend(count) = eCont(tileMe)%tile(n)
5373  align1Recv(count) = eCont(tileMe)%align1(n); align2Recv(count) = eCont(tileMe)%align2(n)
5374  align1Send(count) = eCont(tileMe)%align1(n); align2Send(count) = eCont(tileMe)%align2(n)
5375  refineSend(count) = eCont(tileMe)%refine2(n); refineRecv(count) = eCont(tileMe)%refine1(n)
5376  is1Recv(count) = eCont(tileMe)%is1(n) + 1; ie1Recv(count) = is1Recv(count) + ehalo - 1
5377  js1Recv(count) = eCont(tileMe)%js1(n); je1Recv(count) = eCont(tileMe)%je1(n)
5378  select case(eCont(tileMe)%align2(n))
5379  case ( WEST ) ! w <-> e
5380  is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = is2Recv(count) + ehalo - 1
5381  js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = eCont(tileMe)%je2(n)
5382  ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - whalo + 1
5383  js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n)
5384  ie2Send(count) = eCont(tileMe)%is2(n) - 1; is2Send(count) = ie2Send(count) - whalo + 1
5385  js2Send(count) = eCont(tileMe)%js2(n); je2Send(count) = eCont(tileMe)%je2(n)
5386  case ( SOUTH ) ! s <-> e
5387  rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY
5388  js2Recv(count) = eCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + ehalo -1
5389  is2Recv(count) = eCont(tileMe)%is2(n); ie2Recv(count) = eCont(tileMe)%ie2(n)
5390  ie1Send(count) = eCont(tileMe)%is1(n); is1Send(count) = ie1Send(count) - shalo + 1
5391  js1Send(count) = eCont(tileMe)%js1(n); je1Send(count) = eCont(tileMe)%je1(n)
5392  is2Send(count) = eCont(tileMe)%is2(n); ie2Send(count) = eCont(tileMe)%ie2(n)
5393  je2Send(count) = eCont(tileMe)%js2(n) - 1; js2Send(count) = je2Send(count) - shalo + 1
5394  end select
5395  end do
5396 
5397  do n = 1, sCont(tileMe)%ncontact ! south contact
5398  count = count+1
5399  tileRecv(count) = sCont(tileMe)%tile(n); tileSend(count) = sCont(tileMe)%tile(n)
5400  align1Recv(count) = sCont(tileMe)%align1(n); align2Recv(count) = sCont(tileMe)%align2(n);
5401  align1Send(count) = sCont(tileMe)%align1(n); align2Send(count) = sCont(tileMe)%align2(n);
5402  refineSend(count) = sCont(tileMe)%refine2(n); refineRecv(count) = sCont(tileMe)%refine1(n)
5403  is1Recv(count) = sCont(tileMe)%is1(n); ie1Recv(count) = sCont(tileMe)%ie1(n)
5404  je1Recv(count) = sCont(tileMe)%js1(n) - 1; js1Recv(count) = je1Recv(count) - shalo + 1
5405  select case(sCont(tileMe)%align2(n))
5406  case ( NORTH ) ! n <-> s
5407  is2Recv(count) = sCont(tileMe)%is2(n); ie2Recv(count) = sCont(tileMe)%ie2(n)
5408  je2Recv(count) = sCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - shalo + 1
5409  is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n)
5410  js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + nhalo -1
5411  is2Send(count) = sCont(tileMe)%is2(n); ie2Send(count) = sCont(tileMe)%ie2(n)
5412  js2Send(count) = sCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
5413  case ( EAST ) ! e <-> s
5414  rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY
5415  ie2Recv(count) = sCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - shalo + 1
5416  js2Recv(count) = sCont(tileMe)%js2(n); je2Recv(count) = sCont(tileMe)%je2(n)
5417  is1Send(count) = sCont(tileMe)%is1(n); ie1Send(count) = sCont(tileMe)%ie1(n)
5418  js1Send(count) = sCont(tileMe)%js1(n); je1Send(count) = js1Send(count) + ehalo - 1
5419  is2Send(count) = sCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
5420  js2Send(count) = sCont(tileMe)%js2(n); je2Send(count) = sCont(tileMe)%je2(n)
5421  end select
5422  end do
5423 
5424  do n = 1, wCont(tileMe)%ncontact ! west contact
5425  count = count+1
5426  tileRecv(count) = wCont(tileMe)%tile(n); tileSend(count) = wCont(tileMe)%tile(n)
5427  align1Recv(count) = wCont(tileMe)%align1(n); align2Recv(count) = wCont(tileMe)%align2(n);
5428  align1Send(count) = wCont(tileMe)%align1(n); align2Send(count) = wCont(tileMe)%align2(n);
5429  refineSend(count) = wCont(tileMe)%refine2(n); refineRecv(count) = wCont(tileMe)%refine1(n)
5430  ie1Recv(count) = wCont(tileMe)%is1(n) - 1; is1Recv(count) = ie1Recv(count) - whalo + 1
5431  js1Recv(count) = wCont(tileMe)%js1(n); je1Recv(count) = wCont(tileMe)%je1(n)
5432  select case(wCont(tileMe)%align2(n))
5433  case ( EAST ) ! e <-> w
5434  ie2Recv(count) = wCont(tileMe)%ie2(n); is2Recv(count) = ie2Recv(count) - whalo + 1
5435  js2Recv(count) = wCont(tileMe)%js2(n); je2Recv(count) = wCont(tileMe)%je2(n)
5436  is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + ehalo - 1
5437  js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n)
5438  is2Send(count) = wCont(tileMe)%ie2(n)+1; ie2Send(count) = is2Send(count) + ehalo - 1
5439  js2Send(count) = wCont(tileMe)%js2(n); je2Send(count) = wCont(tileMe)%je2(n)
5440  case ( NORTH ) ! n <-> w
5441  rotateRecv(count) = NINETY; rotateSend(count) = MINUS_NINETY
5442  je2Recv(count) = wCont(tileMe)%je2(n); js2Recv(count) = je2Recv(count) - whalo + 1
5443  is2Recv(count) = wCont(tileMe)%is2(n); ie2Recv(count) = wCont(tileMe)%ie2(n)
5444  is1Send(count) = wCont(tileMe)%is1(n); ie1Send(count) = is1Send(count) + nhalo - 1
5445  js1Send(count) = wCont(tileMe)%js1(n); je1Send(count) = wCont(tileMe)%je1(n)
5446  js2Send(count) = wCont(tileMe)%je2(n)+1; je2Send(count) = js2Send(count) + nhalo - 1
5447  is2Send(count) = wCont(tileMe)%is2(n); ie2Send(count) = wCont(tileMe)%ie2(n)
5448  end select
5449  end do
5450 
5451  do n = 1, nCont(tileMe)%ncontact ! north contact
5452  count = count+1
5453  tileRecv(count) = nCont(tileMe)%tile(n); tileSend(count) = nCont(tileMe)%tile(n)
5454  align1Recv(count) = nCont(tileMe)%align1(n); align2Recv(count) = nCont(tileMe)%align2(n);
5455  align1Send(count) = nCont(tileMe)%align1(n); align2Send(count) = nCont(tileMe)%align2(n);
5456  refineSend(count) = nCont(tileMe)%refine2(n); refineRecv(count) = nCont(tileMe)%refine1(n)
5457  is1Recv(count) = nCont(tileMe)%is1(n); ie1Recv(count) = nCont(tileMe)%ie1(n)
5458  js1Recv(count) = nCont(tileMe)%je1(n)+1; je1Recv(count) = js1Recv(count) + nhalo - 1
5459  select case(nCont(tileMe)%align2(n))
5460  case ( SOUTH ) ! s <-> n
5461  is2Recv(count) = nCont(tileMe)%is2(n); ie2Recv(count) = nCont(tileMe)%ie2(n)
5462  js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = js2Recv(count) + nhalo - 1
5463  is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n)
5464  je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - shalo + 1
5465  is2Send(count) = nCont(tileMe)%is2(n); ie2Send(count) = nCont(tileMe)%ie2(n)
5466  je2Send(count) = nCont(tileMe)%js2(n)-1; js2Send(count) = je2Send(count) - shalo + 1
5467  case ( WEST ) ! w <-> n
5468  rotateRecv(count) = MINUS_NINETY; rotateSend(count) = NINETY
5469  is2Recv(count) = nCont(tileMe)%ie2(n); ie2Recv(count) = is2Recv(count) + nhalo - 1
5470  js2Recv(count) = nCont(tileMe)%js2(n); je2Recv(count) = nCont(tileMe)%je2(n)
5471  is1Send(count) = nCont(tileMe)%is1(n); ie1Send(count) = nCont(tileMe)%ie1(n)
5472  je1Send(count) = nCont(tileMe)%je1(n); js1Send(count) = je1Send(count) - whalo + 1
5473  ie2Send(count) = nCont(tileMe)%is2(n)-1; is2Send(count) = ie2Send(count) - whalo + 1
5474  js2Send(count) = nCont(tileMe)%js2(n); je2Send(count) = nCont(tileMe)%je2(n)
5475  end select
5476  end do
5477 
5478  numS = count
5479  numR = count
5480  !--- figure out the index for corner overlapping,
5481  !--- fill_corner_contact will be updated to deal with the situation that there are multiple tiles on
5482  !--- each side of six sides of cubic grid.
5483  if(.NOT. domain%rotated_ninety) then
5484  call fill_corner_contact(eCont, sCont, wCont, nCont, isgList, iegList, jsgList, jegList, numR, numS, &
5485  tileRecv, tileSend, is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, &
5486  js2Recv, je2Recv, is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, &
5487  js2Send, je2Send, align1Recv, align2Recv, align1Send, align2Send, &
5488  whalo, ehalo, shalo, nhalo, tileMe )
5489  end if
5490 
5491  isc = domain%x(tMe)%compute%begin; iec = domain%x(tMe)%compute%end
5492  jsc = domain%y(tMe)%compute%begin; jec = domain%y(tMe)%compute%end
5493 
5494  !--- compute the overlapping for send.
5495  do n = 1, numS
5496  do list = 0, nlist-1
5497  m = mod( domain%pos+list, nlist )
5498  ntileNbr = size(domain%list(m)%x(:))
5499  do tNbr = 1, ntileNbr
5500  if( domain%list(m)%tile_id(tNbr) .NE. tileSend(n) ) cycle
5501  isc1 = max(isc, is1Send(n)); iec1 = min(iec, ie1Send(n))
5502  jsc1 = max(jsc, js1Send(n)); jec1 = min(jec, je1Send(n))
5503  if( isc1 > iec1 .OR. jsc1 > jec1 ) cycle
5504  !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5505  do dir = 1, 8
5506  !--- get the to_pe's data domain.
5507  select case ( dir )
5508  case ( 1 ) ! eastern halo
5509  if( align2Send(n) .NE. EAST ) cycle
5510  isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5511  jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
5512  case ( 2 ) ! southeast halo
5513  isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5514  jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
5515  case ( 3 ) ! southern halo
5516  if( align2Send(n) .NE. SOUTH ) cycle
5517  isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
5518  jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
5519  case ( 4 ) ! southwest halo
5520  isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
5521  jsd = domain%list(m)%y(tNbr)%compute%begin-shalo; jed = domain%list(m)%y(tNbr)%compute%begin-1
5522  case ( 5 ) ! western halo
5523  if( align2Send(n) .NE. WEST ) cycle
5524  isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
5525  jsd = domain%list(m)%y(tNbr)%compute%begin; jed = domain%list(m)%y(tNbr)%compute%end
5526  case ( 6 ) ! northwest halo
5527  isd = domain%list(m)%x(tNbr)%compute%begin-whalo; ied = domain%list(m)%x(tNbr)%compute%begin-1
5528  jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5529  case ( 7 ) ! northern halo
5530  if( align2Send(n) .NE. NORTH ) cycle
5531  isd = domain%list(m)%x(tNbr)%compute%begin; ied = domain%list(m)%x(tNbr)%compute%end
5532  jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5533  case ( 8 ) ! northeast halo
5534  isd = domain%list(m)%x(tNbr)%compute%end+1; ied = domain%list(m)%x(tNbr)%compute%end+ehalo
5535  jsd = domain%list(m)%y(tNbr)%compute%end+1; jed = domain%list(m)%y(tNbr)%compute%end+nhalo
5536  end select
5537  isd = max(isd, is2Send(n)); ied = min(ied, ie2Send(n))
5538  jsd = max(jsd, js2Send(n)); jed = min(jed, je2Send(n))
5539  if( isd > ied .OR. jsd > jed ) cycle
5540  ioff = 0; joff = 0
5541  nxd = ied - isd + 1
5542  nyd = jed - jsd + 1
5543  select case ( align2Send(n) )
5544  case ( WEST, EAST )
5545  ioff = isd - is2Send(n)
5546  joff = jsd - js2Send(n)
5547  case ( SOUTH, NORTH )
5548  ioff = isd - is2Send(n)
5549  joff = jsd - js2Send(n)
5550  end select
5551 
5552  !--- get the index in current pe.
5553  select case ( rotateSend(n) )
5554  case ( ZERO )
5555  isc2 = is1Send(n) + ioff; iec2 = isc2 + nxd - 1
5556  jsc2 = js1Send(n) + joff; jec2 = jsc2 + nyd - 1
5557  case ( NINETY ) ! N -> W or S -> E
5558  iec2 = ie1Send(n) - joff; isc2 = iec2 - nyd + 1
5559  jsc2 = js1Send(n) + ioff; jec2 = jsc2 + nxd - 1
5560  case ( MINUS_NINETY ) ! W -> N or E -> S
5561  isc2 = is1Send(n) + joff; iec2 = isc2 + nyd - 1
5562  jec2 = je1Send(n) - ioff; jsc2 = jec2 - nxd + 1
5563  end select
5564  is = max(isc1,isc2); ie = min(iec1,iec2)
5565  js = max(jsc1,jsc2); je = min(jec1,jec2)
5566  if(ie.GE.is .AND. je.GE.js )then
5567  if(.not. associated(overlapSend(m)%tileMe)) call allocate_update_overlap(overlapSend(m), MAXOVERLAP)
5568  call insert_overlap_type(overlapSend(m), domain%list(m)%pe, tMe, tNbr, &
5569  is, ie, js, je, dir, rotateSend(n), .true. )
5570  endif
5571  end do ! end do dir = 1, 8
5572  end do ! end do tNbr = 1, ntileNbr
5573  end do ! end do list = 0, nlist-1
5574  end do ! end do n = 1, numS
5575 
5576  !--- compute the overlapping for recv.
5577  do n = 1, numR
5578  do list = 0, nlist-1
5579  m = mod( domain%pos+nlist-list, nlist )
5580  ntileNbr = size(domain%list(m)%x(:))
5581  do tNbr = 1, ntileNbr
5582  if( domain%list(m)%tile_id(tNbr) .NE. tileRecv(n) ) cycle
5583  isc = domain%list(m)%x(tNbr)%compute%begin; iec = domain%list(m)%x(tNbr)%compute%end
5584  jsc = domain%list(m)%y(tNbr)%compute%begin; jec = domain%list(m)%y(tNbr)%compute%end
5585  isc = max(isc, is2Recv(n)); iec = min(iec, ie2Recv(n))
5586  jsc = max(jsc, js2Recv(n)); jec = min(jec, je2Recv(n))
5587  if( isc > iec .OR. jsc > jec ) cycle
5588  !--- find the offset for this overlapping.
5589  ioff = 0; joff = 0
5590  nxc = iec - isc + 1; nyc = jec - jsc + 1
5591  select case ( align2Recv(n) )
5592  case ( WEST, EAST )
5593  if(align2Recv(n) == WEST) then
5594  ioff = isc - is2Recv(n)
5595  else
5596  ioff = ie2Recv(n) - iec
5597  endif
5598  joff = jsc - js2Recv(n)
5599  case ( NORTH, SOUTH )
5600  ioff = isc - is2Recv(n)
5601  if(align2Recv(n) == SOUTH) then
5602  joff = jsc - js2Recv(n)
5603  else
5604  joff = je2Recv(n) - jec
5605  endif
5606  end select
5607 
5608  !--- get the index in current pe.
5609  select case ( rotateRecv(n) )
5610  case ( ZERO )
5611  isd1 = is1Recv(n) + ioff; ied1 = isd1 + nxc - 1
5612  jsd1 = js1Recv(n) + joff; jed1 = jsd1 + nyc - 1
5613  if( align1Recv(n) == WEST ) then
5614  ied1 = ie1Recv(n)-ioff; isd1 = ied1 - nxc + 1
5615  endif
5616  if( align1Recv(n) == SOUTH ) then
5617  jed1 = je1Recv(n)-joff; jsd1 = jed1 - nyc + 1
5618  endif
5619  case ( NINETY ) ! N -> W or S -> E
5620  if( align1Recv(n) == WEST ) then
5621  ied1 = ie1Recv(n)-joff; isd1 = ied1 - nyc + 1
5622  else
5623  isd1 = is1Recv(n)+joff; ied1 = isd1 + nyc - 1
5624  endif
5625  jed1 = je1Recv(n) - ioff; jsd1 = jed1 - nxc + 1
5626  case ( MINUS_NINETY ) ! W -> N or E -> S
5627  ied1 = ie1Recv(n) - joff; isd1 = ied1 - nyc + 1
5628  if( align1Recv(n) == SOUTH ) then
5629  jed1 = je1Recv(n)-ioff; jsd1 = jed1 - nxc + 1
5630  else
5631  jsd1 = js1Recv(n)+ioff; jed1 = jsd1 + nxc - 1
5632  endif
5633  end select
5634 
5635  !--- loop over 8 direction to get the overlapping starting from east with clockwise.
5636  do dir = 1, 8
5637  select case ( dir )
5638  case ( 1 ) ! eastern halo
5639  if( align1Recv(n) .NE. EAST ) cycle
5640  isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5641  jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
5642  case ( 2 ) ! southeast halo
5643  isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5644  jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
5645  case ( 3 ) ! southern halo
5646  if( align1Recv(n) .NE. SOUTH ) cycle
5647  isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
5648  jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
5649  case ( 4 ) ! southwest halo
5650  isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
5651  jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1
5652  case ( 5 ) ! western halo
5653  if( align1Recv(n) .NE. WEST ) cycle
5654  isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
5655  jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end
5656  case ( 6 ) ! northwest halo
5657  isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1
5658  jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5659  case ( 7 ) ! northern halo
5660  if( align1Recv(n) .NE. NORTH ) cycle
5661  isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end
5662  jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5663  case ( 8 ) ! northeast halo
5664  isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end
5665  jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end
5666  end select
5667  is = max(isd1,isd2); ie = min(ied1,ied2)
5668  js = max(jsd1,jsd2); je = min(jed1,jed2)
5669  if(ie.GE.is .AND. je.GE.js )then
5670  if(.not. associated(overlapRecv(m)%tileMe)) call allocate_update_overlap(overlapRecv(m), MAXOVERLAP)
5671  call insert_overlap_type(overlapRecv(m), domain%list(m)%pe, tMe, tNbr, &
5672  is, ie, js, je, dir, rotateRecv(n), .true.)
5673  count = overlapRecv(m)%count
5674  endif
5675  end do ! end do dir = 1, 8
5676  end do ! end do tNbr = 1, ntileNbr
5677  end do ! end do list = 0, nlist-1
5678  end do ! end do n = 1, numR
5679  end do ! end do tMe = 1, ntileMe
5680 
5681  !--- copy the overlapping information into domain data
5682  nsend = 0; nsend2 = 0
5683  do list = 0, nlist-1
5684  m = mod( domain%pos+list, nlist )
5685  if(overlapSend(m)%count>0) nsend = nsend + 1
5686  enddo
5687 
5689  !--- write out send information
5690  unit = mpp_pe() + 1000
5691  do list = 0, nlist-1
5692  m = mod( domain%pos+list, nlist )
5693  if(overlapSend(m)%count==0) cycle
5694  write(unit, *) "********to_pe = " ,overlapSend(m)%pe, " count = ",overlapSend(m)%count
5695  do n = 1, overlapSend(m)%count
5696  write(unit, *) overlapSend(m)%is(n), overlapSend(m)%ie(n), overlapSend(m)%js(n), overlapSend(m)%je(n), &
5697  overlapSend(m)%dir(n), overlapSend(m)%rotation(n)
5698  enddo
5699  enddo
5700  if(nsend >0) call flush(unit)
5701  endif
5702 
5703  dirlist(1) = 1; dirlist(2) = 3; dirlist(3) = 5; dirlist(4) = 7
5704  dirlist(5) = 2; dirlist(6) = 4; dirlist(7) = 6; dirlist(8) = 8
5705 
5706  ! copy the overlap information into domain.
5707  if(nsend >0) then
5708  if(associated(domain%update_T%send)) then
5709  do m = 1, domain%update_T%nsend
5710  call deallocate_overlap_type(domain%update_T%send(m))
5711  enddo
5712  deallocate(domain%update_T%send)
5713  endif
5714  domain%update_T%nsend = nsend
5715  allocate(domain%update_T%send(nsend))
5716  do list = 0, nlist-1
5717  m = mod( domain%pos+list, nlist )
5718  ntileNbr = size(domain%list(m)%x(:))
5719  !--- for the send, the list should be in tileNbr order and dir order to be consistent with Recv
5720  if(overlapSend(m)%count > 0) then
5721  nsend2 = nsend2+1
5722  if(nsend2>nsend) call mpp_error(FATAL, &
5723  "mpp_domains_define.inc(define_contact_point): nsend2 is greater than nsend")
5724  call allocate_update_overlap(domain%update_T%send(nsend2), overlapSend(m)%count)
5725 
5726  do tNbr = 1, ntileNbr
5727  do tt = 1, ntileMe
5728  if(domain%list(m)%pe == domain%pe) then ! own processor
5729  tMe = tNbr+tt-1
5730  if(tMe > ntileMe) tMe = tMe - ntileMe
5731  else
5732  tMe = tt
5733  end if
5734  do n = 1, 8 ! loop over 8 direction
5735  do l = 1, overlapSend(m)%count
5736  if(overlapSend(m)%tileMe(l) .NE. tMe) cycle
5737  if(overlapSend(m)%tileNbr(l) .NE. tNbr) cycle
5738  if(overlapSend(m)%dir(l) .NE. dirlist(n) ) cycle
5739  call insert_overlap_type(domain%update_T%send(nsend2), overlapSend(m)%pe, &
5740  overlapSend(m)%tileMe(l), overlapSend(m)%tileNbr(l), overlapSend(m)%is(l), overlapSend(m)%ie(l), &
5741  overlapSend(m)%js(l), overlapSend(m)%je(l), overlapSend(m)%dir(l), overlapSend(m)%rotation(l), &
5742  overlapSend(m)%from_contact(l) )
5743  end do
5744  end do
5745  end do
5746  end do
5747  end if
5748  enddo
5749  endif
5750 
5751  if(nsend2 .NE. nsend) call mpp_error(FATAL, &
5752  "mpp_domains_define.inc(define_contact_point): nsend2 does not equal to nsend")
5753 
5754  nrecv = 0; nrecv2 = 0
5755  do list = 0, nlist-1
5756  m = mod( domain%pos+list, nlist )
5757  if(overlapRecv(m)%count>0) nrecv = nrecv + 1
5758  enddo
5759 
5761  do list = 0, nlist-1
5762  m = mod( domain%pos+list, nlist )
5763  if(overlapRecv(m)%count==0) cycle
5764  write(unit, *) "********from_pe = " ,overlapRecv(m)%pe, " count = ",overlapRecv(m)%count
5765  do n = 1, overlapRecv(m)%count
5766  write(unit, *) overlapRecv(m)%is(n), overlapRecv(m)%ie(n), overlapRecv(m)%js(n), overlapRecv(m)%je(n), &
5767  overlapRecv(m)%dir(n), overlapRecv(m)%rotation(n)
5768  enddo
5769  enddo
5770  if(nrecv >0) call flush(unit)
5771  endif
5772 
5773  if(nrecv >0) then
5774  if(associated(domain%update_T%recv)) then
5775  do m = 1, domain%update_T%nrecv
5776  call deallocate_overlap_type(domain%update_T%recv(m))
5777  enddo
5778  deallocate(domain%update_T%recv)
5779  endif
5780  domain%update_T%nrecv = nrecv
5781  allocate(domain%update_T%recv(nrecv))
5782 
5783  do list = 0, nlist-1
5784  m = mod( domain%pos+nlist-list, nlist )
5785  ntileNbr = size(domain%list(m)%x(:))
5786  if(overlapRecv(m)%count > 0) then
5787  nrecv2 = nrecv2 + 1
5788  if(nrecv2>nrecv) call mpp_error(FATAL, &
5789  "mpp_domains_define.inc(define_contact_point): nrecv2 is greater than nrecv")
5790  call allocate_update_overlap(domain%update_T%recv(nrecv2), overlapRecv(m)%count)
5791  do tMe = 1, ntileMe
5792  do tt = 1, ntileNbr
5793  !--- make sure the same order tile for different pe count
5794  if(domain%list(m)%pe == domain%pe) then ! own processor
5795  tNbr = tMe+tt-1
5796  if(tNbr>ntileNbr) tNbr = tNbr - ntileNbr
5797  else
5798  tNbr = tt
5799  end if
5800  do n = 1, 8 ! loop over 8 direction
5801  do l = 1, overlapRecv(m)%count
5802  if(overlapRecv(m)%tileMe(l) .NE. tMe) cycle
5803  if(overlapRecv(m)%tileNbr(l) .NE. tNbr) cycle
5804  if(overlapRecv(m)%dir(l) .NE. dirlist(n) ) cycle
5805  call insert_overlap_type(domain%update_T%recv(nrecv2), overlapRecv(m)%pe, &
5806  overlapRecv(m)%tileMe(l), overlapRecv(m)%tileNbr(l), overlapRecv(m)%is(l), overlapRecv(m)%ie(l), &
5807  overlapRecv(m)%js(l), overlapRecv(m)%je(l), overlapRecv(m)%dir(l), overlapRecv(m)%rotation(l), &
5808  overlapRecv(m)%from_contact(l))
5809  count = domain%update_T%recv(nrecv2)%count
5810  end do
5811  end do
5812  end do
5813  end do
5814  end if
5815  end do
5816  endif
5817 
5818  if(nrecv2 .NE. nrecv) call mpp_error(FATAL, &
5819  "mpp_domains_define.inc(define_contact_point): nrecv2 does not equal to nrecv")
5820 
5821  do m = 0,nlist-1
5822  call deallocate_overlap_type(overlapSend(m))
5823  call deallocate_overlap_type(overlapRecv(m))
5824  enddo
5825  !--- release memory
5826  do n = 1, ntiles
5827  deallocate(eCont(n)%tile, wCont(n)%tile, sCont(n)%tile, nCont(n)%tile )
5828  deallocate(eCont(n)%align1, wCont(n)%align1, sCont(n)%align1, nCont(n)%align1)
5829  deallocate(eCont(n)%align2, wCont(n)%align2, sCont(n)%align2, nCont(n)%align2)
5830  deallocate(eCont(n)%refine1, wCont(n)%refine1, sCont(n)%refine1, nCont(n)%refine1)
5831  deallocate(eCont(n)%refine2, wCont(n)%refine2, sCont(n)%refine2, nCont(n)%refine2)
5832  deallocate(eCont(n)%is1, eCont(n)%ie1, eCont(n)%js1, eCont(n)%je1 )
5833  deallocate(eCont(n)%is2, eCont(n)%ie2, eCont(n)%js2, eCont(n)%je2 )
5834  deallocate(wCont(n)%is1, wCont(n)%ie1, wCont(n)%js1, wCont(n)%je1 )
5835  deallocate(wCont(n)%is2, wCont(n)%ie2, wCont(n)%js2, wCont(n)%je2 )
5836  deallocate(sCont(n)%is1, sCont(n)%ie1, sCont(n)%js1, sCont(n)%je1 )
5837  deallocate(sCont(n)%is2, sCont(n)%ie2, sCont(n)%js2, sCont(n)%je2 )
5838  deallocate(nCont(n)%is1, nCont(n)%ie1, nCont(n)%js1, nCont(n)%je1 )
5839  deallocate(nCont(n)%is2, nCont(n)%ie2, nCont(n)%js2, nCont(n)%je2 )
5840  end do
5841 
5842  domain%initialized = .true.
5843 
5844 
5845  end subroutine define_contact_point
5846 
5847 !##############################################################################
5848 !--- always fill the contact according to index order.
5849 subroutine fill_contact(Contact, tile, is1, ie1, js1, je1, is2, ie2, js2, je2, align1, align2, refine1, refine2 )
5850  type(contact_type), intent(inout) :: Contact
5851  integer, intent(in) :: tile
5852  integer, intent(in) :: is1, ie1, js1, je1
5853  integer, intent(in) :: is2, ie2, js2, je2
5854  integer, intent(in) :: align1, align2
5855  real, intent(in) :: refine1, refine2
5856  integer :: pos, n
5857 
5858  do pos = 1, Contact%ncontact
5859  select case(align1)
5860  case(WEST, EAST)
5861  if( js1 < Contact%js1(pos) ) exit
5862  case(SOUTH, NORTH)
5863  if( is1 < Contact%is1(pos) ) exit
5864  end select
5865  end do
5866 
5867  Contact%ncontact = Contact%ncontact + 1
5868  do n = Contact%ncontact, pos+1, -1 ! shift the data if needed.
5869  Contact%tile(n) = Contact%tile(n-1)
5870  Contact%align1(n) = Contact%align1(n-1)
5871  Contact%align2(n) = Contact%align2(n-1)
5872  Contact%is1(n) = Contact%is1(n-1); Contact%ie1(n) = Contact%ie1(n-1)
5873  Contact%js1(n) = Contact%js1(n-1); Contact%je1(n) = Contact%je1(n-1)
5874  Contact%is2(n) = Contact%is2(n-1); Contact%ie2(n) = Contact%ie2(n-1)
5875  Contact%js2(n) = Contact%js2(n-1); Contact%je2(n) = Contact%je2(n-1)
5876  end do
5877 
5878  Contact%tile(pos) = tile
5879  Contact%align1(pos) = align1
5880  Contact%align2(pos) = align2
5881  Contact%refine1(pos) = refine1
5882  Contact%refine2(pos) = refine2
5883  Contact%is1(pos) = is1; Contact%ie1(pos) = ie1
5884  Contact%js1(pos) = js1; Contact%je1(pos) = je1
5885  Contact%is2(pos) = is2; Contact%ie2(pos) = ie2
5886  Contact%js2(pos) = js2; Contact%je2(pos) = je2
5887 
5888 end subroutine fill_contact
5889 
5890 !############################################################################
5891 ! this routine sets the overlapping between tiles for E,C,N-cell based on T-cell overlapping
5892 subroutine set_contact_point(domain, position)
5893  type(domain2d), intent(inout) :: domain
5894  integer, intent(in) :: position
5895 
5896  integer :: ishift, jshift, nlist, list, m, n
5897  integer :: ntileMe, tMe, dir, count, pos, nsend, nrecv
5898  integer :: isoff1, ieoff1, isoff2, ieoff2, jsoff1, jeoff1, jsoff2, jeoff2
5899  type(overlap_type), pointer :: ptrIn => NULL()
5900  type(overlapSpec), pointer :: update_in => NULL()
5901  type(overlapSpec), pointer :: update_out => NULL()
5902  type(overlap_type) :: overlapList(0:size(domain%list(:))-1)
5903  type(overlap_type) :: overlap
5904 
5905  call mpp_get_domain_shift(domain, ishift, jshift, position)
5906  update_in => domain%update_T
5907  select case(position)
5908  case (CORNER)
5909  update_out => domain%update_C
5910  case (EAST)
5911  update_out => domain%update_E
5912  case (NORTH)
5913  update_out => domain%update_N
5914  case default
5915  call mpp_error(FATAL, "mpp_domains_define.inc(set_contact_point): the position should be CORNER, EAST or NORTH")
5916  end select
5917 
5918  update_out%xbegin = update_in%xbegin; update_out%xend = update_in%xend + ishift
5919  update_out%ybegin = update_in%ybegin; update_out%yend = update_in%yend + jshift
5920  update_out%whalo = update_in%whalo; update_out%ehalo = update_in%ehalo
5921  update_out%shalo = update_in%shalo; update_out%nhalo = update_in%nhalo
5922 
5923  nlist = size(domain%list(:))
5924  ntileMe = size(domain%x(:))
5925  call allocate_update_overlap(overlap, MAXOVERLAP)
5926  do m = 0, nlist-1
5927  call init_overlap_type(overlapList(m))
5928  enddo
5929 
5930  !--- first copy the send information in update_out to send
5931  nsend = update_out%nsend
5932  do m = 1, nsend
5933  pos = update_out%send(m)%pe - mpp_root_pe()
5934  call add_update_overlap(overlapList(pos), update_out%send(m))
5935  call deallocate_overlap_type(update_out%send(m))
5936  enddo
5937  if(ASSOCIATED(update_out%send) )deallocate(update_out%send)
5938 
5939  !--- loop over the list of overlapping.
5940  nsend = update_in%nsend
5941  do m = 1, nsend
5942  ptrIn => update_in%send(m)
5943  pos = PtrIn%pe - mpp_root_pe()
5944  do n = 1, ptrIn%count
5945  dir = ptrIn%dir(n)
5946  ! only set overlapping between tiles for send ( ptrOut%overlap(1) is false )
5947  if(ptrIn%from_contact(n)) then
5948  select case ( dir )
5949  case ( 1 ) ! to_pe's eastern halo
5950  select case(ptrIn%rotation(n))
5951  case (ZERO) ! W -> E
5952  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
5953  case (NINETY) ! S -> E
5954  isoff1 = 0; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5955  end select
5956  case ( 2 ) ! to_pe's south-eastearn halo
5957  select case(ptrIn%rotation(n))
5958  case (ZERO)
5959  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
5960  case (NINETY)
5961  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5962  case (MINUS_NINETY)
5963  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5964  end select
5965  case ( 3 ) ! to_pe's southern halo
5966  select case(ptrIn%rotation(n))
5967  case (ZERO) ! N -> S
5968  isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
5969  case (MiNUS_NINETY) ! E -> S
5970  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = ishift
5971  end select
5972  case ( 4 ) ! to_pe's south-westearn halo
5973  select case(ptrIn%rotation(n))
5974  case (ZERO)
5975  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5976  case (NINETY)
5977  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
5978  case (MINUS_NINETY)
5979  isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
5980  end select
5981  case ( 5 ) ! to_pe's western halo
5982  select case(ptrIn%rotation(n))
5983  case (ZERO) ! E -> W
5984  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
5985  case (NINETY) ! N -> W
5986  isoff1 = 0; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
5987  end select
5988  case ( 6 ) ! to_pe's north-westearn halo
5989  select case(ptrIn%rotation(n))
5990  case (ZERO)
5991  isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
5992  case (NINETY)
5993  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
5994  case (MINUS_NINETY)
5995  isoff1 = jshift; ieoff1 = jshift; jsoff1 = ishift; jeoff1 = ishift
5996  end select
5997  case ( 7 ) ! to_pe's northern halo
5998  select case(ptrIn%rotation(n))
5999  case (ZERO) ! S -> N
6000  isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6001  case (MINUS_NINETY) ! W -> N
6002  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = ishift
6003  end select
6004  case ( 8 ) ! to_pe's north-eastearn halo
6005  select case(ptrIn%rotation(n))
6006  case (ZERO)
6007  isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6008  case (NINETY)
6009  isoff1 = 0; ieoff1 = 0; jsoff1 = ishift; jeoff1 = ishift
6010  case (MINUS_NINETY)
6011  isoff1 = jshift; ieoff1 = jshift; jsoff1 = 0; jeoff1 = 0
6012  end select
6013  end select
6014  call insert_overlap_type(overlap, PtrIn%pe, PtrIn%tileMe(n), PtrIn%tileNbr(n), &
6015  Ptrin%is(n) + isoff1, Ptrin%ie(n) + ieoff1, Ptrin%js(n) + jsoff1, &
6016  Ptrin%je(n) + jeoff1, PtrIn%dir(n), PtrIn%rotation(n), PtrIn%from_contact(n))
6017  end if
6018  end do ! do n = 1, prtIn%count
6019  if(overlap%count > 0) then
6020  call add_update_overlap(overlapList(pos), overlap)
6021  call init_overlap_type(overlap)
6022  endif
6023  end do ! do list = 0, nlist-1
6024 
6025  nsend = 0
6026  do list = 0, nlist-1
6027  m = mod( domain%pos+list, nlist )
6028  if(overlapList(m)%count>0) nsend = nsend+1
6029  enddo
6030 
6031  update_out%nsend = nsend
6032  if(nsend>0) then
6033  allocate(update_out%send(nsend))
6034  pos = 0
6035  do list = 0, nlist-1
6036  m = mod( domain%pos+list, nlist )
6037  if(overlapList(m)%count>0) then
6038  pos = pos+1
6039  if(pos>nsend) call mpp_error(FATAL, &
6040  "mpp_domains_define.inc(set_contact_point): pos should be no larger than nsend")
6041  call add_update_overlap(update_out%send(pos), overlapList(m))
6042  call deallocate_overlap_type(overlapList(m))
6043  endif
6044  enddo
6045  if(pos .NE. nsend) call mpp_error(FATAL, &
6046  "mpp_domains_define.inc(set_contact_point): pos should equal to nsend")
6047  endif
6048 
6049 
6050 
6051  !--- first copy the recv information in update_out to recv
6052  nrecv = update_out%nrecv
6053  do m = 1, nrecv
6054  pos = update_out%recv(m)%pe - mpp_root_pe()
6055  call add_update_overlap(overlapList(pos), update_out%recv(m))
6056  call deallocate_overlap_type(update_out%recv(m))
6057  enddo
6058  if(ASSOCIATED(update_out%recv) )deallocate(update_out%recv)
6059 
6060  !--- loop over the list of overlapping.
6061  nrecv = update_in%nrecv
6062  do m=1,nrecv
6063  ptrIn => update_in%recv(m)
6064  pos = PtrIn%pe - mpp_root_pe()
6065  do n = 1, ptrIn%count
6066  dir = ptrIn%dir(n)
6067  ! only set overlapping between tiles for recv ( ptrOut%overlap(1) is false )
6068  if(ptrIn%from_contact(n)) then
6069  select case ( dir )
6070  case ( 1 ) ! E
6071  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = jshift
6072  case ( 2 ) ! SE
6073  isoff1 = ishift; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6074  case ( 3 ) ! S
6075  isoff1 = 0; ieoff1 = ishift; jsoff1 = 0; jeoff1 = 0
6076  case ( 4 ) ! SW
6077  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = 0
6078  case ( 5 ) ! W
6079  isoff1 = 0; ieoff1 = 0; jsoff1 = 0; jeoff1 = jshift
6080  case ( 6 ) ! NW
6081  isoff1 = 0; ieoff1 = 0; jsoff1 = jshift; jeoff1 = jshift
6082  case ( 7 ) ! N
6083  isoff1 = 0; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
6084  case ( 8 ) ! NE
6085  isoff1 = ishift; ieoff1 = ishift; jsoff1 = jshift; jeoff1 = jshift
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  count = overlap%count
6091  end if
6092  end do ! do n = 1, ptrIn%count
6093  if(overlap%count > 0) then
6094  call add_update_overlap(overlapList(pos), overlap)
6095  call init_overlap_type(overlap)
6096  endif
6097  do tMe = 1, size(domain%x(:))
6098  do n = 1, overlap%count
6099  if(overlap%tileMe(n) == tMe) then
6100  if(overlap%dir(n) == 1 ) domain%x(tMe)%loffset = 0
6101  if(overlap%dir(n) == 7 ) domain%y(tMe)%loffset = 0
6102  end if
6103  end do
6104  end do
6105  end do ! do list = 0, nlist-1
6106 
6107  nrecv = 0
6108  do list = 0, nlist-1
6109  m = mod( domain%pos+nlist-list, nlist )
6110  if(overlapList(m)%count>0) nrecv = nrecv+1
6111  enddo
6112 
6113  update_out%nrecv = nrecv
6114  if(nrecv>0) then
6115  allocate(update_out%recv(nrecv))
6116  pos = 0
6117  do list = 0, nlist-1
6118  m = mod( domain%pos+nlist-list, nlist )
6119  if(overlapList(m)%count>0) then
6120  pos = pos+1
6121  if(pos>nrecv) call mpp_error(FATAL, &
6122  "mpp_domains_define.inc(set_contact_point): pos should be no larger than nrecv")
6123  call add_update_overlap(update_out%recv(pos), overlapList(m))
6124  call deallocate_overlap_type(overlapList(m))
6125  endif
6126  enddo
6127  if(pos .NE. nrecv) call mpp_error(FATAL, &
6128  "mpp_domains_define.inc(set_contact_point): pos should equal to nrecv")
6129  endif
6130 
6131  call deallocate_overlap_type(overlap)
6132 
6133 end subroutine set_contact_point
6134 
6135 !--- set up the overlapping for boundary check if the domain is symmetry. The check will be
6136 !--- done on current pe for east boundary for E-cell, north boundary for N-cell,
6137 !--- East and North boundary for C-cell
6138 subroutine set_check_overlap( domain, position )
6139 type(domain2d), intent(in) :: domain
6140 integer, intent(in) :: position
6141 integer :: nlist, m, n
6142 integer, parameter :: MAXCOUNT = 100
6143 integer :: is, ie, js, je
6144 integer :: nsend, nrecv, pos, maxsize, rotation
6145 type(overlap_type) :: overlap
6146 type(overlapSpec), pointer :: update => NULL()
6147 type(overlapSpec), pointer :: check => NULL()
6148 
6149 select case(position)
6150 case (CORNER)
6151  update => domain%update_C
6152  check => domain%check_C
6153 case (EAST)
6154  update => domain%update_E
6155  check => domain%check_E
6156 case (NORTH)
6157  update => domain%update_N
6158  check => domain%check_N
6159 case default
6160  call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): position should be CORNER, EAST or NORTH")
6161 end select
6162 
6163 check%xbegin = update%xbegin; check%xend = update%xend
6164 check%ybegin = update%ybegin; check%yend = update%yend
6165 check%nsend = 0
6166 check%nrecv = 0
6167 if( .NOT. domain%symmetry ) return
6168 
6169 nsend = 0
6170 maxsize = 0
6171 do m = 1, update%nsend
6172  do n = 1, update%send(m)%count
6173  if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6174  if( ( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) .OR. &
6175  ( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) ) then
6176  maxsize = max(maxsize, update%send(m)%count)
6177  nsend = nsend + 1
6178  exit
6179  endif
6180  enddo
6181 enddo
6182 
6183 if(nsend>0) then
6184  allocate(check%send(nsend))
6185  call allocate_check_overlap(overlap, maxsize)
6186 endif
6187 
6188 
6189 nlist = size(domain%list(:))
6190 !--- loop over the list of domains to find the boundary overlap for send
6191 pos = 0
6192 do m = 1, update%nsend
6193  do n = 1, update%send(m)%count
6194  if( update%send(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6195  ! comparing east direction on currently pe
6196  if( (position == EAST .OR. position == CORNER) .AND. update%send(m)%dir(n) == 1 ) then
6197  rotation = update%send(m)%rotation(n)
6198  select case( rotation )
6199  case( ZERO ) ! W -> E
6200  is = update%send(m)%is(n) - 1
6201  ie = is
6202  js = update%send(m)%js(n)
6203  je = update%send(m)%je(n)
6204  case( NINETY ) ! S -> E
6205  is = update%send(m)%is(n)
6206  ie = update%send(m)%ie(n)
6207  js = update%send(m)%js(n) - 1
6208  je = js
6209  end select
6210  call insert_check_overlap(overlap, update%send(m)%pe, &
6211  update%send(m)%tileMe(n), 1, rotation, is, ie, js, je)
6212  end if
6213 
6214  ! comparing north direction on currently pe
6215  if( (position == NORTH .OR. position == CORNER) .AND. update%send(m)%dir(n) == 7 ) then
6216  rotation = update%send(m)%rotation(n)
6217  select case( rotation )
6218  case( ZERO ) ! S->N
6219  is = update%send(m)%is(n)
6220  ie = update%send(m)%ie(n)
6221  js = update%send(m)%js(n) - 1
6222  je = js
6223  case( MINUS_NINETY ) ! W->N
6224  is = update%send(m)%is(n) - 1
6225  ie = is
6226  js = update%send(m)%js(n)
6227  je = update%send(m)%je(n)
6228  end select
6229  call insert_check_overlap(overlap, update%send(m)%pe, &
6230  update%send(m)%tileMe(n), 4, rotation, is, ie, js, je)
6231  end if
6232  end do ! do n =1, update%send(m)%count
6233  if(overlap%count>0) then
6234  pos = pos+1
6235  if(pos>nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6236  call add_check_overlap(check%send(pos), overlap)
6237  call init_overlap_type(overlap)
6238  endif
6239 end do ! end do list = 0, nlist
6240 
6241 if(pos .NE. nsend)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nsend")
6242 
6243 nrecv = 0
6244 maxsize = 0
6245 do m = 1, update%nrecv
6246  do n = 1, update%recv(m)%count
6247  if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6248  if( ( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) .OR. &
6249  ( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) ) then
6250  maxsize = max(maxsize, update%recv(m)%count)
6251  nrecv = nrecv + 1
6252  exit
6253  endif
6254  enddo
6255 enddo
6256 
6257 if(nsend>0) call deallocate_overlap_type(overlap)
6258 
6259 if(nrecv>0) then
6260  allocate(check%recv(nrecv))
6261  call allocate_check_overlap(overlap, maxsize)
6262 endif
6263 
6264 pos = 0
6265 do m = 1, update%nrecv
6266  do n = 1, update%recv(m)%count
6267  if( update%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6268  if( (position == EAST .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 1 ) then
6269  is = update%recv(m)%is(n) - 1
6270  ie = is
6271  js = update%recv(m)%js(n)
6272  je = update%recv(m)%je(n)
6273  call insert_check_overlap(overlap, update%recv(m)%pe, &
6274  update%recv(m)%tileMe(n), 1, update%recv(m)%rotation(n), is, ie, js, je)
6275  end if
6276  if( (position == NORTH .OR. position == CORNER) .AND. update%recv(m)%dir(n) == 7 ) then
6277  is = update%recv(m)%is(n)
6278  ie = update%recv(m)%ie(n)
6279  js = update%recv(m)%js(n) - 1
6280  je = js
6281  call insert_check_overlap(overlap, update%recv(m)%pe, &
6282  update%recv(m)%tileMe(n), 3, update%recv(m)%rotation(n), is, ie, js, je)
6283  end if
6284  end do ! n = 1, overlap%count
6285  if(overlap%count>0) then
6286  pos = pos+1
6287  if(pos>nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6288  call add_check_overlap(check%recv(pos), overlap)
6289  call init_overlap_type(overlap)
6290  endif
6291 end do ! end do list = 0, nlist
6292 
6293 if(pos .NE. nrecv)call mpp_error(FATAL, "mpp_domains_define.inc(set_check_overlap): pos is greater than nrecv")
6294 if(nrecv>0) call deallocate_overlap_type(overlap)
6295 
6296 end subroutine set_check_overlap
6297 
6298 !#############################################################################
6299 !--- set up the overlapping for boundary if the domain is symmetry.
6300 subroutine set_bound_overlap( domain, position )
6301  type(domain2d), intent(inout) :: domain
6302  integer, intent(in) :: position
6303  integer :: m, n, l, count, dr, tMe, i
6304  integer, parameter :: MAXCOUNT = 100
6305  integer, dimension(MAXCOUNT) :: dir, rotation, is, ie, js, je, tileMe, index
6306  integer, dimension(size(domain%x(:)), 4) :: nrecvl
6307  integer, dimension(size(domain%x(:)), 4, MAXCOUNT) :: isl, iel, jsl, jel
6308  type(overlap_type), pointer :: overlap => NULL()
6309  type(overlapSpec), pointer :: update => NULL()
6310  type(overlapSpec), pointer :: bound => NULL()
6311  integer :: nlist_send, nlist_recv, ishift, jshift
6312  integer :: ism, iem, jsm, jem, nsend, nrecv
6313  integer :: isg, ieg, jsg, jeg, nlist, list
6314 ! integer :: isc1, iec1, jsc1, jec1
6315 ! integer :: isc2, iec2, jsc2, jec2
6316  integer :: isd, ied, jsd, jed
6317  integer :: npes_x, npes_y, ipos, jpos, inbr, jnbr
6318  integer :: isc, iec, jsc, jec, my_pe
6319  integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2
6320  integer :: is_south1, ie_south1, js_south1, je_south1
6321  integer :: is_south2, ie_south2, js_south2, je_south2
6322  integer :: is_west0, ie_west0, js_west0, je_west0
6323  integer :: is_west1, ie_west1, js_west1, je_west1
6324  integer :: is_west2, ie_west2, js_west2, je_west2
6325  logical :: x_cyclic, y_cyclic, folded_north
6326 
6327  is_south1=0; ie_south1=0; js_south1=0; je_south1=0
6328  is_south2=0; ie_south2=0; js_south2=0; je_south2=0
6329  is_west0=0; ie_west0=0; js_west0=0; je_west0=0
6330  is_west1=0; ie_west1=0; js_west1=0; je_west1=0
6331  is_west2=0; ie_west2=0; js_west2=0; je_west2=0
6332 
6333 
6334  if( position == CENTER .OR. .NOT. domain%symmetry ) return
6335  call mpp_get_domain_shift(domain, ishift, jshift, position)
6336  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
6337  call mpp_get_memory_domain ( domain, ism, iem, jsm, jem )
6338 
6339  select case(position)
6340  case (CORNER)
6341  update => domain%update_C
6342  bound => domain%bound_C
6343  case (EAST)
6344  update => domain%update_E
6345  bound => domain%bound_E
6346  case (NORTH)
6347  update => domain%update_N
6348  bound => domain%bound_N
6349  case default
6350  call mpp_error( FATAL, "mpp_domains_mod(set_bound_overlap): invalid option of position")
6351  end select
6352 
6353  bound%xbegin = ism; bound%xend = iem + ishift
6354  bound%ybegin = jsm; bound%yend = jem + jshift
6355 
6356  nlist_send = max(update%nsend,4)
6357  nlist_recv = max(update%nrecv,4)
6358  bound%nsend = nlist_send
6359  bound%nrecv = nlist_recv
6360  if(nlist_send >0) then
6361  allocate(bound%send(nlist_send))
6362  bound%send(:)%count = 0
6363  endif
6364  if(nlist_recv >0) then
6365  allocate(bound%recv(nlist_recv))
6366  bound%recv(:)%count = 0
6367  endif
6368  !--- loop over the list of domains to find the boundary overlap for send
6369  nlist = size(domain%list(:))
6370 
6371  npes_x = size(domain%x(1)%list(:))
6372  npes_y = size(domain%y(1)%list(:))
6373  x_cyclic = domain%x(1)%cyclic
6374  y_cyclic = domain%y(1)%cyclic
6375  folded_north = BTEST(domain%fold,NORTH)
6376  ipos = domain%x(1)%pos
6377  jpos = domain%y(1)%pos
6378  isc = domain%x(1)%compute%begin; iec = domain%x(1)%compute%end
6379  jsc = domain%y(1)%compute%begin; jec = domain%y(1)%compute%end
6380 
6381  nsend = 0
6382  if(domain%ntiles == 1) then ! use neighbor processor to configure send and recv
6383  ! currently only set up for west and south boundary
6384 
6385  ! south boundary for send
6386  pe_south1 = NULL_PE; pe_south2 = NULL_PE
6387  if( position == NORTH .OR. position == CORNER ) then
6388  inbr = ipos; jnbr = jpos + 1
6389  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6390  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6391  pe_south1 = domain%pearray(inbr,jnbr)
6392  is_south1 = isc + ishift; ie_south1 = iec+ishift
6393  js_south1 = jec + jshift; je_south1 = js_south1
6394  endif
6395  endif
6396  !--- send to the southwest processor when position is NORTH
6397  if( position == CORNER ) then
6398  inbr = ipos + 1; jnbr = jpos + 1
6399  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6400  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6401  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6402  pe_south2 = domain%pearray(inbr,jnbr)
6403  is_south2 = iec + ishift; ie_south2 = is_south2
6404  js_south2 = jec + jshift; je_south2 = js_south2
6405  endif
6406  endif
6407 
6408  !---west boundary for send
6409  pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6410  if( position == EAST ) then
6411  inbr = ipos+1; jnbr = jpos
6412  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6413  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6414  pe_west1 = domain%pearray(inbr,jnbr)
6415  is_west1 = iec + ishift; ie_west1 = is_west1
6416  js_west1 = jsc + jshift; je_west1 = jec + jshift
6417  endif
6418  else if ( position == CORNER ) then ! possible split into two parts.
6419  !--- on the fold.
6420  if( folded_north .AND. jec == jeg .AND. ipos .LT. (npes_x-1)/2 ) then
6421  inbr = npes_x - ipos - 1; jnbr = jpos
6422  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6423  pe_west0 = domain%pearray(inbr,jnbr)
6424  is_west0 = iec+ishift; ie_west0 = is_west0
6425  js_west0 = jec+jshift; je_west0 = js_west0
6426  endif
6427  endif
6428 
6429  if( folded_north .AND. jec == jeg .AND. ipos .GE. npes_x/2 .AND. ipos .LT. (npes_x-1) ) then
6430  inbr = ipos+1; jnbr = jpos
6431  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6432  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6433  pe_west1 = domain%pearray(inbr,jnbr)
6434  is_west1 = iec + ishift; ie_west1 = is_west1
6435  js_west1 = jsc + jshift; je_west1 = jec
6436  endif
6437  else
6438  inbr = ipos+1; jnbr = jpos
6439  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6440  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6441  pe_west1 = domain%pearray(inbr,jnbr)
6442  is_west1 = iec + ishift; ie_west1 = is_west1
6443  js_west1 = jsc + jshift; je_west1 = jec + jshift
6444  endif
6445  endif
6446  endif
6447  !--- send to the southwest processor when position is NORTH
6448  if( position == CORNER ) then
6449  inbr = ipos + 1; jnbr = jpos + 1
6450  if( inbr == npes_x .AND. x_cyclic) inbr = 0
6451  if( jnbr == npes_y .AND. y_cyclic) jnbr = 0
6452  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6453  pe_west2 = domain%pearray(inbr,jnbr)
6454  is_west2 = iec + ishift; ie_west2 = is_west2
6455  js_west2 = jec + jshift; je_west2 = js_west2
6456  endif
6457  endif
6458 
6459 !write(1000+mpp_pe(),*)"send south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
6460 !write(1000+mpp_pe(),*)"send south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
6461 !write(1000+mpp_pe(),*)"send west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
6462 !write(1000+mpp_pe(),*)"send west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
6463 !write(1000+mpp_pe(),*)"send west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
6464 
6465 
6466  do list = 0,nlist-1
6467  m = mod( domain%pos+list, nlist )
6468  count = 0
6469  my_pe = domain%list(m)%pe
6470  if(my_pe == pe_south1) then
6471  count = count + 1
6472  is(count) = is_south1; ie(count) = ie_south1
6473  js(count) = js_south1; je(count) = je_south1
6474  dir(count) = 2
6475  rotation(count) = ZERO
6476  endif
6477  if(my_pe == pe_south2) then
6478  count = count + 1
6479  is(count) = is_south2; ie(count) = ie_south2
6480  js(count) = js_south2; je(count) = je_south2
6481  dir(count) = 2
6482  rotation(count) = ZERO
6483  endif
6484 
6485  if(my_pe == pe_west0) then
6486  count = count + 1
6487  is(count) = is_west0; ie(count) = ie_west0
6488  js(count) = js_west0; je(count) = je_west0
6489  dir(count) = 3
6490  rotation(count) = ONE_HUNDRED_EIGHTY
6491  endif
6492  if(my_pe == pe_west1) then
6493  count = count + 1
6494  is(count) = is_west1; ie(count) = ie_west1
6495  js(count) = js_west1; je(count) = je_west1
6496  dir(count) = 3
6497  rotation(count) = ZERO
6498  endif
6499  if(my_pe == pe_west2) then
6500  count = count + 1
6501  is(count) = is_west2; ie(count) = ie_west2
6502  js(count) = js_west2; je(count) = je_west2
6503  dir(count) = 3
6504  rotation(count) = ZERO
6505  endif
6506 
6507  if(count >0) then
6508  nsend = nsend + 1
6509  if(nsend > nlist_send) call mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send")
6510  bound%send(nsend)%count = count
6511  bound%send(nsend)%pe = my_pe
6512  allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6513  allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6514  allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6515  allocate(bound%send(nsend)%tileMe(count))
6516  bound%send(nsend)%is(:) = is(1:count)
6517  bound%send(nsend)%ie(:) = ie(1:count)
6518  bound%send(nsend)%js(:) = js(1:count)
6519  bound%send(nsend)%je(:) = je(1:count)
6520  bound%send(nsend)%dir(:) = dir(1:count)
6521  bound%send(nsend)%tileMe(:) = 1
6522  bound%send(nsend)%rotation(:) = rotation(1:count)
6523 !write(1000+mpp_pe(),*) "send:", count, my_pe
6524 !do i = 1, count
6525 ! write(1000+mpp_pe(),*) "send index:", is(i), ie(i), js(i), je(i), dir(i), rotation(i)
6526 !enddo
6527  endif
6528  enddo
6529  else
6530  !--- The following did not consider wide halo case.
6531  do m = 1, update%nsend
6532  overlap => update%send(m)
6533  if( overlap%count == 0 ) cycle
6534  count = 0
6535  do n = 1, overlap%count
6536  !--- currently not support folded-north
6537  if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6538  if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
6539  count=count+1
6540  dir(count) = 1
6541  rotation(count) = overlap%rotation(n)
6542  tileMe(count) = overlap%tileMe(n)
6543  select case( rotation(count) )
6544  case( ZERO ) ! W -> E
6545  is(count) = overlap%is(n) - 1
6546  ie(count) = is(count)
6547  js(count) = overlap%js(n)
6548  je(count) = overlap%je(n)
6549  case( NINETY ) ! S -> E
6550  is(count) = overlap%is(n)
6551  ie(count) = overlap%ie(n)
6552  js(count) = overlap%js(n) - 1
6553  je(count) = js(count)
6554  end select
6555  end if
6556  if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3 ) then ! south
6557  count=count+1
6558  dir(count) = 2
6559  rotation(count) = overlap%rotation(n)
6560  tileMe(count) = overlap%tileMe(n)
6561  select case( rotation(count) )
6562  case( ZERO ) ! N->S
6563  is(count) = overlap%is(n)
6564  ie(count) = overlap%ie(n)
6565  js(count) = overlap%je(n) + 1
6566  je(count) = js(count)
6567  case( MINUS_NINETY ) ! E->S
6568  is(count) = overlap%ie(n) + 1
6569  ie(count) = is(count)
6570  js(count) = overlap%js(n)
6571  je(count) = overlap%je(n)
6572  end select
6573  end if
6574  if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5 ) then ! west
6575  count=count+1
6576  dir(count) = 3
6577  rotation(count) = overlap%rotation(n)
6578  tileMe(count) = overlap%tileMe(n)
6579  select case( rotation(count) )
6580  case( ZERO ) ! E->W
6581  is(count) = overlap%ie(n) + 1
6582  ie(count) = is(count)
6583  js(count) = overlap%js(n)
6584  je(count) = overlap%je(n)
6585  case( NINETY ) ! N->W
6586  is(count) = overlap%is(n)
6587  ie(count) = overlap%ie(n)
6588  js(count) = overlap%je(n) + 1
6589  je(count) = js(count)
6590  end select
6591  end if
6592  if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7 ) then ! north
6593  count=count+1
6594  dir(count) = 4
6595  rotation(count) = overlap%rotation(n)
6596  tileMe(count) = overlap%tileMe(n)
6597  select case( rotation(count) )
6598  case( ZERO ) ! S->N
6599  is(count) = overlap%is(n)
6600  ie(count) = overlap%ie(n)
6601  js(count) = overlap%js(n) - 1
6602  je(count) = js(count)
6603  case( MINUS_NINETY ) ! W->N
6604  is(count) = overlap%is(n) - 1
6605  ie(count) = is(count)
6606  js(count) = overlap%js(n)
6607  je(count) = overlap%je(n)
6608  end select
6609  end if
6610  end do ! do n =1, overlap%count
6611  if(count>0) then
6612  nsend = nsend + 1
6613  bound%send(nsend)%count = count
6614  bound%send(nsend)%pe = overlap%pe
6615  allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) )
6616  allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) )
6617  allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) )
6618  allocate(bound%send(nsend)%tileMe(count))
6619  bound%send(nsend)%is(:) = is(1:count)
6620  bound%send(nsend)%ie(:) = ie(1:count)
6621  bound%send(nsend)%js(:) = js(1:count)
6622  bound%send(nsend)%je(:) = je(1:count)
6623  bound%send(nsend)%dir(:) = dir(1:count)
6624  bound%send(nsend)%tileMe(:) = tileMe(1:count)
6625  bound%send(nsend)%rotation(:) = rotation(1:count)
6626  end if
6627  end do ! end do list = 0, nlist
6628  endif
6629 
6630  !--- loop over the list of domains to find the boundary overlap for recv
6631  bound%nsend = nsend
6632  nrecvl(:,:) = 0
6633  nrecv = 0
6634 
6635  !--- will computing overlap for tripolar grid.
6636  if( domain%ntiles == 1 ) then
6637  ! currently only set up for west and south boundary
6638 
6639  ! south boundary for recv
6640  pe_south1 = NULL_PE; pe_south2 = NULL_PE
6641  if( position == NORTH .OR. position == CORNER ) then
6642  inbr = ipos; jnbr = jpos - 1
6643  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6644  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6645  pe_south1 = domain%pearray(inbr,jnbr)
6646  is_south1 = isc + ishift; ie_south1 = iec+ishift
6647  js_south1 = jsc; je_south1 = js_south1
6648  endif
6649  endif
6650 
6651  !--- south boudary for recv: the southwest point when position is NORTH
6652  if( position == CORNER ) then
6653  inbr = ipos - 1; jnbr = jpos - 1
6654  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6655  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y-1
6656  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6657  pe_south2 = domain%pearray(inbr,jnbr)
6658  is_south2 = isc; ie_south2 = is_south2
6659  js_south2 = jsc; je_south2 = js_south2
6660  endif
6661  endif
6662 
6663 
6664  !---west boundary for recv
6665  pe_west0 = NULL_PE; pe_west1 = NULL_PE; pe_west2 = NULL_PE
6666  if( position == EAST ) then
6667  inbr = ipos-1; jnbr = jpos
6668  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6669  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6670  pe_west1 = domain%pearray(inbr,jnbr)
6671  is_west1 = isc; ie_west1 = is_west1
6672  js_west1 = jsc + jshift; je_west1 = jec + jshift
6673  endif
6674  else if ( position == CORNER ) then ! possible split into two parts.
6675  !--- on the fold.
6676  if( folded_north .AND. jec == jeg .AND. ipos .GT. npes_x/2 ) then
6677  inbr = npes_x - ipos - 1; jnbr = jpos
6678  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6679  pe_west0 = domain%pearray(inbr,jnbr)
6680  is_west0 = isc; ie_west0 = is_west0
6681  js_west0 = jec+jshift; je_west0 = js_west0
6682  endif
6683  inbr = ipos-1; jnbr = jpos
6684  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6685  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6686  pe_west1 = domain%pearray(inbr,jnbr)
6687  is_west1 = isc; ie_west1 = is_west1
6688  js_west1 = jsc + jshift; je_west1 = jec
6689  endif
6690  else
6691  inbr = ipos-1; jnbr = jpos
6692  if( inbr == -1 .AND. x_cyclic) inbr = npes_x-1
6693  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6694  pe_west1 = domain%pearray(inbr,jnbr)
6695  is_west1 = isc; ie_west1 = is_west1
6696  js_west1 = jsc + jshift; je_west1 = jec+jshift
6697  endif
6698  endif
6699  endif
6700 
6701  !--- west boundary for recv: the southwest point when position is CORNER
6702  if( position == CORNER ) then
6703  inbr = ipos - 1; jnbr = jpos - 1
6704  if( inbr == -1 .AND. x_cyclic) inbr = npes_x - 1
6705  if( jnbr == -1 .AND. y_cyclic) jnbr = npes_y - 1
6706  if( inbr .GE. 0 .AND. inbr .LT. npes_x .AND. jnbr .GE. 0 .AND. jnbr .LT. npes_y ) then
6707  pe_west2 = domain%pearray(inbr,jnbr)
6708  is_west2 = isc; ie_west2 = is_west2
6709  js_west2 = jsc; je_west2 = js_west2
6710  endif
6711  endif
6712 
6713 !write(1000+mpp_pe(),*)"recv south 1", pe_south1, is_south1, ie_south1, js_south1, je_south1
6714 !write(1000+mpp_pe(),*)"recv south 2", pe_south2, is_south2, ie_south2, js_south2, je_south2
6715 !write(1000+mpp_pe(),*)"recv west 0", pe_west0, is_west0, ie_west0, js_west0, je_west0
6716 !write(1000+mpp_pe(),*)"recv west 1", pe_west1, is_west1, ie_west1, js_west1, je_west1
6717 !write(1000+mpp_pe(),*)"recv west 2", pe_west2, is_west2, ie_west2, js_west2, je_west2
6718 
6719  tMe = 1
6720  do list = 0,nlist-1
6721  m = mod( domain%pos+nlist-list, nlist )
6722  count = 0
6723  my_pe = domain%list(m)%pe
6724  if(my_pe == pe_south1) then
6725  count = count + 1
6726  is(count) = is_south1; ie(count) = ie_south1
6727  js(count) = js_south1; je(count) = je_south1
6728  dir(count) = 2
6729  rotation(count) = ZERO
6730  index(count) = 1 + ishift
6731  endif
6732  if(my_pe == pe_south2) then
6733  count = count + 1
6734  is(count) = is_south2; ie(count) = ie_south2
6735  js(count) = js_south2; je(count) = je_south2
6736  dir(count) = 2
6737  rotation(count) = ZERO
6738  index(count) = 1
6739  endif
6740  if(my_pe == pe_west0) then
6741  count = count + 1
6742  is(count) = is_west0; ie(count) = ie_west0
6743  js(count) = js_west0; je(count) = je_west0
6744  dir(count) = 3
6745  rotation(count) = ONE_HUNDRED_EIGHTY
6746  index(count) = jec-jsc+1+jshift
6747  endif
6748  if(my_pe == pe_west1) then
6749  count = count + 1
6750  is(count) = is_west1; ie(count) = ie_west1
6751  js(count) = js_west1; je(count) = je_west1
6752  dir(count) = 3
6753  rotation(count) = ZERO
6754  index(count) = 1 + jshift
6755  endif
6756  if(my_pe == pe_west2) then
6757  count = count + 1
6758  is(count) = is_west2; ie(count) = ie_west2
6759  js(count) = js_west2; je(count) = je_west2
6760  dir(count) = 3
6761  rotation(count) = ZERO
6762  index(count) = 1
6763  endif
6764 
6765  if(count >0) then
6766  nrecv = nrecv + 1
6767  if(nrecv > nlist_recv) call mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv")
6768  bound%recv(nrecv)%count = count
6769  bound%recv(nrecv)%pe = my_pe
6770  allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6771  allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6772  allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6773  allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6774 
6775  bound%recv(nrecv)%is(:) = is(1:count)
6776  bound%recv(nrecv)%ie(:) = ie(1:count)
6777  bound%recv(nrecv)%js(:) = js(1:count)
6778  bound%recv(nrecv)%je(:) = je(1:count)
6779  bound%recv(nrecv)%dir(:) = dir(1:count)
6780  bound%recv(nrecv)%tileMe(:) = 1
6781  bound%recv(nrecv)%rotation(:) = rotation(1:count)
6782  bound%recv(nrecv)%index(:) = index(1:count)
6783 !write(1000+mpp_pe(),*) "recv:", count, my_pe
6784 !do i = 1, count
6785 ! write(1000+mpp_pe(),*) "recv index:", is(i), ie(i), js(i), je(i), dir(i), rotation(i)
6786 !enddo
6787 
6788  endif
6789  enddo
6790  else
6791  do m = 1, update%nrecv
6792  overlap => update%recv(m)
6793  if( overlap%count == 0 ) cycle
6794  count = 0
6795  do n = 1, overlap%count
6796  !--- currently not support folded-north
6797  if( overlap%rotation(n) == ONE_HUNDRED_EIGHTY ) cycle
6798  if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 1) then ! east
6799  count=count+1
6800  dir(count) = 1
6801  rotation(count) = overlap%rotation(n)
6802  tileMe(count) = overlap%tileMe(n)
6803  is(count) = overlap%is(n) - 1
6804  ie(count) = is(count)
6805  js(count) = overlap%js(n)
6806  je(count) = overlap%je(n)
6807  tMe = tileMe(count)
6808  nrecvl(tMe, 1) = nrecvl(tMe,1) + 1
6809  isl (tMe,1,nrecvl(tMe, 1)) = is (count)
6810  iel (tMe,1,nrecvl(tMe, 1)) = ie (count)
6811  jsl (tMe,1,nrecvl(tMe, 1)) = js (count)
6812  jel (tMe,1,nrecvl(tMe, 1)) = je (count)
6813  end if
6814 
6815  if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 3) then ! south
6816  count=count+1
6817  dir(count) = 2
6818  rotation(count) = overlap%rotation(n)
6819  tileMe(count) = overlap%tileMe(n)
6820  is(count) = overlap%is(n)
6821  ie(count) = overlap%ie(n)
6822  js(count) = overlap%je(n) + 1
6823  je(count) = js(count)
6824  tMe = tileMe(count)
6825  nrecvl(tMe, 2) = nrecvl(tMe,2) + 1
6826  isl (tMe,2,nrecvl(tMe, 2)) = is (count)
6827  iel (tMe,2,nrecvl(tMe, 2)) = ie (count)
6828  jsl (tMe,2,nrecvl(tMe, 2)) = js (count)
6829  jel (tMe,2,nrecvl(tMe, 2)) = je (count)
6830  end if
6831 
6832  if( (position == EAST .OR. position == CORNER) .AND. overlap%dir(n) == 5) then ! west
6833  count=count+1
6834  dir(count) = 3
6835  rotation(count) = overlap%rotation(n)
6836  tileMe(count) = overlap%tileMe(n)
6837  is(count) = overlap%ie(n) + 1
6838  ie(count) = is(count)
6839  js(count) = overlap%js(n)
6840  je(count) = overlap%je(n)
6841  tMe = tileMe(count)
6842  nrecvl(tMe, 3) = nrecvl(tMe,3) + 1
6843  isl (tMe,3,nrecvl(tMe, 3)) = is (count)
6844  iel (tMe,3,nrecvl(tMe, 3)) = ie (count)
6845  jsl (tMe,3,nrecvl(tMe, 3)) = js (count)
6846  jel (tMe,3,nrecvl(tMe, 3)) = je (count)
6847  end if
6848 
6849  if( (position == NORTH .OR. position == CORNER) .AND. overlap%dir(n) == 7) then ! north
6850  count=count+1
6851  dir(count) = 4
6852  rotation(count) = overlap%rotation(n)
6853  tileMe(count) = overlap%tileMe(n)
6854  is(count) = overlap%is(n)
6855  ie(count) = overlap%ie(n)
6856  js(count) = overlap%js(n) - 1
6857  je(count) = js(count)
6858  tMe = tileMe(count)
6859  nrecvl(tMe, 4) = nrecvl(tMe,4) + 1
6860  isl (tMe,4,nrecvl(tMe, 4)) = is (count)
6861  iel (tMe,4,nrecvl(tMe, 4)) = ie (count)
6862  jsl (tMe,4,nrecvl(tMe, 4)) = js (count)
6863  jel (tMe,4,nrecvl(tMe, 4)) = je (count)
6864  end if
6865  end do ! do n = 1, overlap%count
6866  if(count>0) then
6867  nrecv = nrecv + 1
6868  bound%recv(nrecv)%count = count
6869  bound%recv(nrecv)%pe = overlap%pe
6870  allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) )
6871  allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) )
6872  allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) )
6873  allocate(bound%recv(nrecv)%tileMe(count), bound%recv(nrecv)%rotation(count) )
6874  bound%recv(nrecv)%is(:) = is(1:count)
6875  bound%recv(nrecv)%ie(:) = ie(1:count)
6876  bound%recv(nrecv)%js(:) = js(1:count)
6877  bound%recv(nrecv)%je(:) = je(1:count)
6878  bound%recv(nrecv)%dir(:) = dir(1:count)
6879  bound%recv(nrecv)%tileMe(:) = tileMe(1:count)
6880  bound%recv(nrecv)%rotation(:) = rotation(1:count)
6881  end if
6882  end do ! end do list = 0, nlist
6883  !--- find the boundary index for each contact within the east boundary
6884  do m = 1, nrecv
6885  do n = 1, bound%recv(m)%count
6886  tMe = bound%recv(m)%tileMe(n)
6887  dr = bound%recv(m)%dir(n)
6888  bound%recv(m)%index(n) = 1
6889  do l = 1, nrecvl(tMe,dr)
6890  if(dr == 1 .OR. dr == 3) then ! EAST, WEST
6891  if( bound%recv(m)%js(n) > jsl(tMe, dr, l) ) then
6892  if( bound%recv(m)%rotation(n) == ONE_HUNDRED_EIGHTY ) then
6893  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6894  max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l))+1, &
6895  abs(iel(tMe, dr, l)-isl(tMe, dr, l))+1)
6896  else
6897  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6898  max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6899  abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - jshift
6900  endif
6901  end if
6902  else ! South, North
6903  if( bound%recv(m)%is(n) > isl(tMe, dr, l) ) then
6904  bound%recv(m)%index(n) = bound%recv(m)%index(n) + &
6905  max(abs(jel(tMe, dr, l)-jsl(tMe, dr, l)), &
6906  abs(iel(tMe, dr, l)-isl(tMe, dr, l))) + 1 - ishift
6907  end if
6908  end if
6909  end do
6910  end do
6911  end do
6912 
6913  endif
6914  bound%nrecv = nrecv
6915 
6916 
6917 end subroutine set_bound_overlap
6918 
6919 
6920 !#############################################################################
6921 
6922 subroutine fill_corner_contact(eCont, sCont, wCont, nCont, isg, ieg, jsg, jeg, numR, numS, tileRecv, tileSend, &
6923  is1Recv, ie1Recv, js1Recv, je1Recv, is2Recv, ie2Recv, js2Recv, je2Recv, &
6924  is1Send, ie1Send, js1Send, je1Send, is2Send, ie2Send, js2Send, je2Send, &
6925  align1Recv, align2Recv, align1Send, align2Send, &
6926  whalo, ehalo, shalo, nhalo, tileMe)
6927 type(contact_type), dimension(:), intent(in) :: eCont, sCont, wCont, nCont
6928 integer, dimension(:), intent(in) :: isg, ieg, jsg, jeg
6929 integer, intent(inout) :: numR, numS
6930 integer, dimension(:), intent(inout) :: tileRecv, tileSend
6931 integer, dimension(:), intent(inout) :: is1Recv, ie1Recv, js1Recv, je1Recv
6932 integer, dimension(:), intent(inout) :: is2Recv, ie2Recv, js2Recv, je2Recv
6933 integer, dimension(:), intent(inout) :: is1Send, ie1Send, js1Send, je1Send
6934 integer, dimension(:), intent(inout) :: is2Send, ie2Send, js2Send, je2Send
6935 integer, dimension(:), intent(inout) :: align1Recv, align2Recv, align1Send, align2Send
6936 integer, intent(in) :: tileMe, whalo, ehalo, shalo, nhalo
6937 integer :: is1, ie1, js1, je1, is2, ie2, js2, je2
6938 integer :: tn, tc, n, m
6939 logical :: found_corner
6940 
6941 found_corner = .false.
6942 !--- southeast for recving
6943 if(eCont(tileMe)%ncontact > 0) then
6944  if(eCont(tileMe)%js1(1) == jsg(tileMe) ) then
6945  tn = eCont(tileMe)%tile(1)
6946  if(econt(tileMe)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
6947  if( econt(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
6948  "mpp_domains_define.inc: southeast tile for recv 1 is not tiled properly")
6949  found_corner = .true.; tc = tn
6950  is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6951  is2 = eCont(tileMe)%is2(1); je2 = eCont(tileMe)%js2(1) - 1
6952  else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
6953  if(sCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
6954  found_corner = .true.; tc = sCont(tn)%tile(1)
6955  is1 = eCont(tileMe)%ie1(1) + 1; je1 = eCont(tileMe)%js1(1) - 1
6956  is2 = sCont(tn)%is2(1); je2 = sCont(tn)%je2(1)
6957  end if
6958  end if
6959  end if
6960 end if
6961 if( .not. found_corner ) then ! not found,
6962  n = sCont(tileMe)%ncontact
6963  if( n > 0) then
6964  if( sCont(tileMe)%ie1(n) == ieg(tileMe)) then
6965  tn = sCont(tileMe)%tile(n)
6966  if(scont(tileMe)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
6967  if(ieg(tn) - scont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
6968  "mpp_domains_define.inc: southeast tile for recv 2 is not tiled properly")
6969  found_corner = .true.; tc = tn
6970  is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
6971  is2 = sCont(tileMe)%ie2(n) + 1; je2 = sCont(tileMe)%je2(n)
6972  else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
6973  m = eCont(tn)%ncontact
6974  if(eCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
6975  found_corner = .true.; tc = eCont(tn)%tile(m)
6976  is1 = sCont(tileMe)%ie1(n) + 1; je1 = sCont(tileMe)%js1(n) - 1
6977  is2 = eCont(tn)%is2(m); je2 = eCont(tn)%je2(m)
6978  end if
6979  end if
6980  end if
6981  end if
6982 end if
6983 if(found_corner) then
6984  numR = numR + 1
6985  tileRecv(numR) = tc; align1Recv(numR) = SOUTH_EAST; align2Recv(numR) = NORTH_WEST
6986  is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
6987  js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
6988  is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
6989  js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
6990 end if
6991 
6992 !--- southwest for recving
6993 found_corner = .false.
6994 if(wCont(tileMe)%ncontact > 0) then
6995  if(wCont(tileMe)%js1(1) == jsg(tileMe) ) then
6996  tn = wCont(tileMe)%tile(1)
6997  if(wcont(tileMe)%js2(1) > jsg(tn) ) then ! the corner tile is tn.
6998  if( wcont(tileMe)%js2(1) - jsg(tn) < shalo ) call mpp_error(FATAL, &
6999  "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7000  found_corner = .true.; tc = tn
7001  ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7002  ie2 = wCont(tileMe)%is2(1); je2 = wCont(tileMe)%js2(1) - 1
7003  else if(sCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7004  n = sCont(tn)%ncontact
7005  if(sCont(tn)%ie1(n) == ieg(tn)) then ! corner is nc.
7006  found_corner = .true.; tc = sCont(tn)%tile(n)
7007  ie1 = wCont(tileMe)%is1(1) - 1; je1 = wCont(tileMe)%js1(1) - 1
7008  ie2 = sCont(tn)%ie2(1); je2 = sCont(tn)%je2(1)
7009  end if
7010  end if
7011  end if
7012 end if
7013 if( .not. found_corner ) then ! not found,
7014  n = sCont(tileMe)%ncontact
7015  if( n > 0) then
7016  if( sCont(tileMe)%is1(1) == isg(tileMe)) then
7017  tn = sCont(tileMe)%tile(1)
7018  if(sCont(tileMe)%is2(1) > isg(tn) ) then ! the corner tile is tn.
7019  if( scont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
7020  "mpp_domains_define.inc: southwest tile for recv 1 is not tiled properly")
7021  found_corner = .true.; tc = tn
7022  ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7023  ie2 = sCont(tileMe)%is2(1) - 1; je2 = sCont(tileMe)%js2(1)
7024  else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7025  m = wCont(tn)%ncontact
7026  if(wCont(tn)%je1(m) == jeg(tn)) then ! corner is nc.
7027  found_corner = .true.; tc = wCont(tn)%tile(m)
7028  ie1 = sCont(tileMe)%is1(1) - 1; je1 = sCont(tileMe)%js1(1) - 1
7029  ie2 = wCont(tn)%ie2(m); je2 = wCont(tn)%je2(m)
7030  end if
7031  end if
7032  end if
7033  end if
7034 end if
7035 if(found_corner) then
7036  numR = numR + 1
7037  tileRecv(numR) = tc; align1Recv(numR) = SOUTH_WEST; align2Recv(numR) = NORTH_EAST
7038  is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7039  js1Recv(numR) = je1 - shalo + 1; je1Recv(numR) = je1
7040  is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7041  js2Recv(numR) = je2 - shalo + 1; je2Recv(numR) = je2
7042 end if
7043 
7044 !--- northwest for recving
7045 found_corner = .false.
7046 n = wCont(tileMe)%ncontact
7047 if( n > 0) then
7048  if(wCont(tileMe)%je1(n) == jeg(tileMe) ) then
7049  tn = wCont(tileMe)%tile(n)
7050  if(wcont(tileMe)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
7051  if( jeg(tn) - wcont(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
7052  "mpp_domains_define.inc: northwest tile for recv 1 is not tiled properly")
7053  found_corner = .true.; tc = tn
7054  ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
7055  ie2 = wCont(tileMe)%is2(n); js2 = wCont(tileMe)%je2(n) + 1
7056  else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7057  m = nCont(tn)%ncontact
7058  if(nCont(tn)%ie1(m) == ieg(tn)) then ! corner is nc.
7059  found_corner = .true.; tc = nCont(tn)%tile(m)
7060  ie1 = wCont(tileMe)%is1(n) - 1; js1 = wCont(tileMe)%je1(n) + 1
7061  ie2 = nCont(tn)%ie2(m); js2 = nCont(tn)%js2(m)
7062  end if
7063  endif
7064  endif
7065 end if
7066 if( .not. found_corner ) then ! not found,
7067  if( nCont(tileMe)%ncontact > 0) then
7068  if( nCont(tileMe)%is1(1) == isg(tileMe)) then
7069  tn = nCont(tileMe)%tile(1)
7070  if(nCont(tileMe)%is2(1) > isg(tn) ) then ! the corner tile is tn.
7071  if( ncont(tileMe)%is2(1)-isg(tn) < whalo ) call mpp_error(FATAL, &
7072  "mpp_domains_define.inc: northwest tile for recv 2 is not tiled properly")
7073  found_corner = .true.; tc = tn
7074  ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7075  ie2 = nCont(tileMe)%is2(1) - 1; js2 = nCont(tileMe)%js2(1)
7076  else if(wCont(tn)%ncontact >0) then ! the corner tile may be west tile of tn.
7077  if(wCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7078  found_corner = .true.; tc = wCont(tn)%tile(1)
7079  ie1 = nCont(tileMe)%is1(1) - 1; js1 = nCont(tileMe)%je1(1) + 1
7080  ie2 = wCont(tn)%ie2(1); js2 = wCont(tn)%js2(1)
7081  end if
7082  end if
7083  end if
7084  end if
7085 end if
7086 if(found_corner) then
7087  numR = numR + 1
7088  tileRecv(numR) = tc; align1Recv(numR) =NORTH_WEST; align2Recv(numR) = SOUTH_EAST
7089  is1Recv(numR) = ie1 - whalo + 1; ie1Recv(numR) = ie1
7090  js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
7091  is2Recv(numR) = ie2 - whalo + 1; ie2Recv(numR) = ie2
7092  js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
7093 end if
7094 
7095 !--- northeast for recving
7096 found_corner = .false.
7097 n = eCont(tileMe)%ncontact
7098 if( n > 0) then
7099  if(eCont(tileMe)%je1(n) == jeg(tileMe) ) then
7100  tn = eCont(tileMe)%tile(n)
7101  if(econt(tileMe)%je2(n) < jeg(tn) ) then ! the corner tile is tn.
7102  if( jeg(tn) - econt(tileMe)%je2(n) < nhalo ) call mpp_error(FATAL, &
7103  "mpp_domains_define.inc: northeast tile for recv 1 is not tiled properly")
7104  found_corner = .true.; tc = tn
7105  is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
7106  is2 = eCont(tileMe)%is2(1); js2 = eCont(tileMe)%je2(1) + 1
7107  else if(nCont(tn)%ncontact >0) then ! the corner tile may be south tile of tn.
7108  if(nCont(tn)%is1(1) == isg(tn)) then ! corner is nc.
7109  found_corner = .true.; tc = nCont(tn)%tile(1)
7110  is1 = eCont(tileMe)%ie1(n) + 1; js1 = eCont(tileMe)%je1(n) + 1
7111  is2 = nCont(tn)%is2(1); js2 = nCont(tn)%js2(1)
7112  end if
7113  end if
7114  end if
7115 end if
7116 if( .not. found_corner ) then ! not found,
7117  n = nCont(tileMe)%ncontact
7118  if( n > 0) then
7119  if( nCont(tileMe)%ie1(n) == ieg(tileMe)) then
7120  tn = nCont(tileMe)%tile(n)
7121  if(nCont(tileMe)%ie2(n) < ieg(tn) ) then ! the corner tile is tn.
7122  if(ieg(tn) - sCont(tileMe)%ie2(n) < ehalo ) call mpp_error(FATAL, &
7123  "mpp_domains_define.inc: northeast tile for recv 2 is not tiled properly")
7124  found_corner = .true.; tc = tn
7125  is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
7126  is2 = sCont(tileMe)%ie2(n) + 1; js2 = sCont(tileMe)%js2(n)
7127  else if(eCont(tn)%ncontact >0) then ! the corner tile may be east tile of tn.
7128  if(eCont(tn)%js1(1) == jsg(tn)) then ! corner is nc.
7129  found_corner = .true.; tc = eCont(tn)%tile(1)
7130  is1 = sCont(tileMe)%ie1(n) + 1; js1 = sCont(tileMe)%je1(n) + 1
7131  is2 = eCont(tn)%is2(m); js2 = eCont(tn)%js2(m)
7132  end if
7133  end if
7134  end if
7135  end if
7136 end if
7137 if(found_corner) then
7138  numR = numR + 1
7139  tileRecv(numR) = tc; align1Recv(numR) =NORTH_EAST; align2Recv(numR) = SOUTH_WEST
7140  is1Recv(numR) = is1; ie1Recv(numR) = is1 + ehalo - 1
7141  js1Recv(numR) = js1; je1Recv(numR) = js1 + nhalo - 1
7142  is2Recv(numR) = is2; ie2Recv(numR) = is2 + ehalo - 1
7143  js2Recv(numR) = js2; je2Recv(numR) = js2 + nhalo - 1
7144 end if
7145 
7146 !--- to_pe's southeast for sending
7147 do n = 1, wCont(tileMe)%ncontact
7148  tn = wCont(tileMe)%tile(n)
7149  if(wCont(tileMe)%js2(n) == jsg(tn) ) then
7150  if(wcont(tileMe)%js1(n) > jsg(tileMe) ) then ! send to tile tn.
7151  if( wcont(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
7152  "mpp_domains_define.inc: southeast tile for send 1 is not tiled properly")
7153  numS = numS+1; tileSend(numS) = tn
7154  align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7155  is1Send(numS) = wCont(tileMe)%is1(n); ie1Send(numS) = is1Send(numS) + ehalo - 1
7156  je1Send(numS) = wCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7157  is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7158  je2Send(numS) = wCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7159  end if
7160  end if
7161 end do
7162 do n = 1, nCont(tileMe)%ncontact
7163  tn = nCont(tileMe)%tile(n)
7164  if(nCont(tileMe)%ie2(n) == ieg(tn) ) then
7165  if(nCont(tileMe)%ie1(n) < ieg(tileMe) ) then ! send to tile tn.
7166  if( ieg(tileMe) - nCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
7167  "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7168  numS = numS+1; tileSend(numS) = tn
7169  align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7170  is1Send(numS) = nCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7171  je1Send(numS) = nCont(tileMe)%je1(n) ; js1Send(numS) = je1Send(numS) - shalo + 1
7172  is2Send(numS) = nCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7173  je2Send(numS) = nCont(tileMe)%je2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7174  end if
7175  end if
7176 end do
7177 
7178 !--- found the corner overlap that is not specified through contact line.
7179 n = wCont(tileMe)%ncontact
7180 found_corner = .false.
7181 if( n > 0) then
7182  tn = wCont(tileMe)%tile(n)
7183  if( wCont(tileMe)%je1(n) == jeg(tileMe) .AND. wCont(tileMe)%je2(n) == jeg(tn) ) then
7184  m = nCont(tn)%ncontact
7185  if(m >0) then
7186  tc = nCont(tn)%tile(m)
7187  if( nCont(tn)%ie1(m) == ieg(tn) .AND. nCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7188  end if
7189  end if
7190 end if
7191 if( .not. found_corner ) then ! not found, then starting from north contact
7192  if( nCont(tileMe)%ncontact > 0) then
7193  tn = nCont(tileMe)%tile(1)
7194  if( nCont(tileMe)%is1(1) == isg(tileMe) .AND. nCont(tileMe)%is2(1) == isg(tn) ) then
7195  if(wCont(tn)%ncontact >0) then
7196  tc = wCont(tn)%tile(1)
7197  if( wCont(tn)%js1(1) == jsg(tn) .AND. wCont(tn)%js2(1) == jsg(tc) ) found_corner = .true.
7198  end if
7199  end if
7200  end if
7201 end if
7202 
7203 if(found_corner) then
7204  numS = numS+1; tileSend(numS) = tc
7205  align1Send(numS) = NORTH_WEST; align2Send(numS) = SOUTH_EAST
7206  is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7207  je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7208  is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7209  je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7210 end if
7211 
7212 !--- to_pe's southwest for sending
7213 do n = 1, eCont(tileMe)%ncontact
7214  tn = eCont(tileMe)%tile(n)
7215  if(eCont(tileMe)%js2(n) == jsg(tn) ) then
7216  if(econt(tileMe)%js1(n) > jsg(tileMe) ) then ! send to tile tn.
7217  if( econt(tileMe)%js1(n) - jsg(tileMe) < shalo ) call mpp_error(FATAL, &
7218  "mpp_domains_define.inc: southwest tile for send 1 is not tiled properly")
7219  numS = numS+1; tileSend(numS) = tn
7220  align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7221  ie1Send(numS) = eCont(tileMe)%ie1(n); is1Send(numS) = ie1Send(numS) - whalo + 1
7222  je1Send(numS) = eCont(tileMe)%js1(n) - 1; js1Send(numS) = je1Send(numS) - shalo + 1
7223  ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7224  je2Send(numS) = eCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7225  end if
7226  end if
7227 end do
7228 do n = 1, nCont(tileMe)%ncontact
7229  tn = nCont(tileMe)%tile(n)
7230  if(nCont(tileMe)%is2(n) == isg(tn) ) then
7231  if(ncont(tileMe)%is1(n) > isg(tileMe) ) then ! send to tile tn.
7232  if( ncont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
7233  "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7234  numS = numS+1; tileSend(numS) = tn
7235  align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7236  ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7237  ie1Send(numS) = nCont(tileMe)%je1(n) ; js1Send(numS) = je1Send(numS) - shalo + 1
7238  ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = je2Send(numS) - whalo + 1
7239  je2Send(numS) = nCont(tileMe)%js2(n) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7240  end if
7241  end if
7242 end do
7243 
7244 !--- found the corner overlap that is not specified through contact line.
7245 n = eCont(tileMe)%ncontact
7246 found_corner = .false.
7247 if( n > 0) then
7248  tn = eCont(tileMe)%tile(n)
7249  if( eCont(tileMe)%je1(n) == jeg(tileMe) .AND. eCont(tileMe)%je2(n) == jeg(tn) ) then
7250  if(nCont(tn)%ncontact >0) then
7251  tc = nCont(tn)%tile(1)
7252  if( nCont(tn)%is1(1) == isg(tn) .AND. nCont(tn)%is2(n) == isg(tc) ) found_corner = .true.
7253  end if
7254  end if
7255 end if
7256 if( .not. found_corner ) then ! not found, then starting from north contact
7257  n = nCont(tileMe)%ncontact
7258  if( n > 0) then
7259  tn = nCont(tileMe)%tile(n)
7260  if( nCont(tileMe)%ie1(n) == ieg(tileMe) .AND. nCont(tileMe)%ie2(n) == ieg(tn) ) then
7261  if(eCont(tn)%ncontact >0) then
7262  tc = eCont(tn)%tile(1)
7263  if( eCont(tn)%js1(1) == jsg(tn) .AND. eCont(tn)%js2(n) == jsg(tc) ) found_corner = .true.
7264  end if
7265  end if
7266  end if
7267 end if
7268 
7269 if(found_corner) then
7270  numS = numS+1; tileSend(numS) = tc
7271  align1Send(numS) = NORTH_EAST; align2Send(numS) = SOUTH_WEST
7272  ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7273  je1Send(numS) = jeg(tileMe); js1Send(numS) = je1Send(numS) - shalo + 1
7274  ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7275  je2Send(numS) = jsg(tc) - 1; js2Send(numS) = je2Send(numS) - shalo + 1
7276 end if
7277 
7278 !--- to_pe's northwest for sending
7279 do n = 1, eCont(tileMe)%ncontact
7280  tn = eCont(tileMe)%tile(n)
7281  if(eCont(tileMe)%je2(n) == jeg(tn) ) then
7282  if(econt(tileMe)%je1(n) < jeg(tileMe) ) then ! send to tile tn.
7283  if( jeg(tileMe) - econt(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
7284  "mpp_domains_define.inc: northwest tile for send 1 is not tiled properly")
7285  numS = numS+1; tileSend(numS) = tn
7286  align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7287  ie1Send(numS) = eCont(tileMe)%ie1(n) ; is1Send(numS) = ie1Send(numS) - whalo + 1
7288  js1Send(numS) = eCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7289  ie2Send(numS) = eCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7290  js2Send(numS) = eCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7291  end if
7292  end if
7293 end do
7294 
7295 do n = 1, sCont(tileMe)%ncontact
7296  tn = sCont(tileMe)%tile(n)
7297  if(sCont(tileMe)%is2(n) == isg(tn) ) then
7298  if(scont(tileMe)%is1(n) > isg(tileMe) ) then ! send to tile tn.
7299  if( scont(tileMe)%is1(n) - isg(tileMe) < whalo ) call mpp_error(FATAL, &
7300  "mpp_domains_define.inc: southwest tile for send 2 is not tiled properly")
7301  numS = numS+1; tileSend(numS) = tn
7302  align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7303  ie1Send(numS) = nCont(tileMe)%is1(n) - 1; is1Send(numS) = ie1Send(numS) - whalo + 1
7304  js1Send(numS) = nCont(tileMe)%je1(n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
7305  ie2Send(numS) = nCont(tileMe)%is2(n) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7306  js2Send(numS) = nCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7307  end if
7308  end if
7309 end do
7310 
7311 !--- found the corner overlap that is not specified through contact line.
7312 n = eCont(tileMe)%ncontact
7313 found_corner = .false.
7314 if( n > 0) then
7315  tn = eCont(tileMe)%tile(1)
7316  if( eCont(tileMe)%js1(1) == jsg(tileMe) .AND. eCont(tileMe)%js2(1) == jsg(tn) ) then
7317  if(sCont(tn)%ncontact >0) then
7318  tc = sCont(tn)%tile(1)
7319  if( sCont(tn)%is1(1) == isg(tn) .AND. sCont(tn)%is2(1) == isg(tc) ) found_corner = .true.
7320  end if
7321  end if
7322 end if
7323 if( .not. found_corner ) then ! not found, then starting from north contact
7324  n = sCont(tileMe)%ncontact
7325  found_corner = .false.
7326  if( n > 0) then
7327  tn = sCont(tileMe)%tile(n)
7328  if( sCont(tileMe)%ie1(n) == ieg(tileMe) .AND. sCont(tileMe)%ie2(n) == ieg(tn) ) then
7329  if(eCont(tn)%ncontact >0) then
7330  tc = eCont(tn)%tile(n)
7331  if( eCont(tn)%je1(n) == jeg(tn) .AND. eCont(tn)%je2(n) == jeg(tc) ) found_corner = .true.
7332  end if
7333  end if
7334  end if
7335 end if
7336 
7337 if(found_corner) then
7338  numS = numS+1; tileSend(numS) = tc
7339  align1Send(numS) = SOUTH_EAST; align2Send(numS) = NORTH_WEST
7340  ie1Send(numS) = ieg(tileMe); is1Send(numS) = ie1Send(numS) - whalo + 1
7341  js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7342  ie2Send(numS) = isg(tc) - 1; is2Send(numS) = ie2Send(numS) - whalo + 1
7343  js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7344 end if
7345 
7346 !--- to_pe's northeast for sending
7347 do n = 1, wCont(tileMe)%ncontact
7348  tn = wCont(tileMe)%tile(n)
7349  if(wCont(tileMe)%je2(n) == jeg(tn) ) then
7350  if(wcont(tileMe)%je1(n) < jeg(tileMe) ) then ! send to tile tn.
7351  if( jeg(tileMe) - wcont(tileMe)%je1(n) < nhalo ) call mpp_error(FATAL, &
7352  "mpp_domains_define.inc: northeast tile for send 1 is not tiled properly")
7353  numS = numS+1; tileSend(numS) = tn
7354  align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7355  is1Send(numS) = wCont(tileMe)%is1(n) ; ie1Send(numS) = is1Send(numS) + ehalo - 1
7356  js1Send(numS) = wCont(tileMe)%je1(n) + 1; je1Send(numS) = js1Send(numS) + nhalo - 1
7357  is2Send(numS) = wCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7358  js2Send(numS) = wCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7359  end if
7360  end if
7361 end do
7362 
7363 do n = 1, sCont(tileMe)%ncontact
7364  tn = sCont(tileMe)%tile(n)
7365  if(sCont(tileMe)%ie2(n) == ieg(tn) ) then
7366  if(sCont(tileMe)%ie1(n) < ieg(tileMe) ) then ! send to tile tn.
7367  if( ieg(tileMe) - sCont(tileMe)%ie1(n) < ehalo ) call mpp_error(FATAL, &
7368  "mpp_domains_define.inc: southeast tile for send 2 is not tiled properly")
7369  numS = numS+1; tileSend(numS) = tn
7370  align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7371  is1Send(numS) = sCont(tileMe)%ie1(n) + 1; ie1Send(numS) = is1Send(numS) + ehalo - 1
7372  js1Send(numS) = sCont(tileMe)%js1(n) ; je1Send(numS) = js1Send(numS) + nhalo - 1
7373  is2Send(numS) = sCont(tileMe)%ie2(n) + 1; ie2Send(numS) = is1Send(numS) + ehalo - 1
7374  js2Send(numS) = sCont(tileMe)%je2(n) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7375  end if
7376  end if
7377 end do
7378 
7379 !--- found the corner overlap that is not specified through contact line.
7380 n = wCont(tileMe)%ncontact
7381 found_corner = .false.
7382 if( n > 0) then
7383  tn = wCont(tileMe)%tile(1)
7384  if( wCont(tileMe)%js1(n) == jsg(tileMe) .AND. wCont(tileMe)%js2(n) == jsg(tn) ) then
7385  m = sCont(tn)%ncontact
7386  if(m >0) then
7387  tc = sCont(tn)%tile(m)
7388  if( sCont(tn)%ie1(m) == ieg(tn) .AND. sCont(tn)%ie2(m) == ieg(tc) ) found_corner = .true.
7389  end if
7390  end if
7391 end if
7392 if( .not. found_corner ) then ! not found, then starting from north contact
7393  n = sCont(tileMe)%ncontact
7394  found_corner = .false.
7395  if( n > 0) then
7396  tn = sCont(tileMe)%tile(1)
7397  if( sCont(tileMe)%is1(1) == isg(tileMe) .AND. sCont(tileMe)%is2(1) == isg(tn) ) then
7398  m = wCont(tn)%ncontact
7399  if( m > 0 ) then
7400  tc = wCont(tn)%tile(m)
7401  if( wCont(tn)%je1(m) == jeg(tn) .AND. wCont(tn)%je2(m) == jeg(tc) ) found_corner = .true.
7402  end if
7403  end if
7404  end if
7405 end if
7406 if(found_corner) then
7407  numS = numS+1; tileSend(numS) = tc
7408  align1Send(numS) = SOUTH_WEST; align2Send(numS) = NORTH_EAST
7409  is1Send(numS) = isg(tileMe); ie1Send(numS) = is1Send(numS) + ehalo - 1
7410  js1Send(numS) = jsg(tileMe); je1Send(numS) = js1Send(numS) + nhalo - 1
7411  is2Send(numS) = ieg(tc) + 1; ie2Send(numS) = is2Send(numS) + ehalo - 1
7412  js2Send(numS) = jeg(tc) + 1; je2Send(numS) = js2Send(numS) + nhalo - 1
7413 end if
7414 
7415 end subroutine fill_corner_contact
7416 
7417 !--- find the alignment direction, check if index is reversed, if reversed, exchange index.
7418 subroutine check_alignment( is, ie, js, je, isg, ieg, jsg, jeg, alignment )
7419 integer, intent(inout) :: is, ie, js, je, isg, ieg, jsg, jeg
7420 integer, intent(out) :: alignment
7421 
7422 integer :: i, j
7423 
7424 if ( is == ie ) then ! x-alignment
7425  if ( is == isg ) then
7426  alignment = WEST
7427  else if ( is == ieg ) then
7428  alignment = EAST
7429  else
7430  call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the x-boundary of the tile')
7431  end if
7432  if ( js > je ) then
7433  j = js; js = je; je = j
7434  end if
7435 else if ( js == je ) then ! y-alignment
7436  if ( js == jsg ) then
7437  alignment = SOUTH
7438  else if ( js == jeg ) then
7439  alignment = NORTH
7440  else
7441  call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region is not on the y-boundary of the tile')
7442  end if
7443  if ( is > ie ) then
7444  i = is; is = ie; ie = i
7445  end if
7446 else
7447  call mpp_error(FATAL, 'mpp_domains_define.inc: The contact region should be line contact' )
7448 end if
7449 
7450 end subroutine check_alignment
7451 !#####################################################################
7452 
7453 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7454 ! !
7455 ! MPP_MODIFY_DOMAIN: modify extent of domain !
7456 ! !
7457 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7458 ! <SUBROUTINE NAME="mpp_modify_domain1D" INTERFACE="mpp_modify_domain">
7459 ! <IN NAME="domain_in" TYPE="type(domain1D)" > </IN>
7460 ! <IN NAME="hbegin,hend" TYPE="integer,optional" > </IN>
7461 ! <IN NAME="cbegin,cend" TYPE="integer,optional" > </IN>
7462 ! <IN NAME="gbegin,gend" TYPE="integer,optional" > </IN>
7463 ! <INOUT NAME="domain_out" TYPE="type(domain1D)" > </INOUT>
7464 
7465 ! <PUBLICROUTINE>
7466 subroutine mpp_modify_domain1D(domain_in,domain_out,cbegin,cend,gbegin,gend, hbegin, hend)
7467  ! </PUBLICROUTINE>
7468 type(domain1D), intent(in) :: domain_in
7469 type(domain1D), intent(inout) :: domain_out
7470 integer, intent(in), optional :: hbegin, hend ! halo size
7471 integer, intent(in), optional :: cbegin, cend ! extent of compute_domain
7472 integer, intent(in), optional :: gbegin, gend ! extent of global domain
7473 integer :: ndivs, global_indices(2) !(/ isg, ieg /)
7474 integer :: flag
7475 ! get the global indices of the input domain
7476 global_indices(1) = domain_in%global%begin; global_indices(2) = domain_in%global%end
7477 
7478 ! get the layout
7479 ndivs = size(domain_in%list(:))
7480 
7481 ! get the flag
7482 flag = 0
7483 if(domain_in%cyclic) flag = flag + CYCLIC_GLOBAL_DOMAIN
7484 if(domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN
7485 
7486 call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, &
7487  flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size )
7488 
7489 if(present(cbegin)) domain_out%compute%begin = cbegin
7490 if(present(cend)) domain_out%compute%end = cend
7491 domain_out%compute%size = domain_out%compute%end - domain_out%compute%begin + 1
7492 if(present(gbegin)) domain_out%global%begin = gbegin
7493 if(present(gend)) domain_out%global%end = gend
7495 
7496 end subroutine mpp_modify_domain1D
7497 ! </SUBROUTINE>
7498 
7499 !#######################################################################
7500 !----------------------------------------------------------------------------------
7501 ! <SUBROUTINE NAME="mpp_modify_domain2D" INTERFACE="mpp_modify_domain">
7502 ! <IN NAME="domain_in" TYPE="type(domain2D)" > </IN>
7503 ! <IN NAME="isc,iec" TYPE="integer,optional" > </IN>
7504 ! <IN NAME="jsc,jec" TYPE="integer,optional" > </IN>
7505 ! <IN NAME="isg,ieg" TYPE="integer,optional" > </IN>
7506 ! <IN NAME="jsg,jeg" TYPE="integer,optional" > </IN>
7507 ! <IN NAME="whalo,ehalo" TYPE="integer,optional" > </IN>
7508 ! <IN NAME="shalo,nhalo" TYPE="integer,optional" > </IN>
7509 ! <INOUT NAME="domain_out" TYPE="type(domain2D)" > </INOUT>
7510 
7511 ! <PUBLICROUTINE>
7512 subroutine mpp_modify_domain2D(domain_in, domain_out, isc, iec, jsc, jec, isg, ieg, jsg, jeg, whalo, ehalo, shalo, nhalo)
7513  ! </PUBLICROUTINE>
7514 type(domain2D), intent(in) :: domain_in
7515 type(domain2D), intent(inout) :: domain_out
7516 integer, intent(in), optional :: isc, iec, jsc, jec
7517 integer, intent(in), optional :: isg, ieg, jsg, jeg
7518 integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
7519 integer :: global_indices(4), layout(2)
7520 integer :: xflag, yflag, nlist, i
7521 
7522 if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) then
7523  ! get the global indices of the input domain
7524  global_indices(1) = domain_in%x(1)%global%begin; global_indices(2) = domain_in%x(1)%global%end
7525  global_indices(3) = domain_in%y(1)%global%begin; global_indices(4) = domain_in%y(1)%global%end
7526 
7527  ! get the layout
7528  layout(1) = size(domain_in%x(1)%list(:)); layout(2) = size(domain_in%y(1)%list(:))
7529 
7530  ! get the flag
7531  xflag = 0; yflag = 0
7532  if(domain_in%x(1)%cyclic) xflag = xflag + CYCLIC_GLOBAL_DOMAIN
7533  if(domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN
7534  if(domain_in%y(1)%cyclic) yflag = yflag + CYCLIC_GLOBAL_DOMAIN
7535  if(domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN
7536 
7537  call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, &
7538  xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, &
7539  shalo = shalo, nhalo = nhalo, &
7540  xextent = domain_in%x(1)%list(:)%compute%size, &
7541  yextent = domain_in%y(1)%list(:)%compute%size, &
7542  symmetry=domain_in%symmetry, &
7543  maskmap = domain_in%pearray .NE. NULL_PE )
7545  domain_out%tile_id = domain_in%tile_id
7546 else
7547  call mpp_define_null_domain(domain_out)
7548  nlist = size(domain_in%list(:))
7549  allocate(domain_out%list(0:nlist-1) )
7550  do i = 0, nlist-1
7551  allocate(domain_out%list(i)%tile_id(1))
7552  domain_out%list(i)%tile_id(1) = 1
7553  enddo
7554  call mpp_modify_domain(domain_in%x(1), domain_out%x(1), isc, iec, isg, ieg)
7555  call mpp_modify_domain(domain_in%y(1), domain_out%y(1), jsc, jec, jsg, jeg)
7557  domain_out%tile_id = domain_in%tile_id
7558 endif
7559 
7560 end subroutine mpp_modify_domain2D
7561 ! </SUBROUTINE>
7562 
7563 !#####################################################################
7564 
7565 
7566 subroutine mpp_define_null_domain1D(domain)
7567 type(domain1D), intent(inout) :: domain
7568 
7569 domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0
7570 domain%data%begin = -1; domain%data%end = -1; domain%data%size = 0
7571 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0
7572 domain%pe = NULL_PE
7573 
7574 end subroutine mpp_define_null_domain1D
7575 
7576 !#####################################################################
7577 
7578 
7579 subroutine mpp_define_null_domain2D(domain)
7580 type(domain2D), intent(inout) :: domain
7581 
7582 allocate(domain%x(1), domain%y(1), domain%tile_id(1))
7583 call mpp_define_null_domain(domain%x(1))
7584 call mpp_define_null_domain(domain%y(1))
7585 domain%pe = NULL_PE
7586 domain%tile_id(1) = 1
7587 domain%ntiles = 1
7588 domain%max_ntile_pe = 1
7589 domain%ncontacts = 0
7590 
7591 end subroutine mpp_define_null_domain2D
7592 
7593 !####################################################################
7594 
7595 subroutine mpp_deallocate_domain1D(domain)
7596  type(domain1D), intent(inout) :: domain
7597 
7598  if(ASSOCIATED(domain%list)) deallocate(domain%list)
7599 
7600 end subroutine mpp_deallocate_domain1D
7601 
7602 !####################################################################
7603 
7604 subroutine mpp_deallocate_domain2D(domain)
7605  type(domain2D), intent(inout) :: domain
7606 
7607  call deallocate_domain2D_local(domain)
7608  if(ASSOCIATED(domain%io_domain) ) then
7609  call deallocate_domain2D_local(domain%io_domain)
7610  deallocate(domain%io_domain)
7611  endif
7612 
7613 end subroutine mpp_deallocate_domain2D
7614 
7615 !##################################################################
7616 
7617 subroutine deallocate_domain2D_local(domain)
7618 type(domain2D), intent(inout) :: domain
7619 integer :: i, ntileMe
7620 
7621 ntileMe = size(domain%x(:))
7622 
7623 if(ASSOCIATED(domain%pearray))deallocate(domain%pearray)
7624 do i = 1, ntileMe
7625  call mpp_deallocate_domain1D(domain%x(i))
7626  call mpp_deallocate_domain1D(domain%y(i))
7627 enddo
7628 deallocate(domain%x, domain%y, domain%tile_id)
7629 
7630 if(ASSOCIATED(domain%list)) then
7631  do i = 0, size(domain%list(:))-1
7632  deallocate(domain%list(i)%x, domain%list(i)%y, domain%list(i)%tile_id)
7633  enddo
7634  deallocate(domain%list)
7635 endif
7636 
7637 if(ASSOCIATED(domain%check_C)) call deallocate_overlapSpec(domain%check_C)
7638 if(ASSOCIATED(domain%check_E)) call deallocate_overlapSpec(domain%check_E)
7639 if(ASSOCIATED(domain%check_N)) call deallocate_overlapSpec(domain%check_N)
7640 if(ASSOCIATED(domain%bound_C)) call deallocate_overlapSpec(domain%bound_C)
7641 if(ASSOCIATED(domain%bound_E)) call deallocate_overlapSpec(domain%bound_E)
7642 if(ASSOCIATED(domain%bound_N)) call deallocate_overlapSpec(domain%bound_N)
7643 if(ASSOCIATED(domain%update_T)) call deallocate_overlapSpec(domain%update_T)
7644 if(ASSOCIATED(domain%update_E)) call deallocate_overlapSpec(domain%update_E)
7645 if(ASSOCIATED(domain%update_C)) call deallocate_overlapSpec(domain%update_C)
7646 if(ASSOCIATED(domain%update_N)) call deallocate_overlapSpec(domain%update_N)
7647 
7648 end subroutine deallocate_domain2D_local
7649 
7650 !####################################################################
7651 
7652 subroutine allocate_check_overlap(overlap, count)
7653  type(overlap_type), intent(inout) :: overlap
7654  integer, intent(in ) :: count
7655 
7656  overlap%count = 0
7657  overlap%pe = NULL_PE
7658  if(associated(overlap%tileMe)) call mpp_error(FATAL, &
7659  "allocate_check_overlap(mpp_domains_define): overlap is already been allocated")
7660  if(count < 1) call mpp_error(FATAL, &
7661  "allocate_check_overlap(mpp_domains_define): count should be a positive integer")
7662  allocate(overlap%tileMe (count), overlap%dir(count) )
7663  allocate(overlap%is (count), overlap%ie (count) )
7664  allocate(overlap%js (count), overlap%je (count) )
7665  allocate(overlap%rotation(count) )
7666  overlap%rotation = ZERO
7667 
7668 end subroutine allocate_check_overlap
7669 
7670 !#######################################################################
7671 subroutine insert_check_overlap(overlap, pe, tileMe, dir, rotation, is, ie, js, je)
7672  type(overlap_type), intent(inout) :: overlap
7673  integer, intent(in ) :: pe
7674  integer, intent(in ) :: tileMe, dir, rotation
7675  integer, intent(in ) :: is, ie, js, je
7676  integer :: count
7677 
7678  overlap%count = overlap%count + 1
7679  count = overlap%count
7680  if(.NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
7681  "mpp_domains_define.inc(insert_check_overlap): overlap is not assigned any memory")
7682  if(count > size(overlap%tileMe(:)) ) call mpp_error(FATAL, &
7683  "mpp_domains_define.inc(insert_check_overlap): overlap%count is greater than size(overlap%tileMe)")
7684  if( overlap%pe == NULL_PE ) then
7685  overlap%pe = pe
7686  else
7687  if(overlap%pe .NE. pe) call mpp_error(FATAL, &
7688  "mpp_domains_define.inc(insert_check_overlap): mismatch on pe")
7689  endif
7690  overlap%tileMe (count) = tileMe
7691  overlap%dir (count) = dir
7692  overlap%rotation(count) = rotation
7693  overlap%is (count) = is
7694  overlap%ie (count) = ie
7695  overlap%js (count) = js
7696  overlap%je (count) = je
7697 
7698 end subroutine insert_check_overlap
7699 
7700 !#######################################################################
7701 !--- this routine add the overlap_in into overlap_out
7702 subroutine add_check_overlap( overlap_out, overlap_in)
7703  type(overlap_type), intent(inout) :: overlap_out
7704  type(overlap_type), intent(in ) :: overlap_in
7705  type(overlap_type) :: overlap
7706  integer :: count, count_in, count_out
7707 
7708  ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
7709  count_in = overlap_in %count
7710  count_out = overlap_out%count
7711  count = count_in+count_out
7712  if(count_in == 0) call mpp_error(FATAL, &
7713  "add_check_overlap(mpp_domains_define): overlap_in%count is zero")
7714 
7715  if(count_out == 0) then
7716  if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
7717  "add_check_overlap(mpp_domains_define): overlap is already been allocated but count=0")
7718  call allocate_check_overlap(overlap_out, count_in)
7719  overlap_out%pe = overlap_in%pe
7720  else ! need to expand the dimension size of overlap
7721  call allocate_check_overlap(overlap, count_out)
7722  if(overlap_out%pe .NE. overlap_in%pe) call mpp_error(FATAL, &
7723  "mpp_domains_define.inc(add_check_overlap): mismatch of pe between overlap_in and overlap_out")
7724  overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7725  overlap%is (1:count_out) = overlap_out%is (1:count_out)
7726  overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
7727  overlap%js (1:count_out) = overlap_out%js (1:count_out)
7728  overlap%je (1:count_out) = overlap_out%je (1:count_out)
7729  overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7730  overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7731  call deallocate_overlap_type(overlap_out)
7732  call allocate_check_overlap(overlap_out, count)
7733  overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7734  overlap_out%is (1:count_out) = overlap%is (1:count_out)
7735  overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
7736  overlap_out%js (1:count_out) = overlap%js (1:count_out)
7737  overlap_out%je (1:count_out) = overlap%je (1:count_out)
7738  overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7739  overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7740  call deallocate_overlap_type(overlap)
7741  end if
7742  overlap_out%count = count
7743  overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7744  overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
7745  overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
7746  overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
7747  overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
7748  overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7749  overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7750 
7751 end subroutine add_check_overlap
7752 
7753 !####################################################################
7754 subroutine init_overlap_type(overlap)
7755  type(overlap_type), intent(inout) :: overlap
7756 
7757  overlap%count = 0
7758  overlap%pe = NULL_PE
7759 
7760 end subroutine init_overlap_type
7761 
7762 !####################################################################
7763 
7764 subroutine allocate_update_overlap( overlap, count)
7765  type(overlap_type), intent(inout) :: overlap
7766  integer, intent(in ) :: count
7767 
7768  overlap%count = 0
7769  overlap%pe = NULL_PE
7770  if(associated(overlap%tileMe)) call mpp_error(FATAL, &
7771  "allocate_update_overlap(mpp_domains_define): overlap is already been allocated")
7772  if(count < 1) call mpp_error(FATAL, &
7773  "allocate_update_overlap(mpp_domains_define): count should be a positive integer")
7774  allocate(overlap%tileMe (count), overlap%tileNbr (count) )
7775  allocate(overlap%is (count), overlap%ie (count) )
7776  allocate(overlap%js (count), overlap%je (count) )
7777  allocate(overlap%dir (count), overlap%rotation(count) )
7778  allocate(overlap%from_contact(count), overlap%msgsize (count) )
7779  overlap%rotation = ZERO
7780  overlap%from_contact = .FALSE.
7781 
7782 end subroutine allocate_update_overlap
7783 
7784  !#####################################################################################
7785  subroutine insert_update_overlap(overlap, pe, is1, ie1, js1, je1, is2, ie2, js2, je2, dir, reverse, symmetry)
7786  type(overlap_type), intent(inout) :: overlap
7787  integer, intent(in ) :: pe
7788  integer, intent(in ) :: is1, ie1, js1, je1, is2, ie2, js2, je2
7789  integer, intent(in ) :: dir
7790  logical, optional, intent(in ) :: reverse, symmetry
7791 
7792  logical :: is_reverse, is_symmetry, is_overlapped
7793  integer :: is, ie, js, je, count
7794 
7795  is_reverse = .FALSE.
7796  if(PRESENT(reverse)) is_reverse = reverse
7797  is_symmetry = .FALSE.
7798  if(PRESENT(symmetry)) is_symmetry = symmetry
7799 
7800  is = max(is1,is2); ie = min(ie1,ie2)
7801  js = max(js1,js2); je = min(je1,je2)
7802  is_overlapped = .false.
7803  !--- to avoid unnecessary ( duplicate overlap ) for symmetry domain
7804  if(is_symmetry .AND. (dir == 1 .OR. dir == 5)) then ! x-direction
7805  if( ie .GE. is .AND. je .GT. js ) is_overlapped = .true.
7806  else if(is_symmetry .AND. (dir == 3 .OR. dir == 7)) then ! y-direction
7807  if( ie .GT. is .AND. je .GE. js ) is_overlapped = .true.
7808  else if(ie.GE.is .AND. je.GE.js )then
7809  is_overlapped = .true.
7810  endif
7811 
7812  if(is_overlapped) then
7813  if( overlap%count == 0 ) then
7814  overlap%pe = pe
7815  else
7816  if(overlap%pe .NE. pe) call mpp_error(FATAL, &
7817  "mpp_domains_define.inc(insert_update_overlap): mismatch on pe")
7818  endif
7819  overlap%count = overlap%count+1
7820  count = overlap%count
7821  if(count > MAXOVERLAP) call mpp_error(FATAL, &
7822  "mpp_domains_define.inc(insert_update_overlap): number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7823  overlap%is(count) = is
7824  overlap%ie(count) = ie
7825  overlap%js(count) = js
7826  overlap%je(count) = je
7827  overlap%tileMe (count) = 1
7828  overlap%tileNbr(count) = 1
7829  overlap%dir(count) = dir
7830  if(is_reverse) then
7831  overlap%rotation(count) = ONE_HUNDRED_EIGHTY
7832  else
7833  overlap%rotation(count) = ZERO
7834  end if
7835  end if
7836 
7837  end subroutine insert_update_overlap
7838 
7839  !#####################################################################################
7840 subroutine insert_overlap_type(overlap, pe, tileMe, tileNbr, is, ie, js, je, dir, &
7841  rotation, from_contact)
7842  type(overlap_type), intent(inout) :: overlap
7843  integer, intent(in ) :: tileMe, tileNbr, pe
7844  integer, intent(in ) :: is, ie, js, je
7845  integer, intent(in ) :: dir, rotation
7846  logical, intent(in ) :: from_contact
7847  integer :: count
7848 
7849  if( overlap%count == 0 ) then
7850  overlap%pe = pe
7851  else
7852  if(overlap%pe .NE. pe) call mpp_error(FATAL, &
7853  "mpp_domains_define.inc(insert_overlap_type): mismatch on pe")
7854  endif
7855  overlap%count = overlap%count+1
7856  count = overlap%count
7857  if(count > MAXOVERLAP) call mpp_error(FATAL, &
7858  "mpp_domains_define.inc(insert_overlap_type): number of overlap is greater than MAXOVERLAP, increase MAXOVERLAP")
7859  overlap%tileMe (count) = tileMe
7860  overlap%tileNbr (count) = tileNbr
7861  overlap%is (count) = is
7862  overlap%ie (count) = ie
7863  overlap%js (count) = js
7864  overlap%je (count) = je
7865  overlap%dir (count) = dir
7866  overlap%rotation (count) = rotation
7867  overlap%from_contact(count) = from_contact
7868  overlap%msgsize (count) = (ie-is+1)*(je-js+1)
7869 
7870 end subroutine insert_overlap_type
7871 
7872 
7873 !#######################################################################
7874 subroutine deallocate_overlap_type( overlap)
7875  type(overlap_type), intent(inout) :: overlap
7876 
7877  if(overlap%count == 0) then
7878  if( .NOT. associated(overlap%tileMe)) return
7879  else
7880  if( .NOT. associated(overlap%tileMe)) call mpp_error(FATAL, &
7881  "deallocate_overlap_type(mpp_domains_define): overlap is not been allocated")
7882  endif
7883  if(ASSOCIATED(overlap%tileMe)) deallocate(overlap%tileMe)
7884  if(ASSOCIATED(overlap%tileNbr)) deallocate(overlap%tileNbr)
7885  if(ASSOCIATED(overlap%is)) deallocate(overlap%is)
7886  if(ASSOCIATED(overlap%ie)) deallocate(overlap%ie)
7887  if(ASSOCIATED(overlap%js)) deallocate(overlap%js)
7888  if(ASSOCIATED(overlap%je)) deallocate(overlap%je)
7889  if(ASSOCIATED(overlap%dir)) deallocate(overlap%dir)
7890  if(ASSOCIATED(overlap%rotation)) deallocate(overlap%rotation)
7891  if(ASSOCIATED(overlap%from_contact)) deallocate(overlap%from_contact)
7892  if(ASSOCIATED(overlap%msgsize)) deallocate(overlap%msgsize)
7893  overlap%count = 0
7894 
7895 end subroutine deallocate_overlap_type
7896 
7897 !#######################################################################
7898 subroutine deallocate_overlapSpec(overlap)
7899 type(overlapSpec), intent(inout) :: overlap
7900 integer :: n
7901 
7902  if(ASSOCIATED(overlap%send)) then
7903  do n = 1, size(overlap%send(:))
7904  call deallocate_overlap_type(overlap%send(n))
7905  enddo
7906  deallocate(overlap%send)
7907  endif
7908  if(ASSOCIATED(overlap%recv)) then
7909  do n = 1, size(overlap%recv(:))
7910  call deallocate_overlap_type(overlap%recv(n))
7911  enddo
7912  deallocate(overlap%recv)
7913  endif
7914 
7915 
7916 end subroutine deallocate_overlapSpec
7917 
7918 !#######################################################################
7919 !--- this routine add the overlap_in into overlap_out
7920 subroutine add_update_overlap( overlap_out, overlap_in)
7921  type(overlap_type), intent(inout) :: overlap_out
7922  type(overlap_type), intent(in ) :: overlap_in
7923  type(overlap_type) :: overlap
7924  integer :: count, count_in, count_out, n
7925 
7926  ! if overlap_out%count == 0, then just copy overlap_in to overlap_out
7927  count_in = overlap_in %count
7928  count_out = overlap_out%count
7929  count = count_in+count_out
7930  if(count_in == 0) call mpp_error(FATAL, &
7931  "mpp_domains_define.inc(add_update_overlap): overlap_in%count is zero")
7932 
7933  if(count_out == 0) then
7934  if(associated(overlap_out%tileMe)) call mpp_error(FATAL, &
7935  "mpp_domains_define.inc(add_update_overlap): overlap is already been allocated but count=0")
7936  call allocate_update_overlap(overlap_out, count_in)
7937  overlap_out%pe = overlap_in%pe
7938  else ! need to expand the dimension size of overlap
7939  if(overlap_in%pe .NE. overlap_out%pe) call mpp_error(FATAL, &
7940  "mpp_domains_define.inc(add_update_overlap): mismatch of pe between overlap_in and overlap_out")
7941 
7942  call allocate_update_overlap(overlap, count_out)
7943  overlap%tileMe (1:count_out) = overlap_out%tileMe (1:count_out)
7944  overlap%tileNbr (1:count_out) = overlap_out%tileNbr (1:count_out)
7945  overlap%is (1:count_out) = overlap_out%is (1:count_out)
7946  overlap%ie (1:count_out) = overlap_out%ie (1:count_out)
7947  overlap%js (1:count_out) = overlap_out%js (1:count_out)
7948  overlap%je (1:count_out) = overlap_out%je (1:count_out)
7949  overlap%dir (1:count_out) = overlap_out%dir (1:count_out)
7950  overlap%rotation (1:count_out) = overlap_out%rotation (1:count_out)
7951  overlap%from_contact(1:count_out) = overlap_out%from_contact(1:count_out)
7952  call deallocate_overlap_type(overlap_out)
7953  call allocate_update_overlap(overlap_out, count)
7954  overlap_out%tileMe (1:count_out) = overlap%tileMe (1:count_out)
7955  overlap_out%tileNbr (1:count_out) = overlap%tileNbr (1:count_out)
7956  overlap_out%is (1:count_out) = overlap%is (1:count_out)
7957  overlap_out%ie (1:count_out) = overlap%ie (1:count_out)
7958  overlap_out%js (1:count_out) = overlap%js (1:count_out)
7959  overlap_out%je (1:count_out) = overlap%je (1:count_out)
7960  overlap_out%dir (1:count_out) = overlap%dir (1:count_out)
7961  overlap_out%rotation (1:count_out) = overlap%rotation (1:count_out)
7962  overlap_out%index (1:count_out) = overlap%index (1:count_out)
7963  overlap_out%from_contact(1:count_out) = overlap%from_contact(1:count_out)
7964  overlap_out%msgsize (1:count_out) = overlap%msgsize (1:count_out)
7965  call deallocate_overlap_type(overlap)
7966  end if
7967  overlap_out%count = count
7968  overlap_out%tileMe (count_out+1:count) = overlap_in%tileMe (1:count_in)
7969  overlap_out%tileNbr (count_out+1:count) = overlap_in%tileNbr (1:count_in)
7970  overlap_out%is (count_out+1:count) = overlap_in%is (1:count_in)
7971  overlap_out%ie (count_out+1:count) = overlap_in%ie (1:count_in)
7972  overlap_out%js (count_out+1:count) = overlap_in%js (1:count_in)
7973  overlap_out%je (count_out+1:count) = overlap_in%je (1:count_in)
7974  overlap_out%dir (count_out+1:count) = overlap_in%dir (1:count_in)
7975  overlap_out%rotation (count_out+1:count) = overlap_in%rotation (1:count_in)
7976  overlap_out%from_contact(count_out+1:count) = overlap_in%from_contact(1:count_in)
7977 
7978  do n = count_out+1, count
7979  overlap_out%msgsize(n) = (overlap_out%ie(n)-overlap_out%is(n)+1)*(overlap_out%je(n)-overlap_out%js(n)+1)
7980  enddo
7981 
7982 
7983 end subroutine add_update_overlap
7984 
7985 !##############################################################################
7986 subroutine expand_update_overlap_list(overlapList, npes)
7987  type(overlap_type), pointer :: overlapList(:)
7988  integer, intent(in ) :: npes
7989  type(overlap_type), pointer,save :: newlist(:) => NULL()
7990  integer :: nlist_old, nlist, m
7991 
7992  nlist_old = size(overlaplist(:))
7993  if(nlist_old .GE. npes) call mpp_error(FATAL, &
7994  'mpp_domains_define.inc(expand_update_overlap_list): size of overlaplist should be smaller than npes')
7995  nlist = min(npes, 2*nlist_old)
7996  allocate(newlist(nlist))
7997  do m = 1, nlist_old
7998  call add_update_overlap(newlist(m), overlaplist(m))
7999  call deallocate_overlap_type(overlapList(m))
8000  enddo
8001 
8002  deallocate(overlapList)
8003  overlaplist => newlist
8004  newlist => NULL()
8005 
8006  return
8007 
8008 end subroutine expand_update_overlap_list
8009 
8010 !##################################################################################
8011 subroutine expand_check_overlap_list(overlaplist, npes)
8012  type(overlap_type), pointer :: overlaplist(:)
8013  integer, intent(in) :: npes
8014  type(overlap_type), pointer,save :: newlist(:) => NULL()
8015  integer :: nlist_old, nlist, m
8016 
8017  nlist_old = size(overlaplist(:))
8018  if(nlist_old .GE. npes) call mpp_error(FATAL, &
8019  'mpp_domains_define.inc(expand_check_overlap_list): size of overlaplist should be smaller than npes')
8020  nlist = min(npes, 2*nlist_old)
8021  allocate(newlist(nlist))
8022  do m = 1,size(overlaplist(:))
8023  call add_check_overlap(newlist(m), overlaplist(m))
8024  call deallocate_overlap_type(overlapList(m))
8025  enddo
8026  deallocate(overlapList)
8027  overlaplist => newlist
8028 
8029 
8030  return
8031 
8032 end subroutine expand_check_overlap_list
8033 
8034 
8035 !###############################################################################
8036 subroutine check_overlap_pe_order(domain, overlap, name)
8037  type(domain2d), intent(in) :: domain
8038  type(overlapSpec), intent(in) :: overlap
8039  character(len=*), intent(in) :: name
8040  integer :: m
8041  integer :: pe1, pe2
8042 
8043  !---make sure overlap%nsend and overlap%nrecv is no larger than MAXLIST
8044  if( overlap%nsend > MAXLIST) call mpp_error(FATAL, &
8045  "mpp_domains_define.inc(check_overlap_pe_order): overlap%nsend > MAXLIST, increase MAXLIST")
8046  if( overlap%nrecv > MAXLIST) call mpp_error(FATAL, &
8047  "mpp_domains_define.inc(check_overlap_pe_order): overlap%nrecv > MAXLIST, increase MAXLIST")
8048 
8049  do m = 2, overlap%nsend
8050  pe1 = overlap%send(m-1)%pe
8051  pe2 = overlap%send(m)%pe
8052  !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8053  if( pe2 == domain%pe ) then
8054  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8055  call mpp_error(FATAL, &
8056  "mpp_domains_define.inc(check_overlap_pe_order): send pe2 can not equal to domain%pe")
8057  else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8058  if( pe2 < pe1 ) then
8059  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8060  call mpp_error(FATAL, &
8061  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 1")
8062  endif
8063  else if ( pe2 > domain%pe .AND. pe1 < domain%pe ) then
8064  print*, trim(name)//" at pe = ", domain%pe, ": send pe is ", pe1, pe2
8065  call mpp_error(FATAL, &
8066  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for send 2")
8067  endif
8068  enddo
8069 
8070 
8071  do m = 2, overlap%nrecv
8072  pe1 = overlap%recv(m-1)%pe
8073  pe2 = overlap%recv(m)%pe
8074  !-- when p1 == domain%pe, pe2 could be any value except domain%pe
8075  if( pe2 == domain%pe ) then
8076  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8077  call mpp_error(FATAL, &
8078  "mpp_domains_define.inc(check_overlap_pe_order): recv pe2 can not equal to domain%pe")
8079  else if( (pe1 > domain%pe .AND. pe2 > domain%pe) .OR. (pe1 < domain%pe .AND. pe2 < domain%pe)) then
8080  if( pe2 > pe1 ) then
8081  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8082  call mpp_error(FATAL, &
8083  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 1")
8084  endif
8085  else if ( pe2 < domain%pe .AND. pe1 > domain%pe ) then
8086  print*, trim(name)//" at pe = ", domain%pe, ": recv pe is ", pe1, pe2
8087  call mpp_error(FATAL, &
8088  "mpp_domains_define.inc(check_overlap_pe_order): pe is not in right order for recv 2")
8089  endif
8090  enddo
8091 
8092 
8093 end subroutine check_overlap_pe_order
8094 
8095 
8096 !###############################################################################
8097 subroutine set_domain_comm_inf(update)
8098  type(overlapSpec), intent(inout) :: update
8099 
8100  integer :: m, totsize, n
8101 
8102 
8103  ! first set the send and recv size
8104  update%sendsize = 0
8105  update%recvsize = 0
8106  do m = 1, update%nrecv
8107  totsize = 0
8108  do n = 1, update%recv(m)%count
8109  totsize = totsize + update%recv(m)%msgsize(n)
8110  enddo
8111  update%recv(m)%totsize = totsize
8112  if(m==1) then
8113  update%recv(m)%start_pos = 0
8114  else
8115  update%recv(m)%start_pos = update%recv(m-1)%start_pos + update%recv(m-1)%totsize
8116  endif
8117  update%recvsize = update%recvsize + totsize
8118  enddo
8119 
8120  do m = 1, update%nsend
8121  totsize = 0
8122  do n = 1, update%send(m)%count
8123  totsize = totsize + update%send(m)%msgsize(n)
8124  enddo
8125  update%send(m)%totsize = totsize
8126  if(m==1) then
8127  update%send(m)%start_pos = 0
8128  else
8129  update%send(m)%start_pos = update%send(m-1)%start_pos + update%send(m-1)%totsize
8130  endif
8131  update%sendsize = update%sendsize + totsize
8132  enddo
8133 
8134  return
8135 
8136 
8137 end subroutine set_domain_comm_inf
real(fp), parameter, public half
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version will
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> set_mismatch integer ::tile update_position nbuffersz l_size integer
l_size ! loop over number of fields ke do je do i
l_size ! loop over number of fields ke do je do ie to PE
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> unit
subroutine left(x1, y1, z1, x2, y2, z2, x0, y0, z0, output)
character(len=1), parameter equal
integer, private je
Definition: fms_io.F90:494
integer, save, private iec
Definition: oda_core.F90:124
integer, parameter, public no
integer, private jsd
Definition: fms_io.F90:495
subroutine, public add(value, cumul, num, wgt)
Definition: tools_func.F90:185
integer, parameter recv
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_WRITE_UNLIMITED_AXIS_1D_(unit, field, domain, data, nelems_io) integer, intent(in) ::unit type(fieldtype), intent(inout) ::field type(domain2D), intent(inout) ::domain MPP_TYPE_, intent(inout) ::data(:) integer, intent(in) ::nelems_io(:) ! number of compressed elements from each ! member of the io_domain. It MUST have the ! same order as the io_domain pelist. integer, allocatable ::pelist(:) integer ::i, j, nelems, npes type(domain2d), pointer ::io_domain=> allocatable
int npes
Definition: threadloc.c:26
integer, parameter, public up
subroutine, public copy(self, rhs)
integer, parameter, public corner
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT end
integer, parameter set
character(len=256) text
Definition: mpp_io.F90:1051
integer, pointer refinement
integer, parameter nx
integer(long), parameter true
subroutine, public divide(value, num)
Definition: tools_func.F90:214
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_DO_REDISTRIBUTE_3D_(f_in, f_out, d_comm, d_type) integer(LONG_KIND), intent(in) ::f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) ::d_comm MPP_TYPE_, intent(in) ::d_type MPP_TYPE_ ::field_in(d_comm%domain_in%x(1)%data%begin:d_comm%domain_in%x(1)%data%end, &d_comm%domain_in%y(1)%data%begin:d_comm%domain_in%y(1)%data%end, d_comm%ke) pointer(ptr_field_in, field_in) MPP_TYPE_ ::field_out(d_comm%domain_out%x(1)%data%begin:d_comm%domain_out%x(1)%data%end, &d_comm%domain_out%y(1)%data%begin:d_comm%domain_out%y(1)%data%end, d_comm%ke) pointer(ptr_field_out, field_out) type(domain2D), pointer ::domain_in, domain_out integer ::i, j, k, l, n, l_size integer ::is, ie, js, je integer ::ke integer ::list, pos, msgsize integer ::to_pe, from_pe MPP_TYPE_ ::buffer(size(mpp_domains_stack(:))) pointer(ptr, buffer) integer ::buffer_pos, wordlen, errunit!fix ke errunit=stderr() l_size=size(f_out(:)) ! equal to size(f_in(:)) ke=d_comm%ke domain_in=> d_comm domain_in
double * cross(const double *p1, const double *p2)
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************! this routine is used to retrieve scalar boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, &position, complete, tile_count) type(domain2D), intent(in) ::domain MPP_TYPE_, intent(in) ::field(:,:) MPP_TYPE_, intent(inout), optional ::ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:) integer, intent(in), optional ::flags, position, tile_count logical, intent(in), optional ::complete MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_, allocatable, dimension(:,:) ::ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D integer ::xcount, ycount integer ::ntile logical ::need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(LONG_KIND), dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save ::f_addrs=-9999 integer(LONG_KIND), dimension(4, MAX_DOMAIN_FIELDS, MAX_TILES), save ::b_addrs=-9999 integer, save ::bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags integer ::buffer_size(4) integer ::max_ntile, tile, update_position, ishift, jshift logical ::do_update, is_complete, set_mismatch character(len=3) ::text MPP_TYPE_ ::d_type type(overlapSpec), pointer ::bound=> NULL() ntile
integer, private ieg
Definition: fms_io.F90:496
real, parameter t2
real(r8), dimension(cast_m, cast_n) p
integer(long), parameter false
from from_pe
l_size ! loop over number of fields ke do j
integer, parameter send
character(len=32) name
integer, parameter, public west
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
logical module_is_initialized
integer, private jed
Definition: fms_io.F90:495
l_size ! loop over number of fields ke do je do ie to to_pe
integer, parameter m
character(len=128) version
real(double), parameter zero
real(fp), parameter, public e
logical debug
Definition: mpp.F90:1297
l_size ! loop over number of fields ke do je do ie to is
type
Definition: c2f.py:15
integer, parameter, public global
integer(long_kind) domain_cnt
subroutine, private initialize
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE start
integer, private ied
Definition: fms_io.F90:495
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for sending
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) & T
integer, private ie
Definition: fms_io.F90:494
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call mpp_error(FATAL, 'MPP_TRANSMIT:you cannot transmit to ANY_PE using MPI.') else if(to_pe.NE.NULL_PE) then !no other valid cases except NULL_PE call mpp_error(FATAL
integer error
Definition: mpp.F90:1310
real, dimension(:,:,:), allocatable, private g
Definition: tridiagonal.F90:74
l_size ! loop over number of fields ke do je do ie to je msgsize
integer, private isg
Definition: fms_io.F90:496
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this case
real, parameter t1
integer, parameter, public east
real(fvprc) function, dimension(size(a, 1), size(a, 2)) reverse(A)
integer, private jeg
Definition: fms_io.F90:496
logical, pointer fill
type(gsw_result_mpres) n2
real(double), parameter one
integer, dimension(:), pointer io_layout
logical function received(this, seqno)
string release
Definition: conf.py:67
logical debug_message_passing
integer, save, private isc
Definition: oda_core.F90:124
#define LONG_KIND
type(tms), dimension(nblks), private last
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
integer, parameter, public north
integer, save, private jsc
Definition: oda_core.F90:124
integer, private jsg
Definition: fms_io.F90:496
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) a
#define max(a, b)
Definition: mosaic_util.h:33
logical mosaic_defined
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine MPP_UPDATE_NEST_FINE_2D_(field, nest_domain, wbuffer, ebuffer, sbuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::field3D(size(field, 1), size(field, 2), 1) MPP_TYPE_ ::wbuffer3D(size(wbuffer, 1), size(wbuffer, 2), 1) MPP_TYPE_ ::ebuffer3D(size(ebuffer, 1), size(ebuffer, 2), 1) MPP_TYPE_ ::sbuffer3D(size(sbuffer, 1), size(sbuffer, 2), 1) MPP_TYPE_ ::nbuffer3D(size(nbuffer, 1), size(nbuffer, 2), 1) pointer(ptr, field3D) pointer(ptr_w, wbuffer3D) pointer(ptr_e, ebuffer3D) pointer(ptr_s, sbuffer3D) pointer(ptr_n, nbuffer3D) ptr=LOC(field) ptr_w=LOC(wbuffer) ptr_e=LOC(ebuffer) ptr_s=LOC(sbuffer) ptr_n=LOC(nbuffer) call mpp_update_nest_fine(field3D, nest_domain, wbuffer3D, ebuffer3D, sbuffer3D, nbuffer3D, &flags, complete, position, extra_halo, name, tile_count) returnend subroutine MPP_UPDATE_NEST_FINE_2D_subroutine MPP_UPDATE_NEST_FINE_3D_(field, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, &flags, complete, position, extra_halo, name, tile_count) MPP_TYPE_, intent(in) ::field(:,:,:) type(nest_domain_type), intent(inout) ::nest_domain MPP_TYPE_, intent(inout) ::wbuffer(:,:,:) MPP_TYPE_, intent(inout) ::ebuffer(:,:,:) MPP_TYPE_, intent(inout) ::sbuffer(:,:,:) MPP_TYPE_, intent(inout) ::nbuffer(:,:,:) integer, intent(in), optional ::flags logical, intent(in), optional ::complete integer, intent(in), optional ::position integer, intent(in), optional ::extra_halo character(len= *), intent(in), optional ::name integer, intent(in), optional ::tile_count MPP_TYPE_ ::d_type type(nestSpec), pointer ::update=> dimension(MAX_DOMAIN_FIELDS)
real(kind_real), parameter bound
Definition: type_diag.F90:29
integer, parameter, public cyclic
real(r8), dimension(cast_m, cast_n) t
integer, dimension(:), allocatable pelist
*f90 *************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If not
integer, save, private jec
Definition: oda_core.F90:124
l_size ! loop over number of fields ke do je do ie pos
integer, dimension(:), pointer layout
integer, parameter, public order
#define min(a, b)
Definition: mosaic_util.h:32
integer, parameter, public south
integer, private isd
Definition: fms_io.F90:495
real, parameter p1
Definition: sw_core_nlm.F90:46
real per
Longitude of perihelion with respect to autumnal equinox in NH [degrees].
Definition: astronomy.F90:345
subroutine, public some(xmap, some_arr, grid_id)
Definition: xgrid.F90:3421
type(taucoeff_type), save, public tc
integer, pointer ntiles
l_size ! loop over number of fields ke do je do ie to js
character(len=32) format
Definition: fms_io.F90:535
integer debug_update_level
integer, parameter, public information
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! MPP_TRANSMIT !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MPP_TRANSMIT_(put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, recv_request, send_request)!a message-passing routine intended to be reminiscent equally of both MPI and SHMEM!put_data and get_data are contiguous MPP_TYPE_ arrays!at each call, your put_data array is put to to_pe 's get_data! your get_data array is got from from_pe 's put_data!i.e we assume that typically(e.g updating halo regions) each PE performs a put _and_ a get!special PE designations:! NULL_PE:to disable a put or a get(e.g at boundaries)! ANY_PE:if remote PE for the put or get is to be unspecific! ALL_PES:broadcast and collect operations(collect not yet implemented)!ideally we would not pass length, but this f77-style call performs better(arrays passed by address, not descriptor)!further, this permits< length > contiguous words from an array of any rank to be passed(avoiding f90 rank conformance check)!caller is responsible for completion checks(mpp_sync_self) before and after integer, intent(in) ::put_len, to_pe, get_len, from_pe MPP_TYPE_, intent(in) ::put_data(*) MPP_TYPE_, intent(out) ::get_data(*) logical, intent(in), optional ::block integer, intent(in), optional ::tag integer, intent(out), optional ::recv_request, send_request logical ::block_comm integer ::i MPP_TYPE_, allocatable, save ::local_data(:) !local copy used by non-parallel code(no SHMEM or MPI) integer ::comm_tag integer ::rsize if(.NOT.module_is_initialized) call mpp_error(FATAL, 'MPP_TRANSMIT:You must first call mpp_init.') if(to_pe.EQ.NULL_PE .AND. from_pe.EQ.NULL_PE) return block_comm=.true. if(PRESENT(block)) block_comm=block if(debug) then call SYSTEM_CLOCK(tick) write(stdout_unit,'(a, i18, a, i6, a, 2i6, 2i8)')&'T=', tick, ' PE=', pe, ' MPP_TRANSMIT begin:to_pe, from_pe, put_len, get_len=', to_pe, from_pe, put_len, get_len end if comm_tag=DEFAULT_TAG if(present(tag)) comm_tag=tag!do put first and then get if(to_pe.GE.0 .AND. to_pe.LT.npes) then!use non-blocking sends if(debug .and.(current_clock.NE.0)) call SYSTEM_CLOCK(start_tick)!z1l:truly non-blocking send.! if(request(to_pe).NE.MPI_REQUEST_NULL) then !only one message from pe-> to_pe in queue *PE waiting for to_pe ! call error else get_len so only do gets but you cannot have a pure get with MPI call a get means do a wait to ensure put on remote PE is complete error call increase mpp_nml request_multiply call MPP_TRANSMIT get_len end if return end subroutine MPP_TRANSMIT_ ! MPP_BROADCAST ! subroutine but that doesn t allow !broadcast to a subset of PEs This version and mpp_transmit will remain !backward compatible intent(inout) MPP_BROADCAST begin