FV3 Bundle
fv_tracer2d_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 fv_tracer2d_adm_mod
21  use tp_core_adm_mod, only: fv_tp_2d
22  use tp_core_adm_mod, only: fv_tp_2d_fwd, fv_tp_2d_bwd, fv_tp_2d_adm
23  use fv_mp_nlm_mod, only: mp_reduce_max
24  use fv_mp_nlm_mod, only: ng, mp_gather, is_master
25  use fv_mp_nlm_mod, only: group_halo_update_type
26  use fv_mp_adm_mod, only: start_group_halo_update, complete_group_halo_update
27  use fv_mp_adm_mod, only: start_group_halo_update_adm
28  use mpp_domains_mod, only: mpp_update_domains, mpp_get_boundary, cgrid_ne, domain2d
29  use fv_mp_adm_mod, only: mpp_update_domains_adm
30  use fv_timing_nlm_mod, only: timing_on, timing_off
31  use boundary_adm_mod, only: nested_grid_bc_apply_intt
32  use boundary_adm_mod, only: nested_grid_bc_apply_intt_adm
33  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_atmos_type, fv_grid_bounds_type
34  use mpp_mod, only: mpp_error, fatal, mpp_broadcast, mpp_send, mpp_recv, mpp_sum, mpp_max
35 
36  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
37  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
38 implicit none
39 private
40 
41 public :: tracer_2d, tracer_2d_nested, tracer_2d_1l
42 public :: tracer_2d_fwd, tracer_2d_nested_fwd, tracer_2d_1l_fwd
43 public :: tracer_2d_bwd, tracer_2d_nested_bwd, tracer_2d_1l_bwd
44 
45 real, allocatable, dimension(:,:,:) :: nest_fx_west_accum, nest_fx_east_accum, nest_fx_south_accum, nest_fx_north_accum
46 
47 CONTAINS
48 ! Differentiation of tracer_2d_1l in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
49 !_mod.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_cor
50 !e_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
51 !.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Raylei
52 !gh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_o
53 !rd4 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.
54 !remap_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
55 ! fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiter
56 !s 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
57 !_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subg
58 !rid_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_util
59 !s_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_
60 !mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_m
61 !od.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.
62 !d2a2c_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_
63 !v_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_cor
64 !e_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_uti
65 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
66 ! gradient of useful results: q dp1
67 ! with respect to varying inputs: q dp1 mfx mfy cx cy
68 !-----------------------------------------------------------------------
69 ! !ROUTINE: Perform 2D horizontal-to-lagrangian transport
70 !-----------------------------------------------------------------------
71  SUBROUTINE tracer_2d_1l_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, &
72 & domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, &
73 & nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, &
74 & dpa)
75  IMPLICIT NONE
76  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
77  INTEGER, INTENT(IN) :: npx
78  INTEGER, INTENT(IN) :: npy
79  INTEGER, INTENT(IN) :: npz
80 ! number of tracers to be advected
81  INTEGER, INTENT(IN) :: nq
82  INTEGER, INTENT(IN) :: hord, nord_tr
83  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
84  LOGICAL, INTENT(IN) :: split_damp_tr
85  INTEGER, INTENT(IN) :: q_split
86  INTEGER, INTENT(IN) :: id_divg
87  REAL, INTENT(IN) :: dt, trdm, trdm_pert
88  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
89 ! Tracers
90  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
91 ! DELP before dyn_core
92  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
93 ! Mass Flux X-Dir
94  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
95 ! Mass Flux Y-Dir
96  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
97 ! Courant Number X-Dir
98  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
99 ! Courant Number Y-Dir
100  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
101 ! DELP after advection
102  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je)
103  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
104  TYPE(domain2d), INTENT(INOUT) :: domain
105 ! Local Arrays
106 ! 3D tracers
107  REAL :: qn2(bd%isd:bd%ied, bd%jsd:bd%jed, nq)
108  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
109  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
110  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
111  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
112  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
113  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
114  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
115  REAL :: cmax(npz)
116  REAL :: frac
117  INTEGER :: nsplt
118  INTEGER :: i, j, k, it, iq
119  REAL, DIMENSION(:, :), POINTER :: area, rarea
120  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
121  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
122  INTEGER :: is, ie, js, je
123  INTEGER :: isd, ied, jsd, jed
124  INTRINSIC abs
125  INTRINSIC max
126  INTRINSIC int
127  INTRINSIC real
128  INTRINSIC PRESENT
129  REAL :: max1
130  REAL :: x1
131  REAL :: z1
132  REAL :: y3
133  REAL :: y2
134  REAL :: y1
135 
136  qn2 = 0.0
137  dp2 = 0.0
138  fx = 0.0
139  fy = 0.0
140  ra_x = 0.0
141  ra_y = 0.0
142  xfx = 0.0
143  yfx = 0.0
144  cmax = 0.0
145  frac = 0.0
146  nsplt = 0
147  is = 0
148  ie = 0
149  js = 0
150  je = 0
151  isd = 0
152  ied = 0
153  jsd = 0
154  jed = 0
155  max1 = 0
156  x1 = 0
157  z1 = 0
158  y3 = 0
159  y2 = 0
160  y1 = 0
161 
162  is = bd%is
163  ie = bd%ie
164  js = bd%js
165  je = bd%je
166  isd = bd%isd
167  ied = bd%ied
168  jsd = bd%jsd
169  jed = bd%jed
170  area => gridstruct%area
171  rarea => gridstruct%rarea
172  sin_sg => gridstruct%sin_sg
173  dxa => gridstruct%dxa
174  dya => gridstruct%dya
175  dx => gridstruct%dx
176  dy => gridstruct%dy
177 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
178 !$OMP sin_sg,cy,yfx,dya,dx,cmax)
179  DO k=1,npz
180  DO j=jsd,jed
181  DO i=is,ie+1
182  IF (cx(i, j, k) .GT. 0.) THEN
183  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
184 & j, 3)
185  CALL pushcontrol(1,1)
186  ELSE
187  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
188 & )
189  CALL pushcontrol(1,0)
190  END IF
191  END DO
192  END DO
193  DO j=js,je+1
194  DO i=isd,ied
195  IF (cy(i, j, k) .GT. 0.) THEN
196  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
197 & 1, 4)
198  CALL pushcontrol(1,1)
199  ELSE
200  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
201 & )
202  CALL pushcontrol(1,0)
203  END IF
204  END DO
205  END DO
206  cmax(k) = 0.
207  IF (k .LT. npz/6) THEN
208  DO j=js,je
209  DO i=is,ie
210  IF (cx(i, j, k) .GE. 0.) THEN
211  y1 = cx(i, j, k)
212  ELSE
213  y1 = -cx(i, j, k)
214  END IF
215  IF (cy(i, j, k) .GE. 0.) THEN
216  z1 = cy(i, j, k)
217  ELSE
218  z1 = -cy(i, j, k)
219  END IF
220  IF (cmax(k) .LT. y1) THEN
221  IF (y1 .LT. z1) THEN
222  CALL pushcontrol(2,0)
223  cmax(k) = z1
224  ELSE
225  CALL pushcontrol(2,1)
226  cmax(k) = y1
227  END IF
228  ELSE IF (cmax(k) .LT. z1) THEN
229  CALL pushcontrol(2,2)
230  cmax(k) = z1
231  ELSE
232  CALL pushcontrol(2,3)
233  cmax(k) = cmax(k)
234  END IF
235  END DO
236  END DO
237  CALL pushcontrol(1,1)
238  ELSE
239  DO j=js,je
240  DO i=is,ie
241  IF (cx(i, j, k) .GE. 0.) THEN
242  x1 = cx(i, j, k)
243  ELSE
244  x1 = -cx(i, j, k)
245  END IF
246  IF (cy(i, j, k) .GE. 0.) THEN
247  y3 = cy(i, j, k)
248  ELSE
249  y3 = -cy(i, j, k)
250  END IF
251  IF (x1 .LT. y3) THEN
252  max1 = y3
253  ELSE
254  max1 = x1
255  END IF
256  y2 = max1 + 1. - sin_sg(i, j, 5)
257  IF (cmax(k) .LT. y2) THEN
258  CALL pushcontrol(1,0)
259  cmax(k) = y2
260  ELSE
261  CALL pushcontrol(1,1)
262  cmax(k) = cmax(k)
263  END IF
264  END DO
265  END DO
266  CALL pushcontrol(1,0)
267  END IF
268  END DO
269 ! k-loop
270  CALL mp_reduce_max(cmax, npz)
271 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx, &
272 !$OMP cy,yfx,mfx,mfy,cmax) &
273 !$OMP private(nsplt, frac)
274  DO k=1,npz
275  nsplt = int(1. + cmax(k))
276  IF (nsplt .GT. 1) THEN
277  CALL pushrealarray(frac)
278  frac = 1./REAL(nsplt)
279  DO j=jsd,jed
280  DO i=is,ie+1
281  CALL pushrealarray(cx(i, j, k))
282  cx(i, j, k) = cx(i, j, k)*frac
283  xfx(i, j, k) = xfx(i, j, k)*frac
284  END DO
285  END DO
286  DO j=js,je
287  DO i=is,ie+1
288  CALL pushrealarray(mfx(i, j, k))
289  mfx(i, j, k) = mfx(i, j, k)*frac
290  END DO
291  END DO
292  DO j=js,je+1
293  DO i=isd,ied
294  CALL pushrealarray(cy(i, j, k))
295  cy(i, j, k) = cy(i, j, k)*frac
296  yfx(i, j, k) = yfx(i, j, k)*frac
297  END DO
298  END DO
299  DO j=js,je+1
300  DO i=is,ie
301  CALL pushrealarray(mfy(i, j, k))
302  mfy(i, j, k) = mfy(i, j, k)*frac
303  END DO
304  END DO
305  CALL pushcontrol(1,1)
306  ELSE
307  CALL pushcontrol(1,0)
308  END IF
309  END DO
310 ! Begin k-independent tracer transport; can not be OpenMPed because the mpp_update call.
311  DO k=1,npz
312 !$OMP parallel do default(none) shared(k,is,ie,js,je,isd,ied,jsd,jed,xfx,area,yfx,ra_x,ra_y)
313  DO j=jsd,jed
314  DO i=is,ie
315  CALL pushrealarray(ra_x(i, j))
316  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
317  END DO
318  IF (j .GE. js .AND. j .LE. je) THEN
319  DO i=isd,ied
320  CALL pushrealarray(ra_y(i, j))
321  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
322  END DO
323  CALL pushcontrol(1,1)
324  ELSE
325  CALL pushcontrol(1,0)
326  END IF
327  END DO
328  nsplt = int(1. + cmax(k))
329  DO it=1,nsplt
330 !$OMP parallel do default(none) shared(k,is,ie,js,je,rarea,mfx,mfy,dp1,dp2)
331  DO j=js,je
332  DO i=is,ie
333  CALL pushrealarray(dp2(i, j))
334  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(mfy&
335 & (i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
336  END DO
337  END DO
338 !$OMP parallel do default(none) shared(k,nsplt,it,is,ie,js,je,isd,ied,jsd,jed,npx,npy,cx,xfx,hord,trdm, &
339 !$OMP nord_tr,nq,gridstruct,bd,cy,yfx,mfx,mfy,qn2,q,ra_x,ra_y,dp1,dp2,rarea) &
340 !$OMP private(fx,fy)
341  DO iq=1,nq
342  IF (nsplt .NE. 1) THEN
343  IF (it .EQ. 1) THEN
344  DO j=jsd,jed
345  DO i=isd,ied
346  CALL pushrealarray(qn2(i, j, iq))
347  qn2(i, j, iq) = q(i, j, k, iq)
348  END DO
349  END DO
350  CALL pushcontrol(1,0)
351  ELSE
352  CALL pushcontrol(1,1)
353  END IF
354  IF (hord .EQ. hord_pert) THEN
355  CALL fv_tp_2d_fwd(qn2(isd:ied, jsd:jed, iq), cx(is:ie+1&
356 & , jsd:jed, k), cy(isd:ied, js:je+1, k), npx&
357 & , npy, hord, fx, fy, xfx(is:ie+1, jsd:jed, &
358 & k), yfx(isd:ied, js:je+1, k), gridstruct, &
359 & bd, ra_x, ra_y, mfx=mfx(is:ie+1, js:je, k)&
360 & , mfy=mfy(is:ie, js:je+1, k))
361  CALL pushcontrol(1,0)
362  ELSE
363  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
364  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
365  CALL pushrealarray(qn2(isd:ied, jsd:jed, iq), (ied-isd+1)&
366 & *(jed-jsd+1))
367  CALL fv_tp_2d(qn2(isd:ied, jsd:jed, iq), cx(is:ie+1, jsd:&
368 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
369 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
370 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
371 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
372 & , k))
373  CALL pushcontrol(1,1)
374  END IF
375  IF (it .LT. nsplt) THEN
376 ! not last call
377  DO j=js,je
378  DO i=is,ie
379  CALL pushrealarray(qn2(i, j, iq))
380  qn2(i, j, iq) = (qn2(i, j, iq)*dp1(i, j, k)+(fx(i, j)-&
381 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i&
382 & , j)
383  END DO
384  END DO
385  CALL pushcontrol(2,2)
386  ELSE
387  DO j=js,je
388  DO i=is,ie
389  CALL pushrealarray(q(i, j, k, iq))
390  q(i, j, k, iq) = (qn2(i, j, iq)*dp1(i, j, k)+(fx(i, j)&
391 & -fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(&
392 & i, j)
393  END DO
394  END DO
395  CALL pushcontrol(2,1)
396  END IF
397  ELSE
398  IF (hord .EQ. hord_pert) THEN
399  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), cx(is:ie+&
400 & 1, jsd:jed, k), cy(isd:ied, js:je+1, k), &
401 & npx, npy, hord, fx, fy, xfx(is:ie+1, jsd:&
402 & jed, k), yfx(isd:ied, js:je+1, k), &
403 & gridstruct, bd, ra_x, ra_y, mfx=mfx(is:ie+1&
404 & , js:je, k), mfy=mfy(is:ie, js:je+1, k))
405  CALL pushcontrol(1,1)
406  ELSE
407  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
408  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
409  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1&
410 & )*(jed-jsd+1))
411  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
412 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
413 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
414 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
415 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
416 & , k))
417  CALL pushcontrol(1,0)
418  END IF
419  DO j=js,je
420  DO i=is,ie
421  CALL pushrealarray(q(i, j, k, iq))
422  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-&
423 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, &
424 & j)
425  END DO
426  END DO
427  CALL pushcontrol(2,0)
428  END IF
429  END DO
430 ! tracer-loop
431  IF (it .LT. nsplt) THEN
432 ! not last call
433  DO j=js,je
434  DO i=is,ie
435  CALL pushrealarray(dp1(i, j, k))
436  dp1(i, j, k) = dp2(i, j)
437  END DO
438  END DO
439  CALL pushrealarray(qn2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
440 & nq)
441  CALL mpp_update_domains(qn2, domain)
442  CALL pushcontrol(1,1)
443  ELSE
444  CALL pushcontrol(1,0)
445  END IF
446  END DO
447  CALL pushinteger(it - 1)
448  END DO
449  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
450  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
451  CALL pushrealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
452  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
453  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
454  CALL pushrealarray(qn2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*nq)
455  CALL pushrealarray(frac)
456  CALL pushrealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
457  CALL pushrealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
458  END SUBROUTINE tracer_2d_1l_fwd
459 ! Differentiation of tracer_2d_1l in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
460 !e_mod.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_co
461 !re_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_mo
462 !d.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayle
463 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
464 !ord4 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
465 !.remap_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_2
466 !d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limite
467 !rs 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 f
468 !v_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_sub
469 !grid_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_uti
470 !ls_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
471 !_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_
472 !mod.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
473 !.d2a2c_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
474 !_v_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_co
475 !re_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_ut
476 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
477 ! gradient of useful results: q dp1
478 ! with respect to varying inputs: q dp1 mfx mfy cx cy
479 !-----------------------------------------------------------------------
480 ! !ROUTINE: Perform 2D horizontal-to-lagrangian transport
481 !-----------------------------------------------------------------------
482  SUBROUTINE tracer_2d_1l_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy, &
483 & mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, npz&
484 & , nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, &
485 & nord_tr_pert, trdm_pert, split_damp_tr, dpa)
486  IMPLICIT NONE
487  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
488  INTEGER, INTENT(IN) :: npx
489  INTEGER, INTENT(IN) :: npy
490  INTEGER, INTENT(IN) :: npz
491  INTEGER, INTENT(IN) :: nq
492  INTEGER, INTENT(IN) :: hord, nord_tr
493  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
494  LOGICAL, INTENT(IN) :: split_damp_tr
495  INTEGER, INTENT(IN) :: q_split
496  INTEGER, INTENT(IN) :: id_divg
497  REAL, INTENT(IN) :: dt, trdm, trdm_pert
498  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
499  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
500  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
501  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
502  REAL, INTENT(INOUT) :: dp1_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
503  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
504  REAL, INTENT(INOUT) :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je, npz)
505  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
506  REAL, INTENT(INOUT) :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1, npz)
507  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
508  REAL, INTENT(INOUT) :: cx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
509  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
510  REAL, INTENT(INOUT) :: cy_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
511  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je)
512  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
513  TYPE(domain2d), INTENT(INOUT) :: domain
514  REAL :: qn2(bd%isd:bd%ied, bd%jsd:bd%jed, nq)
515  REAL :: qn2_ad(bd%isd:bd%ied, bd%jsd:bd%jed, nq)
516  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
517  REAL :: dp2_ad(bd%is:bd%ie, bd%js:bd%je)
518  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
519  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
520  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
521  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
522  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
523  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
524  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
525  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
526  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
527  REAL :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
528  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
529  REAL :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
530  REAL :: cmax(npz)
531  REAL :: frac
532  INTEGER :: nsplt
533  INTEGER :: i, j, k, it, iq
534  REAL, DIMENSION(:, :), POINTER :: area, rarea
535  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
536  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
537  INTEGER :: is, ie, js, je
538  INTEGER :: isd, ied, jsd, jed
539  INTRINSIC abs
540  INTRINSIC max
541  INTRINSIC int
542  INTRINSIC real
543  INTRINSIC PRESENT
544  REAL :: max1
545  REAL :: temp_ad
546  REAL :: temp_ad0
547  REAL :: temp_ad1
548  REAL :: temp_ad2
549  REAL :: temp_ad3
550  REAL :: temp
551  REAL :: temp_ad4
552  REAL :: temp_ad5
553  INTEGER :: branch
554  INTEGER :: ad_to
555  REAL :: x1
556  REAL :: z1
557  REAL :: y3
558  REAL :: y2
559  REAL :: y1
560 
561  qn2 = 0.0
562  dp2 = 0.0
563  fx = 0.0
564  fy = 0.0
565  ra_x = 0.0
566  ra_y = 0.0
567  xfx = 0.0
568  yfx = 0.0
569  cmax = 0.0
570  frac = 0.0
571  nsplt = 0
572  is = 0
573  ie = 0
574  js = 0
575  je = 0
576  isd = 0
577  ied = 0
578  jsd = 0
579  jed = 0
580  max1 = 0
581  x1 = 0
582  z1 = 0
583  y3 = 0
584  y2 = 0
585  y1 = 0
586  ad_to = 0
587  branch = 0
588 
589  CALL poprealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
590  CALL poprealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
591  CALL poprealarray(frac)
592  CALL poprealarray(qn2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*nq)
593  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
594  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
595  CALL poprealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
596  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
597  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
598  js = bd%js
599  rarea => gridstruct%rarea
600  jsd = bd%jsd
601  ied = bd%ied
602  ie = bd%ie
603  isd = bd%isd
604  is = bd%is
605  je = bd%je
606  jed = bd%jed
607  mfx_ad = 0.0
608  mfy_ad = 0.0
609  cx_ad = 0.0
610  cy_ad = 0.0
611  xfx_ad = 0.0
612  dp2_ad = 0.0
613  qn2_ad = 0.0
614  ra_x_ad = 0.0
615  ra_y_ad = 0.0
616  yfx_ad = 0.0
617  fx_ad = 0.0
618  fy_ad = 0.0
619  DO k=npz,1,-1
620  CALL popinteger(ad_to)
621  DO it=ad_to,1,-1
622  CALL popcontrol(1,branch)
623  IF (branch .NE. 0) THEN
624  CALL poprealarray(qn2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*nq&
625 & )
626  CALL mpp_update_domains_adm(qn2, qn2_ad, domain)
627  DO j=je,js,-1
628  DO i=ie,is,-1
629  CALL poprealarray(dp1(i, j, k))
630  dp2_ad(i, j) = dp2_ad(i, j) + dp1_ad(i, j, k)
631  dp1_ad(i, j, k) = 0.0
632  END DO
633  END DO
634  END IF
635  DO iq=nq,1,-1
636  CALL popcontrol(2,branch)
637  IF (branch .EQ. 0) THEN
638  DO j=je,js,-1
639  DO i=ie,is,-1
640  CALL poprealarray(q(i, j, k, iq))
641  temp_ad4 = q_ad(i, j, k, iq)/dp2(i, j)
642  temp = q(i, j, k, iq)
643  temp_ad5 = rarea(i, j)*temp_ad4
644  dp1_ad(i, j, k) = dp1_ad(i, j, k) + temp*temp_ad4
645  fx_ad(i, j) = fx_ad(i, j) + temp_ad5
646  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad5
647  fy_ad(i, j) = fy_ad(i, j) + temp_ad5
648  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad5
649  dp2_ad(i, j) = dp2_ad(i, j) - (temp*dp1(i, j, k)+rarea(i&
650 & , j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i, j+1)))*&
651 & temp_ad4/dp2(i, j)
652  q_ad(i, j, k, iq) = dp1(i, j, k)*temp_ad4
653  END DO
654  END DO
655  CALL popcontrol(1,branch)
656  IF (branch .EQ. 0) THEN
657  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)&
658 & *(jed-jsd+1))
659  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
660  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
661  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied&
662 & , jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k), &
663 & cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+&
664 & 1, k), cy_ad(isd:ied, js:je+1, k), npx, npy, &
665 & hord_pert, fx, fx_ad, fy, fy_ad, xfx(is:ie+1, &
666 & jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), yfx(&
667 & isd:ied, js:je+1, k), yfx_ad(isd:ied, js:je+1&
668 & , k), gridstruct, bd, ra_x, ra_x_ad, ra_y, &
669 & ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(is:ie+&
670 & 1, js:je, k), mfy(is:ie, js:je+1, k), mfy_ad(&
671 & is:ie, js:je+1, k))
672  ELSE
673  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(isd:&
674 & ied, jsd:jed, k, iq), cx(is:ie+1, jsd:jed, &
675 & k), cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied&
676 & , js:je+1, k), cy_ad(isd:ied, js:je+1, k), &
677 & npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx(&
678 & is:ie+1, jsd:jed, k), xfx_ad(is:ie+1, jsd:&
679 & jed, k), yfx(isd:ied, js:je+1, k), yfx_ad(&
680 & isd:ied, js:je+1, k), gridstruct, bd, ra_x&
681 & , ra_x_ad, ra_y, ra_y_ad, mfx(is:ie+1, js:&
682 & je, k), mfx_ad(is:ie+1, js:je, k), mfy(is:&
683 & ie, js:je+1, k), mfy_ad(is:ie, js:je+1, k))
684  END IF
685  ELSE
686  IF (branch .EQ. 1) THEN
687  DO j=je,js,-1
688  DO i=ie,is,-1
689  CALL poprealarray(q(i, j, k, iq))
690  temp_ad2 = q_ad(i, j, k, iq)/dp2(i, j)
691  temp_ad3 = rarea(i, j)*temp_ad2
692  qn2_ad(i, j, iq) = qn2_ad(i, j, iq) + dp1(i, j, k)*&
693 & temp_ad2
694  dp1_ad(i, j, k) = dp1_ad(i, j, k) + qn2(i, j, iq)*&
695 & temp_ad2
696  fx_ad(i, j) = fx_ad(i, j) + temp_ad3
697  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad3
698  fy_ad(i, j) = fy_ad(i, j) + temp_ad3
699  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad3
700  dp2_ad(i, j) = dp2_ad(i, j) - (qn2(i, j, iq)*dp1(i, j&
701 & , k)+rarea(i, j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i&
702 & , j+1)))*temp_ad2/dp2(i, j)
703  q_ad(i, j, k, iq) = 0.0
704  END DO
705  END DO
706  ELSE
707  DO j=je,js,-1
708  DO i=ie,is,-1
709  CALL poprealarray(qn2(i, j, iq))
710  temp_ad0 = qn2_ad(i, j, iq)/dp2(i, j)
711  temp_ad1 = rarea(i, j)*temp_ad0
712  dp1_ad(i, j, k) = dp1_ad(i, j, k) + qn2(i, j, iq)*&
713 & temp_ad0
714  fx_ad(i, j) = fx_ad(i, j) + temp_ad1
715  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad1
716  fy_ad(i, j) = fy_ad(i, j) + temp_ad1
717  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad1
718  dp2_ad(i, j) = dp2_ad(i, j) - (qn2(i, j, iq)*dp1(i, j&
719 & , k)+rarea(i, j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i&
720 & , j+1)))*temp_ad0/dp2(i, j)
721  qn2_ad(i, j, iq) = dp1(i, j, k)*temp_ad0
722  END DO
723  END DO
724  END IF
725  CALL popcontrol(1,branch)
726  IF (branch .EQ. 0) THEN
727  CALL fv_tp_2d_bwd(qn2(isd:ied, jsd:jed, iq), qn2_ad(isd&
728 & :ied, jsd:jed, iq), cx(is:ie+1, jsd:jed, k)&
729 & , cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, &
730 & js:je+1, k), cy_ad(isd:ied, js:je+1, k), &
731 & npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx(&
732 & is:ie+1, jsd:jed, k), xfx_ad(is:ie+1, jsd:&
733 & jed, k), yfx(isd:ied, js:je+1, k), yfx_ad(&
734 & isd:ied, js:je+1, k), gridstruct, bd, ra_x&
735 & , ra_x_ad, ra_y, ra_y_ad, mfx(is:ie+1, js:&
736 & je, k), mfx_ad(is:ie+1, js:je, k), mfy(is:&
737 & ie, js:je+1, k), mfy_ad(is:ie, js:je+1, k))
738  ELSE
739  CALL poprealarray(qn2(isd:ied, jsd:jed, iq), (ied-isd+1)*&
740 & (jed-jsd+1))
741  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
742  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
743  CALL fv_tp_2d_adm(qn2(isd:ied, jsd:jed, iq), qn2_ad(isd:&
744 & ied, jsd:jed, iq), cx(is:ie+1, jsd:jed, k), &
745 & cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+&
746 & 1, k), cy_ad(isd:ied, js:je+1, k), npx, npy, &
747 & hord_pert, fx, fx_ad, fy, fy_ad, xfx(is:ie+1, &
748 & jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), yfx(&
749 & isd:ied, js:je+1, k), yfx_ad(isd:ied, js:je+1&
750 & , k), gridstruct, bd, ra_x, ra_x_ad, ra_y, &
751 & ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(is:ie+&
752 & 1, js:je, k), mfy(is:ie, js:je+1, k), mfy_ad(&
753 & is:ie, js:je+1, k))
754  END IF
755  CALL popcontrol(1,branch)
756  IF (branch .EQ. 0) THEN
757  DO j=jed,jsd,-1
758  DO i=ied,isd,-1
759  CALL poprealarray(qn2(i, j, iq))
760  q_ad(i, j, k, iq) = q_ad(i, j, k, iq) + qn2_ad(i, j, &
761 & iq)
762  qn2_ad(i, j, iq) = 0.0
763  END DO
764  END DO
765  END IF
766  END IF
767  END DO
768  DO j=je,js,-1
769  DO i=ie,is,-1
770  CALL poprealarray(dp2(i, j))
771  temp_ad = rarea(i, j)*dp2_ad(i, j)
772  dp1_ad(i, j, k) = dp1_ad(i, j, k) + dp2_ad(i, j)
773  mfx_ad(i, j, k) = mfx_ad(i, j, k) + temp_ad
774  mfx_ad(i+1, j, k) = mfx_ad(i+1, j, k) - temp_ad
775  mfy_ad(i, j, k) = mfy_ad(i, j, k) + temp_ad
776  mfy_ad(i, j+1, k) = mfy_ad(i, j+1, k) - temp_ad
777  dp2_ad(i, j) = 0.0
778  END DO
779  END DO
780  END DO
781  DO j=jed,jsd,-1
782  CALL popcontrol(1,branch)
783  IF (branch .NE. 0) THEN
784  DO i=ied,isd,-1
785  CALL poprealarray(ra_y(i, j))
786  yfx_ad(i, j, k) = yfx_ad(i, j, k) + ra_y_ad(i, j)
787  yfx_ad(i, j+1, k) = yfx_ad(i, j+1, k) - ra_y_ad(i, j)
788  ra_y_ad(i, j) = 0.0
789  END DO
790  END IF
791  DO i=ie,is,-1
792  CALL poprealarray(ra_x(i, j))
793  xfx_ad(i, j, k) = xfx_ad(i, j, k) + ra_x_ad(i, j)
794  xfx_ad(i+1, j, k) = xfx_ad(i+1, j, k) - ra_x_ad(i, j)
795  ra_x_ad(i, j) = 0.0
796  END DO
797  END DO
798  END DO
799  DO k=npz,1,-1
800  CALL popcontrol(1,branch)
801  IF (branch .NE. 0) THEN
802  DO j=je+1,js,-1
803  DO i=ie,is,-1
804  CALL poprealarray(mfy(i, j, k))
805  mfy_ad(i, j, k) = frac*mfy_ad(i, j, k)
806  END DO
807  END DO
808  DO j=je+1,js,-1
809  DO i=ied,isd,-1
810  yfx_ad(i, j, k) = frac*yfx_ad(i, j, k)
811  CALL poprealarray(cy(i, j, k))
812  cy_ad(i, j, k) = frac*cy_ad(i, j, k)
813  END DO
814  END DO
815  DO j=je,js,-1
816  DO i=ie+1,is,-1
817  CALL poprealarray(mfx(i, j, k))
818  mfx_ad(i, j, k) = frac*mfx_ad(i, j, k)
819  END DO
820  END DO
821  DO j=jed,jsd,-1
822  DO i=ie+1,is,-1
823  xfx_ad(i, j, k) = frac*xfx_ad(i, j, k)
824  CALL poprealarray(cx(i, j, k))
825  cx_ad(i, j, k) = frac*cx_ad(i, j, k)
826  END DO
827  END DO
828  CALL poprealarray(frac)
829  END IF
830  END DO
831  dxa => gridstruct%dxa
832  dx => gridstruct%dx
833  dy => gridstruct%dy
834  sin_sg => gridstruct%sin_sg
835  dya => gridstruct%dya
836  DO k=npz,1,-1
837  CALL popcontrol(1,branch)
838  IF (branch .EQ. 0) THEN
839  DO j=je,js,-1
840  DO i=ie,is,-1
841  CALL popcontrol(1,branch)
842  END DO
843  END DO
844  ELSE
845  DO j=je,js,-1
846  DO i=ie,is,-1
847  CALL popcontrol(2,branch)
848  END DO
849  END DO
850  END IF
851  DO j=je+1,js,-1
852  DO i=ied,isd,-1
853  CALL popcontrol(1,branch)
854  IF (branch .EQ. 0) THEN
855  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j)*dx(i, j)*sin_sg(&
856 & i, j, 2)*yfx_ad(i, j, k)
857  yfx_ad(i, j, k) = 0.0
858  ELSE
859  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j-1)*dx(i, j)*&
860 & sin_sg(i, j-1, 4)*yfx_ad(i, j, k)
861  yfx_ad(i, j, k) = 0.0
862  END IF
863  END DO
864  END DO
865  DO j=jed,jsd,-1
866  DO i=ie+1,is,-1
867  CALL popcontrol(1,branch)
868  IF (branch .EQ. 0) THEN
869  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i, j)*dy(i, j)*sin_sg(&
870 & i, j, 1)*xfx_ad(i, j, k)
871  xfx_ad(i, j, k) = 0.0
872  ELSE
873  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i-1, j)*dy(i, j)*&
874 & sin_sg(i-1, j, 3)*xfx_ad(i, j, k)
875  xfx_ad(i, j, k) = 0.0
876  END IF
877  END DO
878  END DO
879  END DO
880  END SUBROUTINE tracer_2d_1l_bwd
881 !-----------------------------------------------------------------------
882 ! !ROUTINE: Perform 2D horizontal-to-lagrangian transport
883 !-----------------------------------------------------------------------
884  SUBROUTINE tracer_2d_1l(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, &
885 & domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, &
886 & nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, &
887 & dpa)
888  IMPLICIT NONE
889  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
890  INTEGER, INTENT(IN) :: npx
891  INTEGER, INTENT(IN) :: npy
892  INTEGER, INTENT(IN) :: npz
893 ! number of tracers to be advected
894  INTEGER, INTENT(IN) :: nq
895  INTEGER, INTENT(IN) :: hord, nord_tr
896  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
897  LOGICAL, INTENT(IN) :: split_damp_tr
898  INTEGER, INTENT(IN) :: q_split
899  INTEGER, INTENT(IN) :: id_divg
900  REAL, INTENT(IN) :: dt, trdm, trdm_pert
901  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
902 ! Tracers
903  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
904 ! DELP before dyn_core
905  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
906 ! Mass Flux X-Dir
907  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
908 ! Mass Flux Y-Dir
909  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
910 ! Courant Number X-Dir
911  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
912 ! Courant Number Y-Dir
913  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
914 ! DELP after advection
915  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je)
916  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
917  TYPE(domain2d), INTENT(INOUT) :: domain
918 ! Local Arrays
919 ! 3D tracers
920  REAL :: qn2(bd%isd:bd%ied, bd%jsd:bd%jed, nq)
921  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
922  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
923  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
924  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
925  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
926  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
927  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
928  REAL :: cmax(npz)
929  REAL :: frac
930  INTEGER :: nsplt
931  INTEGER :: i, j, k, it, iq
932  REAL, DIMENSION(:, :), POINTER :: area, rarea
933  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
934  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
935  INTEGER :: is, ie, js, je
936  INTEGER :: isd, ied, jsd, jed
937  INTRINSIC abs
938  INTRINSIC max
939  INTRINSIC int
940  INTRINSIC real
941  INTRINSIC PRESENT
942  REAL :: max1
943  REAL :: x1
944  REAL :: z1
945  REAL :: y3
946  REAL :: y2
947  REAL :: y1
948  is = bd%is
949  ie = bd%ie
950  js = bd%js
951  je = bd%je
952  isd = bd%isd
953  ied = bd%ied
954  jsd = bd%jsd
955  jed = bd%jed
956  area => gridstruct%area
957  rarea => gridstruct%rarea
958  sin_sg => gridstruct%sin_sg
959  dxa => gridstruct%dxa
960  dya => gridstruct%dya
961  dx => gridstruct%dx
962  dy => gridstruct%dy
963 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
964 !$OMP sin_sg,cy,yfx,dya,dx,cmax)
965  DO k=1,npz
966  DO j=jsd,jed
967  DO i=is,ie+1
968  IF (cx(i, j, k) .GT. 0.) THEN
969  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
970 & j, 3)
971  ELSE
972  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
973 & )
974  END IF
975  END DO
976  END DO
977  DO j=js,je+1
978  DO i=isd,ied
979  IF (cy(i, j, k) .GT. 0.) THEN
980  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
981 & 1, 4)
982  ELSE
983  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
984 & )
985  END IF
986  END DO
987  END DO
988  cmax(k) = 0.
989  IF (k .LT. npz/6) THEN
990  DO j=js,je
991  DO i=is,ie
992  IF (cx(i, j, k) .GE. 0.) THEN
993  y1 = cx(i, j, k)
994  ELSE
995  y1 = -cx(i, j, k)
996  END IF
997  IF (cy(i, j, k) .GE. 0.) THEN
998  z1 = cy(i, j, k)
999  ELSE
1000  z1 = -cy(i, j, k)
1001  END IF
1002  IF (cmax(k) .LT. y1) THEN
1003  IF (y1 .LT. z1) THEN
1004  cmax(k) = z1
1005  ELSE
1006  cmax(k) = y1
1007  END IF
1008  ELSE IF (cmax(k) .LT. z1) THEN
1009  cmax(k) = z1
1010  ELSE
1011  cmax(k) = cmax(k)
1012  END IF
1013  END DO
1014  END DO
1015  ELSE
1016  DO j=js,je
1017  DO i=is,ie
1018  IF (cx(i, j, k) .GE. 0.) THEN
1019  x1 = cx(i, j, k)
1020  ELSE
1021  x1 = -cx(i, j, k)
1022  END IF
1023  IF (cy(i, j, k) .GE. 0.) THEN
1024  y3 = cy(i, j, k)
1025  ELSE
1026  y3 = -cy(i, j, k)
1027  END IF
1028  IF (x1 .LT. y3) THEN
1029  max1 = y3
1030  ELSE
1031  max1 = x1
1032  END IF
1033  y2 = max1 + 1. - sin_sg(i, j, 5)
1034  IF (cmax(k) .LT. y2) THEN
1035  cmax(k) = y2
1036  ELSE
1037  cmax(k) = cmax(k)
1038  END IF
1039  END DO
1040  END DO
1041  END IF
1042  END DO
1043 ! k-loop
1044  CALL mp_reduce_max(cmax, npz)
1045 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx, &
1046 !$OMP cy,yfx,mfx,mfy,cmax) &
1047 !$OMP private(nsplt, frac)
1048  DO k=1,npz
1049  nsplt = int(1. + cmax(k))
1050  IF (nsplt .GT. 1) THEN
1051  frac = 1./REAL(nsplt)
1052  DO j=jsd,jed
1053  DO i=is,ie+1
1054  cx(i, j, k) = cx(i, j, k)*frac
1055  xfx(i, j, k) = xfx(i, j, k)*frac
1056  END DO
1057  END DO
1058  DO j=js,je
1059  DO i=is,ie+1
1060  mfx(i, j, k) = mfx(i, j, k)*frac
1061  END DO
1062  END DO
1063  DO j=js,je+1
1064  DO i=isd,ied
1065  cy(i, j, k) = cy(i, j, k)*frac
1066  yfx(i, j, k) = yfx(i, j, k)*frac
1067  END DO
1068  END DO
1069  DO j=js,je+1
1070  DO i=is,ie
1071  mfy(i, j, k) = mfy(i, j, k)*frac
1072  END DO
1073  END DO
1074  END IF
1075  END DO
1076  CALL timing_on('COMM_TOTAL')
1077  CALL timing_on('COMM_TRACER')
1078  CALL complete_group_halo_update(q_pack, domain)
1079  CALL timing_off('COMM_TRACER')
1080  CALL timing_off('COMM_TOTAL')
1081 ! Begin k-independent tracer transport; can not be OpenMPed because the mpp_update call.
1082  DO k=1,npz
1083 !$OMP parallel do default(none) shared(k,is,ie,js,je,isd,ied,jsd,jed,xfx,area,yfx,ra_x,ra_y)
1084  DO j=jsd,jed
1085  DO i=is,ie
1086  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
1087  END DO
1088  IF (j .GE. js .AND. j .LE. je) THEN
1089  DO i=isd,ied
1090  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
1091  END DO
1092  END IF
1093  END DO
1094  nsplt = int(1. + cmax(k))
1095  DO it=1,nsplt
1096 !$OMP parallel do default(none) shared(k,is,ie,js,je,rarea,mfx,mfy,dp1,dp2)
1097  DO j=js,je
1098  DO i=is,ie
1099  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(mfy&
1100 & (i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
1101  END DO
1102  END DO
1103 !$OMP parallel do default(none) shared(k,nsplt,it,is,ie,js,je,isd,ied,jsd,jed,npx,npy,cx,xfx,hord,trdm, &
1104 !$OMP nord_tr,nq,gridstruct,bd,cy,yfx,mfx,mfy,qn2,q,ra_x,ra_y,dp1,dp2,rarea) &
1105 !$OMP private(fx,fy)
1106  DO iq=1,nq
1107  IF (nsplt .NE. 1) THEN
1108  IF (it .EQ. 1) THEN
1109  DO j=jsd,jed
1110  DO i=isd,ied
1111  qn2(i, j, iq) = q(i, j, k, iq)
1112  END DO
1113  END DO
1114  END IF
1115  IF (hord .EQ. hord_pert) THEN
1116  CALL fv_tp_2d(qn2(isd:ied, jsd:jed, iq), cx(is:ie+1, &
1117 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy&
1118 & , hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
1119 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
1120 & ra_y, mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie&
1121 & , js:je+1, k))
1122  ELSE
1123  CALL fv_tp_2d(qn2(isd:ied, jsd:jed, iq), cx(is:ie+1, jsd:&
1124 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
1125 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
1126 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
1127 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
1128 & , k))
1129  END IF
1130  IF (it .LT. nsplt) THEN
1131 ! not last call
1132  DO j=js,je
1133  DO i=is,ie
1134  qn2(i, j, iq) = (qn2(i, j, iq)*dp1(i, j, k)+(fx(i, j)-&
1135 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i&
1136 & , j)
1137  END DO
1138  END DO
1139  ELSE
1140  DO j=js,je
1141  DO i=is,ie
1142  q(i, j, k, iq) = (qn2(i, j, iq)*dp1(i, j, k)+(fx(i, j)&
1143 & -fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(&
1144 & i, j)
1145  END DO
1146  END DO
1147  END IF
1148  ELSE
1149  IF (hord .EQ. hord_pert) THEN
1150  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, &
1151 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy&
1152 & , hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
1153 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
1154 & ra_y, mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie&
1155 & , js:je+1, k))
1156  ELSE
1157  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
1158 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
1159 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
1160 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
1161 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
1162 & , k))
1163  END IF
1164  DO j=js,je
1165  DO i=is,ie
1166  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-&
1167 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, &
1168 & j)
1169  END DO
1170  END DO
1171  END IF
1172  END DO
1173 ! tracer-loop
1174  IF (it .LT. nsplt) THEN
1175 ! not last call
1176  DO j=js,je
1177  DO i=is,ie
1178  dp1(i, j, k) = dp2(i, j)
1179  END DO
1180  END DO
1181  CALL timing_on('COMM_TOTAL')
1182  CALL timing_on('COMM_TRACER')
1183  CALL mpp_update_domains(qn2, domain)
1184  CALL timing_off('COMM_TRACER')
1185  CALL timing_off('COMM_TOTAL')
1186  END IF
1187  END DO
1188  END DO
1189 ! time-split loop
1190 ! k-loop
1191  IF (PRESENT(dpa)) dpa = dp2
1192  END SUBROUTINE tracer_2d_1l
1193 ! Differentiation of tracer_2d in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
1194 !d.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_m
1195 !od.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.mi
1196 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
1197 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
1198 ! 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.rem
1199 !ap_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 fv
1200 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
1201 !v_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_re
1202 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
1203 !_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_m
1204 !od.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_mod
1205 !.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.
1206 !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.d2a
1207 !2c_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_f
1208 !b 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_m
1209 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
1210 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1211 ! gradient of useful results: q dp1
1212 ! with respect to varying inputs: q dp1 mfx mfy cx cy
1213  SUBROUTINE tracer_2d_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, &
1214 & domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, &
1215 & nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, &
1216 & dpa)
1217  IMPLICIT NONE
1218  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1219  INTEGER, INTENT(IN) :: npx
1220  INTEGER, INTENT(IN) :: npy
1221  INTEGER, INTENT(IN) :: npz
1222 ! number of tracers to be advected
1223  INTEGER, INTENT(IN) :: nq
1224  INTEGER, INTENT(IN) :: hord, nord_tr
1225  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
1226  LOGICAL, INTENT(IN) :: split_damp_tr
1227  INTEGER, INTENT(IN) :: q_split
1228  INTEGER, INTENT(IN) :: id_divg
1229  REAL, INTENT(IN) :: dt, trdm, trdm_pert
1230  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
1231 ! Tracers
1232  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1233 ! DELP before dyn_core
1234  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1235 ! Mass Flux X-Dir
1236  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
1237 ! Mass Flux Y-Dir
1238  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
1239 ! Courant Number X-Dir
1240  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1241 ! Courant Number Y-Dir
1242  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1243 ! DELP after advection
1244  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je, npz)
1245  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1246  TYPE(domain2d), INTENT(INOUT) :: domain
1247 ! Local Arrays
1248  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
1249  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
1250  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
1251  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
1252  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
1253  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1254  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1255  REAL :: cmax(npz)
1256  REAL :: c_global
1257  REAL :: frac, rdt
1258  INTEGER :: ksplt(npz)
1259  INTEGER :: nsplt
1260  INTEGER :: i, j, k, it, iq
1261  REAL, DIMENSION(:, :), POINTER :: area, rarea
1262  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
1263  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
1264  INTEGER :: is, ie, js, je
1265  INTEGER :: isd, ied, jsd, jed
1266  INTRINSIC abs
1267  INTRINSIC max
1268  INTRINSIC int
1269  INTRINSIC real
1270  INTRINSIC PRESENT
1271  REAL :: max1
1272  LOGICAL :: res
1273  REAL :: x1
1274  REAL :: z1
1275  REAL :: y3
1276  REAL :: y2
1277  REAL :: y1
1278 
1279  dp2 = 0.0
1280  fx = 0.0
1281  fy = 0.0
1282  ra_x = 0.0
1283  ra_y = 0.0
1284  xfx = 0.0
1285  yfx = 0.0
1286  cmax = 0.0
1287  c_global = 0.0
1288  frac = 0.0
1289  rdt = 0.0
1290  ksplt = 0
1291  nsplt = 0
1292  is = 0
1293  ie = 0
1294  js = 0
1295  je = 0
1296  isd = 0
1297  ied = 0
1298  jsd = 0
1299  jed = 0
1300  max1 = 0.0
1301  x1 = 0.0
1302  z1 = 0.0
1303  y3 = 0.0
1304  y2 = 0.0
1305  y1 = 0.0
1306 
1307  is = bd%is
1308  ie = bd%ie
1309  js = bd%js
1310  je = bd%je
1311  isd = bd%isd
1312  ied = bd%ied
1313  jsd = bd%jsd
1314  jed = bd%jed
1315  area => gridstruct%area
1316  rarea => gridstruct%rarea
1317  sin_sg => gridstruct%sin_sg
1318  dxa => gridstruct%dxa
1319  dya => gridstruct%dya
1320  dx => gridstruct%dx
1321  dy => gridstruct%dy
1322 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
1323 !$OMP sin_sg,cy,yfx,dya,dx,cmax,q_split,ksplt)
1324  DO k=1,npz
1325  DO j=jsd,jed
1326  DO i=is,ie+1
1327  IF (cx(i, j, k) .GT. 0.) THEN
1328  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
1329 & j, 3)
1330  CALL pushcontrol(1,1)
1331  ELSE
1332  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
1333 & )
1334  CALL pushcontrol(1,0)
1335  END IF
1336  END DO
1337  END DO
1338  DO j=js,je+1
1339  DO i=isd,ied
1340  IF (cy(i, j, k) .GT. 0.) THEN
1341  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
1342 & 1, 4)
1343  CALL pushcontrol(1,1)
1344  ELSE
1345  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
1346 & )
1347  CALL pushcontrol(1,0)
1348  END IF
1349  END DO
1350  END DO
1351  IF (q_split .EQ. 0) THEN
1352  cmax(k) = 0.
1353  IF (k .LT. npz/6) THEN
1354  DO j=js,je
1355  DO i=is,ie
1356  IF (cx(i, j, k) .GE. 0.) THEN
1357  y1 = cx(i, j, k)
1358  ELSE
1359  y1 = -cx(i, j, k)
1360  END IF
1361  IF (cy(i, j, k) .GE. 0.) THEN
1362  z1 = cy(i, j, k)
1363  ELSE
1364  z1 = -cy(i, j, k)
1365  END IF
1366  IF (cmax(k) .LT. y1) THEN
1367  IF (y1 .LT. z1) THEN
1368  CALL pushcontrol(2,0)
1369  cmax(k) = z1
1370  ELSE
1371  CALL pushcontrol(2,1)
1372  cmax(k) = y1
1373  END IF
1374  ELSE IF (cmax(k) .LT. z1) THEN
1375  CALL pushcontrol(2,2)
1376  cmax(k) = z1
1377  ELSE
1378  CALL pushcontrol(2,3)
1379  cmax(k) = cmax(k)
1380  END IF
1381  END DO
1382  END DO
1383  CALL pushcontrol(2,0)
1384  ELSE
1385  DO j=js,je
1386  DO i=is,ie
1387  IF (cx(i, j, k) .GE. 0.) THEN
1388  x1 = cx(i, j, k)
1389  ELSE
1390  x1 = -cx(i, j, k)
1391  END IF
1392  IF (cy(i, j, k) .GE. 0.) THEN
1393  y3 = cy(i, j, k)
1394  ELSE
1395  y3 = -cy(i, j, k)
1396  END IF
1397  IF (x1 .LT. y3) THEN
1398  max1 = y3
1399  ELSE
1400  max1 = x1
1401  END IF
1402  y2 = max1 + 1. - sin_sg(i, j, 5)
1403  IF (cmax(k) .LT. y2) THEN
1404  CALL pushcontrol(1,0)
1405  cmax(k) = y2
1406  ELSE
1407  CALL pushcontrol(1,1)
1408  cmax(k) = cmax(k)
1409  END IF
1410  END DO
1411  END DO
1412  CALL pushcontrol(2,1)
1413  END IF
1414  ELSE
1415  CALL pushcontrol(2,2)
1416  END IF
1417  ksplt(k) = 1
1418  END DO
1419 !--------------------------------------------------------------------------------
1420 ! Determine global nsplt:
1421  IF (q_split .EQ. 0) THEN
1422  CALL mp_reduce_max(cmax, npz)
1423 ! find global max courant number and define nsplt to scale cx,cy,mfx,mfy
1424  c_global = cmax(1)
1425  IF (npz .NE. 1) THEN
1426 ! if NOT shallow water test case
1427  DO k=2,npz
1428  IF (cmax(k) .LT. c_global) THEN
1429  CALL pushcontrol(1,0)
1430  c_global = c_global
1431  ELSE
1432  CALL pushcontrol(1,1)
1433  c_global = cmax(k)
1434  END IF
1435  END DO
1436  CALL pushcontrol(1,0)
1437  ELSE
1438  CALL pushcontrol(1,1)
1439  END IF
1440  nsplt = int(1. + c_global)
1441  res = is_master()
1442  IF (res .AND. nsplt .GT. 4) THEN
1443  CALL pushcontrol(1,0)
1444  WRITE(*, *) 'Tracer_2d_split=', nsplt, c_global
1445  ELSE
1446  CALL pushcontrol(1,0)
1447  END IF
1448  ELSE
1449  CALL pushcontrol(1,1)
1450  nsplt = q_split
1451  END IF
1452 !--------------------------------------------------------------------------------
1453  IF (nsplt .NE. 1) THEN
1454 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt) &
1455 !$OMP private( frac )
1456  DO k=1,npz
1457  ksplt(k) = int(1. + cmax(k))
1458  CALL pushrealarray(frac)
1459  frac = 1./REAL(ksplt(k))
1460  DO j=jsd,jed
1461  DO i=is,ie+1
1462  CALL pushrealarray(cx(i, j, k))
1463  cx(i, j, k) = cx(i, j, k)*frac
1464  xfx(i, j, k) = xfx(i, j, k)*frac
1465  END DO
1466  END DO
1467  DO j=js,je
1468  DO i=is,ie+1
1469  CALL pushrealarray(mfx(i, j, k))
1470  mfx(i, j, k) = mfx(i, j, k)*frac
1471  END DO
1472  END DO
1473  DO j=js,je+1
1474  DO i=isd,ied
1475  CALL pushrealarray(cy(i, j, k))
1476  cy(i, j, k) = cy(i, j, k)*frac
1477  yfx(i, j, k) = yfx(i, j, k)*frac
1478  END DO
1479  END DO
1480  DO j=js,je+1
1481  DO i=is,ie
1482  CALL pushrealarray(mfy(i, j, k))
1483  mfy(i, j, k) = mfy(i, j, k)*frac
1484  END DO
1485  END DO
1486  END DO
1487  CALL pushcontrol(1,1)
1488  ELSE
1489  CALL pushcontrol(1,0)
1490  END IF
1491  DO it=1,nsplt
1492 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq,ksplt,&
1493 !$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm) &
1494 !$OMP private(dp2, ra_x, ra_y, fx, fy)
1495  DO k=1,npz
1496 ! ksplt
1497  IF (it .LE. ksplt(k)) THEN
1498  DO j=js,je
1499  DO i=is,ie
1500  CALL pushrealarray(dp2(i, j))
1501  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(&
1502 & mfy(i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
1503  END DO
1504  END DO
1505  DO j=jsd,jed
1506  DO i=is,ie
1507  CALL pushrealarray(ra_x(i, j))
1508  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
1509  END DO
1510  END DO
1511  DO j=js,je
1512  DO i=isd,ied
1513  CALL pushrealarray(ra_y(i, j))
1514  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
1515  END DO
1516  END DO
1517  DO iq=1,nq
1518  IF (it .EQ. 1 .AND. trdm .GT. 1.e-4) THEN
1519  IF (hord .EQ. hord_pert) THEN
1520  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), cx(is:&
1521 & ie+1, jsd:jed, k), cy(isd:ied, js:je+1, k&
1522 & ), npx, npy, hord, fx, fy, xfx(is:ie+1, &
1523 & jsd:jed, k), yfx(isd:ied, js:je+1, k), &
1524 & gridstruct, bd, ra_x, ra_y, mfx=mfx(is:ie&
1525 & +1, js:je, k), mfy=mfy(is:ie, js:je+1, k)&
1526 & , mass=dp1(isd:ied, jsd:jed, k), nord=&
1527 & nord_tr, damp_c=trdm)
1528  CALL pushcontrol(2,3)
1529  ELSE
1530  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1531  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1532  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd&
1533 & +1)*(jed-jsd+1))
1534  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, &
1535 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
1536 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx&
1537 & (isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
1538 & ra_y, mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie&
1539 & , js:je+1, k), mass=dp1(isd:ied, jsd:jed, k), &
1540 & nord=nord_tr, damp_c=trdm)
1541  CALL pushcontrol(2,2)
1542  END IF
1543  ELSE IF (hord .EQ. hord_pert) THEN
1544  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), cx(is:ie+&
1545 & 1, jsd:jed, k), cy(isd:ied, js:je+1, k), &
1546 & npx, npy, hord, fx, fy, xfx(is:ie+1, jsd:&
1547 & jed, k), yfx(isd:ied, js:je+1, k), &
1548 & gridstruct, bd, ra_x, ra_y, mfx=mfx(is:ie+1&
1549 & , js:je, k), mfy=mfy(is:ie, js:je+1, k))
1550  CALL pushcontrol(2,1)
1551  ELSE
1552  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1553  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1554  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1&
1555 & )*(jed-jsd+1))
1556  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
1557 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
1558 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
1559 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
1560 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
1561 & , k))
1562  CALL pushcontrol(2,0)
1563  END IF
1564  DO j=js,je
1565  DO i=is,ie
1566  CALL pushrealarray(q(i, j, k, iq))
1567  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-&
1568 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, &
1569 & j)
1570  END DO
1571  END DO
1572  END DO
1573  IF (it .NE. nsplt) THEN
1574  DO j=js,je
1575  DO i=is,ie
1576  CALL pushrealarray(dp1(i, j, k))
1577  dp1(i, j, k) = dp2(i, j)
1578  END DO
1579  END DO
1580  CALL pushcontrol(2,2)
1581  ELSE
1582  CALL pushcontrol(2,1)
1583  END IF
1584  ELSE
1585  CALL pushcontrol(2,0)
1586  END IF
1587  END DO
1588 ! npz
1589  IF (it .NE. nsplt) THEN
1590  CALL pushrealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*&
1591 & nq)
1592  CALL start_group_halo_update(q_pack, q, domain)
1593  CALL pushcontrol(1,1)
1594  ELSE
1595  CALL pushcontrol(1,0)
1596  END IF
1597  END DO
1598  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1599  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1600  CALL pushinteger(nsplt)
1601  CALL pushrealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
1602  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
1603  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
1604  CALL pushrealarray(frac)
1605  CALL pushrealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
1606  CALL pushrealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
1607  END SUBROUTINE tracer_2d_fwd
1608 ! Differentiation of tracer_2d in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
1609 !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_
1610 !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
1611 !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
1612 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
1613 !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
1614 !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
1615 !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
1616 !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
1617 !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
1618 !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_
1619 !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
1620 !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
1621 !.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
1622 !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_
1623 !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_
1624 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
1625 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1626 ! gradient of useful results: q dp1
1627 ! with respect to varying inputs: q dp1 mfx mfy cx cy
1628  SUBROUTINE tracer_2d_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy, &
1629 & mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, npz&
1630 & , nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, &
1631 & nord_tr_pert, trdm_pert, split_damp_tr, dpa)
1632  IMPLICIT NONE
1633  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1634  INTEGER, INTENT(IN) :: npx
1635  INTEGER, INTENT(IN) :: npy
1636  INTEGER, INTENT(IN) :: npz
1637  INTEGER, INTENT(IN) :: nq
1638  INTEGER, INTENT(IN) :: hord, nord_tr
1639  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
1640  LOGICAL, INTENT(IN) :: split_damp_tr
1641  INTEGER, INTENT(IN) :: q_split
1642  INTEGER, INTENT(IN) :: id_divg
1643  REAL, INTENT(IN) :: dt, trdm, trdm_pert
1644  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
1645  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1646  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1647  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1648  REAL, INTENT(INOUT) :: dp1_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1649  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
1650  REAL, INTENT(INOUT) :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je, npz)
1651  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
1652  REAL, INTENT(INOUT) :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1, npz)
1653  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1654  REAL, INTENT(INOUT) :: cx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1655  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1656  REAL, INTENT(INOUT) :: cy_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1657  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je, npz)
1658  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1659  TYPE(domain2d), INTENT(INOUT) :: domain
1660  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
1661  REAL :: dp2_ad(bd%is:bd%ie, bd%js:bd%je)
1662  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
1663  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
1664  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
1665  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
1666  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
1667  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
1668  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
1669  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
1670  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1671  REAL :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1672  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1673  REAL :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1674  REAL :: cmax(npz)
1675  REAL :: c_global
1676  REAL :: frac, rdt
1677  INTEGER :: ksplt(npz)
1678  INTEGER :: nsplt
1679  INTEGER :: i, j, k, it, iq
1680  REAL, DIMENSION(:, :), POINTER :: area, rarea
1681  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
1682  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
1683  INTEGER :: is, ie, js, je
1684  INTEGER :: isd, ied, jsd, jed
1685  INTRINSIC abs
1686  INTRINSIC max
1687  INTRINSIC int
1688  INTRINSIC real
1689  INTRINSIC PRESENT
1690  REAL :: max1
1691  REAL :: temp_ad
1692  REAL :: temp
1693  REAL :: temp_ad0
1694  REAL :: temp_ad1
1695  INTEGER :: branch
1696  REAL :: x1
1697  REAL :: z1
1698  REAL :: y3
1699  REAL :: y2
1700  REAL :: y1
1701 
1702  dp2 = 0.0
1703  fx = 0.0
1704  fy = 0.0
1705  ra_x = 0.0
1706  ra_y = 0.0
1707  xfx = 0.0
1708  yfx = 0.0
1709  cmax = 0.0
1710  c_global = 0.0
1711  frac = 0.0
1712  rdt = 0.0
1713  ksplt = 0
1714  nsplt = 0
1715  is = 0
1716  ie = 0
1717  js = 0
1718  je = 0
1719  isd = 0
1720  ied = 0
1721  jsd = 0
1722  jed = 0
1723  max1 = 0.0
1724  x1 = 0.0
1725  z1 = 0.0
1726  y3 = 0.0
1727  y2 = 0.0
1728  y1 = 0.0
1729  branch = 0
1730 
1731  CALL poprealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
1732  CALL poprealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
1733  CALL poprealarray(frac)
1734  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
1735  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
1736  CALL poprealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
1737  CALL popinteger(nsplt)
1738  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1739  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1740  js = bd%js
1741  rarea => gridstruct%rarea
1742  jsd = bd%jsd
1743  ied = bd%ied
1744  ie = bd%ie
1745  isd = bd%isd
1746  is = bd%is
1747  je = bd%je
1748  jed = bd%jed
1749  mfx_ad = 0.0
1750  mfy_ad = 0.0
1751  cx_ad = 0.0
1752  cy_ad = 0.0
1753  xfx_ad = 0.0
1754  dp2_ad = 0.0
1755  ra_x_ad = 0.0
1756  ra_y_ad = 0.0
1757  yfx_ad = 0.0
1758  fx_ad = 0.0
1759  fy_ad = 0.0
1760  DO it=nsplt,1,-1
1761  CALL popcontrol(1,branch)
1762  IF (branch .NE. 0) THEN
1763  CALL poprealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*nq&
1764 & )
1765  CALL start_group_halo_update_adm(q_pack, q, q_ad, domain)
1766  END IF
1767  DO k=npz,1,-1
1768  CALL popcontrol(2,branch)
1769  IF (branch .NE. 0) THEN
1770  IF (branch .NE. 1) THEN
1771  DO j=je,js,-1
1772  DO i=ie,is,-1
1773  CALL poprealarray(dp1(i, j, k))
1774  dp2_ad(i, j) = dp2_ad(i, j) + dp1_ad(i, j, k)
1775  dp1_ad(i, j, k) = 0.0
1776  END DO
1777  END DO
1778  END IF
1779  DO iq=nq,1,-1
1780  DO j=je,js,-1
1781  DO i=ie,is,-1
1782  CALL poprealarray(q(i, j, k, iq))
1783  temp_ad0 = q_ad(i, j, k, iq)/dp2(i, j)
1784  temp = q(i, j, k, iq)
1785  temp_ad1 = rarea(i, j)*temp_ad0
1786  dp1_ad(i, j, k) = dp1_ad(i, j, k) + temp*temp_ad0
1787  fx_ad(i, j) = fx_ad(i, j) + temp_ad1
1788  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad1
1789  fy_ad(i, j) = fy_ad(i, j) + temp_ad1
1790  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad1
1791  dp2_ad(i, j) = dp2_ad(i, j) - (temp*dp1(i, j, k)+rarea(i&
1792 & , j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i, j+1)))*&
1793 & temp_ad0/dp2(i, j)
1794  q_ad(i, j, k, iq) = dp1(i, j, k)*temp_ad0
1795  END DO
1796  END DO
1797  CALL popcontrol(2,branch)
1798  IF (branch .LT. 2) THEN
1799  IF (branch .EQ. 0) THEN
1800  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+&
1801 & 1)*(jed-jsd+1))
1802  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1803  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1804  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:&
1805 & ied, jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k&
1806 & ), cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, &
1807 & js:je+1, k), cy_ad(isd:ied, js:je+1, k), npx&
1808 & , npy, hord_pert, fx, fx_ad, fy, fy_ad, xfx(&
1809 & is:ie+1, jsd:jed, k), xfx_ad(is:ie+1, jsd:&
1810 & jed, k), yfx(isd:ied, js:je+1, k), yfx_ad(&
1811 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
1812 & ra_x_ad, ra_y, ra_y_ad, mfx(is:ie+1, js:je, &
1813 & k), mfx_ad(is:ie+1, js:je, k), mfy(is:ie, js&
1814 & :je+1, k), mfy_ad(is:ie, js:je+1, k))
1815  ELSE
1816  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(&
1817 & isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd&
1818 & :jed, k), cx_ad(is:ie+1, jsd:jed, k), cy(&
1819 & isd:ied, js:je+1, k), cy_ad(isd:ied, js:&
1820 & je+1, k), npx, npy, hord, fx, fx_ad, fy, &
1821 & fy_ad, xfx(is:ie+1, jsd:jed, k), xfx_ad(&
1822 & is:ie+1, jsd:jed, k), yfx(isd:ied, js:je+&
1823 & 1, k), yfx_ad(isd:ied, js:je+1, k), &
1824 & gridstruct, bd, ra_x, ra_x_ad, ra_y, &
1825 & ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(&
1826 & is:ie+1, js:je, k), mfy(is:ie, js:je+1, k&
1827 & ), mfy_ad(is:ie, js:je+1, k))
1828  END IF
1829  ELSE IF (branch .EQ. 2) THEN
1830  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)&
1831 & *(jed-jsd+1))
1832  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
1833  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
1834  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied&
1835 & , jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k), &
1836 & cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+&
1837 & 1, k), cy_ad(isd:ied, js:je+1, k), npx, npy, &
1838 & hord_pert, fx, fx_ad, fy, fy_ad, xfx(is:ie+1, &
1839 & jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), yfx(&
1840 & isd:ied, js:je+1, k), yfx_ad(isd:ied, js:je+1&
1841 & , k), gridstruct, bd, ra_x, ra_x_ad, ra_y, &
1842 & ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(is:ie+&
1843 & 1, js:je, k), mfy(is:ie, js:je+1, k), mfy_ad(&
1844 & is:ie, js:je+1, k), dp1(isd:ied, jsd:jed, k), &
1845 & dp1_ad(isd:ied, jsd:jed, k), nord=nord_tr_pert&
1846 & , damp_c=trdm_pert)
1847  ELSE
1848  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(isd:&
1849 & ied, jsd:jed, k, iq), cx(is:ie+1, jsd:jed, &
1850 & k), cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied&
1851 & , js:je+1, k), cy_ad(isd:ied, js:je+1, k), &
1852 & npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx(&
1853 & is:ie+1, jsd:jed, k), xfx_ad(is:ie+1, jsd:&
1854 & jed, k), yfx(isd:ied, js:je+1, k), yfx_ad(&
1855 & isd:ied, js:je+1, k), gridstruct, bd, ra_x&
1856 & , ra_x_ad, ra_y, ra_y_ad, mfx(is:ie+1, js:&
1857 & je, k), mfx_ad(is:ie+1, js:je, k), mfy(is:&
1858 & ie, js:je+1, k), mfy_ad(is:ie, js:je+1, k)&
1859 & , dp1(isd:ied, jsd:jed, k), dp1_ad(isd:ied&
1860 & , jsd:jed, k), nord=nord_tr, damp_c=trdm)
1861  END IF
1862  END DO
1863  DO j=je,js,-1
1864  DO i=ied,isd,-1
1865  CALL poprealarray(ra_y(i, j))
1866  yfx_ad(i, j, k) = yfx_ad(i, j, k) + ra_y_ad(i, j)
1867  yfx_ad(i, j+1, k) = yfx_ad(i, j+1, k) - ra_y_ad(i, j)
1868  ra_y_ad(i, j) = 0.0
1869  END DO
1870  END DO
1871  DO j=jed,jsd,-1
1872  DO i=ie,is,-1
1873  CALL poprealarray(ra_x(i, j))
1874  xfx_ad(i, j, k) = xfx_ad(i, j, k) + ra_x_ad(i, j)
1875  xfx_ad(i+1, j, k) = xfx_ad(i+1, j, k) - ra_x_ad(i, j)
1876  ra_x_ad(i, j) = 0.0
1877  END DO
1878  END DO
1879  DO j=je,js,-1
1880  DO i=ie,is,-1
1881  CALL poprealarray(dp2(i, j))
1882  temp_ad = rarea(i, j)*dp2_ad(i, j)
1883  dp1_ad(i, j, k) = dp1_ad(i, j, k) + dp2_ad(i, j)
1884  mfx_ad(i, j, k) = mfx_ad(i, j, k) + temp_ad
1885  mfx_ad(i+1, j, k) = mfx_ad(i+1, j, k) - temp_ad
1886  mfy_ad(i, j, k) = mfy_ad(i, j, k) + temp_ad
1887  mfy_ad(i, j+1, k) = mfy_ad(i, j+1, k) - temp_ad
1888  dp2_ad(i, j) = 0.0
1889  END DO
1890  END DO
1891  END IF
1892  END DO
1893  END DO
1894  CALL popcontrol(1,branch)
1895  IF (branch .NE. 0) THEN
1896  DO k=npz,1,-1
1897  DO j=je+1,js,-1
1898  DO i=ie,is,-1
1899  CALL poprealarray(mfy(i, j, k))
1900  mfy_ad(i, j, k) = frac*mfy_ad(i, j, k)
1901  END DO
1902  END DO
1903  DO j=je+1,js,-1
1904  DO i=ied,isd,-1
1905  yfx_ad(i, j, k) = frac*yfx_ad(i, j, k)
1906  CALL poprealarray(cy(i, j, k))
1907  cy_ad(i, j, k) = frac*cy_ad(i, j, k)
1908  END DO
1909  END DO
1910  DO j=je,js,-1
1911  DO i=ie+1,is,-1
1912  CALL poprealarray(mfx(i, j, k))
1913  mfx_ad(i, j, k) = frac*mfx_ad(i, j, k)
1914  END DO
1915  END DO
1916  DO j=jed,jsd,-1
1917  DO i=ie+1,is,-1
1918  xfx_ad(i, j, k) = frac*xfx_ad(i, j, k)
1919  CALL poprealarray(cx(i, j, k))
1920  cx_ad(i, j, k) = frac*cx_ad(i, j, k)
1921  END DO
1922  END DO
1923  CALL poprealarray(frac)
1924  END DO
1925  END IF
1926  CALL popcontrol(1,branch)
1927  IF (branch .EQ. 0) THEN
1928  CALL popcontrol(1,branch)
1929  IF (branch .EQ. 0) THEN
1930  DO k=npz,2,-1
1931  CALL popcontrol(1,branch)
1932  END DO
1933  END IF
1934  END IF
1935  dxa => gridstruct%dxa
1936  dx => gridstruct%dx
1937  dy => gridstruct%dy
1938  sin_sg => gridstruct%sin_sg
1939  dya => gridstruct%dya
1940  DO k=npz,1,-1
1941  CALL popcontrol(2,branch)
1942  IF (branch .EQ. 0) THEN
1943  DO j=je,js,-1
1944  DO i=ie,is,-1
1945  CALL popcontrol(2,branch)
1946  END DO
1947  END DO
1948  ELSE IF (branch .EQ. 1) THEN
1949  DO j=je,js,-1
1950  DO i=ie,is,-1
1951  CALL popcontrol(1,branch)
1952  END DO
1953  END DO
1954  END IF
1955  DO j=je+1,js,-1
1956  DO i=ied,isd,-1
1957  CALL popcontrol(1,branch)
1958  IF (branch .EQ. 0) THEN
1959  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j)*dx(i, j)*sin_sg(&
1960 & i, j, 2)*yfx_ad(i, j, k)
1961  yfx_ad(i, j, k) = 0.0
1962  ELSE
1963  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j-1)*dx(i, j)*&
1964 & sin_sg(i, j-1, 4)*yfx_ad(i, j, k)
1965  yfx_ad(i, j, k) = 0.0
1966  END IF
1967  END DO
1968  END DO
1969  DO j=jed,jsd,-1
1970  DO i=ie+1,is,-1
1971  CALL popcontrol(1,branch)
1972  IF (branch .EQ. 0) THEN
1973  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i, j)*dy(i, j)*sin_sg(&
1974 & i, j, 1)*xfx_ad(i, j, k)
1975  xfx_ad(i, j, k) = 0.0
1976  ELSE
1977  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i-1, j)*dy(i, j)*&
1978 & sin_sg(i-1, j, 3)*xfx_ad(i, j, k)
1979  xfx_ad(i, j, k) = 0.0
1980  END IF
1981  END DO
1982  END DO
1983  END DO
1984  END SUBROUTINE tracer_2d_bwd
1985  SUBROUTINE tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain&
1986 & , npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, &
1987 & trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
1988  IMPLICIT NONE
1989  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1990  INTEGER, INTENT(IN) :: npx
1991  INTEGER, INTENT(IN) :: npy
1992  INTEGER, INTENT(IN) :: npz
1993 ! number of tracers to be advected
1994  INTEGER, INTENT(IN) :: nq
1995  INTEGER, INTENT(IN) :: hord, nord_tr
1996  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
1997  LOGICAL, INTENT(IN) :: split_damp_tr
1998  INTEGER, INTENT(IN) :: q_split
1999  INTEGER, INTENT(IN) :: id_divg
2000  REAL, INTENT(IN) :: dt, trdm, trdm_pert
2001  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
2002 ! Tracers
2003  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
2004 ! DELP before dyn_core
2005  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2006 ! Mass Flux X-Dir
2007  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
2008 ! Mass Flux Y-Dir
2009  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
2010 ! Courant Number X-Dir
2011  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2012 ! Courant Number Y-Dir
2013  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2014 ! DELP after advection
2015  REAL, OPTIONAL, INTENT(OUT) :: dpa(bd%is:bd%ie, bd%js:bd%je, npz)
2016  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2017  TYPE(domain2d), INTENT(INOUT) :: domain
2018 ! Local Arrays
2019  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
2020  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
2021  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
2022  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
2023  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
2024  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2025  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2026  REAL :: cmax(npz)
2027  REAL :: c_global
2028  REAL :: frac, rdt
2029  INTEGER :: ksplt(npz)
2030  INTEGER :: nsplt
2031  INTEGER :: i, j, k, it, iq
2032  REAL, DIMENSION(:, :), POINTER :: area, rarea
2033  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
2034  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
2035  INTEGER :: is, ie, js, je
2036  INTEGER :: isd, ied, jsd, jed
2037  INTRINSIC abs
2038  INTRINSIC max
2039  INTRINSIC int
2040  INTRINSIC real
2041  INTRINSIC PRESENT
2042  REAL :: max1
2043  REAL :: x1
2044  REAL :: z1
2045  REAL :: y3
2046  REAL :: y2
2047  REAL :: y1
2048  is = bd%is
2049  ie = bd%ie
2050  js = bd%js
2051  je = bd%je
2052  isd = bd%isd
2053  ied = bd%ied
2054  jsd = bd%jsd
2055  jed = bd%jed
2056  area => gridstruct%area
2057  rarea => gridstruct%rarea
2058  sin_sg => gridstruct%sin_sg
2059  dxa => gridstruct%dxa
2060  dya => gridstruct%dya
2061  dx => gridstruct%dx
2062  dy => gridstruct%dy
2063 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
2064 !$OMP sin_sg,cy,yfx,dya,dx,cmax,q_split,ksplt)
2065  DO k=1,npz
2066  DO j=jsd,jed
2067  DO i=is,ie+1
2068  IF (cx(i, j, k) .GT. 0.) THEN
2069  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
2070 & j, 3)
2071  ELSE
2072  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
2073 & )
2074  END IF
2075  END DO
2076  END DO
2077  DO j=js,je+1
2078  DO i=isd,ied
2079  IF (cy(i, j, k) .GT. 0.) THEN
2080  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
2081 & 1, 4)
2082  ELSE
2083  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
2084 & )
2085  END IF
2086  END DO
2087  END DO
2088  IF (q_split .EQ. 0) THEN
2089  cmax(k) = 0.
2090  IF (k .LT. npz/6) THEN
2091  DO j=js,je
2092  DO i=is,ie
2093  IF (cx(i, j, k) .GE. 0.) THEN
2094  y1 = cx(i, j, k)
2095  ELSE
2096  y1 = -cx(i, j, k)
2097  END IF
2098  IF (cy(i, j, k) .GE. 0.) THEN
2099  z1 = cy(i, j, k)
2100  ELSE
2101  z1 = -cy(i, j, k)
2102  END IF
2103  IF (cmax(k) .LT. y1) THEN
2104  IF (y1 .LT. z1) THEN
2105  cmax(k) = z1
2106  ELSE
2107  cmax(k) = y1
2108  END IF
2109  ELSE IF (cmax(k) .LT. z1) THEN
2110  cmax(k) = z1
2111  ELSE
2112  cmax(k) = cmax(k)
2113  END IF
2114  END DO
2115  END DO
2116  ELSE
2117  DO j=js,je
2118  DO i=is,ie
2119  IF (cx(i, j, k) .GE. 0.) THEN
2120  x1 = cx(i, j, k)
2121  ELSE
2122  x1 = -cx(i, j, k)
2123  END IF
2124  IF (cy(i, j, k) .GE. 0.) THEN
2125  y3 = cy(i, j, k)
2126  ELSE
2127  y3 = -cy(i, j, k)
2128  END IF
2129  IF (x1 .LT. y3) THEN
2130  max1 = y3
2131  ELSE
2132  max1 = x1
2133  END IF
2134  y2 = max1 + 1. - sin_sg(i, j, 5)
2135  IF (cmax(k) .LT. y2) THEN
2136  cmax(k) = y2
2137  ELSE
2138  cmax(k) = cmax(k)
2139  END IF
2140  END DO
2141  END DO
2142  END IF
2143  END IF
2144  ksplt(k) = 1
2145  END DO
2146 !--------------------------------------------------------------------------------
2147 ! Determine global nsplt:
2148  IF (q_split .EQ. 0) THEN
2149  CALL mp_reduce_max(cmax, npz)
2150 ! find global max courant number and define nsplt to scale cx,cy,mfx,mfy
2151  c_global = cmax(1)
2152  IF (npz .NE. 1) THEN
2153 ! if NOT shallow water test case
2154  DO k=2,npz
2155  IF (cmax(k) .LT. c_global) THEN
2156  c_global = c_global
2157  ELSE
2158  c_global = cmax(k)
2159  END IF
2160  END DO
2161  END IF
2162  nsplt = int(1. + c_global)
2163  IF (is_master() .AND. nsplt .GT. 4) WRITE(*, *) 'Tracer_2d_split='&
2164 & , nsplt, c_global
2165  ELSE
2166  nsplt = q_split
2167  END IF
2168 !--------------------------------------------------------------------------------
2169  IF (nsplt .NE. 1) THEN
2170 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,mfx,cy,yfx,mfy,cmax,nsplt,ksplt) &
2171 !$OMP private( frac )
2172  DO k=1,npz
2173  ksplt(k) = int(1. + cmax(k))
2174  frac = 1./REAL(ksplt(k))
2175  DO j=jsd,jed
2176  DO i=is,ie+1
2177  cx(i, j, k) = cx(i, j, k)*frac
2178  xfx(i, j, k) = xfx(i, j, k)*frac
2179  END DO
2180  END DO
2181  DO j=js,je
2182  DO i=is,ie+1
2183  mfx(i, j, k) = mfx(i, j, k)*frac
2184  END DO
2185  END DO
2186  DO j=js,je+1
2187  DO i=isd,ied
2188  cy(i, j, k) = cy(i, j, k)*frac
2189  yfx(i, j, k) = yfx(i, j, k)*frac
2190  END DO
2191  END DO
2192  DO j=js,je+1
2193  DO i=is,ie
2194  mfy(i, j, k) = mfy(i, j, k)*frac
2195  END DO
2196  END DO
2197  END DO
2198  END IF
2199  DO it=1,nsplt
2200  CALL timing_on('COMM_TOTAL')
2201  CALL timing_on('COMM_TRACER')
2202  CALL complete_group_halo_update(q_pack, domain)
2203  CALL timing_off('COMM_TRACER')
2204  CALL timing_off('COMM_TOTAL')
2205 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq,ksplt,&
2206 !$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm) &
2207 !$OMP private(dp2, ra_x, ra_y, fx, fy)
2208  DO k=1,npz
2209 ! ksplt
2210  IF (it .LE. ksplt(k)) THEN
2211  DO j=js,je
2212  DO i=is,ie
2213  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(&
2214 & mfy(i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
2215  END DO
2216  END DO
2217  DO j=jsd,jed
2218  DO i=is,ie
2219  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
2220  END DO
2221  END DO
2222  DO j=js,je
2223  DO i=isd,ied
2224  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
2225  END DO
2226  END DO
2227  DO iq=1,nq
2228  IF (it .EQ. 1 .AND. trdm .GT. 1.e-4) THEN
2229  IF (hord .EQ. hord_pert) THEN
2230  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1&
2231 & , jsd:jed, k), cy(isd:ied, js:je+1, k), npx, &
2232 & npy, hord, fx, fy, xfx(is:ie+1, jsd:jed, k), &
2233 & yfx(isd:ied, js:je+1, k), gridstruct, bd, &
2234 & ra_x, ra_y, mfx(is:ie+1, js:je, k), mfy(is:ie&
2235 & , js:je+1, k), dp1(isd:ied, jsd:jed, k), &
2236 & nord_tr, trdm)
2237  ELSE
2238  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, &
2239 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
2240 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx&
2241 & (isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
2242 & ra_y, mfx(is:ie+1, js:je, k), mfy(is:ie, js:je+1&
2243 & , k), dp1(isd:ied, jsd:jed, k), nord_tr, trdm)
2244  END IF
2245  ELSE IF (hord .EQ. hord_pert) THEN
2246  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, &
2247 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy&
2248 & , hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
2249 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
2250 & ra_y, mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie&
2251 & , js:je+1, k))
2252  ELSE
2253  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
2254 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
2255 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
2256 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
2257 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
2258 & , k))
2259  END IF
2260  DO j=js,je
2261  DO i=is,ie
2262  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-&
2263 & fx(i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, &
2264 & j)
2265  END DO
2266  END DO
2267  END DO
2268  IF (it .NE. nsplt) THEN
2269  DO j=js,je
2270  DO i=is,ie
2271  dp1(i, j, k) = dp2(i, j)
2272  END DO
2273  END DO
2274  END IF
2275  END IF
2276  END DO
2277 ! npz
2278  IF (it .NE. nsplt) THEN
2279  CALL timing_on('COMM_TOTAL')
2280  CALL timing_on('COMM_TRACER')
2281  CALL start_group_halo_update(q_pack, q, domain)
2282  CALL timing_off('COMM_TRACER')
2283  CALL timing_off('COMM_TOTAL')
2284  END IF
2285  END DO
2286 ! nsplt
2287  IF (PRESENT(dpa)) dpa = dp1(bd%is:bd%ie, bd%js:bd%je, 1:npz)
2288  END SUBROUTINE tracer_2d
2289 ! Differentiation of tracer_2d_nested in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_
2290 !edge_mod.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
2291 !_core_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
2292 !_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Ra
2293 !yleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c
2294 !2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_
2295 !mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rema
2296 !p_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_lim
2297 !iters 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_cubi
2298 !c fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_
2299 !subgrid_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_
2300 !utils_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_ut
2301 !ils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_uti
2302 !ls_mod.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_
2303 !mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.
2304 !ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp
2305 !_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid
2306 !_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
2307 ! gradient of useful results: q dp1
2308 ! with respect to varying inputs: q dp1 mfx mfy cx cy
2309  SUBROUTINE tracer_2d_nested_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, &
2310 & bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, &
2311 & nord_tr, trdm, k_split, neststruct, parent_grid, hord_pert, &
2312 & nord_tr_pert, trdm_pert, split_damp_tr)
2313  !USE ISO_C_BINDING
2314  !USE ADMM_TAPENADE_INTERFACE
2315  IMPLICIT NONE
2316  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
2317  INTEGER, INTENT(IN) :: npx
2318  INTEGER, INTENT(IN) :: npy
2319  INTEGER, INTENT(IN) :: npz
2320 ! number of tracers to be advected
2321  INTEGER, INTENT(IN) :: nq
2322  INTEGER, INTENT(IN) :: hord, nord_tr
2323  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
2324  LOGICAL, INTENT(IN) :: split_damp_tr
2325  INTEGER, INTENT(IN) :: q_split, k_split
2326  INTEGER, INTENT(IN) :: id_divg
2327  REAL, INTENT(IN) :: dt, trdm, trdm_pert
2328  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
2329 ! Tracers
2330  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
2331 ! DELP before dyn_core
2332  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2333 ! Mass Flux X-Dir
2334  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
2335 ! Mass Flux Y-Dir
2336  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
2337 ! Courant Number X-Dir
2338  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2339 ! Courant Number Y-Dir
2340  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2341  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2342  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
2343  TYPE(fv_atmos_type), INTENT(INOUT) :: parent_grid
2344  TYPE(domain2d), INTENT(INOUT) :: domain
2345 ! Local Arrays
2346  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
2347  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
2348  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
2349  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
2350  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
2351  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2352  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2353  REAL :: cmax(npz)
2354  REAL :: cmax_t
2355  REAL :: c_global
2356  REAL :: frac, rdt
2357  INTEGER :: nsplt, nsplt_parent
2358  INTEGER, SAVE :: msg_split_steps=1
2359  INTEGER :: i, j, k, it, iq
2360  REAL, DIMENSION(:, :), POINTER :: area, rarea
2361  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
2362  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
2363  INTEGER :: is, ie, js, je
2364  INTEGER :: isd, ied, jsd, jed
2365  INTRINSIC abs
2366  INTRINSIC max
2367  INTRINSIC int
2368  INTRINSIC real
2369  REAL :: max1
2370  REAL :: arg1
2371  REAL :: arg2
2372  LOGICAL :: res
2373  REAL :: x2
2374  REAL :: x1
2375  REAL :: y2
2376  REAL :: y1
2377 
2378  dp2 = 0.0
2379  fx = 0.0
2380  fy = 0.0
2381  ra_x = 0.0
2382  ra_y = 0.0
2383  xfx = 0.0
2384  yfx = 0.0
2385  cmax = 0.0
2386  cmax_t = 0.0
2387  c_global = 0.0
2388  frac = 0.0
2389  rdt = 0.0
2390  nsplt = 0
2391  nsplt_parent = 0
2392  it = 0
2393  iq = 0
2394  is = 0
2395  ie = 0
2396  js = 0
2397  je = 0
2398  isd = 0
2399  ied = 0
2400  jsd = 0
2401  jed = 0
2402  max1 = 0.0
2403  arg1 = 0.0
2404  arg2 = 0.0
2405  x2 = 0.0
2406  x1 = 0.0
2407  y2 = 0.0
2408  y1 = 0.0
2409 
2410  is = bd%is
2411  ie = bd%ie
2412  js = bd%js
2413  je = bd%je
2414  isd = bd%isd
2415  ied = bd%ied
2416  jsd = bd%jsd
2417  jed = bd%jed
2418  area => gridstruct%area
2419  rarea => gridstruct%rarea
2420  sin_sg => gridstruct%sin_sg
2421  dxa => gridstruct%dxa
2422  dya => gridstruct%dya
2423  dx => gridstruct%dx
2424  dy => gridstruct%dy
2425 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
2426 !$OMP sin_sg,cy,yfx,dya,dx)
2427  DO k=1,npz
2428  DO j=jsd,jed
2429  DO i=is,ie+1
2430  IF (cx(i, j, k) .GT. 0.) THEN
2431  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
2432 & j, 3)
2433  CALL pushcontrol(1,1)
2434  ELSE
2435  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
2436 & )
2437  CALL pushcontrol(1,0)
2438  END IF
2439  END DO
2440  END DO
2441  DO j=js,je+1
2442  DO i=isd,ied
2443  IF (cy(i, j, k) .GT. 0.) THEN
2444  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
2445 & 1, 4)
2446  CALL pushcontrol(1,1)
2447  ELSE
2448  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
2449 & )
2450  CALL pushcontrol(1,0)
2451  END IF
2452  END DO
2453  END DO
2454  END DO
2455 !--------------------------------------------------------------------------------
2456  IF (q_split .EQ. 0) THEN
2457 ! Determine nsplt
2458 !$OMP parallel do default(none) shared(is,ie,js,je,npz,cmax,cx,cy,sin_sg) &
2459 !$OMP private(cmax_t )
2460  DO k=1,npz
2461  cmax(k) = 0.
2462  IF (k .LT. 4) THEN
2463 ! Top layers: C < max( abs(c_x), abs(c_y) )
2464  DO j=js,je
2465  DO i=is,ie
2466  IF (cx(i, j, k) .GE. 0.) THEN
2467  x1 = cx(i, j, k)
2468  ELSE
2469  x1 = -cx(i, j, k)
2470  END IF
2471  IF (cy(i, j, k) .GE. 0.) THEN
2472  y1 = cy(i, j, k)
2473  ELSE
2474  y1 = -cy(i, j, k)
2475  END IF
2476  IF (x1 .LT. y1) THEN
2477  cmax_t = y1
2478  ELSE
2479  cmax_t = x1
2480  END IF
2481  IF (cmax_t .LT. cmax(k)) THEN
2482  CALL pushcontrol(1,0)
2483  cmax(k) = cmax(k)
2484  ELSE
2485  CALL pushcontrol(1,1)
2486  cmax(k) = cmax_t
2487  END IF
2488  END DO
2489  END DO
2490  CALL pushcontrol(1,1)
2491  ELSE
2492  DO j=js,je
2493  DO i=is,ie
2494  IF (cx(i, j, k) .GE. 0.) THEN
2495  x2 = cx(i, j, k)
2496  ELSE
2497  x2 = -cx(i, j, k)
2498  END IF
2499  IF (cy(i, j, k) .GE. 0.) THEN
2500  y2 = cy(i, j, k)
2501  ELSE
2502  y2 = -cy(i, j, k)
2503  END IF
2504  IF (x2 .LT. y2) THEN
2505  max1 = y2
2506  ELSE
2507  max1 = x2
2508  END IF
2509  cmax_t = max1 + 1. - sin_sg(i, j, 5)
2510  IF (cmax_t .LT. cmax(k)) THEN
2511  CALL pushcontrol(1,0)
2512  cmax(k) = cmax(k)
2513  ELSE
2514  CALL pushcontrol(1,1)
2515  cmax(k) = cmax_t
2516  END IF
2517  END DO
2518  END DO
2519  CALL pushcontrol(1,0)
2520  END IF
2521  END DO
2522  CALL mp_reduce_max(cmax, npz)
2523 ! find global max courant number and define nsplt to scale cx,cy,mfx,mfy
2524  c_global = cmax(1)
2525  IF (npz .NE. 1) THEN
2526 ! if NOT shallow water test case
2527  DO k=2,npz
2528  IF (cmax(k) .LT. c_global) THEN
2529  CALL pushcontrol(1,0)
2530  c_global = c_global
2531  ELSE
2532  CALL pushcontrol(1,1)
2533  c_global = cmax(k)
2534  END IF
2535  END DO
2536  CALL pushcontrol(1,0)
2537  ELSE
2538  CALL pushcontrol(1,1)
2539  END IF
2540  nsplt = int(1. + c_global)
2541  res = is_master()
2542  IF (res .AND. nsplt .GT. 3) THEN
2543  CALL pushcontrol(1,0)
2544  WRITE(*, *) 'Tracer_2d_split=', nsplt, c_global
2545  ELSE
2546  CALL pushcontrol(1,0)
2547  END IF
2548  ELSE
2549  nsplt = q_split
2550  CALL pushcontrol(1,1)
2551  END IF
2552 !--------------------------------------------------------------------------------
2553  frac = 1./REAL(nsplt)
2554  IF (nsplt .NE. 1) THEN
2555 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,frac,xfx,mfx,cy,yfx,mfy)
2556  DO k=1,npz
2557  DO j=jsd,jed
2558  DO i=is,ie+1
2559  CALL pushrealarray(cx(i, j, k))
2560  cx(i, j, k) = cx(i, j, k)*frac
2561  xfx(i, j, k) = xfx(i, j, k)*frac
2562  END DO
2563  END DO
2564  DO j=js,je
2565  DO i=is,ie+1
2566  CALL pushrealarray(mfx(i, j, k))
2567  mfx(i, j, k) = mfx(i, j, k)*frac
2568  END DO
2569  END DO
2570  DO j=js,je+1
2571  DO i=isd,ied
2572  CALL pushrealarray(cy(i, j, k))
2573  cy(i, j, k) = cy(i, j, k)*frac
2574  yfx(i, j, k) = yfx(i, j, k)*frac
2575  END DO
2576  END DO
2577  DO j=js,je+1
2578  DO i=is,ie
2579  CALL pushrealarray(mfy(i, j, k))
2580  mfy(i, j, k) = mfy(i, j, k)*frac
2581  END DO
2582  END DO
2583  END DO
2584  CALL pushcontrol(1,1)
2585  ELSE
2586  CALL pushcontrol(1,0)
2587  END IF
2588  DO it=1,nsplt
2589  IF (gridstruct%nested) neststruct%tracer_nest_timestep = &
2590 & neststruct%tracer_nest_timestep + 1
2591  IF (gridstruct%nested) THEN
2592  DO iq=1,nq
2593  arg1 = REAL(neststruct%tracer_nest_timestep) + REAL(nsplt*&
2594 & k_split)
2595  arg2 = real(nsplt*k_split)
2596  CALL pushrealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
2597 & jed-jsd+1)*npz)
2598  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
2599 & 0, npx, npy, npz, bd, REAL(neststruct& & %tracer_nest_timestep) + REAL(nsplt*& & k_split), REAL(nsplt*k_split), &
2600 & neststruct%q_bc(iq), bctype=&
2601 & neststruct%nestbctype)
2602  end do
2603  CALL pushcontrol(1,1)
2604  ELSE
2605  CALL pushcontrol(1,0)
2606  END IF
2607 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq, &
2608 !$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm) &
2609 !$OMP private(dp2, ra_x, ra_y, fx, fy)
2610  DO k=1,npz
2611  DO j=js,je
2612  DO i=is,ie
2613  CALL pushrealarray(dp2(i, j))
2614  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(mfy&
2615 & (i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
2616  END DO
2617  END DO
2618  DO j=jsd,jed
2619  DO i=is,ie
2620  CALL pushrealarray(ra_x(i, j))
2621  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
2622  END DO
2623  END DO
2624  DO j=js,je
2625  DO i=isd,ied
2626  CALL pushrealarray(ra_y(i, j))
2627  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
2628  END DO
2629  END DO
2630  DO iq=1,nq
2631  IF (it .EQ. 1 .AND. trdm .GT. 1.e-4) THEN
2632  IF (hord .EQ. hord_pert) THEN
2633  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), cx(is:ie+&
2634 & 1, jsd:jed, k), cy(isd:ied, js:je+1, k), &
2635 & npx, npy, hord, fx, fy, xfx(is:ie+1, jsd:&
2636 & jed, k), yfx(isd:ied, js:je+1, k), &
2637 & gridstruct, bd, ra_x, ra_y, mfx=mfx(is:ie+1&
2638 & , js:je, k), mfy=mfy(is:ie, js:je+1, k), &
2639 & mass=dp1(isd:ied, jsd:jed, k), nord=nord_tr&
2640 & , damp_c=trdm)
2641  CALL pushcontrol(2,3)
2642  ELSE
2643  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2644  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2645  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1&
2646 & )*(jed-jsd+1))
2647  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
2648 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
2649 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
2650 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
2651 & mfx=mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1&
2652 & , k), mass=dp1(isd:ied, jsd:jed, k), nord=nord_tr&
2653 & , damp_c=trdm)
2654  CALL pushcontrol(2,2)
2655  END IF
2656  ELSE IF (hord .EQ. hord_pert) THEN
2657  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1&
2658 & , jsd:jed, k), cy(isd:ied, js:je+1, k), npx, &
2659 & npy, hord, fx, fy, xfx(is:ie+1, jsd:jed, k), &
2660 & yfx(isd:ied, js:je+1, k), gridstruct, bd, &
2661 & ra_x, ra_y, mfx=mfx(is:ie+1, js:je, k), mfy=&
2662 & mfy(is:ie, js:je+1, k))
2663  CALL pushcontrol(2,1)
2664  ELSE
2665  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2666  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2667  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)*&
2668 & (jed-jsd+1))
2669  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
2670 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
2671 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(isd&
2672 & :ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, mfx=&
2673 & mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1, k))
2674  CALL pushcontrol(2,0)
2675  END IF
2676  DO j=js,je
2677  DO i=is,ie
2678  CALL pushrealarray(q(i, j, k, iq))
2679  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-fx&
2680 & (i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, j)
2681  END DO
2682  END DO
2683  END DO
2684  END DO
2685 ! npz
2686  IF (it .NE. nsplt) THEN
2687  CALL pushrealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*&
2688 & nq)
2689  CALL start_group_halo_update(q_pack, q, domain)
2690  CALL pushcontrol(1,0)
2691  ELSE
2692  CALL pushcontrol(1,1)
2693  END IF
2694 !Apply nested-grid BCs
2695  IF (gridstruct%nested) THEN
2696  DO iq=1,nq
2697  arg1 = REAL(neststruct%tracer_nest_timestep)
2698  arg2 = REAL(nsplt*k_split)
2699  CALL pushrealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
2700 & jed-jsd+1)*npz)
2701  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
2702 & 0, npx, npy, npz, bd, REAL(neststruct& & %tracer_nest_timestep), REAL(nsplt*& & k_split), neststruct%q_bc(iq), bctype&
2703 & =neststruct%nestbctype)
2704  end do
2705  CALL pushcontrol(1,1)
2706  ELSE
2707  CALL pushcontrol(1,0)
2708  END IF
2709  END DO
2710 ! nsplt
2711  IF (id_divg .GT. 0) THEN
2712  rdt = 1./(frac*dt)
2713 !$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,rdt)
2714  DO k=1,npz
2715  DO j=js,je
2716  DO i=is,ie
2717  CALL pushrealarray(dp1(i, j, k))
2718  dp1(i, j, k) = (xfx(i+1, j, k)-xfx(i, j, k)+(yfx(i, j+1, k)-&
2719 & yfx(i, j, k)))*rarea(i, j)*rdt
2720  END DO
2721  END DO
2722  END DO
2723  CALL pushinteger(je)
2724  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2725  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2726  CALL pushinteger(nsplt)
2727  CALL pushrealarray(rdt)
2728  CALL pushinteger(is)
2729  CALL pushrealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
2730  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
2731  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
2732  CALL pushinteger(ie)
2733  CALL pushrealarray(frac)
2734  CALL pushrealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
2735  !CALL PUSHPOINTER8(C_LOC(rarea))
2736  CALL pushrealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
2737  CALL pushinteger(js)
2738  CALL pushcontrol(1,1)
2739  ELSE
2740  CALL pushinteger(je)
2741  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2742  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2743  CALL pushinteger(nsplt)
2744  CALL pushinteger(is)
2745  CALL pushrealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
2746  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
2747  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
2748  CALL pushinteger(ie)
2749  CALL pushrealarray(frac)
2750  CALL pushrealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
2751  !CALL PUSHPOINTER8(C_LOC(rarea))
2752  CALL pushrealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
2753  CALL pushinteger(js)
2754  CALL pushcontrol(1,0)
2755  END IF
2756  END SUBROUTINE tracer_2d_nested_fwd
2757 ! Differentiation of tracer_2d_nested in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b
2758 !_edge_mod.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 dy
2759 !n_core_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_cor
2760 !e_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.R
2761 !ayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.
2762 !c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz
2763 !_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rem
2764 !ap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_li
2765 !miters 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_cub
2766 !ic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv
2767 !_subgrid_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
2768 !_utils_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_u
2769 !tils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_ut
2770 !ils_mod.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
2771 !_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod
2772 !.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d t
2773 !p_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gri
2774 !d_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
2775 ! gradient of useful results: q dp1
2776 ! with respect to varying inputs: q dp1 mfx mfy cx cy
2777  SUBROUTINE tracer_2d_nested_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy&
2778 & , mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, &
2779 & npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, k_split&
2780 & , neststruct, parent_grid, hord_pert, nord_tr_pert, trdm_pert, &
2781 & split_damp_tr)
2782  !USE ISO_C_BINDING
2783  !USE ADMM_TAPENADE_INTERFACE
2784  IMPLICIT NONE
2785  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
2786  INTEGER, INTENT(IN) :: npx
2787  INTEGER, INTENT(IN) :: npy
2788  INTEGER, INTENT(IN) :: npz
2789  INTEGER, INTENT(IN) :: nq
2790  INTEGER, INTENT(IN) :: hord, nord_tr
2791  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
2792  LOGICAL, INTENT(IN) :: split_damp_tr
2793  INTEGER, INTENT(IN) :: q_split, k_split
2794  INTEGER, INTENT(IN) :: id_divg
2795  REAL, INTENT(IN) :: dt, trdm, trdm_pert
2796  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
2797  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
2798  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
2799  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2800  REAL, INTENT(INOUT) :: dp1_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2801  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
2802  REAL, INTENT(INOUT) :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je, npz)
2803  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
2804  REAL, INTENT(INOUT) :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1, npz)
2805  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2806  REAL, INTENT(INOUT) :: cx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2807  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2808  REAL, INTENT(INOUT) :: cy_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2809  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2810  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
2811  TYPE(fv_atmos_type), INTENT(INOUT) :: parent_grid
2812  TYPE(domain2d), INTENT(INOUT) :: domain
2813  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
2814  REAL :: dp2_ad(bd%is:bd%ie, bd%js:bd%je)
2815  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
2816  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
2817  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
2818  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
2819  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
2820  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
2821  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
2822  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
2823  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2824  REAL :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
2825  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2826  REAL :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
2827  REAL :: cmax(npz)
2828  REAL :: cmax_t
2829  REAL :: c_global
2830  REAL :: frac, rdt
2831  INTEGER :: nsplt, nsplt_parent
2832  INTEGER, SAVE :: msg_split_steps=1
2833  INTEGER :: i, j, k, it, iq
2834  REAL, DIMENSION(:, :), POINTER :: area, rarea
2835  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
2836  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
2837  INTEGER :: is, ie, js, je
2838  INTEGER :: isd, ied, jsd, jed
2839  INTRINSIC abs
2840  INTRINSIC max
2841  INTRINSIC int
2842  INTRINSIC real
2843  REAL :: max1
2844  REAL :: arg1
2845  REAL :: arg2
2846  REAL :: temp_ad
2847  REAL :: temp
2848  REAL :: temp_ad0
2849  REAL :: temp_ad1
2850  REAL :: temp_ad2
2851  INTEGER :: branch
2852  !TYPE(C_PTR) :: cptr
2853  !INTEGER :: unknown_shape_in_tracer_2d_nested
2854  REAL :: x2
2855  REAL :: x1
2856  REAL :: y2
2857  REAL :: y1
2858 
2859  dp2 = 0.0
2860  fx = 0.0
2861  fy = 0.0
2862  ra_x = 0.0
2863  ra_y = 0.0
2864  xfx = 0.0
2865  yfx = 0.0
2866  cmax = 0.0
2867  cmax_t = 0.0
2868  c_global = 0.0
2869  frac = 0.0
2870  rdt = 0.0
2871  nsplt = 0
2872  nsplt_parent = 0
2873  it = 0
2874  iq = 0
2875  is = 0
2876  ie = 0
2877  js = 0
2878  je = 0
2879  isd = 0
2880  ied = 0
2881  jsd = 0
2882  jed = 0
2883  max1 = 0.0
2884  arg1 = 0.0
2885  arg2 = 0.0
2886  x2 = 0.0
2887  x1 = 0.0
2888  y2 = 0.0
2889  y1 = 0.0
2890  branch = 0
2891 
2892  CALL popcontrol(1,branch)
2893  IF (branch .EQ. 0) THEN
2894  CALL popinteger(js)
2895  CALL poprealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
2896  !CALL POPPOINTER8(cptr)
2897  rarea => gridstruct%rarea ! (/unknown_shape_in_tracer_2d_nested&
2898 !& /))
2899  CALL poprealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
2900  CALL poprealarray(frac)
2901  CALL popinteger(ie)
2902  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
2903  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
2904  CALL poprealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
2905  CALL popinteger(is)
2906  CALL popinteger(nsplt)
2907  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2908  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2909  CALL popinteger(je)
2910  xfx_ad = 0.0
2911  yfx_ad = 0.0
2912  ELSE
2913  CALL popinteger(js)
2914  CALL poprealarray(xfx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
2915  !CALL POPPOINTER8(cptr)
2916  rarea => gridstruct%rarea ! (/unknown_shape_in_tracer_2d_nested&
2917 !i& /))
2918  CALL poprealarray(dp2, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
2919  CALL poprealarray(frac)
2920  CALL popinteger(ie)
2921  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
2922  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
2923  CALL poprealarray(yfx, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
2924  CALL popinteger(is)
2925  CALL poprealarray(rdt)
2926  CALL popinteger(nsplt)
2927  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2928  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2929  CALL popinteger(je)
2930  xfx_ad = 0.0
2931  yfx_ad = 0.0
2932  DO k=npz,1,-1
2933  DO j=je,js,-1
2934  DO i=ie,is,-1
2935  CALL poprealarray(dp1(i, j, k))
2936  temp_ad2 = rarea(i, j)*rdt*dp1_ad(i, j, k)
2937  xfx_ad(i+1, j, k) = xfx_ad(i+1, j, k) + temp_ad2
2938  xfx_ad(i, j, k) = xfx_ad(i, j, k) - temp_ad2
2939  yfx_ad(i, j+1, k) = yfx_ad(i, j+1, k) + temp_ad2
2940  yfx_ad(i, j, k) = yfx_ad(i, j, k) - temp_ad2
2941  dp1_ad(i, j, k) = 0.0
2942  END DO
2943  END DO
2944  END DO
2945  END IF
2946  jsd = bd%jsd
2947  ied = bd%ied
2948  isd = bd%isd
2949  jed = bd%jed
2950  mfx_ad = 0.0
2951  mfy_ad = 0.0
2952  cx_ad = 0.0
2953  cy_ad = 0.0
2954  dp2_ad = 0.0
2955  ra_x_ad = 0.0
2956  ra_y_ad = 0.0
2957  fx_ad = 0.0
2958  fy_ad = 0.0
2959  DO it=nsplt,1,-1
2960  CALL popcontrol(1,branch)
2961  IF (branch .NE. 0) THEN
2962  DO iq=nq,1,-1
2963  CALL poprealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
2964 & jed-jsd+1)*npz)
2965  CALL nested_grid_bc_apply_intt_adm(q(isd:ied, jsd:jed, :, iq)&
2966 & , q_ad(isd:ied, jsd:jed, :, iq), &
2967 & 0, 0, npx, npy, npz, bd, arg1, &
2968 & arg2, neststruct%q_bc(iq), &
2969 & neststruct%nestbctype)
2970  END DO
2971  END IF
2972  CALL popcontrol(1,branch)
2973  IF (branch .EQ. 0) THEN
2974  CALL poprealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*nq&
2975 & )
2976  CALL start_group_halo_update_adm(q_pack, q, q_ad, domain)
2977  END IF
2978  DO k=npz,1,-1
2979  DO iq=nq,1,-1
2980  DO j=je,js,-1
2981  DO i=ie,is,-1
2982  CALL poprealarray(q(i, j, k, iq))
2983  temp_ad0 = q_ad(i, j, k, iq)/dp2(i, j)
2984  temp = q(i, j, k, iq)
2985  temp_ad1 = rarea(i, j)*temp_ad0
2986  dp1_ad(i, j, k) = dp1_ad(i, j, k) + temp*temp_ad0
2987  fx_ad(i, j) = fx_ad(i, j) + temp_ad1
2988  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad1
2989  fy_ad(i, j) = fy_ad(i, j) + temp_ad1
2990  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad1
2991  dp2_ad(i, j) = dp2_ad(i, j) - (temp*dp1(i, j, k)+rarea(i, &
2992 & j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i, j+1)))*temp_ad0/&
2993 & dp2(i, j)
2994  q_ad(i, j, k, iq) = dp1(i, j, k)*temp_ad0
2995  END DO
2996  END DO
2997  CALL popcontrol(2,branch)
2998  IF (branch .LT. 2) THEN
2999  IF (branch .EQ. 0) THEN
3000  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)&
3001 & *(jed-jsd+1))
3002  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3003  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3004  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied&
3005 & , jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k), &
3006 & cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+&
3007 & 1, k), cy_ad(isd:ied, js:je+1, k), npx, npy, &
3008 & hord_pert, fx, fx_ad, fy, fy_ad, xfx(is:ie+1, &
3009 & jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), yfx(&
3010 & isd:ied, js:je+1, k), yfx_ad(isd:ied, js:je+1&
3011 & , k), gridstruct, bd, ra_x, ra_x_ad, ra_y, &
3012 & ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(is:ie+&
3013 & 1, js:je, k), mfy(is:ie, js:je+1, k), mfy_ad(&
3014 & is:ie, js:je+1, k))
3015  ELSE
3016  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(isd:&
3017 & ied, jsd:jed, k, iq), cx(is:ie+1, jsd:jed, &
3018 & k), cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied&
3019 & , js:je+1, k), cy_ad(isd:ied, js:je+1, k), &
3020 & npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx(&
3021 & is:ie+1, jsd:jed, k), xfx_ad(is:ie+1, jsd:&
3022 & jed, k), yfx(isd:ied, js:je+1, k), yfx_ad(&
3023 & isd:ied, js:je+1, k), gridstruct, bd, ra_x&
3024 & , ra_x_ad, ra_y, ra_y_ad, mfx(is:ie+1, js:&
3025 & je, k), mfx_ad(is:ie+1, js:je, k), mfy(is:&
3026 & ie, js:je+1, k), mfy_ad(is:ie, js:je+1, k))
3027  END IF
3028  ELSE IF (branch .EQ. 2) THEN
3029  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)*(&
3030 & jed-jsd+1))
3031  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3032  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3033  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied, &
3034 & jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k), cx_ad(&
3035 & is:ie+1, jsd:jed, k), cy(isd:ied, js:je+1, k), &
3036 & cy_ad(isd:ied, js:je+1, k), npx, npy, hord_pert&
3037 & , fx, fx_ad, fy, fy_ad, xfx(is:ie+1, jsd:jed, k)&
3038 & , xfx_ad(is:ie+1, jsd:jed, k), yfx(isd:ied, js:&
3039 & je+1, k), yfx_ad(isd:ied, js:je+1, k), &
3040 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, &
3041 & mfx(is:ie+1, js:je, k), mfx_ad(is:ie+1, js:je, k&
3042 & ), mfy(is:ie, js:je+1, k), mfy_ad(is:ie, js:je+1&
3043 & , k), dp1(isd:ied, jsd:jed, k), dp1_ad(isd:ied, &
3044 & jsd:jed, k), nord=nord_tr_pert, damp_c=trdm_pert&
3045 & )
3046  ELSE
3047  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(isd:&
3048 & ied, jsd:jed, k, iq), cx(is:ie+1, jsd:jed, k)&
3049 & , cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied, js:&
3050 & je+1, k), cy_ad(isd:ied, js:je+1, k), npx, &
3051 & npy, hord, fx, fx_ad, fy, fy_ad, xfx(is:ie+1&
3052 & , jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), &
3053 & yfx(isd:ied, js:je+1, k), yfx_ad(isd:ied, js:&
3054 & je+1, k), gridstruct, bd, ra_x, ra_x_ad, ra_y&
3055 & , ra_y_ad, mfx(is:ie+1, js:je, k), mfx_ad(is:&
3056 & ie+1, js:je, k), mfy(is:ie, js:je+1, k), &
3057 & mfy_ad(is:ie, js:je+1, k), dp1(isd:ied, jsd:&
3058 & jed, k), dp1_ad(isd:ied, jsd:jed, k), nord=&
3059 & nord_tr, damp_c=trdm)
3060  END IF
3061  END DO
3062  DO j=je,js,-1
3063  DO i=ied,isd,-1
3064  CALL poprealarray(ra_y(i, j))
3065  yfx_ad(i, j, k) = yfx_ad(i, j, k) + ra_y_ad(i, j)
3066  yfx_ad(i, j+1, k) = yfx_ad(i, j+1, k) - ra_y_ad(i, j)
3067  ra_y_ad(i, j) = 0.0
3068  END DO
3069  END DO
3070  DO j=jed,jsd,-1
3071  DO i=ie,is,-1
3072  CALL poprealarray(ra_x(i, j))
3073  xfx_ad(i, j, k) = xfx_ad(i, j, k) + ra_x_ad(i, j)
3074  xfx_ad(i+1, j, k) = xfx_ad(i+1, j, k) - ra_x_ad(i, j)
3075  ra_x_ad(i, j) = 0.0
3076  END DO
3077  END DO
3078  DO j=je,js,-1
3079  DO i=ie,is,-1
3080  CALL poprealarray(dp2(i, j))
3081  temp_ad = rarea(i, j)*dp2_ad(i, j)
3082  dp1_ad(i, j, k) = dp1_ad(i, j, k) + dp2_ad(i, j)
3083  mfx_ad(i, j, k) = mfx_ad(i, j, k) + temp_ad
3084  mfx_ad(i+1, j, k) = mfx_ad(i+1, j, k) - temp_ad
3085  mfy_ad(i, j, k) = mfy_ad(i, j, k) + temp_ad
3086  mfy_ad(i, j+1, k) = mfy_ad(i, j+1, k) - temp_ad
3087  dp2_ad(i, j) = 0.0
3088  END DO
3089  END DO
3090  END DO
3091  CALL popcontrol(1,branch)
3092  IF (branch .NE. 0) THEN
3093  DO iq=nq,1,-1
3094  CALL poprealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
3095 & jed-jsd+1)*npz)
3096  CALL nested_grid_bc_apply_intt_adm(q(isd:ied, jsd:jed, :, iq)&
3097 & , q_ad(isd:ied, jsd:jed, :, iq), &
3098 & 0, 0, npx, npy, npz, bd, arg1, &
3099 & arg2, neststruct%q_bc(iq), &
3100 & neststruct%nestbctype)
3101  END DO
3102  END IF
3103  END DO
3104  CALL popcontrol(1,branch)
3105  IF (branch .NE. 0) THEN
3106  DO k=npz,1,-1
3107  DO j=je+1,js,-1
3108  DO i=ie,is,-1
3109  CALL poprealarray(mfy(i, j, k))
3110  mfy_ad(i, j, k) = frac*mfy_ad(i, j, k)
3111  END DO
3112  END DO
3113  DO j=je+1,js,-1
3114  DO i=ied,isd,-1
3115  yfx_ad(i, j, k) = frac*yfx_ad(i, j, k)
3116  CALL poprealarray(cy(i, j, k))
3117  cy_ad(i, j, k) = frac*cy_ad(i, j, k)
3118  END DO
3119  END DO
3120  DO j=je,js,-1
3121  DO i=ie+1,is,-1
3122  CALL poprealarray(mfx(i, j, k))
3123  mfx_ad(i, j, k) = frac*mfx_ad(i, j, k)
3124  END DO
3125  END DO
3126  DO j=jed,jsd,-1
3127  DO i=ie+1,is,-1
3128  xfx_ad(i, j, k) = frac*xfx_ad(i, j, k)
3129  CALL poprealarray(cx(i, j, k))
3130  cx_ad(i, j, k) = frac*cx_ad(i, j, k)
3131  END DO
3132  END DO
3133  END DO
3134  END IF
3135  CALL popcontrol(1,branch)
3136  IF (branch .EQ. 0) THEN
3137  CALL popcontrol(1,branch)
3138  IF (branch .EQ. 0) THEN
3139  DO k=npz,2,-1
3140  CALL popcontrol(1,branch)
3141  END DO
3142  END IF
3143  sin_sg => gridstruct%sin_sg
3144  DO k=npz,1,-1
3145  CALL popcontrol(1,branch)
3146  IF (branch .EQ. 0) THEN
3147  DO j=je,js,-1
3148  DO i=ie,is,-1
3149  CALL popcontrol(1,branch)
3150  END DO
3151  END DO
3152  ELSE
3153  DO j=je,js,-1
3154  DO i=ie,is,-1
3155  CALL popcontrol(1,branch)
3156  END DO
3157  END DO
3158  END IF
3159  END DO
3160  ELSE
3161  sin_sg => gridstruct%sin_sg
3162  END IF
3163  dxa => gridstruct%dxa
3164  dx => gridstruct%dx
3165  dy => gridstruct%dy
3166  dya => gridstruct%dya
3167  DO k=npz,1,-1
3168  DO j=je+1,js,-1
3169  DO i=ied,isd,-1
3170  CALL popcontrol(1,branch)
3171  IF (branch .EQ. 0) THEN
3172  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j)*dx(i, j)*sin_sg(&
3173 & i, j, 2)*yfx_ad(i, j, k)
3174  yfx_ad(i, j, k) = 0.0
3175  ELSE
3176  cy_ad(i, j, k) = cy_ad(i, j, k) + dya(i, j-1)*dx(i, j)*&
3177 & sin_sg(i, j-1, 4)*yfx_ad(i, j, k)
3178  yfx_ad(i, j, k) = 0.0
3179  END IF
3180  END DO
3181  END DO
3182  DO j=jed,jsd,-1
3183  DO i=ie+1,is,-1
3184  CALL popcontrol(1,branch)
3185  IF (branch .EQ. 0) THEN
3186  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i, j)*dy(i, j)*sin_sg(&
3187 & i, j, 1)*xfx_ad(i, j, k)
3188  xfx_ad(i, j, k) = 0.0
3189  ELSE
3190  cx_ad(i, j, k) = cx_ad(i, j, k) + dxa(i-1, j)*dy(i, j)*&
3191 & sin_sg(i-1, j, 3)*xfx_ad(i, j, k)
3192  xfx_ad(i, j, k) = 0.0
3193  END IF
3194  END DO
3195  END DO
3196  END DO
3197  END SUBROUTINE tracer_2d_nested_bwd
3198  SUBROUTINE tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, &
3199 & domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, &
3200 & nord_tr, trdm, k_split, neststruct, parent_grid, hord_pert, &
3201 & nord_tr_pert, trdm_pert, split_damp_tr)
3202  IMPLICIT NONE
3203  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3204  INTEGER, INTENT(IN) :: npx
3205  INTEGER, INTENT(IN) :: npy
3206  INTEGER, INTENT(IN) :: npz
3207 ! number of tracers to be advected
3208  INTEGER, INTENT(IN) :: nq
3209  INTEGER, INTENT(IN) :: hord, nord_tr
3210  INTEGER, INTENT(IN) :: hord_pert, nord_tr_pert
3211  LOGICAL, INTENT(IN) :: split_damp_tr
3212  INTEGER, INTENT(IN) :: q_split, k_split
3213  INTEGER, INTENT(IN) :: id_divg
3214  REAL, INTENT(IN) :: dt, trdm, trdm_pert
3215  TYPE(group_halo_update_type), INTENT(INOUT) :: q_pack
3216 ! Tracers
3217  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
3218 ! DELP before dyn_core
3219  REAL, INTENT(INOUT) :: dp1(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3220 ! Mass Flux X-Dir
3221  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
3222 ! Mass Flux Y-Dir
3223  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
3224 ! Courant Number X-Dir
3225  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
3226 ! Courant Number Y-Dir
3227  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
3228  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3229  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
3230  TYPE(fv_atmos_type), INTENT(INOUT) :: parent_grid
3231  TYPE(domain2d), INTENT(INOUT) :: domain
3232 ! Local Arrays
3233  REAL :: dp2(bd%is:bd%ie, bd%js:bd%je)
3234  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
3235  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
3236  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
3237  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
3238  REAL :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
3239  REAL :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
3240  REAL :: cmax(npz)
3241  REAL :: cmax_t
3242  REAL :: c_global
3243  REAL :: frac, rdt
3244  INTEGER :: nsplt, nsplt_parent
3245  INTEGER, SAVE :: msg_split_steps=1
3246  INTEGER :: i, j, k, it, iq
3247  REAL, DIMENSION(:, :), POINTER :: area, rarea
3248  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
3249  REAL, DIMENSION(:, :), POINTER :: dxa, dya, dx, dy
3250  INTEGER :: is, ie, js, je
3251  INTEGER :: isd, ied, jsd, jed
3252  INTRINSIC abs
3253  INTRINSIC max
3254  INTRINSIC int
3255  INTRINSIC real
3256  REAL :: max1
3257  REAL :: arg1
3258  REAL :: arg2
3259  REAL :: x2
3260  REAL :: x1
3261  REAL :: y2
3262  REAL :: y1
3263  is = bd%is
3264  ie = bd%ie
3265  js = bd%js
3266  je = bd%je
3267  isd = bd%isd
3268  ied = bd%ied
3269  jsd = bd%jsd
3270  jed = bd%jed
3271  area => gridstruct%area
3272  rarea => gridstruct%rarea
3273  sin_sg => gridstruct%sin_sg
3274  dxa => gridstruct%dxa
3275  dya => gridstruct%dya
3276  dx => gridstruct%dx
3277  dy => gridstruct%dy
3278 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,xfx,dxa,dy, &
3279 !$OMP sin_sg,cy,yfx,dya,dx)
3280  DO k=1,npz
3281  DO j=jsd,jed
3282  DO i=is,ie+1
3283  IF (cx(i, j, k) .GT. 0.) THEN
3284  xfx(i, j, k) = cx(i, j, k)*dxa(i-1, j)*dy(i, j)*sin_sg(i-1, &
3285 & j, 3)
3286  ELSE
3287  xfx(i, j, k) = cx(i, j, k)*dxa(i, j)*dy(i, j)*sin_sg(i, j, 1&
3288 & )
3289  END IF
3290  END DO
3291  END DO
3292  DO j=js,je+1
3293  DO i=isd,ied
3294  IF (cy(i, j, k) .GT. 0.) THEN
3295  yfx(i, j, k) = cy(i, j, k)*dya(i, j-1)*dx(i, j)*sin_sg(i, j-&
3296 & 1, 4)
3297  ELSE
3298  yfx(i, j, k) = cy(i, j, k)*dya(i, j)*dx(i, j)*sin_sg(i, j, 2&
3299 & )
3300  END IF
3301  END DO
3302  END DO
3303  END DO
3304 !--------------------------------------------------------------------------------
3305  IF (q_split .EQ. 0) THEN
3306 ! Determine nsplt
3307 !$OMP parallel do default(none) shared(is,ie,js,je,npz,cmax,cx,cy,sin_sg) &
3308 !$OMP private(cmax_t )
3309  DO k=1,npz
3310  cmax(k) = 0.
3311  IF (k .LT. 4) THEN
3312 ! Top layers: C < max( abs(c_x), abs(c_y) )
3313  DO j=js,je
3314  DO i=is,ie
3315  IF (cx(i, j, k) .GE. 0.) THEN
3316  x1 = cx(i, j, k)
3317  ELSE
3318  x1 = -cx(i, j, k)
3319  END IF
3320  IF (cy(i, j, k) .GE. 0.) THEN
3321  y1 = cy(i, j, k)
3322  ELSE
3323  y1 = -cy(i, j, k)
3324  END IF
3325  IF (x1 .LT. y1) THEN
3326  cmax_t = y1
3327  ELSE
3328  cmax_t = x1
3329  END IF
3330  IF (cmax_t .LT. cmax(k)) THEN
3331  cmax(k) = cmax(k)
3332  ELSE
3333  cmax(k) = cmax_t
3334  END IF
3335  END DO
3336  END DO
3337  ELSE
3338  DO j=js,je
3339  DO i=is,ie
3340  IF (cx(i, j, k) .GE. 0.) THEN
3341  x2 = cx(i, j, k)
3342  ELSE
3343  x2 = -cx(i, j, k)
3344  END IF
3345  IF (cy(i, j, k) .GE. 0.) THEN
3346  y2 = cy(i, j, k)
3347  ELSE
3348  y2 = -cy(i, j, k)
3349  END IF
3350  IF (x2 .LT. y2) THEN
3351  max1 = y2
3352  ELSE
3353  max1 = x2
3354  END IF
3355  cmax_t = max1 + 1. - sin_sg(i, j, 5)
3356  IF (cmax_t .LT. cmax(k)) THEN
3357  cmax(k) = cmax(k)
3358  ELSE
3359  cmax(k) = cmax_t
3360  END IF
3361  END DO
3362  END DO
3363  END IF
3364  END DO
3365  CALL mp_reduce_max(cmax, npz)
3366 ! find global max courant number and define nsplt to scale cx,cy,mfx,mfy
3367  c_global = cmax(1)
3368  IF (npz .NE. 1) THEN
3369 ! if NOT shallow water test case
3370  DO k=2,npz
3371  IF (cmax(k) .LT. c_global) THEN
3372  c_global = c_global
3373  ELSE
3374  c_global = cmax(k)
3375  END IF
3376  END DO
3377  END IF
3378  nsplt = int(1. + c_global)
3379  IF (is_master() .AND. nsplt .GT. 3) WRITE(*, *) 'Tracer_2d_split='&
3380 & , nsplt, c_global
3381  ELSE
3382  nsplt = q_split
3383  IF (gridstruct%nested .AND. neststruct%nestbctype .GT. 1) THEN
3384  IF (q_split/parent_grid%flagstruct%q_split .LT. 1) THEN
3385  msg_split_steps = 1
3386  ELSE
3387  msg_split_steps = q_split/parent_grid%flagstruct%q_split
3388  END IF
3389  END IF
3390  END IF
3391 !--------------------------------------------------------------------------------
3392  frac = 1./REAL(nsplt)
3393  IF (nsplt .NE. 1) THEN
3394 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,cx,frac,xfx,mfx,cy,yfx,mfy)
3395  DO k=1,npz
3396  DO j=jsd,jed
3397  DO i=is,ie+1
3398  cx(i, j, k) = cx(i, j, k)*frac
3399  xfx(i, j, k) = xfx(i, j, k)*frac
3400  END DO
3401  END DO
3402  DO j=js,je
3403  DO i=is,ie+1
3404  mfx(i, j, k) = mfx(i, j, k)*frac
3405  END DO
3406  END DO
3407  DO j=js,je+1
3408  DO i=isd,ied
3409  cy(i, j, k) = cy(i, j, k)*frac
3410  yfx(i, j, k) = yfx(i, j, k)*frac
3411  END DO
3412  END DO
3413  DO j=js,je+1
3414  DO i=is,ie
3415  mfy(i, j, k) = mfy(i, j, k)*frac
3416  END DO
3417  END DO
3418  END DO
3419  END IF
3420  DO it=1,nsplt
3421  IF (gridstruct%nested) neststruct%tracer_nest_timestep = &
3422 & neststruct%tracer_nest_timestep + 1
3423  CALL timing_on('COMM_TOTAL')
3424  CALL timing_on('COMM_TRACER')
3425  CALL complete_group_halo_update(q_pack, domain)
3426  CALL timing_off('COMM_TRACER')
3427  CALL timing_off('COMM_TOTAL')
3428  IF (gridstruct%nested) THEN
3429  DO iq=1,nq
3430  arg1 = REAL(neststruct%tracer_nest_timestep) + REAL(nsplt*&
3431 & k_split)
3432  arg2 = real(nsplt*k_split)
3433  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
3434 & 0, npx, npy, npz, bd, arg1, arg2, &
3435 & neststruct%q_bc(iq), neststruct%&
3436 & nestbctype)
3437  END DO
3438  END IF
3439 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,npz,dp1,mfx,mfy,rarea,nq, &
3440 !$OMP area,xfx,yfx,q,cx,cy,npx,npy,hord,gridstruct,bd,it,nsplt,nord_tr,trdm) &
3441 !$OMP private(dp2, ra_x, ra_y, fx, fy)
3442  DO k=1,npz
3443  DO j=js,je
3444  DO i=is,ie
3445  dp2(i, j) = dp1(i, j, k) + (mfx(i, j, k)-mfx(i+1, j, k)+(mfy&
3446 & (i, j, k)-mfy(i, j+1, k)))*rarea(i, j)
3447  END DO
3448  END DO
3449  DO j=jsd,jed
3450  DO i=is,ie
3451  ra_x(i, j) = area(i, j) + (xfx(i, j, k)-xfx(i+1, j, k))
3452  END DO
3453  END DO
3454  DO j=js,je
3455  DO i=isd,ied
3456  ra_y(i, j) = area(i, j) + (yfx(i, j, k)-yfx(i, j+1, k))
3457  END DO
3458  END DO
3459  DO iq=1,nq
3460  IF (it .EQ. 1 .AND. trdm .GT. 1.e-4) THEN
3461  IF (hord .EQ. hord_pert) THEN
3462  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, &
3463 & jsd:jed, k), cy(isd:ied, js:je+1, k), npx, npy&
3464 & , hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
3465 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, &
3466 & ra_y, mfx(is:ie+1, js:je, k), mfy(is:ie, js:je+&
3467 & 1, k), dp1(isd:ied, jsd:jed, k), nord_tr, trdm)
3468  ELSE
3469  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
3470 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
3471 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(&
3472 & isd:ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, &
3473 & mfx(is:ie+1, js:je, k), mfy(is:ie, js:je+1, k), &
3474 & dp1(isd:ied, jsd:jed, k), nord_tr, trdm)
3475  END IF
3476  ELSE IF (hord .EQ. hord_pert) THEN
3477  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd&
3478 & :jed, k), cy(isd:ied, js:je+1, k), npx, npy, hord&
3479 & , fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(isd:ied, &
3480 & js:je+1, k), gridstruct, bd, ra_x, ra_y, mfx=mfx(&
3481 & is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1, k))
3482  ELSE
3483  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), cx(is:ie+1, jsd:&
3484 & jed, k), cy(isd:ied, js:je+1, k), npx, npy, &
3485 & hord, fx, fy, xfx(is:ie+1, jsd:jed, k), yfx(isd&
3486 & :ied, js:je+1, k), gridstruct, bd, ra_x, ra_y, mfx=&
3487 & mfx(is:ie+1, js:je, k), mfy=mfy(is:ie, js:je+1, k))
3488  END IF
3489  DO j=js,je
3490  DO i=is,ie
3491  q(i, j, k, iq) = (q(i, j, k, iq)*dp1(i, j, k)+(fx(i, j)-fx&
3492 & (i+1, j)+(fy(i, j)-fy(i, j+1)))*rarea(i, j))/dp2(i, j)
3493  END DO
3494  END DO
3495  END DO
3496  END DO
3497 ! npz
3498  IF (it .NE. nsplt) THEN
3499  CALL timing_on('COMM_TOTAL')
3500  CALL timing_on('COMM_TRACER')
3501  CALL start_group_halo_update(q_pack, q, domain)
3502  CALL timing_off('COMM_TRACER')
3503  CALL timing_off('COMM_TOTAL')
3504  END IF
3505 !Apply nested-grid BCs
3506  IF (gridstruct%nested) THEN
3507  DO iq=1,nq
3508  arg1 = REAL(neststruct%tracer_nest_timestep)
3509  arg2 = REAL(nsplt*k_split)
3510  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
3511 & 0, npx, npy, npz, bd, arg1, arg2, &
3512 & neststruct%q_bc(iq), neststruct%&
3513 & nestbctype)
3514  END DO
3515  END IF
3516  END DO
3517 ! nsplt
3518  IF (id_divg .GT. 0) THEN
3519  rdt = 1./(frac*dt)
3520 !$OMP parallel do default(none) shared(is,ie,js,je,npz,dp1,xfx,yfx,rarea,rdt)
3521  DO k=1,npz
3522  DO j=js,je
3523  DO i=is,ie
3524  dp1(i, j, k) = (xfx(i+1, j, k)-xfx(i, j, k)+(yfx(i, j+1, k)-&
3525 & yfx(i, j, k)))*rarea(i, j)*rdt
3526  END DO
3527  END DO
3528  END DO
3529  END IF
3530  END SUBROUTINE tracer_2d_nested
3531 end module fv_tracer2d_adm_mod
3532 
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
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
fv_mp_adm_mod::mpp_update_domains_adm
Definition: fv_mp_adm.F90:91
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
tp_core_adm_mod
Definition: tp_core_adm.F90:20
mpp_mod::mpp_max
Definition: mpp.F90:616
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
fv_tracer2d_adm_mod::nest_fx_south_accum
real, dimension(:,:,:), allocatable nest_fx_south_accum
Definition: fv_tracer2d_adm.F90:45
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
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
fv_tracer2d_adm_mod::tracer_2d_bwd
subroutine, public tracer_2d_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy, mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:1632
tp_core_adm_mod::fv_tp_2d_adm
subroutine, public fv_tp_2d_adm(q, q_ad, crx, crx_ad, cry, cry_ad, npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx, xfx_ad, yfx, yfx_ad, gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx, mfx_ad, mfy, mfy_ad, mass, mass_ad, nord, damp_c)
Definition: tp_core_adm.F90:113
fv_arrays_nlm_mod::fv_atmos_type
Definition: fv_arrays_nlm.F90:611
fv_tracer2d_adm_mod
Definition: fv_tracer2d_adm.F90:20
tp_core_adm_mod::fv_tp_2d_fwd
subroutine, public fv_tp_2d_fwd(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
Definition: tp_core_adm.F90:7028
mpp_mod::mpp_broadcast
Definition: mpp.F90:1124
mpp_mod
Definition: mpp.F90:39
fv_tracer2d_adm_mod::tracer_2d_nested
subroutine, public tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, k_split, neststruct, parent_grid, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr)
Definition: fv_tracer2d_adm.F90:3206
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
fv_tracer2d_adm_mod::tracer_2d_1l
subroutine, public tracer_2d_1l(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:888
fv_tracer2d_adm_mod::nest_fx_west_accum
real, dimension(:,:,:), allocatable nest_fx_west_accum
Definition: fv_tracer2d_adm.F90:45
fv_mp_adm_mod::start_group_halo_update_adm
Definition: fv_mp_adm.F90:53
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_tracer2d_adm_mod::nest_fx_north_accum
real, dimension(:,:,:), allocatable nest_fx_north_accum
Definition: fv_tracer2d_adm.F90:45
tp_core_adm_mod::fv_tp_2d
subroutine, public fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
Definition: tp_core_adm.F90:385
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
mpp_mod::mpp_recv
Definition: mpp.F90:975
fv_tracer2d_adm_mod::nest_fx_east_accum
real, dimension(:,:,:), allocatable nest_fx_east_accum
Definition: fv_tracer2d_adm.F90:45
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
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
fv_tracer2d_adm_mod::tracer_2d_1l_fwd
subroutine, public tracer_2d_1l_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:75
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
mpp_mod::mpp_sum
Definition: mpp.F90:680
tp_core_adm_mod::fv_tp_2d_bwd
subroutine, public fv_tp_2d_bwd(q, q_ad, crx, crx_ad, cry, cry_ad, npx, npy, hord, fx, fx_ad, fy, fy_ad, xfx, xfx_ad, yfx, yfx_ad, gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx, mfx_ad, mfy, mfy_ad, mass, mass_ad, nord, damp_c)
Definition: tp_core_adm.F90:7267
fv_tracer2d_adm_mod::tracer_2d_fwd
subroutine, public tracer_2d_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:1217
fv_tracer2d_adm_mod::tracer_2d_1l_bwd
subroutine, public tracer_2d_1l_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy, mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:486
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
fv_mp_adm_mod
Definition: fv_mp_adm.F90:1
fv_tracer2d_adm_mod::tracer_2d
subroutine, public tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr, dpa)
Definition: fv_tracer2d_adm.F90:1988
mpp_mod::mpp_send
Definition: mpp.F90:1033
mpp_domains_mod::mpp_get_boundary
Definition: mpp_domains.F90:1900
fv_mp_adm_mod::complete_group_halo_update
subroutine, public complete_group_halo_update(group, groupp, domain)
Definition: fv_mp_adm.F90:436
fv_tracer2d_adm_mod::tracer_2d_nested_bwd
subroutine, public tracer_2d_nested_bwd(q, q_ad, dp1, dp1_ad, mfx, mfx_ad, mfy, mfy_ad, cx, cx_ad, cy, cy_ad, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, k_split, neststruct, parent_grid, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr)
Definition: fv_tracer2d_adm.F90:2786
fv_arrays_nlm_mod::fv_nest_type
Definition: fv_arrays_nlm.F90:534
mpp_mod::mpp_error
Definition: mpp.F90:402
fv_mp_adm_mod::start_group_halo_update
Definition: fv_mp_adm.F90:45
max
#define max(a, b)
Definition: mosaic_util.h:33
fv_tracer2d_adm_mod::tracer_2d_nested_fwd
subroutine, public tracer_2d_nested_fwd(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, k_split, neststruct, parent_grid, hord_pert, nord_tr_pert, trdm_pert, split_damp_tr)
Definition: fv_tracer2d_adm.F90:2313
boundary_adm_mod
Definition: boundary_adm.F90:20
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
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