FMS  2025.04
Flexible Modeling System
mpp_define_nest_domains.inc
1 ! -*-f90-*-
2 
3 
4 !***********************************************************************
5 !* Apache License 2.0
6 !*
7 !* This file is part of the GFDL Flexible Modeling System (FMS).
8 !*
9 !* Licensed under the Apache License, Version 2.0 (the "License");
10 !* you may not use this file except in compliance with the License.
11 !* You may obtain a copy of the License at
12 !*
13 !* http://www.apache.org/licenses/LICENSE-2.0
14 !*
15 !* FMS is distributed in the hope that it will be useful, but WITHOUT
16 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
17 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
18 !* PARTICULAR PURPOSE. See the License for the specific language
19 !* governing permissions and limitations under the License.
20 !***********************************************************************
21 
22 !> @file
23 !> @brief Routines for use in @ref mpp_domains_mod for routines utilizing
24 !! domains with nested grids
25 
26 !> @addtogroup mpp_domains_mod
27 !> @{
28 
29 !#############################################################################
30 !> @brief Set up a domain to pass data between aligned coarse and fine grid of nested model.
31 !!
32 !> Set up a domain to pass data between aligned coarse and fine grid of a nested
33 !! model. Supports multiple and telescoping nests. A telescoping nest is defined as
34 !! a nest within a nest. Nest domains may span multiple tiles, but cannot contain a
35 !! coarse-grid, cube corner. Concurrent nesting is the only supported mechanism,
36 !! i.e. coarse and fine grid are on individual, non-overlapping, processor lists.
37 !! Coarse and fine grid domain need to be defined before calling mpp_define_nest_domains.
38 !! An mpp_broadcast is needed to broadcast both fine and coarse grid domain onto all processors.\n
39 !!\n
40 !! mpp_update_nest_coarse is used to pass data from fine grid to coarse grid computing domain.
41 !! mpp_update_nest_fine is used to pass data from coarse grid to fine grid halo.
42 !! You may call mpp_get_C2F_index before calling mpp_update_nest_fine to get the index for
43 !! passing data from coarse to fine. You may call mpp_get_F2C_index before calling
44 !! mpp_update_nest_coarse to get the index for passing data from coarse to fine.
45 !!
46 !> @note The following tests for nesting of regular lat-lon grids upon a cubed-sphere
47 !! grid are done in test_mpp_domains:\n
48 !! a) a first-level nest spanning multiple cubed-sphere faces (tiles 1, 2, & 4)\n
49 !! b) a first-level nest wholly contained within tile 3\n
50 !! c) a second-level nest contained within the nest mentioned in a)\n
51 !! Tests are done for data at T, E, C, N-cell center.\n
52 !!
53 !!
54 !! Below is an example to pass data between fine and coarse grid (More details on how to
55 !! use the nesting domain update are available in routine test_update_nest_domain of
56 !! test_fms/mpp/test_mpp_domains.F90.\n
57 !!\n
58 !! @code{.F90}
59 !! if( concurrent ) then
60 !! call mpp_broadcast_domain(domain_fine)
61 !! call mpp_broadcast_domain(domain_coarse)
62 !! endif
63 !!
64 !! call mpp_define_nest_domains(nest_domain,domain,num_nest,nest_level(1:num_nest), &
65 !! tile_fine(1:num_nest), tile_coarse(1:num_nest), &
66 !! istart_coarse(1:num_nest), icount_coarse(1:num_nest), &
67 !! jstart_coarse(1:num_nest), jcount_coarse(1:num_nest), &
68 !! npes_nest_tile, x_refine(1:num_nest), y_refine(1:num_nest), &
69 !! extra_halo=extra_halo, name="nest_domain")
70 !!
71 !! call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, WEST, level)
72 !! call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, EAST, level)
73 !! call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, SOUTH, level)
74 !! call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, NORTH, level)
75 !!
76 !! allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c,nz))
77 !! allocate(ebuffer(ise_c:iee_c, jse_c:jee_c,nz))
78 !! allocate(sbuffer(iss_c:ies_c, jss_c:jes_c,nz))
79 !! allocate(nbuffer(isn_c:ien_c, jsn_c:jen_c,nz))
80 !! call mpp_update_nest_fine(x, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer)
81 !!
82 !! call mpp_get_F2C_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f, nest_level=level)
83 !! allocate(buffer (is_f:ie_f, js_f:je_f,nz))
84 !! call mpp_update_nest_coarse(x, nest_domain, buffer)
85 !
86 !! call mpp_define_nest_domains (nest_domain, domain, num_nest, nest_level, tile_fine, tile_coarse,
87 !! istart_coarse, icount_coarse, jstart_coarse, jcount_coarse,
88 !! npes_nest_tile, x_refine, y_refine, extra_halo, name)
89 !!
90 !! @endcode
91 !!
92 !> @note Currently the contact will be limited to overlap contact.
93 !!
94 subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, tile_fine, tile_coarse, &
95  istart_coarse, icount_coarse, jstart_coarse, jcount_coarse, npes_nest_tile, &
96  x_refine, y_refine, extra_halo, name)
97  type(nest_domain_type), intent(inout) :: nest_domain !< holds the information to pass data
98  !! between nest and parent grids.
99  type(domain2d), target, intent(in ) :: domain !< domain for the grid defined in the current pelist
100  integer, intent(in ) :: num_nest !< number of nests
101  integer, intent(in ) :: nest_level(:) !< array containing the nest level for each nest
102  !!(>1 implies a telescoping nest)
103  integer, intent(in ) :: tile_fine(:), tile_coarse(:) !< array containing tile number of the
104  !! nest grid (monotonically increasing starting with 7),
105  !! array containing tile number of the parent grid corresponding
106  !! to the lower left corner of a given nest
107  integer, intent(in ) :: istart_coarse(:), icount_coarse(:), jstart_coarse(:), jcount_coarse(:) !<start
108  !! array containing index in the parent grid of the lower left corner of a given
109  !! nest, count: array containing span of the nest on the parent grid
110  integer, intent(in ) :: npes_nest_tile(:) !< array containing number of pes to allocated
111  !! to each defined tile
112  integer, intent(in ) :: x_refine(:), y_refine(:) !< array containing refinement ratio
113  !! for each nest
114  integer, optional, intent(in ) :: extra_halo !< extra halo for passing data from coarse grid to fine grid.
115  !! default is 0 and currently only support extra_halo = 0.
116  character(len=*), optional, intent(in ) :: name !< name of the nest domain
117 
118  integer :: n, l, m, my_tile_coarse
119  integer :: npes_level, prev_tile_coarse
120  integer :: extra_halo_local, npes_nest_top
121  integer, dimension(:), allocatable :: pes, pe_start_pos, pe_end_pos, pelist_level
122  logical, dimension(:), allocatable :: is_nest_fine, is_nest_coarse
123  integer, dimension(num_nest) :: istart_fine, iend_fine, jstart_fine, jend_fine
124  integer, dimension(num_nest) :: iend_coarse, jend_coarse
125  integer :: nnest, nlevels, ntiles_top, ntiles, pos
126  logical :: is_first
127 
128  if(PRESENT(name)) then
129  if(len_trim(name) > name_length) then
130  call mpp_error(fatal, "mpp_domains_define.inc(mpp_define_nest_domain): "// &
131  "the len_trim of optional argument name ="//trim(name)// &
132  " is greater than NAME_LENGTH, change the argument name or increase NAME_LENGTH")
133  endif
134  nest_domain%name = name
135  endif
136 
137  extra_halo_local = 0
138  if(present(extra_halo)) then
139  if(extra_halo .NE. 0) call mpp_error(fatal, &
140  & "mpp_define_nest_domains.inc: only support extra_halo=0, contact developer")
141  extra_halo_local = extra_halo
142  endif
143 
144  !---make sure dimension size is correct
145  if(size(tile_fine(:)) .NE. num_nest) call mpp_error(fatal, &
146  & .NE."mpp_define_nest_domains.inc: size(tile_fine) num_nest")
147  if(size(tile_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
148  & .NE."mpp_define_nest_domains.inc: size(tile_coarse) num_nest")
149  if(size(istart_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
150  & .NE."mpp_define_nest_domains.inc: size(istart_coarse) num_nest")
151  if(size(icount_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
152  & .NE."mpp_define_nest_domains.inc: size(icount_coarse) num_nest")
153  if(size(jstart_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
154  & .NE."mpp_define_nest_domains.inc: size(jstart_coarse) num_nest")
155  if(size(jcount_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
156  & .NE."mpp_define_nest_domains.inc: size(jcount_coarse) num_nest")
157 
158  do n = 1, num_nest
159  if(istart_coarse(n) < 1) call mpp_error(fatal, "mpp_define_nest_domains.inc: istart_coarse < 1")
160  if(icount_coarse(n) < 1) call mpp_error(fatal, "mpp_define_nest_domains.inc: iend_coarse < 1")
161  if(jstart_coarse(n) < 1) call mpp_error(fatal, "mpp_define_nest_domains.inc: jstart_coarse < 1")
162  if(jcount_coarse(n) < 1) call mpp_error(fatal, "mpp_define_nest_domains.inc: jend_coarse < 1")
163  iend_coarse(n) = istart_coarse(n) + icount_coarse(n) - 1
164  jend_coarse(n) = jstart_coarse(n) + jcount_coarse(n) - 1
165  istart_fine(n) = 1 ; iend_fine(n) = icount_coarse(n)*x_refine(n)
166  jstart_fine(n) = 1 ; jend_fine(n) = jcount_coarse(n)*y_refine(n)
167  end do
168 
169  !--- make sure the nest level is monotonic and no jumping
170  if(nest_level(1) .NE. 1) call mpp_error(fatal, .NE."mpp_define_nest_domains.inc: nest_level(1) 1")
171  do n = 2, num_nest
172  if(nest_level(n) < nest_level(n-1)) call mpp_error(fatal, &
173  & "mpp_define_nest_domains.inc: nest_level is not monotone increasing")
174  if(nest_level(n) > nest_level(n-1)+1) call mpp_error(fatal, &
175  & "mpp_define_nest_domains.inc: nest_level(n) > nest_level(n-1)+1")
176  enddo
177  nlevels = nest_level(num_nest)
178 
179  !---make sure tile_fine and tile_nest are monotone increasing.
180  do n = 2, num_nest
181  if(tile_fine(n) < tile_fine(n-1)) call mpp_error(fatal, &
182  & "mpp_define_nest_domains.inc: tile_fine is not monotone increasing")
183  if(tile_coarse(n) < tile_coarse(n-1)) call mpp_error(fatal, "mpp_define_nest_domains.inc: "// &
184  "tile_coarse is not monotone increasing")
185  enddo
186 
187  allocate( pes(mpp_npes()) )
188  call mpp_get_current_pelist(pes)
189 
190  nest_domain%num_nest = num_nest
191  allocate(nest_domain%tile_fine(num_nest), nest_domain%tile_coarse(num_nest) )
192  allocate(nest_domain%istart_fine(num_nest), nest_domain%iend_fine(num_nest) )
193  allocate(nest_domain%jstart_fine(num_nest), nest_domain%jend_fine(num_nest) )
194  allocate(nest_domain%istart_coarse(num_nest), nest_domain%iend_coarse(num_nest) )
195  allocate(nest_domain%jstart_coarse(num_nest), nest_domain%jend_coarse(num_nest) )
196 
197  !---Added to enable moving nests
198  if (associated(nest_domain%nest_level)) deallocate(nest_domain%nest_level) !< Check if allocated
199  allocate(nest_domain%nest_level(num_nest))
200 
201  nest_domain%tile_fine = tile_fine(1:num_nest)
202  nest_domain%tile_coarse = tile_coarse(1:num_nest)
203  nest_domain%istart_fine = istart_fine(1:num_nest)
204  nest_domain%iend_fine = iend_fine(1:num_nest)
205  nest_domain%jstart_fine = jstart_fine(1:num_nest)
206  nest_domain%jend_fine = jend_fine(1:num_nest)
207  nest_domain%istart_coarse = istart_coarse(1:num_nest)
208  nest_domain%iend_coarse = iend_coarse(1:num_nest)
209  nest_domain%jstart_coarse = jstart_coarse(1:num_nest)
210  nest_domain%jend_coarse = jend_coarse(1:num_nest)
211 
212  !---Added to enable moving nests; need this information when shifting the nest position.
213  nest_domain%nest_level = nest_level(1:num_nest)
214 
215  !--- make sure the tile_id of top level of grid is continuous and starting from 1
216  if(mpp_pe()==mpp_root_pe()) then
217  ntiles_top = domain%ntiles
218  do n = 1, ntiles_top
219  if(domain%tile_id_all(n) .NE. n) call mpp_error(fatal, &
220  "mpp_define_nest_domains.inc: top level grid tile_id should be 1, 2, ..,ntiles")
221  enddo
222  endif
223  call mpp_broadcast(ntiles_top, mpp_root_pe())
224  !--- make sure the nest grid tile_ids are continuous
225  do n = 1, num_nest
226  if(tile_fine(n) .NE. ntiles_top+n) then
227  print*, "tile_fine, ntile_top, n=", tile_fine(n), ntiles_top, n, mpp_pe()
228  call mpp_error(fatal, "mpp_define_nest_domains.inc: tile_id is not continuous")
229  endif
230  enddo
231 
232  allocate(pe_start_pos(ntiles_top+num_nest))
233  allocate(pe_end_pos(ntiles_top+num_nest))
234 
235  do n = 2, ntiles_top
236  if(npes_nest_tile(n) .NE. npes_nest_tile(n-1)) call mpp_error(fatal, &
237  "mpp_define_nest_domains.inc: all the tiles in top grid should use same number of MPI ranks")
238  enddo
239 
240  npes_nest_top = npes_nest_tile(1)*ntiles_top
241 
242  !--- get the pe start and end pos for each tile
243  do n = 1, ntiles_top
244  pe_start_pos(n) = 1
245  pe_end_pos(n) = npes_nest_tile(1)*ntiles_top
246  enddo
247  ntiles = tile_fine(num_nest)
248  if(ntiles .NE. ntiles_top + num_nest) call mpp_error(fatal, "mpp_define_nest_domains.inc: "// &
249  .NE."ntiles ntiles_top + num_nest")
250  do n = 1, num_nest
251  pe_start_pos(ntiles_top+n) = pe_end_pos(ntiles_top+n-1) + 1
252  pe_end_pos(ntiles_top+n) = pe_end_pos(ntiles_top+n-1) + npes_nest_tile(tile_fine(n))
253  enddo
254 
255  nest_domain%num_level = nlevels
256  if (associated(nest_domain%nest)) deallocate(nest_domain%nest) !< Check if allocated
257  allocate(nest_domain%nest(nlevels))
258  allocate(pelist_level(mpp_npes()))
259  allocate(is_nest_fine(nlevels))
260  allocate(is_nest_coarse(nlevels))
261 
262  !--- setup pelist for each level
263  pos = 0
264  is_nest_fine(:) = .false.
265  is_nest_coarse(:) = .false.
266  do l = 1, nlevels
267  npes_level = 0
268  pos = 0
269  is_first = .true.
270  prev_tile_coarse = 0
271  !--- first get coarse processor
272  do n = 1, num_nest
273  if(nest_level(n) == l) then
274  if(mpp_pe() .GE. pes(pe_start_pos(tile_fine(n))) .AND. mpp_pe() .LE. pes(pe_end_pos(tile_fine(n)))) then
275  is_nest_fine(l) = .true.
276  endif
277  if(mpp_pe() .GE. pes(pe_start_pos(tile_coarse(n))) .AND. mpp_pe() .LE. pes(pe_end_pos(tile_coarse(n)))) then
278  is_nest_coarse(l) = .true.
279  endif
280  if(pos==0 .OR. (l .NE. 1 .AND. prev_tile_coarse .NE. tile_coarse(n)) ) then
281  do m = pe_start_pos(tile_coarse(n)), pe_end_pos(tile_coarse(n))
282  pos = pos+1
283  pelist_level(pos) = pes(m)
284  enddo
285  npes_level = npes_level + pe_end_pos(tile_coarse(n)) - pe_start_pos(tile_coarse(n)) + 1
286  endif
287  prev_tile_coarse = tile_coarse(n)
288  endif
289  enddo
290  ! fine processor
291  do n = 1, num_nest
292  if(nest_level(n) == l) then
293  do m = pe_start_pos(tile_fine(n)), pe_end_pos(tile_fine(n))
294  pos = pos+1
295  pelist_level(pos) = pes(m)
296  enddo
297  npes_level = npes_level + pe_end_pos(tile_fine(n)) - pe_start_pos(tile_fine(n)) + 1
298  endif
299  enddo
300 
301  if (associated(nest_domain%nest(l)%pelist)) deallocate(nest_domain%nest(l)%pelist) !< Check if allocated
302  allocate(nest_domain%nest(l)%pelist(npes_level))
303  nest_domain%nest(l)%pelist(:) = pelist_level(1:npes_level)
304 
305  call mpp_declare_pelist(nest_domain%nest(l)%pelist)
306  nest_domain%nest(l)%on_level = any(nest_domain%nest(l)%pelist(:)==mpp_pe())
307  nest_domain%nest(l)%is_fine_pe = is_nest_fine(l)
308  nest_domain%nest(l)%is_coarse_pe = is_nest_coarse(l)
309  if(nest_domain%nest(l)%on_level .neqv. (is_nest_fine(l) .OR. is_nest_coarse(l))) then
310  print*, "on_level=", nest_domain%nest(l)%on_level, is_nest_fine(l), is_nest_coarse(l), mpp_pe(),l
311  call mpp_error(fatal, "mpp_define_nest_domains.inc:on_level does not match is_nest_fine/is_nest_coarse")
312  endif
313  if(is_nest_fine(l) .and. is_nest_coarse(l)) then
314  call mpp_error(fatal, "mpp_define_nest_domains.inc: is_nest_fine and is_nest_coarse can not both be true")
315  endif
316  enddo
317 
318  if(count(is_nest_fine)>1) call mpp_error(fatal, "mpp_define_nest_domains.inc: count(is_nest_fine)>1")
319  if(count(is_nest_coarse)>1) call mpp_error(fatal, "mpp_define_nest_domains.inc: count(is_nest_coarse)>1")
320 
321  do l = 1, nlevels
322  !--- setup for each level
323  if(nest_domain%nest(l)%on_level) then
324  call mpp_set_current_pelist(nest_domain%nest(l)%pelist)
325  nnest = count(nest_level==l)
326  nest_domain%nest(l)%num_nest = nnest
327  allocate(nest_domain%nest(l)%tile_fine(nnest), nest_domain%nest(l)%tile_coarse(nnest) )
328  allocate(nest_domain%nest(l)%istart_fine(nnest), nest_domain%nest(l)%iend_fine(nnest) )
329  allocate(nest_domain%nest(l)%jstart_fine(nnest), nest_domain%nest(l)%jend_fine(nnest) )
330  allocate(nest_domain%nest(l)%istart_coarse(nnest), nest_domain%nest(l)%iend_coarse(nnest) )
331  allocate(nest_domain%nest(l)%jstart_coarse(nnest), nest_domain%nest(l)%jend_coarse(nnest) )
332  my_tile_coarse = 0
333 
334  pos=0
335  do n = 1, num_nest
336  if(nest_level(n) ==l) then
337  pos = pos+1
338  nest_domain%nest(l)%tile_fine(pos) = tile_fine(n)
339  nest_domain%nest(l)%tile_coarse(pos) = tile_coarse(n)
340  nest_domain%nest(l)%istart_fine(pos) = istart_fine(n)
341  nest_domain%nest(l)%iend_fine(pos) = iend_fine(n)
342  nest_domain%nest(l)%jstart_fine(pos) = jstart_fine(n)
343  nest_domain%nest(l)%jend_fine(pos) = jend_fine(n)
344  nest_domain%nest(l)%istart_coarse(pos) = istart_coarse(n)
345  nest_domain%nest(l)%iend_coarse(pos) = iend_coarse(n)
346  nest_domain%nest(l)%jstart_coarse(pos) = jstart_coarse(n)
347  nest_domain%nest(l)%jend_coarse(pos) = jend_coarse(n)
348  if(l==1) then
349  my_tile_coarse = 1
350  else if( (mpp_pe() .GE. pes(pe_start_pos(tile_fine(n))) .AND. &
351  & mpp_pe() .LE. pes(pe_end_pos(tile_fine(n)))) .OR. &
352  & (mpp_pe() .GE. pes(pe_start_pos(tile_coarse(n))) .AND. &
353  & mpp_pe() .LE. pes(pe_end_pos(tile_coarse(n)))) ) then
354  my_tile_coarse = tile_coarse(n)
355  endif
356  endif
357  enddo
358  if(my_tile_coarse == 0) call mpp_error(fatal, "mpp_define_nest_domains.inc: my_tile_coarse == 0")
359 
360  if(pos .NE. nest_domain%nest(l)%num_nest) &
361  call mpp_error(fatal, .NE."mpp_define_nest_domains.inc:pos nest_domain%nest(l)%num_nest")
362 
363  if(is_nest_fine(l)) then
364  nest_domain%nest(l)%domain_fine=>domain
365  allocate(nest_domain%nest(l)%domain_coarse)
366  else if(is_nest_coarse(l)) then
367  nest_domain%nest(l)%domain_coarse=>domain
368  allocate(nest_domain%nest(l)%domain_fine)
369  endif
370 !!!! DEBUG CODE ! has problems on coarse domain
371 !!$ print*, 'MPP_BROADCAST_DOMAIN: ', mpp_pe(), l, & !ASSOCIATED(nest_domain%nest(l)%domain_fine), &
372 !!$ nest_domain%nest(l)%domain_fine%tile_id(1), nest_domain%nest(l)%tile_fine, tile_fine
373 !!!! END DEBUG CODE
374  call mpp_broadcast_domain(nest_domain%nest(l)%domain_fine, nest_domain%nest(l)%tile_fine)
375  call mpp_broadcast_domain(nest_domain%nest(l)%domain_coarse, my_tile_coarse)
376  call define_nest_level_type(nest_domain%nest(l), x_refine(l), y_refine(l), extra_halo_local)
377  endif
378  enddo
379 
380 end subroutine mpp_define_nest_domains
381 
382 !> Based on mpp_define_nest_domains, but just resets positioning of nest
383 !> Modifies the parent/coarse start and end indices of the nest location
384 !! Computes new overlaps of nest PEs on parent PEs
385 !! Ramstrom/HRD Moving Nest
386 subroutine mpp_shift_nest_domains(nest_domain, domain, delta_i_coarse, delta_j_coarse, extra_halo)
387  type(nest_domain_type), intent(inout) :: nest_domain !< holds the information to pass data
388  !! between nest and parent grids.
389  type(domain2d), target, intent(in ) :: domain !< domain for the grid defined in the current pelist
390  integer, intent(in ) :: delta_i_coarse(:) !< Array of deltas of coarse grid in y direction
391  integer, intent(in ) :: delta_j_coarse(:) !< Array of deltas of coarse grid in y direction
392  integer, optional, intent(in ) :: extra_halo !< Extra halo size
393 
394  integer :: n, l, my_tile_coarse
395  integer :: num_nest
396  integer :: extra_halo_local
397  integer :: nlevels, pos
398  integer, pointer :: nest_level(:)
399 
400  nest_level => nest_domain%nest_level
401 
402  extra_halo_local = 0
403  if(present(extra_halo)) then
404  if(extra_halo .NE. 0) call mpp_error(fatal, &
405  & "shift mpp_define_nest_domains.inc: only support extra_halo=0, contact developer")
406  extra_halo_local = extra_halo
407  endif
408 
409  num_nest = nest_domain%num_nest
410  nlevels = nest_level(num_nest)
411 
412  !---make sure dimension size is correct
413  if(size(delta_i_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
414  & .NE."shift mpp_define_nest_domains.inc: size(delta_i_coarse) num_nest")
415  if(size(delta_j_coarse(:)) .NE. num_nest) call mpp_error(fatal, &
416  & .NE."shift mpp_define_nest_domains.inc: size(delta_j_coarse) num_nest")
417 
418  ! Step through all nests and apply any modifications
419  ! Should only need to modify {i,j}{start,end}_coarse
420  ! The indices for fine do not change when the nest moves; only if it was changing size (which it cannot)
421  ! The PEs for running each component remain the same
422  ! But the nest may connect to different parent PEs after motion, so that must be recalculated
423  do n = 1, num_nest
424  ! Moving nest code performs validation to ensure nest does not run off edge
425 
426  nest_domain%istart_coarse(n) = nest_domain%istart_coarse(n) + delta_i_coarse(n)
427  nest_domain%iend_coarse(n) = nest_domain%iend_coarse(n) + delta_i_coarse(n)
428 
429  nest_domain%jstart_coarse(n) = nest_domain%jstart_coarse(n) + delta_j_coarse(n)
430  nest_domain%jend_coarse(n) = nest_domain%jend_coarse(n) + delta_j_coarse(n)
431 
432  end do
433 
434  ! Apply the nest motion in the nest_level_type structures
435  do l = 1, nlevels
436  !--- setup for each level
437  if(nest_domain%nest(l)%on_level) then
438  !nnest = count(nest_level==l)
439  my_tile_coarse = 0
440 
441  pos=0
442  do n = 1, num_nest
443  if(nest_level(n) ==l) then
444  pos = pos+1
445  nest_domain%nest(l)%istart_coarse(pos) = nest_domain%istart_coarse(n)
446  nest_domain%nest(l)%iend_coarse(pos) = nest_domain%iend_coarse(n)
447  nest_domain%nest(l)%jstart_coarse(pos) = nest_domain%jstart_coarse(n)
448  nest_domain%nest(l)%jend_coarse(pos) = nest_domain%jend_coarse(n)
449  endif
450  enddo
451 
452  if(pos .NE. nest_domain%nest(l)%num_nest) &
453  call mpp_error(fatal, .NE."shift mpp_define_nest_domains.inc:pos nest_domain%nest(l)%num_nest")
454 
455  ! The nest may connect to different parent PEs after motion, so this must be recalculated
456  call define_nest_level_type(nest_domain%nest(l), nest_domain%nest(l)%x_refine, &
457  & nest_domain%nest(l)%y_refine, extra_halo_local)
458  endif
459  enddo
460 
461 end subroutine mpp_shift_nest_domains
462 
463 
464 subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo)
465  type(nest_level_type), intent(inout) :: nest_domain !< nest domain to be defined
466  integer, intent(in ) :: extra_halo !< halo value
467  integer, intent(in ) :: x_refine, y_refine !< x and y refinements
468 
469  integer :: n
470  integer :: npes, npes_fine, npes_coarse
471  integer, allocatable :: pes_coarse(:)
472  integer, allocatable :: pes_fine(:)
473  integer, dimension(nest_domain%num_nest) :: my_nest_id
474  integer :: my_num_nest
475 
476  npes = size(nest_domain%pelist(:))
477  npes_coarse = size(nest_domain%domain_coarse%list(:))
478  npes_fine = size(nest_domain%domain_fine%list(:))
479  !--- pes_fine and pes_coarse should be subset of pelist
480  allocate( pes_coarse(npes_coarse) )
481  allocate( pes_fine(npes_fine ) )
482  do n = 1, npes_coarse
483  pes_coarse(n) = nest_domain%domain_coarse%list(n-1)%pe
484  if( .NOT. any(nest_domain%pelist(:) == pes_coarse(n)) ) then
485  call mpp_error(fatal, "mpp_define_nest_domains.inc: pelist_coarse is not subset of pelist")
486  endif
487  enddo
488  do n = 1, npes_fine
489  pes_fine(n) = nest_domain%domain_fine%list(n-1)%pe
490  if( .NOT. any(nest_domain%pelist(:) == pes_fine(n)) ) then
491  call mpp_error(fatal, "mpp_define_nest_domains.inc: pelist_fine is not subset of pelist")
492  endif
493  enddo
494 
495  if (associated(nest_domain%pelist_fine)) deallocate(nest_domain%pelist_fine) !< Check if allocated
496  allocate(nest_domain%pelist_fine(npes_fine))
497  if (associated(nest_domain%pelist_coarse)) deallocate(nest_domain%pelist_coarse) !< Check if allocated
498  allocate(nest_domain%pelist_coarse(npes_coarse))
499  nest_domain%pelist_fine = pes_fine
500  nest_domain%pelist_coarse = pes_coarse
501  if( nest_domain%is_fine_pe .neqv. any(pes_fine(:) == mpp_pe()) ) then
502  call mpp_error(fatal, .neqv."mpp_define_nest_domains.inc: nest_domain%is_fine_pe ANY(pes_fine(:) == mpp_pe())")
503  endif
504  if( nest_domain%is_coarse_pe .neqv. any(pes_coarse(:) == mpp_pe()) ) then
505  call mpp_error(fatal, "mpp_define_nest_domains.inc: "// &
506  .neqv."nest_domain%is_coarse_pe ANY(pes_coarse(:) == mpp_pe())")
507  endif
508 
509  !--- figure out the corresponding nested region.
510  !--- on coarse grid pe, it might overlap multiple fine regon.
511  !--- on fine grid pe, it always only overlap at most 1 coarse region.
512  my_num_nest= 0
513  my_nest_id(:) = 0
514  if( nest_domain%is_fine_pe ) then
515  !--- figure out the nest number on current pe
516  do n = 1, nest_domain%num_nest
517  if(nest_domain%domain_fine%tile_id(1) == nest_domain%tile_fine(n)) then
518  my_num_nest = my_num_nest + 1
519  my_nest_id(my_num_nest) = n
520  exit
521  end if
522  end do
523  if(my_num_nest .NE. 1) then
524  print*, "num_nest=", my_num_nest, nest_domain%domain_fine%tile_id(1), nest_domain%tile_fine(1)
525  call mpp_error(fatal, .ne."mpp_define_nest_domains.inc: my_num_nest 1 on fine pelist")
526  endif
527  else if( nest_domain%is_coarse_pe ) then
528  my_num_nest = nest_domain%num_nest
529  do n = 1, nest_domain%num_nest
530  my_nest_id(n) = n
531  enddo
532  endif
533 
534  nest_domain%my_num_nest = my_num_nest
535  if(my_num_nest>0) then
536  allocate(nest_domain%my_nest_id(my_num_nest))
537  nest_domain%my_nest_id(:) = my_nest_id(1:my_num_nest)
538  endif
539 
540  !--- We are assuming the fine grid is fully overlapped with coarse grid.
541  if( nest_domain%is_fine_pe ) then
542  if( nest_domain%iend_fine(my_nest_id(1))-nest_domain%istart_fine(my_nest_id(1))+1 &
543  .NE. nest_domain%domain_fine%x(1)%global%size .OR. &
544  nest_domain%jend_fine(my_nest_id(1))-nest_domain%jstart_fine(my_nest_id(1))+1 &
545  .NE. nest_domain%domain_fine%y(1)%global%size ) then
546  print*, "x size are", nest_domain%domain_fine%x(1)%global%size, &
547  nest_domain%istart_fine(my_nest_id(1)), nest_domain%iend_fine(my_nest_id(1))
548  print*, "y size are", nest_domain%domain_fine%y(1)%global%size, &
549  nest_domain%jstart_fine(my_nest_id(1)), nest_domain%jend_fine(my_nest_id(1))
550  call mpp_error(fatal, "mpp_define_nest_domains.inc: The fine global domain is not covered by coarse domain")
551  endif
552  endif
553 
554  ! only support concurrent run for fine and coarse domain, currently only check on coarse pe
555  if(nest_domain%is_coarse_pe) then
556 ! if( npes_fine + npes_coarse .NE. npes ) then
557 ! print*, "On pe =", mpp_pe(), npes_fine, npes_coarse, npes
558 ! call mpp_error(FATAL, "mpp_domains_define.inc: size(pelist_coarse)+size(pelist_fine) .NE. size(pelist)")
559 ! endif
560  endif
561 
562  !--- coarse grid and fine grid should be both symmetry or non-symmetry.
563  if(nest_domain%domain_coarse%symmetry .neqv. nest_domain%domain_fine%symmetry) then
564  print*,"symmetry is", nest_domain%domain_coarse%symmetry, nest_domain%domain_fine%symmetry, mpp_pe()
565  call mpp_error(fatal, .neqv..NOT."mpp_domains_define.inc: domain_coarse%symmetry domain_fine%symmetry")
566  endif
567 
568  nest_domain%x_refine = x_refine
569  nest_domain%y_refine = y_refine
570 
571  if (associated(nest_domain%C2F_T)) deallocate(nest_domain%C2F_T) !< Check if allocated
572  if (associated(nest_domain%C2F_C)) deallocate(nest_domain%C2F_C) !< Check if allocated
573  if (associated(nest_domain%C2F_E)) deallocate(nest_domain%C2F_E) !< Check if allocated
574  if (associated(nest_domain%C2F_N)) deallocate(nest_domain%C2F_N) !< Check if allocated
575  allocate( nest_domain%C2F_T, nest_domain%C2F_C, nest_domain%C2F_E, nest_domain%C2F_N )
576  nest_domain%C2F_T%next => null()
577  nest_domain%C2F_C%next => null()
578  nest_domain%C2F_N%next => null()
579  nest_domain%C2F_E%next => null()
580  if (associated(nest_domain%F2C_T)) deallocate(nest_domain%F2C_T) !< Check if allocated
581  if (associated(nest_domain%F2C_C)) deallocate(nest_domain%F2C_C) !< Check if allocated
582  if (associated(nest_domain%F2C_E)) deallocate(nest_domain%F2C_E) !< Check if allocated
583  if (associated(nest_domain%F2C_N)) deallocate(nest_domain%F2C_N) !< Check if allocated
584  allocate( nest_domain%F2C_T, nest_domain%F2C_C, nest_domain%F2C_E, nest_domain%F2C_N )
585 
586  call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_T, center, "F2C T-cell")
587  call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_E, east, "F2C E-cell")
588  call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_C, corner, "F2C C-cell")
589  call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_N, north, "F2C N-cell")
590 
591  call compute_overlap_coarse_to_fine(nest_domain, nest_domain%C2F_T, extra_halo, center, "C2F T-cell")
592  call compute_overlap_coarse_to_fine(nest_domain, nest_domain%C2F_E, extra_halo, east, "C2F E-cell")
593  call compute_overlap_coarse_to_fine(nest_domain, nest_domain%C2F_C, extra_halo, corner, "C2F C-cell")
594  call compute_overlap_coarse_to_fine(nest_domain, nest_domain%C2F_N, extra_halo, north, "C2F N-cell")
595 
596  deallocate(pes_fine, pes_coarse)
597 
598 
599 end subroutine define_nest_level_type
600 
601 
602 !###############################################################################
603 subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, position, name)
604  type(nest_level_type), intent(inout) :: nest_domain
605  type(nestspec), intent(inout) :: overlap
606  integer, intent(in ) :: extra_halo
607  integer, intent(in ) :: position
608  character(len=*), intent(in ) :: name
609 
610  type(domain2d), pointer :: domain_fine =>null()
611  type(domain2d), pointer :: domain_coarse=>null()
612  type(overlap_type), allocatable :: overlapList(:)
613  logical :: is_first
614  integer :: tile_fine, tile_coarse
615  integer :: istart_fine, iend_fine, jstart_fine, jend_fine
616  integer :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse
617  integer :: whalo, ehalo, shalo, nhalo
618  integer :: npes, npes_fine, npes_coarse, n, m
619  integer :: isg_fine, ieg_fine, jsg_fine, jeg_fine
620  integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse
621  integer :: is_coarse, ie_coarse, js_coarse, je_coarse
622  integer :: is_coarse2, ie_coarse2, js_coarse2, je_coarse2
623  integer :: rotate
624  integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2)
625  integer :: isc_fine, iec_fine, jsc_fine, jec_fine
626  integer :: isd_fine, ied_fine, jsd_fine, jed_fine
627  integer :: x_refine, y_refine, ishift, jshift
628  integer :: nsend, nrecv, dir, l, nn
629  integer :: nconvert
630  integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:)
631  integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:)
632  integer, allocatable :: isgl_fine(:), iegl_fine(:), jsgl_fine(:), jegl_fine(:)
633  integer :: outunit
634 
635 
636  outunit = stdout()
637  domain_fine => nest_domain%domain_fine
638  domain_coarse => nest_domain%domain_coarse
639  call mpp_get_domain_shift (domain_coarse, ishift, jshift, position)
640  npes = mpp_npes()
641  npes_fine = size(nest_domain%pelist_fine(:))
642  npes_coarse = size(nest_domain%pelist_coarse(:))
643 
644  allocate(isl_coarse(npes_coarse), iel_coarse(npes_coarse))
645  allocate(jsl_coarse(npes_coarse), jel_coarse(npes_coarse))
646  allocate(isl_fine(npes_fine ), iel_fine(npes_fine ))
647  allocate(jsl_fine(npes_fine ), jel_fine(npes_fine ))
648  allocate(isgl_fine(npes_fine ), iegl_fine(npes_fine ))
649  allocate(jsgl_fine(npes_fine ), jegl_fine(npes_fine ))
650 
651  call mpp_get_global_domain (domain_fine, xbegin=isg_fine, xend=ieg_fine, &
652  ybegin=jsg_fine, yend=jeg_fine)
653  call mpp_get_compute_domain (domain_coarse, xbegin=isc_coarse, xend=iec_coarse, &
654  ybegin=jsc_coarse, yend=jec_coarse)
655  call mpp_get_compute_domain (domain_fine, xbegin=isc_fine, xend=iec_fine, &
656  ybegin=jsc_fine, yend=jec_fine)
657  call mpp_get_compute_domains(domain_coarse, xbegin=isl_coarse, xend=iel_coarse, &
658  ybegin=jsl_coarse, yend=jel_coarse)
659  call mpp_get_compute_domains(domain_fine, xbegin=isl_fine, xend=iel_fine, &
660  ybegin=jsl_fine, yend=jel_fine)
661  call mpp_get_global_domains(domain_fine, xbegin=isgl_fine, xend=iegl_fine, &
662  ybegin=jsgl_fine, yend=jegl_fine)
663 
664  if( nest_domain%is_coarse_pe ) then
665  allocate(overlaplist(npes_fine))
666  overlap%xbegin = isc_coarse - domain_coarse%whalo
667  overlap%xend = iec_coarse + domain_coarse%ehalo + ishift
668  overlap%ybegin = jsc_coarse - domain_coarse%shalo
669  overlap%yend = jec_coarse + domain_coarse%nhalo + jshift
670  else
671  allocate(overlaplist(npes_coarse))
672  overlap%xbegin = isc_fine - domain_fine%whalo
673  overlap%xend = iec_fine + domain_fine%ehalo + ishift
674  overlap%ybegin = jsc_fine - domain_fine%shalo
675  overlap%yend = jec_fine + domain_fine%nhalo + jshift
676  endif
677 
678  overlap%extra_halo = extra_halo
679  x_refine = nest_domain%x_refine
680  y_refine = nest_domain%y_refine
681  whalo = domain_fine%whalo + extra_halo
682  ehalo = domain_fine%ehalo + extra_halo
683  shalo = domain_fine%shalo + extra_halo
684  nhalo = domain_fine%nhalo + extra_halo
685 
686  isd_fine = isc_fine - whalo
687  ied_fine = iec_fine + ehalo
688  jsd_fine = jsc_fine - shalo
689  jed_fine = jec_fine + nhalo
690 
691  overlap%nsend = 0
692  overlap%nrecv = 0
693  call init_index_type(overlap%west)
694  call init_index_type(overlap%east)
695  call init_index_type(overlap%south)
696  call init_index_type(overlap%north)
697  nsend = 0
698  nrecv = 0
699 
700  do nn = 1, nest_domain%num_nest
701 
702  tile_fine = nest_domain%tile_fine(nn)
703  tile_coarse = nest_domain%tile_coarse(nn)
704  istart_fine = nest_domain%istart_fine(nn)
705  iend_fine = nest_domain%iend_fine(nn)
706  jstart_fine = nest_domain%jstart_fine(nn)
707  jend_fine = nest_domain%jend_fine(nn)
708  istart_coarse = nest_domain%istart_coarse(nn)
709  iend_coarse = nest_domain%iend_coarse(nn)
710  jstart_coarse = nest_domain%jstart_coarse(nn)
711  jend_coarse = nest_domain%jend_coarse(nn)
712 
713  !--- first compute the halo region and corresponding index in coarse grid.
714  if( nest_domain%is_fine_pe .and. domain_fine%tile_id(1) == tile_fine) then
715  if( ieg_fine == iec_fine ) then ! east halo
716  is_coarse = iend_coarse
717  ie_coarse = iend_coarse + ehalo
718  js_coarse = jstart_coarse + ( jsc_fine - jsg_fine )/y_refine
719  je_coarse = jstart_coarse + ( jec_fine - jsg_fine )/y_refine
720  js_coarse = js_coarse - shalo
721  je_coarse = je_coarse + nhalo
722 
723  overlap%east%is_me = iec_fine + 1
724  overlap%east%ie_me = ied_fine
725  overlap%east%js_me = jsd_fine
726  overlap%east%je_me = jed_fine
727  overlap%east%is_you = is_coarse
728  overlap%east%ie_you = ie_coarse
729  overlap%east%js_you = js_coarse
730  overlap%east%je_you = je_coarse
731  endif
732 
733  if( jsg_fine == jsc_fine ) then ! south
734  is_coarse = istart_coarse + ( isc_fine - isg_fine )/x_refine
735  ie_coarse = istart_coarse + ( iec_fine - isg_fine )/x_refine
736  is_coarse = is_coarse - whalo
737  ie_coarse = ie_coarse + ehalo
738  js_coarse = jstart_coarse - shalo
739  je_coarse = jstart_coarse
740  overlap%south%is_me = isd_fine
741  overlap%south%ie_me = ied_fine
742  overlap%south%js_me = jsd_fine
743  overlap%south%je_me = jsc_fine-1
744  overlap%south%is_you = is_coarse
745  overlap%south%ie_you = ie_coarse
746  overlap%south%js_you = js_coarse
747  overlap%south%je_you = je_coarse
748  endif
749 
750  if( isg_fine == isc_fine ) then ! west
751  is_coarse = istart_coarse - whalo
752  ie_coarse = istart_coarse
753  js_coarse = jstart_coarse + ( jsc_fine - jsg_fine )/y_refine
754  je_coarse = jstart_coarse + ( jec_fine - jsg_fine )/y_refine
755  js_coarse = js_coarse - shalo
756  je_coarse = je_coarse + nhalo
757  overlap%west%is_me = isd_fine
758  overlap%west%ie_me = isc_fine-1
759  overlap%west%js_me = jsd_fine
760  overlap%west%je_me = jed_fine
761  overlap%west%is_you = is_coarse
762  overlap%west%ie_you = ie_coarse
763  overlap%west%js_you = js_coarse
764  overlap%west%je_you = je_coarse
765  endif
766 
767  if( jeg_fine == jec_fine ) then ! north
768  is_coarse = istart_coarse + ( isc_fine - isg_fine )/x_refine
769  ie_coarse = istart_coarse + ( iec_fine - isg_fine )/x_refine
770  is_coarse = is_coarse - whalo
771  ie_coarse = ie_coarse + ehalo
772  js_coarse = jend_coarse
773  je_coarse = jend_coarse + nhalo
774  overlap%north%is_me = isd_fine
775  overlap%north%ie_me = ied_fine
776  overlap%north%js_me = jec_fine+1
777  overlap%north%je_me = jed_fine
778  overlap%north%is_you = is_coarse
779  overlap%north%ie_you = ie_coarse
780  overlap%north%js_you = js_coarse
781  overlap%north%je_you = je_coarse
782  endif
783 
784  !-------------------------------------------------------------------------
785  !
786  ! Receiving
787  !
788  !-------------------------------------------------------------------------
789  !--- loop through coarse pelist
790  do n = 1, npes_coarse
791  is_first = .true.
792  do m = 1, 4
793  select case (m)
794  case (1) !--- east halo receiving
795  dir = 1
796  is_coarse = overlap%east%is_you
797  ie_coarse = overlap%east%ie_you
798  js_coarse = overlap%east%js_you
799  je_coarse = overlap%east%je_you
800  case (2) !--- south halo receiving
801  dir = 3
802  is_coarse = overlap%south%is_you
803  ie_coarse = overlap%south%ie_you
804  js_coarse = overlap%south%js_you
805  je_coarse = overlap%south%je_you
806  case (3) !--- west halo receiving
807  dir = 5
808  is_coarse = overlap%west%is_you
809  ie_coarse = overlap%west%ie_you
810  js_coarse = overlap%west%js_you
811  je_coarse = overlap%west%je_you
812  case (4) !--- north halo receiving
813  dir = 7
814  is_coarse = overlap%north%is_you
815  ie_coarse = overlap%north%ie_you
816  js_coarse = overlap%north%js_you
817  je_coarse = overlap%north%je_you
818  end select
819  if( je_coarse .GE. js_coarse .AND. ie_coarse .GE. is_coarse ) then
820  ! convert coarse grid index to the nested grid coarse grid index.
821  nconvert = convert_index_to_nest(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, &
822  jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%list(n-1)%tile_id(1), &
823  isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), &
824  is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
825  do l = 1, nconvert
826  is_coarse2 = max( is_coarse, is_convert2(l) )
827  ie_coarse2 = min( ie_coarse, ie_convert2(l) )
828  js_coarse2 = max( js_coarse, js_convert2(l) )
829  je_coarse2 = min( je_coarse, je_convert2(l) )
830  if( ie_coarse2 .GE. is_coarse2 .AND. je_coarse2 .GE. js_coarse2 ) then
831  select case (m)
832  case (1) !--- east halo
833  is_coarse2 = is_coarse2+ishift
834  ie_coarse2 = ie_coarse2+ishift
835  if(je_coarse2 == overlap%east%je_you) je_coarse2 = je_coarse2+jshift
836  case (2) !--- south halo
837  if(ie_coarse2 == overlap%south%ie_you) ie_coarse2 = ie_coarse2+ishift
838  case (3) !--- west halo
839  if(je_coarse2 == overlap%west%je_you) je_coarse2 = je_coarse2+jshift
840  case (4) !--- north halo
841  if(ie_coarse2 == overlap%north%ie_you) ie_coarse2 = ie_coarse2+ishift
842  js_coarse2 = js_coarse2+jshift
843  je_coarse2 = je_coarse2+jshift
844  end select
845 
846  if(is_first) then
847  nrecv = nrecv + 1
848  call allocate_nest_overlap(overlaplist(nrecv), maxoverlap)
849  is_first = .false.
850  endif
851  rotate = -rotate2(l)
852  call insert_nest_overlap(overlaplist(nrecv), nest_domain%pelist_coarse(n), &
853  is_coarse2, ie_coarse2, js_coarse2, je_coarse2 , dir, rotate2(l))
854  endif
855  enddo
856  endif
857  enddo
858  enddo
859 
860  endif
861  !-----------------------------------------------------------------------
862  !
863  ! Sending
864  !
865  !-----------------------------------------------------------------------
866 
867  if( nest_domain%is_coarse_pe ) then
868  do n = 1, npes_fine
869  if( domain_fine%list(n-1)%tile_id(1) .NE. tile_fine ) cycle
870  is_first = .true.
871  isg_fine = isgl_fine(n)
872  ieg_fine = iegl_fine(n)
873  jsg_fine = jsgl_fine(n)
874  jeg_fine = jegl_fine(n)
875 
876  !--- to_pe's east
877  if( ieg_fine == iel_fine(n) ) then
878  dir = 1
879  is_coarse = iend_coarse
880  ie_coarse = iend_coarse + ehalo
881  js_coarse = jstart_coarse + ( jsl_fine(n) - jsg_fine )/y_refine
882  je_coarse = jstart_coarse + ( jel_fine(n) - jsg_fine )/y_refine
883  js_coarse = js_coarse - shalo
884  je_coarse = je_coarse + nhalo
885  !--- convert the index to coarse grid index.
886  nconvert = convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, &
887  & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, ie_coarse,&
888  & js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
889  do l = 1, nconvert
890  is_coarse = max(isc_coarse, is_convert2(l))
891  ie_coarse = min(iec_coarse, ie_convert2(l))
892  js_coarse = max(jsc_coarse, js_convert2(l))
893  je_coarse = min(jec_coarse, je_convert2(l))
894  if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then
895  if(rotate2(l)==zero) then
896  is_coarse = is_coarse+ishift
897  ie_coarse = ie_coarse+ishift
898  if( je_coarse == je_convert2(l) ) je_coarse = je_coarse+jshift
899  else if(rotate2(l) == minus_ninety) then
900  js_coarse = js_coarse+ishift
901  je_coarse = je_coarse+ishift
902  if(is_coarse==is_convert2(l)) is_coarse = is_coarse-jshift
903  is_coarse = is_coarse+jshift
904  ie_coarse = ie_coarse+jshift
905  else if(rotate2(l) == ninety) then
906  if(ie_coarse==ie_convert2(l)) ie_coarse = ie_coarse+jshift
907  endif
908 
909  if(is_first) then
910  nsend = nsend + 1
911  call allocate_nest_overlap(overlaplist(nsend), maxoverlap)
912  is_first = .false.
913  endif
914  rotate = -rotate2(l)
915  call insert_nest_overlap(overlaplist(nsend), nest_domain%pelist_fine(n), &
916  is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate)
917  endif
918  enddo
919  endif
920 
921  !--- to_pe's south
922  if( jsg_fine == jsl_fine(n) ) then
923  dir = 3
924  is_coarse = istart_coarse + ( isl_fine(n) - isg_fine )/x_refine
925  ie_coarse = istart_coarse + ( iel_fine(n) - isg_fine )/x_refine
926  is_coarse = is_coarse - shalo
927  ie_coarse = ie_coarse + nhalo
928  js_coarse = jstart_coarse - shalo
929  je_coarse = jstart_coarse
930  !--- convert the index to coarse grid index.
931  nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, &
932  & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, &
933  & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
934  do l = 1, nconvert
935  is_coarse = max(isc_coarse, is_convert2(l))
936  ie_coarse = min(iec_coarse, ie_convert2(l))
937  js_coarse = max(jsc_coarse, js_convert2(l))
938  je_coarse = min(jec_coarse, je_convert2(l))
939 
940  if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then
941  if(rotate2(l)==zero .AND. ie_coarse==ie_convert2(l)) then
942  ie_coarse = ie_coarse+ishift
943  else if( rotate2(l) .NE. zero .AND. je_coarse == je_convert2(l) ) then
944  je_coarse = je_coarse+ishift
945  endif
946  if(is_first) then
947  nsend = nsend + 1
948  call allocate_nest_overlap(overlaplist(nsend), maxoverlap)
949  is_first = .false.
950  endif
951  rotate = -rotate2(l)
952  call insert_nest_overlap(overlaplist(nsend), nest_domain%pelist_fine(n), &
953  is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate)
954  endif
955  enddo
956  endif
957 
958  !--- to_pe's west
959  if( isg_fine == isl_fine(n) ) then
960  dir = 5
961  is_coarse = istart_coarse - whalo
962  ie_coarse = istart_coarse
963  js_coarse = jstart_coarse + ( jsl_fine(n) - jsg_fine )/y_refine
964  je_coarse = jstart_coarse + ( jel_fine(n) - jsg_fine )/y_refine
965  js_coarse = js_coarse - shalo
966  je_coarse = je_coarse + nhalo
967  !--- convert the index to coarse grid index.
968  nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, &
969  & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, &
970  & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
971  do l = 1, nconvert
972  is_coarse = max(isc_coarse, is_convert2(l))
973  ie_coarse = min(iec_coarse, ie_convert2(l))
974  js_coarse = max(jsc_coarse, js_convert2(l))
975  je_coarse = min(jec_coarse, je_convert2(l))
976  if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then
977  if(rotate2(l)==zero .and. je_coarse == je_convert2(l) ) then
978  je_coarse = je_coarse+jshift
979  else if(rotate2(l) .NE. zero .and. ie_coarse == ie_convert2(l) ) then
980  ie_coarse = ie_coarse+jshift
981  endif
982  if(is_first) then
983  nsend = nsend + 1
984  call allocate_nest_overlap(overlaplist(nsend), maxoverlap)
985  is_first = .false.
986  endif
987  rotate = -rotate2(l)
988  call insert_nest_overlap(overlaplist(nsend), nest_domain%pelist_fine(n), &
989  is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate)
990  endif
991  enddo
992  endif
993 
994  !--- to_pe's north
995  if( jeg_fine == jel_fine(n) ) then
996  dir = 7
997  is_coarse = istart_coarse + ( isl_fine(n) - isg_fine )/x_refine
998  ie_coarse = istart_coarse + ( iel_fine(n) - isg_fine )/x_refine
999  is_coarse = is_coarse - shalo
1000  ie_coarse = ie_coarse + nhalo
1001  js_coarse = jend_coarse
1002  je_coarse = jend_coarse + nhalo
1003  !--- convert the index to coarse grid index.
1004  nconvert=convert_index_to_coarse(domain_coarse, 0, 0, tile_coarse, istart_coarse, iend_coarse, &
1005  & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_coarse, &
1006  & ie_coarse, js_coarse, je_coarse, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
1007  do l = 1, nconvert
1008  is_coarse = max(isc_coarse, is_convert2(l))
1009  ie_coarse = min(iec_coarse, ie_convert2(l))
1010  js_coarse = max(jsc_coarse, js_convert2(l))
1011  je_coarse = min(jec_coarse, je_convert2(l))
1012  if( ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then
1013  if(rotate2(l)==zero) then
1014  if(ie_coarse==ie_convert2(l)) ie_coarse = ie_coarse+ishift
1015  js_coarse = js_coarse+jshift
1016  je_coarse = je_coarse+jshift
1017  else if(rotate2(l) == ninety) then
1018  if(js_coarse==js_convert2(l)) js_coarse = js_coarse-ishift
1019  js_coarse = js_coarse+ishift
1020  je_coarse = je_coarse+ishift
1021  is_coarse = is_coarse+jshift
1022  ie_coarse = ie_coarse+jshift
1023  else if(rotate2(l) == minus_ninety ) then
1024  if(je_coarse==je_convert2(l)) je_coarse = je_coarse+ishift
1025  endif
1026  if(is_first) then
1027  nsend = nsend + 1
1028  call allocate_nest_overlap(overlaplist(nsend), maxoverlap)
1029  is_first = .false.
1030  endif
1031  rotate = -rotate2(l)
1032  call insert_nest_overlap(overlaplist(nsend), nest_domain%pelist_fine(n), &
1033  is_coarse, ie_coarse, js_coarse, je_coarse , dir, rotate)
1034  endif
1035  enddo
1036  endif
1037  enddo
1038  endif
1039  enddo
1040 
1041  !--- copy the overlapping into nest_domain data.
1042  overlap%nrecv = nrecv
1043  if( nrecv > 0 ) then
1044  if (associated(overlap%recv)) deallocate(overlap%recv) !< Check if allocated
1045  allocate(overlap%recv(nrecv))
1046  do n = 1, nrecv
1047  call copy_nest_overlap( overlap%recv(n), overlaplist(n) )
1048 ! call print_nest_overlap(overlap%recv(n), "C2F RECV")
1049  call deallocate_nest_overlap( overlaplist(n) )
1050  enddo
1051  endif
1052 
1053  overlap%nsend = nsend
1054  if( nsend > 0 ) then
1055  if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated
1056  allocate(overlap%send(nsend))
1057  do n = 1, nsend
1058  call copy_nest_overlap( overlap%send(n), overlaplist(n) )
1059 ! call print_nest_overlap(overlap%send(n), "C2F SEND")
1060  call deallocate_nest_overlap( overlaplist(n) )
1061  enddo
1062  endif
1063  if(allocated(overlaplist))deallocate(overlaplist)
1064 
1065 
1066  deallocate(isl_coarse, iel_coarse, jsl_coarse, jel_coarse)
1067  deallocate(isl_fine, iel_fine, jsl_fine, jel_fine)
1068  deallocate(isgl_fine, iegl_fine, jsgl_fine, jegl_fine)
1069 
1070  !--- add shift value accoring grid position
1071  if( nest_domain%is_fine_pe ) then
1072  if( ieg_fine == iec_fine ) then ! east halo
1073  overlap%east%is_me = overlap%east%is_me + ishift
1074  overlap%east%ie_me = overlap%east%ie_me + ishift
1075  overlap%east%je_me = overlap%east%je_me + jshift
1076  overlap%east%is_you = overlap%east%is_you + ishift
1077  overlap%east%ie_you = overlap%east%ie_you + ishift
1078  overlap%east%je_you = overlap%east%je_you + jshift
1079  endif
1080 
1081  if( jsg_fine == jsc_fine ) then ! south
1082  overlap%south%ie_me = overlap%south%ie_me + ishift
1083  overlap%south%ie_you = overlap%south%ie_you + ishift
1084  endif
1085 
1086  if( isg_fine == isc_fine ) then ! west
1087  overlap%west%je_me = overlap%west%je_me + jshift
1088  overlap%west%je_you = overlap%west%je_you + jshift
1089  endif
1090 
1091  if( jeg_fine == jec_fine ) then ! north
1092  overlap%north%ie_me = overlap%north%ie_me + ishift
1093  overlap%north%js_me = overlap%north%js_me + jshift
1094  overlap%north%je_me = overlap%north%je_me + jshift
1095  overlap%north%ie_you = overlap%north%ie_you + ishift
1096  overlap%north%js_you = overlap%north%js_you + jshift
1097  overlap%north%je_you = overlap%north%je_you + jshift
1098  endif
1099  endif
1100 
1101  if(debug_message_passing) call debug_message_size(overlap, name)
1102 
1103 
1104 end subroutine compute_overlap_coarse_to_fine
1105 
1106 !###############################################################################
1107 !> This routine will compute the send and recv information between overlapped nesting
1108 !! region. The data is assumed on T-cell center.
1109 subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name)
1110  type(nest_level_type), intent(inout) :: nest_domain
1111  type(nestspec), intent(inout) :: overlap
1112  integer, intent(in ) :: position
1113  character(len=*), intent(in ) :: name
1114 
1115  !--- local variables
1116 
1117  type(domain2d), pointer :: domain_fine =>null()
1118  type(domain2d), pointer :: domain_coarse=>null()
1119  type(overlap_type), allocatable :: overlapList(:)
1120  integer :: tile_fine, tile_coarse
1121  integer :: istart_fine, iend_fine, jstart_fine, jend_fine
1122  integer :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse
1123  integer :: npes_fine, npes_coarse, n
1124  integer :: isg_fine, ieg_fine, jsg_fine, jeg_fine
1125  integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse
1126  integer :: is_coarse, ie_coarse, js_coarse, je_coarse
1127  integer :: isc_fine, iec_fine, jsc_fine, jec_fine
1128  integer :: is_you, ie_you, js_you, je_you
1129  integer :: x_refine, y_refine
1130  integer :: nsend, nrecv, dir
1131  integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:)
1132  integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:)
1133  integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2)
1134  integer :: is2, ie2, js2, je2, nconvert
1135  integer :: xbegin_c, xend_c, ybegin_c, yend_c
1136  integer :: ishift, jshift, l, is3, ie3, js3, je3, nn
1137 
1138  domain_fine => nest_domain%domain_fine
1139  domain_coarse => nest_domain%domain_coarse
1140  npes_fine = size(nest_domain%pelist_fine(:))
1141  npes_coarse = size(nest_domain%pelist_coarse(:))
1142 
1143  allocate(isl_coarse(npes_coarse), iel_coarse(npes_coarse) )
1144  allocate(jsl_coarse(npes_coarse), jel_coarse(npes_coarse) )
1145  allocate(isl_fine(npes_fine), iel_fine(npes_fine) )
1146  allocate(jsl_fine(npes_fine), jel_fine(npes_fine) )
1147  call mpp_get_domain_shift (domain_coarse, ishift, jshift, position)
1148 
1149  call mpp_get_compute_domain (domain_coarse, xbegin=isc_coarse, xend=iec_coarse, ybegin=jsc_coarse, yend=jec_coarse)
1150  call mpp_get_compute_domain (domain_fine, xbegin=isc_fine, xend=iec_fine, ybegin=jsc_fine, yend=jec_fine)
1151  call mpp_get_compute_domains(domain_coarse, xbegin=isl_coarse, xend=iel_coarse, ybegin=jsl_coarse, yend=jel_coarse)
1152  call mpp_get_compute_domains(domain_fine, xbegin=isl_fine, xend=iel_fine, ybegin=jsl_fine, yend=jel_fine)
1153  call mpp_get_global_domain (domain_fine, xbegin=isg_fine, xend=ieg_fine, ybegin=jsg_fine, yend=jeg_fine)
1154  overlap%center%is_you = 0; overlap%center%ie_you = -1
1155  overlap%center%js_you = 0; overlap%center%je_you = -1
1156 
1157  overlap%nsend = 0
1158  overlap%nrecv = 0
1159  call init_index_type(overlap%center)
1160 
1161  if( nest_domain%is_fine_pe ) then
1162  overlap%xbegin = 0; overlap%xend = -1
1163  overlap%ybegin = 0; overlap%yend = -1
1164  else
1165  overlap%xbegin = isc_coarse - domain_coarse%whalo
1166  overlap%xend = iec_coarse + domain_coarse%ehalo + ishift
1167  overlap%ybegin = jsc_coarse - domain_coarse%shalo
1168  overlap%yend = jec_coarse + domain_coarse%nhalo + jshift
1169  overlap%xsize_c = overlap%xend - overlap%xbegin + 1
1170  overlap%ysize_c = overlap%yend - overlap%ybegin + 1
1171  overlap%xbegin_f = 0
1172  overlap%xend_f = -1
1173  overlap%ybegin_f = 0
1174  overlap%yend_f = -1
1175  overlap%xbegin_c = 0
1176  overlap%xend_c = -1
1177  overlap%ybegin_c = 0
1178  overlap%yend_c = -1
1179  endif
1180 
1181  if(nest_domain%is_fine_pe) then
1182  nsend = 0
1183  allocate(overlaplist(npes_coarse))
1184  do nn = 1, nest_domain%num_nest
1185  tile_fine = nest_domain%tile_fine(nn)
1186  tile_coarse = nest_domain%tile_coarse(nn)
1187  istart_fine = nest_domain%istart_fine(nn)
1188  iend_fine = nest_domain%iend_fine(nn)
1189  jstart_fine = nest_domain%jstart_fine(nn)
1190  jend_fine = nest_domain%jend_fine(nn)
1191  istart_coarse = nest_domain%istart_coarse(nn)
1192  iend_coarse = nest_domain%iend_coarse(nn)
1193  jstart_coarse = nest_domain%jstart_coarse(nn)
1194  jend_coarse = nest_domain%jend_coarse(nn)
1195  x_refine = nest_domain%x_refine
1196  y_refine = nest_domain%y_refine
1197 
1198  !--- set up the data range for fine and coarse grid.
1199  !--- on coarse grid pelist, xbegin_f, ybegin_f, xend_f, yend_f is dummy value
1200  !--- on fine grid pelist, xbegin_c, xend_c, ybegin_c, yend_c are the coarse grid index that
1201  !--- the fine grid overlapped with.
1202  !--- One coarse grid box might overlap with multiple fine grid processor. We use
1203  !--- the west/south/southwest processor to store the coarse grid data.
1204  if(tile_fine .NE. domain_fine%tile_id(1)) cycle
1205  is_coarse = istart_coarse + (isc_fine-istart_fine)/x_refine
1206  ie_coarse = istart_coarse + (iec_fine-istart_fine)/x_refine
1207  if(mod(isc_fine-istart_fine, x_refine) .NE. 0 ) is_coarse = is_coarse + 1
1208  js_coarse = jstart_coarse + (jsc_fine-jstart_fine)/y_refine
1209  je_coarse = jstart_coarse + (jec_fine-jstart_fine)/y_refine
1210  if(mod(jsc_fine-jstart_fine, y_refine) .NE. 0 ) js_coarse = js_coarse + 1
1211  overlap%xbegin_c = is_coarse
1212  overlap%xend_c = ie_coarse
1213  overlap%ybegin_c = js_coarse
1214  overlap%yend_c = je_coarse
1215  overlap%xbegin_f = istart_fine + (overlap%xbegin_c-istart_coarse)*x_refine
1216  overlap%xend_f = istart_fine + (overlap%xend_c-istart_coarse+1)*x_refine - 1
1217  overlap%ybegin_f = jstart_fine + (overlap%ybegin_c-jstart_coarse)*y_refine
1218  overlap%yend_f = jstart_fine + (overlap%yend_c-jstart_coarse+1)*y_refine - 1
1219  xbegin_c = overlap%xbegin_c
1220  xend_c = overlap%xend_c
1221  ybegin_c = overlap%ybegin_c
1222  yend_c = overlap%yend_c
1223  ! if(iec_fine == ieg_fine) then
1224  overlap%xend_c = overlap%xend_c + ishift
1225  overlap%xend_f = overlap%xend_f + ishift
1226  ! endif
1227  ! if(jec_fine == jeg_fine) then
1228  overlap%yend_c = overlap%yend_c + jshift
1229  overlap%yend_f = overlap%yend_f + jshift
1230  ! endif
1231 
1232  overlap%xsize_c = overlap%xend_c - overlap%xbegin_c + 1
1233  overlap%ysize_c = overlap%yend_c - overlap%ybegin_c + 1
1234 
1235  !-----------------------------------------------------------------------------------------
1236  !
1237  ! Sending From fine to coarse.
1238  ! compute the send information from fine grid to coarse grid. This will only need to send
1239  ! the internal of fine grid to coarse grid.
1240  !-----------------------------------------------------------------------------------------
1241  do n = 1, npes_coarse
1242  nconvert = convert_index_to_nest(domain_coarse, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, &
1243  jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%list(n-1)%tile_id(1), &
1244  isl_coarse(n), iel_coarse(n), jsl_coarse(n), jel_coarse(n), &
1245  is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
1246  is2 = xbegin_c; ie2 = xend_c
1247  js2 = ybegin_c; je2 = yend_c
1248  is3 = is2; js3 = js2
1249  do l = 1, nconvert
1250  if(rotate2(l) == ninety .OR. rotate2(l) == minus_ninety) then
1251  ie3 = ie2 + jshift
1252  je3 = je2 + ishift
1253  else
1254  ie3 = ie2 + ishift
1255  je3 = je2 + jshift
1256  endif
1257  is_coarse = max( is3, is_convert2(l) )
1258  ie_coarse = min( ie3, ie_convert2(l) )
1259  js_coarse = max( js3, js_convert2(l) )
1260  je_coarse = min( je3, je_convert2(l) )
1261  if(ie_coarse .GE. is_coarse .AND. je_coarse .GE. js_coarse ) then
1262  dir = 0
1263  nsend = nsend + 1
1264  call allocate_nest_overlap(overlaplist(nsend), maxoverlap)
1265  call insert_nest_overlap(overlaplist(nsend), nest_domain%pelist_coarse(n), &
1266  is_coarse, ie_coarse, js_coarse, je_coarse, dir, rotate2(l))
1267  endif
1268  enddo
1269  enddo
1270  enddo
1271  overlap%nsend = nsend
1272  if(nsend > 0) then
1273  if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated
1274  allocate(overlap%send(nsend))
1275  do n = 1, nsend
1276  call copy_nest_overlap(overlap%send(n), overlaplist(n) )
1277 ! call print_nest_overlap(overlap%send(n), "SEND")
1278  call deallocate_nest_overlap(overlaplist(n))
1279  enddo
1280  endif
1281  if(allocated(overlaplist))deallocate(overlaplist)
1282  endif
1283  !--------------------------------------------------------------------------------
1284  ! compute the recv information from fine grid to coarse grid. This will only need to send
1285  ! the internal of fine grid to coarse grid.
1286  !--------------------------------------------------------------------------------
1287 
1288  if( nest_domain%is_coarse_pe ) then
1289  nrecv = 0
1290  allocate(overlaplist(npes_fine))
1291  do nn = 1, nest_domain%num_nest
1292  tile_fine = nest_domain%tile_fine(nn)
1293  tile_coarse = nest_domain%tile_coarse(nn)
1294  istart_fine = nest_domain%istart_fine(nn)
1295  iend_fine = nest_domain%iend_fine(nn)
1296  jstart_fine = nest_domain%jstart_fine(nn)
1297  jend_fine = nest_domain%jend_fine(nn)
1298  istart_coarse = nest_domain%istart_coarse(nn)
1299  iend_coarse = nest_domain%iend_coarse(nn)
1300  jstart_coarse = nest_domain%jstart_coarse(nn)
1301  jend_coarse = nest_domain%jend_coarse(nn)
1302  x_refine = nest_domain%x_refine
1303  y_refine = nest_domain%y_refine
1304 
1305  dir = 0
1306  do n = 1, npes_fine
1307  if(tile_fine .NE. domain_fine%list(n-1)%tile_id(1)) cycle
1308  is_you = istart_coarse + (isl_fine(n)-istart_fine)/x_refine
1309  ie_you = istart_coarse + (iel_fine(n)-istart_fine)/x_refine
1310  if(mod(isl_fine(n)-istart_fine, x_refine) .NE. 0 ) is_you = is_you + 1
1311  js_you = jstart_coarse + (jsl_fine(n)-jstart_fine)/y_refine
1312  je_you = jstart_coarse + (jel_fine(n)-jstart_fine)/y_refine
1313  if(mod(jsl_fine(n)-jstart_fine, y_refine) .NE. 0 ) js_you = js_you + 1
1314  nconvert=convert_index_to_coarse(domain_coarse, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, &
1315  & jstart_coarse, jend_coarse, domain_coarse%ntiles, domain_coarse%tile_id(1), is_you, ie_you, &
1316  & js_you, je_you, is_convert2, ie_convert2, js_convert2, je_convert2, rotate2)
1317  do l = 1, nconvert
1318  is2 = max(is_convert2(l), isc_coarse)
1319  ie2 = min(ie_convert2(l), iec_coarse+ishift)
1320  js2 = max(js_convert2(l), jsc_coarse)
1321  je2 = min(je_convert2(l), jec_coarse+jshift)
1322 
1323  if( ie2 .GE. is2 .AND. je2 .GE. js2 ) then
1324  nrecv = nrecv + 1
1325  call allocate_nest_overlap(overlaplist(nrecv), maxoverlap)
1326  call insert_nest_overlap(overlaplist(nrecv), nest_domain%pelist_fine(n), &
1327  is2, ie2, js2, je2, dir, rotate2(l))
1328  endif
1329  enddo
1330  enddo
1331  enddo
1332  overlap%nrecv = nrecv
1333  if(nrecv > 0) then
1334  allocate(overlap%recv(nrecv))
1335  do n = 1, nrecv
1336  call copy_nest_overlap(overlap%recv(n), overlaplist(n) )
1337 ! call print_nest_overlap(overlap%recv(n), "RECV")
1338  call deallocate_nest_overlap( overlaplist(n) )
1339  enddo
1340  endif
1341  if(allocated(overlaplist))deallocate(overlaplist)
1342 
1343  endif
1344 
1345  if(debug_message_passing) call debug_message_size(overlap, name)
1346 
1347  deallocate(isl_coarse, iel_coarse, jsl_coarse, jel_coarse)
1348  deallocate(isl_fine, iel_fine, jsl_fine, jel_fine)
1349 
1350 end subroutine compute_overlap_fine_to_coarse
1351 
1352 function find_index(array, index_data, start_pos)
1353  integer, intent(in) :: array(:)
1354  integer, intent(in) :: index_data
1355  integer, intent(in) :: start_pos
1356  integer :: find_index
1357  integer :: i
1358 
1359  find_index = 0
1360  do i = start_pos, size(array)
1361  if(array(i) == index_data) then
1362  find_index = i
1363  exit
1364  endif
1365  enddo
1366  if(find_index == 0) then
1367  print*, "start_pos = ", start_pos, index_data, array
1368  call mpp_error(fatal, "mpp_define_nest_domains.inc: can not find data in array")
1369  endif
1370 
1371 end function find_index
1372 
1373 subroutine debug_message_size(overlap, name)
1374  type(nestspec), intent(in) :: overlap
1375  character(len=*), intent(in) :: name
1376  integer, allocatable :: msg1(:), msg2(:), msg3(:), pelist(:)
1377  integer :: m, n, l, npes, msgsize
1378  integer :: is, ie, js, je, outunit
1379 
1380  outunit = stdout()
1381  npes = mpp_npes()
1382  allocate(msg1(npes), msg2(npes), msg3(npes) )
1383  allocate(pelist(npes))
1384  call mpp_get_current_pelist(pelist)
1385  msg1 = 0
1386  msg2 = 0
1387  msg3 = 0
1388  l = 0
1389  do m = 1, overlap%nrecv
1390  msgsize = 0
1391  do n = 1, overlap%recv(m)%count
1392  is = overlap%recv(m)%is(n); ie = overlap%recv(m)%ie(n)
1393  js = overlap%recv(m)%js(n); je = overlap%recv(m)%je(n)
1394  msgsize = msgsize + (ie-is+1)*(je-js+1)
1395  end do
1396  l = find_index(pelist, overlap%recv(m)%pe, l+1)
1397  msg2(l) = msgsize
1398  enddo
1399  l = 0
1400  do m = 1, overlap%nsend
1401  msgsize = 0
1402  do n = 1, overlap%send(m)%count
1403  is = overlap%send(m)%is(n); ie = overlap%send(m)%ie(n)
1404  js = overlap%send(m)%js(n); je = overlap%send(m)%je(n)
1405  msgsize = msgsize + (ie-is+1)*(je-js+1)
1406  end do
1407  l = find_index(pelist, overlap%send(m)%pe, l+1)
1408  msg3(l) = msgsize
1409  enddo
1410 
1411  call mpp_alltoall(msg3, 1, msg1, 1)
1412 
1413  do m = 1, npes
1414  if(msg1(m) .NE. msg2(m)) then
1415  print*, "debug_message_size: My pe = ", mpp_pe(), ",name =", trim(name),", from pe=", &
1416  pelist(m), ":send size = ", msg1(m), ", recv size = ", msg2(m)
1417  call mpp_error(fatal, "debug_message_size: mismatch on send and recv size")
1418  endif
1419  enddo
1420  write(outunit,*)"NOTE from compute_overlap_fine_to_coarse: "// &
1421  "message sizes are matched between send and recv for "//trim(name)
1422  deallocate(msg1, msg2, msg3, pelist)
1423 
1424 end subroutine debug_message_size
1425 
1426 !###############################################################################
1427 
1428 subroutine init_index_type (indexData )
1429  type(index_type), intent(inout) :: indexData
1430 
1431  indexdata%is_me = 0
1432  indexdata%ie_me = -1
1433  indexdata%js_me = 0
1434  indexdata%je_me = -1
1435  indexdata%is_you = 0
1436  indexdata%ie_you = -1
1437  indexdata%js_you = 0
1438  indexdata%je_you = -1
1439 
1440 end subroutine init_index_type
1441 
1442 subroutine allocate_nest_overlap(overlap, count)
1443  type(overlap_type), intent(inout) :: overlap
1444  integer, intent(in ) :: count
1445 
1446  overlap%count = 0
1447  overlap%pe = null_pe
1448  if( ASSOCIATED(overlap%is) ) call mpp_error(fatal, &
1449  "mpp_define_nest_domains.inc: overlap is already been allocated")
1450 
1451  allocate(overlap%is (count) )
1452  allocate(overlap%ie (count) )
1453  allocate(overlap%js (count) )
1454  allocate(overlap%je (count) )
1455  allocate(overlap%dir (count) )
1456  allocate(overlap%rotation (count) )
1457  allocate(overlap%msgsize (count) )
1458 
1459 end subroutine allocate_nest_overlap
1460 
1461 !##############################################################################
1462 subroutine deallocate_nest_overlap(overlap)
1463  type(overlap_type), intent(inout) :: overlap
1464 
1465  overlap%count = 0
1466  overlap%pe = null_pe
1467  deallocate(overlap%is)
1468  deallocate(overlap%ie)
1469  deallocate(overlap%js)
1470  deallocate(overlap%je)
1471  deallocate(overlap%dir)
1472  deallocate(overlap%rotation)
1473  deallocate(overlap%msgsize)
1474 
1475 end subroutine deallocate_nest_overlap
1476 
1477 !##############################################################################
1478 subroutine insert_nest_overlap(overlap, pe, is, ie, js, je, dir, rotation)
1479  type(overlap_type), intent(inout) :: overlap
1480  integer, intent(in ) :: pe
1481  integer, intent(in ) :: is, ie, js, je
1482  integer, intent(in ) :: dir, rotation
1483  integer :: count
1484 
1485  if( overlap%count == 0 ) then
1486  overlap%pe = pe
1487  else
1488  if(overlap%pe .NE. pe) call mpp_error(fatal, &
1489  "mpp_define_nest_domains.inc: mismatch on pe")
1490  endif
1491  overlap%count = overlap%count+1
1492  count = overlap%count
1493  if(count > size(overlap%is(:))) call mpp_error(fatal, &
1494  "mpp_define_nest_domains.inc: overlap%count > size(overlap%is), contact developer")
1495  overlap%is (count) = is
1496  overlap%ie (count) = ie
1497  overlap%js (count) = js
1498  overlap%je (count) = je
1499  overlap%dir (count) = dir
1500  overlap%rotation (count) = rotation
1501  overlap%msgsize (count) = (ie-is+1)*(je-js+1)
1502 
1503 end subroutine insert_nest_overlap
1504 
1505 subroutine print_nest_overlap(overlap, msg)
1506  type(overlap_type), intent(in) :: overlap
1507  character(len=*), intent(in) :: msg
1508 
1509  integer :: i
1510  write(1000+mpp_pe(),*) trim(msg), ",pe=",overlap%pe, overlap%count
1511  do i = 1, overlap%count
1512  write(1000+mpp_pe(),*) trim(msg), ",index=", overlap%is(i), overlap%ie(i),overlap%js(i),overlap%je(i)
1513  write(1000+mpp_pe(),*) trim(msg), ",rotation=", overlap%dir(i), overlap%rotation(i), overlap%msgsize(i)
1514  enddo
1515  flush(1000+mpp_pe())
1516 
1517 end subroutine print_nest_overlap
1518 
1519 !#########################################################
1520 subroutine copy_nest_overlap(overlap_out, overlap_in)
1521  type(overlap_type), intent(inout) :: overlap_out
1522  type(overlap_type), intent(in) :: overlap_in
1523 
1524  if(overlap_in%count == 0) call mpp_error(fatal, &
1525  "mpp_define_nest_domains.inc: overlap_in%count is 0")
1526 
1527  if(associated(overlap_out%is)) call mpp_error(fatal, &
1528  "mpp_define_nest_domains.inc: overlap_out is already been allocated")
1529 
1530  call allocate_nest_overlap(overlap_out, overlap_in%count)
1531  overlap_out%count = overlap_in%count
1532  overlap_out%pe = overlap_in%pe
1533 
1534  overlap_out%is(:) = overlap_in%is(1:overlap_in%count)
1535  overlap_out%ie(:) = overlap_in%ie(1:overlap_in%count)
1536  overlap_out%js(:) = overlap_in%js(1:overlap_in%count)
1537  overlap_out%je(:) = overlap_in%je(1:overlap_in%count)
1538  overlap_out%is(:) = overlap_in%is(1:overlap_in%count)
1539  overlap_out%dir(:) = overlap_in%dir(1:overlap_in%count)
1540  overlap_out%rotation(:) = overlap_in%rotation(1:overlap_in%count)
1541  overlap_out%msgsize(:) = overlap_in%msgsize(1:overlap_in%count)
1542 
1543 
1544 end subroutine copy_nest_overlap
1545 
1546 
1547 !#######################################################################
1548  ! this routine found the domain has the same halo size with the input
1549  ! whalo, ehalo,
1550 function search_c2f_nest_overlap(nest_domain, nest_level, extra_halo, position)
1551  type(nest_domain_type), intent(inout) :: nest_domain
1552  integer, intent(in) :: extra_halo
1553  integer, intent(in) :: position, nest_level
1554  type(nestspec), pointer :: search_C2F_nest_overlap
1555  type(nestspec), pointer :: update_ref
1556  character(len=128) :: name
1557 
1558  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
1559  "mpp_define_nest_domains.inc(search_C2F_nest_overlap): nest_level should be between 1 and nest_domain%num_level")
1560 
1561  select case(position)
1562  case (center)
1563  name = trim(nest_domain%name)//" T-cell"
1564  update_ref => nest_domain%nest(nest_level)%C2F_T
1565  case (corner)
1566  update_ref => nest_domain%nest(nest_level)%C2F_C
1567  case (north)
1568  update_ref => nest_domain%nest(nest_level)%C2F_N
1569  case (east)
1570  update_ref => nest_domain%nest(nest_level)%C2F_E
1571  case default
1572  call mpp_error(fatal, &
1573  & "mpp_define_nest_domains.inc(search_C2F_nest_overlap): position should be CENTER|CORNER|EAST|NORTH")
1574  end select
1575 
1576  search_c2f_nest_overlap => update_ref
1577 
1578  do
1579  if(extra_halo == search_c2f_nest_overlap%extra_halo) then
1580  exit ! found domain
1581  endif
1582  !--- if not found, switch to next
1583  if(.NOT. ASSOCIATED(search_c2f_nest_overlap%next)) then
1584  allocate(search_c2f_nest_overlap%next)
1585  search_c2f_nest_overlap => search_c2f_nest_overlap%next
1586  call compute_overlap_coarse_to_fine(nest_domain%nest(nest_level), search_c2f_nest_overlap, &
1587  & extra_halo, position, name)
1588  exit
1589  else
1590  search_c2f_nest_overlap => search_c2f_nest_overlap%next
1591  end if
1592 
1593  end do
1594 
1595  update_ref => null()
1596 
1597  end function search_c2f_nest_overlap
1598 
1599 !#######################################################################
1600  ! this routine found the domain has the same halo size with the input
1601  ! whalo, ehalo,
1602  function search_f2c_nest_overlap(nest_domain, nest_level, position)
1603  type(nest_domain_type), intent(inout) :: nest_domain
1604  integer, intent(in) :: position, nest_level
1605  type(nestspec), pointer :: search_F2C_nest_overlap
1606 
1607  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
1608  "mpp_define_nest_domains.inc(search_F2C_nest_overlap): nest_level should be between 1 and nest_domain%num_level")
1609 
1610  select case(position)
1611  case (center)
1612  search_f2c_nest_overlap => nest_domain%nest(nest_level)%F2C_T
1613  case (corner)
1614  search_f2c_nest_overlap => nest_domain%nest(nest_level)%F2C_C
1615  case (north)
1616  search_f2c_nest_overlap => nest_domain%nest(nest_level)%F2C_N
1617  case (east)
1618  search_f2c_nest_overlap => nest_domain%nest(nest_level)%F2C_E
1619  case default
1620  call mpp_error(fatal, &
1621  & "mpp_define_nest_domains.inc(search_F2C_nest_overlap): position should be CENTER|CORNER|EAST|NORTH")
1622  end select
1623 
1624  end function search_f2c_nest_overlap
1625 
1626  !################################################################
1627  !> @brief Get the index of the data passed from coarse grid to fine grid.
1628  !!
1629  !> Get the index of the data passed from coarse grid to fine grid.
1630  !!
1631  !! <br>Example usage:
1632  !! @code{.F90}
1633  !! call mpp_get_C2F_index(nest_domain, is_fine, ie_fine, js_fine, je_fine,
1634  !! is_coarse, ie_coarse, js_coarse, je_coarse, dir,
1635  !! nest_level, position)
1636  !! @endcode
1637  subroutine mpp_get_c2f_index(nest_domain, is_fine, ie_fine, js_fine, je_fine, &
1638  is_coarse, ie_coarse, js_coarse, je_coarse, dir, nest_level, position)
1639 
1640  type(nest_domain_type), intent(in ) :: nest_domain !< holds the information to pass data
1641  !! between fine and coarse grids
1642  integer, intent(out) :: is_fine, ie_fine, js_fine, je_fine !< index in the fine
1643  !! grid of the nested region
1644  integer, intent(out) :: is_coarse, ie_coarse, js_coarse, je_coarse !< index in the coarse
1645  !! grid of the nested region
1646  integer, intent(in ) :: dir, nest_level !< direction of the halo update.
1647  !! Its value should be WEST, EAST, SOUTH or NORTH.;
1648  !! level of the nest (> 1 implies a telescoping nest)
1649  integer, optional, intent(in ) :: position !< Cell position. It value should be CENTER,
1650  !! EAST, CORNER, or NORTH.
1651 
1652  integer :: update_position
1653  type(nestspec), pointer :: update => null()
1654 
1655  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
1656  "mpp_define_nest_domains.inc(mpp_get_C2F_index): nest_level should be between 1 and nest_domain%num_level")
1657 
1658  update_position = center
1659  if(present(position)) update_position = position
1660 
1661  select case(update_position)
1662  case (center)
1663  update => nest_domain%nest(nest_level)%C2F_T
1664  case (east)
1665  update => nest_domain%nest(nest_level)%C2F_E
1666  case (corner)
1667  update => nest_domain%nest(nest_level)%C2F_C
1668  case (north)
1669  update => nest_domain%nest(nest_level)%C2F_N
1670  case default
1671  call mpp_error(fatal, "mpp_define_nest_domains.inc(mpp_get_C2F_index): invalid option argument position")
1672  end select
1673 
1674  select case(dir)
1675  case(west)
1676  is_fine = update%west%is_me
1677  ie_fine = update%west%ie_me
1678  js_fine = update%west%js_me
1679  je_fine = update%west%je_me
1680  is_coarse = update%west%is_you
1681  ie_coarse = update%west%ie_you
1682  js_coarse = update%west%js_you
1683  je_coarse = update%west%je_you
1684  case(east)
1685  is_fine = update%east%is_me
1686  ie_fine = update%east%ie_me
1687  js_fine = update%east%js_me
1688  je_fine = update%east%je_me
1689  is_coarse = update%east%is_you
1690  ie_coarse = update%east%ie_you
1691  js_coarse = update%east%js_you
1692  je_coarse = update%east%je_you
1693  case(south)
1694  is_fine = update%south%is_me
1695  ie_fine = update%south%ie_me
1696  js_fine = update%south%js_me
1697  je_fine = update%south%je_me
1698  is_coarse = update%south%is_you
1699  ie_coarse = update%south%ie_you
1700  js_coarse = update%south%js_you
1701  je_coarse = update%south%je_you
1702  case(north)
1703  is_fine = update%north%is_me
1704  ie_fine = update%north%ie_me
1705  js_fine = update%north%js_me
1706  je_fine = update%north%je_me
1707  is_coarse = update%north%is_you
1708  ie_coarse = update%north%ie_you
1709  js_coarse = update%north%js_you
1710  je_coarse = update%north%je_you
1711  case default
1712  call mpp_error(fatal, "mpp_define_nest_domains.inc: invalid value for argument dir")
1713  end select
1714 
1715 
1716  end subroutine mpp_get_c2f_index
1717 
1718  subroutine mpp_get_f2c_index_fine(nest_domain, is_coarse, ie_coarse, js_coarse, je_coarse, &
1719  is_fine, ie_fine, js_fine, je_fine, nest_level, position)
1720 
1721  type(nest_domain_type), intent(in ) :: nest_domain !< Holds the information to pass data
1722  !! between fine and coarse grid.
1723  integer, intent(out) :: is_fine, ie_fine, js_fine, je_fine !< index in the fine
1724  !! grid of the nested region
1725  integer, intent(out) :: is_coarse, ie_coarse, js_coarse, je_coarse !< index in
1726  !! the coarse grid of the nested region
1727  integer, intent(in) :: nest_level !< level of the nest (> 1 implies a telescoping nest)
1728  integer, optional, intent(in ) :: position !< Cell position. It value should be CENTER,
1729  !! EAST, CORNER, or NORTH.
1730 
1731  integer :: update_position
1732  type(nestspec), pointer :: update => null()
1733 
1734  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
1735  "mpp_define_nest_domains.inc(mpp_get_F2C_index): nest_level should be between 1 and nest_domain%num_level")
1736 
1737  if(.not. nest_domain%nest(nest_level)%on_level) call mpp_error(fatal, &
1738  "mpp_define_nest_domains.inc(mpp_get_F2C_index_fine): nest_domain%nest(nest_level)%on_level is false")
1739 
1740  update_position = center
1741  if(present(position)) update_position = position
1742 
1743  select case(update_position)
1744  case (center)
1745  update => nest_domain%nest(nest_level)%F2C_T
1746  case (east)
1747  update => nest_domain%nest(nest_level)%F2C_E
1748  case (corner)
1749  update => nest_domain%nest(nest_level)%F2C_C
1750  case (north)
1751  update => nest_domain%nest(nest_level)%F2C_N
1752  case default
1753  call mpp_error(fatal, "mpp_define_nest_domains.inc(mpp_get_F2C_index): invalid option argument position")
1754  end select
1755  is_fine = update%xbegin_f
1756  ie_fine = update%xend_f
1757  js_fine = update%ybegin_f
1758  je_fine = update%yend_f
1759  is_coarse = update%xbegin_c
1760  ie_coarse = update%xend_c
1761  js_coarse = update%ybegin_c
1762  je_coarse = update%yend_c
1763 
1764  end subroutine mpp_get_f2c_index_fine
1765 
1766  !################################################################
1767  subroutine mpp_get_f2c_index_coarse(nest_domain, is_coarse, ie_coarse, js_coarse, je_coarse, nest_level, position)
1768 
1769  type(nest_domain_type), intent(in ) :: nest_domain !< Holds the information to pass data
1770  !! between fine and coarse grid.
1771  integer, intent(out) :: is_coarse, ie_coarse, js_coarse, je_coarse !< index in the fine
1772  !! grid of the nested region
1773  integer, intent(in ) :: nest_level !< level of the nest (> 1 implies a telescoping nest)
1774  integer, optional, intent(in ) :: position !< Cell position. It value should be CENTER,
1775  !! EAST, CORNER, or NORTH.
1776 
1777  integer :: update_position
1778  type(nestspec), pointer :: update => null()
1779 
1780  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
1781  & "mpp_define_nest_domains.inc(mpp_get_F2C_index_coarse):"// &
1782  & "nest_level should be between 1 and nest_domain%num_level")
1783 
1784 
1785  update_position = center
1786  if(present(position)) update_position = position
1787 
1788  select case(update_position)
1789  case (center)
1790  update => nest_domain%nest(nest_level)%F2C_T
1791  case (east)
1792  update => nest_domain%nest(nest_level)%F2C_E
1793  case (corner)
1794  update => nest_domain%nest(nest_level)%F2C_C
1795  case (north)
1796  update => nest_domain%nest(nest_level)%F2C_N
1797  case default
1798  call mpp_error(fatal, &
1799  & "mpp_define_nest_domains.inc(mpp_get_F2C_index_coarse): invalid option argument position")
1800  end select
1801  is_coarse = update%xbegin_c
1802  ie_coarse = update%xend_c
1803  js_coarse = update%ybegin_c
1804  je_coarse = update%yend_c
1805 
1806  end subroutine mpp_get_f2c_index_coarse
1807 
1808  subroutine get_coarse_index(rotate, is, ie, js, je, iadd, jadd, is_c, ie_c, js_c, je_c)
1809  integer, intent(in) :: rotate, is, ie, js, je, iadd, jadd
1810  integer, intent(out) :: is_c, ie_c, js_c, je_c
1811 
1812  if(rotate == 0) then
1813  is_c = is; ie_c = ie
1814  js_c = js; je_c = je
1815  else
1816  is_c = js; ie_c = je
1817  js_c = is; je_c = ie
1818  endif
1819  is_c = is_c + iadd; ie_c = ie_c + iadd
1820  js_c = js_c + jadd; je_c = je_c + jadd
1821 
1822  end subroutine get_coarse_index
1823 
1824  !--- this routine will get number of nest.
1825  subroutine get_nnest(domain, num_nest, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, jend_coarse, &
1826  x_refine, y_refine, nnest, t_coarse, ncross_coarse, rotate_coarse, &
1827  is_coarse, ie_coarse, js_coarse, je_coarse, is_fine, ie_fine, js_fine, je_fine)
1828  type(domain2d), intent(in) :: domain
1829  integer, intent(in) :: num_nest, istart_coarse(:), iend_coarse(:), jstart_coarse(:), jend_coarse(:)
1830  integer, intent(in) :: tile_coarse(:)
1831  integer, intent(in) :: x_refine, y_refine
1832  integer, intent(out) :: nnest, is_coarse(:), ie_coarse(:), js_coarse(:), je_coarse(:)
1833  integer, intent(out) :: is_fine(:), ie_fine(:), js_fine(:), je_fine(:)
1834  integer, intent(out) :: t_coarse(:), ncross_coarse(:), rotate_coarse(:)
1835  integer :: is, ie, js, je, tile, isg, ieg, jsg, jeg
1836  integer :: ncross, rotate, i1, i2
1837  integer :: is_c, ie_c, js_c, je_c
1838  integer :: n, iadd, jadd
1839 
1840 
1841  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
1842  nnest = 0
1843  do n = 1, num_nest
1844  is = istart_coarse(n); ie = iend_coarse(n)
1845  js = jstart_coarse(n); je = jend_coarse(n)
1846  tile = tile_coarse(n)
1847  iadd = 0 ; jadd = 0
1848  ncross = 0
1849  rotate = 0
1850  do while ( ie .GE. is .AND. je .GE. js)
1851  nnest = nnest+1
1852  t_coarse(nnest) = tile
1853  ncross_coarse(nnest) = ncross
1854  rotate_coarse(nnest) = rotate
1855  !--- rotate should be 0, 90 or -90.
1856  if(rotate .NE. 0 .AND. rotate .NE. 90 .AND. rotate .NE. -90) then
1857  call mpp_error(fatal, "get_nnest: roate should be 0, 90 or -90")
1858  endif
1859  if( ieg .GE. ie .AND. jeg .GE. je) then
1860  is_coarse(nnest) = is; ie_coarse(nnest) = ie
1861  js_coarse(nnest) = js; je_coarse(nnest) = je
1862  call get_coarse_index(rotate, is_coarse(nnest), ie_coarse(nnest), js_coarse(nnest), je_coarse(nnest), &
1863  iadd, jadd, is_c, ie_c, js_c, je_c)
1864  is = ie + 1; js = je + 1
1865  else if( ieg .GE. ie ) then ! jeg < je, will cross the north edge
1866  is_coarse(nnest) = is; ie_coarse(nnest) = ie
1867  js_coarse(nnest) = js; je_coarse(nnest) = jeg
1868  call get_coarse_index(rotate, is_coarse(nnest), ie_coarse(nnest), js_coarse(nnest), je_coarse(nnest), &
1869  iadd, jadd, is_c, ie_c, js_c, je_c)
1870  if(rotate ==0) then
1871  jadd = jadd + jeg
1872  else
1873  iadd = iadd + ieg
1874  endif
1875  js = 1; je = je-jeg
1876  ncross = ncross+1
1877  if(mod(tile,2) ==0) then ! tile 2 4 6
1878  tile = tile + 1
1879  if(tile>6) tile=tile-6
1880  else ! rotate 90 degree
1881  tile = tile + 2
1882  if(tile>6) tile=tile-6
1883  i1 = is; i2 = ie
1884  is = js; ie = je
1885  js = i1; je = i2
1886  rotate = rotate + 90
1887  endif
1888 
1889 
1890  else if( jeg .GE. je ) then ! ieg < ie, will cross the east edge
1891  is_coarse(nnest) = is; ie_coarse(nnest) = ieg
1892  js_coarse(nnest) = js; je_coarse(nnest) = je
1893  call get_coarse_index(rotate, is_coarse(nnest), ie_coarse(nnest), js_coarse(nnest), je_coarse(nnest), &
1894  iadd, jadd, is_c, ie_c, js_c, je_c)
1895  if(rotate ==0) then
1896  iadd = iadd + ieg
1897  else
1898  jadd = jadd + jeg
1899  endif
1900  is = 1; ie = ie-ieg
1901  ncross = ncross+1
1902  if(mod(tile,2) ==0) then ! rotate -90
1903  tile = tile + 2
1904  if(tile>6) tile=tile-6
1905  i1 = is; i2 = ie
1906  is = js; ie = je
1907  js = i1; je = i2
1908  rotate = rotate - 90
1909  else
1910  tile = tile + 1
1911  if(tile>6) tile=tile-6
1912  endif
1913  else
1914  call mpp_error(fatal, "get_nnest: do not support cross the corner")
1915  endif
1916 
1917  !--- is_c:ie_c,js_c:je_c must be inside istart_coarse(n):iend_coarse(n), jstart_coarse(n):jend_coarse(n)
1918  if(is_c < istart_coarse(n)) call mpp_error(fatal, "get_nnest: is_c < istart_coarse")
1919  if(ie_c > iend_coarse(n)) call mpp_error(fatal, "get_nnest: ie_c > iend_coarse")
1920  if(js_c < jstart_coarse(n)) call mpp_error(fatal, "get_nnest: js_c < jstart_coarse")
1921  if(je_c > jend_coarse(n)) call mpp_error(fatal, "get_nnest: je_c > jend_coarse")
1922  is_fine(nnest) = (is_c - istart_coarse(n)) * x_refine + 1
1923  ie_fine(nnest) = (ie_c - istart_coarse(n)+1) * x_refine
1924  js_fine(nnest) = (js_c - jstart_coarse(n)) * y_refine + 1
1925  je_fine(nnest) = (je_c - jstart_coarse(n)+1) * y_refine
1926 
1927  !--- it should not cross the edge more than 3 times.
1928  if(ncross > 3) call mpp_error(fatal, "get_nnest: nncross > 3")
1929  enddo
1930  enddo
1931 
1932 
1933  end subroutine get_nnest
1934 
1935 
1936  !> This routine will convert the global coarse grid index to nest grid index.
1937  function convert_index_to_nest(domain, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, &
1938  & jend_coarse, ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in, is_out, ie_out,&
1939  & js_out, je_out, rotate_out)
1940  type(domain2d), intent(in) :: domain
1941  integer, intent(in) :: ishift, jshift
1942  integer, intent(in) :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse
1943  integer, intent(in) :: tile_coarse
1944  integer, intent(in) :: ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in
1945  integer, intent(out) :: is_out(:), ie_out(:), js_out(:), je_out(:), rotate_out(:)
1946  integer :: convert_index_to_nest
1947  integer :: is, ie, js, je, tile, isg, ieg, jsg, jeg
1948  integer :: ncross, rotate, nout, diff, ntiles
1949 
1950  ntiles = ntiles_coarse
1951  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
1952  is = istart_coarse; ie = iend_coarse
1953  js = jstart_coarse; je = jend_coarse
1954  tile = tile_coarse
1955 
1956  if(size(is_out(:)) < 2) call mpp_error(fatal,"convert_index_to_nest: size(is_out(:)) < 2")
1957  if(size(ie_out(:)) < 2) call mpp_error(fatal,"convert_index_to_nest: size(ie_out(:)) < 2")
1958  if(size(js_out(:)) < 2) call mpp_error(fatal,"convert_index_to_nest: size(js_out(:)) < 2")
1959  if(size(je_out(:)) < 2) call mpp_error(fatal,"convert_index_to_nest: size(je_out(:)) < 2")
1960  if(size(rotate_out(:)) < 2) call mpp_error(fatal,"convert_index_to_nest: size(rotate_out(:)) < 2")
1961  if( ie > ieg .AND. je > jeg) then
1962  call mpp_error(fatal, "convert_index_to_nest: do not support cross the corner, contact developer")
1963  endif
1964  if( is > ieg .or. js > jeg) call mpp_error(fatal,.or."convert_index_to_nest: is > ieg js > jeg")
1965 
1966 
1967  nout = 0
1968 
1969  if(tile == tile_in) then
1970  nout = nout+1
1971  rotate_out(nout) = zero
1972  is_out(nout) = is_in; ie_out(nout) = ie_in + ishift
1973  js_out(nout) = js_in; je_out(nout) = je_in + jshift
1974  endif
1975 
1976  diff = tile_in - tile
1977  if(diff < 0) diff = diff + ntiles
1978  ncross = -1
1979  if( ie > ieg ) then
1980  select case(diff)
1981  case (0)
1982  rotate = zero
1983  ncross = 4
1984  case (1)
1985  if(mod(tile,2) ==1) then ! tile 1 3 5
1986  rotate = zero
1987  ncross = 1
1988  endif
1989  case (2)
1990  if(mod(tile,2) ==0) then ! tile 2 4 6
1991  rotate = minus_ninety
1992  ncross = 1
1993  endif
1994  case (3)
1995  rotate = minus_ninety
1996  ncross = 2
1997  case (4)
1998  if(mod(tile,2) ==1) then ! tile 1 3 5
1999  rotate = minus_ninety
2000  ncross = 3
2001  endif
2002  case (5)
2003  if(mod(tile,2) ==0) then ! tile 2 4 6
2004  rotate = zero
2005  ncross = 3
2006  endif
2007  case default
2008  call mpp_error(fatal,"convert_index_to_nest: invalid value of diff")
2009  end select
2010 
2011  if(ncross > 0) then
2012  nout =nout+1
2013  rotate_out(nout) = rotate
2014  if(rotate_out(nout) == zero) then
2015  js_out(nout) = js_in
2016  je_out(nout) = je_in + jshift
2017  is_out(nout) = is_in+ncross*ieg
2018  ie_out(nout) = ie_in+ncross*ieg + ishift
2019  else if(rotate_out(nout) == minus_ninety) then
2020  js_out(nout) = ieg-ie_in + 1
2021  je_out(nout) = ieg-is_in + 1 + ishift
2022  is_out(nout) = js_in+ncross*jeg
2023  ie_out(nout) = je_in+ncross*jeg + jshift
2024  endif
2025  endif
2026  else if( je > jeg ) then
2027  select case(diff)
2028  case (0)
2029  rotate = zero
2030  ncross = 4
2031  case (1)
2032  if(mod(tile,2) ==0) then ! tile 2 4 6
2033  rotate = zero
2034  ncross = 1
2035  endif
2036  case (2)
2037  if(mod(tile,2) ==1) then ! tile 1 3 5
2038  rotate = ninety
2039  ncross = 1
2040  endif
2041  case (3)
2042  rotate = ninety
2043  ncross = 2
2044  case (4)
2045  if(mod(tile,2) ==0) then ! tile 2 4 6
2046  rotate = ninety
2047  ncross = 3
2048  endif
2049  case (5)
2050  if(mod(tile,2) ==1) then ! tile 1 3 5
2051  rotate = zero
2052  ncross = 3
2053  endif
2054  end select
2055 
2056  if(ncross > 0) then
2057  nout =nout+1
2058  rotate_out(nout) = rotate
2059 
2060  if(rotate_out(nout) == zero) then
2061  js_out(nout) = js_in
2062  je_out(nout) = je_in + jshift
2063  is_out(nout) = is_in+ncross*ieg
2064  ie_out(nout) = ie_in+ncross*ieg + ishift
2065  else if(rotate_out(nout) == ninety) then
2066  is_out(nout) = ieg-je_in + 1
2067  ie_out(nout) = ieg-js_in+1 + jshift
2068  js_out(nout) = is_in+ncross*jeg
2069  je_out(nout) = ie_in+ncross*jeg + ishift
2070  endif
2071  endif
2072  endif
2073 
2074  convert_index_to_nest = nout
2075 
2076  end function convert_index_to_nest
2077 
2078  function convert_index_to_coarse(domain, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, &
2079  & jend_coarse, ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in, is_out, ie_out,&
2080  & js_out, je_out, rotate_out)
2081  type(domain2d), intent(in) :: domain
2082  integer, intent(in) :: ishift, jshift
2083  integer, intent(in) :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse
2084  integer, intent(in) :: tile_coarse
2085  integer, intent(in) :: ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in
2086  integer, intent(out) :: is_out(:), ie_out(:), js_out(:), je_out(:), rotate_out(:)
2087  integer :: convert_index_to_coarse
2088  integer :: is, ie, js, je, isg, ieg, jsg, jeg
2089  integer :: ncross, rotate, ntiles, nout, diff, tile
2090 
2091  ntiles = ntiles_coarse
2092  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
2093  is = istart_coarse; ie = iend_coarse
2094  js = jstart_coarse; je = jend_coarse
2095  tile = tile_coarse
2096 
2097  if(size(is_out(:)) < 2) call mpp_error(fatal,"convert_index_to_coarse: size(is_out(:)) < 2")
2098  if(size(ie_out(:)) < 2) call mpp_error(fatal,"convert_index_to_coarse: size(ie_out(:)) < 2")
2099  if(size(js_out(:)) < 2) call mpp_error(fatal,"convert_index_to_coarse: size(js_out(:)) < 2")
2100  if(size(je_out(:)) < 2) call mpp_error(fatal,"convert_index_to_coarse: size(je_out(:)) < 2")
2101  if(size(rotate_out(:)) < 2) call mpp_error(fatal,"convert_index_to_coarse: size(rotate_out(:)) < 2")
2102  if( ie > ieg .AND. je > jeg) then
2103  call mpp_error(fatal, "convert_index_to_coarse: do not support cross the corner, contact developer")
2104  endif
2105  if( is > ieg .or. js > jeg) call mpp_error(fatal,.or."convert_index_to_coarse: is > ieg js > jeg")
2106 
2107  nout = 0
2108 
2109  if(tile_coarse == tile_in) then
2110  nout = nout+1
2111  rotate_out(nout) = zero
2112  is_out(nout) = is_in; ie_out(nout) = ie_in + ishift
2113  js_out(nout) = js_in; je_out(nout) = je_in + jshift
2114  endif
2115 
2116  diff = tile_in - tile
2117  if(diff < 0) diff = diff + ntiles
2118  ncross = -1
2119  if( ie > ieg ) then
2120  select case(diff)
2121  case (0)
2122  rotate = zero
2123  ncross = 4
2124  case (1)
2125  if(mod(tile,2) ==1) then ! tile 1 3 5
2126  rotate = zero
2127  ncross = 1
2128  endif
2129  case (2)
2130  if(mod(tile,2) ==0) then ! tile 2 4 6
2131  rotate = minus_ninety
2132  ncross = 1
2133  endif
2134  case (3)
2135  rotate = minus_ninety
2136  ncross = 2
2137  case (4)
2138  if(mod(tile,2) ==1) then ! tile 1 3 5
2139  rotate = minus_ninety
2140  ncross = 3
2141  endif
2142  case (5)
2143  if(mod(tile,2) ==0) then ! tile 2 4 6
2144  rotate = zero
2145  ncross = 3
2146  endif
2147  case default
2148  call mpp_error(fatal,"convert_index_to_coarse: invalid value of diff")
2149  end select
2150 
2151  if(ncross > 0) then
2152  nout =nout+1
2153  rotate_out(nout) = rotate
2154  if(rotate_out(nout) == zero) then
2155  js_out(nout) = js_in
2156  je_out(nout) = je_in + jshift
2157  is_out(nout) = is_in-ncross*ieg
2158  ie_out(nout) = ie_in-ncross*ieg + ishift
2159  else if(rotate_out(nout) == minus_ninety) then
2160  is_out(nout) = ieg-je_in + 1
2161  ie_out(nout) = ieg-js_in + 1 + ishift
2162  js_out(nout) = is_in-ncross*jeg
2163  je_out(nout) = ie_in-ncross*jeg + jshift
2164  endif
2165  endif
2166  else if( je > jeg ) then
2167  select case(diff)
2168  case (0)
2169  rotate = zero
2170  ncross = 4
2171  case (1)
2172  if(mod(tile,2) ==0) then ! tile 2 4 6
2173  rotate = zero
2174  ncross = 1
2175  endif
2176  case (2)
2177  if(mod(tile,2) ==1) then ! tile 1 3 5
2178  rotate = ninety
2179  ncross = 1
2180  endif
2181  case (3)
2182  rotate = ninety
2183  ncross = 2
2184  case (4)
2185  if(mod(tile,2) ==0) then ! tile 2 4 6
2186  rotate = ninety
2187  ncross = 3
2188  endif
2189  case (5)
2190  if(mod(tile,2) ==1) then ! tile 1 3 5
2191  rotate = zero
2192  ncross = 3
2193  endif
2194  end select
2195 
2196  if(ncross > 0) then
2197  nout =nout+1
2198  rotate_out(nout) = rotate
2199 
2200  if(rotate_out(nout) == zero) then
2201  js_out(nout) = js_in
2202  je_out(nout) = je_in + jshift
2203  is_out(nout) = is_in-ncross*ieg
2204  ie_out(nout) = ie_in-ncross*ieg + ishift
2205  else if(rotate_out(nout) == ninety) then
2206  is_out(nout) = js_in - ncross*jeg
2207  ie_out(nout) = je_in - ncross*jeg + ishift
2208  js_out(nout) = jeg - ie_in + 1
2209  je_out(nout) = jeg - is_in + 1 + jshift
2210  endif
2211  endif
2212  endif
2213 
2214  convert_index_to_coarse = nout
2215 
2216 
2217  end function convert_index_to_coarse
2218 
2219 
2220  subroutine convert_index_back(domain, ishift, jshift, rotate, is_in, ie_in, js_in, je_in, is_out, ie_out, &
2221  & js_out, je_out)
2222  type(domain2d), intent(in) :: domain
2223  integer, intent(in) :: ishift, jshift
2224  integer, intent(in) :: is_in, ie_in, js_in, je_in, rotate
2225  integer, intent(out) :: is_out, ie_out, js_out, je_out
2226  integer :: isg, ieg, jsg, jeg
2227  integer :: ncross
2228 
2229  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
2230  ncross = 0
2231  if( je_in > jeg+jshift .and. ie_in > ieg+ishift ) then
2232  call mpp_error(fatal,.and."convert_index_back: je_in > jeg ie_in > ieg")
2233  else if (je_in > jeg+jshift) then
2234  ncross = je_in/jeg
2235  select case(rotate)
2236  case(0)
2237  is_out = is_in
2238  ie_out = ie_in
2239  js_out = js_in - ncross*jeg
2240  je_out = je_in - ncross*jeg
2241  case(90)
2242  is_out = js_in - ncross*jeg
2243  ie_out = je_in - ncross*jeg
2244  js_out = jeg - ie_in + 1
2245  je_out = jeg - is_in + 1
2246  case default
2247  call mpp_error(fatal, "convert_index_back: rotate should be 0 or 90 when je_in>jeg")
2248  end select
2249  else if (ie_in > ieg+ishift) then
2250  ncross = ie_in/ieg
2251  select case(rotate)
2252  case(0)
2253  is_out = is_in - ncross*ieg
2254  ie_out = ie_in - ncross*ieg
2255  js_out = js_in
2256  je_out = je_in
2257  case(-90)
2258  js_out = is_in - ncross*ieg
2259  je_out = ie_in - ncross*ieg
2260  is_out = ieg - je_in + 1
2261  ie_out = ieg - js_in + 1
2262  case default
2263  call mpp_error(fatal, "convert_index_back: rotate should be 0 or -90 when ie_in>ieg")
2264  end select
2265  else
2266  is_out = is_in
2267  ie_out = ie_in
2268  js_out = js_in
2269  je_out = je_in
2270  endif
2271 
2272  end subroutine convert_index_back
2273 
2274 
2275 
2276  function get_nest_vector_recv(nest_domain, update_x, update_y, ind_x, ind_y, start_pos, pelist)
2277  type(nest_level_type), intent(in) :: nest_domain
2278  type(nestspec), intent(in) :: update_x, update_y
2279  integer, intent(out) :: ind_x(:), ind_y(:)
2280  integer, intent(out) :: start_pos(:)
2281  integer, intent(out) :: pelist(:)
2282  integer :: get_nest_vector_recv
2283  integer :: nlist, nrecv_x, nrecv_y, ntot, n
2284  integer :: ix, iy, rank_x, rank_y, cur_pos
2285  integer :: nrecv
2286 
2287  nlist = size(nest_domain%pelist)
2288  nrecv_x = update_x%nrecv
2289  nrecv_y = update_y%nrecv
2290 
2291  ntot = nrecv_x + nrecv_y
2292 
2293  n = 1
2294  ix = 1
2295  iy = 1
2296  ind_x = -1
2297  ind_y = -1
2298  nrecv = 0
2299  cur_pos = 0
2300  do while (n<=ntot)
2301  if ( ix <= nrecv_x ) then
2302  rank_x = update_x%recv(ix)%pe
2303  else
2304  rank_x = -1
2305  endif
2306  if ( iy <= nrecv_y ) then
2307  rank_y = update_y%recv(iy)%pe
2308  else
2309  rank_y = -1
2310  endif
2311  nrecv = nrecv + 1
2312  start_pos(nrecv) = cur_pos
2313  if ( (rank_x == rank_y) .and. ( (rank_x >= 0) .and. (rank_y >= 0) ) ) then
2314  n = n+2
2315  ind_x(nrecv) = ix
2316  ind_y(nrecv) = iy
2317  cur_pos = cur_pos + update_x%recv(ix)%totsize + update_y%recv(iy)%totsize
2318  pelist(nrecv) = update_x%recv(ix)%pe
2319  ix = ix + 1
2320  iy = iy + 1
2321  else if ( rank_x < rank_y ) then
2322  n = n+1
2323  if ( rank_x < 0 ) then
2324  ind_x(nrecv) = -1
2325  ind_y(nrecv) = iy
2326  cur_pos = cur_pos + update_y%recv(iy)%totsize
2327  pelist(nrecv) = update_y%recv(iy)%pe
2328  iy = iy + 1
2329  else
2330  ind_x(nrecv) = ix
2331  ind_y(nrecv) = -1
2332  cur_pos = cur_pos + update_x%recv(ix)%totsize
2333  pelist(nrecv) = update_x%recv(ix)%pe
2334  ix = ix + 1
2335  endif
2336  else if ( rank_y < rank_x ) then
2337  n = n+1
2338  if ( rank_y < 0 ) then
2339  ind_x(nrecv) = ix
2340  ind_y(nrecv) = -1
2341  cur_pos = cur_pos + update_x%recv(ix)%totsize
2342  pelist(nrecv) = update_x%recv(ix)%pe
2343  ix = ix + 1
2344  else
2345  ind_x(nrecv) = -1
2346  ind_y(nrecv) = iy
2347  cur_pos = cur_pos + update_y%recv(iy)%totsize
2348  pelist(nrecv) = update_y%recv(iy)%pe
2349  iy = iy + 1
2350  endif
2351  endif
2352  end do
2353 
2354  get_nest_vector_recv = nrecv
2355 
2356 
2357  end function get_nest_vector_recv
2358 
2359 
2360  function get_nest_vector_send(nest_domain, update_x, update_y, ind_x, ind_y, start_pos, pelist)
2361  type(nest_level_type), intent(in) :: nest_domain
2362  type(nestspec), intent(in) :: update_x, update_y
2363  integer, intent(out) :: ind_x(:), ind_y(:)
2364  integer, intent(out) :: start_pos(:)
2365  integer, intent(out) :: pelist(:)
2366  integer :: get_nest_vector_send
2367  integer :: nlist, nsend_x, nsend_y, ntot, n
2368  integer :: ix, iy, rank_x, rank_y, cur_pos
2369  integer :: nsend
2370 
2371  nlist = size(nest_domain%pelist_fine(:)) + size(nest_domain%pelist_coarse(:))
2372  nsend_x = update_x%nsend
2373  nsend_y = update_y%nsend
2374 
2375  ntot = nsend_x + nsend_y
2376 
2377  n = 1
2378  ix = 1
2379  iy = 1
2380  ind_x = -1
2381  ind_y = -1
2382  nsend = 0
2383  cur_pos = 0
2384  do while (n<=ntot)
2385  if ( ix <= nsend_x ) then
2386  rank_x = update_x%send(ix)%pe
2387  else
2388  rank_x = -1
2389  endif
2390  if ( iy <= nsend_y ) then
2391  rank_y = update_y%send(iy)%pe
2392  else
2393  rank_y = -1
2394  endif
2395  nsend = nsend + 1
2396  start_pos(nsend) = cur_pos
2397  if ( (rank_x == rank_y) .and. ( (rank_x >= 0) .and. (rank_y >= 0) ) ) then
2398  n = n+2
2399  ind_x(nsend) = ix
2400  ind_y(nsend) = iy
2401  cur_pos = cur_pos + update_x%send(ix)%totsize + update_y%send(iy)%totsize
2402  pelist(nsend) = update_x%send(ix)%pe
2403  ix = ix + 1
2404  iy = iy + 1
2405  else if ( rank_x < rank_y ) then
2406  n = n+1
2407  if ( rank_x < 0 ) then
2408  ind_x(nsend) = -1
2409  ind_y(nsend) = iy
2410  cur_pos = cur_pos + update_y%send(iy)%totsize
2411  pelist(nsend) = update_y%send(iy)%pe
2412  iy = iy + 1
2413  else
2414  ind_x(nsend) = ix
2415  ind_y(nsend) = -1
2416  cur_pos = cur_pos + update_x%send(ix)%totsize
2417  pelist(nsend) = update_x%send(ix)%pe
2418  ix = ix + 1
2419  endif
2420  else if ( rank_y < rank_x ) then
2421  n = n+1
2422  if ( rank_y < 0 ) then
2423  ind_x(nsend) = ix
2424  ind_y(nsend) = -1
2425  cur_pos = cur_pos + update_x%send(ix)%totsize
2426  pelist(nsend) = update_x%send(ix)%pe
2427  ix = ix + 1
2428  else
2429  ind_x(nsend) = -1
2430  ind_y(nsend) = iy
2431  cur_pos = cur_pos + update_y%send(iy)%totsize
2432  pelist(nsend) = update_y%send(iy)%pe
2433  iy = iy + 1
2434  endif
2435  endif
2436  end do
2437 
2438  get_nest_vector_send = nsend
2439 
2440 
2441  end function get_nest_vector_send
2442 
2443  subroutine check_data_size_1d(module, str1, size1, str2, size2)
2444  character(len=*), intent(in) :: module, str1, str2
2445  integer, intent(in) :: size1, size2
2446 
2447 
2448  if(size2 > 0 .AND. size1 .NE. size2 ) then
2449  print '(a, 3I5)', trim(module), mpp_pe(), size1, size2
2450  call mpp_error(fatal, trim(module)//": mismatch between size of "//trim(str1)//" and "//trim(str2))
2451  endif
2452 
2453  end subroutine check_data_size_1d
2454 
2455 
2456  subroutine check_data_size_2d(module, str1, isize1, jsize1, str2, isize2, jsize2)
2457  character(len=*), intent(in) :: module, str1, str2
2458  integer, intent(in) :: isize1, jsize1, isize2, jsize2
2459 
2460 
2461  if(isize2 > 0 .AND. jsize2 > 0 .AND. (isize1 .NE. isize2 .OR. jsize1 .NE. jsize2) ) then
2462  print '(a, 5I5)', trim(module), mpp_pe(), isize1, jsize1, isize2, jsize2
2463  call mpp_error(fatal, trim(module)//": mismatch between size of "//trim(str1)//" and "//trim(str2))
2464  endif
2465 
2466  end subroutine check_data_size_2d
2467 
2468  function mpp_get_nest_coarse_domain(nest_domain, nest_level)
2469  type(nest_domain_type), intent(in) :: nest_domain
2470  integer, intent(in) :: nest_level
2471  type(domain2d), pointer :: mpp_get_nest_coarse_domain
2472 
2473  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2474  & "mpp_define_nest_domains.inc(mpp_get_nest_coarse_domain):"// &
2475  & "nest_level should be between 1 and nest_domain%num_level")
2476 
2477  if(.not. nest_domain%nest(nest_level)%on_level) call mpp_error(fatal, &
2478  "mpp_define_nest_domains.inc(mpp_get_nest_coarse_domain): nest_domain%nest(nest_level)%on_level is false")
2479  mpp_get_nest_coarse_domain => nest_domain%nest(nest_level)%domain_coarse
2480 
2481  end function mpp_get_nest_coarse_domain
2482 
2483  function mpp_get_nest_fine_domain(nest_domain, nest_level)
2484  type(nest_domain_type), intent(in) :: nest_domain
2485  integer, intent(in) :: nest_level
2486  type(domain2d), pointer :: mpp_get_nest_fine_domain
2487 
2488  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2489  & "mpp_define_nest_domains.inc(mpp_get_nest_fine_domain):"// &
2490  & "nest_level should be between 1 and nest_domain%num_level")
2491 
2492  if(.not. nest_domain%nest(nest_level)%on_level) call mpp_error(fatal, &
2493  "mpp_define_nest_domains.inc(mpp_get_nest_fine_domain): nest_domain%nest(nest_level)%on_level is false")
2494  mpp_get_nest_fine_domain => nest_domain%nest(nest_level)%domain_fine
2495 
2496  end function mpp_get_nest_fine_domain
2497 
2498  function mpp_get_nest_npes(nest_domain, nest_level)
2499  type(nest_domain_type), intent(in) :: nest_domain
2500  integer, intent(in) :: nest_level
2501  integer :: mpp_get_nest_npes
2502 
2503  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2504  "mpp_define_nest_domains.inc(mpp_get_nest_npes): nest_level should be between 1 and nest_domain%num_level")
2505 
2506  mpp_get_nest_npes = size(nest_domain%nest(nest_level)%pelist(:))
2507 
2508  end function mpp_get_nest_npes
2509 
2510  subroutine mpp_get_nest_pelist(nest_domain, nest_level, pelist)
2511  type(nest_domain_type), intent(in) :: nest_domain
2512  integer, intent(in) :: nest_level
2513  integer, intent(out) :: pelist(:)
2514  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2515  "mpp_define_nest_domains.inc(mpp_get_nest_pelist): nest_level should be between 1 and nest_domain%num_level")
2516 
2517  if(size(pelist) .NE. size(nest_domain%nest(nest_level)%pelist)) call mpp_error(fatal, &
2518  .NE."mpp_define_nest_domains.inc(mpp_get_nest_pelist): size(pelist) size(nest_domain%nest(nest_level)%pelist)")
2519 
2520  pelist = nest_domain%nest(nest_level)%pelist
2521 
2522  end subroutine mpp_get_nest_pelist
2523 
2524  function mpp_get_nest_fine_npes(nest_domain, nest_level)
2525  type(nest_domain_type), intent(in) :: nest_domain
2526  integer, intent(in) :: nest_level
2527  integer :: mpp_get_nest_fine_npes
2528 
2529  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2530  "mpp_define_nest_domains.inc(mpp_get_nest_fine_npes): nest_level should be between 1 and nest_domain%num_level")
2531 
2532  mpp_get_nest_fine_npes = size(nest_domain%nest(nest_level)%pelist_fine(:))
2533 
2534  end function mpp_get_nest_fine_npes
2535 
2536  subroutine mpp_get_nest_fine_pelist(nest_domain, nest_level, pelist)
2537  type(nest_domain_type), intent(in) :: nest_domain
2538  integer, intent(in) :: nest_level
2539  integer, intent(out) :: pelist(:)
2540  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2541  & "mpp_define_nest_domains.inc(mpp_get_nest_fine_pelist):"// &
2542  & "nest_level should be between 1 and nest_domain%num_level")
2543 
2544  if(size(pelist) .NE. size(nest_domain%nest(nest_level)%pelist_fine)) call mpp_error(fatal, &
2545  "mpp_define_nest_domains.inc(mpp_get_nest_fine_pelist): size(pelist) "// &
2546  .NE." size(nest_domain%nest(nest_level)%pelist)")
2547 
2548  pelist = nest_domain%nest(nest_level)%pelist_fine
2549 
2550  end subroutine mpp_get_nest_fine_pelist
2551 
2552 
2553 
2554  function mpp_is_nest_fine(nest_domain, nest_level)
2555  type(nest_domain_type), intent(in) :: nest_domain
2556  integer, intent(in) :: nest_level
2557  logical :: mpp_is_nest_fine
2558 
2559  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2560  "mpp_define_nest_domains.inc(mpp_is_nest_fine): nest_level should be between 1 and nest_domain%num_level")
2561 
2562  if(.not. nest_domain%nest(nest_level)%on_level) call mpp_error(fatal, &
2563  "mpp_define_nest_domains.inc(mpp_is_nest_fine): nest_domain%nest(nest_level)%on_level is false")
2564 
2565  mpp_is_nest_fine = nest_domain%nest(nest_level)%is_fine_pe
2566 
2567  end function mpp_is_nest_fine
2568 
2569  function mpp_is_nest_coarse(nest_domain, nest_level)
2570  type(nest_domain_type), intent(in) :: nest_domain
2571  integer, intent(in) :: nest_level
2572  logical :: mpp_is_nest_coarse
2573 
2574  if(nest_level < 1 .OR. nest_level > nest_domain%num_level) call mpp_error(fatal, &
2575  "mpp_define_nest_domains.inc(mpp_is_nest_coarse): nest_level should be between 1 and nest_domain%num_level")
2576 
2577  if(.not. nest_domain%nest(nest_level)%on_level) call mpp_error(fatal, &
2578  "mpp_define_nest_domains.inc(mpp_is_nest_coarse): nest_domain%nest(nest_level)%on_level is false")
2579 
2580  mpp_is_nest_coarse = nest_domain%nest(nest_level)%is_coarse_pe
2581 
2582  end function mpp_is_nest_coarse
2583 !> @}
mpp_define_nest_domains
subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, tile_fine, tile_coarse, istart_coarse, icount_coarse, jstart_coarse, jcount_coarse, npes_nest_tile, x_refine, y_refine, extra_halo, name)
Set up a domain to pass data between aligned coarse and fine grid of nested model.
Definition: mpp_define_nest_domains.inc:97
mpp_shift_nest_domains
subroutine mpp_shift_nest_domains(nest_domain, domain, delta_i_coarse, delta_j_coarse, extra_halo)
Based on mpp_define_nest_domains, but just resets positioning of nest Modifies the parent/coarse star...
Definition: mpp_define_nest_domains.inc:387
compute_overlap_fine_to_coarse
subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name)
This routine will compute the send and recv information between overlapped nesting region....
Definition: mpp_define_nest_domains.inc:1110
convert_index_to_nest
integer function convert_index_to_nest(domain, ishift, jshift, tile_coarse, istart_coarse, iend_coarse, jstart_coarse, jend_coarse, ntiles_coarse, tile_in, is_in, ie_in, js_in, je_in, is_out, ie_out, js_out, je_out, rotate_out)
This routine will convert the global coarse grid index to nest grid index.
Definition: mpp_define_nest_domains.inc:1940
mpp_get_f2c_index_coarse
subroutine mpp_get_f2c_index_coarse(nest_domain, is_coarse, ie_coarse, js_coarse, je_coarse, nest_level, position)
Definition: mpp_define_nest_domains.inc:1768
mpp_get_f2c_index_fine
subroutine mpp_get_f2c_index_fine(nest_domain, is_coarse, ie_coarse, js_coarse, je_coarse, is_fine, ie_fine, js_fine, je_fine, nest_level, position)
Definition: mpp_define_nest_domains.inc:1720
define_nest_level_type
subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo)
Definition: mpp_define_nest_domains.inc:465
mpp_get_domain_shift
subroutine mpp_get_domain_shift(domain, ishift, jshift, position)
Returns the shift value in x and y-direction according to domain position..
Definition: mpp_domains_util.inc:811
mpp_get_c2f_index
subroutine mpp_get_c2f_index(nest_domain, is_fine, ie_fine, js_fine, je_fine, is_coarse, ie_coarse, js_coarse, je_coarse, dir, nest_level, position)
Get the index of the data passed from coarse grid to fine grid.
Definition: mpp_define_nest_domains.inc:1639
stdout
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
mpp_set_current_pelist
subroutine mpp_set_current_pelist(pelist, no_sync)
Set context pelist.
Definition: mpp_util.inc:498
mpp_declare_pelist
subroutine mpp_declare_pelist(pelist, name, commID)
Declare a pelist.
Definition: mpp_util.inc:469
mpp_npes
integer function mpp_npes()
Returns processor count for current pelist.
Definition: mpp_util.inc:420
mpp_pe
integer function mpp_pe()
Returns processor ID.
Definition: mpp_util.inc:406