FV3 Bundle
boundary_adm.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 boundary_adm_mod
21 
22  use fv_mp_nlm_mod, only: ng, isc,jsc,iec,jec, isd,jsd,ied,jed, is,js,ie,je, is_master
23  use constants_mod, only: grav
24 
25  use mpp_domains_mod, only: mpp_get_compute_domain, mpp_get_data_domain, mpp_get_global_domain
26  use mpp_domains_mod, only: center, corner, north, east
27  use mpp_domains_mod, only: mpp_global_field, mpp_get_pelist
28  use mpp_mod, only: mpp_error, fatal, mpp_sum, mpp_sync, mpp_npes, mpp_broadcast, warning, mpp_pe
29 
30  use fv_mp_nlm_mod, only: mp_bcst
31  use fv_arrays_nlm_mod, only: fv_atmos_type, fv_nest_bc_type_3d, fv_grid_bounds_type
32  use mpp_mod, only: mpp_send, mpp_recv
33  use fv_timing_nlm_mod, only: timing_on, timing_off
34  use mpp_domains_mod, only : nest_domain_type, west, south
35  use mpp_domains_mod, only : mpp_get_c2f_index, mpp_update_nest_fine
36  use mpp_domains_mod, only : mpp_get_f2c_index, mpp_update_nest_coarse
37  !use mpp_domains_mod, only : mpp_get_domain_shift
38 
39  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
40  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
41 
42  implicit none
43  public extrapolation_bc
44  public nested_grid_bc, update_coarse_grid
45  public fill_nested_grid, nested_grid_bc_apply_intt
46  public nested_grid_bc_send, nested_grid_bc_recv, nested_grid_bc_save_proc
47 
48  public nested_grid_bc_apply_intt_adm
49 
50  interface nested_grid_bc
51  module procedure nested_grid_bc_2d
52  module procedure nested_grid_bc_mpp
53  module procedure nested_grid_bc_mpp_send
54  module procedure nested_grid_bc_2d_mpp
55  module procedure nested_grid_bc_3d
56  end interface
57 
58 
59  interface fill_nested_grid
60  module procedure fill_nested_grid_2d
61  module procedure fill_nested_grid_3d
62  end interface
63 
64  interface update_coarse_grid
65  module procedure update_coarse_grid_mpp
66  module procedure update_coarse_grid_mpp_2d
67  end interface
68 
69 CONTAINS
70 !Linear extrapolation into halo region
71 !Not to be confused with extrapolated-in-time nested BCs
72  SUBROUTINE extrapolation_bc(q, istag, jstag, npx, npy, bd, pd_in, &
73 & debug_in)
74  IMPLICIT NONE
75  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
76  INTEGER, INTENT(IN) :: istag, jstag, npx, npy
77  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag), intent(&
78 & INOUT) :: q
79  LOGICAL, INTENT(IN), OPTIONAL :: pd_in, debug_in
80  INTEGER :: i, j, istart, iend, jstart, jend
81  LOGICAL :: pd, debug
82  INTEGER :: is, ie, js, je
83  INTEGER :: isd, ied, jsd, jed
84  INTRINSIC max
85  INTRINSIC min
86  INTRINSIC PRESENT
87  INTRINSIC real
88  is = bd%is
89  ie = bd%ie
90  js = bd%js
91  je = bd%je
92  isd = bd%isd
93  ied = bd%ied
94  jsd = bd%jsd
95  jed = bd%jed
96  IF (isd .LT. 1) THEN
97  istart = 1
98  ELSE
99  istart = isd
100  END IF
101  IF (ied .GT. npx - 1) THEN
102  iend = npx - 1
103  ELSE
104  iend = ied
105  END IF
106  IF (jsd .LT. 1) THEN
107  jstart = 1
108  ELSE
109  jstart = jsd
110  END IF
111  IF (jed .GT. npy - 1) THEN
112  jend = npy - 1
113  ELSE
114  jend = jed
115  END IF
116 !Positive-definite extrapolation: shift from linear extrapolation to zero-gradient when the extrapolated value turns negative.
117  IF (PRESENT(pd_in)) THEN
118  pd = pd_in
119  ELSE
120  pd = .false.
121  END IF
122  IF (PRESENT(debug_in)) THEN
123  debug = debug_in
124  ELSE
125  debug = .false.
126  END IF
127  IF (is .EQ. 1) THEN
128  IF (pd) THEN
129  DO j=jstart,jend+jstag
130  DO i=0,isd,-1
131  IF (REAL(i) .LE. 1. - q(1, j)/(q(2, j)-q(1, j)+1.e-12) .AND.&
132 & q(1, j) .LT. q(2, j)) THEN
133  q(i, j) = q(i+1, j)
134  ELSE
135  q(i, j) = REAL(2-i)*q(1, j) - REAL(1-i)*q(2, j)
136  END IF
137  END DO
138  END DO
139  ELSE
140  DO j=jstart,jend+jstag
141  DO i=0,isd,-1
142  q(i, j) = REAL(2-i)*q(1, j) - REAL(1-i)*q(2, j)
143  END DO
144  END DO
145  END IF
146  END IF
147  IF (js .EQ. 1) THEN
148  IF (pd) THEN
149  DO j=0,jsd,-1
150  DO i=istart,iend+istag
151  IF (REAL(j) .LE. 1. - q(i, 1)/(q(i, 2)-q(i, 1)+1.e-12) .AND.&
152 & q(i, 1) .LT. q(i, 2)) THEN
153  q(i, j) = q(i, j+1)
154  ELSE
155  q(i, j) = REAL(2-j)*q(i, 1) - REAL(1-j)*q(i, 2)
156  END IF
157  END DO
158  END DO
159  ELSE
160  DO j=0,jsd,-1
161  DO i=istart,iend+istag
162  q(i, j) = REAL(2-j)*q(i, 1) - REAL(1-j)*q(i, 2)
163  END DO
164  END DO
165  END IF
166  END IF
167  IF (ie .EQ. npx - 1) THEN
168  IF (pd) THEN
169  DO j=jstart,jend+jstag
170  DO i=ie+1+istag,ied+istag
171  IF (REAL(i) .GE. ie + istag + q(ie+istag, j)/(q(ie+istag-1, &
172 & j)-q(ie+istag, j)+1.e-12) .AND. q(ie+istag, j) .LT. q(ie&
173 & +istag-1, j)) THEN
174  q(i, j) = q(i-1, j)
175  ELSE
176  q(i, j) = REAL(i-(ie+istag-1))*q(ie+istag, j) + REAL(ie+&
177 & istag-i)*q(ie+istag-1, j)
178  end if
179  END DO
180  END DO
181  ELSE
182  DO j=jstart,jend+jstag
183  DO i=ie+1+istag,ied+istag
184  q(i, j) = REAL(i-(ie+istag-1))*q(ie+istag, j) + REAL(ie+&
185 & istag-i)*q(ie+istag-1, j)
186  end do
187  END DO
188  END IF
189  END IF
190  IF (je .EQ. npy - 1) THEN
191  IF (pd) THEN
192  DO j=je+1+jstag,jed+jstag
193  DO i=istart,iend+istag
194  IF (REAL(j) .GE. je + jstag + q(i, je+jstag)/(q(i, je+jstag-&
195 & 1)-q(i, je+jstag)+1.e-12) .AND. q(i, je+jstag-1) .GT. q(&
196 & i, je+jstag)) THEN
197  q(i, j) = q(i, j-1)
198  ELSE
199  q(i, j) = REAL(j-(je+jstag-1))*q(i, je+jstag) + REAL(je+&
200 & jstag-j)*q(i, je+jstag-1)
201  end if
202  END DO
203  END DO
204  ELSE
205  DO j=je+1+jstag,jed+jstag
206  DO i=istart,iend+istag
207  q(i, j) = REAL(j-(je+jstag-1))*q(i, je+jstag) + REAL(je+&
208 & jstag-j)*q(i, je+jstag-1)
209  end do
210  END DO
211  END IF
212  END IF
213 !CORNERS: Average of extrapolations
214  IF (is .EQ. 1 .AND. js .EQ. 1) THEN
215  IF (pd) THEN
216  DO j=0,jsd,-1
217  DO i=0,isd,-1
218  IF (REAL(i) .LE. 1. - q(1, j)/(q(2, j)-q(1, j)+1.e-12) .AND.&
219 & q(2, j) .GT. q(1, j)) THEN
220  q(i, j) = 0.5*q(i+1, j)
221  ELSE
222  q(i, j) = 0.5*(REAL(2-i)*q(1, j)-REAL(1-i)*q(2, j))
223  END IF
224  IF (REAL(j) .LE. 1. - q(i, 1)/(q(i, 2)-q(i, 1)+1.e-12) .AND.&
225 & q(i, 2) .GT. q(i, 1)) THEN
226  q(i, j) = q(i, j) + 0.5*q(i, j+1)
227  ELSE
228  q(i, j) = q(i, j) + 0.5*(REAL(2-j)*q(i, 1)-REAL(1-j)*q(i, &
229 & 2))
230  end if
231  END DO
232  END DO
233  ELSE
234  DO j=jsd,0
235  DO i=isd,0
236  q(i, j) = 0.5*(REAL(2-i)*q(1, j)-REAL(1-i)*q(2, j)) + 0.5*(&
237 & REAL(2-j)*q(i, 1)-REAL(1-j)*q(i, 2))
238  end do
239  END DO
240  END IF
241  END IF
242  IF (is .EQ. 1 .AND. je .EQ. npy - 1) THEN
243  IF (pd) THEN
244  DO j=je+1+jstag,jed+jstag
245  DO i=0,isd,-1
246  IF (REAL(i) .LE. 1. - q(1, j)/(q(2, j)-q(1, j)+1.e-12) .AND.&
247 & q(2, j) .GT. q(1, j)) THEN
248  q(i, j) = 0.5*q(i+1, j)
249  ELSE
250  q(i, j) = 0.5*(REAL(2-i)*q(1, j)-REAL(1-i)*q(2, j))
251  END IF
252 !'Unary plus' removed to appease IBM compiler
253 !if (real(j) >= je+jstag - q(i,je+jstag)/(q(i,je+jstag-1)-q(i,je+jstag)+1.e-12) .and. &
254  IF (REAL(j) .GE. je + jstag - q(i, je+jstag)/(q(i, je+jstag-&
255 & 1)-q(i, je+jstag)+1.e-12) .AND. q(i, je+jstag-1) .GT. q(&
256 & i, je+jstag)) THEN
257  q(i, j) = q(i, j) + 0.5*q(i, j-1)
258  ELSE
259  q(i, j) = q(i, j) + 0.5*(REAL(j-(je+jstag-1))*q(i, je+&
260 & jstag)+REAL(je+jstag-j)*q(i, je+jstag-1))
261  end if
262  END DO
263  END DO
264  ELSE
265  DO j=je+1+jstag,jed+jstag
266  DO i=isd,0
267  q(i, j) = 0.5*(REAL(2-i)*q(1, j)-REAL(1-i)*q(2, j)) + 0.5*(&
268 & REAL(j-(je+jstag-1))*q(i, je+jstag)+REAL(je+jstag-j)*q(i, &
269 & je+jstag-1))
270  end do
271  END DO
272  END IF
273  END IF
274  IF (ie .EQ. npx - 1 .AND. je .EQ. npy - 1) THEN
275  IF (pd) THEN
276  DO j=je+1+jstag,jed+jstag
277  DO i=ie+1+istag,ied+istag
278  IF (REAL(i) .GE. ie + istag + q(ie+istag, j)/(q(ie+istag-1, &
279 & j)-q(ie+istag, j)+1.e-12) .AND. q(ie+istag-1, j) .GT. q(&
280 & ie+istag, j)) THEN
281  q(i, j) = 0.5*q(i-1, j)
282  ELSE
283  q(i, j) = 0.5*(REAL(i-(ie+istag-1))*q(ie+istag, j)+REAL(ie&
284 & +istag-i)*q(ie+istag-1, j))
285  end if
286  IF (REAL(j) .GE. je + jstag + q(i, je+jstag)/(q(i, je+jstag-&
287 & 1)-q(i, je+jstag)+1.e-12) .AND. q(i, je+jstag-1) .GT. q(&
288 & i, je+jstag)) THEN
289  q(i, j) = q(i, j) + 0.5*q(i, j-1)
290  ELSE
291  q(i, j) = q(i, j) + 0.5*(REAL(j-(je+jstag-1))*q(i, je+&
292 & jstag)+REAL(je+jstag-j)*q(i, je+jstag-1))
293  end if
294  END DO
295  END DO
296  ELSE
297  DO j=je+1+jstag,jed+jstag
298  DO i=ie+1+istag,ied+istag
299  q(i, j) = 0.5*(REAL(i-(ie+istag-1))*q(ie+istag, j)+REAL(ie+&
300 & istag-i)*q(ie+istag-1, j)) + 0.5*(REAL(j-(je+jstag-1))*q(i&
301 & , je+jstag)+REAL(je+jstag-j)*q(i, je+jstag-1))
302  end do
303  END DO
304  END IF
305  END IF
306  IF (ie .EQ. npx - 1 .AND. js .EQ. 1) THEN
307  IF (pd) THEN
308  DO j=0,jsd,-1
309  DO i=ie+1+istag,ied+istag
310  IF (REAL(i) .GE. ie + istag + q(ie+istag, j)/(q(ie+istag-1, &
311 & j)-q(ie+istag, j)+1.e-12) .AND. q(ie+istag-1, j) .GT. q(&
312 & ie+istag, j)) THEN
313  q(i, j) = 0.5*q(i-1, j)
314  ELSE
315  q(i, j) = 0.5*(REAL(i-(ie+istag-1))*q(ie+istag, j)+REAL(ie&
316 & +istag-i)*q(ie+istag-1, j))
317  end if
318  IF (REAL(j) .LE. 1. - q(i, 1)/(q(i, 2)-q(i, 1)+1.e-12) .AND.&
319 & q(i, 2) .GT. q(i, 1)) THEN
320  q(i, j) = q(i, j) + 0.5*q(i, j+1)
321  ELSE
322  q(i, j) = q(i, j) + 0.5*(REAL(2-j)*q(i, 1)-REAL(1-j)*q(i, &
323 & 2))
324  end if
325  END DO
326  END DO
327  ELSE
328  DO j=jsd,0
329  DO i=ie+1+istag,ied+istag
330  q(i, j) = 0.5*(REAL(i-(ie+istag-1))*q(ie+istag, j)+REAL(ie+&
331 & istag-i)*q(ie+istag-1, j)) + 0.5*(REAL(2-j)*q(i, 1)-REAL(1&
332 & -j)*q(i, 2))
333  end do
334  END DO
335  END IF
336  END IF
337  END SUBROUTINE extrapolation_bc
338  SUBROUTINE fill_nested_grid_2d(var_nest, var_coarse, ind, wt, istag, &
339 & jstag, isg, ieg, jsg, jeg, bd, istart_in, iend_in, jstart_in, &
340 & jend_in)
341  IMPLICIT NONE
342  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
343  INTEGER, INTENT(IN) :: istag, jstag, isg, ieg, jsg, jeg
344  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag), INTENT(&
345 & INOUT) :: var_nest
346  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag), INTENT(IN) :: &
347 & var_coarse
348  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
349 & INTENT(IN) :: ind
350  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
351 & INTENT(IN) :: wt
352  INTEGER, INTENT(IN), OPTIONAL :: istart_in, iend_in, jstart_in, &
353 & jend_in
354  INTEGER :: i, j, ic, jc
355  INTEGER :: istart, iend, jstart, jend
356  INTEGER :: is, ie, js, je
357  INTEGER :: isd, ied, jsd, jed
358  INTRINSIC PRESENT
359  is = bd%is
360  ie = bd%ie
361  js = bd%js
362  je = bd%je
363  isd = bd%isd
364  ied = bd%ied
365  jsd = bd%jsd
366  jed = bd%jed
367  IF (PRESENT(istart_in)) THEN
368  istart = istart_in
369  ELSE
370  istart = isd
371  END IF
372  IF (PRESENT(iend_in)) THEN
373  iend = iend_in + istag
374  ELSE
375  iend = ied + istag
376  END IF
377  IF (PRESENT(jstart_in)) THEN
378  jstart = jstart_in
379  ELSE
380  jstart = jsd
381  END IF
382  IF (PRESENT(jend_in)) THEN
383  jend = jend_in + jstag
384  ELSE
385  jend = jed + jstag
386  END IF
387  DO j=jstart,jend
388  DO i=istart,iend
389  ic = ind(i, j, 1)
390  jc = ind(i, j, 2)
391  var_nest(i, j) = wt(i, j, 1)*var_coarse(ic, jc) + wt(i, j, 2)*&
392 & var_coarse(ic, jc+1) + wt(i, j, 3)*var_coarse(ic+1, jc+1) + wt&
393 & (i, j, 4)*var_coarse(ic+1, jc)
394  END DO
395  END DO
396  END SUBROUTINE fill_nested_grid_2d
397  SUBROUTINE fill_nested_grid_3d(var_nest, var_coarse, ind, wt, istag, &
398 & jstag, isg, ieg, jsg, jeg, npz, bd, istart_in, iend_in, jstart_in, &
399 & jend_in)
400  IMPLICIT NONE
401  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
402  INTEGER, INTENT(IN) :: istag, jstag, isg, ieg, jsg, jeg, npz
403  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
404 & INTENT(INOUT) :: var_nest
405  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag, npz), INTENT(IN) :: &
406 & var_coarse
407  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
408 & INTENT(IN) :: ind
409  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
410 & INTENT(IN) :: wt
411  INTEGER, INTENT(IN), OPTIONAL :: istart_in, iend_in, jstart_in, &
412 & jend_in
413  INTEGER :: i, j, ic, jc, k
414  INTEGER :: istart, iend, jstart, jend
415  INTEGER :: is, ie, js, je
416  INTEGER :: isd, ied, jsd, jed
417  INTRINSIC PRESENT
418  is = bd%is
419  ie = bd%ie
420  js = bd%js
421  je = bd%je
422  isd = bd%isd
423  ied = bd%ied
424  jsd = bd%jsd
425  jed = bd%jed
426  IF (PRESENT(istart_in)) THEN
427  istart = istart_in
428  ELSE
429  istart = isd
430  END IF
431  IF (PRESENT(iend_in)) THEN
432  iend = iend_in + istag
433  ELSE
434  iend = ied + istag
435  END IF
436  IF (PRESENT(jstart_in)) THEN
437  jstart = jstart_in
438  ELSE
439  jstart = jsd
440  END IF
441  IF (PRESENT(jend_in)) THEN
442  jend = jend_in + jstag
443  ELSE
444  jend = jed + jstag
445  END IF
446  DO k=1,npz
447  DO j=jstart,jend
448  DO i=istart,iend
449  ic = ind(i, j, 1)
450  jc = ind(i, j, 2)
451  var_nest(i, j, k) = wt(i, j, 1)*var_coarse(ic, jc, k) + wt(i, &
452 & j, 2)*var_coarse(ic, jc+1, k) + wt(i, j, 3)*var_coarse(ic+1&
453 & , jc+1, k) + wt(i, j, 4)*var_coarse(ic+1, jc, k)
454  END DO
455  END DO
456  END DO
457  END SUBROUTINE fill_nested_grid_3d
458  SUBROUTINE nested_grid_bc_mpp(var_nest, var_coarse, nest_domain, ind, &
459 & wt, istag, jstag, npx, npy, npz, bd, isg, ieg, jsg, jeg, nstep_in, &
460 & nsplit_in, proc_in)
461  IMPLICIT NONE
462  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
463  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, npz, isg, ieg, jsg, &
464 & jeg
465  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
466 & INTENT(INOUT) :: var_nest
467  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag, npz), INTENT(IN) :: &
468 & var_coarse
469  TYPE(NEST_DOMAIN_TYPE), INTENT(INOUT) :: nest_domain
470  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
471 & INTENT(IN) :: ind
472  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
473 & INTENT(IN) :: wt
474  INTEGER, INTENT(IN), OPTIONAL :: nstep_in, nsplit_in
475  LOGICAL, INTENT(IN), OPTIONAL :: proc_in
476  INTEGER :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c
477  INTEGER :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c
478  INTEGER :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c
479  INTEGER :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c
480  REAL, ALLOCATABLE :: wbuffer(:, :, :)
481  REAL, ALLOCATABLE :: ebuffer(:, :, :)
482  REAL, ALLOCATABLE :: sbuffer(:, :, :)
483  REAL, ALLOCATABLE :: nbuffer(:, :, :)
484  INTEGER :: i, j, ic, jc, istart, iend, k
485  INTEGER :: position
486  LOGICAL :: process
487  INTEGER :: is, ie, js, je
488  INTEGER :: isd, ied, jsd, jed
489  INTRINSIC PRESENT
490  is = bd%is
491  ie = bd%ie
492  js = bd%js
493  je = bd%je
494  isd = bd%isd
495  ied = bd%ied
496  jsd = bd%jsd
497  jed = bd%jed
498  IF (PRESENT(proc_in)) THEN
499  process = proc_in
500  ELSE
501  process = .true.
502  END IF
503  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
504  position = corner
505  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
506  position = north
507  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
508  position = east
509  ELSE
510  position = center
511  END IF
512  CALL mpp_get_c2f_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, &
513 & isw_c, iew_c, jsw_c, jew_c, west, position)
514  CALL mpp_get_c2f_index(nest_domain, ise_f, iee_f, jse_f, jee_f, &
515 & ise_c, iee_c, jse_c, jee_c, east, position)
516  CALL mpp_get_c2f_index(nest_domain, iss_f, ies_f, jss_f, jes_f, &
517 & iss_c, ies_c, jss_c, jes_c, south, position)
518  CALL mpp_get_c2f_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, &
519 & isn_c, ien_c, jsn_c, jen_c, north, position)
520  IF (iew_c .GE. isw_c .AND. jew_c .GE. jsw_c) THEN
521  ALLOCATE(wbuffer(isw_c:iew_c, jsw_c:jew_c, npz))
522  ELSE
523  ALLOCATE(wbuffer(1, 1, 1))
524  END IF
525  wbuffer = 0.0
526  IF (iee_c .GE. ise_c .AND. jee_c .GE. jse_c) THEN
527  ALLOCATE(ebuffer(ise_c:iee_c, jse_c:jee_c, npz))
528  ELSE
529  ALLOCATE(ebuffer(1, 1, 1))
530  END IF
531  ebuffer = 0.0
532  IF (ies_c .GE. iss_c .AND. jes_c .GE. jss_c) THEN
533  ALLOCATE(sbuffer(iss_c:ies_c, jss_c:jes_c, npz))
534  ELSE
535  ALLOCATE(sbuffer(1, 1, 1))
536  END IF
537  sbuffer = 0.0
538  IF (ien_c .GE. isn_c .AND. jen_c .GE. jsn_c) THEN
539  ALLOCATE(nbuffer(isn_c:ien_c, jsn_c:jen_c, npz))
540  ELSE
541  ALLOCATE(nbuffer(1, 1, 1))
542  END IF
543  nbuffer = 0.0
544  CALL timing_on('COMM_TOTAL')
545  CALL mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer&
546 & , ebuffer, nbuffer, position)
547  CALL timing_off('COMM_TOTAL')
548 !process
549  IF (process) THEN
550  IF (is .EQ. 1) THEN
551  DO k=1,npz
552  DO j=jsd,jed+jstag
553  DO i=isd,0
554  ic = ind(i, j, 1)
555  jc = ind(i, j, 2)
556  var_nest(i, j, k) = wt(i, j, 1)*wbuffer(ic, jc, k) + wt(i&
557 & , j, 2)*wbuffer(ic, jc+1, k) + wt(i, j, 3)*wbuffer(ic+1&
558 & , jc+1, k) + wt(i, j, 4)*wbuffer(ic+1, jc, k)
559  END DO
560  END DO
561  END DO
562  END IF
563  IF (js .EQ. 1) THEN
564  IF (is .EQ. 1) THEN
565  istart = is
566  ELSE
567  istart = isd
568  END IF
569  IF (ie .EQ. npx - 1) THEN
570  iend = ie
571  ELSE
572  iend = ied
573  END IF
574  DO k=1,npz
575  DO j=jsd,0
576  DO i=istart,iend+istag
577  ic = ind(i, j, 1)
578  jc = ind(i, j, 2)
579  var_nest(i, j, k) = wt(i, j, 1)*sbuffer(ic, jc, k) + wt(i&
580 & , j, 2)*sbuffer(ic, jc+1, k) + wt(i, j, 3)*sbuffer(ic+1&
581 & , jc+1, k) + wt(i, j, 4)*sbuffer(ic+1, jc, k)
582  END DO
583  END DO
584  END DO
585  END IF
586  IF (ie .EQ. npx - 1) THEN
587  DO k=1,npz
588  DO j=jsd,jed+jstag
589  DO i=npx+istag,ied+istag
590  ic = ind(i, j, 1)
591  jc = ind(i, j, 2)
592  var_nest(i, j, k) = wt(i, j, 1)*ebuffer(ic, jc, k) + wt(i&
593 & , j, 2)*ebuffer(ic, jc+1, k) + wt(i, j, 3)*ebuffer(ic+1&
594 & , jc+1, k) + wt(i, j, 4)*ebuffer(ic+1, jc, k)
595  END DO
596  END DO
597  END DO
598  END IF
599  IF (je .EQ. npy - 1) THEN
600  IF (is .EQ. 1) THEN
601  istart = is
602  ELSE
603  istart = isd
604  END IF
605  IF (ie .EQ. npx - 1) THEN
606  iend = ie
607  ELSE
608  iend = ied
609  END IF
610  DO k=1,npz
611  DO j=npy+jstag,jed+jstag
612  DO i=istart,iend+istag
613  ic = ind(i, j, 1)
614  jc = ind(i, j, 2)
615  var_nest(i, j, k) = wt(i, j, 1)*nbuffer(ic, jc, k) + wt(i&
616 & , j, 2)*nbuffer(ic, jc+1, k) + wt(i, j, 3)*nbuffer(ic+1&
617 & , jc+1, k) + wt(i, j, 4)*nbuffer(ic+1, jc, k)
618  END DO
619  END DO
620  END DO
621  END IF
622  END IF
623  DEALLOCATE(wbuffer)
624  DEALLOCATE(ebuffer)
625  DEALLOCATE(sbuffer)
626  DEALLOCATE(nbuffer)
627  END SUBROUTINE nested_grid_bc_mpp
628  SUBROUTINE nested_grid_bc_mpp_send(var_coarse, nest_domain, istag, &
629 & jstag)
630  IMPLICIT NONE
631  REAL, DIMENSION(:, :, :), INTENT(IN) :: var_coarse
632  TYPE(NEST_DOMAIN_TYPE), INTENT(INOUT) :: nest_domain
633  INTEGER, INTENT(IN) :: istag, jstag
634  REAL, ALLOCATABLE :: wbuffer(:, :, :)
635  REAL, ALLOCATABLE :: ebuffer(:, :, :)
636  REAL, ALLOCATABLE :: sbuffer(:, :, :)
637  REAL, ALLOCATABLE :: nbuffer(:, :, :)
638  INTEGER :: i, j, ic, jc, istart, iend, k
639  INTEGER :: position
640  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
641  position = corner
642  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
643  position = north
644  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
645  position = east
646  ELSE
647  position = center
648  END IF
649  ALLOCATE(wbuffer(1, 1, 1))
650  ALLOCATE(ebuffer(1, 1, 1))
651  ALLOCATE(sbuffer(1, 1, 1))
652  ALLOCATE(nbuffer(1, 1, 1))
653  CALL timing_on('COMM_TOTAL')
654  CALL mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer&
655 & , ebuffer, nbuffer, position)
656  CALL timing_off('COMM_TOTAL')
657  DEALLOCATE(wbuffer)
658  DEALLOCATE(ebuffer)
659  DEALLOCATE(sbuffer)
660  DEALLOCATE(nbuffer)
661  END SUBROUTINE nested_grid_bc_mpp_send
662  SUBROUTINE nested_grid_bc_2d_mpp(var_nest, var_coarse, nest_domain, &
663 & ind, wt, istag, jstag, npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, &
664 & nsplit_in, proc_in)
665  IMPLICIT NONE
666  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
667  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg
668  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag), INTENT(&
669 & INOUT) :: var_nest
670  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag), INTENT(IN) :: &
671 & var_coarse
672  TYPE(NEST_DOMAIN_TYPE), INTENT(INOUT) :: nest_domain
673  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
674 & INTENT(IN) :: ind
675  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
676 & INTENT(IN) :: wt
677  INTEGER, INTENT(IN), OPTIONAL :: nstep_in, nsplit_in
678  LOGICAL, INTENT(IN), OPTIONAL :: proc_in
679  INTEGER :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c
680  INTEGER :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c
681  INTEGER :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c
682  INTEGER :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c
683  REAL, ALLOCATABLE :: wbuffer(:, :)
684  REAL, ALLOCATABLE :: ebuffer(:, :)
685  REAL, ALLOCATABLE :: sbuffer(:, :)
686  REAL, ALLOCATABLE :: nbuffer(:, :)
687  INTEGER :: i, j, ic, jc, istart, iend, k
688  INTEGER :: position
689  LOGICAL :: process
690  INTEGER :: is, ie, js, je
691  INTEGER :: isd, ied, jsd, jed
692  INTRINSIC PRESENT
693  is = bd%is
694  ie = bd%ie
695  js = bd%js
696  je = bd%je
697  isd = bd%isd
698  ied = bd%ied
699  jsd = bd%jsd
700  jed = bd%jed
701  IF (PRESENT(proc_in)) THEN
702  process = proc_in
703  ELSE
704  process = .true.
705  END IF
706  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
707  position = corner
708  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
709  position = north
710  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
711  position = east
712  ELSE
713  position = center
714  END IF
715  CALL mpp_get_c2f_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, &
716 & isw_c, iew_c, jsw_c, jew_c, west, position)
717  CALL mpp_get_c2f_index(nest_domain, ise_f, iee_f, jse_f, jee_f, &
718 & ise_c, iee_c, jse_c, jee_c, east, position)
719  CALL mpp_get_c2f_index(nest_domain, iss_f, ies_f, jss_f, jes_f, &
720 & iss_c, ies_c, jss_c, jes_c, south, position)
721  CALL mpp_get_c2f_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, &
722 & isn_c, ien_c, jsn_c, jen_c, north, position)
723  IF (iew_c .GE. isw_c .AND. jew_c .GE. jsw_c) THEN
724  ALLOCATE(wbuffer(isw_c:iew_c, jsw_c:jew_c))
725  ELSE
726  ALLOCATE(wbuffer(1, 1))
727  END IF
728  wbuffer = 0.0
729  IF (iee_c .GE. ise_c .AND. jee_c .GE. jse_c) THEN
730  ALLOCATE(ebuffer(ise_c:iee_c, jse_c:jee_c))
731  ELSE
732  ALLOCATE(ebuffer(1, 1))
733  END IF
734  ebuffer = 0.0
735  IF (ies_c .GE. iss_c .AND. jes_c .GE. jss_c) THEN
736  ALLOCATE(sbuffer(iss_c:ies_c, jss_c:jes_c))
737  ELSE
738  ALLOCATE(sbuffer(1, 1))
739  END IF
740  sbuffer = 0.0
741  IF (ien_c .GE. isn_c .AND. jen_c .GE. jsn_c) THEN
742  ALLOCATE(nbuffer(isn_c:ien_c, jsn_c:jen_c))
743  ELSE
744  ALLOCATE(nbuffer(1, 1))
745  END IF
746  nbuffer = 0.0
747  CALL timing_on('COMM_TOTAL')
748  CALL mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer&
749 & , ebuffer, nbuffer, position)
750  CALL timing_off('COMM_TOTAL')
751 !process
752  IF (process) THEN
753  IF (is .EQ. 1) THEN
754  DO j=jsd,jed+jstag
755  DO i=isd,0
756  ic = ind(i, j, 1)
757  jc = ind(i, j, 2)
758  var_nest(i, j) = wt(i, j, 1)*wbuffer(ic, jc) + wt(i, j, 2)*&
759 & wbuffer(ic, jc+1) + wt(i, j, 3)*wbuffer(ic+1, jc+1) + wt(i&
760 & , j, 4)*wbuffer(ic+1, jc)
761  END DO
762  END DO
763  END IF
764  IF (js .EQ. 1) THEN
765  IF (is .EQ. 1) THEN
766  istart = is
767  ELSE
768  istart = isd
769  END IF
770  IF (ie .EQ. npx - 1) THEN
771  iend = ie
772  ELSE
773  iend = ied
774  END IF
775  DO j=jsd,0
776  DO i=istart,iend+istag
777  ic = ind(i, j, 1)
778  jc = ind(i, j, 2)
779  var_nest(i, j) = wt(i, j, 1)*sbuffer(ic, jc) + wt(i, j, 2)*&
780 & sbuffer(ic, jc+1) + wt(i, j, 3)*sbuffer(ic+1, jc+1) + wt(i&
781 & , j, 4)*sbuffer(ic+1, jc)
782  END DO
783  END DO
784  END IF
785  IF (ie .EQ. npx - 1) THEN
786  DO j=jsd,jed+jstag
787  DO i=npx+istag,ied+istag
788  ic = ind(i, j, 1)
789  jc = ind(i, j, 2)
790  var_nest(i, j) = wt(i, j, 1)*ebuffer(ic, jc) + wt(i, j, 2)*&
791 & ebuffer(ic, jc+1) + wt(i, j, 3)*ebuffer(ic+1, jc+1) + wt(i&
792 & , j, 4)*ebuffer(ic+1, jc)
793  END DO
794  END DO
795  END IF
796  IF (je .EQ. npy - 1) THEN
797  IF (is .EQ. 1) THEN
798  istart = is
799  ELSE
800  istart = isd
801  END IF
802  IF (ie .EQ. npx - 1) THEN
803  iend = ie
804  ELSE
805  iend = ied
806  END IF
807  DO j=npy+jstag,jed+jstag
808  DO i=istart,iend+istag
809  ic = ind(i, j, 1)
810  jc = ind(i, j, 2)
811  var_nest(i, j) = wt(i, j, 1)*nbuffer(ic, jc) + wt(i, j, 2)*&
812 & nbuffer(ic, jc+1) + wt(i, j, 3)*nbuffer(ic+1, jc+1) + wt(i&
813 & , j, 4)*nbuffer(ic+1, jc)
814  END DO
815  END DO
816  END IF
817  END IF
818  DEALLOCATE(wbuffer)
819  DEALLOCATE(ebuffer)
820  DEALLOCATE(sbuffer)
821  DEALLOCATE(nbuffer)
822  END SUBROUTINE nested_grid_bc_2d_mpp
823  SUBROUTINE nested_grid_bc_2d(var_nest, var_coarse, ind, wt, istag, &
824 & jstag, npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in)
825  IMPLICIT NONE
826  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
827  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg
828  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag), INTENT(&
829 & INOUT) :: var_nest
830  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag), INTENT(IN) :: &
831 & var_coarse
832  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
833 & INTENT(IN) :: ind
834  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
835 & INTENT(IN) :: wt
836  INTEGER, INTENT(IN), OPTIONAL :: nstep_in, nsplit_in
837  INTEGER :: nstep, nsplit
838  INTEGER :: i, j, ic, jc, istart, iend
839  INTEGER :: is, ie, js, je
840  INTEGER :: isd, ied, jsd, jed
841  INTRINSIC PRESENT
842  is = bd%is
843  ie = bd%ie
844  js = bd%js
845  je = bd%je
846  isd = bd%isd
847  ied = bd%ied
848  jsd = bd%jsd
849  jed = bd%jed
850  IF ((.NOT.PRESENT(nstep_in)) .OR. (.NOT.PRESENT(nsplit_in))) THEN
851  nstep = 1
852  nsplit = 2
853  ELSE
854  nstep = nstep_in
855  nsplit = nsplit_in
856  END IF
857  IF (is .EQ. 1) THEN
858  DO j=jsd,jed+jstag
859  DO i=isd,0
860  ic = ind(i, j, 1)
861  jc = ind(i, j, 2)
862  var_nest(i, j) = wt(i, j, 1)*var_coarse(ic, jc) + wt(i, j, 2)*&
863 & var_coarse(ic, jc+1) + wt(i, j, 3)*var_coarse(ic+1, jc+1) + &
864 & wt(i, j, 4)*var_coarse(ic+1, jc)
865  END DO
866  END DO
867  END IF
868  IF (js .EQ. 1) THEN
869  IF (is .EQ. 1) THEN
870  istart = is
871  ELSE
872  istart = isd
873  END IF
874  IF (ie .EQ. npx - 1) THEN
875  iend = ie
876  ELSE
877  iend = ied
878  END IF
879  DO j=jsd,0
880  DO i=istart,iend+istag
881  ic = ind(i, j, 1)
882  jc = ind(i, j, 2)
883  var_nest(i, j) = wt(i, j, 1)*var_coarse(ic, jc) + wt(i, j, 2)*&
884 & var_coarse(ic, jc+1) + wt(i, j, 3)*var_coarse(ic+1, jc+1) + &
885 & wt(i, j, 4)*var_coarse(ic+1, jc)
886  END DO
887  END DO
888  END IF
889  IF (ie .EQ. npx - 1) THEN
890  DO j=jsd,jed+jstag
891  DO i=npx+istag,ied+istag
892  ic = ind(i, j, 1)
893  jc = ind(i, j, 2)
894  var_nest(i, j) = wt(i, j, 1)*var_coarse(ic, jc) + wt(i, j, 2)*&
895 & var_coarse(ic, jc+1) + wt(i, j, 3)*var_coarse(ic+1, jc+1) + &
896 & wt(i, j, 4)*var_coarse(ic+1, jc)
897  END DO
898  END DO
899  END IF
900  IF (je .EQ. npy - 1) THEN
901  IF (is .EQ. 1) THEN
902  istart = is
903  ELSE
904  istart = isd
905  END IF
906  IF (ie .EQ. npx - 1) THEN
907  iend = ie
908  ELSE
909  iend = ied
910  END IF
911  DO j=npy+jstag,jed+jstag
912  DO i=istart,iend+istag
913  ic = ind(i, j, 1)
914  jc = ind(i, j, 2)
915  var_nest(i, j) = wt(i, j, 1)*var_coarse(ic, jc) + wt(i, j, 2)*&
916 & var_coarse(ic, jc+1) + wt(i, j, 3)*var_coarse(ic+1, jc+1) + &
917 & wt(i, j, 4)*var_coarse(ic+1, jc)
918  END DO
919  END DO
920  END IF
921  END SUBROUTINE nested_grid_bc_2d
922  SUBROUTINE nested_grid_bc_3d(var_nest, var_coarse, ind, wt, istag, &
923 & jstag, npx, npy, npz, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in)
924  IMPLICIT NONE
925  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
926  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, isg, ieg, jsg, jeg, &
927 & npz
928  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
929 & INTENT(INOUT) :: var_nest
930  REAL, DIMENSION(isg:ieg+istag, jsg:jeg+jstag, npz), INTENT(IN) :: &
931 & var_coarse
932  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
933 & INTENT(IN) :: ind
934  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
935 & INTENT(IN) :: wt
936  INTEGER, INTENT(IN), OPTIONAL :: nstep_in, nsplit_in
937  INTEGER :: nstep, nsplit
938  INTEGER :: i, j, ic, jc, istart, iend, k
939  INTEGER :: is, ie, js, je
940  INTEGER :: isd, ied, jsd, jed
941  INTRINSIC PRESENT
942  is = bd%is
943  ie = bd%ie
944  js = bd%js
945  je = bd%je
946  isd = bd%isd
947  ied = bd%ied
948  jsd = bd%jsd
949  jed = bd%jed
950  IF ((.NOT.PRESENT(nstep_in)) .OR. (.NOT.PRESENT(nsplit_in))) THEN
951  nstep = 1
952  nsplit = 2
953  ELSE
954  nstep = nstep_in
955  nsplit = nsplit_in
956  END IF
957  IF (is .EQ. 1) THEN
958  DO k=1,npz
959  DO j=jsd,jed+jstag
960  DO i=isd,0
961  ic = ind(i, j, 1)
962  jc = ind(i, j, 2)
963  var_nest(i, j, k) = wt(i, j, 1)*var_coarse(ic, jc, k) + wt(i&
964 & , j, 2)*var_coarse(ic, jc+1, k) + wt(i, j, 3)*var_coarse(&
965 & ic+1, jc+1, k) + wt(i, j, 4)*var_coarse(ic+1, jc, k)
966  END DO
967  END DO
968  END DO
969  END IF
970  IF (js .EQ. 1) THEN
971  IF (is .EQ. 1) THEN
972  istart = is
973  ELSE
974  istart = isd
975  END IF
976  IF (ie .EQ. npx - 1) THEN
977  iend = ie
978  ELSE
979  iend = ied
980  END IF
981  DO k=1,npz
982  DO j=jsd,0
983  DO i=istart,iend+istag
984  ic = ind(i, j, 1)
985  jc = ind(i, j, 2)
986  var_nest(i, j, k) = wt(i, j, 1)*var_coarse(ic, jc, k) + wt(i&
987 & , j, 2)*var_coarse(ic, jc+1, k) + wt(i, j, 3)*var_coarse(&
988 & ic+1, jc+1, k) + wt(i, j, 4)*var_coarse(ic+1, jc, k)
989  END DO
990  END DO
991  END DO
992  END IF
993  IF (ie .EQ. npx - 1) THEN
994  DO k=1,npz
995  DO j=jsd,jed+jstag
996  DO i=npx+istag,ied+istag
997  ic = ind(i, j, 1)
998  jc = ind(i, j, 2)
999  var_nest(i, j, k) = wt(i, j, 1)*var_coarse(ic, jc, k) + wt(i&
1000 & , j, 2)*var_coarse(ic, jc+1, k) + wt(i, j, 3)*var_coarse(&
1001 & ic+1, jc+1, k) + wt(i, j, 4)*var_coarse(ic+1, jc, k)
1002  END DO
1003  END DO
1004  END DO
1005  END IF
1006  IF (je .EQ. npy - 1) THEN
1007  IF (is .EQ. 1) THEN
1008  istart = is
1009  ELSE
1010  istart = isd
1011  END IF
1012  IF (ie .EQ. npx - 1) THEN
1013  iend = ie
1014  ELSE
1015  iend = ied
1016  END IF
1017  DO k=1,npz
1018  DO j=npy+jstag,jed+jstag
1019  DO i=istart,iend+istag
1020  ic = ind(i, j, 1)
1021  jc = ind(i, j, 2)
1022  var_nest(i, j, k) = wt(i, j, 1)*var_coarse(ic, jc, k) + wt(i&
1023 & , j, 2)*var_coarse(ic, jc+1, k) + wt(i, j, 3)*var_coarse(&
1024 & ic+1, jc+1, k) + wt(i, j, 4)*var_coarse(ic+1, jc, k)
1025  END DO
1026  END DO
1027  END DO
1028  END IF
1029  END SUBROUTINE nested_grid_bc_3d
1030  SUBROUTINE nested_grid_bc_send(var_coarse, nest_domain, istag, jstag)
1031  IMPLICIT NONE
1032  REAL, DIMENSION(:, :, :), INTENT(IN) :: var_coarse
1033  TYPE(nest_domain_type), INTENT(INOUT) :: nest_domain
1034  INTEGER, INTENT(IN) :: istag, jstag
1035  INTEGER :: position
1036  REAL :: wbuffer(1, 1, 1)
1037  REAL :: ebuffer(1, 1, 1)
1038  REAL :: sbuffer(1, 1, 1)
1039  REAL :: nbuffer(1, 1, 1)
1040  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
1041  position = corner
1042  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
1043  position = north
1044  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
1045  position = east
1046  ELSE
1047  position = center
1048  END IF
1049  CALL timing_on('COMM_TOTAL')
1050  CALL mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer&
1051 & , ebuffer, nbuffer, position)
1052  CALL timing_off('COMM_TOTAL')
1053  END SUBROUTINE nested_grid_bc_send
1054  SUBROUTINE nested_grid_bc_recv(nest_domain, istag, jstag, npz, bd, &
1055 & nest_bc_buffers)
1056  IMPLICIT NONE
1057  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1058  TYPE(nest_domain_type), INTENT(INOUT) :: nest_domain
1059  INTEGER, INTENT(IN) :: istag, jstag, npz
1060  TYPE(fv_nest_bc_type_3d), INTENT(INOUT), TARGET :: nest_bc_buffers
1061  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz) :: &
1062 & var_coarse_dummy
1063  INTEGER :: position
1064  INTEGER :: isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c
1065  INTEGER :: ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c
1066  INTEGER :: iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c
1067  INTEGER :: isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c
1068  INTEGER :: i, j, k
1069  INTRINSIC ALLOCATED
1070  var_coarse_dummy = 0.0
1071  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
1072  position = corner
1073  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
1074  position = north
1075  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
1076  position = east
1077  ELSE
1078  position = center
1079  END IF
1080  IF (.NOT.ALLOCATED(nest_bc_buffers%west_t1)) THEN
1081  CALL mpp_get_c2f_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, &
1082 & isw_c, iew_c, jsw_c, jew_c, west, position)
1083  CALL mpp_get_c2f_index(nest_domain, ise_f, iee_f, jse_f, jee_f, &
1084 & ise_c, iee_c, jse_c, jee_c, east, position)
1085  CALL mpp_get_c2f_index(nest_domain, iss_f, ies_f, jss_f, jes_f, &
1086 & iss_c, ies_c, jss_c, jes_c, south, position)
1087  CALL mpp_get_c2f_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, &
1088 & isn_c, ien_c, jsn_c, jen_c, north, position)
1089  IF (iew_c .GE. isw_c .AND. jew_c .GE. jsw_c) THEN
1090  IF (.NOT.ALLOCATED(nest_bc_buffers%west_t1)) THEN
1091  ALLOCATE(nest_bc_buffers%west_t1(isw_c:iew_c, jsw_c:jew_c, npz&
1092 & ))
1093  END IF
1094 !compatible with first touch principle
1095  DO k=1,npz
1096  DO j=jsw_c,jew_c
1097  DO i=isw_c,iew_c
1098  nest_bc_buffers%west_t1(i, j, k) = 0.
1099  END DO
1100  END DO
1101  END DO
1102  ELSE
1103  ALLOCATE(nest_bc_buffers%west_t1(1, 1, 1))
1104  nest_bc_buffers%west_t1(1, 1, 1) = 0.
1105  END IF
1106  IF (iee_c .GE. ise_c .AND. jee_c .GE. jse_c) THEN
1107  IF (.NOT.ALLOCATED(nest_bc_buffers%east_t1)) THEN
1108  ALLOCATE(nest_bc_buffers%east_t1(ise_c:iee_c, jse_c:jee_c, npz&
1109 & ))
1110  END IF
1111  DO k=1,npz
1112  DO j=jse_c,jee_c
1113  DO i=ise_c,iee_c
1114  nest_bc_buffers%east_t1(i, j, k) = 0.
1115  END DO
1116  END DO
1117  END DO
1118  ELSE
1119  ALLOCATE(nest_bc_buffers%east_t1(1, 1, 1))
1120  nest_bc_buffers%east_t1(1, 1, 1) = 0.
1121  END IF
1122  IF (ies_c .GE. iss_c .AND. jes_c .GE. jss_c) THEN
1123  IF (.NOT.ALLOCATED(nest_bc_buffers%south_t1)) THEN
1124  ALLOCATE(nest_bc_buffers%south_t1(iss_c:ies_c, jss_c:jes_c, &
1125 & npz))
1126  END IF
1127  DO k=1,npz
1128  DO j=jss_c,jes_c
1129  DO i=iss_c,ies_c
1130  nest_bc_buffers%south_t1(i, j, k) = 0.
1131  END DO
1132  END DO
1133  END DO
1134  ELSE
1135  ALLOCATE(nest_bc_buffers%south_t1(1, 1, 1))
1136  nest_bc_buffers%south_t1(1, 1, 1) = 0.
1137  END IF
1138  IF (ien_c .GE. isn_c .AND. jen_c .GE. jsn_c) THEN
1139  IF (.NOT.ALLOCATED(nest_bc_buffers%north_t1)) THEN
1140  ALLOCATE(nest_bc_buffers%north_t1(isn_c:ien_c, jsn_c:jen_c, &
1141 & npz))
1142  END IF
1143  DO k=1,npz
1144  DO j=jsn_c,jen_c
1145  DO i=isn_c,ien_c
1146  nest_bc_buffers%north_t1(i, j, k) = 0.
1147  END DO
1148  END DO
1149  END DO
1150  ELSE
1151  ALLOCATE(nest_bc_buffers%north_t1(1, 1, 1))
1152  nest_bc_buffers%north_t1(1, 1, 1) = 0
1153  END IF
1154  END IF
1155  CALL timing_on('COMM_TOTAL')
1156  CALL mpp_update_nest_fine(var_coarse_dummy, nest_domain, &
1157 & nest_bc_buffers%west_t1, nest_bc_buffers%&
1158 & south_t1, nest_bc_buffers%east_t1, &
1159 & nest_bc_buffers%north_t1, position)
1160  CALL timing_off('COMM_TOTAL')
1161  END SUBROUTINE nested_grid_bc_recv
1162  SUBROUTINE nested_grid_bc_save_proc(nest_domain, ind, wt, istag, jstag&
1163 & , npx, npy, npz, bd, nest_bc, nest_bc_buffers, pd_in)
1164  IMPLICIT NONE
1165  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1166  TYPE(nest_domain_type), INTENT(INOUT) :: nest_domain
1167  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, npz
1168  INTEGER, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 2), &
1169 & INTENT(IN) :: ind
1170  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, 4), &
1171 & INTENT(IN) :: wt
1172  LOGICAL, INTENT(IN), OPTIONAL :: pd_in
1173 !!NOTE: if declaring an ALLOCATABLE array with intent(OUT), the resulting dummy array
1174 !! will NOT be allocated! This goes for allocatable members of derived types as well.
1175  TYPE(fv_nest_bc_type_3d), INTENT(INOUT), TARGET :: nest_bc, &
1176 & nest_bc_buffers
1177  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz) :: &
1178 & var_coarse_dummy
1179  REAL, DIMENSION(:, :, :), POINTER :: var_east, var_west, var_south, &
1180 & var_north
1181  REAL, DIMENSION(:, :, :), POINTER :: buf_east, buf_west, buf_south, &
1182 & buf_north
1183  INTEGER :: position
1184  INTEGER :: i, j, k, ic, jc, istart, iend
1185  LOGICAL :: process
1186  LOGICAL, SAVE :: pd=.false.
1187  INTEGER :: is, ie, js, je
1188  INTEGER :: isd, ied, jsd, jed
1189  INTRINSIC PRESENT
1190  INTRINSIC max
1191  is = bd%is
1192  ie = bd%ie
1193  js = bd%js
1194  je = bd%je
1195  isd = bd%isd
1196  ied = bd%ied
1197  jsd = bd%jsd
1198  jed = bd%jed
1199  IF (PRESENT(pd_in)) THEN
1200  pd = pd_in
1201  ELSE
1202  pd = .false.
1203  END IF
1204  var_east => nest_bc%east_t1
1205  var_west => nest_bc%west_t1
1206  var_north => nest_bc%north_t1
1207  var_south => nest_bc%south_t1
1208  buf_east => nest_bc_buffers%east_t1
1209  buf_west => nest_bc_buffers%west_t1
1210  buf_north => nest_bc_buffers%north_t1
1211  buf_south => nest_bc_buffers%south_t1
1212 ! ?buffer has uninterpolated coarse-grid data; need to perform interpolation ourselves
1213 !To do this more securely, instead of using is/etc we could use the fine-grid indices defined above
1214  IF (is .EQ. 1) THEN
1215 !$NO-MP parallel do default(none) shared(npz,isd,ied,jsd,jed,jstag,ind,var_west,wt,buf_west) private(ic,jc)
1216  DO k=1,npz
1217  DO j=jsd,jed+jstag
1218  DO i=isd,0
1219  ic = ind(i, j, 1)
1220  jc = ind(i, j, 2)
1221  var_west(i, j, k) = wt(i, j, 1)*buf_west(ic, jc, k) + wt(i, &
1222 & j, 2)*buf_west(ic, jc+1, k) + wt(i, j, 3)*buf_west(ic+1, &
1223 & jc+1, k) + wt(i, j, 4)*buf_west(ic+1, jc, k)
1224  END DO
1225  END DO
1226  END DO
1227  IF (pd) THEN
1228 !$NO-MP parallel do default(none) shared(npz,jsd,jed,jstag,isd,var_west,nest_BC)
1229  DO k=1,npz
1230  DO j=jsd,jed+jstag
1231  DO i=isd,0
1232  IF (var_west(i, j, k) .LT. 0.5*nest_bc%west_t0(i, j, k)) &
1233 & THEN
1234  var_west(i, j, k) = 0.5*nest_bc%west_t0(i, j, k)
1235  ELSE
1236  var_west(i, j, k) = var_west(i, j, k)
1237  END IF
1238  END DO
1239  END DO
1240  END DO
1241  END IF
1242  END IF
1243  IF (js .EQ. 1) THEN
1244  IF (is .EQ. 1) THEN
1245  istart = is
1246  ELSE
1247  istart = isd
1248  END IF
1249  IF (ie .EQ. npx - 1) THEN
1250  iend = ie
1251  ELSE
1252  iend = ied
1253  END IF
1254 !$NO-MP parallel do default(none) shared(npz,istart,iend,jsd,jed,istag,ind,var_south,wt,buf_south) private(ic,jc)
1255  DO k=1,npz
1256  DO j=jsd,0
1257  DO i=istart,iend+istag
1258  ic = ind(i, j, 1)
1259  jc = ind(i, j, 2)
1260  var_south(i, j, k) = wt(i, j, 1)*buf_south(ic, jc, k) + wt(i&
1261 & , j, 2)*buf_south(ic, jc+1, k) + wt(i, j, 3)*buf_south(ic+&
1262 & 1, jc+1, k) + wt(i, j, 4)*buf_south(ic+1, jc, k)
1263  END DO
1264  END DO
1265  END DO
1266  IF (pd) THEN
1267 !$NO-MP parallel do default(none) shared(npz,jsd,jed,istart,iend,istag,var_south,nest_BC)
1268  DO k=1,npz
1269  DO j=jsd,0
1270  DO i=istart,iend+istag
1271  IF (var_south(i, j, k) .LT. 0.5*nest_bc%south_t0(i, j, k)&
1272 & ) THEN
1273  var_south(i, j, k) = 0.5*nest_bc%south_t0(i, j, k)
1274  ELSE
1275  var_south(i, j, k) = var_south(i, j, k)
1276  END IF
1277  END DO
1278  END DO
1279  END DO
1280  END IF
1281  END IF
1282  IF (ie .EQ. npx - 1) THEN
1283 !$NO-MP parallel do default(none) shared(npx,npz,isd,ied,jsd,jed,istag,jstag,ind,var_east,wt,buf_east) private(ic,jc)
1284  DO k=1,npz
1285  DO j=jsd,jed+jstag
1286  DO i=npx+istag,ied+istag
1287  ic = ind(i, j, 1)
1288  jc = ind(i, j, 2)
1289  var_east(i, j, k) = wt(i, j, 1)*buf_east(ic, jc, k) + wt(i, &
1290 & j, 2)*buf_east(ic, jc+1, k) + wt(i, j, 3)*buf_east(ic+1, &
1291 & jc+1, k) + wt(i, j, 4)*buf_east(ic+1, jc, k)
1292  END DO
1293  END DO
1294  END DO
1295  IF (pd) THEN
1296 !$NO-MP parallel do default(none) shared(npx,npz,jsd,jed,istag,jstag,ied,var_east,nest_BC)
1297  DO k=1,npz
1298  DO j=jsd,jed+jstag
1299  DO i=npx+istag,ied+istag
1300  IF (var_east(i, j, k) .LT. 0.5*nest_bc%east_t0(i, j, k)) &
1301 & THEN
1302  var_east(i, j, k) = 0.5*nest_bc%east_t0(i, j, k)
1303  ELSE
1304  var_east(i, j, k) = var_east(i, j, k)
1305  END IF
1306  END DO
1307  END DO
1308  END DO
1309  END IF
1310  END IF
1311  IF (je .EQ. npy - 1) THEN
1312  IF (is .EQ. 1) THEN
1313  istart = is
1314  ELSE
1315  istart = isd
1316  END IF
1317  IF (ie .EQ. npx - 1) THEN
1318  iend = ie
1319  ELSE
1320  iend = ied
1321  END IF
1322 !$NO-MP parallel do default(none) shared(npy,npz,istart,iend,jsd,jed,istag,jstag,ind,var_north,wt,buf_north) private(ic,jc)
1323  DO k=1,npz
1324  DO j=npy+jstag,jed+jstag
1325  DO i=istart,iend+istag
1326  ic = ind(i, j, 1)
1327  jc = ind(i, j, 2)
1328  var_north(i, j, k) = wt(i, j, 1)*buf_north(ic, jc, k) + wt(i&
1329 & , j, 2)*buf_north(ic, jc+1, k) + wt(i, j, 3)*buf_north(ic+&
1330 & 1, jc+1, k) + wt(i, j, 4)*buf_north(ic+1, jc, k)
1331  END DO
1332  END DO
1333  END DO
1334  IF (pd) THEN
1335 !$NO-MP parallel do default(none) shared(npy,npz,jsd,jed,istart,iend,istag,jstag,ied,var_north,nest_BC)
1336  DO k=1,npz
1337  DO j=npy+jstag,jed+jstag
1338  DO i=istart,iend+istag
1339  IF (var_north(i, j, k) .LT. 0.5*nest_bc%north_t0(i, j, k)&
1340 & ) THEN
1341  var_north(i, j, k) = 0.5*nest_bc%north_t0(i, j, k)
1342  ELSE
1343  var_north(i, j, k) = var_north(i, j, k)
1344  END IF
1345  END DO
1346  END DO
1347  END DO
1348  END IF
1349  END IF
1350  END SUBROUTINE nested_grid_bc_save_proc
1351 ! Differentiation of nested_grid_bc_apply_intt in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
1352 !od.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_
1353 !mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.m
1354 !ix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh
1355 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
1356 !4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.re
1357 !map_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d f
1358 !v_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
1359 !fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_r
1360 !estart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgri
1361 !d_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_
1362 !mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mo
1363 !d.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod
1364 !.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2
1365 !a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_
1366 !fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_
1367 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
1368 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1369 ! gradient of useful results: var_nest
1370 ! with respect to varying inputs: var_nest
1371 ! A NOTE ON BCTYPE: currently only an interpolation BC is implemented,
1372 ! bctype >= 2 currently correspond
1373 ! to a flux BC on the tracers ONLY, which is implemented in fv_tracer.
1374  SUBROUTINE nested_grid_bc_apply_intt_adm(var_nest, var_nest_ad, istag&
1375 & , jstag, npx, npy, npz, bd, step, split, bc, bctype)
1376  IMPLICIT NONE
1377  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1378  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, npz
1379  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
1380 & INTENT(INOUT) :: var_nest
1381  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
1382 & INTENT(INOUT) :: var_nest_ad
1383  REAL, INTENT(IN) :: split, step
1384  INTEGER, INTENT(IN) :: bctype
1385  TYPE(fv_nest_bc_type_3d), INTENT(IN), TARGET :: bc
1386  REAL, DIMENSION(:, :, :), POINTER :: var_t0, var_t1
1387  INTEGER :: i, j, istart, iend, k
1388  REAL :: denom
1389  LOGICAL, SAVE :: printdiag=.true.
1390  INTEGER :: is, ie, js, je
1391  INTEGER :: isd, ied, jsd, jed
1392  INTEGER :: ad_from
1393  INTEGER :: ad_to
1394  INTEGER :: branch
1395  is = bd%is
1396  ie = bd%ie
1397  js = bd%js
1398  je = bd%je
1399  isd = bd%isd
1400  ied = bd%ied
1401  jsd = bd%jsd
1402  jed = bd%jed
1403  IF (is .EQ. 1) THEN
1404  CALL pushcontrol1b(0)
1405  ELSE
1406  CALL pushcontrol1b(1)
1407  END IF
1408  IF (js .EQ. 1) THEN
1409  IF (is .EQ. 1) THEN
1410  istart = is
1411  ELSE
1412  istart = isd
1413  END IF
1414  IF (ie .EQ. npx - 1) THEN
1415  iend = ie
1416  ELSE
1417  iend = ied
1418  END IF
1419  DO k=1,npz
1420  DO j=jsd,0
1421  ad_from = istart
1422  i = iend + istag + 1
1423  CALL pushinteger4(i - 1)
1424  CALL pushinteger4(ad_from)
1425  END DO
1426  END DO
1427  CALL pushcontrol1b(0)
1428  ELSE
1429  CALL pushcontrol1b(1)
1430  END IF
1431  IF (ie .EQ. npx - 1) THEN
1432  CALL pushcontrol1b(0)
1433  ELSE
1434  CALL pushcontrol1b(1)
1435  END IF
1436  IF (je .EQ. npy - 1) THEN
1437  IF (is .EQ. 1) THEN
1438  istart = is
1439  ELSE
1440  istart = isd
1441  END IF
1442  IF (ie .EQ. npx - 1) THEN
1443  iend = ie
1444  ELSE
1445  iend = ied
1446  END IF
1447  DO k=npz,1,-1
1448  DO j=jed+jstag,npy+jstag,-1
1449  DO i=iend+istag,istart,-1
1450  var_nest_ad(i, j, k) = 0.0
1451  END DO
1452  END DO
1453  END DO
1454  END IF
1455  CALL popcontrol1b(branch)
1456  IF (branch .EQ. 0) THEN
1457  DO k=npz,1,-1
1458  DO j=jed+jstag,jsd,-1
1459  DO i=ied+istag,npx+istag,-1
1460  var_nest_ad(i, j, k) = 0.0
1461  END DO
1462  END DO
1463  END DO
1464  END IF
1465  CALL popcontrol1b(branch)
1466  IF (branch .EQ. 0) THEN
1467  DO k=npz,1,-1
1468  DO j=0,jsd,-1
1469  CALL popinteger4(ad_from)
1470  CALL popinteger4(ad_to)
1471  DO i=ad_to,ad_from,-1
1472  var_nest_ad(i, j, k) = 0.0
1473  END DO
1474  END DO
1475  END DO
1476  END IF
1477  CALL popcontrol1b(branch)
1478  IF (branch .EQ. 0) THEN
1479  DO k=npz,1,-1
1480  DO j=jed+jstag,jsd,-1
1481  DO i=0,isd,-1
1482  var_nest_ad(i, j, k) = 0.0
1483  END DO
1484  END DO
1485  END DO
1486  END IF
1487  END SUBROUTINE nested_grid_bc_apply_intt_adm
1488 ! A NOTE ON BCTYPE: currently only an interpolation BC is implemented,
1489 ! bctype >= 2 currently correspond
1490 ! to a flux BC on the tracers ONLY, which is implemented in fv_tracer.
1491  SUBROUTINE nested_grid_bc_apply_intt(var_nest, istag, jstag, npx, npy&
1492 & , npz, bd, step, split, bc, bctype)
1493  IMPLICIT NONE
1494  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1495  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, npz
1496  REAL, DIMENSION(bd%isd:bd%ied+istag, bd%jsd:bd%jed+jstag, npz), &
1497 & INTENT(INOUT) :: var_nest
1498  REAL, INTENT(IN) :: split, step
1499  INTEGER, INTENT(IN) :: bctype
1500  TYPE(fv_nest_bc_type_3d), INTENT(IN), TARGET :: bc
1501  REAL, DIMENSION(:, :, :), POINTER :: var_t0, var_t1
1502  INTEGER :: i, j, istart, iend, k
1503  REAL :: denom
1504  LOGICAL, SAVE :: printdiag=.true.
1505  INTEGER :: is, ie, js, je
1506  INTEGER :: isd, ied, jsd, jed
1507  is = bd%is
1508  ie = bd%ie
1509  js = bd%js
1510  je = bd%je
1511  isd = bd%isd
1512  ied = bd%ied
1513  jsd = bd%jsd
1514  jed = bd%jed
1515  denom = 1./split
1516  IF (is .EQ. 1) THEN
1517  var_t0 => bc%west_t0
1518  var_t1 => bc%west_t1
1519  DO k=1,npz
1520  DO j=jsd,jed+jstag
1521  DO i=isd,0
1522  var_nest(i, j, k) = (var_t0(i, j, k)*(split-step)+step*&
1523 & var_t1(i, j, k))*denom
1524  END DO
1525  END DO
1526  END DO
1527  END IF
1528  IF (js .EQ. 1) THEN
1529  IF (is .EQ. 1) THEN
1530  istart = is
1531  ELSE
1532  istart = isd
1533  END IF
1534  IF (ie .EQ. npx - 1) THEN
1535  iend = ie
1536  ELSE
1537  iend = ied
1538  END IF
1539  var_t0 => bc%south_t0
1540  var_t1 => bc%south_t1
1541  DO k=1,npz
1542  DO j=jsd,0
1543  DO i=istart,iend+istag
1544  var_nest(i, j, k) = (var_t0(i, j, k)*(split-step)+step*&
1545 & var_t1(i, j, k))*denom
1546  END DO
1547  END DO
1548  END DO
1549  END IF
1550  IF (ie .EQ. npx - 1) THEN
1551  var_t0 => bc%east_t0
1552  var_t1 => bc%east_t1
1553  DO k=1,npz
1554  DO j=jsd,jed+jstag
1555  DO i=npx+istag,ied+istag
1556  var_nest(i, j, k) = (var_t0(i, j, k)*(split-step)+step*&
1557 & var_t1(i, j, k))*denom
1558  END DO
1559  END DO
1560  END DO
1561  END IF
1562  IF (je .EQ. npy - 1) THEN
1563  IF (is .EQ. 1) THEN
1564  istart = is
1565  ELSE
1566  istart = isd
1567  END IF
1568  IF (ie .EQ. npx - 1) THEN
1569  iend = ie
1570  ELSE
1571  iend = ied
1572  END IF
1573  var_t0 => bc%north_t0
1574  var_t1 => bc%north_t1
1575  DO k=1,npz
1576  DO j=npy+jstag,jed+jstag
1577  DO i=istart,iend+istag
1578  var_nest(i, j, k) = (var_t0(i, j, k)*(split-step)+step*&
1579 & var_t1(i, j, k))*denom
1580  END DO
1581  END DO
1582  END DO
1583  END IF
1584  END SUBROUTINE nested_grid_bc_apply_intt
1585  SUBROUTINE update_coarse_grid_mpp_2d(var_coarse, var_nest, nest_domain&
1586 & , ind_update, dx, dy, area, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, &
1587 & js_n, je_n, isu, ieu, jsu, jeu, npx, npy, istag, jstag, r, &
1588 & nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid)
1589  IMPLICIT NONE
1590  INTEGER, INTENT(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n&
1591 & , je_n
1592  INTEGER, INTENT(IN) :: isu, ieu, jsu, jeu
1593  INTEGER, INTENT(IN) :: istag, jstag, r, nestupdate, upoff, nsponge
1594  INTEGER, INTENT(IN) :: ind_update(isd_p:ied_p+1, jsd_p:jed_p+1, 2)
1595  INTEGER, INTENT(IN) :: npx, npy
1596  REAL, INTENT(IN) :: var_nest(is_n:ie_n+istag, js_n:je_n+jstag)
1597  REAL, INTENT(INOUT) :: var_coarse(isd_p:ied_p+istag, jsd_p:jed_p+&
1598 & jstag)
1599  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
1600  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
1601  REAL, INTENT(IN) :: area(isd:ied, jsd:jed)
1602  LOGICAL, INTENT(IN) :: parent_proc, child_proc
1603  TYPE(FV_ATMOS_TYPE), INTENT(INOUT) :: parent_grid
1604  TYPE(NEST_DOMAIN_TYPE), INTENT(INOUT) :: nest_domain
1605  REAL :: var_nest_3d(is_n:ie_n+istag, js_n:je_n+jstag, 1)
1606  REAL :: var_coarse_3d(isd_p:ied_p+istag, jsd_p:jed_p+jstag, 1)
1607  INTRINSIC SIZE
1608  IF (child_proc .AND. SIZE(var_nest) .GT. 1) var_nest_3d(is_n:ie_n+&
1609 & istag, js_n:je_n+jstag, 1) = var_nest(is_n:ie_n+istag, js_n:je_n+&
1610 & jstag)
1611  IF (parent_proc .AND. SIZE(var_coarse) .GT. 1) var_coarse_3d(isd_p:&
1612 & ied_p+istag, jsd_p:jed_p, 1) = var_coarse(isd_p:ied_p+istag, jsd_p&
1613 & :jed_p+jstag)
1614  CALL update_coarse_grid_mpp(var_coarse_3d, var_nest_3d, nest_domain&
1615 & , ind_update, dx, dy, area, isd_p, ied_p, &
1616 & jsd_p, jed_p, is_n, ie_n, js_n, je_n, isu, ieu&
1617 & , jsu, jeu, npx, npy, 1, istag, jstag, r, &
1618 & nestupdate, upoff, nsponge, parent_proc, &
1619 & child_proc, parent_grid)
1620  IF (SIZE(var_coarse) .GT. 1 .AND. parent_proc) var_coarse(isd_p:&
1621 & ied_p+istag, jsd_p:jed_p+jstag) = var_coarse_3d(isd_p:ied_p+istag&
1622 & , jsd_p:jed_p, 1)
1623  END SUBROUTINE update_coarse_grid_mpp_2d
1624  SUBROUTINE update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, &
1625 & ind_update, dx, dy, area, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, &
1626 & js_n, je_n, isu, ieu, jsu, jeu, npx, npy, npz, istag, jstag, r, &
1627 & nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid)
1628  IMPLICIT NONE
1629 !This routine assumes the coarse and nested grids are properly
1630 ! aligned, and that in particular for odd refinement ratios all
1631 ! coarse-grid points coincide with nested-grid points
1632  INTEGER, INTENT(IN) :: isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n&
1633 & , je_n
1634  INTEGER, INTENT(IN) :: isu, ieu, jsu, jeu
1635  INTEGER, INTENT(IN) :: istag, jstag, npx, npy, npz, r, nestupdate, &
1636 & upoff, nsponge
1637  INTEGER, INTENT(IN) :: ind_update(isd_p:ied_p+1, jsd_p:jed_p+1, 2)
1638  REAL, INTENT(IN) :: var_nest(is_n:ie_n+istag, js_n:je_n+jstag, npz)
1639  REAL, INTENT(INOUT) :: var_coarse(isd_p:ied_p+istag, jsd_p:jed_p+&
1640 & jstag, npz)
1641  REAL, INTENT(IN) :: area(isd:ied, jsd:jed)
1642  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
1643  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
1644  LOGICAL, INTENT(IN) :: parent_proc, child_proc
1645  TYPE(FV_ATMOS_TYPE), INTENT(INOUT) :: parent_grid
1646  TYPE(NEST_DOMAIN_TYPE), INTENT(INOUT) :: nest_domain
1647  INTEGER :: in, jn, ini, jnj, s, qr
1648  INTEGER :: is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f
1649  INTEGER :: istart, istop, jstart, jstop, ishift, jshift, j, i, k
1650  REAL :: val
1651  REAL, DIMENSION(:, :, :), ALLOCATABLE :: nest_dat
1652  REAL :: var_nest_send(is_n:ie_n+istag, js_n:je_n+jstag, npz)
1653  INTEGER :: position
1654  IF (istag .EQ. 1 .AND. jstag .EQ. 1) THEN
1655  position = corner
1656  ELSE IF (istag .EQ. 0 .AND. jstag .EQ. 1) THEN
1657  position = north
1658  ELSE IF (istag .EQ. 1 .AND. jstag .EQ. 0) THEN
1659  position = east
1660  ELSE
1661  position = center
1662  END IF
1663  CALL mpp_get_f2c_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, &
1664 & ie_f, js_f, je_f, position)
1665  IF (ie_f .GT. is_f .AND. je_f .GT. js_f) THEN
1666  ALLOCATE(nest_dat(is_f:ie_f, js_f:je_f, npz))
1667  ELSE
1668  ALLOCATE(nest_dat(1, 1, 1))
1669  END IF
1670  nest_dat = -600.0
1671  IF (child_proc) THEN
1672 !! IF an area average (for istag == jstag == 0) or a linear average then multiply in the areas before sending data
1673  IF (istag .EQ. 0 .AND. jstag .EQ. 0) THEN
1674  SELECT CASE (nestupdate)
1675  CASE (1, 2, 6, 7, 8)
1676 !$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,area)
1677  DO k=1,npz
1678  DO j=js_n,je_n
1679  DO i=is_n,ie_n
1680  var_nest_send(i, j, k) = var_nest(i, j, k)*area(i, j)
1681  END DO
1682  END DO
1683  END DO
1684  END SELECT
1685  ELSE IF (istag .EQ. 0 .AND. jstag .GT. 0) THEN
1686  SELECT CASE (nestupdate)
1687  CASE (1, 6, 7, 8)
1688 !$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,dx)
1689  DO k=1,npz
1690  DO j=js_n,je_n+1
1691  DO i=is_n,ie_n
1692  var_nest_send(i, j, k) = var_nest(i, j, k)*dx(i, j)
1693  END DO
1694  END DO
1695  END DO
1696  CASE DEFAULT
1697  CALL mpp_error(fatal, 'nestupdate type not implemented')
1698  END SELECT
1699  ELSE IF (istag .GT. 0 .AND. jstag .EQ. 0) THEN
1700  SELECT CASE (nestupdate)
1701  CASE (1, 6, 7, 8)
1702 !averaging update; in-line average for face-averaged values instead of areal average
1703 !$NO-MP parallel do default(none) shared(npz,js_n,je_n,is_n,ie_n,var_nest_send,var_nest,dy)
1704  DO k=1,npz
1705  DO j=js_n,je_n
1706  DO i=is_n,ie_n+1
1707  var_nest_send(i, j, k) = var_nest(i, j, k)*dy(i, j)
1708  END DO
1709  END DO
1710  END DO
1711  CASE DEFAULT
1712  CALL mpp_error(fatal, 'nestupdate type not implemented')
1713  END SELECT
1714  ELSE
1715  CALL mpp_error(fatal, &
1716 & 'Cannot have both nonzero istag and jstag.')
1717  END IF
1718  END IF
1719  CALL timing_on('COMM_TOTAL')
1720  CALL mpp_update_nest_coarse(var_nest_send, nest_domain, nest_dat, &
1721 & position=position)
1722  CALL timing_off('COMM_TOTAL')
1723 !rounds down (since r > 0)
1724  s = r/2
1725  qr = r*upoff + nsponge - s
1726  IF (parent_proc .AND. (.NOT.(ieu .LT. isu .OR. jeu .LT. jsu))) THEN
1727  IF (istag .EQ. 0 .AND. jstag .EQ. 0) THEN
1728  SELECT CASE (nestupdate)
1729  CASE (1, 2, 6, 7, 8)
1730 ! 1 = Conserving update on all variables; 2 = conserving update for cell-centered values; 6 = conserving remap-update
1731 !$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) &
1732 !$NO-MP private(in,jn,val)
1733  DO k=1,npz
1734  DO j=jsu,jeu
1735  DO i=isu,ieu
1736  in = ind_update(i, j, 1)
1737  jn = ind_update(i, j, 2)
1738 !!$ if (in < max(1+qr,is_f) .or. in > min(npx-1-qr-r+1,ie_f) .or. &
1739 !!$ jn < max(1+qr,js_f) .or. jn > min(npy-1-qr-r+1,je_f)) then
1740 !!$ write(mpp_pe()+3000,'(A, 14I6)') 'SKIP: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npy-1-qr-r+1, isu, ieu,
1741 !jsu, jeu
1742 !!$ cycle
1743 !!$ endif
1744  val = 0.
1745  DO jnj=jn,jn+r-1
1746  DO ini=in,in+r-1
1747  val = val + nest_dat(ini, jnj, k)
1748  END DO
1749  END DO
1750 !var_coarse(i,j,k) = val/r**2.
1751 !!! CLEANUP: Couldn't rarea and rdx and rdy be built into the weight arrays?
1752 !!! Two-way updates do not yet have weights, tho
1753  var_coarse(i, j, k) = val*parent_grid%gridstruct%rarea(i&
1754 & , j)
1755  END DO
1756  END DO
1757  END DO
1758  CASE DEFAULT
1759  CALL mpp_error(fatal, 'nestupdate type not implemented')
1760  END SELECT
1761  ELSE IF (istag .EQ. 0 .AND. jstag .GT. 0) THEN
1762  SELECT CASE (nestupdate)
1763  CASE (1, 6, 7, 8)
1764 !$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) &
1765 !$NO-MP private(in,jn,val)
1766  DO k=1,npz
1767  DO j=jsu,jeu+1
1768  DO i=isu,ieu
1769  in = ind_update(i, j, 1)
1770  jn = ind_update(i, j, 2)
1771 !!$ if (in < max(1+qr,is_f) .or. in > min(npx-1-qr-r+1,ie_f) .or. &
1772 !!$ jn < max(1+qr+s,js_f) .or. jn > min(npy-1-qr-s+1,je_f)) then
1773 !!$ write(mpp_pe()+3000,'(A, 14I)') 'SKIP u: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npy-1-qr-s+1, isu, ieu,
1774 ! jsu, jeu
1775 !!$ cycle
1776 !!$ endif
1777  val = 0.
1778  DO ini=in,in+r-1
1779  val = val + nest_dat(ini, jn, k)
1780  END DO
1781 ! var_coarse(i,j,k) = val/r
1782  var_coarse(i, j, k) = val*parent_grid%gridstruct%rdx(i, &
1783 & j)
1784  END DO
1785  END DO
1786  END DO
1787  CASE DEFAULT
1788  CALL mpp_error(fatal, 'nestupdate type not implemented')
1789  END SELECT
1790  ELSE IF (istag .GT. 0 .AND. jstag .EQ. 0) THEN
1791  SELECT CASE (nestupdate)
1792  CASE (1, 6, 7, 8)
1793 !averaging update; in-line average for face-averaged values instead of areal average
1794 !$NO-MP parallel do default(none) shared(npz,jsu,jeu,isu,ieu,ind_update,nest_dat,parent_grid,var_coarse,r) &
1795 !$NO-MP private(in,jn,val)
1796  DO k=1,npz
1797  DO j=jsu,jeu
1798  DO i=isu,ieu+1
1799  in = ind_update(i, j, 1)
1800  jn = ind_update(i, j, 2)
1801 !!$ if (in < max(1+qr+s,is_f) .or. in > min(npx-1-qr-s+1,ie_f) .or. &
1802 !!$ jn < max(1+qr,js_f) .or. jn > min(npy-1-qr-r+1,je_f)) then
1803 !!$ write(mpp_pe()+3000,'(A, 14I6)') 'SKIP v: ', i, j, in, jn, 1+qr, is_f, ie_f, js_f, je_f, npx-1-qr-s+1, isu, ieu
1804 !, jsu, jeu
1805 !!$ cycle
1806 !!$ endif
1807  val = 0.
1808  DO jnj=jn,jn+r-1
1809  val = val + nest_dat(in, jnj, k)
1810  END DO
1811 ! var_coarse(i,j,k) = val/r
1812  var_coarse(i, j, k) = val*parent_grid%gridstruct%rdy(i, &
1813 & j)
1814  END DO
1815  END DO
1816  END DO
1817  CASE DEFAULT
1818  CALL mpp_error(fatal, 'nestupdate type not implemented')
1819  END SELECT
1820  END IF
1821  END IF
1822  DEALLOCATE(nest_dat)
1823  END SUBROUTINE update_coarse_grid_mpp
1824 end module boundary_adm_mod
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
boundary_adm_mod::nested_grid_bc_apply_intt
subroutine, public nested_grid_bc_apply_intt(var_nest, istag, jstag, npx, npy, npz, bd, step, split, bc, bctype)
Definition: boundary_adm.F90:1493
constants_mod
Definition: constants.F90:24
boundary_adm_mod::update_coarse_grid
Definition: boundary_adm.F90:64
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
boundary_adm_mod::fill_nested_grid_2d
subroutine fill_nested_grid_2d(var_nest, var_coarse, ind, wt, istag, jstag, isg, ieg, jsg, jeg, bd, istart_in, iend_in, jstart_in, jend_in)
Definition: boundary_adm.F90:341
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
boundary_adm_mod::nested_grid_bc_apply_intt_adm
subroutine, public nested_grid_bc_apply_intt_adm(var_nest, var_nest_ad, istag, jstag, npx, npy, npz, bd, step, split, bc, bctype)
Definition: boundary_adm.F90:1376
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
boundary_adm_mod::update_coarse_grid_mpp
subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, dx, dy, area, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, isu, ieu, jsu, jeu, npx, npy, npz, istag, jstag, r, nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid)
Definition: boundary_adm.F90:1628
fv_arrays_nlm_mod::fv_atmos_type
Definition: fv_arrays_nlm.F90:611
boundary_adm_mod::fill_nested_grid_3d
subroutine fill_nested_grid_3d(var_nest, var_coarse, ind, wt, istag, jstag, isg, ieg, jsg, jeg, npz, bd, istart_in, iend_in, jstart_in, jend_in)
Definition: boundary_adm.F90:400
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
mpp_mod::mpp_broadcast
Definition: mpp.F90:1124
mpp_mod
Definition: mpp.F90:39
boundary_adm_mod::nested_grid_bc_2d
subroutine nested_grid_bc_2d(var_nest, var_coarse, ind, wt, istag, jstag, npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in)
Definition: boundary_adm.F90:825
boundary_adm_mod::nested_grid_bc_send
subroutine, public nested_grid_bc_send(var_coarse, nest_domain, istag, jstag)
Definition: boundary_adm.F90:1031
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
if
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
mpp_domains_mod
Definition: mpp_domains.F90:128
boundary_adm_mod::update_coarse_grid_mpp_2d
subroutine update_coarse_grid_mpp_2d(var_coarse, var_nest, nest_domain, ind_update, dx, dy, area, isd_p, ied_p, jsd_p, jed_p, is_n, ie_n, js_n, je_n, isu, ieu, jsu, jeu, npx, npy, istag, jstag, r, nestupdate, upoff, nsponge, parent_proc, child_proc, parent_grid)
Definition: boundary_adm.F90:1589
mpp_domains_mod::mpp_update_nest_coarse
Definition: mpp_domains.F90:1727
mpp_domains_mod::mpp_get_data_domain
Definition: mpp_domains.F90:2617
boundary_adm_mod::nested_grid_bc_3d
subroutine nested_grid_bc_3d(var_nest, var_coarse, ind, wt, istag, jstag, npx, npy, npz, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in)
Definition: boundary_adm.F90:924
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
mpp_mod::mpp_recv
Definition: mpp.F90:975
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
boundary_adm_mod::nested_grid_bc_recv
subroutine, public nested_grid_bc_recv(nest_domain, istag, jstag, npz, bd, nest_bc_buffers)
Definition: boundary_adm.F90:1056
boundary_adm_mod::nested_grid_bc_2d_mpp
subroutine nested_grid_bc_2d_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, npx, npy, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in)
Definition: boundary_adm.F90:665
mpp_domains_mod::mpp_get_pelist
Definition: mpp_domains.F90:2734
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
mpp_mod::mpp_sum
Definition: mpp.F90:680
boundary_adm_mod::nested_grid_bc_save_proc
subroutine, public nested_grid_bc_save_proc(nest_domain, ind, wt, istag, jstag, npx, npy, npz, bd, nest_bc, nest_bc_buffers, pd_in)
Definition: boundary_adm.F90:1164
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
mpp_domains_mod::mpp_update_nest_fine
Definition: mpp_domains.F90:1681
mpp_mod::mpp_send
Definition: mpp.F90:1033
mpp_domains_mod::nest_domain_type
Definition: mpp_domains.F90:449
constants_mod::grav
real, parameter, public grav
Acceleration due to gravity [m/s^2].
Definition: constants.F90:76
boundary_adm_mod::nested_grid_bc
Definition: boundary_adm.F90:50
mpp_mod::mpp_error
Definition: mpp.F90:402
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
boundary_adm_mod::nested_grid_bc_mpp
subroutine nested_grid_bc_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, jstag, npx, npy, npz, bd, isg, ieg, jsg, jeg, nstep_in, nsplit_in, proc_in)
Definition: boundary_adm.F90:461
max
#define max(a, b)
Definition: mosaic_util.h:33
boundary_adm_mod::fill_nested_grid
Definition: boundary_adm.F90:59
mpp_domains_mod::mpp_get_compute_domain
Definition: mpp_domains.F90:2578
boundary_adm_mod::nested_grid_bc_mpp_send
subroutine nested_grid_bc_mpp_send(var_coarse, nest_domain, istag, jstag)
Definition: boundary_adm.F90:630
mpp_domains_mod::mpp_get_global_domain
Definition: mpp_domains.F90:2635
boundary_adm_mod
Definition: boundary_adm.F90:20
boundary_adm_mod::extrapolation_bc
subroutine, public extrapolation_bc(q, istag, jstag, npx, npy, bd, pd_in, debug_in)
Definition: boundary_adm.F90:74
min
#define min(a, b)
Definition: mosaic_util.h:32
fv_arrays_nlm_mod::fv_nest_bc_type_3d
Definition: fv_arrays_nlm.F90:508
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
fv_arrays_nlm_mod::fv_grid_bounds_type
Definition: fv_arrays_nlm.F90:601
mpp_domains_mod::mpp_global_field
Definition: mpp_domains.F90:2111
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175