FV3 Bundle
fv_mp_tlm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20 module fv_mp_tlm_mod
21 
22 use fv_arrays_nlm_mod, only: r_grid
23 use fv_arrays_tlmadm_mod,only: fv_timing_onoff
24 use mpp_domains_mod, only : domain2d
25 use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update
26 use mpp_domains_mod, only : mpp_group_update_initialized
27 use mpp_domains_mod, only : mpp_create_group_update,mpp_reset_group_update_field
28 use mpp_domains_mod, only : group_halo_update_type => mpp_group_update_type
29 
30 use fv_mp_nlm_mod, only : xdir, ydir, ng
31 use fv_mp_nlm_mod, only : is, ie, js, je
32 use fv_mp_nlm_mod, only : isd, ied, jsd, jed
33 use mpp_domains_mod, only : mpp_update_domains, mpp_get_boundary
34 use mpp_domains_mod, only : mpp_global_sum
35 
36 use fv_timing_nlm_mod, only: timing_on, timing_off
37 
38 implicit none
39 private
40 
41 #include "mpif.h"
42 
43 integer :: commglobal, ierror, npes
44 
45 !fv_mp_nlm_mod routines
46 public complete_group_halo_update
47 public start_group_halo_update, start_group_halo_update_tlm
48 public fill_corners_tlm, mp_reduce_sum_tlm
49 
50 !mpp_domains interface
51 public mpp_update_domains_tlm, mpp_get_boundary_tlm, mpp_global_sum_tlm
52 
53 
54 ! Regular fv_mp_nlm_mod routines
55 ! --------------------------
56 interface start_group_halo_update
57  module procedure start_var_group_update_2d
58  module procedure start_var_group_update_3d
59  module procedure start_var_group_update_4d
60  module procedure start_vector_group_update_2d
61  module procedure start_vector_group_update_3d
62 end interface start_group_halo_update
63 
64 interface start_group_halo_update_tlm
65  module procedure start_var_group_update_2d_tlm
66  module procedure start_var_group_update_3d_tlm
67  module procedure start_var_group_update_4d_tlm
68  module procedure start_vector_group_update_2d_tlm
69  module procedure start_vector_group_update_3d_tlm
70 end interface
71 
72 interface fill_corners_tlm
73  module procedure fill_corners_2d_r4_tlm
74  module procedure fill_corners_2d_r8_tlm
75  module procedure fill_corners_xy_2d_r4_tlm
76  module procedure fill_corners_xy_2d_r8_tlm
77 end interface
78 
79 interface fill_corners_agrid_tlm
80  module procedure fill_corners_agrid_r4_tlm
81  module procedure fill_corners_agrid_r8_tlm
82 end interface
83 
84 interface fill_corners_cgrid_tlm
85  module procedure fill_corners_cgrid_r4_tlm
86  module procedure fill_corners_cgrid_r8_tlm
87 end interface
88 
89 interface fill_corners_dgrid_tlm
90  module procedure fill_corners_dgrid_r4_tlm
91  module procedure fill_corners_dgrid_r8_tlm
92 end interface
93 
94 interface mp_reduce_sum_tlm
95  module procedure mp_reduce_sum_r4_tlm
96  module procedure mp_reduce_sum_r4_1d_tlm
97  module procedure mp_reduce_sum_r8_tlm
98  module procedure mp_reduce_sum_r8_1d_tlm
99 end interface
100 
101 
102 ! These are invented interfaces to mpp_domains
103 ! --------------------------------------------
104 
105 interface mpp_global_sum_tlm
106  module procedure mpp_global_sum_2d_tlm
107 end interface
108 
109 interface mpp_update_domains_tlm
110  module procedure mpp_update_domain2d_2d_tlm
111  module procedure mpp_update_domain2d_3d_tlm
112  module procedure mpp_update_domain2d_4d_tlm
113  module procedure mpp_update_domain2d_5d_tlm
114  module procedure mpp_update_domain2d_2dv_tlm
115  module procedure mpp_update_domain2d_3dv_tlm
116  module procedure mpp_update_domain2d_4dv_tlm
117  module procedure mpp_update_domain2d_5dv_tlm
118 end interface
119 
120 interface mpp_get_boundary_tlm
121  module procedure mpp_get_boundary_2d_tlm
122  module procedure mpp_get_boundary_3d_tlm
123  module procedure mpp_get_boundary_2dv_tlm
124  module procedure mpp_get_boundary_3dv_tlm
125 end interface
126 
127 contains
128 
129 
130 subroutine start_var_group_update_2d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
131  type(group_halo_update_type), intent(inout) :: group
132  real, dimension(:,:), intent(inout) :: array
133  type(domain2D), intent(inout) :: domain
134  integer, optional, intent(in) :: flags
135  integer, optional, intent(in) :: position
136  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
137  logical, optional, intent(in) :: complete
138  real :: d_type
139  logical :: is_complete
140 ! Arguments:
141 ! (inout) group - The data type that store information for group update.
142 ! This data will be used in do_group_pass.
143 ! (inout) array - The array which is having its halos points exchanged.
144 ! (in) domain - contains domain information.
145 ! (in) flags - An optional integer indicating which directions the
146 ! data should be sent.
147 ! (in) position - An optional argument indicating the position. This is
148 ! may be CORNER, but is CENTER by default.
149 ! (in) complete - An optional argument indicating whether the halo updates
150 ! should be initiated immediately or wait for second
151 ! pass_..._start call. Omitting complete is the same as
152 ! setting complete to .true.
153 
154  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
155 
156 #ifdef OLDMPP
157 
158  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
159 
160 #else
161 
162  if (mpp_group_update_initialized(group)) then
163  call mpp_reset_group_update_field(group,array)
164  else
165  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
166  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
167  endif
168 
169  is_complete = .true.
170  if(present(complete)) is_complete = complete
171  if(is_complete) then
172  call mpp_start_group_update(group, domain, d_type)
173  endif
174 
175 #endif
176 
177  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
178 
179 end subroutine start_var_group_update_2d
180 
181 
182 subroutine start_var_group_update_3d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
183  type(group_halo_update_type), intent(inout) :: group
184  real, dimension(:,:,:), intent(inout) :: array
185  type(domain2D), intent(inout) :: domain
186  integer, optional, intent(in) :: flags
187  integer, optional, intent(in) :: position
188  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
189  logical, optional, intent(in) :: complete
190  real :: d_type
191  logical :: is_complete
192 
193 ! Arguments:
194 ! (inout) group - The data type that store information for group update.
195 ! This data will be used in do_group_pass.
196 ! (inout) array - The array which is having its halos points exchanged.
197 ! (in) domain - contains domain information.
198 ! (in) flags - An optional integer indicating which directions the
199 ! data should be sent.
200 ! (in) position - An optional argument indicating the position. This is
201 ! may be CORNER, but is CENTER by default.
202 ! (in) complete - An optional argument indicating whether the halo updates
203 ! should be initiated immediately or wait for second
204 ! pass_..._start call. Omitting complete is the same as
205 ! setting complete to .true.
206 
207  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
208 
209 #ifdef OLDMPP
210 
211  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
212 
213 #else
214 
215  if (mpp_group_update_initialized(group)) then
216  call mpp_reset_group_update_field(group,array)
217  else
218  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
219  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
220  endif
221 
222  is_complete = .true.
223  if(present(complete)) is_complete = complete
224  if(is_complete) then
225  call mpp_start_group_update(group, domain, d_type)
226  endif
227 
228 #endif
229 
230  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
231 
232 end subroutine start_var_group_update_3d
233 
234 subroutine start_var_group_update_4d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
235  type(group_halo_update_type), intent(inout) :: group
236  real, dimension(:,:,:,:), intent(inout) :: array
237  type(domain2D), intent(inout) :: domain
238  integer, optional, intent(in) :: flags
239  integer, optional, intent(in) :: position
240  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
241  logical, optional, intent(in) :: complete
242  real :: d_type
243  logical :: is_complete
244 
245 ! Arguments:
246 ! (inout) group - The data type that store information for group update.
247 ! This data will be used in do_group_pass.
248 ! (inout) array - The array which is having its halos points exchanged.
249 ! (in) domain - contains domain information.
250 ! (in) flags - An optional integer indicating which directions the
251 ! data should be sent.
252 ! (in) position - An optional argument indicating the position. This is
253 ! may be CORNER, but is CENTER by default.
254 ! (in) complete - An optional argument indicating whether the halo updates
255 ! should be initiated immediately or wait for second
256 ! pass_..._start call. Omitting complete is the same as
257 ! setting complete to .true.
258 
259  integer :: dirflag
260 
261  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
262 
263 #ifdef OLDMPP
264 
265  call mpp_update_domains(array, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
266 
267 #else
268 
269  if (mpp_group_update_initialized(group)) then
270  call mpp_reset_group_update_field(group,array)
271  else
272  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
273  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
274  endif
275 
276  is_complete = .true.
277  if(present(complete)) is_complete = complete
278  if(is_complete) then
279  call mpp_start_group_update(group, domain, d_type)
280  endif
281 
282 #endif
283 
284  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
285 
286 end subroutine start_var_group_update_4d
287 
288 
289 
290 subroutine start_vector_group_update_2d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
291  type(group_halo_update_type), intent(inout) :: group
292  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt
293  type(domain2d), intent(inout) :: domain
294  integer, optional, intent(in) :: flags
295  integer, optional, intent(in) :: gridtype
296  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
297  logical, optional, intent(in) :: complete
298  real :: d_type
299  logical :: is_complete
300 
301 ! Arguments:
302 ! (inout) group - The data type that store information for group update.
303 ! This data will be used in do_group_pass.
304 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
305 ! is having its halos points exchanged.
306 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
307 ! which is having its halos points exchanged.
308 ! (in) domain - Contains domain decomposition information.
309 ! (in) flags - An optional integer indicating which directions the
310 ! data should be sent.
311 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
312 ! CGRID_NE or DGRID_NE, indicating where the two components of the
313 ! vector are discretized.
314 ! (in) complete - An optional argument indicating whether the halo updates
315 ! should be initiated immediately or wait for second
316 ! pass_..._start call. Omitting complete is the same as
317 ! setting complete to .true.
318 
319  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
320 
321 #ifdef OLDMPP
322 
323  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
324  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
325 
326 #else
327 
328  if (mpp_group_update_initialized(group)) then
329  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
330  else
331  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
332  flags=flags, gridtype=gridtype, &
333  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
334  endif
335 
336  is_complete = .true.
337  if(present(complete)) is_complete = complete
338  if(is_complete) then
339  call mpp_start_group_update(group, domain, d_type)
340  endif
341 
342 #endif
343 
344  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
345 
346 end subroutine start_vector_group_update_2d
347 
348 subroutine start_vector_group_update_3d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
349  type(group_halo_update_type), intent(inout) :: group
350  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt
351  type(domain2d), intent(inout) :: domain
352  integer, optional, intent(in) :: flags
353  integer, optional, intent(in) :: gridtype
354  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
355  logical, optional, intent(in) :: complete
356  real :: d_type
357  logical :: is_complete
358 
359 ! Arguments:
360 ! (inout) group - The data type that store information for group update.
361 ! This data will be used in do_group_pass.
362 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
363 ! is having its halos points exchanged.
364 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
365 ! which is having its halos points exchanged.
366 ! (in) domain - Contains domain decomposition information.
367 ! (in) flags - An optional integer indicating which directions the
368 ! data should be sent.
369 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
370 ! CGRID_NE or DGRID_NE, indicating where the two components of the
371 ! vector are discretized.
372 ! (in) complete - An optional argument indicating whether the halo updates
373 ! should be initiated immediately or wait for second
374 ! pass_..._start call. Omitting complete is the same as
375 ! setting complete to .true.
376 
377  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
378 
379 #ifdef OLDMPP
380 
381  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
382  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
383 
384 #else
385 
386  if (mpp_group_update_initialized(group)) then
387  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
388  else
389  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
390  flags=flags, gridtype=gridtype, &
391  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
392  endif
393 
394  is_complete = .true.
395  if(present(complete)) is_complete = complete
396  if(is_complete) then
397  call mpp_start_group_update(group, domain, d_type)
398  endif
399 
400 #endif
401 
402  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
403 
404 end subroutine start_vector_group_update_3d
405 
406 
407 ! start_group_halo_update_tlm
408 ! ---------------------------
409 
410  subroutine start_var_group_update_2d_tlm(group, &
411 #ifndef OLDMPP
412  group_tl, &
413 #endif
414  array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
415 
416  type(group_halo_update_type), intent(inout) :: group
417 #ifndef OLDMPP
418  type(group_halo_update_type), intent(inout) :: group_tl
419 #endif
420  real, dimension(:,:), intent(inout) :: array, array_tl
421  type(domain2D), intent(inout) :: domain
422  integer, optional, intent(in) :: flags
423  integer, optional, intent(in) :: position
424  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
425  logical, optional, intent(in) :: complete, complete_tl
426  real :: d_type
427  logical :: is_complete, is_complete_tl
428 ! Arguments:
429 ! (inout) group - The data type that store information for group update.
430 ! This data will be used in do_group_pass.
431 ! (inout) array - The array which is having its halos points exchanged.
432 ! (in) domain - contains domain information.
433 ! (in) flags - An optional integer indicating which directions the
434 ! data should be sent.
435 ! (in) position - An optional argument indicating the position. This is
436 ! may be CORNER, but is CENTER by default.
437 ! (in) complete - An optional argument indicating whether the halo updates
438 ! should be initiated immediately or wait for second
439 ! pass_..._start call. Omitting complete is the same as
440 ! setting complete to .true.
441 
442  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
443 
444 #ifdef OLDMPP
445 
446  call mpp_update_domains(array , domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
447  call mpp_update_domains(array_tl, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
448 
449 #else
450 
451  if (mpp_group_update_initialized(group)) then
452  call mpp_reset_group_update_field(group,array)
453  else
454  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
455  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
456  endif
457 
458  is_complete = .true.
459  if(present(complete)) is_complete = complete
460  if(is_complete) then
461  call mpp_start_group_update(group, domain, d_type)
462  endif
463 
464 
465  if (mpp_group_update_initialized(group_tl)) then
466  call mpp_reset_group_update_field(group_tl,array_tl)
467  else
468  call mpp_create_group_update(group_tl, array_tl, domain, flags=flags, position=position, &
469  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
470  endif
471 
472  is_complete_tl = .true.
473  if(present(complete_tl)) is_complete_tl = complete_tl
474  if(is_complete_tl) then
475  call mpp_start_group_update(group_tl, domain, d_type)
476  endif
477 
478 #endif
479 
480  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
481 
482 end subroutine start_var_group_update_2d_tlm
483 
484 subroutine start_var_group_update_3d_tlm(group, &
485 #ifndef OLDMPP
486  group_tl, &
487 #endif
488  array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
489 
490  type(group_halo_update_type), intent(inout) :: group
491 #ifndef OLDMPP
492  type(group_halo_update_type), intent(inout) :: group_tl
493 #endif
494  real, dimension(:,:,:), intent(inout) :: array, array_tl
495  type(domain2D), intent(inout) :: domain
496  integer, optional, intent(in) :: flags
497  integer, optional, intent(in) :: position
498  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
499  logical, optional, intent(in) :: complete, complete_tl
500  real :: d_type
501  logical :: is_complete, is_complete_tl
502 
503 ! Arguments:
504 ! (inout) group - The data type that store information for group update.
505 ! This data will be used in do_group_pass.
506 ! (inout) array - The array which is having its halos points exchanged.
507 ! (in) domain - contains domain information.
508 ! (in) flags - An optional integer indicating which directions the
509 ! data should be sent.
510 ! (in) position - An optional argument indicating the position. This is
511 ! may be CORNER, but is CENTER by default.
512 ! (in) complete - An optional argument indicating whether the halo updates
513 ! should be initiated immediately or wait for second
514 ! pass_..._start call. Omitting complete is the same as
515 ! setting complete to .true.
516 
517  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
518 
519 #ifdef OLDMPP
520 
521  call mpp_update_domains(array , domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
522  call mpp_update_domains(array_tl, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
523 
524 #else
525 
526  if (mpp_group_update_initialized(group)) then
527  call mpp_reset_group_update_field(group,array)
528  else
529  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
530  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
531  endif
532 
533  is_complete = .true.
534  if(present(complete)) is_complete = complete
535  if(is_complete) then
536  call mpp_start_group_update(group, domain, d_type)
537  endif
538 
539  if (mpp_group_update_initialized(group_tl)) then
540  call mpp_reset_group_update_field(group_tl,array_tl)
541  else
542  call mpp_create_group_update(group_tl, array_tl, domain, flags=flags, position=position, &
543  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
544  endif
545 
546  is_complete_tl = .true.
547  if(present(complete_tl)) is_complete_tl = complete_tl
548  if(is_complete_tl) then
549  call mpp_start_group_update(group_tl, domain, d_type)
550  endif
551 
552 #endif
553 
554  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
555 
556 end subroutine start_var_group_update_3d_tlm
557 
558 subroutine start_var_group_update_4d_tlm(group, &
559 #ifndef OLDMPP
560  group_tl, &
561 #endif
562  array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
563 
564  type(group_halo_update_type), intent(inout) :: group
565 #ifndef OLDMPP
566  type(group_halo_update_type), intent(inout) :: group_tl
567 #endif
568  real, dimension(:,:,:,:), intent(inout) :: array, array_tl
569  type(domain2D), intent(inout) :: domain
570  integer, optional, intent(in) :: flags
571  integer, optional, intent(in) :: position
572  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
573  logical, optional, intent(in) :: complete, complete_tl
574  real :: d_type
575  logical :: is_complete, is_complete_tl
576 
577 ! Arguments:
578 ! (inout) group - The data type that store information for group update.
579 ! This data will be used in do_group_pass.
580 ! (inout) array - The array which is having its halos points exchanged.
581 ! (in) domain - contains domain information.
582 ! (in) flags - An optional integer indicating which directions the
583 ! data should be sent.
584 ! (in) position - An optional argument indicating the position. This is
585 ! may be CORNER, but is CENTER by default.
586 ! (in) complete - An optional argument indicating whether the halo updates
587 ! should be initiated immediately or wait for second
588 ! pass_..._start call. Omitting complete is the same as
589 ! setting complete to .true.
590 
591  integer :: dirflag
592 
593  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
594 
595 #ifdef OLDMPP
596 
597  call mpp_update_domains(array , domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
598  call mpp_update_domains(array_tl, domain, flags=flags, position=position, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
599 
600 #else
601 
602  if (mpp_group_update_initialized(group)) then
603  call mpp_reset_group_update_field(group,array)
604  else
605  call mpp_create_group_update(group, array, domain, flags=flags, position=position, &
606  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
607  endif
608 
609  is_complete = .true.
610  if(present(complete)) is_complete = complete
611  if(is_complete) then
612  call mpp_start_group_update(group, domain, d_type)
613  endif
614 
615  if (mpp_group_update_initialized(group_tl)) then
616  call mpp_reset_group_update_field(group_tl,array_tl)
617  else
618  call mpp_create_group_update(group_tl, array_tl, domain, flags=flags, position=position, &
619  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
620  endif
621 
622  is_complete_tl = .true.
623  if(present(complete_tl)) is_complete_tl = complete_tl
624  if(is_complete_tl) then
625  call mpp_start_group_update(group_tl, domain, d_type)
626  endif
627 
628 #endif
629 
630  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
631 
632 end subroutine start_var_group_update_4d_tlm
633 
634 
635 
636 subroutine start_vector_group_update_2d_tlm(group,&
637 #ifndef OLDMPP
638  group_tl, &
639 #endif
640  u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete, complete_tl)
641 
642  type(group_halo_update_type), intent(inout) :: group
643 #ifndef OLDMPP
644  type(group_halo_update_type), intent(inout) :: group_tl
645 #endif
646  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt
647  real, dimension(:,:), intent(inout) :: u_cmpt_tl, v_cmpt_tl
648  type(domain2d), intent(inout) :: domain
649  integer, optional, intent(in) :: flags
650  integer, optional, intent(in) :: gridtype
651  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
652  logical, optional, intent(in) :: complete, complete_tl
653  real :: d_type
654  logical :: is_complete, is_complete_tl
655 
656 ! Arguments:
657 ! (inout) group - The data type that store information for group update.
658 ! This data will be used in do_group_pass.
659 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
660 ! is having its halos points exchanged.
661 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
662 ! which is having its halos points exchanged.
663 ! (in) domain - Contains domain decomposition information.
664 ! (in) flags - An optional integer indicating which directions the
665 ! data should be sent.
666 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
667 ! CGRID_NE or DGRID_NE, indicating where the two components of the
668 ! vector are discretized.
669 ! (in) complete - An optional argument indicating whether the halo updates
670 ! should be initiated immediately or wait for second
671 ! pass_..._start call. Omitting complete is the same as
672 ! setting complete to .true.
673 
674  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
675 
676 #ifdef OLDMPP
677 
678  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
679  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
680  call mpp_update_domains(u_cmpt_tl, v_cmpt_tl, domain, flags=flags, gridtype=gridtype, &
681  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
682 
683 #else
684 
685 
686  if (mpp_group_update_initialized(group)) then
687  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
688  else
689  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
690  flags=flags, gridtype=gridtype, &
691  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
692  endif
693 
694  is_complete = .true.
695  if(present(complete)) is_complete = complete
696  if(is_complete) then
697  call mpp_start_group_update(group, domain, d_type)
698  endif
699 
700 
701  if (mpp_group_update_initialized(group_tl)) then
702  call mpp_reset_group_update_field(group_tl,u_cmpt_tl, v_cmpt_tl)
703  else
704  call mpp_create_group_update(group_tl, u_cmpt_tl, v_cmpt_tl, domain, &
705  flags=flags, gridtype=gridtype, &
706  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
707  endif
708 
709  is_complete_tl = .true.
710  if(present(complete_tl)) is_complete_tl = complete_tl
711  if(is_complete_tl) then
712  call mpp_start_group_update(group_tl, domain, d_type)
713  endif
714 
715 #endif
716 
717  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
718 
719 end subroutine start_vector_group_update_2d_tlm
720 
721 subroutine start_vector_group_update_3d_tlm(group, &
722 #ifndef OLDMPP
723  group_tl, &
724 #endif
725  u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete, complete_tl)
726 
727  type(group_halo_update_type), intent(inout) :: group
728 #ifndef OLDMPP
729  type(group_halo_update_type), intent(inout) :: group_tl
730 #endif
731  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt
732  real, dimension(:,:,:), intent(inout) :: u_cmpt_tl, v_cmpt_tl
733  type(domain2d), intent(inout) :: domain
734  integer, optional, intent(in) :: flags
735  integer, optional, intent(in) :: gridtype
736  integer, optional, intent(in) :: whalo, ehalo, shalo, nhalo
737  logical, optional, intent(in) :: complete, complete_tl
738  real :: d_type
739  logical :: is_complete, is_complete_tl
740 
741 ! Arguments:
742 ! (inout) group - The data type that store information for group update.
743 ! This data will be used in do_group_pass.
744 ! (inout) u_cmpt - The nominal zonal (u) component of the vector pair which
745 ! is having its halos points exchanged.
746 ! (inout) v_cmpt - The nominal meridional (v) component of the vector pair
747 ! which is having its halos points exchanged.
748 ! (in) domain - Contains domain decomposition information.
749 ! (in) flags - An optional integer indicating which directions the
750 ! data should be sent.
751 ! (in) gridtype - An optional flag, which may be one of A_GRID, BGRID_NE,
752 ! CGRID_NE or DGRID_NE, indicating where the two components of the
753 ! vector are discretized.
754 ! (in) complete - An optional argument indicating whether the halo updates
755 ! should be initiated immediately or wait for second
756 ! pass_..._start call. Omitting complete is the same as
757 ! setting complete to .true.
758 
759  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
760 
761 #ifdef OLDMPP
762 
763  call mpp_update_domains(u_cmpt, v_cmpt, domain, flags=flags, gridtype=gridtype, &
764  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
765  call mpp_update_domains(u_cmpt_tl, v_cmpt_tl, domain, flags=flags, gridtype=gridtype, &
766  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo, complete=complete)
767 
768 #else
769 
770 
771  if (mpp_group_update_initialized(group)) then
772  call mpp_reset_group_update_field(group,u_cmpt, v_cmpt)
773  else
774  call mpp_create_group_update(group, u_cmpt, v_cmpt, domain, &
775  flags=flags, gridtype=gridtype, &
776  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
777  endif
778 
779  is_complete = .true.
780  if(present(complete)) is_complete = complete
781  if(is_complete) then
782  call mpp_start_group_update(group, domain, d_type)
783  endif
784 
785  if (mpp_group_update_initialized(group_tl)) then
786  call mpp_reset_group_update_field(group_tl,u_cmpt_tl, v_cmpt_tl)
787  else
788  call mpp_create_group_update(group_tl, u_cmpt_tl, v_cmpt_tl, domain, &
789  flags=flags, gridtype=gridtype, &
790  whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo)
791  endif
792 
793  is_complete_tl = .true.
794  if(present(complete_tl)) is_complete_tl = complete_tl
795  if(is_complete_tl) then
796  call mpp_start_group_update(group_tl, domain, d_type)
797  endif
798 
799 #endif
800 
801  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
802 
803 end subroutine start_vector_group_update_3d_tlm
804 
805 
806 
807 ! complete_group_halo_update
808 ! --------------------------
809 
810 subroutine complete_group_halo_update(group,&
811 #ifndef OLDMPP
812  group_tl, &
813 #endif
814  domain)
815  type(group_halo_update_type), intent(inout) :: group
816 #ifndef OLDMPP
817  type(group_halo_update_type), intent(inout) :: group_tl
818 #endif
819  type(domain2d), intent(inout) :: domain
820  real :: d_type
821 
822 ! Arguments:
823 ! (inout) group - The data type that store information for group update.
824 ! (in) domain - Contains domain decomposition information.
825 
826  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
827 
828 #ifndef OLDMPP
829 
830  call mpp_complete_group_update(group, domain, d_type)
831  call mpp_complete_group_update(group_tl, domain, d_type)
832 
833 #endif
834 
835  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
836 
837 end subroutine complete_group_halo_update
838 
839 
840 ! fill_corners_tlm
841 ! ----------------
842 
843  subroutine fill_corners_2d_r4_tlm(q, q_tl, npx, npy, fill, agrid, bgrid)
844  implicit none
845  real(kind=4), dimension(isd:, jsd:), intent(inout) :: q
846  real(kind=4), dimension(isd:, jsd:), intent(inout) :: q_tl
847  integer, intent(in) :: npx, npy
848 ! x-dir or y-dir
849  integer, intent(in) :: fill
850  logical, optional, intent(in) :: agrid, bgrid
851  integer :: i, j
852  intrinsic present
853  if (present(bgrid)) then
854  if (bgrid) then
855  select case (fill)
856  case (xdir)
857  do j=1,ng
858  do i=1,ng
859 !sw corner
860  if (is .eq. 1 .and. js .eq. 1) then
861  q_tl(1-i, 1-j) = q_tl(1-j, i+1)
862  q(1-i, 1-j) = q(1-j, i+1)
863  end if
864 !nw corner
865  if (is .eq. 1 .and. je .eq. npy - 1) then
866  q_tl(1-i, npy+j) = q_tl(1-j, npy-i)
867  q(1-i, npy+j) = q(1-j, npy-i)
868  end if
869 !se corner
870  if (ie .eq. npx - 1 .and. js .eq. 1) then
871  q_tl(npx+i, 1-j) = q_tl(npx+j, i+1)
872  q(npx+i, 1-j) = q(npx+j, i+1)
873  end if
874 !ne corner
875  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
876  q_tl(npx+i, npy+j) = q_tl(npx+j, npy-i)
877  q(npx+i, npy+j) = q(npx+j, npy-i)
878  end if
879  end do
880  end do
881  case (ydir)
882  do j=1,ng
883  do i=1,ng
884 !sw corner
885  if (is .eq. 1 .and. js .eq. 1) then
886  q_tl(1-j, 1-i) = q_tl(i+1, 1-j)
887  q(1-j, 1-i) = q(i+1, 1-j)
888  end if
889 !nw corner
890  if (is .eq. 1 .and. je .eq. npy - 1) then
891  q_tl(1-j, npy+i) = q_tl(i+1, npy+j)
892  q(1-j, npy+i) = q(i+1, npy+j)
893  end if
894 !se corner
895  if (ie .eq. npx - 1 .and. js .eq. 1) then
896  q_tl(npx+j, 1-i) = q_tl(npx-i, 1-j)
897  q(npx+j, 1-i) = q(npx-i, 1-j)
898  end if
899 !ne corner
900  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
901  q_tl(npx+j, npy+i) = q_tl(npx-i, npy+j)
902  q(npx+j, npy+i) = q(npx-i, npy+j)
903  end if
904  end do
905  end do
906  case default
907  do j=1,ng
908  do i=1,ng
909 !sw corner
910  if (is .eq. 1 .and. js .eq. 1) then
911  q_tl(1-i, 1-j) = q_tl(1-j, i+1)
912  q(1-i, 1-j) = q(1-j, i+1)
913  end if
914 !nw corner
915  if (is .eq. 1 .and. je .eq. npy - 1) then
916  q_tl(1-i, npy+j) = q_tl(1-j, npy-i)
917  q(1-i, npy+j) = q(1-j, npy-i)
918  end if
919 !se corner
920  if (ie .eq. npx - 1 .and. js .eq. 1) then
921  q_tl(npx+i, 1-j) = q_tl(npx+j, i+1)
922  q(npx+i, 1-j) = q(npx+j, i+1)
923  end if
924 !ne corner
925  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
926  q_tl(npx+i, npy+j) = q_tl(npx+j, npy-i)
927  q(npx+i, npy+j) = q(npx+j, npy-i)
928  end if
929  end do
930  end do
931  end select
932  end if
933  else if (present(agrid)) then
934  if (agrid) then
935  select case (fill)
936  case (xdir)
937  do j=1,ng
938  do i=1,ng
939 !sw corner
940  if (is .eq. 1 .and. js .eq. 1) then
941  q_tl(1-i, 1-j) = q_tl(1-j, i)
942  q(1-i, 1-j) = q(1-j, i)
943  end if
944 !nw corner
945  if (is .eq. 1 .and. je .eq. npy - 1) then
946  q_tl(1-i, npy-1+j) = q_tl(1-j, npy-1-i+1)
947  q(1-i, npy-1+j) = q(1-j, npy-1-i+1)
948  end if
949 !se corner
950  if (ie .eq. npx - 1 .and. js .eq. 1) then
951  q_tl(npx-1+i, 1-j) = q_tl(npx-1+j, i)
952  q(npx-1+i, 1-j) = q(npx-1+j, i)
953  end if
954 !ne corner
955  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
956  q_tl(npx-1+i, npy-1+j) = q_tl(npx-1+j, npy-1-i+1)
957  q(npx-1+i, npy-1+j) = q(npx-1+j, npy-1-i+1)
958  end if
959  end do
960  end do
961  case (ydir)
962  do j=1,ng
963  do i=1,ng
964 !sw corner
965  if (is .eq. 1 .and. js .eq. 1) then
966  q_tl(1-j, 1-i) = q_tl(i, 1-j)
967  q(1-j, 1-i) = q(i, 1-j)
968  end if
969 !nw corner
970  if (is .eq. 1 .and. je .eq. npy - 1) then
971  q_tl(1-j, npy-1+i) = q_tl(i, npy-1+j)
972  q(1-j, npy-1+i) = q(i, npy-1+j)
973  end if
974 !se corner
975  if (ie .eq. npx - 1 .and. js .eq. 1) then
976  q_tl(npx-1+j, 1-i) = q_tl(npx-1-i+1, 1-j)
977  q(npx-1+j, 1-i) = q(npx-1-i+1, 1-j)
978  end if
979 !ne corner
980  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
981  q_tl(npx-1+j, npy-1+i) = q_tl(npx-1-i+1, npy-1+j)
982  q(npx-1+j, npy-1+i) = q(npx-1-i+1, npy-1+j)
983  end if
984  end do
985  end do
986  case default
987  do j=1,ng
988  do i=1,ng
989 !sw corner
990  if (is .eq. 1 .and. js .eq. 1) then
991  q_tl(1-j, 1-i) = q_tl(i, 1-j)
992  q(1-j, 1-i) = q(i, 1-j)
993  end if
994 !nw corner
995  if (is .eq. 1 .and. je .eq. npy - 1) then
996  q_tl(1-j, npy-1+i) = q_tl(i, npy-1+j)
997  q(1-j, npy-1+i) = q(i, npy-1+j)
998  end if
999 !se corner
1000  if (ie .eq. npx - 1 .and. js .eq. 1) then
1001  q_tl(npx-1+j, 1-i) = q_tl(npx-1-i+1, 1-j)
1002  q(npx-1+j, 1-i) = q(npx-1-i+1, 1-j)
1003  end if
1004 !ne corner
1005  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1006  q_tl(npx-1+j, npy-1+i) = q_tl(npx-1-i+1, npy-1+j)
1007  q(npx-1+j, npy-1+i) = q(npx-1-i+1, npy-1+j)
1008  end if
1009  end do
1010  end do
1011  end select
1012  end if
1013  end if
1014  end subroutine fill_corners_2d_r4_tlm
1015 
1016  subroutine fill_corners_2d_r8_tlm(q, q_tl, npx, npy, fill, agrid, bgrid)
1017  implicit none
1018  real(kind=8), dimension(isd:, jsd:), intent(inout) :: q
1019  real(kind=8), dimension(isd:, jsd:), intent(inout) :: q_tl
1020  integer, intent(in) :: npx, npy
1021 ! x-dir or y-dir
1022  integer, intent(in) :: fill
1023  logical, optional, intent(in) :: agrid, bgrid
1024  integer :: i, j
1025  intrinsic present
1026  if (present(bgrid)) then
1027  if (bgrid) then
1028  select case (fill)
1029  case (xdir)
1030  do j=1,ng
1031  do i=1,ng
1032 !sw corner
1033  if (is .eq. 1 .and. js .eq. 1) then
1034  q_tl(1-i, 1-j) = q_tl(1-j, i+1)
1035  q(1-i, 1-j) = q(1-j, i+1)
1036  end if
1037 !nw corner
1038  if (is .eq. 1 .and. je .eq. npy - 1) then
1039  q_tl(1-i, npy+j) = q_tl(1-j, npy-i)
1040  q(1-i, npy+j) = q(1-j, npy-i)
1041  end if
1042 !se corner
1043  if (ie .eq. npx - 1 .and. js .eq. 1) then
1044  q_tl(npx+i, 1-j) = q_tl(npx+j, i+1)
1045  q(npx+i, 1-j) = q(npx+j, i+1)
1046  end if
1047 !ne corner
1048  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1049  q_tl(npx+i, npy+j) = q_tl(npx+j, npy-i)
1050  q(npx+i, npy+j) = q(npx+j, npy-i)
1051  end if
1052  end do
1053  end do
1054  case (ydir)
1055  do j=1,ng
1056  do i=1,ng
1057 !sw corner
1058  if (is .eq. 1 .and. js .eq. 1) then
1059  q_tl(1-j, 1-i) = q_tl(i+1, 1-j)
1060  q(1-j, 1-i) = q(i+1, 1-j)
1061  end if
1062 !nw corner
1063  if (is .eq. 1 .and. je .eq. npy - 1) then
1064  q_tl(1-j, npy+i) = q_tl(i+1, npy+j)
1065  q(1-j, npy+i) = q(i+1, npy+j)
1066  end if
1067 !se corner
1068  if (ie .eq. npx - 1 .and. js .eq. 1) then
1069  q_tl(npx+j, 1-i) = q_tl(npx-i, 1-j)
1070  q(npx+j, 1-i) = q(npx-i, 1-j)
1071  end if
1072 !ne corner
1073  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1074  q_tl(npx+j, npy+i) = q_tl(npx-i, npy+j)
1075  q(npx+j, npy+i) = q(npx-i, npy+j)
1076  end if
1077  end do
1078  end do
1079  case default
1080  do j=1,ng
1081  do i=1,ng
1082 !sw corner
1083  if (is .eq. 1 .and. js .eq. 1) then
1084  q_tl(1-i, 1-j) = q_tl(1-j, i+1)
1085  q(1-i, 1-j) = q(1-j, i+1)
1086  end if
1087 !nw corner
1088  if (is .eq. 1 .and. je .eq. npy - 1) then
1089  q_tl(1-i, npy+j) = q_tl(1-j, npy-i)
1090  q(1-i, npy+j) = q(1-j, npy-i)
1091  end if
1092 !se corner
1093  if (ie .eq. npx - 1 .and. js .eq. 1) then
1094  q_tl(npx+i, 1-j) = q_tl(npx+j, i+1)
1095  q(npx+i, 1-j) = q(npx+j, i+1)
1096  end if
1097 !ne corner
1098  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1099  q_tl(npx+i, npy+j) = q_tl(npx+j, npy-i)
1100  q(npx+i, npy+j) = q(npx+j, npy-i)
1101  end if
1102  end do
1103  end do
1104  end select
1105  end if
1106  else if (present(agrid)) then
1107  if (agrid) then
1108  select case (fill)
1109  case (xdir)
1110  do j=1,ng
1111  do i=1,ng
1112 !sw corner
1113  if (is .eq. 1 .and. js .eq. 1) then
1114  q_tl(1-i, 1-j) = q_tl(1-j, i)
1115  q(1-i, 1-j) = q(1-j, i)
1116  end if
1117 !nw corner
1118  if (is .eq. 1 .and. je .eq. npy - 1) then
1119  q_tl(1-i, npy-1+j) = q_tl(1-j, npy-1-i+1)
1120  q(1-i, npy-1+j) = q(1-j, npy-1-i+1)
1121  end if
1122 !se corner
1123  if (ie .eq. npx - 1 .and. js .eq. 1) then
1124  q_tl(npx-1+i, 1-j) = q_tl(npx-1+j, i)
1125  q(npx-1+i, 1-j) = q(npx-1+j, i)
1126  end if
1127 !ne corner
1128  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1129  q_tl(npx-1+i, npy-1+j) = q_tl(npx-1+j, npy-1-i+1)
1130  q(npx-1+i, npy-1+j) = q(npx-1+j, npy-1-i+1)
1131  end if
1132  end do
1133  end do
1134  case (ydir)
1135  do j=1,ng
1136  do i=1,ng
1137 !sw corner
1138  if (is .eq. 1 .and. js .eq. 1) then
1139  q_tl(1-j, 1-i) = q_tl(i, 1-j)
1140  q(1-j, 1-i) = q(i, 1-j)
1141  end if
1142 !nw corner
1143  if (is .eq. 1 .and. je .eq. npy - 1) then
1144  q_tl(1-j, npy-1+i) = q_tl(i, npy-1+j)
1145  q(1-j, npy-1+i) = q(i, npy-1+j)
1146  end if
1147 !se corner
1148  if (ie .eq. npx - 1 .and. js .eq. 1) then
1149  q_tl(npx-1+j, 1-i) = q_tl(npx-1-i+1, 1-j)
1150  q(npx-1+j, 1-i) = q(npx-1-i+1, 1-j)
1151  end if
1152 !ne corner
1153  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1154  q_tl(npx-1+j, npy-1+i) = q_tl(npx-1-i+1, npy-1+j)
1155  q(npx-1+j, npy-1+i) = q(npx-1-i+1, npy-1+j)
1156  end if
1157  end do
1158  end do
1159  case default
1160  do j=1,ng
1161  do i=1,ng
1162 !sw corner
1163  if (is .eq. 1 .and. js .eq. 1) then
1164  q_tl(1-j, 1-i) = q_tl(i, 1-j)
1165  q(1-j, 1-i) = q(i, 1-j)
1166  end if
1167 !nw corner
1168  if (is .eq. 1 .and. je .eq. npy - 1) then
1169  q_tl(1-j, npy-1+i) = q_tl(i, npy-1+j)
1170  q(1-j, npy-1+i) = q(i, npy-1+j)
1171  end if
1172 !se corner
1173  if (ie .eq. npx - 1 .and. js .eq. 1) then
1174  q_tl(npx-1+j, 1-i) = q_tl(npx-1-i+1, 1-j)
1175  q(npx-1+j, 1-i) = q(npx-1-i+1, 1-j)
1176  end if
1177 !ne corner
1178  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1179  q_tl(npx-1+j, npy-1+i) = q_tl(npx-1-i+1, npy-1+j)
1180  q(npx-1+j, npy-1+i) = q(npx-1-i+1, npy-1+j)
1181  end if
1182  end do
1183  end do
1184  end select
1185  end if
1186  end if
1187  end subroutine fill_corners_2d_r8_tlm
1188 
1189  subroutine fill_corners_xy_2d_r4_tlm(x, x_tl, y, y_tl, npx, npy, dgrid&
1190 & , agrid, cgrid, vector)
1191  implicit none
1192 !(isd:ied ,jsd:jed+1)
1193  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x
1194  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x_tl
1195 !(isd:ied+1,jsd:jed )
1196  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y
1197  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y_tl
1198  integer, intent(in) :: npx, npy
1199  logical, optional, intent(in) :: dgrid, agrid, cgrid, vector
1200  integer :: i, j
1201  real(kind=4) :: mysign
1202  intrinsic present
1203  mysign = 1.0
1204  if (present(vector)) then
1205  if (vector) mysign = -1.0
1206  end if
1207  if (present(dgrid)) then
1208  call fill_corners_dgrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1209  else if (present(cgrid)) then
1210  call fill_corners_cgrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1211  else if (present(agrid)) then
1212  call fill_corners_agrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1213  else
1214  call fill_corners_agrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1215  end if
1216  end subroutine fill_corners_xy_2d_r4_tlm
1217 
1218  subroutine fill_corners_xy_2d_r8_tlm(x, x_tl, y, y_tl, npx, npy, dgrid&
1219 & , agrid, cgrid, vector)
1220  implicit none
1221 !(isd:ied ,jsd:jed+1)
1222  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x
1223  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x_tl
1224 !(isd:ied+1,jsd:jed )
1225  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y
1226  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y_tl
1227  integer, intent(in) :: npx, npy
1228  logical, optional, intent(in) :: dgrid, agrid, cgrid, vector
1229  integer :: i, j
1230  real(kind=8) :: mysign
1231  intrinsic present
1232  mysign = 1.0
1233  if (present(vector)) then
1234  if (vector) mysign = -1.0
1235  end if
1236  if (present(dgrid)) then
1237  call fill_corners_dgrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1238  else if (present(cgrid)) then
1239  call fill_corners_cgrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1240  else if (present(agrid)) then
1241  call fill_corners_agrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1242  else
1243  call fill_corners_agrid_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
1244  end if
1245  end subroutine fill_corners_xy_2d_r8_tlm
1246 
1247  subroutine fill_corners_agrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, &
1248 & mysign)
1249  implicit none
1250  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x
1251  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x_tl
1252  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y
1253  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y_tl
1254  integer, intent(in) :: npx, npy
1255  real(kind=4), intent(in) :: mysign
1256  integer :: i, j
1257  do j=1,ng
1258  do i=1,ng
1259 !sw corner
1260  if (is .eq. 1 .and. js .eq. 1) then
1261  x_tl(1-i, 1-j) = mysign*y_tl(1-j, i)
1262  x(1-i, 1-j) = mysign*y(1-j, i)
1263  end if
1264 !nw corner
1265  if (is .eq. 1 .and. je .eq. npy - 1) then
1266  x_tl(1-i, npy-1+j) = y_tl(1-j, npy-1-i+1)
1267  x(1-i, npy-1+j) = y(1-j, npy-1-i+1)
1268  end if
1269 !se corner
1270  if (ie .eq. npx - 1 .and. js .eq. 1) then
1271  x_tl(npx-1+i, 1-j) = y_tl(npx-1+j, i)
1272  x(npx-1+i, 1-j) = y(npx-1+j, i)
1273  end if
1274 !ne corner
1275  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1276  x_tl(npx-1+i, npy-1+j) = mysign*y_tl(npx-1+j, npy-1-i+1)
1277  x(npx-1+i, npy-1+j) = mysign*y(npx-1+j, npy-1-i+1)
1278  end if
1279  end do
1280  end do
1281  do j=1,ng
1282  do i=1,ng
1283 !sw corner
1284  if (is .eq. 1 .and. js .eq. 1) then
1285  y_tl(1-j, 1-i) = mysign*x_tl(i, 1-j)
1286  y(1-j, 1-i) = mysign*x(i, 1-j)
1287  end if
1288 !nw corner
1289  if (is .eq. 1 .and. je .eq. npy - 1) then
1290  y_tl(1-j, npy-1+i) = x_tl(i, npy-1+j)
1291  y(1-j, npy-1+i) = x(i, npy-1+j)
1292  end if
1293 !se corner
1294  if (ie .eq. npx - 1 .and. js .eq. 1) then
1295  y_tl(npx-1+j, 1-i) = x_tl(npx-1-i+1, 1-j)
1296  y(npx-1+j, 1-i) = x(npx-1-i+1, 1-j)
1297  end if
1298 !ne corner
1299  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1300  y_tl(npx-1+j, npy-1+i) = mysign*x_tl(npx-1-i+1, npy-1+j)
1301  y(npx-1+j, npy-1+i) = mysign*x(npx-1-i+1, npy-1+j)
1302  end if
1303  end do
1304  end do
1305  end subroutine fill_corners_agrid_r4_tlm
1306 
1307  subroutine fill_corners_agrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, &
1308 & mysign)
1309  implicit none
1310  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x
1311  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x_tl
1312  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y
1313  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y_tl
1314  integer, intent(in) :: npx, npy
1315  real(kind=8), intent(in) :: mysign
1316  integer :: i, j
1317  do j=1,ng
1318  do i=1,ng
1319 !sw corner
1320  if (is .eq. 1 .and. js .eq. 1) then
1321  x_tl(1-i, 1-j) = mysign*y_tl(1-j, i)
1322  x(1-i, 1-j) = mysign*y(1-j, i)
1323  end if
1324 !nw corner
1325  if (is .eq. 1 .and. je .eq. npy - 1) then
1326  x_tl(1-i, npy-1+j) = y_tl(1-j, npy-1-i+1)
1327  x(1-i, npy-1+j) = y(1-j, npy-1-i+1)
1328  end if
1329 !se corner
1330  if (ie .eq. npx - 1 .and. js .eq. 1) then
1331  x_tl(npx-1+i, 1-j) = y_tl(npx-1+j, i)
1332  x(npx-1+i, 1-j) = y(npx-1+j, i)
1333  end if
1334 !ne corner
1335  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1336  x_tl(npx-1+i, npy-1+j) = mysign*y_tl(npx-1+j, npy-1-i+1)
1337  x(npx-1+i, npy-1+j) = mysign*y(npx-1+j, npy-1-i+1)
1338  end if
1339  end do
1340  end do
1341  do j=1,ng
1342  do i=1,ng
1343 !sw corner
1344  if (is .eq. 1 .and. js .eq. 1) then
1345  y_tl(1-j, 1-i) = mysign*x_tl(i, 1-j)
1346  y(1-j, 1-i) = mysign*x(i, 1-j)
1347  end if
1348 !nw corner
1349  if (is .eq. 1 .and. je .eq. npy - 1) then
1350  y_tl(1-j, npy-1+i) = x_tl(i, npy-1+j)
1351  y(1-j, npy-1+i) = x(i, npy-1+j)
1352  end if
1353 !se corner
1354  if (ie .eq. npx - 1 .and. js .eq. 1) then
1355  y_tl(npx-1+j, 1-i) = x_tl(npx-1-i+1, 1-j)
1356  y(npx-1+j, 1-i) = x(npx-1-i+1, 1-j)
1357  end if
1358 !ne corner
1359  if (ie .eq. npx - 1 .and. je .eq. npy - 1) then
1360  y_tl(npx-1+j, npy-1+i) = mysign*x_tl(npx-1-i+1, npy-1+j)
1361  y(npx-1+j, npy-1+i) = mysign*x(npx-1-i+1, npy-1+j)
1362  end if
1363  end do
1364  end do
1365  end subroutine fill_corners_agrid_r8_tlm
1366 
1367  subroutine fill_corners_cgrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, &
1368 & mysign)
1369  implicit none
1370  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x
1371  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x_tl
1372  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y
1373  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y_tl
1374  integer, intent(in) :: npx, npy
1375  real(kind=4), intent(in) :: mysign
1376  integer :: i, j
1377  do j=1,ng
1378  do i=1,ng
1379 !sw corner
1380  if (is .eq. 1 .and. js .eq. 1) then
1381  x_tl(1-i, 1-j) = y_tl(j, 1-i)
1382  x(1-i, 1-j) = y(j, 1-i)
1383  end if
1384 !nw corner
1385  if (is .eq. 1 .and. je + 1 .eq. npy) then
1386  x_tl(1-i, npy-1+j) = mysign*y_tl(j, npy+i)
1387  x(1-i, npy-1+j) = mysign*y(j, npy+i)
1388  end if
1389 !se corner
1390  if (ie + 1 .eq. npx .and. js .eq. 1) then
1391  x_tl(npx+i, 1-j) = mysign*y_tl(npx-j, 1-i)
1392  x(npx+i, 1-j) = mysign*y(npx-j, 1-i)
1393  end if
1394 !ne corner
1395  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1396  x_tl(npx+i, npy-1+j) = y_tl(npx-j, npy+i)
1397  x(npx+i, npy-1+j) = y(npx-j, npy+i)
1398  end if
1399  end do
1400  end do
1401  do j=1,ng
1402  do i=1,ng
1403 !sw corner
1404  if (is .eq. 1 .and. js .eq. 1) then
1405  y_tl(1-i, 1-j) = x_tl(1-j, i)
1406  y(1-i, 1-j) = x(1-j, i)
1407  end if
1408 !nw corner
1409  if (is .eq. 1 .and. je + 1 .eq. npy) then
1410  y_tl(1-i, npy+j) = mysign*x_tl(1-j, npy-i)
1411  y(1-i, npy+j) = mysign*x(1-j, npy-i)
1412  end if
1413 !se corner
1414  if (ie + 1 .eq. npx .and. js .eq. 1) then
1415  y_tl(npx-1+i, 1-j) = mysign*x_tl(npx+j, i)
1416  y(npx-1+i, 1-j) = mysign*x(npx+j, i)
1417  end if
1418 !ne corner
1419  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1420  y_tl(npx-1+i, npy+j) = x_tl(npx+j, npy-i)
1421  y(npx-1+i, npy+j) = x(npx+j, npy-i)
1422  end if
1423  end do
1424  end do
1425  end subroutine fill_corners_cgrid_r4_tlm
1426 
1427  subroutine fill_corners_cgrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, &
1428 & mysign)
1429  implicit none
1430  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x
1431  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x_tl
1432  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y
1433  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y_tl
1434  integer, intent(in) :: npx, npy
1435  real(kind=8), intent(in) :: mysign
1436  integer :: i, j
1437  do j=1,ng
1438  do i=1,ng
1439 !sw corner
1440  if (is .eq. 1 .and. js .eq. 1) then
1441  x_tl(1-i, 1-j) = y_tl(j, 1-i)
1442  x(1-i, 1-j) = y(j, 1-i)
1443  end if
1444 !nw corner
1445  if (is .eq. 1 .and. je + 1 .eq. npy) then
1446  x_tl(1-i, npy-1+j) = mysign*y_tl(j, npy+i)
1447  x(1-i, npy-1+j) = mysign*y(j, npy+i)
1448  end if
1449 !se corner
1450  if (ie + 1 .eq. npx .and. js .eq. 1) then
1451  x_tl(npx+i, 1-j) = mysign*y_tl(npx-j, 1-i)
1452  x(npx+i, 1-j) = mysign*y(npx-j, 1-i)
1453  end if
1454 !ne corner
1455  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1456  x_tl(npx+i, npy-1+j) = y_tl(npx-j, npy+i)
1457  x(npx+i, npy-1+j) = y(npx-j, npy+i)
1458  end if
1459  end do
1460  end do
1461  do j=1,ng
1462  do i=1,ng
1463 !sw corner
1464  if (is .eq. 1 .and. js .eq. 1) then
1465  y_tl(1-i, 1-j) = x_tl(1-j, i)
1466  y(1-i, 1-j) = x(1-j, i)
1467  end if
1468 !nw corner
1469  if (is .eq. 1 .and. je + 1 .eq. npy) then
1470  y_tl(1-i, npy+j) = mysign*x_tl(1-j, npy-i)
1471  y(1-i, npy+j) = mysign*x(1-j, npy-i)
1472  end if
1473 !se corner
1474  if (ie + 1 .eq. npx .and. js .eq. 1) then
1475  y_tl(npx-1+i, 1-j) = mysign*x_tl(npx+j, i)
1476  y(npx-1+i, 1-j) = mysign*x(npx+j, i)
1477  end if
1478 !ne corner
1479  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1480  y_tl(npx-1+i, npy+j) = x_tl(npx+j, npy-i)
1481  y(npx-1+i, npy+j) = x(npx+j, npy-i)
1482  end if
1483  end do
1484  end do
1485  end subroutine fill_corners_cgrid_r8_tlm
1486 
1487  subroutine fill_corners_dgrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, &
1488 & mysign)
1489  implicit none
1490  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x
1491  real(kind=4), dimension(isd:, jsd:), intent(inout) :: x_tl
1492  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y
1493  real(kind=4), dimension(isd:, jsd:), intent(inout) :: y_tl
1494  integer, intent(in) :: npx, npy
1495  real(kind=4), intent(in) :: mysign
1496  integer :: i, j
1497  do j=1,ng
1498  do i=1,ng
1499 ! if ((is == 1) .and. (js == 1)) x(1-i ,1-j ) = y(j+1 ,1-i ) !sw corner
1500 ! if ((is == 1) .and. (je+1==npy)) x(1-i ,npy+j) = mysign*y(j+1 ,npy-1+i) !nw corner
1501 ! if ((ie+1==npx) .and. (js == 1)) x(npx-1+i,1-j ) = mysign*y(npx-j,1-i ) !se corner
1502 ! if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) = y(npx-j,npy-1+i) !ne corner
1503 !sw corner
1504  if (is .eq. 1 .and. js .eq. 1) then
1505  x_tl(1-i, 1-j) = mysign*y_tl(1-j, i)
1506  x(1-i, 1-j) = mysign*y(1-j, i)
1507  end if
1508 !nw corner
1509  if (is .eq. 1 .and. je + 1 .eq. npy) then
1510  x_tl(1-i, npy+j) = y_tl(1-j, npy-i)
1511  x(1-i, npy+j) = y(1-j, npy-i)
1512  end if
1513 !se corner
1514  if (ie + 1 .eq. npx .and. js .eq. 1) then
1515  x_tl(npx-1+i, 1-j) = y_tl(npx+j, i)
1516  x(npx-1+i, 1-j) = y(npx+j, i)
1517  end if
1518 !ne corner
1519  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1520  x_tl(npx-1+i, npy+j) = mysign*y_tl(npx+j, npy-i)
1521  x(npx-1+i, npy+j) = mysign*y(npx+j, npy-i)
1522  end if
1523  end do
1524  end do
1525  do j=1,ng
1526  do i=1,ng
1527 ! if ((is == 1) .and. (js == 1)) y(1-i ,1-j ) = x(1-j ,i+1 ) !sw corner
1528 ! if ((is == 1) .and. (je+1==npy)) y(1-i ,npy-1+j) = mysign*x(1-j ,npy-i) !nw corner
1529 ! if ((ie+1==npx) .and. (js == 1)) y(npx+i ,1-j ) = mysign*x(npx-1+j,i+1 ) !se corner
1530 ! if ((ie+1==npx) .and. (je+1==npy)) y(npx+i ,npy-1+j) = x(npx-1+j,npy-i) !ne corner
1531 !sw corner
1532  if (is .eq. 1 .and. js .eq. 1) then
1533  y_tl(1-i, 1-j) = mysign*x_tl(j, 1-i)
1534  y(1-i, 1-j) = mysign*x(j, 1-i)
1535  end if
1536 !nw corner
1537  if (is .eq. 1 .and. je + 1 .eq. npy) then
1538  y_tl(1-i, npy-1+j) = x_tl(j, npy+i)
1539  y(1-i, npy-1+j) = x(j, npy+i)
1540  end if
1541 !se corner
1542  if (ie + 1 .eq. npx .and. js .eq. 1) then
1543  y_tl(npx+i, 1-j) = x_tl(npx-j, 1-i)
1544  y(npx+i, 1-j) = x(npx-j, 1-i)
1545  end if
1546 !ne corner
1547  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1548  y_tl(npx+i, npy-1+j) = mysign*x_tl(npx-j, npy+i)
1549  y(npx+i, npy-1+j) = mysign*x(npx-j, npy+i)
1550  end if
1551  end do
1552  end do
1553  end subroutine fill_corners_dgrid_r4_tlm
1554 
1555  subroutine fill_corners_dgrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, &
1556 & mysign)
1557  implicit none
1558  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x
1559  real(kind=8), dimension(isd:, jsd:), intent(inout) :: x_tl
1560  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y
1561  real(kind=8), dimension(isd:, jsd:), intent(inout) :: y_tl
1562  integer, intent(in) :: npx, npy
1563  real(kind=8), intent(in) :: mysign
1564  integer :: i, j
1565  do j=1,ng
1566  do i=1,ng
1567 ! if ((is == 1) .and. (js == 1)) x(1-i ,1-j ) = y(j+1 ,1-i ) !sw corner
1568 ! if ((is == 1) .and. (je+1==npy)) x(1-i ,npy+j) = mysign*y(j+1 ,npy-1+i) !nw corner
1569 ! if ((ie+1==npx) .and. (js == 1)) x(npx-1+i,1-j ) = mysign*y(npx-j,1-i ) !se corner
1570 ! if ((ie+1==npx) .and. (je+1==npy)) x(npx-1+i,npy+j) = y(npx-j,npy-1+i) !ne corner
1571 !sw corner
1572  if (is .eq. 1 .and. js .eq. 1) then
1573  x_tl(1-i, 1-j) = mysign*y_tl(1-j, i)
1574  x(1-i, 1-j) = mysign*y(1-j, i)
1575  end if
1576 !nw corner
1577  if (is .eq. 1 .and. je + 1 .eq. npy) then
1578  x_tl(1-i, npy+j) = y_tl(1-j, npy-i)
1579  x(1-i, npy+j) = y(1-j, npy-i)
1580  end if
1581 !se corner
1582  if (ie + 1 .eq. npx .and. js .eq. 1) then
1583  x_tl(npx-1+i, 1-j) = y_tl(npx+j, i)
1584  x(npx-1+i, 1-j) = y(npx+j, i)
1585  end if
1586 !ne corner
1587  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1588  x_tl(npx-1+i, npy+j) = mysign*y_tl(npx+j, npy-i)
1589  x(npx-1+i, npy+j) = mysign*y(npx+j, npy-i)
1590  end if
1591  end do
1592  end do
1593  do j=1,ng
1594  do i=1,ng
1595 ! if ((is == 1) .and. (js == 1)) y(1-i ,1-j ) = x(1-j ,i+1 ) !sw corner
1596 ! if ((is == 1) .and. (je+1==npy)) y(1-i ,npy-1+j) = mysign*x(1-j ,npy-i) !nw corner
1597 ! if ((ie+1==npx) .and. (js == 1)) y(npx+i ,1-j ) = mysign*x(npx-1+j,i+1 ) !se corner
1598 ! if ((ie+1==npx) .and. (je+1==npy)) y(npx+i ,npy-1+j) = x(npx-1+j,npy-i) !ne corner
1599 !sw corner
1600  if (is .eq. 1 .and. js .eq. 1) then
1601  y_tl(1-i, 1-j) = mysign*x_tl(j, 1-i)
1602  y(1-i, 1-j) = mysign*x(j, 1-i)
1603  end if
1604 !nw corner
1605  if (is .eq. 1 .and. je + 1 .eq. npy) then
1606  y_tl(1-i, npy-1+j) = x_tl(j, npy+i)
1607  y(1-i, npy-1+j) = x(j, npy+i)
1608  end if
1609 !se corner
1610  if (ie + 1 .eq. npx .and. js .eq. 1) then
1611  y_tl(npx+i, 1-j) = x_tl(npx-j, 1-i)
1612  y(npx+i, 1-j) = x(npx-j, 1-i)
1613  end if
1614 !ne corner
1615  if (ie + 1 .eq. npx .and. je + 1 .eq. npy) then
1616  y_tl(npx+i, npy-1+j) = mysign*x_tl(npx-j, npy+i)
1617  y(npx+i, npy-1+j) = mysign*x(npx-j, npy+i)
1618  end if
1619  end do
1620  end do
1621  end subroutine fill_corners_dgrid_r8_tlm
1622 
1623 
1624 ! mp_reduce_sum_tlm
1625 ! -----------------
1626 
1627  subroutine mp_reduce_sum_r4_tlm(mysum,mysum_tl)
1628  real(kind=4), intent(INOUT) :: mysum, mysum_tl
1629 
1630  real(kind=4) :: gsum, gsum_tl
1631 
1632  call mpi_allreduce( mysum, gsum, 1, mpi_real, mpi_sum, &
1633  commglobal, ierror )
1634  call mpi_allreduce( mysum_tl, gsum_tl, 1, mpi_real, mpi_sum, &
1635  commglobal, ierror )
1636 
1637  mysum = gsum
1638  mysum_tl = 0.0!gsum_tl
1639 
1640  end subroutine mp_reduce_sum_r4_tlm
1641 
1642  subroutine mp_reduce_sum_r8_tlm(mysum,mysum_tl)
1643  real(kind=8), intent(INOUT) :: mysum, mysum_tl
1644 
1645  real(kind=8) :: gsum, gsum_tl
1646 
1647  call mpi_allreduce( mysum, gsum, 1, mpi_double_precision, mpi_sum, &
1648  commglobal, ierror )
1649  call mpi_allreduce( mysum_tl, gsum_tl, 1, mpi_double_precision, mpi_sum, &
1650  commglobal, ierror )
1651 
1652  mysum = gsum
1653  mysum_tl = 0.0!gsum_tl
1654 
1655  end subroutine mp_reduce_sum_r8_tlm
1656 
1657  subroutine mp_reduce_sum_r4_1d_tlm(mysum, mysum_tl, sum1d, sum1d_tl, npts)
1658  integer, intent(in) :: npts
1659  real(kind=4), intent(in) :: sum1d(npts), sum1d_tl(npts)
1660  real(kind=4), intent(INOUT) :: mysum, mysum_tl
1661 
1662  real(kind=4) :: gsum, gsum_tl
1663  integer :: i
1664 
1665  mysum = 0.0
1666  mysum_tl = 0.0
1667  do i=1,npts
1668  mysum = mysum + sum1d(i)
1669  mysum_tl = mysum_tl + sum1d_tl(i)
1670  enddo
1671 
1672  call mpi_allreduce( mysum, gsum, 1, mpi_double_precision, mpi_sum, &
1673  commglobal, ierror )
1674  call mpi_allreduce( mysum_tl, gsum_tl, 1, mpi_double_precision, mpi_sum, &
1675  commglobal, ierror )
1676 
1677  mysum = gsum
1678  mysum_tl = 0.0!gsum_tl
1679 
1680  end subroutine mp_reduce_sum_r4_1d_tlm
1681 
1682  subroutine mp_reduce_sum_r8_1d_tlm(mysum, mysum_tl, sum1d, sum1d_tl, npts)
1683  integer, intent(in) :: npts
1684  real(kind=8), intent(in) :: sum1d(npts), sum1d_tl(npts)
1685  real(kind=8), intent(INOUT) :: mysum, mysum_tl
1686 
1687  real(kind=8) :: gsum, gsum_tl
1688  integer :: i
1689 
1690  mysum = 0.0
1691  mysum_tl = 0.0
1692  do i=1,npts
1693  mysum = mysum + sum1d(i)
1694  mysum_tl = mysum_tl + sum1d_tl(i)
1695  enddo
1696 
1697  call mpi_allreduce( mysum, gsum, 1, mpi_double_precision, mpi_sum, &
1698  commglobal, ierror )
1699  call mpi_allreduce( mysum_tl, gsum_tl, 1, mpi_double_precision, mpi_sum, &
1700  commglobal, ierror )
1701 
1702 
1703  mysum = gsum
1704  mysum_tl = 0.0!gsum_tl
1705 
1706  end subroutine mp_reduce_sum_r8_1d_tlm
1707 
1708 
1709 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1710 !!! MPP_DOMAINS INTERFACES THAT ARE NOT NORMALLY IN FV_MP_MOD !!!
1711 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1712 
1713 
1714 ! mpp_global_sum_tlm
1715 ! ------------------
1716 
1717  real(kind=r_grid) function mpp_global_sum_2d_tlm(domain, field, field_tl, flags, position, tile_count, mpp_global_sum_2d)
1718 
1719  implicit none
1720  type(domain2d), intent(in) :: domain
1721  real(r_grid), intent(in) :: field(:, :)
1722  real(r_grid), intent(in) :: field_tl(:, :)
1723  integer, intent(in), optional :: flags
1724  integer, intent(in), optional :: position
1725  integer, intent(in), optional :: tile_count
1726  real(kind=r_grid) :: mpp_global_sum_2d
1727 
1728  mpp_global_sum_2d = mpp_global_sum(domain,field,flags=flags,position=position,tile_count=tile_count)
1729  mpp_global_sum_2d_tlm = 0.0!mpp_global_sum(domain,field_tl,flags=flags,position=position,tile_count=tile_count)
1730 
1731  end function mpp_global_sum_2d_tlm
1732 
1733 
1734 ! mpp_update_domains_tlm
1735 ! ----------------------
1736 
1737 subroutine mpp_update_domain2d_2d_tlm(array, array_tl, domain, flags, complete, position, &
1738  whalo, ehalo, shalo, nhalo, name, tile_count)
1739 
1740  real, dimension(:,:), intent(inout) :: array, array_tl
1741  type(domain2d), intent(inout) :: domain
1742  integer, intent(in), optional :: flags
1743  logical, intent(in), optional :: complete
1744  integer, intent(in), optional :: position
1745  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1746  character(len=*), intent(in), optional :: name
1747  integer, intent(in), optional :: tile_count
1748 
1749  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1750 
1751  call mpp_update_domains( array, domain, &
1752  flags = flags, complete = complete, position = position, &
1753  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1754  name = name, tile_count = tile_count )
1755  call mpp_update_domains( array_tl, domain, &
1756  flags = flags, complete = complete, position = position, &
1757  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1758  name = name, tile_count = tile_count )
1759 
1760  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1761 
1762 end subroutine mpp_update_domain2d_2d_tlm
1763 
1764 subroutine mpp_update_domain2d_3d_tlm(array, array_tl, domain, flags, complete, position, &
1765  whalo, ehalo, shalo, nhalo, name, tile_count)
1766 
1767  real, dimension(:,:,:), intent(inout) :: array, array_tl
1768  type(domain2d), intent(inout) :: domain
1769  integer, intent(in), optional :: flags
1770  logical, intent(in), optional :: complete
1771  integer, intent(in), optional :: position
1772  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1773  character(len=*), intent(in), optional :: name
1774  integer, intent(in), optional :: tile_count
1775 
1776  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1777 
1778  call mpp_update_domains( array, domain, &
1779  flags = flags, complete = complete, position = position, &
1780  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1781  name = name, tile_count = tile_count )
1782  call mpp_update_domains( array_tl, domain, &
1783  flags = flags, complete = complete, position = position, &
1784  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1785  name = name, tile_count = tile_count )
1786 
1787  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1788 
1789 end subroutine mpp_update_domain2d_3d_tlm
1790 
1791 subroutine mpp_update_domain2d_4d_tlm(array, array_tl, domain, flags, complete, position, &
1792  whalo, ehalo, shalo, nhalo, name, tile_count)
1793 
1794  real, dimension(:,:,:,:), intent(inout) :: array, array_tl
1795  type(domain2d), intent(inout) :: domain
1796  integer, intent(in), optional :: flags
1797  logical, intent(in), optional :: complete
1798  integer, intent(in), optional :: position
1799  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1800  character(len=*), intent(in), optional :: name
1801  integer, intent(in), optional :: tile_count
1802 
1803  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1804 
1805  call mpp_update_domains( array, domain, &
1806  flags = flags, complete = complete, position = position, &
1807  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1808  name = name, tile_count = tile_count )
1809  call mpp_update_domains( array_tl, domain, &
1810  flags = flags, complete = complete, position = position, &
1811  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1812  name = name, tile_count = tile_count )
1813 
1814  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1815 
1816 end subroutine mpp_update_domain2d_4d_tlm
1817 
1818 subroutine mpp_update_domain2d_5d_tlm(array, array_tl, domain, flags, complete, position, &
1819  whalo, ehalo, shalo, nhalo, name, tile_count)
1820 
1821  real, dimension(:,:,:,:,:), intent(inout) :: array, array_tl
1822  type(domain2d), intent(inout) :: domain
1823  integer, intent(in), optional :: flags
1824  logical, intent(in), optional :: complete
1825  integer, intent(in), optional :: position
1826  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1827  character(len=*), intent(in), optional :: name
1828  integer, intent(in), optional :: tile_count
1829 
1830  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1831 
1832  call mpp_update_domains( array, domain, &
1833  flags = flags, complete = complete, position = position, &
1834  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1835  name = name, tile_count = tile_count )
1836  call mpp_update_domains( array_tl, domain, &
1837  flags = flags, complete = complete, position = position, &
1838  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1839  name = name, tile_count = tile_count )
1840 
1841  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1842 
1843 end subroutine mpp_update_domain2d_5d_tlm
1844 
1845 subroutine mpp_update_domain2d_2dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, &
1846  whalo, ehalo, shalo, nhalo, name, tile_count )
1847 
1848  real, dimension(:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmpt_tl, v_cmpt_tl
1849  type(domain2d), intent(inout) :: domain
1850  integer, intent(in), optional :: flags, gridtype
1851  logical, intent(in), optional :: complete
1852  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1853  character(len=*), intent(in), optional :: name
1854  integer, intent(in), optional :: tile_count
1855 
1856  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1857 
1858  call mpp_update_domains( u_cmpt,v_cmpt,domain,flags = flags, gridtype = gridtype, complete = complete, &
1859  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1860  name = name, tile_count = tile_count )
1861  call mpp_update_domains( u_cmpt_tl,v_cmpt_tl,domain,flags = flags, gridtype = gridtype, complete = complete, &
1862  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1863  name = name, tile_count = tile_count )
1864 
1865  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1866 
1867 end subroutine mpp_update_domain2d_2dv_tlm
1868 
1869 subroutine mpp_update_domain2d_3dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, &
1870  whalo, ehalo, shalo, nhalo, name, tile_count )
1871 
1872  real, dimension(:,:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmpt_tl, v_cmpt_tl
1873  type(domain2d), intent(inout) :: domain
1874  integer, intent(in), optional :: flags, gridtype
1875  logical, intent(in), optional :: complete
1876  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1877  character(len=*), intent(in), optional :: name
1878  integer, intent(in), optional :: tile_count
1879 
1880  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1881 
1882  call mpp_update_domains( u_cmpt,v_cmpt,domain,flags = flags, gridtype = gridtype, complete = complete, &
1883  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1884  name = name, tile_count = tile_count )
1885  call mpp_update_domains( u_cmpt_tl,v_cmpt_tl,domain,flags = flags, gridtype = gridtype, complete = complete, &
1886  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1887  name = name, tile_count = tile_count )
1888 
1889  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1890 
1891 end subroutine mpp_update_domain2d_3dv_tlm
1892 
1893 subroutine mpp_update_domain2d_4dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, &
1894  whalo, ehalo, shalo, nhalo, name, tile_count )
1895 
1896  real, dimension(:,:,:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmpt_tl, v_cmpt_tl
1897  type(domain2d), intent(inout) :: domain
1898  integer, intent(in), optional :: flags, gridtype
1899  logical, intent(in), optional :: complete
1900  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1901  character(len=*), intent(in), optional :: name
1902  integer, intent(in), optional :: tile_count
1903 
1904  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1905 
1906  call mpp_update_domains( u_cmpt,v_cmpt,domain,flags = flags, gridtype = gridtype, complete = complete, &
1907  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1908  name = name, tile_count = tile_count )
1909  call mpp_update_domains( u_cmpt_tl,v_cmpt_tl,domain,flags = flags, gridtype = gridtype, complete = complete, &
1910  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1911  name = name, tile_count = tile_count )
1912 
1913  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1914 
1915 end subroutine mpp_update_domain2d_4dv_tlm
1916 
1917 subroutine mpp_update_domain2d_5dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, &
1918  whalo, ehalo, shalo, nhalo, name, tile_count )
1919 
1920  real, dimension(:,:,:,:,:), intent(inout) :: u_cmpt, v_cmpt, u_cmpt_tl, v_cmpt_tl
1921  type(domain2d), intent(inout) :: domain
1922  integer, intent(in), optional :: flags, gridtype
1923  logical, intent(in), optional :: complete
1924  integer, intent(in), optional :: whalo, ehalo, shalo, nhalo
1925  character(len=*), intent(in), optional :: name
1926  integer, intent(in), optional :: tile_count
1927 
1928  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1929 
1930  call mpp_update_domains( u_cmpt,v_cmpt,domain,flags = flags, gridtype = gridtype, complete = complete, &
1931  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1932  name = name, tile_count = tile_count )
1933  call mpp_update_domains( u_cmpt_tl,v_cmpt_tl,domain,flags = flags, gridtype = gridtype, complete = complete, &
1934  whalo = whalo, ehalo = ehalo, shalo = shalo, nhalo = nhalo, &
1935  name = name, tile_count = tile_count )
1936 
1937  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1938 
1939 end subroutine mpp_update_domain2d_5dv_tlm
1940 
1941 
1942 ! mpp_get_boundary_tlm
1943 ! --------------------
1944 
1945  subroutine mpp_get_boundary_2d_tlm( array, array_tl, domain, &
1946  ebuffer, ebuffer_tl, &
1947  sbuffer, sbuffer_tl, &
1948  wbuffer, wbuffer_tl, &
1949  nbuffer, nbuffer_tl, &
1950  flags, position, complete, tile_count )
1951 
1952  real, dimension(:,:), intent(in) :: array, array_tl
1953  type(domain2d), intent(in) :: domain
1954  real, intent(inout), optional :: ebuffer(:), sbuffer(:), wbuffer(:), nbuffer(:)
1955  real, intent(inout), optional :: ebuffer_tl(:), sbuffer_tl(:), wbuffer_tl(:), nbuffer_tl(:)
1956  integer, intent(in), optional :: flags, position, tile_count
1957  logical, intent(in), optional :: complete
1958 
1959  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
1960 
1961  if (present(wbuffer)) wbuffer = 0.0
1962  if (present(sbuffer)) sbuffer = 0.0
1963  if (present(ebuffer)) ebuffer = 0.0
1964  if (present(nbuffer)) nbuffer = 0.0
1965  if (present(wbuffer_tl)) wbuffer_tl = 0.0
1966  if (present(sbuffer_tl)) sbuffer_tl = 0.0
1967  if (present(ebuffer_tl)) ebuffer_tl = 0.0
1968  if (present(nbuffer_tl)) nbuffer_tl = 0.0
1969 
1970  call mpp_get_boundary( array,domain,ebuffer=ebuffer,sbuffer=sbuffer,wbuffer=wbuffer,nbuffer=nbuffer,&
1971  flags = flags, position = position, complete = complete, tile_count = tile_count )
1972  call mpp_get_boundary( array_tl,domain,ebuffer=ebuffer_tl,sbuffer=sbuffer_tl,wbuffer=wbuffer_tl,nbuffer=nbuffer_tl,&
1973  flags = flags, position = position, complete = complete, tile_count = tile_count )
1974 
1975  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
1976 
1977 end subroutine mpp_get_boundary_2d_tlm
1978 
1979  subroutine mpp_get_boundary_3d_tlm( array, array_tl, domain, &
1980  ebuffer, ebuffer_tl, &
1981  sbuffer, sbuffer_tl, &
1982  wbuffer, wbuffer_tl, &
1983  nbuffer, nbuffer_tl, &
1984  flags, position, complete, tile_count )
1985 
1986  real, dimension(:,:,:), intent(in) :: array, array_tl
1987  type(domain2d), intent(in) :: domain
1988  real, intent(inout), optional :: ebuffer(:,:), sbuffer(:,:), wbuffer(:,:), nbuffer(:,:)
1989  real, intent(inout), optional :: ebuffer_tl(:,:), sbuffer_tl(:,:), wbuffer_tl(:,:), nbuffer_tl(:,:)
1990  integer, intent(in), optional :: flags, position, tile_count
1991  logical, intent(in), optional :: complete
1992 
1993  if (present(wbuffer)) wbuffer = 0.0
1994  if (present(sbuffer)) sbuffer = 0.0
1995  if (present(ebuffer)) ebuffer = 0.0
1996  if (present(nbuffer)) nbuffer = 0.0
1997  if (present(wbuffer_tl)) wbuffer_tl = 0.0
1998  if (present(sbuffer_tl)) sbuffer_tl = 0.0
1999  if (present(ebuffer_tl)) ebuffer_tl = 0.0
2000  if (present(nbuffer_tl)) nbuffer_tl = 0.0
2001 
2002  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
2003 
2004  call mpp_get_boundary( array,domain,ebuffer=ebuffer,sbuffer=sbuffer,wbuffer=wbuffer,nbuffer=nbuffer,&
2005  flags = flags, position = position, complete = complete, tile_count = tile_count )
2006  call mpp_get_boundary( array_tl,domain,ebuffer=ebuffer_tl,sbuffer=sbuffer_tl,wbuffer=wbuffer_tl,nbuffer=nbuffer_tl,&
2007  flags = flags, position = position, complete = complete, tile_count = tile_count )
2008 
2009  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
2010 
2011 end subroutine mpp_get_boundary_3d_tlm
2012 
2013  subroutine mpp_get_boundary_2dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, &
2014  ebufferx, ebufferx_tl, &
2015  sbufferx, sbufferx_tl, &
2016  wbufferx, wbufferx_tl, &
2017  nbufferx, nbufferx_tl, &
2018  ebuffery, ebuffery_tl, &
2019  sbuffery, sbuffery_tl, &
2020  wbuffery, wbuffery_tl, &
2021  nbuffery, nbuffery_tl, &
2022  flags, gridtype, complete, tile_count )
2023 
2024  real, dimension(:,:), intent(in) :: u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl
2025  type(domain2d), intent(in) :: domain
2026  real, intent(inout), optional :: ebufferx(:), sbufferx(:), wbufferx(:), nbufferx(:)
2027  real, intent(inout), optional :: ebufferx_tl(:), sbufferx_tl(:), wbufferx_tl(:), nbufferx_tl(:)
2028  real, intent(inout), optional :: ebuffery(:), sbuffery(:), wbuffery(:), nbuffery(:)
2029  real, intent(inout), optional :: ebuffery_tl(:), sbuffery_tl(:), wbuffery_tl(:), nbuffery_tl(:)
2030  integer, intent(in), optional :: flags, gridtype, tile_count
2031  logical, intent(in), optional :: complete
2032 
2033  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
2034 
2035  if (present(wbufferx)) wbufferx = 0.0
2036  if (present(sbufferx)) sbufferx = 0.0
2037  if (present(ebufferx)) ebufferx = 0.0
2038  if (present(nbufferx)) nbufferx = 0.0
2039  if (present(wbufferx_tl)) wbufferx_tl = 0.0
2040  if (present(sbufferx_tl)) sbufferx_tl = 0.0
2041  if (present(ebufferx_tl)) ebufferx_tl = 0.0
2042  if (present(nbufferx_tl)) nbufferx_tl = 0.0
2043  if (present(wbuffery)) wbuffery = 0.0
2044  if (present(sbuffery)) sbuffery = 0.0
2045  if (present(ebuffery)) ebuffery = 0.0
2046  if (present(nbuffery)) nbuffery = 0.0
2047  if (present(wbuffery_tl)) wbuffery_tl = 0.0
2048  if (present(sbuffery_tl)) sbuffery_tl = 0.0
2049  if (present(ebuffery_tl)) ebuffery_tl = 0.0
2050  if (present(nbuffery_tl)) nbuffery_tl = 0.0
2051 
2052  call mpp_get_boundary( u_cmpt, v_cmpt, domain, &
2053  ebufferx = ebufferx, &
2054  sbufferx = sbufferx, &
2055  wbufferx = wbufferx, &
2056  nbufferx = nbufferx, &
2057  ebuffery = ebuffery, &
2058  sbuffery = sbuffery, &
2059  wbuffery = wbuffery, &
2060  nbuffery = nbuffery, &
2061  flags = flags, gridtype = gridtype, &
2062  complete = complete, tile_count = tile_count )
2063 
2064  call mpp_get_boundary( u_cmpt_tl, v_cmpt_tl, domain, &
2065  ebufferx = ebufferx_tl, &
2066  sbufferx = sbufferx_tl, &
2067  wbufferx = wbufferx_tl, &
2068  nbufferx = nbufferx_tl, &
2069  ebuffery = ebuffery_tl, &
2070  sbuffery = sbuffery_tl, &
2071  wbuffery = wbuffery_tl, &
2072  nbuffery = nbuffery_tl, &
2073  flags = flags, gridtype = gridtype, &
2074  complete = complete, tile_count = tile_count )
2075 
2076  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
2077 
2078 end subroutine mpp_get_boundary_2dv_tlm
2079 
2080  subroutine mpp_get_boundary_3dv_tlm( u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, &
2081  ebufferx, ebufferx_tl, &
2082  sbufferx, sbufferx_tl, &
2083  wbufferx, wbufferx_tl, &
2084  nbufferx, nbufferx_tl, &
2085  ebuffery, ebuffery_tl, &
2086  sbuffery, sbuffery_tl, &
2087  wbuffery, wbuffery_tl, &
2088  nbuffery, nbuffery_tl, &
2089  flags, gridtype, complete, tile_count )
2090 
2091  real, dimension(:,:,:), intent(in) :: u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl
2092  type(domain2d), intent(in) :: domain
2093  real, intent(inout), optional :: ebufferx(:,:), sbufferx(:,:), wbufferx(:,:), nbufferx(:,:)
2094  real, intent(inout), optional :: ebufferx_tl(:,:), sbufferx_tl(:,:), wbufferx_tl(:,:), nbufferx_tl(:,:)
2095  real, intent(inout), optional :: ebuffery(:,:), sbuffery(:,:), wbuffery(:,:), nbuffery(:,:)
2096  real, intent(inout), optional :: ebuffery_tl(:,:), sbuffery_tl(:,:), wbuffery_tl(:,:), nbuffery_tl(:,:)
2097  integer, intent(in), optional :: flags, gridtype, tile_count
2098  logical, intent(in), optional :: complete
2099 
2100  if (fv_timing_onoff) call timing_on(' TLM_COMM_TOTAL')
2101 
2102  if (present(wbufferx)) wbufferx = 0.0
2103  if (present(sbufferx)) sbufferx = 0.0
2104  if (present(ebufferx)) ebufferx = 0.0
2105  if (present(nbufferx)) nbufferx = 0.0
2106  if (present(wbufferx_tl)) wbufferx_tl = 0.0
2107  if (present(sbufferx_tl)) sbufferx_tl = 0.0
2108  if (present(ebufferx_tl)) ebufferx_tl = 0.0
2109  if (present(nbufferx_tl)) nbufferx_tl = 0.0
2110  if (present(wbuffery)) wbuffery = 0.0
2111  if (present(sbuffery)) sbuffery = 0.0
2112  if (present(ebuffery)) ebuffery = 0.0
2113  if (present(nbuffery)) nbuffery = 0.0
2114  if (present(wbuffery_tl)) wbuffery_tl = 0.0
2115  if (present(sbuffery_tl)) sbuffery_tl = 0.0
2116  if (present(ebuffery_tl)) ebuffery_tl = 0.0
2117  if (present(nbuffery_tl)) nbuffery_tl = 0.0
2118 
2119  call mpp_get_boundary( u_cmpt, v_cmpt, domain, &
2120  ebufferx = ebufferx, &
2121  sbufferx = sbufferx, &
2122  wbufferx = wbufferx, &
2123  nbufferx = nbufferx, &
2124  ebuffery = ebuffery, &
2125  sbuffery = sbuffery, &
2126  wbuffery = wbuffery, &
2127  nbuffery = nbuffery, &
2128  flags = flags, gridtype = gridtype, &
2129  complete = complete, tile_count = tile_count )
2130 
2131  call mpp_get_boundary( u_cmpt_tl, v_cmpt_tl, domain, &
2132  ebufferx = ebufferx_tl, &
2133  sbufferx = sbufferx_tl, &
2134  wbufferx = wbufferx_tl, &
2135  nbufferx = nbufferx_tl, &
2136  ebuffery = ebuffery_tl, &
2137  sbuffery = sbuffery_tl, &
2138  wbuffery = wbuffery_tl, &
2139  nbuffery = nbuffery_tl, &
2140  flags = flags, gridtype = gridtype, &
2141  complete = complete, tile_count = tile_count )
2142 
2143  if (fv_timing_onoff) call timing_off(' TLM_COMM_TOTAL')
2144 
2145 end subroutine mpp_get_boundary_3dv_tlm
2146 
2147 end module fv_mp_tlm_mod
fv_mp_tlm_mod::start_var_group_update_2d_tlm
subroutine start_var_group_update_2d_tlm(group, group_tl, array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
Definition: fv_mp_tlm.F90:415
fv_mp_tlm_mod::start_vector_group_update_3d
subroutine start_vector_group_update_3d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_tlm.F90:349
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
fv_mp_tlm_mod::mpp_update_domain2d_5dv_tlm
subroutine mpp_update_domain2d_5dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1919
fv_mp_tlm_mod::fill_corners_2d_r4_tlm
subroutine fill_corners_2d_r4_tlm(q, q_tl, npx, npy, fill, agrid, bgrid)
Definition: fv_mp_tlm.F90:844
fv_mp_tlm_mod
Definition: fv_mp_tlm.F90:20
fv_mp_tlm_mod::fill_corners_xy_2d_r8_tlm
subroutine fill_corners_xy_2d_r8_tlm(x, x_tl, y, y_tl, npx, npy, dgrid, agrid, cgrid, vector)
Definition: fv_mp_tlm.F90:1220
fv_mp_tlm_mod::fill_corners_cgrid_r4_tlm
subroutine fill_corners_cgrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1369
fv_mp_tlm_mod::mpp_update_domain2d_3d_tlm
subroutine mpp_update_domain2d_3d_tlm(array, array_tl, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1766
fv_mp_tlm_mod::mpp_get_boundary_3dv_tlm
subroutine mpp_get_boundary_3dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, ebufferx, ebufferx_tl, sbufferx, sbufferx_tl, wbufferx, wbufferx_tl, nbufferx, nbufferx_tl, ebuffery, ebuffery_tl, sbuffery, sbuffery_tl, wbuffery, wbuffery_tl, nbuffery, nbuffery_tl, flags, gridtype, complete, tile_count)
Definition: fv_mp_tlm.F90:2090
fv_mp_tlm_mod::start_vector_group_update_2d_tlm
subroutine start_vector_group_update_2d_tlm(group, group_tl, u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete, complete_tl)
Definition: fv_mp_tlm.F90:641
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
fv_mp_tlm_mod::mp_reduce_sum_tlm
Definition: fv_mp_tlm.F90:94
fv_mp_tlm_mod::mpp_get_boundary_tlm
Definition: fv_mp_tlm.F90:120
fv_mp_tlm_mod::fill_corners_2d_r8_tlm
subroutine fill_corners_2d_r8_tlm(q, q_tl, npx, npy, fill, agrid, bgrid)
Definition: fv_mp_tlm.F90:1017
fv_mp_tlm_mod::fill_corners_dgrid_r8_tlm
subroutine fill_corners_dgrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1557
fv_mp_tlm_mod::ierror
integer ierror
Definition: fv_mp_tlm.F90:43
mpp_domains_mod::mpp_start_group_update
Definition: mpp_domains.F90:1406
fv_mp_tlm_mod::mpp_update_domain2d_4d_tlm
subroutine mpp_update_domain2d_4d_tlm(array, array_tl, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1793
fv_mp_tlm_mod::fill_corners_tlm
Definition: fv_mp_tlm.F90:72
fv_mp_tlm_mod::mpp_update_domain2d_4dv_tlm
subroutine mpp_update_domain2d_4dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1895
fv_mp_tlm_mod::fill_corners_xy_2d_r4_tlm
subroutine fill_corners_xy_2d_r4_tlm(x, x_tl, y, y_tl, npx, npy, dgrid, agrid, cgrid, vector)
Definition: fv_mp_tlm.F90:1191
fv_mp_tlm_mod::mpp_update_domains_tlm
Definition: fv_mp_tlm.F90:109
fv_mp_tlm_mod::start_var_group_update_4d
subroutine start_var_group_update_4d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_tlm.F90:235
fv_mp_tlm_mod::mp_reduce_sum_r4_tlm
subroutine mp_reduce_sum_r4_tlm(mysum, mysum_tl)
Definition: fv_mp_tlm.F90:1628
fv_mp_tlm_mod::fill_corners_cgrid_tlm
Definition: fv_mp_tlm.F90:84
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
fv_mp_tlm_mod::complete_group_halo_update
subroutine, public complete_group_halo_update(group, group_tl, domain)
Definition: fv_mp_tlm.F90:815
fv_mp_tlm_mod::start_vector_group_update_3d_tlm
subroutine start_vector_group_update_3d_tlm(group, group_tl, u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete, complete_tl)
Definition: fv_mp_tlm.F90:726
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_mp_tlm_mod::start_group_halo_update_tlm
Definition: fv_mp_tlm.F90:64
fv_mp_tlm_mod::fill_corners_agrid_r4_tlm
subroutine fill_corners_agrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1249
fv_mp_tlm_mod::fill_corners_dgrid_tlm
Definition: fv_mp_tlm.F90:89
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_tlm_mod::fill_corners_agrid_tlm
Definition: fv_mp_tlm.F90:79
fv_mp_tlm_mod::start_var_group_update_3d_tlm
subroutine start_var_group_update_3d_tlm(group, group_tl, array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
Definition: fv_mp_tlm.F90:489
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
fv_mp_tlm_mod::start_var_group_update_4d_tlm
subroutine start_var_group_update_4d_tlm(group, group_tl, array, array_tl, domain, flags, position, whalo, ehalo, shalo, nhalo, complete, complete_tl)
Definition: fv_mp_tlm.F90:563
fv_mp_tlm_mod::fill_corners_cgrid_r8_tlm
subroutine fill_corners_cgrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1429
mpp_domains_mod::mpp_complete_group_update
Definition: mpp_domains.F90:1411
fv_mp_tlm_mod::mpp_update_domain2d_2dv_tlm
subroutine mpp_update_domain2d_2dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1847
fv_mp_tlm_mod::start_vector_group_update_2d
subroutine start_vector_group_update_2d(group, u_cmpt, v_cmpt, domain, flags, gridtype, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_tlm.F90:291
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_mp_tlm_mod::mpp_get_boundary_3d_tlm
subroutine mpp_get_boundary_3d_tlm(array, array_tl, domain, ebuffer, ebuffer_tl, sbuffer, sbuffer_tl, wbuffer, wbuffer_tl, nbuffer, nbuffer_tl, flags, position, complete, tile_count)
Definition: fv_mp_tlm.F90:1985
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_tlm_mod::mp_reduce_sum_r8_tlm
subroutine mp_reduce_sum_r8_tlm(mysum, mysum_tl)
Definition: fv_mp_tlm.F90:1643
mpp_domains_mod::mpp_get_boundary
Definition: mpp_domains.F90:1900
fv_mp_tlm_mod::mpp_get_boundary_2dv_tlm
subroutine mpp_get_boundary_2dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, ebufferx, ebufferx_tl, sbufferx, sbufferx_tl, wbufferx, wbufferx_tl, nbufferx, nbufferx_tl, ebuffery, ebuffery_tl, sbuffery, sbuffery_tl, wbuffery, wbuffery_tl, nbuffery, nbuffery_tl, flags, gridtype, complete, tile_count)
Definition: fv_mp_tlm.F90:2023
fv_mp_tlm_mod::start_var_group_update_3d
subroutine start_var_group_update_3d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_tlm.F90:183
fv_mp_tlm_mod::start_group_halo_update
Definition: fv_mp_tlm.F90:56
fv_mp_tlm_mod::mpp_update_domain2d_5d_tlm
subroutine mpp_update_domain2d_5d_tlm(array, array_tl, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1820
fv_mp_tlm_mod::start_var_group_update_2d
subroutine start_var_group_update_2d(group, array, domain, flags, position, whalo, ehalo, shalo, nhalo, complete)
Definition: fv_mp_tlm.F90:131
fv_mp_tlm_mod::fill_corners_agrid_r8_tlm
subroutine fill_corners_agrid_r8_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1309
fv_mp_tlm_mod::mpp_update_domain2d_2d_tlm
subroutine mpp_update_domain2d_2d_tlm(array, array_tl, domain, flags, complete, position, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1739
fv_arrays_tlmadm_mod::fv_timing_onoff
logical fv_timing_onoff
Definition: fv_arrays_tlmadm.F90:27
fv_mp_tlm_mod::fill_corners_dgrid_r4_tlm
subroutine fill_corners_dgrid_r4_tlm(x, x_tl, y, y_tl, npx, npy, mysign)
Definition: fv_mp_tlm.F90:1489
fv_mp_tlm_mod::mp_reduce_sum_r4_1d_tlm
subroutine mp_reduce_sum_r4_1d_tlm(mysum, mysum_tl, sum1d, sum1d_tl, npts)
Definition: fv_mp_tlm.F90:1658
mpp_domains_mod::mpp_group_update_type
Definition: mpp_domains.F90:546
fv_mp_tlm_mod::mpp_global_sum_2d_tlm
real(kind=r_grid) function mpp_global_sum_2d_tlm(domain, field, field_tl, flags, position, tile_count, mpp_global_sum_2d)
Definition: fv_mp_tlm.F90:1718
mpp_domains_mod::mpp_create_group_update
Definition: mpp_domains.F90:1386
fv_mp_tlm_mod::commglobal
integer commglobal
Definition: fv_mp_tlm.F90:43
fv_mp_tlm_mod::mpp_global_sum_tlm
Definition: fv_mp_tlm.F90:105
fv_mp_tlm_mod::mpp_update_domain2d_3dv_tlm
subroutine mpp_update_domain2d_3dv_tlm(u_cmpt, u_cmpt_tl, v_cmpt, v_cmpt_tl, domain, flags, gridtype, complete, whalo, ehalo, shalo, nhalo, name, tile_count)
Definition: fv_mp_tlm.F90:1871
fv_mp_tlm_mod::mpp_get_boundary_2d_tlm
subroutine mpp_get_boundary_2d_tlm(array, array_tl, domain, ebuffer, ebuffer_tl, sbuffer, sbuffer_tl, wbuffer, wbuffer_tl, nbuffer, nbuffer_tl, flags, position, complete, tile_count)
Definition: fv_mp_tlm.F90:1951
fv_mp_tlm_mod::mp_reduce_sum_r8_1d_tlm
subroutine mp_reduce_sum_r8_1d_tlm(mysum, mysum_tl, sum1d, sum1d_tl, npts)
Definition: fv_mp_tlm.F90:1683
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175