FV3 Bundle
sw_core_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 sw_core_adm_mod
21 
22  use fv_mp_nlm_mod, only: ng
23  use tp_core_adm_mod, only: fv_tp_2d, pert_ppm, copy_corners
24  use tp_core_adm_mod, only: fv_tp_2d_adm, fv_tp_2d_fwd, fv_tp_2d_bwd, copy_corners_adm, pert_ppm_adm
25  use fv_mp_nlm_mod, only: xdir, ydir
26  use fv_mp_nlm_mod, only: fill_corners
27  use fv_mp_adm_mod, only: fill_corners_adm
28  use fv_arrays_nlm_mod, only: fv_grid_type, fv_grid_bounds_type, fv_flags_type, r_grid
29  use a2b_edge_adm_mod, only: a2b_ord4
30  use a2b_edge_adm_mod, only: a2b_ord4_fwd, a2b_ord4_bwd, a2b_ord4_adm
31  use fv_arrays_nlm_mod, only: fvprc
32 
33  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
34  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
35 
36 #ifdef SW_DYNAMICS
37  use test_cases_nlm_mod, only: test_case
38 #endif
39 
40  use fv_arrays_tlmadm_mod, only: fpp
41 
42  implicit none
43 
44  real, parameter:: r3 = 1./3.
45  real, parameter:: t11=27./28., t12=-13./28., t13=3./7., t14=6./7., t15=3./28.
46  real, parameter:: s11=11./14., s13=-13./14., s14=4./7., s15=3./14.
47  real, parameter:: near_zero = 1.e-9 ! for KE limiter
48 #ifdef OVERLOAD_R4
49  real, parameter:: big_number = 1.e8
50 #else
51  real, parameter:: big_number = 1.e30
52 #endif
53 !----------------------
54 ! PPM volume mean form:
55 !----------------------
56  real, parameter:: p1 = 7./12. ! 0.58333333
57  real, parameter:: p2 = -1./12.
58 !----------------------------
59 ! 4-pt Lagrange interpolation
60 !----------------------------
61  real, parameter:: a1 = 0.5625
62  real, parameter:: a2 = -0.0625
63 !----------------------------------------------
64 ! volume-conserving cubic with 2nd drv=0 at end point:
65  real, parameter:: c1 = -2./14.
66  real, parameter:: c2 = 11./14.
67  real, parameter:: c3 = 5./14.
68 ! 3-pt off-center intp formular:
69 ! real, parameter:: c1 = -0.125
70 ! real, parameter:: c2 = 0.75
71 ! real, parameter:: c3 = 0.375
72 !----------------------------------------------
73 ! scheme 2.1: perturbation form
74  REAL, PARAMETER :: b1=1./30.
75  REAL, PARAMETER :: b2=-(13./60.)
76  REAL, PARAMETER :: b3=-(13./60.)
77  REAL, PARAMETER :: b4=0.45
78  REAL, PARAMETER :: b5=-0.05
79  PRIVATE
80  PUBLIC c_sw, d_sw, fill_4corners, del6_vt_flux, divergence_corner, &
81 & divergence_corner_nest
82  PUBLIC c_sw_fwd, c_sw_bwd, d_sw_fwd, d_sw_bwd, fill_4corners_fwd, &
83 & fill_4corners_bwd, del6_vt_flux_adm, divergence_corner_fwd, &
84 & divergence_corner_bwd, divergence_corner_nest_fwd, &
85 & divergence_corner_nest_bwd
86  PUBLIC d2a2c_vect
87  PUBLIC d2a2c_vect_fwd, d2a2c_vect_bwd
88 
89 CONTAINS
90 ! Differentiation of c_sw in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b
91 !_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_mod.p_
92 !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.mix_dp
93 !dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super
94 ! fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_g
95 !rid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
96 !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_mapz
97 !_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_map
98 !z_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_restart
99 !_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_z ma
100 !in_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_mod.Ri
101 !em_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.SIM3
102 !p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_
103 !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.d2a2c_ve
104 !ct 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 sw_
105 !core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.co
106 !py_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.g
107 !reat_circle_dist sw_core_mod.edge_interpolate4)):
108 ! gradient of useful results: u v w delp ua uc ptc ut delpc
109 ! va vc vt divg_d wc pt
110 ! with respect to varying inputs: u v w delp ua uc ptc ut delpc
111 ! va vc vt divg_d wc pt
112  SUBROUTINE c_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc&
113 & , ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, &
114 & flagstruct)
115  !USE ISO_C_BINDING
116  !USE ADMM_TAPENADE_INTERFACE
117  IMPLICIT NONE
118  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
119  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
120 & , vc
121  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
122 & , uc
123  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
124 & , pt, ua, va, ut, vt
125  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
126  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc, wc
127  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
128  INTEGER, INTENT(IN) :: nord
129  REAL, INTENT(IN) :: dt2
130  LOGICAL, INTENT(IN) :: hydrostatic
131  LOGICAL, INTENT(IN) :: dord4
132  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
133  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
134 ! Local:
135  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
136  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort, ke
137  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx, fx1, fx2
138  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy, fy1, fy2
139  REAL :: dt4
140  INTEGER :: i, j, is2, ie1
141  INTEGER :: iep1, jep1
142  INTEGER :: is, ie, js, je
143  INTEGER :: isd, ied, jsd, jed
144  INTEGER :: npx, npy
145  LOGICAL :: nested
146  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
147  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
148  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
149  REAL, DIMENSION(:, :), POINTER :: dx, dy, dxc, dyc
150 
151  vort = 0.0
152  ke = 0.0
153  fx = 0.0
154  fx1 = 0.0
155  fx2 = 0.0
156  fy = 0.0
157  fy1 = 0.0
158  fy2 = 0.0
159  dt4 = 0.0
160  is2 = 0
161  ie1 = 0
162  iep1 = 0
163  jep1 = 0
164  is = 0
165  ie = 0
166  js = 0
167  je = 0
168  isd = 0
169  ied = 0
170  jsd = 0
171  jed = 0
172  npx = 0
173  npy = 0
174 
175  is = bd%is
176  ie = bd%ie
177  js = bd%js
178  je = bd%je
179  npx = flagstruct%npx
180  npy = flagstruct%npy
181  nested = gridstruct%nested
182  sin_sg => gridstruct%sin_sg
183  cos_sg => gridstruct%cos_sg
184  cosa_u => gridstruct%cosa_u
185  cosa_v => gridstruct%cosa_v
186  sina_u => gridstruct%sina_u
187  sina_v => gridstruct%sina_v
188  dx => gridstruct%dx
189  dy => gridstruct%dy
190  dxc => gridstruct%dxc
191  dyc => gridstruct%dyc
192  sw_corner = gridstruct%sw_corner
193  se_corner = gridstruct%se_corner
194  nw_corner = gridstruct%nw_corner
195  ne_corner = gridstruct%ne_corner
196  iep1 = ie + 1
197  jep1 = je + 1
198  CALL d2a2c_vect_fwd(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct&
199 & , bd, npx, npy, nested, flagstruct%grid_type)
200  IF (nord .GT. 0) THEN
201  IF (nested) THEN
202  CALL divergence_corner_nest_fwd(u, v, ua, va, divg_d, gridstruct&
203 & , flagstruct, bd)
204  CALL pushcontrol(2,2)
205  ELSE
206  CALL divergence_corner_fwd(u, v, ua, va, divg_d, gridstruct, &
207 & flagstruct, bd)
208  CALL pushcontrol(2,1)
209  END IF
210  ELSE
211  CALL pushcontrol(2,0)
212  END IF
213  DO j=js-1,jep1
214  DO i=is-1,iep1+1
215  IF (ut(i, j) .GT. 0.) THEN
216  CALL pushrealarray(ut(i, j))
217  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i-1, j, 3)
218  CALL pushcontrol(1,1)
219  ELSE
220  CALL pushrealarray(ut(i, j))
221  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i, j, 1)
222  CALL pushcontrol(1,0)
223  END IF
224  END DO
225  END DO
226  DO j=js-1,je+2
227  DO i=is-1,iep1
228  IF (vt(i, j) .GT. 0.) THEN
229  CALL pushrealarray(vt(i, j))
230  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j-1, 4)
231  CALL pushcontrol(1,1)
232  ELSE
233  CALL pushrealarray(vt(i, j))
234  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j, 2)
235  CALL pushcontrol(1,0)
236  END IF
237  END DO
238  END DO
239 !----------------
240 ! Transport delp:
241 !----------------
242 ! Xdir:
243  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) THEN
244  CALL fill2_4corners_fwd(delp, pt, 1, bd, npx, npy, sw_corner, &
245 & se_corner, ne_corner, nw_corner)
246  CALL pushcontrol(1,0)
247  ELSE
248  CALL pushcontrol(1,1)
249  END IF
250  IF (hydrostatic) THEN
251  DO j=js-1,jep1
252  DO i=is-1,ie+2
253  IF (ut(i, j) .GT. 0.) THEN
254  fx1(i, j) = delp(i-1, j)
255  fx(i, j) = pt(i-1, j)
256  CALL pushcontrol(1,0)
257  ELSE
258  fx1(i, j) = delp(i, j)
259  fx(i, j) = pt(i, j)
260  CALL pushcontrol(1,1)
261  END IF
262  CALL pushrealarray(fx1(i, j))
263  fx1(i, j) = ut(i, j)*fx1(i, j)
264  CALL pushrealarray(fx(i, j))
265  fx(i, j) = fx1(i, j)*fx(i, j)
266  END DO
267  END DO
268  CALL pushcontrol(1,0)
269  ELSE
270  IF (flagstruct%grid_type .LT. 3) THEN
271  CALL fill_4corners_fwd(w, 1, bd, npx, npy, sw_corner, se_corner&
272 & , ne_corner, nw_corner)
273  CALL pushcontrol(1,1)
274  ELSE
275  CALL pushcontrol(1,0)
276  END IF
277  DO j=js-1,je+1
278  DO i=is-1,ie+2
279  IF (ut(i, j) .GT. 0.) THEN
280  fx1(i, j) = delp(i-1, j)
281  fx(i, j) = pt(i-1, j)
282  fx2(i, j) = w(i-1, j)
283  CALL pushcontrol(1,0)
284  ELSE
285  fx1(i, j) = delp(i, j)
286  fx(i, j) = pt(i, j)
287  fx2(i, j) = w(i, j)
288  CALL pushcontrol(1,1)
289  END IF
290  CALL pushrealarray(fx1(i, j))
291  fx1(i, j) = ut(i, j)*fx1(i, j)
292  CALL pushrealarray(fx(i, j))
293  fx(i, j) = fx1(i, j)*fx(i, j)
294  CALL pushrealarray(fx2(i, j))
295  fx2(i, j) = fx1(i, j)*fx2(i, j)
296  END DO
297  END DO
298  CALL pushcontrol(1,1)
299  END IF
300 ! Ydir:
301  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) THEN
302  CALL fill2_4corners_fwd(delp, pt, 2, bd, npx, npy, sw_corner, &
303 & se_corner, ne_corner, nw_corner)
304  CALL pushcontrol(1,0)
305  ELSE
306  CALL pushcontrol(1,1)
307  END IF
308  IF (hydrostatic) THEN
309  DO j=js-1,jep1+1
310  DO i=is-1,iep1
311  IF (vt(i, j) .GT. 0.) THEN
312  fy1(i, j) = delp(i, j-1)
313  fy(i, j) = pt(i, j-1)
314  CALL pushcontrol(1,0)
315  ELSE
316  fy1(i, j) = delp(i, j)
317  fy(i, j) = pt(i, j)
318  CALL pushcontrol(1,1)
319  END IF
320  CALL pushrealarray(fy1(i, j))
321  fy1(i, j) = vt(i, j)*fy1(i, j)
322  CALL pushrealarray(fy(i, j))
323  fy(i, j) = fy1(i, j)*fy(i, j)
324  END DO
325  END DO
326  DO j=js-1,jep1
327  DO i=is-1,iep1
328  CALL pushrealarray(delpc(i, j))
329  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
330 & fy1(i, j+1)))*gridstruct%rarea(i, j)
331  CALL pushrealarray(ptc(i, j))
332  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
333 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
334  END DO
335  END DO
336  CALL pushcontrol(1,0)
337  ELSE
338  IF (flagstruct%grid_type .LT. 3) THEN
339  CALL fill_4corners_fwd(w, 2, bd, npx, npy, sw_corner, se_corner&
340 & , ne_corner, nw_corner)
341  CALL pushcontrol(1,1)
342  ELSE
343  CALL pushcontrol(1,0)
344  END IF
345  DO j=js-1,je+2
346  DO i=is-1,ie+1
347  IF (vt(i, j) .GT. 0.) THEN
348  fy1(i, j) = delp(i, j-1)
349  fy(i, j) = pt(i, j-1)
350  fy2(i, j) = w(i, j-1)
351  CALL pushcontrol(1,0)
352  ELSE
353  fy1(i, j) = delp(i, j)
354  fy(i, j) = pt(i, j)
355  fy2(i, j) = w(i, j)
356  CALL pushcontrol(1,1)
357  END IF
358  CALL pushrealarray(fy1(i, j))
359  fy1(i, j) = vt(i, j)*fy1(i, j)
360  CALL pushrealarray(fy(i, j))
361  fy(i, j) = fy1(i, j)*fy(i, j)
362  CALL pushrealarray(fy2(i, j))
363  fy2(i, j) = fy1(i, j)*fy2(i, j)
364  END DO
365  END DO
366  DO j=js-1,je+1
367  DO i=is-1,ie+1
368  CALL pushrealarray(delpc(i, j))
369  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
370 & fy1(i, j+1)))*gridstruct%rarea(i, j)
371  CALL pushrealarray(ptc(i, j))
372  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
373 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
374  CALL pushrealarray(wc(i, j))
375  wc(i, j) = (w(i, j)*delp(i, j)+(fx2(i, j)-fx2(i+1, j)+(fy2(i, &
376 & j)-fy2(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
377  END DO
378  END DO
379  CALL pushcontrol(1,1)
380  END IF
381 !------------
382 ! Compute KE:
383 !------------
384 !Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the tru
385 !e coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa.
386 !Use the alpha for the cell KE is being computed in.
387 !!! TO DO:
388 !!! Need separate versions for nesting/single-tile
389 !!! and for cubed-sphere
390  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
391  DO j=js-1,jep1
392  DO i=is-1,iep1
393  IF (ua(i, j) .GT. 0.) THEN
394  ke(i, j) = uc(i, j)
395  CALL pushcontrol(1,1)
396  ELSE
397  ke(i, j) = uc(i+1, j)
398  CALL pushcontrol(1,0)
399  END IF
400  END DO
401  END DO
402  DO j=js-1,jep1
403  DO i=is-1,iep1
404  IF (va(i, j) .GT. 0.) THEN
405  vort(i, j) = vc(i, j)
406  CALL pushcontrol(1,1)
407  ELSE
408  vort(i, j) = vc(i, j+1)
409  CALL pushcontrol(1,0)
410  END IF
411  END DO
412  END DO
413  CALL pushcontrol(1,0)
414  ELSE
415  DO j=js-1,jep1
416  DO i=is-1,iep1
417  IF (ua(i, j) .GT. 0.) THEN
418  IF (i .EQ. 1) THEN
419  ke(1, j) = uc(1, j)*sin_sg(1, j, 1) + v(1, j)*cos_sg(1, j&
420 & , 1)
421  CALL pushcontrol(3,5)
422  ELSE IF (i .EQ. npx) THEN
423  ke(i, j) = uc(npx, j)*sin_sg(npx, j, 1) + v(npx, j)*cos_sg&
424 & (npx, j, 1)
425  CALL pushcontrol(3,4)
426  ELSE
427  ke(i, j) = uc(i, j)
428  CALL pushcontrol(3,3)
429  END IF
430  ELSE IF (i .EQ. 0) THEN
431  ke(0, j) = uc(1, j)*sin_sg(0, j, 3) + v(1, j)*cos_sg(0, j, 3&
432 & )
433  CALL pushcontrol(3,2)
434  ELSE IF (i .EQ. npx - 1) THEN
435  ke(i, j) = uc(npx, j)*sin_sg(npx-1, j, 3) + v(npx, j)*cos_sg&
436 & (npx-1, j, 3)
437  CALL pushcontrol(3,1)
438  ELSE
439  ke(i, j) = uc(i+1, j)
440  CALL pushcontrol(3,0)
441  END IF
442  END DO
443  END DO
444  DO j=js-1,jep1
445  DO i=is-1,iep1
446  IF (va(i, j) .GT. 0.) THEN
447  IF (j .EQ. 1) THEN
448  vort(i, 1) = vc(i, 1)*sin_sg(i, 1, 2) + u(i, 1)*cos_sg(i, &
449 & 1, 2)
450  CALL pushcontrol(3,5)
451  ELSE IF (j .EQ. npy) THEN
452  vort(i, j) = vc(i, npy)*sin_sg(i, npy, 2) + u(i, npy)*&
453 & cos_sg(i, npy, 2)
454  CALL pushcontrol(3,4)
455  ELSE
456  vort(i, j) = vc(i, j)
457  CALL pushcontrol(3,3)
458  END IF
459  ELSE IF (j .EQ. 0) THEN
460  vort(i, 0) = vc(i, 1)*sin_sg(i, 0, 4) + u(i, 1)*cos_sg(i, 0&
461 & , 4)
462  CALL pushcontrol(3,2)
463  ELSE IF (j .EQ. npy - 1) THEN
464  vort(i, j) = vc(i, npy)*sin_sg(i, npy-1, 4) + u(i, npy)*&
465 & cos_sg(i, npy-1, 4)
466  CALL pushcontrol(3,1)
467  ELSE
468  vort(i, j) = vc(i, j+1)
469  CALL pushcontrol(3,0)
470  END IF
471  END DO
472  END DO
473  CALL pushcontrol(1,1)
474  END IF
475  dt4 = 0.5*dt2
476  DO j=js-1,jep1
477  DO i=is-1,iep1
478  CALL pushrealarray(ke(i, j))
479  ke(i, j) = dt4*(ua(i, j)*ke(i, j)+va(i, j)*vort(i, j))
480  END DO
481  END DO
482 !------------------------------
483 ! Compute circulation on C grid
484 !------------------------------
485 ! To consider using true co-variant winds at face edges?
486  DO j=js-1,je+1
487  DO i=is,ie+1
488  CALL pushrealarray(fx(i, j))
489  fx(i, j) = uc(i, j)*dxc(i, j)
490  END DO
491  END DO
492  DO j=js,je+1
493  DO i=is-1,ie+1
494  CALL pushrealarray(fy(i, j))
495  fy(i, j) = vc(i, j)*dyc(i, j)
496  END DO
497  END DO
498  DO j=js,je+1
499  DO i=is,ie+1
500  CALL pushrealarray(vort(i, j))
501  vort(i, j) = fx(i, j-1) - fx(i, j) + (fy(i, j)-fy(i-1, j))
502  END DO
503  END DO
504 ! Remove the extra term at the corners:
505  IF (sw_corner) THEN
506  CALL pushrealarray(vort(1, 1))
507  vort(1, 1) = vort(1, 1) + fy(0, 1)
508  CALL pushcontrol(1,0)
509  ELSE
510  CALL pushcontrol(1,1)
511  END IF
512  IF (se_corner) THEN
513  CALL pushrealarray(vort(npx, 1))
514  vort(npx, 1) = vort(npx, 1) - fy(npx, 1)
515  CALL pushcontrol(1,0)
516  ELSE
517  CALL pushcontrol(1,1)
518  END IF
519  IF (ne_corner) THEN
520  CALL pushrealarray(vort(npx, npy))
521  vort(npx, npy) = vort(npx, npy) - fy(npx, npy)
522  CALL pushcontrol(1,0)
523  ELSE
524  CALL pushcontrol(1,1)
525  END IF
526  IF (nw_corner) THEN
527  CALL pushrealarray(vort(1, npy))
528  vort(1, npy) = vort(1, npy) + fy(0, npy)
529  CALL pushcontrol(1,1)
530  ELSE
531  CALL pushcontrol(1,0)
532  END IF
533 !----------------------------
534 ! Compute absolute vorticity
535 !----------------------------
536  DO j=js,je+1
537  DO i=is,ie+1
538  CALL pushrealarray(vort(i, j))
539  vort(i, j) = gridstruct%fc(i, j) + gridstruct%rarea_c(i, j)*vort&
540 & (i, j)
541  END DO
542  END DO
543 !----------------------------------
544 ! Transport absolute vorticity:
545 !----------------------------------
546 !To go from v to contravariant v at the edges, we divide by sin_sg;
547 ! but we then must multiply by sin_sg to get the proper flux.
548 ! These cancel, leaving us with fy1 = dt2*v at the edges.
549 ! (For the same reason we only divide by sin instead of sin**2 in the interior)
550 !! TO DO: separate versions for nesting/single-tile and cubed-sphere
551  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
552  DO j=js,je
553  DO i=is,iep1
554  CALL pushrealarray(fy1(i, j))
555  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
556  IF (fy1(i, j) .GT. 0.) THEN
557  CALL pushrealarray(fy(i, j))
558  fy(i, j) = vort(i, j)
559  CALL pushcontrol(1,1)
560  ELSE
561  CALL pushrealarray(fy(i, j))
562  fy(i, j) = vort(i, j+1)
563  CALL pushcontrol(1,0)
564  END IF
565  END DO
566  END DO
567  DO j=js,jep1
568  DO i=is,ie
569  CALL pushrealarray(fx1(i, j))
570  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
571  IF (fx1(i, j) .GT. 0.) THEN
572  CALL pushrealarray(fx(i, j))
573  fx(i, j) = vort(i, j)
574  CALL pushcontrol(1,1)
575  ELSE
576  CALL pushrealarray(fx(i, j))
577  fx(i, j) = vort(i+1, j)
578  CALL pushcontrol(1,0)
579  END IF
580  END DO
581  END DO
582  CALL pushcontrol(1,1)
583  ELSE
584  DO j=js,je
585 !DEC$ VECTOR ALWAYS
586  DO i=is,iep1
587  IF (i .EQ. 1 .OR. i .EQ. npx) THEN
588  CALL pushrealarray(fy1(i, j))
589  fy1(i, j) = dt2*v(i, j)
590  CALL pushcontrol(1,0)
591  ELSE
592  CALL pushrealarray(fy1(i, j))
593  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
594  CALL pushcontrol(1,1)
595  END IF
596  IF (fy1(i, j) .GT. 0.) THEN
597  CALL pushrealarray(fy(i, j))
598  fy(i, j) = vort(i, j)
599  CALL pushcontrol(1,1)
600  ELSE
601  CALL pushrealarray(fy(i, j))
602  fy(i, j) = vort(i, j+1)
603  CALL pushcontrol(1,0)
604  END IF
605  END DO
606  END DO
607  DO j=js,jep1
608  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
609 !DEC$ VECTOR ALWAYS
610  DO i=is,ie
611  CALL pushrealarray(fx1(i, j))
612  fx1(i, j) = dt2*u(i, j)
613  IF (fx1(i, j) .GT. 0.) THEN
614  CALL pushrealarray(fx(i, j))
615  fx(i, j) = vort(i, j)
616  CALL pushcontrol(1,1)
617  ELSE
618  CALL pushrealarray(fx(i, j))
619  fx(i, j) = vort(i+1, j)
620  CALL pushcontrol(1,0)
621  END IF
622  END DO
623  CALL pushcontrol(1,1)
624  ELSE
625 !DEC$ VECTOR ALWAYS
626  DO i=is,ie
627  CALL pushrealarray(fx1(i, j))
628  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
629  IF (fx1(i, j) .GT. 0.) THEN
630  CALL pushrealarray(fx(i, j))
631  fx(i, j) = vort(i, j)
632  CALL pushcontrol(1,1)
633  ELSE
634  CALL pushrealarray(fx(i, j))
635  fx(i, j) = vort(i+1, j)
636  CALL pushcontrol(1,0)
637  END IF
638  END DO
639  CALL pushcontrol(1,0)
640  END IF
641  END DO
642  CALL pushcontrol(1,0)
643  END IF
644 ! Update time-centered winds on the C-Grid
645  DO j=js,je
646  DO i=is,iep1
647  uc(i, j) = uc(i, j) + fy1(i, j)*fy(i, j) + gridstruct%rdxc(i, j)&
648 & *(ke(i-1, j)-ke(i, j))
649  END DO
650  END DO
651  DO j=js,jep1
652  DO i=is,ie
653  vc(i, j) = vc(i, j) - fx1(i, j)*fx(i, j) + gridstruct%rdyc(i, j)&
654 & *(ke(i, j-1)-ke(i, j))
655  END DO
656  END DO
657  CALL pushrealarray(fx2, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
658  CALL pushrealarray(fx1, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
659  CALL pushinteger(je)
660  CALL pushrealarray(fy, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
661  CALL pushrealarray(fx, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
662  CALL pushinteger(is)
663  !CALL PUSHPOINTER8(C_LOC(sina_v))
664  !CALL PUSHPOINTER8(C_LOC(sina_u))
665  CALL pushrealarray(vort, (bd%ie-bd%is+3)*(bd%je-bd%js+3))
666  CALL pushinteger(ie)
667  !CALL PUSHPOINTER8(C_LOC(dyc))
668  CALL pushrealarray(dt4)
669  !CALL PUSHPOINTER8(C_LOC(sin_sg))
670  CALL pushinteger(iep1)
671  !CALL PUSHPOINTER8(C_LOC(cosa_v))
672  CALL pushinteger(jep1)
673  !CALL PUSHPOINTER8(C_LOC(cosa_u))
674  CALL pushrealarray(fy2, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
675  CALL pushrealarray(fy1, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
676  !CALL PUSHPOINTER8(C_LOC(dy))
677  !CALL PUSHPOINTER8(C_LOC(dxc))
678  CALL pushinteger(npy)
679  CALL pushinteger(npx)
680  CALL pushinteger(js)
681  END SUBROUTINE c_sw_fwd
682 ! Differentiation of c_sw in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2
683 !b_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_mod.p
684 !_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.mix_dp
685 ! dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Supe
686 !r fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_
687 !grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
688 ! 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_map
689 !z_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_ma
690 !pz_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_restar
691 !t_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_z m
692 !ain_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_mod.R
693 !iem_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.SIM
694 !3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest
695 !_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.d2a2c_v
696 !ect 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 sw
697 !_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.c
698 !opy_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.
699 !great_circle_dist sw_core_mod.edge_interpolate4)):
700 ! gradient of useful results: u v w delp ua uc ptc ut delpc
701 ! va vc vt divg_d wc pt
702 ! with respect to varying inputs: u v w delp ua uc ptc ut delpc
703 ! va vc vt divg_d wc pt
704  SUBROUTINE c_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, &
705 & pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, &
706 & va, va_ad, wc, wc_ad, ut, ut_ad, vt, vt_ad, divg_d, divg_d_ad, nord&
707 & , dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
708  !USE ISO_C_BINDING
709  !USE ADMM_TAPENADE_INTERFACE
710  IMPLICIT NONE
711  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
712  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
713 & , vc
714  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
715 & u_ad, vc_ad
716  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
717 & , uc
718  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
719 & v_ad, uc_ad
720  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
721 & , pt, ua, va, ut, vt
722  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
723 & delp_ad, pt_ad, ua_ad, va_ad, ut_ad, vt_ad
724  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
725  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w_ad
726  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc, wc
727  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc_ad, ptc_ad, &
728 & wc_ad
729  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
730  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d_ad
731  INTEGER, INTENT(IN) :: nord
732  REAL, INTENT(IN) :: dt2
733  LOGICAL, INTENT(IN) :: hydrostatic
734  LOGICAL, INTENT(IN) :: dord4
735  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
736  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
737  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
738  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort, ke
739  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort_ad, ke_ad
740  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx, fx1, fx2
741  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx_ad, fx1_ad, &
742 & fx2_ad
743  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy, fy1, fy2
744  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy_ad, fy1_ad, &
745 & fy2_ad
746  REAL :: dt4
747  INTEGER :: i, j, is2, ie1
748  INTEGER :: iep1, jep1
749  INTEGER :: is, ie, js, je
750  INTEGER :: isd, ied, jsd, jed
751  INTEGER :: npx, npy
752  LOGICAL :: nested
753  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
754  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
755  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
756  REAL, DIMENSION(:, :), POINTER :: dx, dy, dxc, dyc
757  REAL :: temp_ad
758  REAL :: temp_ad0
759  REAL :: temp_ad1
760  REAL :: temp_ad2
761  REAL :: temp_ad3
762  REAL :: temp_ad4
763  REAL :: temp_ad5
764  REAL :: temp_ad6
765  REAL :: temp_ad7
766  REAL :: temp_ad8
767  REAL :: temp_ad9
768  REAL :: temp_ad10
769  REAL :: temp_ad11
770  REAL :: temp_ad12
771  REAL :: temp_ad13
772  INTEGER :: branch
773  !TYPE(C_PTR) :: cptr
774  !INTEGER :: unknown_shape_in_c_sw
775 
776  vort = 0.0
777  ke = 0.0
778  fx = 0.0
779  fx1 = 0.0
780  fx2 = 0.0
781  fy = 0.0
782  fy1 = 0.0
783  fy2 = 0.0
784  dt4 = 0.0
785  is2 = 0
786  ie1 = 0
787  iep1 = 0
788  jep1 = 0
789  is = 0
790  ie = 0
791  js = 0
792  je = 0
793  isd = 0
794  ied = 0
795  jsd = 0
796  jed = 0
797  npx = 0
798  npy = 0
799  branch = 0
800 
801  CALL popinteger(js)
802  CALL popinteger(npx)
803  CALL popinteger(npy)
804  !CALL POPPOINTER8(cptr)
805  dxc => gridstruct%dxc ! (/unknown_shape_in_c_sw/))
806  !CALL POPPOINTER8(cptr)
807  dy => gridstruct%dy ! (/unknown_shape_in_c_sw/))
808  CALL poprealarray(fy1, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
809  CALL poprealarray(fy2, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
810  !CALL POPPOINTER8(cptr)
811  cosa_u => gridstruct%cosa_u ! (/unknown_shape_in_c_sw/))
812  CALL popinteger(jep1)
813  !CALL POPPOINTER8(cptr)
814  cosa_v => gridstruct%cosa_v ! (/unknown_shape_in_c_sw/))
815  CALL popinteger(iep1)
816  !CALL POPPOINTER8(cptr)
817  sin_sg => gridstruct%sin_sg ! (/unknown_shape_in_c_sw/))
818  CALL poprealarray(dt4)
819  !CALL POPPOINTER8(cptr)
820  dyc => gridstruct%dyc ! (/unknown_shape_in_c_sw/))
821  CALL popinteger(ie)
822  CALL poprealarray(vort, (bd%ie-bd%is+3)*(bd%je-bd%js+3))
823  !CALL POPPOINTER8(cptr)
824  sina_u => gridstruct%sina_u ! (/unknown_shape_in_c_sw/))
825  !CALL POPPOINTER8(cptr)
826  sina_v => gridstruct%sina_v ! (/unknown_shape_in_c_sw/))
827  CALL popinteger(is)
828  CALL poprealarray(fx, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
829  CALL poprealarray(fy, (bd%ie-bd%is+3)*(bd%je-bd%js+4))
830  CALL popinteger(je)
831  CALL poprealarray(fx1, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
832  CALL poprealarray(fx2, (bd%ie-bd%is+4)*(bd%je-bd%js+3))
833  ke_ad = 0.0
834  fx_ad = 0.0
835  fx1_ad = 0.0
836  DO j=jep1,js,-1
837  DO i=ie,is,-1
838  temp_ad13 = gridstruct%rdyc(i, j)*vc_ad(i, j)
839  fx1_ad(i, j) = fx1_ad(i, j) - fx(i, j)*vc_ad(i, j)
840  fx_ad(i, j) = fx_ad(i, j) - fx1(i, j)*vc_ad(i, j)
841  ke_ad(i, j-1) = ke_ad(i, j-1) + temp_ad13
842  ke_ad(i, j) = ke_ad(i, j) - temp_ad13
843  END DO
844  END DO
845  fy1_ad = 0.0
846  fy_ad = 0.0
847  DO j=je,js,-1
848  DO i=iep1,is,-1
849  temp_ad12 = gridstruct%rdxc(i, j)*uc_ad(i, j)
850  fy1_ad(i, j) = fy1_ad(i, j) + fy(i, j)*uc_ad(i, j)
851  fy_ad(i, j) = fy_ad(i, j) + fy1(i, j)*uc_ad(i, j)
852  ke_ad(i-1, j) = ke_ad(i-1, j) + temp_ad12
853  ke_ad(i, j) = ke_ad(i, j) - temp_ad12
854  END DO
855  END DO
856  CALL popcontrol(1,branch)
857  IF (branch .EQ. 0) THEN
858  vort_ad = 0.0
859  DO j=jep1,js,-1
860  CALL popcontrol(1,branch)
861  IF (branch .EQ. 0) THEN
862  DO i=ie,is,-1
863  CALL popcontrol(1,branch)
864  IF (branch .EQ. 0) THEN
865  CALL poprealarray(fx(i, j))
866  vort_ad(i+1, j) = vort_ad(i+1, j) + fx_ad(i, j)
867  fx_ad(i, j) = 0.0
868  ELSE
869  CALL poprealarray(fx(i, j))
870  vort_ad(i, j) = vort_ad(i, j) + fx_ad(i, j)
871  fx_ad(i, j) = 0.0
872  END IF
873  CALL poprealarray(fx1(i, j))
874  temp_ad11 = dt2*fx1_ad(i, j)/sina_v(i, j)
875  u_ad(i, j) = u_ad(i, j) + temp_ad11
876  vc_ad(i, j) = vc_ad(i, j) - cosa_v(i, j)*temp_ad11
877  fx1_ad(i, j) = 0.0
878  END DO
879  ELSE
880  DO i=ie,is,-1
881  CALL popcontrol(1,branch)
882  IF (branch .EQ. 0) THEN
883  CALL poprealarray(fx(i, j))
884  vort_ad(i+1, j) = vort_ad(i+1, j) + fx_ad(i, j)
885  fx_ad(i, j) = 0.0
886  ELSE
887  CALL poprealarray(fx(i, j))
888  vort_ad(i, j) = vort_ad(i, j) + fx_ad(i, j)
889  fx_ad(i, j) = 0.0
890  END IF
891  CALL poprealarray(fx1(i, j))
892  u_ad(i, j) = u_ad(i, j) + dt2*fx1_ad(i, j)
893  fx1_ad(i, j) = 0.0
894  END DO
895  END IF
896  END DO
897  DO j=je,js,-1
898  DO i=iep1,is,-1
899  CALL popcontrol(1,branch)
900  IF (branch .EQ. 0) THEN
901  CALL poprealarray(fy(i, j))
902  vort_ad(i, j+1) = vort_ad(i, j+1) + fy_ad(i, j)
903  fy_ad(i, j) = 0.0
904  ELSE
905  CALL poprealarray(fy(i, j))
906  vort_ad(i, j) = vort_ad(i, j) + fy_ad(i, j)
907  fy_ad(i, j) = 0.0
908  END IF
909  CALL popcontrol(1,branch)
910  IF (branch .EQ. 0) THEN
911  CALL poprealarray(fy1(i, j))
912  v_ad(i, j) = v_ad(i, j) + dt2*fy1_ad(i, j)
913  fy1_ad(i, j) = 0.0
914  ELSE
915  CALL poprealarray(fy1(i, j))
916  temp_ad10 = dt2*fy1_ad(i, j)/sina_u(i, j)
917  v_ad(i, j) = v_ad(i, j) + temp_ad10
918  uc_ad(i, j) = uc_ad(i, j) - cosa_u(i, j)*temp_ad10
919  fy1_ad(i, j) = 0.0
920  END IF
921  END DO
922  END DO
923  ELSE
924  vort_ad = 0.0
925  DO j=jep1,js,-1
926  DO i=ie,is,-1
927  CALL popcontrol(1,branch)
928  IF (branch .EQ. 0) THEN
929  CALL poprealarray(fx(i, j))
930  vort_ad(i+1, j) = vort_ad(i+1, j) + fx_ad(i, j)
931  fx_ad(i, j) = 0.0
932  ELSE
933  CALL poprealarray(fx(i, j))
934  vort_ad(i, j) = vort_ad(i, j) + fx_ad(i, j)
935  fx_ad(i, j) = 0.0
936  END IF
937  CALL poprealarray(fx1(i, j))
938  temp_ad9 = dt2*fx1_ad(i, j)/sina_v(i, j)
939  u_ad(i, j) = u_ad(i, j) + temp_ad9
940  vc_ad(i, j) = vc_ad(i, j) - cosa_v(i, j)*temp_ad9
941  fx1_ad(i, j) = 0.0
942  END DO
943  END DO
944  DO j=je,js,-1
945  DO i=iep1,is,-1
946  CALL popcontrol(1,branch)
947  IF (branch .EQ. 0) THEN
948  CALL poprealarray(fy(i, j))
949  vort_ad(i, j+1) = vort_ad(i, j+1) + fy_ad(i, j)
950  fy_ad(i, j) = 0.0
951  ELSE
952  CALL poprealarray(fy(i, j))
953  vort_ad(i, j) = vort_ad(i, j) + fy_ad(i, j)
954  fy_ad(i, j) = 0.0
955  END IF
956  CALL poprealarray(fy1(i, j))
957  temp_ad8 = dt2*fy1_ad(i, j)/sina_u(i, j)
958  v_ad(i, j) = v_ad(i, j) + temp_ad8
959  uc_ad(i, j) = uc_ad(i, j) - cosa_u(i, j)*temp_ad8
960  fy1_ad(i, j) = 0.0
961  END DO
962  END DO
963  END IF
964  DO j=je+1,js,-1
965  DO i=ie+1,is,-1
966  CALL poprealarray(vort(i, j))
967  vort_ad(i, j) = gridstruct%rarea_c(i, j)*vort_ad(i, j)
968  END DO
969  END DO
970  CALL popcontrol(1,branch)
971  IF (branch .NE. 0) THEN
972  CALL poprealarray(vort(1, npy))
973  fy_ad(0, npy) = fy_ad(0, npy) + vort_ad(1, npy)
974  END IF
975  CALL popcontrol(1,branch)
976  IF (branch .EQ. 0) THEN
977  CALL poprealarray(vort(npx, npy))
978  fy_ad(npx, npy) = fy_ad(npx, npy) - vort_ad(npx, npy)
979  END IF
980  CALL popcontrol(1,branch)
981  IF (branch .EQ. 0) THEN
982  CALL poprealarray(vort(npx, 1))
983  fy_ad(npx, 1) = fy_ad(npx, 1) - vort_ad(npx, 1)
984  END IF
985  CALL popcontrol(1,branch)
986  IF (branch .EQ. 0) THEN
987  CALL poprealarray(vort(1, 1))
988  fy_ad(0, 1) = fy_ad(0, 1) + vort_ad(1, 1)
989  END IF
990  DO j=je+1,js,-1
991  DO i=ie+1,is,-1
992  CALL poprealarray(vort(i, j))
993  fx_ad(i, j-1) = fx_ad(i, j-1) + vort_ad(i, j)
994  fx_ad(i, j) = fx_ad(i, j) - vort_ad(i, j)
995  fy_ad(i, j) = fy_ad(i, j) + vort_ad(i, j)
996  fy_ad(i-1, j) = fy_ad(i-1, j) - vort_ad(i, j)
997  vort_ad(i, j) = 0.0
998  END DO
999  END DO
1000  DO j=je+1,js,-1
1001  DO i=ie+1,is-1,-1
1002  CALL poprealarray(fy(i, j))
1003  vc_ad(i, j) = vc_ad(i, j) + dyc(i, j)*fy_ad(i, j)
1004  fy_ad(i, j) = 0.0
1005  END DO
1006  END DO
1007  DO j=je+1,js-1,-1
1008  DO i=ie+1,is,-1
1009  CALL poprealarray(fx(i, j))
1010  uc_ad(i, j) = uc_ad(i, j) + dxc(i, j)*fx_ad(i, j)
1011  fx_ad(i, j) = 0.0
1012  END DO
1013  END DO
1014  DO j=jep1,js-1,-1
1015  DO i=iep1,is-1,-1
1016  CALL poprealarray(ke(i, j))
1017  temp_ad7 = dt4*ke_ad(i, j)
1018  ua_ad(i, j) = ua_ad(i, j) + ke(i, j)*temp_ad7
1019  va_ad(i, j) = va_ad(i, j) + vort(i, j)*temp_ad7
1020  vort_ad(i, j) = vort_ad(i, j) + va(i, j)*temp_ad7
1021  ke_ad(i, j) = ua(i, j)*temp_ad7
1022  END DO
1023  END DO
1024  cos_sg => gridstruct%cos_sg
1025  CALL popcontrol(1,branch)
1026  IF (branch .EQ. 0) THEN
1027  DO j=jep1,js-1,-1
1028  DO i=iep1,is-1,-1
1029  CALL popcontrol(1,branch)
1030  IF (branch .EQ. 0) THEN
1031  vc_ad(i, j+1) = vc_ad(i, j+1) + vort_ad(i, j)
1032  vort_ad(i, j) = 0.0
1033  ELSE
1034  vc_ad(i, j) = vc_ad(i, j) + vort_ad(i, j)
1035  vort_ad(i, j) = 0.0
1036  END IF
1037  END DO
1038  END DO
1039  DO j=jep1,js-1,-1
1040  DO i=iep1,is-1,-1
1041  CALL popcontrol(1,branch)
1042  IF (branch .EQ. 0) THEN
1043  uc_ad(i+1, j) = uc_ad(i+1, j) + ke_ad(i, j)
1044  ke_ad(i, j) = 0.0
1045  ELSE
1046  uc_ad(i, j) = uc_ad(i, j) + ke_ad(i, j)
1047  ke_ad(i, j) = 0.0
1048  END IF
1049  END DO
1050  END DO
1051  ELSE
1052  DO j=jep1,js-1,-1
1053  DO i=iep1,is-1,-1
1054  CALL popcontrol(3,branch)
1055  IF (branch .LT. 3) THEN
1056  IF (branch .EQ. 0) THEN
1057  vc_ad(i, j+1) = vc_ad(i, j+1) + vort_ad(i, j)
1058  vort_ad(i, j) = 0.0
1059  ELSE IF (branch .EQ. 1) THEN
1060  vc_ad(i, npy) = vc_ad(i, npy) + sin_sg(i, npy-1, 4)*&
1061 & vort_ad(i, j)
1062  u_ad(i, npy) = u_ad(i, npy) + cos_sg(i, npy-1, 4)*vort_ad(&
1063 & i, j)
1064  vort_ad(i, j) = 0.0
1065  ELSE
1066  vc_ad(i, 1) = vc_ad(i, 1) + sin_sg(i, 0, 4)*vort_ad(i, 0)
1067  u_ad(i, 1) = u_ad(i, 1) + cos_sg(i, 0, 4)*vort_ad(i, 0)
1068  vort_ad(i, 0) = 0.0
1069  END IF
1070  ELSE IF (branch .EQ. 3) THEN
1071  vc_ad(i, j) = vc_ad(i, j) + vort_ad(i, j)
1072  vort_ad(i, j) = 0.0
1073  ELSE IF (branch .EQ. 4) THEN
1074  vc_ad(i, npy) = vc_ad(i, npy) + sin_sg(i, npy, 2)*vort_ad(i&
1075 & , j)
1076  u_ad(i, npy) = u_ad(i, npy) + cos_sg(i, npy, 2)*vort_ad(i, j&
1077 & )
1078  vort_ad(i, j) = 0.0
1079  ELSE
1080  vc_ad(i, 1) = vc_ad(i, 1) + sin_sg(i, 1, 2)*vort_ad(i, 1)
1081  u_ad(i, 1) = u_ad(i, 1) + cos_sg(i, 1, 2)*vort_ad(i, 1)
1082  vort_ad(i, 1) = 0.0
1083  END IF
1084  END DO
1085  END DO
1086  DO j=jep1,js-1,-1
1087  DO i=iep1,is-1,-1
1088  CALL popcontrol(3,branch)
1089  IF (branch .LT. 3) THEN
1090  IF (branch .EQ. 0) THEN
1091  uc_ad(i+1, j) = uc_ad(i+1, j) + ke_ad(i, j)
1092  ke_ad(i, j) = 0.0
1093  ELSE IF (branch .EQ. 1) THEN
1094  uc_ad(npx, j) = uc_ad(npx, j) + sin_sg(npx-1, j, 3)*ke_ad(&
1095 & i, j)
1096  v_ad(npx, j) = v_ad(npx, j) + cos_sg(npx-1, j, 3)*ke_ad(i&
1097 & , j)
1098  ke_ad(i, j) = 0.0
1099  ELSE
1100  uc_ad(1, j) = uc_ad(1, j) + sin_sg(0, j, 3)*ke_ad(0, j)
1101  v_ad(1, j) = v_ad(1, j) + cos_sg(0, j, 3)*ke_ad(0, j)
1102  ke_ad(0, j) = 0.0
1103  END IF
1104  ELSE IF (branch .EQ. 3) THEN
1105  uc_ad(i, j) = uc_ad(i, j) + ke_ad(i, j)
1106  ke_ad(i, j) = 0.0
1107  ELSE IF (branch .EQ. 4) THEN
1108  uc_ad(npx, j) = uc_ad(npx, j) + sin_sg(npx, j, 1)*ke_ad(i, j&
1109 & )
1110  v_ad(npx, j) = v_ad(npx, j) + cos_sg(npx, j, 1)*ke_ad(i, j)
1111  ke_ad(i, j) = 0.0
1112  ELSE
1113  uc_ad(1, j) = uc_ad(1, j) + sin_sg(1, j, 1)*ke_ad(1, j)
1114  v_ad(1, j) = v_ad(1, j) + cos_sg(1, j, 1)*ke_ad(1, j)
1115  ke_ad(1, j) = 0.0
1116  END IF
1117  END DO
1118  END DO
1119  END IF
1120  CALL popcontrol(1,branch)
1121  IF (branch .EQ. 0) THEN
1122  DO j=jep1,js-1,-1
1123  DO i=iep1,is-1,-1
1124  CALL poprealarray(ptc(i, j))
1125  temp_ad = ptc_ad(i, j)/delpc(i, j)
1126  temp_ad0 = gridstruct%rarea(i, j)*temp_ad
1127  pt_ad(i, j) = pt_ad(i, j) + delp(i, j)*temp_ad
1128  fx_ad(i, j) = fx_ad(i, j) + temp_ad0
1129  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad0
1130  fy_ad(i, j) = fy_ad(i, j) + temp_ad0
1131  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad0
1132  delpc_ad(i, j) = delpc_ad(i, j) - (pt(i, j)*delp(i, j)+&
1133 & gridstruct%rarea(i, j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i, j&
1134 & +1)))*temp_ad/delpc(i, j)
1135  delp_ad(i, j) = delp_ad(i, j) + delpc_ad(i, j) + pt(i, j)*&
1136 & temp_ad
1137  ptc_ad(i, j) = 0.0
1138  CALL poprealarray(delpc(i, j))
1139  temp_ad1 = gridstruct%rarea(i, j)*delpc_ad(i, j)
1140  fx1_ad(i, j) = fx1_ad(i, j) + temp_ad1
1141  fx1_ad(i+1, j) = fx1_ad(i+1, j) - temp_ad1
1142  fy1_ad(i, j) = fy1_ad(i, j) + temp_ad1
1143  fy1_ad(i, j+1) = fy1_ad(i, j+1) - temp_ad1
1144  delpc_ad(i, j) = 0.0
1145  END DO
1146  END DO
1147  DO j=jep1+1,js-1,-1
1148  DO i=iep1,is-1,-1
1149  CALL poprealarray(fy(i, j))
1150  fy1_ad(i, j) = fy1_ad(i, j) + fy(i, j)*fy_ad(i, j)
1151  fy_ad(i, j) = fy1(i, j)*fy_ad(i, j)
1152  CALL poprealarray(fy1(i, j))
1153  vt_ad(i, j) = vt_ad(i, j) + fy1(i, j)*fy1_ad(i, j)
1154  fy1_ad(i, j) = vt(i, j)*fy1_ad(i, j)
1155  CALL popcontrol(1,branch)
1156  IF (branch .EQ. 0) THEN
1157  pt_ad(i, j-1) = pt_ad(i, j-1) + fy_ad(i, j)
1158  fy_ad(i, j) = 0.0
1159  delp_ad(i, j-1) = delp_ad(i, j-1) + fy1_ad(i, j)
1160  fy1_ad(i, j) = 0.0
1161  ELSE
1162  pt_ad(i, j) = pt_ad(i, j) + fy_ad(i, j)
1163  fy_ad(i, j) = 0.0
1164  delp_ad(i, j) = delp_ad(i, j) + fy1_ad(i, j)
1165  fy1_ad(i, j) = 0.0
1166  END IF
1167  END DO
1168  END DO
1169  fx2_ad = 0.0
1170  ELSE
1171  fy2_ad = 0.0
1172  fx2_ad = 0.0
1173  DO j=je+1,js-1,-1
1174  DO i=ie+1,is-1,-1
1175  temp_ad4 = ptc_ad(i, j)/delpc(i, j)
1176  CALL poprealarray(wc(i, j))
1177  temp_ad2 = wc_ad(i, j)/delpc(i, j)
1178  temp_ad3 = gridstruct%rarea(i, j)*temp_ad2
1179  w_ad(i, j) = w_ad(i, j) + delp(i, j)*temp_ad2
1180  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad3
1181  fx2_ad(i+1, j) = fx2_ad(i+1, j) - temp_ad3
1182  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad3
1183  fy2_ad(i, j+1) = fy2_ad(i, j+1) - temp_ad3
1184  delpc_ad(i, j) = delpc_ad(i, j) - (pt(i, j)*delp(i, j)+&
1185 & gridstruct%rarea(i, j)*(fx(i, j)-fx(i+1, j)+fy(i, j)-fy(i, j&
1186 & +1)))*temp_ad4/delpc(i, j) - (w(i, j)*delp(i, j)+gridstruct%&
1187 & rarea(i, j)*(fx2(i, j)-fx2(i+1, j)+fy2(i, j)-fy2(i, j+1)))*&
1188 & temp_ad2/delpc(i, j)
1189  delp_ad(i, j) = delp_ad(i, j) + pt(i, j)*temp_ad4 + delpc_ad(i&
1190 & , j) + w(i, j)*temp_ad2
1191  wc_ad(i, j) = 0.0
1192  CALL poprealarray(ptc(i, j))
1193  temp_ad5 = gridstruct%rarea(i, j)*temp_ad4
1194  pt_ad(i, j) = pt_ad(i, j) + delp(i, j)*temp_ad4
1195  fx_ad(i, j) = fx_ad(i, j) + temp_ad5
1196  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad5
1197  fy_ad(i, j) = fy_ad(i, j) + temp_ad5
1198  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad5
1199  ptc_ad(i, j) = 0.0
1200  CALL poprealarray(delpc(i, j))
1201  temp_ad6 = gridstruct%rarea(i, j)*delpc_ad(i, j)
1202  fx1_ad(i, j) = fx1_ad(i, j) + temp_ad6
1203  fx1_ad(i+1, j) = fx1_ad(i+1, j) - temp_ad6
1204  fy1_ad(i, j) = fy1_ad(i, j) + temp_ad6
1205  fy1_ad(i, j+1) = fy1_ad(i, j+1) - temp_ad6
1206  delpc_ad(i, j) = 0.0
1207  END DO
1208  END DO
1209  DO j=je+2,js-1,-1
1210  DO i=ie+1,is-1,-1
1211  CALL poprealarray(fy2(i, j))
1212  CALL poprealarray(fy(i, j))
1213  fy1_ad(i, j) = fy1_ad(i, j) + fy(i, j)*fy_ad(i, j) + fy2(i, j)&
1214 & *fy2_ad(i, j)
1215  fy2_ad(i, j) = fy1(i, j)*fy2_ad(i, j)
1216  fy_ad(i, j) = fy1(i, j)*fy_ad(i, j)
1217  CALL poprealarray(fy1(i, j))
1218  vt_ad(i, j) = vt_ad(i, j) + fy1(i, j)*fy1_ad(i, j)
1219  fy1_ad(i, j) = vt(i, j)*fy1_ad(i, j)
1220  CALL popcontrol(1,branch)
1221  IF (branch .EQ. 0) THEN
1222  w_ad(i, j-1) = w_ad(i, j-1) + fy2_ad(i, j)
1223  fy2_ad(i, j) = 0.0
1224  pt_ad(i, j-1) = pt_ad(i, j-1) + fy_ad(i, j)
1225  fy_ad(i, j) = 0.0
1226  delp_ad(i, j-1) = delp_ad(i, j-1) + fy1_ad(i, j)
1227  fy1_ad(i, j) = 0.0
1228  ELSE
1229  w_ad(i, j) = w_ad(i, j) + fy2_ad(i, j)
1230  fy2_ad(i, j) = 0.0
1231  pt_ad(i, j) = pt_ad(i, j) + fy_ad(i, j)
1232  fy_ad(i, j) = 0.0
1233  delp_ad(i, j) = delp_ad(i, j) + fy1_ad(i, j)
1234  fy1_ad(i, j) = 0.0
1235  END IF
1236  END DO
1237  END DO
1238  CALL popcontrol(1,branch)
1239  IF (branch .NE. 0) CALL fill_4corners_bwd(w, w_ad, 2, bd, npx, npy&
1240 & , sw_corner, se_corner, &
1241 & ne_corner, nw_corner)
1242  END IF
1243  CALL popcontrol(1,branch)
1244  IF (branch .EQ. 0) CALL fill2_4corners_bwd(delp, delp_ad, pt, pt_ad&
1245 & , 2, bd, npx, npy, sw_corner, &
1246 & se_corner, ne_corner, nw_corner&
1247 & )
1248  CALL popcontrol(1,branch)
1249  IF (branch .EQ. 0) THEN
1250  DO j=jep1,js-1,-1
1251  DO i=ie+2,is-1,-1
1252  CALL poprealarray(fx(i, j))
1253  fx1_ad(i, j) = fx1_ad(i, j) + fx(i, j)*fx_ad(i, j)
1254  fx_ad(i, j) = fx1(i, j)*fx_ad(i, j)
1255  CALL poprealarray(fx1(i, j))
1256  ut_ad(i, j) = ut_ad(i, j) + fx1(i, j)*fx1_ad(i, j)
1257  fx1_ad(i, j) = ut(i, j)*fx1_ad(i, j)
1258  CALL popcontrol(1,branch)
1259  IF (branch .EQ. 0) THEN
1260  pt_ad(i-1, j) = pt_ad(i-1, j) + fx_ad(i, j)
1261  fx_ad(i, j) = 0.0
1262  delp_ad(i-1, j) = delp_ad(i-1, j) + fx1_ad(i, j)
1263  fx1_ad(i, j) = 0.0
1264  ELSE
1265  pt_ad(i, j) = pt_ad(i, j) + fx_ad(i, j)
1266  fx_ad(i, j) = 0.0
1267  delp_ad(i, j) = delp_ad(i, j) + fx1_ad(i, j)
1268  fx1_ad(i, j) = 0.0
1269  END IF
1270  END DO
1271  END DO
1272  ELSE
1273  DO j=je+1,js-1,-1
1274  DO i=ie+2,is-1,-1
1275  CALL poprealarray(fx2(i, j))
1276  CALL poprealarray(fx(i, j))
1277  fx1_ad(i, j) = fx1_ad(i, j) + fx(i, j)*fx_ad(i, j) + fx2(i, j)&
1278 & *fx2_ad(i, j)
1279  fx2_ad(i, j) = fx1(i, j)*fx2_ad(i, j)
1280  fx_ad(i, j) = fx1(i, j)*fx_ad(i, j)
1281  CALL poprealarray(fx1(i, j))
1282  ut_ad(i, j) = ut_ad(i, j) + fx1(i, j)*fx1_ad(i, j)
1283  fx1_ad(i, j) = ut(i, j)*fx1_ad(i, j)
1284  CALL popcontrol(1,branch)
1285  IF (branch .EQ. 0) THEN
1286  w_ad(i-1, j) = w_ad(i-1, j) + fx2_ad(i, j)
1287  fx2_ad(i, j) = 0.0
1288  pt_ad(i-1, j) = pt_ad(i-1, j) + fx_ad(i, j)
1289  fx_ad(i, j) = 0.0
1290  delp_ad(i-1, j) = delp_ad(i-1, j) + fx1_ad(i, j)
1291  fx1_ad(i, j) = 0.0
1292  ELSE
1293  w_ad(i, j) = w_ad(i, j) + fx2_ad(i, j)
1294  fx2_ad(i, j) = 0.0
1295  pt_ad(i, j) = pt_ad(i, j) + fx_ad(i, j)
1296  fx_ad(i, j) = 0.0
1297  delp_ad(i, j) = delp_ad(i, j) + fx1_ad(i, j)
1298  fx1_ad(i, j) = 0.0
1299  END IF
1300  END DO
1301  END DO
1302  CALL popcontrol(1,branch)
1303  IF (branch .NE. 0) CALL fill_4corners_bwd(w, w_ad, 1, bd, npx, npy&
1304 & , sw_corner, se_corner, &
1305 & ne_corner, nw_corner)
1306  END IF
1307  CALL popcontrol(1,branch)
1308  IF (branch .EQ. 0) CALL fill2_4corners_bwd(delp, delp_ad, pt, pt_ad&
1309 & , 1, bd, npx, npy, sw_corner, &
1310 & se_corner, ne_corner, nw_corner&
1311 & )
1312  dx => gridstruct%dx
1313  DO j=je+2,js-1,-1
1314  DO i=iep1,is-1,-1
1315  CALL popcontrol(1,branch)
1316  IF (branch .EQ. 0) THEN
1317  CALL poprealarray(vt(i, j))
1318  vt_ad(i, j) = dx(i, j)*sin_sg(i, j, 2)*dt2*vt_ad(i, j)
1319  ELSE
1320  CALL poprealarray(vt(i, j))
1321  vt_ad(i, j) = dx(i, j)*sin_sg(i, j-1, 4)*dt2*vt_ad(i, j)
1322  END IF
1323  END DO
1324  END DO
1325  DO j=jep1,js-1,-1
1326  DO i=iep1+1,is-1,-1
1327  CALL popcontrol(1,branch)
1328  IF (branch .EQ. 0) THEN
1329  CALL poprealarray(ut(i, j))
1330  ut_ad(i, j) = dy(i, j)*sin_sg(i, j, 1)*dt2*ut_ad(i, j)
1331  ELSE
1332  CALL poprealarray(ut(i, j))
1333  ut_ad(i, j) = dy(i, j)*sin_sg(i-1, j, 3)*dt2*ut_ad(i, j)
1334  END IF
1335  END DO
1336  END DO
1337  CALL popcontrol(2,branch)
1338  IF (branch .NE. 0) THEN
1339  IF (branch .EQ. 1) THEN
1340  CALL divergence_corner_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, &
1341 & va_ad, divg_d, divg_d_ad, gridstruct, &
1342 & flagstruct, bd)
1343  ELSE
1344  CALL divergence_corner_nest_bwd(u, u_ad, v, v_ad, ua, ua_ad, va&
1345 & , va_ad, divg_d, divg_d_ad, gridstruct&
1346 & , flagstruct, bd)
1347  divg_d_ad = 0.0
1348  END IF
1349  END IF
1350  CALL d2a2c_vect_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, va_ad, uc, &
1351 & uc_ad, vc, vc_ad, ut, ut_ad, vt, vt_ad, dord4, &
1352 & gridstruct, bd, npx, npy, nested, flagstruct%grid_type&
1353 & )
1354  END SUBROUTINE c_sw_bwd
1355  SUBROUTINE c_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut&
1356 & , vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, &
1357 & flagstruct)
1358  IMPLICIT NONE
1359  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1360  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
1361 & , vc
1362  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
1363 & , uc
1364  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
1365 & , pt, ua, va, ut, vt
1366  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
1367  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
1368 & , ptc, wc
1369  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
1370 & divg_d
1371  INTEGER, INTENT(IN) :: nord
1372  REAL, INTENT(IN) :: dt2
1373  LOGICAL, INTENT(IN) :: hydrostatic
1374  LOGICAL, INTENT(IN) :: dord4
1375  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1376  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
1377 ! Local:
1378  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
1379  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+1) :: vort, ke
1380  REAL, DIMENSION(bd%is-1:bd%ie+2, bd%js-1:bd%je+1) :: fx, fx1, fx2
1381  REAL, DIMENSION(bd%is-1:bd%ie+1, bd%js-1:bd%je+2) :: fy, fy1, fy2
1382  REAL :: dt4
1383  INTEGER :: i, j, is2, ie1
1384  INTEGER :: iep1, jep1
1385  INTEGER :: is, ie, js, je
1386  INTEGER :: isd, ied, jsd, jed
1387  INTEGER :: npx, npy
1388  LOGICAL :: nested
1389  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
1390  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
1391  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
1392  REAL, DIMENSION(:, :), POINTER :: dx, dy, dxc, dyc
1393  is = bd%is
1394  ie = bd%ie
1395  js = bd%js
1396  je = bd%je
1397  isd = bd%isd
1398  ied = bd%ied
1399  jsd = bd%jsd
1400  jed = bd%jed
1401  npx = flagstruct%npx
1402  npy = flagstruct%npy
1403  nested = gridstruct%nested
1404  sin_sg => gridstruct%sin_sg
1405  cos_sg => gridstruct%cos_sg
1406  cosa_u => gridstruct%cosa_u
1407  cosa_v => gridstruct%cosa_v
1408  sina_u => gridstruct%sina_u
1409  sina_v => gridstruct%sina_v
1410  dx => gridstruct%dx
1411  dy => gridstruct%dy
1412  dxc => gridstruct%dxc
1413  dyc => gridstruct%dyc
1414  sw_corner = gridstruct%sw_corner
1415  se_corner = gridstruct%se_corner
1416  nw_corner = gridstruct%nw_corner
1417  ne_corner = gridstruct%ne_corner
1418  iep1 = ie + 1
1419  jep1 = je + 1
1420  CALL d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd&
1421 & , npx, npy, nested, flagstruct%grid_type)
1422  IF (nord .GT. 0) THEN
1423  IF (nested) THEN
1424  CALL divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, &
1425 & flagstruct, bd)
1426  ELSE
1427  CALL divergence_corner(u, v, ua, va, divg_d, gridstruct, &
1428 & flagstruct, bd)
1429  END IF
1430  END IF
1431  DO j=js-1,jep1
1432  DO i=is-1,iep1+1
1433  IF (ut(i, j) .GT. 0.) THEN
1434  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i-1, j, 3)
1435  ELSE
1436  ut(i, j) = dt2*ut(i, j)*dy(i, j)*sin_sg(i, j, 1)
1437  END IF
1438  END DO
1439  END DO
1440  DO j=js-1,je+2
1441  DO i=is-1,iep1
1442  IF (vt(i, j) .GT. 0.) THEN
1443  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j-1, 4)
1444  ELSE
1445  vt(i, j) = dt2*vt(i, j)*dx(i, j)*sin_sg(i, j, 2)
1446  END IF
1447  END DO
1448  END DO
1449 !----------------
1450 ! Transport delp:
1451 !----------------
1452 ! Xdir:
1453  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
1454 & fill2_4corners(delp, pt, 1, bd, npx, npy, sw_corner, se_corner, &
1455 & ne_corner, nw_corner)
1456  IF (hydrostatic) THEN
1457  DO j=js-1,jep1
1458  DO i=is-1,ie+2
1459  IF (ut(i, j) .GT. 0.) THEN
1460  fx1(i, j) = delp(i-1, j)
1461  fx(i, j) = pt(i-1, j)
1462  ELSE
1463  fx1(i, j) = delp(i, j)
1464  fx(i, j) = pt(i, j)
1465  END IF
1466  fx1(i, j) = ut(i, j)*fx1(i, j)
1467  fx(i, j) = fx1(i, j)*fx(i, j)
1468  END DO
1469  END DO
1470  ELSE
1471  IF (flagstruct%grid_type .LT. 3) CALL fill_4corners(w, 1, bd, npx&
1472 & , npy, sw_corner, &
1473 & se_corner, ne_corner&
1474 & , nw_corner)
1475  DO j=js-1,je+1
1476  DO i=is-1,ie+2
1477  IF (ut(i, j) .GT. 0.) THEN
1478  fx1(i, j) = delp(i-1, j)
1479  fx(i, j) = pt(i-1, j)
1480  fx2(i, j) = w(i-1, j)
1481  ELSE
1482  fx1(i, j) = delp(i, j)
1483  fx(i, j) = pt(i, j)
1484  fx2(i, j) = w(i, j)
1485  END IF
1486  fx1(i, j) = ut(i, j)*fx1(i, j)
1487  fx(i, j) = fx1(i, j)*fx(i, j)
1488  fx2(i, j) = fx1(i, j)*fx2(i, j)
1489  END DO
1490  END DO
1491  END IF
1492 ! Ydir:
1493  IF (flagstruct%grid_type .LT. 3 .AND. (.NOT.nested)) CALL &
1494 & fill2_4corners(delp, pt, 2, bd, npx, npy, sw_corner, se_corner, &
1495 & ne_corner, nw_corner)
1496  IF (hydrostatic) THEN
1497  DO j=js-1,jep1+1
1498  DO i=is-1,iep1
1499  IF (vt(i, j) .GT. 0.) THEN
1500  fy1(i, j) = delp(i, j-1)
1501  fy(i, j) = pt(i, j-1)
1502  ELSE
1503  fy1(i, j) = delp(i, j)
1504  fy(i, j) = pt(i, j)
1505  END IF
1506  fy1(i, j) = vt(i, j)*fy1(i, j)
1507  fy(i, j) = fy1(i, j)*fy(i, j)
1508  END DO
1509  END DO
1510  DO j=js-1,jep1
1511  DO i=is-1,iep1
1512  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
1513 & fy1(i, j+1)))*gridstruct%rarea(i, j)
1514  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
1515 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
1516  END DO
1517  END DO
1518  ELSE
1519  IF (flagstruct%grid_type .LT. 3) CALL fill_4corners(w, 2, bd, npx&
1520 & , npy, sw_corner, &
1521 & se_corner, ne_corner&
1522 & , nw_corner)
1523  DO j=js-1,je+2
1524  DO i=is-1,ie+1
1525  IF (vt(i, j) .GT. 0.) THEN
1526  fy1(i, j) = delp(i, j-1)
1527  fy(i, j) = pt(i, j-1)
1528  fy2(i, j) = w(i, j-1)
1529  ELSE
1530  fy1(i, j) = delp(i, j)
1531  fy(i, j) = pt(i, j)
1532  fy2(i, j) = w(i, j)
1533  END IF
1534  fy1(i, j) = vt(i, j)*fy1(i, j)
1535  fy(i, j) = fy1(i, j)*fy(i, j)
1536  fy2(i, j) = fy1(i, j)*fy2(i, j)
1537  END DO
1538  END DO
1539  DO j=js-1,je+1
1540  DO i=is-1,ie+1
1541  delpc(i, j) = delp(i, j) + (fx1(i, j)-fx1(i+1, j)+(fy1(i, j)-&
1542 & fy1(i, j+1)))*gridstruct%rarea(i, j)
1543  ptc(i, j) = (pt(i, j)*delp(i, j)+(fx(i, j)-fx(i+1, j)+(fy(i, j&
1544 & )-fy(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
1545  wc(i, j) = (w(i, j)*delp(i, j)+(fx2(i, j)-fx2(i+1, j)+(fy2(i, &
1546 & j)-fy2(i, j+1)))*gridstruct%rarea(i, j))/delpc(i, j)
1547  END DO
1548  END DO
1549  END IF
1550 !------------
1551 ! Compute KE:
1552 !------------
1553 !Since uc = u*, i.e. the covariant wind perpendicular to the face edge, if we want to compute kinetic energy we will need the tru
1554 !e coordinate-parallel covariant wind, computed through u = uc*sina + v*cosa.
1555 !Use the alpha for the cell KE is being computed in.
1556 !!! TO DO:
1557 !!! Need separate versions for nesting/single-tile
1558 !!! and for cubed-sphere
1559  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
1560  DO j=js-1,jep1
1561  DO i=is-1,iep1
1562  IF (ua(i, j) .GT. 0.) THEN
1563  ke(i, j) = uc(i, j)
1564  ELSE
1565  ke(i, j) = uc(i+1, j)
1566  END IF
1567  END DO
1568  END DO
1569  DO j=js-1,jep1
1570  DO i=is-1,iep1
1571  IF (va(i, j) .GT. 0.) THEN
1572  vort(i, j) = vc(i, j)
1573  ELSE
1574  vort(i, j) = vc(i, j+1)
1575  END IF
1576  END DO
1577  END DO
1578  ELSE
1579  DO j=js-1,jep1
1580  DO i=is-1,iep1
1581  IF (ua(i, j) .GT. 0.) THEN
1582  IF (i .EQ. 1) THEN
1583  ke(1, j) = uc(1, j)*sin_sg(1, j, 1) + v(1, j)*cos_sg(1, j&
1584 & , 1)
1585  ELSE IF (i .EQ. npx) THEN
1586  ke(i, j) = uc(npx, j)*sin_sg(npx, j, 1) + v(npx, j)*cos_sg&
1587 & (npx, j, 1)
1588  ELSE
1589  ke(i, j) = uc(i, j)
1590  END IF
1591  ELSE IF (i .EQ. 0) THEN
1592  ke(0, j) = uc(1, j)*sin_sg(0, j, 3) + v(1, j)*cos_sg(0, j, 3&
1593 & )
1594  ELSE IF (i .EQ. npx - 1) THEN
1595  ke(i, j) = uc(npx, j)*sin_sg(npx-1, j, 3) + v(npx, j)*cos_sg&
1596 & (npx-1, j, 3)
1597  ELSE
1598  ke(i, j) = uc(i+1, j)
1599  END IF
1600  END DO
1601  END DO
1602  DO j=js-1,jep1
1603  DO i=is-1,iep1
1604  IF (va(i, j) .GT. 0.) THEN
1605  IF (j .EQ. 1) THEN
1606  vort(i, 1) = vc(i, 1)*sin_sg(i, 1, 2) + u(i, 1)*cos_sg(i, &
1607 & 1, 2)
1608  ELSE IF (j .EQ. npy) THEN
1609  vort(i, j) = vc(i, npy)*sin_sg(i, npy, 2) + u(i, npy)*&
1610 & cos_sg(i, npy, 2)
1611  ELSE
1612  vort(i, j) = vc(i, j)
1613  END IF
1614  ELSE IF (j .EQ. 0) THEN
1615  vort(i, 0) = vc(i, 1)*sin_sg(i, 0, 4) + u(i, 1)*cos_sg(i, 0&
1616 & , 4)
1617  ELSE IF (j .EQ. npy - 1) THEN
1618  vort(i, j) = vc(i, npy)*sin_sg(i, npy-1, 4) + u(i, npy)*&
1619 & cos_sg(i, npy-1, 4)
1620  ELSE
1621  vort(i, j) = vc(i, j+1)
1622  END IF
1623  END DO
1624  END DO
1625  END IF
1626  dt4 = 0.5*dt2
1627  DO j=js-1,jep1
1628  DO i=is-1,iep1
1629  ke(i, j) = dt4*(ua(i, j)*ke(i, j)+va(i, j)*vort(i, j))
1630  END DO
1631  END DO
1632 !------------------------------
1633 ! Compute circulation on C grid
1634 !------------------------------
1635 ! To consider using true co-variant winds at face edges?
1636  DO j=js-1,je+1
1637  DO i=is,ie+1
1638  fx(i, j) = uc(i, j)*dxc(i, j)
1639  END DO
1640  END DO
1641  DO j=js,je+1
1642  DO i=is-1,ie+1
1643  fy(i, j) = vc(i, j)*dyc(i, j)
1644  END DO
1645  END DO
1646  DO j=js,je+1
1647  DO i=is,ie+1
1648  vort(i, j) = fx(i, j-1) - fx(i, j) + (fy(i, j)-fy(i-1, j))
1649  END DO
1650  END DO
1651 ! Remove the extra term at the corners:
1652  IF (sw_corner) vort(1, 1) = vort(1, 1) + fy(0, 1)
1653  IF (se_corner) vort(npx, 1) = vort(npx, 1) - fy(npx, 1)
1654  IF (ne_corner) vort(npx, npy) = vort(npx, npy) - fy(npx, npy)
1655  IF (nw_corner) vort(1, npy) = vort(1, npy) + fy(0, npy)
1656 !----------------------------
1657 ! Compute absolute vorticity
1658 !----------------------------
1659  DO j=js,je+1
1660  DO i=is,ie+1
1661  vort(i, j) = gridstruct%fc(i, j) + gridstruct%rarea_c(i, j)*vort&
1662 & (i, j)
1663  END DO
1664  END DO
1665 !----------------------------------
1666 ! Transport absolute vorticity:
1667 !----------------------------------
1668 !To go from v to contravariant v at the edges, we divide by sin_sg;
1669 ! but we then must multiply by sin_sg to get the proper flux.
1670 ! These cancel, leaving us with fy1 = dt2*v at the edges.
1671 ! (For the same reason we only divide by sin instead of sin**2 in the interior)
1672 !! TO DO: separate versions for nesting/single-tile and cubed-sphere
1673  IF (nested .OR. flagstruct%grid_type .GE. 3) THEN
1674  DO j=js,je
1675  DO i=is,iep1
1676  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
1677  IF (fy1(i, j) .GT. 0.) THEN
1678  fy(i, j) = vort(i, j)
1679  ELSE
1680  fy(i, j) = vort(i, j+1)
1681  END IF
1682  END DO
1683  END DO
1684  DO j=js,jep1
1685  DO i=is,ie
1686  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
1687  IF (fx1(i, j) .GT. 0.) THEN
1688  fx(i, j) = vort(i, j)
1689  ELSE
1690  fx(i, j) = vort(i+1, j)
1691  END IF
1692  END DO
1693  END DO
1694  ELSE
1695  DO j=js,je
1696 !DEC$ VECTOR ALWAYS
1697  DO i=is,iep1
1698  IF (i .EQ. 1 .OR. i .EQ. npx) THEN
1699  fy1(i, j) = dt2*v(i, j)
1700  ELSE
1701  fy1(i, j) = dt2*(v(i, j)-uc(i, j)*cosa_u(i, j))/sina_u(i, j)
1702  END IF
1703  IF (fy1(i, j) .GT. 0.) THEN
1704  fy(i, j) = vort(i, j)
1705  ELSE
1706  fy(i, j) = vort(i, j+1)
1707  END IF
1708  END DO
1709  END DO
1710  DO j=js,jep1
1711  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
1712 !DEC$ VECTOR ALWAYS
1713  DO i=is,ie
1714  fx1(i, j) = dt2*u(i, j)
1715  IF (fx1(i, j) .GT. 0.) THEN
1716  fx(i, j) = vort(i, j)
1717  ELSE
1718  fx(i, j) = vort(i+1, j)
1719  END IF
1720  END DO
1721  ELSE
1722 !DEC$ VECTOR ALWAYS
1723  DO i=is,ie
1724  fx1(i, j) = dt2*(u(i, j)-vc(i, j)*cosa_v(i, j))/sina_v(i, j)
1725  IF (fx1(i, j) .GT. 0.) THEN
1726  fx(i, j) = vort(i, j)
1727  ELSE
1728  fx(i, j) = vort(i+1, j)
1729  END IF
1730  END DO
1731  END IF
1732  END DO
1733  END IF
1734 ! Update time-centered winds on the C-Grid
1735  DO j=js,je
1736  DO i=is,iep1
1737  uc(i, j) = uc(i, j) + fy1(i, j)*fy(i, j) + gridstruct%rdxc(i, j)&
1738 & *(ke(i-1, j)-ke(i, j))
1739  END DO
1740  END DO
1741  DO j=js,jep1
1742  DO i=is,ie
1743  vc(i, j) = vc(i, j) - fx1(i, j)*fx(i, j) + gridstruct%rdyc(i, j)&
1744 & *(ke(i, j-1)-ke(i, j))
1745  END DO
1746  END DO
1747  END SUBROUTINE c_sw
1748 ! Differentiation of d_sw in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b
1749 !_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_mod.p_
1750 !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.mix_dp
1751 !dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super
1752 ! fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_g
1753 !rid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
1754 !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_mapz
1755 !_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_map
1756 !z_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_restart
1757 !_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_z ma
1758 !in_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_mod.Ri
1759 !em_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.SIM3
1760 !p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_
1761 !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.d2a2c_ve
1762 !ct 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 sw_
1763 !core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.co
1764 !py_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.g
1765 !reat_circle_dist sw_core_mod.edge_interpolate4)):
1766 ! gradient of useful results: yfx_adv q crx_adv u v w delp
1767 ! ua xfx_adv uc ptc xflux cry_adv delpc va vc yflux
1768 ! divg_d z_rat heat_source pt cx cy dpx
1769 ! with respect to varying inputs: yfx_adv q crx_adv u v w delp
1770 ! ua xfx_adv uc ptc xflux cry_adv delpc va vc yflux
1771 ! divg_d z_rat heat_source pt cx cy dpx
1772 ! d_sw :: D-Grid Shallow Water Routine
1773  SUBROUTINE d_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, &
1774 & divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, &
1775 & q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, &
1776 & inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, &
1777 & nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t&
1778 & , d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, &
1779 & hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, &
1780 & nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, &
1781 & d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
1782  !USE ISO_C_BINDING
1783  !USE ADMM_TAPENADE_INTERFACE
1784  IMPLICIT NONE
1785  INTEGER, INTENT(IN) :: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
1786 ! nord=1 divergence damping; (del-4) or 3 (del-8)
1787  INTEGER, INTENT(IN) :: nord
1788 ! vorticity damping
1789  INTEGER, INTENT(IN) :: nord_v
1790 ! vertical velocity
1791  INTEGER, INTENT(IN) :: nord_w
1792 ! pt
1793  INTEGER, INTENT(IN) :: nord_t
1794  INTEGER, INTENT(IN) :: sphum, nq, k, km
1795  REAL, INTENT(IN) :: dt, dddmp, d2_bg, d4_bg, d_con
1796  REAL, INTENT(IN) :: zvir
1797  REAL, INTENT(IN) :: damp_v, damp_w, damp_t, kgb
1798  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1799  INTEGER, INTENT(IN) :: hord_tr_pert, hord_mt_pert, hord_vt_pert, &
1800 & hord_tm_pert, hord_dp_pert, nord_pert, nord_v_pert, nord_w_pert, &
1801 & nord_t_pert
1802  LOGICAL, INTENT(IN) :: split_damp
1803  REAL, INTENT(IN) :: dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert&
1804 & , damp_w_pert, damp_t_pert
1805 ! divergence
1806  REAL, INTENT(INOUT) :: divg_d(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1807  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: z_rat
1808  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
1809 & , pt, ua, va
1810  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
1811  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
1812 & q_con
1813  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
1814 & , vc
1815  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
1816 & , uc
1817  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
1818  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc
1819  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: heat_source
1820  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
1821 & dpx
1822 ! The flux capacitors:
1823  REAL, INTENT(INOUT) :: xflux(bd%is:bd%ie+1, bd%js:bd%je)
1824  REAL, INTENT(INOUT) :: yflux(bd%is:bd%ie, bd%js:bd%je+1)
1825 !------------------------
1826  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed)
1827  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1)
1828  LOGICAL, INTENT(IN) :: hydrostatic
1829  LOGICAL, INTENT(IN) :: inline_q
1830  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed) :: crx_adv, xfx_adv
1831  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1) :: cry_adv, yfx_adv
1832  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1833  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
1834 ! Local:
1835  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
1836  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1837  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1838 !---
1839  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1840  REAL :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1841 ! work array
1842  REAL :: dw(bd%is:bd%ie, bd%js:bd%je)
1843 !---
1844  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub, vb
1845 ! work array
1846  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
1847 ! needs this for corner_comm
1848  REAL :: ke(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1849 ! Vorticity
1850  REAL :: vort(bd%isd:bd%ied, bd%jsd:bd%jed)
1851 ! 1-D X-direction Fluxes
1852  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
1853 ! 1-D Y-direction Fluxes
1854  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
1855  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
1856  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
1857  REAL :: gx(bd%is:bd%ie+1, bd%js:bd%je)
1858 ! work Y-dir flux array
1859  REAL :: gy(bd%is:bd%ie, bd%js:bd%je+1)
1860  LOGICAL :: fill_c
1861  REAL :: dt2, dt4, dt5, dt6
1862  REAL :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
1863  REAL :: u_lon
1864  INTEGER :: i, j, is2, ie1, js2, je1, n, nt, n2, iq
1865  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
1866  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
1867  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
1868  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
1869  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
1870  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
1871  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
1872 & , rdx, rdy
1873  INTEGER :: is, ie, js, je
1874  INTEGER :: isd, ied, jsd, jed
1875  INTEGER :: npx, npy
1876  LOGICAL :: nested
1877  REAL :: delp_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1878  REAL :: pt_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1879  REAL :: vort_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1880  REAL :: wk_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1881  REAL :: delpc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1882  REAL :: ptc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
1883  REAL :: ke_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1884  REAL :: vc_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1885  REAL :: uc_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1886  REAL :: divg_d_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
1887  REAL :: ut_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
1888  REAL :: vt_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
1889  INTRINSIC max
1890  INTRINSIC min
1891  INTRINSIC abs
1892  INTEGER :: max1
1893  INTEGER :: max2
1894  INTEGER :: max3
1895  INTEGER :: max4
1896  REAL :: abs0
1897  INTEGER :: min1
1898  INTEGER :: min2
1899  INTEGER :: min3
1900  INTEGER :: min4
1901 
1902  ut = 0.0
1903  vt = 0.0
1904  fx2 = 0.0
1905  fy2 = 0.0
1906  dw = 0.0
1907  ub = 0.0
1908  vb = 0.0
1909  wk = 0.0
1910  ke = 0.0
1911  vort = 0.0
1912  fx = 0.0
1913  fy = 0.0
1914  ra_x = 0.0
1915  ra_y = 0.0
1916  gx = 0.0
1917  gy = 0.0
1918  dt2 = 0.0
1919  dt4 = 0.0
1920  dt5 = 0.0
1921  dt6 = 0.0
1922  damp = 0.0
1923  damp2 = 0.0
1924  damp4 = 0.0
1925  dd8 = 0.0
1926  u2 = 0.0
1927  v2 = 0.0
1928  du2 = 0.0
1929  dv2 = 0.0
1930  u_lon = 0.0
1931  is2 = 0
1932  ie1 = 0
1933  js2 = 0
1934  je1 = 0
1935  n = 0
1936  nt = 0
1937  n2 = 0
1938  iq = 0
1939  is = 0
1940  ie = 0
1941  js = 0
1942  je = 0
1943  isd = 0
1944  ied = 0
1945  jsd = 0
1946  jed = 0
1947  npx = 0
1948  npy = 0
1949  max1 = 0
1950  max2 = 0
1951  max3 = 0
1952  max4 = 0
1953  abs0 = 0.0
1954  min1 = 0
1955  min2 = 0
1956  min3 = 0
1957  min4 = 0
1958 
1959  is = bd%is
1960  ie = bd%ie
1961  js = bd%js
1962  je = bd%je
1963  isd = bd%isd
1964  ied = bd%ied
1965  jsd = bd%jsd
1966  jed = bd%jed
1967  npx = flagstruct%npx
1968  npy = flagstruct%npy
1969  nested = gridstruct%nested
1970  area => gridstruct%area
1971  rarea => gridstruct%rarea
1972  sin_sg => gridstruct%sin_sg
1973  cosa_u => gridstruct%cosa_u
1974  cosa_v => gridstruct%cosa_v
1975  cosa_s => gridstruct%cosa_s
1976  rsin_u => gridstruct%rsin_u
1977  rsin_v => gridstruct%rsin_v
1978  rsina => gridstruct%rsina
1979  f0 => gridstruct%f0
1980  rsin2 => gridstruct%rsin2
1981  cosa => gridstruct%cosa
1982  dx => gridstruct%dx
1983  dy => gridstruct%dy
1984  rdxa => gridstruct%rdxa
1985  rdya => gridstruct%rdya
1986  rdx => gridstruct%rdx
1987  rdy => gridstruct%rdy
1988  sw_corner = gridstruct%sw_corner
1989  se_corner = gridstruct%se_corner
1990  nw_corner = gridstruct%nw_corner
1991  ne_corner = gridstruct%ne_corner
1992 ! end grid_type choices
1993  IF (flagstruct%grid_type .LT. 3) THEN
1994 !!! TO DO: separate versions for nesting and for cubed-sphere
1995  IF (nested) THEN
1996  DO j=jsd,jed
1997  DO i=is-1,ie+2
1998  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j)+&
1999 & vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
2000  END DO
2001  END DO
2002  DO j=js-1,je+2
2003  DO i=isd,ied
2004  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1, j&
2005 & -1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
2006  END DO
2007  END DO
2008  CALL pushcontrol(1,0)
2009  ELSE
2010  DO j=jsd,jed
2011  IF (j .NE. 0 .AND. j .NE. 1 .AND. j .NE. npy - 1 .AND. j .NE. &
2012 & npy) THEN
2013  DO i=is-1,ie+2
2014  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j&
2015 & )+vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
2016  END DO
2017  CALL pushcontrol(1,1)
2018  ELSE
2019  CALL pushcontrol(1,0)
2020  END IF
2021  END DO
2022  DO j=js-1,je+2
2023  IF (j .NE. 1 .AND. j .NE. npy) THEN
2024  DO i=isd,ied
2025  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1&
2026 & , j-1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
2027  END DO
2028  CALL pushcontrol(1,1)
2029  ELSE
2030  CALL pushcontrol(1,0)
2031  END IF
2032  END DO
2033  CALL pushcontrol(1,1)
2034  END IF
2035 !.not. nested
2036  IF (.NOT.nested) THEN
2037 ! West face
2038 ! West edge:
2039  IF (is .EQ. 1) THEN
2040  DO j=jsd,jed
2041  IF (uc(1, j)*dt .GT. 0.) THEN
2042  ut(1, j) = uc(1, j)/sin_sg(0, j, 3)
2043  CALL pushcontrol(1,1)
2044  ELSE
2045  ut(1, j) = uc(1, j)/sin_sg(1, j, 1)
2046  CALL pushcontrol(1,0)
2047  END IF
2048  END DO
2049  IF (3 .LT. js) THEN
2050  max1 = js
2051  ELSE
2052  max1 = 3
2053  END IF
2054  IF (npy - 2 .GT. je + 1) THEN
2055  min1 = je + 1
2056  ELSE
2057  min1 = npy - 2
2058  END IF
2059  DO j=max1,min1
2060  vt(0, j) = vc(0, j) - 0.25*cosa_v(0, j)*(ut(0, j-1)+ut(1, j-&
2061 & 1)+ut(0, j)+ut(1, j))
2062  vt(1, j) = vc(1, j) - 0.25*cosa_v(1, j)*(ut(1, j-1)+ut(2, j-&
2063 & 1)+ut(1, j)+ut(2, j))
2064  END DO
2065  CALL pushcontrol(1,0)
2066  ELSE
2067  CALL pushcontrol(1,1)
2068  END IF
2069 ! East edge:
2070  IF (ie + 1 .EQ. npx) THEN
2071  DO j=jsd,jed
2072  IF (uc(npx, j)*dt .GT. 0.) THEN
2073  ut(npx, j) = uc(npx, j)/sin_sg(npx-1, j, 3)
2074  CALL pushcontrol(1,1)
2075  ELSE
2076  ut(npx, j) = uc(npx, j)/sin_sg(npx, j, 1)
2077  CALL pushcontrol(1,0)
2078  END IF
2079  END DO
2080  IF (3 .LT. js) THEN
2081  max2 = js
2082  ELSE
2083  max2 = 3
2084  END IF
2085  IF (npy - 2 .GT. je + 1) THEN
2086  min2 = je + 1
2087  ELSE
2088  min2 = npy - 2
2089  END IF
2090  DO j=max2,min2
2091  vt(npx-1, j) = vc(npx-1, j) - 0.25*cosa_v(npx-1, j)*(ut(npx-&
2092 & 1, j-1)+ut(npx, j-1)+ut(npx-1, j)+ut(npx, j))
2093  vt(npx, j) = vc(npx, j) - 0.25*cosa_v(npx, j)*(ut(npx, j-1)+&
2094 & ut(npx+1, j-1)+ut(npx, j)+ut(npx+1, j))
2095  END DO
2096  CALL pushcontrol(1,0)
2097  ELSE
2098  CALL pushcontrol(1,1)
2099  END IF
2100 ! South (Bottom) edge:
2101  IF (js .EQ. 1) THEN
2102  DO i=isd,ied
2103  IF (vc(i, 1)*dt .GT. 0.) THEN
2104  vt(i, 1) = vc(i, 1)/sin_sg(i, 0, 4)
2105  CALL pushcontrol(1,1)
2106  ELSE
2107  vt(i, 1) = vc(i, 1)/sin_sg(i, 1, 2)
2108  CALL pushcontrol(1,0)
2109  END IF
2110  END DO
2111  IF (3 .LT. is) THEN
2112  max3 = is
2113  ELSE
2114  max3 = 3
2115  END IF
2116  IF (npx - 2 .GT. ie + 1) THEN
2117  min3 = ie + 1
2118  ELSE
2119  min3 = npx - 2
2120  END IF
2121  DO i=max3,min3
2122  ut(i, 0) = uc(i, 0) - 0.25*cosa_u(i, 0)*(vt(i-1, 0)+vt(i, 0)&
2123 & +vt(i-1, 1)+vt(i, 1))
2124  ut(i, 1) = uc(i, 1) - 0.25*cosa_u(i, 1)*(vt(i-1, 1)+vt(i, 1)&
2125 & +vt(i-1, 2)+vt(i, 2))
2126  END DO
2127  CALL pushcontrol(1,0)
2128  ELSE
2129  CALL pushcontrol(1,1)
2130  END IF
2131 ! North edge:
2132  IF (je + 1 .EQ. npy) THEN
2133  DO i=isd,ied
2134  IF (vc(i, npy)*dt .GT. 0.) THEN
2135  vt(i, npy) = vc(i, npy)/sin_sg(i, npy-1, 4)
2136  CALL pushcontrol(1,1)
2137  ELSE
2138  vt(i, npy) = vc(i, npy)/sin_sg(i, npy, 2)
2139  CALL pushcontrol(1,0)
2140  END IF
2141  END DO
2142  IF (3 .LT. is) THEN
2143  max4 = is
2144  ELSE
2145  max4 = 3
2146  END IF
2147  IF (npx - 2 .GT. ie + 1) THEN
2148  min4 = ie + 1
2149  ELSE
2150  min4 = npx - 2
2151  END IF
2152  DO i=max4,min4
2153  ut(i, npy-1) = uc(i, npy-1) - 0.25*cosa_u(i, npy-1)*(vt(i-1&
2154 & , npy-1)+vt(i, npy-1)+vt(i-1, npy)+vt(i, npy))
2155  ut(i, npy) = uc(i, npy) - 0.25*cosa_u(i, npy)*(vt(i-1, npy)+&
2156 & vt(i, npy)+vt(i-1, npy+1)+vt(i, npy+1))
2157  END DO
2158  CALL pushcontrol(1,0)
2159  ELSE
2160  CALL pushcontrol(1,1)
2161  END IF
2162 ! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values
2163 ! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously).
2164 ! It then computes the halo uc, vc values so as to be consistent with the computations on
2165 ! the facing panel.
2166 !The system solved is:
2167 ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1)
2168 ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2)
2169 ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1)
2170  IF (sw_corner) THEN
2171  damp = 1./(1.-0.0625*cosa_u(2, 0)*cosa_v(1, 0))
2172  ut(2, 0) = (uc(2, 0)-0.25*cosa_u(2, 0)*(vt(1, 1)+vt(2, 1)+vt(2&
2173 & , 0)+vc(1, 0)-0.25*cosa_v(1, 0)*(ut(1, 0)+ut(1, -1)+ut(2, -1&
2174 & ))))*damp
2175  damp = 1./(1.-0.0625*cosa_u(0, 1)*cosa_v(0, 2))
2176  vt(0, 2) = (vc(0, 2)-0.25*cosa_v(0, 2)*(ut(1, 1)+ut(1, 2)+ut(0&
2177 & , 2)+uc(0, 1)-0.25*cosa_u(0, 1)*(vt(0, 1)+vt(-1, 1)+vt(-1, 2&
2178 & ))))*damp
2179  damp = 1./(1.-0.0625*cosa_u(2, 1)*cosa_v(1, 2))
2180  ut(2, 1) = (uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2&
2181 & , 2)+vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2, 2))&
2182 & ))*damp
2183  vt(1, 2) = (vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2&
2184 & , 2)+uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2, 2))&
2185 & ))*damp
2186  CALL pushcontrol(1,0)
2187  ELSE
2188  CALL pushcontrol(1,1)
2189  END IF
2190  IF (se_corner) THEN
2191  damp = 1./(1.-0.0625*cosa_u(npx-1, 0)*cosa_v(npx-1, 0))
2192  ut(npx-1, 0) = (uc(npx-1, 0)-0.25*cosa_u(npx-1, 0)*(vt(npx-1, &
2193 & 1)+vt(npx-2, 1)+vt(npx-2, 0)+vc(npx-1, 0)-0.25*cosa_v(npx-1&
2194 & , 0)*(ut(npx, 0)+ut(npx, -1)+ut(npx-1, -1))))*damp
2195  damp = 1./(1.-0.0625*cosa_u(npx+1, 1)*cosa_v(npx, 2))
2196  vt(npx, 2) = (vc(npx, 2)-0.25*cosa_v(npx, 2)*(ut(npx, 1)+ut(&
2197 & npx, 2)+ut(npx+1, 2)+uc(npx+1, 1)-0.25*cosa_u(npx+1, 1)*(vt(&
2198 & npx, 1)+vt(npx+1, 1)+vt(npx+1, 2))))*damp
2199  damp = 1./(1.-0.0625*cosa_u(npx-1, 1)*cosa_v(npx-1, 2))
2200  ut(npx-1, 1) = (uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*(vt(npx-1, &
2201 & 1)+vt(npx-2, 1)+vt(npx-2, 2)+vc(npx-1, 2)-0.25*cosa_v(npx-1&
2202 & , 2)*(ut(npx, 1)+ut(npx, 2)+ut(npx-1, 2))))*damp
2203  vt(npx-1, 2) = (vc(npx-1, 2)-0.25*cosa_v(npx-1, 2)*(ut(npx, 1)&
2204 & +ut(npx, 2)+ut(npx-1, 2)+uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*&
2205 & (vt(npx-1, 1)+vt(npx-2, 1)+vt(npx-2, 2))))*damp
2206  CALL pushcontrol(1,0)
2207  ELSE
2208  CALL pushcontrol(1,1)
2209  END IF
2210  IF (ne_corner) THEN
2211  damp = 1./(1.-0.0625*cosa_u(npx-1, npy)*cosa_v(npx-1, npy+1))
2212  ut(npx-1, npy) = (uc(npx-1, npy)-0.25*cosa_u(npx-1, npy)*(vt(&
2213 & npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy+1)+vc(npx-1, npy+1)&
2214 & -0.25*cosa_v(npx-1, npy+1)*(ut(npx, npy)+ut(npx, npy+1)+ut(&
2215 & npx-1, npy+1))))*damp
2216  damp = 1./(1.-0.0625*cosa_u(npx+1, npy-1)*cosa_v(npx, npy-1))
2217  vt(npx, npy-1) = (vc(npx, npy-1)-0.25*cosa_v(npx, npy-1)*(ut(&
2218 & npx, npy-1)+ut(npx, npy-2)+ut(npx+1, npy-2)+uc(npx+1, npy-1)&
2219 & -0.25*cosa_u(npx+1, npy-1)*(vt(npx, npy)+vt(npx+1, npy)+vt(&
2220 & npx+1, npy-1))))*damp
2221  damp = 1./(1.-0.0625*cosa_u(npx-1, npy-1)*cosa_v(npx-1, npy-1)&
2222 & )
2223  ut(npx-1, npy-1) = (uc(npx-1, npy-1)-0.25*cosa_u(npx-1, npy-1)&
2224 & *(vt(npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy-1)+vc(npx-1, &
2225 & npy-1)-0.25*cosa_v(npx-1, npy-1)*(ut(npx, npy-1)+ut(npx, npy&
2226 & -2)+ut(npx-1, npy-2))))*damp
2227  vt(npx-1, npy-1) = (vc(npx-1, npy-1)-0.25*cosa_v(npx-1, npy-1)&
2228 & *(ut(npx, npy-1)+ut(npx, npy-2)+ut(npx-1, npy-2)+uc(npx-1, &
2229 & npy-1)-0.25*cosa_u(npx-1, npy-1)*(vt(npx-1, npy)+vt(npx-2, &
2230 & npy)+vt(npx-2, npy-1))))*damp
2231  CALL pushcontrol(1,0)
2232  ELSE
2233  CALL pushcontrol(1,1)
2234  END IF
2235  IF (nw_corner) THEN
2236  damp = 1./(1.-0.0625*cosa_u(2, npy)*cosa_v(1, npy+1))
2237  ut(2, npy) = (uc(2, npy)-0.25*cosa_u(2, npy)*(vt(1, npy)+vt(2&
2238 & , npy)+vt(2, npy+1)+vc(1, npy+1)-0.25*cosa_v(1, npy+1)*(ut(1&
2239 & , npy)+ut(1, npy+1)+ut(2, npy+1))))*damp
2240  damp = 1./(1.-0.0625*cosa_u(0, npy-1)*cosa_v(0, npy-1))
2241  vt(0, npy-1) = (vc(0, npy-1)-0.25*cosa_v(0, npy-1)*(ut(1, npy-&
2242 & 1)+ut(1, npy-2)+ut(0, npy-2)+uc(0, npy-1)-0.25*cosa_u(0, npy&
2243 & -1)*(vt(0, npy)+vt(-1, npy)+vt(-1, npy-1))))*damp
2244  damp = 1./(1.-0.0625*cosa_u(2, npy-1)*cosa_v(1, npy-1))
2245  ut(2, npy-1) = (uc(2, npy-1)-0.25*cosa_u(2, npy-1)*(vt(1, npy)&
2246 & +vt(2, npy)+vt(2, npy-1)+vc(1, npy-1)-0.25*cosa_v(1, npy-1)*&
2247 & (ut(1, npy-1)+ut(1, npy-2)+ut(2, npy-2))))*damp
2248  vt(1, npy-1) = (vc(1, npy-1)-0.25*cosa_v(1, npy-1)*(ut(1, npy-&
2249 & 1)+ut(1, npy-2)+ut(2, npy-2)+uc(2, npy-1)-0.25*cosa_u(2, npy&
2250 & -1)*(vt(1, npy)+vt(2, npy)+vt(2, npy-1))))*damp
2251  CALL pushcontrol(2,3)
2252  ELSE
2253  CALL pushcontrol(2,2)
2254  END IF
2255  ELSE
2256  CALL pushcontrol(2,1)
2257  END IF
2258  ELSE
2259 ! flagstruct%grid_type >= 3
2260  DO j=jsd,jed
2261  DO i=is,ie+1
2262  ut(i, j) = uc(i, j)
2263  END DO
2264  END DO
2265  DO j=js,je+1
2266  DO i=isd,ied
2267  vt(i, j) = vc(i, j)
2268  END DO
2269  END DO
2270  CALL pushcontrol(2,0)
2271  END IF
2272  DO j=jsd,jed
2273  DO i=is,ie+1
2274  CALL pushrealarray(xfx_adv(i, j))
2275  xfx_adv(i, j) = dt*ut(i, j)
2276  END DO
2277  END DO
2278  DO j=js,je+1
2279  DO i=isd,ied
2280  CALL pushrealarray(yfx_adv(i, j))
2281  yfx_adv(i, j) = dt*vt(i, j)
2282  END DO
2283  END DO
2284 ! Explanation of the following code:
2285 ! xfx_adv = dt*ut*dy
2286 ! crx_adv = dt*ut/dx
2287  DO j=jsd,jed
2288 !DEC$ VECTOR ALWAYS
2289  DO i=is,ie+1
2290  IF (xfx_adv(i, j) .GT. 0.) THEN
2291  CALL pushrealarray(crx_adv(i, j))
2292  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i-1, j)
2293  CALL pushrealarray(xfx_adv(i, j))
2294  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i-1, j, 3)
2295  CALL pushcontrol(1,1)
2296  ELSE
2297  CALL pushrealarray(crx_adv(i, j))
2298  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i, j)
2299  CALL pushrealarray(xfx_adv(i, j))
2300  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i, j, 1)
2301  CALL pushcontrol(1,0)
2302  END IF
2303  END DO
2304  END DO
2305  DO j=js,je+1
2306 !DEC$ VECTOR ALWAYS
2307  DO i=isd,ied
2308  IF (yfx_adv(i, j) .GT. 0.) THEN
2309  CALL pushrealarray(cry_adv(i, j))
2310  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j-1)
2311  CALL pushrealarray(yfx_adv(i, j))
2312  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j-1, 4)
2313  CALL pushcontrol(1,1)
2314  ELSE
2315  CALL pushrealarray(cry_adv(i, j))
2316  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j)
2317  CALL pushrealarray(yfx_adv(i, j))
2318  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j, 2)
2319  CALL pushcontrol(1,0)
2320  END IF
2321  END DO
2322  END DO
2323  DO j=jsd,jed
2324  DO i=is,ie
2325  ra_x(i, j) = area(i, j) + (xfx_adv(i, j)-xfx_adv(i+1, j))
2326  END DO
2327  END DO
2328  DO j=js,je
2329  DO i=isd,ied
2330  ra_y(i, j) = area(i, j) + (yfx_adv(i, j)-yfx_adv(i, j+1))
2331  END DO
2332  END DO
2333  IF (hord_dp .EQ. hord_dp_pert .AND. (.NOT.split_damp)) THEN
2334  CALL fv_tp_2d_fwd(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx&
2335 & , fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y&
2336 & , nord=nord_v, damp_c=damp_v)
2337  CALL pushcontrol(1,1)
2338  ELSE
2339  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2340  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2341  CALL pushrealarray(delp, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2342  CALL fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, &
2343 & fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, nord=&
2344 & nord_v, damp_c=damp_v)
2345  CALL pushcontrol(1,0)
2346  END IF
2347 ! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>>
2348  DO j=jsd,jed
2349  DO i=is,ie+1
2350  cx(i, j) = cx(i, j) + crx_adv(i, j)
2351  END DO
2352  END DO
2353  DO j=js,je
2354  DO i=is,ie+1
2355  xflux(i, j) = xflux(i, j) + fx(i, j)
2356  END DO
2357  END DO
2358  DO j=js,je+1
2359  DO i=isd,ied
2360  cy(i, j) = cy(i, j) + cry_adv(i, j)
2361  END DO
2362  DO i=is,ie
2363  yflux(i, j) = yflux(i, j) + fy(i, j)
2364  END DO
2365  END DO
2366  DO j=js,je
2367  DO i=is,ie
2368  heat_source(i, j) = 0.
2369  END DO
2370  END DO
2371  IF (.NOT.hydrostatic) THEN
2372  IF (damp_w .GT. 1.e-5) THEN
2373  IF (dt .GE. 0.) THEN
2374  abs0 = dt
2375  ELSE
2376  abs0 = -dt
2377  END IF
2378  dd8 = kgb*abs0
2379  damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1)
2380  CALL del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, &
2381 & gridstruct, bd)
2382  DO j=js,je
2383  DO i=is,ie
2384  dw(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
2385 & rarea(i, j)
2386 ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw
2387 ! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j))
2388  heat_source(i, j) = dd8 - dw(i, j)*(w(i, j)+0.5*dw(i, j))
2389  END DO
2390  END DO
2391  CALL pushcontrol(1,0)
2392  ELSE
2393  CALL pushcontrol(1,1)
2394  END IF
2395  IF (hord_vt .EQ. hord_vt_pert) THEN
2396  CALL fv_tp_2d_fwd(w, crx_adv, cry_adv, npx, npy, hord_vt, gx&
2397 & , gy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, &
2398 & ra_y, mfx=fx, mfy=fy)
2399  CALL pushcontrol(1,1)
2400  ELSE
2401  CALL pushrealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2402  CALL pushrealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2403  CALL pushrealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2404  CALL fv_tp_2d(w, crx_adv, cry_adv, npx, npy, hord_vt, gx, &
2405 & gy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=fx&
2406 & , mfy=fy)
2407  CALL pushcontrol(1,0)
2408  END IF
2409  DO j=js,je
2410  DO i=is,ie
2411  CALL pushrealarray(w(i, j))
2412  w(i, j) = delp(i, j)*w(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j)-&
2413 & gy(i, j+1)))*rarea(i, j)
2414  END DO
2415  END DO
2416  CALL pushcontrol(1,0)
2417  ELSE
2418  CALL pushcontrol(1,1)
2419  END IF
2420 ! if ( inline_q .and. zvir>0.01 ) then
2421 ! do j=jsd,jed
2422 ! do i=isd,ied
2423 ! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum))
2424 ! enddo
2425 ! enddo
2426 ! endif
2427  IF (hord_tm .EQ. hord_tm_pert .AND. (.NOT.split_damp)) THEN
2428  CALL fv_tp_2d_fwd(pt, crx_adv, cry_adv, npx, npy, hord_tm, gx, &
2429 & gy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, &
2430 & mfx=fx, mfy=fy, mass=delp, nord=nord_t, damp_c=&
2431 & damp_t)
2432  CALL pushcontrol(1,0)
2433  ELSE
2434  CALL pushrealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2435  CALL pushrealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2436  CALL pushrealarray(pt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2437  CALL fv_tp_2d(pt, crx_adv, cry_adv, npx, npy, hord_tm, gx, gy&
2438 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=fx, &
2439 & mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
2440  CALL pushcontrol(1,1)
2441  END IF
2442  IF (inline_q) THEN
2443  DO j=js,je
2444  DO i=is,ie
2445  wk(i, j) = delp(i, j)
2446  CALL pushrealarray(delp(i, j))
2447  delp(i, j) = wk(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
2448 & +1)))*rarea(i, j)
2449  CALL pushrealarray(pt(i, j))
2450  pt(i, j) = (pt(i, j)*wk(i, j)+(gx(i, j)-gx(i+1, j)+(gy(i, j)-&
2451 & gy(i, j+1)))*rarea(i, j))/delp(i, j)
2452  END DO
2453  END DO
2454  DO iq=1,nq
2455  IF (hord_tr .EQ. hord_tr_pert) THEN
2456  CALL fv_tp_2d_fwd(q(isd:ied, jsd:jed, k, iq), crx_adv, &
2457 & cry_adv, npx, npy, hord_tr, gx, gy, xfx_adv, &
2458 & yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=fx, &
2459 & mfy=fy, mass=delp, nord=nord_t, damp_c=damp_t)
2460  CALL pushcontrol(1,1)
2461  ELSE
2462  CALL pushrealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
2463  CALL pushrealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
2464  CALL pushrealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)*(&
2465 & jed-jsd+1))
2466  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), crx_adv, cry_adv, &
2467 & npx, npy, hord_tr, gx, gy, xfx_adv, yfx_adv, &
2468 & gridstruct, bd, ra_x, ra_y, mfx=fx, mfy=fy, mass=delp&
2469 & , nord=nord_t, damp_c=damp_t)
2470  CALL pushcontrol(1,0)
2471  END IF
2472  DO j=js,je
2473  DO i=is,ie
2474  CALL pushrealarray(q(i, j, k, iq))
2475  q(i, j, k, iq) = (q(i, j, k, iq)*wk(i, j)+(gx(i, j)-gx(i+1, &
2476 & j)+(gy(i, j)-gy(i, j+1)))*rarea(i, j))/delp(i, j)
2477  END DO
2478  END DO
2479  END DO
2480  CALL pushcontrol(1,0)
2481  ELSE
2482 ! if ( zvir>0.01 ) then
2483 ! do j=js,je
2484 ! do i=is,ie
2485 ! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum))
2486 ! enddo
2487 ! enddo
2488 ! endif
2489  DO j=js,je
2490  DO i=is,ie
2491  CALL pushrealarray(pt(i, j))
2492  pt(i, j) = pt(i, j)*delp(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j&
2493 & )-gy(i, j+1)))*rarea(i, j)
2494  CALL pushrealarray(delp(i, j))
2495  delp(i, j) = delp(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i&
2496 & , j+1)))*rarea(i, j)
2497  CALL pushrealarray(pt(i, j))
2498  pt(i, j) = pt(i, j)/delp(i, j)
2499  END DO
2500  END DO
2501  CALL pushcontrol(1,1)
2502  END IF
2503  IF (fpp%fpp_overload_r4) THEN
2504  DO j=js,je
2505  DO i=is,ie
2506  dpx(i, j) = dpx(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
2507 & +1)))*rarea(i, j)
2508  END DO
2509  END DO
2510  CALL pushcontrol(1,0)
2511  ELSE
2512  CALL pushcontrol(1,1)
2513  END IF
2514 !----------------------
2515 ! Kinetic Energy Fluxes
2516 !----------------------
2517 ! Compute B grid contra-variant components for KE:
2518  dt5 = 0.5*dt
2519  dt4 = 0.25*dt
2520  IF (nested) THEN
2521  CALL pushcontrol(1,0)
2522  is2 = is
2523  ie1 = ie + 1
2524  js2 = js
2525  je1 = je + 1
2526  ELSE
2527  IF (2 .LT. is) THEN
2528  is2 = is
2529  ELSE
2530  is2 = 2
2531  END IF
2532  IF (npx - 1 .GT. ie + 1) THEN
2533  ie1 = ie + 1
2534  ELSE
2535  ie1 = npx - 1
2536  END IF
2537  IF (2 .LT. js) THEN
2538  js2 = js
2539  ELSE
2540  js2 = 2
2541  END IF
2542  IF (npy - 1 .GT. je + 1) THEN
2543  CALL pushcontrol(1,1)
2544  je1 = je + 1
2545  ELSE
2546  CALL pushcontrol(1,1)
2547  je1 = npy - 1
2548  END IF
2549  END IF
2550 !!! TO DO: separate versions for nested and for cubed-sphere
2551  IF (flagstruct%grid_type .LT. 3) THEN
2552  IF (nested) THEN
2553  DO j=js2,je1
2554  DO i=is2,ie1
2555  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
2556 & cosa(i, j))*rsina(i, j)
2557  END DO
2558  END DO
2559  CALL pushcontrol(2,0)
2560  ELSE
2561  IF (js .EQ. 1) THEN
2562  DO i=is,ie+1
2563 ! corner values are incorrect
2564  vb(i, 1) = dt5*(vt(i-1, 1)+vt(i, 1))
2565  END DO
2566  CALL pushcontrol(1,1)
2567  ELSE
2568  CALL pushcontrol(1,0)
2569  END IF
2570  DO j=js2,je1
2571  DO i=is2,ie1
2572  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
2573 & cosa(i, j))*rsina(i, j)
2574  END DO
2575  IF (is .EQ. 1) THEN
2576 ! 2-pt extrapolation from both sides:
2577  vb(1, j) = dt4*(-vt(-1, j)+3.*(vt(0, j)+vt(1, j))-vt(2, j))
2578  CALL pushcontrol(1,0)
2579  ELSE
2580  CALL pushcontrol(1,1)
2581  END IF
2582  IF (ie + 1 .EQ. npx) THEN
2583 ! 2-pt extrapolation from both sides:
2584  vb(npx, j) = dt4*(-vt(npx-2, j)+3.*(vt(npx-1, j)+vt(npx, j))&
2585 & -vt(npx+1, j))
2586  CALL pushcontrol(1,1)
2587  ELSE
2588  CALL pushcontrol(1,0)
2589  END IF
2590  END DO
2591  IF (je + 1 .EQ. npy) THEN
2592  DO i=is,ie+1
2593 ! corner values are incorrect
2594  vb(i, npy) = dt5*(vt(i-1, npy)+vt(i, npy))
2595  END DO
2596  CALL pushcontrol(2,1)
2597  ELSE
2598  CALL pushcontrol(2,2)
2599  END IF
2600  END IF
2601  ELSE
2602  DO j=js,je+1
2603  DO i=is,ie+1
2604  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j))
2605  END DO
2606  END DO
2607  CALL pushcontrol(2,3)
2608  END IF
2609  IF (hord_mt .EQ. hord_mt_pert) THEN
2610  CALL ytp_v_fwd(is, ie, js, je, isd, ied, jsd, jed, vb, u, v, ub&
2611 & , hord_mt, gridstruct%dy, gridstruct%rdy, npx, npy, &
2612 & flagstruct%grid_type, nested)
2613  CALL pushcontrol(1,1)
2614  ELSE
2615  CALL ytp_v(is, ie, js, je, isd, ied, jsd, jed, vb, u, v, ub, &
2616 & hord_mt, gridstruct%dy, gridstruct%rdy, npx, npy, &
2617 & flagstruct%grid_type, nested)
2618  CALL pushcontrol(1,0)
2619  END IF
2620  DO j=js,je+1
2621  DO i=is,ie+1
2622  ke(i, j) = vb(i, j)*ub(i, j)
2623  END DO
2624  END DO
2625  IF (flagstruct%grid_type .LT. 3) THEN
2626  IF (nested) THEN
2627  DO j=js,je+1
2628  DO i=is2,ie1
2629  CALL pushrealarray(ub(i, j))
2630  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
2631 & cosa(i, j))*rsina(i, j)
2632  END DO
2633  END DO
2634  CALL pushcontrol(2,0)
2635  ELSE
2636  IF (is .EQ. 1) THEN
2637  DO j=js,je+1
2638 ! corner values are incorrect
2639  CALL pushrealarray(ub(1, j))
2640  ub(1, j) = dt5*(ut(1, j-1)+ut(1, j))
2641  END DO
2642  CALL pushcontrol(1,1)
2643  ELSE
2644  CALL pushcontrol(1,0)
2645  END IF
2646  DO j=js,je+1
2647  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
2648  DO i=is2,ie1
2649 ! 2-pt extrapolation from both sides:
2650  CALL pushrealarray(ub(i, j))
2651  ub(i, j) = dt4*(-ut(i, j-2)+3.*(ut(i, j-1)+ut(i, j))-ut(i&
2652 & , j+1))
2653  END DO
2654  CALL pushcontrol(1,1)
2655  ELSE
2656  DO i=is2,ie1
2657  CALL pushrealarray(ub(i, j))
2658  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
2659 & cosa(i, j))*rsina(i, j)
2660  END DO
2661  CALL pushcontrol(1,0)
2662  END IF
2663  END DO
2664  IF (ie + 1 .EQ. npx) THEN
2665  DO j=js,je+1
2666 ! corner values are incorrect
2667  CALL pushrealarray(ub(npx, j))
2668  ub(npx, j) = dt5*(ut(npx, j-1)+ut(npx, j))
2669  END DO
2670  CALL pushcontrol(2,1)
2671  ELSE
2672  CALL pushcontrol(2,2)
2673  END IF
2674  END IF
2675  ELSE
2676  DO j=js,je+1
2677  DO i=is,ie+1
2678  CALL pushrealarray(ub(i, j))
2679  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j))
2680  END DO
2681  END DO
2682  CALL pushcontrol(2,3)
2683  END IF
2684  IF (hord_mt .EQ. hord_mt_pert) THEN
2685  CALL xtp_u_fwd(is, ie, js, je, isd, ied, jsd, jed, ub, u, v, vb&
2686 & , hord_mt, gridstruct%dx, gridstruct%rdx, npx, npy, &
2687 & flagstruct%grid_type, nested)
2688  CALL pushcontrol(1,1)
2689  ELSE
2690  CALL pushrealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
2691  CALL xtp_u(is, ie, js, je, isd, ied, jsd, jed, ub, u, v, vb, &
2692 & hord_mt, gridstruct%dx, gridstruct%rdx, npx, npy, &
2693 & flagstruct%grid_type, nested)
2694  CALL pushcontrol(1,0)
2695  END IF
2696  DO j=js,je+1
2697  DO i=is,ie+1
2698  ke(i, j) = 0.5*(ke(i, j)+ub(i, j)*vb(i, j))
2699  END DO
2700  END DO
2701 !-----------------------------------------
2702 ! Fix KE at the 4 corners of the face:
2703 !-----------------------------------------
2704  IF (.NOT.nested) THEN
2705  dt6 = dt/6.
2706  IF (sw_corner) THEN
2707  ke(1, 1) = dt6*((ut(1, 1)+ut(1, 0))*u(1, 1)+(vt(1, 1)+vt(0, 1))*&
2708 & v(1, 1)+(ut(1, 1)+vt(1, 1))*u(0, 1))
2709  CALL pushcontrol(1,0)
2710  ELSE
2711  CALL pushcontrol(1,1)
2712  END IF
2713  IF (se_corner) THEN
2714 !i = npx
2715  ke(npx, 1) = dt6*((ut(npx, 1)+ut(npx, 0))*u(npx-1, 1)+(vt(npx, 1&
2716 & )+vt(npx-1, 1))*v(npx, 1)+(ut(npx, 1)-vt(npx-1, 1))*u(npx, 1))
2717  CALL pushcontrol(1,0)
2718  ELSE
2719  CALL pushcontrol(1,1)
2720  END IF
2721  IF (ne_corner) THEN
2722 !i = npx; j = npy
2723  ke(npx, npy) = dt6*((ut(npx, npy)+ut(npx, npy-1))*u(npx-1, npy)+&
2724 & (vt(npx, npy)+vt(npx-1, npy))*v(npx, npy-1)+(ut(npx, npy-1)+vt&
2725 & (npx-1, npy))*u(npx, npy))
2726  CALL pushcontrol(1,0)
2727  ELSE
2728  CALL pushcontrol(1,1)
2729  END IF
2730  IF (nw_corner) THEN
2731 !j = npy
2732  ke(1, npy) = dt6*((ut(1, npy)+ut(1, npy-1))*u(1, npy)+(vt(1, npy&
2733 & )+vt(0, npy))*v(1, npy-1)+(ut(1, npy-1)-vt(1, npy))*u(0, npy))
2734  CALL pushcontrol(2,2)
2735  ELSE
2736  CALL pushcontrol(2,1)
2737  END IF
2738  ELSE
2739  CALL pushcontrol(2,0)
2740  END IF
2741 ! Compute vorticity:
2742  DO j=jsd,jed+1
2743  DO i=isd,ied
2744  CALL pushrealarray(vt(i, j))
2745  vt(i, j) = u(i, j)*dx(i, j)
2746  END DO
2747  END DO
2748  DO j=jsd,jed
2749  DO i=isd,ied+1
2750  CALL pushrealarray(ut(i, j))
2751  ut(i, j) = v(i, j)*dy(i, j)
2752  END DO
2753  END DO
2754 ! wk is "volume-mean" relative vorticity
2755  DO j=jsd,jed
2756  DO i=isd,ied
2757  CALL pushrealarray(wk(i, j))
2758  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i+1, j)-ut(i, j)&
2759 & ))
2760  END DO
2761  END DO
2762  IF (.NOT.hydrostatic) THEN
2763  IF (flagstruct%do_f3d) THEN
2764  CALL pushcontrol(1,0)
2765  ELSE
2766  DO j=js,je
2767  DO i=is,ie
2768  CALL pushrealarray(w(i, j))
2769  w(i, j) = w(i, j)/delp(i, j)
2770  END DO
2771  END DO
2772  CALL pushcontrol(1,1)
2773  END IF
2774  IF (damp_w .GT. 1.e-5) THEN
2775  DO j=js,je
2776  DO i=is,ie
2777  CALL pushrealarray(w(i, j))
2778  w(i, j) = w(i, j) + dw(i, j)
2779  END DO
2780  END DO
2781  CALL pushcontrol(2,0)
2782  ELSE
2783  CALL pushcontrol(2,1)
2784  END IF
2785  ELSE
2786  CALL pushcontrol(2,2)
2787  END IF
2788 !-----------------------------
2789 ! Compute divergence damping
2790 !-----------------------------
2791 !! damp = dddmp * da_min_c
2792 !
2793 ! if ( nord==0 ) then
2794 !! area ~ dxb*dyb*sin(alpha)
2795 !
2796 ! if (nested) then
2797 !
2798 ! do j=js,je+1
2799 ! do i=is-1,ie+1
2800 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
2801 ! *dyc(i,j)*sina_v(i,j)
2802 ! enddo
2803 ! enddo
2804 !
2805 ! do j=js-1,je+1
2806 ! do i=is2,ie1
2807 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
2808 ! *dxc(i,j)*sina_u(i,j)
2809 ! enddo
2810 ! enddo
2811 !
2812 ! else
2813 ! do j=js,je+1
2814 !
2815 ! if ( (j==1 .or. j==npy) ) then
2816 ! do i=is-1,ie+1
2817 ! if (vc(i,j) > 0) then
2818 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4)
2819 ! else
2820 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2)
2821 ! end if
2822 ! enddo
2823 ! else
2824 ! do i=is-1,ie+1
2825 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
2826 ! *dyc(i,j)*sina_v(i,j)
2827 ! enddo
2828 ! endif
2829 ! enddo
2830 !
2831 ! do j=js-1,je+1
2832 ! do i=is2,ie1
2833 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
2834 ! *dxc(i,j)*sina_u(i,j)
2835 ! enddo
2836 ! if ( is == 1 ) then
2837 ! if (uc(1,j) > 0) then
2838 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3)
2839 ! else
2840 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1)
2841 ! end if
2842 ! end if
2843 ! if ( (ie+1)==npx ) then
2844 ! if (uc(npx,j) > 0) then
2845 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
2846 ! sin_sg(npx-1,j,3)
2847 ! else
2848 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
2849 ! sin_sg(npx,j,1)
2850 ! end if
2851 ! end if
2852 ! enddo
2853 ! endif
2854 !
2855 ! do j=js,je+1
2856 ! do i=is,ie+1
2857 ! delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j)
2858 ! enddo
2859 ! enddo
2860 !
2861 !! Remove the extra term at the corners:
2862 ! if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
2863 ! if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
2864 ! if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy)
2865 ! if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
2866 !
2867 ! do j=js,je+1
2868 ! do i=is,ie+1
2869 ! delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j)
2870 ! damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt)))
2871 ! vort(i,j) = damp*delpc(i,j)
2872 ! ke(i,j) = ke(i,j) + vort(i,j)
2873 ! enddo
2874 ! enddo
2875 ! else
2876 !!--------------------------
2877 !! Higher order divg damping
2878 !!--------------------------
2879 ! do j=js,je+1
2880 ! do i=is,ie+1
2881 !! Save divergence for external mode filter
2882 ! delpc(i,j) = divg_d(i,j)
2883 ! enddo
2884 ! enddo
2885 !
2886 ! n2 = nord + 1 ! N > 1
2887 ! do n=1,nord
2888 ! nt = nord-n
2889 !
2890 ! fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. &
2891 ! ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) &
2892 ! .and. .not. nested
2893 !
2894 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.)
2895 ! do j=js-nt,je+1+nt
2896 ! do i=is-1-nt,ie+1+nt
2897 ! vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j)
2898 ! enddo
2899 ! enddo
2900 !
2901 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.)
2902 ! do j=js-1-nt,je+1+nt
2903 ! do i=is-nt,ie+1+nt
2904 ! uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j)
2905 ! enddo
2906 ! enddo
2907 !
2908 ! if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.)
2909 ! do j=js-nt,je+1+nt
2910 ! do i=is-nt,ie+1+nt
2911 ! divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j)
2912 ! enddo
2913 ! enddo
2914 !
2915 !! Remove the extra term at the corners:
2916 ! if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
2917 ! if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
2918 ! if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy)
2919 ! if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
2920 !
2921 ! if ( .not. gridstruct%stretched_grid ) then
2922 ! do j=js-nt,je+1+nt
2923 ! do i=is-nt,ie+1+nt
2924 ! divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j)
2925 ! enddo
2926 ! enddo
2927 ! endif
2928 !
2929 ! enddo ! n-loop
2930 !
2931 ! if ( dddmp<1.E-5) then
2932 ! vort(:,:) = 0.
2933 ! else
2934 ! if ( flagstruct%grid_type < 3 ) then
2935 !! Interpolate relative vort to cell corners
2936 ! call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.)
2937 ! do j=js,je+1
2938 ! do i=is,ie+1
2939 !! The following is an approxi form of Smagorinsky diffusion
2940 ! vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2)
2941 ! enddo
2942 ! enddo
2943 ! else ! Correct form: works only for doubly preiodic domain
2944 ! call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng)
2945 ! endif
2946 ! endif
2947 !
2948 ! if (gridstruct%stretched_grid ) then
2949 !! Stretched grid with variable damping ~ area
2950 ! dd8 = gridstruct%da_min * d4_bg**n2
2951 ! else
2952 ! dd8 = ( gridstruct%da_min_c*d4_bg )**n2
2953 ! endif
2954 !
2955 ! do j=js,je+1
2956 ! do i=is,ie+1
2957 ! damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2
2958 ! vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j)
2959 ! ke(i,j) = ke(i,j) + vort(i,j)
2960 ! enddo
2961 ! enddo
2962 !
2963 ! endif
2964  IF (.NOT.split_damp) THEN
2965  CALL compute_divergence_damping_fwd(nord, d2_bg, d4_bg, dddmp, &
2966 & dt, vort, ptc, delpc, ke, u, v, &
2967 & uc, vc, ua, va, divg_d, wk, &
2968 & gridstruct, flagstruct, bd)
2969  CALL pushcontrol(1,0)
2970  ELSE
2971  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2972  CALL pushrealarray(divg_d, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+2))
2973  CALL pushrealarray(vc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
2974  CALL pushrealarray(uc, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
2975  CALL pushrealarray(delpc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2976  CALL pushrealarray(ptc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2977  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2978  CALL compute_divergence_damping(nord, d2_bg, d4_bg&
2979 & , dddmp, dt, vort, ptc, delpc, ke, &
2980 & u, v, uc, vc, ua, va, divg_d, wk, &
2981 & gridstruct, flagstruct, bd)
2982  CALL pushcontrol(1,1)
2983  END IF
2984  IF (d_con .GT. 1.e-5) THEN
2985  DO j=js,je+1
2986  DO i=is,ie
2987  CALL pushrealarray(ub(i, j))
2988  ub(i, j) = vort(i, j) - vort(i+1, j)
2989  END DO
2990  END DO
2991  DO j=js,je
2992  DO i=is,ie+1
2993  CALL pushrealarray(vb(i, j))
2994  vb(i, j) = vort(i, j) - vort(i, j+1)
2995  END DO
2996  END DO
2997  CALL pushcontrol(1,0)
2998  ELSE
2999  CALL pushcontrol(1,1)
3000  END IF
3001 ! Vorticity transport
3002  IF (hydrostatic) THEN
3003  DO j=jsd,jed
3004  DO i=isd,ied
3005  vort(i, j) = wk(i, j) + f0(i, j)
3006  END DO
3007  END DO
3008  CALL pushcontrol(2,0)
3009  ELSE IF (flagstruct%do_f3d) THEN
3010  DO j=jsd,jed
3011  DO i=isd,ied
3012  vort(i, j) = wk(i, j) + f0(i, j)*z_rat(i, j)
3013  END DO
3014  END DO
3015  CALL pushcontrol(2,1)
3016  ELSE
3017  DO j=jsd,jed
3018  DO i=isd,ied
3019  vort(i, j) = wk(i, j) + f0(i, j)
3020  END DO
3021  END DO
3022  CALL pushcontrol(2,2)
3023  END IF
3024  IF (hord_vt .EQ. hord_vt_pert) THEN
3025  CALL fv_tp_2d_fwd(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx&
3026 & , fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y)
3027  CALL pushcontrol(1,1)
3028  ELSE
3029  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3030  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3031  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3032  CALL fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, &
3033 & fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y)
3034  CALL pushcontrol(1,0)
3035  END IF
3036  DO j=js,je+1
3037  DO i=is,ie
3038  CALL pushrealarray(u(i, j))
3039  u(i, j) = vt(i, j) + (ke(i, j)-ke(i+1, j)) + fy(i, j)
3040  END DO
3041  END DO
3042  DO j=js,je
3043  DO i=is,ie+1
3044  CALL pushrealarray(v(i, j))
3045  v(i, j) = ut(i, j) + (ke(i, j)-ke(i, j+1)) - fx(i, j)
3046  END DO
3047  END DO
3048 !--------------------------------------------------------
3049 ! damping applied to relative vorticity (wk):
3050  IF (damp_v .GT. 1.e-5) THEN
3051  damp4 = (damp_v*gridstruct%da_min_c)**(nord_v+1)
3052  CALL pushrealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3053  CALL pushrealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3054  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3055  CALL del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, &
3056 & gridstruct, bd)
3057  CALL pushcontrol(1,0)
3058  ELSE
3059  CALL pushcontrol(1,1)
3060  END IF
3061  IF (damp_v_pert .GT. 1.e-5) THEN
3062  damp4 = (damp_v_pert*gridstruct%da_min_c)**(nord_v_pert+1)
3063  CALL pushrealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3064  CALL pushrealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3065  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3066 ! CALL DEL6_VT_FLUX(nord_v_pert, npx, npy, damp4, wk, vort, ut, vt, &
3067 !& gridstruct, bd)
3068  CALL pushcontrol(1,0)
3069  ELSE
3070  CALL pushcontrol(1,1)
3071  END IF
3072  IF (d_con .GT. 1.e-5) THEN
3073  DO j=js,je+1
3074  DO i=is,ie
3075  CALL pushrealarray(ub(i, j))
3076  ub(i, j) = (ub(i, j)+vt(i, j))*rdx(i, j)
3077  CALL pushrealarray(fy(i, j))
3078  fy(i, j) = u(i, j)*rdx(i, j)
3079  CALL pushrealarray(gy(i, j))
3080  gy(i, j) = fy(i, j)*ub(i, j)
3081  END DO
3082  END DO
3083  DO j=js,je
3084  DO i=is,ie+1
3085  CALL pushrealarray(vb(i, j))
3086  vb(i, j) = (vb(i, j)-ut(i, j))*rdy(i, j)
3087  CALL pushrealarray(fx(i, j))
3088  fx(i, j) = v(i, j)*rdy(i, j)
3089  CALL pushrealarray(gx(i, j))
3090  gx(i, j) = fx(i, j)*vb(i, j)
3091  END DO
3092  END DO
3093 !----------------------------------
3094 ! Heating due to damping:
3095 !----------------------------------
3096  damp = 0.25*d_con
3097  DO j=js,je
3098  DO i=is,ie
3099  u2 = fy(i, j) + fy(i, j+1)
3100  du2 = ub(i, j) + ub(i, j+1)
3101  v2 = fx(i, j) + fx(i+1, j)
3102  dv2 = vb(i, j) + vb(i+1, j)
3103 ! Total energy conserving:
3104 ! Convert lost KE due to divergence damping to "heat"
3105  CALL pushrealarray(heat_source(i, j))
3106  heat_source(i, j) = delp(i, j)*(heat_source(i, j)-damp*rsin2(i&
3107 & , j)*(ub(i, j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j)**2+2.&
3108 & *(gy(i, j)+gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, j)*(u2*&
3109 & dv2+v2*du2+du2*dv2)))
3110  END DO
3111  END DO
3112  CALL pushcontrol(1,0)
3113  ELSE
3114  CALL pushcontrol(1,1)
3115  END IF
3116 ! Add diffusive fluxes to the momentum equation:
3117  IF (damp_v .GT. 1.e-5) THEN
3118  DO j=js,je+1
3119  DO i=is,ie
3120  CALL pushrealarray(u(i, j))
3121  u(i, j) = u(i, j) + vt(i, j)
3122  END DO
3123  END DO
3124  DO j=js,je
3125  DO i=is,ie+1
3126  CALL pushrealarray(v(i, j))
3127  v(i, j) = v(i, j) - ut(i, j)
3128  END DO
3129  END DO
3130  CALL pushcontrol(1,0)
3131  ELSE
3132  CALL pushcontrol(1,1)
3133  END IF
3134  IF (damp_v_pert .GT. 1.e-5) THEN
3135  DO j=js,je+1
3136  DO i=is,ie
3137  CALL pushrealarray(u(i, j))
3138  !u(i, j) = u(i, j) + vt(i, j)
3139  END DO
3140  END DO
3141  DO j=js,je
3142  DO i=is,ie+1
3143  CALL pushrealarray(v(i, j))
3144  !v(i, j) = v(i, j) - ut(i, j)
3145  END DO
3146  END DO
3147  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3148  !CALL PUSHPOINTER8(C_LOC(rdxa))
3149  CALL pushinteger(je)
3150  CALL pushinteger(min4)
3151  CALL pushinteger(ie1)
3152  CALL pushinteger(min3)
3153  CALL pushinteger(min2)
3154  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3155  CALL pushinteger(min1)
3156  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3157  CALL pushinteger(js2)
3158  CALL pushrealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3159  !CALL PUSHPOINTER8(C_LOC(rdx))
3160  !CALL PUSHPOINTER8(C_LOC(rsina))
3161  CALL pushinteger(is)
3162  !CALL PUSHPOINTER8(C_LOC(rsin_u))
3163  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3164  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
3165  CALL pushrealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3166  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
3167  CALL pushinteger(ie)
3168  CALL pushrealarray(dt6)
3169  CALL pushrealarray(dt4)
3170  !CALL PUSHPOINTER8(C_LOC(sin_sg))
3171  CALL pushinteger(je1)
3172  CALL pushrealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3173  !CALL PUSHPOINTER8(C_LOC(cosa))
3174  !CALL PUSHPOINTER8(C_LOC(cosa_v))
3175  !CALL PUSHPOINTER8(C_LOC(cosa_u))
3176  CALL pushrealarray(ub, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3177  !CALL PUSHPOINTER8(C_LOC(rdya))
3178  !CALL PUSHPOINTER8(C_LOC(dy))
3179  CALL pushinteger(is2)
3180  !CALL PUSHPOINTER8(C_LOC(dx))
3181  CALL pushrealarray(dw, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
3182  CALL pushrealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3183  CALL pushrealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3184  CALL pushrealarray(damp)
3185  CALL pushinteger(max4)
3186  CALL pushinteger(max3)
3187  CALL pushinteger(max2)
3188  CALL pushinteger(max1)
3189  CALL pushinteger(npy)
3190  CALL pushinteger(npx)
3191  CALL pushinteger(js)
3192  CALL pushrealarray(damp4)
3193  CALL pushcontrol(1,1)
3194  ELSE
3195  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3196  !CALL PUSHPOINTER8(C_LOC(rdxa))
3197  CALL pushinteger(je)
3198  CALL pushinteger(min4)
3199  CALL pushinteger(ie1)
3200  CALL pushinteger(min3)
3201  CALL pushinteger(min2)
3202  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3203  CALL pushinteger(min1)
3204  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3205  CALL pushinteger(js2)
3206  CALL pushrealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3207  !CALL PUSHPOINTER8(C_LOC(rdx))
3208  !CALL PUSHPOINTER8(C_LOC(rsina))
3209  CALL pushinteger(is)
3210  !CALL PUSHPOINTER8(C_LOC(rsin_u))
3211  CALL pushrealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3212  CALL pushrealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
3213  CALL pushrealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3214  CALL pushrealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
3215  CALL pushinteger(ie)
3216  CALL pushrealarray(dt6)
3217  CALL pushrealarray(dt4)
3218  !CALL PUSHPOINTER8(C_LOC(sin_sg))
3219  CALL pushinteger(je1)
3220  CALL pushrealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3221  !CALL PUSHPOINTER8(C_LOC(cosa))
3222  !CALL PUSHPOINTER8(C_LOC(cosa_v))
3223  !CALL PUSHPOINTER8(C_LOC(cosa_u))
3224  CALL pushrealarray(ub, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3225  !CALL PUSHPOINTER8(C_LOC(rdya))
3226  !CALL PUSHPOINTER8(C_LOC(dy))
3227  CALL pushinteger(is2)
3228  !CALL PUSHPOINTER8(C_LOC(dx))
3229  CALL pushrealarray(dw, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
3230  CALL pushrealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3231  CALL pushrealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3232  CALL pushrealarray(damp)
3233  CALL pushinteger(max4)
3234  CALL pushinteger(max3)
3235  CALL pushinteger(max2)
3236  CALL pushinteger(max1)
3237  CALL pushinteger(npy)
3238  CALL pushinteger(npx)
3239  CALL pushinteger(js)
3240  CALL pushrealarray(damp4)
3241  CALL pushcontrol(1,0)
3242  END IF
3243  END SUBROUTINE d_sw_fwd
3244 ! Differentiation of d_sw in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2
3245 !b_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_mod.p
3246 !_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.mix_dp
3247 ! dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Supe
3248 !r fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_
3249 !grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
3250 ! 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_map
3251 !z_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_ma
3252 !pz_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_restar
3253 !t_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_z m
3254 !ain_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_mod.R
3255 !iem_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.SIM
3256 !3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest
3257 !_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.d2a2c_v
3258 !ect 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 sw
3259 !_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.c
3260 !opy_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.
3261 !great_circle_dist sw_core_mod.edge_interpolate4)):
3262 ! gradient of useful results: yfx_adv q crx_adv u v w delp
3263 ! ua xfx_adv uc ptc xflux cry_adv delpc va vc yflux
3264 ! divg_d z_rat heat_source pt cx cy dpx
3265 ! with respect to varying inputs: yfx_adv q crx_adv u v w delp
3266 ! ua xfx_adv uc ptc xflux cry_adv delpc va vc yflux
3267 ! divg_d z_rat heat_source pt cx cy dpx
3268 ! d_sw :: D-Grid Shallow Water Routine
3269  SUBROUTINE d_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, &
3270 & pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, &
3271 & va, va_ad, divg_d, divg_d_ad, xflux, xflux_ad, yflux, yflux_ad, cx, &
3272 & cx_ad, cy, cy_ad, crx_adv, crx_adv_ad, cry_adv, cry_adv_ad, xfx_adv&
3273 & , xfx_adv_ad, yfx_adv, yfx_adv_ad, q_con, z_rat, z_rat_ad, kgb, &
3274 & heat_source, heat_source_ad, dpx, dpx_ad, zvir, sphum, nq, q, q_ad, &
3275 & k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, &
3276 & nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, &
3277 & damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert&
3278 & , hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp&
3279 & , nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, &
3280 & d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
3281  !USE ISO_C_BINDING
3282  !USE ADMM_TAPENADE_INTERFACE
3283  IMPLICIT NONE
3284  INTEGER, INTENT(IN) :: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
3285  INTEGER, INTENT(IN) :: nord
3286  INTEGER, INTENT(IN) :: nord_v
3287  INTEGER, INTENT(IN) :: nord_w
3288  INTEGER, INTENT(IN) :: nord_t
3289  INTEGER, INTENT(IN) :: sphum, nq, k, km
3290  REAL, INTENT(IN) :: dt, dddmp, d2_bg, d4_bg, d_con
3291  REAL, INTENT(IN) :: zvir
3292  REAL, INTENT(IN) :: damp_v, damp_w, damp_t, kgb
3293  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
3294  INTEGER, INTENT(IN) :: hord_tr_pert, hord_mt_pert, hord_vt_pert, &
3295 & hord_tm_pert, hord_dp_pert, nord_pert, nord_v_pert, nord_w_pert, &
3296 & nord_t_pert
3297  LOGICAL, INTENT(IN) :: split_damp
3298  REAL, INTENT(IN) :: dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert&
3299 & , damp_w_pert, damp_t_pert
3300  REAL, INTENT(INOUT) :: divg_d(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3301  REAL, INTENT(INOUT) :: divg_d_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3302  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: z_rat
3303  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: z_rat_ad
3304  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
3305 & , pt, ua, va
3306  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
3307 & delp_ad, pt_ad, ua_ad, va_ad
3308  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
3309  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w_ad
3310  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
3311 & q_con
3312  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
3313 & , vc
3314  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
3315 & u_ad, vc_ad
3316  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
3317 & , uc
3318  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
3319 & v_ad, uc_ad
3320  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
3321  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
3322  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc, ptc
3323  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: delpc_ad, ptc_ad
3324  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: heat_source
3325  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: heat_source_ad
3326  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
3327 & dpx
3328  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
3329 & dpx_ad
3330  REAL, INTENT(INOUT) :: xflux(bd%is:bd%ie+1, bd%js:bd%je)
3331  REAL, INTENT(INOUT) :: xflux_ad(bd%is:bd%ie+1, bd%js:bd%je)
3332  REAL, INTENT(INOUT) :: yflux(bd%is:bd%ie, bd%js:bd%je+1)
3333  REAL, INTENT(INOUT) :: yflux_ad(bd%is:bd%ie, bd%js:bd%je+1)
3334  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed)
3335  REAL, INTENT(INOUT) :: cx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
3336  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1)
3337  REAL, INTENT(INOUT) :: cy_ad(bd%isd:bd%ied, bd%js:bd%je+1)
3338  LOGICAL, INTENT(IN) :: hydrostatic
3339  LOGICAL, INTENT(IN) :: inline_q
3340  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed) :: crx_adv, xfx_adv
3341  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed) :: crx_adv_ad, &
3342 & xfx_adv_ad
3343  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1) :: cry_adv, yfx_adv
3344  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1) :: cry_adv_ad, &
3345 & yfx_adv_ad
3346  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3347  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
3348  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
3349  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3350  REAL :: ut_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3351  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3352  REAL :: vt_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3353  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3354  REAL :: fx2_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3355  REAL :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3356  REAL :: fy2_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3357  REAL :: dw(bd%is:bd%ie, bd%js:bd%je)
3358  REAL :: dw_ad(bd%is:bd%ie, bd%js:bd%je)
3359  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub, vb
3360  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub_ad, vb_ad
3361  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
3362  REAL :: wk_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
3363  REAL :: ke(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3364  REAL :: ke_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3365  REAL :: vort(bd%isd:bd%ied, bd%jsd:bd%jed)
3366  REAL :: vort_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
3367  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
3368  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
3369  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
3370  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
3371  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
3372  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
3373  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
3374  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
3375  REAL :: gx(bd%is:bd%ie+1, bd%js:bd%je)
3376  REAL :: gx_ad(bd%is:bd%ie+1, bd%js:bd%je)
3377  REAL :: gy(bd%is:bd%ie, bd%js:bd%je+1)
3378  REAL :: gy_ad(bd%is:bd%ie, bd%js:bd%je+1)
3379  LOGICAL :: fill_c
3380  REAL :: dt2, dt4, dt5, dt6
3381  REAL :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
3382  REAL :: u2_ad, v2_ad, du2_ad, dv2_ad
3383  REAL :: u_lon
3384  INTEGER :: i, j, is2, ie1, js2, je1, n, nt, n2, iq
3385  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
3386  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
3387  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
3388  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
3389  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
3390  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
3391  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
3392 & , rdx, rdy
3393  INTEGER :: is, ie, js, je
3394  INTEGER :: isd, ied, jsd, jed
3395  INTEGER :: npx, npy
3396  LOGICAL :: nested
3397  REAL :: delp_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3398  REAL :: pt_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3399  REAL :: vort_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3400  REAL :: wk_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3401  REAL :: delpc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3402  REAL :: ptc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
3403  REAL :: ke_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3404  REAL :: vc_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3405  REAL :: uc_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3406  REAL :: divg_d_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3407  REAL :: ut_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
3408  REAL :: vt_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
3409  INTRINSIC max
3410  INTRINSIC min
3411  INTRINSIC abs
3412  INTEGER :: max1
3413  INTEGER :: max2
3414  INTEGER :: max3
3415  INTEGER :: max4
3416  REAL :: abs0
3417  INTEGER :: min1
3418  INTEGER :: min2
3419  INTEGER :: min3
3420  INTEGER :: min4
3421  REAL :: temp_ad
3422  REAL :: temp_ad0
3423  REAL :: temp_ad1
3424  REAL :: temp_ad2
3425  REAL :: temp_ad3
3426  REAL :: temp_ad4
3427  REAL :: temp_ad5
3428  REAL :: temp_ad6
3429  REAL :: temp_ad7
3430  REAL :: temp_ad8
3431  REAL :: temp_ad9
3432  REAL :: temp_ad10
3433  REAL :: temp_ad11
3434  REAL :: temp_ad12
3435  REAL :: temp_ad13
3436  REAL :: temp_ad14
3437  REAL :: temp_ad15
3438  REAL :: temp_ad16
3439  REAL :: temp_ad17
3440  REAL :: temp_ad18
3441  REAL :: temp_ad19
3442  REAL :: temp_ad20
3443  REAL :: temp_ad21
3444  REAL :: temp_ad22
3445  REAL :: temp_ad23
3446  REAL :: temp_ad24
3447  REAL :: temp_ad25
3448  REAL :: temp_ad26
3449  REAL :: temp_ad27
3450  REAL :: temp_ad28
3451  REAL :: temp_ad29
3452  REAL :: temp_ad30
3453  REAL :: temp_ad31
3454  REAL :: temp_ad32
3455  REAL :: temp_ad33
3456  REAL :: temp_ad34
3457  REAL :: temp_ad35
3458  REAL :: temp_ad36
3459  REAL :: temp_ad37
3460  REAL :: temp_ad38
3461  REAL :: temp_ad39
3462  REAL :: temp_ad40
3463  REAL :: temp_ad41
3464  REAL :: temp_ad42
3465  REAL :: temp_ad43
3466  REAL :: temp_ad44
3467  REAL :: temp_ad45
3468  REAL :: temp_ad46
3469  REAL :: temp_ad47
3470  REAL :: temp_ad48
3471  REAL :: temp_ad49
3472  REAL :: temp_ad50
3473  REAL :: temp_ad51
3474  REAL :: temp_ad52
3475  REAL :: temp
3476  REAL :: temp_ad53
3477  REAL :: temp_ad54
3478  REAL :: temp_ad55
3479  REAL :: temp_ad56
3480  REAL :: temp_ad57
3481  REAL :: temp_ad58
3482  REAL :: temp_ad59
3483  REAL :: temp_ad60
3484  REAL :: temp_ad61
3485  REAL :: temp_ad62
3486  REAL :: temp_ad63
3487  REAL :: temp_ad64
3488  REAL :: temp_ad65
3489  REAL :: temp_ad66
3490  REAL :: temp_ad67
3491  REAL :: temp_ad68
3492  REAL :: temp_ad69
3493  REAL :: temp_ad70
3494  REAL :: temp_ad71
3495  REAL :: temp_ad72
3496  REAL :: temp_ad73
3497  REAL :: temp_ad74
3498  REAL :: temp_ad75
3499  REAL :: temp_ad76
3500  REAL :: temp_ad77
3501  REAL :: temp_ad78
3502  REAL :: temp_ad79
3503  REAL :: temp_ad80
3504  REAL :: temp_ad81
3505  REAL :: temp_ad82
3506  REAL :: temp_ad83
3507  REAL :: temp_ad84
3508  REAL :: temp_ad85
3509  REAL :: temp_ad86
3510  REAL :: temp_ad87
3511  REAL :: temp0
3512  REAL :: temp_ad88
3513  REAL :: temp_ad89
3514  REAL :: temp_ad90
3515  REAL :: temp_ad91
3516  INTEGER :: branch
3517  !TYPE(C_PTR) :: cptr
3518  !INTEGER :: unknown_shape_in_d_sw
3519 
3520  ut = 0.0
3521  vt = 0.0
3522  fx2 = 0.0
3523  fy2 = 0.0
3524  dw = 0.0
3525  ub = 0.0
3526  vb = 0.0
3527  wk = 0.0
3528  ke = 0.0
3529  vort = 0.0
3530  fx = 0.0
3531  fy = 0.0
3532  ra_x = 0.0
3533  ra_y = 0.0
3534  gx = 0.0
3535  gy = 0.0
3536  dt2 = 0.0
3537  dt4 = 0.0
3538  dt5 = 0.0
3539  dt6 = 0.0
3540  damp = 0.0
3541  damp2 = 0.0
3542  damp4 = 0.0
3543  dd8 = 0.0
3544  u2 = 0.0
3545  v2 = 0.0
3546  du2 = 0.0
3547  dv2 = 0.0
3548  u_lon = 0.0
3549  is2 = 0
3550  ie1 = 0
3551  js2 = 0
3552  je1 = 0
3553  n = 0
3554  nt = 0
3555  n2 = 0
3556  iq = 0
3557  is = 0
3558  ie = 0
3559  js = 0
3560  je = 0
3561  isd = 0
3562  ied = 0
3563  jsd = 0
3564  jed = 0
3565  npx = 0
3566  npy = 0
3567  max1 = 0
3568  max2 = 0
3569  max3 = 0
3570  max4 = 0
3571  abs0 = 0.0
3572  min1 = 0
3573  min2 = 0
3574  min3 = 0
3575  min4 = 0
3576  branch = 0
3577 
3578  is = bd%is
3579  ie = bd%ie
3580  js = bd%js
3581  je = bd%je
3582  isd = bd%isd
3583  ied = bd%ied
3584  jsd = bd%jsd
3585  jed = bd%jed
3586  npx = flagstruct%npx
3587  npy = flagstruct%npy
3588  nested = gridstruct%nested
3589  area => gridstruct%area
3590  rarea => gridstruct%rarea
3591  sin_sg => gridstruct%sin_sg
3592  cosa_u => gridstruct%cosa_u
3593  cosa_v => gridstruct%cosa_v
3594  cosa_s => gridstruct%cosa_s
3595  rsin_u => gridstruct%rsin_u
3596  rsin_v => gridstruct%rsin_v
3597  rsina => gridstruct%rsina
3598  f0 => gridstruct%f0
3599  rsin2 => gridstruct%rsin2
3600  cosa => gridstruct%cosa
3601  dx => gridstruct%dx
3602  dy => gridstruct%dy
3603  rdxa => gridstruct%rdxa
3604  rdya => gridstruct%rdya
3605  rdx => gridstruct%rdx
3606  rdy => gridstruct%rdy
3607  sw_corner = gridstruct%sw_corner
3608  se_corner = gridstruct%se_corner
3609  nw_corner = gridstruct%nw_corner
3610  ne_corner = gridstruct%ne_corner
3611  CALL popcontrol(1,branch)
3612  IF (branch .EQ. 0) THEN
3613  CALL poprealarray(damp4)
3614  CALL popinteger(js)
3615  CALL popinteger(npx)
3616  CALL popinteger(npy)
3617  CALL popinteger(max1)
3618  CALL popinteger(max2)
3619  CALL popinteger(max3)
3620  CALL popinteger(max4)
3621  CALL poprealarray(damp)
3622  CALL poprealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3623  CALL poprealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3624  CALL poprealarray(dw, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
3625  !CALL POPPOINTER8(cptr)
3626  dx => gridstruct%dx ! (/unknown_shape_in_d_sw/))
3627  CALL popinteger(is2)
3628  !CALL POPPOINTER8(cptr)
3629  dy => gridstruct%dy ! (/unknown_shape_in_d_sw/))
3630  !CALL POPPOINTER8(cptr)
3631  rdya => gridstruct%rdya ! (/unknown_shape_in_d_sw/))
3632  CALL poprealarray(ub, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3633  !CALL POPPOINTER8(cptr)
3634  cosa_u => gridstruct%cosa_u ! (/unknown_shape_in_d_sw/))
3635  !CALL POPPOINTER8(cptr)
3636  cosa_v => gridstruct%cosa_v ! (/unknown_shape_in_d_sw/))
3637  !CALL POPPOINTER8(cptr)
3638  cosa => gridstruct%cosa ! (/unknown_shape_in_d_sw/))
3639  CALL poprealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3640  CALL popinteger(je1)
3641  !CALL POPPOINTER8(cptr)
3642  sin_sg => gridstruct%sin_sg ! (/unknown_shape_in_d_sw/))
3643  CALL poprealarray(dt4)
3644  CALL poprealarray(dt6)
3645  CALL popinteger(ie)
3646  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
3647  CALL poprealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3648  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
3649  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3650  !CALL POPPOINTER8(cptr)
3651  rsin_u => gridstruct%rsin_u ! (/unknown_shape_in_d_sw/))
3652  CALL popinteger(is)
3653  !CALL POPPOINTER8(cptr)
3654  rsina => gridstruct%rsina ! (/unknown_shape_in_d_sw/))
3655  !CALL POPPOINTER8(cptr)
3656  rdx => gridstruct%rdx ! (/unknown_shape_in_d_sw/))
3657  CALL poprealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3658  CALL popinteger(js2)
3659  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3660  CALL popinteger(min1)
3661  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3662  CALL popinteger(min2)
3663  CALL popinteger(min3)
3664  CALL popinteger(ie1)
3665  CALL popinteger(min4)
3666  CALL popinteger(je)
3667  !CALL POPPOINTER8(cptr)
3668  rdxa => gridstruct%rdxa ! (/unknown_shape_in_d_sw/))
3669  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3670  ut_ad = 0.0
3671  vt_ad = 0.0
3672  ELSE
3673  CALL poprealarray(damp4)
3674  CALL popinteger(js)
3675  CALL popinteger(npx)
3676  CALL popinteger(npy)
3677  CALL popinteger(max1)
3678  CALL popinteger(max2)
3679  CALL popinteger(max3)
3680  CALL popinteger(max4)
3681  CALL poprealarray(damp)
3682  CALL poprealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3683  CALL poprealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3684  CALL poprealarray(dw, (bd%ie-bd%is+1)*(bd%je-bd%js+1))
3685  !CALL POPPOINTER8(cptr)
3686  dx => gridstruct%dx ! (/unknown_shape_in_d_sw/))
3687  CALL popinteger(is2)
3688  !CALL POPPOINTER8(cptr)
3689  dy => gridstruct%dy ! (/unknown_shape_in_d_sw/))
3690  !CALL POPPOINTER8(cptr)
3691  rdya => gridstruct%rdya ! (/unknown_shape_in_d_sw/))
3692  CALL poprealarray(ub, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3693  !CALL POPPOINTER8(cptr)
3694  cosa_u => gridstruct%cosa_u ! (/unknown_shape_in_d_sw/))
3695  !CALL POPPOINTER8(cptr)
3696  cosa_v => gridstruct%cosa_v ! (/unknown_shape_in_d_sw/))
3697  !CALL POPPOINTER8(cptr)
3698  cosa => gridstruct%cosa ! (/unknown_shape_in_d_sw/))
3699  CALL poprealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3700  CALL popinteger(je1)
3701  !CALL POPPOINTER8(cptr)
3702  sin_sg => gridstruct%sin_sg ! (/unknown_shape_in_d_sw/))
3703  CALL poprealarray(dt4)
3704  CALL poprealarray(dt6)
3705  CALL popinteger(ie)
3706  CALL poprealarray(ra_x, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
3707  CALL poprealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
3708  CALL poprealarray(ra_y, (bd%ied-bd%isd+1)*(bd%je-bd%js+1))
3709  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3710  !CALL POPPOINTER8(cptr)
3711  rsin_u => gridstruct%rsin_u ! (/unknown_shape_in_d_sw/))
3712  CALL popinteger(is)
3713  !CALL POPPOINTER8(cptr)
3714  rsina => gridstruct%rsina ! (/unknown_shape_in_d_sw/))
3715  !CALL POPPOINTER8(cptr)
3716  rdx => gridstruct%rdx ! (/unknown_shape_in_d_sw/))
3717  CALL poprealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3718  CALL popinteger(js2)
3719  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3720  CALL popinteger(min1)
3721  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3722  CALL popinteger(min2)
3723  CALL popinteger(min3)
3724  CALL popinteger(ie1)
3725  CALL popinteger(min4)
3726  CALL popinteger(je)
3727  !CALL POPPOINTER8(cptr)
3728  rdxa => gridstruct%rdxa ! (/unknown_shape_in_d_sw/))
3729  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3730  ut_ad = 0.0
3731  DO j=je,js,-1
3732  DO i=ie+1,is,-1
3733  CALL poprealarray(v(i, j))
3734  ut_ad(i, j) = ut_ad(i, j) - v_ad(i, j)
3735  END DO
3736  END DO
3737  vt_ad = 0.0
3738  DO j=je+1,js,-1
3739  DO i=ie,is,-1
3740  CALL poprealarray(u(i, j))
3741  vt_ad(i, j) = vt_ad(i, j) + u_ad(i, j)
3742  END DO
3743  END DO
3744  END IF
3745  CALL popcontrol(1,branch)
3746  IF (branch .EQ. 0) THEN
3747  DO j=je,js,-1
3748  DO i=ie+1,is,-1
3749  CALL poprealarray(v(i, j))
3750  !ut_ad(i, j) = ut_ad(i, j) - v_ad(i, j)
3751  END DO
3752  END DO
3753  DO j=je+1,js,-1
3754  DO i=ie,is,-1
3755  CALL poprealarray(u(i, j))
3756  !vt_ad(i, j) = vt_ad(i, j) + u_ad(i, j)
3757  END DO
3758  END DO
3759  END IF
3760  rsin2 => gridstruct%rsin2
3761  cosa_s => gridstruct%cosa_s
3762  CALL popcontrol(1,branch)
3763  IF (branch .EQ. 0) THEN
3764  gx_ad = 0.0
3765  gy_ad = 0.0
3766  ub_ad = 0.0
3767  vb_ad = 0.0
3768  fx_ad = 0.0
3769  fy_ad = 0.0
3770  DO j=je,js,-1
3771  DO i=ie,is,-1
3772  dv2 = vb(i, j) + vb(i+1, j)
3773  v2 = fx(i, j) + fx(i+1, j)
3774  du2 = ub(i, j) + ub(i, j+1)
3775  u2 = fy(i, j) + fy(i, j+1)
3776  CALL poprealarray(heat_source(i, j))
3777  temp0 = damp*rsin2(i, j)
3778  temp_ad88 = delp(i, j)*heat_source_ad(i, j)
3779  temp_ad89 = -(temp0*temp_ad88)
3780  temp_ad90 = 2.*temp_ad89
3781  temp_ad91 = -(cosa_s(i, j)*temp_ad89)
3782  delp_ad(i, j) = delp_ad(i, j) + (heat_source(i, j)-temp0*(ub(i&
3783 & , j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j)**2+2.*(gy(i, j)&
3784 & +gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, j)*(u2*dv2+v2*du2&
3785 & +du2*dv2)))*heat_source_ad(i, j)
3786  ub_ad(i, j) = ub_ad(i, j) + 2*ub(i, j)*temp_ad89
3787  ub_ad(i, j+1) = ub_ad(i, j+1) + 2*ub(i, j+1)*temp_ad89
3788  vb_ad(i, j) = vb_ad(i, j) + 2*vb(i, j)*temp_ad89
3789  vb_ad(i+1, j) = vb_ad(i+1, j) + 2*vb(i+1, j)*temp_ad89
3790  gy_ad(i, j) = gy_ad(i, j) + temp_ad90
3791  gy_ad(i, j+1) = gy_ad(i, j+1) + temp_ad90
3792  gx_ad(i, j) = gx_ad(i, j) + temp_ad90
3793  gx_ad(i+1, j) = gx_ad(i+1, j) + temp_ad90
3794  u2_ad = dv2*temp_ad91
3795  dv2_ad = (du2+u2)*temp_ad91
3796  v2_ad = du2*temp_ad91
3797  du2_ad = (dv2+v2)*temp_ad91
3798  heat_source_ad(i, j) = temp_ad88
3799  vb_ad(i, j) = vb_ad(i, j) + dv2_ad
3800  vb_ad(i+1, j) = vb_ad(i+1, j) + dv2_ad
3801  fx_ad(i, j) = fx_ad(i, j) + v2_ad
3802  fx_ad(i+1, j) = fx_ad(i+1, j) + v2_ad
3803  ub_ad(i, j) = ub_ad(i, j) + du2_ad
3804  ub_ad(i, j+1) = ub_ad(i, j+1) + du2_ad
3805  fy_ad(i, j) = fy_ad(i, j) + u2_ad
3806  fy_ad(i, j+1) = fy_ad(i, j+1) + u2_ad
3807  END DO
3808  END DO
3809  rdy => gridstruct%rdy
3810  DO j=je,js,-1
3811  DO i=ie+1,is,-1
3812  CALL poprealarray(gx(i, j))
3813  fx_ad(i, j) = fx_ad(i, j) + vb(i, j)*gx_ad(i, j)
3814  vb_ad(i, j) = vb_ad(i, j) + fx(i, j)*gx_ad(i, j)
3815  gx_ad(i, j) = 0.0
3816  CALL poprealarray(fx(i, j))
3817  v_ad(i, j) = v_ad(i, j) + rdy(i, j)*fx_ad(i, j)
3818  fx_ad(i, j) = 0.0
3819  CALL poprealarray(vb(i, j))
3820  temp_ad87 = rdy(i, j)*vb_ad(i, j)
3821  ut_ad(i, j) = ut_ad(i, j) - temp_ad87
3822  vb_ad(i, j) = temp_ad87
3823  END DO
3824  END DO
3825  DO j=je+1,js,-1
3826  DO i=ie,is,-1
3827  CALL poprealarray(gy(i, j))
3828  fy_ad(i, j) = fy_ad(i, j) + ub(i, j)*gy_ad(i, j)
3829  ub_ad(i, j) = ub_ad(i, j) + fy(i, j)*gy_ad(i, j)
3830  gy_ad(i, j) = 0.0
3831  CALL poprealarray(fy(i, j))
3832  u_ad(i, j) = u_ad(i, j) + rdx(i, j)*fy_ad(i, j)
3833  fy_ad(i, j) = 0.0
3834  CALL poprealarray(ub(i, j))
3835  temp_ad86 = rdx(i, j)*ub_ad(i, j)
3836  vt_ad(i, j) = vt_ad(i, j) + temp_ad86
3837  ub_ad(i, j) = temp_ad86
3838  END DO
3839  END DO
3840  ELSE
3841  gx_ad = 0.0
3842  gy_ad = 0.0
3843  ub_ad = 0.0
3844  vb_ad = 0.0
3845  fx_ad = 0.0
3846  fy_ad = 0.0
3847  END IF
3848  CALL popcontrol(1,branch)
3849  IF (branch .EQ. 0) THEN
3850  damp4 = (damp_v_pert*gridstruct%da_min_c)**(nord_v_pert+1)
3851  npx = flagstruct%npx
3852  npy = flagstruct%npy
3853  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3854  CALL poprealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3855  CALL poprealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3856  wk_ad = 0.0
3857  vort_ad = 0.0
3858  CALL del6_vt_flux_adm(nord_v_pert, npx, npy, damp4, wk, wk_ad, &
3859 & vort, vort_ad, ut, ut_ad, vt, vt_ad, gridstruct, &
3860 & bd)
3861  ELSE
3862  vort_ad = 0.0
3863  wk_ad = 0.0
3864  END IF
3865  CALL popcontrol(1,branch)
3866  IF (branch .EQ. 0) THEN
3867  damp4 = (damp_v*gridstruct%da_min_c)**(nord_v+1)
3868  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3869  CALL poprealarray(ut, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3870  CALL poprealarray(vt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3871 ! CALL DEL6_VT_FLUX_ADM(nord_v, npx, npy, damp4, wk, wk_ad, vort, &
3872 !& vort_ad, ut, ut_ad, vt, vt_ad, gridstruct, bd)
3873  END IF
3874  ke_ad = 0.0
3875  DO j=je,js,-1
3876  DO i=ie+1,is,-1
3877  CALL poprealarray(v(i, j))
3878  ut_ad(i, j) = ut_ad(i, j) + v_ad(i, j)
3879  ke_ad(i, j) = ke_ad(i, j) + v_ad(i, j)
3880  ke_ad(i, j+1) = ke_ad(i, j+1) - v_ad(i, j)
3881  fx_ad(i, j) = fx_ad(i, j) - v_ad(i, j)
3882  v_ad(i, j) = 0.0
3883  END DO
3884  END DO
3885  DO j=je+1,js,-1
3886  DO i=ie,is,-1
3887  CALL poprealarray(u(i, j))
3888  vt_ad(i, j) = vt_ad(i, j) + u_ad(i, j)
3889  ke_ad(i, j) = ke_ad(i, j) + u_ad(i, j)
3890  fy_ad(i, j) = fy_ad(i, j) + u_ad(i, j)
3891  ke_ad(i+1, j) = ke_ad(i+1, j) - u_ad(i, j)
3892  u_ad(i, j) = 0.0
3893  END DO
3894  END DO
3895  CALL popcontrol(1,branch)
3896  IF (branch .EQ. 0) THEN
3897  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3898  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
3899  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
3900  ra_x_ad = 0.0
3901  ra_y_ad = 0.0
3902  CALL fv_tp_2d_adm(vort, vort_ad, crx_adv, crx_adv_ad, cry_adv, &
3903 & cry_adv_ad, npx, npy, hord_vt_pert, fx, fx_ad, fy, &
3904 & fy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
3905 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad)
3906  ELSE
3907  ra_x_ad = 0.0
3908  ra_y_ad = 0.0
3909  CALL fv_tp_2d_bwd(vort, vort_ad, crx_adv, crx_adv_ad, cry_adv, &
3910 & cry_adv_ad, npx, npy, hord_vt, fx, fx_ad, fy, fy_ad&
3911 & , xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
3912 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad)
3913  END IF
3914  f0 => gridstruct%f0
3915  jsd = bd%jsd
3916  ied = bd%ied
3917  isd = bd%isd
3918  jed = bd%jed
3919  CALL popcontrol(2,branch)
3920  IF (branch .EQ. 0) THEN
3921  DO j=jed,jsd,-1
3922  DO i=ied,isd,-1
3923  wk_ad(i, j) = wk_ad(i, j) + vort_ad(i, j)
3924  vort_ad(i, j) = 0.0
3925  END DO
3926  END DO
3927  ELSE IF (branch .EQ. 1) THEN
3928  DO j=jed,jsd,-1
3929  DO i=ied,isd,-1
3930  wk_ad(i, j) = wk_ad(i, j) + vort_ad(i, j)
3931  z_rat_ad(i, j) = z_rat_ad(i, j) + f0(i, j)*vort_ad(i, j)
3932  vort_ad(i, j) = 0.0
3933  END DO
3934  END DO
3935  ELSE
3936  DO j=jed,jsd,-1
3937  DO i=ied,isd,-1
3938  wk_ad(i, j) = wk_ad(i, j) + vort_ad(i, j)
3939  vort_ad(i, j) = 0.0
3940  END DO
3941  END DO
3942  END IF
3943  CALL popcontrol(1,branch)
3944  IF (branch .EQ. 0) THEN
3945  DO j=je,js,-1
3946  DO i=ie+1,is,-1
3947  CALL poprealarray(vb(i, j))
3948  vort_ad(i, j) = vort_ad(i, j) + vb_ad(i, j)
3949  vort_ad(i, j+1) = vort_ad(i, j+1) - vb_ad(i, j)
3950  vb_ad(i, j) = 0.0
3951  END DO
3952  END DO
3953  DO j=je+1,js,-1
3954  DO i=ie,is,-1
3955  CALL poprealarray(ub(i, j))
3956  vort_ad(i, j) = vort_ad(i, j) + ub_ad(i, j)
3957  vort_ad(i+1, j) = vort_ad(i+1, j) - ub_ad(i, j)
3958  ub_ad(i, j) = 0.0
3959  END DO
3960  END DO
3961  END IF
3962  CALL popcontrol(1,branch)
3963  IF (branch .EQ. 0) THEN
3964  CALL compute_divergence_damping_bwd(nord, d2_bg, d4_bg, dddmp, &
3965 & dt, vort, vort_ad, ptc, ptc_ad, &
3966 & delpc, delpc_ad, ke, ke_ad, u, &
3967 & u_ad, v, v_ad, uc, uc_ad, vc, &
3968 & vc_ad, ua, ua_ad, va, va_ad, &
3969 & divg_d, divg_d_ad, wk, wk_ad, &
3970 & gridstruct, flagstruct, bd)
3971  ELSE
3972  CALL poprealarray(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3973  CALL poprealarray(ptc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3974  CALL poprealarray(delpc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3975  CALL poprealarray(uc, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
3976  CALL poprealarray(vc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
3977  CALL poprealarray(divg_d, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+2))
3978  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
3979  CALL compute_divergence_damping_adm(nord_pert, d2_bg_pert, &
3980 & d4_bg_pert, dddmp_pert, dt, vort, &
3981 & vort_ad, ptc, ptc_ad, delpc, &
3982 & delpc_ad, ke, ke_ad, u, u_ad, v, &
3983 & v_ad, uc, uc_ad, vc, vc_ad, ua, &
3984 & ua_ad, va, va_ad, divg_d, divg_d_ad&
3985 & , wk, wk_ad, gridstruct, flagstruct&
3986 & , bd)
3987  END IF
3988  CALL popcontrol(2,branch)
3989  IF (branch .EQ. 0) THEN
3990  dw_ad = 0.0
3991  DO j=je,js,-1
3992  DO i=ie,is,-1
3993  CALL poprealarray(w(i, j))
3994  dw_ad(i, j) = dw_ad(i, j) + w_ad(i, j)
3995  END DO
3996  END DO
3997  ELSE IF (branch .EQ. 1) THEN
3998  dw_ad = 0.0
3999  ELSE
4000  dw_ad = 0.0
4001  GOTO 100
4002  END IF
4003  CALL popcontrol(1,branch)
4004  IF (branch .NE. 0) THEN
4005  DO j=je,js,-1
4006  DO i=ie,is,-1
4007  CALL poprealarray(w(i, j))
4008  temp_ad85 = w_ad(i, j)/delp(i, j)
4009  delp_ad(i, j) = delp_ad(i, j) - w(i, j)*temp_ad85/delp(i, j)
4010  w_ad(i, j) = temp_ad85
4011  END DO
4012  END DO
4013  END IF
4014  100 rarea => gridstruct%rarea
4015  DO j=jed,jsd,-1
4016  DO i=ied,isd,-1
4017  CALL poprealarray(wk(i, j))
4018  temp_ad84 = rarea(i, j)*wk_ad(i, j)
4019  vt_ad(i, j) = vt_ad(i, j) + temp_ad84
4020  vt_ad(i, j+1) = vt_ad(i, j+1) - temp_ad84
4021  ut_ad(i+1, j) = ut_ad(i+1, j) + temp_ad84
4022  ut_ad(i, j) = ut_ad(i, j) - temp_ad84
4023  wk_ad(i, j) = 0.0
4024  END DO
4025  END DO
4026  DO j=jed,jsd,-1
4027  DO i=ied+1,isd,-1
4028  CALL poprealarray(ut(i, j))
4029  v_ad(i, j) = v_ad(i, j) + dy(i, j)*ut_ad(i, j)
4030  ut_ad(i, j) = 0.0
4031  END DO
4032  END DO
4033  DO j=jed+1,jsd,-1
4034  DO i=ied,isd,-1
4035  CALL poprealarray(vt(i, j))
4036  u_ad(i, j) = u_ad(i, j) + dx(i, j)*vt_ad(i, j)
4037  vt_ad(i, j) = 0.0
4038  END DO
4039  END DO
4040  CALL popcontrol(2,branch)
4041  IF (branch .NE. 0) THEN
4042  IF (branch .NE. 1) THEN
4043  dt6 = dt/6.
4044  temp_ad80 = dt6*ke_ad(1, npy)
4045  temp_ad81 = u(1, npy)*temp_ad80
4046  temp_ad82 = v(1, npy-1)*temp_ad80
4047  temp_ad83 = u(0, npy)*temp_ad80
4048  ut_ad(1, npy) = ut_ad(1, npy) + temp_ad81
4049  ut_ad(1, npy-1) = ut_ad(1, npy-1) + temp_ad83 + temp_ad81
4050  u_ad(1, npy) = u_ad(1, npy) + (ut(1, npy)+ut(1, npy-1))*&
4051 & temp_ad80
4052  vt_ad(1, npy) = vt_ad(1, npy) + temp_ad82 - temp_ad83
4053  vt_ad(0, npy) = vt_ad(0, npy) + temp_ad82
4054  v_ad(1, npy-1) = v_ad(1, npy-1) + (vt(1, npy)+vt(0, npy))*&
4055 & temp_ad80
4056  u_ad(0, npy) = u_ad(0, npy) + (ut(1, npy-1)-vt(1, npy))*&
4057 & temp_ad80
4058  ke_ad(1, npy) = 0.0
4059  END IF
4060  CALL popcontrol(1,branch)
4061  IF (branch .EQ. 0) THEN
4062  temp_ad76 = dt6*ke_ad(npx, npy)
4063  temp_ad77 = u(npx-1, npy)*temp_ad76
4064  temp_ad78 = v(npx, npy-1)*temp_ad76
4065  temp_ad79 = u(npx, npy)*temp_ad76
4066  ut_ad(npx, npy) = ut_ad(npx, npy) + temp_ad77
4067  ut_ad(npx, npy-1) = ut_ad(npx, npy-1) + temp_ad79 + temp_ad77
4068  u_ad(npx-1, npy) = u_ad(npx-1, npy) + (ut(npx, npy)+ut(npx, npy-&
4069 & 1))*temp_ad76
4070  vt_ad(npx, npy) = vt_ad(npx, npy) + temp_ad78
4071  vt_ad(npx-1, npy) = vt_ad(npx-1, npy) + temp_ad79 + temp_ad78
4072  v_ad(npx, npy-1) = v_ad(npx, npy-1) + (vt(npx, npy)+vt(npx-1, &
4073 & npy))*temp_ad76
4074  u_ad(npx, npy) = u_ad(npx, npy) + (ut(npx, npy-1)+vt(npx-1, npy)&
4075 & )*temp_ad76
4076  ke_ad(npx, npy) = 0.0
4077  END IF
4078  CALL popcontrol(1,branch)
4079  IF (branch .EQ. 0) THEN
4080  temp_ad72 = dt6*ke_ad(npx, 1)
4081  temp_ad73 = u(npx-1, 1)*temp_ad72
4082  temp_ad74 = v(npx, 1)*temp_ad72
4083  temp_ad75 = u(npx, 1)*temp_ad72
4084  ut_ad(npx, 1) = ut_ad(npx, 1) + temp_ad75 + temp_ad73
4085  ut_ad(npx, 0) = ut_ad(npx, 0) + temp_ad73
4086  u_ad(npx-1, 1) = u_ad(npx-1, 1) + (ut(npx, 1)+ut(npx, 0))*&
4087 & temp_ad72
4088  vt_ad(npx, 1) = vt_ad(npx, 1) + temp_ad74
4089  vt_ad(npx-1, 1) = vt_ad(npx-1, 1) + temp_ad74 - temp_ad75
4090  v_ad(npx, 1) = v_ad(npx, 1) + (vt(npx, 1)+vt(npx-1, 1))*&
4091 & temp_ad72
4092  u_ad(npx, 1) = u_ad(npx, 1) + (ut(npx, 1)-vt(npx-1, 1))*&
4093 & temp_ad72
4094  ke_ad(npx, 1) = 0.0
4095  END IF
4096  CALL popcontrol(1,branch)
4097  IF (branch .EQ. 0) THEN
4098  temp_ad71 = dt6*ke_ad(1, 1)
4099  ut_ad(1, 1) = ut_ad(1, 1) + (u(0, 1)+u(1, 1))*temp_ad71
4100  ut_ad(1, 0) = ut_ad(1, 0) + u(1, 1)*temp_ad71
4101  u_ad(1, 1) = u_ad(1, 1) + (ut(1, 1)+ut(1, 0))*temp_ad71
4102  vt_ad(1, 1) = vt_ad(1, 1) + (u(0, 1)+v(1, 1))*temp_ad71
4103  vt_ad(0, 1) = vt_ad(0, 1) + v(1, 1)*temp_ad71
4104  v_ad(1, 1) = v_ad(1, 1) + (vt(1, 1)+vt(0, 1))*temp_ad71
4105  u_ad(0, 1) = u_ad(0, 1) + (ut(1, 1)+vt(1, 1))*temp_ad71
4106  ke_ad(1, 1) = 0.0
4107  END IF
4108  END IF
4109  nested = gridstruct%nested
4110  DO j=je+1,js,-1
4111  DO i=ie+1,is,-1
4112  temp_ad70 = 0.5*ke_ad(i, j)
4113  ub_ad(i, j) = ub_ad(i, j) + vb(i, j)*temp_ad70
4114  vb_ad(i, j) = vb_ad(i, j) + ub(i, j)*temp_ad70
4115  ke_ad(i, j) = temp_ad70
4116  END DO
4117  END DO
4118  CALL popcontrol(1,branch)
4119  IF (branch .EQ. 0) THEN
4120  CALL poprealarray(vb, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
4121  CALL xtp_u_adm(is, ie, js, je, isd, ied, jsd, jed, ub, ub_ad, u, &
4122 & u_ad, v, vb, vb_ad, hord_mt_pert, gridstruct%dx, &
4123 & gridstruct%rdx, npx, npy, flagstruct%grid_type, nested)
4124  ELSE
4125  CALL xtp_u_bwd(is, ie, js, je, isd, ied, jsd, jed, ub, ub_ad, u&
4126 & , u_ad, v, vb, vb_ad, hord_mt, gridstruct%dx, &
4127 & gridstruct%rdx, npx, npy, flagstruct%grid_type, nested&
4128 & )
4129  END IF
4130  dt5 = 0.5*dt
4131  CALL popcontrol(2,branch)
4132  IF (branch .LT. 2) THEN
4133  IF (branch .EQ. 0) THEN
4134  DO j=je+1,js,-1
4135  DO i=ie1,is2,-1
4136  CALL poprealarray(ub(i, j))
4137  temp_ad65 = dt5*rsina(i, j)*ub_ad(i, j)
4138  temp_ad66 = -(cosa(i, j)*temp_ad65)
4139  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad65
4140  uc_ad(i, j) = uc_ad(i, j) + temp_ad65
4141  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad66
4142  vc_ad(i, j) = vc_ad(i, j) + temp_ad66
4143  ub_ad(i, j) = 0.0
4144  END DO
4145  END DO
4146  GOTO 110
4147  ELSE
4148  DO j=je+1,js,-1
4149  CALL poprealarray(ub(npx, j))
4150  ut_ad(npx, j-1) = ut_ad(npx, j-1) + dt5*ub_ad(npx, j)
4151  ut_ad(npx, j) = ut_ad(npx, j) + dt5*ub_ad(npx, j)
4152  ub_ad(npx, j) = 0.0
4153  END DO
4154  END IF
4155  ELSE IF (branch .NE. 2) THEN
4156  DO j=je+1,js,-1
4157  DO i=ie+1,is,-1
4158  CALL poprealarray(ub(i, j))
4159  uc_ad(i, j-1) = uc_ad(i, j-1) + dt5*ub_ad(i, j)
4160  uc_ad(i, j) = uc_ad(i, j) + dt5*ub_ad(i, j)
4161  ub_ad(i, j) = 0.0
4162  END DO
4163  END DO
4164  GOTO 110
4165  END IF
4166  cosa => gridstruct%cosa
4167  dt4 = 0.25*dt
4168  rsina => gridstruct%rsina
4169  DO j=je+1,js,-1
4170  CALL popcontrol(1,branch)
4171  IF (branch .EQ. 0) THEN
4172  DO i=ie1,is2,-1
4173  CALL poprealarray(ub(i, j))
4174  temp_ad68 = dt5*rsina(i, j)*ub_ad(i, j)
4175  temp_ad69 = -(cosa(i, j)*temp_ad68)
4176  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad68
4177  uc_ad(i, j) = uc_ad(i, j) + temp_ad68
4178  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad69
4179  vc_ad(i, j) = vc_ad(i, j) + temp_ad69
4180  ub_ad(i, j) = 0.0
4181  END DO
4182  ELSE
4183  DO i=ie1,is2,-1
4184  CALL poprealarray(ub(i, j))
4185  temp_ad67 = dt4*ub_ad(i, j)
4186  ut_ad(i, j-1) = ut_ad(i, j-1) + 3.*temp_ad67
4187  ut_ad(i, j) = ut_ad(i, j) + 3.*temp_ad67
4188  ut_ad(i, j-2) = ut_ad(i, j-2) - temp_ad67
4189  ut_ad(i, j+1) = ut_ad(i, j+1) - temp_ad67
4190  ub_ad(i, j) = 0.0
4191  END DO
4192  END IF
4193  END DO
4194  CALL popcontrol(1,branch)
4195  IF (branch .NE. 0) THEN
4196  DO j=je+1,js,-1
4197  CALL poprealarray(ub(1, j))
4198  ut_ad(1, j-1) = ut_ad(1, j-1) + dt5*ub_ad(1, j)
4199  ut_ad(1, j) = ut_ad(1, j) + dt5*ub_ad(1, j)
4200  ub_ad(1, j) = 0.0
4201  END DO
4202  END IF
4203  110 DO j=je+1,js,-1
4204  DO i=ie+1,is,-1
4205  vb_ad(i, j) = vb_ad(i, j) + ub(i, j)*ke_ad(i, j)
4206  ub_ad(i, j) = ub_ad(i, j) + vb(i, j)*ke_ad(i, j)
4207  ke_ad(i, j) = 0.0
4208  END DO
4209  END DO
4210  CALL popcontrol(1,branch)
4211  IF (branch .EQ. 0) THEN
4212  CALL ytp_v_adm(is, ie, js, je, isd, ied, jsd, jed, vb, vb_ad, u, v&
4213 & , v_ad, ub, ub_ad, hord_mt_pert, gridstruct%dy, &
4214 & gridstruct%rdy, npx, npy, flagstruct%grid_type, nested)
4215  ELSE
4216  CALL ytp_v_bwd(is, ie, js, je, isd, ied, jsd, jed, vb, vb_ad, u&
4217 & , v, v_ad, ub, ub_ad, hord_mt, gridstruct%dy, &
4218 & gridstruct%rdy, npx, npy, flagstruct%grid_type, nested&
4219 & )
4220  END IF
4221  CALL popcontrol(2,branch)
4222  IF (branch .LT. 2) THEN
4223  IF (branch .EQ. 0) THEN
4224  DO j=je1,js2,-1
4225  DO i=ie1,is2,-1
4226  temp_ad59 = dt5*rsina(i, j)*vb_ad(i, j)
4227  temp_ad60 = -(cosa(i, j)*temp_ad59)
4228  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad59
4229  vc_ad(i, j) = vc_ad(i, j) + temp_ad59
4230  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad60
4231  uc_ad(i, j) = uc_ad(i, j) + temp_ad60
4232  vb_ad(i, j) = 0.0
4233  END DO
4234  END DO
4235  GOTO 120
4236  ELSE
4237  DO i=ie+1,is,-1
4238  vt_ad(i-1, npy) = vt_ad(i-1, npy) + dt5*vb_ad(i, npy)
4239  vt_ad(i, npy) = vt_ad(i, npy) + dt5*vb_ad(i, npy)
4240  vb_ad(i, npy) = 0.0
4241  END DO
4242  END IF
4243  ELSE IF (branch .NE. 2) THEN
4244  DO j=je+1,js,-1
4245  DO i=ie+1,is,-1
4246  vc_ad(i-1, j) = vc_ad(i-1, j) + dt5*vb_ad(i, j)
4247  vc_ad(i, j) = vc_ad(i, j) + dt5*vb_ad(i, j)
4248  vb_ad(i, j) = 0.0
4249  END DO
4250  END DO
4251  GOTO 120
4252  END IF
4253  DO j=je1,js2,-1
4254  CALL popcontrol(1,branch)
4255  IF (branch .NE. 0) THEN
4256  temp_ad64 = dt4*vb_ad(npx, j)
4257  vt_ad(npx-1, j) = vt_ad(npx-1, j) + 3.*temp_ad64
4258  vt_ad(npx, j) = vt_ad(npx, j) + 3.*temp_ad64
4259  vt_ad(npx-2, j) = vt_ad(npx-2, j) - temp_ad64
4260  vt_ad(npx+1, j) = vt_ad(npx+1, j) - temp_ad64
4261  vb_ad(npx, j) = 0.0
4262  END IF
4263  CALL popcontrol(1,branch)
4264  IF (branch .EQ. 0) THEN
4265  temp_ad63 = dt4*vb_ad(1, j)
4266  vt_ad(0, j) = vt_ad(0, j) + 3.*temp_ad63
4267  vt_ad(1, j) = vt_ad(1, j) + 3.*temp_ad63
4268  vt_ad(-1, j) = vt_ad(-1, j) - temp_ad63
4269  vt_ad(2, j) = vt_ad(2, j) - temp_ad63
4270  vb_ad(1, j) = 0.0
4271  END IF
4272  DO i=ie1,is2,-1
4273  temp_ad61 = dt5*rsina(i, j)*vb_ad(i, j)
4274  temp_ad62 = -(cosa(i, j)*temp_ad61)
4275  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad61
4276  vc_ad(i, j) = vc_ad(i, j) + temp_ad61
4277  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad62
4278  uc_ad(i, j) = uc_ad(i, j) + temp_ad62
4279  vb_ad(i, j) = 0.0
4280  END DO
4281  END DO
4282  CALL popcontrol(1,branch)
4283  IF (branch .NE. 0) THEN
4284  DO i=ie+1,is,-1
4285  vt_ad(i-1, 1) = vt_ad(i-1, 1) + dt5*vb_ad(i, 1)
4286  vt_ad(i, 1) = vt_ad(i, 1) + dt5*vb_ad(i, 1)
4287  vb_ad(i, 1) = 0.0
4288  END DO
4289  END IF
4290  120 CALL popcontrol(1,branch)
4291  CALL popcontrol(1,branch)
4292  IF (branch .EQ. 0) THEN
4293  DO j=je,js,-1
4294  DO i=ie,is,-1
4295  temp_ad58 = rarea(i, j)*dpx_ad(i, j)
4296  fx_ad(i, j) = fx_ad(i, j) + temp_ad58
4297  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad58
4298  fy_ad(i, j) = fy_ad(i, j) + temp_ad58
4299  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad58
4300  END DO
4301  END DO
4302  END IF
4303  CALL popcontrol(1,branch)
4304  IF (branch .EQ. 0) THEN
4305  DO iq=nq,1,-1
4306  DO j=je,js,-1
4307  DO i=ie,is,-1
4308  CALL poprealarray(q(i, j, k, iq))
4309  temp_ad53 = q_ad(i, j, k, iq)/delp(i, j)
4310  temp = q(i, j, k, iq)
4311  temp_ad54 = rarea(i, j)*temp_ad53
4312  wk_ad(i, j) = wk_ad(i, j) + temp*temp_ad53
4313  gx_ad(i, j) = gx_ad(i, j) + temp_ad54
4314  gx_ad(i+1, j) = gx_ad(i+1, j) - temp_ad54
4315  gy_ad(i, j) = gy_ad(i, j) + temp_ad54
4316  gy_ad(i, j+1) = gy_ad(i, j+1) - temp_ad54
4317  delp_ad(i, j) = delp_ad(i, j) - (temp*wk(i, j)+rarea(i, j)*(&
4318 & gx(i, j)-gx(i+1, j)+gy(i, j)-gy(i, j+1)))*temp_ad53/delp(i&
4319 & , j)
4320  q_ad(i, j, k, iq) = wk(i, j)*temp_ad53
4321  END DO
4322  END DO
4323  CALL popcontrol(1,branch)
4324  IF (branch .EQ. 0) THEN
4325  CALL poprealarray(q(isd:ied, jsd:jed, k, iq), (ied-isd+1)*(&
4326 & jed-jsd+1))
4327  CALL poprealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
4328  CALL poprealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
4329  CALL fv_tp_2d_adm(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied, &
4330 & jsd:jed, k, iq), crx_adv, crx_adv_ad, cry_adv, &
4331 & cry_adv_ad, npx, npy, hord_tr_pert, gx, gx_ad, gy&
4332 & , gy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad&
4333 & , gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, &
4334 & mfx=fx, mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad, mass=&
4335 & delp, mass_ad=delp_ad, nord=nord_t_pert, damp_c=&
4336 & damp_t_pert)
4337  ELSE
4338  CALL fv_tp_2d_bwd(q(isd:ied, jsd:jed, k, iq), q_ad(isd:ied&
4339 & , jsd:jed, k, iq), crx_adv, crx_adv_ad, cry_adv&
4340 & , cry_adv_ad, npx, npy, hord_tr, gx, gx_ad, gy&
4341 & , gy_ad, xfx_adv, xfx_adv_ad, yfx_adv, &
4342 & yfx_adv_ad, gridstruct, bd, ra_x, ra_x_ad, ra_y&
4343 & , ra_y_ad, mfx=fx, mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad&
4344 & , mass=delp, mass_ad=delp_ad, nord=nord_t, damp_c=&
4345 & damp_t)
4346  END IF
4347  END DO
4348  DO j=je,js,-1
4349  DO i=ie,is,-1
4350  CALL poprealarray(pt(i, j))
4351  temp_ad50 = pt_ad(i, j)/delp(i, j)
4352  temp_ad51 = rarea(i, j)*temp_ad50
4353  gx_ad(i, j) = gx_ad(i, j) + temp_ad51
4354  gx_ad(i+1, j) = gx_ad(i+1, j) - temp_ad51
4355  gy_ad(i, j) = gy_ad(i, j) + temp_ad51
4356  gy_ad(i, j+1) = gy_ad(i, j+1) - temp_ad51
4357  delp_ad(i, j) = delp_ad(i, j) - (pt(i, j)*wk(i, j)+rarea(i, j)&
4358 & *(gx(i, j)-gx(i+1, j)+gy(i, j)-gy(i, j+1)))*temp_ad50/delp(i&
4359 & , j)
4360  wk_ad(i, j) = wk_ad(i, j) + delp_ad(i, j) + pt(i, j)*temp_ad50
4361  pt_ad(i, j) = wk(i, j)*temp_ad50
4362  CALL poprealarray(delp(i, j))
4363  temp_ad52 = rarea(i, j)*delp_ad(i, j)
4364  fx_ad(i, j) = fx_ad(i, j) + temp_ad52
4365  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad52
4366  fy_ad(i, j) = fy_ad(i, j) + temp_ad52
4367  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad52
4368  delp_ad(i, j) = wk_ad(i, j)
4369  wk_ad(i, j) = 0.0
4370  END DO
4371  END DO
4372  ELSE
4373  DO j=je,js,-1
4374  DO i=ie,is,-1
4375  CALL poprealarray(pt(i, j))
4376  temp_ad55 = pt_ad(i, j)/delp(i, j)
4377  delp_ad(i, j) = delp_ad(i, j) - pt(i, j)*temp_ad55/delp(i, j)
4378  pt_ad(i, j) = temp_ad55
4379  CALL poprealarray(delp(i, j))
4380  temp_ad56 = rarea(i, j)*delp_ad(i, j)
4381  fx_ad(i, j) = fx_ad(i, j) + temp_ad56
4382  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad56
4383  fy_ad(i, j) = fy_ad(i, j) + temp_ad56
4384  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad56
4385  CALL poprealarray(pt(i, j))
4386  temp_ad57 = rarea(i, j)*pt_ad(i, j)
4387  delp_ad(i, j) = delp_ad(i, j) + pt(i, j)*pt_ad(i, j)
4388  gx_ad(i, j) = gx_ad(i, j) + temp_ad57
4389  gx_ad(i+1, j) = gx_ad(i+1, j) - temp_ad57
4390  gy_ad(i, j) = gy_ad(i, j) + temp_ad57
4391  gy_ad(i, j+1) = gy_ad(i, j+1) - temp_ad57
4392  pt_ad(i, j) = delp(i, j)*pt_ad(i, j)
4393  END DO
4394  END DO
4395  END IF
4396  CALL popcontrol(1,branch)
4397  IF (branch .EQ. 0) THEN
4398  CALL fv_tp_2d_bwd(pt, pt_ad, crx_adv, crx_adv_ad, cry_adv, &
4399 & cry_adv_ad, npx, npy, hord_tm, gx, gx_ad, gy, gy_ad&
4400 & , xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4401 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx=&
4402 & fx, mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad, mass=delp, mass_ad=&
4403 & delp_ad, nord=nord_t, damp_c=damp_t)
4404  ELSE
4405  CALL poprealarray(pt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
4406  CALL poprealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
4407  CALL poprealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
4408  CALL fv_tp_2d_adm(pt, pt_ad, crx_adv, crx_adv_ad, cry_adv, &
4409 & cry_adv_ad, npx, npy, hord_tm_pert, gx, gx_ad, gy, &
4410 & gy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4411 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx=fx, &
4412 & mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad, mass=delp, mass_ad&
4413 & =delp_ad, nord=nord_t_pert, damp_c=damp_t_pert)
4414  END IF
4415  CALL popcontrol(1,branch)
4416  IF (branch .EQ. 0) THEN
4417  DO j=je,js,-1
4418  DO i=ie,is,-1
4419  CALL poprealarray(w(i, j))
4420  temp_ad49 = rarea(i, j)*w_ad(i, j)
4421  delp_ad(i, j) = delp_ad(i, j) + w(i, j)*w_ad(i, j)
4422  gx_ad(i, j) = gx_ad(i, j) + temp_ad49
4423  gx_ad(i+1, j) = gx_ad(i+1, j) - temp_ad49
4424  gy_ad(i, j) = gy_ad(i, j) + temp_ad49
4425  gy_ad(i, j+1) = gy_ad(i, j+1) - temp_ad49
4426  w_ad(i, j) = delp(i, j)*w_ad(i, j)
4427  END DO
4428  END DO
4429  CALL popcontrol(1,branch)
4430  IF (branch .EQ. 0) THEN
4431  CALL poprealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
4432  CALL poprealarray(gx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
4433  CALL poprealarray(gy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
4434  CALL fv_tp_2d_adm(w, w_ad, crx_adv, crx_adv_ad, cry_adv, &
4435 & cry_adv_ad, npx, npy, hord_vt_pert, gx, gx_ad, gy, &
4436 & gy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4437 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx=fx&
4438 & , mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad)
4439  ELSE
4440  CALL fv_tp_2d_bwd(w, w_ad, crx_adv, crx_adv_ad, cry_adv, &
4441 & cry_adv_ad, npx, npy, hord_vt, gx, gx_ad, gy, &
4442 & gy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4443 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx&
4444 & =fx, mfx_ad=fx_ad, mfy=fy, mfy_ad=fy_ad)
4445  END IF
4446  CALL popcontrol(1,branch)
4447  IF (branch .EQ. 0) THEN
4448  fy2_ad = 0.0
4449  fx2_ad = 0.0
4450  DO j=je,js,-1
4451  DO i=ie,is,-1
4452  temp_ad47 = -(dw(i, j)*heat_source_ad(i, j))
4453  dw_ad(i, j) = dw_ad(i, j) + 0.5*temp_ad47 - (w(i, j)+0.5*dw(&
4454 & i, j))*heat_source_ad(i, j)
4455  w_ad(i, j) = w_ad(i, j) + temp_ad47
4456  heat_source_ad(i, j) = 0.0
4457  temp_ad48 = rarea(i, j)*dw_ad(i, j)
4458  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad48
4459  fx2_ad(i+1, j) = fx2_ad(i+1, j) - temp_ad48
4460  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad48
4461  fy2_ad(i, j+1) = fy2_ad(i, j+1) - temp_ad48
4462  dw_ad(i, j) = 0.0
4463  END DO
4464  END DO
4465  damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1)
4466  CALL del6_vt_flux_adm(nord_w, npx, npy, damp4, w, w_ad, wk, &
4467 & wk_ad, fx2, fx2_ad, fy2, fy2_ad, gridstruct, bd)
4468  END IF
4469  END IF
4470  DO j=je,js,-1
4471  DO i=ie,is,-1
4472  heat_source_ad(i, j) = 0.0
4473  END DO
4474  END DO
4475  DO j=je+1,js,-1
4476  DO i=ie,is,-1
4477  fy_ad(i, j) = fy_ad(i, j) + yflux_ad(i, j)
4478  END DO
4479  DO i=ied,isd,-1
4480  cry_adv_ad(i, j) = cry_adv_ad(i, j) + cy_ad(i, j)
4481  END DO
4482  END DO
4483  DO j=je,js,-1
4484  DO i=ie+1,is,-1
4485  fx_ad(i, j) = fx_ad(i, j) + xflux_ad(i, j)
4486  END DO
4487  END DO
4488  DO j=jed,jsd,-1
4489  DO i=ie+1,is,-1
4490  crx_adv_ad(i, j) = crx_adv_ad(i, j) + cx_ad(i, j)
4491  END DO
4492  END DO
4493  CALL popcontrol(1,branch)
4494  IF (branch .EQ. 0) THEN
4495  CALL poprealarray(delp, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
4496  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
4497  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
4498  CALL fv_tp_2d_adm(delp, delp_ad, crx_adv, crx_adv_ad, cry_adv, &
4499 & cry_adv_ad, npx, npy, hord_dp_pert, fx, fx_ad, fy, &
4500 & fy_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4501 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, nord=&
4502 & nord_v_pert, damp_c=damp_v_pert)
4503  ELSE
4504  CALL fv_tp_2d_bwd(delp, delp_ad, crx_adv, crx_adv_ad, cry_adv, &
4505 & cry_adv_ad, npx, npy, hord_dp, fx, fx_ad, fy, fy_ad&
4506 & , xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, &
4507 & gridstruct, bd, ra_x, ra_x_ad, ra_y, ra_y_ad, nord=&
4508 & nord_v, damp_c=damp_v)
4509  END IF
4510  DO j=je,js,-1
4511  DO i=ied,isd,-1
4512  yfx_adv_ad(i, j) = yfx_adv_ad(i, j) + ra_y_ad(i, j)
4513  yfx_adv_ad(i, j+1) = yfx_adv_ad(i, j+1) - ra_y_ad(i, j)
4514  ra_y_ad(i, j) = 0.0
4515  END DO
4516  END DO
4517  DO j=jed,jsd,-1
4518  DO i=ie,is,-1
4519  xfx_adv_ad(i, j) = xfx_adv_ad(i, j) + ra_x_ad(i, j)
4520  xfx_adv_ad(i+1, j) = xfx_adv_ad(i+1, j) - ra_x_ad(i, j)
4521  ra_x_ad(i, j) = 0.0
4522  END DO
4523  END DO
4524  DO j=je+1,js,-1
4525  DO i=ied,isd,-1
4526  CALL popcontrol(1,branch)
4527  IF (branch .EQ. 0) THEN
4528  CALL poprealarray(yfx_adv(i, j))
4529  yfx_adv_ad(i, j) = rdya(i, j)*cry_adv_ad(i, j) + sin_sg(i, j, &
4530 & 2)*dx(i, j)*yfx_adv_ad(i, j)
4531  CALL poprealarray(cry_adv(i, j))
4532  cry_adv_ad(i, j) = 0.0
4533  ELSE
4534  CALL poprealarray(yfx_adv(i, j))
4535  yfx_adv_ad(i, j) = rdya(i, j-1)*cry_adv_ad(i, j) + sin_sg(i, j&
4536 & -1, 4)*dx(i, j)*yfx_adv_ad(i, j)
4537  CALL poprealarray(cry_adv(i, j))
4538  cry_adv_ad(i, j) = 0.0
4539  END IF
4540  END DO
4541  END DO
4542  DO j=jed,jsd,-1
4543  DO i=ie+1,is,-1
4544  CALL popcontrol(1,branch)
4545  IF (branch .EQ. 0) THEN
4546  CALL poprealarray(xfx_adv(i, j))
4547  xfx_adv_ad(i, j) = rdxa(i, j)*crx_adv_ad(i, j) + sin_sg(i, j, &
4548 & 1)*dy(i, j)*xfx_adv_ad(i, j)
4549  CALL poprealarray(crx_adv(i, j))
4550  crx_adv_ad(i, j) = 0.0
4551  ELSE
4552  CALL poprealarray(xfx_adv(i, j))
4553  xfx_adv_ad(i, j) = rdxa(i-1, j)*crx_adv_ad(i, j) + sin_sg(i-1&
4554 & , j, 3)*dy(i, j)*xfx_adv_ad(i, j)
4555  CALL poprealarray(crx_adv(i, j))
4556  crx_adv_ad(i, j) = 0.0
4557  END IF
4558  END DO
4559  END DO
4560  DO j=je+1,js,-1
4561  DO i=ied,isd,-1
4562  CALL poprealarray(yfx_adv(i, j))
4563  vt_ad(i, j) = vt_ad(i, j) + dt*yfx_adv_ad(i, j)
4564  yfx_adv_ad(i, j) = 0.0
4565  END DO
4566  END DO
4567  DO j=jed,jsd,-1
4568  DO i=ie+1,is,-1
4569  CALL poprealarray(xfx_adv(i, j))
4570  ut_ad(i, j) = ut_ad(i, j) + dt*xfx_adv_ad(i, j)
4571  xfx_adv_ad(i, j) = 0.0
4572  END DO
4573  END DO
4574  CALL popcontrol(2,branch)
4575  IF (branch .LT. 2) THEN
4576  IF (branch .EQ. 0) THEN
4577  DO j=je+1,js,-1
4578  DO i=ied,isd,-1
4579  vc_ad(i, j) = vc_ad(i, j) + vt_ad(i, j)
4580  vt_ad(i, j) = 0.0
4581  END DO
4582  END DO
4583  DO j=jed,jsd,-1
4584  DO i=ie+1,is,-1
4585  uc_ad(i, j) = uc_ad(i, j) + ut_ad(i, j)
4586  ut_ad(i, j) = 0.0
4587  END DO
4588  END DO
4589  GOTO 130
4590  END IF
4591  ELSE
4592  IF (branch .NE. 2) THEN
4593  cosa_u => gridstruct%cosa_u
4594  cosa_v => gridstruct%cosa_v
4595  damp = 1./(1.-0.0625*cosa_u(2, npy-1)*cosa_v(1, npy-1))
4596  temp_ad39 = -(damp*cosa_v(1, npy-1)*0.25*vt_ad(1, npy-1))
4597  temp_ad40 = -(cosa_u(2, npy-1)*0.25*temp_ad39)
4598  ut_ad(1, npy-1) = ut_ad(1, npy-1) + temp_ad39
4599  ut_ad(1, npy-2) = ut_ad(1, npy-2) + temp_ad39
4600  ut_ad(2, npy-2) = ut_ad(2, npy-2) + temp_ad39
4601  uc_ad(2, npy-1) = uc_ad(2, npy-1) + damp*ut_ad(2, npy-1) + &
4602 & temp_ad39
4603  temp_ad41 = -(damp*cosa_u(2, npy-1)*0.25*ut_ad(2, npy-1))
4604  vc_ad(1, npy-1) = vc_ad(1, npy-1) + temp_ad41 + damp*vt_ad(1, &
4605 & npy-1)
4606  vt_ad(1, npy) = vt_ad(1, npy) + temp_ad40
4607  vt_ad(2, npy) = vt_ad(2, npy) + temp_ad40
4608  vt_ad(2, npy-1) = vt_ad(2, npy-1) + temp_ad40
4609  vt_ad(1, npy-1) = 0.0
4610  temp_ad42 = -(cosa_v(1, npy-1)*0.25*temp_ad41)
4611  vt_ad(1, npy) = vt_ad(1, npy) + temp_ad41
4612  vt_ad(2, npy) = vt_ad(2, npy) + temp_ad41
4613  vt_ad(2, npy-1) = vt_ad(2, npy-1) + temp_ad41
4614  ut_ad(1, npy-1) = ut_ad(1, npy-1) + temp_ad42
4615  ut_ad(1, npy-2) = ut_ad(1, npy-2) + temp_ad42
4616  ut_ad(2, npy-2) = ut_ad(2, npy-2) + temp_ad42
4617  ut_ad(2, npy-1) = 0.0
4618  damp = 1./(1.-0.0625*cosa_u(0, npy-1)*cosa_v(0, npy-1))
4619  temp_ad43 = -(damp*cosa_v(0, npy-1)*0.25*vt_ad(0, npy-1))
4620  temp_ad44 = -(cosa_u(0, npy-1)*0.25*temp_ad43)
4621  vc_ad(0, npy-1) = vc_ad(0, npy-1) + damp*vt_ad(0, npy-1)
4622  ut_ad(1, npy-1) = ut_ad(1, npy-1) + temp_ad43
4623  ut_ad(1, npy-2) = ut_ad(1, npy-2) + temp_ad43
4624  ut_ad(0, npy-2) = ut_ad(0, npy-2) + temp_ad43
4625  uc_ad(0, npy-1) = uc_ad(0, npy-1) + temp_ad43
4626  vt_ad(0, npy) = vt_ad(0, npy) + temp_ad44
4627  vt_ad(-1, npy) = vt_ad(-1, npy) + temp_ad44
4628  vt_ad(-1, npy-1) = vt_ad(-1, npy-1) + temp_ad44
4629  vt_ad(0, npy-1) = 0.0
4630  damp = 1./(1.-0.0625*cosa_u(2, npy)*cosa_v(1, npy+1))
4631  temp_ad45 = -(damp*cosa_u(2, npy)*0.25*ut_ad(2, npy))
4632  temp_ad46 = -(cosa_v(1, npy+1)*0.25*temp_ad45)
4633  uc_ad(2, npy) = uc_ad(2, npy) + damp*ut_ad(2, npy)
4634  vt_ad(1, npy) = vt_ad(1, npy) + temp_ad45
4635  vt_ad(2, npy) = vt_ad(2, npy) + temp_ad45
4636  vt_ad(2, npy+1) = vt_ad(2, npy+1) + temp_ad45
4637  vc_ad(1, npy+1) = vc_ad(1, npy+1) + temp_ad45
4638  ut_ad(1, npy) = ut_ad(1, npy) + temp_ad46
4639  ut_ad(1, npy+1) = ut_ad(1, npy+1) + temp_ad46
4640  ut_ad(2, npy+1) = ut_ad(2, npy+1) + temp_ad46
4641  ut_ad(2, npy) = 0.0
4642  END IF
4643  CALL popcontrol(1,branch)
4644  IF (branch .EQ. 0) THEN
4645  damp = 1./(1.-0.0625*cosa_u(npx-1, npy-1)*cosa_v(npx-1, npy-1))
4646  temp_ad31 = -(damp*cosa_v(npx-1, npy-1)*0.25*vt_ad(npx-1, npy-1)&
4647 & )
4648  temp_ad32 = -(cosa_u(npx-1, npy-1)*0.25*temp_ad31)
4649  ut_ad(npx, npy-1) = ut_ad(npx, npy-1) + temp_ad31
4650  ut_ad(npx, npy-2) = ut_ad(npx, npy-2) + temp_ad31
4651  ut_ad(npx-1, npy-2) = ut_ad(npx-1, npy-2) + temp_ad31
4652  uc_ad(npx-1, npy-1) = uc_ad(npx-1, npy-1) + damp*ut_ad(npx-1, &
4653 & npy-1) + temp_ad31
4654  temp_ad33 = -(damp*cosa_u(npx-1, npy-1)*0.25*ut_ad(npx-1, npy-1)&
4655 & )
4656  vc_ad(npx-1, npy-1) = vc_ad(npx-1, npy-1) + temp_ad33 + damp*&
4657 & vt_ad(npx-1, npy-1)
4658  vt_ad(npx-1, npy) = vt_ad(npx-1, npy) + temp_ad32
4659  vt_ad(npx-2, npy) = vt_ad(npx-2, npy) + temp_ad32
4660  vt_ad(npx-2, npy-1) = vt_ad(npx-2, npy-1) + temp_ad32
4661  vt_ad(npx-1, npy-1) = 0.0
4662  temp_ad34 = -(cosa_v(npx-1, npy-1)*0.25*temp_ad33)
4663  vt_ad(npx-1, npy) = vt_ad(npx-1, npy) + temp_ad33
4664  vt_ad(npx-2, npy) = vt_ad(npx-2, npy) + temp_ad33
4665  vt_ad(npx-2, npy-1) = vt_ad(npx-2, npy-1) + temp_ad33
4666  ut_ad(npx, npy-1) = ut_ad(npx, npy-1) + temp_ad34
4667  ut_ad(npx, npy-2) = ut_ad(npx, npy-2) + temp_ad34
4668  ut_ad(npx-1, npy-2) = ut_ad(npx-1, npy-2) + temp_ad34
4669  ut_ad(npx-1, npy-1) = 0.0
4670  damp = 1./(1.-0.0625*cosa_u(npx+1, npy-1)*cosa_v(npx, npy-1))
4671  temp_ad35 = -(damp*cosa_v(npx, npy-1)*0.25*vt_ad(npx, npy-1))
4672  temp_ad36 = -(cosa_u(npx+1, npy-1)*0.25*temp_ad35)
4673  vc_ad(npx, npy-1) = vc_ad(npx, npy-1) + damp*vt_ad(npx, npy-1)
4674  ut_ad(npx, npy-1) = ut_ad(npx, npy-1) + temp_ad35
4675  ut_ad(npx, npy-2) = ut_ad(npx, npy-2) + temp_ad35
4676  ut_ad(npx+1, npy-2) = ut_ad(npx+1, npy-2) + temp_ad35
4677  uc_ad(npx+1, npy-1) = uc_ad(npx+1, npy-1) + temp_ad35
4678  vt_ad(npx, npy) = vt_ad(npx, npy) + temp_ad36
4679  vt_ad(npx+1, npy) = vt_ad(npx+1, npy) + temp_ad36
4680  vt_ad(npx+1, npy-1) = vt_ad(npx+1, npy-1) + temp_ad36
4681  vt_ad(npx, npy-1) = 0.0
4682  damp = 1./(1.-0.0625*cosa_u(npx-1, npy)*cosa_v(npx-1, npy+1))
4683  temp_ad37 = -(damp*cosa_u(npx-1, npy)*0.25*ut_ad(npx-1, npy))
4684  temp_ad38 = -(cosa_v(npx-1, npy+1)*0.25*temp_ad37)
4685  uc_ad(npx-1, npy) = uc_ad(npx-1, npy) + damp*ut_ad(npx-1, npy)
4686  vt_ad(npx-1, npy) = vt_ad(npx-1, npy) + temp_ad37
4687  vt_ad(npx-2, npy) = vt_ad(npx-2, npy) + temp_ad37
4688  vt_ad(npx-2, npy+1) = vt_ad(npx-2, npy+1) + temp_ad37
4689  vc_ad(npx-1, npy+1) = vc_ad(npx-1, npy+1) + temp_ad37
4690  ut_ad(npx, npy) = ut_ad(npx, npy) + temp_ad38
4691  ut_ad(npx, npy+1) = ut_ad(npx, npy+1) + temp_ad38
4692  ut_ad(npx-1, npy+1) = ut_ad(npx-1, npy+1) + temp_ad38
4693  ut_ad(npx-1, npy) = 0.0
4694  END IF
4695  CALL popcontrol(1,branch)
4696  IF (branch .EQ. 0) THEN
4697  damp = 1./(1.-0.0625*cosa_u(npx-1, 1)*cosa_v(npx-1, 2))
4698  temp_ad23 = -(damp*cosa_v(npx-1, 2)*0.25*vt_ad(npx-1, 2))
4699  temp_ad24 = -(cosa_u(npx-1, 1)*0.25*temp_ad23)
4700  ut_ad(npx, 1) = ut_ad(npx, 1) + temp_ad23
4701  ut_ad(npx, 2) = ut_ad(npx, 2) + temp_ad23
4702  ut_ad(npx-1, 2) = ut_ad(npx-1, 2) + temp_ad23
4703  uc_ad(npx-1, 1) = uc_ad(npx-1, 1) + damp*ut_ad(npx-1, 1) + &
4704 & temp_ad23
4705  temp_ad25 = -(damp*cosa_u(npx-1, 1)*0.25*ut_ad(npx-1, 1))
4706  vc_ad(npx-1, 2) = vc_ad(npx-1, 2) + temp_ad25 + damp*vt_ad(npx-1&
4707 & , 2)
4708  vt_ad(npx-1, 1) = vt_ad(npx-1, 1) + temp_ad24
4709  vt_ad(npx-2, 1) = vt_ad(npx-2, 1) + temp_ad24
4710  vt_ad(npx-2, 2) = vt_ad(npx-2, 2) + temp_ad24
4711  vt_ad(npx-1, 2) = 0.0
4712  temp_ad26 = -(cosa_v(npx-1, 2)*0.25*temp_ad25)
4713  vt_ad(npx-1, 1) = vt_ad(npx-1, 1) + temp_ad25
4714  vt_ad(npx-2, 1) = vt_ad(npx-2, 1) + temp_ad25
4715  vt_ad(npx-2, 2) = vt_ad(npx-2, 2) + temp_ad25
4716  ut_ad(npx, 1) = ut_ad(npx, 1) + temp_ad26
4717  ut_ad(npx, 2) = ut_ad(npx, 2) + temp_ad26
4718  ut_ad(npx-1, 2) = ut_ad(npx-1, 2) + temp_ad26
4719  ut_ad(npx-1, 1) = 0.0
4720  damp = 1./(1.-0.0625*cosa_u(npx+1, 1)*cosa_v(npx, 2))
4721  temp_ad27 = -(damp*cosa_v(npx, 2)*0.25*vt_ad(npx, 2))
4722  temp_ad28 = -(cosa_u(npx+1, 1)*0.25*temp_ad27)
4723  vc_ad(npx, 2) = vc_ad(npx, 2) + damp*vt_ad(npx, 2)
4724  ut_ad(npx, 1) = ut_ad(npx, 1) + temp_ad27
4725  ut_ad(npx, 2) = ut_ad(npx, 2) + temp_ad27
4726  ut_ad(npx+1, 2) = ut_ad(npx+1, 2) + temp_ad27
4727  uc_ad(npx+1, 1) = uc_ad(npx+1, 1) + temp_ad27
4728  vt_ad(npx, 1) = vt_ad(npx, 1) + temp_ad28
4729  vt_ad(npx+1, 1) = vt_ad(npx+1, 1) + temp_ad28
4730  vt_ad(npx+1, 2) = vt_ad(npx+1, 2) + temp_ad28
4731  vt_ad(npx, 2) = 0.0
4732  damp = 1./(1.-0.0625*cosa_u(npx-1, 0)*cosa_v(npx-1, 0))
4733  temp_ad29 = -(damp*cosa_u(npx-1, 0)*0.25*ut_ad(npx-1, 0))
4734  temp_ad30 = -(cosa_v(npx-1, 0)*0.25*temp_ad29)
4735  uc_ad(npx-1, 0) = uc_ad(npx-1, 0) + damp*ut_ad(npx-1, 0)
4736  vt_ad(npx-1, 1) = vt_ad(npx-1, 1) + temp_ad29
4737  vt_ad(npx-2, 1) = vt_ad(npx-2, 1) + temp_ad29
4738  vt_ad(npx-2, 0) = vt_ad(npx-2, 0) + temp_ad29
4739  vc_ad(npx-1, 0) = vc_ad(npx-1, 0) + temp_ad29
4740  ut_ad(npx, 0) = ut_ad(npx, 0) + temp_ad30
4741  ut_ad(npx, -1) = ut_ad(npx, -1) + temp_ad30
4742  ut_ad(npx-1, -1) = ut_ad(npx-1, -1) + temp_ad30
4743  ut_ad(npx-1, 0) = 0.0
4744  END IF
4745  CALL popcontrol(1,branch)
4746  IF (branch .EQ. 0) THEN
4747  damp = 1./(1.-0.0625*cosa_u(2, 1)*cosa_v(1, 2))
4748  temp_ad15 = -(damp*cosa_v(1, 2)*0.25*vt_ad(1, 2))
4749  temp_ad16 = -(cosa_u(2, 1)*0.25*temp_ad15)
4750  ut_ad(1, 1) = ut_ad(1, 1) + temp_ad15
4751  ut_ad(1, 2) = ut_ad(1, 2) + temp_ad15
4752  ut_ad(2, 2) = ut_ad(2, 2) + temp_ad15
4753  uc_ad(2, 1) = uc_ad(2, 1) + damp*ut_ad(2, 1) + temp_ad15
4754  temp_ad17 = -(damp*cosa_u(2, 1)*0.25*ut_ad(2, 1))
4755  vc_ad(1, 2) = vc_ad(1, 2) + temp_ad17 + damp*vt_ad(1, 2)
4756  vt_ad(1, 1) = vt_ad(1, 1) + temp_ad16
4757  vt_ad(2, 1) = vt_ad(2, 1) + temp_ad16
4758  vt_ad(2, 2) = vt_ad(2, 2) + temp_ad16
4759  vt_ad(1, 2) = 0.0
4760  temp_ad18 = -(cosa_v(1, 2)*0.25*temp_ad17)
4761  vt_ad(1, 1) = vt_ad(1, 1) + temp_ad17
4762  vt_ad(2, 1) = vt_ad(2, 1) + temp_ad17
4763  vt_ad(2, 2) = vt_ad(2, 2) + temp_ad17
4764  ut_ad(1, 1) = ut_ad(1, 1) + temp_ad18
4765  ut_ad(1, 2) = ut_ad(1, 2) + temp_ad18
4766  ut_ad(2, 2) = ut_ad(2, 2) + temp_ad18
4767  ut_ad(2, 1) = 0.0
4768  damp = 1./(1.-0.0625*cosa_u(0, 1)*cosa_v(0, 2))
4769  temp_ad19 = -(damp*cosa_v(0, 2)*0.25*vt_ad(0, 2))
4770  temp_ad20 = -(cosa_u(0, 1)*0.25*temp_ad19)
4771  vc_ad(0, 2) = vc_ad(0, 2) + damp*vt_ad(0, 2)
4772  ut_ad(1, 1) = ut_ad(1, 1) + temp_ad19
4773  ut_ad(1, 2) = ut_ad(1, 2) + temp_ad19
4774  ut_ad(0, 2) = ut_ad(0, 2) + temp_ad19
4775  uc_ad(0, 1) = uc_ad(0, 1) + temp_ad19
4776  vt_ad(0, 1) = vt_ad(0, 1) + temp_ad20
4777  vt_ad(-1, 1) = vt_ad(-1, 1) + temp_ad20
4778  vt_ad(-1, 2) = vt_ad(-1, 2) + temp_ad20
4779  vt_ad(0, 2) = 0.0
4780  damp = 1./(1.-0.0625*cosa_u(2, 0)*cosa_v(1, 0))
4781  temp_ad21 = -(damp*cosa_u(2, 0)*0.25*ut_ad(2, 0))
4782  temp_ad22 = -(cosa_v(1, 0)*0.25*temp_ad21)
4783  uc_ad(2, 0) = uc_ad(2, 0) + damp*ut_ad(2, 0)
4784  vt_ad(1, 1) = vt_ad(1, 1) + temp_ad21
4785  vt_ad(2, 1) = vt_ad(2, 1) + temp_ad21
4786  vt_ad(2, 0) = vt_ad(2, 0) + temp_ad21
4787  vc_ad(1, 0) = vc_ad(1, 0) + temp_ad21
4788  ut_ad(1, 0) = ut_ad(1, 0) + temp_ad22
4789  ut_ad(1, -1) = ut_ad(1, -1) + temp_ad22
4790  ut_ad(2, -1) = ut_ad(2, -1) + temp_ad22
4791  ut_ad(2, 0) = 0.0
4792  END IF
4793  CALL popcontrol(1,branch)
4794  IF (branch .EQ. 0) THEN
4795  DO i=min4,max4,-1
4796  temp_ad13 = -(cosa_u(i, npy)*0.25*ut_ad(i, npy))
4797  uc_ad(i, npy) = uc_ad(i, npy) + ut_ad(i, npy)
4798  vt_ad(i-1, npy) = vt_ad(i-1, npy) + temp_ad13
4799  vt_ad(i, npy) = vt_ad(i, npy) + temp_ad13
4800  vt_ad(i-1, npy+1) = vt_ad(i-1, npy+1) + temp_ad13
4801  vt_ad(i, npy+1) = vt_ad(i, npy+1) + temp_ad13
4802  ut_ad(i, npy) = 0.0
4803  temp_ad14 = -(cosa_u(i, npy-1)*0.25*ut_ad(i, npy-1))
4804  uc_ad(i, npy-1) = uc_ad(i, npy-1) + ut_ad(i, npy-1)
4805  vt_ad(i-1, npy-1) = vt_ad(i-1, npy-1) + temp_ad14
4806  vt_ad(i, npy-1) = vt_ad(i, npy-1) + temp_ad14
4807  vt_ad(i-1, npy) = vt_ad(i-1, npy) + temp_ad14
4808  vt_ad(i, npy) = vt_ad(i, npy) + temp_ad14
4809  ut_ad(i, npy-1) = 0.0
4810  END DO
4811  DO i=ied,isd,-1
4812  CALL popcontrol(1,branch)
4813  IF (branch .EQ. 0) THEN
4814  vc_ad(i, npy) = vc_ad(i, npy) + vt_ad(i, npy)/sin_sg(i, npy&
4815 & , 2)
4816  vt_ad(i, npy) = 0.0
4817  ELSE
4818  vc_ad(i, npy) = vc_ad(i, npy) + vt_ad(i, npy)/sin_sg(i, npy-&
4819 & 1, 4)
4820  vt_ad(i, npy) = 0.0
4821  END IF
4822  END DO
4823  END IF
4824  CALL popcontrol(1,branch)
4825  IF (branch .EQ. 0) THEN
4826  DO i=min3,max3,-1
4827  temp_ad11 = -(cosa_u(i, 1)*0.25*ut_ad(i, 1))
4828  uc_ad(i, 1) = uc_ad(i, 1) + ut_ad(i, 1)
4829  vt_ad(i-1, 1) = vt_ad(i-1, 1) + temp_ad11
4830  vt_ad(i, 1) = vt_ad(i, 1) + temp_ad11
4831  vt_ad(i-1, 2) = vt_ad(i-1, 2) + temp_ad11
4832  vt_ad(i, 2) = vt_ad(i, 2) + temp_ad11
4833  ut_ad(i, 1) = 0.0
4834  temp_ad12 = -(cosa_u(i, 0)*0.25*ut_ad(i, 0))
4835  uc_ad(i, 0) = uc_ad(i, 0) + ut_ad(i, 0)
4836  vt_ad(i-1, 0) = vt_ad(i-1, 0) + temp_ad12
4837  vt_ad(i, 0) = vt_ad(i, 0) + temp_ad12
4838  vt_ad(i-1, 1) = vt_ad(i-1, 1) + temp_ad12
4839  vt_ad(i, 1) = vt_ad(i, 1) + temp_ad12
4840  ut_ad(i, 0) = 0.0
4841  END DO
4842  DO i=ied,isd,-1
4843  CALL popcontrol(1,branch)
4844  IF (branch .EQ. 0) THEN
4845  vc_ad(i, 1) = vc_ad(i, 1) + vt_ad(i, 1)/sin_sg(i, 1, 2)
4846  vt_ad(i, 1) = 0.0
4847  ELSE
4848  vc_ad(i, 1) = vc_ad(i, 1) + vt_ad(i, 1)/sin_sg(i, 0, 4)
4849  vt_ad(i, 1) = 0.0
4850  END IF
4851  END DO
4852  END IF
4853  CALL popcontrol(1,branch)
4854  IF (branch .EQ. 0) THEN
4855  DO j=min2,max2,-1
4856  temp_ad9 = -(cosa_v(npx, j)*0.25*vt_ad(npx, j))
4857  vc_ad(npx, j) = vc_ad(npx, j) + vt_ad(npx, j)
4858  ut_ad(npx, j-1) = ut_ad(npx, j-1) + temp_ad9
4859  ut_ad(npx+1, j-1) = ut_ad(npx+1, j-1) + temp_ad9
4860  ut_ad(npx, j) = ut_ad(npx, j) + temp_ad9
4861  ut_ad(npx+1, j) = ut_ad(npx+1, j) + temp_ad9
4862  vt_ad(npx, j) = 0.0
4863  temp_ad10 = -(cosa_v(npx-1, j)*0.25*vt_ad(npx-1, j))
4864  vc_ad(npx-1, j) = vc_ad(npx-1, j) + vt_ad(npx-1, j)
4865  ut_ad(npx-1, j-1) = ut_ad(npx-1, j-1) + temp_ad10
4866  ut_ad(npx, j-1) = ut_ad(npx, j-1) + temp_ad10
4867  ut_ad(npx-1, j) = ut_ad(npx-1, j) + temp_ad10
4868  ut_ad(npx, j) = ut_ad(npx, j) + temp_ad10
4869  vt_ad(npx-1, j) = 0.0
4870  END DO
4871  DO j=jed,jsd,-1
4872  CALL popcontrol(1,branch)
4873  IF (branch .EQ. 0) THEN
4874  uc_ad(npx, j) = uc_ad(npx, j) + ut_ad(npx, j)/sin_sg(npx, j&
4875 & , 1)
4876  ut_ad(npx, j) = 0.0
4877  ELSE
4878  uc_ad(npx, j) = uc_ad(npx, j) + ut_ad(npx, j)/sin_sg(npx-1, &
4879 & j, 3)
4880  ut_ad(npx, j) = 0.0
4881  END IF
4882  END DO
4883  END IF
4884  CALL popcontrol(1,branch)
4885  IF (branch .EQ. 0) THEN
4886  DO j=min1,max1,-1
4887  temp_ad7 = -(cosa_v(1, j)*0.25*vt_ad(1, j))
4888  vc_ad(1, j) = vc_ad(1, j) + vt_ad(1, j)
4889  ut_ad(1, j-1) = ut_ad(1, j-1) + temp_ad7
4890  ut_ad(2, j-1) = ut_ad(2, j-1) + temp_ad7
4891  ut_ad(1, j) = ut_ad(1, j) + temp_ad7
4892  ut_ad(2, j) = ut_ad(2, j) + temp_ad7
4893  vt_ad(1, j) = 0.0
4894  temp_ad8 = -(cosa_v(0, j)*0.25*vt_ad(0, j))
4895  vc_ad(0, j) = vc_ad(0, j) + vt_ad(0, j)
4896  ut_ad(0, j-1) = ut_ad(0, j-1) + temp_ad8
4897  ut_ad(1, j-1) = ut_ad(1, j-1) + temp_ad8
4898  ut_ad(0, j) = ut_ad(0, j) + temp_ad8
4899  ut_ad(1, j) = ut_ad(1, j) + temp_ad8
4900  vt_ad(0, j) = 0.0
4901  END DO
4902  DO j=jed,jsd,-1
4903  CALL popcontrol(1,branch)
4904  IF (branch .EQ. 0) THEN
4905  uc_ad(1, j) = uc_ad(1, j) + ut_ad(1, j)/sin_sg(1, j, 1)
4906  ut_ad(1, j) = 0.0
4907  ELSE
4908  uc_ad(1, j) = uc_ad(1, j) + ut_ad(1, j)/sin_sg(0, j, 3)
4909  ut_ad(1, j) = 0.0
4910  END IF
4911  END DO
4912  END IF
4913  END IF
4914  rsin_v => gridstruct%rsin_v
4915  CALL popcontrol(1,branch)
4916  IF (branch .EQ. 0) THEN
4917  DO j=je+2,js-1,-1
4918  DO i=ied,isd,-1
4919  temp_ad1 = rsin_v(i, j)*vt_ad(i, j)
4920  temp_ad2 = -(cosa_v(i, j)*0.25*temp_ad1)
4921  vc_ad(i, j) = vc_ad(i, j) + temp_ad1
4922  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad2
4923  uc_ad(i+1, j-1) = uc_ad(i+1, j-1) + temp_ad2
4924  uc_ad(i, j) = uc_ad(i, j) + temp_ad2
4925  uc_ad(i+1, j) = uc_ad(i+1, j) + temp_ad2
4926  vt_ad(i, j) = 0.0
4927  END DO
4928  END DO
4929  DO j=jed,jsd,-1
4930  DO i=ie+2,is-1,-1
4931  temp_ad = rsin_u(i, j)*ut_ad(i, j)
4932  temp_ad0 = -(cosa_u(i, j)*0.25*temp_ad)
4933  uc_ad(i, j) = uc_ad(i, j) + temp_ad
4934  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad0
4935  vc_ad(i, j) = vc_ad(i, j) + temp_ad0
4936  vc_ad(i-1, j+1) = vc_ad(i-1, j+1) + temp_ad0
4937  vc_ad(i, j+1) = vc_ad(i, j+1) + temp_ad0
4938  ut_ad(i, j) = 0.0
4939  END DO
4940  END DO
4941  ELSE
4942  DO j=je+2,js-1,-1
4943  CALL popcontrol(1,branch)
4944  IF (branch .NE. 0) THEN
4945  DO i=ied,isd,-1
4946  temp_ad5 = rsin_v(i, j)*vt_ad(i, j)
4947  temp_ad6 = -(cosa_v(i, j)*0.25*temp_ad5)
4948  vc_ad(i, j) = vc_ad(i, j) + temp_ad5
4949  uc_ad(i, j-1) = uc_ad(i, j-1) + temp_ad6
4950  uc_ad(i+1, j-1) = uc_ad(i+1, j-1) + temp_ad6
4951  uc_ad(i, j) = uc_ad(i, j) + temp_ad6
4952  uc_ad(i+1, j) = uc_ad(i+1, j) + temp_ad6
4953  vt_ad(i, j) = 0.0
4954  END DO
4955  END IF
4956  END DO
4957  DO j=jed,jsd,-1
4958  CALL popcontrol(1,branch)
4959  IF (branch .NE. 0) THEN
4960  DO i=ie+2,is-1,-1
4961  temp_ad3 = rsin_u(i, j)*ut_ad(i, j)
4962  temp_ad4 = -(cosa_u(i, j)*0.25*temp_ad3)
4963  uc_ad(i, j) = uc_ad(i, j) + temp_ad3
4964  vc_ad(i-1, j) = vc_ad(i-1, j) + temp_ad4
4965  vc_ad(i, j) = vc_ad(i, j) + temp_ad4
4966  vc_ad(i-1, j+1) = vc_ad(i-1, j+1) + temp_ad4
4967  vc_ad(i, j+1) = vc_ad(i, j+1) + temp_ad4
4968  ut_ad(i, j) = 0.0
4969  END DO
4970  END IF
4971  END DO
4972  END IF
4973  130 CONTINUE
4974  END SUBROUTINE d_sw_bwd
4975 ! d_sw :: D-Grid Shallow Water Routine
4976  SUBROUTINE d_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d&
4977 & , xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, &
4978 & z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, &
4979 & dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, &
4980 & nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, &
4981 & hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert&
4982 & , hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, &
4983 & nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, &
4984 & d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
4985  IMPLICIT NONE
4986  INTEGER, INTENT(IN) :: hord_tr, hord_mt, hord_vt, hord_tm, hord_dp
4987 ! nord=1 divergence damping; (del-4) or 3 (del-8)
4988  INTEGER, INTENT(IN) :: nord
4989 ! vorticity damping
4990  INTEGER, INTENT(IN) :: nord_v
4991 ! vertical velocity
4992  INTEGER, INTENT(IN) :: nord_w
4993 ! pt
4994  INTEGER, INTENT(IN) :: nord_t
4995  INTEGER, INTENT(IN) :: sphum, nq, k, km
4996  REAL, INTENT(IN) :: dt, dddmp, d2_bg, d4_bg, d_con
4997  REAL, INTENT(IN) :: zvir
4998  REAL, INTENT(IN) :: damp_v, damp_w, damp_t, kgb
4999  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
5000  INTEGER, INTENT(IN) :: hord_tr_pert, hord_mt_pert, hord_vt_pert, &
5001 & hord_tm_pert, hord_dp_pert, nord_pert, nord_v_pert, nord_w_pert, &
5002 & nord_t_pert
5003  LOGICAL, INTENT(IN) :: split_damp
5004  REAL, INTENT(IN) :: dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert&
5005 & , damp_w_pert, damp_t_pert
5006 ! divergence
5007  REAL, INTENT(INOUT) :: divg_d(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5008  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: z_rat
5009  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: delp&
5010 & , pt, ua, va
5011  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: w
5012  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
5013 & q_con
5014  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: u&
5015 & , vc
5016  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: v&
5017 & , uc
5018  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km, nq)
5019  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: delpc&
5020 & , ptc
5021  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(OUT) :: &
5022 & heat_source
5023  REAL(kind=8), DIMENSION(bd%is:bd%ie, bd%js:bd%je), INTENT(INOUT) :: &
5024 & dpx
5025 ! The flux capacitors:
5026  REAL, INTENT(INOUT) :: xflux(bd%is:bd%ie+1, bd%js:bd%je)
5027  REAL, INTENT(INOUT) :: yflux(bd%is:bd%ie, bd%js:bd%je+1)
5028 !------------------------
5029  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed)
5030  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1)
5031  LOGICAL, INTENT(IN) :: hydrostatic
5032  LOGICAL, INTENT(IN) :: inline_q
5033  REAL, DIMENSION(bd%is:bd%ie+1, bd%jsd:bd%jed), INTENT(OUT) :: &
5034 & crx_adv, xfx_adv
5035  REAL, DIMENSION(bd%isd:bd%ied, bd%js:bd%je+1), INTENT(OUT) :: &
5036 & cry_adv, yfx_adv
5037  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
5038  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
5039 ! Local:
5040  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
5041  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5042  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5043 !---
5044  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5045  REAL :: fy2(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5046 ! work array
5047  REAL :: dw(bd%is:bd%ie, bd%js:bd%je)
5048 !---
5049  REAL, DIMENSION(bd%is:bd%ie+1, bd%js:bd%je+1) :: ub, vb
5050 ! work array
5051  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
5052 ! needs this for corner_comm
5053  REAL :: ke(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5054 ! Vorticity
5055  REAL :: vort(bd%isd:bd%ied, bd%jsd:bd%jed)
5056 ! 1-D X-direction Fluxes
5057  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
5058 ! 1-D Y-direction Fluxes
5059  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
5060  REAL :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
5061  REAL :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
5062  REAL :: gx(bd%is:bd%ie+1, bd%js:bd%je)
5063 ! work Y-dir flux array
5064  REAL :: gy(bd%is:bd%ie, bd%js:bd%je+1)
5065  LOGICAL :: fill_c
5066  REAL :: dt2, dt4, dt5, dt6
5067  REAL :: damp, damp2, damp4, dd8, u2, v2, du2, dv2
5068  REAL :: u_lon
5069  INTEGER :: i, j, is2, ie1, js2, je1, n, nt, n2, iq
5070  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
5071  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
5072  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
5073  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
5074  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
5075  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
5076  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
5077 & , rdx, rdy
5078  INTEGER :: is, ie, js, je
5079  INTEGER :: isd, ied, jsd, jed
5080  INTEGER :: npx, npy
5081  LOGICAL :: nested
5082  REAL :: delp_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5083  REAL :: pt_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5084  REAL :: vort_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5085  REAL :: wk_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5086  REAL :: delpc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5087  REAL :: ptc_tj(bd%isd:bd%ied, bd%jsd:bd%jed)
5088  REAL :: ke_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5089  REAL :: vc_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5090  REAL :: uc_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5091  REAL :: divg_d_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5092  REAL :: ut_tj(bd%isd:bd%ied+1, bd%jsd:bd%jed)
5093  REAL :: vt_tj(bd%isd:bd%ied, bd%jsd:bd%jed+1)
5094  INTRINSIC max
5095  INTRINSIC min
5096  INTRINSIC abs
5097  INTEGER :: max1
5098  INTEGER :: max2
5099  INTEGER :: max3
5100  INTEGER :: max4
5101  REAL :: abs0
5102  INTEGER :: min1
5103  INTEGER :: min2
5104  INTEGER :: min3
5105  INTEGER :: min4
5106  is = bd%is
5107  ie = bd%ie
5108  js = bd%js
5109  je = bd%je
5110  isd = bd%isd
5111  ied = bd%ied
5112  jsd = bd%jsd
5113  jed = bd%jed
5114  npx = flagstruct%npx
5115  npy = flagstruct%npy
5116  nested = gridstruct%nested
5117  area => gridstruct%area
5118  rarea => gridstruct%rarea
5119  sin_sg => gridstruct%sin_sg
5120  cosa_u => gridstruct%cosa_u
5121  cosa_v => gridstruct%cosa_v
5122  cosa_s => gridstruct%cosa_s
5123  sina_u => gridstruct%sina_u
5124  sina_v => gridstruct%sina_v
5125  rsin_u => gridstruct%rsin_u
5126  rsin_v => gridstruct%rsin_v
5127  rsina => gridstruct%rsina
5128  f0 => gridstruct%f0
5129  rsin2 => gridstruct%rsin2
5130  divg_u => gridstruct%divg_u
5131  divg_v => gridstruct%divg_v
5132  cosa => gridstruct%cosa
5133  dx => gridstruct%dx
5134  dy => gridstruct%dy
5135  dxc => gridstruct%dxc
5136  dyc => gridstruct%dyc
5137  rdxa => gridstruct%rdxa
5138  rdya => gridstruct%rdya
5139  rdx => gridstruct%rdx
5140  rdy => gridstruct%rdy
5141  sw_corner = gridstruct%sw_corner
5142  se_corner = gridstruct%se_corner
5143  nw_corner = gridstruct%nw_corner
5144  ne_corner = gridstruct%ne_corner
5145 ! end grid_type choices
5146  IF (flagstruct%grid_type .LT. 3) THEN
5147 !!! TO DO: separate versions for nesting and for cubed-sphere
5148  IF (nested) THEN
5149  DO j=jsd,jed
5150  DO i=is-1,ie+2
5151  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j)+&
5152 & vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
5153  END DO
5154  END DO
5155  DO j=js-1,je+2
5156  DO i=isd,ied
5157  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1, j&
5158 & -1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
5159  END DO
5160  END DO
5161  ELSE
5162  DO j=jsd,jed
5163  IF (j .NE. 0 .AND. j .NE. 1 .AND. j .NE. npy - 1 .AND. j .NE. &
5164 & npy) THEN
5165  DO i=is-1,ie+2
5166  ut(i, j) = (uc(i, j)-0.25*cosa_u(i, j)*(vc(i-1, j)+vc(i, j&
5167 & )+vc(i-1, j+1)+vc(i, j+1)))*rsin_u(i, j)
5168  END DO
5169  END IF
5170  END DO
5171  DO j=js-1,je+2
5172  IF (j .NE. 1 .AND. j .NE. npy) THEN
5173  DO i=isd,ied
5174  vt(i, j) = (vc(i, j)-0.25*cosa_v(i, j)*(uc(i, j-1)+uc(i+1&
5175 & , j-1)+uc(i, j)+uc(i+1, j)))*rsin_v(i, j)
5176  END DO
5177  END IF
5178  END DO
5179  END IF
5180 !.not. nested
5181  IF (.NOT.nested) THEN
5182 ! West face
5183 ! West edge:
5184  IF (is .EQ. 1) THEN
5185  DO j=jsd,jed
5186  IF (uc(1, j)*dt .GT. 0.) THEN
5187  ut(1, j) = uc(1, j)/sin_sg(0, j, 3)
5188  ELSE
5189  ut(1, j) = uc(1, j)/sin_sg(1, j, 1)
5190  END IF
5191  END DO
5192  IF (3 .LT. js) THEN
5193  max1 = js
5194  ELSE
5195  max1 = 3
5196  END IF
5197  IF (npy - 2 .GT. je + 1) THEN
5198  min1 = je + 1
5199  ELSE
5200  min1 = npy - 2
5201  END IF
5202  DO j=max1,min1
5203  vt(0, j) = vc(0, j) - 0.25*cosa_v(0, j)*(ut(0, j-1)+ut(1, j-&
5204 & 1)+ut(0, j)+ut(1, j))
5205  vt(1, j) = vc(1, j) - 0.25*cosa_v(1, j)*(ut(1, j-1)+ut(2, j-&
5206 & 1)+ut(1, j)+ut(2, j))
5207  END DO
5208  END IF
5209 ! East edge:
5210  IF (ie + 1 .EQ. npx) THEN
5211  DO j=jsd,jed
5212  IF (uc(npx, j)*dt .GT. 0.) THEN
5213  ut(npx, j) = uc(npx, j)/sin_sg(npx-1, j, 3)
5214  ELSE
5215  ut(npx, j) = uc(npx, j)/sin_sg(npx, j, 1)
5216  END IF
5217  END DO
5218  IF (3 .LT. js) THEN
5219  max2 = js
5220  ELSE
5221  max2 = 3
5222  END IF
5223  IF (npy - 2 .GT. je + 1) THEN
5224  min2 = je + 1
5225  ELSE
5226  min2 = npy - 2
5227  END IF
5228  DO j=max2,min2
5229  vt(npx-1, j) = vc(npx-1, j) - 0.25*cosa_v(npx-1, j)*(ut(npx-&
5230 & 1, j-1)+ut(npx, j-1)+ut(npx-1, j)+ut(npx, j))
5231  vt(npx, j) = vc(npx, j) - 0.25*cosa_v(npx, j)*(ut(npx, j-1)+&
5232 & ut(npx+1, j-1)+ut(npx, j)+ut(npx+1, j))
5233  END DO
5234  END IF
5235 ! South (Bottom) edge:
5236  IF (js .EQ. 1) THEN
5237  DO i=isd,ied
5238  IF (vc(i, 1)*dt .GT. 0.) THEN
5239  vt(i, 1) = vc(i, 1)/sin_sg(i, 0, 4)
5240  ELSE
5241  vt(i, 1) = vc(i, 1)/sin_sg(i, 1, 2)
5242  END IF
5243  END DO
5244  IF (3 .LT. is) THEN
5245  max3 = is
5246  ELSE
5247  max3 = 3
5248  END IF
5249  IF (npx - 2 .GT. ie + 1) THEN
5250  min3 = ie + 1
5251  ELSE
5252  min3 = npx - 2
5253  END IF
5254  DO i=max3,min3
5255  ut(i, 0) = uc(i, 0) - 0.25*cosa_u(i, 0)*(vt(i-1, 0)+vt(i, 0)&
5256 & +vt(i-1, 1)+vt(i, 1))
5257  ut(i, 1) = uc(i, 1) - 0.25*cosa_u(i, 1)*(vt(i-1, 1)+vt(i, 1)&
5258 & +vt(i-1, 2)+vt(i, 2))
5259  END DO
5260  END IF
5261 ! North edge:
5262  IF (je + 1 .EQ. npy) THEN
5263  DO i=isd,ied
5264  IF (vc(i, npy)*dt .GT. 0.) THEN
5265  vt(i, npy) = vc(i, npy)/sin_sg(i, npy-1, 4)
5266  ELSE
5267  vt(i, npy) = vc(i, npy)/sin_sg(i, npy, 2)
5268  END IF
5269  END DO
5270  IF (3 .LT. is) THEN
5271  max4 = is
5272  ELSE
5273  max4 = 3
5274  END IF
5275  IF (npx - 2 .GT. ie + 1) THEN
5276  min4 = ie + 1
5277  ELSE
5278  min4 = npx - 2
5279  END IF
5280  DO i=max4,min4
5281  ut(i, npy-1) = uc(i, npy-1) - 0.25*cosa_u(i, npy-1)*(vt(i-1&
5282 & , npy-1)+vt(i, npy-1)+vt(i-1, npy)+vt(i, npy))
5283  ut(i, npy) = uc(i, npy) - 0.25*cosa_u(i, npy)*(vt(i-1, npy)+&
5284 & vt(i, npy)+vt(i-1, npy+1)+vt(i, npy+1))
5285  END DO
5286  END IF
5287 ! The following code solves a 2x2 system to get the interior parallel-to-edge uc,vc values
5288 ! near the corners (ex: for the sw corner ut(2,1) and vt(1,2) are solved for simultaneously).
5289 ! It then computes the halo uc, vc values so as to be consistent with the computations on
5290 ! the facing panel.
5291 !The system solved is:
5292 ! ut(2,1) = uc(2,1) - avg(vt)*cosa_u(2,1)
5293 ! vt(1,2) = vc(1,2) - avg(ut)*cosa_v(1,2)
5294 ! in which avg(vt) includes vt(1,2) and avg(ut) includes ut(2,1)
5295  IF (sw_corner) THEN
5296  damp = 1./(1.-0.0625*cosa_u(2, 0)*cosa_v(1, 0))
5297  ut(2, 0) = (uc(2, 0)-0.25*cosa_u(2, 0)*(vt(1, 1)+vt(2, 1)+vt(2&
5298 & , 0)+vc(1, 0)-0.25*cosa_v(1, 0)*(ut(1, 0)+ut(1, -1)+ut(2, -1&
5299 & ))))*damp
5300  damp = 1./(1.-0.0625*cosa_u(0, 1)*cosa_v(0, 2))
5301  vt(0, 2) = (vc(0, 2)-0.25*cosa_v(0, 2)*(ut(1, 1)+ut(1, 2)+ut(0&
5302 & , 2)+uc(0, 1)-0.25*cosa_u(0, 1)*(vt(0, 1)+vt(-1, 1)+vt(-1, 2&
5303 & ))))*damp
5304  damp = 1./(1.-0.0625*cosa_u(2, 1)*cosa_v(1, 2))
5305  ut(2, 1) = (uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2&
5306 & , 2)+vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2, 2))&
5307 & ))*damp
5308  vt(1, 2) = (vc(1, 2)-0.25*cosa_v(1, 2)*(ut(1, 1)+ut(1, 2)+ut(2&
5309 & , 2)+uc(2, 1)-0.25*cosa_u(2, 1)*(vt(1, 1)+vt(2, 1)+vt(2, 2))&
5310 & ))*damp
5311  END IF
5312  IF (se_corner) THEN
5313  damp = 1./(1.-0.0625*cosa_u(npx-1, 0)*cosa_v(npx-1, 0))
5314  ut(npx-1, 0) = (uc(npx-1, 0)-0.25*cosa_u(npx-1, 0)*(vt(npx-1, &
5315 & 1)+vt(npx-2, 1)+vt(npx-2, 0)+vc(npx-1, 0)-0.25*cosa_v(npx-1&
5316 & , 0)*(ut(npx, 0)+ut(npx, -1)+ut(npx-1, -1))))*damp
5317  damp = 1./(1.-0.0625*cosa_u(npx+1, 1)*cosa_v(npx, 2))
5318  vt(npx, 2) = (vc(npx, 2)-0.25*cosa_v(npx, 2)*(ut(npx, 1)+ut(&
5319 & npx, 2)+ut(npx+1, 2)+uc(npx+1, 1)-0.25*cosa_u(npx+1, 1)*(vt(&
5320 & npx, 1)+vt(npx+1, 1)+vt(npx+1, 2))))*damp
5321  damp = 1./(1.-0.0625*cosa_u(npx-1, 1)*cosa_v(npx-1, 2))
5322  ut(npx-1, 1) = (uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*(vt(npx-1, &
5323 & 1)+vt(npx-2, 1)+vt(npx-2, 2)+vc(npx-1, 2)-0.25*cosa_v(npx-1&
5324 & , 2)*(ut(npx, 1)+ut(npx, 2)+ut(npx-1, 2))))*damp
5325  vt(npx-1, 2) = (vc(npx-1, 2)-0.25*cosa_v(npx-1, 2)*(ut(npx, 1)&
5326 & +ut(npx, 2)+ut(npx-1, 2)+uc(npx-1, 1)-0.25*cosa_u(npx-1, 1)*&
5327 & (vt(npx-1, 1)+vt(npx-2, 1)+vt(npx-2, 2))))*damp
5328  END IF
5329  IF (ne_corner) THEN
5330  damp = 1./(1.-0.0625*cosa_u(npx-1, npy)*cosa_v(npx-1, npy+1))
5331  ut(npx-1, npy) = (uc(npx-1, npy)-0.25*cosa_u(npx-1, npy)*(vt(&
5332 & npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy+1)+vc(npx-1, npy+1)&
5333 & -0.25*cosa_v(npx-1, npy+1)*(ut(npx, npy)+ut(npx, npy+1)+ut(&
5334 & npx-1, npy+1))))*damp
5335  damp = 1./(1.-0.0625*cosa_u(npx+1, npy-1)*cosa_v(npx, npy-1))
5336  vt(npx, npy-1) = (vc(npx, npy-1)-0.25*cosa_v(npx, npy-1)*(ut(&
5337 & npx, npy-1)+ut(npx, npy-2)+ut(npx+1, npy-2)+uc(npx+1, npy-1)&
5338 & -0.25*cosa_u(npx+1, npy-1)*(vt(npx, npy)+vt(npx+1, npy)+vt(&
5339 & npx+1, npy-1))))*damp
5340  damp = 1./(1.-0.0625*cosa_u(npx-1, npy-1)*cosa_v(npx-1, npy-1)&
5341 & )
5342  ut(npx-1, npy-1) = (uc(npx-1, npy-1)-0.25*cosa_u(npx-1, npy-1)&
5343 & *(vt(npx-1, npy)+vt(npx-2, npy)+vt(npx-2, npy-1)+vc(npx-1, &
5344 & npy-1)-0.25*cosa_v(npx-1, npy-1)*(ut(npx, npy-1)+ut(npx, npy&
5345 & -2)+ut(npx-1, npy-2))))*damp
5346  vt(npx-1, npy-1) = (vc(npx-1, npy-1)-0.25*cosa_v(npx-1, npy-1)&
5347 & *(ut(npx, npy-1)+ut(npx, npy-2)+ut(npx-1, npy-2)+uc(npx-1, &
5348 & npy-1)-0.25*cosa_u(npx-1, npy-1)*(vt(npx-1, npy)+vt(npx-2, &
5349 & npy)+vt(npx-2, npy-1))))*damp
5350  END IF
5351  IF (nw_corner) THEN
5352  damp = 1./(1.-0.0625*cosa_u(2, npy)*cosa_v(1, npy+1))
5353  ut(2, npy) = (uc(2, npy)-0.25*cosa_u(2, npy)*(vt(1, npy)+vt(2&
5354 & , npy)+vt(2, npy+1)+vc(1, npy+1)-0.25*cosa_v(1, npy+1)*(ut(1&
5355 & , npy)+ut(1, npy+1)+ut(2, npy+1))))*damp
5356  damp = 1./(1.-0.0625*cosa_u(0, npy-1)*cosa_v(0, npy-1))
5357  vt(0, npy-1) = (vc(0, npy-1)-0.25*cosa_v(0, npy-1)*(ut(1, npy-&
5358 & 1)+ut(1, npy-2)+ut(0, npy-2)+uc(0, npy-1)-0.25*cosa_u(0, npy&
5359 & -1)*(vt(0, npy)+vt(-1, npy)+vt(-1, npy-1))))*damp
5360  damp = 1./(1.-0.0625*cosa_u(2, npy-1)*cosa_v(1, npy-1))
5361  ut(2, npy-1) = (uc(2, npy-1)-0.25*cosa_u(2, npy-1)*(vt(1, npy)&
5362 & +vt(2, npy)+vt(2, npy-1)+vc(1, npy-1)-0.25*cosa_v(1, npy-1)*&
5363 & (ut(1, npy-1)+ut(1, npy-2)+ut(2, npy-2))))*damp
5364  vt(1, npy-1) = (vc(1, npy-1)-0.25*cosa_v(1, npy-1)*(ut(1, npy-&
5365 & 1)+ut(1, npy-2)+ut(2, npy-2)+uc(2, npy-1)-0.25*cosa_u(2, npy&
5366 & -1)*(vt(1, npy)+vt(2, npy)+vt(2, npy-1))))*damp
5367  END IF
5368  END IF
5369  ELSE
5370 ! flagstruct%grid_type >= 3
5371  DO j=jsd,jed
5372  DO i=is,ie+1
5373  ut(i, j) = uc(i, j)
5374  END DO
5375  END DO
5376  DO j=js,je+1
5377  DO i=isd,ied
5378  vt(i, j) = vc(i, j)
5379  END DO
5380  END DO
5381  END IF
5382  DO j=jsd,jed
5383  DO i=is,ie+1
5384  xfx_adv(i, j) = dt*ut(i, j)
5385  END DO
5386  END DO
5387  DO j=js,je+1
5388  DO i=isd,ied
5389  yfx_adv(i, j) = dt*vt(i, j)
5390  END DO
5391  END DO
5392 ! Explanation of the following code:
5393 ! xfx_adv = dt*ut*dy
5394 ! crx_adv = dt*ut/dx
5395  DO j=jsd,jed
5396 !DEC$ VECTOR ALWAYS
5397  DO i=is,ie+1
5398  IF (xfx_adv(i, j) .GT. 0.) THEN
5399  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i-1, j)
5400  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i-1, j, 3)
5401  ELSE
5402  crx_adv(i, j) = xfx_adv(i, j)*rdxa(i, j)
5403  xfx_adv(i, j) = dy(i, j)*xfx_adv(i, j)*sin_sg(i, j, 1)
5404  END IF
5405  END DO
5406  END DO
5407  DO j=js,je+1
5408 !DEC$ VECTOR ALWAYS
5409  DO i=isd,ied
5410  IF (yfx_adv(i, j) .GT. 0.) THEN
5411  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j-1)
5412  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j-1, 4)
5413  ELSE
5414  cry_adv(i, j) = yfx_adv(i, j)*rdya(i, j)
5415  yfx_adv(i, j) = dx(i, j)*yfx_adv(i, j)*sin_sg(i, j, 2)
5416  END IF
5417  END DO
5418  END DO
5419  DO j=jsd,jed
5420  DO i=is,ie
5421  ra_x(i, j) = area(i, j) + (xfx_adv(i, j)-xfx_adv(i+1, j))
5422  END DO
5423  END DO
5424  DO j=js,je
5425  DO i=isd,ied
5426  ra_y(i, j) = area(i, j) + (yfx_adv(i, j)-yfx_adv(i, j+1))
5427  END DO
5428  END DO
5429  IF (hord_dp .EQ. hord_dp_pert .AND. (.NOT.split_damp)) THEN
5430  CALL fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, fy&
5431 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, nord=&
5432 & nord_v, damp_c=damp_v)
5433  ELSE
5434  CALL fv_tp_2d(delp, crx_adv, cry_adv, npx, npy, hord_dp, fx, &
5435 & fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, nord=&
5436 & nord_v, damp_c=damp_v)
5437  END IF
5438 ! <<< Save the mass fluxes to the "Flux Capacitor" for tracer transport >>>
5439  DO j=jsd,jed
5440  DO i=is,ie+1
5441  cx(i, j) = cx(i, j) + crx_adv(i, j)
5442  END DO
5443  END DO
5444  DO j=js,je
5445  DO i=is,ie+1
5446  xflux(i, j) = xflux(i, j) + fx(i, j)
5447  END DO
5448  END DO
5449  DO j=js,je+1
5450  DO i=isd,ied
5451  cy(i, j) = cy(i, j) + cry_adv(i, j)
5452  END DO
5453  DO i=is,ie
5454  yflux(i, j) = yflux(i, j) + fy(i, j)
5455  END DO
5456  END DO
5457  DO j=js,je
5458  DO i=is,ie
5459  heat_source(i, j) = 0.
5460  END DO
5461  END DO
5462  IF (.NOT.hydrostatic) THEN
5463  IF (damp_w .GT. 1.e-5) THEN
5464  IF (dt .GE. 0.) THEN
5465  abs0 = dt
5466  ELSE
5467  abs0 = -dt
5468  END IF
5469  dd8 = kgb*abs0
5470  damp4 = (damp_w*gridstruct%da_min_c)**(nord_w+1)
5471  CALL del6_vt_flux(nord_w, npx, npy, damp4, w, wk, fx2, fy2, &
5472 & gridstruct, bd)
5473  DO j=js,je
5474  DO i=is,ie
5475  dw(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
5476 & rarea(i, j)
5477 ! 0.5 * [ (w+dw)**2 - w**2 ] = w*dw + 0.5*dw*dw
5478 ! heat_source(i,j) = -d_con*dw(i,j)*(w(i,j)+0.5*dw(i,j))
5479  heat_source(i, j) = dd8 - dw(i, j)*(w(i, j)+0.5*dw(i, j))
5480  END DO
5481  END DO
5482  END IF
5483  IF (hord_vt .EQ. hord_vt_pert) THEN
5484  CALL fv_tp_2d(w, crx_adv, cry_adv, npx, npy, hord_vt, gx, gy&
5485 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=&
5486 & fx, mfy=fy)
5487  ELSE
5488  CALL fv_tp_2d(w, crx_adv, cry_adv, npx, npy, hord_vt, gx, &
5489 & gy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, mfx=fx&
5490 & , mfy=fy)
5491  END IF
5492  DO j=js,je
5493  DO i=is,ie
5494  w(i, j) = delp(i, j)*w(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j)-&
5495 & gy(i, j+1)))*rarea(i, j)
5496  END DO
5497  END DO
5498  END IF
5499 ! if ( inline_q .and. zvir>0.01 ) then
5500 ! do j=jsd,jed
5501 ! do i=isd,ied
5502 ! pt(i,j) = pt(i,j)/(1.+zvir*q(i,j,k,sphum))
5503 ! enddo
5504 ! enddo
5505 ! endif
5506  IF (hord_tm .EQ. hord_tm_pert .AND. (.NOT.split_damp)) THEN
5507  CALL fv_tp_2d(pt, crx_adv, cry_adv, npx, npy, hord_tm, gx, gy, &
5508 & xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, fx, fy, &
5509 & delp, nord_t, damp_t)
5510  ELSE
5511  CALL fv_tp_2d(pt, crx_adv, cry_adv, npx, npy, hord_tm, gx, gy&
5512 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y, fx, fy, &
5513 & delp, nord_t, damp_t)
5514  END IF
5515  IF (inline_q) THEN
5516  DO j=js,je
5517  DO i=is,ie
5518  wk(i, j) = delp(i, j)
5519  delp(i, j) = wk(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
5520 & +1)))*rarea(i, j)
5521  pt(i, j) = (pt(i, j)*wk(i, j)+(gx(i, j)-gx(i+1, j)+(gy(i, j)-&
5522 & gy(i, j+1)))*rarea(i, j))/delp(i, j)
5523  END DO
5524  END DO
5525  DO iq=1,nq
5526  IF (hord_tr .EQ. hord_tr_pert) THEN
5527  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), crx_adv, cry_adv&
5528 & , npx, npy, hord_tr, gx, gy, xfx_adv, yfx_adv, &
5529 & gridstruct, bd, ra_x, ra_y, fx, fy, delp, nord_t, &
5530 & damp_t)
5531  ELSE
5532  CALL fv_tp_2d(q(isd:ied, jsd:jed, k, iq), crx_adv, cry_adv, &
5533 & npx, npy, hord_tr, gx, gy, xfx_adv, yfx_adv, &
5534 & gridstruct, bd, ra_x, ra_y, fx, fy, delp, nord_t&
5535 & , damp_t)
5536  END IF
5537  DO j=js,je
5538  DO i=is,ie
5539  q(i, j, k, iq) = (q(i, j, k, iq)*wk(i, j)+(gx(i, j)-gx(i+1, &
5540 & j)+(gy(i, j)-gy(i, j+1)))*rarea(i, j))/delp(i, j)
5541  END DO
5542  END DO
5543  END DO
5544  ELSE
5545 ! if ( zvir>0.01 ) then
5546 ! do j=js,je
5547 ! do i=is,ie
5548 ! pt(i,j) = pt(i,j)*(1.+zvir*q(i,j,k,sphum))
5549 ! enddo
5550 ! enddo
5551 ! endif
5552  DO j=js,je
5553  DO i=is,ie
5554  pt(i, j) = pt(i, j)*delp(i, j) + (gx(i, j)-gx(i+1, j)+(gy(i, j&
5555 & )-gy(i, j+1)))*rarea(i, j)
5556  delp(i, j) = delp(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i&
5557 & , j+1)))*rarea(i, j)
5558  pt(i, j) = pt(i, j)/delp(i, j)
5559  END DO
5560  END DO
5561  END IF
5562  IF (fpp%fpp_overload_r4) THEN
5563  DO j=js,je
5564  DO i=is,ie
5565  dpx(i, j) = dpx(i, j) + (fx(i, j)-fx(i+1, j)+(fy(i, j)-fy(i, j&
5566 & +1)))*rarea(i, j)
5567  END DO
5568  END DO
5569  END IF
5570 !----------------------
5571 ! Kinetic Energy Fluxes
5572 !----------------------
5573 ! Compute B grid contra-variant components for KE:
5574  dt5 = 0.5*dt
5575  dt4 = 0.25*dt
5576  IF (nested) THEN
5577  is2 = is
5578  ie1 = ie + 1
5579  js2 = js
5580  je1 = je + 1
5581  ELSE
5582  IF (2 .LT. is) THEN
5583  is2 = is
5584  ELSE
5585  is2 = 2
5586  END IF
5587  IF (npx - 1 .GT. ie + 1) THEN
5588  ie1 = ie + 1
5589  ELSE
5590  ie1 = npx - 1
5591  END IF
5592  IF (2 .LT. js) THEN
5593  js2 = js
5594  ELSE
5595  js2 = 2
5596  END IF
5597  IF (npy - 1 .GT. je + 1) THEN
5598  je1 = je + 1
5599  ELSE
5600  je1 = npy - 1
5601  END IF
5602  END IF
5603 !!! TO DO: separate versions for nested and for cubed-sphere
5604  IF (flagstruct%grid_type .LT. 3) THEN
5605  IF (nested) THEN
5606  DO j=js2,je1
5607  DO i=is2,ie1
5608  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
5609 & cosa(i, j))*rsina(i, j)
5610  END DO
5611  END DO
5612  ELSE
5613  IF (js .EQ. 1) THEN
5614  DO i=is,ie+1
5615 ! corner values are incorrect
5616  vb(i, 1) = dt5*(vt(i-1, 1)+vt(i, 1))
5617  END DO
5618  END IF
5619  DO j=js2,je1
5620  DO i=is2,ie1
5621  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j)-(uc(i, j-1)+uc(i, j))*&
5622 & cosa(i, j))*rsina(i, j)
5623  END DO
5624  IF (is .EQ. 1) vb(1, j) = dt4*(-vt(-1, j)+3.*(vt(0, j)+vt(1, j&
5625 & ))-vt(2, j))
5626 ! 2-pt extrapolation from both sides:
5627  IF (ie + 1 .EQ. npx) vb(npx, j) = dt4*(-vt(npx-2, j)+3.*(vt(&
5628 & npx-1, j)+vt(npx, j))-vt(npx+1, j))
5629 ! 2-pt extrapolation from both sides:
5630  END DO
5631  IF (je + 1 .EQ. npy) THEN
5632  DO i=is,ie+1
5633 ! corner values are incorrect
5634  vb(i, npy) = dt5*(vt(i-1, npy)+vt(i, npy))
5635  END DO
5636  END IF
5637  END IF
5638  ELSE
5639  DO j=js,je+1
5640  DO i=is,ie+1
5641  vb(i, j) = dt5*(vc(i-1, j)+vc(i, j))
5642  END DO
5643  END DO
5644  END IF
5645  IF (hord_mt .EQ. hord_mt_pert) THEN
5646  CALL ytp_v(is, ie, js, je, isd, ied, jsd, jed, vb, u, v, ub, &
5647 & hord_mt, gridstruct%dy, gridstruct%rdy, npx, npy, &
5648 & flagstruct%grid_type, nested)
5649  ELSE
5650  CALL ytp_v(is, ie, js, je, isd, ied, jsd, jed, vb, u, v, ub, &
5651 & hord_mt, gridstruct%dy, gridstruct%rdy, npx, npy, &
5652 & flagstruct%grid_type, nested)
5653  END IF
5654  DO j=js,je+1
5655  DO i=is,ie+1
5656  ke(i, j) = vb(i, j)*ub(i, j)
5657  END DO
5658  END DO
5659  IF (flagstruct%grid_type .LT. 3) THEN
5660  IF (nested) THEN
5661  DO j=js,je+1
5662  DO i=is2,ie1
5663  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
5664 & cosa(i, j))*rsina(i, j)
5665  END DO
5666  END DO
5667  ELSE
5668  IF (is .EQ. 1) THEN
5669  DO j=js,je+1
5670 ! corner values are incorrect
5671  ub(1, j) = dt5*(ut(1, j-1)+ut(1, j))
5672  END DO
5673  END IF
5674  DO j=js,je+1
5675  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
5676  DO i=is2,ie1
5677 ! 2-pt extrapolation from both sides:
5678  ub(i, j) = dt4*(-ut(i, j-2)+3.*(ut(i, j-1)+ut(i, j))-ut(i&
5679 & , j+1))
5680  END DO
5681  ELSE
5682  DO i=is2,ie1
5683  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j)-(vc(i-1, j)+vc(i, j))*&
5684 & cosa(i, j))*rsina(i, j)
5685  END DO
5686  END IF
5687  END DO
5688  IF (ie + 1 .EQ. npx) THEN
5689  DO j=js,je+1
5690 ! corner values are incorrect
5691  ub(npx, j) = dt5*(ut(npx, j-1)+ut(npx, j))
5692  END DO
5693  END IF
5694  END IF
5695  ELSE
5696  DO j=js,je+1
5697  DO i=is,ie+1
5698  ub(i, j) = dt5*(uc(i, j-1)+uc(i, j))
5699  END DO
5700  END DO
5701  END IF
5702  IF (hord_mt .EQ. hord_mt_pert) THEN
5703  CALL xtp_u(is, ie, js, je, isd, ied, jsd, jed, ub, u, v, vb, &
5704 & hord_mt, gridstruct%dx, gridstruct%rdx, npx, npy, &
5705 & flagstruct%grid_type, nested)
5706  ELSE
5707  CALL xtp_u(is, ie, js, je, isd, ied, jsd, jed, ub, u, v, vb, &
5708 & hord_mt, gridstruct%dx, gridstruct%rdx, npx, npy, &
5709 & flagstruct%grid_type, nested)
5710  END IF
5711  DO j=js,je+1
5712  DO i=is,ie+1
5713  ke(i, j) = 0.5*(ke(i, j)+ub(i, j)*vb(i, j))
5714  END DO
5715  END DO
5716 !-----------------------------------------
5717 ! Fix KE at the 4 corners of the face:
5718 !-----------------------------------------
5719  IF (.NOT.nested) THEN
5720  dt6 = dt/6.
5721  IF (sw_corner) ke(1, 1) = dt6*((ut(1, 1)+ut(1, 0))*u(1, 1)+(vt(1, &
5722 & 1)+vt(0, 1))*v(1, 1)+(ut(1, 1)+vt(1, 1))*u(0, 1))
5723  IF (se_corner) ke(npx, 1) = dt6*((ut(npx, 1)+ut(npx, 0))*u(npx-1, &
5724 & 1)+(vt(npx, 1)+vt(npx-1, 1))*v(npx, 1)+(ut(npx, 1)-vt(npx-1, 1&
5725 & ))*u(npx, 1))
5726 !i = npx
5727  IF (ne_corner) ke(npx, npy) = dt6*((ut(npx, npy)+ut(npx, npy-1))*u&
5728 & (npx-1, npy)+(vt(npx, npy)+vt(npx-1, npy))*v(npx, npy-1)+(ut(&
5729 & npx, npy-1)+vt(npx-1, npy))*u(npx, npy))
5730 !i = npx; j = npy
5731  IF (nw_corner) ke(1, npy) = dt6*((ut(1, npy)+ut(1, npy-1))*u(1, &
5732 & npy)+(vt(1, npy)+vt(0, npy))*v(1, npy-1)+(ut(1, npy-1)-vt(1, &
5733 & npy))*u(0, npy))
5734 !j = npy
5735  END IF
5736 ! Compute vorticity:
5737  DO j=jsd,jed+1
5738  DO i=isd,ied
5739  vt(i, j) = u(i, j)*dx(i, j)
5740  END DO
5741  END DO
5742  DO j=jsd,jed
5743  DO i=isd,ied+1
5744  ut(i, j) = v(i, j)*dy(i, j)
5745  END DO
5746  END DO
5747 ! wk is "volume-mean" relative vorticity
5748  DO j=jsd,jed
5749  DO i=isd,ied
5750  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i+1, j)-ut(i, j)&
5751 & ))
5752  END DO
5753  END DO
5754  IF (.NOT.hydrostatic) THEN
5755  IF (.NOT.flagstruct%do_f3d) THEN
5756  DO j=js,je
5757  DO i=is,ie
5758  w(i, j) = w(i, j)/delp(i, j)
5759  END DO
5760  END DO
5761  END IF
5762  IF (damp_w .GT. 1.e-5) THEN
5763  DO j=js,je
5764  DO i=is,ie
5765  w(i, j) = w(i, j) + dw(i, j)
5766  END DO
5767  END DO
5768  END IF
5769  END IF
5770 !-----------------------------
5771 ! Compute divergence damping
5772 !-----------------------------
5773 !! damp = dddmp * da_min_c
5774 !
5775 ! if ( nord==0 ) then
5776 !! area ~ dxb*dyb*sin(alpha)
5777 !
5778 ! if (nested) then
5779 !
5780 ! do j=js,je+1
5781 ! do i=is-1,ie+1
5782 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
5783 ! *dyc(i,j)*sina_v(i,j)
5784 ! enddo
5785 ! enddo
5786 !
5787 ! do j=js-1,je+1
5788 ! do i=is2,ie1
5789 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
5790 ! *dxc(i,j)*sina_u(i,j)
5791 ! enddo
5792 ! enddo
5793 !
5794 ! else
5795 ! do j=js,je+1
5796 !
5797 ! if ( (j==1 .or. j==npy) ) then
5798 ! do i=is-1,ie+1
5799 ! if (vc(i,j) > 0) then
5800 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j-1,4)
5801 ! else
5802 ! ptc(i,j) = u(i,j)*dyc(i,j)*sin_sg(i,j,2)
5803 ! end if
5804 ! enddo
5805 ! else
5806 ! do i=is-1,ie+1
5807 ! ptc(i,j) = (u(i,j)-0.5*(va(i,j-1)+va(i,j))*cosa_v(i,j)) &
5808 ! *dyc(i,j)*sina_v(i,j)
5809 ! enddo
5810 ! endif
5811 ! enddo
5812 !
5813 ! do j=js-1,je+1
5814 ! do i=is2,ie1
5815 ! vort(i,j) = (v(i,j) - 0.5*(ua(i-1,j)+ua(i,j))*cosa_u(i,j)) &
5816 ! *dxc(i,j)*sina_u(i,j)
5817 ! enddo
5818 ! if ( is == 1 ) then
5819 ! if (uc(1,j) > 0) then
5820 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0,j,3)
5821 ! else
5822 ! vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1,j,1)
5823 ! end if
5824 ! end if
5825 ! if ( (ie+1)==npx ) then
5826 ! if (uc(npx,j) > 0) then
5827 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
5828 ! sin_sg(npx-1,j,3)
5829 ! else
5830 ! vort(npx,j) = v(npx,j)*dxc(npx,j)* &
5831 ! sin_sg(npx,j,1)
5832 ! end if
5833 ! end if
5834 ! enddo
5835 ! endif
5836 !
5837 ! do j=js,je+1
5838 ! do i=is,ie+1
5839 ! delpc(i,j) = vort(i,j-1) - vort(i,j) + ptc(i-1,j) - ptc(i,j)
5840 ! enddo
5841 ! enddo
5842 !
5843 !! Remove the extra term at the corners:
5844 ! if (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
5845 ! if (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
5846 ! if (ne_corner) delpc(npx,npy) = delpc(npx,npy) + vort(npx,npy)
5847 ! if (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
5848 !
5849 ! do j=js,je+1
5850 ! do i=is,ie+1
5851 ! delpc(i,j) = gridstruct%rarea_c(i,j)*delpc(i,j)
5852 ! damp = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*abs(delpc(i,j)*dt)))
5853 ! vort(i,j) = damp*delpc(i,j)
5854 ! ke(i,j) = ke(i,j) + vort(i,j)
5855 ! enddo
5856 ! enddo
5857 ! else
5858 !!--------------------------
5859 !! Higher order divg damping
5860 !!--------------------------
5861 ! do j=js,je+1
5862 ! do i=is,ie+1
5863 !! Save divergence for external mode filter
5864 ! delpc(i,j) = divg_d(i,j)
5865 ! enddo
5866 ! enddo
5867 !
5868 ! n2 = nord + 1 ! N > 1
5869 ! do n=1,nord
5870 ! nt = nord-n
5871 !
5872 ! fill_c = (nt/=0) .and. (flagstruct%grid_type<3) .and. &
5873 ! ( sw_corner .or. se_corner .or. ne_corner .or. nw_corner ) &
5874 ! .and. .not. nested
5875 !
5876 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=XDir, BGRID=.true.)
5877 ! do j=js-nt,je+1+nt
5878 ! do i=is-1-nt,ie+1+nt
5879 ! vc(i,j) = (divg_d(i+1,j)-divg_d(i,j))*divg_u(i,j)
5880 ! enddo
5881 ! enddo
5882 !
5883 ! if ( fill_c ) call fill_corners(divg_d, npx, npy, FILL=YDir, BGRID=.true.)
5884 ! do j=js-1-nt,je+1+nt
5885 ! do i=is-nt,ie+1+nt
5886 ! uc(i,j) = (divg_d(i,j+1)-divg_d(i,j))*divg_v(i,j)
5887 ! enddo
5888 ! enddo
5889 !
5890 ! if ( fill_c ) call fill_corners(vc, uc, npx, npy, VECTOR=.true., DGRID=.true.)
5891 ! do j=js-nt,je+1+nt
5892 ! do i=is-nt,ie+1+nt
5893 ! divg_d(i,j) = uc(i,j-1) - uc(i,j) + vc(i-1,j) - vc(i,j)
5894 ! enddo
5895 ! enddo
5896 !
5897 !! Remove the extra term at the corners:
5898 ! if (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
5899 ! if (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
5900 ! if (ne_corner) divg_d(npx,npy) = divg_d(npx,npy) + uc(npx,npy)
5901 ! if (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
5902 !
5903 ! if ( .not. gridstruct%stretched_grid ) then
5904 ! do j=js-nt,je+1+nt
5905 ! do i=is-nt,ie+1+nt
5906 ! divg_d(i,j) = divg_d(i,j)*gridstruct%rarea_c(i,j)
5907 ! enddo
5908 ! enddo
5909 ! endif
5910 !
5911 ! enddo ! n-loop
5912 !
5913 ! if ( dddmp<1.E-5) then
5914 ! vort(:,:) = 0.
5915 ! else
5916 ! if ( flagstruct%grid_type < 3 ) then
5917 !! Interpolate relative vort to cell corners
5918 ! call a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng, .false.)
5919 ! do j=js,je+1
5920 ! do i=is,ie+1
5921 !! The following is an approxi form of Smagorinsky diffusion
5922 ! vort(i,j) = abs(dt)*sqrt(delpc(i,j)**2 + vort(i,j)**2)
5923 ! enddo
5924 ! enddo
5925 ! else ! Correct form: works only for doubly preiodic domain
5926 ! call smag_corner(abs(dt), u, v, ua, va, vort, bd, npx, npy, gridstruct, ng)
5927 ! endif
5928 ! endif
5929 !
5930 ! if (gridstruct%stretched_grid ) then
5931 !! Stretched grid with variable damping ~ area
5932 ! dd8 = gridstruct%da_min * d4_bg**n2
5933 ! else
5934 ! dd8 = ( gridstruct%da_min_c*d4_bg )**n2
5935 ! endif
5936 !
5937 ! do j=js,je+1
5938 ! do i=is,ie+1
5939 ! damp2 = gridstruct%da_min_c*max(d2_bg, min(0.20, dddmp*vort(i,j))) ! del-2
5940 ! vort(i,j) = damp2*delpc(i,j) + dd8*divg_d(i,j)
5941 ! ke(i,j) = ke(i,j) + vort(i,j)
5942 ! enddo
5943 ! enddo
5944 !
5945 ! endif
5946  IF (.NOT.split_damp) THEN
5947  CALL compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, &
5948 & vort, ptc, delpc, ke, u, v, uc, vc, &
5949 & ua, va, divg_d, wk, gridstruct, &
5950 & flagstruct, bd)
5951  ELSE
5952  CALL compute_divergence_damping(nord, d2_bg, d4_bg&
5953 & , dddmp, dt, vort, ptc, delpc, ke, &
5954 & u, v, uc, vc, ua, va, divg_d, wk, &
5955 & gridstruct, flagstruct, bd)
5956  END IF
5957  IF (d_con .GT. 1.e-5) THEN
5958  DO j=js,je+1
5959  DO i=is,ie
5960  ub(i, j) = vort(i, j) - vort(i+1, j)
5961  END DO
5962  END DO
5963  DO j=js,je
5964  DO i=is,ie+1
5965  vb(i, j) = vort(i, j) - vort(i, j+1)
5966  END DO
5967  END DO
5968  END IF
5969 ! Vorticity transport
5970  IF (hydrostatic) THEN
5971  DO j=jsd,jed
5972  DO i=isd,ied
5973  vort(i, j) = wk(i, j) + f0(i, j)
5974  END DO
5975  END DO
5976  ELSE IF (flagstruct%do_f3d) THEN
5977  DO j=jsd,jed
5978  DO i=isd,ied
5979  vort(i, j) = wk(i, j) + f0(i, j)*z_rat(i, j)
5980  END DO
5981  END DO
5982  ELSE
5983  DO j=jsd,jed
5984  DO i=isd,ied
5985  vort(i, j) = wk(i, j) + f0(i, j)
5986  END DO
5987  END DO
5988  END IF
5989  IF (hord_vt .EQ. hord_vt_pert) THEN
5990  CALL fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, fy&
5991 & , xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y)
5992  ELSE
5993  CALL fv_tp_2d(vort, crx_adv, cry_adv, npx, npy, hord_vt, fx, &
5994 & fy, xfx_adv, yfx_adv, gridstruct, bd, ra_x, ra_y)
5995  END IF
5996  DO j=js,je+1
5997  DO i=is,ie
5998  u(i, j) = vt(i, j) + (ke(i, j)-ke(i+1, j)) + fy(i, j)
5999  END DO
6000  END DO
6001  DO j=js,je
6002  DO i=is,ie+1
6003  v(i, j) = ut(i, j) + (ke(i, j)-ke(i, j+1)) - fx(i, j)
6004  END DO
6005  END DO
6006 !--------------------------------------------------------
6007 ! damping applied to relative vorticity (wk):
6008  IF (damp_v .GT. 1.e-5) THEN
6009  damp4 = (damp_v*gridstruct%da_min_c)**(nord_v+1)
6010  CALL del6_vt_flux(nord_v, npx, npy, damp4, wk, vort, ut, vt, &
6011 & gridstruct, bd)
6012  END IF
6013  IF (d_con .GT. 1.e-5) THEN
6014  DO j=js,je+1
6015  DO i=is,ie
6016  ub(i, j) = (ub(i, j)+vt(i, j))*rdx(i, j)
6017  fy(i, j) = u(i, j)*rdx(i, j)
6018  gy(i, j) = fy(i, j)*ub(i, j)
6019  END DO
6020  END DO
6021  DO j=js,je
6022  DO i=is,ie+1
6023  vb(i, j) = (vb(i, j)-ut(i, j))*rdy(i, j)
6024  fx(i, j) = v(i, j)*rdy(i, j)
6025  gx(i, j) = fx(i, j)*vb(i, j)
6026  END DO
6027  END DO
6028 !----------------------------------
6029 ! Heating due to damping:
6030 !----------------------------------
6031  damp = 0.25*d_con
6032  DO j=js,je
6033  DO i=is,ie
6034  u2 = fy(i, j) + fy(i, j+1)
6035  du2 = ub(i, j) + ub(i, j+1)
6036  v2 = fx(i, j) + fx(i+1, j)
6037  dv2 = vb(i, j) + vb(i+1, j)
6038 ! Total energy conserving:
6039 ! Convert lost KE due to divergence damping to "heat"
6040  heat_source(i, j) = delp(i, j)*(heat_source(i, j)-damp*rsin2(i&
6041 & , j)*(ub(i, j)**2+ub(i, j+1)**2+vb(i, j)**2+vb(i+1, j)**2+2.&
6042 & *(gy(i, j)+gy(i, j+1)+gx(i, j)+gx(i+1, j))-cosa_s(i, j)*(u2*&
6043 & dv2+v2*du2+du2*dv2)))
6044  END DO
6045  END DO
6046  END IF
6047 ! Add diffusive fluxes to the momentum equation:
6048  IF (damp_v .GT. 1.e-5) THEN
6049  DO j=js,je+1
6050  DO i=is,ie
6051  u(i, j) = u(i, j) + vt(i, j)
6052  END DO
6053  END DO
6054  DO j=js,je
6055  DO i=is,ie+1
6056  v(i, j) = v(i, j) - ut(i, j)
6057  END DO
6058  END DO
6059  END IF
6060  END SUBROUTINE d_sw
6061 ! Differentiation of del6_vt_flux in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 d
6062 !yn_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_mod.p_grad_c
6063 !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.mix_dp dyn_cor
6064 !e_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dyn
6065 !amics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_uti
6066 !ls_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz
6067 !_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.sc
6068 !alar_profile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.s
6069 !teepz 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_restart_mod.d2
6070 !c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.
6071 !compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solv
6072 !er_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.SIM3p0_solv
6073 !er nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh
6074 ! sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_c
6075 !ore_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mo
6076 !d.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corn
6077 !ers_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_ci
6078 !rcle_dist sw_core_mod.edge_interpolate4)):
6079 ! gradient of useful results: q fy2 d2 fx2
6080 ! with respect to varying inputs: q fy2 d2 fx2
6081  SUBROUTINE del6_vt_flux_adm(nord, npx, npy, damp, q, q_ad, d2, d2_ad, &
6082 & fx2, fx2_ad, fy2, fy2_ad, gridstruct, bd)
6083  IMPLICIT NONE
6084 ! Del-nord damping for the relative vorticity
6085 ! nord must be <= 2
6086 !------------------
6087 ! nord = 0: del-2
6088 ! nord = 1: del-4
6089 ! nord = 2: del-6
6090 !------------------
6091  INTEGER, INTENT(IN) :: nord, npx, npy
6092  REAL, INTENT(IN) :: damp
6093  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6094 ! rel. vorticity ghosted on input
6095  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
6096  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6097  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6098 ! Work arrays:
6099  REAL :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
6100  REAL :: d2_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6101  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd:bd%ied, bd%&
6102 & jsd:bd%jed+1)
6103  REAL :: fx2_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2_ad(bd%isd:bd%ied&
6104 & , bd%jsd:bd%jed+1)
6105  INTEGER :: i, j, nt, n, i1, i2, j1, j2
6106  LOGICAL :: nested
6107  INTEGER :: is, ie, js, je
6108  REAL :: temp_ad
6109  REAL :: temp_ad0
6110  REAL :: temp_ad1
6111  REAL :: temp_ad2
6112  REAL :: temp_ad3
6113  INTEGER :: ad_from
6114  INTEGER :: ad_to
6115  INTEGER :: ad_from0
6116  INTEGER :: ad_to0
6117  INTEGER :: ad_from1
6118  INTEGER :: ad_to1
6119  INTEGER :: ad_from2
6120  INTEGER :: ad_to2
6121  INTEGER :: ad_from3
6122  INTEGER :: ad_to3
6123  INTEGER :: ad_from4
6124  INTEGER :: ad_to4
6125  INTEGER :: branch
6126  nested = gridstruct%nested
6127  is = bd%is
6128  ie = bd%ie
6129  js = bd%js
6130  je = bd%je
6131  i1 = is - 1 - nord
6132  i2 = ie + 1 + nord
6133  j1 = js - 1 - nord
6134  j2 = je + 1 + nord
6135  IF (nord .GT. 0) THEN
6136  CALL pushcontrol1b(1)
6137  ELSE
6138  CALL pushcontrol1b(0)
6139  END IF
6140  IF (nord .GT. 0) THEN
6141  CALL pushcontrol1b(1)
6142  ELSE
6143  CALL pushcontrol1b(0)
6144  END IF
6145  IF (nord .GT. 0) THEN
6146  DO n=1,nord
6147  nt = nord - n
6148  ad_from0 = js - nt - 1
6149  DO j=ad_from0,je+nt+1
6150  ad_from = is - nt - 1
6151  i = ie + nt + 2
6152  CALL pushinteger4(i - 1)
6153  CALL pushinteger4(ad_from)
6154  END DO
6155  CALL pushinteger4(j - 1)
6156  CALL pushinteger4(ad_from0)
6157  ad_from2 = js - nt
6158  DO j=ad_from2,je+nt
6159  ad_from1 = is - nt
6160  i = ie + nt + 2
6161  CALL pushinteger4(i - 1)
6162  CALL pushinteger4(ad_from1)
6163  END DO
6164  CALL pushinteger4(j - 1)
6165  CALL pushinteger4(ad_from2)
6166  ad_from4 = js - nt
6167  DO j=ad_from4,je+nt+1
6168  ad_from3 = is - nt
6169  i = ie + nt + 1
6170  CALL pushinteger4(i - 1)
6171  CALL pushinteger4(ad_from3)
6172  END DO
6173  CALL pushinteger4(j - 1)
6174  CALL pushinteger4(ad_from4)
6175  END DO
6176  DO n=nord,1,-1
6177  CALL popinteger4(ad_from4)
6178  CALL popinteger4(ad_to4)
6179  DO j=ad_to4,ad_from4,-1
6180  CALL popinteger4(ad_from3)
6181  CALL popinteger4(ad_to3)
6182  DO i=ad_to3,ad_from3,-1
6183  temp_ad3 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
6184  d2_ad(i, j) = d2_ad(i, j) + temp_ad3
6185  d2_ad(i, j-1) = d2_ad(i, j-1) - temp_ad3
6186  fy2_ad(i, j) = 0.0
6187  END DO
6188  END DO
6189  CALL copy_corners_adm(d2, d2_ad, npx, npy, 2, nested, bd, &
6190 & gridstruct%sw_corner, gridstruct%se_corner, &
6191 & gridstruct%nw_corner, gridstruct%ne_corner)
6192  CALL popinteger4(ad_from2)
6193  CALL popinteger4(ad_to2)
6194  DO j=ad_to2,ad_from2,-1
6195  CALL popinteger4(ad_from1)
6196  CALL popinteger4(ad_to1)
6197  DO i=ad_to1,ad_from1,-1
6198  temp_ad2 = gridstruct%del6_v(i, j)*fx2_ad(i, j)
6199  d2_ad(i, j) = d2_ad(i, j) + temp_ad2
6200  d2_ad(i-1, j) = d2_ad(i-1, j) - temp_ad2
6201  fx2_ad(i, j) = 0.0
6202  END DO
6203  END DO
6204  CALL copy_corners_adm(d2, d2_ad, npx, npy, 1, nested, bd, &
6205 & gridstruct%sw_corner, gridstruct%se_corner, &
6206 & gridstruct%nw_corner, gridstruct%ne_corner)
6207  CALL popinteger4(ad_from0)
6208  CALL popinteger4(ad_to0)
6209  DO j=ad_to0,ad_from0,-1
6210  CALL popinteger4(ad_from)
6211  CALL popinteger4(ad_to)
6212  DO i=ad_to,ad_from,-1
6213  temp_ad1 = gridstruct%rarea(i, j)*d2_ad(i, j)
6214  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad1
6215  fx2_ad(i+1, j) = fx2_ad(i+1, j) - temp_ad1
6216  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad1
6217  fy2_ad(i, j+1) = fy2_ad(i, j+1) - temp_ad1
6218  d2_ad(i, j) = 0.0
6219  END DO
6220  END DO
6221  END DO
6222  END IF
6223  DO j=je+nord+1,js-nord,-1
6224  DO i=ie+nord,is-nord,-1
6225  temp_ad0 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
6226  d2_ad(i, j-1) = d2_ad(i, j-1) + temp_ad0
6227  d2_ad(i, j) = d2_ad(i, j) - temp_ad0
6228  fy2_ad(i, j) = 0.0
6229  END DO
6230  END DO
6231  CALL popcontrol1b(branch)
6232  IF (branch .NE. 0) CALL copy_corners_adm(d2, d2_ad, npx, npy, 2, &
6233 & nested, bd, gridstruct%sw_corner&
6234 & , gridstruct%se_corner, &
6235 & gridstruct%nw_corner, gridstruct%&
6236 & ne_corner)
6237  DO j=je+nord,js-nord,-1
6238  DO i=ie+nord+1,is-nord,-1
6239  temp_ad = gridstruct%del6_v(i, j)*fx2_ad(i, j)
6240  d2_ad(i-1, j) = d2_ad(i-1, j) + temp_ad
6241  d2_ad(i, j) = d2_ad(i, j) - temp_ad
6242  fx2_ad(i, j) = 0.0
6243  END DO
6244  END DO
6245  CALL popcontrol1b(branch)
6246  IF (branch .NE. 0) CALL copy_corners_adm(d2, d2_ad, npx, npy, 1, &
6247 & nested, bd, gridstruct%sw_corner&
6248 & , gridstruct%se_corner, &
6249 & gridstruct%nw_corner, gridstruct%&
6250 & ne_corner)
6251  DO j=j2,j1,-1
6252  DO i=i2,i1,-1
6253  q_ad(i, j) = q_ad(i, j) + damp*d2_ad(i, j)
6254  d2_ad(i, j) = 0.0
6255  END DO
6256  END DO
6257  END SUBROUTINE del6_vt_flux_adm
6258  SUBROUTINE del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, &
6259 & gridstruct, bd)
6260  IMPLICIT NONE
6261 ! Del-nord damping for the relative vorticity
6262 ! nord must be <= 2
6263 !------------------
6264 ! nord = 0: del-2
6265 ! nord = 1: del-4
6266 ! nord = 2: del-6
6267 !------------------
6268  INTEGER, INTENT(IN) :: nord, npx, npy
6269  REAL, INTENT(IN) :: damp
6270  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6271 ! rel. vorticity ghosted on input
6272  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
6273  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6274 ! Work arrays:
6275  REAL, INTENT(OUT) :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
6276  REAL, INTENT(OUT) :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd&
6277 & :bd%ied, bd%jsd:bd%jed+1)
6278  INTEGER :: i, j, nt, n, i1, i2, j1, j2
6279  LOGICAL :: nested
6280  INTEGER :: is, ie, js, je
6281  nested = gridstruct%nested
6282  is = bd%is
6283  ie = bd%ie
6284  js = bd%js
6285  je = bd%je
6286  i1 = is - 1 - nord
6287  i2 = ie + 1 + nord
6288  j1 = js - 1 - nord
6289  j2 = je + 1 + nord
6290  DO j=j1,j2
6291  DO i=i1,i2
6292  d2(i, j) = damp*q(i, j)
6293  END DO
6294  END DO
6295  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 1, nested, bd, &
6296 & gridstruct%sw_corner, gridstruct%&
6297 & se_corner, gridstruct%nw_corner, &
6298 & gridstruct%ne_corner)
6299  DO j=js-nord,je+nord
6300  DO i=is-nord,ie+nord+1
6301  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
6302  END DO
6303  END DO
6304  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 2, nested, bd, &
6305 & gridstruct%sw_corner, gridstruct%&
6306 & se_corner, gridstruct%nw_corner, &
6307 & gridstruct%ne_corner)
6308  DO j=js-nord,je+nord+1
6309  DO i=is-nord,ie+nord
6310  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
6311  END DO
6312  END DO
6313  IF (nord .GT. 0) THEN
6314  DO n=1,nord
6315  nt = nord - n
6316  DO j=js-nt-1,je+nt+1
6317  DO i=is-nt-1,ie+nt+1
6318  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+(fy2(i, j)-fy2(i, j+1)))*&
6319 & gridstruct%rarea(i, j)
6320  END DO
6321  END DO
6322  CALL copy_corners(d2, npx, npy, 1, nested, bd, gridstruct%&
6323 & sw_corner, gridstruct%se_corner, gridstruct%&
6324 & nw_corner, gridstruct%ne_corner)
6325  DO j=js-nt,je+nt
6326  DO i=is-nt,ie+nt+1
6327  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
6328  END DO
6329  END DO
6330  CALL copy_corners(d2, npx, npy, 2, nested, bd, gridstruct%&
6331 & sw_corner, gridstruct%se_corner, gridstruct%&
6332 & nw_corner, gridstruct%ne_corner)
6333  DO j=js-nt,je+nt+1
6334  DO i=is-nt,ie+nt
6335  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
6336  END DO
6337  END DO
6338  END DO
6339  END IF
6340  END SUBROUTINE del6_vt_flux
6341 ! Differentiation of divergence_corner in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b
6342 !_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
6343 !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
6344 !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
6345 !ayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.
6346 !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
6347 !_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
6348 !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
6349 !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
6350 !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
6351 !_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
6352 !_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
6353 !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
6354 !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
6355 !_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
6356 !.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
6357 !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
6358 !d_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6359 ! gradient of useful results: u v ua va divg_d
6360 ! with respect to varying inputs: u v ua va divg_d
6361  SUBROUTINE divergence_corner_fwd(u, v, ua, va, divg_d, gridstruct, &
6362 & flagstruct, bd)
6363  !USE ISO_C_BINDING
6364  !USE ADMM_TAPENADE_INTERFACE
6365  IMPLICIT NONE
6366  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6367  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
6368  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
6369  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
6370  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
6371  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6372  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
6373 ! local
6374  REAL :: uf(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
6375  REAL :: vf(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
6376  INTEGER :: i, j
6377  INTEGER :: is2, ie1
6378  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
6379  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
6380  INTEGER :: is, ie, js, je
6381  INTEGER :: npx, npy
6382  LOGICAL :: nested
6383  INTRINSIC max
6384  INTRINSIC min
6385 
6386  uf = 0.0
6387  vf = 0.0
6388  is2 = 0
6389  ie1 = 0
6390  is = 0
6391  ie = 0
6392  js = 0
6393  je = 0
6394  npx = 0
6395  npy = 0
6396 
6397  is = bd%is
6398  ie = bd%ie
6399  js = bd%js
6400  je = bd%je
6401  npx = flagstruct%npx
6402  npy = flagstruct%npy
6403  nested = gridstruct%nested
6404  sin_sg => gridstruct%sin_sg
6405  cos_sg => gridstruct%cos_sg
6406  dxc => gridstruct%dxc
6407  dyc => gridstruct%dyc
6408  IF (nested) THEN
6409  CALL pushcontrol(1,0)
6410  is2 = is
6411  ie1 = ie + 1
6412  ELSE
6413  IF (2 .LT. is) THEN
6414  is2 = is
6415  ELSE
6416  is2 = 2
6417  END IF
6418  IF (npx - 1 .GT. ie + 1) THEN
6419  CALL pushcontrol(1,1)
6420  ie1 = ie + 1
6421  ELSE
6422  CALL pushcontrol(1,1)
6423  ie1 = npx - 1
6424  END IF
6425  END IF
6426  IF (flagstruct%grid_type .EQ. 4) THEN
6427  DO j=js-1,je+2
6428  DO i=is-2,ie+2
6429  uf(i, j) = u(i, j)*dyc(i, j)
6430  END DO
6431  END DO
6432  DO j=js-2,je+2
6433  DO i=is-1,ie+2
6434  vf(i, j) = v(i, j)*dxc(i, j)
6435  END DO
6436  END DO
6437  DO j=js-1,je+2
6438  DO i=is-1,ie+2
6439  divg_d(i, j) = gridstruct%rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(&
6440 & uf(i-1, j)-uf(i, j)))
6441  END DO
6442  END DO
6443  CALL pushinteger(je)
6444  CALL pushinteger(is)
6445  CALL pushinteger(ie)
6446  !CALL PUSHPOINTER8(C_LOC(dyc))
6447  !CALL PUSHPOINTER8(C_LOC(dxc))
6448  CALL pushinteger(js)
6449  CALL pushcontrol(1,0)
6450  ELSE
6451 ! 9---4---8
6452 ! | |
6453 ! 1 5 3
6454 ! | |
6455 ! 6---2---7
6456  DO j=js,je+1
6457  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
6458  DO i=is-1,ie+1
6459  uf(i, j) = u(i, j)*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i&
6460 & , j, 2))
6461  END DO
6462  CALL pushcontrol(1,1)
6463  ELSE
6464  DO i=is-1,ie+1
6465  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-&
6466 & 1, 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
6467 & sin_sg(i, j, 2))
6468  END DO
6469  CALL pushcontrol(1,0)
6470  END IF
6471  END DO
6472  DO j=js-1,je+1
6473  DO i=is2,ie1
6474  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
6475 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
6476 & sin_sg(i, j, 1))
6477  END DO
6478  IF (is .EQ. 1) THEN
6479  vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0, j, 3)+sin_sg(1, j&
6480 & , 1))
6481  CALL pushcontrol(1,0)
6482  ELSE
6483  CALL pushcontrol(1,1)
6484  END IF
6485  IF (ie + 1 .EQ. npx) THEN
6486  vf(npx, j) = v(npx, j)*dxc(npx, j)*0.5*(sin_sg(npx-1, j, 3)+&
6487 & sin_sg(npx, j, 1))
6488  CALL pushcontrol(1,1)
6489  ELSE
6490  CALL pushcontrol(1,0)
6491  END IF
6492  END DO
6493  DO j=js,je+1
6494  DO i=is,ie+1
6495  divg_d(i, j) = vf(i, j-1) - vf(i, j) + (uf(i-1, j)-uf(i, j))
6496  END DO
6497  END DO
6498 ! Remove the extra term at the corners:
6499  IF (gridstruct%sw_corner) THEN
6500  divg_d(1, 1) = divg_d(1, 1) - vf(1, 0)
6501  CALL pushcontrol(1,0)
6502  ELSE
6503  CALL pushcontrol(1,1)
6504  END IF
6505  IF (gridstruct%se_corner) THEN
6506  divg_d(npx, 1) = divg_d(npx, 1) - vf(npx, 0)
6507  CALL pushcontrol(1,0)
6508  ELSE
6509  CALL pushcontrol(1,1)
6510  END IF
6511  IF (gridstruct%ne_corner) THEN
6512  divg_d(npx, npy) = divg_d(npx, npy) + vf(npx, npy)
6513  CALL pushcontrol(1,0)
6514  ELSE
6515  CALL pushcontrol(1,1)
6516  END IF
6517  IF (gridstruct%nw_corner) THEN
6518  divg_d(1, npy) = divg_d(1, npy) + vf(1, npy)
6519  CALL pushcontrol(1,1)
6520  ELSE
6521  CALL pushcontrol(1,0)
6522  END IF
6523  DO j=js,je+1
6524  DO i=is,ie+1
6525  divg_d(i, j) = gridstruct%rarea_c(i, j)*divg_d(i, j)
6526  END DO
6527  END DO
6528  CALL pushinteger(je)
6529  CALL pushinteger(ie1)
6530  CALL pushinteger(is)
6531  CALL pushinteger(ie)
6532  !CALL PUSHPOINTER8(C_LOC(dyc))
6533  !CALL PUSHPOINTER8(C_LOC(sin_sg))
6534  CALL pushinteger(is2)
6535  !CALL PUSHPOINTER8(C_LOC(dxc))
6536  !CALL PUSHPOINTER8(C_LOC(cos_sg))
6537  CALL pushinteger(npy)
6538  CALL pushinteger(npx)
6539  CALL pushinteger(js)
6540  CALL pushcontrol(1,1)
6541  END IF
6542  END SUBROUTINE divergence_corner_fwd
6543 ! Differentiation of divergence_corner in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2
6544 !b_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 d
6545 !yn_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_co
6546 !re_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.
6547 !Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod
6548 !.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_map
6549 !z_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.re
6550 !map_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_l
6551 !imiters 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_cu
6552 !bic 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.f
6553 !v_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 n
6554 !h_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_
6555 !utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_u
6556 !tils_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_cor
6557 !e_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_mo
6558 !d.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
6559 !tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gr
6560 !id_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6561 ! gradient of useful results: u v ua va divg_d
6562 ! with respect to varying inputs: u v ua va divg_d
6563  SUBROUTINE divergence_corner_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, &
6564 & va_ad, divg_d, divg_d_ad, gridstruct, flagstruct, bd)
6565  !USE ISO_C_BINDING
6566  !USE ADMM_TAPENADE_INTERFACE
6567  IMPLICIT NONE
6568  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6569  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
6570  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
6571  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
6572  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
6573  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
6574  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua_ad, va_ad
6575  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
6576  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d_ad
6577  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6578  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
6579  REAL :: uf(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
6580  REAL :: uf_ad(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
6581  REAL :: vf(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
6582  REAL :: vf_ad(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
6583  INTEGER :: i, j
6584  INTEGER :: is2, ie1
6585  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
6586  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
6587  INTEGER :: is, ie, js, je
6588  INTEGER :: npx, npy
6589  LOGICAL :: nested
6590  INTRINSIC max
6591  INTRINSIC min
6592  REAL :: temp_ad
6593  REAL :: temp_ad0
6594  REAL :: temp_ad1
6595  REAL :: temp_ad2
6596  REAL :: temp_ad3
6597  INTEGER :: branch
6598  !TYPE(C_PTR) :: cptr
6599  !INTEGER :: unknown_shape_in_divergence_corner
6600 
6601  uf = 0.0
6602  vf = 0.0
6603  is2 = 0
6604  ie1 = 0
6605  is = 0
6606  ie = 0
6607  js = 0
6608  je = 0
6609  npx = 0
6610  npy = 0
6611  branch = 0
6612 
6613  is = bd%is
6614  ie = bd%ie
6615  js = bd%js
6616  je = bd%je
6617  npx = flagstruct%npx
6618  npy = flagstruct%npy
6619  nested = gridstruct%nested
6620  sin_sg => gridstruct%sin_sg
6621  cos_sg => gridstruct%cos_sg
6622  dxc => gridstruct%dxc
6623  dyc => gridstruct%dyc
6624  CALL popcontrol(1,branch)
6625  IF (branch .EQ. 0) THEN
6626  CALL popinteger(js)
6627  !CALL POPPOINTER8(cptr)
6628  dxc => gridstruct%dxc ! (/unknown_shape_in_divergence_corner/)&
6629 !& )
6630  !CALL POPPOINTER8(cptr)
6631  dyc => gridstruct%dyc ! (/unknown_shape_in_divergence_corner/)&
6632 !& )
6633  CALL popinteger(ie)
6634  CALL popinteger(is)
6635  CALL popinteger(je)
6636  uf_ad = 0.0
6637  vf_ad = 0.0
6638  DO j=je+2,js-1,-1
6639  DO i=ie+2,is-1,-1
6640  temp_ad = gridstruct%rarea_c(i, j)*divg_d_ad(i, j)
6641  vf_ad(i, j-1) = vf_ad(i, j-1) + temp_ad
6642  vf_ad(i, j) = vf_ad(i, j) - temp_ad
6643  uf_ad(i-1, j) = uf_ad(i-1, j) + temp_ad
6644  uf_ad(i, j) = uf_ad(i, j) - temp_ad
6645  divg_d_ad(i, j) = 0.0
6646  END DO
6647  END DO
6648  DO j=je+2,js-2,-1
6649  DO i=ie+2,is-1,-1
6650  v_ad(i, j) = v_ad(i, j) + dxc(i, j)*vf_ad(i, j)
6651  vf_ad(i, j) = 0.0
6652  END DO
6653  END DO
6654  DO j=je+2,js-1,-1
6655  DO i=ie+2,is-2,-1
6656  u_ad(i, j) = u_ad(i, j) + dyc(i, j)*uf_ad(i, j)
6657  uf_ad(i, j) = 0.0
6658  END DO
6659  END DO
6660  ELSE
6661  CALL popinteger(js)
6662  CALL popinteger(npx)
6663  CALL popinteger(npy)
6664  !CALL POPPOINTER8(cptr)
6665  cos_sg => gridstruct%cos_sg ! (/&
6666 !& unknown_shape_in_divergence_corner/))
6667  !CALL POPPOINTER8(cptr)
6668  dxc => gridstruct%dxc ! (/unknown_shape_in_divergence_corner/)&
6669 !& )
6670  CALL popinteger(is2)
6671  !CALL POPPOINTER8(cptr)
6672  sin_sg => gridstruct%sin_sg ! (/&
6673 !& unknown_shape_in_divergence_corner/))
6674  !CALL POPPOINTER8(cptr)
6675  dyc => gridstruct%dyc ! (/unknown_shape_in_divergence_corner/)&
6676 !& )
6677  CALL popinteger(ie)
6678  CALL popinteger(is)
6679  CALL popinteger(ie1)
6680  CALL popinteger(je)
6681  DO j=je+1,js,-1
6682  DO i=ie+1,is,-1
6683  divg_d_ad(i, j) = gridstruct%rarea_c(i, j)*divg_d_ad(i, j)
6684  END DO
6685  END DO
6686  CALL popcontrol(1,branch)
6687  IF (branch .EQ. 0) THEN
6688  vf_ad = 0.0
6689  ELSE
6690  npy = flagstruct%npy
6691  vf_ad = 0.0
6692  vf_ad(1, npy) = vf_ad(1, npy) + divg_d_ad(1, npy)
6693  END IF
6694  CALL popcontrol(1,branch)
6695  IF (branch .EQ. 0) THEN
6696  npx = flagstruct%npx
6697  vf_ad(npx, npy) = vf_ad(npx, npy) + divg_d_ad(npx, npy)
6698  END IF
6699  CALL popcontrol(1,branch)
6700  IF (branch .EQ. 0) vf_ad(npx, 0) = vf_ad(npx, 0) - divg_d_ad(npx, &
6701 & 1)
6702  CALL popcontrol(1,branch)
6703  IF (branch .EQ. 0) vf_ad(1, 0) = vf_ad(1, 0) - divg_d_ad(1, 1)
6704  uf_ad = 0.0
6705  DO j=je+1,js,-1
6706  DO i=ie+1,is,-1
6707  vf_ad(i, j-1) = vf_ad(i, j-1) + divg_d_ad(i, j)
6708  vf_ad(i, j) = vf_ad(i, j) - divg_d_ad(i, j)
6709  uf_ad(i-1, j) = uf_ad(i-1, j) + divg_d_ad(i, j)
6710  uf_ad(i, j) = uf_ad(i, j) - divg_d_ad(i, j)
6711  divg_d_ad(i, j) = 0.0
6712  END DO
6713  END DO
6714  DO j=je+1,js-1,-1
6715  CALL popcontrol(1,branch)
6716  IF (branch .NE. 0) THEN
6717  v_ad(npx, j) = v_ad(npx, j) + dxc(npx, j)*(sin_sg(npx-1, j, 3)&
6718 & +sin_sg(npx, j, 1))*0.5*vf_ad(npx, j)
6719  vf_ad(npx, j) = 0.0
6720  END IF
6721  CALL popcontrol(1,branch)
6722  IF (branch .EQ. 0) THEN
6723  v_ad(1, j) = v_ad(1, j) + dxc(1, j)*(sin_sg(0, j, 3)+sin_sg(1&
6724 & , j, 1))*0.5*vf_ad(1, j)
6725  vf_ad(1, j) = 0.0
6726  END IF
6727  DO i=ie1,is2,-1
6728  temp_ad2 = dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+sin_sg(i, j, 1))*&
6729 & vf_ad(i, j)
6730  temp_ad3 = -((cos_sg(i-1, j, 3)+cos_sg(i, j, 1))*0.25*temp_ad2&
6731 & )
6732  v_ad(i, j) = v_ad(i, j) + temp_ad2
6733  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad3
6734  ua_ad(i, j) = ua_ad(i, j) + temp_ad3
6735  vf_ad(i, j) = 0.0
6736  END DO
6737  END DO
6738  DO j=je+1,js,-1
6739  CALL popcontrol(1,branch)
6740  IF (branch .EQ. 0) THEN
6741  DO i=ie+1,is-1,-1
6742  temp_ad0 = dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i, j, 2))&
6743 & *uf_ad(i, j)
6744  temp_ad1 = -((cos_sg(i, j-1, 4)+cos_sg(i, j, 2))*0.25*&
6745 & temp_ad0)
6746  u_ad(i, j) = u_ad(i, j) + temp_ad0
6747  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad1
6748  va_ad(i, j) = va_ad(i, j) + temp_ad1
6749  uf_ad(i, j) = 0.0
6750  END DO
6751  ELSE
6752  DO i=ie+1,is-1,-1
6753  u_ad(i, j) = u_ad(i, j) + dyc(i, j)*(sin_sg(i, j-1, 4)+&
6754 & sin_sg(i, j, 2))*0.5*uf_ad(i, j)
6755  uf_ad(i, j) = 0.0
6756  END DO
6757  END IF
6758  END DO
6759  END IF
6760  CALL popcontrol(1,branch)
6761  END SUBROUTINE divergence_corner_bwd
6762  SUBROUTINE divergence_corner(u, v, ua, va, divg_d, gridstruct, &
6763 & flagstruct, bd)
6764  IMPLICIT NONE
6765  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6766  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
6767  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
6768  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
6769  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
6770 & divg_d
6771  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6772  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
6773 ! local
6774  REAL :: uf(bd%is-2:bd%ie+2, bd%js-1:bd%je+2)
6775  REAL :: vf(bd%is-1:bd%ie+2, bd%js-2:bd%je+2)
6776  INTEGER :: i, j
6777  INTEGER :: is2, ie1
6778  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
6779  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
6780  INTEGER :: is, ie, js, je
6781  INTEGER :: npx, npy
6782  LOGICAL :: nested
6783  INTRINSIC max
6784  INTRINSIC min
6785  is = bd%is
6786  ie = bd%ie
6787  js = bd%js
6788  je = bd%je
6789  npx = flagstruct%npx
6790  npy = flagstruct%npy
6791  nested = gridstruct%nested
6792  sin_sg => gridstruct%sin_sg
6793  cos_sg => gridstruct%cos_sg
6794  dxc => gridstruct%dxc
6795  dyc => gridstruct%dyc
6796  IF (nested) THEN
6797  is2 = is
6798  ie1 = ie + 1
6799  ELSE
6800  IF (2 .LT. is) THEN
6801  is2 = is
6802  ELSE
6803  is2 = 2
6804  END IF
6805  IF (npx - 1 .GT. ie + 1) THEN
6806  ie1 = ie + 1
6807  ELSE
6808  ie1 = npx - 1
6809  END IF
6810  END IF
6811  IF (flagstruct%grid_type .EQ. 4) THEN
6812  DO j=js-1,je+2
6813  DO i=is-2,ie+2
6814  uf(i, j) = u(i, j)*dyc(i, j)
6815  END DO
6816  END DO
6817  DO j=js-2,je+2
6818  DO i=is-1,ie+2
6819  vf(i, j) = v(i, j)*dxc(i, j)
6820  END DO
6821  END DO
6822  DO j=js-1,je+2
6823  DO i=is-1,ie+2
6824  divg_d(i, j) = gridstruct%rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(&
6825 & uf(i-1, j)-uf(i, j)))
6826  END DO
6827  END DO
6828  ELSE
6829 ! 9---4---8
6830 ! | |
6831 ! 1 5 3
6832 ! | |
6833 ! 6---2---7
6834  DO j=js,je+1
6835  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
6836  DO i=is-1,ie+1
6837  uf(i, j) = u(i, j)*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i&
6838 & , j, 2))
6839  END DO
6840  ELSE
6841  DO i=is-1,ie+1
6842  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-&
6843 & 1, 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
6844 & sin_sg(i, j, 2))
6845  END DO
6846  END IF
6847  END DO
6848  DO j=js-1,je+1
6849  DO i=is2,ie1
6850  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
6851 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
6852 & sin_sg(i, j, 1))
6853  END DO
6854  IF (is .EQ. 1) vf(1, j) = v(1, j)*dxc(1, j)*0.5*(sin_sg(0, j, 3)&
6855 & +sin_sg(1, j, 1))
6856  IF (ie + 1 .EQ. npx) vf(npx, j) = v(npx, j)*dxc(npx, j)*0.5*(&
6857 & sin_sg(npx-1, j, 3)+sin_sg(npx, j, 1))
6858  END DO
6859  DO j=js,je+1
6860  DO i=is,ie+1
6861  divg_d(i, j) = vf(i, j-1) - vf(i, j) + (uf(i-1, j)-uf(i, j))
6862  END DO
6863  END DO
6864 ! Remove the extra term at the corners:
6865  IF (gridstruct%sw_corner) divg_d(1, 1) = divg_d(1, 1) - vf(1, 0)
6866  IF (gridstruct%se_corner) divg_d(npx, 1) = divg_d(npx, 1) - vf(npx&
6867 & , 0)
6868  IF (gridstruct%ne_corner) divg_d(npx, npy) = divg_d(npx, npy) + vf&
6869 & (npx, npy)
6870  IF (gridstruct%nw_corner) divg_d(1, npy) = divg_d(1, npy) + vf(1, &
6871 & npy)
6872  DO j=js,je+1
6873  DO i=is,ie+1
6874  divg_d(i, j) = gridstruct%rarea_c(i, j)*divg_d(i, j)
6875  END DO
6876  END DO
6877  END IF
6878  END SUBROUTINE divergence_corner
6879 ! Differentiation of divergence_corner_nest in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4_f
6880 !b a2b_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_
6881 !pe dyn_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 dy
6882 !n_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_
6883 !mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils
6884 !_mod.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
6885 !_mapz_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_mo
6886 !d.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.p
6887 !pm_limiters 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.map
6888 !1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_m
6889 !od.fv_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
6890 !_d nh_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
6891 ! nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile
6892 !nh_utils_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
6893 !_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_cor
6894 !e_mod.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
6895 !_fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner f
6896 !v_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6897 ! gradient of useful results: u v ua va divg_d
6898 ! with respect to varying inputs: u v ua va
6899  SUBROUTINE divergence_corner_nest_fwd(u, v, ua, va, divg_d, gridstruct&
6900 & , flagstruct, bd)
6901  !USE ISO_C_BINDING
6902  !USE ADMM_TAPENADE_INTERFACE
6903  IMPLICIT NONE
6904 !!$ !Edges
6905 !!$
6906 !!$ !West, East
6907 !!$ do j=jsd+1,jed
6908 !!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j)
6909 !!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j)
6910 !!$ end do
6911 !!$
6912 !!$ !North, South
6913 !!$ do i=isd+1,ied
6914 !!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd)
6915 !!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed)
6916 !!$ end do
6917 !!$
6918 !!$ !Corners (just use next corner value)
6919 !!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1)
6920 !!$ divg_d(isd,jed+1) = divg_d(isd+1,jed)
6921 !!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1)
6922 !!$ divg_d(ied+1,jed+1) = divg_d(ied,jed)
6923  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6924  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
6925  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
6926  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
6927  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
6928  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
6929  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
6930 ! local
6931  REAL :: uf(bd%isd:bd%ied, bd%jsd:bd%jed+1)
6932  REAL :: vf(bd%isd:bd%ied+1, bd%jsd:bd%jed)
6933  INTEGER :: i, j
6934  REAL, DIMENSION(:, :), POINTER :: rarea_c
6935  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
6936  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
6937  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
6938  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
6939  INTEGER :: isd, ied, jsd, jed
6940  INTEGER :: npx, npy
6941  LOGICAL :: nested
6942 
6943  uf = 0.0
6944  vf = 0.0
6945  isd = 0
6946  ied = 0
6947  jsd = 0
6948  jed = 0
6949  npx = 0
6950  npy = 0
6951 
6952  isd = bd%isd
6953  ied = bd%ied
6954  jsd = bd%jsd
6955  jed = bd%jed
6956  rarea_c => gridstruct%rarea_c
6957  sin_sg => gridstruct%sin_sg
6958  cos_sg => gridstruct%cos_sg
6959  dxc => gridstruct%dxc
6960  dyc => gridstruct%dyc
6961  divg_d = 1.e25
6962  IF (flagstruct%grid_type .EQ. 4) THEN
6963  DO j=jsd,jed
6964  DO i=isd,ied
6965  uf(i, j) = u(i, j)*dyc(i, j)
6966  END DO
6967  END DO
6968  DO j=jsd,jed
6969  DO i=isd,ied
6970  vf(i, j) = v(i, j)*dxc(i, j)
6971  END DO
6972  END DO
6973  DO j=jsd+1,jed
6974  DO i=isd+1,ied
6975  divg_d(i, j) = rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(uf(i-1, j)-&
6976 & uf(i, j)))
6977  END DO
6978  END DO
6979  CALL pushinteger(jed)
6980  CALL pushinteger(isd)
6981  !CALL PUSHPOINTER8(C_LOC(dyc))
6982  CALL pushinteger(ied)
6983  CALL pushinteger(jsd)
6984  !CALL PUSHPOINTER8(C_LOC(rarea_c))
6985  !CALL PUSHPOINTER8(C_LOC(dxc))
6986  CALL pushcontrol(1,0)
6987  ELSE
6988  DO j=jsd+1,jed
6989  DO i=isd,ied
6990  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-1&
6991 & , 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
6992 & sin_sg(i, j, 2))
6993  END DO
6994  END DO
6995  DO j=jsd,jed
6996  DO i=isd+1,ied
6997  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
6998 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
6999 & sin_sg(i, j, 1))
7000  END DO
7001  END DO
7002  DO j=jsd+1,jed
7003  DO i=isd+1,ied
7004  divg_d(i, j) = (vf(i, j-1)-vf(i, j)+(uf(i-1, j)-uf(i, j)))*&
7005 & rarea_c(i, j)
7006  END DO
7007  END DO
7008  CALL pushinteger(jed)
7009  CALL pushinteger(isd)
7010  !CALL PUSHPOINTER8(C_LOC(dyc))
7011  !CALL PUSHPOINTER8(C_LOC(sin_sg))
7012  CALL pushinteger(ied)
7013  CALL pushinteger(jsd)
7014  !CALL PUSHPOINTER8(C_LOC(rarea_c))
7015  !CALL PUSHPOINTER8(C_LOC(dxc))
7016  !CALL PUSHPOINTER8(C_LOC(cos_sg))
7017  CALL pushcontrol(1,1)
7018  END IF
7019  END SUBROUTINE divergence_corner_nest_fwd
7020 ! Differentiation of divergence_corner_nest in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4_
7021 !fb a2b_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
7022 !_pe dyn_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 d
7023 !yn_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics
7024 !_mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_util
7025 !s_mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez f
7026 !v_mapz_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_m
7027 !od.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.
7028 !ppm_limiters 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.ma
7029 !p1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_
7030 !mod.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_d
7031 !z_d nh_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_solve
7032 !r nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile
7033 ! nh_utils_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 s
7034 !w_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_co
7035 !re_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2
7036 !d_fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner
7037 !fv_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
7038 ! gradient of useful results: u v ua va divg_d
7039 ! with respect to varying inputs: u v ua va
7040  SUBROUTINE divergence_corner_nest_bwd(u, u_ad, v, v_ad, ua, ua_ad, va&
7041 & , va_ad, divg_d, divg_d_ad, gridstruct, flagstruct, bd)
7042  !USE ISO_C_BINDING
7043  !USE ADMM_TAPENADE_INTERFACE
7044  IMPLICIT NONE
7045 !!$ !Edges
7046 !!$
7047 !!$ !West, East
7048 !!$ do j=jsd+1,jed
7049 !!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j)
7050 !!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j)
7051 !!$ end do
7052 !!$
7053 !!$ !North, South
7054 !!$ do i=isd+1,ied
7055 !!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd)
7056 !!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed)
7057 !!$ end do
7058 !!$
7059 !!$ !Corners (just use next corner value)
7060 !!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1)
7061 !!$ divg_d(isd,jed+1) = divg_d(isd+1,jed)
7062 !!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1)
7063 !!$ divg_d(ied+1,jed+1) = divg_d(ied,jed)
7064  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7065  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
7066  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
7067  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
7068  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
7069  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
7070  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua_ad, va_ad
7071  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d
7072  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1) :: divg_d_ad
7073  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
7074  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
7075  REAL :: uf(bd%isd:bd%ied, bd%jsd:bd%jed+1)
7076  REAL :: uf_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
7077  REAL :: vf(bd%isd:bd%ied+1, bd%jsd:bd%jed)
7078  REAL :: vf_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
7079  INTEGER :: i, j
7080  REAL, DIMENSION(:, :), POINTER :: rarea_c
7081  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
7082  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
7083  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
7084  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
7085  INTEGER :: isd, ied, jsd, jed
7086  INTEGER :: npx, npy
7087  LOGICAL :: nested
7088  REAL :: temp_ad
7089  REAL :: temp_ad0
7090  REAL :: temp_ad1
7091  REAL :: temp_ad2
7092  REAL :: temp_ad3
7093  REAL :: temp_ad4
7094  INTEGER :: branch
7095  !TYPE(C_PTR) :: cptr
7096  !INTEGER :: unknown_shape_in_divergence_corner_nest
7097 
7098  uf = 0.0
7099  vf = 0.0
7100  isd = 0
7101  ied = 0
7102  jsd = 0
7103  jed = 0
7104  npx = 0
7105  npy = 0
7106  branch = 0
7107 
7108  isd = bd%isd
7109  ied = bd%ied
7110  jsd = bd%jsd
7111  jed = bd%jed
7112  rarea_c => gridstruct%rarea_c
7113  sin_sg => gridstruct%sin_sg
7114  cos_sg => gridstruct%cos_sg
7115  dxc => gridstruct%dxc
7116  dyc => gridstruct%dyc
7117  CALL popcontrol(1,branch)
7118  IF (branch .EQ. 0) THEN
7119  !CALL POPPOINTER8(cptr)
7120  dxc => gridstruct%dxc ! (/&
7121 !& unknown_shape_in_divergence_corner_nest/))
7122  !CALL POPPOINTER8(cptr)
7123  rarea_c => gridstruct%rarea_c ! (/&
7124 !& unknown_shape_in_divergence_corner_nest/))
7125  CALL popinteger(jsd)
7126  CALL popinteger(ied)
7127  !CALL POPPOINTER8(cptr)
7128  dyc => gridstruct%dyc ! (/&
7129 !& unknown_shape_in_divergence_corner_nest/))
7130  CALL popinteger(isd)
7131  CALL popinteger(jed)
7132  uf_ad = 0.0
7133  vf_ad = 0.0
7134  DO j=jed,jsd+1,-1
7135  DO i=ied,isd+1,-1
7136  temp_ad = rarea_c(i, j)*divg_d_ad(i, j)
7137  vf_ad(i, j-1) = vf_ad(i, j-1) + temp_ad
7138  vf_ad(i, j) = vf_ad(i, j) - temp_ad
7139  uf_ad(i-1, j) = uf_ad(i-1, j) + temp_ad
7140  uf_ad(i, j) = uf_ad(i, j) - temp_ad
7141  divg_d_ad(i, j) = 0.0
7142  END DO
7143  END DO
7144  DO j=jed,jsd,-1
7145  DO i=ied,isd,-1
7146  v_ad(i, j) = v_ad(i, j) + dxc(i, j)*vf_ad(i, j)
7147  vf_ad(i, j) = 0.0
7148  END DO
7149  END DO
7150  DO j=jed,jsd,-1
7151  DO i=ied,isd,-1
7152  u_ad(i, j) = u_ad(i, j) + dyc(i, j)*uf_ad(i, j)
7153  uf_ad(i, j) = 0.0
7154  END DO
7155  END DO
7156  ELSE
7157  !CALL POPPOINTER8(cptr)
7158  cos_sg => gridstruct%cos_sg ! (/&
7159 !& unknown_shape_in_divergence_corner_nest/))
7160  !CALL POPPOINTER8(cptr)
7161  dxc => gridstruct%dxc ! (/&
7162 !& unknown_shape_in_divergence_corner_nest/))
7163  !CALL POPPOINTER8(cptr)
7164  rarea_c => gridstruct%rarea_c ! (/&
7165 !& unknown_shape_in_divergence_corner_nest/))
7166  CALL popinteger(jsd)
7167  CALL popinteger(ied)
7168  !CALL POPPOINTER8(cptr)
7169  sin_sg => gridstruct%sin_sg ! (/&
7170 !& unknown_shape_in_divergence_corner_nest/))
7171  !CALL POPPOINTER8(cptr)
7172  dyc => gridstruct%dyc ! (/&
7173 !& unknown_shape_in_divergence_corner_nest/))
7174  CALL popinteger(isd)
7175  CALL popinteger(jed)
7176  uf_ad = 0.0
7177  vf_ad = 0.0
7178  DO j=jed,jsd+1,-1
7179  DO i=ied,isd+1,-1
7180  temp_ad4 = rarea_c(i, j)*divg_d_ad(i, j)
7181  vf_ad(i, j-1) = vf_ad(i, j-1) + temp_ad4
7182  vf_ad(i, j) = vf_ad(i, j) - temp_ad4
7183  uf_ad(i-1, j) = uf_ad(i-1, j) + temp_ad4
7184  uf_ad(i, j) = uf_ad(i, j) - temp_ad4
7185  divg_d_ad(i, j) = 0.0
7186  END DO
7187  END DO
7188  DO j=jed,jsd,-1
7189  DO i=ied,isd+1,-1
7190  temp_ad2 = dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+sin_sg(i, j, 1))*&
7191 & vf_ad(i, j)
7192  temp_ad3 = -((cos_sg(i-1, j, 3)+cos_sg(i, j, 1))*0.25*temp_ad2&
7193 & )
7194  v_ad(i, j) = v_ad(i, j) + temp_ad2
7195  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad3
7196  ua_ad(i, j) = ua_ad(i, j) + temp_ad3
7197  vf_ad(i, j) = 0.0
7198  END DO
7199  END DO
7200  DO j=jed,jsd+1,-1
7201  DO i=ied,isd,-1
7202  temp_ad0 = dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+sin_sg(i, j, 2))*&
7203 & uf_ad(i, j)
7204  temp_ad1 = -((cos_sg(i, j-1, 4)+cos_sg(i, j, 2))*0.25*temp_ad0&
7205 & )
7206  u_ad(i, j) = u_ad(i, j) + temp_ad0
7207  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad1
7208  va_ad(i, j) = va_ad(i, j) + temp_ad1
7209  uf_ad(i, j) = 0.0
7210  END DO
7211  END DO
7212  END IF
7213  END SUBROUTINE divergence_corner_nest_bwd
7214  SUBROUTINE divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, &
7215 & flagstruct, bd)
7216  IMPLICIT NONE
7217 !!$ !Edges
7218 !!$
7219 !!$ !West, East
7220 !!$ do j=jsd+1,jed
7221 !!$ divg_d(isd ,j) = (vf(isd,j-1) - vf(isd,j) + uf(isd,j) - uf(isd+1,j))*rarea_c(isd,j)
7222 !!$ divg_d(ied+1,j) = (vf(ied+1,j-1) - vf(ied+1,j) + uf(ied-1,j) - uf(ied,j))*rarea_c(ied,j)
7223 !!$ end do
7224 !!$
7225 !!$ !North, South
7226 !!$ do i=isd+1,ied
7227 !!$ divg_d(i,jsd ) = (vf(i,jsd) - vf(i,jsd+1) + uf(i-1,jsd) - uf(i,jsd))*rarea_c(i,jsd)
7228 !!$ divg_d(i,jed+1) = (vf(i,jed-1) - vf(i,jed) + uf(i-1,jed+1) - uf(i,jed+1))*rarea_c(i,jed)
7229 !!$ end do
7230 !!$
7231 !!$ !Corners (just use next corner value)
7232 !!$ divg_d(isd,jsd) = divg_d(isd+1,jsd+1)
7233 !!$ divg_d(isd,jed+1) = divg_d(isd+1,jed)
7234 !!$ divg_d(ied+1,jsd) = divg_d(ied,jsd+1)
7235 !!$ divg_d(ied+1,jed+1) = divg_d(ied,jed)
7236  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7237  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
7238  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
7239  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
7240  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(OUT) :: &
7241 & divg_d
7242  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
7243  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
7244 ! local
7245  REAL :: uf(bd%isd:bd%ied, bd%jsd:bd%jed+1)
7246  REAL :: vf(bd%isd:bd%ied+1, bd%jsd:bd%jed)
7247  INTEGER :: i, j
7248  REAL, DIMENSION(:, :), POINTER :: rarea_c
7249  REAL, DIMENSION(:, :, :), POINTER :: sin_sg, cos_sg
7250  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v
7251  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
7252  REAL, DIMENSION(:, :), POINTER :: dxc, dyc
7253  INTEGER :: isd, ied, jsd, jed
7254  INTEGER :: npx, npy
7255  LOGICAL :: nested
7256  isd = bd%isd
7257  ied = bd%ied
7258  jsd = bd%jsd
7259  jed = bd%jed
7260  npx = flagstruct%npx
7261  npy = flagstruct%npy
7262  nested = gridstruct%nested
7263  rarea_c => gridstruct%rarea_c
7264  sin_sg => gridstruct%sin_sg
7265  cos_sg => gridstruct%cos_sg
7266  cosa_u => gridstruct%cosa_u
7267  cosa_v => gridstruct%cosa_v
7268  sina_u => gridstruct%sina_u
7269  sina_v => gridstruct%sina_v
7270  dxc => gridstruct%dxc
7271  dyc => gridstruct%dyc
7272  divg_d = 1.e25
7273  IF (flagstruct%grid_type .EQ. 4) THEN
7274  DO j=jsd,jed
7275  DO i=isd,ied
7276  uf(i, j) = u(i, j)*dyc(i, j)
7277  END DO
7278  END DO
7279  DO j=jsd,jed
7280  DO i=isd,ied
7281  vf(i, j) = v(i, j)*dxc(i, j)
7282  END DO
7283  END DO
7284  DO j=jsd+1,jed
7285  DO i=isd+1,ied
7286  divg_d(i, j) = rarea_c(i, j)*(vf(i, j-1)-vf(i, j)+(uf(i-1, j)-&
7287 & uf(i, j)))
7288  END DO
7289  END DO
7290  ELSE
7291  DO j=jsd+1,jed
7292  DO i=isd,ied
7293  uf(i, j) = (u(i, j)-0.25*(va(i, j-1)+va(i, j))*(cos_sg(i, j-1&
7294 & , 4)+cos_sg(i, j, 2)))*dyc(i, j)*0.5*(sin_sg(i, j-1, 4)+&
7295 & sin_sg(i, j, 2))
7296  END DO
7297  END DO
7298  DO j=jsd,jed
7299  DO i=isd+1,ied
7300  vf(i, j) = (v(i, j)-0.25*(ua(i-1, j)+ua(i, j))*(cos_sg(i-1, j&
7301 & , 3)+cos_sg(i, j, 1)))*dxc(i, j)*0.5*(sin_sg(i-1, j, 3)+&
7302 & sin_sg(i, j, 1))
7303  END DO
7304  END DO
7305  DO j=jsd+1,jed
7306  DO i=isd+1,ied
7307  divg_d(i, j) = (vf(i, j-1)-vf(i, j)+(uf(i-1, j)-uf(i, j)))*&
7308 & rarea_c(i, j)
7309  END DO
7310  END DO
7311  END IF
7312  END SUBROUTINE divergence_corner_nest
7313  SUBROUTINE smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, &
7314 & gridstruct, ng)
7315  IMPLICIT NONE
7316 ! Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion
7317 !!! work only if (grid_type==4)
7318  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7319  REAL, INTENT(IN) :: dt
7320  INTEGER, INTENT(IN) :: npx, npy, ng
7321  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
7322  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
7323  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
7324  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: smag_c
7325  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
7326 ! local
7327  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
7328  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
7329 ! work array
7330  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
7331  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
7332  INTEGER :: i, j
7333  INTEGER :: is2, ie1
7334  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
7335  INTEGER :: is, ie, js, je
7336  INTEGER :: isd, ied, jsd, jed
7337  INTRINSIC max
7338  INTRINSIC min
7339  INTRINSIC sqrt
7340  is = bd%is
7341  ie = bd%ie
7342  js = bd%js
7343  je = bd%je
7344  isd = bd%isd
7345  ied = bd%ied
7346  jsd = bd%jsd
7347  jed = bd%jed
7348  dxc => gridstruct%dxc
7349  dyc => gridstruct%dyc
7350  dx => gridstruct%dx
7351  dy => gridstruct%dy
7352  rarea => gridstruct%rarea
7353  rarea_c => gridstruct%rarea_c
7354  IF (2 .LT. is) THEN
7355  is2 = is
7356  ELSE
7357  is2 = 2
7358  END IF
7359  IF (npx - 1 .GT. ie + 1) THEN
7360  ie1 = ie + 1
7361  ELSE
7362  ie1 = npx - 1
7363  END IF
7364 ! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s
7365 ! where T = du/dx - dv/dy; S = du/dy + dv/dx
7366 ! Compute tension strain at corners:
7367  DO j=js,je+1
7368  DO i=is-1,ie+1
7369  ut(i, j) = u(i, j)*dyc(i, j)
7370  END DO
7371  END DO
7372  DO j=js-1,je+1
7373  DO i=is,ie+1
7374  vt(i, j) = v(i, j)*dxc(i, j)
7375  END DO
7376  END DO
7377  DO j=js,je+1
7378  DO i=is,ie+1
7379  smag_c(i, j) = rarea_c(i, j)*(vt(i, j-1)-vt(i, j)+(ut(i, j)-ut(i&
7380 & -1, j)))
7381  END DO
7382  END DO
7383 ! Fix the corners?? if grid_type /= 4
7384 ! Compute shear strain:
7385  DO j=jsd,jed+1
7386  DO i=isd,ied
7387  vt(i, j) = u(i, j)*dx(i, j)
7388  END DO
7389  END DO
7390  DO j=jsd,jed
7391  DO i=isd,ied+1
7392  ut(i, j) = v(i, j)*dy(i, j)
7393  END DO
7394  END DO
7395  DO j=jsd,jed
7396  DO i=isd,ied
7397  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i, j)-ut(i+1, j)&
7398 & ))
7399  END DO
7400  END DO
7401  CALL a2b_ord4(wk, sh, gridstruct, npx, npy, is, ie, js, je, ng, &
7402 & .false.)
7403  DO j=js,je+1
7404  DO i=is,ie+1
7405  smag_c(i, j) = dt*sqrt(sh(i, j)**2+smag_c(i, j)**2)
7406  END DO
7407  END DO
7408  END SUBROUTINE smag_corner
7409 ! Differentiation of xtp_u in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_core
7410 !_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_mod.p_grad_c dyn_cor
7411 !e_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.mix_dp dyn_core_mod.g
7412 !eopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamics_m
7413 !od.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_mod.
7414 !c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz_mod.ma
7415 !p_scalar_fb fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.scalar_pr
7416 !ofile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.steepz f
7417 !v_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.d2c_setup
7418 ! fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.compute
7419 !_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solver_c nh
7420 !_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3p0_solver nh_u
7421 !tils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh sw_cor
7422 !e_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_core_mod
7423 !.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mod.compu
7424 !te_divergence_damping_fb sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corners
7425 !tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle_di
7426 !st sw_core_mod.edge_interpolate4)):
7427 ! gradient of useful results: flux u c
7428 ! with respect to varying inputs: flux u c
7429  SUBROUTINE xtp_u_adm(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, &
7430 & u_ad, v, flux, flux_ad, iord, dx, rdx, npx, npy, grid_type, nested)
7431  IMPLICIT NONE
7432  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
7433  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
7434  REAL :: u_ad(isd:ied, jsd:jed+1)
7435  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
7436  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
7437  REAL :: c_ad(is:ie+1, js:je+1)
7438  REAL :: flux(is:ie+1, js:je+1)
7439  REAL :: flux_ad(is:ie+1, js:je+1)
7440  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
7441  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
7442  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
7443  LOGICAL, INTENT(IN) :: nested
7444 ! Local
7445  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
7446  REAL, DIMENSION(is-1:ie+1) :: bl_ad, br_ad, b0_ad
7447  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
7448  REAL :: fx0(is:ie+1)
7449  REAL :: fx0_ad(is:ie+1)
7450  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
7451  REAL :: al_ad(is-1:ie+2), dm_ad(is-2:ie+2)
7452  REAL :: dq(is-3:ie+2)
7453  REAL :: dq_ad(is-3:ie+2)
7454  REAL :: dl, dr, xt, pmp, lac, cfl
7455  REAL :: xt_ad, pmp_ad, lac_ad, cfl_ad
7456  REAL :: pmp_1, lac_1, pmp_2, lac_2
7457  REAL :: pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
7458  REAL :: x0, x1, x0l, x0r
7459  REAL :: x0l_ad, x0r_ad
7460  INTEGER :: i, j
7461  INTEGER :: is3, ie3
7462  INTEGER :: is2, ie2
7463  INTRINSIC max
7464  INTRINSIC min
7465  INTRINSIC abs
7466  INTRINSIC sign
7467  REAL :: min1
7468  REAL :: min1_ad
7469  REAL :: min2
7470  REAL :: min2_ad
7471  REAL :: abs0
7472  REAL :: min3
7473  REAL :: min3_ad
7474  REAL :: min4
7475  REAL :: min4_ad
7476  REAL :: min5
7477  REAL :: min5_ad
7478  REAL :: abs1
7479  REAL :: abs2
7480  REAL :: abs3
7481  REAL :: abs4
7482  REAL :: max1
7483  REAL :: max1_ad
7484  REAL :: min6
7485  REAL :: min6_ad
7486  REAL :: abs5
7487  REAL :: abs6
7488  REAL :: temp_ad
7489  REAL :: temp_ad0
7490  REAL :: temp_ad1
7491  REAL :: temp_ad2
7492  REAL :: temp_ad3
7493  REAL :: temp_ad4
7494  REAL :: x2_ad
7495  REAL :: y1_ad
7496  REAL :: x3_ad
7497  REAL :: y2_ad
7498  REAL :: temp_ad5
7499  REAL :: temp_ad6
7500  REAL :: temp_ad7
7501  REAL :: temp_ad8
7502  REAL :: x4_ad
7503  REAL :: y3_ad
7504  REAL :: z1_ad
7505  REAL :: x5_ad
7506  REAL :: y4_ad
7507  REAL :: x6_ad
7508  REAL :: y5_ad
7509  REAL :: x7_ad
7510  REAL :: y12_ad
7511  REAL :: y6_ad
7512  REAL :: x8_ad
7513  REAL :: y13_ad
7514  REAL :: y7_ad
7515  REAL :: x9_ad
7516  REAL :: y14_ad
7517  REAL :: y8_ad
7518  REAL :: x10_ad
7519  REAL :: y15_ad
7520  REAL :: y9_ad
7521  REAL :: temp_ad9
7522  REAL :: temp_ad10
7523  REAL :: temp_ad11
7524  REAL :: temp_ad12
7525  REAL :: x11_ad
7526  REAL :: y16_ad
7527  REAL :: y10_ad
7528  REAL :: x12_ad
7529  REAL :: y17_ad
7530  REAL :: y11_ad
7531  REAL :: temp
7532  REAL :: temp_ad13
7533  REAL :: temp_ad14
7534  INTEGER :: branch
7535  REAL :: x12
7536  REAL :: x11
7537  REAL :: x10
7538  REAL :: x9
7539  REAL :: x8
7540  REAL :: x7
7541  REAL :: x6
7542  REAL :: x5
7543  REAL :: x4
7544  REAL :: x3
7545  REAL :: x2
7546  REAL :: y17
7547  REAL :: y16
7548  REAL :: y15
7549  REAL :: y14
7550  REAL :: y13
7551  REAL :: y12
7552  REAL :: y11
7553  REAL :: y10
7554  REAL :: z1
7555  REAL :: y9
7556  REAL :: y8
7557  REAL :: y7
7558  REAL :: y6
7559  REAL :: y5
7560  REAL :: y4
7561  REAL :: y3
7562  REAL :: y2
7563  REAL :: y1
7564  IF (nested .OR. grid_type .GT. 3) THEN
7565  CALL pushcontrol1b(0)
7566  is3 = is - 1
7567  ie3 = ie + 1
7568  ELSE
7569  IF (3 .LT. is - 1) THEN
7570  is3 = is - 1
7571  ELSE
7572  is3 = 3
7573  END IF
7574  IF (npx - 3 .GT. ie + 1) THEN
7575  CALL pushcontrol1b(1)
7576  ie3 = ie + 1
7577  ELSE
7578  CALL pushcontrol1b(1)
7579  ie3 = npx - 3
7580  END IF
7581  END IF
7582  IF (iord .EQ. 1) THEN
7583  DO j=js,je+1
7584  DO i=is,ie+1
7585  IF (c(i, j) .GT. 0.) THEN
7586  CALL pushcontrol1b(1)
7587  ELSE
7588  CALL pushcontrol1b(0)
7589  END IF
7590  END DO
7591  END DO
7592  DO j=je+1,js,-1
7593  DO i=ie+1,is,-1
7594  CALL popcontrol1b(branch)
7595  IF (branch .EQ. 0) THEN
7596  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
7597  flux_ad(i, j) = 0.0
7598  ELSE
7599  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
7600  flux_ad(i, j) = 0.0
7601  END IF
7602  END DO
7603  END DO
7604  ELSE IF (iord .LT. 8) THEN
7605 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
7606  DO j=js,je+1
7607  DO i=is3,ie3+1
7608  al(i) = p1*(u(i-1, j)+u(i, j)) + p2*(u(i-2, j)+u(i+1, j))
7609  END DO
7610  DO i=is3,ie3
7611  CALL pushrealarray_adm(bl(i))
7612  bl(i) = al(i) - u(i, j)
7613  CALL pushrealarray_adm(br(i))
7614  br(i) = al(i+1) - u(i, j)
7615  END DO
7616  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
7617  IF (is .EQ. 1) THEN
7618  xt = c3*u(1, j) + c2*u(2, j) + c1*u(3, j)
7619  CALL pushrealarray_adm(br(1))
7620  br(1) = xt - u(1, j)
7621  CALL pushrealarray_adm(bl(2))
7622  bl(2) = xt - u(2, j)
7623  CALL pushrealarray_adm(br(2))
7624  br(2) = al(3) - u(2, j)
7625  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
7626 ! out
7627  CALL pushrealarray_adm(bl(0))
7628  bl(0) = 0.
7629 ! edge
7630  CALL pushrealarray_adm(br(0))
7631  br(0) = 0.
7632 ! edge
7633  CALL pushrealarray_adm(bl(1))
7634  bl(1) = 0.
7635 ! in
7636  CALL pushrealarray_adm(br(1))
7637  br(1) = 0.
7638  CALL pushcontrol2b(0)
7639  ELSE
7640  CALL pushrealarray_adm(bl(0))
7641  bl(0) = c1*u(-2, j) + c2*u(-1, j) + c3*u(0, j) - u(0, j)
7642  xt = 0.5*(((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
7643 & j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j))*u(1, j)&
7644 & -dx(1, j)*u(2, j))/(dx(1, j)+dx(2, j)))
7645  CALL pushrealarray_adm(br(0))
7646  br(0) = xt - u(0, j)
7647  CALL pushrealarray_adm(bl(1))
7648  bl(1) = xt - u(1, j)
7649  CALL pushcontrol2b(1)
7650  END IF
7651  ELSE
7652  CALL pushcontrol2b(2)
7653  END IF
7654 ! call pert_ppm(1, u(2,j), bl(2), br(2), -1)
7655  IF (ie + 1 .EQ. npx) THEN
7656  CALL pushrealarray_adm(bl(npx-2))
7657  bl(npx-2) = al(npx-2) - u(npx-2, j)
7658  xt = c1*u(npx-3, j) + c2*u(npx-2, j) + c3*u(npx-1, j)
7659  CALL pushrealarray_adm(br(npx-2))
7660  br(npx-2) = xt - u(npx-2, j)
7661  CALL pushrealarray_adm(bl(npx-1))
7662  bl(npx-1) = xt - u(npx-1, j)
7663  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
7664 ! in
7665  CALL pushrealarray_adm(bl(npx-1))
7666  bl(npx-1) = 0.
7667 ! edge
7668  CALL pushrealarray_adm(br(npx-1))
7669  br(npx-1) = 0.
7670 ! edge
7671  CALL pushrealarray_adm(bl(npx))
7672  bl(npx) = 0.
7673 ! out
7674  CALL pushrealarray_adm(br(npx))
7675  br(npx) = 0.
7676  CALL pushcontrol2b(3)
7677  ELSE
7678  xt = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
7679 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))+((2.*&
7680 & dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, j)*u(npx+1, j&
7681 & ))/(dx(npx, j)+dx(npx+1, j)))
7682  CALL pushrealarray_adm(br(npx-1))
7683  br(npx-1) = xt - u(npx-1, j)
7684  CALL pushrealarray_adm(bl(npx))
7685  bl(npx) = xt - u(npx, j)
7686  CALL pushrealarray_adm(br(npx))
7687  br(npx) = c3*u(npx, j) + c2*u(npx+1, j) + c1*u(npx+2, j) -&
7688 & u(npx, j)
7689  CALL pushcontrol2b(2)
7690  END IF
7691  ELSE
7692  CALL pushcontrol2b(1)
7693  END IF
7694  ELSE
7695  CALL pushcontrol2b(0)
7696  END IF
7697 ! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
7698  DO i=is-1,ie+1
7699  CALL pushrealarray_adm(b0(i))
7700  b0(i) = bl(i) + br(i)
7701  END DO
7702  IF (iord .EQ. 2) THEN
7703 ! Perfectly linear
7704 !DEC$ VECTOR ALWAYS
7705  DO i=is,ie+1
7706  IF (c(i, j) .GT. 0.) THEN
7707  CALL pushcontrol1b(1)
7708  ELSE
7709  CALL pushcontrol1b(0)
7710  END IF
7711  END DO
7712  CALL pushcontrol2b(3)
7713  ELSE IF (iord .EQ. 3) THEN
7714  DO i=is-1,ie+1
7715  IF (b0(i) .GE. 0.) THEN
7716  x0 = b0(i)
7717  ELSE
7718  x0 = -b0(i)
7719  END IF
7720  IF (bl(i) - br(i) .GE. 0.) THEN
7721  x1 = bl(i) - br(i)
7722  ELSE
7723  x1 = -(bl(i)-br(i))
7724  END IF
7725  smt5(i) = x0 .LT. x1
7726  smt6(i) = 3.*x0 .LT. x1
7727  END DO
7728  DO i=is,ie+1
7729  CALL pushrealarray_adm(fx0(i))
7730  fx0(i) = 0.
7731  END DO
7732  DO i=is,ie+1
7733  IF (c(i, j) .GT. 0.) THEN
7734  cfl = c(i, j)*rdx(i-1, j)
7735  IF (smt6(i-1) .OR. smt5(i)) THEN
7736  CALL pushrealarray_adm(fx0(i))
7737  fx0(i) = br(i-1) - cfl*b0(i-1)
7738  CALL pushcontrol2b(0)
7739  ELSE IF (smt5(i-1)) THEN
7740  IF (bl(i-1) .GE. 0.) THEN
7741  x2 = bl(i-1)
7742  CALL pushcontrol1b(0)
7743  ELSE
7744  x2 = -bl(i-1)
7745  CALL pushcontrol1b(1)
7746  END IF
7747  IF (br(i-1) .GE. 0.) THEN
7748  y1 = br(i-1)
7749  CALL pushcontrol1b(0)
7750  ELSE
7751  y1 = -br(i-1)
7752  CALL pushcontrol1b(1)
7753  END IF
7754  IF (x2 .GT. y1) THEN
7755  CALL pushrealarray_adm(min1)
7756  min1 = y1
7757  CALL pushcontrol1b(0)
7758  ELSE
7759  CALL pushrealarray_adm(min1)
7760  min1 = x2
7761  CALL pushcontrol1b(1)
7762  END IF
7763  CALL pushrealarray_adm(fx0(i))
7764  fx0(i) = sign(min1, br(i-1))
7765  CALL pushcontrol2b(1)
7766  ELSE
7767  CALL pushcontrol2b(2)
7768  END IF
7769  CALL pushcontrol1b(1)
7770  ELSE
7771  cfl = c(i, j)*rdx(i, j)
7772  IF (smt6(i) .OR. smt5(i-1)) THEN
7773  CALL pushrealarray_adm(fx0(i))
7774  fx0(i) = bl(i) + cfl*b0(i)
7775  CALL pushcontrol2b(0)
7776  ELSE IF (smt5(i)) THEN
7777  IF (bl(i) .GE. 0.) THEN
7778  x3 = bl(i)
7779  CALL pushcontrol1b(0)
7780  ELSE
7781  x3 = -bl(i)
7782  CALL pushcontrol1b(1)
7783  END IF
7784  IF (br(i) .GE. 0.) THEN
7785  y2 = br(i)
7786  CALL pushcontrol1b(0)
7787  ELSE
7788  y2 = -br(i)
7789  CALL pushcontrol1b(1)
7790  END IF
7791  IF (x3 .GT. y2) THEN
7792  CALL pushrealarray_adm(min2)
7793  min2 = y2
7794  CALL pushcontrol1b(0)
7795  ELSE
7796  CALL pushrealarray_adm(min2)
7797  min2 = x3
7798  CALL pushcontrol1b(1)
7799  END IF
7800  CALL pushrealarray_adm(fx0(i))
7801  fx0(i) = sign(min2, bl(i))
7802  CALL pushcontrol2b(1)
7803  ELSE
7804  CALL pushcontrol2b(2)
7805  END IF
7806  CALL pushcontrol1b(0)
7807  END IF
7808  END DO
7809  CALL pushcontrol2b(2)
7810  ELSE IF (iord .EQ. 4) THEN
7811 ! more damp than ord5 but less damp than ord6
7812  DO i=is-1,ie+1
7813  IF (b0(i) .GE. 0.) THEN
7814  x0 = b0(i)
7815  ELSE
7816  x0 = -b0(i)
7817  END IF
7818  IF (bl(i) - br(i) .GE. 0.) THEN
7819  x1 = bl(i) - br(i)
7820  ELSE
7821  x1 = -(bl(i)-br(i))
7822  END IF
7823  smt5(i) = x0 .LT. x1
7824 ! if smt6 =.T. --> smt5=.T.
7825  smt6(i) = 3.*x0 .LT. x1
7826  END DO
7827  DO i=is,ie+1
7828  IF (c(i, j) .GT. 0.) THEN
7829  IF (smt6(i-1) .OR. smt5(i)) THEN
7830  CALL pushcontrol2b(3)
7831  ELSE
7832  CALL pushcontrol2b(2)
7833  END IF
7834  ELSE IF (smt6(i) .OR. smt5(i-1)) THEN
7835  CALL pushcontrol2b(1)
7836  ELSE
7837  CALL pushcontrol2b(0)
7838  END IF
7839  END DO
7840  CALL pushcontrol2b(1)
7841  ELSE
7842 ! iord=5,6,7
7843  IF (iord .EQ. 5) THEN
7844  CALL pushcontrol1b(1)
7845  DO i=is-1,ie+1
7846  smt5(i) = bl(i)*br(i) .LT. 0.
7847  END DO
7848  ELSE
7849  DO i=is-1,ie+1
7850  IF (3.*b0(i) .GE. 0.) THEN
7851  abs0 = 3.*b0(i)
7852  ELSE
7853  abs0 = -(3.*b0(i))
7854  END IF
7855  IF (bl(i) - br(i) .GE. 0.) THEN
7856  abs4 = bl(i) - br(i)
7857  ELSE
7858  abs4 = -(bl(i)-br(i))
7859  END IF
7860  smt5(i) = abs0 .LT. abs4
7861  END DO
7862  CALL pushcontrol1b(0)
7863  END IF
7864 !DEC$ VECTOR ALWAYS
7865  DO i=is,ie+1
7866  IF (c(i, j) .GT. 0.) THEN
7867  cfl = c(i, j)*rdx(i-1, j)
7868  CALL pushrealarray_adm(fx0(i))
7869  fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1))
7870  CALL pushcontrol1b(0)
7871  ELSE
7872  cfl = c(i, j)*rdx(i, j)
7873  CALL pushrealarray_adm(fx0(i))
7874  fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i))
7875  CALL pushcontrol1b(1)
7876  END IF
7877  IF (smt5(i-1) .OR. smt5(i)) THEN
7878  CALL pushcontrol1b(1)
7879  ELSE
7880  CALL pushcontrol1b(0)
7881  END IF
7882  END DO
7883  CALL pushcontrol2b(0)
7884  END IF
7885  END DO
7886  al_ad = 0.0
7887  bl_ad = 0.0
7888  br_ad = 0.0
7889  b0_ad = 0.0
7890  fx0_ad = 0.0
7891  DO j=je+1,js,-1
7892  CALL popcontrol2b(branch)
7893  IF (branch .LT. 2) THEN
7894  IF (branch .EQ. 0) THEN
7895  DO i=ie+1,is,-1
7896  CALL popcontrol1b(branch)
7897  IF (branch .NE. 0) fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
7898  CALL popcontrol1b(branch)
7899  IF (branch .EQ. 0) THEN
7900  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
7901  flux_ad(i, j) = 0.0
7902  cfl = c(i, j)*rdx(i-1, j)
7903  CALL poprealarray_adm(fx0(i))
7904  temp_ad7 = (1.-cfl)*fx0_ad(i)
7905  cfl_ad = -(b0(i-1)*temp_ad7) - (br(i-1)-cfl*b0(i-1))*&
7906 & fx0_ad(i)
7907  br_ad(i-1) = br_ad(i-1) + temp_ad7
7908  b0_ad(i-1) = b0_ad(i-1) - cfl*temp_ad7
7909  fx0_ad(i) = 0.0
7910  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
7911  ELSE
7912  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
7913  flux_ad(i, j) = 0.0
7914  cfl = c(i, j)*rdx(i, j)
7915  CALL poprealarray_adm(fx0(i))
7916  temp_ad8 = (cfl+1.)*fx0_ad(i)
7917  cfl_ad = b0(i)*temp_ad8 + (bl(i)+cfl*b0(i))*fx0_ad(i)
7918  bl_ad(i) = bl_ad(i) + temp_ad8
7919  b0_ad(i) = b0_ad(i) + cfl*temp_ad8
7920  fx0_ad(i) = 0.0
7921  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
7922  END IF
7923  END DO
7924  CALL popcontrol1b(branch)
7925  IF (branch .EQ. 0) i = is - 2
7926  ELSE
7927  DO i=ie+1,is,-1
7928  CALL popcontrol2b(branch)
7929  IF (branch .LT. 2) THEN
7930  IF (branch .EQ. 0) THEN
7931  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
7932  flux_ad(i, j) = 0.0
7933  ELSE
7934  cfl = c(i, j)*rdx(i, j)
7935  temp_ad6 = (cfl+1.)*flux_ad(i, j)
7936  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
7937  cfl_ad = b0(i)*temp_ad6 + (bl(i)+cfl*b0(i))*flux_ad(i&
7938 & , j)
7939  bl_ad(i) = bl_ad(i) + temp_ad6
7940  b0_ad(i) = b0_ad(i) + cfl*temp_ad6
7941  flux_ad(i, j) = 0.0
7942  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
7943  END IF
7944  ELSE IF (branch .EQ. 2) THEN
7945  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
7946  flux_ad(i, j) = 0.0
7947  ELSE
7948  cfl = c(i, j)*rdx(i-1, j)
7949  temp_ad5 = (1.-cfl)*flux_ad(i, j)
7950  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
7951  cfl_ad = -(b0(i-1)*temp_ad5) - (br(i-1)-cfl*b0(i-1))*&
7952 & flux_ad(i, j)
7953  br_ad(i-1) = br_ad(i-1) + temp_ad5
7954  b0_ad(i-1) = b0_ad(i-1) - cfl*temp_ad5
7955  flux_ad(i, j) = 0.0
7956  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
7957  END IF
7958  END DO
7959  i = is - 2
7960  END IF
7961  ELSE IF (branch .EQ. 2) THEN
7962  DO i=ie+1,is,-1
7963  CALL popcontrol1b(branch)
7964  IF (branch .EQ. 0) THEN
7965  cfl = c(i, j)*rdx(i, j)
7966  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
7967  cfl_ad = fx0(i)*flux_ad(i, j)
7968  fx0_ad(i) = fx0_ad(i) + (cfl+1.)*flux_ad(i, j)
7969  flux_ad(i, j) = 0.0
7970  CALL popcontrol2b(branch)
7971  IF (branch .EQ. 0) THEN
7972  CALL poprealarray_adm(fx0(i))
7973  bl_ad(i) = bl_ad(i) + fx0_ad(i)
7974  cfl_ad = cfl_ad + b0(i)*fx0_ad(i)
7975  b0_ad(i) = b0_ad(i) + cfl*fx0_ad(i)
7976  fx0_ad(i) = 0.0
7977  ELSE IF (branch .EQ. 1) THEN
7978  CALL poprealarray_adm(fx0(i))
7979  min2_ad = sign(1.d0, min2*bl(i))*fx0_ad(i)
7980  fx0_ad(i) = 0.0
7981  CALL popcontrol1b(branch)
7982  IF (branch .EQ. 0) THEN
7983  CALL poprealarray_adm(min2)
7984  y2_ad = min2_ad
7985  x3_ad = 0.0
7986  ELSE
7987  CALL poprealarray_adm(min2)
7988  x3_ad = min2_ad
7989  y2_ad = 0.0
7990  END IF
7991  CALL popcontrol1b(branch)
7992  IF (branch .EQ. 0) THEN
7993  br_ad(i) = br_ad(i) + y2_ad
7994  ELSE
7995  br_ad(i) = br_ad(i) - y2_ad
7996  END IF
7997  CALL popcontrol1b(branch)
7998  IF (branch .EQ. 0) THEN
7999  bl_ad(i) = bl_ad(i) + x3_ad
8000  ELSE
8001  bl_ad(i) = bl_ad(i) - x3_ad
8002  END IF
8003  END IF
8004  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
8005  ELSE
8006  cfl = c(i, j)*rdx(i-1, j)
8007  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
8008  cfl_ad = -(fx0(i)*flux_ad(i, j))
8009  fx0_ad(i) = fx0_ad(i) + (1.-cfl)*flux_ad(i, j)
8010  flux_ad(i, j) = 0.0
8011  CALL popcontrol2b(branch)
8012  IF (branch .EQ. 0) THEN
8013  CALL poprealarray_adm(fx0(i))
8014  br_ad(i-1) = br_ad(i-1) + fx0_ad(i)
8015  cfl_ad = cfl_ad - b0(i-1)*fx0_ad(i)
8016  b0_ad(i-1) = b0_ad(i-1) - cfl*fx0_ad(i)
8017  fx0_ad(i) = 0.0
8018  ELSE IF (branch .EQ. 1) THEN
8019  CALL poprealarray_adm(fx0(i))
8020  min1_ad = sign(1.d0, min1*br(i-1))*fx0_ad(i)
8021  fx0_ad(i) = 0.0
8022  CALL popcontrol1b(branch)
8023  IF (branch .EQ. 0) THEN
8024  CALL poprealarray_adm(min1)
8025  y1_ad = min1_ad
8026  x2_ad = 0.0
8027  ELSE
8028  CALL poprealarray_adm(min1)
8029  x2_ad = min1_ad
8030  y1_ad = 0.0
8031  END IF
8032  CALL popcontrol1b(branch)
8033  IF (branch .EQ. 0) THEN
8034  br_ad(i-1) = br_ad(i-1) + y1_ad
8035  ELSE
8036  br_ad(i-1) = br_ad(i-1) - y1_ad
8037  END IF
8038  CALL popcontrol1b(branch)
8039  IF (branch .EQ. 0) THEN
8040  bl_ad(i-1) = bl_ad(i-1) + x2_ad
8041  ELSE
8042  bl_ad(i-1) = bl_ad(i-1) - x2_ad
8043  END IF
8044  END IF
8045  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
8046  END IF
8047  END DO
8048  DO i=ie+1,is,-1
8049  CALL poprealarray_adm(fx0(i))
8050  fx0_ad(i) = 0.0
8051  END DO
8052  i = is - 2
8053  ELSE
8054  DO i=ie+1,is,-1
8055  CALL popcontrol1b(branch)
8056  IF (branch .EQ. 0) THEN
8057  cfl = c(i, j)*rdx(i, j)
8058  temp_ad4 = (cfl+1.)*flux_ad(i, j)
8059  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
8060  cfl_ad = b0(i)*temp_ad4 + (bl(i)+cfl*b0(i))*flux_ad(i, j)
8061  bl_ad(i) = bl_ad(i) + temp_ad4
8062  b0_ad(i) = b0_ad(i) + cfl*temp_ad4
8063  flux_ad(i, j) = 0.0
8064  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
8065  ELSE
8066  cfl = c(i, j)*rdx(i-1, j)
8067  temp_ad3 = (1.-cfl)*flux_ad(i, j)
8068  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
8069  cfl_ad = -(b0(i-1)*temp_ad3) - (br(i-1)-cfl*b0(i-1))*&
8070 & flux_ad(i, j)
8071  br_ad(i-1) = br_ad(i-1) + temp_ad3
8072  b0_ad(i-1) = b0_ad(i-1) - cfl*temp_ad3
8073  flux_ad(i, j) = 0.0
8074  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
8075  END IF
8076  END DO
8077  END IF
8078  DO i=ie+1,is-1,-1
8079  CALL poprealarray_adm(b0(i))
8080  bl_ad(i) = bl_ad(i) + b0_ad(i)
8081  br_ad(i) = br_ad(i) + b0_ad(i)
8082  b0_ad(i) = 0.0
8083  END DO
8084  CALL popcontrol2b(branch)
8085  IF (branch .LT. 2) THEN
8086  IF (branch .EQ. 0) GOTO 100
8087  ELSE
8088  IF (branch .EQ. 2) THEN
8089  CALL poprealarray_adm(br(npx))
8090  u_ad(npx, j) = u_ad(npx, j) + (c3-1.0)*br_ad(npx)
8091  u_ad(npx+1, j) = u_ad(npx+1, j) + c2*br_ad(npx)
8092  u_ad(npx+2, j) = u_ad(npx+2, j) + c1*br_ad(npx)
8093  br_ad(npx) = 0.0
8094  CALL poprealarray_adm(bl(npx))
8095  xt_ad = br_ad(npx-1) + bl_ad(npx)
8096  u_ad(npx, j) = u_ad(npx, j) - bl_ad(npx)
8097  bl_ad(npx) = 0.0
8098  CALL poprealarray_adm(br(npx-1))
8099  temp_ad1 = 0.5*xt_ad/(dx(npx-1, j)+dx(npx-2, j))
8100  u_ad(npx-1, j) = u_ad(npx-1, j) + (dx(npx-1, j)*2.+dx(npx-2&
8101 & , j))*temp_ad1 - br_ad(npx-1)
8102  br_ad(npx-1) = 0.0
8103  temp_ad2 = 0.5*xt_ad/(dx(npx, j)+dx(npx+1, j))
8104  u_ad(npx-2, j) = u_ad(npx-2, j) - dx(npx-1, j)*temp_ad1
8105  u_ad(npx, j) = u_ad(npx, j) + (dx(npx, j)*2.+dx(npx+1, j))*&
8106 & temp_ad2
8107  u_ad(npx+1, j) = u_ad(npx+1, j) - dx(npx, j)*temp_ad2
8108  ELSE
8109  CALL poprealarray_adm(br(npx))
8110  br_ad(npx) = 0.0
8111  CALL poprealarray_adm(bl(npx))
8112  bl_ad(npx) = 0.0
8113  CALL poprealarray_adm(br(npx-1))
8114  br_ad(npx-1) = 0.0
8115  CALL poprealarray_adm(bl(npx-1))
8116  bl_ad(npx-1) = 0.0
8117  END IF
8118  CALL poprealarray_adm(bl(npx-1))
8119  xt_ad = br_ad(npx-2) + bl_ad(npx-1)
8120  u_ad(npx-1, j) = u_ad(npx-1, j) - bl_ad(npx-1)
8121  bl_ad(npx-1) = 0.0
8122  CALL poprealarray_adm(br(npx-2))
8123  u_ad(npx-2, j) = u_ad(npx-2, j) - br_ad(npx-2)
8124  br_ad(npx-2) = 0.0
8125  u_ad(npx-3, j) = u_ad(npx-3, j) + c1*xt_ad
8126  u_ad(npx-2, j) = u_ad(npx-2, j) + c2*xt_ad
8127  u_ad(npx-1, j) = u_ad(npx-1, j) + c3*xt_ad
8128  CALL poprealarray_adm(bl(npx-2))
8129  al_ad(npx-2) = al_ad(npx-2) + bl_ad(npx-2)
8130  u_ad(npx-2, j) = u_ad(npx-2, j) - bl_ad(npx-2)
8131  bl_ad(npx-2) = 0.0
8132  END IF
8133  CALL popcontrol2b(branch)
8134  IF (branch .EQ. 0) THEN
8135  CALL poprealarray_adm(br(1))
8136  br_ad(1) = 0.0
8137  CALL poprealarray_adm(bl(1))
8138  bl_ad(1) = 0.0
8139  CALL poprealarray_adm(br(0))
8140  br_ad(0) = 0.0
8141  CALL poprealarray_adm(bl(0))
8142  bl_ad(0) = 0.0
8143  ELSE IF (branch .EQ. 1) THEN
8144  CALL poprealarray_adm(bl(1))
8145  xt_ad = br_ad(0) + bl_ad(1)
8146  u_ad(1, j) = u_ad(1, j) - bl_ad(1)
8147  bl_ad(1) = 0.0
8148  CALL poprealarray_adm(br(0))
8149  temp_ad = 0.5*xt_ad/(dx(0, j)+dx(-1, j))
8150  u_ad(0, j) = u_ad(0, j) + (dx(0, j)*2.+dx(-1, j))*temp_ad - &
8151 & br_ad(0)
8152  br_ad(0) = 0.0
8153  temp_ad0 = 0.5*xt_ad/(dx(1, j)+dx(2, j))
8154  u_ad(-1, j) = u_ad(-1, j) - dx(0, j)*temp_ad
8155  u_ad(1, j) = u_ad(1, j) + (dx(1, j)*2.+dx(2, j))*temp_ad0
8156  u_ad(2, j) = u_ad(2, j) - dx(1, j)*temp_ad0
8157  CALL poprealarray_adm(bl(0))
8158  u_ad(-2, j) = u_ad(-2, j) + c1*bl_ad(0)
8159  u_ad(-1, j) = u_ad(-1, j) + c2*bl_ad(0)
8160  u_ad(0, j) = u_ad(0, j) + (c3-1.0)*bl_ad(0)
8161  bl_ad(0) = 0.0
8162  ELSE
8163  GOTO 100
8164  END IF
8165  CALL poprealarray_adm(br(2))
8166  al_ad(3) = al_ad(3) + br_ad(2)
8167  u_ad(2, j) = u_ad(2, j) - bl_ad(2) - br_ad(2)
8168  br_ad(2) = 0.0
8169  CALL poprealarray_adm(bl(2))
8170  xt_ad = br_ad(1) + bl_ad(2)
8171  bl_ad(2) = 0.0
8172  CALL poprealarray_adm(br(1))
8173  u_ad(1, j) = u_ad(1, j) + c3*xt_ad - br_ad(1)
8174  br_ad(1) = 0.0
8175  u_ad(2, j) = u_ad(2, j) + c2*xt_ad
8176  u_ad(3, j) = u_ad(3, j) + c1*xt_ad
8177  100 DO i=ie3,is3,-1
8178  CALL poprealarray_adm(br(i))
8179  al_ad(i+1) = al_ad(i+1) + br_ad(i)
8180  u_ad(i, j) = u_ad(i, j) - bl_ad(i) - br_ad(i)
8181  br_ad(i) = 0.0
8182  CALL poprealarray_adm(bl(i))
8183  al_ad(i) = al_ad(i) + bl_ad(i)
8184  bl_ad(i) = 0.0
8185  END DO
8186  DO i=ie3+1,is3,-1
8187  u_ad(i-1, j) = u_ad(i-1, j) + p1*al_ad(i)
8188  u_ad(i, j) = u_ad(i, j) + p1*al_ad(i)
8189  u_ad(i-2, j) = u_ad(i-2, j) + p2*al_ad(i)
8190  u_ad(i+1, j) = u_ad(i+1, j) + p2*al_ad(i)
8191  al_ad(i) = 0.0
8192  END DO
8193  END DO
8194  ELSE
8195 ! iord = 8, 9, 10, 11
8196  DO j=js,je+1
8197  DO i=is-2,ie+2
8198  CALL pushrealarray_adm(xt)
8199  xt = 0.25*(u(i+1, j)-u(i-1, j))
8200  IF (xt .GE. 0.) THEN
8201  x4 = xt
8202  CALL pushcontrol1b(0)
8203  ELSE
8204  x4 = -xt
8205  CALL pushcontrol1b(1)
8206  END IF
8207  IF (u(i-1, j) .LT. u(i, j)) THEN
8208  IF (u(i, j) .LT. u(i+1, j)) THEN
8209  max1 = u(i+1, j)
8210  CALL pushcontrol2b(0)
8211  ELSE
8212  max1 = u(i, j)
8213  CALL pushcontrol2b(1)
8214  END IF
8215  ELSE IF (u(i-1, j) .LT. u(i+1, j)) THEN
8216  max1 = u(i+1, j)
8217  CALL pushcontrol2b(2)
8218  ELSE
8219  max1 = u(i-1, j)
8220  CALL pushcontrol2b(3)
8221  END IF
8222  y3 = max1 - u(i, j)
8223  IF (u(i-1, j) .GT. u(i, j)) THEN
8224  IF (u(i, j) .GT. u(i+1, j)) THEN
8225  min6 = u(i+1, j)
8226  CALL pushcontrol2b(0)
8227  ELSE
8228  min6 = u(i, j)
8229  CALL pushcontrol2b(1)
8230  END IF
8231  ELSE IF (u(i-1, j) .GT. u(i+1, j)) THEN
8232  min6 = u(i+1, j)
8233  CALL pushcontrol2b(2)
8234  ELSE
8235  min6 = u(i-1, j)
8236  CALL pushcontrol2b(3)
8237  END IF
8238  z1 = u(i, j) - min6
8239  IF (x4 .GT. y3) THEN
8240  IF (y3 .GT. z1) THEN
8241  CALL pushrealarray_adm(min3)
8242  min3 = z1
8243  CALL pushcontrol2b(0)
8244  ELSE
8245  CALL pushrealarray_adm(min3)
8246  min3 = y3
8247  CALL pushcontrol2b(1)
8248  END IF
8249  ELSE IF (x4 .GT. z1) THEN
8250  CALL pushrealarray_adm(min3)
8251  min3 = z1
8252  CALL pushcontrol2b(2)
8253  ELSE
8254  CALL pushrealarray_adm(min3)
8255  min3 = x4
8256  CALL pushcontrol2b(3)
8257  END IF
8258  dm(i) = sign(min3, xt)
8259  END DO
8260  DO i=is-3,ie+2
8261  dq(i) = u(i+1, j) - u(i, j)
8262  END DO
8263  IF (grid_type .LT. 3) THEN
8264  DO i=is3,ie3+1
8265  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
8266  END DO
8267 ! Perturbation form:
8268  IF (iord .EQ. 8) THEN
8269  DO i=is3,ie3
8270  CALL pushrealarray_adm(xt)
8271  xt = 2.*dm(i)
8272  IF (xt .GE. 0.) THEN
8273  x5 = xt
8274  CALL pushcontrol1b(0)
8275  ELSE
8276  x5 = -xt
8277  CALL pushcontrol1b(1)
8278  END IF
8279  IF (al(i) - u(i, j) .GE. 0.) THEN
8280  y4 = al(i) - u(i, j)
8281  CALL pushcontrol1b(0)
8282  ELSE
8283  y4 = -(al(i)-u(i, j))
8284  CALL pushcontrol1b(1)
8285  END IF
8286  IF (x5 .GT. y4) THEN
8287  CALL pushrealarray_adm(min4)
8288  min4 = y4
8289  CALL pushcontrol1b(0)
8290  ELSE
8291  CALL pushrealarray_adm(min4)
8292  min4 = x5
8293  CALL pushcontrol1b(1)
8294  END IF
8295  CALL pushrealarray_adm(bl(i))
8296  bl(i) = -sign(min4, xt)
8297  IF (xt .GE. 0.) THEN
8298  x6 = xt
8299  CALL pushcontrol1b(0)
8300  ELSE
8301  x6 = -xt
8302  CALL pushcontrol1b(1)
8303  END IF
8304  IF (al(i+1) - u(i, j) .GE. 0.) THEN
8305  y5 = al(i+1) - u(i, j)
8306  CALL pushcontrol1b(0)
8307  ELSE
8308  y5 = -(al(i+1)-u(i, j))
8309  CALL pushcontrol1b(1)
8310  END IF
8311  IF (x6 .GT. y5) THEN
8312  CALL pushrealarray_adm(min5)
8313  min5 = y5
8314  CALL pushcontrol1b(0)
8315  ELSE
8316  CALL pushrealarray_adm(min5)
8317  min5 = x6
8318  CALL pushcontrol1b(1)
8319  END IF
8320  CALL pushrealarray_adm(br(i))
8321  br(i) = sign(min5, xt)
8322  END DO
8323  CALL pushcontrol2b(0)
8324  ELSE IF (iord .EQ. 9) THEN
8325  DO i=is3,ie3
8326  pmp_1 = -(2.*dq(i))
8327  lac_1 = pmp_1 + 1.5*dq(i+1)
8328  IF (0. .LT. pmp_1) THEN
8329  IF (pmp_1 .LT. lac_1) THEN
8330  x7 = lac_1
8331  CALL pushcontrol2b(0)
8332  ELSE
8333  x7 = pmp_1
8334  CALL pushcontrol2b(1)
8335  END IF
8336  ELSE IF (0. .LT. lac_1) THEN
8337  x7 = lac_1
8338  CALL pushcontrol2b(2)
8339  ELSE
8340  CALL pushcontrol2b(3)
8341  x7 = 0.
8342  END IF
8343  IF (0. .GT. pmp_1) THEN
8344  IF (pmp_1 .GT. lac_1) THEN
8345  y12 = lac_1
8346  CALL pushcontrol2b(0)
8347  ELSE
8348  y12 = pmp_1
8349  CALL pushcontrol2b(1)
8350  END IF
8351  ELSE IF (0. .GT. lac_1) THEN
8352  y12 = lac_1
8353  CALL pushcontrol2b(2)
8354  ELSE
8355  y12 = 0.
8356  CALL pushcontrol2b(3)
8357  END IF
8358  IF (al(i) - u(i, j) .LT. y12) THEN
8359  y6 = y12
8360  CALL pushcontrol1b(0)
8361  ELSE
8362  y6 = al(i) - u(i, j)
8363  CALL pushcontrol1b(1)
8364  END IF
8365  IF (x7 .GT. y6) THEN
8366  CALL pushrealarray_adm(bl(i))
8367  bl(i) = y6
8368  CALL pushcontrol1b(0)
8369  ELSE
8370  CALL pushrealarray_adm(bl(i))
8371  bl(i) = x7
8372  CALL pushcontrol1b(1)
8373  END IF
8374  pmp_2 = 2.*dq(i-1)
8375  lac_2 = pmp_2 - 1.5*dq(i-2)
8376  IF (0. .LT. pmp_2) THEN
8377  IF (pmp_2 .LT. lac_2) THEN
8378  x8 = lac_2
8379  CALL pushcontrol2b(0)
8380  ELSE
8381  x8 = pmp_2
8382  CALL pushcontrol2b(1)
8383  END IF
8384  ELSE IF (0. .LT. lac_2) THEN
8385  x8 = lac_2
8386  CALL pushcontrol2b(2)
8387  ELSE
8388  CALL pushcontrol2b(3)
8389  x8 = 0.
8390  END IF
8391  IF (0. .GT. pmp_2) THEN
8392  IF (pmp_2 .GT. lac_2) THEN
8393  y13 = lac_2
8394  CALL pushcontrol2b(0)
8395  ELSE
8396  y13 = pmp_2
8397  CALL pushcontrol2b(1)
8398  END IF
8399  ELSE IF (0. .GT. lac_2) THEN
8400  y13 = lac_2
8401  CALL pushcontrol2b(2)
8402  ELSE
8403  y13 = 0.
8404  CALL pushcontrol2b(3)
8405  END IF
8406  IF (al(i+1) - u(i, j) .LT. y13) THEN
8407  y7 = y13
8408  CALL pushcontrol1b(0)
8409  ELSE
8410  y7 = al(i+1) - u(i, j)
8411  CALL pushcontrol1b(1)
8412  END IF
8413  IF (x8 .GT. y7) THEN
8414  CALL pushrealarray_adm(br(i))
8415  br(i) = y7
8416  CALL pushcontrol1b(0)
8417  ELSE
8418  CALL pushrealarray_adm(br(i))
8419  br(i) = x8
8420  CALL pushcontrol1b(1)
8421  END IF
8422  END DO
8423  CALL pushcontrol2b(1)
8424  ELSE IF (iord .EQ. 10) THEN
8425  DO i=is3,ie3
8426  CALL pushrealarray_adm(bl(i))
8427  bl(i) = al(i) - u(i, j)
8428  CALL pushrealarray_adm(br(i))
8429  br(i) = al(i+1) - u(i, j)
8430  IF (dm(i) .GE. 0.) THEN
8431  abs1 = dm(i)
8432  ELSE
8433  abs1 = -dm(i)
8434  END IF
8435 ! if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then
8436  IF (abs1 .LT. near_zero) THEN
8437  IF (dm(i-1) .GE. 0.) THEN
8438  abs2 = dm(i-1)
8439  ELSE
8440  abs2 = -dm(i-1)
8441  END IF
8442  IF (dm(i+1) .GE. 0.) THEN
8443  abs5 = dm(i+1)
8444  ELSE
8445  abs5 = -dm(i+1)
8446  END IF
8447  IF (abs2 + abs5 .LT. near_zero) THEN
8448 ! 2-delta-x structure detected within 3 cells
8449  bl(i) = 0.
8450  br(i) = 0.
8451  CALL pushcontrol3b(4)
8452  ELSE
8453  CALL pushcontrol3b(3)
8454  END IF
8455  ELSE
8456  IF (3.*(bl(i)+br(i)) .GE. 0.) THEN
8457  abs3 = 3.*(bl(i)+br(i))
8458  ELSE
8459  abs3 = -(3.*(bl(i)+br(i)))
8460  END IF
8461  IF (bl(i) - br(i) .GE. 0.) THEN
8462  abs6 = bl(i) - br(i)
8463  ELSE
8464  abs6 = -(bl(i)-br(i))
8465  END IF
8466  IF (abs3 .GT. abs6) THEN
8467  pmp_1 = -(2.*dq(i))
8468  lac_1 = pmp_1 + 1.5*dq(i+1)
8469  IF (0. .LT. pmp_1) THEN
8470  IF (pmp_1 .LT. lac_1) THEN
8471  x9 = lac_1
8472  CALL pushcontrol2b(0)
8473  ELSE
8474  x9 = pmp_1
8475  CALL pushcontrol2b(1)
8476  END IF
8477  ELSE IF (0. .LT. lac_1) THEN
8478  x9 = lac_1
8479  CALL pushcontrol2b(2)
8480  ELSE
8481  CALL pushcontrol2b(3)
8482  x9 = 0.
8483  END IF
8484  IF (0. .GT. pmp_1) THEN
8485  IF (pmp_1 .GT. lac_1) THEN
8486  y14 = lac_1
8487  CALL pushcontrol2b(0)
8488  ELSE
8489  y14 = pmp_1
8490  CALL pushcontrol2b(1)
8491  END IF
8492  ELSE IF (0. .GT. lac_1) THEN
8493  y14 = lac_1
8494  CALL pushcontrol2b(2)
8495  ELSE
8496  y14 = 0.
8497  CALL pushcontrol2b(3)
8498  END IF
8499  IF (bl(i) .LT. y14) THEN
8500  y8 = y14
8501  CALL pushcontrol1b(0)
8502  ELSE
8503  y8 = bl(i)
8504  CALL pushcontrol1b(1)
8505  END IF
8506  IF (x9 .GT. y8) THEN
8507  bl(i) = y8
8508  CALL pushcontrol1b(0)
8509  ELSE
8510  bl(i) = x9
8511  CALL pushcontrol1b(1)
8512  END IF
8513  pmp_2 = 2.*dq(i-1)
8514  lac_2 = pmp_2 - 1.5*dq(i-2)
8515  IF (0. .LT. pmp_2) THEN
8516  IF (pmp_2 .LT. lac_2) THEN
8517  x10 = lac_2
8518  CALL pushcontrol2b(0)
8519  ELSE
8520  x10 = pmp_2
8521  CALL pushcontrol2b(1)
8522  END IF
8523  ELSE IF (0. .LT. lac_2) THEN
8524  x10 = lac_2
8525  CALL pushcontrol2b(2)
8526  ELSE
8527  CALL pushcontrol2b(3)
8528  x10 = 0.
8529  END IF
8530  IF (0. .GT. pmp_2) THEN
8531  IF (pmp_2 .GT. lac_2) THEN
8532  y15 = lac_2
8533  CALL pushcontrol2b(0)
8534  ELSE
8535  y15 = pmp_2
8536  CALL pushcontrol2b(1)
8537  END IF
8538  ELSE IF (0. .GT. lac_2) THEN
8539  y15 = lac_2
8540  CALL pushcontrol2b(2)
8541  ELSE
8542  y15 = 0.
8543  CALL pushcontrol2b(3)
8544  END IF
8545  IF (br(i) .LT. y15) THEN
8546  y9 = y15
8547  CALL pushcontrol1b(0)
8548  ELSE
8549  y9 = br(i)
8550  CALL pushcontrol1b(1)
8551  END IF
8552  IF (x10 .GT. y9) THEN
8553  br(i) = y9
8554  CALL pushcontrol3b(1)
8555  ELSE
8556  br(i) = x10
8557  CALL pushcontrol3b(2)
8558  END IF
8559  ELSE
8560  CALL pushcontrol3b(0)
8561  END IF
8562  END IF
8563  END DO
8564  CALL pushcontrol2b(2)
8565  ELSE
8566 ! un-limited: 11
8567  DO i=is3,ie3
8568  CALL pushrealarray_adm(bl(i))
8569  bl(i) = al(i) - u(i, j)
8570  CALL pushrealarray_adm(br(i))
8571  br(i) = al(i+1) - u(i, j)
8572  END DO
8573  CALL pushcontrol2b(3)
8574  END IF
8575 !--------------
8576 ! fix the edges
8577 !--------------
8578 !!! TO DO: separate versions for nested and for cubed-sphere
8579  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
8580  CALL pushrealarray_adm(br(2))
8581  br(2) = al(3) - u(2, j)
8582  CALL pushrealarray_adm(xt)
8583  xt = s15*u(1, j) + s11*u(2, j) - s14*dm(2)
8584  CALL pushrealarray_adm(bl(2))
8585  bl(2) = xt - u(2, j)
8586  CALL pushrealarray_adm(br(1))
8587  br(1) = xt - u(1, j)
8588  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
8589 ! out
8590  CALL pushrealarray_adm(bl(0))
8591  bl(0) = 0.
8592 ! edge
8593  CALL pushrealarray_adm(br(0))
8594  br(0) = 0.
8595 ! edge
8596  CALL pushrealarray_adm(bl(1))
8597  bl(1) = 0.
8598 ! in
8599  CALL pushrealarray_adm(br(1))
8600  br(1) = 0.
8601  CALL pushcontrol1b(0)
8602  ELSE
8603  CALL pushrealarray_adm(bl(0))
8604  bl(0) = s14*dm(-1) - s11*dq(-1)
8605  x0l = 0.5*((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
8606 & j))/(dx(0, j)+dx(-1, j))
8607  x0r = 0.5*((2.*dx(1, j)+dx(2, j))*u(1, j)-dx(1, j)*u(2, j)&
8608 & )/(dx(1, j)+dx(2, j))
8609  xt = x0l + x0r
8610  CALL pushrealarray_adm(br(0))
8611  br(0) = xt - u(0, j)
8612  CALL pushrealarray_adm(bl(1))
8613  bl(1) = xt - u(1, j)
8614  CALL pushcontrol1b(1)
8615  END IF
8616  CALL pushrealarray_adm(br(2:2), 1)
8617  CALL pushrealarray_adm(bl(2:2), 1)
8618  CALL pert_ppm(1, u(2:2, j), bl(2:2), br(2:2), -1)
8619  CALL pushcontrol1b(0)
8620  ELSE
8621  CALL pushcontrol1b(1)
8622  END IF
8623  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
8624  CALL pushrealarray_adm(bl(npx-2))
8625  bl(npx-2) = al(npx-2) - u(npx-2, j)
8626  CALL pushrealarray_adm(xt)
8627  xt = s15*u(npx-1, j) + s11*u(npx-2, j) + s14*dm(npx-2)
8628  CALL pushrealarray_adm(br(npx-2))
8629  br(npx-2) = xt - u(npx-2, j)
8630  CALL pushrealarray_adm(bl(npx-1))
8631  bl(npx-1) = xt - u(npx-1, j)
8632  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
8633 ! in
8634  CALL pushrealarray_adm(bl(npx-1))
8635  bl(npx-1) = 0.
8636 ! edge
8637  CALL pushrealarray_adm(br(npx-1))
8638  br(npx-1) = 0.
8639 ! edge
8640  CALL pushrealarray_adm(bl(npx))
8641  bl(npx) = 0.
8642 ! out
8643  CALL pushrealarray_adm(br(npx))
8644  br(npx) = 0.
8645  CALL pushcontrol1b(0)
8646  ELSE
8647  CALL pushrealarray_adm(br(npx))
8648  br(npx) = s11*dq(npx) - s14*dm(npx+1)
8649  x0l = 0.5*((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
8650 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))
8651  x0r = 0.5*((2.*dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, &
8652 & j)*u(npx+1, j))/(dx(npx, j)+dx(npx+1, j))
8653  xt = x0l + x0r
8654  CALL pushrealarray_adm(br(npx-1))
8655  br(npx-1) = xt - u(npx-1, j)
8656  CALL pushrealarray_adm(bl(npx))
8657  bl(npx) = xt - u(npx, j)
8658  CALL pushcontrol1b(1)
8659  END IF
8660  CALL pushrealarray_adm(br(npx-2:npx-2), 1)
8661  CALL pushrealarray_adm(bl(npx-2:npx-2), 1)
8662  CALL pert_ppm(1, u(npx-2:npx-2, j), bl(npx-2:npx-2), br(npx-&
8663 & 2:npx-2), -1)
8664  CALL pushcontrol2b(2)
8665  ELSE
8666  CALL pushcontrol2b(1)
8667  END IF
8668  ELSE
8669 ! Other grids:
8670  DO i=is-1,ie+2
8671  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
8672  END DO
8673  DO i=is-1,ie+1
8674  pmp = -(2.*dq(i))
8675  lac = pmp + 1.5*dq(i+1)
8676  IF (0. .LT. pmp) THEN
8677  IF (pmp .LT. lac) THEN
8678  x11 = lac
8679  CALL pushcontrol2b(0)
8680  ELSE
8681  x11 = pmp
8682  CALL pushcontrol2b(1)
8683  END IF
8684  ELSE IF (0. .LT. lac) THEN
8685  x11 = lac
8686  CALL pushcontrol2b(2)
8687  ELSE
8688  CALL pushcontrol2b(3)
8689  x11 = 0.
8690  END IF
8691  IF (0. .GT. pmp) THEN
8692  IF (pmp .GT. lac) THEN
8693  y16 = lac
8694  CALL pushcontrol2b(0)
8695  ELSE
8696  y16 = pmp
8697  CALL pushcontrol2b(1)
8698  END IF
8699  ELSE IF (0. .GT. lac) THEN
8700  y16 = lac
8701  CALL pushcontrol2b(2)
8702  ELSE
8703  y16 = 0.
8704  CALL pushcontrol2b(3)
8705  END IF
8706  IF (al(i) - u(i, j) .LT. y16) THEN
8707  y10 = y16
8708  CALL pushcontrol1b(0)
8709  ELSE
8710  y10 = al(i) - u(i, j)
8711  CALL pushcontrol1b(1)
8712  END IF
8713  IF (x11 .GT. y10) THEN
8714  CALL pushrealarray_adm(bl(i))
8715  bl(i) = y10
8716  CALL pushcontrol1b(0)
8717  ELSE
8718  CALL pushrealarray_adm(bl(i))
8719  bl(i) = x11
8720  CALL pushcontrol1b(1)
8721  END IF
8722  pmp = 2.*dq(i-1)
8723  lac = pmp - 1.5*dq(i-2)
8724  IF (0. .LT. pmp) THEN
8725  IF (pmp .LT. lac) THEN
8726  x12 = lac
8727  CALL pushcontrol2b(0)
8728  ELSE
8729  x12 = pmp
8730  CALL pushcontrol2b(1)
8731  END IF
8732  ELSE IF (0. .LT. lac) THEN
8733  x12 = lac
8734  CALL pushcontrol2b(2)
8735  ELSE
8736  CALL pushcontrol2b(3)
8737  x12 = 0.
8738  END IF
8739  IF (0. .GT. pmp) THEN
8740  IF (pmp .GT. lac) THEN
8741  y17 = lac
8742  CALL pushcontrol2b(0)
8743  ELSE
8744  y17 = pmp
8745  CALL pushcontrol2b(1)
8746  END IF
8747  ELSE IF (0. .GT. lac) THEN
8748  y17 = lac
8749  CALL pushcontrol2b(2)
8750  ELSE
8751  y17 = 0.
8752  CALL pushcontrol2b(3)
8753  END IF
8754  IF (al(i+1) - u(i, j) .LT. y17) THEN
8755  y11 = y17
8756  CALL pushcontrol1b(0)
8757  ELSE
8758  y11 = al(i+1) - u(i, j)
8759  CALL pushcontrol1b(1)
8760  END IF
8761  IF (x12 .GT. y11) THEN
8762  CALL pushrealarray_adm(br(i))
8763  br(i) = y11
8764  CALL pushcontrol1b(0)
8765  ELSE
8766  CALL pushrealarray_adm(br(i))
8767  br(i) = x12
8768  CALL pushcontrol1b(1)
8769  END IF
8770  END DO
8771  CALL pushcontrol2b(0)
8772  END IF
8773  DO i=is,ie+1
8774  IF (c(i, j) .GT. 0.) THEN
8775  CALL pushcontrol1b(1)
8776  ELSE
8777  CALL pushcontrol1b(0)
8778  END IF
8779  END DO
8780  END DO
8781  dm_ad = 0.0
8782  dq_ad = 0.0
8783  al_ad = 0.0
8784  bl_ad = 0.0
8785  br_ad = 0.0
8786  DO j=je+1,js,-1
8787  DO i=ie+1,is,-1
8788  CALL popcontrol1b(branch)
8789  IF (branch .EQ. 0) THEN
8790  cfl = c(i, j)*rdx(i, j)
8791  temp_ad14 = (cfl+1.)*flux_ad(i, j)
8792  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
8793  cfl_ad = (bl(i)+br(i))*temp_ad14 + (bl(i)+cfl*(bl(i)+br(i)))&
8794 & *flux_ad(i, j)
8795  bl_ad(i) = bl_ad(i) + (cfl+1.0)*temp_ad14
8796  br_ad(i) = br_ad(i) + cfl*temp_ad14
8797  flux_ad(i, j) = 0.0
8798  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
8799  ELSE
8800  cfl = c(i, j)*rdx(i-1, j)
8801  temp = bl(i-1) + br(i-1)
8802  temp_ad13 = (1.-cfl)*flux_ad(i, j)
8803  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
8804  cfl_ad = -(temp*temp_ad13) - (br(i-1)-cfl*temp)*flux_ad(i, j&
8805 & )
8806  br_ad(i-1) = br_ad(i-1) + (1.0-cfl)*temp_ad13
8807  bl_ad(i-1) = bl_ad(i-1) - cfl*temp_ad13
8808  flux_ad(i, j) = 0.0
8809  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
8810  END IF
8811  END DO
8812  CALL popcontrol2b(branch)
8813  IF (branch .EQ. 0) THEN
8814  DO i=ie+1,is-1,-1
8815  CALL popcontrol1b(branch)
8816  IF (branch .EQ. 0) THEN
8817  CALL poprealarray_adm(br(i))
8818  y11_ad = br_ad(i)
8819  br_ad(i) = 0.0
8820  x12_ad = 0.0
8821  ELSE
8822  CALL poprealarray_adm(br(i))
8823  x12_ad = br_ad(i)
8824  br_ad(i) = 0.0
8825  y11_ad = 0.0
8826  END IF
8827  CALL popcontrol1b(branch)
8828  IF (branch .EQ. 0) THEN
8829  y17_ad = y11_ad
8830  ELSE
8831  al_ad(i+1) = al_ad(i+1) + y11_ad
8832  u_ad(i, j) = u_ad(i, j) - y11_ad
8833  y17_ad = 0.0
8834  END IF
8835  CALL popcontrol2b(branch)
8836  IF (branch .LT. 2) THEN
8837  IF (branch .EQ. 0) THEN
8838  lac_ad = y17_ad
8839  pmp_ad = 0.0
8840  ELSE
8841  pmp_ad = y17_ad
8842  lac_ad = 0.0
8843  END IF
8844  ELSE
8845  IF (branch .EQ. 2) THEN
8846  lac_ad = y17_ad
8847  ELSE
8848  lac_ad = 0.0
8849  END IF
8850  pmp_ad = 0.0
8851  END IF
8852  CALL popcontrol2b(branch)
8853  IF (branch .LT. 2) THEN
8854  IF (branch .EQ. 0) THEN
8855  lac_ad = lac_ad + x12_ad
8856  ELSE
8857  pmp_ad = pmp_ad + x12_ad
8858  END IF
8859  ELSE IF (branch .EQ. 2) THEN
8860  lac_ad = lac_ad + x12_ad
8861  END IF
8862  pmp_ad = pmp_ad + lac_ad
8863  dq_ad(i-2) = dq_ad(i-2) - 1.5*lac_ad
8864  dq_ad(i-1) = dq_ad(i-1) + 2.*pmp_ad
8865  CALL popcontrol1b(branch)
8866  IF (branch .EQ. 0) THEN
8867  CALL poprealarray_adm(bl(i))
8868  y10_ad = bl_ad(i)
8869  bl_ad(i) = 0.0
8870  x11_ad = 0.0
8871  ELSE
8872  CALL poprealarray_adm(bl(i))
8873  x11_ad = bl_ad(i)
8874  bl_ad(i) = 0.0
8875  y10_ad = 0.0
8876  END IF
8877  CALL popcontrol1b(branch)
8878  IF (branch .EQ. 0) THEN
8879  y16_ad = y10_ad
8880  ELSE
8881  al_ad(i) = al_ad(i) + y10_ad
8882  u_ad(i, j) = u_ad(i, j) - y10_ad
8883  y16_ad = 0.0
8884  END IF
8885  CALL popcontrol2b(branch)
8886  IF (branch .LT. 2) THEN
8887  IF (branch .EQ. 0) THEN
8888  lac_ad = y16_ad
8889  pmp_ad = 0.0
8890  ELSE
8891  pmp_ad = y16_ad
8892  lac_ad = 0.0
8893  END IF
8894  ELSE
8895  IF (branch .EQ. 2) THEN
8896  lac_ad = y16_ad
8897  ELSE
8898  lac_ad = 0.0
8899  END IF
8900  pmp_ad = 0.0
8901  END IF
8902  CALL popcontrol2b(branch)
8903  IF (branch .LT. 2) THEN
8904  IF (branch .EQ. 0) THEN
8905  lac_ad = lac_ad + x11_ad
8906  ELSE
8907  pmp_ad = pmp_ad + x11_ad
8908  END IF
8909  ELSE IF (branch .EQ. 2) THEN
8910  lac_ad = lac_ad + x11_ad
8911  END IF
8912  pmp_ad = pmp_ad + lac_ad
8913  dq_ad(i+1) = dq_ad(i+1) + 1.5*lac_ad
8914  dq_ad(i) = dq_ad(i) - 2.*pmp_ad
8915  END DO
8916  DO i=ie+2,is-1,-1
8917  u_ad(i-1, j) = u_ad(i-1, j) + 0.5*al_ad(i)
8918  u_ad(i, j) = u_ad(i, j) + 0.5*al_ad(i)
8919  dm_ad(i-1) = dm_ad(i-1) + r3*al_ad(i)
8920  dm_ad(i) = dm_ad(i) - r3*al_ad(i)
8921  al_ad(i) = 0.0
8922  END DO
8923  ELSE
8924  IF (branch .NE. 1) THEN
8925  CALL poprealarray_adm(bl(npx-2:npx-2), 1)
8926  CALL poprealarray_adm(br(npx-2:npx-2), 1)
8927  CALL pert_ppm_adm(1, u(npx-2:npx-2, j), bl(npx-2:npx-2), &
8928 & bl_ad(npx-2:npx-2), br(npx-2:npx-2), br_ad(npx-2&
8929 & :npx-2), -1)
8930  CALL popcontrol1b(branch)
8931  IF (branch .EQ. 0) THEN
8932  CALL poprealarray_adm(br(npx))
8933  br_ad(npx) = 0.0
8934  CALL poprealarray_adm(bl(npx))
8935  bl_ad(npx) = 0.0
8936  CALL poprealarray_adm(br(npx-1))
8937  br_ad(npx-1) = 0.0
8938  CALL poprealarray_adm(bl(npx-1))
8939  bl_ad(npx-1) = 0.0
8940  ELSE
8941  CALL poprealarray_adm(bl(npx))
8942  xt_ad = br_ad(npx-1) + bl_ad(npx)
8943  u_ad(npx, j) = u_ad(npx, j) - bl_ad(npx)
8944  bl_ad(npx) = 0.0
8945  CALL poprealarray_adm(br(npx-1))
8946  u_ad(npx-1, j) = u_ad(npx-1, j) - br_ad(npx-1)
8947  br_ad(npx-1) = 0.0
8948  x0l_ad = xt_ad
8949  x0r_ad = xt_ad
8950  temp_ad11 = 0.5*x0r_ad/(dx(npx, j)+dx(npx+1, j))
8951  u_ad(npx, j) = u_ad(npx, j) + (dx(npx, j)*2.+dx(npx+1, j))&
8952 & *temp_ad11
8953  u_ad(npx+1, j) = u_ad(npx+1, j) - dx(npx, j)*temp_ad11
8954  temp_ad12 = 0.5*x0l_ad/(dx(npx-1, j)+dx(npx-2, j))
8955  u_ad(npx-1, j) = u_ad(npx-1, j) + (dx(npx-1, j)*2.+dx(npx-&
8956 & 2, j))*temp_ad12
8957  u_ad(npx-2, j) = u_ad(npx-2, j) - dx(npx-1, j)*temp_ad12
8958  CALL poprealarray_adm(br(npx))
8959  dq_ad(npx) = dq_ad(npx) + s11*br_ad(npx)
8960  dm_ad(npx+1) = dm_ad(npx+1) - s14*br_ad(npx)
8961  br_ad(npx) = 0.0
8962  END IF
8963  CALL poprealarray_adm(bl(npx-1))
8964  xt_ad = br_ad(npx-2) + bl_ad(npx-1)
8965  u_ad(npx-1, j) = u_ad(npx-1, j) - bl_ad(npx-1)
8966  bl_ad(npx-1) = 0.0
8967  CALL poprealarray_adm(br(npx-2))
8968  u_ad(npx-2, j) = u_ad(npx-2, j) - br_ad(npx-2)
8969  br_ad(npx-2) = 0.0
8970  CALL poprealarray_adm(xt)
8971  u_ad(npx-1, j) = u_ad(npx-1, j) + s15*xt_ad
8972  u_ad(npx-2, j) = u_ad(npx-2, j) + s11*xt_ad - bl_ad(npx-2)
8973  dm_ad(npx-2) = dm_ad(npx-2) + s14*xt_ad
8974  CALL poprealarray_adm(bl(npx-2))
8975  al_ad(npx-2) = al_ad(npx-2) + bl_ad(npx-2)
8976  bl_ad(npx-2) = 0.0
8977  END IF
8978  CALL popcontrol1b(branch)
8979  IF (branch .EQ. 0) THEN
8980  CALL poprealarray_adm(bl(2:2), 1)
8981  CALL poprealarray_adm(br(2:2), 1)
8982  CALL pert_ppm_adm(1, u(2:2, j), bl(2:2), bl_ad(2:2), br(2:2)&
8983 & , br_ad(2:2), -1)
8984  CALL popcontrol1b(branch)
8985  IF (branch .EQ. 0) THEN
8986  CALL poprealarray_adm(br(1))
8987  br_ad(1) = 0.0
8988  CALL poprealarray_adm(bl(1))
8989  bl_ad(1) = 0.0
8990  CALL poprealarray_adm(br(0))
8991  br_ad(0) = 0.0
8992  CALL poprealarray_adm(bl(0))
8993  bl_ad(0) = 0.0
8994  ELSE
8995  CALL poprealarray_adm(bl(1))
8996  xt_ad = br_ad(0) + bl_ad(1)
8997  u_ad(1, j) = u_ad(1, j) - bl_ad(1)
8998  bl_ad(1) = 0.0
8999  CALL poprealarray_adm(br(0))
9000  u_ad(0, j) = u_ad(0, j) - br_ad(0)
9001  br_ad(0) = 0.0
9002  x0l_ad = xt_ad
9003  x0r_ad = xt_ad
9004  temp_ad9 = 0.5*x0r_ad/(dx(1, j)+dx(2, j))
9005  u_ad(1, j) = u_ad(1, j) + (dx(1, j)*2.+dx(2, j))*temp_ad9
9006  u_ad(2, j) = u_ad(2, j) - dx(1, j)*temp_ad9
9007  temp_ad10 = 0.5*x0l_ad/(dx(0, j)+dx(-1, j))
9008  u_ad(0, j) = u_ad(0, j) + (dx(0, j)*2.+dx(-1, j))*&
9009 & temp_ad10
9010  u_ad(-1, j) = u_ad(-1, j) - dx(0, j)*temp_ad10
9011  CALL poprealarray_adm(bl(0))
9012  dm_ad(-1) = dm_ad(-1) + s14*bl_ad(0)
9013  dq_ad(-1) = dq_ad(-1) - s11*bl_ad(0)
9014  bl_ad(0) = 0.0
9015  END IF
9016  CALL poprealarray_adm(br(1))
9017  xt_ad = bl_ad(2) + br_ad(1)
9018  u_ad(1, j) = u_ad(1, j) - br_ad(1)
9019  br_ad(1) = 0.0
9020  CALL poprealarray_adm(bl(2))
9021  u_ad(2, j) = u_ad(2, j) - bl_ad(2)
9022  bl_ad(2) = 0.0
9023  CALL poprealarray_adm(xt)
9024  u_ad(1, j) = u_ad(1, j) + s15*xt_ad
9025  u_ad(2, j) = u_ad(2, j) + s11*xt_ad - br_ad(2)
9026  dm_ad(2) = dm_ad(2) - s14*xt_ad
9027  CALL poprealarray_adm(br(2))
9028  al_ad(3) = al_ad(3) + br_ad(2)
9029  br_ad(2) = 0.0
9030  END IF
9031  CALL popcontrol2b(branch)
9032  IF (branch .LT. 2) THEN
9033  IF (branch .EQ. 0) THEN
9034  DO i=ie3,is3,-1
9035  CALL poprealarray_adm(br(i))
9036  min5_ad = sign(1.d0, min5*xt)*br_ad(i)
9037  br_ad(i) = 0.0
9038  CALL popcontrol1b(branch)
9039  IF (branch .EQ. 0) THEN
9040  CALL poprealarray_adm(min5)
9041  y5_ad = min5_ad
9042  x6_ad = 0.0
9043  ELSE
9044  CALL poprealarray_adm(min5)
9045  x6_ad = min5_ad
9046  y5_ad = 0.0
9047  END IF
9048  CALL popcontrol1b(branch)
9049  IF (branch .EQ. 0) THEN
9050  al_ad(i+1) = al_ad(i+1) + y5_ad
9051  u_ad(i, j) = u_ad(i, j) - y5_ad
9052  ELSE
9053  u_ad(i, j) = u_ad(i, j) + y5_ad
9054  al_ad(i+1) = al_ad(i+1) - y5_ad
9055  END IF
9056  CALL popcontrol1b(branch)
9057  IF (branch .EQ. 0) THEN
9058  xt_ad = x6_ad
9059  ELSE
9060  xt_ad = -x6_ad
9061  END IF
9062  CALL poprealarray_adm(bl(i))
9063  min4_ad = -(sign(1.d0, min4*xt)*bl_ad(i))
9064  bl_ad(i) = 0.0
9065  CALL popcontrol1b(branch)
9066  IF (branch .EQ. 0) THEN
9067  CALL poprealarray_adm(min4)
9068  y4_ad = min4_ad
9069  x5_ad = 0.0
9070  ELSE
9071  CALL poprealarray_adm(min4)
9072  x5_ad = min4_ad
9073  y4_ad = 0.0
9074  END IF
9075  CALL popcontrol1b(branch)
9076  IF (branch .EQ. 0) THEN
9077  al_ad(i) = al_ad(i) + y4_ad
9078  u_ad(i, j) = u_ad(i, j) - y4_ad
9079  ELSE
9080  u_ad(i, j) = u_ad(i, j) + y4_ad
9081  al_ad(i) = al_ad(i) - y4_ad
9082  END IF
9083  CALL popcontrol1b(branch)
9084  IF (branch .EQ. 0) THEN
9085  xt_ad = xt_ad + x5_ad
9086  ELSE
9087  xt_ad = xt_ad - x5_ad
9088  END IF
9089  CALL poprealarray_adm(xt)
9090  dm_ad(i) = dm_ad(i) + 2.*xt_ad
9091  END DO
9092  ELSE
9093  DO i=ie3,is3,-1
9094  CALL popcontrol1b(branch)
9095  IF (branch .EQ. 0) THEN
9096  CALL poprealarray_adm(br(i))
9097  y7_ad = br_ad(i)
9098  br_ad(i) = 0.0
9099  x8_ad = 0.0
9100  ELSE
9101  CALL poprealarray_adm(br(i))
9102  x8_ad = br_ad(i)
9103  br_ad(i) = 0.0
9104  y7_ad = 0.0
9105  END IF
9106  CALL popcontrol1b(branch)
9107  IF (branch .EQ. 0) THEN
9108  y13_ad = y7_ad
9109  ELSE
9110  al_ad(i+1) = al_ad(i+1) + y7_ad
9111  u_ad(i, j) = u_ad(i, j) - y7_ad
9112  y13_ad = 0.0
9113  END IF
9114  CALL popcontrol2b(branch)
9115  IF (branch .LT. 2) THEN
9116  IF (branch .EQ. 0) THEN
9117  lac_2_ad = y13_ad
9118  pmp_2_ad = 0.0
9119  ELSE
9120  pmp_2_ad = y13_ad
9121  lac_2_ad = 0.0
9122  END IF
9123  ELSE
9124  IF (branch .EQ. 2) THEN
9125  lac_2_ad = y13_ad
9126  ELSE
9127  lac_2_ad = 0.0
9128  END IF
9129  pmp_2_ad = 0.0
9130  END IF
9131  CALL popcontrol2b(branch)
9132  IF (branch .LT. 2) THEN
9133  IF (branch .EQ. 0) THEN
9134  lac_2_ad = lac_2_ad + x8_ad
9135  ELSE
9136  pmp_2_ad = pmp_2_ad + x8_ad
9137  END IF
9138  ELSE IF (branch .EQ. 2) THEN
9139  lac_2_ad = lac_2_ad + x8_ad
9140  END IF
9141  pmp_2_ad = pmp_2_ad + lac_2_ad
9142  dq_ad(i-2) = dq_ad(i-2) - 1.5*lac_2_ad
9143  dq_ad(i-1) = dq_ad(i-1) + 2.*pmp_2_ad
9144  CALL popcontrol1b(branch)
9145  IF (branch .EQ. 0) THEN
9146  CALL poprealarray_adm(bl(i))
9147  y6_ad = bl_ad(i)
9148  bl_ad(i) = 0.0
9149  x7_ad = 0.0
9150  ELSE
9151  CALL poprealarray_adm(bl(i))
9152  x7_ad = bl_ad(i)
9153  bl_ad(i) = 0.0
9154  y6_ad = 0.0
9155  END IF
9156  CALL popcontrol1b(branch)
9157  IF (branch .EQ. 0) THEN
9158  y12_ad = y6_ad
9159  ELSE
9160  al_ad(i) = al_ad(i) + y6_ad
9161  u_ad(i, j) = u_ad(i, j) - y6_ad
9162  y12_ad = 0.0
9163  END IF
9164  CALL popcontrol2b(branch)
9165  IF (branch .LT. 2) THEN
9166  IF (branch .EQ. 0) THEN
9167  lac_1_ad = y12_ad
9168  pmp_1_ad = 0.0
9169  ELSE
9170  pmp_1_ad = y12_ad
9171  lac_1_ad = 0.0
9172  END IF
9173  ELSE
9174  IF (branch .EQ. 2) THEN
9175  lac_1_ad = y12_ad
9176  ELSE
9177  lac_1_ad = 0.0
9178  END IF
9179  pmp_1_ad = 0.0
9180  END IF
9181  CALL popcontrol2b(branch)
9182  IF (branch .LT. 2) THEN
9183  IF (branch .EQ. 0) THEN
9184  lac_1_ad = lac_1_ad + x7_ad
9185  ELSE
9186  pmp_1_ad = pmp_1_ad + x7_ad
9187  END IF
9188  ELSE IF (branch .EQ. 2) THEN
9189  lac_1_ad = lac_1_ad + x7_ad
9190  END IF
9191  pmp_1_ad = pmp_1_ad + lac_1_ad
9192  dq_ad(i+1) = dq_ad(i+1) + 1.5*lac_1_ad
9193  dq_ad(i) = dq_ad(i) - 2.*pmp_1_ad
9194  END DO
9195  END IF
9196  ELSE IF (branch .EQ. 2) THEN
9197  DO i=ie3,is3,-1
9198  CALL popcontrol3b(branch)
9199  IF (branch .LT. 2) THEN
9200  IF (branch .EQ. 0) THEN
9201  GOTO 110
9202  ELSE
9203  y9_ad = br_ad(i)
9204  br_ad(i) = 0.0
9205  x10_ad = 0.0
9206  END IF
9207  ELSE IF (branch .EQ. 2) THEN
9208  x10_ad = br_ad(i)
9209  br_ad(i) = 0.0
9210  y9_ad = 0.0
9211  ELSE
9212  IF (branch .NE. 3) THEN
9213  br_ad(i) = 0.0
9214  bl_ad(i) = 0.0
9215  END IF
9216  GOTO 110
9217  END IF
9218  CALL popcontrol1b(branch)
9219  IF (branch .EQ. 0) THEN
9220  y15_ad = y9_ad
9221  ELSE
9222  br_ad(i) = br_ad(i) + y9_ad
9223  y15_ad = 0.0
9224  END IF
9225  CALL popcontrol2b(branch)
9226  IF (branch .LT. 2) THEN
9227  IF (branch .EQ. 0) THEN
9228  lac_2_ad = y15_ad
9229  pmp_2_ad = 0.0
9230  ELSE
9231  pmp_2_ad = y15_ad
9232  lac_2_ad = 0.0
9233  END IF
9234  ELSE
9235  IF (branch .EQ. 2) THEN
9236  lac_2_ad = y15_ad
9237  ELSE
9238  lac_2_ad = 0.0
9239  END IF
9240  pmp_2_ad = 0.0
9241  END IF
9242  CALL popcontrol2b(branch)
9243  IF (branch .LT. 2) THEN
9244  IF (branch .EQ. 0) THEN
9245  lac_2_ad = lac_2_ad + x10_ad
9246  ELSE
9247  pmp_2_ad = pmp_2_ad + x10_ad
9248  END IF
9249  ELSE IF (branch .EQ. 2) THEN
9250  lac_2_ad = lac_2_ad + x10_ad
9251  END IF
9252  pmp_2_ad = pmp_2_ad + lac_2_ad
9253  dq_ad(i-2) = dq_ad(i-2) - 1.5*lac_2_ad
9254  dq_ad(i-1) = dq_ad(i-1) + 2.*pmp_2_ad
9255  CALL popcontrol1b(branch)
9256  IF (branch .EQ. 0) THEN
9257  y8_ad = bl_ad(i)
9258  bl_ad(i) = 0.0
9259  x9_ad = 0.0
9260  ELSE
9261  x9_ad = bl_ad(i)
9262  bl_ad(i) = 0.0
9263  y8_ad = 0.0
9264  END IF
9265  CALL popcontrol1b(branch)
9266  IF (branch .EQ. 0) THEN
9267  y14_ad = y8_ad
9268  ELSE
9269  bl_ad(i) = bl_ad(i) + y8_ad
9270  y14_ad = 0.0
9271  END IF
9272  CALL popcontrol2b(branch)
9273  IF (branch .LT. 2) THEN
9274  IF (branch .EQ. 0) THEN
9275  lac_1_ad = y14_ad
9276  pmp_1_ad = 0.0
9277  ELSE
9278  pmp_1_ad = y14_ad
9279  lac_1_ad = 0.0
9280  END IF
9281  ELSE
9282  IF (branch .EQ. 2) THEN
9283  lac_1_ad = y14_ad
9284  ELSE
9285  lac_1_ad = 0.0
9286  END IF
9287  pmp_1_ad = 0.0
9288  END IF
9289  CALL popcontrol2b(branch)
9290  IF (branch .LT. 2) THEN
9291  IF (branch .EQ. 0) THEN
9292  lac_1_ad = lac_1_ad + x9_ad
9293  ELSE
9294  pmp_1_ad = pmp_1_ad + x9_ad
9295  END IF
9296  ELSE IF (branch .EQ. 2) THEN
9297  lac_1_ad = lac_1_ad + x9_ad
9298  END IF
9299  pmp_1_ad = pmp_1_ad + lac_1_ad
9300  dq_ad(i+1) = dq_ad(i+1) + 1.5*lac_1_ad
9301  dq_ad(i) = dq_ad(i) - 2.*pmp_1_ad
9302  110 CALL poprealarray_adm(br(i))
9303  al_ad(i+1) = al_ad(i+1) + br_ad(i)
9304  u_ad(i, j) = u_ad(i, j) - bl_ad(i) - br_ad(i)
9305  br_ad(i) = 0.0
9306  CALL poprealarray_adm(bl(i))
9307  al_ad(i) = al_ad(i) + bl_ad(i)
9308  bl_ad(i) = 0.0
9309  END DO
9310  ELSE
9311  DO i=ie3,is3,-1
9312  CALL poprealarray_adm(br(i))
9313  al_ad(i+1) = al_ad(i+1) + br_ad(i)
9314  u_ad(i, j) = u_ad(i, j) - bl_ad(i) - br_ad(i)
9315  br_ad(i) = 0.0
9316  CALL poprealarray_adm(bl(i))
9317  al_ad(i) = al_ad(i) + bl_ad(i)
9318  bl_ad(i) = 0.0
9319  END DO
9320  END IF
9321  DO i=ie3+1,is3,-1
9322  u_ad(i-1, j) = u_ad(i-1, j) + 0.5*al_ad(i)
9323  u_ad(i, j) = u_ad(i, j) + 0.5*al_ad(i)
9324  dm_ad(i-1) = dm_ad(i-1) + r3*al_ad(i)
9325  dm_ad(i) = dm_ad(i) - r3*al_ad(i)
9326  al_ad(i) = 0.0
9327  END DO
9328  END IF
9329  DO i=ie+2,is-3,-1
9330  u_ad(i+1, j) = u_ad(i+1, j) + dq_ad(i)
9331  u_ad(i, j) = u_ad(i, j) - dq_ad(i)
9332  dq_ad(i) = 0.0
9333  END DO
9334  DO i=ie+2,is-2,-1
9335  xt = 0.25*(u(i+1, j)-u(i-1, j))
9336  min3_ad = sign(1.d0, min3*xt)*dm_ad(i)
9337  dm_ad(i) = 0.0
9338  CALL popcontrol2b(branch)
9339  IF (branch .LT. 2) THEN
9340  IF (branch .EQ. 0) THEN
9341  CALL poprealarray_adm(min3)
9342  z1_ad = min3_ad
9343  y3_ad = 0.0
9344  ELSE
9345  CALL poprealarray_adm(min3)
9346  y3_ad = min3_ad
9347  z1_ad = 0.0
9348  END IF
9349  x4_ad = 0.0
9350  ELSE
9351  IF (branch .EQ. 2) THEN
9352  CALL poprealarray_adm(min3)
9353  z1_ad = min3_ad
9354  x4_ad = 0.0
9355  ELSE
9356  CALL poprealarray_adm(min3)
9357  x4_ad = min3_ad
9358  z1_ad = 0.0
9359  END IF
9360  y3_ad = 0.0
9361  END IF
9362  u_ad(i, j) = u_ad(i, j) + z1_ad
9363  min6_ad = -z1_ad
9364  CALL popcontrol2b(branch)
9365  IF (branch .LT. 2) THEN
9366  IF (branch .EQ. 0) THEN
9367  u_ad(i+1, j) = u_ad(i+1, j) + min6_ad
9368  ELSE
9369  u_ad(i, j) = u_ad(i, j) + min6_ad
9370  END IF
9371  ELSE IF (branch .EQ. 2) THEN
9372  u_ad(i+1, j) = u_ad(i+1, j) + min6_ad
9373  ELSE
9374  u_ad(i-1, j) = u_ad(i-1, j) + min6_ad
9375  END IF
9376  max1_ad = y3_ad
9377  u_ad(i, j) = u_ad(i, j) - y3_ad
9378  CALL popcontrol2b(branch)
9379  IF (branch .LT. 2) THEN
9380  IF (branch .EQ. 0) THEN
9381  u_ad(i+1, j) = u_ad(i+1, j) + max1_ad
9382  ELSE
9383  u_ad(i, j) = u_ad(i, j) + max1_ad
9384  END IF
9385  ELSE IF (branch .EQ. 2) THEN
9386  u_ad(i+1, j) = u_ad(i+1, j) + max1_ad
9387  ELSE
9388  u_ad(i-1, j) = u_ad(i-1, j) + max1_ad
9389  END IF
9390  CALL popcontrol1b(branch)
9391  IF (branch .EQ. 0) THEN
9392  xt_ad = x4_ad
9393  ELSE
9394  xt_ad = -x4_ad
9395  END IF
9396  CALL poprealarray_adm(xt)
9397  u_ad(i+1, j) = u_ad(i+1, j) + 0.25*xt_ad
9398  u_ad(i-1, j) = u_ad(i-1, j) - 0.25*xt_ad
9399  END DO
9400  END DO
9401  END IF
9402  CALL popcontrol1b(branch)
9403  END SUBROUTINE xtp_u_adm
9404  SUBROUTINE xtp_u(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, &
9405 & iord, dx, rdx, npx, npy, grid_type, nested)
9406  IMPLICIT NONE
9407  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
9408  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
9409  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
9410  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
9411  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
9412  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
9413  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
9414  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
9415  LOGICAL, INTENT(IN) :: nested
9416 ! Local
9417  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
9418  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
9419  REAL :: fx0(is:ie+1)
9420  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
9421  REAL :: dq(is-3:ie+2)
9422  REAL :: dl, dr, xt, pmp, lac, cfl
9423  REAL :: pmp_1, lac_1, pmp_2, lac_2
9424  REAL :: x0, x1, x0l, x0r
9425  INTEGER :: i, j
9426  INTEGER :: is3, ie3
9427  INTEGER :: is2, ie2
9428  INTRINSIC max
9429  INTRINSIC min
9430  INTRINSIC abs
9431  INTRINSIC sign
9432  REAL :: min1
9433  REAL :: min2
9434  REAL :: abs0
9435  REAL :: min3
9436  REAL :: min4
9437  REAL :: min5
9438  REAL :: abs1
9439  REAL :: abs2
9440  REAL :: abs3
9441  REAL :: abs4
9442  REAL :: max1
9443  REAL :: min6
9444  REAL :: abs5
9445  REAL :: abs6
9446  REAL :: x12
9447  REAL :: x11
9448  REAL :: x10
9449  REAL :: x9
9450  REAL :: x8
9451  REAL :: x7
9452  REAL :: x6
9453  REAL :: x5
9454  REAL :: x4
9455  REAL :: x3
9456  REAL :: x2
9457  REAL :: y17
9458  REAL :: y16
9459  REAL :: y15
9460  REAL :: y14
9461  REAL :: y13
9462  REAL :: y12
9463  REAL :: y11
9464  REAL :: y10
9465  REAL :: z1
9466  REAL :: y9
9467  REAL :: y8
9468  REAL :: y7
9469  REAL :: y6
9470  REAL :: y5
9471  REAL :: y4
9472  REAL :: y3
9473  REAL :: y2
9474  REAL :: y1
9475  IF (nested .OR. grid_type .GT. 3) THEN
9476  is3 = is - 1
9477  ie3 = ie + 1
9478  ELSE
9479  IF (3 .LT. is - 1) THEN
9480  is3 = is - 1
9481  ELSE
9482  is3 = 3
9483  END IF
9484  IF (npx - 3 .GT. ie + 1) THEN
9485  ie3 = ie + 1
9486  ELSE
9487  ie3 = npx - 3
9488  END IF
9489  END IF
9490  IF (iord .EQ. 1) THEN
9491  DO j=js,je+1
9492  DO i=is,ie+1
9493  IF (c(i, j) .GT. 0.) THEN
9494  flux(i, j) = u(i-1, j)
9495  ELSE
9496  flux(i, j) = u(i, j)
9497  END IF
9498  END DO
9499  END DO
9500  ELSE IF (iord .LT. 8) THEN
9501 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
9502  DO j=js,je+1
9503  DO i=is3,ie3+1
9504  al(i) = p1*(u(i-1, j)+u(i, j)) + p2*(u(i-2, j)+u(i+1, j))
9505  END DO
9506  DO i=is3,ie3
9507  bl(i) = al(i) - u(i, j)
9508  br(i) = al(i+1) - u(i, j)
9509  END DO
9510  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
9511  IF (is .EQ. 1) THEN
9512  xt = c3*u(1, j) + c2*u(2, j) + c1*u(3, j)
9513  br(1) = xt - u(1, j)
9514  bl(2) = xt - u(2, j)
9515  br(2) = al(3) - u(2, j)
9516  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
9517 ! out
9518  bl(0) = 0.
9519 ! edge
9520  br(0) = 0.
9521 ! edge
9522  bl(1) = 0.
9523 ! in
9524  br(1) = 0.
9525  ELSE
9526  bl(0) = c1*u(-2, j) + c2*u(-1, j) + c3*u(0, j) - u(0, j)
9527  xt = 0.5*(((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
9528 & j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j))*u(1, j)&
9529 & -dx(1, j)*u(2, j))/(dx(1, j)+dx(2, j)))
9530  br(0) = xt - u(0, j)
9531  bl(1) = xt - u(1, j)
9532  END IF
9533  END IF
9534 ! call pert_ppm(1, u(2,j), bl(2), br(2), -1)
9535  IF (ie + 1 .EQ. npx) THEN
9536  bl(npx-2) = al(npx-2) - u(npx-2, j)
9537  xt = c1*u(npx-3, j) + c2*u(npx-2, j) + c3*u(npx-1, j)
9538  br(npx-2) = xt - u(npx-2, j)
9539  bl(npx-1) = xt - u(npx-1, j)
9540  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
9541 ! in
9542  bl(npx-1) = 0.
9543 ! edge
9544  br(npx-1) = 0.
9545 ! edge
9546  bl(npx) = 0.
9547 ! out
9548  br(npx) = 0.
9549  ELSE
9550  xt = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
9551 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))+((2.*&
9552 & dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, j)*u(npx+1, j&
9553 & ))/(dx(npx, j)+dx(npx+1, j)))
9554  br(npx-1) = xt - u(npx-1, j)
9555  bl(npx) = xt - u(npx, j)
9556  br(npx) = c3*u(npx, j) + c2*u(npx+1, j) + c1*u(npx+2, j) -&
9557 & u(npx, j)
9558  END IF
9559  END IF
9560  END IF
9561 ! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
9562  DO i=is-1,ie+1
9563  b0(i) = bl(i) + br(i)
9564  END DO
9565  IF (iord .EQ. 2) THEN
9566 ! Perfectly linear
9567 !DEC$ VECTOR ALWAYS
9568  DO i=is,ie+1
9569  IF (c(i, j) .GT. 0.) THEN
9570  cfl = c(i, j)*rdx(i-1, j)
9571  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
9572  ELSE
9573  cfl = c(i, j)*rdx(i, j)
9574  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
9575  END IF
9576  END DO
9577  ELSE IF (iord .EQ. 3) THEN
9578  DO i=is-1,ie+1
9579  IF (b0(i) .GE. 0.) THEN
9580  x0 = b0(i)
9581  ELSE
9582  x0 = -b0(i)
9583  END IF
9584  IF (bl(i) - br(i) .GE. 0.) THEN
9585  x1 = bl(i) - br(i)
9586  ELSE
9587  x1 = -(bl(i)-br(i))
9588  END IF
9589  smt5(i) = x0 .LT. x1
9590  smt6(i) = 3.*x0 .LT. x1
9591  END DO
9592  DO i=is,ie+1
9593  fx0(i) = 0.
9594  END DO
9595  DO i=is,ie+1
9596  IF (c(i, j) .GT. 0.) THEN
9597  cfl = c(i, j)*rdx(i-1, j)
9598  IF (smt6(i-1) .OR. smt5(i)) THEN
9599  fx0(i) = br(i-1) - cfl*b0(i-1)
9600  ELSE IF (smt5(i-1)) THEN
9601  IF (bl(i-1) .GE. 0.) THEN
9602  x2 = bl(i-1)
9603  ELSE
9604  x2 = -bl(i-1)
9605  END IF
9606  IF (br(i-1) .GE. 0.) THEN
9607  y1 = br(i-1)
9608  ELSE
9609  y1 = -br(i-1)
9610  END IF
9611  IF (x2 .GT. y1) THEN
9612  min1 = y1
9613  ELSE
9614  min1 = x2
9615  END IF
9616  fx0(i) = sign(min1, br(i-1))
9617  END IF
9618  flux(i, j) = u(i-1, j) + (1.-cfl)*fx0(i)
9619  ELSE
9620  cfl = c(i, j)*rdx(i, j)
9621  IF (smt6(i) .OR. smt5(i-1)) THEN
9622  fx0(i) = bl(i) + cfl*b0(i)
9623  ELSE IF (smt5(i)) THEN
9624  IF (bl(i) .GE. 0.) THEN
9625  x3 = bl(i)
9626  ELSE
9627  x3 = -bl(i)
9628  END IF
9629  IF (br(i) .GE. 0.) THEN
9630  y2 = br(i)
9631  ELSE
9632  y2 = -br(i)
9633  END IF
9634  IF (x3 .GT. y2) THEN
9635  min2 = y2
9636  ELSE
9637  min2 = x3
9638  END IF
9639  fx0(i) = sign(min2, bl(i))
9640  END IF
9641  flux(i, j) = u(i, j) + (1.+cfl)*fx0(i)
9642  END IF
9643  END DO
9644  ELSE IF (iord .EQ. 4) THEN
9645 ! more damp than ord5 but less damp than ord6
9646  DO i=is-1,ie+1
9647  IF (b0(i) .GE. 0.) THEN
9648  x0 = b0(i)
9649  ELSE
9650  x0 = -b0(i)
9651  END IF
9652  IF (bl(i) - br(i) .GE. 0.) THEN
9653  x1 = bl(i) - br(i)
9654  ELSE
9655  x1 = -(bl(i)-br(i))
9656  END IF
9657  smt5(i) = x0 .LT. x1
9658 ! if smt6 =.T. --> smt5=.T.
9659  smt6(i) = 3.*x0 .LT. x1
9660  END DO
9661  DO i=is,ie+1
9662  IF (c(i, j) .GT. 0.) THEN
9663  IF (smt6(i-1) .OR. smt5(i)) THEN
9664  cfl = c(i, j)*rdx(i-1, j)
9665  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
9666  ELSE
9667 ! 1st order ONLY_IF smt6(i-1)=.F. .AND. smt5(i)=.F.
9668  flux(i, j) = u(i-1, j)
9669  END IF
9670  ELSE IF (smt6(i) .OR. smt5(i-1)) THEN
9671  cfl = c(i, j)*rdx(i, j)
9672  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
9673  ELSE
9674  flux(i, j) = u(i, j)
9675  END IF
9676  END DO
9677  ELSE
9678 ! iord=5,6,7
9679  IF (iord .EQ. 5) THEN
9680  DO i=is-1,ie+1
9681  smt5(i) = bl(i)*br(i) .LT. 0.
9682  END DO
9683  ELSE
9684  DO i=is-1,ie+1
9685  IF (3.*b0(i) .GE. 0.) THEN
9686  abs0 = 3.*b0(i)
9687  ELSE
9688  abs0 = -(3.*b0(i))
9689  END IF
9690  IF (bl(i) - br(i) .GE. 0.) THEN
9691  abs4 = bl(i) - br(i)
9692  ELSE
9693  abs4 = -(bl(i)-br(i))
9694  END IF
9695  smt5(i) = abs0 .LT. abs4
9696  END DO
9697  END IF
9698 !DEC$ VECTOR ALWAYS
9699  DO i=is,ie+1
9700  IF (c(i, j) .GT. 0.) THEN
9701  cfl = c(i, j)*rdx(i-1, j)
9702  fx0(i) = (1.-cfl)*(br(i-1)-cfl*b0(i-1))
9703  flux(i, j) = u(i-1, j)
9704  ELSE
9705  cfl = c(i, j)*rdx(i, j)
9706  fx0(i) = (1.+cfl)*(bl(i)+cfl*b0(i))
9707  flux(i, j) = u(i, j)
9708  END IF
9709  IF (smt5(i-1) .OR. smt5(i)) flux(i, j) = flux(i, j) + fx0(i)
9710  END DO
9711  END IF
9712  END DO
9713  ELSE
9714 ! iord = 8, 9, 10, 11
9715  DO j=js,je+1
9716  DO i=is-2,ie+2
9717  xt = 0.25*(u(i+1, j)-u(i-1, j))
9718  IF (xt .GE. 0.) THEN
9719  x4 = xt
9720  ELSE
9721  x4 = -xt
9722  END IF
9723  IF (u(i-1, j) .LT. u(i, j)) THEN
9724  IF (u(i, j) .LT. u(i+1, j)) THEN
9725  max1 = u(i+1, j)
9726  ELSE
9727  max1 = u(i, j)
9728  END IF
9729  ELSE IF (u(i-1, j) .LT. u(i+1, j)) THEN
9730  max1 = u(i+1, j)
9731  ELSE
9732  max1 = u(i-1, j)
9733  END IF
9734  y3 = max1 - u(i, j)
9735  IF (u(i-1, j) .GT. u(i, j)) THEN
9736  IF (u(i, j) .GT. u(i+1, j)) THEN
9737  min6 = u(i+1, j)
9738  ELSE
9739  min6 = u(i, j)
9740  END IF
9741  ELSE IF (u(i-1, j) .GT. u(i+1, j)) THEN
9742  min6 = u(i+1, j)
9743  ELSE
9744  min6 = u(i-1, j)
9745  END IF
9746  z1 = u(i, j) - min6
9747  IF (x4 .GT. y3) THEN
9748  IF (y3 .GT. z1) THEN
9749  min3 = z1
9750  ELSE
9751  min3 = y3
9752  END IF
9753  ELSE IF (x4 .GT. z1) THEN
9754  min3 = z1
9755  ELSE
9756  min3 = x4
9757  END IF
9758  dm(i) = sign(min3, xt)
9759  END DO
9760  DO i=is-3,ie+2
9761  dq(i) = u(i+1, j) - u(i, j)
9762  END DO
9763  IF (grid_type .LT. 3) THEN
9764  DO i=is3,ie3+1
9765  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
9766  END DO
9767 ! Perturbation form:
9768  IF (iord .EQ. 8) THEN
9769  DO i=is3,ie3
9770  xt = 2.*dm(i)
9771  IF (xt .GE. 0.) THEN
9772  x5 = xt
9773  ELSE
9774  x5 = -xt
9775  END IF
9776  IF (al(i) - u(i, j) .GE. 0.) THEN
9777  y4 = al(i) - u(i, j)
9778  ELSE
9779  y4 = -(al(i)-u(i, j))
9780  END IF
9781  IF (x5 .GT. y4) THEN
9782  min4 = y4
9783  ELSE
9784  min4 = x5
9785  END IF
9786  bl(i) = -sign(min4, xt)
9787  IF (xt .GE. 0.) THEN
9788  x6 = xt
9789  ELSE
9790  x6 = -xt
9791  END IF
9792  IF (al(i+1) - u(i, j) .GE. 0.) THEN
9793  y5 = al(i+1) - u(i, j)
9794  ELSE
9795  y5 = -(al(i+1)-u(i, j))
9796  END IF
9797  IF (x6 .GT. y5) THEN
9798  min5 = y5
9799  ELSE
9800  min5 = x6
9801  END IF
9802  br(i) = sign(min5, xt)
9803  END DO
9804  ELSE IF (iord .EQ. 9) THEN
9805  DO i=is3,ie3
9806  pmp_1 = -(2.*dq(i))
9807  lac_1 = pmp_1 + 1.5*dq(i+1)
9808  IF (0. .LT. pmp_1) THEN
9809  IF (pmp_1 .LT. lac_1) THEN
9810  x7 = lac_1
9811  ELSE
9812  x7 = pmp_1
9813  END IF
9814  ELSE IF (0. .LT. lac_1) THEN
9815  x7 = lac_1
9816  ELSE
9817  x7 = 0.
9818  END IF
9819  IF (0. .GT. pmp_1) THEN
9820  IF (pmp_1 .GT. lac_1) THEN
9821  y12 = lac_1
9822  ELSE
9823  y12 = pmp_1
9824  END IF
9825  ELSE IF (0. .GT. lac_1) THEN
9826  y12 = lac_1
9827  ELSE
9828  y12 = 0.
9829  END IF
9830  IF (al(i) - u(i, j) .LT. y12) THEN
9831  y6 = y12
9832  ELSE
9833  y6 = al(i) - u(i, j)
9834  END IF
9835  IF (x7 .GT. y6) THEN
9836  bl(i) = y6
9837  ELSE
9838  bl(i) = x7
9839  END IF
9840  pmp_2 = 2.*dq(i-1)
9841  lac_2 = pmp_2 - 1.5*dq(i-2)
9842  IF (0. .LT. pmp_2) THEN
9843  IF (pmp_2 .LT. lac_2) THEN
9844  x8 = lac_2
9845  ELSE
9846  x8 = pmp_2
9847  END IF
9848  ELSE IF (0. .LT. lac_2) THEN
9849  x8 = lac_2
9850  ELSE
9851  x8 = 0.
9852  END IF
9853  IF (0. .GT. pmp_2) THEN
9854  IF (pmp_2 .GT. lac_2) THEN
9855  y13 = lac_2
9856  ELSE
9857  y13 = pmp_2
9858  END IF
9859  ELSE IF (0. .GT. lac_2) THEN
9860  y13 = lac_2
9861  ELSE
9862  y13 = 0.
9863  END IF
9864  IF (al(i+1) - u(i, j) .LT. y13) THEN
9865  y7 = y13
9866  ELSE
9867  y7 = al(i+1) - u(i, j)
9868  END IF
9869  IF (x8 .GT. y7) THEN
9870  br(i) = y7
9871  ELSE
9872  br(i) = x8
9873  END IF
9874  END DO
9875  ELSE IF (iord .EQ. 10) THEN
9876  DO i=is3,ie3
9877  bl(i) = al(i) - u(i, j)
9878  br(i) = al(i+1) - u(i, j)
9879  IF (dm(i) .GE. 0.) THEN
9880  abs1 = dm(i)
9881  ELSE
9882  abs1 = -dm(i)
9883  END IF
9884 ! if ( abs(dm(i-1))+abs(dm(i))+abs(dm(i+1)) < near_zero ) then
9885  IF (abs1 .LT. near_zero) THEN
9886  IF (dm(i-1) .GE. 0.) THEN
9887  abs2 = dm(i-1)
9888  ELSE
9889  abs2 = -dm(i-1)
9890  END IF
9891  IF (dm(i+1) .GE. 0.) THEN
9892  abs5 = dm(i+1)
9893  ELSE
9894  abs5 = -dm(i+1)
9895  END IF
9896  IF (abs2 + abs5 .LT. near_zero) THEN
9897 ! 2-delta-x structure detected within 3 cells
9898  bl(i) = 0.
9899  br(i) = 0.
9900  END IF
9901  ELSE
9902  IF (3.*(bl(i)+br(i)) .GE. 0.) THEN
9903  abs3 = 3.*(bl(i)+br(i))
9904  ELSE
9905  abs3 = -(3.*(bl(i)+br(i)))
9906  END IF
9907  IF (bl(i) - br(i) .GE. 0.) THEN
9908  abs6 = bl(i) - br(i)
9909  ELSE
9910  abs6 = -(bl(i)-br(i))
9911  END IF
9912  IF (abs3 .GT. abs6) THEN
9913  pmp_1 = -(2.*dq(i))
9914  lac_1 = pmp_1 + 1.5*dq(i+1)
9915  IF (0. .LT. pmp_1) THEN
9916  IF (pmp_1 .LT. lac_1) THEN
9917  x9 = lac_1
9918  ELSE
9919  x9 = pmp_1
9920  END IF
9921  ELSE IF (0. .LT. lac_1) THEN
9922  x9 = lac_1
9923  ELSE
9924  x9 = 0.
9925  END IF
9926  IF (0. .GT. pmp_1) THEN
9927  IF (pmp_1 .GT. lac_1) THEN
9928  y14 = lac_1
9929  ELSE
9930  y14 = pmp_1
9931  END IF
9932  ELSE IF (0. .GT. lac_1) THEN
9933  y14 = lac_1
9934  ELSE
9935  y14 = 0.
9936  END IF
9937  IF (bl(i) .LT. y14) THEN
9938  y8 = y14
9939  ELSE
9940  y8 = bl(i)
9941  END IF
9942  IF (x9 .GT. y8) THEN
9943  bl(i) = y8
9944  ELSE
9945  bl(i) = x9
9946  END IF
9947  pmp_2 = 2.*dq(i-1)
9948  lac_2 = pmp_2 - 1.5*dq(i-2)
9949  IF (0. .LT. pmp_2) THEN
9950  IF (pmp_2 .LT. lac_2) THEN
9951  x10 = lac_2
9952  ELSE
9953  x10 = pmp_2
9954  END IF
9955  ELSE IF (0. .LT. lac_2) THEN
9956  x10 = lac_2
9957  ELSE
9958  x10 = 0.
9959  END IF
9960  IF (0. .GT. pmp_2) THEN
9961  IF (pmp_2 .GT. lac_2) THEN
9962  y15 = lac_2
9963  ELSE
9964  y15 = pmp_2
9965  END IF
9966  ELSE IF (0. .GT. lac_2) THEN
9967  y15 = lac_2
9968  ELSE
9969  y15 = 0.
9970  END IF
9971  IF (br(i) .LT. y15) THEN
9972  y9 = y15
9973  ELSE
9974  y9 = br(i)
9975  END IF
9976  IF (x10 .GT. y9) THEN
9977  br(i) = y9
9978  ELSE
9979  br(i) = x10
9980  END IF
9981  END IF
9982  END IF
9983  END DO
9984  ELSE
9985 ! un-limited: 11
9986  DO i=is3,ie3
9987  bl(i) = al(i) - u(i, j)
9988  br(i) = al(i+1) - u(i, j)
9989  END DO
9990  END IF
9991 !--------------
9992 ! fix the edges
9993 !--------------
9994 !!! TO DO: separate versions for nested and for cubed-sphere
9995  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
9996  br(2) = al(3) - u(2, j)
9997  xt = s15*u(1, j) + s11*u(2, j) - s14*dm(2)
9998  bl(2) = xt - u(2, j)
9999  br(1) = xt - u(1, j)
10000  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
10001 ! out
10002  bl(0) = 0.
10003 ! edge
10004  br(0) = 0.
10005 ! edge
10006  bl(1) = 0.
10007 ! in
10008  br(1) = 0.
10009  ELSE
10010  bl(0) = s14*dm(-1) - s11*dq(-1)
10011  x0l = 0.5*((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
10012 & j))/(dx(0, j)+dx(-1, j))
10013  x0r = 0.5*((2.*dx(1, j)+dx(2, j))*u(1, j)-dx(1, j)*u(2, j)&
10014 & )/(dx(1, j)+dx(2, j))
10015  xt = x0l + x0r
10016  br(0) = xt - u(0, j)
10017  bl(1) = xt - u(1, j)
10018  END IF
10019  CALL pert_ppm(1, u(2:2, j), bl(2:2), br(2:2), -1)
10020  END IF
10021  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
10022  bl(npx-2) = al(npx-2) - u(npx-2, j)
10023  xt = s15*u(npx-1, j) + s11*u(npx-2, j) + s14*dm(npx-2)
10024  br(npx-2) = xt - u(npx-2, j)
10025  bl(npx-1) = xt - u(npx-1, j)
10026  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
10027 ! in
10028  bl(npx-1) = 0.
10029 ! edge
10030  br(npx-1) = 0.
10031 ! edge
10032  bl(npx) = 0.
10033 ! out
10034  br(npx) = 0.
10035  ELSE
10036  br(npx) = s11*dq(npx) - s14*dm(npx+1)
10037  x0l = 0.5*((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
10038 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))
10039  x0r = 0.5*((2.*dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, &
10040 & j)*u(npx+1, j))/(dx(npx, j)+dx(npx+1, j))
10041  xt = x0l + x0r
10042  br(npx-1) = xt - u(npx-1, j)
10043  bl(npx) = xt - u(npx, j)
10044  END IF
10045  CALL pert_ppm(1, u(npx-2:npx-2, j), bl(npx-2:npx-2), br(npx-&
10046 & 2:npx-2), -1)
10047  END IF
10048  ELSE
10049 ! Other grids:
10050  DO i=is-1,ie+2
10051  al(i) = 0.5*(u(i-1, j)+u(i, j)) + r3*(dm(i-1)-dm(i))
10052  END DO
10053  DO i=is-1,ie+1
10054  pmp = -(2.*dq(i))
10055  lac = pmp + 1.5*dq(i+1)
10056  IF (0. .LT. pmp) THEN
10057  IF (pmp .LT. lac) THEN
10058  x11 = lac
10059  ELSE
10060  x11 = pmp
10061  END IF
10062  ELSE IF (0. .LT. lac) THEN
10063  x11 = lac
10064  ELSE
10065  x11 = 0.
10066  END IF
10067  IF (0. .GT. pmp) THEN
10068  IF (pmp .GT. lac) THEN
10069  y16 = lac
10070  ELSE
10071  y16 = pmp
10072  END IF
10073  ELSE IF (0. .GT. lac) THEN
10074  y16 = lac
10075  ELSE
10076  y16 = 0.
10077  END IF
10078  IF (al(i) - u(i, j) .LT. y16) THEN
10079  y10 = y16
10080  ELSE
10081  y10 = al(i) - u(i, j)
10082  END IF
10083  IF (x11 .GT. y10) THEN
10084  bl(i) = y10
10085  ELSE
10086  bl(i) = x11
10087  END IF
10088  pmp = 2.*dq(i-1)
10089  lac = pmp - 1.5*dq(i-2)
10090  IF (0. .LT. pmp) THEN
10091  IF (pmp .LT. lac) THEN
10092  x12 = lac
10093  ELSE
10094  x12 = pmp
10095  END IF
10096  ELSE IF (0. .LT. lac) THEN
10097  x12 = lac
10098  ELSE
10099  x12 = 0.
10100  END IF
10101  IF (0. .GT. pmp) THEN
10102  IF (pmp .GT. lac) THEN
10103  y17 = lac
10104  ELSE
10105  y17 = pmp
10106  END IF
10107  ELSE IF (0. .GT. lac) THEN
10108  y17 = lac
10109  ELSE
10110  y17 = 0.
10111  END IF
10112  IF (al(i+1) - u(i, j) .LT. y17) THEN
10113  y11 = y17
10114  ELSE
10115  y11 = al(i+1) - u(i, j)
10116  END IF
10117  IF (x12 .GT. y11) THEN
10118  br(i) = y11
10119  ELSE
10120  br(i) = x12
10121  END IF
10122  END DO
10123  END IF
10124  DO i=is,ie+1
10125  IF (c(i, j) .GT. 0.) THEN
10126  cfl = c(i, j)*rdx(i-1, j)
10127  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*(bl(i-1)+br(i&
10128 & -1)))
10129  ELSE
10130  cfl = c(i, j)*rdx(i, j)
10131  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*(bl(i)+br(i)))
10132  END IF
10133  END DO
10134  END DO
10135  END IF
10136  END SUBROUTINE xtp_u
10137 ! Differentiation of ytp_v in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_core
10138 !_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_mod.p_grad_c dyn_cor
10139 !e_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.mix_dp dyn_core_mod.g
10140 !eopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamics_m
10141 !od.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_mod.
10142 !c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz_mod.ma
10143 !p_scalar_fb fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.scalar_pr
10144 !ofile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.steepz f
10145 !v_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.d2c_setup
10146 ! fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.compute
10147 !_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solver_c nh
10148 !_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3p0_solver nh_u
10149 !tils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh sw_cor
10150 !e_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_core_mod
10151 !.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mod.compu
10152 !te_divergence_damping_fb sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corners
10153 !tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle_di
10154 !st sw_core_mod.edge_interpolate4)):
10155 ! gradient of useful results: flux v c
10156 ! with respect to varying inputs: v c
10157  SUBROUTINE ytp_v_adm(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, v&
10158 & , v_ad, flux, flux_ad, jord, dy, rdy, npx, npy, grid_type, nested)
10159  IMPLICIT NONE
10160  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
10161  INTEGER, INTENT(IN) :: jord
10162  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
10163  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
10164  REAL :: v_ad(isd:ied+1, jsd:jed)
10165 ! Courant N (like FLUX)
10166  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
10167  REAL :: c_ad(is:ie+1, js:je+1)
10168  REAL :: flux(is:ie+1, js:je+1)
10169  REAL :: flux_ad(is:ie+1, js:je+1)
10170  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
10171  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
10172  INTEGER, INTENT(IN) :: npx, npy, grid_type
10173  LOGICAL, INTENT(IN) :: nested
10174 ! Local:
10175  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
10176  REAL :: fx0(is:ie+1)
10177  REAL :: fx0_ad(is:ie+1)
10178  REAL :: dm(is:ie+1, js-2:je+2)
10179  REAL :: dm_ad(is:ie+1, js-2:je+2)
10180  REAL :: al(is:ie+1, js-1:je+2)
10181  REAL :: al_ad(is:ie+1, js-1:je+2)
10182  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
10183  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl_ad, br_ad, b0_ad
10184  REAL :: dq(is:ie+1, js-3:je+2)
10185  REAL :: dq_ad(is:ie+1, js-3:je+2)
10186  REAL :: xt, dl, dr, pmp, lac, cfl
10187  REAL :: xt_ad, pmp_ad, lac_ad, cfl_ad
10188  REAL :: pmp_1, lac_1, pmp_2, lac_2
10189  REAL :: pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
10190  REAL :: x0, x1, x0r, x0l
10191  REAL :: x0r_ad, x0l_ad
10192  INTEGER :: i, j, is1, ie1, js3, je3
10193  INTRINSIC max
10194  INTRINSIC min
10195  INTRINSIC abs
10196  INTRINSIC sign
10197  REAL :: min1
10198  REAL :: min1_ad
10199  REAL :: min2
10200  REAL :: min2_ad
10201  REAL :: abs0
10202  REAL :: min3
10203  REAL :: min3_ad
10204  REAL :: min4
10205  REAL :: min4_ad
10206  REAL :: min5
10207  REAL :: min5_ad
10208  REAL :: abs1
10209  REAL :: abs2
10210  REAL :: abs3
10211  REAL :: abs4
10212  REAL :: max1
10213  REAL :: max1_ad
10214  REAL :: min6
10215  REAL :: min6_ad
10216  REAL :: abs5
10217  REAL :: abs6
10218  INTEGER :: arg1
10219  REAL :: temp_ad
10220  REAL :: temp_ad0
10221  REAL :: temp_ad1
10222  REAL :: temp_ad2
10223  REAL :: temp_ad3
10224  REAL :: temp_ad4
10225  REAL :: x2_ad
10226  REAL :: y1_ad
10227  REAL :: x3_ad
10228  REAL :: y2_ad
10229  REAL :: temp_ad5
10230  REAL :: temp_ad6
10231  REAL :: temp_ad7
10232  REAL :: temp_ad8
10233  REAL :: x4_ad
10234  REAL :: y3_ad
10235  REAL :: z1_ad
10236  REAL :: x5_ad
10237  REAL :: y4_ad
10238  REAL :: x6_ad
10239  REAL :: y5_ad
10240  REAL :: x7_ad
10241  REAL :: y12_ad
10242  REAL :: y6_ad
10243  REAL :: x8_ad
10244  REAL :: y13_ad
10245  REAL :: y7_ad
10246  REAL :: x9_ad
10247  REAL :: y14_ad
10248  REAL :: y8_ad
10249  REAL :: x10_ad
10250  REAL :: y15_ad
10251  REAL :: y9_ad
10252  REAL :: temp_ad9
10253  REAL :: temp_ad10
10254  REAL :: temp_ad11
10255  REAL :: temp_ad12
10256  REAL :: x11_ad
10257  REAL :: y16_ad
10258  REAL :: y10_ad
10259  REAL :: x12_ad
10260  REAL :: y17_ad
10261  REAL :: y11_ad
10262  REAL :: temp
10263  REAL :: temp_ad13
10264  REAL :: temp0
10265  REAL :: temp_ad14
10266  INTEGER :: branch
10267  REAL :: x12
10268  REAL :: x11
10269  REAL :: x10
10270  REAL :: x9
10271  REAL :: x8
10272  REAL :: x7
10273  REAL :: x6
10274  REAL :: x5
10275  REAL :: x4
10276  REAL :: x3
10277  REAL :: x2
10278  REAL :: y17
10279  REAL :: y16
10280  REAL :: y15
10281  REAL :: y14
10282  REAL :: y13
10283  REAL :: y12
10284  REAL :: y11
10285  REAL :: y10
10286  REAL :: z1
10287  REAL :: y9
10288  REAL :: y8
10289  REAL :: y7
10290  REAL :: y6
10291  REAL :: y5
10292  REAL :: y4
10293  REAL :: y3
10294  REAL :: y2
10295  REAL :: y1
10296  IF (nested .OR. grid_type .GT. 3) THEN
10297  CALL pushcontrol1b(0)
10298  js3 = js - 1
10299  je3 = je + 1
10300  ELSE
10301  IF (3 .LT. js - 1) THEN
10302  js3 = js - 1
10303  ELSE
10304  js3 = 3
10305  END IF
10306  IF (npy - 3 .GT. je + 1) THEN
10307  CALL pushcontrol1b(1)
10308  je3 = je + 1
10309  ELSE
10310  CALL pushcontrol1b(1)
10311  je3 = npy - 3
10312  END IF
10313  END IF
10314  IF (jord .EQ. 1) THEN
10315  DO j=js,je+1
10316  DO i=is,ie+1
10317  IF (c(i, j) .GT. 0.) THEN
10318  CALL pushcontrol1b(1)
10319  ELSE
10320  CALL pushcontrol1b(0)
10321  END IF
10322  END DO
10323  END DO
10324  DO j=je+1,js,-1
10325  DO i=ie+1,is,-1
10326  CALL popcontrol1b(branch)
10327  IF (branch .EQ. 0) THEN
10328  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10329  flux_ad(i, j) = 0.0
10330  ELSE
10331  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10332  flux_ad(i, j) = 0.0
10333  END IF
10334  END DO
10335  END DO
10336  ELSE IF (jord .LT. 8) THEN
10337 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
10338  DO j=js3,je3+1
10339  DO i=is,ie+1
10340  al(i, j) = p1*(v(i, j-1)+v(i, j)) + p2*(v(i, j-2)+v(i, j+1))
10341  END DO
10342  END DO
10343  DO j=js3,je3
10344  DO i=is,ie+1
10345  bl(i, j) = al(i, j) - v(i, j)
10346  br(i, j) = al(i, j+1) - v(i, j)
10347  END DO
10348  END DO
10349  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
10350  IF (js .EQ. 1) THEN
10351  DO i=is,ie+1
10352  bl(i, 0) = c1*v(i, -2) + c2*v(i, -1) + c3*v(i, 0) - v(i, 0)
10353  xt = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
10354 & )/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(&
10355 & i, 1)*v(i, 2))/(dy(i, 1)+dy(i, 2)))
10356  br(i, 0) = xt - v(i, 0)
10357  bl(i, 1) = xt - v(i, 1)
10358  xt = c3*v(i, 1) + c2*v(i, 2) + c1*v(i, 3)
10359  br(i, 1) = xt - v(i, 1)
10360  bl(i, 2) = xt - v(i, 2)
10361  br(i, 2) = al(i, 3) - v(i, 2)
10362  END DO
10363  IF (is .EQ. 1) THEN
10364 ! out
10365  bl(1, 0) = 0.
10366 ! edge
10367  br(1, 0) = 0.
10368 ! edge
10369  bl(1, 1) = 0.
10370 ! in
10371  br(1, 1) = 0.
10372  CALL pushcontrol1b(0)
10373  ELSE
10374  CALL pushcontrol1b(1)
10375  END IF
10376  IF (ie + 1 .EQ. npx) THEN
10377 ! out
10378  bl(npx, 0) = 0.
10379 ! edge
10380  br(npx, 0) = 0.
10381 ! edge
10382  bl(npx, 1) = 0.
10383 ! in
10384  br(npx, 1) = 0.
10385  CALL pushcontrol2b(0)
10386  ELSE
10387  CALL pushcontrol2b(1)
10388  END IF
10389  ELSE
10390  CALL pushcontrol2b(2)
10391  END IF
10392 ! j=2
10393 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
10394  IF (je + 1 .EQ. npy) THEN
10395  DO i=is,ie+1
10396  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
10397  xt = c1*v(i, npy-3) + c2*v(i, npy-2) + c3*v(i, npy-1)
10398  br(i, npy-2) = xt - v(i, npy-2)
10399  bl(i, npy-1) = xt - v(i, npy-1)
10400  xt = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
10401 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+((2.*dy(i&
10402 & , npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)*v(i, npy+1))/(dy&
10403 & (i, npy)+dy(i, npy+1)))
10404  br(i, npy-1) = xt - v(i, npy-1)
10405  bl(i, npy) = xt - v(i, npy)
10406  br(i, npy) = c3*v(i, npy) + c2*v(i, npy+1) + c1*v(i, npy+2) &
10407 & - v(i, npy)
10408  END DO
10409  IF (is .EQ. 1) THEN
10410 ! in
10411  bl(1, npy-1) = 0.
10412 ! edge
10413  br(1, npy-1) = 0.
10414 ! edge
10415  bl(1, npy) = 0.
10416 ! out
10417  br(1, npy) = 0.
10418  CALL pushcontrol1b(0)
10419  ELSE
10420  CALL pushcontrol1b(1)
10421  END IF
10422  IF (ie + 1 .EQ. npx) THEN
10423 ! in
10424  bl(npx, npy-1) = 0.
10425 ! edge
10426  br(npx, npy-1) = 0.
10427 ! edge
10428  bl(npx, npy) = 0.
10429 ! out
10430  br(npx, npy) = 0.
10431  CALL pushcontrol2b(3)
10432  ELSE
10433  CALL pushcontrol2b(2)
10434  END IF
10435  ELSE
10436  CALL pushcontrol2b(1)
10437  END IF
10438  ELSE
10439  CALL pushcontrol2b(0)
10440  END IF
10441 ! j=npy-2
10442 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
10443  DO j=js-1,je+1
10444  DO i=is,ie+1
10445  b0(i, j) = bl(i, j) + br(i, j)
10446  END DO
10447  END DO
10448  IF (jord .EQ. 2) THEN
10449 ! Perfectly linear
10450  DO j=js,je+1
10451 !DEC$ VECTOR ALWAYS
10452  DO i=is,ie+1
10453  IF (c(i, j) .GT. 0.) THEN
10454  CALL pushcontrol1b(1)
10455  ELSE
10456  CALL pushcontrol1b(0)
10457  END IF
10458  END DO
10459  END DO
10460  bl_ad = 0.0
10461  br_ad = 0.0
10462  b0_ad = 0.0
10463  DO j=je+1,js,-1
10464  DO i=ie+1,is,-1
10465  CALL popcontrol1b(branch)
10466  IF (branch .EQ. 0) THEN
10467  cfl = c(i, j)*rdy(i, j)
10468  temp_ad4 = (cfl+1.)*flux_ad(i, j)
10469  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10470  cfl_ad = b0(i, j)*temp_ad4 + (bl(i, j)+cfl*b0(i, j))*&
10471 & flux_ad(i, j)
10472  bl_ad(i, j) = bl_ad(i, j) + temp_ad4
10473  b0_ad(i, j) = b0_ad(i, j) + cfl*temp_ad4
10474  flux_ad(i, j) = 0.0
10475  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
10476  ELSE
10477  cfl = c(i, j)*rdy(i, j-1)
10478  temp_ad3 = (1.-cfl)*flux_ad(i, j)
10479  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10480  cfl_ad = -(b0(i, j-1)*temp_ad3) - (br(i, j-1)-cfl*b0(i, j-&
10481 & 1))*flux_ad(i, j)
10482  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad3
10483  b0_ad(i, j-1) = b0_ad(i, j-1) - cfl*temp_ad3
10484  flux_ad(i, j) = 0.0
10485  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
10486  END IF
10487  END DO
10488  END DO
10489  ELSE IF (jord .EQ. 3) THEN
10490  DO j=js-1,je+1
10491  DO i=is,ie+1
10492  IF (b0(i, j) .GE. 0.) THEN
10493  x0 = b0(i, j)
10494  ELSE
10495  x0 = -b0(i, j)
10496  END IF
10497  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
10498  x1 = bl(i, j) - br(i, j)
10499  ELSE
10500  x1 = -(bl(i, j)-br(i, j))
10501  END IF
10502  smt5(i, j) = x0 .LT. x1
10503  smt6(i, j) = 3.*x0 .LT. x1
10504  END DO
10505  END DO
10506  DO j=js,je+1
10507  DO i=is,ie+1
10508  CALL pushrealarray_adm(fx0(i))
10509  fx0(i) = 0.
10510  END DO
10511  DO i=is,ie+1
10512  IF (c(i, j) .GT. 0.) THEN
10513  cfl = c(i, j)*rdy(i, j-1)
10514  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
10515  CALL pushrealarray_adm(fx0(i))
10516  fx0(i) = br(i, j-1) - cfl*b0(i, j-1)
10517  CALL pushcontrol2b(0)
10518  ELSE IF (smt5(i, j-1)) THEN
10519  IF (bl(i, j-1) .GE. 0.) THEN
10520  x2 = bl(i, j-1)
10521  CALL pushcontrol1b(0)
10522  ELSE
10523  x2 = -bl(i, j-1)
10524  CALL pushcontrol1b(1)
10525  END IF
10526  IF (br(i, j-1) .GE. 0.) THEN
10527  y1 = br(i, j-1)
10528  CALL pushcontrol1b(0)
10529  ELSE
10530  y1 = -br(i, j-1)
10531  CALL pushcontrol1b(1)
10532  END IF
10533  IF (x2 .GT. y1) THEN
10534  CALL pushrealarray_adm(min1)
10535  min1 = y1
10536  CALL pushcontrol1b(0)
10537  ELSE
10538  CALL pushrealarray_adm(min1)
10539  min1 = x2
10540  CALL pushcontrol1b(1)
10541  END IF
10542 ! piece-wise linear
10543  CALL pushrealarray_adm(fx0(i))
10544  fx0(i) = sign(min1, br(i, j-1))
10545  CALL pushcontrol2b(1)
10546  ELSE
10547  CALL pushcontrol2b(2)
10548  END IF
10549  CALL pushcontrol1b(1)
10550  ELSE
10551  cfl = c(i, j)*rdy(i, j)
10552  IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
10553  CALL pushrealarray_adm(fx0(i))
10554  fx0(i) = bl(i, j) + cfl*b0(i, j)
10555  CALL pushcontrol2b(0)
10556  ELSE IF (smt5(i, j)) THEN
10557  IF (bl(i, j) .GE. 0.) THEN
10558  x3 = bl(i, j)
10559  CALL pushcontrol1b(0)
10560  ELSE
10561  x3 = -bl(i, j)
10562  CALL pushcontrol1b(1)
10563  END IF
10564  IF (br(i, j) .GE. 0.) THEN
10565  y2 = br(i, j)
10566  CALL pushcontrol1b(0)
10567  ELSE
10568  y2 = -br(i, j)
10569  CALL pushcontrol1b(1)
10570  END IF
10571  IF (x3 .GT. y2) THEN
10572  CALL pushrealarray_adm(min2)
10573  min2 = y2
10574  CALL pushcontrol1b(0)
10575  ELSE
10576  CALL pushrealarray_adm(min2)
10577  min2 = x3
10578  CALL pushcontrol1b(1)
10579  END IF
10580  CALL pushrealarray_adm(fx0(i))
10581  fx0(i) = sign(min2, bl(i, j))
10582  CALL pushcontrol2b(1)
10583  ELSE
10584  CALL pushcontrol2b(2)
10585  END IF
10586  CALL pushcontrol1b(0)
10587  END IF
10588  END DO
10589  END DO
10590  bl_ad = 0.0
10591  br_ad = 0.0
10592  b0_ad = 0.0
10593  fx0_ad = 0.0
10594  DO j=je+1,js,-1
10595  DO i=ie+1,is,-1
10596  CALL popcontrol1b(branch)
10597  IF (branch .EQ. 0) THEN
10598  cfl = c(i, j)*rdy(i, j)
10599  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10600  cfl_ad = fx0(i)*flux_ad(i, j)
10601  fx0_ad(i) = fx0_ad(i) + (cfl+1.)*flux_ad(i, j)
10602  flux_ad(i, j) = 0.0
10603  CALL popcontrol2b(branch)
10604  IF (branch .EQ. 0) THEN
10605  CALL poprealarray_adm(fx0(i))
10606  bl_ad(i, j) = bl_ad(i, j) + fx0_ad(i)
10607  cfl_ad = cfl_ad + b0(i, j)*fx0_ad(i)
10608  b0_ad(i, j) = b0_ad(i, j) + cfl*fx0_ad(i)
10609  fx0_ad(i) = 0.0
10610  ELSE IF (branch .EQ. 1) THEN
10611  CALL poprealarray_adm(fx0(i))
10612  min2_ad = sign(1.d0, min2*bl(i, j))*fx0_ad(i)
10613  fx0_ad(i) = 0.0
10614  CALL popcontrol1b(branch)
10615  IF (branch .EQ. 0) THEN
10616  CALL poprealarray_adm(min2)
10617  y2_ad = min2_ad
10618  x3_ad = 0.0
10619  ELSE
10620  CALL poprealarray_adm(min2)
10621  x3_ad = min2_ad
10622  y2_ad = 0.0
10623  END IF
10624  CALL popcontrol1b(branch)
10625  IF (branch .EQ. 0) THEN
10626  br_ad(i, j) = br_ad(i, j) + y2_ad
10627  ELSE
10628  br_ad(i, j) = br_ad(i, j) - y2_ad
10629  END IF
10630  CALL popcontrol1b(branch)
10631  IF (branch .EQ. 0) THEN
10632  bl_ad(i, j) = bl_ad(i, j) + x3_ad
10633  ELSE
10634  bl_ad(i, j) = bl_ad(i, j) - x3_ad
10635  END IF
10636  END IF
10637  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
10638  ELSE
10639  cfl = c(i, j)*rdy(i, j-1)
10640  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10641  cfl_ad = -(fx0(i)*flux_ad(i, j))
10642  fx0_ad(i) = fx0_ad(i) + (1.-cfl)*flux_ad(i, j)
10643  flux_ad(i, j) = 0.0
10644  CALL popcontrol2b(branch)
10645  IF (branch .EQ. 0) THEN
10646  CALL poprealarray_adm(fx0(i))
10647  br_ad(i, j-1) = br_ad(i, j-1) + fx0_ad(i)
10648  cfl_ad = cfl_ad - b0(i, j-1)*fx0_ad(i)
10649  b0_ad(i, j-1) = b0_ad(i, j-1) - cfl*fx0_ad(i)
10650  fx0_ad(i) = 0.0
10651  ELSE IF (branch .EQ. 1) THEN
10652  CALL poprealarray_adm(fx0(i))
10653  min1_ad = sign(1.d0, min1*br(i, j-1))*fx0_ad(i)
10654  fx0_ad(i) = 0.0
10655  CALL popcontrol1b(branch)
10656  IF (branch .EQ. 0) THEN
10657  CALL poprealarray_adm(min1)
10658  y1_ad = min1_ad
10659  x2_ad = 0.0
10660  ELSE
10661  CALL poprealarray_adm(min1)
10662  x2_ad = min1_ad
10663  y1_ad = 0.0
10664  END IF
10665  CALL popcontrol1b(branch)
10666  IF (branch .EQ. 0) THEN
10667  br_ad(i, j-1) = br_ad(i, j-1) + y1_ad
10668  ELSE
10669  br_ad(i, j-1) = br_ad(i, j-1) - y1_ad
10670  END IF
10671  CALL popcontrol1b(branch)
10672  IF (branch .EQ. 0) THEN
10673  bl_ad(i, j-1) = bl_ad(i, j-1) + x2_ad
10674  ELSE
10675  bl_ad(i, j-1) = bl_ad(i, j-1) - x2_ad
10676  END IF
10677  END IF
10678  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
10679  END IF
10680  END DO
10681  DO i=ie+1,is,-1
10682  CALL poprealarray_adm(fx0(i))
10683  fx0_ad(i) = 0.0
10684  END DO
10685  END DO
10686  DO j=je+1,js-1,-1
10687  i = is - 1
10688  END DO
10689  ELSE IF (jord .EQ. 4) THEN
10690  DO j=js-1,je+1
10691  DO i=is,ie+1
10692  IF (b0(i, j) .GE. 0.) THEN
10693  x0 = b0(i, j)
10694  ELSE
10695  x0 = -b0(i, j)
10696  END IF
10697  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
10698  x1 = bl(i, j) - br(i, j)
10699  ELSE
10700  x1 = -(bl(i, j)-br(i, j))
10701  END IF
10702  smt5(i, j) = x0 .LT. x1
10703  smt6(i, j) = 3.*x0 .LT. x1
10704  END DO
10705  END DO
10706  DO j=js,je+1
10707  DO i=is,ie+1
10708  IF (c(i, j) .GT. 0.) THEN
10709  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
10710  CALL pushcontrol2b(3)
10711  ELSE
10712  CALL pushcontrol2b(2)
10713  END IF
10714  ELSE IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
10715  CALL pushcontrol2b(1)
10716  ELSE
10717  CALL pushcontrol2b(0)
10718  END IF
10719  END DO
10720  END DO
10721  bl_ad = 0.0
10722  br_ad = 0.0
10723  b0_ad = 0.0
10724  DO j=je+1,js,-1
10725  DO i=ie+1,is,-1
10726  CALL popcontrol2b(branch)
10727  IF (branch .LT. 2) THEN
10728  IF (branch .EQ. 0) THEN
10729  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10730  flux_ad(i, j) = 0.0
10731  ELSE
10732  cfl = c(i, j)*rdy(i, j)
10733  temp_ad6 = (cfl+1.)*flux_ad(i, j)
10734  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10735  cfl_ad = b0(i, j)*temp_ad6 + (bl(i, j)+cfl*b0(i, j))*&
10736 & flux_ad(i, j)
10737  bl_ad(i, j) = bl_ad(i, j) + temp_ad6
10738  b0_ad(i, j) = b0_ad(i, j) + cfl*temp_ad6
10739  flux_ad(i, j) = 0.0
10740  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
10741  END IF
10742  ELSE IF (branch .EQ. 2) THEN
10743  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10744  flux_ad(i, j) = 0.0
10745  ELSE
10746  cfl = c(i, j)*rdy(i, j-1)
10747  temp_ad5 = (1.-cfl)*flux_ad(i, j)
10748  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10749  cfl_ad = -(b0(i, j-1)*temp_ad5) - (br(i, j-1)-cfl*b0(i, j-&
10750 & 1))*flux_ad(i, j)
10751  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad5
10752  b0_ad(i, j-1) = b0_ad(i, j-1) - cfl*temp_ad5
10753  flux_ad(i, j) = 0.0
10754  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
10755  END IF
10756  END DO
10757  END DO
10758  DO j=je+1,js-1,-1
10759  i = is - 1
10760  END DO
10761  ELSE
10762 ! jord = 5,6,7
10763 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
10764  IF (jord .EQ. 5) THEN
10765  CALL pushcontrol1b(1)
10766  DO j=js-1,je+1
10767  DO i=is,ie+1
10768  smt5(i, j) = bl(i, j)*br(i, j) .LT. 0.
10769  END DO
10770  END DO
10771  ELSE
10772 ! ord = 6, 7
10773  DO j=js-1,je+1
10774  DO i=is,ie+1
10775  IF (3.*b0(i, j) .GE. 0.) THEN
10776  abs0 = 3.*b0(i, j)
10777  ELSE
10778  abs0 = -(3.*b0(i, j))
10779  END IF
10780  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
10781  abs4 = bl(i, j) - br(i, j)
10782  ELSE
10783  abs4 = -(bl(i, j)-br(i, j))
10784  END IF
10785  smt5(i, j) = abs0 .LT. abs4
10786  END DO
10787  END DO
10788  CALL pushcontrol1b(0)
10789  END IF
10790  DO j=js,je+1
10791 !DEC$ VECTOR ALWAYS
10792  DO i=is,ie+1
10793  IF (c(i, j) .GT. 0.) THEN
10794  CALL pushcontrol1b(0)
10795  ELSE
10796  CALL pushcontrol1b(1)
10797  END IF
10798  IF (smt5(i, j-1) .OR. smt5(i, j)) THEN
10799  CALL pushcontrol1b(1)
10800  ELSE
10801  CALL pushcontrol1b(0)
10802  END IF
10803  END DO
10804  END DO
10805  bl_ad = 0.0
10806  br_ad = 0.0
10807  b0_ad = 0.0
10808  fx0_ad = 0.0
10809  DO j=je+1,js,-1
10810  DO i=ie+1,is,-1
10811  CALL popcontrol1b(branch)
10812  IF (branch .NE. 0) fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
10813  CALL popcontrol1b(branch)
10814  IF (branch .EQ. 0) THEN
10815  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
10816  flux_ad(i, j) = 0.0
10817  cfl = c(i, j)*rdy(i, j-1)
10818  temp_ad7 = (1.-cfl)*fx0_ad(i)
10819  cfl_ad = -(b0(i, j-1)*temp_ad7) - (br(i, j-1)-cfl*b0(i, j-&
10820 & 1))*fx0_ad(i)
10821  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad7
10822  b0_ad(i, j-1) = b0_ad(i, j-1) - cfl*temp_ad7
10823  fx0_ad(i) = 0.0
10824  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
10825  ELSE
10826  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
10827  flux_ad(i, j) = 0.0
10828  cfl = c(i, j)*rdy(i, j)
10829  temp_ad8 = (cfl+1.)*fx0_ad(i)
10830  cfl_ad = b0(i, j)*temp_ad8 + (bl(i, j)+cfl*b0(i, j))*&
10831 & fx0_ad(i)
10832  bl_ad(i, j) = bl_ad(i, j) + temp_ad8
10833  b0_ad(i, j) = b0_ad(i, j) + cfl*temp_ad8
10834  fx0_ad(i) = 0.0
10835  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
10836  END IF
10837  END DO
10838  END DO
10839  CALL popcontrol1b(branch)
10840  IF (branch .EQ. 0) THEN
10841  DO j=je+1,js-1,-1
10842  i = is - 1
10843  END DO
10844  END IF
10845  END IF
10846  DO j=je+1,js-1,-1
10847  DO i=ie+1,is,-1
10848  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
10849  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
10850  b0_ad(i, j) = 0.0
10851  END DO
10852  END DO
10853  CALL popcontrol2b(branch)
10854  IF (branch .LT. 2) THEN
10855  IF (branch .EQ. 0) THEN
10856  al_ad = 0.0
10857  GOTO 100
10858  ELSE
10859  al_ad = 0.0
10860  END IF
10861  ELSE
10862  IF (branch .NE. 2) THEN
10863  br_ad(npx, npy) = 0.0
10864  bl_ad(npx, npy) = 0.0
10865  br_ad(npx, npy-1) = 0.0
10866  bl_ad(npx, npy-1) = 0.0
10867  END IF
10868  CALL popcontrol1b(branch)
10869  IF (branch .EQ. 0) THEN
10870  br_ad(1, npy) = 0.0
10871  bl_ad(1, npy) = 0.0
10872  br_ad(1, npy-1) = 0.0
10873  bl_ad(1, npy-1) = 0.0
10874  END IF
10875  al_ad = 0.0
10876  DO i=ie+1,is,-1
10877  v_ad(i, npy) = v_ad(i, npy) + (c3-1.0)*br_ad(i, npy)
10878  v_ad(i, npy+1) = v_ad(i, npy+1) + c2*br_ad(i, npy)
10879  v_ad(i, npy+2) = v_ad(i, npy+2) + c1*br_ad(i, npy)
10880  br_ad(i, npy) = 0.0
10881  xt_ad = br_ad(i, npy-1) + bl_ad(i, npy)
10882  v_ad(i, npy) = v_ad(i, npy) - bl_ad(i, npy)
10883  bl_ad(i, npy) = 0.0
10884  temp_ad1 = 0.5*xt_ad/(dy(i, npy-1)+dy(i, npy-2))
10885  v_ad(i, npy-1) = v_ad(i, npy-1) + (dy(i, npy-1)*2.+dy(i, npy-2&
10886 & ))*temp_ad1 - br_ad(i, npy-1)
10887  br_ad(i, npy-1) = 0.0
10888  temp_ad2 = 0.5*xt_ad/(dy(i, npy)+dy(i, npy+1))
10889  v_ad(i, npy-2) = v_ad(i, npy-2) - dy(i, npy-1)*temp_ad1
10890  v_ad(i, npy) = v_ad(i, npy) + (dy(i, npy)*2.+dy(i, npy+1))*&
10891 & temp_ad2
10892  v_ad(i, npy+1) = v_ad(i, npy+1) - dy(i, npy)*temp_ad2
10893  xt_ad = br_ad(i, npy-2) + bl_ad(i, npy-1)
10894  v_ad(i, npy-1) = v_ad(i, npy-1) - bl_ad(i, npy-1)
10895  bl_ad(i, npy-1) = 0.0
10896  v_ad(i, npy-2) = v_ad(i, npy-2) - br_ad(i, npy-2)
10897  br_ad(i, npy-2) = 0.0
10898  v_ad(i, npy-3) = v_ad(i, npy-3) + c1*xt_ad
10899  v_ad(i, npy-2) = v_ad(i, npy-2) + c2*xt_ad
10900  v_ad(i, npy-1) = v_ad(i, npy-1) + c3*xt_ad
10901  al_ad(i, npy-2) = al_ad(i, npy-2) + bl_ad(i, npy-2)
10902  v_ad(i, npy-2) = v_ad(i, npy-2) - bl_ad(i, npy-2)
10903  bl_ad(i, npy-2) = 0.0
10904  END DO
10905  END IF
10906  CALL popcontrol2b(branch)
10907  IF (branch .EQ. 0) THEN
10908  br_ad(npx, 1) = 0.0
10909  bl_ad(npx, 1) = 0.0
10910  br_ad(npx, 0) = 0.0
10911  bl_ad(npx, 0) = 0.0
10912  ELSE IF (branch .NE. 1) THEN
10913  GOTO 100
10914  END IF
10915  CALL popcontrol1b(branch)
10916  IF (branch .EQ. 0) THEN
10917  br_ad(1, 1) = 0.0
10918  bl_ad(1, 1) = 0.0
10919  br_ad(1, 0) = 0.0
10920  bl_ad(1, 0) = 0.0
10921  END IF
10922  DO i=ie+1,is,-1
10923  al_ad(i, 3) = al_ad(i, 3) + br_ad(i, 2)
10924  v_ad(i, 2) = v_ad(i, 2) - bl_ad(i, 2) - br_ad(i, 2)
10925  br_ad(i, 2) = 0.0
10926  xt_ad = br_ad(i, 1) + bl_ad(i, 2)
10927  bl_ad(i, 2) = 0.0
10928  v_ad(i, 1) = v_ad(i, 1) + c3*xt_ad - br_ad(i, 1)
10929  br_ad(i, 1) = 0.0
10930  v_ad(i, 2) = v_ad(i, 2) + c2*xt_ad
10931  v_ad(i, 3) = v_ad(i, 3) + c1*xt_ad
10932  xt_ad = br_ad(i, 0) + bl_ad(i, 1)
10933  v_ad(i, 1) = v_ad(i, 1) - bl_ad(i, 1)
10934  bl_ad(i, 1) = 0.0
10935  temp_ad = 0.5*xt_ad/(dy(i, 0)+dy(i, -1))
10936  v_ad(i, 0) = v_ad(i, 0) + (dy(i, 0)*2.+dy(i, -1))*temp_ad - &
10937 & br_ad(i, 0)
10938  br_ad(i, 0) = 0.0
10939  temp_ad0 = 0.5*xt_ad/(dy(i, 1)+dy(i, 2))
10940  v_ad(i, -1) = v_ad(i, -1) - dy(i, 0)*temp_ad
10941  v_ad(i, 1) = v_ad(i, 1) + (dy(i, 1)*2.+dy(i, 2))*temp_ad0
10942  v_ad(i, 2) = v_ad(i, 2) - dy(i, 1)*temp_ad0
10943  v_ad(i, -2) = v_ad(i, -2) + c1*bl_ad(i, 0)
10944  v_ad(i, -1) = v_ad(i, -1) + c2*bl_ad(i, 0)
10945  v_ad(i, 0) = v_ad(i, 0) + (c3-1.0)*bl_ad(i, 0)
10946  bl_ad(i, 0) = 0.0
10947  END DO
10948  100 DO j=je3,js3,-1
10949  DO i=ie+1,is,-1
10950  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
10951  v_ad(i, j) = v_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
10952  br_ad(i, j) = 0.0
10953  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
10954  bl_ad(i, j) = 0.0
10955  END DO
10956  END DO
10957  DO j=je3+1,js3,-1
10958  DO i=ie+1,is,-1
10959  v_ad(i, j-1) = v_ad(i, j-1) + p1*al_ad(i, j)
10960  v_ad(i, j) = v_ad(i, j) + p1*al_ad(i, j)
10961  v_ad(i, j-2) = v_ad(i, j-2) + p2*al_ad(i, j)
10962  v_ad(i, j+1) = v_ad(i, j+1) + p2*al_ad(i, j)
10963  al_ad(i, j) = 0.0
10964  END DO
10965  END DO
10966  ELSE
10967 ! jord= 8, 9, 10
10968  DO j=js-2,je+2
10969  DO i=is,ie+1
10970  xt = 0.25*(v(i, j+1)-v(i, j-1))
10971  IF (xt .GE. 0.) THEN
10972  x4 = xt
10973  CALL pushcontrol1b(0)
10974  ELSE
10975  x4 = -xt
10976  CALL pushcontrol1b(1)
10977  END IF
10978  IF (v(i, j-1) .LT. v(i, j)) THEN
10979  IF (v(i, j) .LT. v(i, j+1)) THEN
10980  max1 = v(i, j+1)
10981  CALL pushcontrol2b(0)
10982  ELSE
10983  max1 = v(i, j)
10984  CALL pushcontrol2b(1)
10985  END IF
10986  ELSE IF (v(i, j-1) .LT. v(i, j+1)) THEN
10987  max1 = v(i, j+1)
10988  CALL pushcontrol2b(2)
10989  ELSE
10990  max1 = v(i, j-1)
10991  CALL pushcontrol2b(3)
10992  END IF
10993  y3 = max1 - v(i, j)
10994  IF (v(i, j-1) .GT. v(i, j)) THEN
10995  IF (v(i, j) .GT. v(i, j+1)) THEN
10996  min6 = v(i, j+1)
10997  CALL pushcontrol2b(0)
10998  ELSE
10999  min6 = v(i, j)
11000  CALL pushcontrol2b(1)
11001  END IF
11002  ELSE IF (v(i, j-1) .GT. v(i, j+1)) THEN
11003  min6 = v(i, j+1)
11004  CALL pushcontrol2b(2)
11005  ELSE
11006  min6 = v(i, j-1)
11007  CALL pushcontrol2b(3)
11008  END IF
11009  z1 = v(i, j) - min6
11010  IF (x4 .GT. y3) THEN
11011  IF (y3 .GT. z1) THEN
11012  CALL pushrealarray_adm(min3)
11013  min3 = z1
11014  CALL pushcontrol2b(0)
11015  ELSE
11016  CALL pushrealarray_adm(min3)
11017  min3 = y3
11018  CALL pushcontrol2b(1)
11019  END IF
11020  ELSE IF (x4 .GT. z1) THEN
11021  CALL pushrealarray_adm(min3)
11022  min3 = z1
11023  CALL pushcontrol2b(2)
11024  ELSE
11025  CALL pushrealarray_adm(min3)
11026  min3 = x4
11027  CALL pushcontrol2b(3)
11028  END IF
11029  dm(i, j) = sign(min3, xt)
11030  END DO
11031  END DO
11032  DO j=js-3,je+2
11033  DO i=is,ie+1
11034  dq(i, j) = v(i, j+1) - v(i, j)
11035  END DO
11036  END DO
11037  IF (grid_type .LT. 3) THEN
11038  DO j=js3,je3+1
11039  DO i=is,ie+1
11040  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
11041 & )
11042  END DO
11043  END DO
11044  IF (jord .EQ. 8) THEN
11045  DO j=js3,je3
11046  DO i=is,ie+1
11047  xt = 2.*dm(i, j)
11048  IF (xt .GE. 0.) THEN
11049  x5 = xt
11050  CALL pushcontrol1b(0)
11051  ELSE
11052  x5 = -xt
11053  CALL pushcontrol1b(1)
11054  END IF
11055  IF (al(i, j) - v(i, j) .GE. 0.) THEN
11056  y4 = al(i, j) - v(i, j)
11057  CALL pushcontrol1b(0)
11058  ELSE
11059  y4 = -(al(i, j)-v(i, j))
11060  CALL pushcontrol1b(1)
11061  END IF
11062  IF (x5 .GT. y4) THEN
11063  CALL pushrealarray_adm(min4)
11064  min4 = y4
11065  CALL pushcontrol1b(0)
11066  ELSE
11067  CALL pushrealarray_adm(min4)
11068  min4 = x5
11069  CALL pushcontrol1b(1)
11070  END IF
11071  bl(i, j) = -sign(min4, xt)
11072  IF (xt .GE. 0.) THEN
11073  x6 = xt
11074  CALL pushcontrol1b(0)
11075  ELSE
11076  x6 = -xt
11077  CALL pushcontrol1b(1)
11078  END IF
11079  IF (al(i, j+1) - v(i, j) .GE. 0.) THEN
11080  y5 = al(i, j+1) - v(i, j)
11081  CALL pushcontrol1b(0)
11082  ELSE
11083  y5 = -(al(i, j+1)-v(i, j))
11084  CALL pushcontrol1b(1)
11085  END IF
11086  IF (x6 .GT. y5) THEN
11087  CALL pushrealarray_adm(min5)
11088  min5 = y5
11089  CALL pushcontrol1b(0)
11090  ELSE
11091  CALL pushrealarray_adm(min5)
11092  min5 = x6
11093  CALL pushcontrol1b(1)
11094  END IF
11095  br(i, j) = sign(min5, xt)
11096  END DO
11097  END DO
11098  CALL pushcontrol2b(0)
11099  ELSE IF (jord .EQ. 9) THEN
11100  DO j=js3,je3
11101  DO i=is,ie+1
11102  pmp_1 = -(2.*dq(i, j))
11103  lac_1 = pmp_1 + 1.5*dq(i, j+1)
11104  IF (0. .LT. pmp_1) THEN
11105  IF (pmp_1 .LT. lac_1) THEN
11106  x7 = lac_1
11107  CALL pushcontrol2b(0)
11108  ELSE
11109  x7 = pmp_1
11110  CALL pushcontrol2b(1)
11111  END IF
11112  ELSE IF (0. .LT. lac_1) THEN
11113  x7 = lac_1
11114  CALL pushcontrol2b(2)
11115  ELSE
11116  CALL pushcontrol2b(3)
11117  x7 = 0.
11118  END IF
11119  IF (0. .GT. pmp_1) THEN
11120  IF (pmp_1 .GT. lac_1) THEN
11121  y12 = lac_1
11122  CALL pushcontrol2b(0)
11123  ELSE
11124  y12 = pmp_1
11125  CALL pushcontrol2b(1)
11126  END IF
11127  ELSE IF (0. .GT. lac_1) THEN
11128  y12 = lac_1
11129  CALL pushcontrol2b(2)
11130  ELSE
11131  y12 = 0.
11132  CALL pushcontrol2b(3)
11133  END IF
11134  IF (al(i, j) - v(i, j) .LT. y12) THEN
11135  y6 = y12
11136  CALL pushcontrol1b(0)
11137  ELSE
11138  y6 = al(i, j) - v(i, j)
11139  CALL pushcontrol1b(1)
11140  END IF
11141  IF (x7 .GT. y6) THEN
11142  bl(i, j) = y6
11143  CALL pushcontrol1b(0)
11144  ELSE
11145  bl(i, j) = x7
11146  CALL pushcontrol1b(1)
11147  END IF
11148  pmp_2 = 2.*dq(i, j-1)
11149  lac_2 = pmp_2 - 1.5*dq(i, j-2)
11150  IF (0. .LT. pmp_2) THEN
11151  IF (pmp_2 .LT. lac_2) THEN
11152  x8 = lac_2
11153  CALL pushcontrol2b(0)
11154  ELSE
11155  x8 = pmp_2
11156  CALL pushcontrol2b(1)
11157  END IF
11158  ELSE IF (0. .LT. lac_2) THEN
11159  x8 = lac_2
11160  CALL pushcontrol2b(2)
11161  ELSE
11162  CALL pushcontrol2b(3)
11163  x8 = 0.
11164  END IF
11165  IF (0. .GT. pmp_2) THEN
11166  IF (pmp_2 .GT. lac_2) THEN
11167  y13 = lac_2
11168  CALL pushcontrol2b(0)
11169  ELSE
11170  y13 = pmp_2
11171  CALL pushcontrol2b(1)
11172  END IF
11173  ELSE IF (0. .GT. lac_2) THEN
11174  y13 = lac_2
11175  CALL pushcontrol2b(2)
11176  ELSE
11177  y13 = 0.
11178  CALL pushcontrol2b(3)
11179  END IF
11180  IF (al(i, j+1) - v(i, j) .LT. y13) THEN
11181  y7 = y13
11182  CALL pushcontrol1b(0)
11183  ELSE
11184  y7 = al(i, j+1) - v(i, j)
11185  CALL pushcontrol1b(1)
11186  END IF
11187  IF (x8 .GT. y7) THEN
11188  br(i, j) = y7
11189  CALL pushcontrol1b(0)
11190  ELSE
11191  br(i, j) = x8
11192  CALL pushcontrol1b(1)
11193  END IF
11194  END DO
11195  END DO
11196  CALL pushcontrol2b(1)
11197  ELSE IF (jord .EQ. 10) THEN
11198  DO j=js3,je3
11199  DO i=is,ie+1
11200  bl(i, j) = al(i, j) - v(i, j)
11201  br(i, j) = al(i, j+1) - v(i, j)
11202  IF (dm(i, j) .GE. 0.) THEN
11203  abs1 = dm(i, j)
11204  ELSE
11205  abs1 = -dm(i, j)
11206  END IF
11207 ! if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then
11208  IF (abs1 .LT. near_zero) THEN
11209  IF (dm(i, j-1) .GE. 0.) THEN
11210  abs2 = dm(i, j-1)
11211  ELSE
11212  abs2 = -dm(i, j-1)
11213  END IF
11214  IF (dm(i, j+1) .GE. 0.) THEN
11215  abs5 = dm(i, j+1)
11216  ELSE
11217  abs5 = -dm(i, j+1)
11218  END IF
11219  IF (abs2 + abs5 .LT. near_zero) THEN
11220  bl(i, j) = 0.
11221  br(i, j) = 0.
11222  CALL pushcontrol3b(4)
11223  ELSE
11224  CALL pushcontrol3b(3)
11225  END IF
11226  ELSE
11227  IF (3.*(bl(i, j)+br(i, j)) .GE. 0.) THEN
11228  abs3 = 3.*(bl(i, j)+br(i, j))
11229  ELSE
11230  abs3 = -(3.*(bl(i, j)+br(i, j)))
11231  END IF
11232  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
11233  abs6 = bl(i, j) - br(i, j)
11234  ELSE
11235  abs6 = -(bl(i, j)-br(i, j))
11236  END IF
11237  IF (abs3 .GT. abs6) THEN
11238  pmp_1 = -(2.*dq(i, j))
11239  lac_1 = pmp_1 + 1.5*dq(i, j+1)
11240  IF (0. .LT. pmp_1) THEN
11241  IF (pmp_1 .LT. lac_1) THEN
11242  x9 = lac_1
11243  CALL pushcontrol2b(0)
11244  ELSE
11245  x9 = pmp_1
11246  CALL pushcontrol2b(1)
11247  END IF
11248  ELSE IF (0. .LT. lac_1) THEN
11249  x9 = lac_1
11250  CALL pushcontrol2b(2)
11251  ELSE
11252  CALL pushcontrol2b(3)
11253  x9 = 0.
11254  END IF
11255  IF (0. .GT. pmp_1) THEN
11256  IF (pmp_1 .GT. lac_1) THEN
11257  y14 = lac_1
11258  CALL pushcontrol2b(0)
11259  ELSE
11260  y14 = pmp_1
11261  CALL pushcontrol2b(1)
11262  END IF
11263  ELSE IF (0. .GT. lac_1) THEN
11264  y14 = lac_1
11265  CALL pushcontrol2b(2)
11266  ELSE
11267  y14 = 0.
11268  CALL pushcontrol2b(3)
11269  END IF
11270  IF (bl(i, j) .LT. y14) THEN
11271  y8 = y14
11272  CALL pushcontrol1b(0)
11273  ELSE
11274  y8 = bl(i, j)
11275  CALL pushcontrol1b(1)
11276  END IF
11277  IF (x9 .GT. y8) THEN
11278  bl(i, j) = y8
11279  CALL pushcontrol1b(0)
11280  ELSE
11281  bl(i, j) = x9
11282  CALL pushcontrol1b(1)
11283  END IF
11284  pmp_2 = 2.*dq(i, j-1)
11285  lac_2 = pmp_2 - 1.5*dq(i, j-2)
11286  IF (0. .LT. pmp_2) THEN
11287  IF (pmp_2 .LT. lac_2) THEN
11288  x10 = lac_2
11289  CALL pushcontrol2b(0)
11290  ELSE
11291  x10 = pmp_2
11292  CALL pushcontrol2b(1)
11293  END IF
11294  ELSE IF (0. .LT. lac_2) THEN
11295  x10 = lac_2
11296  CALL pushcontrol2b(2)
11297  ELSE
11298  CALL pushcontrol2b(3)
11299  x10 = 0.
11300  END IF
11301  IF (0. .GT. pmp_2) THEN
11302  IF (pmp_2 .GT. lac_2) THEN
11303  y15 = lac_2
11304  CALL pushcontrol2b(0)
11305  ELSE
11306  y15 = pmp_2
11307  CALL pushcontrol2b(1)
11308  END IF
11309  ELSE IF (0. .GT. lac_2) THEN
11310  y15 = lac_2
11311  CALL pushcontrol2b(2)
11312  ELSE
11313  y15 = 0.
11314  CALL pushcontrol2b(3)
11315  END IF
11316  IF (br(i, j) .LT. y15) THEN
11317  y9 = y15
11318  CALL pushcontrol1b(0)
11319  ELSE
11320  y9 = br(i, j)
11321  CALL pushcontrol1b(1)
11322  END IF
11323  IF (x10 .GT. y9) THEN
11324  br(i, j) = y9
11325  CALL pushcontrol3b(1)
11326  ELSE
11327  br(i, j) = x10
11328  CALL pushcontrol3b(2)
11329  END IF
11330  ELSE
11331  CALL pushcontrol3b(0)
11332  END IF
11333  END IF
11334  END DO
11335  END DO
11336  CALL pushcontrol2b(2)
11337  ELSE
11338 ! Unlimited:
11339  DO j=js3,je3
11340  DO i=is,ie+1
11341  bl(i, j) = al(i, j) - v(i, j)
11342  br(i, j) = al(i, j+1) - v(i, j)
11343  END DO
11344  END DO
11345  CALL pushcontrol2b(3)
11346  END IF
11347 !--------------
11348 ! fix the edges
11349 !--------------
11350  IF (js .EQ. 1 .AND. (.NOT.nested)) THEN
11351  DO i=is,ie+1
11352  br(i, 2) = al(i, 3) - v(i, 2)
11353  xt = s15*v(i, 1) + s11*v(i, 2) - s14*dm(i, 2)
11354  br(i, 1) = xt - v(i, 1)
11355  bl(i, 2) = xt - v(i, 2)
11356  bl(i, 0) = s14*dm(i, -1) - s11*dq(i, -1)
11357  x0l = 0.5*((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
11358 & )/(dy(i, 0)+dy(i, -1))
11359  x0r = 0.5*((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(i, 1)*v(i, 2))/&
11360 & (dy(i, 1)+dy(i, 2))
11361  xt = x0l + x0r
11362  bl(i, 1) = xt - v(i, 1)
11363  br(i, 0) = xt - v(i, 0)
11364  END DO
11365  IF (is .EQ. 1) THEN
11366 ! out
11367  bl(1, 0) = 0.
11368 ! edge
11369  br(1, 0) = 0.
11370 ! edge
11371  bl(1, 1) = 0.
11372 ! in
11373  br(1, 1) = 0.
11374  CALL pushcontrol1b(0)
11375  ELSE
11376  CALL pushcontrol1b(1)
11377  END IF
11378  IF (ie + 1 .EQ. npx) THEN
11379 ! out
11380  bl(npx, 0) = 0.
11381 ! edge
11382  br(npx, 0) = 0.
11383 ! edge
11384  bl(npx, 1) = 0.
11385 ! in
11386  br(npx, 1) = 0.
11387  CALL pushcontrol1b(0)
11388  ELSE
11389  CALL pushcontrol1b(1)
11390  END IF
11391  j = 2
11392  arg1 = ie - is + 2
11393  CALL pushrealarray_adm(br(:, j), ie - is + 2)
11394  CALL pushrealarray_adm(bl(:, j), ie - is + 2)
11395  CALL pert_ppm(arg1, v(is:ie+1, j), bl(is:ie+1, j), br(is:ie+1&
11396 & , j), -1)
11397  CALL pushcontrol1b(0)
11398  ELSE
11399  CALL pushcontrol1b(1)
11400  END IF
11401  IF (je + 1 .EQ. npy .AND. (.NOT.nested)) THEN
11402  DO i=is,ie+1
11403  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
11404  xt = s15*v(i, npy-1) + s11*v(i, npy-2) + s14*dm(i, npy-2)
11405  br(i, npy-2) = xt - v(i, npy-2)
11406  bl(i, npy-1) = xt - v(i, npy-1)
11407  br(i, npy) = s11*dq(i, npy) - s14*dm(i, npy+1)
11408  x0l = 0.5*((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
11409 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))
11410  x0r = 0.5*((2.*dy(i, npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)&
11411 & *v(i, npy+1))/(dy(i, npy)+dy(i, npy+1))
11412  xt = x0l + x0r
11413  br(i, npy-1) = xt - v(i, npy-1)
11414  bl(i, npy) = xt - v(i, npy)
11415  END DO
11416  IF (is .EQ. 1) THEN
11417 ! in
11418  bl(1, npy-1) = 0.
11419 ! edge
11420  br(1, npy-1) = 0.
11421 ! edge
11422  bl(1, npy) = 0.
11423 ! out
11424  br(1, npy) = 0.
11425  CALL pushcontrol1b(0)
11426  ELSE
11427  CALL pushcontrol1b(1)
11428  END IF
11429  IF (ie + 1 .EQ. npx) THEN
11430 ! in
11431  bl(npx, npy-1) = 0.
11432 ! edge
11433  br(npx, npy-1) = 0.
11434 ! edge
11435  bl(npx, npy) = 0.
11436 ! out
11437  br(npx, npy) = 0.
11438  CALL pushcontrol1b(0)
11439  ELSE
11440  CALL pushcontrol1b(1)
11441  END IF
11442  j = npy - 2
11443  arg1 = ie - is + 2
11444  CALL pushrealarray_adm(br(:, j), ie - is + 2)
11445  CALL pushrealarray_adm(bl(:, j), ie - is + 2)
11446  CALL pert_ppm(arg1, v(is:ie+1, j), bl(is:ie+1, j), br(is:ie+1&
11447 & , j), -1)
11448  CALL pushcontrol2b(2)
11449  ELSE
11450  CALL pushcontrol2b(1)
11451  END IF
11452  ELSE
11453  DO j=js-1,je+2
11454  DO i=is,ie+1
11455  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
11456 & )
11457  END DO
11458  END DO
11459  DO j=js-1,je+1
11460  DO i=is,ie+1
11461  pmp = 2.*dq(i, j-1)
11462  lac = pmp - 1.5*dq(i, j-2)
11463  IF (0. .LT. pmp) THEN
11464  IF (pmp .LT. lac) THEN
11465  x11 = lac
11466  CALL pushcontrol2b(0)
11467  ELSE
11468  x11 = pmp
11469  CALL pushcontrol2b(1)
11470  END IF
11471  ELSE IF (0. .LT. lac) THEN
11472  x11 = lac
11473  CALL pushcontrol2b(2)
11474  ELSE
11475  CALL pushcontrol2b(3)
11476  x11 = 0.
11477  END IF
11478  IF (0. .GT. pmp) THEN
11479  IF (pmp .GT. lac) THEN
11480  y16 = lac
11481  CALL pushcontrol2b(0)
11482  ELSE
11483  y16 = pmp
11484  CALL pushcontrol2b(1)
11485  END IF
11486  ELSE IF (0. .GT. lac) THEN
11487  y16 = lac
11488  CALL pushcontrol2b(2)
11489  ELSE
11490  y16 = 0.
11491  CALL pushcontrol2b(3)
11492  END IF
11493  IF (al(i, j+1) - v(i, j) .LT. y16) THEN
11494  y10 = y16
11495  CALL pushcontrol1b(0)
11496  ELSE
11497  y10 = al(i, j+1) - v(i, j)
11498  CALL pushcontrol1b(1)
11499  END IF
11500  IF (x11 .GT. y10) THEN
11501  br(i, j) = y10
11502  CALL pushcontrol1b(0)
11503  ELSE
11504  br(i, j) = x11
11505  CALL pushcontrol1b(1)
11506  END IF
11507  pmp = -(2.*dq(i, j))
11508  lac = pmp + 1.5*dq(i, j+1)
11509  IF (0. .LT. pmp) THEN
11510  IF (pmp .LT. lac) THEN
11511  x12 = lac
11512  CALL pushcontrol2b(0)
11513  ELSE
11514  x12 = pmp
11515  CALL pushcontrol2b(1)
11516  END IF
11517  ELSE IF (0. .LT. lac) THEN
11518  x12 = lac
11519  CALL pushcontrol2b(2)
11520  ELSE
11521  CALL pushcontrol2b(3)
11522  x12 = 0.
11523  END IF
11524  IF (0. .GT. pmp) THEN
11525  IF (pmp .GT. lac) THEN
11526  y17 = lac
11527  CALL pushcontrol2b(0)
11528  ELSE
11529  y17 = pmp
11530  CALL pushcontrol2b(1)
11531  END IF
11532  ELSE IF (0. .GT. lac) THEN
11533  y17 = lac
11534  CALL pushcontrol2b(2)
11535  ELSE
11536  y17 = 0.
11537  CALL pushcontrol2b(3)
11538  END IF
11539  IF (al(i, j) - v(i, j) .LT. y17) THEN
11540  y11 = y17
11541  CALL pushcontrol1b(0)
11542  ELSE
11543  y11 = al(i, j) - v(i, j)
11544  CALL pushcontrol1b(1)
11545  END IF
11546  IF (x12 .GT. y11) THEN
11547  bl(i, j) = y11
11548  CALL pushcontrol1b(0)
11549  ELSE
11550  bl(i, j) = x12
11551  CALL pushcontrol1b(1)
11552  END IF
11553  END DO
11554  END DO
11555  CALL pushcontrol2b(0)
11556  END IF
11557  CALL pushinteger4(j)
11558  DO j=js,je+1
11559  DO i=is,ie+1
11560  IF (c(i, j) .GT. 0.) THEN
11561  CALL pushcontrol1b(1)
11562  ELSE
11563  CALL pushcontrol1b(0)
11564  END IF
11565  END DO
11566  END DO
11567  bl_ad = 0.0
11568  br_ad = 0.0
11569  DO j=je+1,js,-1
11570  DO i=ie+1,is,-1
11571  CALL popcontrol1b(branch)
11572  IF (branch .EQ. 0) THEN
11573  cfl = c(i, j)*rdy(i, j)
11574  temp0 = bl(i, j) + br(i, j)
11575  temp_ad14 = (cfl+1.)*flux_ad(i, j)
11576  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
11577  cfl_ad = temp0*temp_ad14 + (bl(i, j)+cfl*temp0)*flux_ad(i, j&
11578 & )
11579  bl_ad(i, j) = bl_ad(i, j) + (cfl+1.0)*temp_ad14
11580  br_ad(i, j) = br_ad(i, j) + cfl*temp_ad14
11581  flux_ad(i, j) = 0.0
11582  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
11583  ELSE
11584  cfl = c(i, j)*rdy(i, j-1)
11585  temp = bl(i, j-1) + br(i, j-1)
11586  temp_ad13 = (1.-cfl)*flux_ad(i, j)
11587  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
11588  cfl_ad = -(temp*temp_ad13) - (br(i, j-1)-cfl*temp)*flux_ad(i&
11589 & , j)
11590  br_ad(i, j-1) = br_ad(i, j-1) + (1.0-cfl)*temp_ad13
11591  bl_ad(i, j-1) = bl_ad(i, j-1) - cfl*temp_ad13
11592  flux_ad(i, j) = 0.0
11593  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
11594  END IF
11595  END DO
11596  END DO
11597  CALL popinteger4(j)
11598  CALL popcontrol2b(branch)
11599  IF (branch .EQ. 0) THEN
11600  dq_ad = 0.0
11601  al_ad = 0.0
11602  DO j=je+1,js-1,-1
11603  DO i=ie+1,is,-1
11604  CALL popcontrol1b(branch)
11605  IF (branch .EQ. 0) THEN
11606  y11_ad = bl_ad(i, j)
11607  bl_ad(i, j) = 0.0
11608  x12_ad = 0.0
11609  ELSE
11610  x12_ad = bl_ad(i, j)
11611  bl_ad(i, j) = 0.0
11612  y11_ad = 0.0
11613  END IF
11614  CALL popcontrol1b(branch)
11615  IF (branch .EQ. 0) THEN
11616  y17_ad = y11_ad
11617  ELSE
11618  al_ad(i, j) = al_ad(i, j) + y11_ad
11619  v_ad(i, j) = v_ad(i, j) - y11_ad
11620  y17_ad = 0.0
11621  END IF
11622  CALL popcontrol2b(branch)
11623  IF (branch .LT. 2) THEN
11624  IF (branch .EQ. 0) THEN
11625  lac_ad = y17_ad
11626  pmp_ad = 0.0
11627  ELSE
11628  pmp_ad = y17_ad
11629  lac_ad = 0.0
11630  END IF
11631  ELSE
11632  IF (branch .EQ. 2) THEN
11633  lac_ad = y17_ad
11634  ELSE
11635  lac_ad = 0.0
11636  END IF
11637  pmp_ad = 0.0
11638  END IF
11639  CALL popcontrol2b(branch)
11640  IF (branch .LT. 2) THEN
11641  IF (branch .EQ. 0) THEN
11642  lac_ad = lac_ad + x12_ad
11643  ELSE
11644  pmp_ad = pmp_ad + x12_ad
11645  END IF
11646  ELSE IF (branch .EQ. 2) THEN
11647  lac_ad = lac_ad + x12_ad
11648  END IF
11649  pmp_ad = pmp_ad + lac_ad
11650  dq_ad(i, j+1) = dq_ad(i, j+1) + 1.5*lac_ad
11651  dq_ad(i, j) = dq_ad(i, j) - 2.*pmp_ad
11652  CALL popcontrol1b(branch)
11653  IF (branch .EQ. 0) THEN
11654  y10_ad = br_ad(i, j)
11655  br_ad(i, j) = 0.0
11656  x11_ad = 0.0
11657  ELSE
11658  x11_ad = br_ad(i, j)
11659  br_ad(i, j) = 0.0
11660  y10_ad = 0.0
11661  END IF
11662  CALL popcontrol1b(branch)
11663  IF (branch .EQ. 0) THEN
11664  y16_ad = y10_ad
11665  ELSE
11666  al_ad(i, j+1) = al_ad(i, j+1) + y10_ad
11667  v_ad(i, j) = v_ad(i, j) - y10_ad
11668  y16_ad = 0.0
11669  END IF
11670  CALL popcontrol2b(branch)
11671  IF (branch .LT. 2) THEN
11672  IF (branch .EQ. 0) THEN
11673  lac_ad = y16_ad
11674  pmp_ad = 0.0
11675  ELSE
11676  pmp_ad = y16_ad
11677  lac_ad = 0.0
11678  END IF
11679  ELSE
11680  IF (branch .EQ. 2) THEN
11681  lac_ad = y16_ad
11682  ELSE
11683  lac_ad = 0.0
11684  END IF
11685  pmp_ad = 0.0
11686  END IF
11687  CALL popcontrol2b(branch)
11688  IF (branch .LT. 2) THEN
11689  IF (branch .EQ. 0) THEN
11690  lac_ad = lac_ad + x11_ad
11691  ELSE
11692  pmp_ad = pmp_ad + x11_ad
11693  END IF
11694  ELSE IF (branch .EQ. 2) THEN
11695  lac_ad = lac_ad + x11_ad
11696  END IF
11697  pmp_ad = pmp_ad + lac_ad
11698  dq_ad(i, j-2) = dq_ad(i, j-2) - 1.5*lac_ad
11699  dq_ad(i, j-1) = dq_ad(i, j-1) + 2.*pmp_ad
11700  END DO
11701  END DO
11702  dm_ad = 0.0
11703  DO j=je+2,js-1,-1
11704  DO i=ie+1,is,-1
11705  v_ad(i, j-1) = v_ad(i, j-1) + 0.5*al_ad(i, j)
11706  v_ad(i, j) = v_ad(i, j) + 0.5*al_ad(i, j)
11707  dm_ad(i, j-1) = dm_ad(i, j-1) + r3*al_ad(i, j)
11708  dm_ad(i, j) = dm_ad(i, j) - r3*al_ad(i, j)
11709  al_ad(i, j) = 0.0
11710  END DO
11711  END DO
11712  ELSE
11713  IF (branch .EQ. 1) THEN
11714  dm_ad = 0.0
11715  dq_ad = 0.0
11716  al_ad = 0.0
11717  ELSE
11718  j = npy - 2
11719  CALL poprealarray_adm(bl(:, j), ie - is + 2)
11720  CALL poprealarray_adm(br(:, j), ie - is + 2)
11721  CALL pert_ppm_adm(arg1, v(is:ie+1, j), bl(is:ie+1, j), bl_ad(&
11722 & is:ie+1, j), br(is:ie+1, j), br_ad(is:ie+1, j), -1&
11723 & )
11724  CALL popcontrol1b(branch)
11725  IF (branch .EQ. 0) THEN
11726  br_ad(npx, npy) = 0.0
11727  bl_ad(npx, npy) = 0.0
11728  br_ad(npx, npy-1) = 0.0
11729  bl_ad(npx, npy-1) = 0.0
11730  END IF
11731  CALL popcontrol1b(branch)
11732  IF (branch .EQ. 0) THEN
11733  br_ad(1, npy) = 0.0
11734  bl_ad(1, npy) = 0.0
11735  br_ad(1, npy-1) = 0.0
11736  bl_ad(1, npy-1) = 0.0
11737  END IF
11738  dm_ad = 0.0
11739  dq_ad = 0.0
11740  al_ad = 0.0
11741  DO i=ie+1,is,-1
11742  xt_ad = br_ad(i, npy-1) + bl_ad(i, npy)
11743  v_ad(i, npy) = v_ad(i, npy) - bl_ad(i, npy)
11744  bl_ad(i, npy) = 0.0
11745  v_ad(i, npy-1) = v_ad(i, npy-1) - br_ad(i, npy-1)
11746  br_ad(i, npy-1) = 0.0
11747  x0l_ad = xt_ad
11748  x0r_ad = xt_ad
11749  temp_ad11 = 0.5*x0r_ad/(dy(i, npy)+dy(i, npy+1))
11750  v_ad(i, npy) = v_ad(i, npy) + (dy(i, npy)*2.+dy(i, npy+1))*&
11751 & temp_ad11
11752  v_ad(i, npy+1) = v_ad(i, npy+1) - dy(i, npy)*temp_ad11
11753  temp_ad12 = 0.5*x0l_ad/(dy(i, npy-1)+dy(i, npy-2))
11754  v_ad(i, npy-1) = v_ad(i, npy-1) + (dy(i, npy-1)*2.+dy(i, npy&
11755 & -2))*temp_ad12
11756  v_ad(i, npy-2) = v_ad(i, npy-2) - dy(i, npy-1)*temp_ad12
11757  dq_ad(i, npy) = dq_ad(i, npy) + s11*br_ad(i, npy)
11758  dm_ad(i, npy+1) = dm_ad(i, npy+1) - s14*br_ad(i, npy)
11759  br_ad(i, npy) = 0.0
11760  xt_ad = br_ad(i, npy-2) + bl_ad(i, npy-1)
11761  v_ad(i, npy-1) = v_ad(i, npy-1) - bl_ad(i, npy-1)
11762  bl_ad(i, npy-1) = 0.0
11763  v_ad(i, npy-2) = v_ad(i, npy-2) - br_ad(i, npy-2)
11764  br_ad(i, npy-2) = 0.0
11765  v_ad(i, npy-1) = v_ad(i, npy-1) + s15*xt_ad
11766  v_ad(i, npy-2) = v_ad(i, npy-2) + s11*xt_ad - bl_ad(i, npy-2&
11767 & )
11768  dm_ad(i, npy-2) = dm_ad(i, npy-2) + s14*xt_ad
11769  al_ad(i, npy-2) = al_ad(i, npy-2) + bl_ad(i, npy-2)
11770  bl_ad(i, npy-2) = 0.0
11771  END DO
11772  END IF
11773  CALL popcontrol1b(branch)
11774  IF (branch .EQ. 0) THEN
11775  j = 2
11776  arg1 = ie - is + 2
11777  CALL poprealarray_adm(bl(:, j), ie - is + 2)
11778  CALL poprealarray_adm(br(:, j), ie - is + 2)
11779  CALL pert_ppm_adm(arg1, v(is:ie+1, j), bl(is:ie+1, j), bl_ad(&
11780 & is:ie+1, j), br(is:ie+1, j), br_ad(is:ie+1, j), -1&
11781 & )
11782  CALL popcontrol1b(branch)
11783  IF (branch .EQ. 0) THEN
11784  br_ad(npx, 1) = 0.0
11785  bl_ad(npx, 1) = 0.0
11786  br_ad(npx, 0) = 0.0
11787  bl_ad(npx, 0) = 0.0
11788  END IF
11789  CALL popcontrol1b(branch)
11790  IF (branch .EQ. 0) THEN
11791  br_ad(1, 1) = 0.0
11792  bl_ad(1, 1) = 0.0
11793  br_ad(1, 0) = 0.0
11794  bl_ad(1, 0) = 0.0
11795  END IF
11796  DO i=ie+1,is,-1
11797  xt_ad = bl_ad(i, 1) + br_ad(i, 0)
11798  v_ad(i, 0) = v_ad(i, 0) - br_ad(i, 0)
11799  br_ad(i, 0) = 0.0
11800  x0l_ad = xt_ad
11801  x0r_ad = xt_ad
11802  temp_ad9 = 0.5*x0r_ad/(dy(i, 1)+dy(i, 2))
11803  v_ad(i, 1) = v_ad(i, 1) + (dy(i, 1)*2.+dy(i, 2))*temp_ad9 - &
11804 & bl_ad(i, 1)
11805  bl_ad(i, 1) = 0.0
11806  v_ad(i, 2) = v_ad(i, 2) - dy(i, 1)*temp_ad9
11807  temp_ad10 = 0.5*x0l_ad/(dy(i, 0)+dy(i, -1))
11808  v_ad(i, 0) = v_ad(i, 0) + (dy(i, 0)*2.+dy(i, -1))*temp_ad10
11809  v_ad(i, -1) = v_ad(i, -1) - dy(i, 0)*temp_ad10
11810  dm_ad(i, -1) = dm_ad(i, -1) + s14*bl_ad(i, 0)
11811  dq_ad(i, -1) = dq_ad(i, -1) - s11*bl_ad(i, 0)
11812  bl_ad(i, 0) = 0.0
11813  xt_ad = br_ad(i, 1) + bl_ad(i, 2)
11814  v_ad(i, 2) = v_ad(i, 2) - bl_ad(i, 2)
11815  bl_ad(i, 2) = 0.0
11816  v_ad(i, 1) = v_ad(i, 1) + s15*xt_ad - br_ad(i, 1)
11817  br_ad(i, 1) = 0.0
11818  v_ad(i, 2) = v_ad(i, 2) + s11*xt_ad - br_ad(i, 2)
11819  dm_ad(i, 2) = dm_ad(i, 2) - s14*xt_ad
11820  al_ad(i, 3) = al_ad(i, 3) + br_ad(i, 2)
11821  br_ad(i, 2) = 0.0
11822  END DO
11823  END IF
11824  CALL popcontrol2b(branch)
11825  IF (branch .LT. 2) THEN
11826  IF (branch .EQ. 0) THEN
11827  DO j=je3,js3,-1
11828  DO i=ie+1,is,-1
11829  xt = 2.*dm(i, j)
11830  min5_ad = sign(1.d0, min5*xt)*br_ad(i, j)
11831  br_ad(i, j) = 0.0
11832  CALL popcontrol1b(branch)
11833  IF (branch .EQ. 0) THEN
11834  CALL poprealarray_adm(min5)
11835  y5_ad = min5_ad
11836  x6_ad = 0.0
11837  ELSE
11838  CALL poprealarray_adm(min5)
11839  x6_ad = min5_ad
11840  y5_ad = 0.0
11841  END IF
11842  CALL popcontrol1b(branch)
11843  IF (branch .EQ. 0) THEN
11844  al_ad(i, j+1) = al_ad(i, j+1) + y5_ad
11845  v_ad(i, j) = v_ad(i, j) - y5_ad
11846  ELSE
11847  v_ad(i, j) = v_ad(i, j) + y5_ad
11848  al_ad(i, j+1) = al_ad(i, j+1) - y5_ad
11849  END IF
11850  CALL popcontrol1b(branch)
11851  IF (branch .EQ. 0) THEN
11852  xt_ad = x6_ad
11853  ELSE
11854  xt_ad = -x6_ad
11855  END IF
11856  min4_ad = -(sign(1.d0, min4*xt)*bl_ad(i, j))
11857  bl_ad(i, j) = 0.0
11858  CALL popcontrol1b(branch)
11859  IF (branch .EQ. 0) THEN
11860  CALL poprealarray_adm(min4)
11861  y4_ad = min4_ad
11862  x5_ad = 0.0
11863  ELSE
11864  CALL poprealarray_adm(min4)
11865  x5_ad = min4_ad
11866  y4_ad = 0.0
11867  END IF
11868  CALL popcontrol1b(branch)
11869  IF (branch .EQ. 0) THEN
11870  al_ad(i, j) = al_ad(i, j) + y4_ad
11871  v_ad(i, j) = v_ad(i, j) - y4_ad
11872  ELSE
11873  v_ad(i, j) = v_ad(i, j) + y4_ad
11874  al_ad(i, j) = al_ad(i, j) - y4_ad
11875  END IF
11876  CALL popcontrol1b(branch)
11877  IF (branch .EQ. 0) THEN
11878  xt_ad = xt_ad + x5_ad
11879  ELSE
11880  xt_ad = xt_ad - x5_ad
11881  END IF
11882  dm_ad(i, j) = dm_ad(i, j) + 2.*xt_ad
11883  END DO
11884  END DO
11885  ELSE
11886  DO j=je3,js3,-1
11887  DO i=ie+1,is,-1
11888  CALL popcontrol1b(branch)
11889  IF (branch .EQ. 0) THEN
11890  y7_ad = br_ad(i, j)
11891  br_ad(i, j) = 0.0
11892  x8_ad = 0.0
11893  ELSE
11894  x8_ad = br_ad(i, j)
11895  br_ad(i, j) = 0.0
11896  y7_ad = 0.0
11897  END IF
11898  CALL popcontrol1b(branch)
11899  IF (branch .EQ. 0) THEN
11900  y13_ad = y7_ad
11901  ELSE
11902  al_ad(i, j+1) = al_ad(i, j+1) + y7_ad
11903  v_ad(i, j) = v_ad(i, j) - y7_ad
11904  y13_ad = 0.0
11905  END IF
11906  CALL popcontrol2b(branch)
11907  IF (branch .LT. 2) THEN
11908  IF (branch .EQ. 0) THEN
11909  lac_2_ad = y13_ad
11910  pmp_2_ad = 0.0
11911  ELSE
11912  pmp_2_ad = y13_ad
11913  lac_2_ad = 0.0
11914  END IF
11915  ELSE
11916  IF (branch .EQ. 2) THEN
11917  lac_2_ad = y13_ad
11918  ELSE
11919  lac_2_ad = 0.0
11920  END IF
11921  pmp_2_ad = 0.0
11922  END IF
11923  CALL popcontrol2b(branch)
11924  IF (branch .LT. 2) THEN
11925  IF (branch .EQ. 0) THEN
11926  lac_2_ad = lac_2_ad + x8_ad
11927  ELSE
11928  pmp_2_ad = pmp_2_ad + x8_ad
11929  END IF
11930  ELSE IF (branch .EQ. 2) THEN
11931  lac_2_ad = lac_2_ad + x8_ad
11932  END IF
11933  pmp_2_ad = pmp_2_ad + lac_2_ad
11934  dq_ad(i, j-2) = dq_ad(i, j-2) - 1.5*lac_2_ad
11935  dq_ad(i, j-1) = dq_ad(i, j-1) + 2.*pmp_2_ad
11936  CALL popcontrol1b(branch)
11937  IF (branch .EQ. 0) THEN
11938  y6_ad = bl_ad(i, j)
11939  bl_ad(i, j) = 0.0
11940  x7_ad = 0.0
11941  ELSE
11942  x7_ad = bl_ad(i, j)
11943  bl_ad(i, j) = 0.0
11944  y6_ad = 0.0
11945  END IF
11946  CALL popcontrol1b(branch)
11947  IF (branch .EQ. 0) THEN
11948  y12_ad = y6_ad
11949  ELSE
11950  al_ad(i, j) = al_ad(i, j) + y6_ad
11951  v_ad(i, j) = v_ad(i, j) - y6_ad
11952  y12_ad = 0.0
11953  END IF
11954  CALL popcontrol2b(branch)
11955  IF (branch .LT. 2) THEN
11956  IF (branch .EQ. 0) THEN
11957  lac_1_ad = y12_ad
11958  pmp_1_ad = 0.0
11959  ELSE
11960  pmp_1_ad = y12_ad
11961  lac_1_ad = 0.0
11962  END IF
11963  ELSE
11964  IF (branch .EQ. 2) THEN
11965  lac_1_ad = y12_ad
11966  ELSE
11967  lac_1_ad = 0.0
11968  END IF
11969  pmp_1_ad = 0.0
11970  END IF
11971  CALL popcontrol2b(branch)
11972  IF (branch .LT. 2) THEN
11973  IF (branch .EQ. 0) THEN
11974  lac_1_ad = lac_1_ad + x7_ad
11975  ELSE
11976  pmp_1_ad = pmp_1_ad + x7_ad
11977  END IF
11978  ELSE IF (branch .EQ. 2) THEN
11979  lac_1_ad = lac_1_ad + x7_ad
11980  END IF
11981  pmp_1_ad = pmp_1_ad + lac_1_ad
11982  dq_ad(i, j+1) = dq_ad(i, j+1) + 1.5*lac_1_ad
11983  dq_ad(i, j) = dq_ad(i, j) - 2.*pmp_1_ad
11984  END DO
11985  END DO
11986  END IF
11987  ELSE IF (branch .EQ. 2) THEN
11988  DO j=je3,js3,-1
11989  DO i=ie+1,is,-1
11990  CALL popcontrol3b(branch)
11991  IF (branch .LT. 2) THEN
11992  IF (branch .EQ. 0) THEN
11993  GOTO 110
11994  ELSE
11995  y9_ad = br_ad(i, j)
11996  br_ad(i, j) = 0.0
11997  x10_ad = 0.0
11998  END IF
11999  ELSE IF (branch .EQ. 2) THEN
12000  x10_ad = br_ad(i, j)
12001  br_ad(i, j) = 0.0
12002  y9_ad = 0.0
12003  ELSE
12004  IF (branch .NE. 3) THEN
12005  br_ad(i, j) = 0.0
12006  bl_ad(i, j) = 0.0
12007  END IF
12008  GOTO 110
12009  END IF
12010  CALL popcontrol1b(branch)
12011  IF (branch .EQ. 0) THEN
12012  y15_ad = y9_ad
12013  ELSE
12014  br_ad(i, j) = br_ad(i, j) + y9_ad
12015  y15_ad = 0.0
12016  END IF
12017  CALL popcontrol2b(branch)
12018  IF (branch .LT. 2) THEN
12019  IF (branch .EQ. 0) THEN
12020  lac_2_ad = y15_ad
12021  pmp_2_ad = 0.0
12022  ELSE
12023  pmp_2_ad = y15_ad
12024  lac_2_ad = 0.0
12025  END IF
12026  ELSE
12027  IF (branch .EQ. 2) THEN
12028  lac_2_ad = y15_ad
12029  ELSE
12030  lac_2_ad = 0.0
12031  END IF
12032  pmp_2_ad = 0.0
12033  END IF
12034  CALL popcontrol2b(branch)
12035  IF (branch .LT. 2) THEN
12036  IF (branch .EQ. 0) THEN
12037  lac_2_ad = lac_2_ad + x10_ad
12038  ELSE
12039  pmp_2_ad = pmp_2_ad + x10_ad
12040  END IF
12041  ELSE IF (branch .EQ. 2) THEN
12042  lac_2_ad = lac_2_ad + x10_ad
12043  END IF
12044  pmp_2_ad = pmp_2_ad + lac_2_ad
12045  dq_ad(i, j-2) = dq_ad(i, j-2) - 1.5*lac_2_ad
12046  dq_ad(i, j-1) = dq_ad(i, j-1) + 2.*pmp_2_ad
12047  CALL popcontrol1b(branch)
12048  IF (branch .EQ. 0) THEN
12049  y8_ad = bl_ad(i, j)
12050  bl_ad(i, j) = 0.0
12051  x9_ad = 0.0
12052  ELSE
12053  x9_ad = bl_ad(i, j)
12054  bl_ad(i, j) = 0.0
12055  y8_ad = 0.0
12056  END IF
12057  CALL popcontrol1b(branch)
12058  IF (branch .EQ. 0) THEN
12059  y14_ad = y8_ad
12060  ELSE
12061  bl_ad(i, j) = bl_ad(i, j) + y8_ad
12062  y14_ad = 0.0
12063  END IF
12064  CALL popcontrol2b(branch)
12065  IF (branch .LT. 2) THEN
12066  IF (branch .EQ. 0) THEN
12067  lac_1_ad = y14_ad
12068  pmp_1_ad = 0.0
12069  ELSE
12070  pmp_1_ad = y14_ad
12071  lac_1_ad = 0.0
12072  END IF
12073  ELSE
12074  IF (branch .EQ. 2) THEN
12075  lac_1_ad = y14_ad
12076  ELSE
12077  lac_1_ad = 0.0
12078  END IF
12079  pmp_1_ad = 0.0
12080  END IF
12081  CALL popcontrol2b(branch)
12082  IF (branch .LT. 2) THEN
12083  IF (branch .EQ. 0) THEN
12084  lac_1_ad = lac_1_ad + x9_ad
12085  ELSE
12086  pmp_1_ad = pmp_1_ad + x9_ad
12087  END IF
12088  ELSE IF (branch .EQ. 2) THEN
12089  lac_1_ad = lac_1_ad + x9_ad
12090  END IF
12091  pmp_1_ad = pmp_1_ad + lac_1_ad
12092  dq_ad(i, j+1) = dq_ad(i, j+1) + 1.5*lac_1_ad
12093  dq_ad(i, j) = dq_ad(i, j) - 2.*pmp_1_ad
12094  110 al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
12095  v_ad(i, j) = v_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
12096  br_ad(i, j) = 0.0
12097  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
12098  bl_ad(i, j) = 0.0
12099  END DO
12100  END DO
12101  ELSE
12102  DO j=je3,js3,-1
12103  DO i=ie+1,is,-1
12104  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
12105  v_ad(i, j) = v_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
12106  br_ad(i, j) = 0.0
12107  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
12108  bl_ad(i, j) = 0.0
12109  END DO
12110  END DO
12111  END IF
12112  DO j=je3+1,js3,-1
12113  DO i=ie+1,is,-1
12114  v_ad(i, j-1) = v_ad(i, j-1) + 0.5*al_ad(i, j)
12115  v_ad(i, j) = v_ad(i, j) + 0.5*al_ad(i, j)
12116  dm_ad(i, j-1) = dm_ad(i, j-1) + r3*al_ad(i, j)
12117  dm_ad(i, j) = dm_ad(i, j) - r3*al_ad(i, j)
12118  al_ad(i, j) = 0.0
12119  END DO
12120  END DO
12121  END IF
12122  DO j=je+2,js-3,-1
12123  DO i=ie+1,is,-1
12124  v_ad(i, j+1) = v_ad(i, j+1) + dq_ad(i, j)
12125  v_ad(i, j) = v_ad(i, j) - dq_ad(i, j)
12126  dq_ad(i, j) = 0.0
12127  END DO
12128  END DO
12129  DO j=je+2,js-2,-1
12130  DO i=ie+1,is,-1
12131  xt = 0.25*(v(i, j+1)-v(i, j-1))
12132  min3_ad = sign(1.d0, min3*xt)*dm_ad(i, j)
12133  dm_ad(i, j) = 0.0
12134  CALL popcontrol2b(branch)
12135  IF (branch .LT. 2) THEN
12136  IF (branch .EQ. 0) THEN
12137  CALL poprealarray_adm(min3)
12138  z1_ad = min3_ad
12139  y3_ad = 0.0
12140  ELSE
12141  CALL poprealarray_adm(min3)
12142  y3_ad = min3_ad
12143  z1_ad = 0.0
12144  END IF
12145  x4_ad = 0.0
12146  ELSE
12147  IF (branch .EQ. 2) THEN
12148  CALL poprealarray_adm(min3)
12149  z1_ad = min3_ad
12150  x4_ad = 0.0
12151  ELSE
12152  CALL poprealarray_adm(min3)
12153  x4_ad = min3_ad
12154  z1_ad = 0.0
12155  END IF
12156  y3_ad = 0.0
12157  END IF
12158  v_ad(i, j) = v_ad(i, j) + z1_ad
12159  min6_ad = -z1_ad
12160  CALL popcontrol2b(branch)
12161  IF (branch .LT. 2) THEN
12162  IF (branch .EQ. 0) THEN
12163  v_ad(i, j+1) = v_ad(i, j+1) + min6_ad
12164  ELSE
12165  v_ad(i, j) = v_ad(i, j) + min6_ad
12166  END IF
12167  ELSE IF (branch .EQ. 2) THEN
12168  v_ad(i, j+1) = v_ad(i, j+1) + min6_ad
12169  ELSE
12170  v_ad(i, j-1) = v_ad(i, j-1) + min6_ad
12171  END IF
12172  max1_ad = y3_ad
12173  v_ad(i, j) = v_ad(i, j) - y3_ad
12174  CALL popcontrol2b(branch)
12175  IF (branch .LT. 2) THEN
12176  IF (branch .EQ. 0) THEN
12177  v_ad(i, j+1) = v_ad(i, j+1) + max1_ad
12178  ELSE
12179  v_ad(i, j) = v_ad(i, j) + max1_ad
12180  END IF
12181  ELSE IF (branch .EQ. 2) THEN
12182  v_ad(i, j+1) = v_ad(i, j+1) + max1_ad
12183  ELSE
12184  v_ad(i, j-1) = v_ad(i, j-1) + max1_ad
12185  END IF
12186  CALL popcontrol1b(branch)
12187  IF (branch .EQ. 0) THEN
12188  xt_ad = x4_ad
12189  ELSE
12190  xt_ad = -x4_ad
12191  END IF
12192  v_ad(i, j+1) = v_ad(i, j+1) + 0.25*xt_ad
12193  v_ad(i, j-1) = v_ad(i, j-1) - 0.25*xt_ad
12194  END DO
12195  END DO
12196  END IF
12197  CALL popcontrol1b(branch)
12198  END SUBROUTINE ytp_v_adm
12199  SUBROUTINE ytp_v(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, &
12200 & jord, dy, rdy, npx, npy, grid_type, nested)
12201  IMPLICIT NONE
12202  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
12203  INTEGER, INTENT(IN) :: jord
12204  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
12205  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
12206 ! Courant N (like FLUX)
12207  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
12208  REAL, INTENT(OUT) :: flux(is:ie+1, js:je+1)
12209  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
12210  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
12211  INTEGER, INTENT(IN) :: npx, npy, grid_type
12212  LOGICAL, INTENT(IN) :: nested
12213 ! Local:
12214  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
12215  REAL :: fx0(is:ie+1)
12216  REAL :: dm(is:ie+1, js-2:je+2)
12217  REAL :: al(is:ie+1, js-1:je+2)
12218  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
12219  REAL :: dq(is:ie+1, js-3:je+2)
12220  REAL :: xt, dl, dr, pmp, lac, cfl
12221  REAL :: pmp_1, lac_1, pmp_2, lac_2
12222  REAL :: x0, x1, x0r, x0l
12223  INTEGER :: i, j, is1, ie1, js3, je3
12224  INTRINSIC max
12225  INTRINSIC min
12226  INTRINSIC abs
12227  INTRINSIC sign
12228  REAL :: min1
12229  REAL :: min2
12230  REAL :: abs0
12231  REAL :: min3
12232  REAL :: min4
12233  REAL :: min5
12234  REAL :: abs1
12235  REAL :: abs2
12236  REAL :: abs3
12237  REAL :: abs4
12238  REAL :: max1
12239  REAL :: min6
12240  REAL :: abs5
12241  REAL :: abs6
12242  INTEGER :: arg1
12243  REAL :: x12
12244  REAL :: x11
12245  REAL :: x10
12246  REAL :: x9
12247  REAL :: x8
12248  REAL :: x7
12249  REAL :: x6
12250  REAL :: x5
12251  REAL :: x4
12252  REAL :: x3
12253  REAL :: x2
12254  REAL :: y17
12255  REAL :: y16
12256  REAL :: y15
12257  REAL :: y14
12258  REAL :: y13
12259  REAL :: y12
12260  REAL :: y11
12261  REAL :: y10
12262  REAL :: z1
12263  REAL :: y9
12264  REAL :: y8
12265  REAL :: y7
12266  REAL :: y6
12267  REAL :: y5
12268  REAL :: y4
12269  REAL :: y3
12270  REAL :: y2
12271  REAL :: y1
12272  IF (nested .OR. grid_type .GT. 3) THEN
12273  js3 = js - 1
12274  je3 = je + 1
12275  ELSE
12276  IF (3 .LT. js - 1) THEN
12277  js3 = js - 1
12278  ELSE
12279  js3 = 3
12280  END IF
12281  IF (npy - 3 .GT. je + 1) THEN
12282  je3 = je + 1
12283  ELSE
12284  je3 = npy - 3
12285  END IF
12286  END IF
12287  IF (jord .EQ. 1) THEN
12288  DO j=js,je+1
12289  DO i=is,ie+1
12290  IF (c(i, j) .GT. 0.) THEN
12291  flux(i, j) = v(i, j-1)
12292  ELSE
12293  flux(i, j) = v(i, j)
12294  END IF
12295  END DO
12296  END DO
12297  ELSE IF (jord .LT. 8) THEN
12298 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
12299  DO j=js3,je3+1
12300  DO i=is,ie+1
12301  al(i, j) = p1*(v(i, j-1)+v(i, j)) + p2*(v(i, j-2)+v(i, j+1))
12302  END DO
12303  END DO
12304  DO j=js3,je3
12305  DO i=is,ie+1
12306  bl(i, j) = al(i, j) - v(i, j)
12307  br(i, j) = al(i, j+1) - v(i, j)
12308  END DO
12309  END DO
12310  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
12311  IF (js .EQ. 1) THEN
12312  DO i=is,ie+1
12313  bl(i, 0) = c1*v(i, -2) + c2*v(i, -1) + c3*v(i, 0) - v(i, 0)
12314  xt = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
12315 & )/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(&
12316 & i, 1)*v(i, 2))/(dy(i, 1)+dy(i, 2)))
12317  br(i, 0) = xt - v(i, 0)
12318  bl(i, 1) = xt - v(i, 1)
12319  xt = c3*v(i, 1) + c2*v(i, 2) + c1*v(i, 3)
12320  br(i, 1) = xt - v(i, 1)
12321  bl(i, 2) = xt - v(i, 2)
12322  br(i, 2) = al(i, 3) - v(i, 2)
12323  END DO
12324  IF (is .EQ. 1) THEN
12325 ! out
12326  bl(1, 0) = 0.
12327 ! edge
12328  br(1, 0) = 0.
12329 ! edge
12330  bl(1, 1) = 0.
12331 ! in
12332  br(1, 1) = 0.
12333  END IF
12334  IF (ie + 1 .EQ. npx) THEN
12335 ! out
12336  bl(npx, 0) = 0.
12337 ! edge
12338  br(npx, 0) = 0.
12339 ! edge
12340  bl(npx, 1) = 0.
12341 ! in
12342  br(npx, 1) = 0.
12343  END IF
12344  END IF
12345 ! j=2
12346 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
12347  IF (je + 1 .EQ. npy) THEN
12348  DO i=is,ie+1
12349  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
12350  xt = c1*v(i, npy-3) + c2*v(i, npy-2) + c3*v(i, npy-1)
12351  br(i, npy-2) = xt - v(i, npy-2)
12352  bl(i, npy-1) = xt - v(i, npy-1)
12353  xt = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
12354 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+((2.*dy(i&
12355 & , npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)*v(i, npy+1))/(dy&
12356 & (i, npy)+dy(i, npy+1)))
12357  br(i, npy-1) = xt - v(i, npy-1)
12358  bl(i, npy) = xt - v(i, npy)
12359  br(i, npy) = c3*v(i, npy) + c2*v(i, npy+1) + c1*v(i, npy+2) &
12360 & - v(i, npy)
12361  END DO
12362  IF (is .EQ. 1) THEN
12363 ! in
12364  bl(1, npy-1) = 0.
12365 ! edge
12366  br(1, npy-1) = 0.
12367 ! edge
12368  bl(1, npy) = 0.
12369 ! out
12370  br(1, npy) = 0.
12371  END IF
12372  IF (ie + 1 .EQ. npx) THEN
12373 ! in
12374  bl(npx, npy-1) = 0.
12375 ! edge
12376  br(npx, npy-1) = 0.
12377 ! edge
12378  bl(npx, npy) = 0.
12379 ! out
12380  br(npx, npy) = 0.
12381  END IF
12382  END IF
12383  END IF
12384 ! j=npy-2
12385 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
12386  DO j=js-1,je+1
12387  DO i=is,ie+1
12388  b0(i, j) = bl(i, j) + br(i, j)
12389  END DO
12390  END DO
12391  IF (jord .EQ. 2) THEN
12392 ! Perfectly linear
12393  DO j=js,je+1
12394 !DEC$ VECTOR ALWAYS
12395  DO i=is,ie+1
12396  IF (c(i, j) .GT. 0.) THEN
12397  cfl = c(i, j)*rdy(i, j-1)
12398  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-&
12399 & 1))
12400  ELSE
12401  cfl = c(i, j)*rdy(i, j)
12402  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
12403  END IF
12404  END DO
12405  END DO
12406  ELSE IF (jord .EQ. 3) THEN
12407  DO j=js-1,je+1
12408  DO i=is,ie+1
12409  IF (b0(i, j) .GE. 0.) THEN
12410  x0 = b0(i, j)
12411  ELSE
12412  x0 = -b0(i, j)
12413  END IF
12414  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
12415  x1 = bl(i, j) - br(i, j)
12416  ELSE
12417  x1 = -(bl(i, j)-br(i, j))
12418  END IF
12419  smt5(i, j) = x0 .LT. x1
12420  smt6(i, j) = 3.*x0 .LT. x1
12421  END DO
12422  END DO
12423  DO j=js,je+1
12424  DO i=is,ie+1
12425  fx0(i) = 0.
12426  END DO
12427  DO i=is,ie+1
12428  IF (c(i, j) .GT. 0.) THEN
12429  cfl = c(i, j)*rdy(i, j-1)
12430  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
12431  fx0(i) = br(i, j-1) - cfl*b0(i, j-1)
12432  ELSE IF (smt5(i, j-1)) THEN
12433  IF (bl(i, j-1) .GE. 0.) THEN
12434  x2 = bl(i, j-1)
12435  ELSE
12436  x2 = -bl(i, j-1)
12437  END IF
12438  IF (br(i, j-1) .GE. 0.) THEN
12439  y1 = br(i, j-1)
12440  ELSE
12441  y1 = -br(i, j-1)
12442  END IF
12443  IF (x2 .GT. y1) THEN
12444  min1 = y1
12445  ELSE
12446  min1 = x2
12447  END IF
12448 ! piece-wise linear
12449  fx0(i) = sign(min1, br(i, j-1))
12450  END IF
12451  flux(i, j) = v(i, j-1) + (1.-cfl)*fx0(i)
12452  ELSE
12453  cfl = c(i, j)*rdy(i, j)
12454  IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
12455  fx0(i) = bl(i, j) + cfl*b0(i, j)
12456  ELSE IF (smt5(i, j)) THEN
12457  IF (bl(i, j) .GE. 0.) THEN
12458  x3 = bl(i, j)
12459  ELSE
12460  x3 = -bl(i, j)
12461  END IF
12462  IF (br(i, j) .GE. 0.) THEN
12463  y2 = br(i, j)
12464  ELSE
12465  y2 = -br(i, j)
12466  END IF
12467  IF (x3 .GT. y2) THEN
12468  min2 = y2
12469  ELSE
12470  min2 = x3
12471  END IF
12472  fx0(i) = sign(min2, bl(i, j))
12473  END IF
12474  flux(i, j) = v(i, j) + (1.+cfl)*fx0(i)
12475  END IF
12476  END DO
12477  END DO
12478  ELSE IF (jord .EQ. 4) THEN
12479  DO j=js-1,je+1
12480  DO i=is,ie+1
12481  IF (b0(i, j) .GE. 0.) THEN
12482  x0 = b0(i, j)
12483  ELSE
12484  x0 = -b0(i, j)
12485  END IF
12486  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
12487  x1 = bl(i, j) - br(i, j)
12488  ELSE
12489  x1 = -(bl(i, j)-br(i, j))
12490  END IF
12491  smt5(i, j) = x0 .LT. x1
12492  smt6(i, j) = 3.*x0 .LT. x1
12493  END DO
12494  END DO
12495  DO j=js,je+1
12496  DO i=is,ie+1
12497  IF (c(i, j) .GT. 0.) THEN
12498  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
12499  cfl = c(i, j)*rdy(i, j-1)
12500  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, &
12501 & j-1))
12502  ELSE
12503  flux(i, j) = v(i, j-1)
12504  END IF
12505  ELSE IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
12506  cfl = c(i, j)*rdy(i, j)
12507  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
12508  ELSE
12509  flux(i, j) = v(i, j)
12510  END IF
12511  END DO
12512  END DO
12513  ELSE
12514 ! jord = 5,6,7
12515 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
12516  IF (jord .EQ. 5) THEN
12517  DO j=js-1,je+1
12518  DO i=is,ie+1
12519  smt5(i, j) = bl(i, j)*br(i, j) .LT. 0.
12520  END DO
12521  END DO
12522  ELSE
12523 ! ord = 6, 7
12524  DO j=js-1,je+1
12525  DO i=is,ie+1
12526  IF (3.*b0(i, j) .GE. 0.) THEN
12527  abs0 = 3.*b0(i, j)
12528  ELSE
12529  abs0 = -(3.*b0(i, j))
12530  END IF
12531  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
12532  abs4 = bl(i, j) - br(i, j)
12533  ELSE
12534  abs4 = -(bl(i, j)-br(i, j))
12535  END IF
12536  smt5(i, j) = abs0 .LT. abs4
12537  END DO
12538  END DO
12539  END IF
12540  DO j=js,je+1
12541 !DEC$ VECTOR ALWAYS
12542  DO i=is,ie+1
12543  IF (c(i, j) .GT. 0.) THEN
12544  cfl = c(i, j)*rdy(i, j-1)
12545  fx0(i) = (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-1))
12546  flux(i, j) = v(i, j-1)
12547  ELSE
12548  cfl = c(i, j)*rdy(i, j)
12549  fx0(i) = (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
12550  flux(i, j) = v(i, j)
12551  END IF
12552  IF (smt5(i, j-1) .OR. smt5(i, j)) flux(i, j) = flux(i, j) + &
12553 & fx0(i)
12554  END DO
12555  END DO
12556  END IF
12557  ELSE
12558 ! jord= 8, 9, 10
12559  DO j=js-2,je+2
12560  DO i=is,ie+1
12561  xt = 0.25*(v(i, j+1)-v(i, j-1))
12562  IF (xt .GE. 0.) THEN
12563  x4 = xt
12564  ELSE
12565  x4 = -xt
12566  END IF
12567  IF (v(i, j-1) .LT. v(i, j)) THEN
12568  IF (v(i, j) .LT. v(i, j+1)) THEN
12569  max1 = v(i, j+1)
12570  ELSE
12571  max1 = v(i, j)
12572  END IF
12573  ELSE IF (v(i, j-1) .LT. v(i, j+1)) THEN
12574  max1 = v(i, j+1)
12575  ELSE
12576  max1 = v(i, j-1)
12577  END IF
12578  y3 = max1 - v(i, j)
12579  IF (v(i, j-1) .GT. v(i, j)) THEN
12580  IF (v(i, j) .GT. v(i, j+1)) THEN
12581  min6 = v(i, j+1)
12582  ELSE
12583  min6 = v(i, j)
12584  END IF
12585  ELSE IF (v(i, j-1) .GT. v(i, j+1)) THEN
12586  min6 = v(i, j+1)
12587  ELSE
12588  min6 = v(i, j-1)
12589  END IF
12590  z1 = v(i, j) - min6
12591  IF (x4 .GT. y3) THEN
12592  IF (y3 .GT. z1) THEN
12593  min3 = z1
12594  ELSE
12595  min3 = y3
12596  END IF
12597  ELSE IF (x4 .GT. z1) THEN
12598  min3 = z1
12599  ELSE
12600  min3 = x4
12601  END IF
12602  dm(i, j) = sign(min3, xt)
12603  END DO
12604  END DO
12605  DO j=js-3,je+2
12606  DO i=is,ie+1
12607  dq(i, j) = v(i, j+1) - v(i, j)
12608  END DO
12609  END DO
12610  IF (grid_type .LT. 3) THEN
12611  DO j=js3,je3+1
12612  DO i=is,ie+1
12613  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
12614 & )
12615  END DO
12616  END DO
12617  IF (jord .EQ. 8) THEN
12618  DO j=js3,je3
12619  DO i=is,ie+1
12620  xt = 2.*dm(i, j)
12621  IF (xt .GE. 0.) THEN
12622  x5 = xt
12623  ELSE
12624  x5 = -xt
12625  END IF
12626  IF (al(i, j) - v(i, j) .GE. 0.) THEN
12627  y4 = al(i, j) - v(i, j)
12628  ELSE
12629  y4 = -(al(i, j)-v(i, j))
12630  END IF
12631  IF (x5 .GT. y4) THEN
12632  min4 = y4
12633  ELSE
12634  min4 = x5
12635  END IF
12636  bl(i, j) = -sign(min4, xt)
12637  IF (xt .GE. 0.) THEN
12638  x6 = xt
12639  ELSE
12640  x6 = -xt
12641  END IF
12642  IF (al(i, j+1) - v(i, j) .GE. 0.) THEN
12643  y5 = al(i, j+1) - v(i, j)
12644  ELSE
12645  y5 = -(al(i, j+1)-v(i, j))
12646  END IF
12647  IF (x6 .GT. y5) THEN
12648  min5 = y5
12649  ELSE
12650  min5 = x6
12651  END IF
12652  br(i, j) = sign(min5, xt)
12653  END DO
12654  END DO
12655  ELSE IF (jord .EQ. 9) THEN
12656  DO j=js3,je3
12657  DO i=is,ie+1
12658  pmp_1 = -(2.*dq(i, j))
12659  lac_1 = pmp_1 + 1.5*dq(i, j+1)
12660  IF (0. .LT. pmp_1) THEN
12661  IF (pmp_1 .LT. lac_1) THEN
12662  x7 = lac_1
12663  ELSE
12664  x7 = pmp_1
12665  END IF
12666  ELSE IF (0. .LT. lac_1) THEN
12667  x7 = lac_1
12668  ELSE
12669  x7 = 0.
12670  END IF
12671  IF (0. .GT. pmp_1) THEN
12672  IF (pmp_1 .GT. lac_1) THEN
12673  y12 = lac_1
12674  ELSE
12675  y12 = pmp_1
12676  END IF
12677  ELSE IF (0. .GT. lac_1) THEN
12678  y12 = lac_1
12679  ELSE
12680  y12 = 0.
12681  END IF
12682  IF (al(i, j) - v(i, j) .LT. y12) THEN
12683  y6 = y12
12684  ELSE
12685  y6 = al(i, j) - v(i, j)
12686  END IF
12687  IF (x7 .GT. y6) THEN
12688  bl(i, j) = y6
12689  ELSE
12690  bl(i, j) = x7
12691  END IF
12692  pmp_2 = 2.*dq(i, j-1)
12693  lac_2 = pmp_2 - 1.5*dq(i, j-2)
12694  IF (0. .LT. pmp_2) THEN
12695  IF (pmp_2 .LT. lac_2) THEN
12696  x8 = lac_2
12697  ELSE
12698  x8 = pmp_2
12699  END IF
12700  ELSE IF (0. .LT. lac_2) THEN
12701  x8 = lac_2
12702  ELSE
12703  x8 = 0.
12704  END IF
12705  IF (0. .GT. pmp_2) THEN
12706  IF (pmp_2 .GT. lac_2) THEN
12707  y13 = lac_2
12708  ELSE
12709  y13 = pmp_2
12710  END IF
12711  ELSE IF (0. .GT. lac_2) THEN
12712  y13 = lac_2
12713  ELSE
12714  y13 = 0.
12715  END IF
12716  IF (al(i, j+1) - v(i, j) .LT. y13) THEN
12717  y7 = y13
12718  ELSE
12719  y7 = al(i, j+1) - v(i, j)
12720  END IF
12721  IF (x8 .GT. y7) THEN
12722  br(i, j) = y7
12723  ELSE
12724  br(i, j) = x8
12725  END IF
12726  END DO
12727  END DO
12728  ELSE IF (jord .EQ. 10) THEN
12729  DO j=js3,je3
12730  DO i=is,ie+1
12731  bl(i, j) = al(i, j) - v(i, j)
12732  br(i, j) = al(i, j+1) - v(i, j)
12733  IF (dm(i, j) .GE. 0.) THEN
12734  abs1 = dm(i, j)
12735  ELSE
12736  abs1 = -dm(i, j)
12737  END IF
12738 ! if ( abs(dm(i,j-1))+abs(dm(i,j))+abs(dm(i,j+1)) < near_zero ) then
12739  IF (abs1 .LT. near_zero) THEN
12740  IF (dm(i, j-1) .GE. 0.) THEN
12741  abs2 = dm(i, j-1)
12742  ELSE
12743  abs2 = -dm(i, j-1)
12744  END IF
12745  IF (dm(i, j+1) .GE. 0.) THEN
12746  abs5 = dm(i, j+1)
12747  ELSE
12748  abs5 = -dm(i, j+1)
12749  END IF
12750  IF (abs2 + abs5 .LT. near_zero) THEN
12751  bl(i, j) = 0.
12752  br(i, j) = 0.
12753  END IF
12754  ELSE
12755  IF (3.*(bl(i, j)+br(i, j)) .GE. 0.) THEN
12756  abs3 = 3.*(bl(i, j)+br(i, j))
12757  ELSE
12758  abs3 = -(3.*(bl(i, j)+br(i, j)))
12759  END IF
12760  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
12761  abs6 = bl(i, j) - br(i, j)
12762  ELSE
12763  abs6 = -(bl(i, j)-br(i, j))
12764  END IF
12765  IF (abs3 .GT. abs6) THEN
12766  pmp_1 = -(2.*dq(i, j))
12767  lac_1 = pmp_1 + 1.5*dq(i, j+1)
12768  IF (0. .LT. pmp_1) THEN
12769  IF (pmp_1 .LT. lac_1) THEN
12770  x9 = lac_1
12771  ELSE
12772  x9 = pmp_1
12773  END IF
12774  ELSE IF (0. .LT. lac_1) THEN
12775  x9 = lac_1
12776  ELSE
12777  x9 = 0.
12778  END IF
12779  IF (0. .GT. pmp_1) THEN
12780  IF (pmp_1 .GT. lac_1) THEN
12781  y14 = lac_1
12782  ELSE
12783  y14 = pmp_1
12784  END IF
12785  ELSE IF (0. .GT. lac_1) THEN
12786  y14 = lac_1
12787  ELSE
12788  y14 = 0.
12789  END IF
12790  IF (bl(i, j) .LT. y14) THEN
12791  y8 = y14
12792  ELSE
12793  y8 = bl(i, j)
12794  END IF
12795  IF (x9 .GT. y8) THEN
12796  bl(i, j) = y8
12797  ELSE
12798  bl(i, j) = x9
12799  END IF
12800  pmp_2 = 2.*dq(i, j-1)
12801  lac_2 = pmp_2 - 1.5*dq(i, j-2)
12802  IF (0. .LT. pmp_2) THEN
12803  IF (pmp_2 .LT. lac_2) THEN
12804  x10 = lac_2
12805  ELSE
12806  x10 = pmp_2
12807  END IF
12808  ELSE IF (0. .LT. lac_2) THEN
12809  x10 = lac_2
12810  ELSE
12811  x10 = 0.
12812  END IF
12813  IF (0. .GT. pmp_2) THEN
12814  IF (pmp_2 .GT. lac_2) THEN
12815  y15 = lac_2
12816  ELSE
12817  y15 = pmp_2
12818  END IF
12819  ELSE IF (0. .GT. lac_2) THEN
12820  y15 = lac_2
12821  ELSE
12822  y15 = 0.
12823  END IF
12824  IF (br(i, j) .LT. y15) THEN
12825  y9 = y15
12826  ELSE
12827  y9 = br(i, j)
12828  END IF
12829  IF (x10 .GT. y9) THEN
12830  br(i, j) = y9
12831  ELSE
12832  br(i, j) = x10
12833  END IF
12834  END IF
12835  END IF
12836  END DO
12837  END DO
12838  ELSE
12839 ! Unlimited:
12840  DO j=js3,je3
12841  DO i=is,ie+1
12842  bl(i, j) = al(i, j) - v(i, j)
12843  br(i, j) = al(i, j+1) - v(i, j)
12844  END DO
12845  END DO
12846  END IF
12847 !--------------
12848 ! fix the edges
12849 !--------------
12850  IF (js .EQ. 1 .AND. (.NOT.nested)) THEN
12851  DO i=is,ie+1
12852  br(i, 2) = al(i, 3) - v(i, 2)
12853  xt = s15*v(i, 1) + s11*v(i, 2) - s14*dm(i, 2)
12854  br(i, 1) = xt - v(i, 1)
12855  bl(i, 2) = xt - v(i, 2)
12856  bl(i, 0) = s14*dm(i, -1) - s11*dq(i, -1)
12857  x0l = 0.5*((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
12858 & )/(dy(i, 0)+dy(i, -1))
12859  x0r = 0.5*((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(i, 1)*v(i, 2))/&
12860 & (dy(i, 1)+dy(i, 2))
12861  xt = x0l + x0r
12862  bl(i, 1) = xt - v(i, 1)
12863  br(i, 0) = xt - v(i, 0)
12864  END DO
12865  IF (is .EQ. 1) THEN
12866 ! out
12867  bl(1, 0) = 0.
12868 ! edge
12869  br(1, 0) = 0.
12870 ! edge
12871  bl(1, 1) = 0.
12872 ! in
12873  br(1, 1) = 0.
12874  END IF
12875  IF (ie + 1 .EQ. npx) THEN
12876 ! out
12877  bl(npx, 0) = 0.
12878 ! edge
12879  br(npx, 0) = 0.
12880 ! edge
12881  bl(npx, 1) = 0.
12882 ! in
12883  br(npx, 1) = 0.
12884  END IF
12885  j = 2
12886  arg1 = ie - is + 2
12887  CALL pert_ppm(arg1, v(is:ie+1, j), bl(is:ie+1, j), br(is:ie+1&
12888 & , j), -1)
12889  END IF
12890  IF (je + 1 .EQ. npy .AND. (.NOT.nested)) THEN
12891  DO i=is,ie+1
12892  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
12893  xt = s15*v(i, npy-1) + s11*v(i, npy-2) + s14*dm(i, npy-2)
12894  br(i, npy-2) = xt - v(i, npy-2)
12895  bl(i, npy-1) = xt - v(i, npy-1)
12896  br(i, npy) = s11*dq(i, npy) - s14*dm(i, npy+1)
12897  x0l = 0.5*((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
12898 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))
12899  x0r = 0.5*((2.*dy(i, npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)&
12900 & *v(i, npy+1))/(dy(i, npy)+dy(i, npy+1))
12901  xt = x0l + x0r
12902  br(i, npy-1) = xt - v(i, npy-1)
12903  bl(i, npy) = xt - v(i, npy)
12904  END DO
12905  IF (is .EQ. 1) THEN
12906 ! in
12907  bl(1, npy-1) = 0.
12908 ! edge
12909  br(1, npy-1) = 0.
12910 ! edge
12911  bl(1, npy) = 0.
12912 ! out
12913  br(1, npy) = 0.
12914  END IF
12915  IF (ie + 1 .EQ. npx) THEN
12916 ! in
12917  bl(npx, npy-1) = 0.
12918 ! edge
12919  br(npx, npy-1) = 0.
12920 ! edge
12921  bl(npx, npy) = 0.
12922 ! out
12923  br(npx, npy) = 0.
12924  END IF
12925  j = npy - 2
12926  arg1 = ie - is + 2
12927  CALL pert_ppm(arg1, v(is:ie+1, j), bl(is:ie+1, j), br(is:ie+1&
12928 & , j), -1)
12929  END IF
12930  ELSE
12931  DO j=js-1,je+2
12932  DO i=is,ie+1
12933  al(i, j) = 0.5*(v(i, j-1)+v(i, j)) + r3*(dm(i, j-1)-dm(i, j)&
12934 & )
12935  END DO
12936  END DO
12937  DO j=js-1,je+1
12938  DO i=is,ie+1
12939  pmp = 2.*dq(i, j-1)
12940  lac = pmp - 1.5*dq(i, j-2)
12941  IF (0. .LT. pmp) THEN
12942  IF (pmp .LT. lac) THEN
12943  x11 = lac
12944  ELSE
12945  x11 = pmp
12946  END IF
12947  ELSE IF (0. .LT. lac) THEN
12948  x11 = lac
12949  ELSE
12950  x11 = 0.
12951  END IF
12952  IF (0. .GT. pmp) THEN
12953  IF (pmp .GT. lac) THEN
12954  y16 = lac
12955  ELSE
12956  y16 = pmp
12957  END IF
12958  ELSE IF (0. .GT. lac) THEN
12959  y16 = lac
12960  ELSE
12961  y16 = 0.
12962  END IF
12963  IF (al(i, j+1) - v(i, j) .LT. y16) THEN
12964  y10 = y16
12965  ELSE
12966  y10 = al(i, j+1) - v(i, j)
12967  END IF
12968  IF (x11 .GT. y10) THEN
12969  br(i, j) = y10
12970  ELSE
12971  br(i, j) = x11
12972  END IF
12973  pmp = -(2.*dq(i, j))
12974  lac = pmp + 1.5*dq(i, j+1)
12975  IF (0. .LT. pmp) THEN
12976  IF (pmp .LT. lac) THEN
12977  x12 = lac
12978  ELSE
12979  x12 = pmp
12980  END IF
12981  ELSE IF (0. .LT. lac) THEN
12982  x12 = lac
12983  ELSE
12984  x12 = 0.
12985  END IF
12986  IF (0. .GT. pmp) THEN
12987  IF (pmp .GT. lac) THEN
12988  y17 = lac
12989  ELSE
12990  y17 = pmp
12991  END IF
12992  ELSE IF (0. .GT. lac) THEN
12993  y17 = lac
12994  ELSE
12995  y17 = 0.
12996  END IF
12997  IF (al(i, j) - v(i, j) .LT. y17) THEN
12998  y11 = y17
12999  ELSE
13000  y11 = al(i, j) - v(i, j)
13001  END IF
13002  IF (x12 .GT. y11) THEN
13003  bl(i, j) = y11
13004  ELSE
13005  bl(i, j) = x12
13006  END IF
13007  END DO
13008  END DO
13009  END IF
13010  DO j=js,je+1
13011  DO i=is,ie+1
13012  IF (c(i, j) .GT. 0.) THEN
13013  cfl = c(i, j)*rdy(i, j-1)
13014  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*(bl(i, j-1&
13015 & )+br(i, j-1)))
13016  ELSE
13017  cfl = c(i, j)*rdy(i, j)
13018  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*(bl(i, j)+br(i&
13019 & , j)))
13020  END IF
13021  END DO
13022  END DO
13023  END IF
13024  END SUBROUTINE ytp_v
13025 ! Differentiation of d2a2c_vect in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
13026 !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_
13027 !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
13028 !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
13029 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
13030 !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
13031 !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
13032 !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
13033 !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
13034 !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
13035 !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_
13036 !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
13037 !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
13038 !.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
13039 !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_
13040 !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_
13041 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
13042 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
13043 ! gradient of useful results: u v ua uc ut va vc vt
13044 ! with respect to varying inputs: u v ua uc ut va vc vt
13045 !There is a limit to how far this routine can fill uc and vc in the
13046 ! halo, and so either mpp_update_domains or some sort of boundary
13047 ! routine (extrapolation, outflow, interpolation from a nested grid)
13048 ! is needed after c_sw is completed if these variables are needed
13049 ! in the halo
13050  SUBROUTINE d2a2c_vect_fwd(u, v, ua, va, uc, vc, ut, vt, dord4, &
13051 & gridstruct, bd, npx, npy, nested, grid_type)
13052  !USE ISO_C_BINDING
13053  !USE ADMM_TAPENADE_INTERFACE
13054  IMPLICIT NONE
13055  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
13056  LOGICAL, INTENT(IN) :: dord4
13057  REAL, INTENT(IN) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
13058  REAL, INTENT(IN) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed)
13059  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: uc
13060  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: vc
13061  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua, va, ut, vt
13062  INTEGER, INTENT(IN) :: npx, npy, grid_type
13063  LOGICAL, INTENT(IN) :: nested
13064  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
13065 ! Local
13066  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp, vtmp
13067  INTEGER :: npt, i, j, ifirst, ilast, id
13068  INTEGER :: is, ie, js, je
13069  INTEGER :: isd, ied, jsd, jed
13070  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
13071  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
13072  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsin2
13073  REAL, DIMENSION(:, :), POINTER :: dxa, dya
13074  INTRINSIC max
13075  INTRINSIC min
13076  INTEGER :: max1
13077  INTEGER :: max2
13078  INTEGER :: max3
13079  INTEGER :: max4
13080  INTEGER :: max5
13081  INTEGER :: max6
13082  INTEGER :: min1
13083  INTEGER :: min2
13084  INTEGER :: min3
13085  INTEGER :: min4
13086  INTEGER :: min5
13087  INTEGER :: min6
13088  INTEGER :: ad_from
13089  INTEGER :: ad_from0
13090 
13091  utmp = 0.0
13092  vtmp = 0.0
13093  npt = 0
13094  ifirst = 0
13095  ilast = 0
13096  id = 0
13097  is = 0
13098  ie = 0
13099  js = 0
13100  je = 0
13101  isd = 0
13102  ied = 0
13103  jsd = 0
13104  jed = 0
13105  max1 = 0
13106  max2 = 0
13107  max3 = 0
13108  max4 = 0
13109  max5 = 0
13110  max6 = 0
13111  min1 = 0
13112  min2 = 0
13113  min3 = 0
13114  min4 = 0
13115  min5 = 0
13116  min6 = 0
13117  ad_from = 0
13118  ad_from0 = 0
13119 
13120  is = bd%is
13121  ie = bd%ie
13122  js = bd%js
13123  je = bd%je
13124  isd = bd%isd
13125  ied = bd%ied
13126  jsd = bd%jsd
13127  jed = bd%jed
13128  sin_sg => gridstruct%sin_sg
13129  cosa_u => gridstruct%cosa_u
13130  cosa_v => gridstruct%cosa_v
13131  cosa_s => gridstruct%cosa_s
13132  rsin_u => gridstruct%rsin_u
13133  rsin_v => gridstruct%rsin_v
13134  rsin2 => gridstruct%rsin2
13135  dxa => gridstruct%dxa
13136  dya => gridstruct%dya
13137  IF (dord4) THEN
13138  id = 1
13139  ELSE
13140  id = 0
13141  END IF
13142  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
13143  npt = 4
13144  ELSE
13145  npt = -2
13146  END IF
13147 ! Initialize the non-existing corner regions
13148  utmp(:, :) = big_number
13149  vtmp(:, :) = big_number
13150  IF (nested) THEN
13151  DO j=jsd+1,jed-1
13152  DO i=isd,ied
13153  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
13154  END DO
13155  END DO
13156  DO i=isd,ied
13157 !j = jsd
13158  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
13159 !j = jed
13160  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
13161  END DO
13162  DO j=jsd,jed
13163  DO i=isd+1,ied-1
13164  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
13165  END DO
13166 !i = isd
13167  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
13168 !i = ied
13169  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
13170  END DO
13171  DO j=jsd,jed
13172  DO i=isd,ied
13173  CALL pushrealarray(ua(i, j))
13174  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
13175  CALL pushrealarray(va(i, j))
13176  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
13177  END DO
13178  END DO
13179  CALL pushcontrol(1,0)
13180  ELSE
13181  IF (npt .LT. js - 1) THEN
13182  max1 = js - 1
13183  ELSE
13184  max1 = npt
13185  END IF
13186  IF (npy - npt .GT. je + 1) THEN
13187  min1 = je + 1
13188  ELSE
13189  min1 = npy - npt
13190  END IF
13191 !----------
13192 ! Interior:
13193 !----------
13194  DO j=max1,min1
13195  IF (npt .LT. isd) THEN
13196  max2 = isd
13197  ELSE
13198  max2 = npt
13199  END IF
13200  IF (npx - npt .GT. ied) THEN
13201  min2 = ied
13202  ELSE
13203  min2 = npx - npt
13204  END IF
13205  ad_from = max2
13206  DO i=ad_from,min2
13207  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
13208  END DO
13209  CALL pushinteger(i - 1)
13210  CALL pushinteger(ad_from)
13211  END DO
13212  IF (npt .LT. jsd) THEN
13213  max3 = jsd
13214  ELSE
13215  max3 = npt
13216  END IF
13217  IF (npy - npt .GT. jed) THEN
13218  min3 = jed
13219  ELSE
13220  min3 = npy - npt
13221  END IF
13222  DO j=max3,min3
13223  IF (npt .LT. is - 1) THEN
13224  max4 = is - 1
13225  ELSE
13226  max4 = npt
13227  END IF
13228  IF (npx - npt .GT. ie + 1) THEN
13229  min4 = ie + 1
13230  ELSE
13231  min4 = npx - npt
13232  END IF
13233  ad_from0 = max4
13234  DO i=ad_from0,min4
13235  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
13236  END DO
13237  CALL pushinteger(i - 1)
13238  CALL pushinteger(ad_from0)
13239  END DO
13240 !----------
13241 ! edges:
13242 !----------
13243  IF (grid_type .LT. 3) THEN
13244  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
13245  DO j=jsd,npt-1
13246  DO i=isd,ied
13247  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
13248  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
13249  END DO
13250  END DO
13251  CALL pushcontrol(1,0)
13252  ELSE
13253  CALL pushcontrol(1,1)
13254  END IF
13255  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
13256  DO j=npy-npt+1,jed
13257  DO i=isd,ied
13258  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
13259  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
13260  END DO
13261  END DO
13262  CALL pushcontrol(1,0)
13263  ELSE
13264  CALL pushcontrol(1,1)
13265  END IF
13266  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
13267  IF (npt .LT. jsd) THEN
13268  max5 = jsd
13269  ELSE
13270  max5 = npt
13271  END IF
13272  IF (npy - npt .GT. jed) THEN
13273  min5 = jed
13274  ELSE
13275  min5 = npy - npt
13276  END IF
13277  DO j=max5,min5
13278  DO i=isd,npt-1
13279  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
13280  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
13281  END DO
13282  END DO
13283  CALL pushcontrol(1,0)
13284  ELSE
13285  CALL pushcontrol(1,1)
13286  END IF
13287  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
13288  IF (npt .LT. jsd) THEN
13289  CALL pushcontrol(1,1)
13290  max6 = jsd
13291  ELSE
13292  max6 = npt
13293  CALL pushcontrol(1,0)
13294  END IF
13295  IF (npy - npt .GT. jed) THEN
13296  CALL pushcontrol(1,1)
13297  min6 = jed
13298  ELSE
13299  min6 = npy - npt
13300  CALL pushcontrol(1,0)
13301  END IF
13302  DO j=max6,min6
13303  DO i=npx-npt+1,ied
13304  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
13305  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
13306  END DO
13307  END DO
13308  CALL pushcontrol(2,2)
13309  ELSE
13310  CALL pushcontrol(2,1)
13311  END IF
13312  ELSE
13313  CALL pushcontrol(2,0)
13314  END IF
13315 ! Contra-variant components at cell center:
13316  DO j=js-1-id,je+1+id
13317  DO i=is-1-id,ie+1+id
13318  CALL pushrealarray(ua(i, j))
13319  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
13320  CALL pushrealarray(va(i, j))
13321  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
13322  END DO
13323  END DO
13324  CALL pushcontrol(1,1)
13325  END IF
13326 ! A -> C
13327 !--------------
13328 ! Fix the edges
13329 !--------------
13330 ! Xdir:
13331  IF (gridstruct%sw_corner) THEN
13332  DO i=-2,0
13333  utmp(i, 0) = -vtmp(0, 1-i)
13334  END DO
13335  CALL pushcontrol(1,0)
13336  ELSE
13337  CALL pushcontrol(1,1)
13338  END IF
13339  IF (gridstruct%se_corner) THEN
13340  DO i=0,2
13341  utmp(npx+i, 0) = vtmp(npx, i+1)
13342  END DO
13343  CALL pushcontrol(1,0)
13344  ELSE
13345  CALL pushcontrol(1,1)
13346  END IF
13347  IF (gridstruct%ne_corner) THEN
13348  DO i=0,2
13349  utmp(npx+i, npy) = -vtmp(npx, je-i)
13350  END DO
13351  CALL pushcontrol(1,0)
13352  ELSE
13353  CALL pushcontrol(1,1)
13354  END IF
13355  IF (gridstruct%nw_corner) THEN
13356  DO i=-2,0
13357  utmp(i, npy) = vtmp(0, je+i)
13358  END DO
13359  CALL pushcontrol(1,0)
13360  ELSE
13361  CALL pushcontrol(1,1)
13362  END IF
13363  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
13364  IF (3 .LT. is - 1) THEN
13365  ifirst = is - 1
13366  ELSE
13367  ifirst = 3
13368  END IF
13369  IF (npx - 2 .GT. ie + 2) THEN
13370  CALL pushcontrol(1,1)
13371  ilast = ie + 2
13372  ELSE
13373  CALL pushcontrol(1,1)
13374  ilast = npx - 2
13375  END IF
13376  ELSE
13377  CALL pushcontrol(1,0)
13378  ifirst = is - 1
13379  ilast = ie + 2
13380  END IF
13381 !---------------------------------------------
13382 ! 4th order interpolation for interior points:
13383 !---------------------------------------------
13384  DO j=js-1,je+1
13385  DO i=ifirst,ilast
13386  uc(i, j) = a2*(utmp(i-2, j)+utmp(i+1, j)) + a1*(utmp(i-1, j)+&
13387 & utmp(i, j))
13388  CALL pushrealarray(ut(i, j))
13389  ut(i, j) = (uc(i, j)-v(i, j)*cosa_u(i, j))*rsin_u(i, j)
13390  END DO
13391  END DO
13392  IF (grid_type .LT. 3) THEN
13393 ! Xdir:
13394  IF (gridstruct%sw_corner) THEN
13395  CALL pushrealarray(ua(-1, 0))
13396  ua(-1, 0) = -va(0, 2)
13397  CALL pushrealarray(ua(0, 0))
13398  ua(0, 0) = -va(0, 1)
13399  CALL pushcontrol(1,0)
13400  ELSE
13401  CALL pushcontrol(1,1)
13402  END IF
13403  IF (gridstruct%se_corner) THEN
13404  CALL pushrealarray(ua(npx, 0))
13405  ua(npx, 0) = va(npx, 1)
13406  CALL pushrealarray(ua(npx+1, 0))
13407  ua(npx+1, 0) = va(npx, 2)
13408  CALL pushcontrol(1,0)
13409  ELSE
13410  CALL pushcontrol(1,1)
13411  END IF
13412  IF (gridstruct%ne_corner) THEN
13413  CALL pushrealarray(ua(npx, npy))
13414  ua(npx, npy) = -va(npx, npy-1)
13415  CALL pushrealarray(ua(npx+1, npy))
13416  ua(npx+1, npy) = -va(npx, npy-2)
13417  CALL pushcontrol(1,0)
13418  ELSE
13419  CALL pushcontrol(1,1)
13420  END IF
13421  IF (gridstruct%nw_corner) THEN
13422  CALL pushrealarray(ua(-1, npy))
13423  ua(-1, npy) = va(0, npy-2)
13424  CALL pushrealarray(ua(0, npy))
13425  ua(0, npy) = va(0, npy-1)
13426  CALL pushcontrol(1,0)
13427  ELSE
13428  CALL pushcontrol(1,1)
13429  END IF
13430  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
13431  DO j=js-1,je+1
13432  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
13433  CALL pushrealarray(ut(1, j))
13434  ut(1, j) = edge_interpolate4_fwd(ua(-1:2, j), dxa(-1:2, j))
13435 !Want to use the UPSTREAM value
13436  IF (ut(1, j) .GT. 0.) THEN
13437  uc(1, j) = ut(1, j)*sin_sg(0, j, 3)
13438  CALL pushcontrol(1,0)
13439  ELSE
13440  uc(1, j) = ut(1, j)*sin_sg(1, j, 1)
13441  CALL pushcontrol(1,1)
13442  END IF
13443  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
13444  CALL pushrealarray(ut(0, j))
13445  ut(0, j) = (uc(0, j)-v(0, j)*cosa_u(0, j))*rsin_u(0, j)
13446  CALL pushrealarray(ut(2, j))
13447  ut(2, j) = (uc(2, j)-v(2, j)*cosa_u(2, j))*rsin_u(2, j)
13448  END DO
13449  CALL pushcontrol(1,0)
13450  ELSE
13451  CALL pushcontrol(1,1)
13452  END IF
13453  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
13454  DO j=js-1,je+1
13455  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
13456 & (npx-1, j)
13457  CALL pushrealarray(ut(npx, j))
13458  ut(npx, j) = edge_interpolate4_fwd(ua(npx-2:npx+1, j), dxa(npx&
13459 & -2:npx+1, j))
13460  IF (ut(npx, j) .GT. 0.) THEN
13461  uc(npx, j) = ut(npx, j)*sin_sg(npx-1, j, 3)
13462  CALL pushcontrol(1,0)
13463  ELSE
13464  uc(npx, j) = ut(npx, j)*sin_sg(npx, j, 1)
13465  CALL pushcontrol(1,1)
13466  END IF
13467  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
13468 & npx+2, j)
13469  CALL pushrealarray(ut(npx-1, j))
13470  ut(npx-1, j) = (uc(npx-1, j)-v(npx-1, j)*cosa_u(npx-1, j))*&
13471 & rsin_u(npx-1, j)
13472  CALL pushrealarray(ut(npx+1, j))
13473  ut(npx+1, j) = (uc(npx+1, j)-v(npx+1, j)*cosa_u(npx+1, j))*&
13474 & rsin_u(npx+1, j)
13475  END DO
13476  CALL pushcontrol(2,0)
13477  ELSE
13478  CALL pushcontrol(2,1)
13479  END IF
13480  ELSE
13481  CALL pushcontrol(2,2)
13482  END IF
13483 !------
13484 ! Ydir:
13485 !------
13486  IF (gridstruct%sw_corner) THEN
13487  DO j=-2,0
13488  vtmp(0, j) = -utmp(1-j, 0)
13489  END DO
13490  CALL pushcontrol(1,0)
13491  ELSE
13492  CALL pushcontrol(1,1)
13493  END IF
13494  IF (gridstruct%nw_corner) THEN
13495  DO j=0,2
13496  vtmp(0, npy+j) = utmp(j+1, npy)
13497  END DO
13498  CALL pushcontrol(1,0)
13499  ELSE
13500  CALL pushcontrol(1,1)
13501  END IF
13502  IF (gridstruct%se_corner) THEN
13503  DO j=-2,0
13504  vtmp(npx, j) = utmp(ie+j, 0)
13505  END DO
13506  CALL pushcontrol(1,0)
13507  ELSE
13508  CALL pushcontrol(1,1)
13509  END IF
13510  IF (gridstruct%ne_corner) THEN
13511  DO j=0,2
13512  vtmp(npx, npy+j) = -utmp(ie-j, npy)
13513  END DO
13514  CALL pushcontrol(1,0)
13515  ELSE
13516  CALL pushcontrol(1,1)
13517  END IF
13518  IF (gridstruct%sw_corner) THEN
13519  CALL pushrealarray(va(0, -1))
13520  va(0, -1) = -ua(2, 0)
13521  CALL pushrealarray(va(0, 0))
13522  va(0, 0) = -ua(1, 0)
13523  CALL pushcontrol(1,0)
13524  ELSE
13525  CALL pushcontrol(1,1)
13526  END IF
13527  IF (gridstruct%se_corner) THEN
13528  CALL pushrealarray(va(npx, 0))
13529  va(npx, 0) = ua(npx-1, 0)
13530  CALL pushrealarray(va(npx, -1))
13531  va(npx, -1) = ua(npx-2, 0)
13532  CALL pushcontrol(1,0)
13533  ELSE
13534  CALL pushcontrol(1,1)
13535  END IF
13536  IF (gridstruct%ne_corner) THEN
13537  CALL pushrealarray(va(npx, npy))
13538  va(npx, npy) = -ua(npx-1, npy)
13539  CALL pushrealarray(va(npx, npy+1))
13540  va(npx, npy+1) = -ua(npx-2, npy)
13541  CALL pushcontrol(1,0)
13542  ELSE
13543  CALL pushcontrol(1,1)
13544  END IF
13545  IF (gridstruct%nw_corner) THEN
13546  CALL pushrealarray(va(0, npy))
13547  va(0, npy) = ua(1, npy)
13548  CALL pushrealarray(va(0, npy+1))
13549  va(0, npy+1) = ua(2, npy)
13550  CALL pushcontrol(1,0)
13551  ELSE
13552  CALL pushcontrol(1,1)
13553  END IF
13554  IF (grid_type .LT. 3) THEN
13555  DO j=js-1,je+2
13556  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
13557  DO i=is-1,ie+1
13558  CALL pushrealarray(vt(i, j))
13559  vt(i, j) = edge_interpolate4_fwd(va(i, -1:2), dya(i, -1:2))
13560  IF (vt(i, j) .GT. 0.) THEN
13561  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
13562  CALL pushcontrol(1,1)
13563  ELSE
13564  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
13565  CALL pushcontrol(1,0)
13566  END IF
13567  END DO
13568  CALL pushcontrol(3,4)
13569  ELSE IF (j .EQ. 0 .OR. (j .EQ. npy - 1 .AND. (.NOT.nested))) &
13570 & THEN
13571  DO i=is-1,ie+1
13572  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
13573  CALL pushrealarray(vt(i, j))
13574  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
13575  END DO
13576  CALL pushcontrol(3,3)
13577  ELSE IF (j .EQ. 2 .OR. (j .EQ. npy + 1 .AND. (.NOT.nested))) &
13578 & THEN
13579  DO i=is-1,ie+1
13580  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
13581  CALL pushrealarray(vt(i, j))
13582  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
13583  END DO
13584  CALL pushcontrol(3,2)
13585  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
13586  DO i=is-1,ie+1
13587  CALL pushrealarray(vt(i, j))
13588  vt(i, j) = edge_interpolate4_fwd(va(i, j-2:j+1), dya(i, j-2:&
13589 & j+1))
13590  IF (vt(i, j) .GT. 0.) THEN
13591  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
13592  CALL pushcontrol(1,1)
13593  ELSE
13594  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
13595  CALL pushcontrol(1,0)
13596  END IF
13597  END DO
13598  CALL pushcontrol(3,1)
13599  ELSE
13600 ! 4th order interpolation for interior points:
13601  DO i=is-1,ie+1
13602  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
13603 & +vtmp(i, j))
13604  CALL pushrealarray(vt(i, j))
13605  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
13606  END DO
13607  CALL pushcontrol(3,0)
13608  END IF
13609  END DO
13610  CALL pushinteger(npt)
13611  CALL pushinteger(jed)
13612  CALL pushinteger(ifirst)
13613  CALL pushinteger(min6)
13614  CALL pushinteger(je)
13615  CALL pushinteger(min5)
13616  CALL pushinteger(min3)
13617  CALL pushinteger(min1)
13618  CALL pushinteger(is)
13619  CALL pushinteger(isd)
13620  !CALL PUSHPOINTER8(C_LOC(rsin_v))
13621  CALL pushinteger(ie)
13622  CALL pushinteger(id)
13623  !CALL PUSHPOINTER8(C_LOC(dya))
13624  !CALL PUSHPOINTER8(C_LOC(sin_sg))
13625  CALL pushinteger(ied)
13626  CALL pushinteger(ilast)
13627  CALL pushinteger(jsd)
13628  !CALL PUSHPOINTER8(C_LOC(cosa_v))
13629  !CALL PUSHPOINTER8(C_LOC(dxa))
13630  CALL pushinteger(max6)
13631  CALL pushinteger(max5)
13632  CALL pushinteger(max3)
13633  CALL pushinteger(max1)
13634  CALL pushinteger(js)
13635  CALL pushcontrol(1,0)
13636  ELSE
13637 ! 4th order interpolation:
13638  DO j=js-1,je+2
13639  DO i=is-1,ie+1
13640  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
13641 & vtmp(i, j))
13642  CALL pushrealarray(vt(i, j))
13643  vt(i, j) = vc(i, j)
13644  END DO
13645  END DO
13646  CALL pushinteger(npt)
13647  CALL pushinteger(jed)
13648  CALL pushinteger(ifirst)
13649  CALL pushinteger(min6)
13650  CALL pushinteger(je)
13651  CALL pushinteger(min5)
13652  CALL pushinteger(min3)
13653  CALL pushinteger(min1)
13654  CALL pushinteger(is)
13655  CALL pushinteger(isd)
13656  CALL pushinteger(ie)
13657  CALL pushinteger(id)
13658  !CALL PUSHPOINTER8(C_LOC(sin_sg))
13659  CALL pushinteger(ied)
13660  CALL pushinteger(ilast)
13661  CALL pushinteger(jsd)
13662  !CALL PUSHPOINTER8(C_LOC(dxa))
13663  CALL pushinteger(max6)
13664  CALL pushinteger(max5)
13665  CALL pushinteger(max3)
13666  CALL pushinteger(max1)
13667  CALL pushinteger(js)
13668  CALL pushcontrol(1,1)
13669  END IF
13670  END SUBROUTINE d2a2c_vect_fwd
13671 ! Differentiation of d2a2c_vect in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
13672 !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_core
13673 !_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.
13674 !mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleig
13675 !h_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_or
13676 !d4 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.r
13677 !emap_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
13678 !fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
13679 ! 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_
13680 !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_subgr
13681 !id_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
13682 !_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_m
13683 !od.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mo
13684 !d.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.d
13685 !2a2c_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
13686 !_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
13687 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
13688 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
13689 ! gradient of useful results: u v ua uc ut va vc vt
13690 ! with respect to varying inputs: u v ua uc ut va vc vt
13691 !There is a limit to how far this routine can fill uc and vc in the
13692 ! halo, and so either mpp_update_domains or some sort of boundary
13693 ! routine (extrapolation, outflow, interpolation from a nested grid)
13694 ! is needed after c_sw is completed if these variables are needed
13695 ! in the halo
13696  SUBROUTINE d2a2c_vect_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, va_ad, uc, &
13697 & uc_ad, vc, vc_ad, ut, ut_ad, vt, vt_ad, dord4, gridstruct, bd, npx, &
13698 & npy, nested, grid_type)
13699  !USE ISO_C_BINDING
13700  !USE ADMM_TAPENADE_INTERFACE
13701  IMPLICIT NONE
13702  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
13703  LOGICAL, INTENT(IN) :: dord4
13704  REAL, INTENT(IN) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
13705  REAL :: u_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
13706  REAL, INTENT(IN) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed)
13707  REAL :: v_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
13708  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: uc
13709  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: uc_ad
13710  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: vc
13711  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: vc_ad
13712  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua, va, ut, vt
13713  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua_ad, va_ad, ut_ad&
13714 & , vt_ad
13715  INTEGER, INTENT(IN) :: npx, npy, grid_type
13716  LOGICAL, INTENT(IN) :: nested
13717  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
13718  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp, vtmp
13719  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp_ad, vtmp_ad
13720  INTEGER :: npt, i, j, ifirst, ilast, id
13721  INTEGER :: is, ie, js, je
13722  INTEGER :: isd, ied, jsd, jed
13723  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
13724  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
13725  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsin2
13726  REAL, DIMENSION(:, :), POINTER :: dxa, dya
13727  INTRINSIC max
13728  INTRINSIC min
13729  INTEGER :: max1
13730  INTEGER :: max2
13731  INTEGER :: max3
13732  INTEGER :: max4
13733  INTEGER :: max5
13734  INTEGER :: max6
13735  INTEGER :: min1
13736  INTEGER :: min2
13737  INTEGER :: min3
13738  INTEGER :: min4
13739  INTEGER :: min5
13740  INTEGER :: min6
13741  REAL :: temp_ad
13742  REAL :: temp_ad0
13743  REAL :: temp_ad1
13744  REAL :: temp_ad2
13745  REAL :: temp_ad3
13746  REAL :: temp_ad4
13747  REAL :: temp_ad5
13748  REAL :: temp_ad6
13749  REAL :: temp_ad7
13750  REAL :: temp_ad8
13751  REAL :: temp_ad9
13752  REAL :: temp_ad10
13753  INTEGER :: ad_from
13754  INTEGER :: ad_to
13755  INTEGER :: ad_from0
13756  INTEGER :: ad_to0
13757  INTEGER :: branch
13758  !TYPE(C_PTR) :: cptr
13759  !INTEGER :: unknown_shape_in_d2a2c_vect
13760 
13761  utmp = 0.0
13762  vtmp = 0.0
13763  npt = 0
13764  ifirst = 0
13765  ilast = 0
13766  id = 0
13767  is = 0
13768  ie = 0
13769  js = 0
13770  je = 0
13771  isd = 0
13772  ied = 0
13773  jsd = 0
13774  jed = 0
13775  max1 = 0
13776  max2 = 0
13777  max3 = 0
13778  max4 = 0
13779  max5 = 0
13780  max6 = 0
13781  min1 = 0
13782  min2 = 0
13783  min3 = 0
13784  min4 = 0
13785  min5 = 0
13786  min6 = 0
13787  ad_from = 0
13788  ad_from0 = 0
13789  ad_to = 0
13790  ad_to0 = 0
13791  branch = 0
13792 
13793  is = bd%is
13794  ie = bd%ie
13795  js = bd%js
13796  je = bd%je
13797  isd = bd%isd
13798  ied = bd%ied
13799  jsd = bd%jsd
13800  jed = bd%jed
13801  sin_sg => gridstruct%sin_sg
13802  cosa_u => gridstruct%cosa_u
13803  cosa_v => gridstruct%cosa_v
13804  cosa_s => gridstruct%cosa_s
13805  rsin_u => gridstruct%rsin_u
13806  rsin_v => gridstruct%rsin_v
13807  rsin2 => gridstruct%rsin2
13808  dxa => gridstruct%dxa
13809  dya => gridstruct%dya
13810  IF (dord4) THEN
13811  id = 1
13812  ELSE
13813  id = 0
13814  END IF
13815  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
13816  npt = 4
13817  ELSE
13818  npt = -2
13819  END IF
13820  CALL popcontrol(1,branch)
13821  IF (branch .EQ. 0) THEN
13822  CALL popinteger(js)
13823  CALL popinteger(max1)
13824  CALL popinteger(max3)
13825  CALL popinteger(max5)
13826  CALL popinteger(max6)
13827  !CALL POPPOINTER8(cptr)
13828  dxa => gridstruct%dxa ! (/unknown_shape_in_d2a2c_vect/))
13829  !CALL POPPOINTER8(cptr)
13830  cosa_v => gridstruct%cosa_v ! (/unknown_shape_in_d2a2c_vect/))
13831  CALL popinteger(jsd)
13832  CALL popinteger(ilast)
13833  CALL popinteger(ied)
13834  !CALL POPPOINTER8(cptr)
13835  sin_sg => gridstruct%sin_sg ! (/unknown_shape_in_d2a2c_vect/))
13836  !CALL POPPOINTER8(cptr)
13837  dya => gridstruct%dya ! (/unknown_shape_in_d2a2c_vect/))
13838  CALL popinteger(id)
13839  CALL popinteger(ie)
13840  !CALL POPPOINTER8(cptr)
13841  rsin_v => gridstruct%rsin_v ! (/unknown_shape_in_d2a2c_vect/))
13842  CALL popinteger(isd)
13843  CALL popinteger(is)
13844  CALL popinteger(min1)
13845  CALL popinteger(min3)
13846  CALL popinteger(min5)
13847  CALL popinteger(je)
13848  CALL popinteger(min6)
13849  CALL popinteger(ifirst)
13850  CALL popinteger(jed)
13851  CALL popinteger(npt)
13852  vtmp_ad = 0.0
13853  DO j=je+2,js-1,-1
13854  CALL popcontrol(3,branch)
13855  IF (branch .LT. 2) THEN
13856  IF (branch .EQ. 0) THEN
13857  DO i=ie+1,is-1,-1
13858  CALL poprealarray(vt(i, j))
13859  temp_ad10 = rsin_v(i, j)*vt_ad(i, j)
13860  vc_ad(i, j) = vc_ad(i, j) + temp_ad10
13861  u_ad(i, j) = u_ad(i, j) - cosa_v(i, j)*temp_ad10
13862  vt_ad(i, j) = 0.0
13863  vtmp_ad(i, j-2) = vtmp_ad(i, j-2) + a2*vc_ad(i, j)
13864  vtmp_ad(i, j+1) = vtmp_ad(i, j+1) + a2*vc_ad(i, j)
13865  vtmp_ad(i, j-1) = vtmp_ad(i, j-1) + a1*vc_ad(i, j)
13866  vtmp_ad(i, j) = vtmp_ad(i, j) + a1*vc_ad(i, j)
13867  vc_ad(i, j) = 0.0
13868  END DO
13869  ELSE
13870  DO i=ie+1,is-1,-1
13871  CALL popcontrol(1,branch)
13872  IF (branch .EQ. 0) THEN
13873  vt_ad(i, j) = vt_ad(i, j) + sin_sg(i, j, 2)*vc_ad(i, j)
13874  vc_ad(i, j) = 0.0
13875  ELSE
13876  vt_ad(i, j) = vt_ad(i, j) + sin_sg(i, j-1, 4)*vc_ad(i, j&
13877 & )
13878  vc_ad(i, j) = 0.0
13879  END IF
13880  CALL edge_interpolate4_bwd(va(i, j-2:j+1), va_ad(i, j-2:j+&
13881 & 1), dya(i, j-2:j+1), vt_ad(i, j))
13882  vt_ad(i, j) = 0.0
13883  CALL poprealarray(vt(i, j))
13884  END DO
13885  END IF
13886  ELSE IF (branch .EQ. 2) THEN
13887  DO i=ie+1,is-1,-1
13888  CALL poprealarray(vt(i, j))
13889  temp_ad9 = rsin_v(i, j)*vt_ad(i, j)
13890  vc_ad(i, j) = vc_ad(i, j) + temp_ad9
13891  u_ad(i, j) = u_ad(i, j) - cosa_v(i, j)*temp_ad9
13892  vt_ad(i, j) = 0.0
13893  vtmp_ad(i, j+1) = vtmp_ad(i, j+1) + c1*vc_ad(i, j)
13894  vtmp_ad(i, j) = vtmp_ad(i, j) + c2*vc_ad(i, j)
13895  vtmp_ad(i, j-1) = vtmp_ad(i, j-1) + c3*vc_ad(i, j)
13896  vc_ad(i, j) = 0.0
13897  END DO
13898  ELSE IF (branch .EQ. 3) THEN
13899  DO i=ie+1,is-1,-1
13900  CALL poprealarray(vt(i, j))
13901  temp_ad8 = rsin_v(i, j)*vt_ad(i, j)
13902  vc_ad(i, j) = vc_ad(i, j) + temp_ad8
13903  u_ad(i, j) = u_ad(i, j) - cosa_v(i, j)*temp_ad8
13904  vt_ad(i, j) = 0.0
13905  vtmp_ad(i, j-2) = vtmp_ad(i, j-2) + c1*vc_ad(i, j)
13906  vtmp_ad(i, j-1) = vtmp_ad(i, j-1) + c2*vc_ad(i, j)
13907  vtmp_ad(i, j) = vtmp_ad(i, j) + c3*vc_ad(i, j)
13908  vc_ad(i, j) = 0.0
13909  END DO
13910  ELSE
13911  DO i=ie+1,is-1,-1
13912  CALL popcontrol(1,branch)
13913  IF (branch .EQ. 0) THEN
13914  vt_ad(i, j) = vt_ad(i, j) + sin_sg(i, j, 2)*vc_ad(i, j)
13915  vc_ad(i, j) = 0.0
13916  ELSE
13917  vt_ad(i, j) = vt_ad(i, j) + sin_sg(i, j-1, 4)*vc_ad(i, j)
13918  vc_ad(i, j) = 0.0
13919  END IF
13920  CALL edge_interpolate4_bwd(va(i, -1:2), va_ad(i, -1:2), dya(&
13921 & i, -1:2), vt_ad(i, j))
13922  vt_ad(i, j) = 0.0
13923  CALL poprealarray(vt(i, j))
13924  END DO
13925  END IF
13926  END DO
13927  ELSE
13928  CALL popinteger(js)
13929  CALL popinteger(max1)
13930  CALL popinteger(max3)
13931  CALL popinteger(max5)
13932  CALL popinteger(max6)
13933  !CALL POPPOINTER8(cptr)
13934  dxa => gridstruct%dxa ! (/unknown_shape_in_d2a2c_vect/))
13935  CALL popinteger(jsd)
13936  CALL popinteger(ilast)
13937  CALL popinteger(ied)
13938  !CALL POPPOINTER8(cptr)
13939  sin_sg => gridstruct%sin_sg ! (/unknown_shape_in_d2a2c_vect/))
13940  CALL popinteger(id)
13941  CALL popinteger(ie)
13942  CALL popinteger(isd)
13943  CALL popinteger(is)
13944  CALL popinteger(min1)
13945  CALL popinteger(min3)
13946  CALL popinteger(min5)
13947  CALL popinteger(je)
13948  CALL popinteger(min6)
13949  CALL popinteger(ifirst)
13950  CALL popinteger(jed)
13951  CALL popinteger(npt)
13952  vtmp_ad = 0.0
13953  DO j=je+2,js-1,-1
13954  DO i=ie+1,is-1,-1
13955  CALL poprealarray(vt(i, j))
13956  vc_ad(i, j) = vc_ad(i, j) + vt_ad(i, j)
13957  vt_ad(i, j) = 0.0
13958  vtmp_ad(i, j-2) = vtmp_ad(i, j-2) + a2*vc_ad(i, j)
13959  vtmp_ad(i, j+1) = vtmp_ad(i, j+1) + a2*vc_ad(i, j)
13960  vtmp_ad(i, j-1) = vtmp_ad(i, j-1) + a1*vc_ad(i, j)
13961  vtmp_ad(i, j) = vtmp_ad(i, j) + a1*vc_ad(i, j)
13962  vc_ad(i, j) = 0.0
13963  END DO
13964  END DO
13965  END IF
13966  CALL popcontrol(1,branch)
13967  IF (branch .EQ. 0) THEN
13968  CALL poprealarray(va(0, npy+1))
13969  ua_ad(2, npy) = ua_ad(2, npy) + va_ad(0, npy+1)
13970  va_ad(0, npy+1) = 0.0
13971  CALL poprealarray(va(0, npy))
13972  ua_ad(1, npy) = ua_ad(1, npy) + va_ad(0, npy)
13973  va_ad(0, npy) = 0.0
13974  END IF
13975  CALL popcontrol(1,branch)
13976  IF (branch .EQ. 0) THEN
13977  CALL poprealarray(va(npx, npy+1))
13978  ua_ad(npx-2, npy) = ua_ad(npx-2, npy) - va_ad(npx, npy+1)
13979  va_ad(npx, npy+1) = 0.0
13980  CALL poprealarray(va(npx, npy))
13981  ua_ad(npx-1, npy) = ua_ad(npx-1, npy) - va_ad(npx, npy)
13982  va_ad(npx, npy) = 0.0
13983  END IF
13984  CALL popcontrol(1,branch)
13985  IF (branch .EQ. 0) THEN
13986  CALL poprealarray(va(npx, -1))
13987  ua_ad(npx-2, 0) = ua_ad(npx-2, 0) + va_ad(npx, -1)
13988  va_ad(npx, -1) = 0.0
13989  CALL poprealarray(va(npx, 0))
13990  ua_ad(npx-1, 0) = ua_ad(npx-1, 0) + va_ad(npx, 0)
13991  va_ad(npx, 0) = 0.0
13992  END IF
13993  CALL popcontrol(1,branch)
13994  IF (branch .EQ. 0) THEN
13995  CALL poprealarray(va(0, 0))
13996  ua_ad(1, 0) = ua_ad(1, 0) - va_ad(0, 0)
13997  va_ad(0, 0) = 0.0
13998  CALL poprealarray(va(0, -1))
13999  ua_ad(2, 0) = ua_ad(2, 0) - va_ad(0, -1)
14000  va_ad(0, -1) = 0.0
14001  END IF
14002  CALL popcontrol(1,branch)
14003  IF (branch .EQ. 0) THEN
14004  utmp_ad = 0.0
14005  DO j=2,0,-1
14006  utmp_ad(ie-j, npy) = utmp_ad(ie-j, npy) - vtmp_ad(npx, npy+j)
14007  vtmp_ad(npx, npy+j) = 0.0
14008  END DO
14009  ELSE
14010  utmp_ad = 0.0
14011  END IF
14012  CALL popcontrol(1,branch)
14013  IF (branch .EQ. 0) THEN
14014  DO j=0,-2,-1
14015  utmp_ad(ie+j, 0) = utmp_ad(ie+j, 0) + vtmp_ad(npx, j)
14016  vtmp_ad(npx, j) = 0.0
14017  END DO
14018  END IF
14019  CALL popcontrol(1,branch)
14020  IF (branch .EQ. 0) THEN
14021  DO j=2,0,-1
14022  utmp_ad(j+1, npy) = utmp_ad(j+1, npy) + vtmp_ad(0, npy+j)
14023  vtmp_ad(0, npy+j) = 0.0
14024  END DO
14025  END IF
14026  CALL popcontrol(1,branch)
14027  IF (branch .EQ. 0) THEN
14028  DO j=0,-2,-1
14029  utmp_ad(1-j, 0) = utmp_ad(1-j, 0) - vtmp_ad(0, j)
14030  vtmp_ad(0, j) = 0.0
14031  END DO
14032  END IF
14033  cosa_u => gridstruct%cosa_u
14034  rsin_u => gridstruct%rsin_u
14035  CALL popcontrol(2,branch)
14036  IF (branch .EQ. 0) THEN
14037  DO j=je+1,js-1,-1
14038  CALL poprealarray(ut(npx+1, j))
14039  temp_ad6 = rsin_u(npx+1, j)*ut_ad(npx+1, j)
14040  uc_ad(npx+1, j) = uc_ad(npx+1, j) + temp_ad6
14041  v_ad(npx+1, j) = v_ad(npx+1, j) - cosa_u(npx+1, j)*temp_ad6
14042  ut_ad(npx+1, j) = 0.0
14043  CALL poprealarray(ut(npx-1, j))
14044  temp_ad7 = rsin_u(npx-1, j)*ut_ad(npx-1, j)
14045  uc_ad(npx-1, j) = uc_ad(npx-1, j) + temp_ad7
14046  v_ad(npx-1, j) = v_ad(npx-1, j) - cosa_u(npx-1, j)*temp_ad7
14047  ut_ad(npx-1, j) = 0.0
14048  utmp_ad(npx, j) = utmp_ad(npx, j) + c3*uc_ad(npx+1, j)
14049  utmp_ad(npx+1, j) = utmp_ad(npx+1, j) + c2*uc_ad(npx+1, j)
14050  utmp_ad(npx+2, j) = utmp_ad(npx+2, j) + c1*uc_ad(npx+1, j)
14051  uc_ad(npx+1, j) = 0.0
14052  CALL popcontrol(1,branch)
14053  IF (branch .EQ. 0) THEN
14054  ut_ad(npx, j) = ut_ad(npx, j) + sin_sg(npx-1, j, 3)*uc_ad(npx&
14055 & , j)
14056  uc_ad(npx, j) = 0.0
14057  ELSE
14058  ut_ad(npx, j) = ut_ad(npx, j) + sin_sg(npx, j, 1)*uc_ad(npx, j&
14059 & )
14060  uc_ad(npx, j) = 0.0
14061  END IF
14062  CALL edge_interpolate4_bwd(ua(npx-2:npx+1, j), ua_ad(npx-2:npx+1&
14063 & , j), dxa(npx-2:npx+1, j), ut_ad(npx, j))
14064  ut_ad(npx, j) = 0.0
14065  CALL poprealarray(ut(npx, j))
14066  utmp_ad(npx-3, j) = utmp_ad(npx-3, j) + c1*uc_ad(npx-1, j)
14067  utmp_ad(npx-2, j) = utmp_ad(npx-2, j) + c2*uc_ad(npx-1, j)
14068  utmp_ad(npx-1, j) = utmp_ad(npx-1, j) + c3*uc_ad(npx-1, j)
14069  uc_ad(npx-1, j) = 0.0
14070  END DO
14071  ELSE IF (branch .NE. 1) THEN
14072  GOTO 100
14073  END IF
14074  CALL popcontrol(1,branch)
14075  IF (branch .EQ. 0) THEN
14076  DO j=je+1,js-1,-1
14077  CALL poprealarray(ut(2, j))
14078  temp_ad4 = rsin_u(2, j)*ut_ad(2, j)
14079  uc_ad(2, j) = uc_ad(2, j) + temp_ad4
14080  v_ad(2, j) = v_ad(2, j) - cosa_u(2, j)*temp_ad4
14081  ut_ad(2, j) = 0.0
14082  CALL poprealarray(ut(0, j))
14083  temp_ad5 = rsin_u(0, j)*ut_ad(0, j)
14084  uc_ad(0, j) = uc_ad(0, j) + temp_ad5
14085  v_ad(0, j) = v_ad(0, j) - cosa_u(0, j)*temp_ad5
14086  ut_ad(0, j) = 0.0
14087  utmp_ad(3, j) = utmp_ad(3, j) + c1*uc_ad(2, j)
14088  utmp_ad(2, j) = utmp_ad(2, j) + c2*uc_ad(2, j)
14089  utmp_ad(1, j) = utmp_ad(1, j) + c3*uc_ad(2, j)
14090  uc_ad(2, j) = 0.0
14091  CALL popcontrol(1,branch)
14092  IF (branch .EQ. 0) THEN
14093  ut_ad(1, j) = ut_ad(1, j) + sin_sg(0, j, 3)*uc_ad(1, j)
14094  uc_ad(1, j) = 0.0
14095  ELSE
14096  ut_ad(1, j) = ut_ad(1, j) + sin_sg(1, j, 1)*uc_ad(1, j)
14097  uc_ad(1, j) = 0.0
14098  END IF
14099  CALL edge_interpolate4_bwd(ua(-1:2, j), ua_ad(-1:2, j), dxa(-1:2&
14100 & , j), ut_ad(1, j))
14101  ut_ad(1, j) = 0.0
14102  CALL poprealarray(ut(1, j))
14103  utmp_ad(-2, j) = utmp_ad(-2, j) + c1*uc_ad(0, j)
14104  utmp_ad(-1, j) = utmp_ad(-1, j) + c2*uc_ad(0, j)
14105  utmp_ad(0, j) = utmp_ad(0, j) + c3*uc_ad(0, j)
14106  uc_ad(0, j) = 0.0
14107  END DO
14108  END IF
14109  CALL popcontrol(1,branch)
14110  IF (branch .EQ. 0) THEN
14111  CALL poprealarray(ua(0, npy))
14112  va_ad(0, npy-1) = va_ad(0, npy-1) + ua_ad(0, npy)
14113  ua_ad(0, npy) = 0.0
14114  CALL poprealarray(ua(-1, npy))
14115  va_ad(0, npy-2) = va_ad(0, npy-2) + ua_ad(-1, npy)
14116  ua_ad(-1, npy) = 0.0
14117  END IF
14118  CALL popcontrol(1,branch)
14119  IF (branch .EQ. 0) THEN
14120  CALL poprealarray(ua(npx+1, npy))
14121  va_ad(npx, npy-2) = va_ad(npx, npy-2) - ua_ad(npx+1, npy)
14122  ua_ad(npx+1, npy) = 0.0
14123  CALL poprealarray(ua(npx, npy))
14124  va_ad(npx, npy-1) = va_ad(npx, npy-1) - ua_ad(npx, npy)
14125  ua_ad(npx, npy) = 0.0
14126  END IF
14127  CALL popcontrol(1,branch)
14128  IF (branch .EQ. 0) THEN
14129  CALL poprealarray(ua(npx+1, 0))
14130  va_ad(npx, 2) = va_ad(npx, 2) + ua_ad(npx+1, 0)
14131  ua_ad(npx+1, 0) = 0.0
14132  CALL poprealarray(ua(npx, 0))
14133  va_ad(npx, 1) = va_ad(npx, 1) + ua_ad(npx, 0)
14134  ua_ad(npx, 0) = 0.0
14135  END IF
14136  CALL popcontrol(1,branch)
14137  IF (branch .EQ. 0) THEN
14138  CALL poprealarray(ua(0, 0))
14139  va_ad(0, 1) = va_ad(0, 1) - ua_ad(0, 0)
14140  ua_ad(0, 0) = 0.0
14141  CALL poprealarray(ua(-1, 0))
14142  va_ad(0, 2) = va_ad(0, 2) - ua_ad(-1, 0)
14143  ua_ad(-1, 0) = 0.0
14144  END IF
14145  100 DO j=je+1,js-1,-1
14146  DO i=ilast,ifirst,-1
14147  CALL poprealarray(ut(i, j))
14148  temp_ad3 = rsin_u(i, j)*ut_ad(i, j)
14149  uc_ad(i, j) = uc_ad(i, j) + temp_ad3
14150  v_ad(i, j) = v_ad(i, j) - cosa_u(i, j)*temp_ad3
14151  ut_ad(i, j) = 0.0
14152  utmp_ad(i-2, j) = utmp_ad(i-2, j) + a2*uc_ad(i, j)
14153  utmp_ad(i+1, j) = utmp_ad(i+1, j) + a2*uc_ad(i, j)
14154  utmp_ad(i-1, j) = utmp_ad(i-1, j) + a1*uc_ad(i, j)
14155  utmp_ad(i, j) = utmp_ad(i, j) + a1*uc_ad(i, j)
14156  uc_ad(i, j) = 0.0
14157  END DO
14158  END DO
14159  CALL popcontrol(1,branch)
14160  CALL popcontrol(1,branch)
14161  IF (branch .EQ. 0) THEN
14162  DO i=0,-2,-1
14163  vtmp_ad(0, je+i) = vtmp_ad(0, je+i) + utmp_ad(i, npy)
14164  utmp_ad(i, npy) = 0.0
14165  END DO
14166  END IF
14167  CALL popcontrol(1,branch)
14168  IF (branch .EQ. 0) THEN
14169  DO i=2,0,-1
14170  vtmp_ad(npx, je-i) = vtmp_ad(npx, je-i) - utmp_ad(npx+i, npy)
14171  utmp_ad(npx+i, npy) = 0.0
14172  END DO
14173  END IF
14174  CALL popcontrol(1,branch)
14175  IF (branch .EQ. 0) THEN
14176  DO i=2,0,-1
14177  vtmp_ad(npx, i+1) = vtmp_ad(npx, i+1) + utmp_ad(npx+i, 0)
14178  utmp_ad(npx+i, 0) = 0.0
14179  END DO
14180  END IF
14181  CALL popcontrol(1,branch)
14182  IF (branch .EQ. 0) THEN
14183  DO i=0,-2,-1
14184  vtmp_ad(0, 1-i) = vtmp_ad(0, 1-i) - utmp_ad(i, 0)
14185  utmp_ad(i, 0) = 0.0
14186  END DO
14187  END IF
14188  rsin2 => gridstruct%rsin2
14189  cosa_s => gridstruct%cosa_s
14190  CALL popcontrol(1,branch)
14191  IF (branch .EQ. 0) THEN
14192  DO j=jed,jsd,-1
14193  DO i=ied,isd,-1
14194  temp_ad0 = rsin2(i, j)*ua_ad(i, j)
14195  CALL poprealarray(va(i, j))
14196  temp_ad = rsin2(i, j)*va_ad(i, j)
14197  vtmp_ad(i, j) = vtmp_ad(i, j) + temp_ad - cosa_s(i, j)*&
14198 & temp_ad0
14199  utmp_ad(i, j) = utmp_ad(i, j) + temp_ad0 - cosa_s(i, j)*&
14200 & temp_ad
14201  va_ad(i, j) = 0.0
14202  CALL poprealarray(ua(i, j))
14203  ua_ad(i, j) = 0.0
14204  END DO
14205  END DO
14206  DO j=jed,jsd,-1
14207  v_ad(ied, j) = v_ad(ied, j) + 0.5*vtmp_ad(ied, j)
14208  v_ad(ied+1, j) = v_ad(ied+1, j) + 0.5*vtmp_ad(ied, j)
14209  vtmp_ad(ied, j) = 0.0
14210  v_ad(isd, j) = v_ad(isd, j) + 0.5*vtmp_ad(isd, j)
14211  v_ad(isd+1, j) = v_ad(isd+1, j) + 0.5*vtmp_ad(isd, j)
14212  vtmp_ad(isd, j) = 0.0
14213  DO i=ied-1,isd+1,-1
14214  v_ad(i-1, j) = v_ad(i-1, j) + a2*vtmp_ad(i, j)
14215  v_ad(i+2, j) = v_ad(i+2, j) + a2*vtmp_ad(i, j)
14216  v_ad(i, j) = v_ad(i, j) + a1*vtmp_ad(i, j)
14217  v_ad(i+1, j) = v_ad(i+1, j) + a1*vtmp_ad(i, j)
14218  vtmp_ad(i, j) = 0.0
14219  END DO
14220  END DO
14221  DO i=ied,isd,-1
14222  u_ad(i, jed) = u_ad(i, jed) + 0.5*utmp_ad(i, jed)
14223  u_ad(i, jed+1) = u_ad(i, jed+1) + 0.5*utmp_ad(i, jed)
14224  utmp_ad(i, jed) = 0.0
14225  u_ad(i, jsd) = u_ad(i, jsd) + 0.5*utmp_ad(i, jsd)
14226  u_ad(i, jsd+1) = u_ad(i, jsd+1) + 0.5*utmp_ad(i, jsd)
14227  utmp_ad(i, jsd) = 0.0
14228  END DO
14229  DO j=jed-1,jsd+1,-1
14230  DO i=ied,isd,-1
14231  u_ad(i, j-1) = u_ad(i, j-1) + a2*utmp_ad(i, j)
14232  u_ad(i, j+2) = u_ad(i, j+2) + a2*utmp_ad(i, j)
14233  u_ad(i, j) = u_ad(i, j) + a1*utmp_ad(i, j)
14234  u_ad(i, j+1) = u_ad(i, j+1) + a1*utmp_ad(i, j)
14235  utmp_ad(i, j) = 0.0
14236  END DO
14237  END DO
14238  ELSE
14239  DO j=je+id+1,js-1-id,-1
14240  DO i=ie+id+1,is-1-id,-1
14241  temp_ad2 = rsin2(i, j)*ua_ad(i, j)
14242  CALL poprealarray(va(i, j))
14243  temp_ad1 = rsin2(i, j)*va_ad(i, j)
14244  vtmp_ad(i, j) = vtmp_ad(i, j) + temp_ad1 - cosa_s(i, j)*&
14245 & temp_ad2
14246  utmp_ad(i, j) = utmp_ad(i, j) + temp_ad2 - cosa_s(i, j)*&
14247 & temp_ad1
14248  va_ad(i, j) = 0.0
14249  CALL poprealarray(ua(i, j))
14250  ua_ad(i, j) = 0.0
14251  END DO
14252  END DO
14253  CALL popcontrol(2,branch)
14254  IF (branch .NE. 0) THEN
14255  IF (branch .NE. 1) THEN
14256  DO j=min6,max6,-1
14257  DO i=ied,npx-npt+1,-1
14258  v_ad(i, j) = v_ad(i, j) + 0.5*vtmp_ad(i, j)
14259  v_ad(i+1, j) = v_ad(i+1, j) + 0.5*vtmp_ad(i, j)
14260  vtmp_ad(i, j) = 0.0
14261  u_ad(i, j) = u_ad(i, j) + 0.5*utmp_ad(i, j)
14262  u_ad(i, j+1) = u_ad(i, j+1) + 0.5*utmp_ad(i, j)
14263  utmp_ad(i, j) = 0.0
14264  END DO
14265  END DO
14266  CALL popcontrol(1,branch)
14267  IF (branch .EQ. 0) jed = bd%jed
14268  CALL popcontrol(1,branch)
14269  IF (branch .EQ. 0) jsd = bd%jsd
14270  END IF
14271  isd = bd%isd
14272  CALL popcontrol(1,branch)
14273  IF (branch .EQ. 0) THEN
14274  DO j=min5,max5,-1
14275  DO i=npt-1,isd,-1
14276  v_ad(i, j) = v_ad(i, j) + 0.5*vtmp_ad(i, j)
14277  v_ad(i+1, j) = v_ad(i+1, j) + 0.5*vtmp_ad(i, j)
14278  vtmp_ad(i, j) = 0.0
14279  u_ad(i, j) = u_ad(i, j) + 0.5*utmp_ad(i, j)
14280  u_ad(i, j+1) = u_ad(i, j+1) + 0.5*utmp_ad(i, j)
14281  utmp_ad(i, j) = 0.0
14282  END DO
14283  END DO
14284  END IF
14285  CALL popcontrol(1,branch)
14286  IF (branch .EQ. 0) THEN
14287  DO j=jed,npy-npt+1,-1
14288  DO i=ied,isd,-1
14289  v_ad(i, j) = v_ad(i, j) + 0.5*vtmp_ad(i, j)
14290  v_ad(i+1, j) = v_ad(i+1, j) + 0.5*vtmp_ad(i, j)
14291  vtmp_ad(i, j) = 0.0
14292  u_ad(i, j) = u_ad(i, j) + 0.5*utmp_ad(i, j)
14293  u_ad(i, j+1) = u_ad(i, j+1) + 0.5*utmp_ad(i, j)
14294  utmp_ad(i, j) = 0.0
14295  END DO
14296  END DO
14297  END IF
14298  CALL popcontrol(1,branch)
14299  IF (branch .EQ. 0) THEN
14300  DO j=npt-1,jsd,-1
14301  DO i=ied,isd,-1
14302  v_ad(i, j) = v_ad(i, j) + 0.5*vtmp_ad(i, j)
14303  v_ad(i+1, j) = v_ad(i+1, j) + 0.5*vtmp_ad(i, j)
14304  vtmp_ad(i, j) = 0.0
14305  u_ad(i, j) = u_ad(i, j) + 0.5*utmp_ad(i, j)
14306  u_ad(i, j+1) = u_ad(i, j+1) + 0.5*utmp_ad(i, j)
14307  utmp_ad(i, j) = 0.0
14308  END DO
14309  END DO
14310  END IF
14311  END IF
14312  DO j=min3,max3,-1
14313  CALL popinteger(ad_from0)
14314  CALL popinteger(ad_to0)
14315  DO i=ad_to0,ad_from0,-1
14316  v_ad(i-1, j) = v_ad(i-1, j) + a2*vtmp_ad(i, j)
14317  v_ad(i+2, j) = v_ad(i+2, j) + a2*vtmp_ad(i, j)
14318  v_ad(i, j) = v_ad(i, j) + a1*vtmp_ad(i, j)
14319  v_ad(i+1, j) = v_ad(i+1, j) + a1*vtmp_ad(i, j)
14320  vtmp_ad(i, j) = 0.0
14321  END DO
14322  END DO
14323  DO j=min1,max1,-1
14324  CALL popinteger(ad_from)
14325  CALL popinteger(ad_to)
14326  DO i=ad_to,ad_from,-1
14327  u_ad(i, j-1) = u_ad(i, j-1) + a2*utmp_ad(i, j)
14328  u_ad(i, j+2) = u_ad(i, j+2) + a2*utmp_ad(i, j)
14329  u_ad(i, j) = u_ad(i, j) + a1*utmp_ad(i, j)
14330  u_ad(i, j+1) = u_ad(i, j+1) + a1*utmp_ad(i, j)
14331  utmp_ad(i, j) = 0.0
14332  END DO
14333  END DO
14334  END IF
14335  END SUBROUTINE d2a2c_vect_bwd
14336 !There is a limit to how far this routine can fill uc and vc in the
14337 ! halo, and so either mpp_update_domains or some sort of boundary
14338 ! routine (extrapolation, outflow, interpolation from a nested grid)
14339 ! is needed after c_sw is completed if these variables are needed
14340 ! in the halo
14341  SUBROUTINE d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct&
14342 & , bd, npx, npy, nested, grid_type)
14343  IMPLICIT NONE
14344  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
14345  LOGICAL, INTENT(IN) :: dord4
14346  REAL, INTENT(IN) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
14347  REAL, INTENT(IN) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed)
14348  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(OUT) :: uc
14349  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(OUT) :: vc
14350  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(OUT) :: ua, va&
14351 & , ut, vt
14352  INTEGER, INTENT(IN) :: npx, npy, grid_type
14353  LOGICAL, INTENT(IN) :: nested
14354  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
14355 ! Local
14356  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: utmp, vtmp
14357  INTEGER :: npt, i, j, ifirst, ilast, id
14358  INTEGER :: is, ie, js, je
14359  INTEGER :: isd, ied, jsd, jed
14360  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
14361  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
14362  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsin2
14363  REAL, DIMENSION(:, :), POINTER :: dxa, dya
14364  INTRINSIC max
14365  INTRINSIC min
14366  INTEGER :: max1
14367  INTEGER :: max2
14368  INTEGER :: max3
14369  INTEGER :: max4
14370  INTEGER :: max5
14371  INTEGER :: max6
14372  INTEGER :: min1
14373  INTEGER :: min2
14374  INTEGER :: min3
14375  INTEGER :: min4
14376  INTEGER :: min5
14377  INTEGER :: min6
14378  is = bd%is
14379  ie = bd%ie
14380  js = bd%js
14381  je = bd%je
14382  isd = bd%isd
14383  ied = bd%ied
14384  jsd = bd%jsd
14385  jed = bd%jed
14386  sin_sg => gridstruct%sin_sg
14387  cosa_u => gridstruct%cosa_u
14388  cosa_v => gridstruct%cosa_v
14389  cosa_s => gridstruct%cosa_s
14390  rsin_u => gridstruct%rsin_u
14391  rsin_v => gridstruct%rsin_v
14392  rsin2 => gridstruct%rsin2
14393  dxa => gridstruct%dxa
14394  dya => gridstruct%dya
14395  IF (dord4) THEN
14396  id = 1
14397  ELSE
14398  id = 0
14399  END IF
14400  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
14401  npt = 4
14402  ELSE
14403  npt = -2
14404  END IF
14405 ! Initialize the non-existing corner regions
14406  utmp(:, :) = big_number
14407  vtmp(:, :) = big_number
14408  IF (nested) THEN
14409  DO j=jsd+1,jed-1
14410  DO i=isd,ied
14411  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
14412  END DO
14413  END DO
14414  DO i=isd,ied
14415 !j = jsd
14416  utmp(i, jsd) = 0.5*(u(i, jsd)+u(i, jsd+1))
14417 !j = jed
14418  utmp(i, jed) = 0.5*(u(i, jed)+u(i, jed+1))
14419  END DO
14420  DO j=jsd,jed
14421  DO i=isd+1,ied-1
14422  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
14423  END DO
14424 !i = isd
14425  vtmp(isd, j) = 0.5*(v(isd, j)+v(isd+1, j))
14426 !i = ied
14427  vtmp(ied, j) = 0.5*(v(ied, j)+v(ied+1, j))
14428  END DO
14429  DO j=jsd,jed
14430  DO i=isd,ied
14431  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
14432  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
14433  END DO
14434  END DO
14435  ELSE
14436  IF (npt .LT. js - 1) THEN
14437  max1 = js - 1
14438  ELSE
14439  max1 = npt
14440  END IF
14441  IF (npy - npt .GT. je + 1) THEN
14442  min1 = je + 1
14443  ELSE
14444  min1 = npy - npt
14445  END IF
14446 !----------
14447 ! Interior:
14448 !----------
14449  DO j=max1,min1
14450  IF (npt .LT. isd) THEN
14451  max2 = isd
14452  ELSE
14453  max2 = npt
14454  END IF
14455  IF (npx - npt .GT. ied) THEN
14456  min2 = ied
14457  ELSE
14458  min2 = npx - npt
14459  END IF
14460  DO i=max2,min2
14461  utmp(i, j) = a2*(u(i, j-1)+u(i, j+2)) + a1*(u(i, j)+u(i, j+1))
14462  END DO
14463  END DO
14464  IF (npt .LT. jsd) THEN
14465  max3 = jsd
14466  ELSE
14467  max3 = npt
14468  END IF
14469  IF (npy - npt .GT. jed) THEN
14470  min3 = jed
14471  ELSE
14472  min3 = npy - npt
14473  END IF
14474  DO j=max3,min3
14475  IF (npt .LT. is - 1) THEN
14476  max4 = is - 1
14477  ELSE
14478  max4 = npt
14479  END IF
14480  IF (npx - npt .GT. ie + 1) THEN
14481  min4 = ie + 1
14482  ELSE
14483  min4 = npx - npt
14484  END IF
14485  DO i=max4,min4
14486  vtmp(i, j) = a2*(v(i-1, j)+v(i+2, j)) + a1*(v(i, j)+v(i+1, j))
14487  END DO
14488  END DO
14489 !----------
14490 ! edges:
14491 !----------
14492  IF (grid_type .LT. 3) THEN
14493  IF (js .EQ. 1 .OR. jsd .LT. npt) THEN
14494  DO j=jsd,npt-1
14495  DO i=isd,ied
14496  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
14497  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
14498  END DO
14499  END DO
14500  END IF
14501  IF (je + 1 .EQ. npy .OR. jed .GE. npy - npt) THEN
14502  DO j=npy-npt+1,jed
14503  DO i=isd,ied
14504  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
14505  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
14506  END DO
14507  END DO
14508  END IF
14509  IF (is .EQ. 1 .OR. isd .LT. npt) THEN
14510  IF (npt .LT. jsd) THEN
14511  max5 = jsd
14512  ELSE
14513  max5 = npt
14514  END IF
14515  IF (npy - npt .GT. jed) THEN
14516  min5 = jed
14517  ELSE
14518  min5 = npy - npt
14519  END IF
14520  DO j=max5,min5
14521  DO i=isd,npt-1
14522  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
14523  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
14524  END DO
14525  END DO
14526  END IF
14527  IF (ie + 1 .EQ. npx .OR. ied .GE. npx - npt) THEN
14528  IF (npt .LT. jsd) THEN
14529  max6 = jsd
14530  ELSE
14531  max6 = npt
14532  END IF
14533  IF (npy - npt .GT. jed) THEN
14534  min6 = jed
14535  ELSE
14536  min6 = npy - npt
14537  END IF
14538  DO j=max6,min6
14539  DO i=npx-npt+1,ied
14540  utmp(i, j) = 0.5*(u(i, j)+u(i, j+1))
14541  vtmp(i, j) = 0.5*(v(i, j)+v(i+1, j))
14542  END DO
14543  END DO
14544  END IF
14545  END IF
14546 ! Contra-variant components at cell center:
14547  DO j=js-1-id,je+1+id
14548  DO i=is-1-id,ie+1+id
14549  ua(i, j) = (utmp(i, j)-vtmp(i, j)*cosa_s(i, j))*rsin2(i, j)
14550  va(i, j) = (vtmp(i, j)-utmp(i, j)*cosa_s(i, j))*rsin2(i, j)
14551  END DO
14552  END DO
14553  END IF
14554 ! A -> C
14555 !--------------
14556 ! Fix the edges
14557 !--------------
14558 ! Xdir:
14559  IF (gridstruct%sw_corner) THEN
14560  DO i=-2,0
14561  utmp(i, 0) = -vtmp(0, 1-i)
14562  END DO
14563  END IF
14564  IF (gridstruct%se_corner) THEN
14565  DO i=0,2
14566  utmp(npx+i, 0) = vtmp(npx, i+1)
14567  END DO
14568  END IF
14569  IF (gridstruct%ne_corner) THEN
14570  DO i=0,2
14571  utmp(npx+i, npy) = -vtmp(npx, je-i)
14572  END DO
14573  END IF
14574  IF (gridstruct%nw_corner) THEN
14575  DO i=-2,0
14576  utmp(i, npy) = vtmp(0, je+i)
14577  END DO
14578  END IF
14579  IF (grid_type .LT. 3 .AND. (.NOT.nested)) THEN
14580  IF (3 .LT. is - 1) THEN
14581  ifirst = is - 1
14582  ELSE
14583  ifirst = 3
14584  END IF
14585  IF (npx - 2 .GT. ie + 2) THEN
14586  ilast = ie + 2
14587  ELSE
14588  ilast = npx - 2
14589  END IF
14590  ELSE
14591  ifirst = is - 1
14592  ilast = ie + 2
14593  END IF
14594 !---------------------------------------------
14595 ! 4th order interpolation for interior points:
14596 !---------------------------------------------
14597  DO j=js-1,je+1
14598  DO i=ifirst,ilast
14599  uc(i, j) = a2*(utmp(i-2, j)+utmp(i+1, j)) + a1*(utmp(i-1, j)+&
14600 & utmp(i, j))
14601  ut(i, j) = (uc(i, j)-v(i, j)*cosa_u(i, j))*rsin_u(i, j)
14602  END DO
14603  END DO
14604  IF (grid_type .LT. 3) THEN
14605 ! Xdir:
14606  IF (gridstruct%sw_corner) THEN
14607  ua(-1, 0) = -va(0, 2)
14608  ua(0, 0) = -va(0, 1)
14609  END IF
14610  IF (gridstruct%se_corner) THEN
14611  ua(npx, 0) = va(npx, 1)
14612  ua(npx+1, 0) = va(npx, 2)
14613  END IF
14614  IF (gridstruct%ne_corner) THEN
14615  ua(npx, npy) = -va(npx, npy-1)
14616  ua(npx+1, npy) = -va(npx, npy-2)
14617  END IF
14618  IF (gridstruct%nw_corner) THEN
14619  ua(-1, npy) = va(0, npy-2)
14620  ua(0, npy) = va(0, npy-1)
14621  END IF
14622  IF (is .EQ. 1 .AND. (.NOT.nested)) THEN
14623  DO j=js-1,je+1
14624  uc(0, j) = c1*utmp(-2, j) + c2*utmp(-1, j) + c3*utmp(0, j)
14625  ut(1, j) = edge_interpolate4(ua(-1:2, j), dxa(-1:2, j))
14626 !Want to use the UPSTREAM value
14627  IF (ut(1, j) .GT. 0.) THEN
14628  uc(1, j) = ut(1, j)*sin_sg(0, j, 3)
14629  ELSE
14630  uc(1, j) = ut(1, j)*sin_sg(1, j, 1)
14631  END IF
14632  uc(2, j) = c1*utmp(3, j) + c2*utmp(2, j) + c3*utmp(1, j)
14633  ut(0, j) = (uc(0, j)-v(0, j)*cosa_u(0, j))*rsin_u(0, j)
14634  ut(2, j) = (uc(2, j)-v(2, j)*cosa_u(2, j))*rsin_u(2, j)
14635  END DO
14636  END IF
14637  IF (ie + 1 .EQ. npx .AND. (.NOT.nested)) THEN
14638  DO j=js-1,je+1
14639  uc(npx-1, j) = c1*utmp(npx-3, j) + c2*utmp(npx-2, j) + c3*utmp&
14640 & (npx-1, j)
14641  ut(npx, j) = edge_interpolate4(ua(npx-2:npx+1, j), dxa(npx-2:&
14642 & npx+1, j))
14643  IF (ut(npx, j) .GT. 0.) THEN
14644  uc(npx, j) = ut(npx, j)*sin_sg(npx-1, j, 3)
14645  ELSE
14646  uc(npx, j) = ut(npx, j)*sin_sg(npx, j, 1)
14647  END IF
14648  uc(npx+1, j) = c3*utmp(npx, j) + c2*utmp(npx+1, j) + c1*utmp(&
14649 & npx+2, j)
14650  ut(npx-1, j) = (uc(npx-1, j)-v(npx-1, j)*cosa_u(npx-1, j))*&
14651 & rsin_u(npx-1, j)
14652  ut(npx+1, j) = (uc(npx+1, j)-v(npx+1, j)*cosa_u(npx+1, j))*&
14653 & rsin_u(npx+1, j)
14654  END DO
14655  END IF
14656  END IF
14657 !------
14658 ! Ydir:
14659 !------
14660  IF (gridstruct%sw_corner) THEN
14661  DO j=-2,0
14662  vtmp(0, j) = -utmp(1-j, 0)
14663  END DO
14664  END IF
14665  IF (gridstruct%nw_corner) THEN
14666  DO j=0,2
14667  vtmp(0, npy+j) = utmp(j+1, npy)
14668  END DO
14669  END IF
14670  IF (gridstruct%se_corner) THEN
14671  DO j=-2,0
14672  vtmp(npx, j) = utmp(ie+j, 0)
14673  END DO
14674  END IF
14675  IF (gridstruct%ne_corner) THEN
14676  DO j=0,2
14677  vtmp(npx, npy+j) = -utmp(ie-j, npy)
14678  END DO
14679  END IF
14680  IF (gridstruct%sw_corner) THEN
14681  va(0, -1) = -ua(2, 0)
14682  va(0, 0) = -ua(1, 0)
14683  END IF
14684  IF (gridstruct%se_corner) THEN
14685  va(npx, 0) = ua(npx-1, 0)
14686  va(npx, -1) = ua(npx-2, 0)
14687  END IF
14688  IF (gridstruct%ne_corner) THEN
14689  va(npx, npy) = -ua(npx-1, npy)
14690  va(npx, npy+1) = -ua(npx-2, npy)
14691  END IF
14692  IF (gridstruct%nw_corner) THEN
14693  va(0, npy) = ua(1, npy)
14694  va(0, npy+1) = ua(2, npy)
14695  END IF
14696  IF (grid_type .LT. 3) THEN
14697  DO j=js-1,je+2
14698  IF (j .EQ. 1 .AND. (.NOT.nested)) THEN
14699  DO i=is-1,ie+1
14700  vt(i, j) = edge_interpolate4(va(i, -1:2), dya(i, -1:2))
14701  IF (vt(i, j) .GT. 0.) THEN
14702  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
14703  ELSE
14704  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
14705  END IF
14706  END DO
14707  ELSE IF (j .EQ. 0 .OR. (j .EQ. npy - 1 .AND. (.NOT.nested))) &
14708 & THEN
14709  DO i=is-1,ie+1
14710  vc(i, j) = c1*vtmp(i, j-2) + c2*vtmp(i, j-1) + c3*vtmp(i, j)
14711  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
14712  END DO
14713  ELSE IF (j .EQ. 2 .OR. (j .EQ. npy + 1 .AND. (.NOT.nested))) &
14714 & THEN
14715  DO i=is-1,ie+1
14716  vc(i, j) = c1*vtmp(i, j+1) + c2*vtmp(i, j) + c3*vtmp(i, j-1)
14717  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
14718  END DO
14719  ELSE IF (j .EQ. npy .AND. (.NOT.nested)) THEN
14720  DO i=is-1,ie+1
14721  vt(i, j) = edge_interpolate4(va(i, j-2:j+1), dya(i, j-2:j+1)&
14722 & )
14723  IF (vt(i, j) .GT. 0.) THEN
14724  vc(i, j) = vt(i, j)*sin_sg(i, j-1, 4)
14725  ELSE
14726  vc(i, j) = vt(i, j)*sin_sg(i, j, 2)
14727  END IF
14728  END DO
14729  ELSE
14730 ! 4th order interpolation for interior points:
14731  DO i=is-1,ie+1
14732  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)&
14733 & +vtmp(i, j))
14734  vt(i, j) = (vc(i, j)-u(i, j)*cosa_v(i, j))*rsin_v(i, j)
14735  END DO
14736  END IF
14737  END DO
14738  ELSE
14739 ! 4th order interpolation:
14740  DO j=js-1,je+2
14741  DO i=is-1,ie+1
14742  vc(i, j) = a2*(vtmp(i, j-2)+vtmp(i, j+1)) + a1*(vtmp(i, j-1)+&
14743 & vtmp(i, j))
14744  vt(i, j) = vc(i, j)
14745  END DO
14746  END DO
14747  END IF
14748  END SUBROUTINE d2a2c_vect
14749 ! Differentiation of edge_interpolate4 in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b
14750 !_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
14751 !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
14752 !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
14753 !ayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.
14754 !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
14755 !_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
14756 !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
14757 !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
14758 !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
14759 !_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
14760 !_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
14761 !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
14762 !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
14763 !_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
14764 !.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
14765 !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
14766 !d_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
14767 ! gradient of useful results: ua edge_interpolate4
14768 ! with respect to varying inputs: ua
14769  REAL FUNCTION edge_interpolate4_fwd(ua, dxa)
14770  IMPLICIT NONE
14771  REAL, INTENT(IN) :: ua(4)
14772  REAL, INTENT(IN) :: dxa(4)
14773  REAL :: t1, t2
14774  REAL :: edge_interpolate4
14775  t1 = dxa(1) + dxa(2)
14776  t2 = dxa(3) + dxa(4)
14777  edge_interpolate4 = 0.5*(((t1+dxa(2))*ua(2)-dxa(2)*ua(1))/t1+((t2+&
14778 & dxa(3))*ua(3)-dxa(3)*ua(4))/t2)
14779  edge_interpolate4_fwd = edge_interpolate4
14780  END FUNCTION edge_interpolate4_fwd
14781 ! Differentiation of edge_interpolate4 in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2
14782 !b_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 d
14783 !yn_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_co
14784 !re_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.
14785 !Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod
14786 !.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_map
14787 !z_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.re
14788 !map_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_l
14789 !imiters 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_cu
14790 !bic 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.f
14791 !v_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 n
14792 !h_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_
14793 !utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_u
14794 !tils_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_cor
14795 !e_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_mo
14796 !d.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
14797 !tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gr
14798 !id_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
14799 ! gradient of useful results: ua edge_interpolate4
14800 ! with respect to varying inputs: ua
14801  SUBROUTINE edge_interpolate4_bwd(ua, ua_ad, dxa, edge_interpolate4_ad)
14802  IMPLICIT NONE
14803  REAL, INTENT(IN) :: ua(4)
14804  REAL :: ua_ad(4)
14805  REAL, INTENT(IN) :: dxa(4)
14806  REAL :: t1, t2
14807  REAL :: temp_ad
14808  REAL :: edge_interpolate4_ad
14809  REAL :: edge_interpolate4
14810  t1 = dxa(1) + dxa(2)
14811  t2 = dxa(3) + dxa(4)
14812  temp_ad = 0.5*edge_interpolate4_ad
14813  ua_ad(2) = ua_ad(2) + (t1+dxa(2))*temp_ad/t1
14814  ua_ad(1) = ua_ad(1) - dxa(2)*temp_ad/t1
14815  ua_ad(3) = ua_ad(3) + (t2+dxa(3))*temp_ad/t2
14816  ua_ad(4) = ua_ad(4) - dxa(3)*temp_ad/t2
14817  END SUBROUTINE edge_interpolate4_bwd
14818  REAL FUNCTION edge_interpolate4(ua, dxa)
14819  IMPLICIT NONE
14820  REAL, INTENT(IN) :: ua(4)
14821  REAL, INTENT(IN) :: dxa(4)
14822  REAL :: t1, t2
14823  t1 = dxa(1) + dxa(2)
14824  t2 = dxa(3) + dxa(4)
14825  edge_interpolate4 = 0.5*(((t1+dxa(2))*ua(2)-dxa(2)*ua(1))/t1+((t2+&
14826 & dxa(3))*ua(3)-dxa(3)*ua(4))/t2)
14827  END FUNCTION edge_interpolate4
14828  SUBROUTINE fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, &
14829 & se_corner, ne_corner, nw_corner)
14830  IMPLICIT NONE
14831  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
14832 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
14833 ! 1: x-dir; 2: y-dir
14834  INTEGER, INTENT(IN) :: dir
14835  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
14836  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
14837  REAL, INTENT(INOUT) :: q3(bd%isd:bd%ied, bd%jsd:bd%jed)
14838  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
14839  INTEGER, INTENT(IN) :: npx, npy
14840  INTEGER :: i, j
14841  INTEGER :: is, ie, js, je
14842  INTEGER :: isd, ied, jsd, jed
14843  is = bd%is
14844  ie = bd%ie
14845  js = bd%js
14846  je = bd%je
14847  isd = bd%isd
14848  ied = bd%ied
14849  jsd = bd%jsd
14850  jed = bd%jed
14851  SELECT CASE (dir)
14852  CASE (1)
14853  IF (sw_corner) THEN
14854  q1(-1, 0) = q1(0, 2)
14855  q1(0, 0) = q1(0, 1)
14856  q1(0, -1) = q1(-1, 1)
14857  q2(-1, 0) = q2(0, 2)
14858  q2(0, 0) = q2(0, 1)
14859  q2(0, -1) = q2(-1, 1)
14860  q3(-1, 0) = q3(0, 2)
14861  q3(0, 0) = q3(0, 1)
14862  q3(0, -1) = q3(-1, 1)
14863  END IF
14864  IF (se_corner) THEN
14865  q1(npx+1, 0) = q1(npx, 2)
14866  q1(npx, 0) = q1(npx, 1)
14867  q1(npx, -1) = q1(npx+1, 1)
14868  q2(npx+1, 0) = q2(npx, 2)
14869  q2(npx, 0) = q2(npx, 1)
14870  q2(npx, -1) = q2(npx+1, 1)
14871  q3(npx+1, 0) = q3(npx, 2)
14872  q3(npx, 0) = q3(npx, 1)
14873  q3(npx, -1) = q3(npx+1, 1)
14874  END IF
14875  IF (ne_corner) THEN
14876  q1(npx, npy) = q1(npx, npy-1)
14877  q1(npx+1, npy) = q1(npx, npy-2)
14878  q1(npx, npy+1) = q1(npx+1, npy-1)
14879  q2(npx, npy) = q2(npx, npy-1)
14880  q2(npx+1, npy) = q2(npx, npy-2)
14881  q2(npx, npy+1) = q2(npx+1, npy-1)
14882  q3(npx, npy) = q3(npx, npy-1)
14883  q3(npx+1, npy) = q3(npx, npy-2)
14884  q3(npx, npy+1) = q3(npx+1, npy-1)
14885  END IF
14886  IF (nw_corner) THEN
14887  q1(0, npy) = q1(0, npy-1)
14888  q1(-1, npy) = q1(0, npy-2)
14889  q1(0, npy+1) = q1(-1, npy-1)
14890  q2(0, npy) = q2(0, npy-1)
14891  q2(-1, npy) = q2(0, npy-2)
14892  q2(0, npy+1) = q2(-1, npy-1)
14893  q3(0, npy) = q3(0, npy-1)
14894  q3(-1, npy) = q3(0, npy-2)
14895  q3(0, npy+1) = q3(-1, npy-1)
14896  END IF
14897  CASE (2)
14898  IF (sw_corner) THEN
14899  q1(0, 0) = q1(1, 0)
14900  q1(0, -1) = q1(2, 0)
14901  q1(-1, 0) = q1(1, -1)
14902  q2(0, 0) = q2(1, 0)
14903  q2(0, -1) = q2(2, 0)
14904  q2(-1, 0) = q2(1, -1)
14905  q3(0, 0) = q3(1, 0)
14906  q3(0, -1) = q3(2, 0)
14907  q3(-1, 0) = q3(1, -1)
14908  END IF
14909  IF (se_corner) THEN
14910  q1(npx, 0) = q1(npx-1, 0)
14911  q1(npx, -1) = q1(npx-2, 0)
14912  q1(npx+1, 0) = q1(npx-1, -1)
14913  q2(npx, 0) = q2(npx-1, 0)
14914  q2(npx, -1) = q2(npx-2, 0)
14915  q2(npx+1, 0) = q2(npx-1, -1)
14916  q3(npx, 0) = q3(npx-1, 0)
14917  q3(npx, -1) = q3(npx-2, 0)
14918  q3(npx+1, 0) = q3(npx-1, -1)
14919  END IF
14920  IF (ne_corner) THEN
14921  q1(npx, npy) = q1(npx-1, npy)
14922  q1(npx, npy+1) = q1(npx-2, npy)
14923  q1(npx+1, npy) = q1(npx-1, npy+1)
14924  q2(npx, npy) = q2(npx-1, npy)
14925  q2(npx, npy+1) = q2(npx-2, npy)
14926  q2(npx+1, npy) = q2(npx-1, npy+1)
14927  q3(npx, npy) = q3(npx-1, npy)
14928  q3(npx, npy+1) = q3(npx-2, npy)
14929  q3(npx+1, npy) = q3(npx-1, npy+1)
14930  END IF
14931  IF (nw_corner) THEN
14932  q1(0, npy) = q1(1, npy)
14933  q1(0, npy+1) = q1(2, npy)
14934  q1(-1, npy) = q1(1, npy+1)
14935  q2(0, npy) = q2(1, npy)
14936  q2(0, npy+1) = q2(2, npy)
14937  q2(-1, npy) = q2(1, npy+1)
14938  q3(0, npy) = q3(1, npy)
14939  q3(0, npy+1) = q3(2, npy)
14940  q3(-1, npy) = q3(1, npy+1)
14941  END IF
14942  END SELECT
14943  END SUBROUTINE fill3_4corners
14944 ! Differentiation of fill2_4corners in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
14945 !ge_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_c
14946 !ore_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_m
14947 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
14948 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
14949 !_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_mo
14950 !d.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_
14951 !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_limit
14952 !ers 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
14953 !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_su
14954 !bgrid_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_ut
14955 !ils_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_util
14956 !s_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
14957 !_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_mo
14958 !d.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.yt
14959 !p_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_c
14960 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
14961 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
14962 ! gradient of useful results: q1 q2
14963 ! with respect to varying inputs: q1 q2
14964  SUBROUTINE fill2_4corners_fwd(q1, q2, dir, bd, npx, npy, sw_corner, &
14965 & se_corner, ne_corner, nw_corner)
14966  IMPLICIT NONE
14967  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
14968 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
14969 ! 1: x-dir; 2: y-dir
14970  INTEGER, INTENT(IN) :: dir
14971  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
14972  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
14973  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
14974  INTEGER, INTENT(IN) :: npx, npy
14975  INTEGER :: is, ie, js, je
14976  INTEGER :: isd, ied, jsd, jed
14977 
14978  is = 0
14979  ie = 0
14980  js = 0
14981  je = 0
14982  isd = 0
14983  ied = 0
14984  jsd = 0
14985  jed = 0
14986 
14987  SELECT CASE (dir)
14988  CASE (1)
14989  IF (sw_corner) THEN
14990  CALL pushrealarray(q1(-1, 0))
14991  q1(-1, 0) = q1(0, 2)
14992  CALL pushrealarray(q1(0, 0))
14993  q1(0, 0) = q1(0, 1)
14994  CALL pushrealarray(q2(-1, 0))
14995  q2(-1, 0) = q2(0, 2)
14996  CALL pushrealarray(q2(0, 0))
14997  q2(0, 0) = q2(0, 1)
14998  CALL pushcontrol(1,0)
14999  ELSE
15000  CALL pushcontrol(1,1)
15001  END IF
15002  IF (se_corner) THEN
15003  CALL pushrealarray(q1(npx+1, 0))
15004  q1(npx+1, 0) = q1(npx, 2)
15005  CALL pushrealarray(q1(npx, 0))
15006  q1(npx, 0) = q1(npx, 1)
15007  CALL pushrealarray(q2(npx+1, 0))
15008  q2(npx+1, 0) = q2(npx, 2)
15009  CALL pushrealarray(q2(npx, 0))
15010  q2(npx, 0) = q2(npx, 1)
15011  CALL pushcontrol(1,0)
15012  ELSE
15013  CALL pushcontrol(1,1)
15014  END IF
15015  IF (nw_corner) THEN
15016  CALL pushrealarray(q1(0, npy))
15017  q1(0, npy) = q1(0, npy-1)
15018  CALL pushrealarray(q1(-1, npy))
15019  q1(-1, npy) = q1(0, npy-2)
15020  CALL pushrealarray(q2(0, npy))
15021  q2(0, npy) = q2(0, npy-1)
15022  CALL pushrealarray(q2(-1, npy))
15023  q2(-1, npy) = q2(0, npy-2)
15024  CALL pushcontrol(1,0)
15025  ELSE
15026  CALL pushcontrol(1,1)
15027  END IF
15028  IF (ne_corner) THEN
15029  CALL pushrealarray(q1(npx, npy))
15030  q1(npx, npy) = q1(npx, npy-1)
15031  CALL pushrealarray(q1(npx+1, npy))
15032  q1(npx+1, npy) = q1(npx, npy-2)
15033  CALL pushrealarray(q2(npx, npy))
15034  q2(npx, npy) = q2(npx, npy-1)
15035  CALL pushrealarray(q2(npx+1, npy))
15036  q2(npx+1, npy) = q2(npx, npy-2)
15037  CALL pushcontrol(3,2)
15038  ELSE
15039  CALL pushcontrol(3,1)
15040  END IF
15041  CASE (2)
15042  IF (sw_corner) THEN
15043  CALL pushrealarray(q1(0, 0))
15044  q1(0, 0) = q1(1, 0)
15045  CALL pushrealarray(q1(0, -1))
15046  q1(0, -1) = q1(2, 0)
15047  CALL pushrealarray(q2(0, 0))
15048  q2(0, 0) = q2(1, 0)
15049  CALL pushrealarray(q2(0, -1))
15050  q2(0, -1) = q2(2, 0)
15051  CALL pushcontrol(1,0)
15052  ELSE
15053  CALL pushcontrol(1,1)
15054  END IF
15055  IF (se_corner) THEN
15056  CALL pushrealarray(q1(npx, 0))
15057  q1(npx, 0) = q1(npx-1, 0)
15058  CALL pushrealarray(q1(npx, -1))
15059  q1(npx, -1) = q1(npx-2, 0)
15060  CALL pushrealarray(q2(npx, 0))
15061  q2(npx, 0) = q2(npx-1, 0)
15062  CALL pushrealarray(q2(npx, -1))
15063  q2(npx, -1) = q2(npx-2, 0)
15064  CALL pushcontrol(1,0)
15065  ELSE
15066  CALL pushcontrol(1,1)
15067  END IF
15068  IF (nw_corner) THEN
15069  CALL pushrealarray(q1(0, npy))
15070  q1(0, npy) = q1(1, npy)
15071  CALL pushrealarray(q1(0, npy+1))
15072  q1(0, npy+1) = q1(2, npy)
15073  CALL pushrealarray(q2(0, npy))
15074  q2(0, npy) = q2(1, npy)
15075  CALL pushrealarray(q2(0, npy+1))
15076  q2(0, npy+1) = q2(2, npy)
15077  CALL pushcontrol(1,0)
15078  ELSE
15079  CALL pushcontrol(1,1)
15080  END IF
15081  IF (ne_corner) THEN
15082  CALL pushrealarray(q1(npx, npy))
15083  q1(npx, npy) = q1(npx-1, npy)
15084  CALL pushrealarray(q1(npx, npy+1))
15085  q1(npx, npy+1) = q1(npx-2, npy)
15086  CALL pushrealarray(q2(npx, npy))
15087  q2(npx, npy) = q2(npx-1, npy)
15088  CALL pushrealarray(q2(npx, npy+1))
15089  q2(npx, npy+1) = q2(npx-2, npy)
15090  CALL pushcontrol(3,4)
15091  ELSE
15092  CALL pushcontrol(3,3)
15093  END IF
15094  CASE DEFAULT
15095  CALL pushcontrol(3,0)
15096  END SELECT
15097  END SUBROUTINE fill2_4corners_fwd
15098 ! Differentiation of fill2_4corners in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_e
15099 !dge_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_
15100 !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_
15101 !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.Ray
15102 !leigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2
15103 !l_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_m
15104 !od.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
15105 !_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_limi
15106 !ters 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
15107 ! 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_s
15108 !ubgrid_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_u
15109 !tils_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_uti
15110 !ls_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_util
15111 !s_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_m
15112 !od.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.y
15113 !tp_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_
15114 !core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_
15115 !utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15116 ! gradient of useful results: q1 q2
15117 ! with respect to varying inputs: q1 q2
15118  SUBROUTINE fill2_4corners_bwd(q1, q1_ad, q2, q2_ad, dir, bd, npx, npy&
15119 & , sw_corner, se_corner, ne_corner, nw_corner)
15120  IMPLICIT NONE
15121  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
15122  INTEGER, INTENT(IN) :: dir
15123  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
15124  REAL, INTENT(INOUT) :: q1_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
15125  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
15126  REAL, INTENT(INOUT) :: q2_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
15127  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
15128  INTEGER, INTENT(IN) :: npx, npy
15129  INTEGER :: is, ie, js, je
15130  INTEGER :: isd, ied, jsd, jed
15131  INTEGER :: branch
15132 
15133  is = 0
15134  ie = 0
15135  js = 0
15136  je = 0
15137  isd = 0
15138  ied = 0
15139  jsd = 0
15140  jed = 0
15141  branch = 0
15142 
15143  CALL popcontrol(3,branch)
15144  IF (branch .LT. 2) THEN
15145  IF (branch .EQ. 0) GOTO 100
15146  ELSE IF (branch .EQ. 2) THEN
15147  CALL poprealarray(q2(npx+1, npy))
15148  q2_ad(npx, npy-2) = q2_ad(npx, npy-2) + q2_ad(npx+1, npy)
15149  q2_ad(npx+1, npy) = 0.0
15150  CALL poprealarray(q2(npx, npy))
15151  q2_ad(npx, npy-1) = q2_ad(npx, npy-1) + q2_ad(npx, npy)
15152  q2_ad(npx, npy) = 0.0
15153  CALL poprealarray(q1(npx+1, npy))
15154  q1_ad(npx, npy-2) = q1_ad(npx, npy-2) + q1_ad(npx+1, npy)
15155  q1_ad(npx+1, npy) = 0.0
15156  CALL poprealarray(q1(npx, npy))
15157  q1_ad(npx, npy-1) = q1_ad(npx, npy-1) + q1_ad(npx, npy)
15158  q1_ad(npx, npy) = 0.0
15159  ELSE
15160  IF (branch .NE. 3) THEN
15161  CALL poprealarray(q2(npx, npy+1))
15162  q2_ad(npx-2, npy) = q2_ad(npx-2, npy) + q2_ad(npx, npy+1)
15163  q2_ad(npx, npy+1) = 0.0
15164  CALL poprealarray(q2(npx, npy))
15165  q2_ad(npx-1, npy) = q2_ad(npx-1, npy) + q2_ad(npx, npy)
15166  q2_ad(npx, npy) = 0.0
15167  CALL poprealarray(q1(npx, npy+1))
15168  q1_ad(npx-2, npy) = q1_ad(npx-2, npy) + q1_ad(npx, npy+1)
15169  q1_ad(npx, npy+1) = 0.0
15170  CALL poprealarray(q1(npx, npy))
15171  q1_ad(npx-1, npy) = q1_ad(npx-1, npy) + q1_ad(npx, npy)
15172  q1_ad(npx, npy) = 0.0
15173  END IF
15174  CALL popcontrol(1,branch)
15175  IF (branch .EQ. 0) THEN
15176  CALL poprealarray(q2(0, npy+1))
15177  q2_ad(2, npy) = q2_ad(2, npy) + q2_ad(0, npy+1)
15178  q2_ad(0, npy+1) = 0.0
15179  CALL poprealarray(q2(0, npy))
15180  q2_ad(1, npy) = q2_ad(1, npy) + q2_ad(0, npy)
15181  q2_ad(0, npy) = 0.0
15182  CALL poprealarray(q1(0, npy+1))
15183  q1_ad(2, npy) = q1_ad(2, npy) + q1_ad(0, npy+1)
15184  q1_ad(0, npy+1) = 0.0
15185  CALL poprealarray(q1(0, npy))
15186  q1_ad(1, npy) = q1_ad(1, npy) + q1_ad(0, npy)
15187  q1_ad(0, npy) = 0.0
15188  END IF
15189  CALL popcontrol(1,branch)
15190  IF (branch .EQ. 0) THEN
15191  CALL poprealarray(q2(npx, -1))
15192  q2_ad(npx-2, 0) = q2_ad(npx-2, 0) + q2_ad(npx, -1)
15193  q2_ad(npx, -1) = 0.0
15194  CALL poprealarray(q2(npx, 0))
15195  q2_ad(npx-1, 0) = q2_ad(npx-1, 0) + q2_ad(npx, 0)
15196  q2_ad(npx, 0) = 0.0
15197  CALL poprealarray(q1(npx, -1))
15198  q1_ad(npx-2, 0) = q1_ad(npx-2, 0) + q1_ad(npx, -1)
15199  q1_ad(npx, -1) = 0.0
15200  CALL poprealarray(q1(npx, 0))
15201  q1_ad(npx-1, 0) = q1_ad(npx-1, 0) + q1_ad(npx, 0)
15202  q1_ad(npx, 0) = 0.0
15203  END IF
15204  CALL popcontrol(1,branch)
15205  IF (branch .EQ. 0) THEN
15206  CALL poprealarray(q2(0, -1))
15207  q2_ad(2, 0) = q2_ad(2, 0) + q2_ad(0, -1)
15208  q2_ad(0, -1) = 0.0
15209  CALL poprealarray(q2(0, 0))
15210  q2_ad(1, 0) = q2_ad(1, 0) + q2_ad(0, 0)
15211  q2_ad(0, 0) = 0.0
15212  CALL poprealarray(q1(0, -1))
15213  q1_ad(2, 0) = q1_ad(2, 0) + q1_ad(0, -1)
15214  q1_ad(0, -1) = 0.0
15215  CALL poprealarray(q1(0, 0))
15216  q1_ad(1, 0) = q1_ad(1, 0) + q1_ad(0, 0)
15217  q1_ad(0, 0) = 0.0
15218  END IF
15219  GOTO 100
15220  END IF
15221  CALL popcontrol(1,branch)
15222  IF (branch .EQ. 0) THEN
15223  CALL poprealarray(q2(-1, npy))
15224  q2_ad(0, npy-2) = q2_ad(0, npy-2) + q2_ad(-1, npy)
15225  q2_ad(-1, npy) = 0.0
15226  CALL poprealarray(q2(0, npy))
15227  q2_ad(0, npy-1) = q2_ad(0, npy-1) + q2_ad(0, npy)
15228  q2_ad(0, npy) = 0.0
15229  CALL poprealarray(q1(-1, npy))
15230  q1_ad(0, npy-2) = q1_ad(0, npy-2) + q1_ad(-1, npy)
15231  q1_ad(-1, npy) = 0.0
15232  CALL poprealarray(q1(0, npy))
15233  q1_ad(0, npy-1) = q1_ad(0, npy-1) + q1_ad(0, npy)
15234  q1_ad(0, npy) = 0.0
15235  END IF
15236  CALL popcontrol(1,branch)
15237  IF (branch .EQ. 0) THEN
15238  CALL poprealarray(q2(npx, 0))
15239  q2_ad(npx, 1) = q2_ad(npx, 1) + q2_ad(npx, 0)
15240  q2_ad(npx, 0) = 0.0
15241  CALL poprealarray(q2(npx+1, 0))
15242  q2_ad(npx, 2) = q2_ad(npx, 2) + q2_ad(npx+1, 0)
15243  q2_ad(npx+1, 0) = 0.0
15244  CALL poprealarray(q1(npx, 0))
15245  q1_ad(npx, 1) = q1_ad(npx, 1) + q1_ad(npx, 0)
15246  q1_ad(npx, 0) = 0.0
15247  CALL poprealarray(q1(npx+1, 0))
15248  q1_ad(npx, 2) = q1_ad(npx, 2) + q1_ad(npx+1, 0)
15249  q1_ad(npx+1, 0) = 0.0
15250  END IF
15251  CALL popcontrol(1,branch)
15252  IF (branch .EQ. 0) THEN
15253  CALL poprealarray(q2(0, 0))
15254  q2_ad(0, 1) = q2_ad(0, 1) + q2_ad(0, 0)
15255  q2_ad(0, 0) = 0.0
15256  CALL poprealarray(q2(-1, 0))
15257  q2_ad(0, 2) = q2_ad(0, 2) + q2_ad(-1, 0)
15258  q2_ad(-1, 0) = 0.0
15259  CALL poprealarray(q1(0, 0))
15260  q1_ad(0, 1) = q1_ad(0, 1) + q1_ad(0, 0)
15261  q1_ad(0, 0) = 0.0
15262  CALL poprealarray(q1(-1, 0))
15263  q1_ad(0, 2) = q1_ad(0, 2) + q1_ad(-1, 0)
15264  q1_ad(-1, 0) = 0.0
15265  END IF
15266  100 CONTINUE
15267  END SUBROUTINE fill2_4corners_bwd
15268  SUBROUTINE fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, &
15269 & se_corner, ne_corner, nw_corner)
15270  IMPLICIT NONE
15271  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
15272 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
15273 ! 1: x-dir; 2: y-dir
15274  INTEGER, INTENT(IN) :: dir
15275  REAL, INTENT(INOUT) :: q1(bd%isd:bd%ied, bd%jsd:bd%jed)
15276  REAL, INTENT(INOUT) :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
15277  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
15278  INTEGER, INTENT(IN) :: npx, npy
15279  INTEGER :: is, ie, js, je
15280  INTEGER :: isd, ied, jsd, jed
15281  is = bd%is
15282  ie = bd%ie
15283  js = bd%js
15284  je = bd%je
15285  isd = bd%isd
15286  ied = bd%ied
15287  jsd = bd%jsd
15288  jed = bd%jed
15289  SELECT CASE (dir)
15290  CASE (1)
15291  IF (sw_corner) THEN
15292  q1(-1, 0) = q1(0, 2)
15293  q1(0, 0) = q1(0, 1)
15294  q2(-1, 0) = q2(0, 2)
15295  q2(0, 0) = q2(0, 1)
15296  END IF
15297  IF (se_corner) THEN
15298  q1(npx+1, 0) = q1(npx, 2)
15299  q1(npx, 0) = q1(npx, 1)
15300  q2(npx+1, 0) = q2(npx, 2)
15301  q2(npx, 0) = q2(npx, 1)
15302  END IF
15303  IF (nw_corner) THEN
15304  q1(0, npy) = q1(0, npy-1)
15305  q1(-1, npy) = q1(0, npy-2)
15306  q2(0, npy) = q2(0, npy-1)
15307  q2(-1, npy) = q2(0, npy-2)
15308  END IF
15309  IF (ne_corner) THEN
15310  q1(npx, npy) = q1(npx, npy-1)
15311  q1(npx+1, npy) = q1(npx, npy-2)
15312  q2(npx, npy) = q2(npx, npy-1)
15313  q2(npx+1, npy) = q2(npx, npy-2)
15314  END IF
15315  CASE (2)
15316  IF (sw_corner) THEN
15317  q1(0, 0) = q1(1, 0)
15318  q1(0, -1) = q1(2, 0)
15319  q2(0, 0) = q2(1, 0)
15320  q2(0, -1) = q2(2, 0)
15321  END IF
15322  IF (se_corner) THEN
15323  q1(npx, 0) = q1(npx-1, 0)
15324  q1(npx, -1) = q1(npx-2, 0)
15325  q2(npx, 0) = q2(npx-1, 0)
15326  q2(npx, -1) = q2(npx-2, 0)
15327  END IF
15328  IF (nw_corner) THEN
15329  q1(0, npy) = q1(1, npy)
15330  q1(0, npy+1) = q1(2, npy)
15331  q2(0, npy) = q2(1, npy)
15332  q2(0, npy+1) = q2(2, npy)
15333  END IF
15334  IF (ne_corner) THEN
15335  q1(npx, npy) = q1(npx-1, npy)
15336  q1(npx, npy+1) = q1(npx-2, npy)
15337  q2(npx, npy) = q2(npx-1, npy)
15338  q2(npx, npy+1) = q2(npx-2, npy)
15339  END IF
15340  END SELECT
15341  END SUBROUTINE fill2_4corners
15342 ! Differentiation of fill_4corners in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
15343 !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
15344 !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
15345 !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
15346 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
15347 !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
15348 !.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
15349 !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
15350 !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
15351 !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
15352 !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
15353 !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
15354 !_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_
15355 !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
15356 !.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
15357 !_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
15358 !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
15359 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15360 ! gradient of useful results: q
15361 ! with respect to varying inputs: q
15362  SUBROUTINE fill_4corners_fwd(q, dir, bd, npx, npy, sw_corner, &
15363 & se_corner, ne_corner, nw_corner)
15364  IMPLICIT NONE
15365  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
15366 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
15367 ! 1: x-dir; 2: y-dir
15368  INTEGER, INTENT(IN) :: dir
15369  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
15370  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
15371  INTEGER, INTENT(IN) :: npx, npy
15372  INTEGER :: is, ie, js, je
15373  INTEGER :: isd, ied, jsd, jed
15374 
15375  is = 0
15376  ie = 0
15377  js = 0
15378  je = 0
15379  isd = 0
15380  ied = 0
15381  jsd = 0
15382  jed = 0
15383 
15384  SELECT CASE (dir)
15385  CASE (1)
15386  IF (sw_corner) THEN
15387  CALL pushrealarray(q(-1, 0))
15388  q(-1, 0) = q(0, 2)
15389  CALL pushrealarray(q(0, 0))
15390  q(0, 0) = q(0, 1)
15391  CALL pushcontrol(1,0)
15392  ELSE
15393  CALL pushcontrol(1,1)
15394  END IF
15395  IF (se_corner) THEN
15396  CALL pushrealarray(q(npx+1, 0))
15397  q(npx+1, 0) = q(npx, 2)
15398  CALL pushrealarray(q(npx, 0))
15399  q(npx, 0) = q(npx, 1)
15400  CALL pushcontrol(1,0)
15401  ELSE
15402  CALL pushcontrol(1,1)
15403  END IF
15404  IF (nw_corner) THEN
15405  CALL pushrealarray(q(0, npy))
15406  q(0, npy) = q(0, npy-1)
15407  CALL pushrealarray(q(-1, npy))
15408  q(-1, npy) = q(0, npy-2)
15409  CALL pushcontrol(1,0)
15410  ELSE
15411  CALL pushcontrol(1,1)
15412  END IF
15413  IF (ne_corner) THEN
15414  CALL pushrealarray(q(npx, npy))
15415  q(npx, npy) = q(npx, npy-1)
15416  CALL pushrealarray(q(npx+1, npy))
15417  q(npx+1, npy) = q(npx, npy-2)
15418  CALL pushcontrol(3,2)
15419  ELSE
15420  CALL pushcontrol(3,1)
15421  END IF
15422  CASE (2)
15423  IF (sw_corner) THEN
15424  CALL pushrealarray(q(0, 0))
15425  q(0, 0) = q(1, 0)
15426  CALL pushrealarray(q(0, -1))
15427  q(0, -1) = q(2, 0)
15428  CALL pushcontrol(1,0)
15429  ELSE
15430  CALL pushcontrol(1,1)
15431  END IF
15432  IF (se_corner) THEN
15433  CALL pushrealarray(q(npx, 0))
15434  q(npx, 0) = q(npx-1, 0)
15435  CALL pushrealarray(q(npx, -1))
15436  q(npx, -1) = q(npx-2, 0)
15437  CALL pushcontrol(1,0)
15438  ELSE
15439  CALL pushcontrol(1,1)
15440  END IF
15441  IF (nw_corner) THEN
15442  CALL pushrealarray(q(0, npy))
15443  q(0, npy) = q(1, npy)
15444  CALL pushrealarray(q(0, npy+1))
15445  q(0, npy+1) = q(2, npy)
15446  CALL pushcontrol(1,0)
15447  ELSE
15448  CALL pushcontrol(1,1)
15449  END IF
15450  IF (ne_corner) THEN
15451  CALL pushrealarray(q(npx, npy))
15452  q(npx, npy) = q(npx-1, npy)
15453  CALL pushrealarray(q(npx, npy+1))
15454  q(npx, npy+1) = q(npx-2, npy)
15455  CALL pushcontrol(3,4)
15456  ELSE
15457  CALL pushcontrol(3,3)
15458  END IF
15459  CASE DEFAULT
15460  CALL pushcontrol(3,0)
15461  END SELECT
15462  END SUBROUTINE fill_4corners_fwd
15463 ! Differentiation of fill_4corners in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
15464 !ge_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_c
15465 !ore_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_m
15466 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
15467 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
15468 !_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_mo
15469 !d.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_
15470 !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_limit
15471 !ers 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
15472 !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_su
15473 !bgrid_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_ut
15474 !ils_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_util
15475 !s_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
15476 !_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_mo
15477 !d.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.yt
15478 !p_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_c
15479 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
15480 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15481 ! gradient of useful results: q
15482 ! with respect to varying inputs: q
15483  SUBROUTINE fill_4corners_bwd(q, q_ad, dir, bd, npx, npy, sw_corner, &
15484 & se_corner, ne_corner, nw_corner)
15485  IMPLICIT NONE
15486  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
15487  INTEGER, INTENT(IN) :: dir
15488  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
15489  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
15490  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
15491  INTEGER, INTENT(IN) :: npx, npy
15492  INTEGER :: is, ie, js, je
15493  INTEGER :: isd, ied, jsd, jed
15494  INTEGER :: branch
15495 
15496  is = 0
15497  ie = 0
15498  js = 0
15499  je = 0
15500  isd = 0
15501  ied = 0
15502  jsd = 0
15503  jed = 0
15504  branch = 0
15505 
15506  CALL popcontrol(3,branch)
15507  IF (branch .LT. 2) THEN
15508  IF (branch .EQ. 0) GOTO 100
15509  ELSE IF (branch .EQ. 2) THEN
15510  CALL poprealarray(q(npx+1, npy))
15511  q_ad(npx, npy-2) = q_ad(npx, npy-2) + q_ad(npx+1, npy)
15512  q_ad(npx+1, npy) = 0.0
15513  CALL poprealarray(q(npx, npy))
15514  q_ad(npx, npy-1) = q_ad(npx, npy-1) + q_ad(npx, npy)
15515  q_ad(npx, npy) = 0.0
15516  ELSE
15517  IF (branch .NE. 3) THEN
15518  CALL poprealarray(q(npx, npy+1))
15519  q_ad(npx-2, npy) = q_ad(npx-2, npy) + q_ad(npx, npy+1)
15520  q_ad(npx, npy+1) = 0.0
15521  CALL poprealarray(q(npx, npy))
15522  q_ad(npx-1, npy) = q_ad(npx-1, npy) + q_ad(npx, npy)
15523  q_ad(npx, npy) = 0.0
15524  END IF
15525  CALL popcontrol(1,branch)
15526  IF (branch .EQ. 0) THEN
15527  CALL poprealarray(q(0, npy+1))
15528  q_ad(2, npy) = q_ad(2, npy) + q_ad(0, npy+1)
15529  q_ad(0, npy+1) = 0.0
15530  CALL poprealarray(q(0, npy))
15531  q_ad(1, npy) = q_ad(1, npy) + q_ad(0, npy)
15532  q_ad(0, npy) = 0.0
15533  END IF
15534  CALL popcontrol(1,branch)
15535  IF (branch .EQ. 0) THEN
15536  CALL poprealarray(q(npx, -1))
15537  q_ad(npx-2, 0) = q_ad(npx-2, 0) + q_ad(npx, -1)
15538  q_ad(npx, -1) = 0.0
15539  CALL poprealarray(q(npx, 0))
15540  q_ad(npx-1, 0) = q_ad(npx-1, 0) + q_ad(npx, 0)
15541  q_ad(npx, 0) = 0.0
15542  END IF
15543  CALL popcontrol(1,branch)
15544  IF (branch .EQ. 0) THEN
15545  CALL poprealarray(q(0, -1))
15546  q_ad(2, 0) = q_ad(2, 0) + q_ad(0, -1)
15547  q_ad(0, -1) = 0.0
15548  CALL poprealarray(q(0, 0))
15549  q_ad(1, 0) = q_ad(1, 0) + q_ad(0, 0)
15550  q_ad(0, 0) = 0.0
15551  END IF
15552  GOTO 100
15553  END IF
15554  CALL popcontrol(1,branch)
15555  IF (branch .EQ. 0) THEN
15556  CALL poprealarray(q(-1, npy))
15557  q_ad(0, npy-2) = q_ad(0, npy-2) + q_ad(-1, npy)
15558  q_ad(-1, npy) = 0.0
15559  CALL poprealarray(q(0, npy))
15560  q_ad(0, npy-1) = q_ad(0, npy-1) + q_ad(0, npy)
15561  q_ad(0, npy) = 0.0
15562  END IF
15563  CALL popcontrol(1,branch)
15564  IF (branch .EQ. 0) THEN
15565  CALL poprealarray(q(npx, 0))
15566  q_ad(npx, 1) = q_ad(npx, 1) + q_ad(npx, 0)
15567  q_ad(npx, 0) = 0.0
15568  CALL poprealarray(q(npx+1, 0))
15569  q_ad(npx, 2) = q_ad(npx, 2) + q_ad(npx+1, 0)
15570  q_ad(npx+1, 0) = 0.0
15571  END IF
15572  CALL popcontrol(1,branch)
15573  IF (branch .EQ. 0) THEN
15574  CALL poprealarray(q(0, 0))
15575  q_ad(0, 1) = q_ad(0, 1) + q_ad(0, 0)
15576  q_ad(0, 0) = 0.0
15577  CALL poprealarray(q(-1, 0))
15578  q_ad(0, 2) = q_ad(0, 2) + q_ad(-1, 0)
15579  q_ad(-1, 0) = 0.0
15580  END IF
15581  100 CONTINUE
15582  END SUBROUTINE fill_4corners_bwd
15583  SUBROUTINE fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, &
15584 & ne_corner, nw_corner)
15585  IMPLICIT NONE
15586  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
15587 ! This routine fill the 4 corners of the scalar fileds only as needed by c_core
15588 ! 1: x-dir; 2: y-dir
15589  INTEGER, INTENT(IN) :: dir
15590  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
15591  LOGICAL, INTENT(IN) :: sw_corner, se_corner, ne_corner, nw_corner
15592  INTEGER, INTENT(IN) :: npx, npy
15593  INTEGER :: is, ie, js, je
15594  INTEGER :: isd, ied, jsd, jed
15595  is = bd%is
15596  ie = bd%ie
15597  js = bd%js
15598  je = bd%je
15599  isd = bd%isd
15600  ied = bd%ied
15601  jsd = bd%jsd
15602  jed = bd%jed
15603  SELECT CASE (dir)
15604  CASE (1)
15605  IF (sw_corner) THEN
15606  q(-1, 0) = q(0, 2)
15607  q(0, 0) = q(0, 1)
15608  END IF
15609  IF (se_corner) THEN
15610  q(npx+1, 0) = q(npx, 2)
15611  q(npx, 0) = q(npx, 1)
15612  END IF
15613  IF (nw_corner) THEN
15614  q(0, npy) = q(0, npy-1)
15615  q(-1, npy) = q(0, npy-2)
15616  END IF
15617  IF (ne_corner) THEN
15618  q(npx, npy) = q(npx, npy-1)
15619  q(npx+1, npy) = q(npx, npy-2)
15620  END IF
15621  CASE (2)
15622  IF (sw_corner) THEN
15623  q(0, 0) = q(1, 0)
15624  q(0, -1) = q(2, 0)
15625  END IF
15626  IF (se_corner) THEN
15627  q(npx, 0) = q(npx-1, 0)
15628  q(npx, -1) = q(npx-2, 0)
15629  END IF
15630  IF (nw_corner) THEN
15631  q(0, npy) = q(1, npy)
15632  q(0, npy+1) = q(2, npy)
15633  END IF
15634  IF (ne_corner) THEN
15635  q(npx, npy) = q(npx-1, npy)
15636  q(npx, npy+1) = q(npx-2, npy)
15637  END IF
15638  END SELECT
15639  END SUBROUTINE fill_4corners
15640 ! Differentiation of xtp_u in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
15641 !.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_mo
15642 !d.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.mix
15643 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
15644 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
15645 !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.rema
15646 !p_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_
15647 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
15648 !_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_res
15649 !tart_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_
15650 !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_mo
15651 !d.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.
15652 !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.n
15653 !est_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.d2a2
15654 !c_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
15655 ! 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_mo
15656 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
15657 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
15658 ! gradient of useful results: flux u c
15659 ! with respect to varying inputs: flux u c
15660  SUBROUTINE xtp_u_fwd(is, ie, js, je, isd, ied, jsd, jed, c, u, v, &
15661 & flux, iord, dx, rdx, npx, npy, grid_type, nested)
15662  IMPLICIT NONE
15663  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
15664  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
15665  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
15666  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
15667  REAL :: flux(is:ie+1, js:je+1)
15668  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
15669  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
15670  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
15671  LOGICAL, INTENT(IN) :: nested
15672 ! Local
15673  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
15674  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
15675  REAL :: fx0(is:ie+1)
15676  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
15677  REAL :: dq(is-3:ie+2)
15678  REAL :: dl, dr, xt, pmp, lac, cfl
15679  REAL :: pmp_1, lac_1, pmp_2, lac_2
15680  REAL :: x0, x1, x0l, x0r
15681  INTEGER :: i, j
15682  INTEGER :: is3, ie3
15683  INTEGER :: is2, ie2
15684  INTRINSIC max
15685  INTRINSIC min
15686 
15687  bl = 0.0
15688  br = 0.0
15689  b0 = 0.0
15690  fx0 = 0.0
15691  al = 0.0
15692  dm = 0.0
15693  dq = 0.0
15694  dl = 0.0
15695  dr = 0.0
15696  xt = 0.0
15697  pmp = 0.0
15698  lac = 0.0
15699  cfl = 0.0
15700  pmp_1 = 0.0
15701  lac_1 = 0.0
15702  pmp_2 = 0.0
15703  lac_2 = 0.0
15704  x0 = 0.0
15705  x1 = 0.0
15706  x0l = 0.0
15707  x0r = 0.0
15708  is3 = 0
15709  ie3 = 0
15710  is2 = 0
15711  ie2 = 0
15712 
15713  IF (nested .OR. grid_type .GT. 3) THEN
15714  CALL pushcontrol(1,0)
15715  is3 = is - 1
15716  ie3 = ie + 1
15717  ELSE
15718  IF (3 .LT. is - 1) THEN
15719  is3 = is - 1
15720  ELSE
15721  is3 = 3
15722  END IF
15723  IF (npx - 3 .GT. ie + 1) THEN
15724  CALL pushcontrol(1,1)
15725  ie3 = ie + 1
15726  ELSE
15727  CALL pushcontrol(1,1)
15728  ie3 = npx - 3
15729  END IF
15730  END IF
15731  IF (iord .EQ. 1) THEN
15732  DO j=js,je+1
15733  DO i=is,ie+1
15734  IF (c(i, j) .GT. 0.) THEN
15735  CALL pushrealarray(flux(i, j))
15736  flux(i, j) = u(i-1, j)
15737  CALL pushcontrol(1,1)
15738  ELSE
15739  CALL pushrealarray(flux(i, j))
15740  flux(i, j) = u(i, j)
15741  CALL pushcontrol(1,0)
15742  END IF
15743  END DO
15744  END DO
15745  CALL pushcontrol(2,0)
15746  ELSE IF (iord .EQ. 333) THEN
15747  CALL pushrealarray(flux, (ie-is+2)*(je-js+2))
15748  DO j=js,je+1
15749  DO i=is,ie+1
15750  IF (c(i, j) .GT. 0.) THEN
15751  flux(i, j) = (2.0*u(i, j)+5.0*u(i-1, j)-u(i-2, j))/6.0 - 0.5&
15752 & *c(i, j)*rdx(i-1, j)*(u(i, j)-u(i-1, j)) + c(i, j)*rdx(i-1&
15753 & , j)*c(i, j)*rdx(i-1, j)/6.0*(u(i, j)-2.0*u(i-1, j)+u(i-2&
15754 & , j))
15755  ELSE
15756  flux(i, j) = (2.0*u(i-1, j)+5.0*u(i, j)-u(i+1, j))/6.0 - 0.5&
15757 & *c(i, j)*rdx(i, j)*(u(i, j)-u(i-1, j)) + c(i, j)*rdx(i, j)&
15758 & *c(i, j)*rdx(i, j)/6.0*(u(i+1, j)-2.0*u(i, j)+u(i-1, j))
15759  END IF
15760  END DO
15761  END DO
15762  CALL pushcontrol(2,1)
15763  ELSE IF (iord .LT. 8) THEN
15764 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
15765  DO j=js,je+1
15766  DO i=is3,ie3+1
15767  al(i) = p1*(u(i-1, j)+u(i, j)) + p2*(u(i-2, j)+u(i+1, j))
15768  END DO
15769  DO i=is3,ie3
15770  CALL pushrealarray(bl(i))
15771  bl(i) = al(i) - u(i, j)
15772  CALL pushrealarray(br(i))
15773  br(i) = al(i+1) - u(i, j)
15774  END DO
15775  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
15776  IF (is .EQ. 1) THEN
15777  xt = c3*u(1, j) + c2*u(2, j) + c1*u(3, j)
15778  CALL pushrealarray(br(1))
15779  br(1) = xt - u(1, j)
15780  CALL pushrealarray(bl(2))
15781  bl(2) = xt - u(2, j)
15782  CALL pushrealarray(br(2))
15783  br(2) = al(3) - u(2, j)
15784  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
15785 ! out
15786  CALL pushrealarray(bl(0))
15787  bl(0) = 0.
15788 ! edge
15789  CALL pushrealarray(br(0))
15790  br(0) = 0.
15791 ! edge
15792  CALL pushrealarray(bl(1))
15793  bl(1) = 0.
15794 ! in
15795  CALL pushrealarray(br(1))
15796  br(1) = 0.
15797  CALL pushcontrol(2,0)
15798  ELSE
15799  CALL pushrealarray(bl(0))
15800  bl(0) = c1*u(-2, j) + c2*u(-1, j) + c3*u(0, j) - u(0, j)
15801  xt = 0.5*(((2.*dx(0, j)+dx(-1, j))*u(0, j)-dx(0, j)*u(-1, &
15802 & j))/(dx(0, j)+dx(-1, j))+((2.*dx(1, j)+dx(2, j))*u(1, j)&
15803 & -dx(1, j)*u(2, j))/(dx(1, j)+dx(2, j)))
15804  CALL pushrealarray(br(0))
15805  br(0) = xt - u(0, j)
15806  CALL pushrealarray(bl(1))
15807  bl(1) = xt - u(1, j)
15808  CALL pushcontrol(2,1)
15809  END IF
15810  ELSE
15811  CALL pushcontrol(2,2)
15812  END IF
15813 ! call pert_ppm(1, u(2,j), bl(2), br(2), -1)
15814  IF (ie + 1 .EQ. npx) THEN
15815  CALL pushrealarray(bl(npx-2))
15816  bl(npx-2) = al(npx-2) - u(npx-2, j)
15817  xt = c1*u(npx-3, j) + c2*u(npx-2, j) + c3*u(npx-1, j)
15818  CALL pushrealarray(br(npx-2))
15819  br(npx-2) = xt - u(npx-2, j)
15820  CALL pushrealarray(bl(npx-1))
15821  bl(npx-1) = xt - u(npx-1, j)
15822  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
15823 ! in
15824  CALL pushrealarray(bl(npx-1))
15825  bl(npx-1) = 0.
15826 ! edge
15827  CALL pushrealarray(br(npx-1))
15828  br(npx-1) = 0.
15829 ! edge
15830  CALL pushrealarray(bl(npx))
15831  bl(npx) = 0.
15832 ! out
15833  CALL pushrealarray(br(npx))
15834  br(npx) = 0.
15835  CALL pushcontrol(2,3)
15836  ELSE
15837  xt = 0.5*(((2.*dx(npx-1, j)+dx(npx-2, j))*u(npx-1, j)-dx(&
15838 & npx-1, j)*u(npx-2, j))/(dx(npx-1, j)+dx(npx-2, j))+((2.*&
15839 & dx(npx, j)+dx(npx+1, j))*u(npx, j)-dx(npx, j)*u(npx+1, j&
15840 & ))/(dx(npx, j)+dx(npx+1, j)))
15841  CALL pushrealarray(br(npx-1))
15842  br(npx-1) = xt - u(npx-1, j)
15843  CALL pushrealarray(bl(npx))
15844  bl(npx) = xt - u(npx, j)
15845  CALL pushrealarray(br(npx))
15846  br(npx) = c3*u(npx, j) + c2*u(npx+1, j) + c1*u(npx+2, j) -&
15847 & u(npx, j)
15848  CALL pushcontrol(2,2)
15849  END IF
15850  ELSE
15851  CALL pushcontrol(2,1)
15852  END IF
15853  ELSE
15854  CALL pushcontrol(2,0)
15855  END IF
15856 ! call pert_ppm(1, u(npx-2,j), bl(npx-2), br(npx-2), -1)
15857  DO i=is-1,ie+1
15858  CALL pushrealarray(b0(i))
15859  b0(i) = bl(i) + br(i)
15860  END DO
15861  IF (iord .EQ. 2) THEN
15862 ! Perfectly linear
15863 !DEC$ VECTOR ALWAYS
15864  DO i=is,ie+1
15865  IF (c(i, j) .GT. 0.) THEN
15866  cfl = c(i, j)*rdx(i-1, j)
15867  CALL pushrealarray(flux(i, j))
15868  flux(i, j) = u(i-1, j) + (1.-cfl)*(br(i-1)-cfl*b0(i-1))
15869  CALL pushcontrol(1,1)
15870  ELSE
15871  cfl = c(i, j)*rdx(i, j)
15872  CALL pushrealarray(flux(i, j))
15873  flux(i, j) = u(i, j) + (1.+cfl)*(bl(i)+cfl*b0(i))
15874  CALL pushcontrol(1,0)
15875  END IF
15876  END DO
15877  CALL pushcontrol(1,1)
15878  ELSE
15879  CALL pushcontrol(1,0)
15880  END IF
15881  END DO
15882  CALL pushinteger(ie3)
15883  CALL pushrealarray(b0, ie - is + 3)
15884  CALL pushrealarray(br, ie - is + 3)
15885  CALL pushrealarray(bl, ie - is + 3)
15886  CALL pushinteger(is3)
15887  CALL pushcontrol(2,3)
15888  ELSE
15889  CALL pushcontrol(2,2)
15890  END IF
15891  END SUBROUTINE xtp_u_fwd
15892 ! Differentiation of xtp_u in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
15893 !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
15894 !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
15895 !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_
15896 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
15897 ! 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
15898 !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
15899 !_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
15900 !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
15901 !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
15902 !_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
15903 !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
15904 !.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.
15905 !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
15906 !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
15907 !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
15908 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
15909 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15910 ! gradient of useful results: flux u c
15911 ! with respect to varying inputs: flux u c
15912  SUBROUTINE xtp_u_bwd(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u&
15913 & , u_ad, v, flux, flux_ad, iord, dx, rdx, npx, npy, grid_type, nested&
15914 & )
15915  IMPLICIT NONE
15916  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
15917  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
15918  REAL :: u_ad(isd:ied, jsd:jed+1)
15919  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
15920  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
15921  REAL :: c_ad(is:ie+1, js:je+1)
15922  REAL :: flux(is:ie+1, js:je+1)
15923  REAL :: flux_ad(is:ie+1, js:je+1)
15924  REAL, INTENT(IN) :: dx(isd:ied, jsd:jed+1)
15925  REAL, INTENT(IN) :: rdx(isd:ied, jsd:jed+1)
15926  INTEGER, INTENT(IN) :: iord, npx, npy, grid_type
15927  LOGICAL, INTENT(IN) :: nested
15928  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
15929  REAL, DIMENSION(is-1:ie+1) :: bl_ad, br_ad, b0_ad
15930  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
15931  REAL :: fx0(is:ie+1)
15932  REAL :: al(is-1:ie+2), dm(is-2:ie+2)
15933  REAL :: al_ad(is-1:ie+2)
15934  REAL :: dq(is-3:ie+2)
15935  REAL :: dl, dr, xt, pmp, lac, cfl
15936  REAL :: xt_ad, cfl_ad
15937  REAL :: pmp_1, lac_1, pmp_2, lac_2
15938  REAL :: x0, x1, x0l, x0r
15939  INTEGER :: i, j
15940  INTEGER :: is3, ie3
15941  INTEGER :: is2, ie2
15942  INTRINSIC max
15943  INTRINSIC min
15944  REAL :: temp_ad
15945  REAL :: temp_ad0
15946  REAL :: temp_ad1
15947  REAL :: temp_ad2
15948  REAL :: temp_ad3
15949  REAL :: temp_ad4
15950  INTEGER :: branch
15951  REAL :: temp_ad5
15952  REAL :: temp_ad6
15953  REAL :: temp_ad7
15954  REAL :: temp_ad8
15955  REAL :: temp_ad9
15956  REAL :: temp_ad10
15957  REAL :: temp_ad11
15958  REAL :: temp_ad12
15959  REAL :: temp_ad13
15960  REAL :: temp_ad14
15961 
15962  bl = 0.0
15963  br = 0.0
15964  b0 = 0.0
15965  fx0 = 0.0
15966  al = 0.0
15967  dm = 0.0
15968  dq = 0.0
15969  dl = 0.0
15970  dr = 0.0
15971  xt = 0.0
15972  pmp = 0.0
15973  lac = 0.0
15974  cfl = 0.0
15975  pmp_1 = 0.0
15976  lac_1 = 0.0
15977  pmp_2 = 0.0
15978  lac_2 = 0.0
15979  x0 = 0.0
15980  x1 = 0.0
15981  x0l = 0.0
15982  x0r = 0.0
15983  is3 = 0
15984  ie3 = 0
15985  is2 = 0
15986  ie2 = 0
15987  branch = 0
15988 
15989  CALL popcontrol(2,branch)
15990  IF (branch .LT. 2) THEN
15991  IF (branch .EQ. 0) THEN
15992  DO j=je+1,js,-1
15993  DO i=ie+1,is,-1
15994  CALL popcontrol(1,branch)
15995  IF (branch .EQ. 0) THEN
15996  CALL poprealarray(flux(i, j))
15997  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
15998  flux_ad(i, j) = 0.0
15999  ELSE
16000  CALL poprealarray(flux(i, j))
16001  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
16002  flux_ad(i, j) = 0.0
16003  END IF
16004  END DO
16005  END DO
16006  ELSE
16007  CALL poprealarray(flux, (ie-is+2)*(je-js+2))
16008  DO j=js,je+1
16009  DO i=is,ie+1
16010  IF (c(i, j) .GT. 0.) THEN
16011  CALL pushcontrol(1,1)
16012  ELSE
16013  CALL pushcontrol(1,0)
16014  END IF
16015  END DO
16016  DO i=ie+1,is,-1
16017  CALL popcontrol(1,branch)
16018  IF (branch .EQ. 0) THEN
16019  temp_ad10 = flux_ad(i, j)/6.0
16020  temp_ad11 = -(rdx(i, j)*0.5*flux_ad(i, j))
16021  temp_ad12 = c(i, j)*temp_ad11
16022  temp_ad13 = rdx(i, j)**2*flux_ad(i, j)
16023  temp_ad14 = c(i, j)**2*temp_ad13/6.0
16024  u_ad(i-1, j) = u_ad(i-1, j) + temp_ad14 - temp_ad12 + 2.0*&
16025 & temp_ad10
16026  u_ad(i, j) = u_ad(i, j) + temp_ad12 - 2.0*temp_ad14 + 5.0*&
16027 & temp_ad10
16028  u_ad(i+1, j) = u_ad(i+1, j) + temp_ad14 - temp_ad10
16029  c_ad(i, j) = c_ad(i, j) + (u(i+1, j)-2.0*u(i, j)+u(i-1, j)&
16030 & )*2*c(i, j)*temp_ad13/6.0 + (u(i, j)-u(i-1, j))*&
16031 & temp_ad11
16032  flux_ad(i, j) = 0.0
16033  ELSE
16034  temp_ad5 = flux_ad(i, j)/6.0
16035  temp_ad6 = -(rdx(i-1, j)*0.5*flux_ad(i, j))
16036  temp_ad7 = c(i, j)*temp_ad6
16037  temp_ad8 = rdx(i-1, j)**2*flux_ad(i, j)
16038  temp_ad9 = c(i, j)**2*temp_ad8/6.0
16039  u_ad(i, j) = u_ad(i, j) + temp_ad9 + temp_ad7 + 2.0*&
16040 & temp_ad5
16041  u_ad(i-1, j) = u_ad(i-1, j) + 5.0*temp_ad5 - temp_ad7 - &
16042 & 2.0*temp_ad9
16043  u_ad(i-2, j) = u_ad(i-2, j) + temp_ad9 - temp_ad5
16044  c_ad(i, j) = c_ad(i, j) + (u(i, j)-2.0*u(i-1, j)+u(i-2, j)&
16045 & )*2*c(i, j)*temp_ad8/6.0 + (u(i, j)-u(i-1, j))*temp_ad6
16046  flux_ad(i, j) = 0.0
16047  END IF
16048  END DO
16049  END DO
16050  END IF
16051  ELSE IF (branch .NE. 2) THEN
16052  CALL popinteger(is3)
16053  CALL poprealarray(bl, ie - is + 3)
16054  CALL poprealarray(br, ie - is + 3)
16055  CALL poprealarray(b0, ie - is + 3)
16056  CALL popinteger(ie3)
16057  al_ad = 0.0
16058  bl_ad = 0.0
16059  br_ad = 0.0
16060  b0_ad = 0.0
16061  DO j=je+1,js,-1
16062  CALL popcontrol(1,branch)
16063  IF (branch .NE. 0) THEN
16064  DO i=ie+1,is,-1
16065  CALL popcontrol(1,branch)
16066  IF (branch .EQ. 0) THEN
16067  cfl = c(i, j)*rdx(i, j)
16068  CALL poprealarray(flux(i, j))
16069  temp_ad4 = (cfl+1.)*flux_ad(i, j)
16070  u_ad(i, j) = u_ad(i, j) + flux_ad(i, j)
16071  cfl_ad = b0(i)*temp_ad4 + (bl(i)+cfl*b0(i))*flux_ad(i, j)
16072  bl_ad(i) = bl_ad(i) + temp_ad4
16073  b0_ad(i) = b0_ad(i) + cfl*temp_ad4
16074  flux_ad(i, j) = 0.0
16075  c_ad(i, j) = c_ad(i, j) + rdx(i, j)*cfl_ad
16076  ELSE
16077  cfl = c(i, j)*rdx(i-1, j)
16078  CALL poprealarray(flux(i, j))
16079  temp_ad3 = (1.-cfl)*flux_ad(i, j)
16080  u_ad(i-1, j) = u_ad(i-1, j) + flux_ad(i, j)
16081  cfl_ad = -(b0(i-1)*temp_ad3) - (br(i-1)-cfl*b0(i-1))*&
16082 & flux_ad(i, j)
16083  br_ad(i-1) = br_ad(i-1) + temp_ad3
16084  b0_ad(i-1) = b0_ad(i-1) - cfl*temp_ad3
16085  flux_ad(i, j) = 0.0
16086  c_ad(i, j) = c_ad(i, j) + rdx(i-1, j)*cfl_ad
16087  END IF
16088  END DO
16089  END IF
16090  DO i=ie+1,is-1,-1
16091  CALL poprealarray(b0(i))
16092  bl_ad(i) = bl_ad(i) + b0_ad(i)
16093  br_ad(i) = br_ad(i) + b0_ad(i)
16094  b0_ad(i) = 0.0
16095  END DO
16096  CALL popcontrol(2,branch)
16097  IF (branch .LT. 2) THEN
16098  IF (branch .EQ. 0) GOTO 100
16099  ELSE
16100  IF (branch .EQ. 2) THEN
16101  CALL poprealarray(br(npx))
16102  u_ad(npx, j) = u_ad(npx, j) + (c3-1.0)*br_ad(npx)
16103  u_ad(npx+1, j) = u_ad(npx+1, j) + c2*br_ad(npx)
16104  u_ad(npx+2, j) = u_ad(npx+2, j) + c1*br_ad(npx)
16105  br_ad(npx) = 0.0
16106  CALL poprealarray(bl(npx))
16107  xt_ad = br_ad(npx-1) + bl_ad(npx)
16108  u_ad(npx, j) = u_ad(npx, j) - bl_ad(npx)
16109  bl_ad(npx) = 0.0
16110  CALL poprealarray(br(npx-1))
16111  temp_ad1 = 0.5*xt_ad/(dx(npx-1, j)+dx(npx-2, j))
16112  u_ad(npx-1, j) = u_ad(npx-1, j) + (dx(npx-1, j)*2.+dx(npx-2&
16113 & , j))*temp_ad1 - br_ad(npx-1)
16114  br_ad(npx-1) = 0.0
16115  temp_ad2 = 0.5*xt_ad/(dx(npx, j)+dx(npx+1, j))
16116  u_ad(npx-2, j) = u_ad(npx-2, j) - dx(npx-1, j)*temp_ad1
16117  u_ad(npx, j) = u_ad(npx, j) + (dx(npx, j)*2.+dx(npx+1, j))*&
16118 & temp_ad2
16119  u_ad(npx+1, j) = u_ad(npx+1, j) - dx(npx, j)*temp_ad2
16120  ELSE
16121  CALL poprealarray(br(npx))
16122  br_ad(npx) = 0.0
16123  CALL poprealarray(bl(npx))
16124  bl_ad(npx) = 0.0
16125  CALL poprealarray(br(npx-1))
16126  br_ad(npx-1) = 0.0
16127  CALL poprealarray(bl(npx-1))
16128  bl_ad(npx-1) = 0.0
16129  END IF
16130  CALL poprealarray(bl(npx-1))
16131  xt_ad = br_ad(npx-2) + bl_ad(npx-1)
16132  u_ad(npx-1, j) = u_ad(npx-1, j) - bl_ad(npx-1)
16133  bl_ad(npx-1) = 0.0
16134  CALL poprealarray(br(npx-2))
16135  u_ad(npx-2, j) = u_ad(npx-2, j) - br_ad(npx-2)
16136  br_ad(npx-2) = 0.0
16137  u_ad(npx-3, j) = u_ad(npx-3, j) + c1*xt_ad
16138  u_ad(npx-2, j) = u_ad(npx-2, j) + c2*xt_ad
16139  u_ad(npx-1, j) = u_ad(npx-1, j) + c3*xt_ad
16140  CALL poprealarray(bl(npx-2))
16141  al_ad(npx-2) = al_ad(npx-2) + bl_ad(npx-2)
16142  u_ad(npx-2, j) = u_ad(npx-2, j) - bl_ad(npx-2)
16143  bl_ad(npx-2) = 0.0
16144  END IF
16145  CALL popcontrol(2,branch)
16146  IF (branch .EQ. 0) THEN
16147  CALL poprealarray(br(1))
16148  br_ad(1) = 0.0
16149  CALL poprealarray(bl(1))
16150  bl_ad(1) = 0.0
16151  CALL poprealarray(br(0))
16152  br_ad(0) = 0.0
16153  CALL poprealarray(bl(0))
16154  bl_ad(0) = 0.0
16155  ELSE IF (branch .EQ. 1) THEN
16156  CALL poprealarray(bl(1))
16157  xt_ad = br_ad(0) + bl_ad(1)
16158  u_ad(1, j) = u_ad(1, j) - bl_ad(1)
16159  bl_ad(1) = 0.0
16160  CALL poprealarray(br(0))
16161  temp_ad = 0.5*xt_ad/(dx(0, j)+dx(-1, j))
16162  u_ad(0, j) = u_ad(0, j) + (dx(0, j)*2.+dx(-1, j))*temp_ad - &
16163 & br_ad(0)
16164  br_ad(0) = 0.0
16165  temp_ad0 = 0.5*xt_ad/(dx(1, j)+dx(2, j))
16166  u_ad(-1, j) = u_ad(-1, j) - dx(0, j)*temp_ad
16167  u_ad(1, j) = u_ad(1, j) + (dx(1, j)*2.+dx(2, j))*temp_ad0
16168  u_ad(2, j) = u_ad(2, j) - dx(1, j)*temp_ad0
16169  CALL poprealarray(bl(0))
16170  u_ad(-2, j) = u_ad(-2, j) + c1*bl_ad(0)
16171  u_ad(-1, j) = u_ad(-1, j) + c2*bl_ad(0)
16172  u_ad(0, j) = u_ad(0, j) + (c3-1.0)*bl_ad(0)
16173  bl_ad(0) = 0.0
16174  ELSE
16175  GOTO 100
16176  END IF
16177  CALL poprealarray(br(2))
16178  al_ad(3) = al_ad(3) + br_ad(2)
16179  u_ad(2, j) = u_ad(2, j) - bl_ad(2) - br_ad(2)
16180  br_ad(2) = 0.0
16181  CALL poprealarray(bl(2))
16182  xt_ad = br_ad(1) + bl_ad(2)
16183  bl_ad(2) = 0.0
16184  CALL poprealarray(br(1))
16185  u_ad(1, j) = u_ad(1, j) + c3*xt_ad - br_ad(1)
16186  br_ad(1) = 0.0
16187  u_ad(2, j) = u_ad(2, j) + c2*xt_ad
16188  u_ad(3, j) = u_ad(3, j) + c1*xt_ad
16189  100 DO i=ie3,is3,-1
16190  CALL poprealarray(br(i))
16191  al_ad(i+1) = al_ad(i+1) + br_ad(i)
16192  u_ad(i, j) = u_ad(i, j) - bl_ad(i) - br_ad(i)
16193  br_ad(i) = 0.0
16194  CALL poprealarray(bl(i))
16195  al_ad(i) = al_ad(i) + bl_ad(i)
16196  bl_ad(i) = 0.0
16197  END DO
16198  DO i=ie3+1,is3,-1
16199  u_ad(i-1, j) = u_ad(i-1, j) + p1*al_ad(i)
16200  u_ad(i, j) = u_ad(i, j) + p1*al_ad(i)
16201  u_ad(i-2, j) = u_ad(i-2, j) + p2*al_ad(i)
16202  u_ad(i+1, j) = u_ad(i+1, j) + p2*al_ad(i)
16203  al_ad(i) = 0.0
16204  END DO
16205  END DO
16206  END IF
16207  CALL popcontrol(1,branch)
16208  END SUBROUTINE xtp_u_bwd
16209 ! Differentiation of ytp_v in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
16210 !.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_mo
16211 !d.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.mix
16212 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
16213 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
16214 !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.rema
16215 !p_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_
16216 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
16217 !_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_res
16218 !tart_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_
16219 !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_mo
16220 !d.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.
16221 !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.n
16222 !est_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.d2a2
16223 !c_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
16224 ! 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_mo
16225 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
16226 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
16227 ! gradient of useful results: flux v c
16228 ! with respect to varying inputs: v c
16229  SUBROUTINE ytp_v_fwd(is, ie, js, je, isd, ied, jsd, jed, c, u, v, &
16230 & flux, jord, dy, rdy, npx, npy, grid_type, nested)
16231  IMPLICIT NONE
16232  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
16233  INTEGER, INTENT(IN) :: jord
16234  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
16235  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
16236 ! Courant N (like FLUX)
16237  REAL, INTENT(IN) :: c(is:ie+1, js:je+1)
16238  REAL :: flux(is:ie+1, js:je+1)
16239  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
16240  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
16241  INTEGER, INTENT(IN) :: npx, npy, grid_type
16242  LOGICAL, INTENT(IN) :: nested
16243 ! Local:
16244  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
16245  REAL :: fx0(is:ie+1)
16246  REAL :: dm(is:ie+1, js-2:je+2)
16247  REAL :: al(is:ie+1, js-1:je+2)
16248  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
16249  REAL :: dq(is:ie+1, js-3:je+2)
16250  REAL :: xt, dl, dr, pmp, lac, cfl
16251  REAL :: pmp_1, lac_1, pmp_2, lac_2
16252  REAL :: x0, x1, x0r, x0l
16253  INTEGER :: i, j, is1, ie1, js3, je3
16254  INTRINSIC max
16255  INTRINSIC min
16256 
16257  fx0 = 0.0
16258  dm = 0.0
16259  al = 0.0
16260  bl = 0.0
16261  br = 0.0
16262  b0 = 0.0
16263  dq = 0.0
16264  xt = 0.0
16265  dl = 0.0
16266  dr = 0.0
16267  pmp = 0.0
16268  lac = 0.0
16269  cfl = 0.0
16270  pmp_1 = 0.0
16271  lac_1 = 0.0
16272  pmp_2 = 0.0
16273  lac_2 = 0.0
16274  x0 = 0.0
16275  x1 = 0.0
16276  x0r = 0.0
16277  x0l = 0.0
16278  is1 = 0
16279  ie1 = 0
16280  js3 = 0
16281  je3 = 0
16282 
16283  IF (nested .OR. grid_type .GT. 3) THEN
16284  CALL pushcontrol(1,0)
16285  js3 = js - 1
16286  je3 = je + 1
16287  ELSE
16288  IF (3 .LT. js - 1) THEN
16289  js3 = js - 1
16290  ELSE
16291  js3 = 3
16292  END IF
16293  IF (npy - 3 .GT. je + 1) THEN
16294  CALL pushcontrol(1,1)
16295  je3 = je + 1
16296  ELSE
16297  CALL pushcontrol(1,1)
16298  je3 = npy - 3
16299  END IF
16300  END IF
16301  IF (jord .EQ. 1) THEN
16302  DO j=js,je+1
16303  DO i=is,ie+1
16304  IF (c(i, j) .GT. 0.) THEN
16305  flux(i, j) = v(i, j-1)
16306  CALL pushcontrol(1,1)
16307  ELSE
16308  flux(i, j) = v(i, j)
16309  CALL pushcontrol(1,0)
16310  END IF
16311  END DO
16312  END DO
16313  CALL pushcontrol(3,0)
16314  ELSE IF (jord .EQ. 333) THEN
16315  CALL pushrealarray(c, (ie-is+2)*(je-js+2))
16316  DO j=js,je+1
16317  DO i=is,ie+1
16318  IF (c(i, j) .GT. 0.) THEN
16319  flux(i, j) = (2.0*v(i, j)+5.0*v(i, j-1)-v(i, j-2))/6.0 - 0.5&
16320 & *c(i, j)*rdy(i, j-1)*(v(i, j)-v(i, j-1)) + c(i, j)*rdy(i, &
16321 & j-1)*c(i, j)*rdy(i, j-1)/6.0*(v(i, j)-2.0*v(i, j-1)+v(i, j&
16322 & -2))
16323  ELSE
16324  flux(i, j) = (2.0*v(i, j-1)+5.0*v(i, j)-v(i, j+1))/6.0 - 0.5&
16325 & *c(i, j)*rdy(i, j)*(v(i, j)-v(i, j-1)) + c(i, j)*rdy(i, j)&
16326 & *c(i, j)*rdy(i, j)/6.0*(v(i, j+1)-2.0*v(i, j)+v(i, j-1))
16327  END IF
16328  END DO
16329  END DO
16330  CALL pushcontrol(3,1)
16331  ELSE IF (jord .LT. 8) THEN
16332 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
16333  DO j=js3,je3+1
16334  DO i=is,ie+1
16335  al(i, j) = p1*(v(i, j-1)+v(i, j)) + p2*(v(i, j-2)+v(i, j+1))
16336  END DO
16337  END DO
16338  DO j=js3,je3
16339  DO i=is,ie+1
16340  bl(i, j) = al(i, j) - v(i, j)
16341  br(i, j) = al(i, j+1) - v(i, j)
16342  END DO
16343  END DO
16344  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
16345  IF (js .EQ. 1) THEN
16346  DO i=is,ie+1
16347  bl(i, 0) = c1*v(i, -2) + c2*v(i, -1) + c3*v(i, 0) - v(i, 0)
16348  xt = 0.5*(((2.*dy(i, 0)+dy(i, -1))*v(i, 0)-dy(i, 0)*v(i, -1)&
16349 & )/(dy(i, 0)+dy(i, -1))+((2.*dy(i, 1)+dy(i, 2))*v(i, 1)-dy(&
16350 & i, 1)*v(i, 2))/(dy(i, 1)+dy(i, 2)))
16351  br(i, 0) = xt - v(i, 0)
16352  bl(i, 1) = xt - v(i, 1)
16353  xt = c3*v(i, 1) + c2*v(i, 2) + c1*v(i, 3)
16354  br(i, 1) = xt - v(i, 1)
16355  bl(i, 2) = xt - v(i, 2)
16356  br(i, 2) = al(i, 3) - v(i, 2)
16357  END DO
16358  IF (is .EQ. 1) THEN
16359 ! out
16360  bl(1, 0) = 0.
16361 ! edge
16362  br(1, 0) = 0.
16363 ! edge
16364  bl(1, 1) = 0.
16365 ! in
16366  br(1, 1) = 0.
16367  CALL pushcontrol(1,0)
16368  ELSE
16369  CALL pushcontrol(1,1)
16370  END IF
16371  IF (ie + 1 .EQ. npx) THEN
16372 ! out
16373  bl(npx, 0) = 0.
16374 ! edge
16375  br(npx, 0) = 0.
16376 ! edge
16377  bl(npx, 1) = 0.
16378 ! in
16379  br(npx, 1) = 0.
16380  CALL pushcontrol(2,0)
16381  ELSE
16382  CALL pushcontrol(2,1)
16383  END IF
16384  ELSE
16385  CALL pushcontrol(2,2)
16386  END IF
16387 ! j=2
16388 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
16389  IF (je + 1 .EQ. npy) THEN
16390  DO i=is,ie+1
16391  bl(i, npy-2) = al(i, npy-2) - v(i, npy-2)
16392  xt = c1*v(i, npy-3) + c2*v(i, npy-2) + c3*v(i, npy-1)
16393  br(i, npy-2) = xt - v(i, npy-2)
16394  bl(i, npy-1) = xt - v(i, npy-1)
16395  xt = 0.5*(((2.*dy(i, npy-1)+dy(i, npy-2))*v(i, npy-1)-dy(i, &
16396 & npy-1)*v(i, npy-2))/(dy(i, npy-1)+dy(i, npy-2))+((2.*dy(i&
16397 & , npy)+dy(i, npy+1))*v(i, npy)-dy(i, npy)*v(i, npy+1))/(dy&
16398 & (i, npy)+dy(i, npy+1)))
16399  br(i, npy-1) = xt - v(i, npy-1)
16400  bl(i, npy) = xt - v(i, npy)
16401  br(i, npy) = c3*v(i, npy) + c2*v(i, npy+1) + c1*v(i, npy+2) &
16402 & - v(i, npy)
16403  END DO
16404  IF (is .EQ. 1) THEN
16405 ! in
16406  bl(1, npy-1) = 0.
16407 ! edge
16408  br(1, npy-1) = 0.
16409 ! edge
16410  bl(1, npy) = 0.
16411 ! out
16412  br(1, npy) = 0.
16413  CALL pushcontrol(1,0)
16414  ELSE
16415  CALL pushcontrol(1,1)
16416  END IF
16417  IF (ie + 1 .EQ. npx) THEN
16418 ! in
16419  bl(npx, npy-1) = 0.
16420 ! edge
16421  br(npx, npy-1) = 0.
16422 ! edge
16423  bl(npx, npy) = 0.
16424 ! out
16425  br(npx, npy) = 0.
16426  CALL pushcontrol(2,3)
16427  ELSE
16428  CALL pushcontrol(2,2)
16429  END IF
16430  ELSE
16431  CALL pushcontrol(2,1)
16432  END IF
16433  ELSE
16434  CALL pushcontrol(2,0)
16435  END IF
16436 ! j=npy-2
16437 ! call pert_ppm(ie-is+2, v(is,j), bl(is,j), br(is,j), -1)
16438  DO j=js-1,je+1
16439  DO i=is,ie+1
16440  b0(i, j) = bl(i, j) + br(i, j)
16441  END DO
16442  END DO
16443  IF (jord .EQ. 2) THEN
16444 ! Perfectly linear
16445  DO j=js,je+1
16446 !DEC$ VECTOR ALWAYS
16447  DO i=is,ie+1
16448  IF (c(i, j) .GT. 0.) THEN
16449  CALL pushrealarray(cfl)
16450  cfl = c(i, j)*rdy(i, j-1)
16451  flux(i, j) = v(i, j-1) + (1.-cfl)*(br(i, j-1)-cfl*b0(i, j-&
16452 & 1))
16453  CALL pushcontrol(1,1)
16454  ELSE
16455  CALL pushrealarray(cfl)
16456  cfl = c(i, j)*rdy(i, j)
16457  flux(i, j) = v(i, j) + (1.+cfl)*(bl(i, j)+cfl*b0(i, j))
16458  CALL pushcontrol(1,0)
16459  END IF
16460  END DO
16461  END DO
16462  CALL pushrealarray(b0, (ie-is+2)*(je-js+3))
16463  CALL pushinteger(js3)
16464  CALL pushrealarray(br, (ie-is+2)*(je-js+3))
16465  CALL pushinteger(je3)
16466  CALL pushrealarray(bl, (ie-is+2)*(je-js+3))
16467  CALL pushrealarray(cfl)
16468  CALL pushcontrol(3,4)
16469  ELSE
16470  CALL pushinteger(js3)
16471  CALL pushinteger(je3)
16472  CALL pushcontrol(3,3)
16473  END IF
16474  ELSE
16475  CALL pushcontrol(3,2)
16476  END IF
16477  END SUBROUTINE ytp_v_fwd
16478 ! Differentiation of ytp_v in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
16479 !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
16480 !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
16481 !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_
16482 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
16483 ! 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
16484 !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
16485 !_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
16486 !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
16487 !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
16488 !_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
16489 !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
16490 !.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.
16491 !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
16492 !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
16493 !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
16494 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
16495 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
16496 ! gradient of useful results: flux v c
16497 ! with respect to varying inputs: v c
16498  SUBROUTINE ytp_v_bwd(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u&
16499 & , v, v_ad, flux, flux_ad, jord, dy, rdy, npx, npy, grid_type, nested&
16500 & )
16501  IMPLICIT NONE
16502  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed
16503  INTEGER, INTENT(IN) :: jord
16504  REAL, INTENT(IN) :: u(isd:ied, jsd:jed+1)
16505  REAL, INTENT(IN) :: v(isd:ied+1, jsd:jed)
16506  REAL :: v_ad(isd:ied+1, jsd:jed)
16507  REAL, INTENT(INOUT) :: c(is:ie+1, js:je+1)
16508  REAL :: c_ad(is:ie+1, js:je+1)
16509  REAL :: flux(is:ie+1, js:je+1)
16510  REAL :: flux_ad(is:ie+1, js:je+1)
16511  REAL, INTENT(IN) :: dy(isd:ied+1, jsd:jed)
16512  REAL, INTENT(IN) :: rdy(isd:ied+1, jsd:jed)
16513  INTEGER, INTENT(IN) :: npx, npy, grid_type
16514  LOGICAL, INTENT(IN) :: nested
16515  LOGICAL, DIMENSION(is:ie+1, js-1:je+1) :: smt5, smt6
16516  REAL :: fx0(is:ie+1)
16517  REAL :: dm(is:ie+1, js-2:je+2)
16518  REAL :: al(is:ie+1, js-1:je+2)
16519  REAL :: al_ad(is:ie+1, js-1:je+2)
16520  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl, br, b0
16521  REAL, DIMENSION(is:ie+1, js-1:je+1) :: bl_ad, br_ad, b0_ad
16522  REAL :: dq(is:ie+1, js-3:je+2)
16523  REAL :: xt, dl, dr, pmp, lac, cfl
16524  REAL :: xt_ad, cfl_ad
16525  REAL :: pmp_1, lac_1, pmp_2, lac_2
16526  REAL :: x0, x1, x0r, x0l
16527  INTEGER :: i, j, is1, ie1, js3, je3
16528  INTRINSIC max
16529  INTRINSIC min
16530  REAL :: temp_ad
16531  REAL :: temp_ad0
16532  REAL :: temp_ad1
16533  REAL :: temp_ad2
16534  REAL :: temp_ad3
16535  REAL :: temp_ad4
16536  INTEGER :: branch
16537  REAL :: temp_ad5
16538  REAL :: temp_ad6
16539  REAL :: temp_ad7
16540  REAL :: temp_ad8
16541  REAL :: temp_ad9
16542  REAL :: temp_ad10
16543  REAL :: temp_ad11
16544  REAL :: temp_ad12
16545  REAL :: temp_ad13
16546  REAL :: temp_ad14
16547 
16548  fx0 = 0.0
16549  dm = 0.0
16550  al = 0.0
16551  bl = 0.0
16552  br = 0.0
16553  b0 = 0.0
16554  dq = 0.0
16555  xt = 0.0
16556  dl = 0.0
16557  dr = 0.0
16558  pmp = 0.0
16559  lac = 0.0
16560  cfl = 0.0
16561  pmp_1 = 0.0
16562  lac_1 = 0.0
16563  pmp_2 = 0.0
16564  lac_2 = 0.0
16565  x0 = 0.0
16566  x1 = 0.0
16567  x0r = 0.0
16568  x0l = 0.0
16569  is1 = 0
16570  ie1 = 0
16571  js3 = 0
16572  je3 = 0
16573  branch = 0
16574 
16575  CALL popcontrol(3,branch)
16576  IF (branch .LT. 2) THEN
16577  IF (branch .EQ. 0) THEN
16578  DO j=je+1,js,-1
16579  DO i=ie+1,is,-1
16580  CALL popcontrol(1,branch)
16581  IF (branch .EQ. 0) THEN
16582  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
16583  flux_ad(i, j) = 0.0
16584  ELSE
16585  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
16586  flux_ad(i, j) = 0.0
16587  END IF
16588  END DO
16589  END DO
16590  ELSE
16591  CALL poprealarray(c, (ie-is+2)*(je-js+2))
16592  DO j=js,je+1
16593  DO i=is,ie+1
16594  IF (c(i, j) .GT. 0.) THEN
16595  CALL pushcontrol(1,1)
16596  ELSE
16597  CALL pushcontrol(1,0)
16598  END IF
16599  END DO
16600  DO i=ie+1,is,-1
16601  CALL popcontrol(1,branch)
16602  IF (branch .EQ. 0) THEN
16603  temp_ad10 = flux_ad(i, j)/6.0
16604  temp_ad11 = -(rdy(i, j)*0.5*flux_ad(i, j))
16605  temp_ad12 = c(i, j)*temp_ad11
16606  temp_ad13 = rdy(i, j)**2*flux_ad(i, j)
16607  temp_ad14 = c(i, j)**2*temp_ad13/6.0
16608  v_ad(i, j-1) = v_ad(i, j-1) + temp_ad14 - temp_ad12 + 2.0*&
16609 & temp_ad10
16610  v_ad(i, j) = v_ad(i, j) + temp_ad12 - 2.0*temp_ad14 + 5.0*&
16611 & temp_ad10
16612  v_ad(i, j+1) = v_ad(i, j+1) + temp_ad14 - temp_ad10
16613  c_ad(i, j) = c_ad(i, j) + (v(i, j+1)-2.0*v(i, j)+v(i, j-1)&
16614 & )*2*c(i, j)*temp_ad13/6.0 + (v(i, j)-v(i, j-1))*&
16615 & temp_ad11
16616  flux_ad(i, j) = 0.0
16617  ELSE
16618  temp_ad5 = flux_ad(i, j)/6.0
16619  temp_ad6 = -(rdy(i, j-1)*0.5*flux_ad(i, j))
16620  temp_ad7 = c(i, j)*temp_ad6
16621  temp_ad8 = rdy(i, j-1)**2*flux_ad(i, j)
16622  temp_ad9 = c(i, j)**2*temp_ad8/6.0
16623  v_ad(i, j) = v_ad(i, j) + temp_ad9 + temp_ad7 + 2.0*&
16624 & temp_ad5
16625  v_ad(i, j-1) = v_ad(i, j-1) + 5.0*temp_ad5 - temp_ad7 - &
16626 & 2.0*temp_ad9
16627  v_ad(i, j-2) = v_ad(i, j-2) + temp_ad9 - temp_ad5
16628  c_ad(i, j) = c_ad(i, j) + (v(i, j)-2.0*v(i, j-1)+v(i, j-2)&
16629 & )*2*c(i, j)*temp_ad8/6.0 + (v(i, j)-v(i, j-1))*temp_ad6
16630  flux_ad(i, j) = 0.0
16631  END IF
16632  END DO
16633  END DO
16634  END IF
16635  ELSE IF (branch .NE. 2) THEN
16636  IF (branch .EQ. 3) THEN
16637  CALL popinteger(je3)
16638  CALL popinteger(js3)
16639  bl_ad = 0.0
16640  br_ad = 0.0
16641  b0_ad = 0.0
16642  ELSE
16643  CALL poprealarray(cfl)
16644  CALL poprealarray(bl, (ie-is+2)*(je-js+3))
16645  CALL popinteger(je3)
16646  CALL poprealarray(br, (ie-is+2)*(je-js+3))
16647  CALL popinteger(js3)
16648  CALL poprealarray(b0, (ie-is+2)*(je-js+3))
16649  bl_ad = 0.0
16650  br_ad = 0.0
16651  b0_ad = 0.0
16652  DO j=je+1,js,-1
16653  DO i=ie+1,is,-1
16654  CALL popcontrol(1,branch)
16655  IF (branch .EQ. 0) THEN
16656  temp_ad4 = (cfl+1.)*flux_ad(i, j)
16657  v_ad(i, j) = v_ad(i, j) + flux_ad(i, j)
16658  cfl_ad = b0(i, j)*temp_ad4 + (bl(i, j)+cfl*b0(i, j))*&
16659 & flux_ad(i, j)
16660  bl_ad(i, j) = bl_ad(i, j) + temp_ad4
16661  b0_ad(i, j) = b0_ad(i, j) + cfl*temp_ad4
16662  flux_ad(i, j) = 0.0
16663  CALL poprealarray(cfl)
16664  c_ad(i, j) = c_ad(i, j) + rdy(i, j)*cfl_ad
16665  ELSE
16666  temp_ad3 = (1.-cfl)*flux_ad(i, j)
16667  v_ad(i, j-1) = v_ad(i, j-1) + flux_ad(i, j)
16668  cfl_ad = -(b0(i, j-1)*temp_ad3) - (br(i, j-1)-cfl*b0(i, j-&
16669 & 1))*flux_ad(i, j)
16670  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad3
16671  b0_ad(i, j-1) = b0_ad(i, j-1) - cfl*temp_ad3
16672  flux_ad(i, j) = 0.0
16673  CALL poprealarray(cfl)
16674  c_ad(i, j) = c_ad(i, j) + rdy(i, j-1)*cfl_ad
16675  END IF
16676  END DO
16677  END DO
16678  END IF
16679  DO j=je+1,js-1,-1
16680  DO i=ie+1,is,-1
16681  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
16682  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
16683  b0_ad(i, j) = 0.0
16684  END DO
16685  END DO
16686  CALL popcontrol(2,branch)
16687  IF (branch .LT. 2) THEN
16688  IF (branch .EQ. 0) THEN
16689  al_ad = 0.0
16690  GOTO 100
16691  ELSE
16692  al_ad = 0.0
16693  END IF
16694  ELSE
16695  IF (branch .NE. 2) THEN
16696  br_ad(npx, npy) = 0.0
16697  bl_ad(npx, npy) = 0.0
16698  br_ad(npx, npy-1) = 0.0
16699  bl_ad(npx, npy-1) = 0.0
16700  END IF
16701  CALL popcontrol(1,branch)
16702  IF (branch .EQ. 0) THEN
16703  br_ad(1, npy) = 0.0
16704  bl_ad(1, npy) = 0.0
16705  br_ad(1, npy-1) = 0.0
16706  bl_ad(1, npy-1) = 0.0
16707  END IF
16708  al_ad = 0.0
16709  DO i=ie+1,is,-1
16710  v_ad(i, npy) = v_ad(i, npy) + (c3-1.0)*br_ad(i, npy)
16711  v_ad(i, npy+1) = v_ad(i, npy+1) + c2*br_ad(i, npy)
16712  v_ad(i, npy+2) = v_ad(i, npy+2) + c1*br_ad(i, npy)
16713  br_ad(i, npy) = 0.0
16714  xt_ad = br_ad(i, npy-1) + bl_ad(i, npy)
16715  v_ad(i, npy) = v_ad(i, npy) - bl_ad(i, npy)
16716  bl_ad(i, npy) = 0.0
16717  temp_ad1 = 0.5*xt_ad/(dy(i, npy-1)+dy(i, npy-2))
16718  v_ad(i, npy-1) = v_ad(i, npy-1) + (dy(i, npy-1)*2.+dy(i, npy-2&
16719 & ))*temp_ad1 - br_ad(i, npy-1)
16720  br_ad(i, npy-1) = 0.0
16721  temp_ad2 = 0.5*xt_ad/(dy(i, npy)+dy(i, npy+1))
16722  v_ad(i, npy-2) = v_ad(i, npy-2) - dy(i, npy-1)*temp_ad1
16723  v_ad(i, npy) = v_ad(i, npy) + (dy(i, npy)*2.+dy(i, npy+1))*&
16724 & temp_ad2
16725  v_ad(i, npy+1) = v_ad(i, npy+1) - dy(i, npy)*temp_ad2
16726  xt_ad = br_ad(i, npy-2) + bl_ad(i, npy-1)
16727  v_ad(i, npy-1) = v_ad(i, npy-1) - bl_ad(i, npy-1)
16728  bl_ad(i, npy-1) = 0.0
16729  v_ad(i, npy-2) = v_ad(i, npy-2) - br_ad(i, npy-2)
16730  br_ad(i, npy-2) = 0.0
16731  v_ad(i, npy-3) = v_ad(i, npy-3) + c1*xt_ad
16732  v_ad(i, npy-2) = v_ad(i, npy-2) + c2*xt_ad
16733  v_ad(i, npy-1) = v_ad(i, npy-1) + c3*xt_ad
16734  al_ad(i, npy-2) = al_ad(i, npy-2) + bl_ad(i, npy-2)
16735  v_ad(i, npy-2) = v_ad(i, npy-2) - bl_ad(i, npy-2)
16736  bl_ad(i, npy-2) = 0.0
16737  END DO
16738  END IF
16739  CALL popcontrol(2,branch)
16740  IF (branch .EQ. 0) THEN
16741  br_ad(npx, 1) = 0.0
16742  bl_ad(npx, 1) = 0.0
16743  br_ad(npx, 0) = 0.0
16744  bl_ad(npx, 0) = 0.0
16745  ELSE IF (branch .NE. 1) THEN
16746  GOTO 100
16747  END IF
16748  CALL popcontrol(1,branch)
16749  IF (branch .EQ. 0) THEN
16750  br_ad(1, 1) = 0.0
16751  bl_ad(1, 1) = 0.0
16752  br_ad(1, 0) = 0.0
16753  bl_ad(1, 0) = 0.0
16754  END IF
16755  DO i=ie+1,is,-1
16756  al_ad(i, 3) = al_ad(i, 3) + br_ad(i, 2)
16757  v_ad(i, 2) = v_ad(i, 2) - bl_ad(i, 2) - br_ad(i, 2)
16758  br_ad(i, 2) = 0.0
16759  xt_ad = br_ad(i, 1) + bl_ad(i, 2)
16760  bl_ad(i, 2) = 0.0
16761  v_ad(i, 1) = v_ad(i, 1) + c3*xt_ad - br_ad(i, 1)
16762  br_ad(i, 1) = 0.0
16763  v_ad(i, 2) = v_ad(i, 2) + c2*xt_ad
16764  v_ad(i, 3) = v_ad(i, 3) + c1*xt_ad
16765  xt_ad = br_ad(i, 0) + bl_ad(i, 1)
16766  v_ad(i, 1) = v_ad(i, 1) - bl_ad(i, 1)
16767  bl_ad(i, 1) = 0.0
16768  temp_ad = 0.5*xt_ad/(dy(i, 0)+dy(i, -1))
16769  v_ad(i, 0) = v_ad(i, 0) + (dy(i, 0)*2.+dy(i, -1))*temp_ad - &
16770 & br_ad(i, 0)
16771  br_ad(i, 0) = 0.0
16772  temp_ad0 = 0.5*xt_ad/(dy(i, 1)+dy(i, 2))
16773  v_ad(i, -1) = v_ad(i, -1) - dy(i, 0)*temp_ad
16774  v_ad(i, 1) = v_ad(i, 1) + (dy(i, 1)*2.+dy(i, 2))*temp_ad0
16775  v_ad(i, 2) = v_ad(i, 2) - dy(i, 1)*temp_ad0
16776  v_ad(i, -2) = v_ad(i, -2) + c1*bl_ad(i, 0)
16777  v_ad(i, -1) = v_ad(i, -1) + c2*bl_ad(i, 0)
16778  v_ad(i, 0) = v_ad(i, 0) + (c3-1.0)*bl_ad(i, 0)
16779  bl_ad(i, 0) = 0.0
16780  END DO
16781  100 DO j=je3,js3,-1
16782  DO i=ie+1,is,-1
16783  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
16784  v_ad(i, j) = v_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
16785  br_ad(i, j) = 0.0
16786  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
16787  bl_ad(i, j) = 0.0
16788  END DO
16789  END DO
16790  DO j=je3+1,js3,-1
16791  DO i=ie+1,is,-1
16792  v_ad(i, j-1) = v_ad(i, j-1) + p1*al_ad(i, j)
16793  v_ad(i, j) = v_ad(i, j) + p1*al_ad(i, j)
16794  v_ad(i, j-2) = v_ad(i, j-2) + p2*al_ad(i, j)
16795  v_ad(i, j+1) = v_ad(i, j+1) + p2*al_ad(i, j)
16796  al_ad(i, j) = 0.0
16797  END DO
16798  END DO
16799  END IF
16800  CALL popcontrol(1,branch)
16801  END SUBROUTINE ytp_v_bwd
16802 ! Differentiation of compute_divergence_damping in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
16803 !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_core
16804 !_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.
16805 !mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleig
16806 !h_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_or
16807 !d4 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.r
16808 !emap_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
16809 !fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
16810 ! 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_
16811 !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_subgr
16812 !id_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
16813 !_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_m
16814 !od.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mo
16815 !d.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.d
16816 !2a2c_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
16817 !_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
16818 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
16819 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
16820 ! gradient of useful results: u v ke ua uc ptc delpc va vc
16821 ! vort divg_d wk
16822 ! with respect to varying inputs: u v ke ua uc ptc delpc va vc
16823 ! divg_d wk
16824  SUBROUTINE compute_divergence_damping_adm(nord, d2_bg, d4_bg, dddmp, &
16825 & dt, vort, vort_ad, ptc, ptc_ad, delpc, delpc_ad, ke, ke_ad, u, u_ad&
16826 & , v, v_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, &
16827 & divg_d_ad, wk, wk_ad, gridstruct, flagstruct, bd)
16828  IMPLICIT NONE
16829 !InOut Arguments
16830  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
16831  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
16832  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
16833  INTEGER, INTENT(IN) :: nord
16834  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
16835  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
16836  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua_ad, va_ad
16837  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
16838  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
16839  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
16840  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
16841 !Intent is really in
16842  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
16843  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
16844 & wk_ad
16845  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
16846  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
16847 & vort_ad
16848  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
16849 & delpc, ptc
16850  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
16851 & delpc_ad, ptc_ad
16852  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
16853 & ke
16854  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
16855 & ke_ad
16856  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
16857  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
16858 & vc_ad
16859  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
16860  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
16861 & uc_ad
16862  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
16863 & divg_d
16864  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
16865 & divg_d_ad
16866 !Locals
16867  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
16868  REAL :: damp_ad, damp2_ad
16869  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
16870  LOGICAL :: nested, fill_c
16871  INTEGER :: i, j, n, n2, nt
16872  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
16873  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
16874  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
16875  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
16876  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
16877  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
16878  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
16879  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
16880 & , rdx, rdy
16881  INTRINSIC ABS
16882  INTRINSIC max
16883  INTRINSIC min
16884  INTRINSIC sqrt
16885  REAL :: max1
16886  REAL :: max1_ad
16887  REAL :: abs0
16888  REAL :: abs1
16889  REAL :: max2
16890  REAL :: max2_ad
16891  REAL :: abs2
16892  REAL :: abs2_ad
16893  REAL :: temp_ad
16894  REAL :: temp_ad0
16895  REAL :: temp_ad1
16896  REAL :: temp_ad2
16897  REAL :: temp_ad3
16898  REAL :: temp_ad4
16899  REAL :: temp_ad5
16900  REAL :: temp_ad6
16901  REAL :: y3_ad
16902  REAL :: y1_ad
16903  REAL :: temp_ad7
16904  REAL :: temp_ad8
16905  REAL :: temp_ad9
16906  REAL :: y2_ad
16907  INTEGER :: branch
16908  INTEGER :: ad_from
16909  INTEGER :: ad_to
16910  INTEGER :: ad_from0
16911  INTEGER :: ad_to0
16912  INTEGER :: ad_from1
16913  INTEGER :: ad_to1
16914  INTEGER :: ad_from2
16915  INTEGER :: ad_to2
16916  INTEGER :: ad_from3
16917  INTEGER :: ad_to3
16918  INTEGER :: ad_from4
16919  INTEGER :: ad_to4
16920  INTEGER :: ad_from5
16921  INTEGER :: ad_to5
16922  INTEGER :: ad_from6
16923  INTEGER :: ad_to6
16924  REAL :: y3
16925  REAL :: y2
16926  REAL :: y1
16927  sin_sg => gridstruct%sin_sg
16928  cosa_u => gridstruct%cosa_u
16929  cosa_v => gridstruct%cosa_v
16930  sina_u => gridstruct%sina_u
16931  sina_v => gridstruct%sina_v
16932  divg_u => gridstruct%divg_u
16933  divg_v => gridstruct%divg_v
16934  dxc => gridstruct%dxc
16935  dyc => gridstruct%dyc
16936  sw_corner = gridstruct%sw_corner
16937  se_corner = gridstruct%se_corner
16938  nw_corner = gridstruct%nw_corner
16939  ne_corner = gridstruct%ne_corner
16940  is = bd%is
16941  ie = bd%ie
16942  js = bd%js
16943  je = bd%je
16944  npx = flagstruct%npx
16945  npy = flagstruct%npy
16946  nested = gridstruct%nested
16947  IF (nested) THEN
16948  CALL pushcontrol1b(0)
16949  is2 = is
16950  ie1 = ie + 1
16951  ELSE
16952  IF (2 .LT. is) THEN
16953  is2 = is
16954  ELSE
16955  is2 = 2
16956  END IF
16957  IF (npx - 1 .GT. ie + 1) THEN
16958  CALL pushcontrol1b(1)
16959  ie1 = ie + 1
16960  ELSE
16961  CALL pushcontrol1b(1)
16962  ie1 = npx - 1
16963  END IF
16964  END IF
16965 !-----------------------------
16966 ! Compute divergence damping
16967 !-----------------------------
16968 ! damp = dddmp * da_min_c
16969  IF (nord .EQ. 0) THEN
16970 ! area ~ dxb*dyb*sin(alpha)
16971  IF (nested) THEN
16972  DO j=js,je+1
16973  DO i=is-1,ie+1
16974  CALL pushrealarray_adm(ptc(i, j))
16975  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j))&
16976 & *dyc(i, j)*sina_v(i, j)
16977  END DO
16978  END DO
16979  DO j=js-1,je+1
16980  DO i=is2,ie1
16981  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
16982 & )*dxc(i, j)*sina_u(i, j)
16983  END DO
16984  END DO
16985  CALL pushcontrol1b(1)
16986  ELSE
16987  DO j=js,je+1
16988  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
16989  DO i=is-1,ie+1
16990  IF (vc(i, j) .GT. 0) THEN
16991  CALL pushrealarray_adm(ptc(i, j))
16992  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j-1, 4)
16993  CALL pushcontrol1b(1)
16994  ELSE
16995  CALL pushrealarray_adm(ptc(i, j))
16996  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j, 2)
16997  CALL pushcontrol1b(0)
16998  END IF
16999  END DO
17000  CALL pushcontrol1b(1)
17001  ELSE
17002  DO i=is-1,ie+1
17003  CALL pushrealarray_adm(ptc(i, j))
17004  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j&
17005 & ))*dyc(i, j)*sina_v(i, j)
17006  END DO
17007  CALL pushcontrol1b(0)
17008  END IF
17009  END DO
17010  DO j=js-1,je+1
17011  DO i=is2,ie1
17012  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
17013 & )*dxc(i, j)*sina_u(i, j)
17014  END DO
17015  IF (is .EQ. 1) THEN
17016  IF (uc(1, j) .GT. 0) THEN
17017  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0, j, 3)
17018  CALL pushcontrol2b(0)
17019  ELSE
17020  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1, j, 1)
17021  CALL pushcontrol2b(1)
17022  END IF
17023  ELSE
17024  CALL pushcontrol2b(2)
17025  END IF
17026  IF (ie + 1 .EQ. npx) THEN
17027  IF (uc(npx, j) .GT. 0) THEN
17028  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx-1, j, 3)
17029  CALL pushcontrol2b(2)
17030  ELSE
17031  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx, j, 1)
17032  CALL pushcontrol2b(1)
17033  END IF
17034  ELSE
17035  CALL pushcontrol2b(0)
17036  END IF
17037  END DO
17038  CALL pushcontrol1b(0)
17039  END IF
17040  DO j=js,je+1
17041  DO i=is,ie+1
17042  CALL pushrealarray_adm(delpc(i, j))
17043  delpc(i, j) = vort(i, j-1) - vort(i, j) + ptc(i-1, j) - ptc(i&
17044 & , j)
17045  END DO
17046  END DO
17047 ! Remove the extra term at the corners:
17048  IF (sw_corner) THEN
17049  CALL pushrealarray_adm(delpc(1, 1))
17050  delpc(1, 1) = delpc(1, 1) - vort(1, 0)
17051  CALL pushcontrol1b(0)
17052  ELSE
17053  CALL pushcontrol1b(1)
17054  END IF
17055  IF (se_corner) THEN
17056  CALL pushrealarray_adm(delpc(npx, 1))
17057  delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
17058  CALL pushcontrol1b(0)
17059  ELSE
17060  CALL pushcontrol1b(1)
17061  END IF
17062  IF (ne_corner) THEN
17063  CALL pushrealarray_adm(delpc(npx, npy))
17064  delpc(npx, npy) = delpc(npx, npy) + vort(npx, npy)
17065  CALL pushcontrol1b(0)
17066  ELSE
17067  CALL pushcontrol1b(1)
17068  END IF
17069  IF (nw_corner) THEN
17070  CALL pushrealarray_adm(delpc(1, npy))
17071  delpc(1, npy) = delpc(1, npy) + vort(1, npy)
17072  CALL pushcontrol1b(1)
17073  ELSE
17074  CALL pushcontrol1b(0)
17075  END IF
17076  DO j=js,je+1
17077  DO i=is,ie+1
17078  CALL pushrealarray_adm(delpc(i, j))
17079  delpc(i, j) = gridstruct%rarea_c(i, j)*delpc(i, j)
17080  IF (delpc(i, j)*dt .GE. 0.) THEN
17081  abs2 = delpc(i, j)*dt
17082  CALL pushcontrol1b(0)
17083  ELSE
17084  abs2 = -(delpc(i, j)*dt)
17085  CALL pushcontrol1b(1)
17086  END IF
17087  y3 = dddmp*abs2
17088  IF (0.20 .GT. y3) THEN
17089  y1 = y3
17090  CALL pushcontrol1b(0)
17091  ELSE
17092  y1 = 0.20
17093  CALL pushcontrol1b(1)
17094  END IF
17095  IF (d2_bg .LT. y1) THEN
17096  max1 = y1
17097  CALL pushcontrol1b(0)
17098  ELSE
17099  max1 = d2_bg
17100  CALL pushcontrol1b(1)
17101  END IF
17102  CALL pushrealarray_adm(damp)
17103  damp = gridstruct%da_min_c*max1
17104  END DO
17105  END DO
17106  DO j=je+1,js,-1
17107  DO i=ie+1,is,-1
17108  vort_ad(i, j) = vort_ad(i, j) + ke_ad(i, j)
17109  damp_ad = delpc(i, j)*vort_ad(i, j)
17110  delpc_ad(i, j) = delpc_ad(i, j) + damp*vort_ad(i, j)
17111  vort_ad(i, j) = 0.0
17112  CALL poprealarray_adm(damp)
17113  max1_ad = gridstruct%da_min_c*damp_ad
17114  CALL popcontrol1b(branch)
17115  IF (branch .EQ. 0) THEN
17116  y1_ad = max1_ad
17117  ELSE
17118  y1_ad = 0.0
17119  END IF
17120  CALL popcontrol1b(branch)
17121  IF (branch .EQ. 0) THEN
17122  y3_ad = y1_ad
17123  ELSE
17124  y3_ad = 0.0
17125  END IF
17126  abs2_ad = dddmp*y3_ad
17127  CALL popcontrol1b(branch)
17128  IF (branch .EQ. 0) THEN
17129  delpc_ad(i, j) = delpc_ad(i, j) + dt*abs2_ad
17130  ELSE
17131  delpc_ad(i, j) = delpc_ad(i, j) - dt*abs2_ad
17132  END IF
17133  CALL poprealarray_adm(delpc(i, j))
17134  delpc_ad(i, j) = gridstruct%rarea_c(i, j)*delpc_ad(i, j)
17135  END DO
17136  END DO
17137  CALL popcontrol1b(branch)
17138  IF (branch .NE. 0) THEN
17139  CALL poprealarray_adm(delpc(1, npy))
17140  vort_ad(1, npy) = vort_ad(1, npy) + delpc_ad(1, npy)
17141  END IF
17142  CALL popcontrol1b(branch)
17143  IF (branch .EQ. 0) THEN
17144  CALL poprealarray_adm(delpc(npx, npy))
17145  vort_ad(npx, npy) = vort_ad(npx, npy) + delpc_ad(npx, npy)
17146  END IF
17147  CALL popcontrol1b(branch)
17148  IF (branch .EQ. 0) THEN
17149  CALL poprealarray_adm(delpc(npx, 1))
17150  vort_ad(npx, 0) = vort_ad(npx, 0) - delpc_ad(npx, 1)
17151  END IF
17152  CALL popcontrol1b(branch)
17153  IF (branch .EQ. 0) THEN
17154  CALL poprealarray_adm(delpc(1, 1))
17155  vort_ad(1, 0) = vort_ad(1, 0) - delpc_ad(1, 1)
17156  END IF
17157  DO j=je+1,js,-1
17158  DO i=ie+1,is,-1
17159  CALL poprealarray_adm(delpc(i, j))
17160  vort_ad(i, j-1) = vort_ad(i, j-1) + delpc_ad(i, j)
17161  vort_ad(i, j) = vort_ad(i, j) - delpc_ad(i, j)
17162  ptc_ad(i-1, j) = ptc_ad(i-1, j) + delpc_ad(i, j)
17163  ptc_ad(i, j) = ptc_ad(i, j) - delpc_ad(i, j)
17164  delpc_ad(i, j) = 0.0
17165  END DO
17166  END DO
17167  CALL popcontrol1b(branch)
17168  IF (branch .EQ. 0) THEN
17169  DO j=je+1,js-1,-1
17170  CALL popcontrol2b(branch)
17171  IF (branch .NE. 0) THEN
17172  IF (branch .EQ. 1) THEN
17173  v_ad(npx, j) = v_ad(npx, j) + sin_sg(npx, j, 1)*dxc(npx, j&
17174 & )*vort_ad(npx, j)
17175  vort_ad(npx, j) = 0.0
17176  ELSE
17177  v_ad(npx, j) = v_ad(npx, j) + sin_sg(npx-1, j, 3)*dxc(npx&
17178 & , j)*vort_ad(npx, j)
17179  vort_ad(npx, j) = 0.0
17180  END IF
17181  END IF
17182  CALL popcontrol2b(branch)
17183  IF (branch .EQ. 0) THEN
17184  v_ad(1, j) = v_ad(1, j) + sin_sg(0, j, 3)*dxc(1, j)*vort_ad(&
17185 & 1, j)
17186  vort_ad(1, j) = 0.0
17187  ELSE IF (branch .EQ. 1) THEN
17188  v_ad(1, j) = v_ad(1, j) + sin_sg(1, j, 1)*dxc(1, j)*vort_ad(&
17189 & 1, j)
17190  vort_ad(1, j) = 0.0
17191  END IF
17192  DO i=ie1,is2,-1
17193  temp_ad5 = dxc(i, j)*sina_u(i, j)*vort_ad(i, j)
17194  temp_ad6 = -(cosa_u(i, j)*0.5*temp_ad5)
17195  v_ad(i, j) = v_ad(i, j) + temp_ad5
17196  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad6
17197  ua_ad(i, j) = ua_ad(i, j) + temp_ad6
17198  vort_ad(i, j) = 0.0
17199  END DO
17200  END DO
17201  DO j=je+1,js,-1
17202  CALL popcontrol1b(branch)
17203  IF (branch .EQ. 0) THEN
17204  DO i=ie+1,is-1,-1
17205  CALL poprealarray_adm(ptc(i, j))
17206  temp_ad3 = dyc(i, j)*sina_v(i, j)*ptc_ad(i, j)
17207  temp_ad4 = -(cosa_v(i, j)*0.5*temp_ad3)
17208  u_ad(i, j) = u_ad(i, j) + temp_ad3
17209  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad4
17210  va_ad(i, j) = va_ad(i, j) + temp_ad4
17211  ptc_ad(i, j) = 0.0
17212  END DO
17213  ELSE
17214  DO i=ie+1,is-1,-1
17215  CALL popcontrol1b(branch)
17216  IF (branch .EQ. 0) THEN
17217  CALL poprealarray_adm(ptc(i, j))
17218  u_ad(i, j) = u_ad(i, j) + sin_sg(i, j, 2)*dyc(i, j)*&
17219 & ptc_ad(i, j)
17220  ptc_ad(i, j) = 0.0
17221  ELSE
17222  CALL poprealarray_adm(ptc(i, j))
17223  u_ad(i, j) = u_ad(i, j) + sin_sg(i, j-1, 4)*dyc(i, j)*&
17224 & ptc_ad(i, j)
17225  ptc_ad(i, j) = 0.0
17226  END IF
17227  END DO
17228  END IF
17229  END DO
17230  ELSE
17231  DO j=je+1,js-1,-1
17232  DO i=ie1,is2,-1
17233  temp_ad1 = dxc(i, j)*sina_u(i, j)*vort_ad(i, j)
17234  temp_ad2 = -(cosa_u(i, j)*0.5*temp_ad1)
17235  v_ad(i, j) = v_ad(i, j) + temp_ad1
17236  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad2
17237  ua_ad(i, j) = ua_ad(i, j) + temp_ad2
17238  vort_ad(i, j) = 0.0
17239  END DO
17240  END DO
17241  DO j=je+1,js,-1
17242  DO i=ie+1,is-1,-1
17243  CALL poprealarray_adm(ptc(i, j))
17244  temp_ad = dyc(i, j)*sina_v(i, j)*ptc_ad(i, j)
17245  temp_ad0 = -(cosa_v(i, j)*0.5*temp_ad)
17246  u_ad(i, j) = u_ad(i, j) + temp_ad
17247  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad0
17248  va_ad(i, j) = va_ad(i, j) + temp_ad0
17249  ptc_ad(i, j) = 0.0
17250  END DO
17251  END DO
17252  END IF
17253  ELSE
17254 !--------------------------
17255 ! Higher order divg damping
17256 !--------------------------
17257  DO j=js,je+1
17258  DO i=is,ie+1
17259 ! Save divergence for external mode filter
17260  CALL pushrealarray_adm(delpc(i, j))
17261  delpc(i, j) = divg_d(i, j)
17262  END DO
17263  END DO
17264 ! N > 1
17265  n2 = nord + 1
17266  DO n=1,nord
17267  nt = nord - n
17268  fill_c = nt .NE. 0 .AND. flagstruct%grid_type .LT. 3 .AND. (((&
17269 & sw_corner .OR. se_corner) .OR. ne_corner) .OR. nw_corner) &
17270 & .AND. (.NOT.nested)
17271  IF (fill_c) THEN
17272  CALL pushcontrol1b(1)
17273  ELSE
17274  CALL pushcontrol1b(0)
17275  END IF
17276  ad_from0 = js - nt
17277  DO j=ad_from0,je+1+nt
17278  ad_from = is - 1 - nt
17279  i = ie + nt + 2
17280  CALL pushinteger4(i - 1)
17281  CALL pushinteger4(ad_from)
17282  END DO
17283  CALL pushinteger4(j - 1)
17284  CALL pushinteger4(ad_from0)
17285  IF (fill_c) THEN
17286  CALL pushcontrol1b(1)
17287  ELSE
17288  CALL pushcontrol1b(0)
17289  END IF
17290  ad_from2 = js - 1 - nt
17291  DO j=ad_from2,je+1+nt
17292  ad_from1 = is - nt
17293  i = ie + nt + 2
17294  CALL pushinteger4(i - 1)
17295  CALL pushinteger4(ad_from1)
17296  END DO
17297  CALL pushinteger4(j - 1)
17298  CALL pushinteger4(ad_from2)
17299  IF (fill_c) THEN
17300  CALL pushcontrol1b(1)
17301  ELSE
17302  CALL pushcontrol1b(0)
17303  END IF
17304  ad_from4 = js - nt
17305  DO j=ad_from4,je+1+nt
17306  ad_from3 = is - nt
17307  i = ie + nt + 2
17308  CALL pushinteger4(i - 1)
17309  CALL pushinteger4(ad_from3)
17310  END DO
17311  CALL pushinteger4(j - 1)
17312  CALL pushinteger4(ad_from4)
17313 ! Remove the extra term at the corners:
17314  IF (sw_corner) THEN
17315  CALL pushcontrol1b(0)
17316  ELSE
17317  CALL pushcontrol1b(1)
17318  END IF
17319  IF (se_corner) THEN
17320  CALL pushcontrol1b(0)
17321  ELSE
17322  CALL pushcontrol1b(1)
17323  END IF
17324  IF (ne_corner) THEN
17325  CALL pushcontrol1b(0)
17326  ELSE
17327  CALL pushcontrol1b(1)
17328  END IF
17329  IF (nw_corner) THEN
17330  CALL pushcontrol1b(0)
17331  ELSE
17332  CALL pushcontrol1b(1)
17333  END IF
17334  IF (.NOT.gridstruct%stretched_grid) THEN
17335  ad_from6 = js - nt
17336  DO j=ad_from6,je+1+nt
17337  ad_from5 = is - nt
17338  i = ie + nt + 2
17339  CALL pushinteger4(i - 1)
17340  CALL pushinteger4(ad_from5)
17341  END DO
17342  CALL pushinteger4(j - 1)
17343  CALL pushinteger4(ad_from6)
17344  CALL pushcontrol1b(1)
17345  ELSE
17346  CALL pushcontrol1b(0)
17347  END IF
17348  END DO
17349 ! n-loop
17350  IF (dddmp .LT. 1.e-5) THEN
17351  CALL pushcontrol2b(0)
17352  vort(:, :) = 0.
17353  ELSE IF (flagstruct%grid_type .LT. 3) THEN
17354 ! Interpolate relative vort to cell corners
17355  CALL pushrealarray_adm(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
17356  CALL a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng&
17357 & , .false.)
17358  DO j=js,je+1
17359  DO i=is,ie+1
17360  IF (dt .GE. 0.) THEN
17361  CALL pushrealarray_adm(abs0)
17362  abs0 = dt
17363  CALL pushcontrol1b(0)
17364  ELSE
17365  CALL pushrealarray_adm(abs0)
17366  abs0 = -dt
17367  CALL pushcontrol1b(1)
17368  END IF
17369 ! The following is an approxi form of Smagorinsky diffusion
17370  CALL pushrealarray_adm(vort(i, j))
17371  vort(i, j) = abs0*sqrt(delpc(i, j)**2+vort(i, j)**2)
17372  END DO
17373  END DO
17374  CALL pushcontrol2b(1)
17375  ELSE
17376  IF (dt .GE. 0.) THEN
17377  abs1 = dt
17378  ELSE
17379  abs1 = -dt
17380  END IF
17381 ! Correct form: works only for doubly preiodic domain
17382  CALL pushrealarray_adm(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
17383  CALL smag_corner(abs1, u, v, ua, va, vort, bd, npx, npy, &
17384 & gridstruct, ng)
17385  CALL pushcontrol2b(2)
17386  END IF
17387  IF (gridstruct%stretched_grid) THEN
17388 ! Stretched grid with variable damping ~ area
17389  dd8 = gridstruct%da_min*d4_bg**n2
17390  ELSE
17391  dd8 = (gridstruct%da_min_c*d4_bg)**n2
17392  END IF
17393  DO j=js,je+1
17394  DO i=is,ie+1
17395  IF (0.20 .GT. dddmp*vort(i, j)) THEN
17396  y2 = dddmp*vort(i, j)
17397  CALL pushcontrol1b(0)
17398  ELSE
17399  CALL pushcontrol1b(1)
17400  y2 = 0.20
17401  END IF
17402  IF (d2_bg .LT. y2) THEN
17403  max2 = y2
17404  CALL pushcontrol1b(0)
17405  ELSE
17406  max2 = d2_bg
17407  CALL pushcontrol1b(1)
17408  END IF
17409 ! del-2
17410  CALL pushrealarray_adm(damp2)
17411  damp2 = gridstruct%da_min_c*max2
17412  END DO
17413  END DO
17414  DO j=je+1,js,-1
17415  DO i=ie+1,is,-1
17416  vort_ad(i, j) = vort_ad(i, j) + ke_ad(i, j)
17417  damp2_ad = delpc(i, j)*vort_ad(i, j)
17418  delpc_ad(i, j) = delpc_ad(i, j) + damp2*vort_ad(i, j)
17419  divg_d_ad(i, j) = divg_d_ad(i, j) + dd8*vort_ad(i, j)
17420  vort_ad(i, j) = 0.0
17421  CALL poprealarray_adm(damp2)
17422  max2_ad = gridstruct%da_min_c*damp2_ad
17423  CALL popcontrol1b(branch)
17424  IF (branch .EQ. 0) THEN
17425  y2_ad = max2_ad
17426  ELSE
17427  y2_ad = 0.0
17428  END IF
17429  CALL popcontrol1b(branch)
17430  IF (branch .EQ. 0) vort_ad(i, j) = vort_ad(i, j) + dddmp*y2_ad
17431  END DO
17432  END DO
17433  CALL popcontrol2b(branch)
17434  IF (branch .NE. 0) THEN
17435  IF (branch .EQ. 1) THEN
17436  DO j=je+1,js,-1
17437  DO i=ie+1,is,-1
17438  CALL poprealarray_adm(vort(i, j))
17439  IF (delpc(i, j)**2 + vort(i, j)**2 .EQ. 0.0) THEN
17440  temp_ad9 = 0.0
17441  ELSE
17442  temp_ad9 = abs0*vort_ad(i, j)/(2.0*sqrt(delpc(i, j)**2+&
17443 & vort(i, j)**2))
17444  END IF
17445  delpc_ad(i, j) = delpc_ad(i, j) + 2*delpc(i, j)*temp_ad9
17446  vort_ad(i, j) = 2*vort(i, j)*temp_ad9
17447  CALL popcontrol1b(branch)
17448  IF (branch .EQ. 0) THEN
17449  CALL poprealarray_adm(abs0)
17450  ELSE
17451  CALL poprealarray_adm(abs0)
17452  END IF
17453  END DO
17454  END DO
17455  CALL poprealarray_adm(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
17456  CALL a2b_ord4_adm(wk, wk_ad, vort, vort_ad, gridstruct, npx, &
17457 & npy, is, ie, js, je, ng, .false.)
17458  ELSE
17459  CALL poprealarray_adm(vort, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
17460  CALL smag_corner_adm(abs1, u, u_ad, v, v_ad, ua, va, vort, &
17461 & vort_ad, bd, npx, npy, gridstruct, ng)
17462  END IF
17463  END IF
17464  DO n=nord,1,-1
17465  CALL popcontrol1b(branch)
17466  IF (branch .NE. 0) THEN
17467  CALL popinteger4(ad_from6)
17468  CALL popinteger4(ad_to6)
17469  DO j=ad_to6,ad_from6,-1
17470  CALL popinteger4(ad_from5)
17471  CALL popinteger4(ad_to5)
17472  DO i=ad_to5,ad_from5,-1
17473  divg_d_ad(i, j) = gridstruct%rarea_c(i, j)*divg_d_ad(i, j)
17474  END DO
17475  END DO
17476  END IF
17477  CALL popcontrol1b(branch)
17478  IF (branch .EQ. 0) uc_ad(1, npy) = uc_ad(1, npy) + divg_d_ad(1, &
17479 & npy)
17480  CALL popcontrol1b(branch)
17481  IF (branch .EQ. 0) uc_ad(npx, npy) = uc_ad(npx, npy) + divg_d_ad&
17482 & (npx, npy)
17483  CALL popcontrol1b(branch)
17484  IF (branch .EQ. 0) uc_ad(npx, 0) = uc_ad(npx, 0) - divg_d_ad(npx&
17485 & , 1)
17486  CALL popcontrol1b(branch)
17487  IF (branch .EQ. 0) uc_ad(1, 0) = uc_ad(1, 0) - divg_d_ad(1, 1)
17488  CALL popinteger4(ad_from4)
17489  CALL popinteger4(ad_to4)
17490  DO j=ad_to4,ad_from4,-1
17491  CALL popinteger4(ad_from3)
17492  CALL popinteger4(ad_to3)
17493  DO i=ad_to3,ad_from3,-1
17494  uc_ad(i, j-1) = uc_ad(i, j-1) + divg_d_ad(i, j)
17495  uc_ad(i, j) = uc_ad(i, j) - divg_d_ad(i, j)
17496  vc_ad(i-1, j) = vc_ad(i-1, j) + divg_d_ad(i, j)
17497  vc_ad(i, j) = vc_ad(i, j) - divg_d_ad(i, j)
17498  divg_d_ad(i, j) = 0.0
17499  END DO
17500  END DO
17501  CALL popcontrol1b(branch)
17502  IF (branch .NE. 0) CALL fill_corners_adm(vc, vc_ad, uc, uc_ad, &
17503 & npx, npy, dgrid=.true., &
17504 & vector=.true.)
17505  CALL popinteger4(ad_from2)
17506  CALL popinteger4(ad_to2)
17507  DO j=ad_to2,ad_from2,-1
17508  CALL popinteger4(ad_from1)
17509  CALL popinteger4(ad_to1)
17510  DO i=ad_to1,ad_from1,-1
17511  temp_ad8 = divg_v(i, j)*uc_ad(i, j)
17512  divg_d_ad(i, j+1) = divg_d_ad(i, j+1) + temp_ad8
17513  divg_d_ad(i, j) = divg_d_ad(i, j) - temp_ad8
17514  uc_ad(i, j) = 0.0
17515  END DO
17516  END DO
17517  CALL popcontrol1b(branch)
17518  IF (branch .NE. 0) CALL fill_corners_adm(divg_d, divg_d_ad, npx&
17519 & , npy, fill=ydir, bgrid=&
17520 & .true.)
17521  CALL popinteger4(ad_from0)
17522  CALL popinteger4(ad_to0)
17523  DO j=ad_to0,ad_from0,-1
17524  CALL popinteger4(ad_from)
17525  CALL popinteger4(ad_to)
17526  DO i=ad_to,ad_from,-1
17527  temp_ad7 = divg_u(i, j)*vc_ad(i, j)
17528  divg_d_ad(i+1, j) = divg_d_ad(i+1, j) + temp_ad7
17529  divg_d_ad(i, j) = divg_d_ad(i, j) - temp_ad7
17530  vc_ad(i, j) = 0.0
17531  END DO
17532  END DO
17533  CALL popcontrol1b(branch)
17534  IF (branch .NE. 0) CALL fill_corners_adm(divg_d, divg_d_ad, npx&
17535 & , npy, fill=xdir, bgrid=&
17536 & .true.)
17537  END DO
17538  DO j=je+1,js,-1
17539  DO i=ie+1,is,-1
17540  CALL poprealarray_adm(delpc(i, j))
17541  divg_d_ad(i, j) = divg_d_ad(i, j) + delpc_ad(i, j)
17542  delpc_ad(i, j) = 0.0
17543  END DO
17544  END DO
17545  END IF
17546  CALL popcontrol1b(branch)
17547  END SUBROUTINE compute_divergence_damping_adm
17548 ! Differentiation of smag_corner in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dy
17549 !n_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_mod.p_grad_c d
17550 !yn_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.mix_dp dyn_core
17551 !_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dyna
17552 !mics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_util
17553 !s_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz_
17554 !mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.sca
17555 !lar_profile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.st
17556 !eepz 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_restart_mod.d2c
17557 !_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.c
17558 !ompute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solve
17559 !r_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.SIM3p0_solve
17560 !r nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh
17561 !sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_co
17562 !re_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mod
17563 !.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corne
17564 !rs_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_cir
17565 !cle_dist sw_core_mod.edge_interpolate4)):
17566 ! gradient of useful results: smag_c u v
17567 ! with respect to varying inputs: u v
17568  SUBROUTINE smag_corner_adm(dt, u, u_ad, v, v_ad, ua, va, smag_c, &
17569 & smag_c_ad, bd, npx, npy, gridstruct, ng)
17570  IMPLICIT NONE
17571 ! Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion
17572 !!! work only if (grid_type==4)
17573  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
17574  REAL, INTENT(IN) :: dt
17575  INTEGER, INTENT(IN) :: npx, npy, ng
17576  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
17577  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
17578  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
17579  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
17580  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
17581  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: smag_c
17582  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: smag_c_ad
17583  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
17584 ! local
17585  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
17586  REAL :: ut_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
17587  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
17588  REAL :: vt_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
17589 ! work array
17590  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
17591  REAL :: wk_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
17592  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
17593  REAL :: sh_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
17594  INTEGER :: i, j
17595  INTEGER :: is2, ie1
17596  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
17597  INTEGER :: is, ie, js, je
17598  INTEGER :: isd, ied, jsd, jed
17599  INTRINSIC max
17600  INTRINSIC min
17601  INTRINSIC sqrt
17602  REAL :: temp_ad
17603  REAL :: temp_ad0
17604  REAL :: temp_ad1
17605  is = bd%is
17606  ie = bd%ie
17607  js = bd%js
17608  je = bd%je
17609  isd = bd%isd
17610  ied = bd%ied
17611  jsd = bd%jsd
17612  jed = bd%jed
17613  dxc => gridstruct%dxc
17614  dyc => gridstruct%dyc
17615  dx => gridstruct%dx
17616  dy => gridstruct%dy
17617  rarea => gridstruct%rarea
17618  rarea_c => gridstruct%rarea_c
17619 ! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s
17620 ! where T = du/dx - dv/dy; S = du/dy + dv/dx
17621 ! Compute tension strain at corners:
17622  DO j=js,je+1
17623  DO i=is-1,ie+1
17624  ut(i, j) = u(i, j)*dyc(i, j)
17625  END DO
17626  END DO
17627  DO j=js-1,je+1
17628  DO i=is,ie+1
17629  vt(i, j) = v(i, j)*dxc(i, j)
17630  END DO
17631  END DO
17632  DO j=js,je+1
17633  DO i=is,ie+1
17634  smag_c(i, j) = rarea_c(i, j)*(vt(i, j-1)-vt(i, j)+(ut(i, j)-ut(i&
17635 & -1, j)))
17636  END DO
17637  END DO
17638 ! Fix the corners?? if grid_type /= 4
17639 ! Compute shear strain:
17640  DO j=jsd,jed+1
17641  DO i=isd,ied
17642  vt(i, j) = u(i, j)*dx(i, j)
17643  END DO
17644  END DO
17645  DO j=jsd,jed
17646  DO i=isd,ied+1
17647  ut(i, j) = v(i, j)*dy(i, j)
17648  END DO
17649  END DO
17650  DO j=jsd,jed
17651  DO i=isd,ied
17652  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+(ut(i, j)-ut(i+1, j)&
17653 & ))
17654  END DO
17655  END DO
17656  CALL a2b_ord4(wk, sh, gridstruct, npx, npy, is, ie, js, je, ng, &
17657 & .false.)
17658  sh_ad = 0.0
17659  DO j=je+1,js,-1
17660  DO i=ie+1,is,-1
17661  IF (sh(i, j)**2 + smag_c(i, j)**2 .EQ. 0.0) THEN
17662  temp_ad1 = 0.0
17663  ELSE
17664  temp_ad1 = dt*smag_c_ad(i, j)/(2.0*sqrt(sh(i, j)**2+smag_c(i, &
17665 & j)**2))
17666  END IF
17667  sh_ad(i, j) = sh_ad(i, j) + 2*sh(i, j)*temp_ad1
17668  smag_c_ad(i, j) = 2*smag_c(i, j)*temp_ad1
17669  END DO
17670  END DO
17671  wk_ad = 0.0
17672  CALL a2b_ord4_adm(wk, wk_ad, sh, sh_ad, gridstruct, npx, npy, is, ie&
17673 & , js, je, ng, .false.)
17674  ut_ad = 0.0
17675  vt_ad = 0.0
17676  DO j=jed,jsd,-1
17677  DO i=ied,isd,-1
17678  temp_ad0 = rarea(i, j)*wk_ad(i, j)
17679  vt_ad(i, j) = vt_ad(i, j) + temp_ad0
17680  vt_ad(i, j+1) = vt_ad(i, j+1) - temp_ad0
17681  ut_ad(i, j) = ut_ad(i, j) + temp_ad0
17682  ut_ad(i+1, j) = ut_ad(i+1, j) - temp_ad0
17683  wk_ad(i, j) = 0.0
17684  END DO
17685  END DO
17686  DO j=jed,jsd,-1
17687  DO i=ied+1,isd,-1
17688  v_ad(i, j) = v_ad(i, j) + dy(i, j)*ut_ad(i, j)
17689  ut_ad(i, j) = 0.0
17690  END DO
17691  END DO
17692  DO j=jed+1,jsd,-1
17693  DO i=ied,isd,-1
17694  u_ad(i, j) = u_ad(i, j) + dx(i, j)*vt_ad(i, j)
17695  vt_ad(i, j) = 0.0
17696  END DO
17697  END DO
17698  DO j=je+1,js,-1
17699  DO i=ie+1,is,-1
17700  temp_ad = rarea_c(i, j)*smag_c_ad(i, j)
17701  vt_ad(i, j-1) = vt_ad(i, j-1) + temp_ad
17702  vt_ad(i, j) = vt_ad(i, j) - temp_ad
17703  ut_ad(i, j) = ut_ad(i, j) + temp_ad
17704  ut_ad(i-1, j) = ut_ad(i-1, j) - temp_ad
17705  smag_c_ad(i, j) = 0.0
17706  END DO
17707  END DO
17708  DO j=je+1,js-1,-1
17709  DO i=ie+1,is,-1
17710  v_ad(i, j) = v_ad(i, j) + dxc(i, j)*vt_ad(i, j)
17711  vt_ad(i, j) = 0.0
17712  END DO
17713  END DO
17714  DO j=je+1,js,-1
17715  DO i=ie+1,is-1,-1
17716  u_ad(i, j) = u_ad(i, j) + dyc(i, j)*ut_ad(i, j)
17717  ut_ad(i, j) = 0.0
17718  END DO
17719  END DO
17720  END SUBROUTINE smag_corner_adm
17721  SUBROUTINE compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, &
17722 & vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, gridstruct, &
17723 & flagstruct, bd)
17724  IMPLICIT NONE
17725 !InOut Arguments
17726  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
17727  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
17728  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
17729  INTEGER, INTENT(IN) :: nord
17730  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
17731  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
17732  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
17733  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
17734 !Intent is really in
17735  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
17736  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
17737  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
17738 & delpc, ptc
17739  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
17740 & ke
17741  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
17742  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
17743  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
17744 & divg_d
17745 !Locals
17746  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
17747  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
17748  LOGICAL :: nested, fill_c
17749  INTEGER :: i, j, n, n2, nt
17750  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
17751  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
17752  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
17753  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
17754  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
17755  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
17756  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
17757  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
17758 & , rdx, rdy
17759  INTRINSIC ABS
17760  INTRINSIC max
17761  INTRINSIC min
17762  INTRINSIC sqrt
17763  REAL :: max1
17764  REAL :: abs0
17765  REAL :: abs1
17766  REAL :: max2
17767  REAL :: abs2
17768  REAL :: y3
17769  REAL :: y2
17770  REAL :: y1
17771  area => gridstruct%area
17772  rarea => gridstruct%rarea
17773  sin_sg => gridstruct%sin_sg
17774  cosa_u => gridstruct%cosa_u
17775  cosa_v => gridstruct%cosa_v
17776  cosa_s => gridstruct%cosa_s
17777  sina_u => gridstruct%sina_u
17778  sina_v => gridstruct%sina_v
17779  rsin_u => gridstruct%rsin_u
17780  rsin_v => gridstruct%rsin_v
17781  rsina => gridstruct%rsina
17782  f0 => gridstruct%f0
17783  rsin2 => gridstruct%rsin2
17784  divg_u => gridstruct%divg_u
17785  divg_v => gridstruct%divg_v
17786  cosa => gridstruct%cosa
17787  dx => gridstruct%dx
17788  dy => gridstruct%dy
17789  dxc => gridstruct%dxc
17790  dyc => gridstruct%dyc
17791  rdxa => gridstruct%rdxa
17792  rdya => gridstruct%rdya
17793  rdx => gridstruct%rdx
17794  rdy => gridstruct%rdy
17795  sw_corner = gridstruct%sw_corner
17796  se_corner = gridstruct%se_corner
17797  nw_corner = gridstruct%nw_corner
17798  ne_corner = gridstruct%ne_corner
17799  IF (dt .GE. 0.) THEN
17800  absdt = dt
17801  ELSE
17802  absdt = -dt
17803  END IF
17804  da_min = gridstruct%da_min
17805  da_min_c = gridstruct%da_min_c
17806  is = bd%is
17807  ie = bd%ie
17808  js = bd%js
17809  je = bd%je
17810  npx = flagstruct%npx
17811  npy = flagstruct%npy
17812  nested = gridstruct%nested
17813  IF (nested) THEN
17814  is2 = is
17815  ie1 = ie + 1
17816  ELSE
17817  IF (2 .LT. is) THEN
17818  is2 = is
17819  ELSE
17820  is2 = 2
17821  END IF
17822  IF (npx - 1 .GT. ie + 1) THEN
17823  ie1 = ie + 1
17824  ELSE
17825  ie1 = npx - 1
17826  END IF
17827  END IF
17828 !-----------------------------
17829 ! Compute divergence damping
17830 !-----------------------------
17831 ! damp = dddmp * da_min_c
17832  IF (nord .EQ. 0) THEN
17833 ! area ~ dxb*dyb*sin(alpha)
17834  IF (nested) THEN
17835  DO j=js,je+1
17836  DO i=is-1,ie+1
17837  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j))&
17838 & *dyc(i, j)*sina_v(i, j)
17839  END DO
17840  END DO
17841  DO j=js-1,je+1
17842  DO i=is2,ie1
17843  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
17844 & )*dxc(i, j)*sina_u(i, j)
17845  END DO
17846  END DO
17847  ELSE
17848  DO j=js,je+1
17849  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
17850  DO i=is-1,ie+1
17851  IF (vc(i, j) .GT. 0) THEN
17852  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j-1, 4)
17853  ELSE
17854  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j, 2)
17855  END IF
17856  END DO
17857  ELSE
17858  DO i=is-1,ie+1
17859  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j&
17860 & ))*dyc(i, j)*sina_v(i, j)
17861  END DO
17862  END IF
17863  END DO
17864  DO j=js-1,je+1
17865  DO i=is2,ie1
17866  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
17867 & )*dxc(i, j)*sina_u(i, j)
17868  END DO
17869  IF (is .EQ. 1) THEN
17870  IF (uc(1, j) .GT. 0) THEN
17871  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0, j, 3)
17872  ELSE
17873  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1, j, 1)
17874  END IF
17875  END IF
17876  IF (ie + 1 .EQ. npx) THEN
17877  IF (uc(npx, j) .GT. 0) THEN
17878  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx-1, j, 3)
17879  ELSE
17880  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx, j, 1)
17881  END IF
17882  END IF
17883  END DO
17884  END IF
17885  DO j=js,je+1
17886  DO i=is,ie+1
17887  delpc(i, j) = vort(i, j-1) - vort(i, j) + ptc(i-1, j) - ptc(i&
17888 & , j)
17889  END DO
17890  END DO
17891 ! Remove the extra term at the corners:
17892  IF (sw_corner) delpc(1, 1) = delpc(1, 1) - vort(1, 0)
17893  IF (se_corner) delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
17894  IF (ne_corner) delpc(npx, npy) = delpc(npx, npy) + vort(npx, npy)
17895  IF (nw_corner) delpc(1, npy) = delpc(1, npy) + vort(1, npy)
17896  DO j=js,je+1
17897  DO i=is,ie+1
17898  delpc(i, j) = gridstruct%rarea_c(i, j)*delpc(i, j)
17899  IF (delpc(i, j)*dt .GE. 0.) THEN
17900  abs2 = delpc(i, j)*dt
17901  ELSE
17902  abs2 = -(delpc(i, j)*dt)
17903  END IF
17904  y3 = dddmp*abs2
17905  IF (0.20 .GT. y3) THEN
17906  y1 = y3
17907  ELSE
17908  y1 = 0.20
17909  END IF
17910  IF (d2_bg .LT. y1) THEN
17911  max1 = y1
17912  ELSE
17913  max1 = d2_bg
17914  END IF
17915  damp = gridstruct%da_min_c*max1
17916  vort(i, j) = damp*delpc(i, j)
17917  ke(i, j) = ke(i, j) + vort(i, j)
17918  END DO
17919  END DO
17920  ELSE
17921 !--------------------------
17922 ! Higher order divg damping
17923 !--------------------------
17924  DO j=js,je+1
17925  DO i=is,ie+1
17926 ! Save divergence for external mode filter
17927  delpc(i, j) = divg_d(i, j)
17928  END DO
17929  END DO
17930 ! N > 1
17931  n2 = nord + 1
17932  DO n=1,nord
17933  nt = nord - n
17934  fill_c = nt .NE. 0 .AND. flagstruct%grid_type .LT. 3 .AND. (((&
17935 & sw_corner .OR. se_corner) .OR. ne_corner) .OR. nw_corner) &
17936 & .AND. (.NOT.nested)
17937  IF (fill_c) CALL fill_corners(divg_d, npx, npy, fill=xdir, bgrid&
17938 & =.true.)
17939  DO j=js-nt,je+1+nt
17940  DO i=is-1-nt,ie+1+nt
17941  vc(i, j) = (divg_d(i+1, j)-divg_d(i, j))*divg_u(i, j)
17942  END DO
17943  END DO
17944  IF (fill_c) CALL fill_corners(divg_d, npx, npy, fill=ydir, bgrid&
17945 & =.true.)
17946  DO j=js-1-nt,je+1+nt
17947  DO i=is-nt,ie+1+nt
17948  uc(i, j) = (divg_d(i, j+1)-divg_d(i, j))*divg_v(i, j)
17949  END DO
17950  END DO
17951  IF (fill_c) CALL fill_corners(vc, uc, npx, npy, dgrid=.true., &
17952 & vector=.true.)
17953  DO j=js-nt,je+1+nt
17954  DO i=is-nt,ie+1+nt
17955  divg_d(i, j) = uc(i, j-1) - uc(i, j) + vc(i-1, j) - vc(i, j)
17956  END DO
17957  END DO
17958 ! Remove the extra term at the corners:
17959  IF (sw_corner) divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
17960  IF (se_corner) divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
17961  IF (ne_corner) divg_d(npx, npy) = divg_d(npx, npy) + uc(npx, npy&
17962 & )
17963  IF (nw_corner) divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
17964  IF (.NOT.gridstruct%stretched_grid) THEN
17965  DO j=js-nt,je+1+nt
17966  DO i=is-nt,ie+1+nt
17967  divg_d(i, j) = divg_d(i, j)*gridstruct%rarea_c(i, j)
17968  END DO
17969  END DO
17970  END IF
17971  END DO
17972 ! n-loop
17973  IF (dddmp .LT. 1.e-5) THEN
17974  vort(:, :) = 0.
17975  ELSE IF (flagstruct%grid_type .LT. 3) THEN
17976 ! Interpolate relative vort to cell corners
17977  CALL a2b_ord4(wk, vort, gridstruct, npx, npy, is, ie, js, je, ng&
17978 & , .false.)
17979  DO j=js,je+1
17980  DO i=is,ie+1
17981  IF (dt .GE. 0.) THEN
17982  abs0 = dt
17983  ELSE
17984  abs0 = -dt
17985  END IF
17986 ! The following is an approxi form of Smagorinsky diffusion
17987  vort(i, j) = abs0*sqrt(delpc(i, j)**2+vort(i, j)**2)
17988  END DO
17989  END DO
17990  ELSE
17991  IF (dt .GE. 0.) THEN
17992  abs1 = dt
17993  ELSE
17994  abs1 = -dt
17995  END IF
17996 ! Correct form: works only for doubly preiodic domain
17997  CALL smag_corner(abs1, u, v, ua, va, vort, bd, npx, npy, &
17998 & gridstruct, ng)
17999  END IF
18000  IF (gridstruct%stretched_grid) THEN
18001 ! Stretched grid with variable damping ~ area
18002  dd8 = gridstruct%da_min*d4_bg**n2
18003  ELSE
18004  dd8 = (gridstruct%da_min_c*d4_bg)**n2
18005  END IF
18006  DO j=js,je+1
18007  DO i=is,ie+1
18008  IF (0.20 .GT. dddmp*vort(i, j)) THEN
18009  y2 = dddmp*vort(i, j)
18010  ELSE
18011  y2 = 0.20
18012  END IF
18013  IF (d2_bg .LT. y2) THEN
18014  max2 = y2
18015  ELSE
18016  max2 = d2_bg
18017  END IF
18018 ! del-2
18019  damp2 = gridstruct%da_min_c*max2
18020  vort(i, j) = damp2*delpc(i, j) + dd8*divg_d(i, j)
18021  ke(i, j) = ke(i, j) + vort(i, j)
18022  END DO
18023  END DO
18024  END IF
18025  END SUBROUTINE compute_divergence_damping
18026 ! Differentiation of compute_divergence_damping in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b
18027 !_ord4_fb a2b_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_m
18028 !od.adv_pe dyn_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_up
18029 !date dyn_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dy
18030 !namics_mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_gri
18031 !d_utils_mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.
18032 !pkez fv_mapz_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_
18033 !mapz_mod.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_map
18034 !z_mod.ppm_limiters 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_
18035 !mod.map1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested
18036 !fv_sg_mod.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.up
18037 !date_dz_d nh_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
18038 !_solver nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_p
18039 !rofile nh_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_
18040 !nest sw_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u
18041 ! sw_core_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.f
18042 !v_tp_2d_fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corn
18043 !er_fb fv_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18044 ! gradient of useful results: u v ke ua uc ptc delpc va vc
18045 ! vort divg_d wk
18046 ! with respect to varying inputs: u v ke ua uc ptc delpc va vc
18047 ! divg_d wk
18048  SUBROUTINE compute_divergence_damping_fwd(nord, d2_bg, d4_bg, dddmp&
18049 & , dt, vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, &
18050 & gridstruct, flagstruct, bd)
18051  !USE ISO_C_BINDING
18052  !USE ADMM_TAPENADE_INTERFACE
18053  IMPLICIT NONE
18054 !InOut Arguments
18055  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
18056  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
18057  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
18058  INTEGER, INTENT(IN) :: nord
18059  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
18060  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
18061  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
18062  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
18063 !Intent is really in
18064  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
18065  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
18066  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
18067 & delpc, ptc
18068  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18069 & ke
18070  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
18071  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
18072  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18073 & divg_d
18074 !Locals
18075  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
18076  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
18077  LOGICAL :: nested, fill_c
18078  INTEGER :: i, j, n, n2, nt
18079  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
18080  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
18081  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
18082  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
18083  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
18084  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
18085  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
18086  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
18087 & , rdx, rdy
18088  INTRINSIC ABS
18089  INTRINSIC max
18090  INTRINSIC min
18091  INTRINSIC sqrt
18092  REAL :: max1
18093  REAL :: abs0
18094  REAL :: abs1
18095  REAL :: max2
18096  REAL :: abs2
18097  INTEGER :: ad_from
18098  INTEGER :: ad_from0
18099  INTEGER :: ad_from1
18100  INTEGER :: ad_from2
18101  INTEGER :: ad_from3
18102  INTEGER :: ad_from4
18103  INTEGER :: ad_from5
18104  INTEGER :: ad_from6
18105  REAL :: y3
18106  REAL :: y2
18107  REAL :: y1
18108 
18109  damp = 0.0
18110  dd8 = 0.0
18111  damp2 = 0.0
18112  da_min = 0.0
18113  da_min_c = 0.0
18114  absdt = 0.0
18115  is = 0
18116  ie = 0
18117  js = 0
18118  je = 0
18119  npx = 0
18120  npy = 0
18121  is2 = 0
18122  ie1 = 0
18123  n = 0
18124  n2 = 0
18125  nt = 0
18126  max1 = 0.0
18127  abs0 = 0.0
18128  abs1 = 0.0
18129  max2 = 0.0
18130  abs2 = 0.0
18131  ad_from = 0
18132  ad_from0 = 0
18133  ad_from1 = 0
18134  ad_from2 = 0
18135  ad_from3 = 0
18136  ad_from4 = 0
18137  ad_from5 = 0
18138  ad_from6 = 0
18139  y3 = 0.0
18140  y2 = 0.0
18141  y1 = 0.0
18142 
18143  sin_sg => gridstruct%sin_sg
18144  cosa_u => gridstruct%cosa_u
18145  cosa_v => gridstruct%cosa_v
18146  sina_u => gridstruct%sina_u
18147  sina_v => gridstruct%sina_v
18148  divg_u => gridstruct%divg_u
18149  divg_v => gridstruct%divg_v
18150  dxc => gridstruct%dxc
18151  dyc => gridstruct%dyc
18152  sw_corner = gridstruct%sw_corner
18153  se_corner = gridstruct%se_corner
18154  nw_corner = gridstruct%nw_corner
18155  ne_corner = gridstruct%ne_corner
18156  is = bd%is
18157  ie = bd%ie
18158  js = bd%js
18159  je = bd%je
18160  npx = flagstruct%npx
18161  npy = flagstruct%npy
18162  nested = gridstruct%nested
18163  IF (nested) THEN
18164  CALL pushcontrol(1,0)
18165  is2 = is
18166  ie1 = ie + 1
18167  ELSE
18168  IF (2 .LT. is) THEN
18169  is2 = is
18170  ELSE
18171  is2 = 2
18172  END IF
18173  IF (npx - 1 .GT. ie + 1) THEN
18174  CALL pushcontrol(1,1)
18175  ie1 = ie + 1
18176  ELSE
18177  CALL pushcontrol(1,1)
18178  ie1 = npx - 1
18179  END IF
18180  END IF
18181 !-----------------------------
18182 ! Compute divergence damping
18183 !-----------------------------
18184 ! damp = dddmp * da_min_c
18185  IF (nord .EQ. 0) THEN
18186 ! area ~ dxb*dyb*sin(alpha)
18187  IF (nested) THEN
18188  DO j=js,je+1
18189  DO i=is-1,ie+1
18190  CALL pushrealarray(ptc(i, j))
18191  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j))&
18192 & *dyc(i, j)*sina_v(i, j)
18193  END DO
18194  END DO
18195  DO j=js-1,je+1
18196  DO i=is2,ie1
18197  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
18198 & )*dxc(i, j)*sina_u(i, j)
18199  END DO
18200  END DO
18201  CALL pushcontrol(1,1)
18202  ELSE
18203  DO j=js,je+1
18204  IF (j .EQ. 1 .OR. j .EQ. npy) THEN
18205  DO i=is-1,ie+1
18206  IF (vc(i, j) .GT. 0) THEN
18207  CALL pushrealarray(ptc(i, j))
18208  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j-1, 4)
18209  CALL pushcontrol(1,1)
18210  ELSE
18211  CALL pushrealarray(ptc(i, j))
18212  ptc(i, j) = u(i, j)*dyc(i, j)*sin_sg(i, j, 2)
18213  CALL pushcontrol(1,0)
18214  END IF
18215  END DO
18216  CALL pushcontrol(1,1)
18217  ELSE
18218  DO i=is-1,ie+1
18219  CALL pushrealarray(ptc(i, j))
18220  ptc(i, j) = (u(i, j)-0.5*(va(i, j-1)+va(i, j))*cosa_v(i, j&
18221 & ))*dyc(i, j)*sina_v(i, j)
18222  END DO
18223  CALL pushcontrol(1,0)
18224  END IF
18225  END DO
18226  DO j=js-1,je+1
18227  DO i=is2,ie1
18228  vort(i, j) = (v(i, j)-0.5*(ua(i-1, j)+ua(i, j))*cosa_u(i, j)&
18229 & )*dxc(i, j)*sina_u(i, j)
18230  END DO
18231  IF (is .EQ. 1) THEN
18232  IF (uc(1, j) .GT. 0) THEN
18233  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(0, j, 3)
18234  CALL pushcontrol(2,0)
18235  ELSE
18236  vort(1, j) = v(1, j)*dxc(1, j)*sin_sg(1, j, 1)
18237  CALL pushcontrol(2,1)
18238  END IF
18239  ELSE
18240  CALL pushcontrol(2,2)
18241  END IF
18242  IF (ie + 1 .EQ. npx) THEN
18243  IF (uc(npx, j) .GT. 0) THEN
18244  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx-1, j, 3)
18245  CALL pushcontrol(2,2)
18246  ELSE
18247  vort(npx, j) = v(npx, j)*dxc(npx, j)*sin_sg(npx, j, 1)
18248  CALL pushcontrol(2,1)
18249  END IF
18250  ELSE
18251  CALL pushcontrol(2,0)
18252  END IF
18253  END DO
18254  CALL pushcontrol(1,0)
18255  END IF
18256  DO j=js,je+1
18257  DO i=is,ie+1
18258  CALL pushrealarray(delpc(i, j))
18259  delpc(i, j) = vort(i, j-1) - vort(i, j) + (ptc(i-1, j)-ptc(i, &
18260 & j))
18261  END DO
18262  END DO
18263 ! Remove the extra term at the corners:
18264  IF (sw_corner) THEN
18265  CALL pushrealarray(delpc(1, 1))
18266  delpc(1, 1) = delpc(1, 1) - vort(1, 0)
18267  CALL pushcontrol(1,0)
18268  ELSE
18269  CALL pushcontrol(1,1)
18270  END IF
18271  IF (se_corner) THEN
18272  CALL pushrealarray(delpc(npx, 1))
18273  delpc(npx, 1) = delpc(npx, 1) - vort(npx, 0)
18274  CALL pushcontrol(1,0)
18275  ELSE
18276  CALL pushcontrol(1,1)
18277  END IF
18278  IF (ne_corner) THEN
18279  CALL pushrealarray(delpc(npx, npy))
18280  delpc(npx, npy) = delpc(npx, npy) + vort(npx, npy)
18281  CALL pushcontrol(1,0)
18282  ELSE
18283  CALL pushcontrol(1,1)
18284  END IF
18285  IF (nw_corner) THEN
18286  CALL pushrealarray(delpc(1, npy))
18287  delpc(1, npy) = delpc(1, npy) + vort(1, npy)
18288  CALL pushcontrol(1,1)
18289  ELSE
18290  CALL pushcontrol(1,0)
18291  END IF
18292  DO j=js,je+1
18293  DO i=is,ie+1
18294  CALL pushrealarray(delpc(i, j))
18295  delpc(i, j) = gridstruct%rarea_c(i, j)*delpc(i, j)
18296  IF (delpc(i, j)*dt .GE. 0.) THEN
18297  abs2 = delpc(i, j)*dt
18298  CALL pushcontrol(1,0)
18299  ELSE
18300  abs2 = -(delpc(i, j)*dt)
18301  CALL pushcontrol(1,1)
18302  END IF
18303  y3 = dddmp*abs2
18304  IF (0.20 .GT. y3) THEN
18305  y1 = y3
18306  CALL pushcontrol(1,0)
18307  ELSE
18308  y1 = 0.20
18309  CALL pushcontrol(1,1)
18310  END IF
18311  IF (d2_bg .LT. y1) THEN
18312  max1 = y1
18313  CALL pushcontrol(1,0)
18314  ELSE
18315  max1 = d2_bg
18316  CALL pushcontrol(1,1)
18317  END IF
18318  CALL pushrealarray(damp)
18319  damp = gridstruct%da_min_c*max1
18320  vort(i, j) = damp*delpc(i, j)
18321  ke(i, j) = ke(i, j) + vort(i, j)
18322  END DO
18323  END DO
18324  CALL pushinteger(je)
18325  CALL pushinteger(ie1)
18326  CALL pushinteger(is)
18327  !CALL PUSHPOINTER8(C_LOC(sina_v))
18328  !CALL PUSHPOINTER8(C_LOC(sina_u))
18329  CALL pushinteger(ie)
18330  !CALL PUSHPOINTER8(C_LOC(dyc))
18331  !CALL PUSHPOINTER8(C_LOC(sin_sg))
18332  !CALL PUSHPOINTER8(C_LOC(cosa_v))
18333  !CALL PUSHPOINTER8(C_LOC(cosa_u))
18334  CALL pushinteger(is2)
18335  !CALL PUSHPOINTER8(C_LOC(dxc))
18336  CALL pushrealarray(damp)
18337  CALL pushinteger(npy)
18338  CALL pushinteger(npx)
18339  CALL pushinteger(js)
18340  CALL pushcontrol(1,0)
18341  ELSE
18342 !--------------------------
18343 ! Higher order divg damping
18344 !--------------------------
18345  DO j=js,je+1
18346  DO i=is,ie+1
18347 ! Save divergence for external mode filter
18348  CALL pushrealarray(delpc(i, j))
18349  delpc(i, j) = divg_d(i, j)
18350  END DO
18351  END DO
18352 ! N > 1
18353  n2 = nord + 1
18354  DO n=1,nord
18355  nt = nord - n
18356  fill_c = nt .NE. 0 .AND. flagstruct%grid_type .LT. 3 .AND. (((&
18357 & sw_corner .OR. se_corner) .OR. ne_corner) .OR. nw_corner) &
18358 & .AND. (.NOT.nested)
18359  IF (fill_c) THEN
18360  CALL fill_corners(divg_d, npx, npy, fill=xdir, bgrid=.true.)
18361  CALL pushcontrol(1,1)
18362  ELSE
18363  CALL pushcontrol(1,0)
18364  END IF
18365  ad_from0 = js - nt
18366  DO j=ad_from0,je+1+nt
18367  ad_from = is - 1 - nt
18368  DO i=ad_from,ie+1+nt
18369  vc(i, j) = (divg_d(i+1, j)-divg_d(i, j))*divg_u(i, j)
18370  END DO
18371  CALL pushinteger(i - 1)
18372  CALL pushinteger(ad_from)
18373  END DO
18374  CALL pushinteger(j - 1)
18375  CALL pushinteger(ad_from0)
18376  IF (fill_c) THEN
18377  CALL fill_corners(divg_d, npx, npy, fill=ydir, bgrid=.true.)
18378  CALL pushcontrol(1,1)
18379  ELSE
18380  CALL pushcontrol(1,0)
18381  END IF
18382  ad_from2 = js - 1 - nt
18383  DO j=ad_from2,je+1+nt
18384  ad_from1 = is - nt
18385  DO i=ad_from1,ie+1+nt
18386  uc(i, j) = (divg_d(i, j+1)-divg_d(i, j))*divg_v(i, j)
18387  END DO
18388  CALL pushinteger(i - 1)
18389  CALL pushinteger(ad_from1)
18390  END DO
18391  CALL pushinteger(j - 1)
18392  CALL pushinteger(ad_from2)
18393  IF (fill_c) THEN
18394  CALL fill_corners(vc, uc, npx, npy, vector=.true., dgrid=&
18395 & .true.)
18396  CALL pushcontrol(1,1)
18397  ELSE
18398  CALL pushcontrol(1,0)
18399  END IF
18400  ad_from4 = js - nt
18401  DO j=ad_from4,je+1+nt
18402  ad_from3 = is - nt
18403  DO i=ad_from3,ie+1+nt
18404  divg_d(i, j) = uc(i, j-1) - uc(i, j) + (vc(i-1, j)-vc(i, j))
18405  END DO
18406  CALL pushinteger(i - 1)
18407  CALL pushinteger(ad_from3)
18408  END DO
18409  CALL pushinteger(j - 1)
18410  CALL pushinteger(ad_from4)
18411 ! Remove the extra term at the corners:
18412  IF (sw_corner) THEN
18413  divg_d(1, 1) = divg_d(1, 1) - uc(1, 0)
18414  CALL pushcontrol(1,0)
18415  ELSE
18416  CALL pushcontrol(1,1)
18417  END IF
18418  IF (se_corner) THEN
18419  divg_d(npx, 1) = divg_d(npx, 1) - uc(npx, 0)
18420  CALL pushcontrol(1,0)
18421  ELSE
18422  CALL pushcontrol(1,1)
18423  END IF
18424  IF (ne_corner) THEN
18425  divg_d(npx, npy) = divg_d(npx, npy) + uc(npx, npy)
18426  CALL pushcontrol(1,0)
18427  ELSE
18428  CALL pushcontrol(1,1)
18429  END IF
18430  IF (nw_corner) THEN
18431  divg_d(1, npy) = divg_d(1, npy) + uc(1, npy)
18432  CALL pushcontrol(1,0)
18433  ELSE
18434  CALL pushcontrol(1,1)
18435  END IF
18436  IF (.NOT.gridstruct%stretched_grid) THEN
18437  ad_from6 = js - nt
18438  DO j=ad_from6,je+1+nt
18439  ad_from5 = is - nt
18440  DO i=ad_from5,ie+1+nt
18441  divg_d(i, j) = divg_d(i, j)*gridstruct%rarea_c(i, j)
18442  END DO
18443  CALL pushinteger(i - 1)
18444  CALL pushinteger(ad_from5)
18445  END DO
18446  CALL pushinteger(j - 1)
18447  CALL pushinteger(ad_from6)
18448  CALL pushcontrol(1,1)
18449  ELSE
18450  CALL pushcontrol(1,0)
18451  END IF
18452  END DO
18453 ! n-loop
18454  IF (dddmp .LT. 1.e-5) THEN
18455  vort(:, :) = 0.
18456  CALL pushcontrol(2,0)
18457  ELSE IF (flagstruct%grid_type .LT. 3) THEN
18458 ! Interpolate relative vort to cell corners
18459  CALL a2b_ord4_fwd(wk, vort, gridstruct, npx, npy, is, ie, js&
18460 & , je, ng, .false.)
18461  DO j=js,je+1
18462  DO i=is,ie+1
18463  IF (dt .GE. 0.) THEN
18464  CALL pushrealarray(abs0)
18465  abs0 = dt
18466  CALL pushcontrol(1,0)
18467  ELSE
18468  CALL pushrealarray(abs0)
18469  abs0 = -dt
18470  CALL pushcontrol(1,1)
18471  END IF
18472 ! The following is an approxi form of Smagorinsky diffusion
18473  CALL pushrealarray(vort(i, j))
18474  vort(i, j) = abs0*sqrt(delpc(i, j)**2+vort(i, j)**2)
18475  END DO
18476  END DO
18477  CALL pushcontrol(2,1)
18478  ELSE
18479  IF (dt .GE. 0.) THEN
18480  abs1 = dt
18481  ELSE
18482  abs1 = -dt
18483  END IF
18484 ! Correct form: works only for doubly preiodic domain
18485  CALL smag_corner_fwd(abs1, u, v, ua, va, vort, bd, npx, npy, &
18486 & gridstruct, ng)
18487  CALL pushcontrol(2,2)
18488  END IF
18489  IF (gridstruct%stretched_grid) THEN
18490 ! Stretched grid with variable damping ~ area
18491  dd8 = gridstruct%da_min*d4_bg**n2
18492  ELSE
18493  dd8 = (gridstruct%da_min_c*d4_bg)**n2
18494  END IF
18495  DO j=js,je+1
18496  DO i=is,ie+1
18497  IF (0.20 .GT. dddmp*vort(i, j)) THEN
18498  y2 = dddmp*vort(i, j)
18499  CALL pushcontrol(1,0)
18500  ELSE
18501  CALL pushcontrol(1,1)
18502  y2 = 0.20
18503  END IF
18504  IF (d2_bg .LT. y2) THEN
18505  max2 = y2
18506  CALL pushcontrol(1,0)
18507  ELSE
18508  max2 = d2_bg
18509  CALL pushcontrol(1,1)
18510  END IF
18511 ! del-2
18512  CALL pushrealarray(damp2)
18513  damp2 = gridstruct%da_min_c*max2
18514  vort(i, j) = damp2*delpc(i, j) + dd8*divg_d(i, j)
18515  ke(i, j) = ke(i, j) + vort(i, j)
18516  END DO
18517  END DO
18518  CALL pushrealarray(damp2)
18519  CALL pushinteger(je)
18520  CALL pushinteger(is)
18521  CALL pushrealarray(dd8)
18522  CALL pushinteger(ie)
18523  CALL pushrealarray(abs1)
18524  CALL pushrealarray(abs0)
18525  CALL pushinteger(js)
18526  CALL pushcontrol(1,1)
18527  END IF
18528  END SUBROUTINE compute_divergence_damping_fwd
18529 ! Differentiation of compute_divergence_damping in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2
18530 !b_ord4_fb a2b_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_
18531 !mod.adv_pe dyn_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_u
18532 !pdate dyn_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_d
18533 !ynamics_mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_gr
18534 !id_utils_mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod
18535 !.pkez fv_mapz_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv
18536 !_mapz_mod.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_ma
18537 !pz_mod.ppm_limiters 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
18538 !_mod.map1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested
18539 ! fv_sg_mod.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.u
18540 !pdate_dz_d nh_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM
18541 !3_solver nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_
18542 !profile nh_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner
18543 !_nest sw_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u_f
18544 !b sw_core_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.
18545 !fv_tp_2d tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_cor
18546 !ner_fb fv_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18547 ! gradient of useful results: u v ke ua uc ptc delpc va vc
18548 ! vort divg_d wk
18549 ! with respect to varying inputs: u v ke ua uc ptc delpc va vc
18550 ! divg_d wk
18551  SUBROUTINE compute_divergence_damping_bwd(nord, d2_bg, d4_bg, dddmp&
18552 & , dt, vort, vort_ad, ptc, ptc_ad, delpc, delpc_ad, ke, ke_ad, u, &
18553 & u_ad, v, v_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, &
18554 & divg_d_ad, wk, wk_ad, gridstruct, flagstruct, bd)
18555  !USE ISO_C_BINDING
18556  !USE ADMM_TAPENADE_INTERFACE
18557  IMPLICIT NONE
18558  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
18559  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
18560  TYPE(FV_FLAGS_TYPE), INTENT(IN), TARGET :: flagstruct
18561  INTEGER, INTENT(IN) :: nord
18562  REAL, INTENT(IN) :: d2_bg, d4_bg, dddmp, dt
18563  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
18564  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ua_ad, va_ad
18565  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
18566  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
18567  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
18568  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
18569  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: wk
18570  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
18571 & wk_ad
18572  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: vort
18573  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
18574 & vort_ad
18575  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
18576 & delpc, ptc
18577  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(INOUT) :: &
18578 & delpc_ad, ptc_ad
18579  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18580 & ke
18581  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18582 & ke_ad
18583  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: vc
18584  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18585 & vc_ad
18586  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: uc
18587  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(INOUT) :: &
18588 & uc_ad
18589  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18590 & divg_d
18591  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed+1), INTENT(INOUT) :: &
18592 & divg_d_ad
18593  REAL :: damp, dd8, damp2, da_min, da_min_c, absdt
18594  REAL :: damp_ad, damp2_ad
18595  INTEGER :: is, ie, js, je, npx, npy, is2, ie1
18596  LOGICAL :: nested, fill_c
18597  INTEGER :: i, j, n, n2, nt
18598  LOGICAL :: sw_corner, se_corner, ne_corner, nw_corner
18599  REAL, DIMENSION(:, :), POINTER :: area, area_c, rarea
18600  REAL, DIMENSION(:, :, :), POINTER :: sin_sg
18601  REAL, DIMENSION(:, :), POINTER :: cosa_u, cosa_v, cosa_s
18602  REAL, DIMENSION(:, :), POINTER :: sina_u, sina_v
18603  REAL, DIMENSION(:, :), POINTER :: rsin_u, rsin_v, rsina
18604  REAL, DIMENSION(:, :), POINTER :: f0, rsin2, divg_u, divg_v
18605  REAL, DIMENSION(:, :), POINTER :: cosa, dx, dy, dxc, dyc, rdxa, rdya&
18606 & , rdx, rdy
18607  INTRINSIC ABS
18608  INTRINSIC max
18609  INTRINSIC min
18610  INTRINSIC sqrt
18611  REAL :: max1
18612  REAL :: max1_ad
18613  REAL :: abs0
18614  REAL :: abs1
18615  REAL :: max2
18616  REAL :: max2_ad
18617  REAL :: abs2
18618  REAL :: abs2_ad
18619  REAL :: temp_ad
18620  REAL :: temp_ad0
18621  REAL :: temp_ad1
18622  REAL :: temp_ad2
18623  REAL :: temp_ad3
18624  REAL :: temp_ad4
18625  REAL :: temp_ad5
18626  REAL :: temp_ad6
18627  REAL :: y3_ad
18628  REAL :: y1_ad
18629  REAL :: temp_ad7
18630  REAL :: temp_ad8
18631  REAL :: temp_ad9
18632  REAL :: y2_ad
18633  INTEGER :: branch
18634  INTEGER :: ad_from
18635  INTEGER :: ad_to
18636  INTEGER :: ad_from0
18637  INTEGER :: ad_to0
18638  INTEGER :: ad_from1
18639  INTEGER :: ad_to1
18640  INTEGER :: ad_from2
18641  INTEGER :: ad_to2
18642  INTEGER :: ad_from3
18643  INTEGER :: ad_to3
18644  INTEGER :: ad_from4
18645  INTEGER :: ad_to4
18646  INTEGER :: ad_from5
18647  INTEGER :: ad_to5
18648  INTEGER :: ad_from6
18649  INTEGER :: ad_to6
18650  !TYPE(C_PTR) :: cptr
18651  !INTEGER :: unknown_shape_in_compute_divergence_damping
18652  REAL :: y3
18653  REAL :: y2
18654  REAL :: y1
18655 
18656  damp = 0.0
18657  dd8 = 0.0
18658  damp2 = 0.0
18659  da_min = 0.0
18660  da_min_c = 0.0
18661  absdt = 0.0
18662  is = 0
18663  ie = 0
18664  js = 0
18665  je = 0
18666  npx = 0
18667  npy = 0
18668  is2 = 0
18669  ie1 = 0
18670  n = 0
18671  n2 = 0
18672  nt = 0
18673  max1 = 0.0
18674  abs0 = 0.0
18675  abs1 = 0.0
18676  max2 = 0.0
18677  abs2 = 0.0
18678  ad_from = 0
18679  ad_from0 = 0
18680  ad_from1 = 0
18681  ad_from2 = 0
18682  ad_from3 = 0
18683  ad_from4 = 0
18684  ad_from5 = 0
18685  ad_from6 = 0
18686  ad_to = 0
18687  ad_to0 = 0
18688  ad_to1 = 0
18689  ad_to2 = 0
18690  ad_to3 = 0
18691  ad_to4 = 0
18692  ad_to5 = 0
18693  ad_to6 = 0
18694  y3 = 0.0
18695  y2 = 0.0
18696  y1 = 0.0
18697  branch = 0
18698 
18699  sin_sg => gridstruct%sin_sg
18700  cosa_u => gridstruct%cosa_u
18701  cosa_v => gridstruct%cosa_v
18702  sina_u => gridstruct%sina_u
18703  sina_v => gridstruct%sina_v
18704  divg_u => gridstruct%divg_u
18705  divg_v => gridstruct%divg_v
18706  dxc => gridstruct%dxc
18707  dyc => gridstruct%dyc
18708  sw_corner = gridstruct%sw_corner
18709  se_corner = gridstruct%se_corner
18710  nw_corner = gridstruct%nw_corner
18711  ne_corner = gridstruct%ne_corner
18712  is = bd%is
18713  ie = bd%ie
18714  js = bd%js
18715  je = bd%je
18716  npx = flagstruct%npx
18717  npy = flagstruct%npy
18718  nested = gridstruct%nested
18719  CALL popcontrol(1,branch)
18720  IF (branch .EQ. 0) THEN
18721  CALL popinteger(js)
18722  CALL popinteger(npx)
18723  CALL popinteger(npy)
18724  CALL poprealarray(damp)
18725  !CALL POPPOINTER8(cptr)
18726  dxc => gridstruct%dxc ! (/&
18727 !& unknown_shape_in_compute_divergence_damping/))
18728  CALL popinteger(is2)
18729  !CALL POPPOINTER8(cptr)
18730  cosa_u => gridstruct%cosa_u ! (/&
18731 !& unknown_shape_in_compute_divergence_damping/))
18732  !CALL POPPOINTER8(cptr)
18733  cosa_v => gridstruct%cosa_v ! (/&
18734 !& unknown_shape_in_compute_divergence_damping/))
18735  !CALL POPPOINTER8(cptr)
18736  sin_sg => gridstruct%sin_sg ! (/&
18737 !& unknown_shape_in_compute_divergence_damping/))
18738  !CALL POPPOINTER8(cptr)
18739  dyc => gridstruct%dyc ! (/&
18740 !& unknown_shape_in_compute_divergence_damping/))
18741  CALL popinteger(ie)
18742  !CALL POPPOINTER8(cptr)
18743  sina_u => gridstruct%sina_u ! (/&
18744 !& unknown_shape_in_compute_divergence_damping/))
18745  !CALL POPPOINTER8(cptr)
18746  sina_v => gridstruct%sina_v ! (/&
18747 !& unknown_shape_in_compute_divergence_damping/))
18748  CALL popinteger(is)
18749  CALL popinteger(ie1)
18750  CALL popinteger(je)
18751  DO j=je+1,js,-1
18752  DO i=ie+1,is,-1
18753  vort_ad(i, j) = vort_ad(i, j) + ke_ad(i, j)
18754  damp_ad = delpc(i, j)*vort_ad(i, j)
18755  delpc_ad(i, j) = delpc_ad(i, j) + damp*vort_ad(i, j)
18756  vort_ad(i, j) = 0.0
18757  CALL poprealarray(damp)
18758  max1_ad = gridstruct%da_min_c*damp_ad
18759  CALL popcontrol(1,branch)
18760  IF (branch .EQ. 0) THEN
18761  y1_ad = max1_ad
18762  ELSE
18763  y1_ad = 0.0
18764  END IF
18765  CALL popcontrol(1,branch)
18766  IF (branch .EQ. 0) THEN
18767  y3_ad = y1_ad
18768  ELSE
18769  y3_ad = 0.0
18770  END IF
18771  abs2_ad = dddmp*y3_ad
18772  CALL popcontrol(1,branch)
18773  IF (branch .EQ. 0) THEN
18774  delpc_ad(i, j) = delpc_ad(i, j) + dt*abs2_ad
18775  ELSE
18776  delpc_ad(i, j) = delpc_ad(i, j) - dt*abs2_ad
18777  END IF
18778  CALL poprealarray(delpc(i, j))
18779  delpc_ad(i, j) = gridstruct%rarea_c(i, j)*delpc_ad(i, j)
18780  END DO
18781  END DO
18782  CALL popcontrol(1,branch)
18783  IF (branch .NE. 0) THEN
18784  npy = flagstruct%npy
18785  CALL poprealarray(delpc(1, npy))
18786  vort_ad(1, npy) = vort_ad(1, npy) + delpc_ad(1, npy)
18787  END IF
18788  CALL popcontrol(1,branch)
18789  IF (branch .EQ. 0) THEN
18790  npx = flagstruct%npx
18791  CALL poprealarray(delpc(npx, npy))
18792  vort_ad(npx, npy) = vort_ad(npx, npy) + delpc_ad(npx, npy)
18793  END IF
18794  CALL popcontrol(1,branch)
18795  IF (branch .EQ. 0) THEN
18796  CALL poprealarray(delpc(npx, 1))
18797  vort_ad(npx, 0) = vort_ad(npx, 0) - delpc_ad(npx, 1)
18798  END IF
18799  CALL popcontrol(1,branch)
18800  IF (branch .EQ. 0) THEN
18801  CALL poprealarray(delpc(1, 1))
18802  vort_ad(1, 0) = vort_ad(1, 0) - delpc_ad(1, 1)
18803  END IF
18804  DO j=je+1,js,-1
18805  DO i=ie+1,is,-1
18806  CALL poprealarray(delpc(i, j))
18807  vort_ad(i, j-1) = vort_ad(i, j-1) + delpc_ad(i, j)
18808  vort_ad(i, j) = vort_ad(i, j) - delpc_ad(i, j)
18809  ptc_ad(i-1, j) = ptc_ad(i-1, j) + delpc_ad(i, j)
18810  ptc_ad(i, j) = ptc_ad(i, j) - delpc_ad(i, j)
18811  delpc_ad(i, j) = 0.0
18812  END DO
18813  END DO
18814  CALL popcontrol(1,branch)
18815  IF (branch .EQ. 0) THEN
18816  DO j=je+1,js-1,-1
18817  CALL popcontrol(2,branch)
18818  IF (branch .NE. 0) THEN
18819  IF (branch .EQ. 1) THEN
18820  v_ad(npx, j) = v_ad(npx, j) + sin_sg(npx, j, 1)*dxc(npx, j&
18821 & )*vort_ad(npx, j)
18822  vort_ad(npx, j) = 0.0
18823  ELSE
18824  v_ad(npx, j) = v_ad(npx, j) + sin_sg(npx-1, j, 3)*dxc(npx&
18825 & , j)*vort_ad(npx, j)
18826  vort_ad(npx, j) = 0.0
18827  END IF
18828  END IF
18829  CALL popcontrol(2,branch)
18830  IF (branch .EQ. 0) THEN
18831  v_ad(1, j) = v_ad(1, j) + sin_sg(0, j, 3)*dxc(1, j)*vort_ad(&
18832 & 1, j)
18833  vort_ad(1, j) = 0.0
18834  ELSE IF (branch .EQ. 1) THEN
18835  v_ad(1, j) = v_ad(1, j) + sin_sg(1, j, 1)*dxc(1, j)*vort_ad(&
18836 & 1, j)
18837  vort_ad(1, j) = 0.0
18838  END IF
18839  DO i=ie1,is2,-1
18840  temp_ad5 = dxc(i, j)*sina_u(i, j)*vort_ad(i, j)
18841  temp_ad6 = -(cosa_u(i, j)*0.5*temp_ad5)
18842  v_ad(i, j) = v_ad(i, j) + temp_ad5
18843  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad6
18844  ua_ad(i, j) = ua_ad(i, j) + temp_ad6
18845  vort_ad(i, j) = 0.0
18846  END DO
18847  END DO
18848  DO j=je+1,js,-1
18849  CALL popcontrol(1,branch)
18850  IF (branch .EQ. 0) THEN
18851  DO i=ie+1,is-1,-1
18852  CALL poprealarray(ptc(i, j))
18853  temp_ad3 = dyc(i, j)*sina_v(i, j)*ptc_ad(i, j)
18854  temp_ad4 = -(cosa_v(i, j)*0.5*temp_ad3)
18855  u_ad(i, j) = u_ad(i, j) + temp_ad3
18856  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad4
18857  va_ad(i, j) = va_ad(i, j) + temp_ad4
18858  ptc_ad(i, j) = 0.0
18859  END DO
18860  ELSE
18861  DO i=ie+1,is-1,-1
18862  CALL popcontrol(1,branch)
18863  IF (branch .EQ. 0) THEN
18864  CALL poprealarray(ptc(i, j))
18865  u_ad(i, j) = u_ad(i, j) + sin_sg(i, j, 2)*dyc(i, j)*&
18866 & ptc_ad(i, j)
18867  ptc_ad(i, j) = 0.0
18868  ELSE
18869  CALL poprealarray(ptc(i, j))
18870  u_ad(i, j) = u_ad(i, j) + sin_sg(i, j-1, 4)*dyc(i, j)*&
18871 & ptc_ad(i, j)
18872  ptc_ad(i, j) = 0.0
18873  END IF
18874  END DO
18875  END IF
18876  END DO
18877  ELSE
18878  DO j=je+1,js-1,-1
18879  DO i=ie1,is2,-1
18880  temp_ad1 = dxc(i, j)*sina_u(i, j)*vort_ad(i, j)
18881  temp_ad2 = -(cosa_u(i, j)*0.5*temp_ad1)
18882  v_ad(i, j) = v_ad(i, j) + temp_ad1
18883  ua_ad(i-1, j) = ua_ad(i-1, j) + temp_ad2
18884  ua_ad(i, j) = ua_ad(i, j) + temp_ad2
18885  vort_ad(i, j) = 0.0
18886  END DO
18887  END DO
18888  DO j=je+1,js,-1
18889  DO i=ie+1,is-1,-1
18890  CALL poprealarray(ptc(i, j))
18891  temp_ad = dyc(i, j)*sina_v(i, j)*ptc_ad(i, j)
18892  temp_ad0 = -(cosa_v(i, j)*0.5*temp_ad)
18893  u_ad(i, j) = u_ad(i, j) + temp_ad
18894  va_ad(i, j-1) = va_ad(i, j-1) + temp_ad0
18895  va_ad(i, j) = va_ad(i, j) + temp_ad0
18896  ptc_ad(i, j) = 0.0
18897  END DO
18898  END DO
18899  END IF
18900  ELSE
18901  CALL popinteger(js)
18902  CALL poprealarray(abs0)
18903  CALL poprealarray(abs1)
18904  CALL popinteger(ie)
18905  CALL poprealarray(dd8)
18906  CALL popinteger(is)
18907  CALL popinteger(je)
18908  CALL poprealarray(damp2)
18909  DO j=je+1,js,-1
18910  DO i=ie+1,is,-1
18911  vort_ad(i, j) = vort_ad(i, j) + ke_ad(i, j)
18912  damp2_ad = delpc(i, j)*vort_ad(i, j)
18913  delpc_ad(i, j) = delpc_ad(i, j) + damp2*vort_ad(i, j)
18914  divg_d_ad(i, j) = divg_d_ad(i, j) + dd8*vort_ad(i, j)
18915  vort_ad(i, j) = 0.0
18916  CALL poprealarray(damp2)
18917  max2_ad = gridstruct%da_min_c*damp2_ad
18918  CALL popcontrol(1,branch)
18919  IF (branch .EQ. 0) THEN
18920  y2_ad = max2_ad
18921  ELSE
18922  y2_ad = 0.0
18923  END IF
18924  CALL popcontrol(1,branch)
18925  IF (branch .EQ. 0) vort_ad(i, j) = vort_ad(i, j) + dddmp*y2_ad
18926  END DO
18927  END DO
18928  CALL popcontrol(2,branch)
18929  IF (branch .EQ. 0) THEN
18930  npx = flagstruct%npx
18931  npy = flagstruct%npy
18932  ELSE IF (branch .EQ. 1) THEN
18933  DO j=je+1,js,-1
18934  DO i=ie+1,is,-1
18935  CALL poprealarray(vort(i, j))
18936  IF (delpc(i, j)**2 + vort(i, j)**2 .EQ. 0.0) THEN
18937  temp_ad9 = 0.0
18938  ELSE
18939  temp_ad9 = abs0*vort_ad(i, j)/(2.0*sqrt(delpc(i, j)**2+&
18940 & vort(i, j)**2))
18941  END IF
18942  delpc_ad(i, j) = delpc_ad(i, j) + 2*delpc(i, j)*temp_ad9
18943  vort_ad(i, j) = 2*vort(i, j)*temp_ad9
18944  CALL popcontrol(1,branch)
18945  IF (branch .EQ. 0) THEN
18946  CALL poprealarray(abs0)
18947  ELSE
18948  CALL poprealarray(abs0)
18949  END IF
18950  END DO
18951  END DO
18952  npx = flagstruct%npx
18953  npy = flagstruct%npy
18954  CALL a2b_ord4_bwd(wk, wk_ad, vort, vort_ad, gridstruct, npx, &
18955 & npy, is, ie, js, je, ng, .false.)
18956  ELSE
18957  npx = flagstruct%npx
18958  npy = flagstruct%npy
18959  CALL smag_corner_bwd(abs1, u, u_ad, v, v_ad, ua, va, vort, &
18960 & vort_ad, bd, npx, npy, gridstruct, ng)
18961  END IF
18962  divg_u => gridstruct%divg_u
18963  divg_v => gridstruct%divg_v
18964  DO n=nord,1,-1
18965  CALL popcontrol(1,branch)
18966  IF (branch .NE. 0) THEN
18967  CALL popinteger(ad_from6)
18968  CALL popinteger(ad_to6)
18969  DO j=ad_to6,ad_from6,-1
18970  CALL popinteger(ad_from5)
18971  CALL popinteger(ad_to5)
18972  DO i=ad_to5,ad_from5,-1
18973  divg_d_ad(i, j) = gridstruct%rarea_c(i, j)*divg_d_ad(i, j)
18974  END DO
18975  END DO
18976  END IF
18977  CALL popcontrol(1,branch)
18978  IF (branch .EQ. 0) uc_ad(1, npy) = uc_ad(1, npy) + divg_d_ad(1, &
18979 & npy)
18980  CALL popcontrol(1,branch)
18981  IF (branch .EQ. 0) uc_ad(npx, npy) = uc_ad(npx, npy) + divg_d_ad&
18982 & (npx, npy)
18983  CALL popcontrol(1,branch)
18984  IF (branch .EQ. 0) uc_ad(npx, 0) = uc_ad(npx, 0) - divg_d_ad(npx&
18985 & , 1)
18986  CALL popcontrol(1,branch)
18987  IF (branch .EQ. 0) uc_ad(1, 0) = uc_ad(1, 0) - divg_d_ad(1, 1)
18988  CALL popinteger(ad_from4)
18989  CALL popinteger(ad_to4)
18990  DO j=ad_to4,ad_from4,-1
18991  CALL popinteger(ad_from3)
18992  CALL popinteger(ad_to3)
18993  DO i=ad_to3,ad_from3,-1
18994  uc_ad(i, j-1) = uc_ad(i, j-1) + divg_d_ad(i, j)
18995  uc_ad(i, j) = uc_ad(i, j) - divg_d_ad(i, j)
18996  vc_ad(i-1, j) = vc_ad(i-1, j) + divg_d_ad(i, j)
18997  vc_ad(i, j) = vc_ad(i, j) - divg_d_ad(i, j)
18998  divg_d_ad(i, j) = 0.0
18999  END DO
19000  END DO
19001  CALL popcontrol(1,branch)
19002  IF (branch .NE. 0) CALL fill_corners_adm(vc, vc_ad, uc, uc_ad, &
19003 & npx, npy, dgrid=.true., &
19004 & vector=.true.)
19005  CALL popinteger(ad_from2)
19006  CALL popinteger(ad_to2)
19007  DO j=ad_to2,ad_from2,-1
19008  CALL popinteger(ad_from1)
19009  CALL popinteger(ad_to1)
19010  DO i=ad_to1,ad_from1,-1
19011  temp_ad8 = divg_v(i, j)*uc_ad(i, j)
19012  divg_d_ad(i, j+1) = divg_d_ad(i, j+1) + temp_ad8
19013  divg_d_ad(i, j) = divg_d_ad(i, j) - temp_ad8
19014  uc_ad(i, j) = 0.0
19015  END DO
19016  END DO
19017  CALL popcontrol(1,branch)
19018  IF (branch .NE. 0) CALL fill_corners_adm(divg_d, divg_d_ad, npx&
19019 & , npy, fill=ydir, bgrid=&
19020 & .true.)
19021  CALL popinteger(ad_from0)
19022  CALL popinteger(ad_to0)
19023  DO j=ad_to0,ad_from0,-1
19024  CALL popinteger(ad_from)
19025  CALL popinteger(ad_to)
19026  DO i=ad_to,ad_from,-1
19027  temp_ad7 = divg_u(i, j)*vc_ad(i, j)
19028  divg_d_ad(i+1, j) = divg_d_ad(i+1, j) + temp_ad7
19029  divg_d_ad(i, j) = divg_d_ad(i, j) - temp_ad7
19030  vc_ad(i, j) = 0.0
19031  END DO
19032  END DO
19033  CALL popcontrol(1,branch)
19034  IF (branch .NE. 0) CALL fill_corners_adm(divg_d, divg_d_ad, npx&
19035 & , npy, fill=xdir, bgrid=&
19036 & .true.)
19037  END DO
19038  DO j=je+1,js,-1
19039  DO i=ie+1,is,-1
19040  CALL poprealarray(delpc(i, j))
19041  divg_d_ad(i, j) = divg_d_ad(i, j) + delpc_ad(i, j)
19042  delpc_ad(i, j) = 0.0
19043  END DO
19044  END DO
19045  END IF
19046  CALL popcontrol(1,branch)
19047  END SUBROUTINE compute_divergence_damping_bwd
19048 ! Differentiation of smag_corner in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
19049 !ge_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_c
19050 !ore_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_m
19051 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
19052 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
19053 !_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_mo
19054 !d.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_
19055 !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_limit
19056 !ers 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
19057 !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_su
19058 !bgrid_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_ut
19059 !ils_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_util
19060 !s_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
19061 !_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_mo
19062 !d.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.yt
19063 !p_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_c
19064 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
19065 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19066 ! gradient of useful results: smag_c u v
19067 ! with respect to varying inputs: u v
19068  SUBROUTINE smag_corner_fwd(dt, u, v, ua, va, smag_c, bd, npx, npy, &
19069 & gridstruct, ng)
19070  !USE ISO_C_BINDING
19071  !USE ADMM_TAPENADE_INTERFACE
19072  IMPLICIT NONE
19073 ! Compute the Tension_Shear strain at cell corners for Smagorinsky diffusion
19074 !!! work only if (grid_type==4)
19075  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
19076  REAL, INTENT(IN) :: dt
19077  INTEGER, INTENT(IN) :: npx, npy, ng
19078  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
19079  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
19080  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
19081  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: smag_c
19082  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
19083 ! local
19084  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
19085  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
19086 ! work array
19087  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
19088  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
19089  INTEGER :: i, j
19090  INTEGER :: is2, ie1
19091  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
19092  INTEGER :: is, ie, js, je
19093  INTEGER :: isd, ied, jsd, jed
19094  INTRINSIC max
19095  INTRINSIC min
19096  INTRINSIC sqrt
19097 
19098  ut = 0.0
19099  vt = 0.0
19100  wk = 0.0
19101  sh = 0.0
19102  is2 = 0
19103  ie1 = 0
19104  is = 0
19105  ie = 0
19106  js = 0
19107  je = 0
19108  isd = 0
19109  ied = 0
19110  jsd = 0
19111  jed = 0
19112 
19113  is = bd%is
19114  ie = bd%ie
19115  js = bd%js
19116  je = bd%je
19117  isd = bd%isd
19118  ied = bd%ied
19119  jsd = bd%jsd
19120  jed = bd%jed
19121  dxc => gridstruct%dxc
19122  dyc => gridstruct%dyc
19123  dx => gridstruct%dx
19124  dy => gridstruct%dy
19125  rarea => gridstruct%rarea
19126  rarea_c => gridstruct%rarea_c
19127 ! Smag = sqrt [ T**2 + S**2 ]: unit = 1/s
19128 ! where T = du/dx - dv/dy; S = du/dy + dv/dx
19129 ! Compute tension strain at corners:
19130  DO j=js,je+1
19131  DO i=is-1,ie+1
19132  ut(i, j) = u(i, j)*dyc(i, j)
19133  END DO
19134  END DO
19135  DO j=js-1,je+1
19136  DO i=is,ie+1
19137  vt(i, j) = v(i, j)*dxc(i, j)
19138  END DO
19139  END DO
19140  DO j=js,je+1
19141  DO i=is,ie+1
19142  smag_c(i, j) = rarea_c(i, j)*(vt(i, j-1)-vt(i, j)-ut(i-1, j)+ut(&
19143 & i, j))
19144  END DO
19145  END DO
19146 ! Fix the corners?? if grid_type /= 4
19147 ! Compute shear strain:
19148  DO j=jsd,jed+1
19149  DO i=isd,ied
19150  vt(i, j) = u(i, j)*dx(i, j)
19151  END DO
19152  END DO
19153  DO j=jsd,jed
19154  DO i=isd,ied+1
19155  ut(i, j) = v(i, j)*dy(i, j)
19156  END DO
19157  END DO
19158  DO j=jsd,jed
19159  DO i=isd,ied
19160  wk(i, j) = rarea(i, j)*(vt(i, j)-vt(i, j+1)+ut(i, j)-ut(i+1, j))
19161  END DO
19162  END DO
19163  CALL a2b_ord4_fwd(wk, sh, gridstruct, npx, npy, is, ie, js, je, &
19164 & ng, .false.)
19165  DO j=js,je+1
19166  DO i=is,ie+1
19167  CALL pushrealarray(smag_c(i, j))
19168  smag_c(i, j) = dt*sqrt(sh(i, j)**2+smag_c(i, j)**2)
19169  END DO
19170  END DO
19171  CALL pushinteger(jed)
19172  CALL pushinteger(je)
19173  CALL pushinteger(is)
19174  CALL pushrealarray(sh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
19175  CALL pushinteger(ie)
19176  !CALL PUSHPOINTER8(C_LOC(dyc))
19177  !CALL PUSHPOINTER8(C_LOC(rarea_c))
19178  !CALL PUSHPOINTER8(C_LOC(dy))
19179  !CALL PUSHPOINTER8(C_LOC(dx))
19180  !CALL PUSHPOINTER8(C_LOC(dxc))
19181  CALL pushinteger(js)
19182  END SUBROUTINE smag_corner_fwd
19183 ! Differentiation of smag_corner in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_e
19184 !dge_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_
19185 !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_
19186 !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.Ray
19187 !leigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2
19188 !l_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_m
19189 !od.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
19190 !_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_limi
19191 !ters 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
19192 ! 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_s
19193 !ubgrid_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_u
19194 !tils_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_uti
19195 !ls_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_util
19196 !s_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_m
19197 !od.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.y
19198 !tp_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_
19199 !core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_
19200 !utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19201 ! gradient of useful results: smag_c u v
19202 ! with respect to varying inputs: u v
19203  SUBROUTINE smag_corner_bwd(dt, u, u_ad, v, v_ad, ua, va, smag_c, &
19204 & smag_c_ad, bd, npx, npy, gridstruct, ng)
19205  !USE ISO_C_BINDING
19206  !USE ADMM_TAPENADE_INTERFACE
19207  IMPLICIT NONE
19208  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
19209  REAL, INTENT(IN) :: dt
19210  INTEGER, INTENT(IN) :: npx, npy, ng
19211  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1), INTENT(IN) :: u
19212  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1) :: u_ad
19213  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed), INTENT(IN) :: v
19214  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed) :: v_ad
19215  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed), INTENT(IN) :: ua, va
19216  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: smag_c
19217  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: smag_c_ad
19218  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
19219  REAL :: ut(bd%isd:bd%ied+1, bd%jsd:bd%jed)
19220  REAL :: ut_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed)
19221  REAL :: vt(bd%isd:bd%ied, bd%jsd:bd%jed+1)
19222  REAL :: vt_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1)
19223  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
19224  REAL :: wk_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
19225  REAL :: sh(bd%isd:bd%ied, bd%jsd:bd%jed)
19226  REAL :: sh_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
19227  INTEGER :: i, j
19228  INTEGER :: is2, ie1
19229  REAL, DIMENSION(:, :), POINTER :: dxc, dyc, dx, dy, rarea, rarea_c
19230  INTEGER :: is, ie, js, je
19231  INTEGER :: isd, ied, jsd, jed
19232  INTRINSIC max
19233  INTRINSIC min
19234  INTRINSIC sqrt
19235  REAL :: temp_ad
19236  REAL :: temp_ad0
19237  REAL :: temp_ad1
19238  !TYPE(C_PTR) :: cptr
19239  !INTEGER :: unknown_shape_in_smag_corner
19240 
19241  ut = 0.0
19242  vt = 0.0
19243  wk = 0.0
19244  sh = 0.0
19245  is2 = 0
19246  ie1 = 0
19247  is = 0
19248  ie = 0
19249  js = 0
19250  je = 0
19251  isd = 0
19252  ied = 0
19253  jsd = 0
19254  jed = 0
19255 
19256  is = bd%is
19257  ie = bd%ie
19258  js = bd%js
19259  je = bd%je
19260  isd = bd%isd
19261  ied = bd%ied
19262  jsd = bd%jsd
19263  jed = bd%jed
19264  dxc => gridstruct%dxc
19265  dyc => gridstruct%dyc
19266  dx => gridstruct%dx
19267  dy => gridstruct%dy
19268  rarea => gridstruct%rarea
19269  rarea_c => gridstruct%rarea_c
19270  CALL popinteger(js)
19271  !CALL POPPOINTER8(cptr)
19272  dxc => gridstruct%dxc ! (/unknown_shape_in_smag_corner/))
19273  !CALL POPPOINTER8(cptr)
19274  dx => gridstruct%dx ! (/unknown_shape_in_smag_corner/))
19275  !CALL POPPOINTER8(cptr)
19276  dy => gridstruct%dy ! (/unknown_shape_in_smag_corner/))
19277  !CALL POPPOINTER8(cptr)
19278  rarea_c => gridstruct%rarea_c ! (/unknown_shape_in_smag_corner/))
19279  !CALL POPPOINTER8(cptr)
19280  dyc => gridstruct%dyc ! (/unknown_shape_in_smag_corner/))
19281  CALL popinteger(ie)
19282  CALL poprealarray(sh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
19283  CALL popinteger(is)
19284  CALL popinteger(je)
19285  CALL popinteger(jed)
19286  sh_ad = 0.0
19287  DO j=je+1,js,-1
19288  DO i=ie+1,is,-1
19289  CALL poprealarray(smag_c(i, j))
19290  IF (sh(i, j)**2 + smag_c(i, j)**2 .EQ. 0.0) THEN
19291  temp_ad1 = 0.0
19292  ELSE
19293  temp_ad1 = dt*smag_c_ad(i, j)/(2.0*sqrt(sh(i, j)**2+smag_c(i, &
19294 & j)**2))
19295  END IF
19296  sh_ad(i, j) = sh_ad(i, j) + 2*sh(i, j)*temp_ad1
19297  smag_c_ad(i, j) = 2*smag_c(i, j)*temp_ad1
19298  END DO
19299  END DO
19300  wk_ad = 0.0
19301  CALL a2b_ord4_bwd(wk, wk_ad, sh, sh_ad, gridstruct, npx, npy, is&
19302 & , ie, js, je, ng, .false.)
19303  rarea => gridstruct%rarea
19304  jsd = bd%jsd
19305  ied = bd%ied
19306  isd = bd%isd
19307  ut_ad = 0.0
19308  vt_ad = 0.0
19309  DO j=jed,jsd,-1
19310  DO i=ied,isd,-1
19311  temp_ad0 = rarea(i, j)*wk_ad(i, j)
19312  vt_ad(i, j) = vt_ad(i, j) + temp_ad0
19313  vt_ad(i, j+1) = vt_ad(i, j+1) - temp_ad0
19314  ut_ad(i, j) = ut_ad(i, j) + temp_ad0
19315  ut_ad(i+1, j) = ut_ad(i+1, j) - temp_ad0
19316  wk_ad(i, j) = 0.0
19317  END DO
19318  END DO
19319  DO j=jed,jsd,-1
19320  DO i=ied+1,isd,-1
19321  v_ad(i, j) = v_ad(i, j) + dy(i, j)*ut_ad(i, j)
19322  ut_ad(i, j) = 0.0
19323  END DO
19324  END DO
19325  DO j=jed+1,jsd,-1
19326  DO i=ied,isd,-1
19327  u_ad(i, j) = u_ad(i, j) + dx(i, j)*vt_ad(i, j)
19328  vt_ad(i, j) = 0.0
19329  END DO
19330  END DO
19331  DO j=je+1,js,-1
19332  DO i=ie+1,is,-1
19333  temp_ad = rarea_c(i, j)*smag_c_ad(i, j)
19334  vt_ad(i, j-1) = vt_ad(i, j-1) + temp_ad
19335  vt_ad(i, j) = vt_ad(i, j) - temp_ad
19336  ut_ad(i, j) = ut_ad(i, j) + temp_ad
19337  ut_ad(i-1, j) = ut_ad(i-1, j) - temp_ad
19338  smag_c_ad(i, j) = 0.0
19339  END DO
19340  END DO
19341  DO j=je+1,js-1,-1
19342  DO i=ie+1,is,-1
19343  v_ad(i, j) = v_ad(i, j) + dxc(i, j)*vt_ad(i, j)
19344  vt_ad(i, j) = 0.0
19345  END DO
19346  END DO
19347  DO j=je+1,js,-1
19348  DO i=ie+1,is-1,-1
19349  u_ad(i, j) = u_ad(i, j) + dyc(i, j)*ut_ad(i, j)
19350  ut_ad(i, j) = 0.0
19351  END DO
19352  END DO
19353  END SUBROUTINE smag_corner_bwd
19354  end module sw_core_adm_mod
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
sw_core_adm_mod::s14
real, parameter s14
Definition: sw_core_adm.F90:46
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
sw_core_adm_mod::xtp_u_fwd
subroutine xtp_u_fwd(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:15662
sw_core_adm_mod::p2
real, parameter p2
Definition: sw_core_adm.F90:57
sw_core_adm_mod::t13
real, parameter t13
Definition: sw_core_adm.F90:45
sw_core_adm_mod::smag_corner
subroutine smag_corner(dt, u, v, ua, va, smag_c, bd, npx, npy, gridstruct, ng)
Definition: sw_core_adm.F90:7315
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
tp_core_adm_mod
Definition: tp_core_adm.F90:20
sw_core_adm_mod::smag_corner_fwd
subroutine smag_corner_fwd(dt, u, v, ua, va, smag_c, bd, npx, npy, gridstruct, ng)
Definition: sw_core_adm.F90:19070
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
sw_core_adm_mod::fill_4corners_fwd
subroutine, public fill_4corners_fwd(q, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:15364
sw_core_adm_mod::a2
real, parameter a2
Definition: sw_core_adm.F90:62
popcontrol2b
subroutine popcontrol2b(cc)
Definition: adBuffer.f:146
a2b_edge_adm_mod::a2b_ord4
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:898
sw_core_adm_mod::b3
real, parameter b3
Definition: sw_core_adm.F90:76
sw_core_adm_mod::p1
real, parameter p1
Definition: sw_core_adm.F90:56
sw_core_adm_mod::t12
real, parameter t12
Definition: sw_core_adm.F90:45
a2b_edge_adm_mod
Definition: a2b_edge_adm.F90:20
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
qg_constants::f0
real(kind=kind_real), parameter f0
Coriolis parameter at southern boundary.
Definition: qg_constants.f90:26
sw_core_adm_mod::xtp_u_bwd
subroutine xtp_u_bwd(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, u_ad, v, flux, flux_ad, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:15915
sw_core_adm_mod::ytp_v_fwd
subroutine ytp_v_fwd(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:16231
sw_core_adm_mod::xtp_u
subroutine xtp_u(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:9406
sw_core_adm_mod::c_sw_fwd
subroutine, public c_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:115
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
sw_core_adm_mod::s11
real, parameter s11
Definition: sw_core_adm.F90:46
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
sw_core_adm_mod::d2a2c_vect_fwd
subroutine, public d2a2c_vect_fwd(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd, npx, npy, nested, grid_type)
Definition: sw_core_adm.F90:13052
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
tp_core_adm_mod::copy_corners
subroutine, public copy_corners(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:537
sw_core_adm_mod::ytp_v_adm
subroutine ytp_v_adm(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, v, v_ad, flux, flux_ad, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:10159
sw_core_adm_mod::compute_divergence_damping_adm
subroutine compute_divergence_damping_adm(nord, d2_bg, d4_bg, dddmp, dt, vort, vort_ad, ptc, ptc_ad, delpc, delpc_ad, ke, ke_ad, u, u_ad, v, v_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, wk, wk_ad, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:16828
sw_core_adm_mod::b5
real, parameter b5
Definition: sw_core_adm.F90:78
sw_core_adm_mod::edge_interpolate4_fwd
real function edge_interpolate4_fwd(ua, dxa)
Definition: sw_core_adm.F90:14770
sw_core_adm_mod::c1
real, parameter c1
Definition: sw_core_adm.F90:65
sw_core_adm_mod::t15
real, parameter t15
Definition: sw_core_adm.F90:45
sw_core_adm_mod::smag_corner_bwd
subroutine smag_corner_bwd(dt, u, u_ad, v, v_ad, ua, va, smag_c, smag_c_ad, bd, npx, npy, gridstruct, ng)
Definition: sw_core_adm.F90:19205
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
sw_core_adm_mod::c_sw
subroutine, public c_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:1358
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
sw_core_adm_mod::fill2_4corners_fwd
subroutine fill2_4corners_fwd(q1, q2, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:14966
sw_core_adm_mod::divergence_corner_fwd
subroutine, public divergence_corner_fwd(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:6363
sw_core_adm_mod::near_zero
real, parameter near_zero
Definition: sw_core_adm.F90:47
pushcontrol2b
subroutine pushcontrol2b(cc)
Definition: adBuffer.f:140
sw_core_adm_mod::c_sw_bwd
subroutine, public c_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, wc, wc_ad, ut, ut_ad, vt, vt_ad, divg_d, divg_d_ad, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:708
sw_core_adm_mod
Definition: sw_core_adm.F90:20
sw_core_adm_mod::s15
real, parameter s15
Definition: sw_core_adm.F90:46
sw_core_adm_mod::t11
real, parameter t11
Definition: sw_core_adm.F90:45
sw_core_adm_mod::xtp_u_adm
subroutine xtp_u_adm(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, u_ad, v, flux, flux_ad, iord, dx, rdx, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:7431
a2b_edge_adm_mod::a2b_ord4_bwd
subroutine, public a2b_ord4_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:2153
sw_core_adm_mod::compute_divergence_damping_fwd
subroutine compute_divergence_damping_fwd(nord, d2_bg, d4_bg, dddmp, dt, vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:18051
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
sw_core_adm_mod::compute_divergence_damping_bwd
subroutine compute_divergence_damping_bwd(nord, d2_bg, d4_bg, dddmp, dt, vort, vort_ad, ptc, ptc_ad, delpc, delpc_ad, ke, ke_ad, u, u_ad, v, v_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, wk, wk_ad, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:18555
sw_core_adm_mod::c3
real, parameter c3
Definition: sw_core_adm.F90:67
sw_core_adm_mod::ytp_v
subroutine ytp_v(is, ie, js, je, isd, ied, jsd, jed, c, u, v, flux, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:12201
sw_core_adm_mod::smag_corner_adm
subroutine smag_corner_adm(dt, u, u_ad, v, v_ad, ua, va, smag_c, smag_c_ad, bd, npx, npy, gridstruct, ng)
Definition: sw_core_adm.F90:17570
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
sw_core_adm_mod::d2a2c_vect
subroutine, public d2a2c_vect(u, v, ua, va, uc, vc, ut, vt, dord4, gridstruct, bd, npx, npy, nested, grid_type)
Definition: sw_core_adm.F90:14343
fv_mp_nlm_mod::ng
integer, parameter, public ng
Definition: fv_mp_nlm_mod.F90:2465
sw_core_adm_mod::del6_vt_flux
subroutine, public del6_vt_flux(nord, npx, npy, damp, q, d2, fx2, fy2, gridstruct, bd)
Definition: sw_core_adm.F90:6260
tapenade_iter
Definition: tapenade_iter.F90:1
sw_core_adm_mod::divergence_corner_nest_fwd
subroutine, public divergence_corner_nest_fwd(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:6901
sw_core_adm_mod::b1
real, parameter b1
Definition: sw_core_adm.F90:74
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
sw_core_adm_mod::fill_4corners_bwd
subroutine, public fill_4corners_bwd(q, q_ad, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:15485
sw_core_adm_mod::divergence_corner_bwd
subroutine, public divergence_corner_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:6565
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
fv_arrays_tlmadm_mod::fpp
type(fpp_type) fpp
Definition: fv_arrays_tlmadm.F90:35
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
sw_core_adm_mod::ytp_v_bwd
subroutine ytp_v_bwd(is, ie, js, je, isd, ied, jsd, jed, c, c_ad, u, v, v_ad, flux, flux_ad, jord, dy, rdy, npx, npy, grid_type, nested)
Definition: sw_core_adm.F90:16501
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
fv_mp_adm_mod
Definition: fv_mp_adm.F90:1
sw_core_adm_mod::divergence_corner_nest
subroutine, public divergence_corner_nest(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:7216
test_cases_nlm_mod
Definition: test_cases_nlm.F90:21
sw_core_adm_mod::edge_interpolate4_bwd
subroutine edge_interpolate4_bwd(ua, ua_ad, dxa, edge_interpolate4_ad)
Definition: sw_core_adm.F90:14802
popcontrol3b
subroutine popcontrol3b(cc)
Definition: adBuffer.f:175
sw_core_adm_mod::t14
real, parameter t14
Definition: sw_core_adm.F90:45
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
sw_core_adm_mod::d2a2c_vect_bwd
subroutine, public d2a2c_vect_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, va_ad, uc, uc_ad, vc, vc_ad, ut, ut_ad, vt, vt_ad, dord4, gridstruct, bd, npx, npy, nested, grid_type)
Definition: sw_core_adm.F90:13699
sw_core_adm_mod::d_sw_bwd
subroutine, public d_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, xflux, xflux_ad, yflux, yflux_ad, cx, cx_ad, cy, cy_ad, crx_adv, crx_adv_ad, cry_adv, cry_adv_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, q_con, z_rat, z_rat_ad, kgb, heat_source, heat_source_ad, dpx, dpx_ad, zvir, sphum, nq, q, q_ad, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:3281
fv_mp_adm_mod::fill_corners_adm
Definition: fv_mp_adm.F90:61
sw_core_adm_mod::c2
real, parameter c2
Definition: sw_core_adm.F90:66
sw_core_adm_mod::b4
real, parameter b4
Definition: sw_core_adm.F90:77
max
#define max(a, b)
Definition: mosaic_util.h:33
a2b_edge_adm_mod::a2b_ord4_adm
subroutine, public a2b_ord4_adm(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:74
tp_core_adm_mod::pert_ppm_adm
subroutine, public pert_ppm_adm(im, a0, al, al_ad, ar, ar_ad, iv)
Definition: tp_core_adm.F90:6235
sw_core_adm_mod::d_sw
subroutine, public d_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:4985
sw_core_adm_mod::d_sw_fwd
subroutine, public d_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:1782
sw_core_adm_mod::fill3_4corners
subroutine fill3_4corners(q1, q2, q3, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:14830
tp_core_adm_mod::copy_corners_adm
subroutine, public copy_corners_adm(q, q_ad, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:6737
sw_core_adm_mod::edge_interpolate4
real function edge_interpolate4(ua, dxa)
Definition: sw_core_adm.F90:14819
test_cases_nlm_mod::test_case
integer, public test_case
Definition: test_cases_nlm.F90:96
sw_core_adm_mod::s13
real, parameter s13
Definition: sw_core_adm.F90:46
sw_core_adm_mod::divergence_corner
subroutine, public divergence_corner(u, v, ua, va, divg_d, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:6764
sw_core_adm_mod::a1
real, parameter a1
Definition: sw_core_adm.F90:61
pushcontrol3b
subroutine pushcontrol3b(cc)
Definition: adBuffer.f:168
sw_core_adm_mod::divergence_corner_nest_bwd
subroutine, public divergence_corner_nest_bwd(u, u_ad, v, v_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:7042
min
#define min(a, b)
Definition: mosaic_util.h:32
sw_core_adm_mod::r3
real, parameter r3
Definition: sw_core_adm.F90:44
sw_core_adm_mod::compute_divergence_damping
subroutine compute_divergence_damping(nord, d2_bg, d4_bg, dddmp, dt, vort, ptc, delpc, ke, u, v, uc, vc, ua, va, divg_d, wk, gridstruct, flagstruct, bd)
Definition: sw_core_adm.F90:17724
sw_core_adm_mod::big_number
real, parameter big_number
Definition: sw_core_adm.F90:51
fv_arrays_nlm_mod::fvprc
integer, parameter fvprc
Definition: fv_arrays_nlm.F90:38
sw_core_adm_mod::fill_4corners
subroutine, public fill_4corners(q, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:15585
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
unstructured_grid_mod::grid_type
Derived type containing the data.
Definition: unstructured_grid_mod.F90:23
qg_constants::u2
real(kind=kind_real), parameter u2
Definition: qg_constants.f90:36
sw_core_adm_mod::fill2_4corners
subroutine fill2_4corners(q1, q2, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:15270
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484
sw_core_adm_mod::b2
real, parameter b2
Definition: sw_core_adm.F90:75
sw_core_adm_mod::del6_vt_flux_adm
subroutine, public del6_vt_flux_adm(nord, npx, npy, damp, q, q_ad, d2, d2_ad, fx2, fx2_ad, fy2, fy2_ad, gridstruct, bd)
Definition: sw_core_adm.F90:6083
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
tp_core_adm_mod::pert_ppm
subroutine, public pert_ppm(im, a0, al, ar, iv)
Definition: tp_core_adm.F90:6339
a2b_edge_adm_mod::a2b_ord4_fwd
subroutine, public a2b_ord4_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:1413
sw_core_adm_mod::fill2_4corners_bwd
subroutine fill2_4corners_bwd(q1, q1_ad, q2, q2_ad, dir, bd, npx, npy, sw_corner, se_corner, ne_corner, nw_corner)
Definition: sw_core_adm.F90:15120