FV3 Bundle
fv_mp_adm.F90
Go to the documentation of this file.
1 module fv_mp_adm_mod
2 
3 use fv_arrays_nlm_mod, only : r_grid
4 use fv_arrays_tlmadm_mod,only : fv_timing_onoff
5 use mpp_domains_mod, only : domain2d
6 use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update
7 use mpp_domains_mod, only : mpp_group_update_initialized
8 use mpp_domains_mod, only : mpp_create_group_update,mpp_reset_group_update_field
9 use mpp_domains_mod, only : group_halo_update_type => mpp_group_update_type
10 
11 #ifdef OLDMPP
12 use mpp_domains_mod, only : mpp_update_domains
13 #endif
14 use mpp_domains_mod, only : mpp_global_sum
15 
16 use mpp_domains_mod, only : mpp_update_domains_ad, mpp_get_boundary_ad
17 
18 use fv_mp_nlm_mod, only : xdir, ydir, ng
19 use fv_mp_nlm_mod, only : is, ie, js, je
20 use fv_mp_nlm_mod, only : isd, ied, jsd, jed
21 
22 use fv_timing_nlm_mod, only: timing_on, timing_off
23 
24 use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
25  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
26 
27 implicit none
28 private
29 
30 #include "mpif.h"
31 
32 integer :: commglobal, ierror, npes
33 
34 !fv_mp_nlm_mod routines
35 public complete_group_halo_update
36 public start_group_halo_update, start_group_halo_update_adm
37 public fill_corners_adm
38 
39 !mpp_domains interface
40 public mpp_update_domains_adm, mpp_get_boundary_adm, mpp_global_sum_adm
41 
42 
43 ! Regular fv_mp_nlm_mod routines
44 ! --------------------------
45 interface start_group_halo_update
46  module procedure start_var_group_update_2d
47  module procedure start_var_group_update_3d
48  module procedure start_var_group_update_4d
49  module procedure start_vector_group_update_2d
50  module procedure start_vector_group_update_3d
51 end interface start_group_halo_update
52 
53 interface start_group_halo_update_adm
54  module procedure start_var_group_update_2d_adm
55  module procedure start_var_group_update_3d_adm
56  module procedure start_var_group_update_4d_adm
57  module procedure start_vector_group_update_2d_adm
58  module procedure start_vector_group_update_3d_adm
59 end interface
60 
61 interface fill_corners_adm
62  module procedure fill_corners_2d_r4_adm
63  module procedure fill_corners_2d_r8_adm
64  module procedure fill_corners_xy_2d_r4_adm
65  module procedure fill_corners_xy_2d_r8_adm
66 end interface
67 
68 interface fill_corners_agrid_adm
69  module procedure fill_corners_agrid_r4_adm
70  module procedure fill_corners_agrid_r8_adm
71 end interface
72 
73 interface fill_corners_cgrid_adm
74  module procedure fill_corners_cgrid_r4_adm
75  module procedure fill_corners_cgrid_r8_adm
76 end interface
77 
78 interface fill_corners_dgrid_adm
79  module procedure fill_corners_dgrid_r4_adm
80  module procedure fill_corners_dgrid_r8_adm
81 end interface
82 
83 
84 ! These are invented interfaces to mpp_domains
85 ! --------------------------------------------
86 
87 interface mpp_global_sum_adm
88  module procedure mpp_global_sum_2d_adm
89 end interface
90 
91 interface mpp_update_domains_adm
92  module procedure mpp_update_domain2d_2d_adm
93  module procedure mpp_update_domain2d_3d_adm
94  module procedure mpp_update_domain2d_4d_adm
95  module procedure mpp_update_domain2d_5d_adm
96  module procedure mpp_update_domain2d_2dv_adm
97  module procedure mpp_update_domain2d_3dv_adm
98  module procedure mpp_update_domain2d_4dv_adm
99  module procedure mpp_update_domain2d_5dv_adm
100 end interface
101 
102 interface mpp_get_boundary_adm
103  module procedure mpp_get_boundary_2d_adm
104  module procedure mpp_get_boundary_3d_adm
105  module procedure mpp_get_boundary_2dv_adm
106  module procedure mpp_get_boundary_3dv_adm
107 end interface
108 
109 contains
110 
111 
112 ! start_group_halo_update
113 ! -----------------------
114 
115 subroutine start_var_group_update_2d(group, &
116 #ifndef OLDMPP
117  groupp, &
118 #endif
119  array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
120 
121  type(group_halo_update_type), intent(inout) :: group
122 #ifndef OLDMPP
123  type(group_halo_update_type), intent(inout) :: groupp
124 #endif
125  real, dimension(:,:), intent(inout) :: array
126  type(domain2D), intent(inout) :: domain
127  integer, optional, intent(in) :: flags
128  integer, optional, intent(in) :: position
129  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
130  logical, optional, intent(in) :: complete
131  real :: d_type
132  logical :: is_complete
133 ! Arguments:
134 ! (inout) group - The data type that store information for group update.
135 ! This data will be used in do_group_pass.
136 ! (inout) array - The array which is having its halos points exchanged.
137 ! (in) domain - contains domain information.
138 ! (in) flags - An optional integer indicating which directions the
139 ! data should be sent.
140 ! (in) position - An optional argument indicating the position. This is
141 ! may be CORNER, but is CENTER by default.
142 ! (in) complete - An optional argument indicating whether the halo updates
143 ! should be initiated immediately or wait for second
144 ! pass_..._start call. Omitting complete is the same as
145 ! setting complete to .true.
146 
147  if (fv_timing_onoff) call timing_on(' FWD_COMM_TOTAL')
148 
149 #ifdef OLDMPP
150 
151  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
152 
153 #else
154 
155  if (mpp_group_update_initialized(group)) then
156  call mpp_reset_group_update_field(group,array)
157  else
158  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
159  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
160  endif
161 
162  is_complete = .true.
163  if(present(complete)) is_complete = complete
164  if(is_complete) then
165  call mpp_start_group_update(group, domain, d_type)
166  endif
167 
168 #endif
169 
170  if (fv_timing_onoff) call timing_off(' FWD_COMM_TOTAL')
171 
172 end subroutine start_var_group_update_2d
173 
174 
175 subroutine start_var_group_update_3d(group, &
176 #ifndef OLDMPP
177  groupp, &
178 #endif
179  array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
180 
181  type(group_halo_update_type), intent(inout) :: group
182 #ifndef OLDMPP
183  type(group_halo_update_type), intent(inout) :: groupp
184 #endif
185  real, dimension(:,:,:), intent(inout) :: array
186  type(domain2D), intent(inout) :: domain
187  integer, optional, intent(in) :: flags
188  integer, optional, intent(in) :: position
189  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
190  logical, optional, intent(in) :: complete
191  real :: d_type
192  logical :: is_complete
193 
194 ! Arguments:
195 ! (inout) group - The data type that store information for group update.
196 ! This data will be used in do_group_pass.
197 ! (inout) array - The array which is having its halos points exchanged.
198 ! (in) domain - contains domain information.
199 ! (in) flags - An optional integer indicating which directions the
200 ! data should be sent.
201 ! (in) position - An optional argument indicating the position. This is
202 ! may be CORNER, but is CENTER by default.
203 ! (in) complete - An optional argument indicating whether the halo updates
204 ! should be initiated immediately or wait for second
205 ! pass_..._start call. Omitting complete is the same as
206 ! setting complete to .true.
207 
208  if (fv_timing_onoff) call timing_on(' FWD_COMM_TOTAL')
209 
210 #ifdef OLDMPP
211 
212  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
213 
214 #else
215 
216  if (mpp_group_update_initialized(group)) then
217  call mpp_reset_group_update_field(group,array)
218  else
219  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
220  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
221  endif
222 
223  is_complete = .true.
224  if(present(complete)) is_complete = complete
225  if(is_complete) then
226  call mpp_start_group_update(group, domain, d_type)
227  endif
228 
229 #endif
230 
231  if (fv_timing_onoff) call timing_off(' FWD_COMM_TOTAL')
232 
233 end subroutine start_var_group_update_3d
234 
235 subroutine start_var_group_update_4d(group, &
236 #ifndef OLDMPP
237  groupp, &
238 #endif
239  array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
240  type(group_halo_update_type), intent(inout) :: group
241 #ifndef OLDMPP
242  type(group_halo_update_type), intent(inout) :: groupp
243 #endif
244  real, dimension(:,:,:,:), intent(inout) :: array
245  type(domain2D), intent(inout) :: domain
246  integer, optional, intent(in) :: flags
247  integer, optional, intent(in) :: position
248  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
249  logical, optional, intent(in) :: complete
250  real :: d_type
251  logical :: is_complete
252 
253 ! Arguments:
254 ! (inout) group - The data type that store information for group update.
255 ! This data will be used in do_group_pass.
256 ! (inout) array - The array which is having its halos points exchanged.
257 ! (in) domain - contains domain information.
258 ! (in) flags - An optional integer indicating which directions the
259 ! data should be sent.
260 ! (in) position - An optional argument indicating the position. This is
261 ! may be CORNER, but is CENTER by default.
262 ! (in) complete - An optional argument indicating whether the halo updates
263 ! should be initiated immediately or wait for second
264 ! pass_..._start call. Omitting complete is the same as
265 ! setting complete to .true.
266 
267  integer :: dirflag
268 
269  if (fv_timing_onoff) call timing_on(' FWD_COMM_TOTAL')
270 
271 #ifdef OLDMPP
272 
273  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
274 
275 #else
276 
277  if (mpp_group_update_initialized(group)) then
278  call mpp_reset_group_update_field(group,array)
279  else
280  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
281  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
282  endif
283 
284  is_complete = .true.
285  if(present(complete)) is_complete = complete
286  if(is_complete) then
287  call mpp_start_group_update(group, domain, d_type)
288  endif
289 
290 #endif
291 
292  if (fv_timing_onoff) call timing_off(' FWD_COMM_TOTAL')
293 
294 end subroutine start_var_group_update_4d
295 
296 
297 
298 subroutine start_vector_group_update_2d(group, &
299 #ifndef OLDMPP
300  groupp, &
301 #endif
302  u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
303  type(group_halo_update_type), intent(inout) :: group
304 #ifndef OLDMPP
305  type(group_halo_update_type), intent(inout) :: groupp
306 #endif
307  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt
308  type(domain2d), intent(inout) :: domain
309  integer, optional, intent(in) :: flags
310  integer, optional, intent(in) :: gridtype
311  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
312  logical, optional, intent(in) :: complete
313  real :: d_type
314  logical :: is_complete
315 
316 ! Arguments:
317 ! (inout) group - The data type that store information for group update.
318 ! This data will be used in do_group_pass.
319 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
320 ! is having its halos points exchanged.
321 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
322 ! which is having its halos points exchanged.
323 ! (in) domain - Contains domain decomposition information.
324 ! (in) flags - An optional integer indicating which directions the
325 ! data should be sent.
326 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
327 ! CGRID_NE or DGRID_NE, indicating where the two components of the
328 ! vector are discretized.
329 ! (in) complete - An optional argument indicating whether the halo updates
330 ! should be initiated immediately or wait for second
331 ! pass_..._start call. Omitting complete is the same as
332 ! setting complete to .true.
333 
334  if (fv_timing_onoff) call timing_on(' FWD_COMM_TOTAL')
335 
336 #ifdef OLDMPP
337 
338  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
339  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
340 
341 #else
342 
343  if (mpp_group_update_initialized(group)) then
344  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
345  else
346  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
347  flags=flags, gridtype=gridtype, &
348  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
349  endif
350 
351  is_complete = .true.
352  if(present(complete)) is_complete = complete
353  if(is_complete) then
354  call mpp_start_group_update(group, domain, d_type)
355  endif
356 
357 #endif
358 
359  if (fv_timing_onoff) call timing_off(' FWD_COMM_TOTAL')
360 
361 end subroutine start_vector_group_update_2d
362 
363 subroutine start_vector_group_update_3d(group, &
364 #ifndef OLDMPP
365  groupp, &
366 #endif
367  u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
368  type(group_halo_update_type), intent(inout) :: group
369 #ifndef OLDMPP
370  type(group_halo_update_type), intent(inout) :: groupp
371 #endif
372  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt
373  type(domain2d), intent(inout) :: domain
374  integer, optional, intent(in) :: flags
375  integer, optional, intent(in) :: gridtype
376  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
377  logical, optional, intent(in) :: complete
378  real :: d_type
379  logical :: is_complete
380 
381 ! Arguments:
382 ! (inout) group - The data type that store information for group update.
383 ! This data will be used in do_group_pass.
384 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
385 ! is having its halos points exchanged.
386 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
387 ! which is having its halos points exchanged.
388 ! (in) domain - Contains domain decomposition information.
389 ! (in) flags - An optional integer indicating which directions the
390 ! data should be sent.
391 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
392 ! CGRID_NE or DGRID_NE, indicating where the two components of the
393 ! vector are discretized.
394 ! (in) complete - An optional argument indicating whether the halo updates
395 ! should be initiated immediately or wait for second
396 ! pass_..._start call. Omitting complete is the same as
397 ! setting complete to .true.
398 
399  if (fv_timing_onoff) call timing_on(' FWD_COMM_TOTAL')
400 
401 #ifdef OLDMPP
402 
403  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
404  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
405 
406 #else
407 
408  if (mpp_group_update_initialized(group)) then
409  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
410  else
411  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
412  flags=flags, gridtype=gridtype, &
413  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
414  endif
415 
416  is_complete = .true.
417  if(present(complete)) is_complete = complete
418  if(is_complete) then
419  call mpp_start_group_update(group, domain, d_type)
420  endif
421 
422 #endif
423 
424  if (fv_timing_onoff) call timing_off(' FWD_COMM_TOTAL')
425 
426 end subroutine start_vector_group_update_3d
427 
428 ! complete_group_halo_update
429 ! --------------------------
430 
431 subroutine complete_group_halo_update(group,&
432 #ifndef OLDMPP
433  groupp, &
434 #endif
435  domain)
436  type(group_halo_update_type), intent(inout) :: group
437 #ifndef OLDMPP
438  type(group_halo_update_type), intent(inout) :: groupp
439 #endif
440  type(domain2d), intent(inout) :: domain
441  real :: d_type
442 
443 ! Arguments:
444 ! (inout) group - The data type that store information for group update.
445 ! (in) domain - Contains domain decomposition information.
446 
447  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
448 
449 #ifndef OLDMPP
450 
451  call mpp_complete_group_update(group, domain, d_type)
452  call mpp_complete_group_update(groupp, domain, d_type)
453 
454 #endif
455 
456  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
457 
458 end subroutine complete_group_halo_update
459 
460 
461 ! start_group_halo_update_adm
462 ! ---------------------------
463 
464  subroutine start_var_group_update_2d_adm(group, &
465 #ifndef OLDMPP
466  groupp, &
467 #endif
468  array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
469  type(group_halo_update_type), intent(inout) :: group
470 #ifndef OLDMPP
471  type(group_halo_update_type), intent(inout) :: groupp
472 #endif
473  real, dimension(:,:), intent(inout) :: array, arrayp
474  real(8) :: array8(10,10)
475  type(domain2D), intent(inout) :: domain
476  integer, optional, intent(in) :: flags
477  integer, optional, intent(in) :: position
478  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
479  logical, optional, intent(in) :: complete
480  real :: d_type
481  logical :: is_complete
482 ! Arguments:
483 ! (inout) group - The data type that store information for group update.
484 ! This data will be used in do_group_pass.
485 ! (inout) array - The array which is having its halos points exchanged.
486 ! (in) domain - contains domain information.
487 ! (in) flags - An optional integer indicating which directions the
488 ! data should be sent.
489 ! (in) position - An optional argument indicating the position. This is
490 ! may be CORNER, but is CENTER by default.
491 ! (in) complete - An optional argument indicating whether the halo updates
492 ! should be initiated immediately or wait for second
493 ! pass_..._start call. Omitting complete is the same as
494 ! setting complete to .true.
495 
496  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
497 
498 #ifdef OLDMPP
499 
500  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
501 
502 #endif
503 
504  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
505 
506 end subroutine start_var_group_update_2d_adm
507 
508 subroutine start_var_group_update_3d_adm(group, &
509 #ifndef OLDMPP
510  groupp, &
511 #endif
512  array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
513  type(group_halo_update_type), intent(inout) :: group
514 #ifndef OLDMPP
515  type(group_halo_update_type), intent(inout) :: groupp
516 #endif
517  real, dimension(:,:,:), intent(inout) :: array, arrayp
518  type(domain2D), intent(inout) :: domain
519  integer, optional, intent(in) :: flags
520  integer, optional, intent(in) :: position
521  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
522  logical, optional, intent(in) :: complete
523  real :: d_type
524  logical :: is_complete
525 
526 ! Arguments:
527 ! (inout) group - The data type that store information for group update.
528 ! This data will be used in do_group_pass.
529 ! (inout) array - The array which is having its halos points exchanged.
530 ! (in) domain - contains domain information.
531 ! (in) flags - An optional integer indicating which directions the
532 ! data should be sent.
533 ! (in) position - An optional argument indicating the position. This is
534 ! may be CORNER, but is CENTER by default.
535 ! (in) complete - An optional argument indicating whether the halo updates
536 ! should be initiated immediately or wait for second
537 ! pass_..._start call. Omitting complete is the same as
538 ! setting complete to .true.
539 
540  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
541 
542 #ifdef OLDMPP
543 
544  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
545 
546 #endif
547 
548  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
549 
550 end subroutine start_var_group_update_3d_adm
551 
552 subroutine start_var_group_update_4d_adm(group, &
553 #ifndef OLDMPP
554  groupp, &
555 #endif
556  array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
557  type(group_halo_update_type), intent(inout) :: group
558 #ifndef OLDMPP
559  type(group_halo_update_type), intent(inout) :: groupp
560 #endif
561  real, dimension(:,:,:,:), intent(inout) :: array, arrayp
562  type(domain2D), intent(inout) :: domain
563  integer, optional, intent(in) :: flags
564  integer, optional, intent(in) :: position
565  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
566  logical, optional, intent(in) :: complete
567  real :: d_type
568  logical :: is_complete
569 
570 ! Arguments:
571 ! (inout) group - The data type that store information for group update.
572 ! This data will be used in do_group_pass.
573 ! (inout) array - The array which is having its halos points exchanged.
574 ! (in) domain - contains domain information.
575 ! (in) flags - An optional integer indicating which directions the
576 ! data should be sent.
577 ! (in) position - An optional argument indicating the position. This is
578 ! may be CORNER, but is CENTER by default.
579 ! (in) complete - An optional argument indicating whether the halo updates
580 ! should be initiated immediately or wait for second
581 ! pass_..._start call. Omitting complete is the same as
582 ! setting complete to .true.
583 
584  integer :: dirflag
585 
586  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
587 
588 #ifdef OLDMPP
589 
590  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
591 
592 #endif
593 
594  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
595 
596 end subroutine start_var_group_update_4d_adm
597 
598 
599 
600 subroutine start_vector_group_update_2d_adm(group, &
601 #ifndef OLDMPP
602  groupp, &
603 #endif
604  u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
605  type(group_halo_update_type), intent(inout) :: group
606 #ifndef OLDMPP
607  type(group_halo_update_type), intent(inout) :: groupp
608 #endif
609  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmptp, v_cmptp
610  type(domain2d), intent(inout) :: domain
611  integer, optional, intent(in) :: flags
612  integer, optional, intent(in) :: gridtype
613  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
614  logical, optional, intent(in) :: complete
615  real :: d_type
616  logical :: is_complete
617 
618 ! Arguments:
619 ! (inout) group - The data type that store information for group update.
620 ! This data will be used in do_group_pass.
621 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
622 ! is having its halos points exchanged.
623 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
624 ! which is having its halos points exchanged.
625 ! (in) domain - Contains domain decomposition information.
626 ! (in) flags - An optional integer indicating which directions the
627 ! data should be sent.
628 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
629 ! CGRID_NE or DGRID_NE, indicating where the two components of the
630 ! vector are discretized.
631 ! (in) complete - An optional argument indicating whether the halo updates
632 ! should be initiated immediately or wait for second
633 ! pass_..._start call. Omitting complete is the same as
634 ! setting complete to .true.
635 
636  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
637 
638 #ifdef OLDMPP
639 
640  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
641  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
642 
643 #endif
644 
645  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
646 
647 end subroutine start_vector_group_update_2d_adm
648 
649 subroutine start_vector_group_update_3d_adm(group, &
650 #ifndef OLDMPP
651  groupp, &
652 #endif
653  u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
654  type(group_halo_update_type), intent(inout) :: group
655 #ifndef OLDMPP
656  type(group_halo_update_type), intent(inout) :: groupp
657 #endif
658  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmptp, v_cmptp
659  type(domain2d), intent(inout) :: domain
660  integer, optional, intent(in) :: flags
661  integer, optional, intent(in) :: gridtype
662  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
663  logical, optional, intent(in) :: complete
664  real :: d_type
665  logical :: is_complete
666 
667 ! Arguments:
668 ! (inout) group - The data type that store information for group update.
669 ! This data will be used in do_group_pass.
670 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
671 ! is having its halos points exchanged.
672 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
673 ! which is having its halos points exchanged.
674 ! (in) domain - Contains domain decomposition information.
675 ! (in) flags - An optional integer indicating which directions the
676 ! data should be sent.
677 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
678 ! CGRID_NE or DGRID_NE, indicating where the two components of the
679 ! vector are discretized.
680 ! (in) complete - An optional argument indicating whether the halo updates
681 ! should be initiated immediately or wait for second
682 ! pass_..._start call. Omitting complete is the same as
683 ! setting complete to .true.
684 
685  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
686 
687 #ifdef OLDMPP
688 
689  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
690  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
691 
692 #endif
693 
694  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
695 
696 end subroutine start_vector_group_update_3d_adm
697 
698 
699 
700 ! fill_corners_adm
701 ! ----------------
702 
703  SUBROUTINE fill_corners_2d_r4_adm(q, q_ad, npx, npy, fill, agrid, &
704 & bgrid)
705  IMPLICIT NONE
706  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: q
707  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: q_ad
708  INTEGER, INTENT(IN) :: npx, npy
709 ! X-Dir or Y-Dir
710  INTEGER, INTENT(IN) :: fill
711  LOGICAL, OPTIONAL, INTENT(IN) :: agrid, bgrid
712  INTEGER :: i, j
713  INTRINSIC PRESENT
714  REAL(kind=4) :: tmp
715  REAL(kind=4) :: tmp_ad
716  REAL(kind=4) :: tmp0
717  REAL(kind=4) :: tmp_ad0
718  REAL(kind=4) :: tmp1
719  REAL(kind=8) :: tmp_ad1
720  REAL(kind=8) :: tmp2
721  REAL(kind=8) :: tmp_ad2
722  REAL(kind=4) :: tmp3
723  REAL(kind=4) :: tmp_ad3
724  REAL(kind=4) :: tmp4
725  REAL(kind=4) :: tmp_ad4
726  REAL(kind=4) :: tmp5
727  REAL(kind=4) :: tmp_ad5
728  REAL(kind=4) :: tmp6
729  REAL(kind=4) :: tmp_ad6
730  REAL(kind=4) :: tmp7
731  REAL(kind=4) :: tmp_ad7
732  REAL(kind=4) :: tmp8
733  REAL(kind=4) :: tmp_ad8
734  REAL(kind=4) :: tmp9
735  REAL(kind=4) :: tmp_ad9
736  REAL(kind=4) :: tmp10
737  REAL(kind=4) :: tmp_ad10
738  REAL(kind=4) :: tmp11
739  REAL(kind=4) :: tmp_ad11
740  REAL(kind=4) :: tmp12
741  REAL(kind=4) :: tmp_ad12
742  REAL(kind=4) :: tmp13
743  REAL(kind=4) :: tmp_ad13
744  REAL(kind=4) :: tmp14
745  REAL(kind=4) :: tmp_ad14
746  REAL(kind=4) :: tmp15
747  REAL(kind=4) :: tmp_ad15
748  REAL(kind=4) :: tmp16
749  REAL(kind=4) :: tmp_ad16
750  REAL(kind=4) :: tmp17
751  REAL(kind=4) :: tmp_ad17
752  REAL(kind=4) :: tmp18
753  REAL(kind=4) :: tmp_ad18
754  REAL(kind=4) :: tmp19
755  REAL(kind=4) :: tmp_ad19
756  REAL(kind=4) :: tmp20
757  REAL(kind=4) :: tmp_ad20
758  REAL(kind=4) :: tmp21
759  REAL(kind=4) :: tmp_ad21
760  REAL(kind=4) :: tmp22
761  REAL(kind=4) :: tmp_ad22
762  INTEGER :: branch
763  IF (PRESENT(bgrid)) THEN
764  IF (bgrid) THEN
765  SELECT CASE (fill)
766  CASE (xdir)
767  DO j=1,ng
768  DO i=1,ng
769 !SW Corner
770  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
771  CALL pushcontrol1b(0)
772  ELSE
773  CALL pushcontrol1b(1)
774  END IF
775 !NW Corner
776  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
777  CALL pushcontrol1b(0)
778  ELSE
779  CALL pushcontrol1b(1)
780  END IF
781 !SE Corner
782  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
783  CALL pushcontrol1b(0)
784  ELSE
785  CALL pushcontrol1b(1)
786  END IF
787 !NE Corner
788  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
789  CALL pushcontrol1b(1)
790  ELSE
791  CALL pushcontrol1b(0)
792  END IF
793  END DO
794  END DO
795  DO j=ng,1,-1
796  DO i=ng,1,-1
797  CALL popcontrol1b(branch)
798  IF (branch .NE. 0) THEN
799  tmp_ad2 = q_ad(npx+i, npy+j)
800  q_ad(npx+i, npy+j) = 0.0
801  q_ad(npx+j, npy-i) = q_ad(npx+j, npy-i) + tmp_ad2
802  END IF
803  CALL popcontrol1b(branch)
804  IF (branch .EQ. 0) THEN
805  tmp_ad1 = q_ad(npx+i, 1-j)
806  q_ad(npx+i, 1-j) = 0.0
807  q_ad(npx+j, i+1) = q_ad(npx+j, i+1) + tmp_ad1
808  END IF
809  CALL popcontrol1b(branch)
810  IF (branch .EQ. 0) THEN
811  tmp_ad0 = q_ad(1-i, npy+j)
812  q_ad(1-i, npy+j) = 0.0
813  q_ad(1-j, npy-i) = q_ad(1-j, npy-i) + tmp_ad0
814  END IF
815  CALL popcontrol1b(branch)
816  IF (branch .EQ. 0) THEN
817  tmp_ad = q_ad(1-i, 1-j)
818  q_ad(1-i, 1-j) = 0.0
819  q_ad(1-j, i+1) = q_ad(1-j, i+1) + tmp_ad
820  END IF
821  END DO
822  END DO
823  CASE (ydir)
824  DO j=1,ng
825  DO i=1,ng
826 !SW Corner
827  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
828  CALL pushcontrol1b(0)
829  ELSE
830  CALL pushcontrol1b(1)
831  END IF
832 !NW Corner
833  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
834  CALL pushcontrol1b(0)
835  ELSE
836  CALL pushcontrol1b(1)
837  END IF
838 !SE Corner
839  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
840  CALL pushcontrol1b(0)
841  ELSE
842  CALL pushcontrol1b(1)
843  END IF
844 !NE Corner
845  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
846  CALL pushcontrol1b(1)
847  ELSE
848  CALL pushcontrol1b(0)
849  END IF
850  END DO
851  END DO
852  DO j=ng,1,-1
853  DO i=ng,1,-1
854  CALL popcontrol1b(branch)
855  IF (branch .NE. 0) THEN
856  tmp_ad6 = q_ad(npx+j, npy+i)
857  q_ad(npx+j, npy+i) = 0.0
858  q_ad(npx-i, npy+j) = q_ad(npx-i, npy+j) + tmp_ad6
859  END IF
860  CALL popcontrol1b(branch)
861  IF (branch .EQ. 0) THEN
862  tmp_ad5 = q_ad(npx+j, 1-i)
863  q_ad(npx+j, 1-i) = 0.0
864  q_ad(npx-i, 1-j) = q_ad(npx-i, 1-j) + tmp_ad5
865  END IF
866  CALL popcontrol1b(branch)
867  IF (branch .EQ. 0) THEN
868  tmp_ad4 = q_ad(1-j, npy+i)
869  q_ad(1-j, npy+i) = 0.0
870  q_ad(i+1, npy+j) = q_ad(i+1, npy+j) + tmp_ad4
871  END IF
872  CALL popcontrol1b(branch)
873  IF (branch .EQ. 0) THEN
874  tmp_ad3 = q_ad(1-j, 1-i)
875  q_ad(1-j, 1-i) = 0.0
876  q_ad(i+1, 1-j) = q_ad(i+1, 1-j) + tmp_ad3
877  END IF
878  END DO
879  END DO
880  CASE DEFAULT
881  DO j=1,ng
882  DO i=1,ng
883 !SW Corner
884  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
885  CALL pushcontrol1b(0)
886  ELSE
887  CALL pushcontrol1b(1)
888  END IF
889 !NW Corner
890  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
891  CALL pushcontrol1b(0)
892  ELSE
893  CALL pushcontrol1b(1)
894  END IF
895 !SE Corner
896  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
897  CALL pushcontrol1b(0)
898  ELSE
899  CALL pushcontrol1b(1)
900  END IF
901 !NE Corner
902  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
903  CALL pushcontrol1b(1)
904  ELSE
905  CALL pushcontrol1b(0)
906  END IF
907  END DO
908  END DO
909  DO j=ng,1,-1
910  DO i=ng,1,-1
911  CALL popcontrol1b(branch)
912  IF (branch .NE. 0) THEN
913  tmp_ad10 = q_ad(npx+i, npy+j)
914  q_ad(npx+i, npy+j) = 0.0
915  q_ad(npx+j, npy-i) = q_ad(npx+j, npy-i) + tmp_ad10
916  END IF
917  CALL popcontrol1b(branch)
918  IF (branch .EQ. 0) THEN
919  tmp_ad9 = q_ad(npx+i, 1-j)
920  q_ad(npx+i, 1-j) = 0.0
921  q_ad(npx+j, i+1) = q_ad(npx+j, i+1) + tmp_ad9
922  END IF
923  CALL popcontrol1b(branch)
924  IF (branch .EQ. 0) THEN
925  tmp_ad8 = q_ad(1-i, npy+j)
926  q_ad(1-i, npy+j) = 0.0
927  q_ad(1-j, npy-i) = q_ad(1-j, npy-i) + tmp_ad8
928  END IF
929  CALL popcontrol1b(branch)
930  IF (branch .EQ. 0) THEN
931  tmp_ad7 = q_ad(1-i, 1-j)
932  q_ad(1-i, 1-j) = 0.0
933  q_ad(1-j, i+1) = q_ad(1-j, i+1) + tmp_ad7
934  END IF
935  END DO
936  END DO
937  END SELECT
938  END IF
939  ELSE IF (PRESENT(agrid)) THEN
940  IF (agrid) THEN
941  SELECT CASE (fill)
942  CASE (xdir)
943  DO j=1,ng
944  DO i=1,ng
945 !SW Corner
946  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
947  CALL pushcontrol1b(0)
948  ELSE
949  CALL pushcontrol1b(1)
950  END IF
951 !NW Corner
952  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
953  CALL pushcontrol1b(0)
954  ELSE
955  CALL pushcontrol1b(1)
956  END IF
957 !SE Corner
958  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
959  CALL pushcontrol1b(0)
960  ELSE
961  CALL pushcontrol1b(1)
962  END IF
963 !NE Corner
964  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
965  CALL pushcontrol1b(1)
966  ELSE
967  CALL pushcontrol1b(0)
968  END IF
969  END DO
970  END DO
971  DO j=ng,1,-1
972  DO i=ng,1,-1
973  CALL popcontrol1b(branch)
974  IF (branch .NE. 0) THEN
975  tmp_ad14 = q_ad(npx-1+i, npy-1+j)
976  q_ad(npx-1+i, npy-1+j) = 0.0
977  q_ad(npx-1+j, npy-1-i+1) = q_ad(npx-1+j, npy-1-i+1) + &
978 & tmp_ad14
979  END IF
980  CALL popcontrol1b(branch)
981  IF (branch .EQ. 0) THEN
982  tmp_ad13 = q_ad(npx-1+i, 1-j)
983  q_ad(npx-1+i, 1-j) = 0.0
984  q_ad(npx-1+j, i) = q_ad(npx-1+j, i) + tmp_ad13
985  END IF
986  CALL popcontrol1b(branch)
987  IF (branch .EQ. 0) THEN
988  tmp_ad12 = q_ad(1-i, npy-1+j)
989  q_ad(1-i, npy-1+j) = 0.0
990  q_ad(1-j, npy-1-i+1) = q_ad(1-j, npy-1-i+1) + tmp_ad12
991  END IF
992  CALL popcontrol1b(branch)
993  IF (branch .EQ. 0) THEN
994  tmp_ad11 = q_ad(1-i, 1-j)
995  q_ad(1-i, 1-j) = 0.0
996  q_ad(1-j, i) = q_ad(1-j, i) + tmp_ad11
997  END IF
998  END DO
999  END DO
1000  CASE (ydir)
1001  DO j=1,ng
1002  DO i=1,ng
1003 !SW Corner
1004  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1005  CALL pushcontrol1b(0)
1006  ELSE
1007  CALL pushcontrol1b(1)
1008  END IF
1009 !NW Corner
1010  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1011  CALL pushcontrol1b(0)
1012  ELSE
1013  CALL pushcontrol1b(1)
1014  END IF
1015 !SE Corner
1016  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1017  CALL pushcontrol1b(0)
1018  ELSE
1019  CALL pushcontrol1b(1)
1020  END IF
1021 !NE Corner
1022  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1023  CALL pushcontrol1b(1)
1024  ELSE
1025  CALL pushcontrol1b(0)
1026  END IF
1027  END DO
1028  END DO
1029  DO j=ng,1,-1
1030  DO i=ng,1,-1
1031  CALL popcontrol1b(branch)
1032  IF (branch .NE. 0) THEN
1033  tmp_ad18 = q_ad(npx-1+j, npy-1+i)
1034  q_ad(npx-1+j, npy-1+i) = 0.0
1035  q_ad(npx-1-i+1, npy-1+j) = q_ad(npx-1-i+1, npy-1+j) + &
1036 & tmp_ad18
1037  END IF
1038  CALL popcontrol1b(branch)
1039  IF (branch .EQ. 0) THEN
1040  tmp_ad17 = q_ad(npx-1+j, 1-i)
1041  q_ad(npx-1+j, 1-i) = 0.0
1042  q_ad(npx-1-i+1, 1-j) = q_ad(npx-1-i+1, 1-j) + tmp_ad17
1043  END IF
1044  CALL popcontrol1b(branch)
1045  IF (branch .EQ. 0) THEN
1046  tmp_ad16 = q_ad(1-j, npy-1+i)
1047  q_ad(1-j, npy-1+i) = 0.0
1048  q_ad(i, npy-1+j) = q_ad(i, npy-1+j) + tmp_ad16
1049  END IF
1050  CALL popcontrol1b(branch)
1051  IF (branch .EQ. 0) THEN
1052  tmp_ad15 = q_ad(1-j, 1-i)
1053  q_ad(1-j, 1-i) = 0.0
1054  q_ad(i, 1-j) = q_ad(i, 1-j) + tmp_ad15
1055  END IF
1056  END DO
1057  END DO
1058  CASE DEFAULT
1059  DO j=1,ng
1060  DO i=1,ng
1061 !SW Corner
1062  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1063  CALL pushcontrol1b(0)
1064  ELSE
1065  CALL pushcontrol1b(1)
1066  END IF
1067 !NW Corner
1068  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1069  CALL pushcontrol1b(0)
1070  ELSE
1071  CALL pushcontrol1b(1)
1072  END IF
1073 !SE Corner
1074  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1075  CALL pushcontrol1b(0)
1076  ELSE
1077  CALL pushcontrol1b(1)
1078  END IF
1079 !NE Corner
1080  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1081  CALL pushcontrol1b(1)
1082  ELSE
1083  CALL pushcontrol1b(0)
1084  END IF
1085  END DO
1086  END DO
1087  DO j=ng,1,-1
1088  DO i=ng,1,-1
1089  CALL popcontrol1b(branch)
1090  IF (branch .NE. 0) THEN
1091  tmp_ad22 = q_ad(npx-1+j, npy-1+i)
1092  q_ad(npx-1+j, npy-1+i) = 0.0
1093  q_ad(npx-1-i+1, npy-1+j) = q_ad(npx-1-i+1, npy-1+j) + &
1094 & tmp_ad22
1095  END IF
1096  CALL popcontrol1b(branch)
1097  IF (branch .EQ. 0) THEN
1098  tmp_ad21 = q_ad(npx-1+j, 1-i)
1099  q_ad(npx-1+j, 1-i) = 0.0
1100  q_ad(npx-1-i+1, 1-j) = q_ad(npx-1-i+1, 1-j) + tmp_ad21
1101  END IF
1102  CALL popcontrol1b(branch)
1103  IF (branch .EQ. 0) THEN
1104  tmp_ad20 = q_ad(1-j, npy-1+i)
1105  q_ad(1-j, npy-1+i) = 0.0
1106  q_ad(i, npy-1+j) = q_ad(i, npy-1+j) + tmp_ad20
1107  END IF
1108  CALL popcontrol1b(branch)
1109  IF (branch .EQ. 0) THEN
1110  tmp_ad19 = q_ad(1-j, 1-i)
1111  q_ad(1-j, 1-i) = 0.0
1112  q_ad(i, 1-j) = q_ad(i, 1-j) + tmp_ad19
1113  END IF
1114  END DO
1115  END DO
1116  END SELECT
1117  END IF
1118  END IF
1119  END SUBROUTINE fill_corners_2d_r4_adm
1120 
1121  SUBROUTINE fill_corners_2d_r8_adm(q, q_ad, npx, npy, fill, agrid, &
1122 & bgrid)
1123  IMPLICIT NONE
1124  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: q
1125  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: q_ad
1126  INTEGER, INTENT(IN) :: npx, npy
1127 ! X-Dir or Y-Dir
1128  INTEGER, INTENT(IN) :: fill
1129  LOGICAL, OPTIONAL, INTENT(IN) :: agrid, bgrid
1130  INTEGER :: i, j
1131  INTRINSIC PRESENT
1132  REAL(kind=8) :: tmp
1133  REAL(kind=8) :: tmp_ad
1134  REAL(kind=8) :: tmp0
1135  REAL(kind=8) :: tmp_ad0
1136  REAL(kind=8) :: tmp1
1137  REAL(kind=8) :: tmp_ad1
1138  REAL(kind=8) :: tmp2
1139  REAL(kind=8) :: tmp_ad2
1140  REAL(kind=8) :: tmp3
1141  REAL(kind=8) :: tmp_ad3
1142  REAL(kind=8) :: tmp4
1143  REAL(kind=8) :: tmp_ad4
1144  REAL(kind=8) :: tmp5
1145  REAL(kind=8) :: tmp_ad5
1146  REAL(kind=8) :: tmp6
1147  REAL(kind=8) :: tmp_ad6
1148  REAL(kind=8) :: tmp7
1149  REAL(kind=8) :: tmp_ad7
1150  REAL(kind=8) :: tmp8
1151  REAL(kind=8) :: tmp_ad8
1152  REAL(kind=8) :: tmp9
1153  REAL(kind=8) :: tmp_ad9
1154  REAL(kind=8) :: tmp10
1155  REAL(kind=8) :: tmp_ad10
1156  REAL(kind=8) :: tmp11
1157  REAL(kind=8) :: tmp_ad11
1158  REAL(kind=8) :: tmp12
1159  REAL(kind=8) :: tmp_ad12
1160  REAL(kind=8) :: tmp13
1161  REAL(kind=8) :: tmp_ad13
1162  REAL(kind=8) :: tmp14
1163  REAL(kind=8) :: tmp_ad14
1164  REAL(kind=8) :: tmp15
1165  REAL(kind=8) :: tmp_ad15
1166  REAL(kind=8) :: tmp16
1167  REAL(kind=8) :: tmp_ad16
1168  REAL(kind=8) :: tmp17
1169  REAL(kind=8) :: tmp_ad17
1170  REAL(kind=8) :: tmp18
1171  REAL(kind=8) :: tmp_ad18
1172  REAL(kind=8) :: tmp19
1173  REAL(kind=8) :: tmp_ad19
1174  REAL(kind=8) :: tmp20
1175  REAL(kind=8) :: tmp_ad20
1176  REAL(kind=8) :: tmp21
1177  REAL(kind=8) :: tmp_ad21
1178  REAL(kind=8) :: tmp22
1179  REAL(kind=8) :: tmp_ad22
1180  INTEGER :: branch
1181  IF (PRESENT(bgrid)) THEN
1182  IF (bgrid) THEN
1183  SELECT CASE (fill)
1184  CASE (xdir)
1185  DO j=1,ng
1186  DO i=1,ng
1187 !SW Corner
1188  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1189  CALL pushcontrol1b(0)
1190  ELSE
1191  CALL pushcontrol1b(1)
1192  END IF
1193 !NW Corner
1194  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1195  CALL pushcontrol1b(0)
1196  ELSE
1197  CALL pushcontrol1b(1)
1198  END IF
1199 !SE Corner
1200  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1201  CALL pushcontrol1b(0)
1202  ELSE
1203  CALL pushcontrol1b(1)
1204  END IF
1205 !NE Corner
1206  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1207  CALL pushcontrol1b(1)
1208  ELSE
1209  CALL pushcontrol1b(0)
1210  END IF
1211  END DO
1212  END DO
1213  DO j=ng,1,-1
1214  DO i=ng,1,-1
1215  CALL popcontrol1b(branch)
1216  IF (branch .NE. 0) THEN
1217  tmp_ad2 = q_ad(npx+i, npy+j)
1218  q_ad(npx+i, npy+j) = 0.0
1219  q_ad(npx+j, npy-i) = q_ad(npx+j, npy-i) + tmp_ad2
1220  END IF
1221  CALL popcontrol1b(branch)
1222  IF (branch .EQ. 0) THEN
1223  tmp_ad1 = q_ad(npx+i, 1-j)
1224  q_ad(npx+i, 1-j) = 0.0
1225  q_ad(npx+j, i+1) = q_ad(npx+j, i+1) + tmp_ad1
1226  END IF
1227  CALL popcontrol1b(branch)
1228  IF (branch .EQ. 0) THEN
1229  tmp_ad0 = q_ad(1-i, npy+j)
1230  q_ad(1-i, npy+j) = 0.0
1231  q_ad(1-j, npy-i) = q_ad(1-j, npy-i) + tmp_ad0
1232  END IF
1233  CALL popcontrol1b(branch)
1234  IF (branch .EQ. 0) THEN
1235  tmp_ad = q_ad(1-i, 1-j)
1236  q_ad(1-i, 1-j) = 0.0
1237  q_ad(1-j, i+1) = q_ad(1-j, i+1) + tmp_ad
1238  END IF
1239  END DO
1240  END DO
1241  CASE (ydir)
1242  DO j=1,ng
1243  DO i=1,ng
1244 !SW Corner
1245  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1246  CALL pushcontrol1b(0)
1247  ELSE
1248  CALL pushcontrol1b(1)
1249  END IF
1250 !NW Corner
1251  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1252  CALL pushcontrol1b(0)
1253  ELSE
1254  CALL pushcontrol1b(1)
1255  END IF
1256 !SE Corner
1257  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1258  CALL pushcontrol1b(0)
1259  ELSE
1260  CALL pushcontrol1b(1)
1261  END IF
1262 !NE Corner
1263  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1264  CALL pushcontrol1b(1)
1265  ELSE
1266  CALL pushcontrol1b(0)
1267  END IF
1268  END DO
1269  END DO
1270  DO j=ng,1,-1
1271  DO i=ng,1,-1
1272  CALL popcontrol1b(branch)
1273  IF (branch .NE. 0) THEN
1274  tmp_ad6 = q_ad(npx+j, npy+i)
1275  q_ad(npx+j, npy+i) = 0.0
1276  q_ad(npx-i, npy+j) = q_ad(npx-i, npy+j) + tmp_ad6
1277  END IF
1278  CALL popcontrol1b(branch)
1279  IF (branch .EQ. 0) THEN
1280  tmp_ad5 = q_ad(npx+j, 1-i)
1281  q_ad(npx+j, 1-i) = 0.0
1282  q_ad(npx-i, 1-j) = q_ad(npx-i, 1-j) + tmp_ad5
1283  END IF
1284  CALL popcontrol1b(branch)
1285  IF (branch .EQ. 0) THEN
1286  tmp_ad4 = q_ad(1-j, npy+i)
1287  q_ad(1-j, npy+i) = 0.0
1288  q_ad(i+1, npy+j) = q_ad(i+1, npy+j) + tmp_ad4
1289  END IF
1290  CALL popcontrol1b(branch)
1291  IF (branch .EQ. 0) THEN
1292  tmp_ad3 = q_ad(1-j, 1-i)
1293  q_ad(1-j, 1-i) = 0.0
1294  q_ad(i+1, 1-j) = q_ad(i+1, 1-j) + tmp_ad3
1295  END IF
1296  END DO
1297  END DO
1298  CASE DEFAULT
1299  DO j=1,ng
1300  DO i=1,ng
1301 !SW Corner
1302  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1303  CALL pushcontrol1b(0)
1304  ELSE
1305  CALL pushcontrol1b(1)
1306  END IF
1307 !NW Corner
1308  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1309  CALL pushcontrol1b(0)
1310  ELSE
1311  CALL pushcontrol1b(1)
1312  END IF
1313 !SE Corner
1314  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1315  CALL pushcontrol1b(0)
1316  ELSE
1317  CALL pushcontrol1b(1)
1318  END IF
1319 !NE Corner
1320  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1321  CALL pushcontrol1b(1)
1322  ELSE
1323  CALL pushcontrol1b(0)
1324  END IF
1325  END DO
1326  END DO
1327  DO j=ng,1,-1
1328  DO i=ng,1,-1
1329  CALL popcontrol1b(branch)
1330  IF (branch .NE. 0) THEN
1331  tmp_ad10 = q_ad(npx+i, npy+j)
1332  q_ad(npx+i, npy+j) = 0.0
1333  q_ad(npx+j, npy-i) = q_ad(npx+j, npy-i) + tmp_ad10
1334  END IF
1335  CALL popcontrol1b(branch)
1336  IF (branch .EQ. 0) THEN
1337  tmp_ad9 = q_ad(npx+i, 1-j)
1338  q_ad(npx+i, 1-j) = 0.0
1339  q_ad(npx+j, i+1) = q_ad(npx+j, i+1) + tmp_ad9
1340  END IF
1341  CALL popcontrol1b(branch)
1342  IF (branch .EQ. 0) THEN
1343  tmp_ad8 = q_ad(1-i, npy+j)
1344  q_ad(1-i, npy+j) = 0.0
1345  q_ad(1-j, npy-i) = q_ad(1-j, npy-i) + tmp_ad8
1346  END IF
1347  CALL popcontrol1b(branch)
1348  IF (branch .EQ. 0) THEN
1349  tmp_ad7 = q_ad(1-i, 1-j)
1350  q_ad(1-i, 1-j) = 0.0
1351  q_ad(1-j, i+1) = q_ad(1-j, i+1) + tmp_ad7
1352  END IF
1353  END DO
1354  END DO
1355  END SELECT
1356  END IF
1357  ELSE IF (PRESENT(agrid)) THEN
1358  IF (agrid) THEN
1359  SELECT CASE (fill)
1360  CASE (xdir)
1361  DO j=1,ng
1362  DO i=1,ng
1363 !SW Corner
1364  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1365  CALL pushcontrol1b(0)
1366  ELSE
1367  CALL pushcontrol1b(1)
1368  END IF
1369 !NW Corner
1370  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1371  CALL pushcontrol1b(0)
1372  ELSE
1373  CALL pushcontrol1b(1)
1374  END IF
1375 !SE Corner
1376  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1377  CALL pushcontrol1b(0)
1378  ELSE
1379  CALL pushcontrol1b(1)
1380  END IF
1381 !NE Corner
1382  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1383  CALL pushcontrol1b(1)
1384  ELSE
1385  CALL pushcontrol1b(0)
1386  END IF
1387  END DO
1388  END DO
1389  DO j=ng,1,-1
1390  DO i=ng,1,-1
1391  CALL popcontrol1b(branch)
1392  IF (branch .NE. 0) THEN
1393  tmp_ad14 = q_ad(npx-1+i, npy-1+j)
1394  q_ad(npx-1+i, npy-1+j) = 0.0
1395  q_ad(npx-1+j, npy-1-i+1) = q_ad(npx-1+j, npy-1-i+1) + &
1396 & tmp_ad14
1397  END IF
1398  CALL popcontrol1b(branch)
1399  IF (branch .EQ. 0) THEN
1400  tmp_ad13 = q_ad(npx-1+i, 1-j)
1401  q_ad(npx-1+i, 1-j) = 0.0
1402  q_ad(npx-1+j, i) = q_ad(npx-1+j, i) + tmp_ad13
1403  END IF
1404  CALL popcontrol1b(branch)
1405  IF (branch .EQ. 0) THEN
1406  tmp_ad12 = q_ad(1-i, npy-1+j)
1407  q_ad(1-i, npy-1+j) = 0.0
1408  q_ad(1-j, npy-1-i+1) = q_ad(1-j, npy-1-i+1) + tmp_ad12
1409  END IF
1410  CALL popcontrol1b(branch)
1411  IF (branch .EQ. 0) THEN
1412  tmp_ad11 = q_ad(1-i, 1-j)
1413  q_ad(1-i, 1-j) = 0.0
1414  q_ad(1-j, i) = q_ad(1-j, i) + tmp_ad11
1415  END IF
1416  END DO
1417  END DO
1418  CASE (ydir)
1419  DO j=1,ng
1420  DO i=1,ng
1421 !SW Corner
1422  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1423  CALL pushcontrol1b(0)
1424  ELSE
1425  CALL pushcontrol1b(1)
1426  END IF
1427 !NW Corner
1428  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1429  CALL pushcontrol1b(0)
1430  ELSE
1431  CALL pushcontrol1b(1)
1432  END IF
1433 !SE Corner
1434  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1435  CALL pushcontrol1b(0)
1436  ELSE
1437  CALL pushcontrol1b(1)
1438  END IF
1439 !NE Corner
1440  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1441  CALL pushcontrol1b(1)
1442  ELSE
1443  CALL pushcontrol1b(0)
1444  END IF
1445  END DO
1446  END DO
1447  DO j=ng,1,-1
1448  DO i=ng,1,-1
1449  CALL popcontrol1b(branch)
1450  IF (branch .NE. 0) THEN
1451  tmp_ad18 = q_ad(npx-1+j, npy-1+i)
1452  q_ad(npx-1+j, npy-1+i) = 0.0
1453  q_ad(npx-1-i+1, npy-1+j) = q_ad(npx-1-i+1, npy-1+j) + &
1454 & tmp_ad18
1455  END IF
1456  CALL popcontrol1b(branch)
1457  IF (branch .EQ. 0) THEN
1458  tmp_ad17 = q_ad(npx-1+j, 1-i)
1459  q_ad(npx-1+j, 1-i) = 0.0
1460  q_ad(npx-1-i+1, 1-j) = q_ad(npx-1-i+1, 1-j) + tmp_ad17
1461  END IF
1462  CALL popcontrol1b(branch)
1463  IF (branch .EQ. 0) THEN
1464  tmp_ad16 = q_ad(1-j, npy-1+i)
1465  q_ad(1-j, npy-1+i) = 0.0
1466  q_ad(i, npy-1+j) = q_ad(i, npy-1+j) + tmp_ad16
1467  END IF
1468  CALL popcontrol1b(branch)
1469  IF (branch .EQ. 0) THEN
1470  tmp_ad15 = q_ad(1-j, 1-i)
1471  q_ad(1-j, 1-i) = 0.0
1472  q_ad(i, 1-j) = q_ad(i, 1-j) + tmp_ad15
1473  END IF
1474  END DO
1475  END DO
1476  CASE DEFAULT
1477  DO j=1,ng
1478  DO i=1,ng
1479 !SW Corner
1480  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1481  CALL pushcontrol1b(0)
1482  ELSE
1483  CALL pushcontrol1b(1)
1484  END IF
1485 !NW Corner
1486  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1487  CALL pushcontrol1b(0)
1488  ELSE
1489  CALL pushcontrol1b(1)
1490  END IF
1491 !SE Corner
1492  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1493  CALL pushcontrol1b(0)
1494  ELSE
1495  CALL pushcontrol1b(1)
1496  END IF
1497 !NE Corner
1498  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1499  CALL pushcontrol1b(1)
1500  ELSE
1501  CALL pushcontrol1b(0)
1502  END IF
1503  END DO
1504  END DO
1505  DO j=ng,1,-1
1506  DO i=ng,1,-1
1507  CALL popcontrol1b(branch)
1508  IF (branch .NE. 0) THEN
1509  tmp_ad22 = q_ad(npx-1+j, npy-1+i)
1510  q_ad(npx-1+j, npy-1+i) = 0.0
1511  q_ad(npx-1-i+1, npy-1+j) = q_ad(npx-1-i+1, npy-1+j) + &
1512 & tmp_ad22
1513  END IF
1514  CALL popcontrol1b(branch)
1515  IF (branch .EQ. 0) THEN
1516  tmp_ad21 = q_ad(npx-1+j, 1-i)
1517  q_ad(npx-1+j, 1-i) = 0.0
1518  q_ad(npx-1-i+1, 1-j) = q_ad(npx-1-i+1, 1-j) + tmp_ad21
1519  END IF
1520  CALL popcontrol1b(branch)
1521  IF (branch .EQ. 0) THEN
1522  tmp_ad20 = q_ad(1-j, npy-1+i)
1523  q_ad(1-j, npy-1+i) = 0.0
1524  q_ad(i, npy-1+j) = q_ad(i, npy-1+j) + tmp_ad20
1525  END IF
1526  CALL popcontrol1b(branch)
1527  IF (branch .EQ. 0) THEN
1528  tmp_ad19 = q_ad(1-j, 1-i)
1529  q_ad(1-j, 1-i) = 0.0
1530  q_ad(i, 1-j) = q_ad(i, 1-j) + tmp_ad19
1531  END IF
1532  END DO
1533  END DO
1534  END SELECT
1535  END IF
1536  END IF
1537  END SUBROUTINE fill_corners_2d_r8_adm
1538 
1539  SUBROUTINE fill_corners_xy_2d_r4_adm(x, x_ad, y, y_ad, npx, npy, dgrid&
1540 & , agrid, cgrid, vector)
1541  IMPLICIT NONE
1542 !(isd:ied ,jsd:jed+1)
1543  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1544  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1545 !(isd:ied+1,jsd:jed )
1546  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1547  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1548  INTEGER, INTENT(IN) :: npx, npy
1549  LOGICAL, OPTIONAL, INTENT(IN) :: dgrid, agrid, cgrid, vector
1550  INTEGER :: i, j
1551  REAL(kind=4) :: mysign
1552  INTRINSIC PRESENT
1553  INTEGER :: branch
1554  mysign = 1.0
1555  IF (PRESENT(vector)) THEN
1556  IF (vector) THEN
1557  CALL pushcontrol1b(0)
1558  mysign = -1.0
1559  ELSE
1560  CALL pushcontrol1b(0)
1561  END IF
1562  ELSE
1563  CALL pushcontrol1b(1)
1564  END IF
1565  IF (PRESENT(dgrid)) THEN
1566  CALL fill_corners_dgrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1567  ELSE IF (PRESENT(cgrid)) THEN
1568  CALL fill_corners_cgrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1569  ELSE IF (PRESENT(agrid)) THEN
1570  CALL fill_corners_agrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1571  ELSE
1572  CALL fill_corners_agrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1573  END IF
1574  CALL popcontrol1b(branch)
1575  END SUBROUTINE fill_corners_xy_2d_r4_adm
1576 
1577  SUBROUTINE fill_corners_xy_2d_r8_adm(x, x_ad, y, y_ad, npx, npy, dgrid&
1578 & , agrid, cgrid, vector)
1579  IMPLICIT NONE
1580 !(isd:ied ,jsd:jed+1)
1581  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1582  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1583 !(isd:ied+1,jsd:jed )
1584  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1585  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1586  INTEGER, INTENT(IN) :: npx, npy
1587  LOGICAL, OPTIONAL, INTENT(IN) :: dgrid, agrid, cgrid, vector
1588  INTEGER :: i, j
1589  REAL(kind=8) :: mysign
1590  INTRINSIC PRESENT
1591  INTEGER :: branch
1592  mysign = 1.0
1593  IF (PRESENT(vector)) THEN
1594  IF (vector) THEN
1595  CALL pushcontrol1b(0)
1596  mysign = -1.0
1597  ELSE
1598  CALL pushcontrol1b(0)
1599  END IF
1600  ELSE
1601  CALL pushcontrol1b(1)
1602  END IF
1603  IF (PRESENT(dgrid)) THEN
1604  CALL fill_corners_dgrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1605  ELSE IF (PRESENT(cgrid)) THEN
1606  CALL fill_corners_cgrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1607  ELSE IF (PRESENT(agrid)) THEN
1608  CALL fill_corners_agrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1609  ELSE
1610  CALL fill_corners_agrid_adm(x, x_ad, y, y_ad, npx, npy, mysign)
1611  END IF
1612  CALL popcontrol1b(branch)
1613  END SUBROUTINE fill_corners_xy_2d_r8_adm
1614 
1615 ! fill_corners_agrid_adm
1616 ! ----------------------
1617 
1618  SUBROUTINE fill_corners_agrid_r4_adm(x, x_ad, y, y_ad, npx, npy, &
1619 & mysign)
1620  IMPLICIT NONE
1621  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1622  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1623  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1624  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1625  INTEGER, INTENT(IN) :: npx, npy
1626  REAL(kind=4), INTENT(IN) :: mysign
1627  INTEGER :: i, j
1628  INTEGER :: branch
1629  DO j=1,ng
1630  DO i=1,ng
1631 !SW Corner
1632  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1633  CALL pushcontrol1b(0)
1634  ELSE
1635  CALL pushcontrol1b(1)
1636  END IF
1637 !NW Corner
1638  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1639  CALL pushcontrol1b(0)
1640  ELSE
1641  CALL pushcontrol1b(1)
1642  END IF
1643 !SE Corner
1644  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1645  CALL pushcontrol1b(0)
1646  ELSE
1647  CALL pushcontrol1b(1)
1648  END IF
1649 !NE Corner
1650  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1651  CALL pushcontrol1b(1)
1652  ELSE
1653  CALL pushcontrol1b(0)
1654  END IF
1655  END DO
1656  END DO
1657  DO j=1,ng
1658  DO i=1,ng
1659 !SW Corner
1660  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1661  CALL pushcontrol1b(0)
1662  ELSE
1663  CALL pushcontrol1b(1)
1664  END IF
1665 !NW Corner
1666  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1667  CALL pushcontrol1b(0)
1668  ELSE
1669  CALL pushcontrol1b(1)
1670  END IF
1671 !SE Corner
1672  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1673  CALL pushcontrol1b(0)
1674  ELSE
1675  CALL pushcontrol1b(1)
1676  END IF
1677 !NE Corner
1678  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1679  CALL pushcontrol1b(1)
1680  ELSE
1681  CALL pushcontrol1b(0)
1682  END IF
1683  END DO
1684  END DO
1685  DO j=ng,1,-1
1686  DO i=ng,1,-1
1687  CALL popcontrol1b(branch)
1688  IF (branch .NE. 0) THEN
1689  x_ad(npx-1-i+1, npy-1+j) = x_ad(npx-1-i+1, npy-1+j) + mysign*&
1690 & y_ad(npx-1+j, npy-1+i)
1691  y_ad(npx-1+j, npy-1+i) = 0.0
1692  END IF
1693  CALL popcontrol1b(branch)
1694  IF (branch .EQ. 0) THEN
1695  x_ad(npx-1-i+1, 1-j) = x_ad(npx-1-i+1, 1-j) + y_ad(npx-1+j, 1-&
1696 & i)
1697  y_ad(npx-1+j, 1-i) = 0.0
1698  END IF
1699  CALL popcontrol1b(branch)
1700  IF (branch .EQ. 0) THEN
1701  x_ad(i, npy-1+j) = x_ad(i, npy-1+j) + y_ad(1-j, npy-1+i)
1702  y_ad(1-j, npy-1+i) = 0.0
1703  END IF
1704  CALL popcontrol1b(branch)
1705  IF (branch .EQ. 0) THEN
1706  x_ad(i, 1-j) = x_ad(i, 1-j) + mysign*y_ad(1-j, 1-i)
1707  y_ad(1-j, 1-i) = 0.0
1708  END IF
1709  END DO
1710  END DO
1711  DO j=ng,1,-1
1712  DO i=ng,1,-1
1713  CALL popcontrol1b(branch)
1714  IF (branch .NE. 0) THEN
1715  y_ad(npx-1+j, npy-1-i+1) = y_ad(npx-1+j, npy-1-i+1) + mysign*&
1716 & x_ad(npx-1+i, npy-1+j)
1717  x_ad(npx-1+i, npy-1+j) = 0.0
1718  END IF
1719  CALL popcontrol1b(branch)
1720  IF (branch .EQ. 0) THEN
1721  y_ad(npx-1+j, i) = y_ad(npx-1+j, i) + x_ad(npx-1+i, 1-j)
1722  x_ad(npx-1+i, 1-j) = 0.0
1723  END IF
1724  CALL popcontrol1b(branch)
1725  IF (branch .EQ. 0) THEN
1726  y_ad(1-j, npy-1-i+1) = y_ad(1-j, npy-1-i+1) + x_ad(1-i, npy-1+&
1727 & j)
1728  x_ad(1-i, npy-1+j) = 0.0
1729  END IF
1730  CALL popcontrol1b(branch)
1731  IF (branch .EQ. 0) THEN
1732  y_ad(1-j, i) = y_ad(1-j, i) + mysign*x_ad(1-i, 1-j)
1733  x_ad(1-i, 1-j) = 0.0
1734  END IF
1735  END DO
1736  END DO
1737  END SUBROUTINE fill_corners_agrid_r4_adm
1738 
1739  SUBROUTINE fill_corners_agrid_r8_adm(x, x_ad, y, y_ad, npx, npy, &
1740 & mysign)
1741  IMPLICIT NONE
1742  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1743  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1744  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1745  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1746  INTEGER, INTENT(IN) :: npx, npy
1747  REAL(kind=8), INTENT(IN) :: mysign
1748  INTEGER :: i, j
1749  INTEGER :: branch
1750  DO j=1,ng
1751  DO i=1,ng
1752 !SW Corner
1753  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1754  CALL pushcontrol1b(0)
1755  ELSE
1756  CALL pushcontrol1b(1)
1757  END IF
1758 !NW Corner
1759  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1760  CALL pushcontrol1b(0)
1761  ELSE
1762  CALL pushcontrol1b(1)
1763  END IF
1764 !SE Corner
1765  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1766  CALL pushcontrol1b(0)
1767  ELSE
1768  CALL pushcontrol1b(1)
1769  END IF
1770 !NE Corner
1771  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1772  CALL pushcontrol1b(1)
1773  ELSE
1774  CALL pushcontrol1b(0)
1775  END IF
1776  END DO
1777  END DO
1778  DO j=1,ng
1779  DO i=1,ng
1780 !SW Corner
1781  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1782  CALL pushcontrol1b(0)
1783  ELSE
1784  CALL pushcontrol1b(1)
1785  END IF
1786 !NW Corner
1787  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
1788  CALL pushcontrol1b(0)
1789  ELSE
1790  CALL pushcontrol1b(1)
1791  END IF
1792 !SE Corner
1793  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
1794  CALL pushcontrol1b(0)
1795  ELSE
1796  CALL pushcontrol1b(1)
1797  END IF
1798 !NE Corner
1799  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
1800  CALL pushcontrol1b(1)
1801  ELSE
1802  CALL pushcontrol1b(0)
1803  END IF
1804  END DO
1805  END DO
1806  DO j=ng,1,-1
1807  DO i=ng,1,-1
1808  CALL popcontrol1b(branch)
1809  IF (branch .NE. 0) THEN
1810  x_ad(npx-1-i+1, npy-1+j) = x_ad(npx-1-i+1, npy-1+j) + mysign*&
1811 & y_ad(npx-1+j, npy-1+i)
1812  y_ad(npx-1+j, npy-1+i) = 0.0
1813  END IF
1814  CALL popcontrol1b(branch)
1815  IF (branch .EQ. 0) THEN
1816  x_ad(npx-1-i+1, 1-j) = x_ad(npx-1-i+1, 1-j) + y_ad(npx-1+j, 1-&
1817 & i)
1818  y_ad(npx-1+j, 1-i) = 0.0
1819  END IF
1820  CALL popcontrol1b(branch)
1821  IF (branch .EQ. 0) THEN
1822  x_ad(i, npy-1+j) = x_ad(i, npy-1+j) + y_ad(1-j, npy-1+i)
1823  y_ad(1-j, npy-1+i) = 0.0
1824  END IF
1825  CALL popcontrol1b(branch)
1826  IF (branch .EQ. 0) THEN
1827  x_ad(i, 1-j) = x_ad(i, 1-j) + mysign*y_ad(1-j, 1-i)
1828  y_ad(1-j, 1-i) = 0.0
1829  END IF
1830  END DO
1831  END DO
1832  DO j=ng,1,-1
1833  DO i=ng,1,-1
1834  CALL popcontrol1b(branch)
1835  IF (branch .NE. 0) THEN
1836  y_ad(npx-1+j, npy-1-i+1) = y_ad(npx-1+j, npy-1-i+1) + mysign*&
1837 & x_ad(npx-1+i, npy-1+j)
1838  x_ad(npx-1+i, npy-1+j) = 0.0
1839  END IF
1840  CALL popcontrol1b(branch)
1841  IF (branch .EQ. 0) THEN
1842  y_ad(npx-1+j, i) = y_ad(npx-1+j, i) + x_ad(npx-1+i, 1-j)
1843  x_ad(npx-1+i, 1-j) = 0.0
1844  END IF
1845  CALL popcontrol1b(branch)
1846  IF (branch .EQ. 0) THEN
1847  y_ad(1-j, npy-1-i+1) = y_ad(1-j, npy-1-i+1) + x_ad(1-i, npy-1+&
1848 & j)
1849  x_ad(1-i, npy-1+j) = 0.0
1850  END IF
1851  CALL popcontrol1b(branch)
1852  IF (branch .EQ. 0) THEN
1853  y_ad(1-j, i) = y_ad(1-j, i) + mysign*x_ad(1-i, 1-j)
1854  x_ad(1-i, 1-j) = 0.0
1855  END IF
1856  END DO
1857  END DO
1858  END SUBROUTINE fill_corners_agrid_r8_adm
1859 
1860 ! fill_corners_cgrid_adm
1861 ! ----------------------
1862 
1863  SUBROUTINE fill_corners_cgrid_r4_adm(x, x_ad, y, y_ad, npx, npy, &
1864 & mysign)
1865  IMPLICIT NONE
1866  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1867  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1868  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1869  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1870  INTEGER, INTENT(IN) :: npx, npy
1871  REAL(kind=4), INTENT(IN) :: mysign
1872  INTEGER :: i, j
1873  INTEGER :: branch
1874  DO j=1,ng
1875  DO i=1,ng
1876 !SW Corner
1877  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1878  CALL pushcontrol1b(0)
1879  ELSE
1880  CALL pushcontrol1b(1)
1881  END IF
1882 !NW Corner
1883  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
1884  CALL pushcontrol1b(0)
1885  ELSE
1886  CALL pushcontrol1b(1)
1887  END IF
1888 !SE Corner
1889  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
1890  CALL pushcontrol1b(0)
1891  ELSE
1892  CALL pushcontrol1b(1)
1893  END IF
1894 !NE Corner
1895  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
1896  CALL pushcontrol1b(1)
1897  ELSE
1898  CALL pushcontrol1b(0)
1899  END IF
1900  END DO
1901  END DO
1902  DO j=1,ng
1903  DO i=1,ng
1904 !SW Corner
1905  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1906  CALL pushcontrol1b(0)
1907  ELSE
1908  CALL pushcontrol1b(1)
1909  END IF
1910 !NW Corner
1911  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
1912  CALL pushcontrol1b(0)
1913  ELSE
1914  CALL pushcontrol1b(1)
1915  END IF
1916 !SE Corner
1917  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
1918  CALL pushcontrol1b(0)
1919  ELSE
1920  CALL pushcontrol1b(1)
1921  END IF
1922 !NE Corner
1923  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
1924  CALL pushcontrol1b(1)
1925  ELSE
1926  CALL pushcontrol1b(0)
1927  END IF
1928  END DO
1929  END DO
1930  DO j=ng,1,-1
1931  DO i=ng,1,-1
1932  CALL popcontrol1b(branch)
1933  IF (branch .NE. 0) THEN
1934  x_ad(npx+j, npy-i) = x_ad(npx+j, npy-i) + y_ad(npx-1+i, npy+j)
1935  y_ad(npx-1+i, npy+j) = 0.0
1936  END IF
1937  CALL popcontrol1b(branch)
1938  IF (branch .EQ. 0) THEN
1939  x_ad(npx+j, i) = x_ad(npx+j, i) + mysign*y_ad(npx-1+i, 1-j)
1940  y_ad(npx-1+i, 1-j) = 0.0
1941  END IF
1942  CALL popcontrol1b(branch)
1943  IF (branch .EQ. 0) THEN
1944  x_ad(1-j, npy-i) = x_ad(1-j, npy-i) + mysign*y_ad(1-i, npy+j)
1945  y_ad(1-i, npy+j) = 0.0
1946  END IF
1947  CALL popcontrol1b(branch)
1948  IF (branch .EQ. 0) THEN
1949  x_ad(1-j, i) = x_ad(1-j, i) + y_ad(1-i, 1-j)
1950  y_ad(1-i, 1-j) = 0.0
1951  END IF
1952  END DO
1953  END DO
1954  DO j=ng,1,-1
1955  DO i=ng,1,-1
1956  CALL popcontrol1b(branch)
1957  IF (branch .NE. 0) THEN
1958  y_ad(npx-j, npy+i) = y_ad(npx-j, npy+i) + x_ad(npx+i, npy-1+j)
1959  x_ad(npx+i, npy-1+j) = 0.0
1960  END IF
1961  CALL popcontrol1b(branch)
1962  IF (branch .EQ. 0) THEN
1963  y_ad(npx-j, 1-i) = y_ad(npx-j, 1-i) + mysign*x_ad(npx+i, 1-j)
1964  x_ad(npx+i, 1-j) = 0.0
1965  END IF
1966  CALL popcontrol1b(branch)
1967  IF (branch .EQ. 0) THEN
1968  y_ad(j, npy+i) = y_ad(j, npy+i) + mysign*x_ad(1-i, npy-1+j)
1969  x_ad(1-i, npy-1+j) = 0.0
1970  END IF
1971  CALL popcontrol1b(branch)
1972  IF (branch .EQ. 0) THEN
1973  y_ad(j, 1-i) = y_ad(j, 1-i) + x_ad(1-i, 1-j)
1974  x_ad(1-i, 1-j) = 0.0
1975  END IF
1976  END DO
1977  END DO
1978  END SUBROUTINE fill_corners_cgrid_r4_adm
1979 
1980  SUBROUTINE fill_corners_cgrid_r8_adm(x, x_ad, y, y_ad, npx, npy, &
1981 & mysign)
1982  IMPLICIT NONE
1983  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
1984  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
1985  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
1986  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
1987  INTEGER, INTENT(IN) :: npx, npy
1988  REAL(kind=8), INTENT(IN) :: mysign
1989  INTEGER :: i, j
1990  INTEGER :: branch
1991  DO j=1,ng
1992  DO i=1,ng
1993 !SW Corner
1994  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
1995  CALL pushcontrol1b(0)
1996  ELSE
1997  CALL pushcontrol1b(1)
1998  END IF
1999 !NW Corner
2000  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2001  CALL pushcontrol1b(0)
2002  ELSE
2003  CALL pushcontrol1b(1)
2004  END IF
2005 !SE Corner
2006  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2007  CALL pushcontrol1b(0)
2008  ELSE
2009  CALL pushcontrol1b(1)
2010  END IF
2011 !NE Corner
2012  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2013  CALL pushcontrol1b(1)
2014  ELSE
2015  CALL pushcontrol1b(0)
2016  END IF
2017  END DO
2018  END DO
2019  DO j=1,ng
2020  DO i=1,ng
2021 !SW Corner
2022  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
2023  CALL pushcontrol1b(0)
2024  ELSE
2025  CALL pushcontrol1b(1)
2026  END IF
2027 !NW Corner
2028  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2029  CALL pushcontrol1b(0)
2030  ELSE
2031  CALL pushcontrol1b(1)
2032  END IF
2033 !SE Corner
2034  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2035  CALL pushcontrol1b(0)
2036  ELSE
2037  CALL pushcontrol1b(1)
2038  END IF
2039 !NE Corner
2040  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2041  CALL pushcontrol1b(1)
2042  ELSE
2043  CALL pushcontrol1b(0)
2044  END IF
2045  END DO
2046  END DO
2047  DO j=ng,1,-1
2048  DO i=ng,1,-1
2049  CALL popcontrol1b(branch)
2050  IF (branch .NE. 0) THEN
2051  x_ad(npx+j, npy-i) = x_ad(npx+j, npy-i) + y_ad(npx-1+i, npy+j)
2052  y_ad(npx-1+i, npy+j) = 0.0
2053  END IF
2054  CALL popcontrol1b(branch)
2055  IF (branch .EQ. 0) THEN
2056  x_ad(npx+j, i) = x_ad(npx+j, i) + mysign*y_ad(npx-1+i, 1-j)
2057  y_ad(npx-1+i, 1-j) = 0.0
2058  END IF
2059  CALL popcontrol1b(branch)
2060  IF (branch .EQ. 0) THEN
2061  x_ad(1-j, npy-i) = x_ad(1-j, npy-i) + mysign*y_ad(1-i, npy+j)
2062  y_ad(1-i, npy+j) = 0.0
2063  END IF
2064  CALL popcontrol1b(branch)
2065  IF (branch .EQ. 0) THEN
2066  x_ad(1-j, i) = x_ad(1-j, i) + y_ad(1-i, 1-j)
2067  y_ad(1-i, 1-j) = 0.0
2068  END IF
2069  END DO
2070  END DO
2071  DO j=ng,1,-1
2072  DO i=ng,1,-1
2073  CALL popcontrol1b(branch)
2074  IF (branch .NE. 0) THEN
2075  y_ad(npx-j, npy+i) = y_ad(npx-j, npy+i) + x_ad(npx+i, npy-1+j)
2076  x_ad(npx+i, npy-1+j) = 0.0
2077  END IF
2078  CALL popcontrol1b(branch)
2079  IF (branch .EQ. 0) THEN
2080  y_ad(npx-j, 1-i) = y_ad(npx-j, 1-i) + mysign*x_ad(npx+i, 1-j)
2081  x_ad(npx+i, 1-j) = 0.0
2082  END IF
2083  CALL popcontrol1b(branch)
2084  IF (branch .EQ. 0) THEN
2085  y_ad(j, npy+i) = y_ad(j, npy+i) + mysign*x_ad(1-i, npy-1+j)
2086  x_ad(1-i, npy-1+j) = 0.0
2087  END IF
2088  CALL popcontrol1b(branch)
2089  IF (branch .EQ. 0) THEN
2090  y_ad(j, 1-i) = y_ad(j, 1-i) + x_ad(1-i, 1-j)
2091  x_ad(1-i, 1-j) = 0.0
2092  END IF
2093  END DO
2094  END DO
2095  END SUBROUTINE fill_corners_cgrid_r8_adm
2096 
2097 ! fill_corners_dgrid_adm
2098 ! ----------------------
2099 
2100  SUBROUTINE fill_corners_dgrid_r4_adm(x, x_ad, y, y_ad, npx, npy, &
2101 & mysign)
2102  IMPLICIT NONE
2103  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
2104  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
2105  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
2106  REAL(kind=4), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
2107  INTEGER, INTENT(IN) :: npx, npy
2108  REAL(kind=4), INTENT(IN) :: mysign
2109  INTEGER :: i, j
2110  INTEGER :: branch
2111  DO j=1,ng
2112  DO i=1,ng
2113 ! if ((is == 1) .and. (js == 1)) x(1-i ,1-j ) = y(j+1 ,1-i ) !SW Corner
2114 ! if ((is == 1) .and. (je+1==npy)) x(1-i ,npy+j) = mySign*y(j+1 ,npy-1+i) !NW Corner
2115 ! if ((ie+1==npx) .and. (js == 1)) x(npx-1+i,1-j ) = mySign*y(npx-j,1-i ) !SE Corner
2116 ! if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) = y(npx-j,npy-1+i) !NE Corner
2117 !SW Corner
2118  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
2119  CALL pushcontrol1b(0)
2120  ELSE
2121  CALL pushcontrol1b(1)
2122  END IF
2123 !NW Corner
2124  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2125  CALL pushcontrol1b(0)
2126  ELSE
2127  CALL pushcontrol1b(1)
2128  END IF
2129 !SE Corner
2130  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2131  CALL pushcontrol1b(0)
2132  ELSE
2133  CALL pushcontrol1b(1)
2134  END IF
2135 !NE Corner
2136  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2137  CALL pushcontrol1b(1)
2138  ELSE
2139  CALL pushcontrol1b(0)
2140  END IF
2141  END DO
2142  END DO
2143  DO j=1,ng
2144  DO i=1,ng
2145 ! if ((is == 1) .and. (js == 1)) y(1-i ,1-j ) = x(1-j ,i+1 ) !SW Corner
2146 ! if ((is == 1) .and. (je+1==npy)) y(1-i ,npy-1+j) = mySign*x(1-j ,npy-i) !NW Corner
2147 ! if ((ie+1==npx) .and. (js == 1)) y(npx+i ,1-j ) = mySign*x(npx-1+j,i+1 ) !SE Corner
2148 ! if ((ie+1==npx) .and. (je+1==npy)) y(npx+i ,npy-1+j) = x(npx-1+j,npy-i) !NE Corner
2149 !SW Corner
2150  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
2151  CALL pushcontrol1b(0)
2152  ELSE
2153  CALL pushcontrol1b(1)
2154  END IF
2155 !NW Corner
2156  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2157  CALL pushcontrol1b(0)
2158  ELSE
2159  CALL pushcontrol1b(1)
2160  END IF
2161 !SE Corner
2162  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2163  CALL pushcontrol1b(0)
2164  ELSE
2165  CALL pushcontrol1b(1)
2166  END IF
2167 !NE Corner
2168  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2169  CALL pushcontrol1b(1)
2170  ELSE
2171  CALL pushcontrol1b(0)
2172  END IF
2173  END DO
2174  END DO
2175  DO j=ng,1,-1
2176  DO i=ng,1,-1
2177  CALL popcontrol1b(branch)
2178  IF (branch .NE. 0) THEN
2179  x_ad(npx-j, npy+i) = x_ad(npx-j, npy+i) + mysign*y_ad(npx+i, &
2180 & npy-1+j)
2181  y_ad(npx+i, npy-1+j) = 0.0
2182  END IF
2183  CALL popcontrol1b(branch)
2184  IF (branch .EQ. 0) THEN
2185  x_ad(npx-j, 1-i) = x_ad(npx-j, 1-i) + y_ad(npx+i, 1-j)
2186  y_ad(npx+i, 1-j) = 0.0
2187  END IF
2188  CALL popcontrol1b(branch)
2189  IF (branch .EQ. 0) THEN
2190  x_ad(j, npy+i) = x_ad(j, npy+i) + y_ad(1-i, npy-1+j)
2191  y_ad(1-i, npy-1+j) = 0.0
2192  END IF
2193  CALL popcontrol1b(branch)
2194  IF (branch .EQ. 0) THEN
2195  x_ad(j, 1-i) = x_ad(j, 1-i) + mysign*y_ad(1-i, 1-j)
2196  y_ad(1-i, 1-j) = 0.0
2197  END IF
2198  END DO
2199  END DO
2200  DO j=ng,1,-1
2201  DO i=ng,1,-1
2202  CALL popcontrol1b(branch)
2203  IF (branch .NE. 0) THEN
2204  y_ad(npx+j, npy-i) = y_ad(npx+j, npy-i) + mysign*x_ad(npx-1+i&
2205 & , npy+j)
2206  x_ad(npx-1+i, npy+j) = 0.0
2207  END IF
2208  CALL popcontrol1b(branch)
2209  IF (branch .EQ. 0) THEN
2210  y_ad(npx+j, i) = y_ad(npx+j, i) + x_ad(npx-1+i, 1-j)
2211  x_ad(npx-1+i, 1-j) = 0.0
2212  END IF
2213  CALL popcontrol1b(branch)
2214  IF (branch .EQ. 0) THEN
2215  y_ad(1-j, npy-i) = y_ad(1-j, npy-i) + x_ad(1-i, npy+j)
2216  x_ad(1-i, npy+j) = 0.0
2217  END IF
2218  CALL popcontrol1b(branch)
2219  IF (branch .EQ. 0) THEN
2220  y_ad(1-j, i) = y_ad(1-j, i) + mysign*x_ad(1-i, 1-j)
2221  x_ad(1-i, 1-j) = 0.0
2222  END IF
2223  END DO
2224  END DO
2225  END SUBROUTINE fill_corners_dgrid_r4_adm
2226 
2227  SUBROUTINE fill_corners_dgrid_r8_adm(x, x_ad, y, y_ad, npx, npy, &
2228 & mysign)
2229  IMPLICIT NONE
2230  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x
2231  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: x_ad
2232  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y
2233  REAL(kind=8), DIMENSION(isd:, jsd:), INTENT(INOUT) :: y_ad
2234  INTEGER, INTENT(IN) :: npx, npy
2235  REAL(kind=8), INTENT(IN) :: mysign
2236  INTEGER :: i, j
2237  INTEGER :: branch
2238  DO j=1,ng
2239  DO i=1,ng
2240 ! if ((is == 1) .and. (js == 1)) x(1-i ,1-j ) = y(j+1 ,1-i ) !SW Corner
2241 ! if ((is == 1) .and. (je+1==npy)) x(1-i ,npy+j) = mySign*y(j+1 ,npy-1+i) !NW Corner
2242 ! if ((ie+1==npx) .and. (js == 1)) x(npx-1+i,1-j ) = mySign*y(npx-j,1-i ) !SE Corner
2243 ! if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) = y(npx-j,npy-1+i) !NE Corner
2244 !SW Corner
2245  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
2246  CALL pushcontrol1b(0)
2247  ELSE
2248  CALL pushcontrol1b(1)
2249  END IF
2250 !NW Corner
2251  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2252  CALL pushcontrol1b(0)
2253  ELSE
2254  CALL pushcontrol1b(1)
2255  END IF
2256 !SE Corner
2257  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2258  CALL pushcontrol1b(0)
2259  ELSE
2260  CALL pushcontrol1b(1)
2261  END IF
2262 !NE Corner
2263  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2264  CALL pushcontrol1b(1)
2265  ELSE
2266  CALL pushcontrol1b(0)
2267  END IF
2268  END DO
2269  END DO
2270  DO j=1,ng
2271  DO i=1,ng
2272 ! if ((is == 1) .and. (js == 1)) y(1-i ,1-j ) = x(1-j ,i+1 ) !SW Corner
2273 ! if ((is == 1) .and. (je+1==npy)) y(1-i ,npy-1+j) = mySign*x(1-j ,npy-i) !NW Corner
2274 ! if ((ie+1==npx) .and. (js == 1)) y(npx+i ,1-j ) = mySign*x(npx-1+j,i+1 ) !SE Corner
2275 ! if ((ie+1==npx) .and. (je+1==npy)) y(npx+i ,npy-1+j) = x(npx-1+j,npy-i) !NE Corner
2276 !SW Corner
2277  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
2278  CALL pushcontrol1b(0)
2279  ELSE
2280  CALL pushcontrol1b(1)
2281  END IF
2282 !NW Corner
2283  IF (is .EQ. 1 .AND. je + 1 .EQ. npy) THEN
2284  CALL pushcontrol1b(0)
2285  ELSE
2286  CALL pushcontrol1b(1)
2287  END IF
2288 !SE Corner
2289  IF (ie + 1 .EQ. npx .AND. js .EQ. 1) THEN
2290  CALL pushcontrol1b(0)
2291  ELSE
2292  CALL pushcontrol1b(1)
2293  END IF
2294 !NE Corner
2295  IF (ie + 1 .EQ. npx .AND. je + 1 .EQ. npy) THEN
2296  CALL pushcontrol1b(1)
2297  ELSE
2298  CALL pushcontrol1b(0)
2299  END IF
2300  END DO
2301  END DO
2302  DO j=ng,1,-1
2303  DO i=ng,1,-1
2304  CALL popcontrol1b(branch)
2305  IF (branch .NE. 0) THEN
2306  x_ad(npx-j, npy+i) = x_ad(npx-j, npy+i) + mysign*y_ad(npx+i, &
2307 & npy-1+j)
2308  y_ad(npx+i, npy-1+j) = 0.0
2309  END IF
2310  CALL popcontrol1b(branch)
2311  IF (branch .EQ. 0) THEN
2312  x_ad(npx-j, 1-i) = x_ad(npx-j, 1-i) + y_ad(npx+i, 1-j)
2313  y_ad(npx+i, 1-j) = 0.0
2314  END IF
2315  CALL popcontrol1b(branch)
2316  IF (branch .EQ. 0) THEN
2317  x_ad(j, npy+i) = x_ad(j, npy+i) + y_ad(1-i, npy-1+j)
2318  y_ad(1-i, npy-1+j) = 0.0
2319  END IF
2320  CALL popcontrol1b(branch)
2321  IF (branch .EQ. 0) THEN
2322  x_ad(j, 1-i) = x_ad(j, 1-i) + mysign*y_ad(1-i, 1-j)
2323  y_ad(1-i, 1-j) = 0.0
2324  END IF
2325  END DO
2326  END DO
2327  DO j=ng,1,-1
2328  DO i=ng,1,-1
2329  CALL popcontrol1b(branch)
2330  IF (branch .NE. 0) THEN
2331  y_ad(npx+j, npy-i) = y_ad(npx+j, npy-i) + mysign*x_ad(npx-1+i&
2332 & , npy+j)
2333  x_ad(npx-1+i, npy+j) = 0.0
2334  END IF
2335  CALL popcontrol1b(branch)
2336  IF (branch .EQ. 0) THEN
2337  y_ad(npx+j, i) = y_ad(npx+j, i) + x_ad(npx-1+i, 1-j)
2338  x_ad(npx-1+i, 1-j) = 0.0
2339  END IF
2340  CALL popcontrol1b(branch)
2341  IF (branch .EQ. 0) THEN
2342  y_ad(1-j, npy-i) = y_ad(1-j, npy-i) + x_ad(1-i, npy+j)
2343  x_ad(1-i, npy+j) = 0.0
2344  END IF
2345  CALL popcontrol1b(branch)
2346  IF (branch .EQ. 0) THEN
2347  y_ad(1-j, i) = y_ad(1-j, i) + mysign*x_ad(1-i, 1-j)
2348  x_ad(1-i, 1-j) = 0.0
2349  END IF
2350  END DO
2351  END DO
2352  END SUBROUTINE fill_corners_dgrid_r8_adm
2353 
2354 
2355 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2356 !!! MPP_DOMAINS INTERFACES THAT ARE NOT NORMALLY IN FV_MP_MOD !!!
2357 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2358 
2359 
2360 ! mpp_global_sum_adm
2361 ! ------------------
2362 
2363  real(kind=r_grid) function mpp_global_sum_2d_adm(domain, field, field_ad, flags, position, tile_count)
2364 
2365  implicit none
2366  type(domain2d), intent(in) :: domain
2367  real(r_grid), intent(in) :: field(:, :)
2368  real(r_grid), intent(in) :: field_ad(:, :)
2369  integer, intent(in), optional :: flags
2370  integer, intent(in), optional :: position
2371  integer, intent(in), optional :: tile_count
2372 
2373  mpp_global_sum_2d_adm = 0.0
2374 
2375  end function mpp_global_sum_2d_adm
2376 
2377 
2378 ! mpp_update_domains_adm
2379 ! ----------------------
2380 
2381 subroutine mpp_update_domain2d_2d_adm(array, arrayp, domain, flags, complete, position, &
2382  whalo, ehalo, shalo, nhalo, name, tile_count)
2383 
2384  real, dimension(:,:), intent(inout) :: array, arrayp
2385  type(domain2d), intent(inout) :: domain
2386  integer, intent(in), optional :: flags
2387  logical, intent(in), optional :: complete
2388  integer, intent(in), optional :: position
2389  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2390  character(len=*), intent(in), optional :: name
2391  integer, intent(in), optional :: tile_count
2392 
2393  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2394 
2395  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2396 
2397  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2398 
2399 end subroutine mpp_update_domain2d_2d_adm
2400 
2401 subroutine mpp_update_domain2d_3d_adm(array, arrayp, domain, flags, complete, position, &
2402  whalo, ehalo, shalo, nhalo, name, tile_count)
2403 
2404  real, dimension(:,:,:), intent(inout) :: array, arrayp
2405  type(domain2d), intent(inout) :: domain
2406  integer, intent(in), optional :: flags
2407  logical, intent(in), optional :: complete
2408  integer, intent(in), optional :: position
2409  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2410  character(len=*), intent(in), optional :: name
2411  integer, intent(in), optional :: tile_count
2412 
2413  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2414 
2415  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2416 
2417  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2418 
2419 end subroutine mpp_update_domain2d_3d_adm
2420 
2421 subroutine mpp_update_domain2d_4d_adm(array, arrayp, domain, flags, complete, position, &
2422  whalo, ehalo, shalo, nhalo, name, tile_count)
2423 
2424  real, dimension(:,:,:,:), intent(inout) :: array, arrayp
2425  type(domain2d), intent(inout) :: domain
2426  integer, intent(in), optional :: flags
2427  logical, intent(in), optional :: complete
2428  integer, intent(in), optional :: position
2429  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2430  character(len=*), intent(in), optional :: name
2431  integer, intent(in), optional :: tile_count
2432 
2433  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2434  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2435 
2436  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2437 
2438 end subroutine mpp_update_domain2d_4d_adm
2439 
2440 subroutine mpp_update_domain2d_5d_adm(array, arrayp, domain, flags, complete, position, &
2441  whalo, ehalo, shalo, nhalo, name, tile_count)
2442 
2443  real, dimension(:,:,:,:,:), intent(inout) :: array, arrayp
2444  type(domain2d), intent(inout) :: domain
2445  integer, intent(in), optional :: flags
2446  logical, intent(in), optional :: complete
2447  integer, intent(in), optional :: position
2448  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2449  character(len=*), intent(in), optional :: name
2450  integer, intent(in), optional :: tile_count
2451 
2452  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2453 
2454  call mpp_update_domains_ad(arrayp, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2455 
2456  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2457 
2458 end subroutine mpp_update_domain2d_5d_adm
2459 
2460 subroutine mpp_update_domain2d_2dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, &
2461  whalo, ehalo, shalo, nhalo, name, tile_count )
2462 
2463  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt
2464  real, dimension(:,:), intent(inout) :: u_cmptp, v_cmptp
2465  type(domain2d), intent(inout) :: domain
2466  integer, intent(in), optional :: flags, gridtype
2467  logical, intent(in), optional :: complete
2468  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2469  character(len=*), intent(in), optional :: name
2470  integer, intent(in), optional :: tile_count
2471 
2472  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2473 
2474  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
2475  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2476 
2477  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2478 
2479 end subroutine mpp_update_domain2d_2dv_adm
2480 
2481 subroutine mpp_update_domain2d_3dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, &
2482  whalo, ehalo, shalo, nhalo, name, tile_count )
2483 
2484  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt
2485  real, dimension(:,:,:), intent(inout) :: u_cmptp, v_cmptp
2486  type(domain2d), intent(inout) :: domain
2487  integer, intent(in), optional :: flags, gridtype
2488  logical, intent(in), optional :: complete
2489  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2490  character(len=*), intent(in), optional :: name
2491  integer, intent(in), optional :: tile_count
2492 
2493  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2494 
2495  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
2496  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2497 
2498  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2499 
2500 end subroutine mpp_update_domain2d_3dv_adm
2501 
2502 subroutine mpp_update_domain2d_4dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, &
2503  whalo, ehalo, shalo, nhalo, name, tile_count )
2504 
2505  real, dimension(:,:,:,:), intent(inout) :: u_cmpt, v_cmpt
2506  real, dimension(:,:,:,:), intent(inout) :: u_cmptp, v_cmptp
2507  type(domain2d), intent(inout) :: domain
2508  integer, intent(in), optional :: flags, gridtype
2509  logical, intent(in), optional :: complete
2510  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2511  character(len=*), intent(in), optional :: name
2512  integer, intent(in), optional :: tile_count
2513 
2514  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2515 
2516  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
2517  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2518 
2519  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2520 
2521 end subroutine mpp_update_domain2d_4dv_adm
2522 
2523 subroutine mpp_update_domain2d_5dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, &
2524  whalo, ehalo, shalo, nhalo, name, tile_count )
2525 
2526  real, dimension(:,:,:,:,:), intent(inout) :: u_cmpt, v_cmpt
2527  real, dimension(:,:,:,:,:), intent(inout) :: u_cmptp, v_cmptp
2528  type(domain2d), intent(inout) :: domain
2529  integer, intent(in), optional :: flags, gridtype
2530  logical, intent(in), optional :: complete
2531  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
2532  character(len=*), intent(in), optional :: name
2533  integer, intent(in), optional :: tile_count
2534 
2535  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2536 
2537  call mpp_update_domains_ad(u_cmptp, v_cmptp, domain, flags=flags, gridtype=gridtype, &
2538  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
2539 
2540  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2541 
2542 end subroutine mpp_update_domain2d_5dv_adm
2543 
2544 
2545 ! mpp_get_boundary_adm
2546 ! --------------------
2547 
2548  subroutine mpp_get_boundary_2d_adm( array, arrayp, domain, &
2549  ebuffer, sbuffer, wbuffer, nbuffer, &
2550  ebuffer_ad, sbuffer_ad, wbuffer_ad, nbuffer_ad, &
2551  flags, position, complete, tile_count )
2552 
2553  real, dimension(:,:), intent(in) :: array, arrayp
2554  type(domain2d), intent(in) :: domain
2555  real, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:)
2556  real, intent(inout), optional :: ebuffer_ad(:), sbuffer_ad(:), wbuffer_ad(:), nbuffer_ad(:)
2557  integer, intent(in), optional :: flags, position, tile_count
2558  logical, intent(in), optional :: complete
2559 
2560  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2561 
2562  call mpp_get_boundary_ad( arrayp, domain,ebuffer=ebuffer_ad,sbuffer=sbuffer_ad,wbuffer=wbuffer_ad,nbuffer=nbuffer_ad,&
2563  flags = flags, position = position, complete = complete, tile_count = tile_count )
2564 
2565  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2566 
2567  end subroutine mpp_get_boundary_2d_adm
2568 
2569  subroutine mpp_get_boundary_3d_adm( array, arrayp, domain, &
2570  ebuffer, sbuffer, wbuffer, nbuffer, &
2571  ebuffer_ad, sbuffer_ad, wbuffer_ad, nbuffer_ad, &
2572  flags, position, complete, tile_count )
2573 
2574  real, dimension(:,:,:), intent(in) :: array, arrayp
2575  type(domain2d), intent(in) :: domain
2576  real, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:)
2577  real, intent(inout), optional :: ebuffer_ad(:,:), sbuffer_ad(:,:), wbuffer_ad(:,:), nbuffer_ad(:,:)
2578  integer, intent(in), optional :: flags, position, tile_count
2579  logical, intent(in), optional :: complete
2580 
2581  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2582 
2583  call mpp_get_boundary_ad( arrayp, domain,ebuffer=ebuffer_ad,sbuffer=sbuffer_ad,wbuffer=wbuffer_ad,nbuffer=nbuffer_ad,&
2584  flags = flags, position = position, complete = complete, tile_count = tile_count )
2585 
2586  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2587 
2588 end subroutine mpp_get_boundary_3d_adm
2589 
2590  subroutine mpp_get_boundary_2dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, &
2591  ebufferx, sbufferx, wbufferx, nbufferx, &
2592  ebuffery, sbuffery, wbuffery, nbuffery, &
2593  ebufferx_ad, sbufferx_ad, wbufferx_ad, nbufferx_ad, &
2594  ebuffery_ad, sbuffery_ad, wbuffery_ad, nbuffery_ad, &
2595  flags, gridtype, complete, tile_count )
2596 
2597  real, dimension(:,:), intent(in) :: u_cmpt, v_cmpt
2598  real, dimension(:,:), intent(in) :: u_cmptp, v_cmptp
2599  type(domain2d), intent(in) :: domain
2600  real, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:)
2601  real, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:)
2602  real, intent(inout), optional :: ebufferx_ad(:), sbufferx_ad(:), wbufferx_ad(:), nbufferx_ad(:)
2603  real, intent(inout), optional :: ebuffery_ad(:), sbuffery_ad(:), wbuffery_ad(:), nbuffery_ad(:)
2604  integer, intent(in), optional :: flags, gridtype, tile_count
2605  logical, intent(in), optional :: complete
2606 
2607  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2608 
2609  call mpp_get_boundary_ad( u_cmptp, v_cmptp, domain, &
2610  ebufferx = ebufferx_ad, sbufferx = sbufferx_ad, wbufferx = wbufferx_ad, nbufferx = nbufferx_ad, &
2611  ebuffery = ebuffery_ad, sbuffery = sbuffery_ad, wbuffery = wbuffery_ad, nbuffery = nbuffery_ad, &
2612  flags = flags, gridtype = gridtype, &
2613  complete = complete, tile_count = tile_count )
2614 
2615  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2616 
2617 end subroutine mpp_get_boundary_2dv_adm
2618 
2619  subroutine mpp_get_boundary_3dv_adm( u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, &
2620  ebufferx, sbufferx, wbufferx, nbufferx, &
2621  ebuffery, sbuffery, wbuffery, nbuffery, &
2622  ebufferx_ad, sbufferx_ad, wbufferx_ad, nbufferx_ad, &
2623  ebuffery_ad, sbuffery_ad, wbuffery_ad, nbuffery_ad, &
2624  flags, gridtype, complete, tile_count )
2625 
2626  real, dimension(:,:,:), intent(in) :: u_cmpt, v_cmpt
2627  real, dimension(:,:,:), intent(in) :: u_cmptp, v_cmptp
2628  type(domain2d), intent(in) :: domain
2629  real, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:)
2630  real, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:)
2631  real, intent(inout), optional :: ebufferx_ad(:,:), sbufferx_ad(:,:), wbufferx_ad(:,:), nbufferx_ad(:,:)
2632  real, intent(inout), optional :: ebuffery_ad(:,:), sbuffery_ad(:,:), wbuffery_ad(:,:), nbuffery_ad(:,:)
2633  integer, intent(in), optional :: flags, gridtype, tile_count
2634  logical, intent(in), optional :: complete
2635 
2636  if (fv_timing_onoff) call timing_on(' BWD_COMM_TOTAL')
2637 
2638  call mpp_get_boundary_ad( u_cmptp, v_cmptp, domain, &
2639  ebufferx = ebufferx_ad, sbufferx = sbufferx_ad, wbufferx = wbufferx_ad, nbufferx = nbufferx_ad, &
2640  ebuffery = ebuffery_ad, sbuffery = sbuffery_ad, wbuffery = wbuffery_ad, nbuffery = nbuffery_ad, &
2641  flags = flags, gridtype = gridtype, &
2642  complete = complete, tile_count = tile_count )
2643 
2644  if (fv_timing_onoff) call timing_off(' BWD_COMM_TOTAL')
2645 
2646 end subroutine mpp_get_boundary_3dv_adm
2647 
2648 
2649 end module fv_mp_adm_mod
fv_mp_adm_mod::fill_corners_2d_r4_adm
subroutine fill_corners_2d_r4_adm(q, q_ad, npx, npy, fill, agrid, bgrid)
Definition: fv_mp_adm.F90:705
fv_mp_adm_mod::mpp_update_domain2d_5d_adm
subroutine mpp_update_domain2d_5d_adm(array, arrayp, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2442
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
fv_mp_adm_mod::commglobal
integer commglobal
Definition: fv_mp_adm.F90:32
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
fv_mp_adm_mod::mpp_update_domains_adm
Definition: fv_mp_adm.F90:91
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
fv_mp_adm_mod::mpp_update_domain2d_3dv_adm
subroutine mpp_update_domain2d_3dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2483
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
fv_mp_adm_mod::fill_corners_dgrid_adm
Definition: fv_mp_adm.F90:78
fv_mp_adm_mod::mpp_update_domain2d_2d_adm
subroutine mpp_update_domain2d_2d_adm(array, arrayp, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2383
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
fv_mp_adm_mod::mpp_global_sum_2d_adm
real(kind=r_grid) function mpp_global_sum_2d_adm(domain, field, field_ad, flags, position, tile_count)
Definition: fv_mp_adm.F90:2364
fv_mp_adm_mod::mpp_update_domain2d_4d_adm
subroutine mpp_update_domain2d_4d_adm(array, arrayp, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2423
mpp_domains_mod::mpp_start_group_update
Definition: mpp_domains.F90:1406
fv_mp_adm_mod::mpp_update_domain2d_5dv_adm
subroutine mpp_update_domain2d_5dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2525
fv_mp_adm_mod::mpp_update_domain2d_3d_adm
subroutine mpp_update_domain2d_3d_adm(array, arrayp, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2403
fv_mp_adm_mod::fill_corners_cgrid_adm
Definition: fv_mp_adm.F90:73
fv_mp_adm_mod::fill_corners_2d_r8_adm
subroutine fill_corners_2d_r8_adm(q, q_ad, npx, npy, fill, agrid, bgrid)
Definition: fv_mp_adm.F90:1123
fv_mp_adm_mod::start_vector_group_update_3d_adm
subroutine start_vector_group_update_3d_adm(group, groupp, u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:654
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
fv_mp_adm_mod::fill_corners_agrid_adm
Definition: fv_mp_adm.F90:68
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
fv_mp_adm_mod::start_group_halo_update_adm
Definition: fv_mp_adm.F90:53
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_mp_adm_mod::mpp_get_boundary_3dv_adm
subroutine mpp_get_boundary_3dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, ebufferx, sbufferx, wbufferx, nbufferx, ebuffery, sbuffery, wbuffery, nbuffery, ebufferx_ad, sbufferx_ad, wbufferx_ad, nbufferx_ad, ebuffery_ad, sbuffery_ad, wbuffery_ad, nbuffery_ad, flags, gridtype, complete, tile_count)
Definition: fv_mp_adm.F90:2625
mpp_domains_mod::mpp_global_sum
Definition: mpp_domains.F90:2390
mpp_domains_mod::mpp_reset_group_update_field
Definition: mpp_domains.F90:1416
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
fv_mp_adm_mod::fill_corners_dgrid_r4_adm
subroutine fill_corners_dgrid_r4_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:2102
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
mpp_domains_mod::mpp_update_domains_ad
Definition: mpp_domains.F90:1783
fv_mp_nlm_mod::ng
integer, parameter, public ng
Definition: fv_mp_nlm_mod.F90:2465
fv_timing_nlm_mod::timing_on
subroutine timing_on(blk_name)
Definition: fv_timing_nlm.F90:101
tapenade_iter
Definition: tapenade_iter.F90:1
mpp_domains_mod::mpp_complete_group_update
Definition: mpp_domains.F90:1411
fv_mp_adm_mod::fill_corners_agrid_r8_adm
subroutine fill_corners_agrid_r8_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:1741
fv_mp_adm_mod::mpp_update_domain2d_4dv_adm
subroutine mpp_update_domain2d_4dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2504
fv_mp_adm_mod::start_vector_group_update_3d
subroutine start_vector_group_update_3d(group, groupp, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:368
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
fv_mp_adm_mod::fill_corners_xy_2d_r4_adm
subroutine fill_corners_xy_2d_r4_adm(x, x_ad, y, y_ad, npx, npy, dgrid, agrid, cgrid, vector)
Definition: fv_mp_adm.F90:1541
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
fv_mp_adm_mod
Definition: fv_mp_adm.F90:1
fv_mp_adm_mod::ierror
integer ierror
Definition: fv_mp_adm.F90:32
mpp_domains_mod::mpp_get_boundary_ad
Definition: mpp_domains.F90:1921
fv_mp_adm_mod::mpp_get_boundary_3d_adm
subroutine mpp_get_boundary_3d_adm(array, arrayp, domain, ebuffer, sbuffer, wbuffer, nbuffer, ebuffer_ad, sbuffer_ad, wbuffer_ad, nbuffer_ad, flags, position, complete, tile_count)
Definition: fv_mp_adm.F90:2573
fv_mp_adm_mod::mpp_get_boundary_2d_adm
subroutine mpp_get_boundary_2d_adm(array, arrayp, domain, ebuffer, sbuffer, wbuffer, nbuffer, ebuffer_ad, sbuffer_ad, wbuffer_ad, nbuffer_ad, flags, position, complete, tile_count)
Definition: fv_mp_adm.F90:2552
fv_mp_adm_mod::fill_corners_cgrid_r8_adm
subroutine fill_corners_cgrid_r8_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:1982
fv_mp_adm_mod::fill_corners_cgrid_r4_adm
subroutine fill_corners_cgrid_r4_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:1865
fv_mp_adm_mod::start_var_group_update_3d
subroutine start_var_group_update_3d(group, groupp, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:180
fv_mp_adm_mod::start_vector_group_update_2d_adm
subroutine start_vector_group_update_2d_adm(group, groupp, u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:605
fv_mp_adm_mod::complete_group_halo_update
subroutine, public complete_group_halo_update(group, groupp, domain)
Definition: fv_mp_adm.F90:436
fv_mp_adm_mod::mpp_get_boundary_adm
Definition: fv_mp_adm.F90:102
fv_mp_adm_mod::mpp_global_sum_adm
Definition: fv_mp_adm.F90:87
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
fv_mp_adm_mod::fill_corners_adm
Definition: fv_mp_adm.F90:61
fv_mp_adm_mod::fill_corners_xy_2d_r8_adm
subroutine fill_corners_xy_2d_r8_adm(x, x_ad, y, y_ad, npx, npy, dgrid, agrid, cgrid, vector)
Definition: fv_mp_adm.F90:1579
fv_mp_adm_mod::start_group_halo_update
Definition: fv_mp_adm.F90:45
fv_arrays_tlmadm_mod::fv_timing_onoff
logical fv_timing_onoff
Definition: fv_arrays_tlmadm.F90:27
fv_mp_adm_mod::mpp_get_boundary_2dv_adm
subroutine mpp_get_boundary_2dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, ebufferx, sbufferx, wbufferx, nbufferx, ebuffery, sbuffery, wbuffery, nbuffery, ebufferx_ad, sbufferx_ad, wbufferx_ad, nbufferx_ad, ebuffery_ad, sbuffery_ad, wbuffery_ad, nbuffery_ad, flags, gridtype, complete, tile_count)
Definition: fv_mp_adm.F90:2596
mpp_domains_mod::mpp_group_update_type
Definition: mpp_domains.F90:546
fv_mp_adm_mod::fill_corners_agrid_r4_adm
subroutine fill_corners_agrid_r4_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:1620
mpp_domains_mod::mpp_create_group_update
Definition: mpp_domains.F90:1386
fv_mp_adm_mod::start_var_group_update_2d
subroutine start_var_group_update_2d(group, groupp, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:120
fv_mp_adm_mod::start_var_group_update_4d_adm
subroutine start_var_group_update_4d_adm(group, groupp, array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:557
fv_mp_adm_mod::mpp_update_domain2d_2dv_adm
subroutine mpp_update_domain2d_2dv_adm(u_cmpt, u_cmptp, v_cmpt, v_cmptp, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_adm.F90:2462
fv_mp_adm_mod::start_vector_group_update_2d
subroutine start_vector_group_update_2d(group, groupp, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:303
fv_mp_adm_mod::start_var_group_update_4d
subroutine start_var_group_update_4d(group, groupp, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:240
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
fv_mp_adm_mod::fill_corners_dgrid_r8_adm
subroutine fill_corners_dgrid_r8_adm(x, x_ad, y, y_ad, npx, npy, mysign)
Definition: fv_mp_adm.F90:2229
fv_mp_adm_mod::start_var_group_update_3d_adm
subroutine start_var_group_update_3d_adm(group, groupp, array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:513
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
fv_mp_adm_mod::start_var_group_update_2d_adm
subroutine start_var_group_update_2d_adm(group, groupp, array, arrayp, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_adm.F90:469
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175