FMS  2026.01.01-dev
Flexible Modeling System
mpp_domains_misc.inc
1 ! -*-f90-*-
2 !***********************************************************************
3 !* Apache License 2.0
4 !*
5 !* This file is part of the GFDL Flexible Modeling System (FMS).
6 !*
7 !* Licensed under the Apache License, Version 2.0 (the "License");
8 !* you may not use this file except in compliance with the License.
9 !* You may obtain a copy of the License at
10 !*
11 !* http://www.apache.org/licenses/LICENSE-2.0
12 !*
13 !* FMS is distributed in the hope that it will be useful, but WITHOUT
14 !* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
15 !* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
16 !* PARTICULAR PURPOSE. See the License for the specific language
17 !* governing permissions and limitations under the License.
18 !***********************************************************************
19 
20 !> @file
21 !> @brief Initialization and finalization routines for @ref mpp_domains_mod as well
22 !! as other utility routines.
23 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
24 !> @ingroup mpp_domains_mod
25 !> @{
26 !!
27 ! !
28 ! MPP_DOMAINS: initialization and termination !
29 ! !
30 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
31 
32  !> @brief Initialize domain decomp package.
33  !!
34  !> Called to initialize the <TT>mpp_domains_mod</TT> package.
35  !! <TT>flags</TT> can be set to <TT>MPP_VERBOSE</TT> to have
36  !! <TT>mpp_domains_mod</TT> keep you informed of what it's up
37  !! to. <TT>MPP_DEBUG</TT> returns even more information for debugging.
38  !!
39  !! <TT>mpp_domains_init</TT> will call <TT>mpp_init</TT>, to make sure
40  !! <TT>@ref mpp_mod</TT> is initialized. (Repeated
41  !! calls to <TT>@ref mpp_init</TT> do no harm, so don't worry if you already
42  !! called it).
43  subroutine mpp_domains_init(flags)
44  integer, intent(in), optional :: flags
45  integer :: n
46  integer :: io_status, iunit
47 
48  if( module_is_initialized )return
49  call mpp_init(flags) !this is a no-op if already initialized
50  module_is_initialized = .true.
51  pe = mpp_root_pe()
52  iunit = stdlog()
53  if( mpp_pe() .EQ.mpp_root_pe() ) write( iunit,'(/a)' )'MPP_DOMAINS module '//trim(version)
54 
55  if( PRESENT(flags) )then
56  debug = flags.EQ.mpp_debug
57  verbose = flags.EQ.mpp_verbose .OR. debug
58  domain_clocks_on = flags.EQ.mpp_domain_time
59  end if
60 
61  !--- namelist
62  read (input_nml_file, mpp_domains_nml, iostat=io_status)
63  if (io_status > 0) then
64  call mpp_error(fatal,'=>mpp_domains_init: Error reading mpp_domains_nml')
65  endif
66 
67 
68  select case(lowercase(trim(debug_update_domain)))
69  case("none")
70  debug_update_level = no_check
71  case("fatal")
72  debug_update_level = fatal
73  case("warning")
74  debug_update_level = warning
75  case("note")
76  debug_update_level = note
77  case default
78  call mpp_error(fatal, "mpp_domains_init: debug_update_level should be 'none', 'fatal', 'warning', or 'note'")
79  end select
80 
81  allocate(nonblock_data(max_nonblock_update))
82 
83  do n = 1, max_nonblock_update
84  call init_nonblock_type(nonblock_data(n))
85  enddo
86 
87  call mpp_domains_set_stack_size(32768) !default, pretty arbitrary
88 
89 !NULL_DOMAIN is a domaintype that can be used to initialize to undef
90  call mpp_define_null_domain(null_domain1d);
91  call mpp_define_null_domain(null_domain2d);
92  call mpp_define_null_ug_domain(null_domainug)
93 
94  if( domain_clocks_on )then
95  pack_clock = mpp_clock_id( 'Halo pack' )
96  send_clock = mpp_clock_id( 'Halo send' )
97  recv_clock = mpp_clock_id( 'Halo recv' )
98  unpk_clock = mpp_clock_id( 'Halo unpk' )
99  wait_clock = mpp_clock_id( 'Halo wait' )
100  send_pack_clock_nonblock = mpp_clock_id( 'Halo pack and send nonblock' )
101  recv_clock_nonblock = mpp_clock_id( 'Halo recv nonblock' )
102  unpk_clock_nonblock = mpp_clock_id( 'Halo unpk nonblock' )
103  wait_clock_nonblock = mpp_clock_id( 'Halo wait nonblock' )
104  nest_pack_clock = mpp_clock_id( 'nest pack' )
105  nest_send_clock = mpp_clock_id( 'nest send' )
106  nest_recv_clock = mpp_clock_id( 'nest recv' )
107  nest_unpk_clock = mpp_clock_id( 'nest unpk' )
108  nest_wait_clock = mpp_clock_id( 'nest wait' )
109  group_pack_clock = mpp_clock_id( 'group pack' )
110  group_send_clock = mpp_clock_id( 'group send' )
111  group_recv_clock = mpp_clock_id( 'group recv' )
112  group_unpk_clock = mpp_clock_id( 'group unpk' )
113  group_wait_clock = mpp_clock_id( 'group wait' )
114  nonblock_group_pack_clock = mpp_clock_id( 'nonblock group pack' )
115  nonblock_group_send_clock = mpp_clock_id( 'nonblock group send' )
116  nonblock_group_recv_clock = mpp_clock_id( 'nonblock group recv' )
117  nonblock_group_unpk_clock = mpp_clock_id( 'nonblock group unpk' )
118  nonblock_group_wait_clock = mpp_clock_id( 'nonblock group wait' )
119  end if
120  return
121  end subroutine mpp_domains_init
122 
123 !#####################################################################
124 subroutine init_nonblock_type( nonblock_obj )
125  type(nonblock_type), intent(inout) :: nonblock_obj
126 
127 
128  nonblock_obj%recv_pos = 0
129  nonblock_obj%send_pos = 0
130  nonblock_obj%recv_msgsize = 0
131  nonblock_obj%send_msgsize = 0
132  nonblock_obj%update_flags = 0
133  nonblock_obj%update_position = 0
134  nonblock_obj%update_gridtype = 0
135  nonblock_obj%update_whalo = 0
136  nonblock_obj%update_ehalo = 0
137  nonblock_obj%update_shalo = 0
138  nonblock_obj%update_nhalo = 0
139  nonblock_obj%request_send_count = 0
140  nonblock_obj%request_recv_count = 0
141  nonblock_obj%size_recv(:) = 0
142  nonblock_obj%type_recv(:) = mpi_datatype_null
143  nonblock_obj%request_send(:) = mpi_request_null
144  nonblock_obj%request_recv(:) = mpi_request_null
145  nonblock_obj%buffer_pos_send(:) = 0
146  nonblock_obj%buffer_pos_recv(:) = 0
147  nonblock_obj%nfields = 0
148  nonblock_obj%field_addrs(:) = 0
149  nonblock_obj%field_addrs2(:) = 0
150 
151  return
152 
153 end subroutine init_nonblock_type
154 
155 !#####################################################################
156 
157  !> @brief Exit <TT>mpp_domains_mod</TT>.
158  !! Serves no particular purpose, but is provided should you require to
159  !! re-initialize <TT>mpp_domains_mod</TT>, for some odd reason.
160  subroutine mpp_domains_exit()
161  integer :: iunit
162  if( .NOT.module_is_initialized )return
163  call mpp_max(mpp_domains_stack_hwm)
164  iunit = stdout()
165  if( mpp_pe().EQ.mpp_root_pe() )write( iunit,* )'MPP_DOMAINS_STACK high water mark=', mpp_domains_stack_hwm
166  module_is_initialized = .false.
167  return
168  end subroutine mpp_domains_exit
169 
170 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
171 ! !
172 ! MPP_CHECK_FIELD: Check parallel !
173 ! !
174 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
175 
176  !> This routine is used to do parallel checking for 3d data between n and m pe. The comparison is
177  !! is done on pelist2. When size of pelist2 is 1, we can check the halo; otherwise,
178  !! halo can not be checked.
179  subroutine mpp_check_field_3d(field_in, pelist1, pelist2, domain, mesg, &
180  w_halo, s_halo, e_halo, n_halo, force_abort, position )
181 
182  real, dimension(:,:,:), intent(in) :: field_in !< field to be checked
183  integer, dimension(:), intent(in) :: pelist1, pelist2 !< pe list for the two groups
184  type(domain2d), intent(in) :: domain !< domain for each pe
185  character(len=*), intent(in) :: mesg !< message to be printed out
186  !! if differences found
187  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo
188  !< halo size for west, south, east and north
189  logical, intent(in), optional :: force_abort !< when true, call mpp_error if any difference
190  !! found. default value is false.
191  integer, intent(in), optional :: position !< when domain is symmetry, only value = CENTER is
192  !! implemented.
193 
194  integer :: k
195  character(len=256) :: temp_mesg
196 
197 
198  do k = 1, size(field_in,3)
199  write(temp_mesg, '(a, i3)') trim(mesg)//" at level " , k
200  call mpp_check_field_2d(field_in(:,:,k), pelist1, pelist2, domain, temp_mesg, &
201  w_halo, s_halo, e_halo, n_halo, force_abort, position )
202  enddo
203 
204  end subroutine mpp_check_field_3d
205 
206 
207 !#####################################################################################
208 
209  !> This routine is used to do parallel checking for 2d data between n and m pe. The comparison is
210  !! is done on pelist2. When size of pelist2 is 1, we can check the halo; otherwise,
211  !! halo can not be checked.
212  subroutine mpp_check_field_2d(field_in, pelist1, pelist2, domain, mesg, &
213  w_halo, s_halo, e_halo, n_halo,force_abort, position )
214 
215  real, dimension(:,:), intent(in) :: field_in !< field to be checked
216  integer, dimension(:), intent(in) :: pelist1, pelist2 !< pe list for the two groups
217  type(domain2d), intent(in) :: domain !< domain for each pe
218  character(len=*), intent(in) :: mesg !< message to be printed out
219  !! if differences found
220  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo !< halo size for west, south, east and north
221  logical, intent(in), optional :: force_abort !< when true, call mpp_error if any difference
222  !! found. default value is false.
223  integer, intent(in), optional :: position !< when domain is symmetry, only value = CENTER is
224  !! implemented.
225 
226  if(present(position)) then
227  if(position .NE. center .AND. domain%symmetry) call mpp_error(fatal, &
228  'mpp_check_field: when domain is symmetry, only value CENTER is implemented, contact author')
229  endif
230 
231  if(size(pelist2(:)) == 1) then
232  call mpp_check_field_2d_type1(field_in, pelist1, pelist2, domain, mesg, &
233  w_halo, s_halo, e_halo, n_halo, force_abort )
234  else if(size(pelist1(:)) == 1) then
235  call mpp_check_field_2d_type1(field_in, pelist2, pelist1, domain, mesg, &
236  w_halo, s_halo, e_halo, n_halo, force_abort )
237  else if(size(pelist1(:)) .gt. 1 .and. size(pelist2(:)) .gt. 1) then
238  call mpp_check_field_2d_type2(field_in, pelist1, pelist2, domain, mesg, force_abort )
239  else
240  call mpp_error(fatal, 'mpp_check_field: size of both pelists should be greater than 0')
241  endif
242 
243  end subroutine mpp_check_field_2d
244 
245 
246 !####################################################################################
247 
248  !> This routine is used to check field between running on 1 pe (pelist2) and
249  !! n pe(pelist1). The need_to_be_checked data is sent to the pelist2 and All the
250  !! comparison is done on pelist2.
251  subroutine mpp_check_field_2d_type1(field_in, pelist1, pelist2, domain, mesg, &
252  w_halo, s_halo, e_halo, n_halo,force_abort )
253 
254  real, dimension(:,:), intent(in) :: field_in !< field to be checked
255  integer, dimension(:), intent(in) :: pelist1, pelist2 !< pe list for the two groups
256  type(domain2d), intent(in) :: domain !< domain for each pe
257  character(len=*), intent(in) :: mesg !< message to be printed out
258  !! if differences found
259  integer, intent(in), optional :: w_halo, s_halo, e_halo, n_halo !< halo size for west, south, east and north
260  logical, intent(in), optional :: force_abort !< when, call mpp_error if any difference
261  !! found. default value is false.
262 ! some local data
263 
264  integer :: pe,npes, p
265  integer :: hwest, hsouth, heast, hnorth, isg, ieg, jsg, jeg, xhalo, yhalo
266  integer :: i,j,im,jm,l,is,ie,js,je,isc,iec,jsc,jec,isd,ied,jsd,jed
267  real,dimension(:,:), allocatable :: field1,field2
268  real,dimension(:), allocatable :: send_buffer
269  integer, dimension(4) :: ibounds
270  logical :: check_success, error_exit
271 
272  check_success = .true.
273  error_exit = .false.
274  if(present(force_abort)) error_exit = force_abort
275  hwest = 0; if(present(w_halo)) hwest = w_halo
276  heast = 0; if(present(e_halo)) heast = e_halo
277  hsouth = 0; if(present(s_halo)) hsouth = s_halo
278  hnorth = 0; if(present(n_halo)) hnorth = n_halo
279 
280  pe = mpp_pe()
281  npes = mpp_npes()
282 
283  call mpp_get_compute_domain(domain, isc, iec, jsc, jec)
284  call mpp_get_data_domain(domain, isd, ied, jsd, jed)
285  call mpp_get_global_domain(domain, isg, ieg, jsg, jeg)
286  xhalo = isc - isd
287  yhalo = jsc - jsd
288  !--- need to checked halo size should not be bigger than x_halo or y_halo
289  if(hwest .gt. xhalo .or. heast .gt. xhalo .or. hsouth .gt. yhalo .or. hnorth .gt. yhalo) &
290  call mpp_error(fatal,'mpp_check_field: '//trim(mesg)//': The halo size is not correct')
291 
292  is = isc - hwest; ie = iec + heast; js = jsc - hsouth; je = jec + hnorth
293  allocate(field2(is:ie,js:je))
294 
295  ! check if the field_in is on compute domain or data domain
296  if((size(field_in,1) .eq. iec-isc+1) .and. (size(field_in,2) .eq. jec-jsc+1)) then
297  !if field_in on compute domain, you can not check halo points
298  if( hwest .ne. 0 .or. heast .ne. 0 .or. hsouth .ne. 0 .or. hnorth .ne. 0 ) &
299  call mpp_error(fatal,'mpp_check_field: '//trim(mesg)//': field is on compute domain, can not check halo')
300  field2(:,:) = field_in(:,:)
301  else if((size(field_in,1) .eq. ied-isd+1) .and. (size(field_in,2) .eq. jed-jsd+1)) then
302  field2(is:ie,js:je) = field_in(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1)
303  else if((size(field_in,1) .eq. ieg-isg+1) .and. (size(field_in,2) .eq. jeg-jsg+1)) then
304  if( hwest .ne. 0 .or. heast .ne. 0 .or. hsouth .ne. 0 .or. hnorth .ne. 0 ) &
305  call mpp_error(fatal,'mpp_check_field: '//trim(mesg)//': field is on compute domain, can not check halo')
306  field2(is:ie,js:je) = field_in(1:ie-is+1,1:je-js+1)
307  else if((size(field_in,1) .eq. ieg-isg+1+2*xhalo) .and. (size(field_in,2) .eq. jeg-jsg+1+2*yhalo)) then
308  field2(is:ie,js:je) = field_in(is-isd+1:ie-isd+1,js-jsd+1:je-jsd+1)
309  else
310  print*, 'on pe ', pe, 'domain: ', isc, iec, jsc, jec, isd, ied, jsd, jed, 'size of field: ', size(field_in,1), &
311  & size(field_in,2)
312  call mpp_error(fatal,'mpp_check_field: '//trim(mesg)//':field is not on compute, data or global domain')
313  endif
314 
315  call mpp_sync_self()
316 
317  if(any(pelist1 == pe)) then ! send data to root pe
318 
319  im = ie-is+1; jm=je-js+1
320  allocate(send_buffer(im*jm))
321 
322  ibounds(1) = is; ibounds(2) = ie; ibounds(3) = js; ibounds(4) = je
323  l = 0
324  do i = is,ie
325  do j = js,je
326  l = l+1
327  send_buffer(l) = field2(i,j)
328  enddo
329  enddo
330 ! send the check bounds and data to the root pe
331  ! Force use of "scalar", integer pointer mpp interface
332  call mpp_send(ibounds(1), plen=4, to_pe=pelist2(1), tag=comm_tag_1)
333  call mpp_send(send_buffer(1),plen=im*jm, to_pe=pelist2(1), tag=comm_tag_2)
334 
335  else if(pelist2(1) == pe) then ! receive data and compare
336  do p = pelist1(1), pelist1(size(pelist1(:)))
337  ! Force use of "scalar", integer pointer mpp interface
338  call mpp_recv(ibounds(1), glen=4,from_pe=p, tag=comm_tag_1)
339  is = ibounds(1); ie = ibounds(2); js=ibounds(3); je=ibounds(4)
340  im = ie-is+1; jm=je-js+1
341  if(allocated(field1)) deallocate(field1)
342  if(allocated(send_buffer)) deallocate(send_buffer)
343  allocate(field1(is:ie,js:je),send_buffer(im*jm))
344  ! Force use of "scalar", integer pointer mpp interface
345  call mpp_recv(send_buffer(1),glen=im*jm,from_pe=p, tag=comm_tag_2)
346  l = 0
347 
348 ! compare here, the comparison criteria can be changed according to need
349  do i = is,ie
350  do j = js,je
351  l = l+1
352  field1(i,j) = send_buffer(l)
353  if(field1(i,j) .ne. field2(i,j)) then
354  ! write to standard output
355  print*,trim(mesg)//": ", i, j, field1(i,j), field2(i,j), field1(i,j) - field2(i,j)
356 ! write(stdout(),'(a,2i,2f)') trim(mesg), i, j, pass_field(i,j), field_check(i,j)
357  check_success = .false.
358  if(error_exit) call mpp_error(fatal,"mpp_check_field: can not reproduce at this point")
359  endif
360  enddo
361  enddo
362  enddo
363 
364  if(check_success) then
365  print*, trim(mesg)//": ", 'comparison between 1 pe and ', npes-1, ' pes is ok'
366  endif
367  ! release memery
368  deallocate(field1)
369  endif
370 
371  deallocate(field2)
372 
373  call mpp_sync()
374  if (allocated(send_buffer)) deallocate(send_buffer)
375 
376  end subroutine mpp_check_field_2d_type1
377 
378 !####################################################################
379 
380  !> This routine is used to check field between running on m pe (root pe) and
381  !! n pe. This routine can not check halo.
382  subroutine mpp_check_field_2d_type2(field_in, pelist1, pelist2, domain, mesg,force_abort)
383 
384  real, dimension(:,:), intent(in) :: field_in
385  type(domain2d), intent(in) :: domain
386  integer, dimension(:), intent(in) :: pelist1
387  integer, dimension(:), intent(in) :: pelist2
388  character(len=*), intent(in) :: mesg
389  logical, intent(in), optional :: force_abort !< when, call mpp_error if any difference
390  !! found. default value is false.
391 ! some local variables
392  logical :: check_success, error_exit
393  real, dimension(:,:), allocatable :: field1, field2
394  integer :: i, j, pe, npes, isd,ied,jsd,jed, is, ie, js, je
395  type(domain2d) :: domain1, domain2
396 
397  check_success = .true.
398  error_exit = .false.
399  if(present(force_abort)) error_exit = force_abort
400  pe = mpp_pe()
401  npes = mpp_npes()
402  call mpp_sync_self()
403  if(any(pelist1 == pe)) domain1 = domain
404  if(any(pelist2 == pe)) domain2 = domain
405 
406 ! Comparison is made on pelist2.
407  if(any(pelist2 == pe)) then
408  call mpp_get_data_domain(domain2, isd, ied, jsd, jed)
409  call mpp_get_compute_domain(domain2, is, ie, js, je)
410  allocate(field1(isd:ied, jsd:jed),field2(isd:ied, jsd:jed))
411  if((size(field_in,1) .ne. ied-isd+1) .or. (size(field_in,2) .ne. jed-jsd+1)) &
412  call mpp_error(fatal,'mpp_check_field: input field is not on the data domain')
413  field2(isd:ied, jsd:jed) = field_in(:,:)
414  endif
415 
416 ! allocate field1 on pelist1
417 ! if field1 is left unallocated, the code will try to access unallocated memory
418 ! when field1 is set to 0 in mpp_redistribute
419  if(any(pelist1 == pe)) then
420  allocate(field1(1,1))
421  endif
422 
423 ! broadcast domain
424  call mpp_broadcast_domain(domain1)
425  call mpp_broadcast_domain(domain2)
426 
427  call mpp_redistribute(domain1,field_in,domain2,field1)
428 
429  if(any(pelist2 == pe)) then
430  do i =is,ie
431  do j =js,je
432  if(field1(i,j) .ne. field2(i,j)) then
433  print*, trim(mesg)//": ", i, j, field1(i,j), field2(i,j), field1(i,j) - field2(i,j)
434 ! write(stdout(),'(a,2i,2f)') trim(mesg), i, j, field_check(i,j), field_out(i,j)
435  check_success = .false.
436  if(error_exit) call mpp_error(fatal,"mpp_check_field: can not reproduce at this point")
437  endif
438  enddo
439  enddo
440  if(check_success) &
441  print*, trim(mesg)//": ", 'comparison between ', size(pelist1(:)), ' pes and ', &
442  size(pelist2(:)), ' pe on', pe, ' pes is ok'
443  endif
444 
445  if(any(pelist2 == pe)) deallocate(field1, field2)
446 
447  if(any(pelist1 == pe)) deallocate(field1)
448 
449  call mpp_sync()
450 
451  return
452 
453  end subroutine mpp_check_field_2d_type2
454 
455 
456 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
457 ! !
458 ! MPP_BROADCAST_DOMAIN !
459 ! !
460 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
461 
462  !> broadcast domain (useful only outside the context of its own pelist)
463  subroutine mpp_broadcast_domain_1( domain )
464  type(domain2d), intent(inout) :: domain
465  integer, allocatable :: pes(:)
466  logical :: native !> true if I'm on the pelist of this domain
467  integer :: listsize, listpos
468  integer :: n
469  integer, dimension(12) :: msg, info !> pe and compute domain of each item in list
470  integer :: errunit
471 
472  errunit = stderr()
473  if( .NOT.module_is_initialized ) &
474  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_1: You must first call mpp_domains_init.' )
475 
476 !get the current pelist
477  allocate( pes(0:mpp_npes()-1) )
478  call mpp_get_current_pelist(pes)
479 
480 !am I part of this domain?
481  native = ASSOCIATED(domain%list)
482 
483 !set local list size
484  if( native )then
485  listsize = size(domain%list(:))
486  else
487  listsize = 0
488  end if
489  call mpp_max(listsize)
490 
491  if( .NOT.native )then
492 !initialize domain%list and set null values in message
493  allocate( domain%list(0:listsize-1) )
494  domain%pe = null_pe
495  domain%pos = -1
496  allocate(domain%x(1), domain%y(1), domain%tile_id(1))
497  do n = 0, listsize-1
498  allocate(domain%list(n)%x(1), domain%list(n)%y(1), domain%list(n)%tile_id(1) )
499  end do
500  domain%x%compute%begin = 1
501  domain%x%compute%end = -1
502  domain%y%compute%begin = 1
503  domain%y%compute%end = -1
504  domain%x%domain_data %begin = -1
505  domain%x%domain_data %end = -1
506  domain%y%domain_data %begin = -1
507  domain%y%domain_data %end = -1
508  domain%x%global %begin = -1
509  domain%x%global %end = -1
510  domain%y%global %begin = -1
511  domain%y%global %end = -1
512  domain%tile_id = -1
513  domain%whalo = -1
514  domain%ehalo = -1
515  domain%shalo = -1
516  domain%nhalo = -1
517  domain%symmetry = .false.
518  end if
519 !initialize values in info
520  info(1) = domain%pe
521  call mpp_get_compute_domain( domain, info(2), info(3), info(4), info(5) )
522  info(6) = domain%tile_id(1)
523  info(7) = domain%whalo
524  info(8) = domain%ehalo
525  info(9) = domain%shalo
526  info(10)= domain%nhalo
527  if(domain%symmetry) then
528  info(11) = 1
529  else
530  info(11) = 0
531  endif
532  info(12) = domain%ntiles
533 !broadcast your info across current pelist and unpack if needed
534  listpos = 0
535  do n = 0,mpp_npes()-1
536  msg = info
537  if( mpp_pe().EQ.pes(n) .AND. debug )write( errunit,* )'PE ', mpp_pe(), 'broadcasting msg ', msg
538  call mpp_broadcast( msg, 12, pes(n) )
539 !no need to unpack message if native
540 !no need to unpack message from non-native PE
541  if( .NOT.native .AND. msg(1).NE.null_pe )then
542  domain%list(listpos)%pe = msg(1)
543  domain%list(listpos)%x%compute%begin = msg(2)
544  domain%list(listpos)%x%compute%end = msg(3)
545  domain%list(listpos)%y%compute%begin = msg(4)
546  domain%list(listpos)%y%compute%end = msg(5)
547  domain%list(listpos)%tile_id(1) = msg(6)
548  if(domain%x(1)%global%begin < 0) then
549  domain%x(1)%domain_data %begin = msg(2)
550  domain%x(1)%domain_data %end = msg(3)
551  domain%y(1)%domain_data %begin = msg(4)
552  domain%y(1)%domain_data %end = msg(5)
553  domain%x(1)%global%begin = msg(2)
554  domain%x(1)%global%end = msg(3)
555  domain%y(1)%global%begin = msg(4)
556  domain%y(1)%global%end = msg(5)
557  domain%whalo = msg(7)
558  domain%ehalo = msg(8)
559  domain%shalo = msg(9)
560  domain%nhalo = msg(10)
561  if(msg(11) == 1) then
562  domain%symmetry = .true.
563  else
564  domain%symmetry = .false.
565  endif
566  domain%ntiles = msg(12)
567  else
568  domain%x(1)%domain_data %begin = msg(2) - msg(7)
569  domain%x(1)%domain_data %end = msg(3) + msg(8)
570  domain%y(1)%domain_data %begin = msg(4) - msg(9)
571  domain%y(1)%domain_data %end = msg(5) + msg(10)
572  domain%x(1)%global%begin = min(domain%x(1)%global%begin, msg(2))
573  domain%x(1)%global%end = max(domain%x(1)%global%end, msg(3))
574  domain%y(1)%global%begin = min(domain%y(1)%global%begin, msg(4))
575  domain%y(1)%global%end = max(domain%y(1)%global%end, msg(5))
576  endif
577  listpos = listpos + 1
578  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
579  end if
580  end do
581 
582  end subroutine mpp_broadcast_domain_1
583 
584 
585 !##############################################################################
586  !> Broadcast domain (useful only outside the context of its own pelist)
587  subroutine mpp_broadcast_domain_2( domain_in, domain_out )
588  type(domain2d), intent(in) :: domain_in
589  type(domain2d), intent(inout) :: domain_out
590  integer, allocatable :: pes(:)
591  integer :: listpos
592  integer :: n
593  integer, dimension(12) :: msg, info !< pe and compute domain of each item in list
594  integer :: errunit, npes_in, npes_out, pstart, pend
595 
596  errunit = stderr()
597  if( .NOT.module_is_initialized ) &
598  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_2: You must first call mpp_domains_init.' )
599 
600 !get the current pelist
601  allocate( pes(0:mpp_npes()-1) )
602  call mpp_get_current_pelist(pes)
603 
604 ! domain_in must be initialized
605  if( .not. ASSOCIATED(domain_in%list) ) then
606  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_2: domain_in is not initialized')
607  endif
608  if( ASSOCIATED(domain_out%list) ) then
609  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_2: domain_out is already initialized')
610  endif
611 
612  npes_in = size(domain_in%list(:))
613  if( npes_in == mpp_npes() ) then
614  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_2: size(domain_in%list(:)) == mpp_npes()')
615  endif
616  npes_out = mpp_npes() - npes_in
617 
618 !initialize domain_out%list and set null values in message
619  allocate( domain_out%list(0:npes_out-1) )
620  domain_out%pe = null_pe
621  domain_out%pos = -1
622  allocate(domain_out%x(1), domain_out%y(1), domain_out%tile_id(1))
623  do n = 0, npes_out-1
624  allocate(domain_out%list(n)%x(1), domain_out%list(n)%y(1), domain_out%list(n)%tile_id(1) )
625  end do
626  domain_out%x%compute%begin = 1
627  domain_out%x%compute%end = -1
628  domain_out%y%compute%begin = 1
629  domain_out%y%compute%end = -1
630  domain_out%x%domain_data %begin = -1
631  domain_out%x%domain_data %end = -1
632  domain_out%y%domain_data %begin = -1
633  domain_out%y%domain_data %end = -1
634  domain_out%x%global %begin = -1
635  domain_out%x%global %end = -1
636  domain_out%y%global %begin = -1
637  domain_out%y%global %end = -1
638  domain_out%tile_id = -1
639  domain_out%whalo = -1
640  domain_out%ehalo = -1
641  domain_out%shalo = -1
642  domain_out%nhalo = -1
643  domain_out%symmetry = .false.
644 !initialize values in info
645  info(1) = domain_in%pe
646  call mpp_get_compute_domain( domain_in, info(2), info(3), info(4), info(5) )
647  info(6) = domain_in%tile_id(1)
648  info(7) = domain_in%whalo
649  info(8) = domain_in%ehalo
650  info(9) = domain_in%shalo
651  info(10)= domain_in%nhalo
652  if(domain_in%symmetry) then
653  info(11) = 1
654  else
655  info(11) = 0
656  endif
657  info(12) = domain_in%ntiles
658 
659 !broadcast your info across current pelist and unpack if needed
660  if( domain_in%list(0)%pe == mpp_root_pe() ) then
661  pstart = npes_in
662  pend = mpp_npes()-1
663  else
664  pstart = 0
665  pend = npes_out-1
666  endif
667  do n = 0,mpp_npes()-1
668  msg = info
669  if( mpp_pe().EQ.pes(n) .AND. debug )write( errunit,* )'PE ', mpp_pe(), 'broadcasting msg ', msg
670  call mpp_broadcast( msg, 12, pes(n) )
671  !--- pack if from other domain
672  if( n .GE. pstart .AND. n .LE. pend )then
673  listpos = n - pstart
674  domain_out%list(listpos)%pe = msg(1)
675  domain_out%list(listpos)%x%compute%begin = msg(2)
676  domain_out%list(listpos)%x%compute%end = msg(3)
677  domain_out%list(listpos)%y%compute%begin = msg(4)
678  domain_out%list(listpos)%y%compute%end = msg(5)
679  domain_out%list(listpos)%tile_id(1) = msg(6)
680  if(domain_out%x(1)%global%begin < 0) then
681  domain_out%x(1)%domain_data %begin = msg(2)
682  domain_out%x(1)%domain_data %end = msg(3)
683  domain_out%y(1)%domain_data %begin = msg(4)
684  domain_out%y(1)%domain_data %end = msg(5)
685  domain_out%x(1)%global%begin = msg(2)
686  domain_out%x(1)%global%end = msg(3)
687  domain_out%y(1)%global%begin = msg(4)
688  domain_out%y(1)%global%end = msg(5)
689  domain_out%whalo = msg(7)
690  domain_out%ehalo = msg(8)
691  domain_out%shalo = msg(9)
692  domain_out%nhalo = msg(10)
693  if(msg(11) == 1) then
694  domain_out%symmetry = .true.
695  else
696  domain_out%symmetry = .false.
697  endif
698  domain_out%ntiles = msg(12)
699  else
700  domain_out%x(1)%domain_data %begin = msg(2) - msg(7)
701  domain_out%x(1)%domain_data %end = msg(3) + msg(8)
702  domain_out%y(1)%domain_data %begin = msg(4) - msg(9)
703  domain_out%y(1)%domain_data %end = msg(5) + msg(10)
704  domain_out%x(1)%global%begin = min(domain_out%x(1)%global%begin, msg(2))
705  domain_out%x(1)%global%end = max(domain_out%x(1)%global%end, msg(3))
706  domain_out%y(1)%global%begin = min(domain_out%y(1)%global%begin, msg(4))
707  domain_out%y(1)%global%end = max(domain_out%y(1)%global%end, msg(5))
708  endif
709  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
710  end if
711  end do
712 
713  end subroutine mpp_broadcast_domain_2
714 
715  !> Broadcast fine nested domain (useful only outside the context of its own pelist)
716  subroutine mpp_broadcast_domain_nest_fine( domain, tile_nest )
717  type(domain2d), intent(inout) :: domain
718  integer, intent(in) :: tile_nest(:)
719  integer, allocatable :: pes(:)
720  logical :: native !< true if I'm on the pelist of this domain
721  integer :: listsize, listpos, nestsize(size(tile_nest(:)))
722  integer :: n, tile, ind, num_nest
723  integer, dimension(15) :: msg, info !< pe and compute domain of each item in list
724  integer :: errunit
725 
726  errunit = stderr()
727  if( .NOT.module_is_initialized ) &
728  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_NEST_FINE: You must first call mpp_domains_init.' )
729 
730 !get the current pelist
731  allocate( pes(0:mpp_npes()-1) )
732  call mpp_get_current_pelist(pes)
733 
734 !am I part of this domain?
735  native = ASSOCIATED(domain%list)
736  num_nest = size(tile_nest(:))
737 !set local list size
738  nestsize = 0
739  if( native )then
740  tile = domain%tile_id(1)
741  ind = 0
742  do n = 1, num_nest
743  if(tile_nest(n) == tile) then
744  ind = n
745  exit
746  endif
747  enddo
748  if(ind == 0) call mpp_error( fatal, &
749  & 'MPP_BROADCAST_DOMAIN_NEST_FINE:native is true, but tile_id is found in tile_nest')
750  nestsize(ind) = size(domain%list(:))
751  end if
752  call mpp_max(nestsize, num_nest)
753  listsize = sum(nestsize)
754 
755  if( .NOT.native )then
756 !initialize domain%list and set null values in message
757  allocate( domain%list(0:listsize-1) )
758  domain%pe = null_pe
759  domain%pos = -1
760  allocate(domain%x(1), domain%y(1), domain%tile_id(1))
761  do n = 0, listsize-1
762  allocate(domain%list(n)%x(1), domain%list(n)%y(1), domain%list(n)%tile_id(1) )
763  end do
764  domain%x%compute%begin = 0
765  domain%x%compute%end = -1
766  domain%y%compute%begin = 0
767  domain%y%compute%end = -1
768  domain%x%domain_data %begin = 0
769  domain%x%domain_data %end = -1
770  domain%y%domain_data %begin = 0
771  domain%y%domain_data %end = -1
772  domain%x%global %begin = 0
773  domain%x%global %end = -1
774  domain%y%global %begin = 0
775  domain%y%global %end = -1
776  domain%tile_id = -1
777  domain%whalo = -1
778  domain%ehalo = -1
779  domain%shalo = -1
780  domain%nhalo = -1
781  domain%symmetry = .false.
782  end if
783 !initialize values in info
784  info(1) = domain%pe
785  call mpp_get_compute_domain( domain, info(2), info(3), info(4), info(5) )
786  info(6) = domain%tile_id(1)
787  info(7) = domain%whalo
788  info(8) = domain%ehalo
789  info(9) = domain%shalo
790  info(10)= domain%nhalo
791  if(domain%symmetry) then
792  info(11) = 1
793  else
794  info(11) = 0
795  endif
796  call mpp_get_global_domain( domain, info(12), info(13), info(14), info(15) )
797 !broadcast your info across current pelist and unpack if needed
798  listpos = 0
799  do n = 0,mpp_npes()-1
800  msg = info
801  if( mpp_pe().EQ.pes(n) .AND. debug )write( errunit,* )'PE ', mpp_pe(), 'broadcasting msg ', msg
802  call mpp_broadcast( msg, 15, pes(n) )
803 !no need to unpack message if native
804 !no need to unpack message from non-native PE
805  if( .NOT.native .AND. msg(1).NE.null_pe )then
806  domain%list(listpos)%pe = msg(1)
807  if(domain%x(1)%compute%begin == 0) then
808  domain%whalo = msg(7)
809  domain%ehalo = msg(8)
810  domain%shalo = msg(9)
811  domain%nhalo = msg(10)
812  if(msg(11) == 1) then
813  domain%symmetry = .true.
814  else
815  domain%symmetry = .false.
816  endif
817  endif
818  domain%list(listpos)%x%compute%begin = msg(2)
819  domain%list(listpos)%x%compute%end = msg(3)
820  domain%list(listpos)%y%compute%begin = msg(4)
821  domain%list(listpos)%y%compute%end = msg(5)
822  domain%list(listpos)%tile_id(1) = msg(6)
823  domain%list(listpos)%x%global %begin = msg(12)
824  domain%list(listpos)%x%global %end = msg(13)
825  domain%list(listpos)%y%global %begin = msg(14)
826  domain%list(listpos)%y%global %end = msg(15)
827  listpos = listpos + 1
828  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
829  end if
830  end do
831 
832  end subroutine mpp_broadcast_domain_nest_fine
833 
834  !> Broadcast nested domain (useful only outside the context of its own pelist)
835  subroutine mpp_broadcast_domain_nest_coarse( domain, tile_coarse )
836  type(domain2d), intent(inout) :: domain
837  integer, intent(in) :: tile_coarse
838  integer, allocatable :: pes(:)
839  logical :: native !< true if I'm on the pelist of this domain
840  integer :: listsize, listpos
841  integer, allocatable :: tile_pesize(:)
842  integer :: n, maxtile
843  integer, dimension(17) :: msg, info !< pe and compute domain of each item in list
844  integer :: errunit
845 
846  errunit = stderr()
847  if( .NOT.module_is_initialized ) &
848  call mpp_error( fatal, 'MPP_BROADCAST_DOMAIN_NEST_COARSE: You must first call mpp_domains_init.' )
849 
850 !get the current pelist
851  allocate( pes(0:mpp_npes()-1) )
852  call mpp_get_current_pelist(pes)
853 
854  maxtile = tile_coarse
855  call mpp_max(maxtile)
856  allocate(tile_pesize(maxtile))
857  tile_pesize = 0
858 !am I part of this domain?
859  native = ASSOCIATED(domain%list)
860 !set local list size
861  if( native )then
862 ! tile = domain%tile_id(1)
863 ! if(tile .NE. tile_coarse) then
864 ! print*, "tile,tile_coarse=", tile, tile_coarse, mpp_pe()
865 ! call mpp_error( FATAL, 'MPP_BROADCAST_DOMAIN_NEST_COARSE: tile .NE. tile_coarse')
866 ! endif
867  tile_pesize(tile_coarse) = size(domain%list(:))
868  end if
869  call mpp_max(tile_pesize, maxtile)
870  listsize = tile_pesize(tile_coarse)
871 
872  if( .NOT.native )then
873 !initialize domain%list and set null values in message
874  allocate( domain%list(0:listsize-1) )
875  domain%pe = null_pe
876  domain%pos = -1
877  allocate(domain%x(1), domain%y(1), domain%tile_id(1))
878  do n = 0, listsize-1
879  allocate(domain%list(n)%x(1), domain%list(n)%y(1), domain%list(n)%tile_id(1) )
880  end do
881  domain%x%compute%begin = 0
882  domain%x%compute%end = -1
883  domain%y%compute%begin = 0
884  domain%y%compute%end = -1
885  domain%x%domain_data %begin = 0
886  domain%x%domain_data %end = -1
887  domain%y%domain_data %begin = 0
888  domain%y%domain_data %end = -1
889  domain%x%global %begin = 0
890  domain%x%global %end = -1
891  domain%y%global %begin = 0
892  domain%y%global %end = -1
893  domain%tile_id = -1
894  domain%whalo = -1
895  domain%ehalo = -1
896  domain%shalo = -1
897  domain%nhalo = -1
898  domain%symmetry = .false.
899  domain%ntiles = 0
900  end if
901 !initialize values in info
902  info(1) = domain%pe
903  call mpp_get_compute_domain( domain, info(2), info(3), info(4), info(5) )
904  info(6) = domain%tile_id(1)
905  info(7) = domain%whalo
906  info(8) = domain%ehalo
907  info(9) = domain%shalo
908  info(10)= domain%nhalo
909  if(domain%symmetry) then
910  info(11) = 1
911  else
912  info(11) = 0
913  endif
914  call mpp_get_global_domain( domain, info(12), info(13), info(14), info(15) )
915  info(16) = tile_coarse
916  info(17) = domain%ntiles
917 !broadcast your info across current pelist and unpack if needed
918  listpos = 0
919  do n = 0,mpp_npes()-1
920  msg = info
921  call mpp_broadcast( msg, 17, pes(n) )
922 !no need to unpack message if native
923 !no need to unpack message from non-native PE
924  if( .NOT.native .AND. msg(1).NE.null_pe .AND. tile_coarse==msg(16) )then
925  domain%list(listpos)%pe = msg(1)
926  if(domain%x(1)%compute%begin == 0) then
927  domain%x(1)%domain_data %begin = msg(2) - msg(7)
928  domain%x(1)%domain_data %end = msg(3) + msg(8)
929  domain%y(1)%domain_data %begin = msg(4) - msg(9)
930  domain%y(1)%domain_data %end = msg(5) + msg(10)
931  domain%x(1)%global%begin = msg(12)
932  domain%x(1)%global%end = msg(13)
933  domain%y(1)%global%begin = msg(14)
934  domain%y(1)%global%end = msg(15)
935  domain%whalo = msg(7)
936  domain%ehalo = msg(8)
937  domain%shalo = msg(9)
938  domain%nhalo = msg(10)
939  domain%ntiles = msg(17)
940  if(msg(11) == 1) then
941  domain%symmetry = .true.
942  else
943  domain%symmetry = .false.
944  endif
945  endif
946  domain%list(listpos)%x%compute%begin = msg(2)
947  domain%list(listpos)%x%compute%end = msg(3)
948  domain%list(listpos)%y%compute%begin = msg(4)
949  domain%list(listpos)%y%compute%end = msg(5)
950  domain%list(listpos)%tile_id(1) = msg(6)
951  domain%list(listpos)%x%global %begin = msg(12)
952  domain%list(listpos)%x%global %end = msg(13)
953  domain%list(listpos)%y%global %begin = msg(14)
954  domain%list(listpos)%y%global %end = msg(15)
955  listpos = listpos + 1
956  if( debug )write( errunit,* )'PE ', mpp_pe(), 'received domain from PE ', msg(1), 'is,ie,js,je=', msg(2:5)
957  end if
958  end do
959 
960  end subroutine mpp_broadcast_domain_nest_coarse
961 !> @}
962 
963 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
964 ! !
965 ! MPP_UPDATE_DOMAINS: fill halos for 2D decomposition !
966 ! !
967 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
968 
969 #undef VECTOR_FIELD_
970 #define VECTOR_FIELD_
971 #undef MPP_TYPE_
972 #define MPP_TYPE_ real(r8_kind)
973 #undef MPP_UPDATE_DOMAINS_2D_
974 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r8_2D
975 #undef MPP_UPDATE_DOMAINS_3D_
976 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r8_3D
977 #undef MPP_UPDATE_DOMAINS_4D_
978 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r8_4D
979 #undef MPP_UPDATE_DOMAINS_5D_
980 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r8_5D
981 #ifdef VECTOR_FIELD_
982 #undef MPP_UPDATE_DOMAINS_2D_V_
983 #define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r8_2Dv
984 #undef MPP_UPDATE_DOMAINS_3D_V_
985 #define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r8_3Dv
986 #undef MPP_UPDATE_DOMAINS_4D_V_
987 #define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r8_4Dv
988 #undef MPP_UPDATE_DOMAINS_5D_V_
989 #define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r8_5Dv
990 #endif
991 #undef MPP_REDISTRIBUTE_REGISTER_
992 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_r8
993 #undef MPP_REDISTRIBUTE_2D_
994 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r8_2D
995 #undef MPP_REDISTRIBUTE_3D_
996 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r8_3D
997 #undef MPP_REDISTRIBUTE_4D_
998 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r8_4D
999 #undef MPP_REDISTRIBUTE_5D_
1000 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r8_5D
1001 #include <mpp_update_domains2D.fh>
1002 #undef VECTOR_FIELD_
1003 
1004 #ifdef OVERLOAD_C8
1005 #undef MPP_TYPE_
1006 #define MPP_TYPE_ complex(c8_kind)
1007 #undef MPP_UPDATE_DOMAINS_2D_
1008 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c8_2D
1009 #undef MPP_UPDATE_DOMAINS_3D_
1010 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c8_3D
1011 #undef MPP_UPDATE_DOMAINS_4D_
1012 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c8_4D
1013 #undef MPP_UPDATE_DOMAINS_5D_
1014 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c8_5D
1015 #undef MPP_REDISTRIBUTE_REGISTER_
1016 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_c8
1017 #undef MPP_REDISTRIBUTE_2D_
1018 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c8_2D
1019 #undef MPP_REDISTRIBUTE_3D_
1020 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c8_3D
1021 #undef MPP_REDISTRIBUTE_4D_
1022 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c8_4D
1023 #undef MPP_REDISTRIBUTE_5D_
1024 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c8_5D
1025 #include <mpp_update_domains2D.fh>
1026 #endif
1027 
1028 #undef MPP_TYPE_
1029 #define MPP_TYPE_ integer(i8_kind)
1030 #undef MPP_UPDATE_DOMAINS_2D_
1031 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i8_2D
1032 #undef MPP_UPDATE_DOMAINS_3D_
1033 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i8_3D
1034 #undef MPP_UPDATE_DOMAINS_4D_
1035 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i8_4D
1036 #undef MPP_UPDATE_DOMAINS_5D_
1037 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i8_5D
1038 #undef MPP_REDISTRIBUTE_REGISTER_
1039 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_i8
1040 #undef MPP_REDISTRIBUTE_2D_
1041 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i8_2D
1042 #undef MPP_REDISTRIBUTE_3D_
1043 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i8_3D
1044 #undef MPP_REDISTRIBUTE_4D_
1045 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i8_4D
1046 #undef MPP_REDISTRIBUTE_5D_
1047 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i8_5D
1048 #include <mpp_update_domains2D.fh>
1049 
1050 #undef VECTOR_FIELD_
1051 #define VECTOR_FIELD_
1052 #undef MPP_TYPE_
1053 #define MPP_TYPE_ real(r4_kind)
1054 #undef MPP_UPDATE_DOMAINS_2D_
1055 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_r4_2D
1056 #undef MPP_UPDATE_DOMAINS_3D_
1057 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_r4_3D
1058 #undef MPP_UPDATE_DOMAINS_4D_
1059 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_r4_4D
1060 #undef MPP_UPDATE_DOMAINS_5D_
1061 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_r4_5D
1062 #ifdef VECTOR_FIELD_
1063 #undef MPP_UPDATE_DOMAINS_2D_V_
1064 #define MPP_UPDATE_DOMAINS_2D_V_ mpp_update_domain2D_r4_2Dv
1065 #undef MPP_UPDATE_DOMAINS_3D_V_
1066 #define MPP_UPDATE_DOMAINS_3D_V_ mpp_update_domain2D_r4_3Dv
1067 #undef MPP_UPDATE_DOMAINS_4D_V_
1068 #define MPP_UPDATE_DOMAINS_4D_V_ mpp_update_domain2D_r4_4Dv
1069 #undef MPP_UPDATE_DOMAINS_5D_V_
1070 #define MPP_UPDATE_DOMAINS_5D_V_ mpp_update_domain2D_r4_5Dv
1071 #undef MPP_REDISTRIBUTE_REGISTER_
1072 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_r4
1073 #undef MPP_REDISTRIBUTE_2D_
1074 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_r4_2D
1075 #undef MPP_REDISTRIBUTE_3D_
1076 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_r4_3D
1077 #undef MPP_REDISTRIBUTE_4D_
1078 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_r4_4D
1079 #undef MPP_REDISTRIBUTE_5D_
1080 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_r4_5D
1081 #include <mpp_update_domains2D.fh>
1082 #undef VECTOR_FIELD_
1083 #endif
1084 
1085 #ifdef OVERLOAD_C4
1086 #undef MPP_TYPE_
1087 #define MPP_TYPE_ complex(c4_kind)
1088 #undef MPP_UPDATE_DOMAINS_2D_
1089 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_c4_2D
1090 #undef MPP_UPDATE_DOMAINS_3D_
1091 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_c4_3D
1092 #undef MPP_UPDATE_DOMAINS_4D_
1093 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_c4_4D
1094 #undef MPP_UPDATE_DOMAINS_5D_
1095 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_c4_5D
1096 #undef MPP_REDISTRIBUTE_REGISTER_
1097 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_c4
1098 #undef MPP_REDISTRIBUTE_2D_
1099 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_c4_2D
1100 #undef MPP_REDISTRIBUTE_3D_
1101 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_c4_3D
1102 #undef MPP_REDISTRIBUTE_4D_
1103 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_c4_4D
1104 #undef MPP_REDISTRIBUTE_5D_
1105 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_c4_5D
1106 #include <mpp_update_domains2D.fh>
1107 #endif
1108 
1109 #undef MPP_TYPE_
1110 #define MPP_TYPE_ integer(i4_kind)
1111 #undef MPP_UPDATE_DOMAINS_2D_
1112 #define MPP_UPDATE_DOMAINS_2D_ mpp_update_domain2D_i4_2D
1113 #undef MPP_UPDATE_DOMAINS_3D_
1114 #define MPP_UPDATE_DOMAINS_3D_ mpp_update_domain2D_i4_3D
1115 #undef MPP_UPDATE_DOMAINS_4D_
1116 #define MPP_UPDATE_DOMAINS_4D_ mpp_update_domain2D_i4_4D
1117 #undef MPP_UPDATE_DOMAINS_5D_
1118 #define MPP_UPDATE_DOMAINS_5D_ mpp_update_domain2D_i4_5D
1119 #undef MPP_REDISTRIBUTE_REGISTER_
1120 #define MPP_REDISTRIBUTE_REGISTER_ mpp_redistribute_register_i4
1121 #undef MPP_REDISTRIBUTE_2D_
1122 #define MPP_REDISTRIBUTE_2D_ mpp_redistribute_i4_2D
1123 #undef MPP_REDISTRIBUTE_3D_
1124 #define MPP_REDISTRIBUTE_3D_ mpp_redistribute_i4_3D
1125 #undef MPP_REDISTRIBUTE_4D_
1126 #define MPP_REDISTRIBUTE_4D_ mpp_redistribute_i4_4D
1127 #undef MPP_REDISTRIBUTE_5D_
1128 #define MPP_REDISTRIBUTE_5D_ mpp_redistribute_i4_5D
1129 #include <mpp_update_domains2D.fh>
1130 
1131 
1132 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1133 ! !
1134 ! MPP_START_UPDATE_DOMAINS and MPP_COMPLETE_UPDATE_DOMAINS: !
1135 ! fill halos for 2D decomposition --- non-blocking !
1136 ! !
1137 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1138 
1139 #undef VECTOR_FIELD_
1140 #define VECTOR_FIELD_
1141 #undef MPP_TYPE_
1142 #define MPP_TYPE_ real(r8_kind)
1143 #undef MPP_START_UPDATE_DOMAINS_2D_
1144 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_r8_2D
1145 #undef MPP_START_UPDATE_DOMAINS_3D_
1146 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_r8_3D
1147 #undef MPP_START_UPDATE_DOMAINS_4D_
1148 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_r8_4D
1149 #undef MPP_START_UPDATE_DOMAINS_5D_
1150 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_r8_5D
1151 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1152 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_r8_2D
1153 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1154 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_r8_3D
1155 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1156 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_r8_4D
1157 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1158 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_r8_5D
1159 #ifdef VECTOR_FIELD_
1160 #undef MPP_START_UPDATE_DOMAINS_2D_V_
1161 #define MPP_START_UPDATE_DOMAINS_2D_V_ mpp_start_update_domain2D_r8_2Dv
1162 #undef MPP_START_UPDATE_DOMAINS_3D_V_
1163 #define MPP_START_UPDATE_DOMAINS_3D_V_ mpp_start_update_domain2D_r8_3Dv
1164 #undef MPP_START_UPDATE_DOMAINS_4D_V_
1165 #define MPP_START_UPDATE_DOMAINS_4D_V_ mpp_start_update_domain2D_r8_4Dv
1166 #undef MPP_START_UPDATE_DOMAINS_5D_V_
1167 #define MPP_START_UPDATE_DOMAINS_5D_V_ mpp_start_update_domain2D_r8_5Dv
1168 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_V_
1169 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_V_ mpp_complete_update_domain2D_r8_2Dv
1170 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_V_
1171 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_V_ mpp_complete_update_domain2D_r8_3Dv
1172 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_V_
1173 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_V_ mpp_complete_update_domain2D_r8_4Dv
1174 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_V_
1175 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_V_ mpp_complete_update_domain2D_r8_5Dv
1176 #endif
1177 #include <mpp_update_domains2D_nonblock.fh>
1178 
1179 #ifdef OVERLOAD_C8
1180 #undef VECTOR_FIELD_
1181 #undef MPP_TYPE_
1182 #define MPP_TYPE_ complex(c8_kind)
1183 #undef MPP_START_UPDATE_DOMAINS_2D_
1184 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_c8_2D
1185 #undef MPP_START_UPDATE_DOMAINS_3D_
1186 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_c8_3D
1187 #undef MPP_START_UPDATE_DOMAINS_4D_
1188 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_c8_4D
1189 #undef MPP_START_UPDATE_DOMAINS_5D_
1190 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_c8_5D
1191 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1192 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_c8_2D
1193 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1194 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_c8_3D
1195 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1196 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_c8_4D
1197 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1198 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_c8_5D
1199 #include <mpp_update_domains2D_nonblock.fh>
1200 #endif
1201 
1202 #undef VECTOR_FIELD_
1203 #undef MPP_TYPE_
1204 #define MPP_TYPE_ integer(i8_kind)
1205 #undef MPP_START_UPDATE_DOMAINS_2D_
1206 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_i8_2D
1207 #undef MPP_START_UPDATE_DOMAINS_3D_
1208 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_i8_3D
1209 #undef MPP_START_UPDATE_DOMAINS_4D_
1210 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_i8_4D
1211 #undef MPP_START_UPDATE_DOMAINS_5D_
1212 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_i8_5D
1213 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1214 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_i8_2D
1215 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1216 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_i8_3D
1217 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1218 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_i8_4D
1219 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1220 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_i8_5D
1221 #include <mpp_update_domains2D_nonblock.fh>
1222 
1223 #undef VECTOR_FIELD_
1224 #define VECTOR_FIELD_
1225 #undef MPP_TYPE_
1226 #define MPP_TYPE_ real(r4_kind)
1227 #undef MPP_START_UPDATE_DOMAINS_2D_
1228 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_r4_2D
1229 #undef MPP_START_UPDATE_DOMAINS_3D_
1230 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_r4_3D
1231 #undef MPP_START_UPDATE_DOMAINS_4D_
1232 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_r4_4D
1233 #undef MPP_START_UPDATE_DOMAINS_5D_
1234 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_r4_5D
1235 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1236 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_r4_2D
1237 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1238 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_r4_3D
1239 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1240 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_r4_4D
1241 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1242 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_r4_5D
1243 #ifdef VECTOR_FIELD_
1244 #undef MPP_START_UPDATE_DOMAINS_2D_V_
1245 #define MPP_START_UPDATE_DOMAINS_2D_V_ mpp_start_update_domain2D_r4_2Dv
1246 #undef MPP_START_UPDATE_DOMAINS_3D_V_
1247 #define MPP_START_UPDATE_DOMAINS_3D_V_ mpp_start_update_domain2D_r4_3Dv
1248 #undef MPP_START_UPDATE_DOMAINS_4D_V_
1249 #define MPP_START_UPDATE_DOMAINS_4D_V_ mpp_start_update_domain2D_r4_4Dv
1250 #undef MPP_START_UPDATE_DOMAINS_5D_V_
1251 #define MPP_START_UPDATE_DOMAINS_5D_V_ mpp_start_update_domain2D_r4_5Dv
1252 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_V_
1253 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_V_ mpp_complete_update_domain2D_r4_2Dv
1254 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_V_
1255 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_V_ mpp_complete_update_domain2D_r4_3Dv
1256 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_V_
1257 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_V_ mpp_complete_update_domain2D_r4_4Dv
1258 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_V_
1259 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_V_ mpp_complete_update_domain2D_r4_5Dv
1260 #endif
1261 #include <mpp_update_domains2D_nonblock.fh>
1262 
1263 #ifdef OVERLOAD_C4
1264 #undef VECTOR_FIELD_
1265 #undef MPP_TYPE_
1266 #define MPP_TYPE_ complex(c4_kind)
1267 #undef MPP_START_UPDATE_DOMAINS_2D_
1268 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_c4_2D
1269 #undef MPP_START_UPDATE_DOMAINS_3D_
1270 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_c4_3D
1271 #undef MPP_START_UPDATE_DOMAINS_4D_
1272 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_c4_4D
1273 #undef MPP_START_UPDATE_DOMAINS_5D_
1274 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_c4_5D
1275 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1276 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_c4_2D
1277 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1278 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_c4_3D
1279 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1280 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_c4_4D
1281 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1282 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_c4_5D
1283 #include <mpp_update_domains2D_nonblock.fh>
1284 #endif
1285 
1286 #undef VECTOR_FIELD_
1287 #undef MPP_TYPE_
1288 #define MPP_TYPE_ integer(i4_kind)
1289 #undef MPP_START_UPDATE_DOMAINS_2D_
1290 #define MPP_START_UPDATE_DOMAINS_2D_ mpp_start_update_domain2D_i4_2D
1291 #undef MPP_START_UPDATE_DOMAINS_3D_
1292 #define MPP_START_UPDATE_DOMAINS_3D_ mpp_start_update_domain2D_i4_3D
1293 #undef MPP_START_UPDATE_DOMAINS_4D_
1294 #define MPP_START_UPDATE_DOMAINS_4D_ mpp_start_update_domain2D_i4_4D
1295 #undef MPP_START_UPDATE_DOMAINS_5D_
1296 #define MPP_START_UPDATE_DOMAINS_5D_ mpp_start_update_domain2D_i4_5D
1297 #undef MPP_COMPLETE_UPDATE_DOMAINS_2D_
1298 #define MPP_COMPLETE_UPDATE_DOMAINS_2D_ mpp_complete_update_domain2D_i4_2D
1299 #undef MPP_COMPLETE_UPDATE_DOMAINS_3D_
1300 #define MPP_COMPLETE_UPDATE_DOMAINS_3D_ mpp_complete_update_domain2D_i4_3D
1301 #undef MPP_COMPLETE_UPDATE_DOMAINS_4D_
1302 #define MPP_COMPLETE_UPDATE_DOMAINS_4D_ mpp_complete_update_domain2D_i4_4D
1303 #undef MPP_COMPLETE_UPDATE_DOMAINS_5D_
1304 #define MPP_COMPLETE_UPDATE_DOMAINS_5D_ mpp_complete_update_domain2D_i4_5D
1305 #include <mpp_update_domains2D_nonblock.fh>
1306 
1307 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1308 ! !
1309 ! mpp_start_do_update and mpp_complete_do_update !
1310 ! private routine. To be called in mpp_start_update_domains !
1311 ! and mpp_complete_update_domains !
1312 ! !
1313 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1314 #undef MPP_TYPE_
1315 #define MPP_TYPE_ real(r8_kind)
1316 #undef MPI_TYPE_
1317 #define MPI_TYPE_ MPI_REAL8
1318 #undef MPP_START_DO_UPDATE_3D_
1319 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_r8_3D
1320 #undef MPP_COMPLETE_DO_UPDATE_3D_
1321 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_r8_3D
1322 #undef MPP_START_DO_UPDATE_3D_V_
1323 #define MPP_START_DO_UPDATE_3D_V_ mpp_start_do_update_r8_3Dv
1324 #undef MPP_COMPLETE_DO_UPDATE_3D_V_
1325 #define MPP_COMPLETE_DO_UPDATE_3D_V_ mpp_complete_do_update_r8_3Dv
1326 #include <mpp_do_update_nonblock.fh>
1327 #include <mpp_do_updateV_nonblock.fh>
1328 
1329 #ifdef OVERLOAD_C8
1330 #undef MPP_TYPE_
1331 #define MPP_TYPE_ complex(c8_kind)
1332 #undef MPI_TYPE_
1333 #define MPI_TYPE_ MPI_DOUBLE_COMPLEX
1334 #undef MPP_START_DO_UPDATE_3D_
1335 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_c8_3D
1336 #undef MPP_COMPLETE_DO_UPDATE_3D_
1337 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_c8_3D
1338 #include <mpp_do_update_nonblock.fh>
1339 #endif
1340 
1341 #undef MPP_TYPE_
1342 #define MPP_TYPE_ integer(i8_kind)
1343 #undef MPI_TYPE_
1344 #define MPI_TYPE_ MPI_INTEGER8
1345 #undef MPP_START_DO_UPDATE_3D_
1346 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_i8_3D
1347 #undef MPP_COMPLETE_DO_UPDATE_3D_
1348 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_i8_3D
1349 #include <mpp_do_update_nonblock.fh>
1350 
1351 #undef MPP_TYPE_
1352 #define MPP_TYPE_ real(r4_kind)
1353 #undef MPI_TYPE_
1354 #define MPI_TYPE_ MPI_REAL4
1355 #undef MPP_START_DO_UPDATE_3D_
1356 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_r4_3D
1357 #undef MPP_COMPLETE_DO_UPDATE_3D_
1358 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_r4_3D
1359 #undef MPP_START_DO_UPDATE_3D_V_
1360 #define MPP_START_DO_UPDATE_3D_V_ mpp_start_do_update_r4_3Dv
1361 #undef MPP_COMPLETE_DO_UPDATE_3D_V_
1362 #define MPP_COMPLETE_DO_UPDATE_3D_V_ mpp_complete_do_update_r4_3Dv
1363 #include <mpp_do_update_nonblock.fh>
1364 #include <mpp_do_updateV_nonblock.fh>
1365 
1366 #ifdef OVERLOAD_C4
1367 #undef MPP_TYPE_
1368 #define MPP_TYPE_ complex(c4_kind)
1369 #undef MPI_TYPE_
1370 #define MPI_TYPE_ MPI_COMPLEX
1371 #undef MPP_START_DO_UPDATE_3D_
1372 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_c4_3D
1373 #undef MPP_COMPLETE_DO_UPDATE_3D_
1374 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_c4_3D
1375 #include <mpp_do_update_nonblock.fh>
1376 #endif
1377 
1378 #undef MPP_TYPE_
1379 #define MPP_TYPE_ integer(i4_kind)
1380 #undef MPI_TYPE_
1381 #define MPI_TYPE_ MPI_INTEGER4
1382 #undef MPP_START_DO_UPDATE_3D_
1383 #define MPP_START_DO_UPDATE_3D_ mpp_start_do_update_i4_3D
1384 #undef MPP_COMPLETE_DO_UPDATE_3D_
1385 #define MPP_COMPLETE_DO_UPDATE_3D_ mpp_complete_do_update_i4_3D
1386 #include <mpp_do_update_nonblock.fh>
1387 
1388 !*******************************************************
1389 #undef VECTOR_FIELD_
1390 #define VECTOR_FIELD_
1391 #undef MPP_TYPE_
1392 #define MPP_TYPE_ real(r8_kind)
1393 #undef MPP_DO_UPDATE_3D_
1394 #define MPP_DO_UPDATE_3D_ mpp_do_update_r8_3d
1395 #ifdef VECTOR_FIELD_
1396 #undef MPP_DO_UPDATE_3D_V_
1397 #define MPP_DO_UPDATE_3D_V_ mpp_do_update_r8_3dv
1398 #endif
1399 #include <mpp_do_update.fh>
1400 #include <mpp_do_updateV.fh>
1401 
1402 #ifdef OVERLOAD_C8
1403 #undef VECTOR_FIELD_
1404 #undef MPP_TYPE_
1405 #define MPP_TYPE_ complex(c8_kind)
1406 #undef MPP_DO_UPDATE_3D_
1407 #define MPP_DO_UPDATE_3D_ mpp_do_update_c8_3d
1408 #include <mpp_do_update.fh>
1409 #define VECTOR_FIELD_
1410 #endif
1411 
1412 #undef MPP_TYPE_
1413 #define MPP_TYPE_ integer(i8_kind)
1414 #undef MPP_DO_UPDATE_3D_
1415 #define MPP_DO_UPDATE_3D_ mpp_do_update_i8_3d
1416 #include <mpp_do_update.fh>
1417 
1418 #undef VECTOR_FIELD_
1419 #define VECTOR_FIELD_
1420 #undef MPP_TYPE_
1421 #define MPP_TYPE_ real(r4_kind)
1422 #undef MPP_DO_UPDATE_3D_
1423 #define MPP_DO_UPDATE_3D_ mpp_do_update_r4_3d
1424 #ifdef VECTOR_FIELD_
1425 #undef MPP_DO_UPDATE_3D_V_
1426 #define MPP_DO_UPDATE_3D_V_ mpp_do_update_r4_3dv
1427 #endif
1428 #include <mpp_do_update.fh>
1429 #include <mpp_do_updateV.fh>
1430 
1431 #ifdef OVERLOAD_C4
1432 #undef VECTOR_FIELD_
1433 #undef MPP_TYPE_
1434 #define MPP_TYPE_ complex(c4_kind)
1435 #undef MPP_DO_UPDATE_3D_
1436 #define MPP_DO_UPDATE_3D_ mpp_do_update_c4_3d
1437 #include <mpp_do_update.fh>
1438 #define VECTOR_FIELD_
1439 #endif
1440 
1441 #undef MPP_TYPE_
1442 #define MPP_TYPE_ integer(i4_kind)
1443 #undef MPP_DO_UPDATE_3D_
1444 #define MPP_DO_UPDATE_3D_ mpp_do_update_i4_3d
1445 #include <mpp_do_update.fh>
1446 
1447 
1448 #undef MPP_TYPE_
1449 #define MPP_TYPE_ real(r8_kind)
1450 #undef MPP_DO_CHECK_3D_
1451 #define MPP_DO_CHECK_3D_ mpp_do_check_r8_3d
1452 #ifdef VECTOR_FIELD_
1453 #undef MPP_DO_CHECK_3D_V_
1454 #define MPP_DO_CHECK_3D_V_ mpp_do_check_r8_3dv
1455 #endif
1456 #include <mpp_do_check.fh>
1457 #include <mpp_do_checkV.fh>
1458 
1459 #ifdef OVERLOAD_C8
1460 #undef VECTOR_FIELD_
1461 #undef MPP_TYPE_
1462 #define MPP_TYPE_ complex(c8_kind)
1463 #undef MPP_DO_CHECK_3D_
1464 #define MPP_DO_CHECK_3D_ mpp_do_check_c8_3d
1465 #include <mpp_do_check.fh>
1466 #define VECTOR_FIELD_
1467 #endif
1468 
1469 #undef MPP_TYPE_
1470 #define MPP_TYPE_ integer(i8_kind)
1471 #undef MPP_DO_CHECK_3D_
1472 #define MPP_DO_CHECK_3D_ mpp_do_check_i8_3d
1473 #include <mpp_do_check.fh>
1474 
1475 #undef VECTOR_FIELD_
1476 #define VECTOR_FIELD_
1477 #undef MPP_TYPE_
1478 #define MPP_TYPE_ real(r4_kind)
1479 #undef MPP_DO_CHECK_3D_
1480 #define MPP_DO_CHECK_3D_ mpp_do_check_r4_3d
1481 #ifdef VECTOR_FIELD_
1482 #undef MPP_DO_CHECK_3D_V_
1483 #define MPP_DO_CHECK_3D_V_ mpp_do_check_r4_3dv
1484 #endif
1485 #include <mpp_do_check.fh>
1486 #include <mpp_do_checkV.fh>
1487 
1488 #ifdef OVERLOAD_C4
1489 #undef VECTOR_FIELD_
1490 #undef MPP_TYPE_
1491 #define MPP_TYPE_ complex(c4_kind)
1492 #undef MPP_DO_CHECK_3D_
1493 #define MPP_DO_CHECK_3D_ mpp_do_check_c4_3d
1494 #include <mpp_do_check.fh>
1495 #endif
1496 
1497 #undef MPP_TYPE_
1498 #define MPP_TYPE_ integer(i4_kind)
1499 #undef MPP_DO_CHECK_3D_
1500 #define MPP_DO_CHECK_3D_ mpp_do_check_i4_3d
1501 #include <mpp_do_check.fh>
1502 
1503 #undef VECTOR_FIELD_
1504 #define VECTOR_FIELD_
1505 #undef MPP_TYPE_
1506 #define MPP_TYPE_ real(r8_kind)
1507 #undef MPP_UPDATE_NEST_FINE_2D_
1508 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_r8_2D
1509 #undef MPP_UPDATE_NEST_FINE_3D_
1510 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_r8_3D
1511 #undef MPP_UPDATE_NEST_FINE_4D_
1512 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_r8_4D
1513 #undef MPP_UPDATE_NEST_FINE_2D_V_
1514 #define MPP_UPDATE_NEST_FINE_2D_V_ mpp_update_nest_fine_r8_2Dv
1515 #undef MPP_UPDATE_NEST_FINE_3D_V_
1516 #define MPP_UPDATE_NEST_FINE_3D_V_ mpp_update_nest_fine_r8_3Dv
1517 #undef MPP_UPDATE_NEST_FINE_4D_V_
1518 #define MPP_UPDATE_NEST_FINE_4D_V_ mpp_update_nest_fine_r8_4Dv
1519 #undef MPP_UPDATE_NEST_COARSE_2D_
1520 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_r8_2D
1521 #undef MPP_UPDATE_NEST_COARSE_3D_
1522 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_r8_3D
1523 #undef MPP_UPDATE_NEST_COARSE_4D_
1524 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_r8_4D
1525 #undef MPP_UPDATE_NEST_COARSE_2D_V_
1526 #define MPP_UPDATE_NEST_COARSE_2D_V_ mpp_update_nest_coarse_r8_2Dv
1527 #undef MPP_UPDATE_NEST_COARSE_3D_V_
1528 #define MPP_UPDATE_NEST_COARSE_3D_V_ mpp_update_nest_coarse_r8_3Dv
1529 #undef MPP_UPDATE_NEST_COARSE_4D_V_
1530 #define MPP_UPDATE_NEST_COARSE_4D_V_ mpp_update_nest_coarse_r8_4Dv
1531 #include <mpp_update_nest_domains.fh>
1532 
1533 #ifdef OVERLOAD_C8
1534 #undef VECTOR_FIELD_
1535 #undef MPP_TYPE_
1536 #define MPP_TYPE_ complex(c8_kind)
1537 #undef MPP_UPDATE_NEST_FINE_2D_
1538 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_c8_2D
1539 #undef MPP_UPDATE_NEST_FINE_3D_
1540 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_c8_3D
1541 #undef MPP_UPDATE_NEST_FINE_4D_
1542 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_c8_4D
1543 #undef MPP_UPDATE_NEST_COARSE_2D_
1544 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_c8_2D
1545 #undef MPP_UPDATE_NEST_COARSE_3D_
1546 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_c8_3D
1547 #undef MPP_UPDATE_NEST_COARSE_4D_
1548 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_c8_4D
1549 #include <mpp_update_nest_domains.fh>
1550 #endif
1551 
1552 #undef VECTOR_FIELD_
1553 #undef MPP_TYPE_
1554 #define MPP_TYPE_ integer(i8_kind)
1555 #undef MPP_UPDATE_NEST_FINE_2D_
1556 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_i8_2D
1557 #undef MPP_UPDATE_NEST_FINE_3D_
1558 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_i8_3D
1559 #undef MPP_UPDATE_NEST_FINE_4D_
1560 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_i8_4D
1561 #undef MPP_UPDATE_NEST_COARSE_2D_
1562 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_i8_2D
1563 #undef MPP_UPDATE_NEST_COARSE_3D_
1564 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_i8_3D
1565 #undef MPP_UPDATE_NEST_COARSE_4D_
1566 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_i8_4D
1567 #include <mpp_update_nest_domains.fh>
1568 
1569 #undef VECTOR_FIELD_
1570 #define VECTOR_FIELD_
1571 #undef MPP_TYPE_
1572 #define MPP_TYPE_ real(r4_kind)
1573 #undef MPP_UPDATE_NEST_FINE_2D_
1574 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_r4_2D
1575 #undef MPP_UPDATE_NEST_FINE_3D_
1576 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_r4_3D
1577 #undef MPP_UPDATE_NEST_FINE_4D_
1578 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_r4_4D
1579 #undef MPP_UPDATE_NEST_FINE_2D_V_
1580 #define MPP_UPDATE_NEST_FINE_2D_V_ mpp_update_nest_fine_r4_2Dv
1581 #undef MPP_UPDATE_NEST_FINE_3D_V_
1582 #define MPP_UPDATE_NEST_FINE_3D_V_ mpp_update_nest_fine_r4_3Dv
1583 #undef MPP_UPDATE_NEST_FINE_4D_V_
1584 #define MPP_UPDATE_NEST_FINE_4D_V_ mpp_update_nest_fine_r4_4Dv
1585 #undef MPP_UPDATE_NEST_COARSE_2D_
1586 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_r4_2D
1587 #undef MPP_UPDATE_NEST_COARSE_3D_
1588 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_r4_3D
1589 #undef MPP_UPDATE_NEST_COARSE_4D_
1590 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_r4_4D
1591 #undef MPP_UPDATE_NEST_COARSE_2D_V_
1592 #define MPP_UPDATE_NEST_COARSE_2D_V_ mpp_update_nest_coarse_r4_2Dv
1593 #undef MPP_UPDATE_NEST_COARSE_3D_V_
1594 #define MPP_UPDATE_NEST_COARSE_3D_V_ mpp_update_nest_coarse_r4_3Dv
1595 #undef MPP_UPDATE_NEST_COARSE_4D_V_
1596 #define MPP_UPDATE_NEST_COARSE_4D_V_ mpp_update_nest_coarse_r4_4Dv
1597 #include <mpp_update_nest_domains.fh>
1598 
1599 #ifdef OVERLOAD_C4
1600 #undef VECTOR_FIELD_
1601 #undef MPP_TYPE_
1602 #define MPP_TYPE_ complex(c4_kind)
1603 #undef MPP_UPDATE_NEST_FINE_2D_
1604 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_c4_2D
1605 #undef MPP_UPDATE_NEST_FINE_3D_
1606 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_c4_3D
1607 #undef MPP_UPDATE_NEST_FINE_4D_
1608 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_c4_4D
1609 #undef MPP_UPDATE_NEST_COARSE_2D_
1610 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_c4_2D
1611 #undef MPP_UPDATE_NEST_COARSE_3D_
1612 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_c4_3D
1613 #undef MPP_UPDATE_NEST_COARSE_4D_
1614 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_c4_4D
1615 #include <mpp_update_nest_domains.fh>
1616 #endif
1617 
1618 #undef VECTOR_FIELD_
1619 #undef MPP_TYPE_
1620 #define MPP_TYPE_ integer(i4_kind)
1621 #undef MPP_UPDATE_NEST_FINE_2D_
1622 #define MPP_UPDATE_NEST_FINE_2D_ mpp_update_nest_fine_i4_2D
1623 #undef MPP_UPDATE_NEST_FINE_3D_
1624 #define MPP_UPDATE_NEST_FINE_3D_ mpp_update_nest_fine_i4_3D
1625 #undef MPP_UPDATE_NEST_FINE_4D_
1626 #define MPP_UPDATE_NEST_FINE_4D_ mpp_update_nest_fine_i4_4D
1627 #undef MPP_UPDATE_NEST_COARSE_2D_
1628 #define MPP_UPDATE_NEST_COARSE_2D_ mpp_update_nest_coarse_i4_2D
1629 #undef MPP_UPDATE_NEST_COARSE_3D_
1630 #define MPP_UPDATE_NEST_COARSE_3D_ mpp_update_nest_coarse_i4_3D
1631 #undef MPP_UPDATE_NEST_COARSE_4D_
1632 #define MPP_UPDATE_NEST_COARSE_4D_ mpp_update_nest_coarse_i4_4D
1633 #include <mpp_update_nest_domains.fh>
1634 
1635 #undef VECTOR_FIELD_
1636 #define VECTOR_FIELD_
1637 #undef MPP_TYPE_
1638 #define MPP_TYPE_ real(r8_kind)
1639 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1640 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_r8_3D
1641 #undef MPP_DO_UPDATE_NEST_FINE_3D_V_
1642 #define MPP_DO_UPDATE_NEST_FINE_3D_V_ mpp_do_update_nest_fine_r8_3Dv
1643 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1644 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_r8_3D
1645 #undef MPP_DO_UPDATE_NEST_COARSE_3D_V_
1646 #define MPP_DO_UPDATE_NEST_COARSE_3D_V_ mpp_do_update_nest_coarse_r8_3Dv
1647 #include <mpp_do_update_nest.fh>
1648 
1649 #ifdef OVERLOAD_C8
1650 #undef VECTOR_FIELD_
1651 #undef MPP_TYPE_
1652 #define MPP_TYPE_ complex(c8_kind)
1653 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1654 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_c8_3D
1655 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1656 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_c8_3D
1657 #include <mpp_do_update_nest.fh>
1658 #endif
1659 
1660 #undef VECTOR_FIELD_
1661 #undef MPP_TYPE_
1662 #define MPP_TYPE_ integer(i8_kind)
1663 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1664 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_i8_3D
1665 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1666 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_i8_3D
1667 #include <mpp_do_update_nest.fh>
1668 
1669 #undef VECTOR_FIELD_
1670 #define VECTOR_FIELD_
1671 #undef MPP_TYPE_
1672 #define MPP_TYPE_ real(r4_kind)
1673 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1674 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_r4_3D
1675 #undef MPP_DO_UPDATE_NEST_FINE_3D_V_
1676 #define MPP_DO_UPDATE_NEST_FINE_3D_V_ mpp_do_update_nest_fine_r4_3Dv
1677 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1678 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_r4_3D
1679 #undef MPP_DO_UPDATE_NEST_COARSE_3D_V_
1680 #define MPP_DO_UPDATE_NEST_COARSE_3D_V_ mpp_do_update_nest_coarse_r4_3Dv
1681 #include <mpp_do_update_nest.fh>
1682 
1683 #ifdef OVERLOAD_C4
1684 #undef VECTOR_FIELD_
1685 #undef MPP_TYPE_
1686 #define MPP_TYPE_ complex(c4_kind)
1687 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1688 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_c4_3D
1689 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1690 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_c4_3D
1691 #include <mpp_do_update_nest.fh>
1692 #endif
1693 
1694 #undef VECTOR_FIELD_
1695 #undef MPP_TYPE_
1696 #define MPP_TYPE_ integer(i4_kind)
1697 #undef MPP_DO_UPDATE_NEST_FINE_3D_
1698 #define MPP_DO_UPDATE_NEST_FINE_3D_ mpp_do_update_nest_fine_i4_3D
1699 #undef MPP_DO_UPDATE_NEST_COARSE_3D_
1700 #define MPP_DO_UPDATE_NEST_COARSE_3D_ mpp_do_update_nest_coarse_i4_3D
1701 #include <mpp_do_update_nest.fh>
1702 
1703 !bnc
1704 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1705 ! !
1706 ! MPP_UPDATE_DOMAINS_AD: adjoint fill halos for 2D decomposition !
1707 ! !
1708 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1709 #undef VECTOR_FIELD_
1710 #define VECTOR_FIELD_
1711 #undef MPP_TYPE_
1712 #define MPP_TYPE_ real(r8_kind)
1713 #undef MPP_UPDATE_DOMAINS_AD_2D_
1714 #define MPP_UPDATE_DOMAINS_AD_2D_ mpp_update_domains_ad_2D_r8_2D
1715 #undef MPP_UPDATE_DOMAINS_AD_3D_
1716 #define MPP_UPDATE_DOMAINS_AD_3D_ mpp_update_domains_ad_2D_r8_3D
1717 #undef MPP_UPDATE_DOMAINS_AD_4D_
1718 #define MPP_UPDATE_DOMAINS_AD_4D_ mpp_update_domains_ad_2D_r8_4D
1719 #undef MPP_UPDATE_DOMAINS_AD_5D_
1720 #define MPP_UPDATE_DOMAINS_AD_5D_ mpp_update_domains_ad_2D_r8_5D
1721 #ifdef VECTOR_FIELD_
1722 #undef MPP_UPDATE_DOMAINS_AD_2D_V_
1723 #define MPP_UPDATE_DOMAINS_AD_2D_V_ mpp_update_domains_ad_2D_r8_2Dv
1724 #undef MPP_UPDATE_DOMAINS_AD_3D_V_
1725 #define MPP_UPDATE_DOMAINS_AD_3D_V_ mpp_update_domains_ad_2D_r8_3Dv
1726 #undef MPP_UPDATE_DOMAINS_AD_4D_V_
1727 #define MPP_UPDATE_DOMAINS_AD_4D_V_ mpp_update_domains_ad_2D_r8_4Dv
1728 #undef MPP_UPDATE_DOMAINS_AD_5D_V_
1729 #define MPP_UPDATE_DOMAINS_AD_5D_V_ mpp_update_domains_ad_2D_r8_5Dv
1730 #endif
1731 #include <mpp_update_domains2D_ad.fh>
1732 
1733 #undef VECTOR_FIELD_
1734 #define VECTOR_FIELD_
1735 #undef MPP_TYPE_
1736 #define MPP_TYPE_ real(r4_kind)
1737 #undef MPP_UPDATE_DOMAINS_AD_2D_
1738 #define MPP_UPDATE_DOMAINS_AD_2D_ mpp_update_domains_ad_2D_r4_2D
1739 #undef MPP_UPDATE_DOMAINS_AD_3D_
1740 #define MPP_UPDATE_DOMAINS_AD_3D_ mpp_update_domains_ad_2D_r4_3D
1741 #undef MPP_UPDATE_DOMAINS_AD_4D_
1742 #define MPP_UPDATE_DOMAINS_AD_4D_ mpp_update_domains_ad_2D_r4_4D
1743 #undef MPP_UPDATE_DOMAINS_AD_5D_
1744 #define MPP_UPDATE_DOMAINS_AD_5D_ mpp_update_domains_ad_2D_r4_5D
1745 #ifdef VECTOR_FIELD_
1746 #undef MPP_UPDATE_DOMAINS_AD_2D_V_
1747 #define MPP_UPDATE_DOMAINS_AD_2D_V_ mpp_update_domains_ad_2D_r4_2Dv
1748 #undef MPP_UPDATE_DOMAINS_AD_3D_V_
1749 #define MPP_UPDATE_DOMAINS_AD_3D_V_ mpp_update_domains_ad_2D_r4_3Dv
1750 #undef MPP_UPDATE_DOMAINS_AD_4D_V_
1751 #define MPP_UPDATE_DOMAINS_AD_4D_V_ mpp_update_domains_ad_2D_r4_4Dv
1752 #undef MPP_UPDATE_DOMAINS_AD_5D_V_
1753 #define MPP_UPDATE_DOMAINS_AD_5D_V_ mpp_update_domains_ad_2D_r4_5Dv
1754 #endif
1755 #include <mpp_update_domains2D_ad.fh>
1756 
1757 !*******************************************************
1758 #undef VECTOR_FIELD_
1759 #define VECTOR_FIELD_
1760 #undef MPP_TYPE_
1761 #define MPP_TYPE_ real(r8_kind)
1762 #undef MPP_DO_UPDATE_AD_3D_
1763 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r8_3d
1764 #ifdef VECTOR_FIELD_
1765 #undef MPP_DO_UPDATE_AD_3D_V_
1766 #define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r8_3dv
1767 #endif
1768 #include <mpp_do_update_ad.fh>
1769 #include <mpp_do_updateV_ad.fh>
1770 
1771 #ifdef OVERLOAD_C8
1772 #undef VECTOR_FIELD_
1773 #undef MPP_TYPE_
1774 #define MPP_TYPE_ complex(c8_kind)
1775 #undef MPP_DO_UPDATE_AD_3D_
1776 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c8_3d
1777 #include <mpp_do_update_ad.fh>
1778 #define VECTOR_FIELD_
1779 #endif
1780 
1781 #undef MPP_TYPE_
1782 #define MPP_TYPE_ integer(i8_kind)
1783 #undef MPP_DO_UPDATE_AD_3D_
1784 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i8_3d
1785 #include <mpp_do_update_ad.fh>
1786 
1787 #undef VECTOR_FIELD_
1788 #define VECTOR_FIELD_
1789 #undef MPP_TYPE_
1790 #define MPP_TYPE_ real(r4_kind)
1791 #undef MPP_DO_UPDATE_AD_3D_
1792 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r4_3d
1793 #ifdef VECTOR_FIELD_
1794 #undef MPP_DO_UPDATE_AD_3D_V_
1795 #define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r4_3dv
1796 #endif
1797 #include <mpp_do_update_ad.fh>
1798 #include <mpp_do_updateV_ad.fh>
1799 
1800 #ifdef OVERLOAD_C4
1801 #undef VECTOR_FIELD_
1802 #undef MPP_TYPE_
1803 #define MPP_TYPE_ complex(c4_kind)
1804 #undef MPP_DO_UPDATE_AD_3D_
1805 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c4_3d
1806 #include <mpp_do_update_ad.fh>
1807 #define VECTOR_FIELD_
1808 #endif
1809 
1810 #undef MPP_TYPE_
1811 #define MPP_TYPE_ integer(i4_kind)
1812 #undef MPP_DO_UPDATE_AD_3D_
1813 #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i4_3d
1814 #include <mpp_do_update_ad.fh>
1815 
1816 !********************************************************
1817 #undef MPP_TYPE_
1818 #define MPP_TYPE_ real(r8_kind)
1819 #undef MPP_DO_REDISTRIBUTE_3D_
1820 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_r8_3D
1821 #include <mpp_do_redistribute.fh>
1822 #undef VECTOR_FIELD_
1823 
1824 #ifdef OVERLOAD_C8
1825 #undef MPP_TYPE_
1826 #define MPP_TYPE_ complex(c8_kind)
1827 #undef MPP_DO_REDISTRIBUTE_3D_
1828 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_c8_3D
1829 #include <mpp_do_redistribute.fh>
1830 #endif
1831 
1832 #undef MPP_TYPE_
1833 #define MPP_TYPE_ integer(i8_kind)
1834 #undef MPP_DO_REDISTRIBUTE_3D_
1835 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_i8_3D
1836 #include <mpp_do_redistribute.fh>
1837 
1838 #undef MPP_TYPE_
1839 #define MPP_TYPE_ logical(l8_kind)
1840 #undef MPP_DO_REDISTRIBUTE_3D_
1841 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_l8_3D
1842 #include <mpp_do_redistribute.fh>
1843 
1844 #undef MPP_TYPE_
1845 #define MPP_TYPE_ real(r4_kind)
1846 #undef MPP_DO_REDISTRIBUTE_3D_
1847 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_r4_3D
1848 #include <mpp_do_redistribute.fh>
1849 #undef VECTOR_FIELD_
1850 
1851 #ifdef OVERLOAD_C4
1852 #undef MPP_TYPE_
1853 #define MPP_TYPE_ complex(c4_kind)
1854 #undef MPP_DO_REDISTRIBUTE_3D_
1855 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_c4_3D
1856 #include <mpp_do_redistribute.fh>
1857 #endif
1858 
1859 #undef MPP_TYPE_
1860 #define MPP_TYPE_ integer(i4_kind)
1861 #undef MPP_DO_REDISTRIBUTE_3D_
1862 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_i4_3D
1863 #include <mpp_do_redistribute.fh>
1864 
1865 #undef MPP_TYPE_
1866 #define MPP_TYPE_ logical(l4_kind)
1867 #undef MPP_DO_REDISTRIBUTE_3D_
1868 #define MPP_DO_REDISTRIBUTE_3D_ mpp_do_redistribute_l4_3D
1869 #include <mpp_do_redistribute.fh>
1870 
1871 #undef MPP_TYPE_
1872 #define MPP_TYPE_ real(r8_kind)
1873 #undef MPP_GET_BOUNDARY_2D_
1874 #define MPP_GET_BOUNDARY_2D_ mpp_get_boundary_r8_2d
1875 #undef MPP_GET_BOUNDARY_3D_
1876 #define MPP_GET_BOUNDARY_3D_ mpp_get_boundary_r8_3d
1877 !#undef MPP_GET_BOUNDARY_4D_
1878 !#define MPP_GET_BOUNDARY_4D_ mpp_get_boundary_r8_4d
1879 !#undef MPP_GET_BOUNDARY_5D_
1880 !#define MPP_GET_BOUNDARY_5D_ mpp_get_boundary_r8_5d
1881 #undef MPP_GET_BOUNDARY_2D_V_
1882 #define MPP_GET_BOUNDARY_2D_V_ mpp_get_boundary_r8_2dv
1883 #undef MPP_GET_BOUNDARY_3D_V_
1884 #define MPP_GET_BOUNDARY_3D_V_ mpp_get_boundary_r8_3dv
1885 !#undef MPP_GET_BOUNDARY_4D_V_
1886 !#define MPP_GET_BOUNDARY_4D_V_ mpp_get_boundary_r8_4dv
1887 !#undef MPP_GET_BOUNDARY_5D_V_
1888 !#define MPP_GET_BOUNDARY_5D_V_ mpp_get_boundary_r8_5dv
1889 #include <mpp_get_boundary.fh>
1890 
1891 #undef MPP_TYPE_
1892 #define MPP_TYPE_ real(r8_kind)
1893 #undef MPP_GET_BOUNDARY_AD_2D_
1894 #define MPP_GET_BOUNDARY_AD_2D_ mpp_get_boundary_ad_r8_2d
1895 #undef MPP_GET_BOUNDARY_AD_3D_
1896 #define MPP_GET_BOUNDARY_AD_3D_ mpp_get_boundary_ad_r8_3d
1897 #undef MPP_GET_BOUNDARY_AD_2D_V_
1898 #define MPP_GET_BOUNDARY_AD_2D_V_ mpp_get_boundary_ad_r8_2dv
1899 #undef MPP_GET_BOUNDARY_AD_3D_V_
1900 #define MPP_GET_BOUNDARY_AD_3D_V_ mpp_get_boundary_ad_r8_3dv
1901 #include <mpp_get_boundary_ad.fh>
1902 
1903 #undef MPP_TYPE_
1904 #define MPP_TYPE_ real(r4_kind)
1905 #undef MPP_GET_BOUNDARY_2D_
1906 #define MPP_GET_BOUNDARY_2D_ mpp_get_boundary_r4_2d
1907 #undef MPP_GET_BOUNDARY_3D_
1908 #define MPP_GET_BOUNDARY_3D_ mpp_get_boundary_r4_3d
1909 !#undef MPP_GET_BOUNDARY_4D_
1910 !#define MPP_GET_BOUNDARY_4D_ mpp_get_boundary_r4_4d
1911 !#undef MPP_GET_BOUNDARY_5D_
1912 !#define MPP_GET_BOUNDARY_5D_ mpp_get_boundary_r4_5d
1913 #undef MPP_GET_BOUNDARY_2D_V_
1914 #define MPP_GET_BOUNDARY_2D_V_ mpp_get_boundary_r4_2dv
1915 #undef MPP_GET_BOUNDARY_3D_V_
1916 #define MPP_GET_BOUNDARY_3D_V_ mpp_get_boundary_r4_3dv
1917 !#undef MPP_GET_BOUNDARY_4D_V_
1918 !#define MPP_GET_BOUNDARY_4D_V_ mpp_get_boundary_r4_4dv
1919 !#undef MPP_GET_BOUNDARY_5D_V_
1920 !#define MPP_GET_BOUNDARY_5D_V_ mpp_get_boundary_r4_5dv
1921 #include <mpp_get_boundary.fh>
1922 
1923 #undef MPP_TYPE_
1924 #define MPP_TYPE_ real(r4_kind)
1925 #undef MPP_GET_BOUNDARY_AD_2D_
1926 #define MPP_GET_BOUNDARY_AD_2D_ mpp_get_boundary_ad_r4_2d
1927 #undef MPP_GET_BOUNDARY_AD_3D_
1928 #define MPP_GET_BOUNDARY_AD_3D_ mpp_get_boundary_ad_r4_3d
1929 #undef MPP_GET_BOUNDARY_AD_2D_V_
1930 #define MPP_GET_BOUNDARY_AD_2D_V_ mpp_get_boundary_ad_r4_2dv
1931 #undef MPP_GET_BOUNDARY_AD_3D_V_
1932 #define MPP_GET_BOUNDARY_AD_3D_V_ mpp_get_boundary_ad_r4_3dv
1933 #include <mpp_get_boundary_ad.fh>
1934 
1935 #undef MPP_TYPE_
1936 #define MPP_TYPE_ real(r8_kind)
1937 #undef MPP_DO_GET_BOUNDARY_3D_
1938 #define MPP_DO_GET_BOUNDARY_3D_ mpp_do_get_boundary_r8_3d
1939 #undef MPP_DO_GET_BOUNDARY_3DV_
1940 #define MPP_DO_GET_BOUNDARY_3D_V_ mpp_do_get_boundary_r8_3dv
1941 #include <mpp_do_get_boundary.fh>
1942 
1943 #undef MPP_TYPE_
1944 #define MPP_TYPE_ real(r8_kind)
1945 #undef MPP_DO_GET_BOUNDARY_AD_3D_
1946 #define MPP_DO_GET_BOUNDARY_AD_3D_ mpp_do_get_boundary_ad_r8_3d
1947 #undef MPP_DO_GET_BOUNDARY_AD_3DV_
1948 #define MPP_DO_GET_BOUNDARY_AD_3D_V_ mpp_do_get_boundary_ad_r8_3dv
1949 #include <mpp_do_get_boundary_ad.fh>
1950 
1951 #undef MPP_TYPE_
1952 #define MPP_TYPE_ real(r4_kind)
1953 #undef MPP_DO_GET_BOUNDARY_3D_
1954 #define MPP_DO_GET_BOUNDARY_3D_ mpp_do_get_boundary_r4_3d
1955 #undef MPP_DO_GET_BOUNDARY_3D_V_
1956 #define MPP_DO_GET_BOUNDARY_3D_V_ mpp_do_get_boundary_r4_3dv
1957 #include <mpp_do_get_boundary.fh>
1958 
1959 #undef MPP_TYPE_
1960 #define MPP_TYPE_ real(r4_kind)
1961 #undef MPP_DO_GET_BOUNDARY_AD_3D_
1962 #define MPP_DO_GET_BOUNDARY_AD_3D_ mpp_do_get_boundary_ad_r4_3d
1963 #undef MPP_DO_GET_BOUNDARY_AD_3D_V_
1964 #define MPP_DO_GET_BOUNDARY_AD_3D_V_ mpp_do_get_boundary_ad_r4_3dv
1965 #include <mpp_do_get_boundary_ad.fh>
1966 
1967 #undef MPP_TYPE_
1968 #define MPP_TYPE_ real(r8_kind)
1969 #undef MPI_TYPE_
1970 #define MPI_TYPE_ MPI_REAL8
1971 #undef MPP_CREATE_GROUP_UPDATE_
1972 #define MPP_CREATE_GROUP_UPDATE_ mpp_create_group_update_r8
1973 #undef MPP_CREATE_GROUP_UPDATE_V_
1974 #define MPP_CREATE_GROUP_UPDATE_V_ mpp_create_group_update_r8_v
1975 #undef MPP_DO_GROUP_UPDATE_
1976 #define MPP_DO_GROUP_UPDATE_ mpp_do_group_update_r8
1977 #undef MPP_START_GROUP_UPDATE_
1978 #define MPP_START_GROUP_UPDATE_ mpp_start_group_update_r8
1979 #undef MPP_COMPLETE_GROUP_UPDATE_
1980 #define MPP_COMPLETE_GROUP_UPDATE_ mpp_complete_group_update_r8
1981 #undef MPP_RESET_GROUP_UPDATE_FIELD_
1982 #define MPP_RESET_GROUP_UPDATE_FIELD_ mpp_reset_group_update_field_r8
1983 #undef MPP_RESET_GROUP_UPDATE_FIELD_V_
1984 #define MPP_RESET_GROUP_UPDATE_FIELD_V_ mpp_reset_group_update_field_r8_v
1985 #undef GROUP_UPDATE_PACK_
1986 #define GROUP_UPDATE_PACK_ group_update_pack_r8
1987 #undef GROUP_UPDATE_UNPACK_
1988 #define GROUP_UPDATE_UNPACK_ group_update_unpack_r8
1989 #undef GROUP_UPDATE_PACK_GENERAL_
1990 #define GROUP_UPDATE_PACK_GENERAL_ group_update_pack_general_r8
1991 #undef GROUP_UPDATE_UNPACK_GENERAL_
1992 #define GROUP_UPDATE_UNPACK_GENERAL_ group_update_unpack_general_r8
1993 #undef SET_ZERO_
1994 #define SET_ZERO_ set_zero_r8
1995 #undef NEGATE_HALO_
1996 #define NEGATE_HALO_ negate_halo_r8
1997 #undef FLIP_I_
1998 #define FLIP_I_ flip_i_r8
1999 #include <mpp_group_update.fh>
2000 
2001 #undef MPP_TYPE_
2002 #define MPP_TYPE_ real(r4_kind)
2003 #undef MPI_TYPE_
2004 #define MPI_TYPE_ MPI_REAL4
2005 #undef MPP_CREATE_GROUP_UPDATE_
2006 #define MPP_CREATE_GROUP_UPDATE_ mpp_create_group_update_r4
2007 #undef MPP_CREATE_GROUP_UPDATE_V_
2008 #define MPP_CREATE_GROUP_UPDATE_V_ mpp_create_group_update_r4_v
2009 #undef MPP_DO_GROUP_UPDATE_
2010 #define MPP_DO_GROUP_UPDATE_ mpp_do_group_update_r4
2011 #undef MPP_START_GROUP_UPDATE_
2012 #define MPP_START_GROUP_UPDATE_ mpp_start_group_update_r4
2013 #undef MPP_COMPLETE_GROUP_UPDATE_
2014 #define MPP_COMPLETE_GROUP_UPDATE_ mpp_complete_group_update_r4
2015 #undef MPP_RESET_GROUP_UPDATE_FIELD_
2016 #define MPP_RESET_GROUP_UPDATE_FIELD_ mpp_reset_group_update_field_r4
2017 #undef MPP_RESET_GROUP_UPDATE_FIELD_V_
2018 #define MPP_RESET_GROUP_UPDATE_FIELD_V_ mpp_reset_group_update_field_r4_v
2019 #undef GROUP_UPDATE_PACK_
2020 #define GROUP_UPDATE_PACK_ group_update_pack_r4
2021 #undef GROUP_UPDATE_UNPACK_
2022 #define GROUP_UPDATE_UNPACK_ group_update_unpack_r4
2023 #undef GROUP_UPDATE_PACK_GENERAL_
2024 #define GROUP_UPDATE_PACK_GENERAL_ group_update_pack_general_r4
2025 #undef GROUP_UPDATE_UNPACK_GENERAL_
2026 #define GROUP_UPDATE_UNPACK_GENERAL_ group_update_unpack_general_r4
2027 #undef SET_ZERO_
2028 #define SET_ZERO_ set_zero_r4
2029 #undef NEGATE_HALO_
2030 #define NEGATE_HALO_ negate_halo_r4
2031 #undef FLIP_I_
2032 #define FLIP_I_ flip_i_r4
2033 #include <mpp_group_update.fh>
mpp_check_field_2d_type1
subroutine mpp_check_field_2d_type1(field_in, pelist1, pelist2, domain, mesg, w_halo, s_halo, e_halo, n_halo, force_abort)
This routine is used to check field between running on 1 pe (pelist2) and n pe(pelist1)....
Definition: mpp_domains_misc.inc:253
mpp_broadcast_domain_1
subroutine logical mpp_broadcast_domain_1(domain)
broadcast domain (useful only outside the context of its own pelist)
Definition: mpp_domains_misc.inc:464
mpp_domains_init
subroutine mpp_domains_init(flags)
Initialize domain decomp package.
Definition: mpp_domains_misc.inc:44
mpp_check_field_2d
subroutine mpp_check_field_2d(field_in, pelist1, pelist2, domain, mesg, w_halo, s_halo, e_halo, n_halo, force_abort, position)
This routine is used to do parallel checking for 2d data between n and m pe. The comparison is is don...
Definition: mpp_domains_misc.inc:214
mpp_domains_exit
subroutine mpp_domains_exit()
Exit mpp_domains_mod. Serves no particular purpose, but is provided should you require to re-initiali...
Definition: mpp_domains_misc.inc:161
mpp_check_field_3d
subroutine mpp_check_field_3d(field_in, pelist1, pelist2, domain, mesg, w_halo, s_halo, e_halo, n_halo, force_abort, position)
This routine is used to do parallel checking for 3d data between n and m pe. The comparison is is don...
Definition: mpp_domains_misc.inc:181
mpp_broadcast_domain_nest_coarse
subroutine mpp_broadcast_domain_nest_coarse(domain, tile_coarse)
Broadcast nested domain (useful only outside the context of its own pelist)
Definition: mpp_domains_misc.inc:836
mpp_check_field_2d_type2
subroutine mpp_check_field_2d_type2(field_in, pelist1, pelist2, domain, mesg, force_abort)
This routine is used to check field between running on m pe (root pe) and n pe. This routine can not ...
Definition: mpp_domains_misc.inc:383
mpp_domains_set_stack_size
subroutine mpp_domains_set_stack_size(n)
Set user stack size.
Definition: mpp_domains_util.inc:35
init_nonblock_type
subroutine init_nonblock_type(nonblock_obj)
Initialize domain decomp package.
Definition: mpp_domains_misc.inc:125
mpp_sync_self
subroutine mpp_sync_self(pelist, check, request, msg_size, msg_type)
This is to check if current PE's outstanding puts are complete but we can't use shmem_fence because w...
Definition: mpp_util_mpi.inc:178
stdout
integer function stdout()
This function returns the current standard fortran unit numbers for output.
Definition: mpp_util.inc:42
stderr
integer function stderr()
This function returns the current standard fortran unit numbers for error messages.
Definition: mpp_util.inc:50
stdlog
integer function stdlog()
This function returns the current standard fortran unit numbers for log messages. Log messages,...
Definition: mpp_util.inc:58
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
mpp_sync
subroutine mpp_sync(pelist, do_self)
Synchronize PEs in list.
Definition: mpp_util_mpi.inc:155
mpp_clock_id
integer function mpp_clock_id(name, flags, grain)
Return an ID for a new or existing clock.
Definition: mpp_util.inc:736