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