FV3 Bundle
tp_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 tp_core_adm_mod
21 !BOP
22 !
23 ! !MODULE: tp_core --- A collection of routines to support FV transport
24 !
25  use fv_mp_nlm_mod, only: ng
26  use fv_grid_utils_nlm_mod, only: big_number
27  use fv_arrays_nlm_mod, only: fv_grid_type, fv_grid_bounds_type, r_grid
28 
29  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
30  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
31 
32  implicit none
33 
34  private
35  public fv_tp_2d, pert_ppm, copy_corners, &
36  fv_tp_2d_adm, copy_corners_adm, &
37  fv_tp_2d_fwd, fv_tp_2d_bwd, pert_ppm_adm
38 
39  real, parameter:: ppm_fac = 1.5 ! nonlinear scheme limiter: between 1 and 2
40  real, parameter:: r3 = 1./3.
41  real, parameter:: near_zero = 1.e-25
42  real, parameter:: ppm_limiter = 2.0
43 
44 #ifdef WAVE_FORM
45 ! Suresh & Huynh scheme 2.2 (purtabation form)
46 ! The wave-form is more diffusive than scheme 2.1
47  real, parameter:: b1 = 0.0375
48  real, parameter:: b2 = -7./30.
49  real, parameter:: b3 = -23./120.
50  real, parameter:: b4 = 13./30.
51  real, parameter:: b5 = -11./240.
52 #else
53 ! scheme 2.1: perturbation form
54  real, parameter:: b1 = 1./30.
55  real, parameter:: b2 = -13./60.
56  real, parameter:: b3 = -13./60.
57  real, parameter:: b4 = 0.45
58  real, parameter:: b5 = -0.05
59 #endif
60  real, parameter:: t11 = 27./28., t12 = -13./28., t13=3./7.
61  real, parameter:: s11 = 11./14., s14 = 4./7., s15=3./14.
62 !----------------------------------------------------
63 ! volume-conserving cubic with 2nd drv=0 at end point:
64 !----------------------------------------------------
65 ! Non-monotonic
66  real, parameter:: c1 = -2./14.
67  real, parameter:: c2 = 11./14.
68  real, parameter:: c3 = 5./14.
69 !----------------------
70 ! PPM volume mean form:
71 !----------------------
72  real, parameter:: p1 = 7./12. ! 0.58333333
73  real, parameter:: p2 = -1./12.
74 ! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1))
75 ! integer:: is, ie, js, je, isd, ied, jsd, jed
76 
77 !
78 !EOP
79 !-----------------------------------------------------------------------
80 
81 CONTAINS
82 ! Differentiation of fv_tp_2d in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_c
83 !ore_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_
84 !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_mo
85 !d.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamic
86 !s_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_m
87 !od.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
88 !.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.scalar
89 !_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.steep
90 !z 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_se
91 !tup 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.comp
92 !ute_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
93 ! 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_solver n
94 !h_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 sw_
95 !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_core_
96 !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.co
97 !mpute_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_
98 !fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle
99 !_dist sw_core_mod.edge_interpolate4)):
100 ! gradient of useful results: xfx q mass mfx mfy ra_x ra_y
101 ! yfx fx fy crx cry
102 ! with respect to varying inputs: xfx q mass mfx mfy ra_x ra_y
103 ! yfx fx fy crx cry
104 ! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1))
105 ! integer:: is, ie, js, je, isd, ied, jsd, jed
106 !
107 !EOP
108 !-----------------------------------------------------------------------
109  SUBROUTINE fv_tp_2d_adm(q, q_ad, crx, crx_ad, cry, cry_ad, npx, npy, &
110 & hord, fx, fx_ad, fy, fy_ad, xfx, xfx_ad, yfx, yfx_ad, gridstruct, bd&
111 & , ra_x, ra_x_ad, ra_y, ra_y_ad, mfx, mfx_ad, mfy, mfy_ad, mass, &
112 & mass_ad, nord, damp_c)
113  IMPLICIT NONE
114  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
115  INTEGER, INTENT(IN) :: npx, npy
116  INTEGER, INTENT(IN) :: hord
117 !
118  REAL, INTENT(IN) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed)
119  REAL :: crx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
120 !
121  REAL, INTENT(IN) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed)
122  REAL :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
123 !
124  REAL, INTENT(IN) :: cry(bd%isd:bd%ied, bd%js:bd%je+1)
125  REAL :: cry_ad(bd%isd:bd%ied, bd%js:bd%je+1)
126 !
127  REAL, INTENT(IN) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1)
128  REAL :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1)
129  REAL, INTENT(IN) :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
130  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
131  REAL, INTENT(IN) :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
132  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
133 ! transported scalar
134  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
135  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
136 ! Flux in x ( E )
137  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
138  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
139 ! Flux in y ( N )
140  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
141  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
142  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
143 ! optional Arguments:
144 ! Mass Flux X-Dir
145  REAL, OPTIONAL, INTENT(IN) :: mfx(bd%is:bd%ie+1, bd%js:bd%je)
146  REAL, OPTIONAL :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je)
147 ! Mass Flux Y-Dir
148  REAL, OPTIONAL, INTENT(IN) :: mfy(bd%is:bd%ie, bd%js:bd%je+1)
149  REAL, OPTIONAL :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1)
150  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
151  REAL, OPTIONAL :: mass_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
152  REAL, OPTIONAL, INTENT(IN) :: damp_c
153  INTEGER, OPTIONAL, INTENT(IN) :: nord
154 ! Local:
155  INTEGER :: ord_ou, ord_in
156  REAL :: q_i(bd%isd:bd%ied, bd%js:bd%je)
157  REAL :: q_i_ad(bd%isd:bd%ied, bd%js:bd%je)
158  REAL :: q_j(bd%is:bd%ie, bd%jsd:bd%jed)
159  REAL :: q_j_ad(bd%is:bd%ie, bd%jsd:bd%jed)
160  REAL :: fx2(bd%is:bd%ie+1, bd%jsd:bd%jed)
161  REAL :: fx2_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
162  REAL :: fy2(bd%isd:bd%ied, bd%js:bd%je+1)
163  REAL :: fy2_ad(bd%isd:bd%ied, bd%js:bd%je+1)
164  REAL :: fyy(bd%isd:bd%ied, bd%js:bd%je+1)
165  REAL :: fyy_ad(bd%isd:bd%ied, bd%js:bd%je+1)
166  REAL :: fx1(bd%is:bd%ie+1, bd%jsd:bd%jed)
167  REAL :: fx1_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
168  REAL :: damp
169  INTEGER :: i, j
170  INTEGER :: is, ie, js, je, isd, ied, jsd, jed
171  INTRINSIC PRESENT
172  REAL :: temp_ad
173  REAL :: temp_ad0
174  REAL :: temp_ad1
175  REAL :: temp_ad2
176  REAL :: temp_ad3
177  REAL :: temp_ad4
178  INTEGER :: branch
179  is = bd%is
180  ie = bd%ie
181  js = bd%js
182  je = bd%je
183  isd = bd%isd
184  ied = bd%ied
185  jsd = bd%jsd
186  jed = bd%jed
187  IF (hord .EQ. 10) THEN
188  ord_in = 8
189  ELSE
190  ord_in = hord
191  END IF
192  ord_ou = hord
193  IF (.NOT.gridstruct%nested) THEN
194  CALL pushrealarray_adm(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
195  CALL copy_corners(q, npx, npy, 2, gridstruct%nested, bd, &
196 & gridstruct%sw_corner, gridstruct%se_corner, gridstruct&
197 & %nw_corner, gridstruct%ne_corner)
198  CALL pushcontrol1b(0)
199  ELSE
200  CALL pushcontrol1b(1)
201  END IF
202  CALL yppm(fy2, q, cry, ord_in, isd, ied, isd, ied, js, je, jsd, jed&
203 & , npx, npy, gridstruct%dya, gridstruct%nested, gridstruct%&
204 & grid_type)
205  DO j=js,je+1
206  DO i=isd,ied
207  fyy(i, j) = yfx(i, j)*fy2(i, j)
208  END DO
209  END DO
210  DO j=js,je
211  DO i=isd,ied
212  q_i(i, j) = (q(i, j)*gridstruct%area(i, j)+fyy(i, j)-fyy(i, j+1)&
213 & )/ra_y(i, j)
214  END DO
215  END DO
216  CALL pushrealarray_adm(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
217  CALL xppm(fx, q_i, crx(is:ie+1, js:je), ord_ou, is, ie, isd, ied, js&
218 & , je, jsd, jed, npx, npy, gridstruct%dxa, gridstruct%nested, &
219 & gridstruct%grid_type)
220  IF (.NOT.gridstruct%nested) THEN
221  CALL pushrealarray_adm(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
222  CALL copy_corners(q, npx, npy, 1, gridstruct%nested, bd, &
223 & gridstruct%sw_corner, gridstruct%se_corner, gridstruct&
224 & %nw_corner, gridstruct%ne_corner)
225  CALL pushcontrol1b(0)
226  ELSE
227  CALL pushcontrol1b(1)
228  END IF
229  CALL xppm(fx2, q, crx, ord_in, is, ie, isd, ied, jsd, jed, jsd, jed&
230 & , npx, npy, gridstruct%dxa, gridstruct%nested, gridstruct%&
231 & grid_type)
232  DO j=jsd,jed
233  DO i=is,ie+1
234  fx1(i, j) = xfx(i, j)*fx2(i, j)
235  END DO
236  END DO
237  DO j=jsd,jed
238  DO i=is,ie
239  q_j(i, j) = (q(i, j)*gridstruct%area(i, j)+fx1(i, j)-fx1(i+1, j)&
240 & )/ra_x(i, j)
241  END DO
242  END DO
243  CALL pushrealarray_adm(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
244  CALL yppm(fy, q_j, cry, ord_ou, is, ie, isd, ied, js, je, jsd, jed, &
245 & npx, npy, gridstruct%dya, gridstruct%nested, gridstruct%&
246 & grid_type)
247 !----------------
248 ! Flux averaging:
249 !----------------
250  IF (PRESENT(mfx) .AND. PRESENT(mfy)) THEN
251  IF (PRESENT(nord) .AND. PRESENT(damp_c) .AND. PRESENT(mass)) THEN
252  IF (damp_c .GT. 1.e-4) THEN
253  damp = (damp_c*gridstruct%da_min)**(nord+1)
254  CALL deln_flux_adm(nord, is, ie, js, je, npx, npy, damp, q, &
255 & q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd, mass&
256 & , mass_ad)
257  END IF
258  END IF
259  fy2_ad = 0.0
260  DO j=js,je+1
261  DO i=ie,is,-1
262  temp_ad4 = 0.5*mfy(i, j)*fy_ad(i, j)
263  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad4
264  mfy_ad(i, j) = mfy_ad(i, j) + 0.5*(fy(i, j)+fy2(i, j))*fy_ad(i&
265 & , j)
266  fy_ad(i, j) = temp_ad4
267  END DO
268  END DO
269  fx2_ad = 0.0
270  DO j=js,je
271  DO i=ie+1,is,-1
272  temp_ad3 = 0.5*mfx(i, j)*fx_ad(i, j)
273  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad3
274  mfx_ad(i, j) = mfx_ad(i, j) + 0.5*(fx(i, j)+fx2(i, j))*fx_ad(i&
275 & , j)
276  fx_ad(i, j) = temp_ad3
277  END DO
278  END DO
279  ELSE
280  IF (PRESENT(nord) .AND. PRESENT(damp_c)) THEN
281  IF (damp_c .GT. 1.e-4) THEN
282  damp = (damp_c*gridstruct%da_min)**(nord+1)
283  CALL deln_flux_adm(nord, is, ie, js, je, npx, npy, damp, q, &
284 & q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd)
285  END IF
286  END IF
287  fy2_ad = 0.0
288  DO j=je+1,js,-1
289  DO i=ie,is,-1
290  temp_ad2 = 0.5*yfx(i, j)*fy_ad(i, j)
291  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad2
292  yfx_ad(i, j) = yfx_ad(i, j) + 0.5*(fy(i, j)+fy2(i, j))*fy_ad(i&
293 & , j)
294  fy_ad(i, j) = temp_ad2
295  END DO
296  END DO
297  fx2_ad = 0.0
298  DO j=je,js,-1
299  DO i=ie+1,is,-1
300  temp_ad1 = 0.5*xfx(i, j)*fx_ad(i, j)
301  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad1
302  xfx_ad(i, j) = xfx_ad(i, j) + 0.5*(fx(i, j)+fx2(i, j))*fx_ad(i&
303 & , j)
304  fx_ad(i, j) = temp_ad1
305  END DO
306  END DO
307  END IF
308  CALL poprealarray_adm(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
309  q_j_ad = 0.0
310  CALL yppm_adm(fy, fy_ad, q_j, q_j_ad, cry, cry_ad, ord_ou, is, ie, &
311 & isd, ied, js, je, jsd, jed, npx, npy, gridstruct%dya, &
312 & gridstruct%nested, gridstruct%grid_type)
313  fx1_ad = 0.0
314  DO j=jed,jsd,-1
315  DO i=ie,is,-1
316  temp_ad0 = q_j_ad(i, j)/ra_x(i, j)
317  q_ad(i, j) = q_ad(i, j) + gridstruct%area(i, j)*temp_ad0
318  fx1_ad(i, j) = fx1_ad(i, j) + temp_ad0
319  fx1_ad(i+1, j) = fx1_ad(i+1, j) - temp_ad0
320  ra_x_ad(i, j) = ra_x_ad(i, j) - (gridstruct%area(i, j)*q(i, j)+&
321 & fx1(i, j)-fx1(i+1, j))*temp_ad0/ra_x(i, j)
322  q_j_ad(i, j) = 0.0
323  END DO
324  END DO
325  DO j=jsd,jed
326  DO i=ie+1,is,-1
327  xfx_ad(i, j) = xfx_ad(i, j) + fx2(i, j)*fx1_ad(i, j)
328  fx2_ad(i, j) = fx2_ad(i, j) + xfx(i, j)*fx1_ad(i, j)
329  fx1_ad(i, j) = 0.0
330  END DO
331  END DO
332  CALL xppm_adm(fx2, fx2_ad, q, q_ad, crx, crx_ad, ord_in, is, ie, isd&
333 & , ied, jsd, jed, jsd, jed, npx, npy, gridstruct%dxa, &
334 & gridstruct%nested, gridstruct%grid_type)
335  CALL popcontrol1b(branch)
336  IF (branch .EQ. 0) THEN
337  CALL poprealarray_adm(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
338  CALL copy_corners_adm(q, q_ad, npx, npy, 1, gridstruct%nested, bd&
339 & , gridstruct%sw_corner, gridstruct%se_corner, &
340 & gridstruct%nw_corner, gridstruct%ne_corner)
341  END IF
342  CALL poprealarray_adm(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
343  q_i_ad = 0.0
344  CALL xppm_adm(fx, fx_ad, q_i, q_i_ad, crx(is:ie+1, js:je), crx_ad(is&
345 & :ie+1, js:je), ord_ou, is, ie, isd, ied, js, je, jsd, jed, &
346 & npx, npy, gridstruct%dxa, gridstruct%nested, gridstruct%&
347 & grid_type)
348  fyy_ad = 0.0
349  DO j=je,js,-1
350  DO i=ied,isd,-1
351  temp_ad = q_i_ad(i, j)/ra_y(i, j)
352  q_ad(i, j) = q_ad(i, j) + gridstruct%area(i, j)*temp_ad
353  fyy_ad(i, j) = fyy_ad(i, j) + temp_ad
354  fyy_ad(i, j+1) = fyy_ad(i, j+1) - temp_ad
355  ra_y_ad(i, j) = ra_y_ad(i, j) - (gridstruct%area(i, j)*q(i, j)+&
356 & fyy(i, j)-fyy(i, j+1))*temp_ad/ra_y(i, j)
357  q_i_ad(i, j) = 0.0
358  END DO
359  END DO
360  DO j=je+1,js,-1
361  DO i=ied,isd,-1
362  yfx_ad(i, j) = yfx_ad(i, j) + fy2(i, j)*fyy_ad(i, j)
363  fy2_ad(i, j) = fy2_ad(i, j) + yfx(i, j)*fyy_ad(i, j)
364  fyy_ad(i, j) = 0.0
365  END DO
366  END DO
367  CALL yppm_adm(fy2, fy2_ad, q, q_ad, cry, cry_ad, ord_in, isd, ied, &
368 & isd, ied, js, je, jsd, jed, npx, npy, gridstruct%dya, &
369 & gridstruct%nested, gridstruct%grid_type)
370  CALL popcontrol1b(branch)
371  IF (branch .EQ. 0) THEN
372  CALL poprealarray_adm(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
373  CALL copy_corners_adm(q, q_ad, npx, npy, 2, gridstruct%nested, bd&
374 & , gridstruct%sw_corner, gridstruct%se_corner, &
375 & gridstruct%nw_corner, gridstruct%ne_corner)
376  END IF
377  END SUBROUTINE fv_tp_2d_adm
378 ! q(i+0.5) = p1*(q(i-1)+q(i)) + p2*(q(i-2)+q(i+1))
379 ! integer:: is, ie, js, je, isd, ied, jsd, jed
380 !
381 !EOP
382 !-----------------------------------------------------------------------
383  SUBROUTINE fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, &
384 & gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
385  IMPLICIT NONE
386  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
387  INTEGER, INTENT(IN) :: npx, npy
388  INTEGER, INTENT(IN) :: hord
389 !
390  REAL, INTENT(IN) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed)
391 !
392  REAL, INTENT(IN) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed)
393 !
394  REAL, INTENT(IN) :: cry(bd%isd:bd%ied, bd%js:bd%je+1)
395 !
396  REAL, INTENT(IN) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1)
397  REAL, INTENT(IN) :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
398  REAL, INTENT(IN) :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
399 ! transported scalar
400  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
401 ! Flux in x ( E )
402  REAL, INTENT(OUT) :: fx(bd%is:bd%ie+1, bd%js:bd%je)
403 ! Flux in y ( N )
404  REAL, INTENT(OUT) :: fy(bd%is:bd%ie, bd%js:bd%je+1)
405  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
406 ! optional Arguments:
407 ! Mass Flux X-Dir
408  REAL, OPTIONAL, INTENT(IN) :: mfx(bd%is:bd%ie+1, bd%js:bd%je)
409 ! Mass Flux Y-Dir
410  REAL, OPTIONAL, INTENT(IN) :: mfy(bd%is:bd%ie, bd%js:bd%je+1)
411  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
412  REAL, OPTIONAL, INTENT(IN) :: damp_c
413  INTEGER, OPTIONAL, INTENT(IN) :: nord
414 ! Local:
415  INTEGER :: ord_ou, ord_in
416  REAL :: q_i(bd%isd:bd%ied, bd%js:bd%je)
417  REAL :: q_j(bd%is:bd%ie, bd%jsd:bd%jed)
418  REAL :: fx2(bd%is:bd%ie+1, bd%jsd:bd%jed)
419  REAL :: fy2(bd%isd:bd%ied, bd%js:bd%je+1)
420  REAL :: fyy(bd%isd:bd%ied, bd%js:bd%je+1)
421  REAL :: fx1(bd%is:bd%ie+1, bd%jsd:bd%jed)
422  REAL :: damp
423  INTEGER :: i, j
424  INTEGER :: is, ie, js, je, isd, ied, jsd, jed
425  INTRINSIC PRESENT
426  is = bd%is
427  ie = bd%ie
428  js = bd%js
429  je = bd%je
430  isd = bd%isd
431  ied = bd%ied
432  jsd = bd%jsd
433  jed = bd%jed
434  IF (hord .EQ. 10) THEN
435  ord_in = 8
436  ELSE
437  ord_in = hord
438  END IF
439  ord_ou = hord
440  IF (.NOT.gridstruct%nested) CALL copy_corners(q, npx, npy, 2, &
441 & gridstruct%nested, bd, &
442 & gridstruct%sw_corner, &
443 & gridstruct%se_corner, &
444 & gridstruct%nw_corner, &
445 & gridstruct%ne_corner)
446  CALL yppm(fy2, q, cry, ord_in, isd, ied, isd, ied, js, je, jsd, jed&
447 & , npx, npy, gridstruct%dya, gridstruct%nested, gridstruct%&
448 & grid_type)
449  DO j=js,je+1
450  DO i=isd,ied
451  fyy(i, j) = yfx(i, j)*fy2(i, j)
452  END DO
453  END DO
454  DO j=js,je
455  DO i=isd,ied
456  q_i(i, j) = (q(i, j)*gridstruct%area(i, j)+fyy(i, j)-fyy(i, j+1)&
457 & )/ra_y(i, j)
458  END DO
459  END DO
460  CALL xppm(fx, q_i, crx(is:ie+1, js:je), ord_ou, is, ie, isd, ied, js&
461 & , je, jsd, jed, npx, npy, gridstruct%dxa, gridstruct%nested, &
462 & gridstruct%grid_type)
463  IF (.NOT.gridstruct%nested) CALL copy_corners(q, npx, npy, 1, &
464 & gridstruct%nested, bd, &
465 & gridstruct%sw_corner, &
466 & gridstruct%se_corner, &
467 & gridstruct%nw_corner, &
468 & gridstruct%ne_corner)
469  CALL xppm(fx2, q, crx, ord_in, is, ie, isd, ied, jsd, jed, jsd, jed&
470 & , npx, npy, gridstruct%dxa, gridstruct%nested, gridstruct%&
471 & grid_type)
472  DO j=jsd,jed
473  DO i=is,ie+1
474  fx1(i, j) = xfx(i, j)*fx2(i, j)
475  END DO
476  END DO
477  DO j=jsd,jed
478  DO i=is,ie
479  q_j(i, j) = (q(i, j)*gridstruct%area(i, j)+fx1(i, j)-fx1(i+1, j)&
480 & )/ra_x(i, j)
481  END DO
482  END DO
483  CALL yppm(fy, q_j, cry, ord_ou, is, ie, isd, ied, js, je, jsd, jed, &
484 & npx, npy, gridstruct%dya, gridstruct%nested, gridstruct%&
485 & grid_type)
486 !----------------
487 ! Flux averaging:
488 !----------------
489  IF (PRESENT(mfx) .AND. PRESENT(mfy)) THEN
490 !---------------------------------
491 ! For transport of pt and tracers
492 !---------------------------------
493  DO j=js,je
494  DO i=is,ie+1
495  fx(i, j) = 0.5*(fx(i, j)+fx2(i, j))*mfx(i, j)
496  END DO
497  END DO
498  DO j=js,je+1
499  DO i=is,ie
500  fy(i, j) = 0.5*(fy(i, j)+fy2(i, j))*mfy(i, j)
501  END DO
502  END DO
503  IF (PRESENT(nord) .AND. PRESENT(damp_c) .AND. PRESENT(mass)) THEN
504  IF (damp_c .GT. 1.e-4) THEN
505  damp = (damp_c*gridstruct%da_min)**(nord+1)
506  CALL deln_flux(nord, is, ie, js, je, npx, npy, damp, q, fx, fy&
507 & , gridstruct, bd, mass)
508  END IF
509  END IF
510  ELSE
511 !---------------------------------
512 ! For transport of delp, vorticity
513 !---------------------------------
514  DO j=js,je
515  DO i=is,ie+1
516  fx(i, j) = 0.5*(fx(i, j)+fx2(i, j))*xfx(i, j)
517  END DO
518  END DO
519  DO j=js,je+1
520  DO i=is,ie
521  fy(i, j) = 0.5*(fy(i, j)+fy2(i, j))*yfx(i, j)
522  END DO
523  END DO
524  IF (PRESENT(nord) .AND. PRESENT(damp_c)) THEN
525  IF (damp_c .GT. 1.e-4) THEN
526  damp = (damp_c*gridstruct%da_min)**(nord+1)
527  CALL deln_flux(nord, is, ie, js, je, npx, npy, damp, q, fx, fy&
528 & , gridstruct, bd)
529  END IF
530  END IF
531  END IF
532  END SUBROUTINE fv_tp_2d
533 !Weird arguments are because this routine is called in a lot of
534 !places outside of tp_core, sometimes very deeply nested in the call tree.
535  SUBROUTINE copy_corners(q, npx, npy, dir, nested, bd, sw_corner, &
536 & se_corner, nw_corner, ne_corner)
537  IMPLICIT NONE
538  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
539  INTEGER, INTENT(IN) :: npx, npy, dir
540  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
541  LOGICAL, INTENT(IN) :: nested, sw_corner, se_corner, nw_corner, &
542 & ne_corner
543  INTEGER :: i, j
544  IF (nested) THEN
545  RETURN
546  ELSE IF (dir .EQ. 1) THEN
547 ! XDir:
548  IF (sw_corner) THEN
549  DO j=1-ng,0
550  DO i=1-ng,0
551  q(i, j) = q(j, 1-i)
552  END DO
553  END DO
554  END IF
555  IF (se_corner) THEN
556  DO j=1-ng,0
557  DO i=npx,npx+ng-1
558  q(i, j) = q(npy-j, i-npx+1)
559  END DO
560  END DO
561  END IF
562  IF (ne_corner) THEN
563  DO j=npy,npy+ng-1
564  DO i=npx,npx+ng-1
565  q(i, j) = q(j, 2*npx-1-i)
566  END DO
567  END DO
568  END IF
569  IF (nw_corner) THEN
570  DO j=npy,npy+ng-1
571  DO i=1-ng,0
572  q(i, j) = q(npy-j, i-1+npx)
573  END DO
574  END DO
575  END IF
576  ELSE IF (dir .EQ. 2) THEN
577 ! YDir:
578  IF (sw_corner) THEN
579  DO j=1-ng,0
580  DO i=1-ng,0
581  q(i, j) = q(1-j, i)
582  END DO
583  END DO
584  END IF
585  IF (se_corner) THEN
586  DO j=1-ng,0
587  DO i=npx,npx+ng-1
588  q(i, j) = q(npy+j-1, npx-i)
589  END DO
590  END DO
591  END IF
592  IF (ne_corner) THEN
593  DO j=npy,npy+ng-1
594  DO i=npx,npx+ng-1
595  q(i, j) = q(2*npy-1-j, i)
596  END DO
597  END DO
598  END IF
599  IF (nw_corner) THEN
600  DO j=npy,npy+ng-1
601  DO i=1-ng,0
602  q(i, j) = q(j+1-npx, npy-i)
603  END DO
604  END DO
605  END IF
606  END IF
607  END SUBROUTINE copy_corners
608 ! Differentiation of xppm in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_core_
609 !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_core
610 !_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.ge
611 !opk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamics_mo
612 !d.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_mod.c
613 !2l_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.map
614 !_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_pro
615 !file_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 fv
616 !_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
617 !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_
618 !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_
619 !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_ut
620 !ils_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_core
621 !_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.
622 !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.comput
623 !e_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 t
624 !p_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle_dis
625 !t sw_core_mod.edge_interpolate4)):
626 ! gradient of useful results: q flux c
627 ! with respect to varying inputs: q flux c
628  SUBROUTINE xppm_adm(flux, flux_ad, q, q_ad, c, c_ad, iord, is, ie, isd&
629 & , ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
630  IMPLICIT NONE
631  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed
632 ! compute domain
633  INTEGER, INTENT(IN) :: jfirst, jlast
634  INTEGER, INTENT(IN) :: iord
635  INTEGER, INTENT(IN) :: npx, npy
636  REAL, INTENT(IN) :: q(isd:ied, jfirst:jlast)
637  REAL :: q_ad(isd:ied, jfirst:jlast)
638 ! Courant N (like FLUX)
639  REAL, INTENT(IN) :: c(is:ie+1, jfirst:jlast)
640  REAL :: c_ad(is:ie+1, jfirst:jlast)
641  REAL, INTENT(IN) :: dxa(isd:ied, jsd:jed)
642  LOGICAL, INTENT(IN) :: nested
643  INTEGER, INTENT(IN) :: grid_type
644 ! !OUTPUT PARAMETERS:
645 ! Flux
646  REAL :: flux(is:ie+1, jfirst:jlast)
647  REAL :: flux_ad(is:ie+1, jfirst:jlast)
648 ! Local
649  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
650  REAL, DIMENSION(is-1:ie+1) :: bl_ad, br_ad, b0_ad
651  REAL :: q1(isd:ied)
652  REAL :: q1_ad(isd:ied)
653  REAL, DIMENSION(is:ie+1) :: fx0, fx1
654  REAL, DIMENSION(is:ie+1) :: fx0_ad, fx1_ad
655  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
656  REAL :: al(is-1:ie+2)
657  REAL :: al_ad(is-1:ie+2)
658  REAL :: dm(is-2:ie+2)
659  REAL :: dm_ad(is-2:ie+2)
660  REAL :: dq(is-3:ie+2)
661  REAL :: dq_ad(is-3:ie+2)
662  INTEGER :: i, j, ie3, is1, ie1
663  REAL :: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2
664  REAL :: xt_ad, qtmp_ad, pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
665  INTRINSIC max
666  INTRINSIC min
667  INTRINSIC abs
668  INTRINSIC sign
669  REAL :: min1
670  REAL :: min1_ad
671  REAL :: min2
672  REAL :: min2_ad
673  REAL :: abs0
674  REAL :: abs0_ad
675  REAL :: abs1
676  REAL :: min3
677  REAL :: min3_ad
678  REAL :: min4
679  REAL :: min4_ad
680  REAL :: min5
681  REAL :: min5_ad
682  REAL :: min6
683  REAL :: min6_ad
684  REAL :: min7
685  REAL :: min7_ad
686  REAL :: abs2
687  REAL :: abs3
688  REAL :: abs4
689  REAL :: max1
690  REAL :: max1_ad
691  REAL :: min8
692  REAL :: min8_ad
693  REAL :: abs5
694  REAL :: abs6
695  REAL :: abs7
696  INTEGER :: arg1
697  REAL :: temp_ad
698  REAL :: temp_ad0
699  REAL :: temp_ad1
700  REAL :: temp_ad2
701  REAL :: temp
702  REAL :: temp_ad3
703  REAL :: temp_ad4
704  REAL :: temp0
705  REAL :: temp_ad5
706  REAL :: temp_ad6
707  REAL :: temp_ad7
708  REAL :: temp_ad8
709  REAL :: temp_ad9
710  REAL :: temp_ad10
711  REAL :: temp_ad11
712  REAL :: temp_ad12
713  REAL :: x2_ad
714  REAL :: y1_ad
715  REAL :: x3_ad
716  REAL :: y2_ad
717  REAL :: temp_ad13
718  REAL :: temp_ad14
719  REAL :: temp_ad15
720  REAL :: temp_ad16
721  REAL :: x4_ad
722  REAL :: y3_ad
723  REAL :: z1_ad
724  REAL :: x5_ad
725  REAL :: y4_ad
726  REAL :: x6_ad
727  REAL :: y5_ad
728  REAL :: x7_ad
729  REAL :: y6_ad
730  REAL :: x8_ad
731  REAL :: y7_ad
732  REAL :: x9_ad
733  REAL :: y14_ad
734  REAL :: y8_ad
735  REAL :: x10_ad
736  REAL :: y15_ad
737  REAL :: y9_ad
738  REAL :: temp_ad17
739  REAL :: temp_ad18
740  REAL :: z2_ad
741  REAL :: y10_ad
742  REAL :: z3_ad
743  REAL :: y11_ad
744  REAL :: temp_ad19
745  REAL :: temp_ad20
746  REAL :: z4_ad
747  REAL :: y12_ad
748  REAL :: z5_ad
749  REAL :: y13_ad
750  REAL :: temp1
751  REAL :: temp_ad21
752  REAL :: temp_ad22
753  REAL :: temp_ad23
754  REAL :: temp_ad24
755  INTEGER :: branch
756  REAL :: x10
757  REAL :: x9
758  REAL :: x8
759  REAL :: x7
760  REAL :: x6
761  REAL :: x5
762  REAL :: x4
763  REAL :: x3
764  REAL :: x2
765  REAL :: y15
766  REAL :: y14
767  REAL :: y13
768  REAL :: y12
769  REAL :: y11
770  REAL :: y10
771  REAL :: z5
772  REAL :: z4
773  REAL :: z3
774  REAL :: z2
775  REAL :: z1
776  REAL :: y9
777  REAL :: y8
778  REAL :: y7
779  REAL :: y6
780  REAL :: y5
781  REAL :: y4
782  REAL :: y3
783  REAL :: y2
784  REAL :: y1
785  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
786  IF (3 .LT. is - 1) THEN
787  is1 = is - 1
788  ELSE
789  is1 = 3
790  END IF
791  IF (npx - 2 .GT. ie + 2) THEN
792  ie3 = ie + 2
793  ELSE
794  ie3 = npx - 2
795  END IF
796  IF (npx - 3 .GT. ie + 1) THEN
797  CALL pushcontrol1b(1)
798  ie1 = ie + 1
799  ELSE
800  CALL pushcontrol1b(1)
801  ie1 = npx - 3
802  END IF
803  ELSE
804  CALL pushcontrol1b(0)
805  is1 = is - 1
806  ie3 = ie + 2
807  ie1 = ie + 1
808  END IF
809  DO j=jfirst,jlast
810  DO i=isd,ied
811  CALL pushrealarray_adm(q1(i))
812  q1(i) = q(i, j)
813  END DO
814  IF (iord .LT. 8 .OR. iord .EQ. 333) THEN
815 ! ord = 2: perfectly linear ppm scheme
816 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
817  DO i=is1,ie3
818  CALL pushrealarray_adm(al(i))
819  al(i) = p1*(q1(i-1)+q1(i)) + p2*(q1(i-2)+q1(i+1))
820  END DO
821  IF (iord .EQ. 7) THEN
822  DO i=is1,ie3
823  IF (al(i) .LT. 0.) THEN
824  CALL pushrealarray_adm(al(i))
825  al(i) = 0.5*(q1(i-1)+q1(i))
826  CALL pushcontrol1b(1)
827  ELSE
828  CALL pushcontrol1b(0)
829  END IF
830  END DO
831  CALL pushcontrol1b(0)
832  ELSE
833  CALL pushcontrol1b(1)
834  END IF
835  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
836  IF (is .EQ. 1) THEN
837  CALL pushrealarray_adm(al(0))
838  al(0) = c1*q1(-2) + c2*q1(-1) + c3*q1(0)
839  CALL pushrealarray_adm(al(1))
840  al(1) = 0.5*(((2.*dxa(0, j)+dxa(-1, j))*q1(0)-dxa(0, j)*q1(-&
841 & 1))/(dxa(-1, j)+dxa(0, j))+((2.*dxa(1, j)+dxa(2, j))*q1(1)&
842 & -dxa(1, j)*q1(2))/(dxa(1, j)+dxa(2, j)))
843  CALL pushrealarray_adm(al(2))
844  al(2) = c3*q1(1) + c2*q1(2) + c1*q1(3)
845  IF (iord .EQ. 7) THEN
846  IF (0. .LT. al(0)) THEN
847  CALL pushrealarray_adm(al(0))
848  al(0) = al(0)
849  CALL pushcontrol1b(0)
850  ELSE
851  CALL pushrealarray_adm(al(0))
852  al(0) = 0.
853  CALL pushcontrol1b(1)
854  END IF
855  IF (0. .LT. al(1)) THEN
856  CALL pushrealarray_adm(al(1))
857  al(1) = al(1)
858  CALL pushcontrol1b(0)
859  ELSE
860  CALL pushrealarray_adm(al(1))
861  al(1) = 0.
862  CALL pushcontrol1b(1)
863  END IF
864  IF (0. .LT. al(2)) THEN
865  CALL pushrealarray_adm(al(2))
866  al(2) = al(2)
867  CALL pushcontrol2b(3)
868  ELSE
869  CALL pushrealarray_adm(al(2))
870  al(2) = 0.
871  CALL pushcontrol2b(2)
872  END IF
873  ELSE
874  CALL pushcontrol2b(0)
875  END IF
876  ELSE
877  CALL pushcontrol2b(1)
878  END IF
879  IF (ie + 1 .EQ. npx) THEN
880  CALL pushrealarray_adm(al(npx-1))
881  al(npx-1) = c1*q1(npx-3) + c2*q1(npx-2) + c3*q1(npx-1)
882  CALL pushrealarray_adm(al(npx))
883  al(npx) = 0.5*(((2.*dxa(npx-1, j)+dxa(npx-2, j))*q1(npx-1)-&
884 & dxa(npx-1, j)*q1(npx-2))/(dxa(npx-2, j)+dxa(npx-1, j))+((&
885 & 2.*dxa(npx, j)+dxa(npx+1, j))*q1(npx)-dxa(npx, j)*q1(npx+1&
886 & ))/(dxa(npx, j)+dxa(npx+1, j)))
887  CALL pushrealarray_adm(al(npx+1))
888  al(npx+1) = c3*q1(npx) + c2*q1(npx+1) + c1*q1(npx+2)
889  IF (iord .EQ. 7) THEN
890  IF (0. .LT. al(npx-1)) THEN
891  CALL pushrealarray_adm(al(npx-1))
892  al(npx-1) = al(npx-1)
893  CALL pushcontrol1b(0)
894  ELSE
895  CALL pushrealarray_adm(al(npx-1))
896  al(npx-1) = 0.
897  CALL pushcontrol1b(1)
898  END IF
899  IF (0. .LT. al(npx)) THEN
900  CALL pushrealarray_adm(al(npx))
901  al(npx) = al(npx)
902  CALL pushcontrol1b(0)
903  ELSE
904  CALL pushrealarray_adm(al(npx))
905  al(npx) = 0.
906  CALL pushcontrol1b(1)
907  END IF
908  IF (0. .LT. al(npx+1)) THEN
909  CALL pushrealarray_adm(al(npx+1))
910  al(npx+1) = al(npx+1)
911  CALL pushcontrol3b(4)
912  ELSE
913  CALL pushrealarray_adm(al(npx+1))
914  al(npx+1) = 0.
915  CALL pushcontrol3b(3)
916  END IF
917  ELSE
918  CALL pushcontrol3b(0)
919  END IF
920  ELSE
921  CALL pushcontrol3b(1)
922  END IF
923  ELSE
924  CALL pushcontrol3b(2)
925  END IF
926  IF (iord .EQ. 1) THEN
927  DO i=is,ie+1
928  IF (c(i, j) .GT. 0.) THEN
929  CALL pushcontrol1b(1)
930  ELSE
931  CALL pushcontrol1b(0)
932  END IF
933  END DO
934  CALL pushcontrol3b(0)
935  ELSE IF (iord .EQ. 2) THEN
936 ! perfectly linear scheme
937 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
938 !DEC$ VECTOR ALWAYS
939  DO i=is,ie+1
940  CALL pushrealarray_adm(xt)
941  xt = c(i, j)
942  IF (xt .GT. 0.) THEN
943  CALL pushrealarray_adm(qtmp)
944  CALL pushcontrol1b(1)
945  ELSE
946  CALL pushrealarray_adm(qtmp)
947  CALL pushcontrol1b(0)
948  END IF
949  END DO
950  CALL pushcontrol3b(1)
951  ELSE IF (iord .EQ. 333) THEN
952 ! x0 = sign(dim(xt, 0.), 1.)
953 ! x1 = sign(dim(0., xt), 1.)
954 ! flux(i,j) = x0*(q1(i-1)+(1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp)))) &
955 ! + x1*(q1(i) +(1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp))))
956 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
957 !DEC$ VECTOR ALWAYS
958  DO i=is,ie+1
959  CALL pushrealarray_adm(xt)
960  xt = c(i, j)
961  IF (xt .GT. 0.) THEN
962  CALL pushcontrol1b(1)
963  ELSE
964  CALL pushcontrol1b(0)
965  END IF
966  END DO
967  CALL pushcontrol3b(2)
968  ELSE IF (iord .EQ. 3) THEN
969  DO i=is-1,ie+1
970  CALL pushrealarray_adm(bl(i))
971  bl(i) = al(i) - q1(i)
972  CALL pushrealarray_adm(br(i))
973  br(i) = al(i+1) - q1(i)
974  CALL pushrealarray_adm(b0(i))
975  b0(i) = bl(i) + br(i)
976  IF (b0(i) .GE. 0.) THEN
977  x0 = b0(i)
978  ELSE
979  x0 = -b0(i)
980  END IF
981  IF (bl(i) - br(i) .GE. 0.) THEN
982  CALL pushrealarray_adm(xt)
983  xt = bl(i) - br(i)
984  CALL pushcontrol1b(0)
985  ELSE
986  CALL pushrealarray_adm(xt)
987  xt = -(bl(i)-br(i))
988  CALL pushcontrol1b(1)
989  END IF
990  smt5(i) = x0 .LT. xt
991  smt6(i) = 3.*x0 .LT. xt
992  END DO
993  DO i=is,ie+1
994  CALL pushrealarray_adm(fx1(i))
995  fx1(i) = 0.
996  END DO
997  DO i=is,ie+1
998  CALL pushrealarray_adm(xt)
999  xt = c(i, j)
1000  IF (xt .GT. 0.) THEN
1001  IF (smt6(i-1) .OR. smt5(i)) THEN
1002  CALL pushrealarray_adm(fx1(i))
1003  fx1(i) = br(i-1) - xt*b0(i-1)
1004  CALL pushcontrol3b(5)
1005  ELSE IF (smt5(i-1)) THEN
1006  IF (bl(i-1) .GE. 0.) THEN
1007  x2 = bl(i-1)
1008  CALL pushcontrol1b(0)
1009  ELSE
1010  x2 = -bl(i-1)
1011  CALL pushcontrol1b(1)
1012  END IF
1013  IF (br(i-1) .GE. 0.) THEN
1014  y1 = br(i-1)
1015  CALL pushcontrol1b(0)
1016  ELSE
1017  y1 = -br(i-1)
1018  CALL pushcontrol1b(1)
1019  END IF
1020  IF (x2 .GT. y1) THEN
1021  CALL pushrealarray_adm(min1)
1022  min1 = y1
1023  CALL pushcontrol1b(0)
1024  ELSE
1025  CALL pushrealarray_adm(min1)
1026  min1 = x2
1027  CALL pushcontrol1b(1)
1028  END IF
1029 ! 2nd order, piece-wise linear
1030  CALL pushrealarray_adm(fx1(i))
1031  fx1(i) = sign(min1, br(i-1))
1032  CALL pushcontrol3b(4)
1033  ELSE
1034  CALL pushcontrol3b(3)
1035  END IF
1036  ELSE IF (smt6(i) .OR. smt5(i-1)) THEN
1037  CALL pushrealarray_adm(fx1(i))
1038  fx1(i) = bl(i) + xt*b0(i)
1039  CALL pushcontrol3b(2)
1040  ELSE IF (smt5(i)) THEN
1041  IF (bl(i) .GE. 0.) THEN
1042  x3 = bl(i)
1043  CALL pushcontrol1b(0)
1044  ELSE
1045  x3 = -bl(i)
1046  CALL pushcontrol1b(1)
1047  END IF
1048  IF (br(i) .GE. 0.) THEN
1049  y2 = br(i)
1050  CALL pushcontrol1b(0)
1051  ELSE
1052  y2 = -br(i)
1053  CALL pushcontrol1b(1)
1054  END IF
1055  IF (x3 .GT. y2) THEN
1056  CALL pushrealarray_adm(min2)
1057  min2 = y2
1058  CALL pushcontrol1b(0)
1059  ELSE
1060  CALL pushrealarray_adm(min2)
1061  min2 = x3
1062  CALL pushcontrol1b(1)
1063  END IF
1064  CALL pushrealarray_adm(fx1(i))
1065  fx1(i) = sign(min2, bl(i))
1066  CALL pushcontrol3b(1)
1067  ELSE
1068  CALL pushcontrol3b(0)
1069  END IF
1070  IF (xt .GE. 0.) THEN
1071  CALL pushrealarray_adm(abs0)
1072  abs0 = xt
1073  CALL pushcontrol1b(0)
1074  ELSE
1075  CALL pushrealarray_adm(abs0)
1076  abs0 = -xt
1077  CALL pushcontrol1b(1)
1078  END IF
1079  END DO
1080  CALL pushcontrol3b(3)
1081  ELSE IF (iord .EQ. 4) THEN
1082  DO i=is-1,ie+1
1083  CALL pushrealarray_adm(bl(i))
1084  bl(i) = al(i) - q1(i)
1085  CALL pushrealarray_adm(br(i))
1086  br(i) = al(i+1) - q1(i)
1087  CALL pushrealarray_adm(b0(i))
1088  b0(i) = bl(i) + br(i)
1089  IF (b0(i) .GE. 0.) THEN
1090  x0 = b0(i)
1091  ELSE
1092  x0 = -b0(i)
1093  END IF
1094  IF (bl(i) - br(i) .GE. 0.) THEN
1095  CALL pushrealarray_adm(xt)
1096  xt = bl(i) - br(i)
1097  CALL pushcontrol1b(0)
1098  ELSE
1099  CALL pushrealarray_adm(xt)
1100  xt = -(bl(i)-br(i))
1101  CALL pushcontrol1b(1)
1102  END IF
1103  smt5(i) = x0 .LT. xt
1104  smt6(i) = 3.*x0 .LT. xt
1105  END DO
1106  DO i=is,ie+1
1107  CALL pushrealarray_adm(fx1(i))
1108  fx1(i) = 0.
1109  END DO
1110 !DEC$ VECTOR ALWAYS
1111  DO i=is,ie+1
1112  IF (c(i, j) .GT. 0.) THEN
1113  IF (smt6(i-1) .OR. smt5(i)) THEN
1114  CALL pushrealarray_adm(fx1(i))
1115  fx1(i) = (1.-c(i, j))*(br(i-1)-c(i, j)*b0(i-1))
1116  CALL pushcontrol2b(0)
1117  ELSE
1118  CALL pushcontrol2b(1)
1119  END IF
1120  ELSE IF (smt6(i) .OR. smt5(i-1)) THEN
1121  CALL pushrealarray_adm(fx1(i))
1122  fx1(i) = (1.+c(i, j))*(bl(i)+c(i, j)*b0(i))
1123  CALL pushcontrol2b(2)
1124  ELSE
1125  CALL pushcontrol2b(3)
1126  END IF
1127  END DO
1128  CALL pushcontrol3b(4)
1129  ELSE
1130 ! iord = 5 & 6
1131  IF (iord .EQ. 5) THEN
1132  DO i=is-1,ie+1
1133  CALL pushrealarray_adm(bl(i))
1134  bl(i) = al(i) - q1(i)
1135  CALL pushrealarray_adm(br(i))
1136  br(i) = al(i+1) - q1(i)
1137  CALL pushrealarray_adm(b0(i))
1138  b0(i) = bl(i) + br(i)
1139  smt5(i) = bl(i)*br(i) .LT. 0.
1140  END DO
1141  CALL pushcontrol1b(1)
1142  ELSE
1143  DO i=is-1,ie+1
1144  CALL pushrealarray_adm(bl(i))
1145  bl(i) = al(i) - q1(i)
1146  CALL pushrealarray_adm(br(i))
1147  br(i) = al(i+1) - q1(i)
1148  CALL pushrealarray_adm(b0(i))
1149  b0(i) = bl(i) + br(i)
1150  IF (3.*b0(i) .GE. 0.) THEN
1151  abs1 = 3.*b0(i)
1152  ELSE
1153  abs1 = -(3.*b0(i))
1154  END IF
1155  IF (bl(i) - br(i) .GE. 0.) THEN
1156  abs4 = bl(i) - br(i)
1157  ELSE
1158  abs4 = -(bl(i)-br(i))
1159  END IF
1160  smt5(i) = abs1 .LT. abs4
1161  END DO
1162  CALL pushcontrol1b(0)
1163  END IF
1164 !DEC$ VECTOR ALWAYS
1165  DO i=is,ie+1
1166  IF (c(i, j) .GT. 0.) THEN
1167  CALL pushrealarray_adm(fx1(i))
1168  fx1(i) = (1.-c(i, j))*(br(i-1)-c(i, j)*b0(i-1))
1169  CALL pushcontrol1b(0)
1170  ELSE
1171  CALL pushrealarray_adm(fx1(i))
1172  fx1(i) = (1.+c(i, j))*(bl(i)+c(i, j)*b0(i))
1173  CALL pushcontrol1b(1)
1174  END IF
1175  IF (smt5(i-1) .OR. smt5(i)) THEN
1176  CALL pushcontrol1b(1)
1177  ELSE
1178  CALL pushcontrol1b(0)
1179  END IF
1180  END DO
1181  CALL pushcontrol3b(5)
1182  END IF
1183  ELSE
1184 ! Monotonic constraints:
1185 ! ord = 8: PPM with Lin's PPM fast monotone constraint
1186 ! ord = 10: PPM with Lin's modification of Huynh 2nd constraint
1187 ! ord = 13: 10 plus positive definite constraint
1188  DO i=is-2,ie+2
1189  CALL pushrealarray_adm(xt)
1190  xt = 0.25*(q1(i+1)-q1(i-1))
1191  IF (xt .GE. 0.) THEN
1192  x4 = xt
1193  CALL pushcontrol1b(0)
1194  ELSE
1195  x4 = -xt
1196  CALL pushcontrol1b(1)
1197  END IF
1198  IF (q1(i-1) .LT. q1(i)) THEN
1199  IF (q1(i) .LT. q1(i+1)) THEN
1200  max1 = q1(i+1)
1201  CALL pushcontrol2b(0)
1202  ELSE
1203  max1 = q1(i)
1204  CALL pushcontrol2b(1)
1205  END IF
1206  ELSE IF (q1(i-1) .LT. q1(i+1)) THEN
1207  max1 = q1(i+1)
1208  CALL pushcontrol2b(2)
1209  ELSE
1210  max1 = q1(i-1)
1211  CALL pushcontrol2b(3)
1212  END IF
1213  y3 = max1 - q1(i)
1214  IF (q1(i-1) .GT. q1(i)) THEN
1215  IF (q1(i) .GT. q1(i+1)) THEN
1216  min8 = q1(i+1)
1217  CALL pushcontrol2b(0)
1218  ELSE
1219  min8 = q1(i)
1220  CALL pushcontrol2b(1)
1221  END IF
1222  ELSE IF (q1(i-1) .GT. q1(i+1)) THEN
1223  min8 = q1(i+1)
1224  CALL pushcontrol2b(2)
1225  ELSE
1226  min8 = q1(i-1)
1227  CALL pushcontrol2b(3)
1228  END IF
1229  z1 = q1(i) - min8
1230  IF (x4 .GT. y3) THEN
1231  IF (y3 .GT. z1) THEN
1232  CALL pushrealarray_adm(min3)
1233  min3 = z1
1234  CALL pushcontrol2b(0)
1235  ELSE
1236  CALL pushrealarray_adm(min3)
1237  min3 = y3
1238  CALL pushcontrol2b(1)
1239  END IF
1240  ELSE IF (x4 .GT. z1) THEN
1241  CALL pushrealarray_adm(min3)
1242  min3 = z1
1243  CALL pushcontrol2b(2)
1244  ELSE
1245  CALL pushrealarray_adm(min3)
1246  min3 = x4
1247  CALL pushcontrol2b(3)
1248  END IF
1249  dm(i) = sign(min3, xt)
1250  END DO
1251  DO i=is1,ie1+1
1252  CALL pushrealarray_adm(al(i))
1253  al(i) = 0.5*(q1(i-1)+q1(i)) + r3*(dm(i-1)-dm(i))
1254  END DO
1255  IF (iord .EQ. 8) THEN
1256  DO i=is1,ie1
1257  CALL pushrealarray_adm(xt)
1258  xt = 2.*dm(i)
1259  IF (xt .GE. 0.) THEN
1260  x5 = xt
1261  CALL pushcontrol1b(0)
1262  ELSE
1263  x5 = -xt
1264  CALL pushcontrol1b(1)
1265  END IF
1266  IF (al(i) - q1(i) .GE. 0.) THEN
1267  y4 = al(i) - q1(i)
1268  CALL pushcontrol1b(0)
1269  ELSE
1270  y4 = -(al(i)-q1(i))
1271  CALL pushcontrol1b(1)
1272  END IF
1273  IF (x5 .GT. y4) THEN
1274  CALL pushrealarray_adm(min4)
1275  min4 = y4
1276  CALL pushcontrol1b(0)
1277  ELSE
1278  CALL pushrealarray_adm(min4)
1279  min4 = x5
1280  CALL pushcontrol1b(1)
1281  END IF
1282  CALL pushrealarray_adm(bl(i))
1283  bl(i) = -sign(min4, xt)
1284  IF (xt .GE. 0.) THEN
1285  x6 = xt
1286  CALL pushcontrol1b(0)
1287  ELSE
1288  x6 = -xt
1289  CALL pushcontrol1b(1)
1290  END IF
1291  IF (al(i+1) - q1(i) .GE. 0.) THEN
1292  y5 = al(i+1) - q1(i)
1293  CALL pushcontrol1b(0)
1294  ELSE
1295  y5 = -(al(i+1)-q1(i))
1296  CALL pushcontrol1b(1)
1297  END IF
1298  IF (x6 .GT. y5) THEN
1299  CALL pushrealarray_adm(min5)
1300  min5 = y5
1301  CALL pushcontrol1b(0)
1302  ELSE
1303  CALL pushrealarray_adm(min5)
1304  min5 = x6
1305  CALL pushcontrol1b(1)
1306  END IF
1307  CALL pushrealarray_adm(br(i))
1308  br(i) = sign(min5, xt)
1309  END DO
1310  CALL pushcontrol2b(0)
1311  ELSE IF (iord .EQ. 11) THEN
1312 ! This is emulation of 2nd van Leer scheme using PPM codes
1313  DO i=is1,ie1
1314  CALL pushrealarray_adm(xt)
1315  xt = ppm_fac*dm(i)
1316  IF (xt .GE. 0.) THEN
1317  x7 = xt
1318  CALL pushcontrol1b(0)
1319  ELSE
1320  x7 = -xt
1321  CALL pushcontrol1b(1)
1322  END IF
1323  IF (al(i) - q1(i) .GE. 0.) THEN
1324  y6 = al(i) - q1(i)
1325  CALL pushcontrol1b(0)
1326  ELSE
1327  y6 = -(al(i)-q1(i))
1328  CALL pushcontrol1b(1)
1329  END IF
1330  IF (x7 .GT. y6) THEN
1331  CALL pushrealarray_adm(min6)
1332  min6 = y6
1333  CALL pushcontrol1b(0)
1334  ELSE
1335  CALL pushrealarray_adm(min6)
1336  min6 = x7
1337  CALL pushcontrol1b(1)
1338  END IF
1339  CALL pushrealarray_adm(bl(i))
1340  bl(i) = -sign(min6, xt)
1341  IF (xt .GE. 0.) THEN
1342  x8 = xt
1343  CALL pushcontrol1b(0)
1344  ELSE
1345  x8 = -xt
1346  CALL pushcontrol1b(1)
1347  END IF
1348  IF (al(i+1) - q1(i) .GE. 0.) THEN
1349  y7 = al(i+1) - q1(i)
1350  CALL pushcontrol1b(0)
1351  ELSE
1352  y7 = -(al(i+1)-q1(i))
1353  CALL pushcontrol1b(1)
1354  END IF
1355  IF (x8 .GT. y7) THEN
1356  CALL pushrealarray_adm(min7)
1357  min7 = y7
1358  CALL pushcontrol1b(0)
1359  ELSE
1360  CALL pushrealarray_adm(min7)
1361  min7 = x8
1362  CALL pushcontrol1b(1)
1363  END IF
1364  CALL pushrealarray_adm(br(i))
1365  br(i) = sign(min7, xt)
1366  END DO
1367  CALL pushcontrol2b(1)
1368  ELSE
1369  DO i=is1-2,ie1+1
1370  dq(i) = 2.*(q1(i+1)-q1(i))
1371  END DO
1372  DO i=is1,ie1
1373  CALL pushrealarray_adm(bl(i))
1374  bl(i) = al(i) - q1(i)
1375  CALL pushrealarray_adm(br(i))
1376  br(i) = al(i+1) - q1(i)
1377  IF (dm(i-1) .GE. 0.) THEN
1378  abs2 = dm(i-1)
1379  ELSE
1380  abs2 = -dm(i-1)
1381  END IF
1382  IF (dm(i) .GE. 0.) THEN
1383  abs5 = dm(i)
1384  ELSE
1385  abs5 = -dm(i)
1386  END IF
1387  IF (dm(i+1) .GE. 0.) THEN
1388  abs7 = dm(i+1)
1389  ELSE
1390  abs7 = -dm(i+1)
1391  END IF
1392  IF (abs2 + abs5 + abs7 .LT. near_zero) THEN
1393  bl(i) = 0.
1394  br(i) = 0.
1395  CALL pushcontrol2b(3)
1396  ELSE
1397  IF (3.*(bl(i)+br(i)) .GE. 0.) THEN
1398  abs3 = 3.*(bl(i)+br(i))
1399  ELSE
1400  abs3 = -(3.*(bl(i)+br(i)))
1401  END IF
1402  IF (bl(i) - br(i) .GE. 0.) THEN
1403  abs6 = bl(i) - br(i)
1404  ELSE
1405  abs6 = -(bl(i)-br(i))
1406  END IF
1407  IF (abs3 .GT. abs6) THEN
1408  pmp_2 = dq(i-1)
1409  lac_2 = pmp_2 - 0.75*dq(i-2)
1410  IF (0. .LT. pmp_2) THEN
1411  IF (pmp_2 .LT. lac_2) THEN
1412  x9 = lac_2
1413  CALL pushcontrol2b(0)
1414  ELSE
1415  x9 = pmp_2
1416  CALL pushcontrol2b(1)
1417  END IF
1418  ELSE IF (0. .LT. lac_2) THEN
1419  x9 = lac_2
1420  CALL pushcontrol2b(2)
1421  ELSE
1422  CALL pushcontrol2b(3)
1423  x9 = 0.
1424  END IF
1425  IF (0. .GT. pmp_2) THEN
1426  IF (pmp_2 .GT. lac_2) THEN
1427  y14 = lac_2
1428  CALL pushcontrol2b(0)
1429  ELSE
1430  y14 = pmp_2
1431  CALL pushcontrol2b(1)
1432  END IF
1433  ELSE IF (0. .GT. lac_2) THEN
1434  y14 = lac_2
1435  CALL pushcontrol2b(2)
1436  ELSE
1437  y14 = 0.
1438  CALL pushcontrol2b(3)
1439  END IF
1440  IF (br(i) .LT. y14) THEN
1441  y8 = y14
1442  CALL pushcontrol1b(0)
1443  ELSE
1444  y8 = br(i)
1445  CALL pushcontrol1b(1)
1446  END IF
1447  IF (x9 .GT. y8) THEN
1448  br(i) = y8
1449  CALL pushcontrol1b(0)
1450  ELSE
1451  br(i) = x9
1452  CALL pushcontrol1b(1)
1453  END IF
1454  pmp_1 = -dq(i)
1455  lac_1 = pmp_1 + 0.75*dq(i+1)
1456  IF (0. .LT. pmp_1) THEN
1457  IF (pmp_1 .LT. lac_1) THEN
1458  x10 = lac_1
1459  CALL pushcontrol2b(0)
1460  ELSE
1461  x10 = pmp_1
1462  CALL pushcontrol2b(1)
1463  END IF
1464  ELSE IF (0. .LT. lac_1) THEN
1465  x10 = lac_1
1466  CALL pushcontrol2b(2)
1467  ELSE
1468  CALL pushcontrol2b(3)
1469  x10 = 0.
1470  END IF
1471  IF (0. .GT. pmp_1) THEN
1472  IF (pmp_1 .GT. lac_1) THEN
1473  y15 = lac_1
1474  CALL pushcontrol2b(0)
1475  ELSE
1476  y15 = pmp_1
1477  CALL pushcontrol2b(1)
1478  END IF
1479  ELSE IF (0. .GT. lac_1) THEN
1480  y15 = lac_1
1481  CALL pushcontrol2b(2)
1482  ELSE
1483  y15 = 0.
1484  CALL pushcontrol2b(3)
1485  END IF
1486  IF (bl(i) .LT. y15) THEN
1487  y9 = y15
1488  CALL pushcontrol1b(0)
1489  ELSE
1490  y9 = bl(i)
1491  CALL pushcontrol1b(1)
1492  END IF
1493  IF (x10 .GT. y9) THEN
1494  bl(i) = y9
1495  CALL pushcontrol2b(1)
1496  ELSE
1497  bl(i) = x10
1498  CALL pushcontrol2b(2)
1499  END IF
1500  ELSE
1501  CALL pushcontrol2b(0)
1502  END IF
1503  END IF
1504  END DO
1505  CALL pushcontrol2b(2)
1506  END IF
1507 ! Positive definite constraint:
1508  IF (iord .EQ. 9 .OR. iord .EQ. 13) THEN
1509  arg1 = ie1 - is1 + 1
1510  CALL pushrealarray_adm(br(is1:ie1), ie1 - is1 + 1)
1511  CALL pushrealarray_adm(bl(is1:ie1), ie1 - is1 + 1)
1512  CALL pert_ppm(arg1, q1(is1:ie1), bl(is1:ie1), br(is1:ie1), 0)
1513  CALL pushcontrol1b(0)
1514  ELSE
1515  CALL pushcontrol1b(1)
1516  END IF
1517  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
1518  IF (is .EQ. 1) THEN
1519  CALL pushrealarray_adm(bl(0))
1520  bl(0) = s14*dm(-1) + s11*(q1(-1)-q1(0))
1521  CALL pushrealarray_adm(xt)
1522  xt = 0.5*(((2.*dxa(0, j)+dxa(-1, j))*q1(0)-dxa(0, j)*q1(-1))&
1523 & /(dxa(-1, j)+dxa(0, j))+((2.*dxa(1, j)+dxa(2, j))*q1(1)-&
1524 & dxa(1, j)*q1(2))/(dxa(1, j)+dxa(2, j)))
1525  IF (q1(1) .GT. q1(2)) THEN
1526  z2 = q1(2)
1527  CALL pushcontrol1b(0)
1528  ELSE
1529  z2 = q1(1)
1530  CALL pushcontrol1b(1)
1531  END IF
1532  IF (q1(-1) .GT. q1(0)) THEN
1533  IF (q1(0) .GT. z2) THEN
1534  y10 = z2
1535  CALL pushcontrol2b(0)
1536  ELSE
1537  y10 = q1(0)
1538  CALL pushcontrol2b(1)
1539  END IF
1540  ELSE IF (q1(-1) .GT. z2) THEN
1541  y10 = z2
1542  CALL pushcontrol2b(2)
1543  ELSE
1544  y10 = q1(-1)
1545  CALL pushcontrol2b(3)
1546  END IF
1547  IF (xt .LT. y10) THEN
1548  xt = y10
1549  CALL pushcontrol1b(0)
1550  ELSE
1551  xt = xt
1552  CALL pushcontrol1b(1)
1553  END IF
1554  IF (q1(1) .LT. q1(2)) THEN
1555  z3 = q1(2)
1556  CALL pushcontrol1b(0)
1557  ELSE
1558  z3 = q1(1)
1559  CALL pushcontrol1b(1)
1560  END IF
1561  IF (q1(-1) .LT. q1(0)) THEN
1562  IF (q1(0) .LT. z3) THEN
1563  y11 = z3
1564  CALL pushcontrol2b(0)
1565  ELSE
1566  y11 = q1(0)
1567  CALL pushcontrol2b(1)
1568  END IF
1569  ELSE IF (q1(-1) .LT. z3) THEN
1570  y11 = z3
1571  CALL pushcontrol2b(2)
1572  ELSE
1573  y11 = q1(-1)
1574  CALL pushcontrol2b(3)
1575  END IF
1576  IF (xt .GT. y11) THEN
1577  xt = y11
1578  CALL pushcontrol1b(0)
1579  ELSE
1580  xt = xt
1581  CALL pushcontrol1b(1)
1582  END IF
1583 ! endif
1584  CALL pushrealarray_adm(br(0))
1585  br(0) = xt - q1(0)
1586  CALL pushrealarray_adm(bl(1))
1587  bl(1) = xt - q1(1)
1588  xt = s15*q1(1) + s11*q1(2) - s14*dm(2)
1589  CALL pushrealarray_adm(br(1))
1590  br(1) = xt - q1(1)
1591  CALL pushrealarray_adm(bl(2))
1592  bl(2) = xt - q1(2)
1593  CALL pushrealarray_adm(br(2))
1594  br(2) = al(3) - q1(2)
1595  CALL pushrealarray_adm(br(0:2), 3)
1596  CALL pushrealarray_adm(bl(0:2), 3)
1597  CALL pert_ppm(3, q1(0:2), bl(0:2), br(0:2), 1)
1598  CALL pushcontrol1b(0)
1599  ELSE
1600  CALL pushcontrol1b(1)
1601  END IF
1602  IF (ie + 1 .EQ. npx) THEN
1603  CALL pushrealarray_adm(bl(npx-2))
1604  bl(npx-2) = al(npx-2) - q1(npx-2)
1605  CALL pushrealarray_adm(xt)
1606  xt = s15*q1(npx-1) + s11*q1(npx-2) + s14*dm(npx-2)
1607  CALL pushrealarray_adm(br(npx-2))
1608  br(npx-2) = xt - q1(npx-2)
1609  CALL pushrealarray_adm(bl(npx-1))
1610  bl(npx-1) = xt - q1(npx-1)
1611  xt = 0.5*(((2.*dxa(npx-1, j)+dxa(npx-2, j))*q1(npx-1)-dxa(&
1612 & npx-1, j)*q1(npx-2))/(dxa(npx-2, j)+dxa(npx-1, j))+((2.*&
1613 & dxa(npx, j)+dxa(npx+1, j))*q1(npx)-dxa(npx, j)*q1(npx+1))/&
1614 & (dxa(npx, j)+dxa(npx+1, j)))
1615  IF (q1(npx) .GT. q1(npx+1)) THEN
1616  z4 = q1(npx+1)
1617  CALL pushcontrol1b(0)
1618  ELSE
1619  z4 = q1(npx)
1620  CALL pushcontrol1b(1)
1621  END IF
1622  IF (q1(npx-2) .GT. q1(npx-1)) THEN
1623  IF (q1(npx-1) .GT. z4) THEN
1624  y12 = z4
1625  CALL pushcontrol2b(0)
1626  ELSE
1627  y12 = q1(npx-1)
1628  CALL pushcontrol2b(1)
1629  END IF
1630  ELSE IF (q1(npx-2) .GT. z4) THEN
1631  y12 = z4
1632  CALL pushcontrol2b(2)
1633  ELSE
1634  y12 = q1(npx-2)
1635  CALL pushcontrol2b(3)
1636  END IF
1637  IF (xt .LT. y12) THEN
1638  xt = y12
1639  CALL pushcontrol1b(0)
1640  ELSE
1641  xt = xt
1642  CALL pushcontrol1b(1)
1643  END IF
1644  IF (q1(npx) .LT. q1(npx+1)) THEN
1645  z5 = q1(npx+1)
1646  CALL pushcontrol1b(0)
1647  ELSE
1648  z5 = q1(npx)
1649  CALL pushcontrol1b(1)
1650  END IF
1651  IF (q1(npx-2) .LT. q1(npx-1)) THEN
1652  IF (q1(npx-1) .LT. z5) THEN
1653  y13 = z5
1654  CALL pushcontrol2b(0)
1655  ELSE
1656  y13 = q1(npx-1)
1657  CALL pushcontrol2b(1)
1658  END IF
1659  ELSE IF (q1(npx-2) .LT. z5) THEN
1660  y13 = z5
1661  CALL pushcontrol2b(2)
1662  ELSE
1663  y13 = q1(npx-2)
1664  CALL pushcontrol2b(3)
1665  END IF
1666  IF (xt .GT. y13) THEN
1667  xt = y13
1668  CALL pushcontrol1b(0)
1669  ELSE
1670  xt = xt
1671  CALL pushcontrol1b(1)
1672  END IF
1673 ! endif
1674  CALL pushrealarray_adm(br(npx-1))
1675  br(npx-1) = xt - q1(npx-1)
1676  CALL pushrealarray_adm(bl(npx))
1677  bl(npx) = xt - q1(npx)
1678  CALL pushrealarray_adm(br(npx))
1679  br(npx) = s11*(q1(npx+1)-q1(npx)) - s14*dm(npx+1)
1680  CALL pushrealarray_adm(br(npx-2:npx), 3)
1681  CALL pushrealarray_adm(bl(npx-2:npx), 3)
1682  CALL pert_ppm(3, q1(npx-2:npx), bl(npx-2:npx), br(npx-2:npx)&
1683 & , 1)
1684  CALL pushcontrol2b(2)
1685  ELSE
1686  CALL pushcontrol2b(1)
1687  END IF
1688  ELSE
1689  CALL pushcontrol2b(0)
1690  END IF
1691  DO i=is,ie+1
1692  IF (c(i, j) .GT. 0.) THEN
1693  CALL pushcontrol1b(1)
1694  ELSE
1695  CALL pushcontrol1b(0)
1696  END IF
1697  END DO
1698  CALL pushcontrol3b(6)
1699  END IF
1700  END DO
1701  dm_ad = 0.0
1702  dq_ad = 0.0
1703  al_ad = 0.0
1704  bl_ad = 0.0
1705  q1_ad = 0.0
1706  br_ad = 0.0
1707  b0_ad = 0.0
1708  fx0_ad = 0.0
1709  fx1_ad = 0.0
1710  DO j=jlast,jfirst,-1
1711  CALL popcontrol3b(branch)
1712  IF (branch .LT. 3) THEN
1713  IF (branch .EQ. 0) THEN
1714  DO i=ie+1,is,-1
1715  CALL popcontrol1b(branch)
1716  IF (branch .EQ. 0) THEN
1717  q1_ad(i) = q1_ad(i) + flux_ad(i, j)
1718  flux_ad(i, j) = 0.0
1719  ELSE
1720  q1_ad(i-1) = q1_ad(i-1) + flux_ad(i, j)
1721  flux_ad(i, j) = 0.0
1722  END IF
1723  END DO
1724  ELSE IF (branch .EQ. 1) THEN
1725  DO i=ie+1,is,-1
1726  CALL popcontrol1b(branch)
1727  IF (branch .EQ. 0) THEN
1728  xt = c(i, j)
1729  qtmp = q1(i)
1730  temp0 = al(i) + al(i+1) - 2*qtmp
1731  temp_ad5 = (xt+1.)*flux_ad(i, j)
1732  temp_ad6 = xt*temp_ad5
1733  qtmp_ad = flux_ad(i, j) - temp_ad5 - 2*temp_ad6
1734  xt_ad = temp0*temp_ad5 + (al(i)-qtmp+xt*temp0)*flux_ad(i, &
1735 & j)
1736  al_ad(i) = al_ad(i) + temp_ad6 + temp_ad5
1737  al_ad(i+1) = al_ad(i+1) + temp_ad6
1738  flux_ad(i, j) = 0.0
1739  CALL poprealarray_adm(qtmp)
1740  q1_ad(i) = q1_ad(i) + qtmp_ad
1741  ELSE
1742  xt = c(i, j)
1743  qtmp = q1(i-1)
1744  temp = al(i-1) + al(i) - 2*qtmp
1745  temp_ad3 = (1.-xt)*flux_ad(i, j)
1746  temp_ad4 = -(xt*temp_ad3)
1747  qtmp_ad = flux_ad(i, j) - temp_ad3 - 2*temp_ad4
1748  xt_ad = -(temp*temp_ad3) - (al(i)-qtmp-xt*temp)*flux_ad(i&
1749 & , j)
1750  al_ad(i) = al_ad(i) + temp_ad4 + temp_ad3
1751  al_ad(i-1) = al_ad(i-1) + temp_ad4
1752  flux_ad(i, j) = 0.0
1753  CALL poprealarray_adm(qtmp)
1754  q1_ad(i-1) = q1_ad(i-1) + qtmp_ad
1755  END IF
1756  CALL poprealarray_adm(xt)
1757  c_ad(i, j) = c_ad(i, j) + xt_ad
1758  END DO
1759  ELSE
1760  DO i=ie+1,is,-1
1761  CALL popcontrol1b(branch)
1762  IF (branch .EQ. 0) THEN
1763  xt = c(i, j)
1764  temp_ad10 = flux_ad(i, j)/6.0
1765  temp_ad11 = -(0.5*xt*flux_ad(i, j))
1766  temp_ad12 = xt**2*flux_ad(i, j)/6.0
1767  q1_ad(i-1) = q1_ad(i-1) + temp_ad12 - temp_ad11 + 2.0*&
1768 & temp_ad10
1769  q1_ad(i) = q1_ad(i) + temp_ad11 - 2.0*temp_ad12 + 5.0*&
1770 & temp_ad10
1771  q1_ad(i+1) = q1_ad(i+1) + temp_ad12 - temp_ad10
1772  xt_ad = ((q1(i+1)-2.0*q1(i)+q1(i-1))*2*xt/6.0-0.5*(q1(i)-&
1773 & q1(i-1)))*flux_ad(i, j)
1774  flux_ad(i, j) = 0.0
1775  ELSE
1776  xt = c(i, j)
1777  temp_ad7 = flux_ad(i, j)/6.0
1778  temp_ad8 = -(0.5*xt*flux_ad(i, j))
1779  temp_ad9 = xt**2*flux_ad(i, j)/6.0
1780  q1_ad(i) = q1_ad(i) + temp_ad9 + temp_ad8 + 2.0*temp_ad7
1781  q1_ad(i-1) = q1_ad(i-1) + 5.0*temp_ad7 - temp_ad8 - 2.0*&
1782 & temp_ad9
1783  q1_ad(i-2) = q1_ad(i-2) + temp_ad9 - temp_ad7
1784  xt_ad = ((q1(i)-2.0*q1(i-1)+q1(i-2))*2*xt/6.0-0.5*(q1(i)-&
1785 & q1(i-1)))*flux_ad(i, j)
1786  flux_ad(i, j) = 0.0
1787  END IF
1788  CALL poprealarray_adm(xt)
1789  c_ad(i, j) = c_ad(i, j) + xt_ad
1790  END DO
1791  END IF
1792  ELSE IF (branch .LT. 5) THEN
1793  IF (branch .EQ. 3) THEN
1794  DO i=ie+1,is,-1
1795  fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
1796  abs0_ad = -(fx1(i)*flux_ad(i, j))
1797  fx1_ad(i) = fx1_ad(i) + (1.-abs0)*flux_ad(i, j)
1798  flux_ad(i, j) = 0.0
1799  xt = c(i, j)
1800  CALL popcontrol1b(branch)
1801  IF (branch .EQ. 0) THEN
1802  CALL poprealarray_adm(abs0)
1803  xt_ad = abs0_ad
1804  ELSE
1805  CALL poprealarray_adm(abs0)
1806  xt_ad = -abs0_ad
1807  END IF
1808  CALL popcontrol3b(branch)
1809  IF (branch .LT. 3) THEN
1810  IF (branch .NE. 0) THEN
1811  IF (branch .EQ. 1) THEN
1812  CALL poprealarray_adm(fx1(i))
1813  min2_ad = sign(1.d0, min2*bl(i))*fx1_ad(i)
1814  fx1_ad(i) = 0.0
1815  CALL popcontrol1b(branch)
1816  IF (branch .EQ. 0) THEN
1817  CALL poprealarray_adm(min2)
1818  y2_ad = min2_ad
1819  x3_ad = 0.0
1820  ELSE
1821  CALL poprealarray_adm(min2)
1822  x3_ad = min2_ad
1823  y2_ad = 0.0
1824  END IF
1825  CALL popcontrol1b(branch)
1826  IF (branch .EQ. 0) THEN
1827  br_ad(i) = br_ad(i) + y2_ad
1828  ELSE
1829  br_ad(i) = br_ad(i) - y2_ad
1830  END IF
1831  CALL popcontrol1b(branch)
1832  IF (branch .EQ. 0) THEN
1833  bl_ad(i) = bl_ad(i) + x3_ad
1834  ELSE
1835  bl_ad(i) = bl_ad(i) - x3_ad
1836  END IF
1837  ELSE
1838  CALL poprealarray_adm(fx1(i))
1839  bl_ad(i) = bl_ad(i) + fx1_ad(i)
1840  xt_ad = xt_ad + b0(i)*fx1_ad(i)
1841  b0_ad(i) = b0_ad(i) + xt*fx1_ad(i)
1842  fx1_ad(i) = 0.0
1843  END IF
1844  END IF
1845  q1_ad(i) = q1_ad(i) + fx0_ad(i)
1846  fx0_ad(i) = 0.0
1847  ELSE
1848  IF (branch .NE. 3) THEN
1849  IF (branch .EQ. 4) THEN
1850  CALL poprealarray_adm(fx1(i))
1851  min1_ad = sign(1.d0, min1*br(i-1))*fx1_ad(i)
1852  fx1_ad(i) = 0.0
1853  CALL popcontrol1b(branch)
1854  IF (branch .EQ. 0) THEN
1855  CALL poprealarray_adm(min1)
1856  y1_ad = min1_ad
1857  x2_ad = 0.0
1858  ELSE
1859  CALL poprealarray_adm(min1)
1860  x2_ad = min1_ad
1861  y1_ad = 0.0
1862  END IF
1863  CALL popcontrol1b(branch)
1864  IF (branch .EQ. 0) THEN
1865  br_ad(i-1) = br_ad(i-1) + y1_ad
1866  ELSE
1867  br_ad(i-1) = br_ad(i-1) - y1_ad
1868  END IF
1869  CALL popcontrol1b(branch)
1870  IF (branch .EQ. 0) THEN
1871  bl_ad(i-1) = bl_ad(i-1) + x2_ad
1872  ELSE
1873  bl_ad(i-1) = bl_ad(i-1) - x2_ad
1874  END IF
1875  ELSE
1876  CALL poprealarray_adm(fx1(i))
1877  br_ad(i-1) = br_ad(i-1) + fx1_ad(i)
1878  xt_ad = xt_ad - b0(i-1)*fx1_ad(i)
1879  b0_ad(i-1) = b0_ad(i-1) - xt*fx1_ad(i)
1880  fx1_ad(i) = 0.0
1881  END IF
1882  END IF
1883  q1_ad(i-1) = q1_ad(i-1) + fx0_ad(i)
1884  fx0_ad(i) = 0.0
1885  END IF
1886  CALL poprealarray_adm(xt)
1887  c_ad(i, j) = c_ad(i, j) + xt_ad
1888  END DO
1889  DO i=ie+1,is,-1
1890  CALL poprealarray_adm(fx1(i))
1891  fx1_ad(i) = 0.0
1892  END DO
1893  DO i=ie+1,is-1,-1
1894  CALL popcontrol1b(branch)
1895  IF (branch .EQ. 0) THEN
1896  CALL poprealarray_adm(xt)
1897  ELSE
1898  CALL poprealarray_adm(xt)
1899  END IF
1900  CALL poprealarray_adm(b0(i))
1901  bl_ad(i) = bl_ad(i) + b0_ad(i)
1902  br_ad(i) = br_ad(i) + b0_ad(i)
1903  b0_ad(i) = 0.0
1904  CALL poprealarray_adm(br(i))
1905  al_ad(i+1) = al_ad(i+1) + br_ad(i)
1906  q1_ad(i) = q1_ad(i) - bl_ad(i) - br_ad(i)
1907  br_ad(i) = 0.0
1908  CALL poprealarray_adm(bl(i))
1909  al_ad(i) = al_ad(i) + bl_ad(i)
1910  bl_ad(i) = 0.0
1911  END DO
1912  ELSE
1913  DO i=ie+1,is,-1
1914  fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
1915  fx1_ad(i) = fx1_ad(i) + flux_ad(i, j)
1916  flux_ad(i, j) = 0.0
1917  CALL popcontrol2b(branch)
1918  IF (branch .LT. 2) THEN
1919  IF (branch .EQ. 0) THEN
1920  CALL poprealarray_adm(fx1(i))
1921  temp_ad13 = (1.-c(i, j))*fx1_ad(i)
1922  c_ad(i, j) = c_ad(i, j) - b0(i-1)*temp_ad13 - (br(i-1)-c&
1923 & (i, j)*b0(i-1))*fx1_ad(i)
1924  br_ad(i-1) = br_ad(i-1) + temp_ad13
1925  b0_ad(i-1) = b0_ad(i-1) - c(i, j)*temp_ad13
1926  fx1_ad(i) = 0.0
1927  END IF
1928  q1_ad(i-1) = q1_ad(i-1) + fx0_ad(i)
1929  fx0_ad(i) = 0.0
1930  ELSE
1931  IF (branch .EQ. 2) THEN
1932  CALL poprealarray_adm(fx1(i))
1933  temp_ad14 = (c(i, j)+1.)*fx1_ad(i)
1934  c_ad(i, j) = c_ad(i, j) + b0(i)*temp_ad14 + (bl(i)+c(i, &
1935 & j)*b0(i))*fx1_ad(i)
1936  bl_ad(i) = bl_ad(i) + temp_ad14
1937  b0_ad(i) = b0_ad(i) + c(i, j)*temp_ad14
1938  fx1_ad(i) = 0.0
1939  END IF
1940  q1_ad(i) = q1_ad(i) + fx0_ad(i)
1941  fx0_ad(i) = 0.0
1942  END IF
1943  END DO
1944  DO i=ie+1,is,-1
1945  CALL poprealarray_adm(fx1(i))
1946  fx1_ad(i) = 0.0
1947  END DO
1948  DO i=ie+1,is-1,-1
1949  CALL popcontrol1b(branch)
1950  IF (branch .EQ. 0) THEN
1951  CALL poprealarray_adm(xt)
1952  ELSE
1953  CALL poprealarray_adm(xt)
1954  END IF
1955  CALL poprealarray_adm(b0(i))
1956  bl_ad(i) = bl_ad(i) + b0_ad(i)
1957  br_ad(i) = br_ad(i) + b0_ad(i)
1958  b0_ad(i) = 0.0
1959  CALL poprealarray_adm(br(i))
1960  al_ad(i+1) = al_ad(i+1) + br_ad(i)
1961  q1_ad(i) = q1_ad(i) - bl_ad(i) - br_ad(i)
1962  br_ad(i) = 0.0
1963  CALL poprealarray_adm(bl(i))
1964  al_ad(i) = al_ad(i) + bl_ad(i)
1965  bl_ad(i) = 0.0
1966  END DO
1967  END IF
1968  ELSE IF (branch .EQ. 5) THEN
1969  DO i=ie+1,is,-1
1970  CALL popcontrol1b(branch)
1971  IF (branch .NE. 0) fx1_ad(i) = fx1_ad(i) + flux_ad(i, j)
1972  CALL popcontrol1b(branch)
1973  IF (branch .EQ. 0) THEN
1974  q1_ad(i-1) = q1_ad(i-1) + flux_ad(i, j)
1975  flux_ad(i, j) = 0.0
1976  CALL poprealarray_adm(fx1(i))
1977  temp_ad15 = (1.-c(i, j))*fx1_ad(i)
1978  c_ad(i, j) = c_ad(i, j) - b0(i-1)*temp_ad15 - (br(i-1)-c(i, &
1979 & j)*b0(i-1))*fx1_ad(i)
1980  br_ad(i-1) = br_ad(i-1) + temp_ad15
1981  b0_ad(i-1) = b0_ad(i-1) - c(i, j)*temp_ad15
1982  fx1_ad(i) = 0.0
1983  ELSE
1984  q1_ad(i) = q1_ad(i) + flux_ad(i, j)
1985  flux_ad(i, j) = 0.0
1986  CALL poprealarray_adm(fx1(i))
1987  temp_ad16 = (c(i, j)+1.)*fx1_ad(i)
1988  c_ad(i, j) = c_ad(i, j) + b0(i)*temp_ad16 + (bl(i)+c(i, j)*&
1989 & b0(i))*fx1_ad(i)
1990  bl_ad(i) = bl_ad(i) + temp_ad16
1991  b0_ad(i) = b0_ad(i) + c(i, j)*temp_ad16
1992  fx1_ad(i) = 0.0
1993  END IF
1994  END DO
1995  CALL popcontrol1b(branch)
1996  IF (branch .EQ. 0) THEN
1997  DO i=ie+1,is-1,-1
1998  CALL poprealarray_adm(b0(i))
1999  bl_ad(i) = bl_ad(i) + b0_ad(i)
2000  br_ad(i) = br_ad(i) + b0_ad(i)
2001  b0_ad(i) = 0.0
2002  CALL poprealarray_adm(br(i))
2003  al_ad(i+1) = al_ad(i+1) + br_ad(i)
2004  q1_ad(i) = q1_ad(i) - bl_ad(i) - br_ad(i)
2005  br_ad(i) = 0.0
2006  CALL poprealarray_adm(bl(i))
2007  al_ad(i) = al_ad(i) + bl_ad(i)
2008  bl_ad(i) = 0.0
2009  END DO
2010  ELSE
2011  DO i=ie+1,is-1,-1
2012  CALL poprealarray_adm(b0(i))
2013  bl_ad(i) = bl_ad(i) + b0_ad(i)
2014  br_ad(i) = br_ad(i) + b0_ad(i)
2015  b0_ad(i) = 0.0
2016  CALL poprealarray_adm(br(i))
2017  al_ad(i+1) = al_ad(i+1) + br_ad(i)
2018  q1_ad(i) = q1_ad(i) - bl_ad(i) - br_ad(i)
2019  br_ad(i) = 0.0
2020  CALL poprealarray_adm(bl(i))
2021  al_ad(i) = al_ad(i) + bl_ad(i)
2022  bl_ad(i) = 0.0
2023  END DO
2024  END IF
2025  ELSE
2026  DO i=ie+1,is,-1
2027  CALL popcontrol1b(branch)
2028  IF (branch .EQ. 0) THEN
2029  temp_ad23 = (c(i, j)+1.)*flux_ad(i, j)
2030  temp_ad24 = c(i, j)*temp_ad23
2031  q1_ad(i) = q1_ad(i) + flux_ad(i, j)
2032  c_ad(i, j) = c_ad(i, j) + (bl(i)+br(i))*temp_ad23 + (bl(i)+c&
2033 & (i, j)*(bl(i)+br(i)))*flux_ad(i, j)
2034  bl_ad(i) = bl_ad(i) + temp_ad24 + temp_ad23
2035  br_ad(i) = br_ad(i) + temp_ad24
2036  flux_ad(i, j) = 0.0
2037  ELSE
2038  temp1 = bl(i-1) + br(i-1)
2039  temp_ad21 = (1.-c(i, j))*flux_ad(i, j)
2040  temp_ad22 = -(c(i, j)*temp_ad21)
2041  q1_ad(i-1) = q1_ad(i-1) + flux_ad(i, j)
2042  c_ad(i, j) = c_ad(i, j) - temp1*temp_ad21 - (br(i-1)-c(i, j)&
2043 & *temp1)*flux_ad(i, j)
2044  br_ad(i-1) = br_ad(i-1) + temp_ad22 + temp_ad21
2045  bl_ad(i-1) = bl_ad(i-1) + temp_ad22
2046  flux_ad(i, j) = 0.0
2047  END IF
2048  END DO
2049  CALL popcontrol2b(branch)
2050  IF (branch .NE. 0) THEN
2051  IF (branch .NE. 1) THEN
2052  CALL poprealarray_adm(bl(npx-2:npx), 3)
2053  CALL poprealarray_adm(br(npx-2:npx), 3)
2054  CALL pert_ppm_adm(3, q1(npx-2:npx), bl(npx-2:npx), bl_ad(npx&
2055 & -2:npx), br(npx-2:npx), br_ad(npx-2:npx), 1)
2056  CALL poprealarray_adm(br(npx))
2057  q1_ad(npx+1) = q1_ad(npx+1) + s11*br_ad(npx)
2058  q1_ad(npx) = q1_ad(npx) - bl_ad(npx) - s11*br_ad(npx)
2059  dm_ad(npx+1) = dm_ad(npx+1) - s14*br_ad(npx)
2060  br_ad(npx) = 0.0
2061  CALL poprealarray_adm(bl(npx))
2062  xt_ad = br_ad(npx-1) + bl_ad(npx)
2063  bl_ad(npx) = 0.0
2064  CALL poprealarray_adm(br(npx-1))
2065  q1_ad(npx-1) = q1_ad(npx-1) - br_ad(npx-1)
2066  br_ad(npx-1) = 0.0
2067  CALL popcontrol1b(branch)
2068  IF (branch .EQ. 0) THEN
2069  y13_ad = xt_ad
2070  xt_ad = 0.0
2071  ELSE
2072  y13_ad = 0.0
2073  END IF
2074  CALL popcontrol2b(branch)
2075  IF (branch .LT. 2) THEN
2076  IF (branch .EQ. 0) THEN
2077  z5_ad = y13_ad
2078  ELSE
2079  q1_ad(npx-1) = q1_ad(npx-1) + y13_ad
2080  z5_ad = 0.0
2081  END IF
2082  ELSE IF (branch .EQ. 2) THEN
2083  z5_ad = y13_ad
2084  ELSE
2085  q1_ad(npx-2) = q1_ad(npx-2) + y13_ad
2086  z5_ad = 0.0
2087  END IF
2088  CALL popcontrol1b(branch)
2089  IF (branch .EQ. 0) THEN
2090  q1_ad(npx+1) = q1_ad(npx+1) + z5_ad
2091  ELSE
2092  q1_ad(npx) = q1_ad(npx) + z5_ad
2093  END IF
2094  CALL popcontrol1b(branch)
2095  IF (branch .EQ. 0) THEN
2096  y12_ad = xt_ad
2097  xt_ad = 0.0
2098  ELSE
2099  y12_ad = 0.0
2100  END IF
2101  CALL popcontrol2b(branch)
2102  IF (branch .LT. 2) THEN
2103  IF (branch .EQ. 0) THEN
2104  z4_ad = y12_ad
2105  ELSE
2106  q1_ad(npx-1) = q1_ad(npx-1) + y12_ad
2107  z4_ad = 0.0
2108  END IF
2109  ELSE IF (branch .EQ. 2) THEN
2110  z4_ad = y12_ad
2111  ELSE
2112  q1_ad(npx-2) = q1_ad(npx-2) + y12_ad
2113  z4_ad = 0.0
2114  END IF
2115  CALL popcontrol1b(branch)
2116  IF (branch .EQ. 0) THEN
2117  q1_ad(npx+1) = q1_ad(npx+1) + z4_ad
2118  ELSE
2119  q1_ad(npx) = q1_ad(npx) + z4_ad
2120  END IF
2121  temp_ad19 = 0.5*xt_ad/(dxa(npx-2, j)+dxa(npx-1, j))
2122  temp_ad20 = 0.5*xt_ad/(dxa(npx, j)+dxa(npx+1, j))
2123  q1_ad(npx-1) = q1_ad(npx-1) + (dxa(npx-1, j)*2.+dxa(npx-2, j&
2124 & ))*temp_ad19
2125  q1_ad(npx-2) = q1_ad(npx-2) - dxa(npx-1, j)*temp_ad19
2126  q1_ad(npx) = q1_ad(npx) + (dxa(npx, j)*2.+dxa(npx+1, j))*&
2127 & temp_ad20
2128  q1_ad(npx+1) = q1_ad(npx+1) - dxa(npx, j)*temp_ad20
2129  CALL poprealarray_adm(bl(npx-1))
2130  xt_ad = br_ad(npx-2) + bl_ad(npx-1)
2131  q1_ad(npx-1) = q1_ad(npx-1) - bl_ad(npx-1)
2132  bl_ad(npx-1) = 0.0
2133  CALL poprealarray_adm(br(npx-2))
2134  q1_ad(npx-2) = q1_ad(npx-2) - br_ad(npx-2)
2135  br_ad(npx-2) = 0.0
2136  CALL poprealarray_adm(xt)
2137  q1_ad(npx-1) = q1_ad(npx-1) + s15*xt_ad
2138  q1_ad(npx-2) = q1_ad(npx-2) + s11*xt_ad - bl_ad(npx-2)
2139  dm_ad(npx-2) = dm_ad(npx-2) + s14*xt_ad
2140  CALL poprealarray_adm(bl(npx-2))
2141  al_ad(npx-2) = al_ad(npx-2) + bl_ad(npx-2)
2142  bl_ad(npx-2) = 0.0
2143  END IF
2144  CALL popcontrol1b(branch)
2145  IF (branch .EQ. 0) THEN
2146  CALL poprealarray_adm(bl(0:2), 3)
2147  CALL poprealarray_adm(br(0:2), 3)
2148  CALL pert_ppm_adm(3, q1(0:2), bl(0:2), bl_ad(0:2), br(0:2), &
2149 & br_ad(0:2), 1)
2150  CALL poprealarray_adm(br(2))
2151  al_ad(3) = al_ad(3) + br_ad(2)
2152  q1_ad(2) = q1_ad(2) - bl_ad(2) - br_ad(2)
2153  br_ad(2) = 0.0
2154  CALL poprealarray_adm(bl(2))
2155  xt_ad = br_ad(1) + bl_ad(2)
2156  bl_ad(2) = 0.0
2157  CALL poprealarray_adm(br(1))
2158  q1_ad(1) = q1_ad(1) + s15*xt_ad - br_ad(1)
2159  br_ad(1) = 0.0
2160  q1_ad(2) = q1_ad(2) + s11*xt_ad
2161  dm_ad(2) = dm_ad(2) - s14*xt_ad
2162  CALL poprealarray_adm(bl(1))
2163  xt_ad = br_ad(0) + bl_ad(1)
2164  q1_ad(1) = q1_ad(1) - bl_ad(1)
2165  bl_ad(1) = 0.0
2166  CALL poprealarray_adm(br(0))
2167  q1_ad(0) = q1_ad(0) - br_ad(0)
2168  br_ad(0) = 0.0
2169  CALL popcontrol1b(branch)
2170  IF (branch .EQ. 0) THEN
2171  y11_ad = xt_ad
2172  xt_ad = 0.0
2173  ELSE
2174  y11_ad = 0.0
2175  END IF
2176  CALL popcontrol2b(branch)
2177  IF (branch .LT. 2) THEN
2178  IF (branch .EQ. 0) THEN
2179  z3_ad = y11_ad
2180  ELSE
2181  q1_ad(0) = q1_ad(0) + y11_ad
2182  z3_ad = 0.0
2183  END IF
2184  ELSE IF (branch .EQ. 2) THEN
2185  z3_ad = y11_ad
2186  ELSE
2187  q1_ad(-1) = q1_ad(-1) + y11_ad
2188  z3_ad = 0.0
2189  END IF
2190  CALL popcontrol1b(branch)
2191  IF (branch .EQ. 0) THEN
2192  q1_ad(2) = q1_ad(2) + z3_ad
2193  ELSE
2194  q1_ad(1) = q1_ad(1) + z3_ad
2195  END IF
2196  CALL popcontrol1b(branch)
2197  IF (branch .EQ. 0) THEN
2198  y10_ad = xt_ad
2199  xt_ad = 0.0
2200  ELSE
2201  y10_ad = 0.0
2202  END IF
2203  CALL popcontrol2b(branch)
2204  IF (branch .LT. 2) THEN
2205  IF (branch .EQ. 0) THEN
2206  z2_ad = y10_ad
2207  ELSE
2208  q1_ad(0) = q1_ad(0) + y10_ad
2209  z2_ad = 0.0
2210  END IF
2211  ELSE IF (branch .EQ. 2) THEN
2212  z2_ad = y10_ad
2213  ELSE
2214  q1_ad(-1) = q1_ad(-1) + y10_ad
2215  z2_ad = 0.0
2216  END IF
2217  CALL popcontrol1b(branch)
2218  IF (branch .EQ. 0) THEN
2219  q1_ad(2) = q1_ad(2) + z2_ad
2220  ELSE
2221  q1_ad(1) = q1_ad(1) + z2_ad
2222  END IF
2223  CALL poprealarray_adm(xt)
2224  temp_ad17 = 0.5*xt_ad/(dxa(-1, j)+dxa(0, j))
2225  temp_ad18 = 0.5*xt_ad/(dxa(1, j)+dxa(2, j))
2226  q1_ad(0) = q1_ad(0) + (dxa(0, j)*2.+dxa(-1, j))*temp_ad17
2227  q1_ad(-1) = q1_ad(-1) - dxa(0, j)*temp_ad17
2228  q1_ad(1) = q1_ad(1) + (dxa(1, j)*2.+dxa(2, j))*temp_ad18
2229  q1_ad(2) = q1_ad(2) - dxa(1, j)*temp_ad18
2230  CALL poprealarray_adm(bl(0))
2231  dm_ad(-1) = dm_ad(-1) + s14*bl_ad(0)
2232  q1_ad(-1) = q1_ad(-1) + s11*bl_ad(0)
2233  q1_ad(0) = q1_ad(0) - s11*bl_ad(0)
2234  bl_ad(0) = 0.0
2235  END IF
2236  END IF
2237  CALL popcontrol1b(branch)
2238  IF (branch .EQ. 0) THEN
2239  arg1 = ie1 - is1 + 1
2240  CALL poprealarray_adm(bl(is1:ie1), ie1 - is1 + 1)
2241  CALL poprealarray_adm(br(is1:ie1), ie1 - is1 + 1)
2242  CALL pert_ppm_adm(arg1, q1(is1:ie1), bl(is1:ie1), bl_ad(is1:&
2243 & ie1), br(is1:ie1), br_ad(is1:ie1), 0)
2244  END IF
2245  CALL popcontrol2b(branch)
2246  IF (branch .EQ. 0) THEN
2247  DO i=ie1,is1,-1
2248  CALL poprealarray_adm(br(i))
2249  min5_ad = sign(1.d0, min5*xt)*br_ad(i)
2250  br_ad(i) = 0.0
2251  CALL popcontrol1b(branch)
2252  IF (branch .EQ. 0) THEN
2253  CALL poprealarray_adm(min5)
2254  y5_ad = min5_ad
2255  x6_ad = 0.0
2256  ELSE
2257  CALL poprealarray_adm(min5)
2258  x6_ad = min5_ad
2259  y5_ad = 0.0
2260  END IF
2261  CALL popcontrol1b(branch)
2262  IF (branch .EQ. 0) THEN
2263  al_ad(i+1) = al_ad(i+1) + y5_ad
2264  q1_ad(i) = q1_ad(i) - y5_ad
2265  ELSE
2266  q1_ad(i) = q1_ad(i) + y5_ad
2267  al_ad(i+1) = al_ad(i+1) - y5_ad
2268  END IF
2269  CALL popcontrol1b(branch)
2270  IF (branch .EQ. 0) THEN
2271  xt_ad = x6_ad
2272  ELSE
2273  xt_ad = -x6_ad
2274  END IF
2275  CALL poprealarray_adm(bl(i))
2276  min4_ad = -(sign(1.d0, min4*xt)*bl_ad(i))
2277  bl_ad(i) = 0.0
2278  CALL popcontrol1b(branch)
2279  IF (branch .EQ. 0) THEN
2280  CALL poprealarray_adm(min4)
2281  y4_ad = min4_ad
2282  x5_ad = 0.0
2283  ELSE
2284  CALL poprealarray_adm(min4)
2285  x5_ad = min4_ad
2286  y4_ad = 0.0
2287  END IF
2288  CALL popcontrol1b(branch)
2289  IF (branch .EQ. 0) THEN
2290  al_ad(i) = al_ad(i) + y4_ad
2291  q1_ad(i) = q1_ad(i) - y4_ad
2292  ELSE
2293  q1_ad(i) = q1_ad(i) + y4_ad
2294  al_ad(i) = al_ad(i) - y4_ad
2295  END IF
2296  CALL popcontrol1b(branch)
2297  IF (branch .EQ. 0) THEN
2298  xt_ad = xt_ad + x5_ad
2299  ELSE
2300  xt_ad = xt_ad - x5_ad
2301  END IF
2302  CALL poprealarray_adm(xt)
2303  dm_ad(i) = dm_ad(i) + 2.*xt_ad
2304  END DO
2305  ELSE IF (branch .EQ. 1) THEN
2306  DO i=ie1,is1,-1
2307  CALL poprealarray_adm(br(i))
2308  min7_ad = sign(1.d0, min7*xt)*br_ad(i)
2309  br_ad(i) = 0.0
2310  CALL popcontrol1b(branch)
2311  IF (branch .EQ. 0) THEN
2312  CALL poprealarray_adm(min7)
2313  y7_ad = min7_ad
2314  x8_ad = 0.0
2315  ELSE
2316  CALL poprealarray_adm(min7)
2317  x8_ad = min7_ad
2318  y7_ad = 0.0
2319  END IF
2320  CALL popcontrol1b(branch)
2321  IF (branch .EQ. 0) THEN
2322  al_ad(i+1) = al_ad(i+1) + y7_ad
2323  q1_ad(i) = q1_ad(i) - y7_ad
2324  ELSE
2325  q1_ad(i) = q1_ad(i) + y7_ad
2326  al_ad(i+1) = al_ad(i+1) - y7_ad
2327  END IF
2328  CALL popcontrol1b(branch)
2329  IF (branch .EQ. 0) THEN
2330  xt_ad = x8_ad
2331  ELSE
2332  xt_ad = -x8_ad
2333  END IF
2334  CALL poprealarray_adm(bl(i))
2335  min6_ad = -(sign(1.d0, min6*xt)*bl_ad(i))
2336  bl_ad(i) = 0.0
2337  CALL popcontrol1b(branch)
2338  IF (branch .EQ. 0) THEN
2339  CALL poprealarray_adm(min6)
2340  y6_ad = min6_ad
2341  x7_ad = 0.0
2342  ELSE
2343  CALL poprealarray_adm(min6)
2344  x7_ad = min6_ad
2345  y6_ad = 0.0
2346  END IF
2347  CALL popcontrol1b(branch)
2348  IF (branch .EQ. 0) THEN
2349  al_ad(i) = al_ad(i) + y6_ad
2350  q1_ad(i) = q1_ad(i) - y6_ad
2351  ELSE
2352  q1_ad(i) = q1_ad(i) + y6_ad
2353  al_ad(i) = al_ad(i) - y6_ad
2354  END IF
2355  CALL popcontrol1b(branch)
2356  IF (branch .EQ. 0) THEN
2357  xt_ad = xt_ad + x7_ad
2358  ELSE
2359  xt_ad = xt_ad - x7_ad
2360  END IF
2361  CALL poprealarray_adm(xt)
2362  dm_ad(i) = dm_ad(i) + ppm_fac*xt_ad
2363  END DO
2364  ELSE
2365  DO i=ie1,is1,-1
2366  CALL popcontrol2b(branch)
2367  IF (branch .LT. 2) THEN
2368  IF (branch .EQ. 0) THEN
2369  GOTO 100
2370  ELSE
2371  y9_ad = bl_ad(i)
2372  bl_ad(i) = 0.0
2373  x10_ad = 0.0
2374  END IF
2375  ELSE IF (branch .EQ. 2) THEN
2376  x10_ad = bl_ad(i)
2377  bl_ad(i) = 0.0
2378  y9_ad = 0.0
2379  ELSE
2380  br_ad(i) = 0.0
2381  bl_ad(i) = 0.0
2382  GOTO 100
2383  END IF
2384  CALL popcontrol1b(branch)
2385  IF (branch .EQ. 0) THEN
2386  y15_ad = y9_ad
2387  ELSE
2388  bl_ad(i) = bl_ad(i) + y9_ad
2389  y15_ad = 0.0
2390  END IF
2391  CALL popcontrol2b(branch)
2392  IF (branch .LT. 2) THEN
2393  IF (branch .EQ. 0) THEN
2394  lac_1_ad = y15_ad
2395  pmp_1_ad = 0.0
2396  ELSE
2397  pmp_1_ad = y15_ad
2398  lac_1_ad = 0.0
2399  END IF
2400  ELSE
2401  IF (branch .EQ. 2) THEN
2402  lac_1_ad = y15_ad
2403  ELSE
2404  lac_1_ad = 0.0
2405  END IF
2406  pmp_1_ad = 0.0
2407  END IF
2408  CALL popcontrol2b(branch)
2409  IF (branch .LT. 2) THEN
2410  IF (branch .EQ. 0) THEN
2411  lac_1_ad = lac_1_ad + x10_ad
2412  ELSE
2413  pmp_1_ad = pmp_1_ad + x10_ad
2414  END IF
2415  ELSE IF (branch .EQ. 2) THEN
2416  lac_1_ad = lac_1_ad + x10_ad
2417  END IF
2418  pmp_1_ad = pmp_1_ad + lac_1_ad
2419  dq_ad(i+1) = dq_ad(i+1) + 0.75*lac_1_ad
2420  dq_ad(i) = dq_ad(i) - pmp_1_ad
2421  CALL popcontrol1b(branch)
2422  IF (branch .EQ. 0) THEN
2423  y8_ad = br_ad(i)
2424  br_ad(i) = 0.0
2425  x9_ad = 0.0
2426  ELSE
2427  x9_ad = br_ad(i)
2428  br_ad(i) = 0.0
2429  y8_ad = 0.0
2430  END IF
2431  CALL popcontrol1b(branch)
2432  IF (branch .EQ. 0) THEN
2433  y14_ad = y8_ad
2434  ELSE
2435  br_ad(i) = br_ad(i) + y8_ad
2436  y14_ad = 0.0
2437  END IF
2438  CALL popcontrol2b(branch)
2439  IF (branch .LT. 2) THEN
2440  IF (branch .EQ. 0) THEN
2441  lac_2_ad = y14_ad
2442  pmp_2_ad = 0.0
2443  ELSE
2444  pmp_2_ad = y14_ad
2445  lac_2_ad = 0.0
2446  END IF
2447  ELSE
2448  IF (branch .EQ. 2) THEN
2449  lac_2_ad = y14_ad
2450  ELSE
2451  lac_2_ad = 0.0
2452  END IF
2453  pmp_2_ad = 0.0
2454  END IF
2455  CALL popcontrol2b(branch)
2456  IF (branch .LT. 2) THEN
2457  IF (branch .EQ. 0) THEN
2458  lac_2_ad = lac_2_ad + x9_ad
2459  ELSE
2460  pmp_2_ad = pmp_2_ad + x9_ad
2461  END IF
2462  ELSE IF (branch .EQ. 2) THEN
2463  lac_2_ad = lac_2_ad + x9_ad
2464  END IF
2465  pmp_2_ad = pmp_2_ad + lac_2_ad
2466  dq_ad(i-2) = dq_ad(i-2) - 0.75*lac_2_ad
2467  dq_ad(i-1) = dq_ad(i-1) + pmp_2_ad
2468  100 CALL poprealarray_adm(br(i))
2469  al_ad(i+1) = al_ad(i+1) + br_ad(i)
2470  q1_ad(i) = q1_ad(i) - bl_ad(i) - br_ad(i)
2471  br_ad(i) = 0.0
2472  CALL poprealarray_adm(bl(i))
2473  al_ad(i) = al_ad(i) + bl_ad(i)
2474  bl_ad(i) = 0.0
2475  END DO
2476  DO i=ie1+1,is1-2,-1
2477  q1_ad(i+1) = q1_ad(i+1) + 2.*dq_ad(i)
2478  q1_ad(i) = q1_ad(i) - 2.*dq_ad(i)
2479  dq_ad(i) = 0.0
2480  END DO
2481  END IF
2482  DO i=ie1+1,is1,-1
2483  CALL poprealarray_adm(al(i))
2484  q1_ad(i-1) = q1_ad(i-1) + 0.5*al_ad(i)
2485  q1_ad(i) = q1_ad(i) + 0.5*al_ad(i)
2486  dm_ad(i-1) = dm_ad(i-1) + r3*al_ad(i)
2487  dm_ad(i) = dm_ad(i) - r3*al_ad(i)
2488  al_ad(i) = 0.0
2489  END DO
2490  DO i=ie+2,is-2,-1
2491  xt = 0.25*(q1(i+1)-q1(i-1))
2492  min3_ad = sign(1.d0, min3*xt)*dm_ad(i)
2493  dm_ad(i) = 0.0
2494  CALL popcontrol2b(branch)
2495  IF (branch .LT. 2) THEN
2496  IF (branch .EQ. 0) THEN
2497  CALL poprealarray_adm(min3)
2498  z1_ad = min3_ad
2499  y3_ad = 0.0
2500  ELSE
2501  CALL poprealarray_adm(min3)
2502  y3_ad = min3_ad
2503  z1_ad = 0.0
2504  END IF
2505  x4_ad = 0.0
2506  ELSE
2507  IF (branch .EQ. 2) THEN
2508  CALL poprealarray_adm(min3)
2509  z1_ad = min3_ad
2510  x4_ad = 0.0
2511  ELSE
2512  CALL poprealarray_adm(min3)
2513  x4_ad = min3_ad
2514  z1_ad = 0.0
2515  END IF
2516  y3_ad = 0.0
2517  END IF
2518  q1_ad(i) = q1_ad(i) + z1_ad
2519  min8_ad = -z1_ad
2520  CALL popcontrol2b(branch)
2521  IF (branch .LT. 2) THEN
2522  IF (branch .EQ. 0) THEN
2523  q1_ad(i+1) = q1_ad(i+1) + min8_ad
2524  ELSE
2525  q1_ad(i) = q1_ad(i) + min8_ad
2526  END IF
2527  ELSE IF (branch .EQ. 2) THEN
2528  q1_ad(i+1) = q1_ad(i+1) + min8_ad
2529  ELSE
2530  q1_ad(i-1) = q1_ad(i-1) + min8_ad
2531  END IF
2532  max1_ad = y3_ad
2533  q1_ad(i) = q1_ad(i) - y3_ad
2534  CALL popcontrol2b(branch)
2535  IF (branch .LT. 2) THEN
2536  IF (branch .EQ. 0) THEN
2537  q1_ad(i+1) = q1_ad(i+1) + max1_ad
2538  ELSE
2539  q1_ad(i) = q1_ad(i) + max1_ad
2540  END IF
2541  ELSE IF (branch .EQ. 2) THEN
2542  q1_ad(i+1) = q1_ad(i+1) + max1_ad
2543  ELSE
2544  q1_ad(i-1) = q1_ad(i-1) + max1_ad
2545  END IF
2546  CALL popcontrol1b(branch)
2547  IF (branch .EQ. 0) THEN
2548  xt_ad = x4_ad
2549  ELSE
2550  xt_ad = -x4_ad
2551  END IF
2552  CALL poprealarray_adm(xt)
2553  q1_ad(i+1) = q1_ad(i+1) + 0.25*xt_ad
2554  q1_ad(i-1) = q1_ad(i-1) - 0.25*xt_ad
2555  END DO
2556  GOTO 130
2557  END IF
2558  CALL popcontrol3b(branch)
2559  IF (branch .LT. 2) THEN
2560  IF (branch .NE. 0) GOTO 110
2561  ELSE IF (branch .EQ. 2) THEN
2562  GOTO 120
2563  ELSE
2564  IF (branch .EQ. 3) THEN
2565  CALL poprealarray_adm(al(npx+1))
2566  al_ad(npx+1) = 0.0
2567  ELSE
2568  CALL poprealarray_adm(al(npx+1))
2569  END IF
2570  CALL popcontrol1b(branch)
2571  IF (branch .EQ. 0) THEN
2572  CALL poprealarray_adm(al(npx))
2573  ELSE
2574  CALL poprealarray_adm(al(npx))
2575  al_ad(npx) = 0.0
2576  END IF
2577  CALL popcontrol1b(branch)
2578  IF (branch .EQ. 0) THEN
2579  CALL poprealarray_adm(al(npx-1))
2580  ELSE
2581  CALL poprealarray_adm(al(npx-1))
2582  al_ad(npx-1) = 0.0
2583  END IF
2584  END IF
2585  CALL poprealarray_adm(al(npx+1))
2586  q1_ad(npx) = q1_ad(npx) + c3*al_ad(npx+1)
2587  q1_ad(npx+1) = q1_ad(npx+1) + c2*al_ad(npx+1)
2588  q1_ad(npx+2) = q1_ad(npx+2) + c1*al_ad(npx+1)
2589  al_ad(npx+1) = 0.0
2590  CALL poprealarray_adm(al(npx))
2591  temp_ad1 = 0.5*al_ad(npx)/(dxa(npx-2, j)+dxa(npx-1, j))
2592  temp_ad2 = 0.5*al_ad(npx)/(dxa(npx, j)+dxa(npx+1, j))
2593  q1_ad(npx-1) = q1_ad(npx-1) + (dxa(npx-1, j)*2.+dxa(npx-2, j))*&
2594 & temp_ad1
2595  q1_ad(npx-2) = q1_ad(npx-2) - dxa(npx-1, j)*temp_ad1
2596  q1_ad(npx) = q1_ad(npx) + (dxa(npx, j)*2.+dxa(npx+1, j))*temp_ad2
2597  q1_ad(npx+1) = q1_ad(npx+1) - dxa(npx, j)*temp_ad2
2598  al_ad(npx) = 0.0
2599  CALL poprealarray_adm(al(npx-1))
2600  q1_ad(npx-3) = q1_ad(npx-3) + c1*al_ad(npx-1)
2601  q1_ad(npx-2) = q1_ad(npx-2) + c2*al_ad(npx-1)
2602  q1_ad(npx-1) = q1_ad(npx-1) + c3*al_ad(npx-1)
2603  al_ad(npx-1) = 0.0
2604  110 CALL popcontrol2b(branch)
2605  IF (branch .LT. 2) THEN
2606  IF (branch .NE. 0) GOTO 120
2607  ELSE
2608  IF (branch .EQ. 2) THEN
2609  CALL poprealarray_adm(al(2))
2610  al_ad(2) = 0.0
2611  ELSE
2612  CALL poprealarray_adm(al(2))
2613  END IF
2614  CALL popcontrol1b(branch)
2615  IF (branch .EQ. 0) THEN
2616  CALL poprealarray_adm(al(1))
2617  ELSE
2618  CALL poprealarray_adm(al(1))
2619  al_ad(1) = 0.0
2620  END IF
2621  CALL popcontrol1b(branch)
2622  IF (branch .EQ. 0) THEN
2623  CALL poprealarray_adm(al(0))
2624  ELSE
2625  CALL poprealarray_adm(al(0))
2626  al_ad(0) = 0.0
2627  END IF
2628  END IF
2629  CALL poprealarray_adm(al(2))
2630  q1_ad(1) = q1_ad(1) + c3*al_ad(2)
2631  q1_ad(2) = q1_ad(2) + c2*al_ad(2)
2632  q1_ad(3) = q1_ad(3) + c1*al_ad(2)
2633  al_ad(2) = 0.0
2634  CALL poprealarray_adm(al(1))
2635  temp_ad = 0.5*al_ad(1)/(dxa(-1, j)+dxa(0, j))
2636  temp_ad0 = 0.5*al_ad(1)/(dxa(1, j)+dxa(2, j))
2637  q1_ad(0) = q1_ad(0) + (dxa(0, j)*2.+dxa(-1, j))*temp_ad
2638  q1_ad(-1) = q1_ad(-1) - dxa(0, j)*temp_ad
2639  q1_ad(1) = q1_ad(1) + (dxa(1, j)*2.+dxa(2, j))*temp_ad0
2640  q1_ad(2) = q1_ad(2) - dxa(1, j)*temp_ad0
2641  al_ad(1) = 0.0
2642  CALL poprealarray_adm(al(0))
2643  q1_ad(-2) = q1_ad(-2) + c1*al_ad(0)
2644  q1_ad(-1) = q1_ad(-1) + c2*al_ad(0)
2645  q1_ad(0) = q1_ad(0) + c3*al_ad(0)
2646  al_ad(0) = 0.0
2647  120 CALL popcontrol1b(branch)
2648  IF (branch .EQ. 0) THEN
2649  DO i=ie3,is1,-1
2650  CALL popcontrol1b(branch)
2651  IF (branch .NE. 0) THEN
2652  CALL poprealarray_adm(al(i))
2653  q1_ad(i-1) = q1_ad(i-1) + 0.5*al_ad(i)
2654  q1_ad(i) = q1_ad(i) + 0.5*al_ad(i)
2655  al_ad(i) = 0.0
2656  END IF
2657  END DO
2658  END IF
2659  DO i=ie3,is1,-1
2660  CALL poprealarray_adm(al(i))
2661  q1_ad(i-1) = q1_ad(i-1) + p1*al_ad(i)
2662  q1_ad(i) = q1_ad(i) + p1*al_ad(i)
2663  q1_ad(i-2) = q1_ad(i-2) + p2*al_ad(i)
2664  q1_ad(i+1) = q1_ad(i+1) + p2*al_ad(i)
2665  al_ad(i) = 0.0
2666  END DO
2667  130 DO i=ied,isd,-1
2668  CALL poprealarray_adm(q1(i))
2669  q_ad(i, j) = q_ad(i, j) + q1_ad(i)
2670  q1_ad(i) = 0.0
2671  END DO
2672  END DO
2673  CALL popcontrol1b(branch)
2674  END SUBROUTINE xppm_adm
2675  SUBROUTINE xppm(flux, q, c, iord, is, ie, isd, ied, jfirst, jlast, jsd&
2676 & , jed, npx, npy, dxa, nested, grid_type)
2677  IMPLICIT NONE
2678  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed
2679 ! compute domain
2680  INTEGER, INTENT(IN) :: jfirst, jlast
2681  INTEGER, INTENT(IN) :: iord
2682  INTEGER, INTENT(IN) :: npx, npy
2683  REAL, INTENT(IN) :: q(isd:ied, jfirst:jlast)
2684 ! Courant N (like FLUX)
2685  REAL, INTENT(IN) :: c(is:ie+1, jfirst:jlast)
2686  REAL, INTENT(IN) :: dxa(isd:ied, jsd:jed)
2687  LOGICAL, INTENT(IN) :: nested
2688  INTEGER, INTENT(IN) :: grid_type
2689 ! !OUTPUT PARAMETERS:
2690 ! Flux
2691  REAL, INTENT(OUT) :: flux(is:ie+1, jfirst:jlast)
2692 ! Local
2693  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
2694  REAL :: q1(isd:ied)
2695  REAL, DIMENSION(is:ie+1) :: fx0, fx1
2696  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
2697  REAL :: al(is-1:ie+2)
2698  REAL :: dm(is-2:ie+2)
2699  REAL :: dq(is-3:ie+2)
2700  INTEGER :: i, j, ie3, is1, ie1
2701  REAL :: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2
2702  INTRINSIC max
2703  INTRINSIC min
2704  INTRINSIC abs
2705  INTRINSIC sign
2706  REAL :: min1
2707  REAL :: min2
2708  REAL :: abs0
2709  REAL :: abs1
2710  REAL :: min3
2711  REAL :: min4
2712  REAL :: min5
2713  REAL :: min6
2714  REAL :: min7
2715  REAL :: abs2
2716  REAL :: abs3
2717  REAL :: abs4
2718  REAL :: max1
2719  REAL :: min8
2720  REAL :: abs5
2721  REAL :: abs6
2722  REAL :: abs7
2723  INTEGER :: arg1
2724  REAL :: x10
2725  REAL :: x9
2726  REAL :: x8
2727  REAL :: x7
2728  REAL :: x6
2729  REAL :: x5
2730  REAL :: x4
2731  REAL :: x3
2732  REAL :: x2
2733  REAL :: y15
2734  REAL :: y14
2735  REAL :: y13
2736  REAL :: y12
2737  REAL :: y11
2738  REAL :: y10
2739  REAL :: z5
2740  REAL :: z4
2741  REAL :: z3
2742  REAL :: z2
2743  REAL :: z1
2744  REAL :: y9
2745  REAL :: y8
2746  REAL :: y7
2747  REAL :: y6
2748  REAL :: y5
2749  REAL :: y4
2750  REAL :: y3
2751  REAL :: y2
2752  REAL :: y1
2753  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
2754  IF (3 .LT. is - 1) THEN
2755  is1 = is - 1
2756  ELSE
2757  is1 = 3
2758  END IF
2759  IF (npx - 2 .GT. ie + 2) THEN
2760  ie3 = ie + 2
2761  ELSE
2762  ie3 = npx - 2
2763  END IF
2764  IF (npx - 3 .GT. ie + 1) THEN
2765  ie1 = ie + 1
2766  ELSE
2767  ie1 = npx - 3
2768  END IF
2769  ELSE
2770  is1 = is - 1
2771  ie3 = ie + 2
2772  ie1 = ie + 1
2773  END IF
2774  DO j=jfirst,jlast
2775  DO i=isd,ied
2776  q1(i) = q(i, j)
2777  END DO
2778  IF (iord .LT. 8 .OR. iord .EQ. 333) THEN
2779 ! ord = 2: perfectly linear ppm scheme
2780 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
2781  DO i=is1,ie3
2782  al(i) = p1*(q1(i-1)+q1(i)) + p2*(q1(i-2)+q1(i+1))
2783  END DO
2784  IF (iord .EQ. 7) THEN
2785  DO i=is1,ie3
2786  IF (al(i) .LT. 0.) al(i) = 0.5*(q1(i-1)+q1(i))
2787  END DO
2788  END IF
2789  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
2790  IF (is .EQ. 1) THEN
2791  al(0) = c1*q1(-2) + c2*q1(-1) + c3*q1(0)
2792  al(1) = 0.5*(((2.*dxa(0, j)+dxa(-1, j))*q1(0)-dxa(0, j)*q1(-&
2793 & 1))/(dxa(-1, j)+dxa(0, j))+((2.*dxa(1, j)+dxa(2, j))*q1(1)&
2794 & -dxa(1, j)*q1(2))/(dxa(1, j)+dxa(2, j)))
2795  al(2) = c3*q1(1) + c2*q1(2) + c1*q1(3)
2796  IF (iord .EQ. 7) THEN
2797  IF (0. .LT. al(0)) THEN
2798  al(0) = al(0)
2799  ELSE
2800  al(0) = 0.
2801  END IF
2802  IF (0. .LT. al(1)) THEN
2803  al(1) = al(1)
2804  ELSE
2805  al(1) = 0.
2806  END IF
2807  IF (0. .LT. al(2)) THEN
2808  al(2) = al(2)
2809  ELSE
2810  al(2) = 0.
2811  END IF
2812  END IF
2813  END IF
2814  IF (ie + 1 .EQ. npx) THEN
2815  al(npx-1) = c1*q1(npx-3) + c2*q1(npx-2) + c3*q1(npx-1)
2816  al(npx) = 0.5*(((2.*dxa(npx-1, j)+dxa(npx-2, j))*q1(npx-1)-&
2817 & dxa(npx-1, j)*q1(npx-2))/(dxa(npx-2, j)+dxa(npx-1, j))+((&
2818 & 2.*dxa(npx, j)+dxa(npx+1, j))*q1(npx)-dxa(npx, j)*q1(npx+1&
2819 & ))/(dxa(npx, j)+dxa(npx+1, j)))
2820  al(npx+1) = c3*q1(npx) + c2*q1(npx+1) + c1*q1(npx+2)
2821  IF (iord .EQ. 7) THEN
2822  IF (0. .LT. al(npx-1)) THEN
2823  al(npx-1) = al(npx-1)
2824  ELSE
2825  al(npx-1) = 0.
2826  END IF
2827  IF (0. .LT. al(npx)) THEN
2828  al(npx) = al(npx)
2829  ELSE
2830  al(npx) = 0.
2831  END IF
2832  IF (0. .LT. al(npx+1)) THEN
2833  al(npx+1) = al(npx+1)
2834  ELSE
2835  al(npx+1) = 0.
2836  END IF
2837  END IF
2838  END IF
2839  END IF
2840  IF (iord .EQ. 1) THEN
2841  DO i=is,ie+1
2842  IF (c(i, j) .GT. 0.) THEN
2843  flux(i, j) = q1(i-1)
2844  ELSE
2845  flux(i, j) = q1(i)
2846  END IF
2847  END DO
2848  ELSE IF (iord .EQ. 2) THEN
2849 ! perfectly linear scheme
2850 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
2851 !DEC$ VECTOR ALWAYS
2852  DO i=is,ie+1
2853  xt = c(i, j)
2854  IF (xt .GT. 0.) THEN
2855  qtmp = q1(i-1)
2856  flux(i, j) = qtmp + (1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-&
2857 & (qtmp+qtmp)))
2858  ELSE
2859  qtmp = q1(i)
2860  flux(i, j) = qtmp + (1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-&
2861 & (qtmp+qtmp)))
2862  END IF
2863  END DO
2864  ELSE IF (iord .EQ. 333) THEN
2865 ! x0 = sign(dim(xt, 0.), 1.)
2866 ! x1 = sign(dim(0., xt), 1.)
2867 ! flux(i,j) = x0*(q1(i-1)+(1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-(qtmp+qtmp)))) &
2868 ! + x1*(q1(i) +(1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-(qtmp+qtmp))))
2869 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
2870 !DEC$ VECTOR ALWAYS
2871  DO i=is,ie+1
2872  xt = c(i, j)
2873  IF (xt .GT. 0.) THEN
2874  flux(i, j) = (2.0*q1(i)+5.0*q1(i-1)-q1(i-2))/6.0 - 0.5*xt*&
2875 & (q1(i)-q1(i-1)) + xt*xt/6.0*(q1(i)-2.0*q1(i-1)+q1(i-2))
2876  ELSE
2877  flux(i, j) = (2.0*q1(i-1)+5.0*q1(i)-q1(i+1))/6.0 - 0.5*xt*&
2878 & (q1(i)-q1(i-1)) + xt*xt/6.0*(q1(i+1)-2.0*q1(i)+q1(i-1))
2879  END IF
2880  END DO
2881  ELSE IF (iord .EQ. 3) THEN
2882  DO i=is-1,ie+1
2883  bl(i) = al(i) - q1(i)
2884  br(i) = al(i+1) - q1(i)
2885  b0(i) = bl(i) + br(i)
2886  IF (b0(i) .GE. 0.) THEN
2887  x0 = b0(i)
2888  ELSE
2889  x0 = -b0(i)
2890  END IF
2891  IF (bl(i) - br(i) .GE. 0.) THEN
2892  xt = bl(i) - br(i)
2893  ELSE
2894  xt = -(bl(i)-br(i))
2895  END IF
2896  smt5(i) = x0 .LT. xt
2897  smt6(i) = 3.*x0 .LT. xt
2898  END DO
2899  DO i=is,ie+1
2900  fx1(i) = 0.
2901  END DO
2902  DO i=is,ie+1
2903  xt = c(i, j)
2904  IF (xt .GT. 0.) THEN
2905  fx0(i) = q1(i-1)
2906  IF (smt6(i-1) .OR. smt5(i)) THEN
2907  fx1(i) = br(i-1) - xt*b0(i-1)
2908  ELSE IF (smt5(i-1)) THEN
2909  IF (bl(i-1) .GE. 0.) THEN
2910  x2 = bl(i-1)
2911  ELSE
2912  x2 = -bl(i-1)
2913  END IF
2914  IF (br(i-1) .GE. 0.) THEN
2915  y1 = br(i-1)
2916  ELSE
2917  y1 = -br(i-1)
2918  END IF
2919  IF (x2 .GT. y1) THEN
2920  min1 = y1
2921  ELSE
2922  min1 = x2
2923  END IF
2924 ! 2nd order, piece-wise linear
2925  fx1(i) = sign(min1, br(i-1))
2926  END IF
2927  ELSE
2928  fx0(i) = q1(i)
2929  IF (smt6(i) .OR. smt5(i-1)) THEN
2930  fx1(i) = bl(i) + xt*b0(i)
2931  ELSE IF (smt5(i)) THEN
2932  IF (bl(i) .GE. 0.) THEN
2933  x3 = bl(i)
2934  ELSE
2935  x3 = -bl(i)
2936  END IF
2937  IF (br(i) .GE. 0.) THEN
2938  y2 = br(i)
2939  ELSE
2940  y2 = -br(i)
2941  END IF
2942  IF (x3 .GT. y2) THEN
2943  min2 = y2
2944  ELSE
2945  min2 = x3
2946  END IF
2947  fx1(i) = sign(min2, bl(i))
2948  END IF
2949  END IF
2950  IF (xt .GE. 0.) THEN
2951  abs0 = xt
2952  ELSE
2953  abs0 = -xt
2954  END IF
2955  flux(i, j) = fx0(i) + (1.-abs0)*fx1(i)
2956  END DO
2957  ELSE IF (iord .EQ. 4) THEN
2958  DO i=is-1,ie+1
2959  bl(i) = al(i) - q1(i)
2960  br(i) = al(i+1) - q1(i)
2961  b0(i) = bl(i) + br(i)
2962  IF (b0(i) .GE. 0.) THEN
2963  x0 = b0(i)
2964  ELSE
2965  x0 = -b0(i)
2966  END IF
2967  IF (bl(i) - br(i) .GE. 0.) THEN
2968  xt = bl(i) - br(i)
2969  ELSE
2970  xt = -(bl(i)-br(i))
2971  END IF
2972  smt5(i) = x0 .LT. xt
2973  smt6(i) = 3.*x0 .LT. xt
2974  END DO
2975  DO i=is,ie+1
2976  fx1(i) = 0.
2977  END DO
2978 !DEC$ VECTOR ALWAYS
2979  DO i=is,ie+1
2980  IF (c(i, j) .GT. 0.) THEN
2981  fx0(i) = q1(i-1)
2982  IF (smt6(i-1) .OR. smt5(i)) fx1(i) = (1.-c(i, j))*(br(i-1)&
2983 & -c(i, j)*b0(i-1))
2984  ELSE
2985  fx0(i) = q1(i)
2986  IF (smt6(i) .OR. smt5(i-1)) fx1(i) = (1.+c(i, j))*(bl(i)+c&
2987 & (i, j)*b0(i))
2988  END IF
2989  flux(i, j) = fx0(i) + fx1(i)
2990  END DO
2991  ELSE
2992 ! iord = 5 & 6
2993  IF (iord .EQ. 5) THEN
2994  DO i=is-1,ie+1
2995  bl(i) = al(i) - q1(i)
2996  br(i) = al(i+1) - q1(i)
2997  b0(i) = bl(i) + br(i)
2998  smt5(i) = bl(i)*br(i) .LT. 0.
2999  END DO
3000  ELSE
3001  DO i=is-1,ie+1
3002  bl(i) = al(i) - q1(i)
3003  br(i) = al(i+1) - q1(i)
3004  b0(i) = bl(i) + br(i)
3005  IF (3.*b0(i) .GE. 0.) THEN
3006  abs1 = 3.*b0(i)
3007  ELSE
3008  abs1 = -(3.*b0(i))
3009  END IF
3010  IF (bl(i) - br(i) .GE. 0.) THEN
3011  abs4 = bl(i) - br(i)
3012  ELSE
3013  abs4 = -(bl(i)-br(i))
3014  END IF
3015  smt5(i) = abs1 .LT. abs4
3016  END DO
3017  END IF
3018 !DEC$ VECTOR ALWAYS
3019  DO i=is,ie+1
3020  IF (c(i, j) .GT. 0.) THEN
3021  fx1(i) = (1.-c(i, j))*(br(i-1)-c(i, j)*b0(i-1))
3022  flux(i, j) = q1(i-1)
3023  ELSE
3024  fx1(i) = (1.+c(i, j))*(bl(i)+c(i, j)*b0(i))
3025  flux(i, j) = q1(i)
3026  END IF
3027  IF (smt5(i-1) .OR. smt5(i)) flux(i, j) = flux(i, j) + fx1(i)
3028  END DO
3029  END IF
3030  ELSE
3031 ! Monotonic constraints:
3032 ! ord = 8: PPM with Lin's PPM fast monotone constraint
3033 ! ord = 10: PPM with Lin's modification of Huynh 2nd constraint
3034 ! ord = 13: 10 plus positive definite constraint
3035  DO i=is-2,ie+2
3036  xt = 0.25*(q1(i+1)-q1(i-1))
3037  IF (xt .GE. 0.) THEN
3038  x4 = xt
3039  ELSE
3040  x4 = -xt
3041  END IF
3042  IF (q1(i-1) .LT. q1(i)) THEN
3043  IF (q1(i) .LT. q1(i+1)) THEN
3044  max1 = q1(i+1)
3045  ELSE
3046  max1 = q1(i)
3047  END IF
3048  ELSE IF (q1(i-1) .LT. q1(i+1)) THEN
3049  max1 = q1(i+1)
3050  ELSE
3051  max1 = q1(i-1)
3052  END IF
3053  y3 = max1 - q1(i)
3054  IF (q1(i-1) .GT. q1(i)) THEN
3055  IF (q1(i) .GT. q1(i+1)) THEN
3056  min8 = q1(i+1)
3057  ELSE
3058  min8 = q1(i)
3059  END IF
3060  ELSE IF (q1(i-1) .GT. q1(i+1)) THEN
3061  min8 = q1(i+1)
3062  ELSE
3063  min8 = q1(i-1)
3064  END IF
3065  z1 = q1(i) - min8
3066  IF (x4 .GT. y3) THEN
3067  IF (y3 .GT. z1) THEN
3068  min3 = z1
3069  ELSE
3070  min3 = y3
3071  END IF
3072  ELSE IF (x4 .GT. z1) THEN
3073  min3 = z1
3074  ELSE
3075  min3 = x4
3076  END IF
3077  dm(i) = sign(min3, xt)
3078  END DO
3079  DO i=is1,ie1+1
3080  al(i) = 0.5*(q1(i-1)+q1(i)) + r3*(dm(i-1)-dm(i))
3081  END DO
3082  IF (iord .EQ. 8) THEN
3083  DO i=is1,ie1
3084  xt = 2.*dm(i)
3085  IF (xt .GE. 0.) THEN
3086  x5 = xt
3087  ELSE
3088  x5 = -xt
3089  END IF
3090  IF (al(i) - q1(i) .GE. 0.) THEN
3091  y4 = al(i) - q1(i)
3092  ELSE
3093  y4 = -(al(i)-q1(i))
3094  END IF
3095  IF (x5 .GT. y4) THEN
3096  min4 = y4
3097  ELSE
3098  min4 = x5
3099  END IF
3100  bl(i) = -sign(min4, xt)
3101  IF (xt .GE. 0.) THEN
3102  x6 = xt
3103  ELSE
3104  x6 = -xt
3105  END IF
3106  IF (al(i+1) - q1(i) .GE. 0.) THEN
3107  y5 = al(i+1) - q1(i)
3108  ELSE
3109  y5 = -(al(i+1)-q1(i))
3110  END IF
3111  IF (x6 .GT. y5) THEN
3112  min5 = y5
3113  ELSE
3114  min5 = x6
3115  END IF
3116  br(i) = sign(min5, xt)
3117  END DO
3118  ELSE IF (iord .EQ. 11) THEN
3119 ! This is emulation of 2nd van Leer scheme using PPM codes
3120  DO i=is1,ie1
3121  xt = ppm_fac*dm(i)
3122  IF (xt .GE. 0.) THEN
3123  x7 = xt
3124  ELSE
3125  x7 = -xt
3126  END IF
3127  IF (al(i) - q1(i) .GE. 0.) THEN
3128  y6 = al(i) - q1(i)
3129  ELSE
3130  y6 = -(al(i)-q1(i))
3131  END IF
3132  IF (x7 .GT. y6) THEN
3133  min6 = y6
3134  ELSE
3135  min6 = x7
3136  END IF
3137  bl(i) = -sign(min6, xt)
3138  IF (xt .GE. 0.) THEN
3139  x8 = xt
3140  ELSE
3141  x8 = -xt
3142  END IF
3143  IF (al(i+1) - q1(i) .GE. 0.) THEN
3144  y7 = al(i+1) - q1(i)
3145  ELSE
3146  y7 = -(al(i+1)-q1(i))
3147  END IF
3148  IF (x8 .GT. y7) THEN
3149  min7 = y7
3150  ELSE
3151  min7 = x8
3152  END IF
3153  br(i) = sign(min7, xt)
3154  END DO
3155  ELSE
3156  DO i=is1-2,ie1+1
3157  dq(i) = 2.*(q1(i+1)-q1(i))
3158  END DO
3159  DO i=is1,ie1
3160  bl(i) = al(i) - q1(i)
3161  br(i) = al(i+1) - q1(i)
3162  IF (dm(i-1) .GE. 0.) THEN
3163  abs2 = dm(i-1)
3164  ELSE
3165  abs2 = -dm(i-1)
3166  END IF
3167  IF (dm(i) .GE. 0.) THEN
3168  abs5 = dm(i)
3169  ELSE
3170  abs5 = -dm(i)
3171  END IF
3172  IF (dm(i+1) .GE. 0.) THEN
3173  abs7 = dm(i+1)
3174  ELSE
3175  abs7 = -dm(i+1)
3176  END IF
3177  IF (abs2 + abs5 + abs7 .LT. near_zero) THEN
3178  bl(i) = 0.
3179  br(i) = 0.
3180  ELSE
3181  IF (3.*(bl(i)+br(i)) .GE. 0.) THEN
3182  abs3 = 3.*(bl(i)+br(i))
3183  ELSE
3184  abs3 = -(3.*(bl(i)+br(i)))
3185  END IF
3186  IF (bl(i) - br(i) .GE. 0.) THEN
3187  abs6 = bl(i) - br(i)
3188  ELSE
3189  abs6 = -(bl(i)-br(i))
3190  END IF
3191  IF (abs3 .GT. abs6) THEN
3192  pmp_2 = dq(i-1)
3193  lac_2 = pmp_2 - 0.75*dq(i-2)
3194  IF (0. .LT. pmp_2) THEN
3195  IF (pmp_2 .LT. lac_2) THEN
3196  x9 = lac_2
3197  ELSE
3198  x9 = pmp_2
3199  END IF
3200  ELSE IF (0. .LT. lac_2) THEN
3201  x9 = lac_2
3202  ELSE
3203  x9 = 0.
3204  END IF
3205  IF (0. .GT. pmp_2) THEN
3206  IF (pmp_2 .GT. lac_2) THEN
3207  y14 = lac_2
3208  ELSE
3209  y14 = pmp_2
3210  END IF
3211  ELSE IF (0. .GT. lac_2) THEN
3212  y14 = lac_2
3213  ELSE
3214  y14 = 0.
3215  END IF
3216  IF (br(i) .LT. y14) THEN
3217  y8 = y14
3218  ELSE
3219  y8 = br(i)
3220  END IF
3221  IF (x9 .GT. y8) THEN
3222  br(i) = y8
3223  ELSE
3224  br(i) = x9
3225  END IF
3226  pmp_1 = -dq(i)
3227  lac_1 = pmp_1 + 0.75*dq(i+1)
3228  IF (0. .LT. pmp_1) THEN
3229  IF (pmp_1 .LT. lac_1) THEN
3230  x10 = lac_1
3231  ELSE
3232  x10 = pmp_1
3233  END IF
3234  ELSE IF (0. .LT. lac_1) THEN
3235  x10 = lac_1
3236  ELSE
3237  x10 = 0.
3238  END IF
3239  IF (0. .GT. pmp_1) THEN
3240  IF (pmp_1 .GT. lac_1) THEN
3241  y15 = lac_1
3242  ELSE
3243  y15 = pmp_1
3244  END IF
3245  ELSE IF (0. .GT. lac_1) THEN
3246  y15 = lac_1
3247  ELSE
3248  y15 = 0.
3249  END IF
3250  IF (bl(i) .LT. y15) THEN
3251  y9 = y15
3252  ELSE
3253  y9 = bl(i)
3254  END IF
3255  IF (x10 .GT. y9) THEN
3256  bl(i) = y9
3257  ELSE
3258  bl(i) = x10
3259  END IF
3260  END IF
3261  END IF
3262  END DO
3263  END IF
3264 ! Positive definite constraint:
3265  IF (iord .EQ. 9 .OR. iord .EQ. 13) THEN
3266  arg1 = ie1 - is1 + 1
3267  CALL pert_ppm(arg1, q1(is1:ie1), bl(is1:ie1), br(is1:ie1), 0)
3268  END IF
3269  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
3270  IF (is .EQ. 1) THEN
3271  bl(0) = s14*dm(-1) + s11*(q1(-1)-q1(0))
3272  xt = 0.5*(((2.*dxa(0, j)+dxa(-1, j))*q1(0)-dxa(0, j)*q1(-1))&
3273 & /(dxa(-1, j)+dxa(0, j))+((2.*dxa(1, j)+dxa(2, j))*q1(1)-&
3274 & dxa(1, j)*q1(2))/(dxa(1, j)+dxa(2, j)))
3275  IF (q1(1) .GT. q1(2)) THEN
3276  z2 = q1(2)
3277  ELSE
3278  z2 = q1(1)
3279  END IF
3280  IF (q1(-1) .GT. q1(0)) THEN
3281  IF (q1(0) .GT. z2) THEN
3282  y10 = z2
3283  ELSE
3284  y10 = q1(0)
3285  END IF
3286  ELSE IF (q1(-1) .GT. z2) THEN
3287  y10 = z2
3288  ELSE
3289  y10 = q1(-1)
3290  END IF
3291  IF (xt .LT. y10) THEN
3292  xt = y10
3293  ELSE
3294  xt = xt
3295  END IF
3296  IF (q1(1) .LT. q1(2)) THEN
3297  z3 = q1(2)
3298  ELSE
3299  z3 = q1(1)
3300  END IF
3301  IF (q1(-1) .LT. q1(0)) THEN
3302  IF (q1(0) .LT. z3) THEN
3303  y11 = z3
3304  ELSE
3305  y11 = q1(0)
3306  END IF
3307  ELSE IF (q1(-1) .LT. z3) THEN
3308  y11 = z3
3309  ELSE
3310  y11 = q1(-1)
3311  END IF
3312  IF (xt .GT. y11) THEN
3313  xt = y11
3314  ELSE
3315  xt = xt
3316  END IF
3317 ! endif
3318  br(0) = xt - q1(0)
3319  bl(1) = xt - q1(1)
3320  xt = s15*q1(1) + s11*q1(2) - s14*dm(2)
3321  br(1) = xt - q1(1)
3322  bl(2) = xt - q1(2)
3323  br(2) = al(3) - q1(2)
3324  CALL pert_ppm(3, q1(0:2), bl(0:2), br(0:2), 1)
3325  END IF
3326  IF (ie + 1 .EQ. npx) THEN
3327  bl(npx-2) = al(npx-2) - q1(npx-2)
3328  xt = s15*q1(npx-1) + s11*q1(npx-2) + s14*dm(npx-2)
3329  br(npx-2) = xt - q1(npx-2)
3330  bl(npx-1) = xt - q1(npx-1)
3331  xt = 0.5*(((2.*dxa(npx-1, j)+dxa(npx-2, j))*q1(npx-1)-dxa(&
3332 & npx-1, j)*q1(npx-2))/(dxa(npx-2, j)+dxa(npx-1, j))+((2.*&
3333 & dxa(npx, j)+dxa(npx+1, j))*q1(npx)-dxa(npx, j)*q1(npx+1))/&
3334 & (dxa(npx, j)+dxa(npx+1, j)))
3335  IF (q1(npx) .GT. q1(npx+1)) THEN
3336  z4 = q1(npx+1)
3337  ELSE
3338  z4 = q1(npx)
3339  END IF
3340  IF (q1(npx-2) .GT. q1(npx-1)) THEN
3341  IF (q1(npx-1) .GT. z4) THEN
3342  y12 = z4
3343  ELSE
3344  y12 = q1(npx-1)
3345  END IF
3346  ELSE IF (q1(npx-2) .GT. z4) THEN
3347  y12 = z4
3348  ELSE
3349  y12 = q1(npx-2)
3350  END IF
3351  IF (xt .LT. y12) THEN
3352  xt = y12
3353  ELSE
3354  xt = xt
3355  END IF
3356  IF (q1(npx) .LT. q1(npx+1)) THEN
3357  z5 = q1(npx+1)
3358  ELSE
3359  z5 = q1(npx)
3360  END IF
3361  IF (q1(npx-2) .LT. q1(npx-1)) THEN
3362  IF (q1(npx-1) .LT. z5) THEN
3363  y13 = z5
3364  ELSE
3365  y13 = q1(npx-1)
3366  END IF
3367  ELSE IF (q1(npx-2) .LT. z5) THEN
3368  y13 = z5
3369  ELSE
3370  y13 = q1(npx-2)
3371  END IF
3372  IF (xt .GT. y13) THEN
3373  xt = y13
3374  ELSE
3375  xt = xt
3376  END IF
3377 ! endif
3378  br(npx-1) = xt - q1(npx-1)
3379  bl(npx) = xt - q1(npx)
3380  br(npx) = s11*(q1(npx+1)-q1(npx)) - s14*dm(npx+1)
3381  CALL pert_ppm(3, q1(npx-2:npx), bl(npx-2:npx), br(npx-2:npx)&
3382 & , 1)
3383  END IF
3384  END IF
3385  DO i=is,ie+1
3386  IF (c(i, j) .GT. 0.) THEN
3387  flux(i, j) = q1(i-1) + (1.-c(i, j))*(br(i-1)-c(i, j)*(bl(i-1&
3388 & )+br(i-1)))
3389  ELSE
3390  flux(i, j) = q1(i) + (1.+c(i, j))*(bl(i)+c(i, j)*(bl(i)+br(i&
3391 & )))
3392  END IF
3393  END DO
3394  END IF
3395  END DO
3396  END SUBROUTINE xppm
3397 ! Differentiation of yppm in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_core_
3398 !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_core
3399 !_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.ge
3400 !opk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamics_mo
3401 !d.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_mod.c
3402 !2l_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.map
3403 !_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_pro
3404 !file_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 fv
3405 !_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
3406 !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_
3407 !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_
3408 !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_ut
3409 !ils_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_core
3410 !_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.
3411 !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.comput
3412 !e_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 t
3413 !p_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle_dis
3414 !t sw_core_mod.edge_interpolate4)):
3415 ! gradient of useful results: q flux c
3416 ! with respect to varying inputs: q flux c
3417  SUBROUTINE yppm_adm(flux, flux_ad, q, q_ad, c, c_ad, jord, ifirst, &
3418 & ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
3419  IMPLICIT NONE
3420 ! Compute domain
3421  INTEGER, INTENT(IN) :: ifirst, ilast
3422  INTEGER, INTENT(IN) :: isd, ied, js, je, jsd, jed
3423  INTEGER, INTENT(IN) :: jord
3424  INTEGER, INTENT(IN) :: npx, npy
3425  REAL, INTENT(IN) :: q(ifirst:ilast, jsd:jed)
3426  REAL :: q_ad(ifirst:ilast, jsd:jed)
3427 ! Courant number
3428  REAL, INTENT(IN) :: c(isd:ied, js:je+1)
3429  REAL :: c_ad(isd:ied, js:je+1)
3430 ! Flux
3431  REAL :: flux(ifirst:ilast, js:je+1)
3432  REAL :: flux_ad(ifirst:ilast, js:je+1)
3433  REAL, INTENT(IN) :: dya(isd:ied, jsd:jed)
3434  LOGICAL, INTENT(IN) :: nested
3435  INTEGER, INTENT(IN) :: grid_type
3436 ! Local:
3437  REAL :: dm(ifirst:ilast, js-2:je+2)
3438  REAL :: dm_ad(ifirst:ilast, js-2:je+2)
3439  REAL :: al(ifirst:ilast, js-1:je+2)
3440  REAL :: al_ad(ifirst:ilast, js-1:je+2)
3441  REAL, DIMENSION(ifirst:ilast, js-1:je+1) :: bl, br, b0
3442  REAL, DIMENSION(ifirst:ilast, js-1:je+1) :: bl_ad, br_ad, b0_ad
3443  REAL :: dq(ifirst:ilast, js-3:je+2)
3444  REAL :: dq_ad(ifirst:ilast, js-3:je+2)
3445  REAL, DIMENSION(ifirst:ilast) :: fx0, fx1
3446  REAL, DIMENSION(ifirst:ilast) :: fx0_ad, fx1_ad
3447  LOGICAL, DIMENSION(ifirst:ilast, js-1:je+1) :: smt5, smt6
3448  REAL :: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1
3449  REAL :: xt_ad, qtmp_ad, pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
3450  INTEGER :: i, j, js1, je3, je1
3451  INTRINSIC max
3452  INTRINSIC min
3453  INTRINSIC abs
3454  INTRINSIC sign
3455  REAL :: min1
3456  REAL :: min1_ad
3457  REAL :: min2
3458  REAL :: min2_ad
3459  REAL :: abs0
3460  REAL :: abs0_ad
3461  REAL :: abs1
3462  REAL :: min3
3463  REAL :: min3_ad
3464  REAL :: min4
3465  REAL :: min4_ad
3466  REAL :: min5
3467  REAL :: min5_ad
3468  REAL :: min6
3469  REAL :: min6_ad
3470  REAL :: min7
3471  REAL :: min7_ad
3472  REAL :: abs2
3473  REAL :: abs3
3474  REAL :: abs4
3475  REAL :: max1
3476  REAL :: max1_ad
3477  REAL :: min8
3478  REAL :: min8_ad
3479  REAL :: abs5
3480  REAL :: abs6
3481  REAL :: abs7
3482  INTEGER :: arg1
3483  REAL :: temp_ad
3484  REAL :: temp_ad0
3485  REAL :: temp_ad1
3486  REAL :: temp_ad2
3487  REAL :: temp
3488  REAL :: temp_ad3
3489  REAL :: temp_ad4
3490  REAL :: temp0
3491  REAL :: temp_ad5
3492  REAL :: temp_ad6
3493  REAL :: temp_ad7
3494  REAL :: temp_ad8
3495  REAL :: temp_ad9
3496  REAL :: temp_ad10
3497  REAL :: temp_ad11
3498  REAL :: temp_ad12
3499  REAL :: x1_ad
3500  REAL :: y1_ad
3501  REAL :: x2_ad
3502  REAL :: y2_ad
3503  REAL :: temp_ad13
3504  REAL :: temp_ad14
3505  REAL :: temp_ad15
3506  REAL :: temp_ad16
3507  REAL :: x3_ad
3508  REAL :: y3_ad
3509  REAL :: z1_ad
3510  REAL :: x4_ad
3511  REAL :: y4_ad
3512  REAL :: x5_ad
3513  REAL :: y5_ad
3514  REAL :: x6_ad
3515  REAL :: y6_ad
3516  REAL :: x7_ad
3517  REAL :: y7_ad
3518  REAL :: x8_ad
3519  REAL :: y14_ad
3520  REAL :: y8_ad
3521  REAL :: x9_ad
3522  REAL :: y15_ad
3523  REAL :: y9_ad
3524  REAL :: temp_ad17
3525  REAL :: temp_ad18
3526  REAL :: z2_ad
3527  REAL :: y10_ad
3528  REAL :: z3_ad
3529  REAL :: y11_ad
3530  REAL :: temp_ad19
3531  REAL :: temp_ad20
3532  REAL :: z4_ad
3533  REAL :: y12_ad
3534  REAL :: z5_ad
3535  REAL :: y13_ad
3536  REAL :: temp1
3537  REAL :: temp_ad21
3538  REAL :: temp_ad22
3539  REAL :: temp2
3540  REAL :: temp_ad23
3541  REAL :: temp_ad24
3542  INTEGER :: branch
3543  REAL :: x9
3544  REAL :: x8
3545  REAL :: x7
3546  REAL :: x6
3547  REAL :: x5
3548  REAL :: x4
3549  REAL :: x3
3550  REAL :: x2
3551  REAL :: x1
3552  REAL :: y15
3553  REAL :: y14
3554  REAL :: y13
3555  REAL :: y12
3556  REAL :: y11
3557  REAL :: y10
3558  REAL :: z5
3559  REAL :: z4
3560  REAL :: z3
3561  REAL :: z2
3562  REAL :: z1
3563  REAL :: y9
3564  REAL :: y8
3565  REAL :: y7
3566  REAL :: y6
3567  REAL :: y5
3568  REAL :: y4
3569  REAL :: y3
3570  REAL :: y2
3571  REAL :: y1
3572  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
3573  IF (3 .LT. js - 1) THEN
3574  js1 = js - 1
3575  ELSE
3576  js1 = 3
3577  END IF
3578  IF (npy - 2 .GT. je + 2) THEN
3579  je3 = je + 2
3580  ELSE
3581  je3 = npy - 2
3582  END IF
3583  IF (npy - 3 .GT. je + 1) THEN
3584  CALL pushcontrol1b(1)
3585  je1 = je + 1
3586  ELSE
3587  CALL pushcontrol1b(1)
3588  je1 = npy - 3
3589  END IF
3590  ELSE
3591  CALL pushcontrol1b(0)
3592 ! Nested grid OR Doubly periodic domain:
3593  js1 = js - 1
3594  je3 = je + 2
3595  je1 = je + 1
3596  END IF
3597  IF (jord .LT. 8 .OR. jord .EQ. 333) THEN
3598  DO j=js1,je3
3599  DO i=ifirst,ilast
3600  al(i, j) = p1*(q(i, j-1)+q(i, j)) + p2*(q(i, j-2)+q(i, j+1))
3601  END DO
3602  END DO
3603  IF (jord .EQ. 7) THEN
3604  DO j=js1,je3
3605  DO i=ifirst,ilast
3606  IF (al(i, j) .LT. 0.) THEN
3607  al(i, j) = 0.5*(q(i, j)+q(i, j+1))
3608  CALL pushcontrol1b(1)
3609  ELSE
3610  CALL pushcontrol1b(0)
3611  END IF
3612  END DO
3613  END DO
3614  CALL pushcontrol1b(0)
3615  ELSE
3616  CALL pushcontrol1b(1)
3617  END IF
3618  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
3619  IF (js .EQ. 1) THEN
3620  DO i=ifirst,ilast
3621  al(i, 0) = c1*q(i, -2) + c2*q(i, -1) + c3*q(i, 0)
3622  al(i, 1) = 0.5*(((2.*dya(i, 0)+dya(i, -1))*q(i, 0)-dya(i, 0)&
3623 & *q(i, -1))/(dya(i, -1)+dya(i, 0))+((2.*dya(i, 1)+dya(i, 2)&
3624 & )*q(i, 1)-dya(i, 1)*q(i, 2))/(dya(i, 1)+dya(i, 2)))
3625  al(i, 2) = c3*q(i, 1) + c2*q(i, 2) + c1*q(i, 3)
3626  END DO
3627  IF (jord .EQ. 7) THEN
3628  DO i=ifirst,ilast
3629  IF (0. .LT. al(i, 0)) THEN
3630  CALL pushcontrol1b(0)
3631  al(i, 0) = al(i, 0)
3632  ELSE
3633  al(i, 0) = 0.
3634  CALL pushcontrol1b(1)
3635  END IF
3636  IF (0. .LT. al(i, 1)) THEN
3637  CALL pushcontrol1b(0)
3638  al(i, 1) = al(i, 1)
3639  ELSE
3640  al(i, 1) = 0.
3641  CALL pushcontrol1b(1)
3642  END IF
3643  IF (0. .LT. al(i, 2)) THEN
3644  CALL pushcontrol1b(0)
3645  al(i, 2) = al(i, 2)
3646  ELSE
3647  al(i, 2) = 0.
3648  CALL pushcontrol1b(1)
3649  END IF
3650  END DO
3651  CALL pushcontrol2b(0)
3652  ELSE
3653  CALL pushcontrol2b(1)
3654  END IF
3655  ELSE
3656  CALL pushcontrol2b(2)
3657  END IF
3658  IF (je + 1 .EQ. npy) THEN
3659  DO i=ifirst,ilast
3660  al(i, npy-1) = c1*q(i, npy-3) + c2*q(i, npy-2) + c3*q(i, npy&
3661 & -1)
3662  al(i, npy) = 0.5*(((2.*dya(i, npy-1)+dya(i, npy-2))*q(i, npy&
3663 & -1)-dya(i, npy-1)*q(i, npy-2))/(dya(i, npy-2)+dya(i, npy-1&
3664 & ))+((2.*dya(i, npy)+dya(i, npy+1))*q(i, npy)-dya(i, npy)*q&
3665 & (i, npy+1))/(dya(i, npy)+dya(i, npy+1)))
3666  al(i, npy+1) = c3*q(i, npy) + c2*q(i, npy+1) + c1*q(i, npy+2&
3667 & )
3668  END DO
3669  IF (jord .EQ. 7) THEN
3670  DO i=ifirst,ilast
3671  IF (0. .LT. al(i, npy-1)) THEN
3672  CALL pushcontrol1b(0)
3673  al(i, npy-1) = al(i, npy-1)
3674  ELSE
3675  al(i, npy-1) = 0.
3676  CALL pushcontrol1b(1)
3677  END IF
3678  IF (0. .LT. al(i, npy)) THEN
3679  CALL pushcontrol1b(0)
3680  al(i, npy) = al(i, npy)
3681  ELSE
3682  al(i, npy) = 0.
3683  CALL pushcontrol1b(1)
3684  END IF
3685  IF (0. .LT. al(i, npy+1)) THEN
3686  CALL pushcontrol1b(0)
3687  al(i, npy+1) = al(i, npy+1)
3688  ELSE
3689  al(i, npy+1) = 0.
3690  CALL pushcontrol1b(1)
3691  END IF
3692  END DO
3693  CALL pushcontrol2b(0)
3694  ELSE
3695  CALL pushcontrol2b(1)
3696  END IF
3697  ELSE
3698  CALL pushcontrol2b(2)
3699  END IF
3700  ELSE
3701  CALL pushcontrol2b(3)
3702  END IF
3703  IF (jord .EQ. 1) THEN
3704  DO j=js,je+1
3705  DO i=ifirst,ilast
3706  IF (c(i, j) .GT. 0.) THEN
3707  CALL pushcontrol1b(1)
3708  ELSE
3709  CALL pushcontrol1b(0)
3710  END IF
3711  END DO
3712  END DO
3713  DO j=je+1,js,-1
3714  DO i=ilast,ifirst,-1
3715  CALL popcontrol1b(branch)
3716  IF (branch .EQ. 0) THEN
3717  q_ad(i, j) = q_ad(i, j) + flux_ad(i, j)
3718  flux_ad(i, j) = 0.0
3719  ELSE
3720  q_ad(i, j-1) = q_ad(i, j-1) + flux_ad(i, j)
3721  flux_ad(i, j) = 0.0
3722  END IF
3723  END DO
3724  END DO
3725  al_ad = 0.0
3726  ELSE IF (jord .EQ. 2) THEN
3727 ! Perfectly linear scheme
3728 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
3729  DO j=js,je+1
3730 !DEC$ VECTOR ALWAYS
3731  DO i=ifirst,ilast
3732  xt = c(i, j)
3733  IF (xt .GT. 0.) THEN
3734  CALL pushcontrol1b(1)
3735  ELSE
3736  CALL pushcontrol1b(0)
3737  END IF
3738  END DO
3739  END DO
3740  al_ad = 0.0
3741  DO j=je+1,js,-1
3742  DO i=ilast,ifirst,-1
3743  CALL popcontrol1b(branch)
3744  IF (branch .EQ. 0) THEN
3745  xt = c(i, j)
3746  qtmp = q(i, j)
3747  temp0 = al(i, j) + al(i, j+1) - 2*qtmp
3748  temp_ad5 = (xt+1.)*flux_ad(i, j)
3749  temp_ad6 = xt*temp_ad5
3750  qtmp_ad = flux_ad(i, j) - temp_ad5 - 2*temp_ad6
3751  xt_ad = temp0*temp_ad5 + (al(i, j)-qtmp+xt*temp0)*flux_ad(&
3752 & i, j)
3753  al_ad(i, j) = al_ad(i, j) + temp_ad6 + temp_ad5
3754  al_ad(i, j+1) = al_ad(i, j+1) + temp_ad6
3755  flux_ad(i, j) = 0.0
3756  q_ad(i, j) = q_ad(i, j) + qtmp_ad
3757  ELSE
3758  xt = c(i, j)
3759  qtmp = q(i, j-1)
3760  temp = al(i, j-1) + al(i, j) - 2*qtmp
3761  temp_ad3 = (1.-xt)*flux_ad(i, j)
3762  temp_ad4 = -(xt*temp_ad3)
3763  qtmp_ad = flux_ad(i, j) - temp_ad3 - 2*temp_ad4
3764  xt_ad = -(temp*temp_ad3) - (al(i, j)-qtmp-xt*temp)*flux_ad&
3765 & (i, j)
3766  al_ad(i, j) = al_ad(i, j) + temp_ad4 + temp_ad3
3767  al_ad(i, j-1) = al_ad(i, j-1) + temp_ad4
3768  flux_ad(i, j) = 0.0
3769  q_ad(i, j-1) = q_ad(i, j-1) + qtmp_ad
3770  END IF
3771  c_ad(i, j) = c_ad(i, j) + xt_ad
3772  END DO
3773  END DO
3774  ELSE IF (jord .EQ. 333) THEN
3775 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
3776  DO j=js,je+1
3777 !DEC$ VECTOR ALWAYS
3778  DO i=ifirst,ilast
3779  xt = c(i, j)
3780  IF (xt .GT. 0.) THEN
3781  CALL pushcontrol1b(1)
3782  ELSE
3783  CALL pushcontrol1b(0)
3784  END IF
3785  END DO
3786  END DO
3787  DO j=je+1,js,-1
3788  DO i=ilast,ifirst,-1
3789  CALL popcontrol1b(branch)
3790  IF (branch .EQ. 0) THEN
3791  xt = c(i, j)
3792  temp_ad10 = flux_ad(i, j)/6.0
3793  temp_ad11 = -(0.5*xt*flux_ad(i, j))
3794  temp_ad12 = xt**2*flux_ad(i, j)/6.0
3795  q_ad(i, j-1) = q_ad(i, j-1) + temp_ad12 - temp_ad11 + 2.0*&
3796 & temp_ad10
3797  q_ad(i, j) = q_ad(i, j) + temp_ad11 - 2.0*temp_ad12 + 5.0*&
3798 & temp_ad10
3799  q_ad(i, j+1) = q_ad(i, j+1) + temp_ad12 - temp_ad10
3800  xt_ad = ((q(i, j+1)-2.0*q(i, j)+q(i, j-1))*2*xt/6.0-0.5*(q&
3801 & (i, j)-q(i, j-1)))*flux_ad(i, j)
3802  flux_ad(i, j) = 0.0
3803  ELSE
3804  xt = c(i, j)
3805  temp_ad7 = flux_ad(i, j)/6.0
3806  temp_ad8 = -(0.5*xt*flux_ad(i, j))
3807  temp_ad9 = xt**2*flux_ad(i, j)/6.0
3808  q_ad(i, j) = q_ad(i, j) + temp_ad9 + temp_ad8 + 2.0*&
3809 & temp_ad7
3810  q_ad(i, j-1) = q_ad(i, j-1) + 5.0*temp_ad7 - temp_ad8 - &
3811 & 2.0*temp_ad9
3812  q_ad(i, j-2) = q_ad(i, j-2) + temp_ad9 - temp_ad7
3813  xt_ad = ((q(i, j)-2.0*q(i, j-1)+q(i, j-2))*2*xt/6.0-0.5*(q&
3814 & (i, j)-q(i, j-1)))*flux_ad(i, j)
3815  flux_ad(i, j) = 0.0
3816  END IF
3817  c_ad(i, j) = c_ad(i, j) + xt_ad
3818  END DO
3819  END DO
3820  al_ad = 0.0
3821  ELSE IF (jord .EQ. 3) THEN
3822  DO j=js-1,je+1
3823  DO i=ifirst,ilast
3824  bl(i, j) = al(i, j) - q(i, j)
3825  br(i, j) = al(i, j+1) - q(i, j)
3826  b0(i, j) = bl(i, j) + br(i, j)
3827  IF (b0(i, j) .GE. 0.) THEN
3828  x0 = b0(i, j)
3829  ELSE
3830  x0 = -b0(i, j)
3831  END IF
3832  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
3833  xt = bl(i, j) - br(i, j)
3834  ELSE
3835  xt = -(bl(i, j)-br(i, j))
3836  END IF
3837  smt5(i, j) = x0 .LT. xt
3838  smt6(i, j) = 3.*x0 .LT. xt
3839  END DO
3840  END DO
3841  DO j=js,je+1
3842  DO i=ifirst,ilast
3843  CALL pushrealarray_adm(fx1(i))
3844  fx1(i) = 0.
3845  END DO
3846  DO i=ifirst,ilast
3847  xt = c(i, j)
3848  IF (xt .GT. 0.) THEN
3849  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
3850  CALL pushrealarray_adm(fx1(i))
3851  fx1(i) = br(i, j-1) - xt*b0(i, j-1)
3852  CALL pushcontrol3b(5)
3853  ELSE IF (smt5(i, j-1)) THEN
3854  IF (bl(i, j-1) .GE. 0.) THEN
3855  x1 = bl(i, j-1)
3856  CALL pushcontrol1b(0)
3857  ELSE
3858  x1 = -bl(i, j-1)
3859  CALL pushcontrol1b(1)
3860  END IF
3861  IF (br(i, j-1) .GE. 0.) THEN
3862  y1 = br(i, j-1)
3863  CALL pushcontrol1b(0)
3864  ELSE
3865  y1 = -br(i, j-1)
3866  CALL pushcontrol1b(1)
3867  END IF
3868  IF (x1 .GT. y1) THEN
3869  CALL pushrealarray_adm(min1)
3870  min1 = y1
3871  CALL pushcontrol1b(0)
3872  ELSE
3873  CALL pushrealarray_adm(min1)
3874  min1 = x1
3875  CALL pushcontrol1b(1)
3876  END IF
3877 ! both up-downwind sides are noisy; 2nd order, piece-wise linear
3878  CALL pushrealarray_adm(fx1(i))
3879  fx1(i) = sign(min1, br(i, j-1))
3880  CALL pushcontrol3b(4)
3881  ELSE
3882  CALL pushcontrol3b(3)
3883  END IF
3884  ELSE IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
3885  CALL pushrealarray_adm(fx1(i))
3886  fx1(i) = bl(i, j) + xt*b0(i, j)
3887  CALL pushcontrol3b(2)
3888  ELSE IF (smt5(i, j)) THEN
3889  IF (bl(i, j) .GE. 0.) THEN
3890  x2 = bl(i, j)
3891  CALL pushcontrol1b(0)
3892  ELSE
3893  x2 = -bl(i, j)
3894  CALL pushcontrol1b(1)
3895  END IF
3896  IF (br(i, j) .GE. 0.) THEN
3897  y2 = br(i, j)
3898  CALL pushcontrol1b(0)
3899  ELSE
3900  y2 = -br(i, j)
3901  CALL pushcontrol1b(1)
3902  END IF
3903  IF (x2 .GT. y2) THEN
3904  CALL pushrealarray_adm(min2)
3905  min2 = y2
3906  CALL pushcontrol1b(0)
3907  ELSE
3908  CALL pushrealarray_adm(min2)
3909  min2 = x2
3910  CALL pushcontrol1b(1)
3911  END IF
3912  CALL pushrealarray_adm(fx1(i))
3913  fx1(i) = sign(min2, bl(i, j))
3914  CALL pushcontrol3b(1)
3915  ELSE
3916  CALL pushcontrol3b(0)
3917  END IF
3918  IF (xt .GE. 0.) THEN
3919  CALL pushrealarray_adm(abs0)
3920  abs0 = xt
3921  CALL pushcontrol1b(0)
3922  ELSE
3923  CALL pushrealarray_adm(abs0)
3924  abs0 = -xt
3925  CALL pushcontrol1b(1)
3926  END IF
3927  END DO
3928  END DO
3929  bl_ad = 0.0
3930  br_ad = 0.0
3931  b0_ad = 0.0
3932  fx0_ad = 0.0
3933  fx1_ad = 0.0
3934  DO j=je+1,js,-1
3935  DO i=ilast,ifirst,-1
3936  fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
3937  abs0_ad = -(fx1(i)*flux_ad(i, j))
3938  fx1_ad(i) = fx1_ad(i) + (1.-abs0)*flux_ad(i, j)
3939  flux_ad(i, j) = 0.0
3940  xt = c(i, j)
3941  CALL popcontrol1b(branch)
3942  IF (branch .EQ. 0) THEN
3943  CALL poprealarray_adm(abs0)
3944  xt_ad = abs0_ad
3945  ELSE
3946  CALL poprealarray_adm(abs0)
3947  xt_ad = -abs0_ad
3948  END IF
3949  CALL popcontrol3b(branch)
3950  IF (branch .LT. 3) THEN
3951  IF (branch .NE. 0) THEN
3952  IF (branch .EQ. 1) THEN
3953  CALL poprealarray_adm(fx1(i))
3954  min2_ad = sign(1.d0, min2*bl(i, j))*fx1_ad(i)
3955  fx1_ad(i) = 0.0
3956  CALL popcontrol1b(branch)
3957  IF (branch .EQ. 0) THEN
3958  CALL poprealarray_adm(min2)
3959  y2_ad = min2_ad
3960  x2_ad = 0.0
3961  ELSE
3962  CALL poprealarray_adm(min2)
3963  x2_ad = min2_ad
3964  y2_ad = 0.0
3965  END IF
3966  CALL popcontrol1b(branch)
3967  IF (branch .EQ. 0) THEN
3968  br_ad(i, j) = br_ad(i, j) + y2_ad
3969  ELSE
3970  br_ad(i, j) = br_ad(i, j) - y2_ad
3971  END IF
3972  CALL popcontrol1b(branch)
3973  IF (branch .EQ. 0) THEN
3974  bl_ad(i, j) = bl_ad(i, j) + x2_ad
3975  ELSE
3976  bl_ad(i, j) = bl_ad(i, j) - x2_ad
3977  END IF
3978  ELSE
3979  CALL poprealarray_adm(fx1(i))
3980  bl_ad(i, j) = bl_ad(i, j) + fx1_ad(i)
3981  xt_ad = xt_ad + b0(i, j)*fx1_ad(i)
3982  b0_ad(i, j) = b0_ad(i, j) + xt*fx1_ad(i)
3983  fx1_ad(i) = 0.0
3984  END IF
3985  END IF
3986  q_ad(i, j) = q_ad(i, j) + fx0_ad(i)
3987  fx0_ad(i) = 0.0
3988  ELSE
3989  IF (branch .NE. 3) THEN
3990  IF (branch .EQ. 4) THEN
3991  CALL poprealarray_adm(fx1(i))
3992  min1_ad = sign(1.d0, min1*br(i, j-1))*fx1_ad(i)
3993  fx1_ad(i) = 0.0
3994  CALL popcontrol1b(branch)
3995  IF (branch .EQ. 0) THEN
3996  CALL poprealarray_adm(min1)
3997  y1_ad = min1_ad
3998  x1_ad = 0.0
3999  ELSE
4000  CALL poprealarray_adm(min1)
4001  x1_ad = min1_ad
4002  y1_ad = 0.0
4003  END IF
4004  CALL popcontrol1b(branch)
4005  IF (branch .EQ. 0) THEN
4006  br_ad(i, j-1) = br_ad(i, j-1) + y1_ad
4007  ELSE
4008  br_ad(i, j-1) = br_ad(i, j-1) - y1_ad
4009  END IF
4010  CALL popcontrol1b(branch)
4011  IF (branch .EQ. 0) THEN
4012  bl_ad(i, j-1) = bl_ad(i, j-1) + x1_ad
4013  ELSE
4014  bl_ad(i, j-1) = bl_ad(i, j-1) - x1_ad
4015  END IF
4016  ELSE
4017  CALL poprealarray_adm(fx1(i))
4018  br_ad(i, j-1) = br_ad(i, j-1) + fx1_ad(i)
4019  xt_ad = xt_ad - b0(i, j-1)*fx1_ad(i)
4020  b0_ad(i, j-1) = b0_ad(i, j-1) - xt*fx1_ad(i)
4021  fx1_ad(i) = 0.0
4022  END IF
4023  END IF
4024  q_ad(i, j-1) = q_ad(i, j-1) + fx0_ad(i)
4025  fx0_ad(i) = 0.0
4026  END IF
4027  c_ad(i, j) = c_ad(i, j) + xt_ad
4028  END DO
4029  DO i=ilast,ifirst,-1
4030  CALL poprealarray_adm(fx1(i))
4031  fx1_ad(i) = 0.0
4032  END DO
4033  END DO
4034  al_ad = 0.0
4035  DO j=je+1,js-1,-1
4036  DO i=ilast,ifirst,-1
4037  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
4038  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
4039  b0_ad(i, j) = 0.0
4040  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
4041  q_ad(i, j) = q_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
4042  br_ad(i, j) = 0.0
4043  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
4044  bl_ad(i, j) = 0.0
4045  END DO
4046  END DO
4047  ELSE IF (jord .EQ. 4) THEN
4048  DO j=js-1,je+1
4049  DO i=ifirst,ilast
4050  bl(i, j) = al(i, j) - q(i, j)
4051  br(i, j) = al(i, j+1) - q(i, j)
4052  b0(i, j) = bl(i, j) + br(i, j)
4053  IF (b0(i, j) .GE. 0.) THEN
4054  x0 = b0(i, j)
4055  ELSE
4056  x0 = -b0(i, j)
4057  END IF
4058  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
4059  xt = bl(i, j) - br(i, j)
4060  ELSE
4061  xt = -(bl(i, j)-br(i, j))
4062  END IF
4063  smt5(i, j) = x0 .LT. xt
4064  smt6(i, j) = 3.*x0 .LT. xt
4065  END DO
4066  END DO
4067  DO j=js,je+1
4068 !DEC$ VECTOR ALWAYS
4069  DO i=ifirst,ilast
4070  IF (c(i, j) .GT. 0.) THEN
4071  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
4072  CALL pushcontrol2b(0)
4073  ELSE
4074  CALL pushcontrol2b(1)
4075  END IF
4076  ELSE IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
4077  CALL pushcontrol2b(2)
4078  ELSE
4079  CALL pushcontrol2b(3)
4080  END IF
4081  END DO
4082  END DO
4083  bl_ad = 0.0
4084  br_ad = 0.0
4085  b0_ad = 0.0
4086  fx0_ad = 0.0
4087  fx1_ad = 0.0
4088  DO j=je+1,js,-1
4089  DO i=ilast,ifirst,-1
4090  fx0_ad(i) = fx0_ad(i) + flux_ad(i, j)
4091  fx1_ad(i) = fx1_ad(i) + flux_ad(i, j)
4092  flux_ad(i, j) = 0.0
4093  CALL popcontrol2b(branch)
4094  IF (branch .LT. 2) THEN
4095  IF (branch .EQ. 0) THEN
4096  temp_ad13 = (1.-c(i, j))*fx1_ad(i)
4097  c_ad(i, j) = c_ad(i, j) - b0(i, j-1)*temp_ad13 - (br(i, &
4098 & j-1)-c(i, j)*b0(i, j-1))*fx1_ad(i)
4099  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad13
4100  b0_ad(i, j-1) = b0_ad(i, j-1) - c(i, j)*temp_ad13
4101  fx1_ad(i) = 0.0
4102  END IF
4103  q_ad(i, j-1) = q_ad(i, j-1) + fx0_ad(i)
4104  fx0_ad(i) = 0.0
4105  ELSE
4106  IF (branch .EQ. 2) THEN
4107  temp_ad14 = (c(i, j)+1.)*fx1_ad(i)
4108  c_ad(i, j) = c_ad(i, j) + b0(i, j)*temp_ad14 + (bl(i, j)&
4109 & +c(i, j)*b0(i, j))*fx1_ad(i)
4110  bl_ad(i, j) = bl_ad(i, j) + temp_ad14
4111  b0_ad(i, j) = b0_ad(i, j) + c(i, j)*temp_ad14
4112  fx1_ad(i) = 0.0
4113  END IF
4114  q_ad(i, j) = q_ad(i, j) + fx0_ad(i)
4115  fx0_ad(i) = 0.0
4116  END IF
4117  END DO
4118  DO i=ilast,ifirst,-1
4119  fx1_ad(i) = 0.0
4120  END DO
4121  END DO
4122  al_ad = 0.0
4123  DO j=je+1,js-1,-1
4124  DO i=ilast,ifirst,-1
4125  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
4126  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
4127  b0_ad(i, j) = 0.0
4128  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
4129  q_ad(i, j) = q_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
4130  br_ad(i, j) = 0.0
4131  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
4132  bl_ad(i, j) = 0.0
4133  END DO
4134  END DO
4135  ELSE
4136 ! jord=5,6,7
4137  IF (jord .EQ. 5) THEN
4138  DO j=js-1,je+1
4139  DO i=ifirst,ilast
4140  bl(i, j) = al(i, j) - q(i, j)
4141  br(i, j) = al(i, j+1) - q(i, j)
4142  b0(i, j) = bl(i, j) + br(i, j)
4143  smt5(i, j) = bl(i, j)*br(i, j) .LT. 0.
4144  END DO
4145  END DO
4146  CALL pushcontrol1b(1)
4147  ELSE
4148  DO j=js-1,je+1
4149  DO i=ifirst,ilast
4150  bl(i, j) = al(i, j) - q(i, j)
4151  br(i, j) = al(i, j+1) - q(i, j)
4152  b0(i, j) = bl(i, j) + br(i, j)
4153  IF (3.*b0(i, j) .GE. 0.) THEN
4154  abs1 = 3.*b0(i, j)
4155  ELSE
4156  abs1 = -(3.*b0(i, j))
4157  END IF
4158  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
4159  abs4 = bl(i, j) - br(i, j)
4160  ELSE
4161  abs4 = -(bl(i, j)-br(i, j))
4162  END IF
4163  smt5(i, j) = abs1 .LT. abs4
4164  END DO
4165  END DO
4166  CALL pushcontrol1b(0)
4167  END IF
4168  DO j=js,je+1
4169 !DEC$ VECTOR ALWAYS
4170  DO i=ifirst,ilast
4171  IF (c(i, j) .GT. 0.) THEN
4172  CALL pushcontrol1b(0)
4173  ELSE
4174  CALL pushcontrol1b(1)
4175  END IF
4176  IF (smt5(i, j-1) .OR. smt5(i, j)) THEN
4177  CALL pushcontrol1b(1)
4178  ELSE
4179  CALL pushcontrol1b(0)
4180  END IF
4181  END DO
4182  END DO
4183  bl_ad = 0.0
4184  br_ad = 0.0
4185  b0_ad = 0.0
4186  fx1_ad = 0.0
4187  DO j=je+1,js,-1
4188  DO i=ilast,ifirst,-1
4189  CALL popcontrol1b(branch)
4190  IF (branch .NE. 0) fx1_ad(i) = fx1_ad(i) + flux_ad(i, j)
4191  CALL popcontrol1b(branch)
4192  IF (branch .EQ. 0) THEN
4193  q_ad(i, j-1) = q_ad(i, j-1) + flux_ad(i, j)
4194  flux_ad(i, j) = 0.0
4195  temp_ad15 = (1.-c(i, j))*fx1_ad(i)
4196  c_ad(i, j) = c_ad(i, j) - b0(i, j-1)*temp_ad15 - (br(i, j-&
4197 & 1)-c(i, j)*b0(i, j-1))*fx1_ad(i)
4198  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad15
4199  b0_ad(i, j-1) = b0_ad(i, j-1) - c(i, j)*temp_ad15
4200  fx1_ad(i) = 0.0
4201  ELSE
4202  q_ad(i, j) = q_ad(i, j) + flux_ad(i, j)
4203  flux_ad(i, j) = 0.0
4204  temp_ad16 = (c(i, j)+1.)*fx1_ad(i)
4205  c_ad(i, j) = c_ad(i, j) + b0(i, j)*temp_ad16 + (bl(i, j)+c&
4206 & (i, j)*b0(i, j))*fx1_ad(i)
4207  bl_ad(i, j) = bl_ad(i, j) + temp_ad16
4208  b0_ad(i, j) = b0_ad(i, j) + c(i, j)*temp_ad16
4209  fx1_ad(i) = 0.0
4210  END IF
4211  END DO
4212  END DO
4213  CALL popcontrol1b(branch)
4214  IF (branch .EQ. 0) THEN
4215  al_ad = 0.0
4216  DO j=je+1,js-1,-1
4217  DO i=ilast,ifirst,-1
4218  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
4219  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
4220  b0_ad(i, j) = 0.0
4221  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
4222  q_ad(i, j) = q_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
4223  br_ad(i, j) = 0.0
4224  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
4225  bl_ad(i, j) = 0.0
4226  END DO
4227  END DO
4228  ELSE
4229  al_ad = 0.0
4230  DO j=je+1,js-1,-1
4231  DO i=ilast,ifirst,-1
4232  bl_ad(i, j) = bl_ad(i, j) + b0_ad(i, j)
4233  br_ad(i, j) = br_ad(i, j) + b0_ad(i, j)
4234  b0_ad(i, j) = 0.0
4235  al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
4236  q_ad(i, j) = q_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
4237  br_ad(i, j) = 0.0
4238  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
4239  bl_ad(i, j) = 0.0
4240  END DO
4241  END DO
4242  END IF
4243  END IF
4244  CALL popcontrol2b(branch)
4245  IF (branch .LT. 2) THEN
4246  IF (branch .EQ. 0) THEN
4247  DO i=ilast,ifirst,-1
4248  CALL popcontrol1b(branch)
4249  IF (branch .NE. 0) al_ad(i, npy+1) = 0.0
4250  CALL popcontrol1b(branch)
4251  IF (branch .NE. 0) al_ad(i, npy) = 0.0
4252  CALL popcontrol1b(branch)
4253  IF (branch .NE. 0) al_ad(i, npy-1) = 0.0
4254  END DO
4255  END IF
4256  DO i=ilast,ifirst,-1
4257  q_ad(i, npy) = q_ad(i, npy) + c3*al_ad(i, npy+1)
4258  q_ad(i, npy+1) = q_ad(i, npy+1) + c2*al_ad(i, npy+1)
4259  q_ad(i, npy+2) = q_ad(i, npy+2) + c1*al_ad(i, npy+1)
4260  al_ad(i, npy+1) = 0.0
4261  temp_ad1 = 0.5*al_ad(i, npy)/(dya(i, npy-2)+dya(i, npy-1))
4262  temp_ad2 = 0.5*al_ad(i, npy)/(dya(i, npy)+dya(i, npy+1))
4263  q_ad(i, npy-1) = q_ad(i, npy-1) + (dya(i, npy-1)*2.+dya(i, npy&
4264 & -2))*temp_ad1
4265  q_ad(i, npy-2) = q_ad(i, npy-2) - dya(i, npy-1)*temp_ad1
4266  q_ad(i, npy) = q_ad(i, npy) + (dya(i, npy)*2.+dya(i, npy+1))*&
4267 & temp_ad2
4268  q_ad(i, npy+1) = q_ad(i, npy+1) - dya(i, npy)*temp_ad2
4269  al_ad(i, npy) = 0.0
4270  q_ad(i, npy-3) = q_ad(i, npy-3) + c1*al_ad(i, npy-1)
4271  q_ad(i, npy-2) = q_ad(i, npy-2) + c2*al_ad(i, npy-1)
4272  q_ad(i, npy-1) = q_ad(i, npy-1) + c3*al_ad(i, npy-1)
4273  al_ad(i, npy-1) = 0.0
4274  END DO
4275  ELSE IF (branch .NE. 2) THEN
4276  GOTO 100
4277  END IF
4278  CALL popcontrol2b(branch)
4279  IF (branch .EQ. 0) THEN
4280  DO i=ilast,ifirst,-1
4281  CALL popcontrol1b(branch)
4282  IF (branch .NE. 0) al_ad(i, 2) = 0.0
4283  CALL popcontrol1b(branch)
4284  IF (branch .NE. 0) al_ad(i, 1) = 0.0
4285  CALL popcontrol1b(branch)
4286  IF (branch .NE. 0) al_ad(i, 0) = 0.0
4287  END DO
4288  ELSE IF (branch .NE. 1) THEN
4289  GOTO 100
4290  END IF
4291  DO i=ilast,ifirst,-1
4292  q_ad(i, 1) = q_ad(i, 1) + c3*al_ad(i, 2)
4293  q_ad(i, 2) = q_ad(i, 2) + c2*al_ad(i, 2)
4294  q_ad(i, 3) = q_ad(i, 3) + c1*al_ad(i, 2)
4295  al_ad(i, 2) = 0.0
4296  temp_ad = 0.5*al_ad(i, 1)/(dya(i, -1)+dya(i, 0))
4297  temp_ad0 = 0.5*al_ad(i, 1)/(dya(i, 1)+dya(i, 2))
4298  q_ad(i, 0) = q_ad(i, 0) + (dya(i, 0)*2.+dya(i, -1))*temp_ad
4299  q_ad(i, -1) = q_ad(i, -1) - dya(i, 0)*temp_ad
4300  q_ad(i, 1) = q_ad(i, 1) + (dya(i, 1)*2.+dya(i, 2))*temp_ad0
4301  q_ad(i, 2) = q_ad(i, 2) - dya(i, 1)*temp_ad0
4302  al_ad(i, 1) = 0.0
4303  q_ad(i, -2) = q_ad(i, -2) + c1*al_ad(i, 0)
4304  q_ad(i, -1) = q_ad(i, -1) + c2*al_ad(i, 0)
4305  q_ad(i, 0) = q_ad(i, 0) + c3*al_ad(i, 0)
4306  al_ad(i, 0) = 0.0
4307  END DO
4308  100 CALL popcontrol1b(branch)
4309  IF (branch .EQ. 0) THEN
4310  DO j=je3,js1,-1
4311  DO i=ilast,ifirst,-1
4312  CALL popcontrol1b(branch)
4313  IF (branch .NE. 0) THEN
4314  q_ad(i, j) = q_ad(i, j) + 0.5*al_ad(i, j)
4315  q_ad(i, j+1) = q_ad(i, j+1) + 0.5*al_ad(i, j)
4316  al_ad(i, j) = 0.0
4317  END IF
4318  END DO
4319  END DO
4320  END IF
4321  DO j=je3,js1,-1
4322  DO i=ilast,ifirst,-1
4323  q_ad(i, j-1) = q_ad(i, j-1) + p1*al_ad(i, j)
4324  q_ad(i, j) = q_ad(i, j) + p1*al_ad(i, j)
4325  q_ad(i, j-2) = q_ad(i, j-2) + p2*al_ad(i, j)
4326  q_ad(i, j+1) = q_ad(i, j+1) + p2*al_ad(i, j)
4327  al_ad(i, j) = 0.0
4328  END DO
4329  END DO
4330  ELSE
4331 ! Monotonic constraints:
4332 ! ord = 8: PPM with Lin's PPM fast monotone constraint
4333 ! ord > 8: PPM with Lin's modification of Huynh 2nd constraint
4334  DO j=js-2,je+2
4335  DO i=ifirst,ilast
4336  xt = 0.25*(q(i, j+1)-q(i, j-1))
4337  IF (xt .GE. 0.) THEN
4338  x3 = xt
4339  CALL pushcontrol1b(0)
4340  ELSE
4341  x3 = -xt
4342  CALL pushcontrol1b(1)
4343  END IF
4344  IF (q(i, j-1) .LT. q(i, j)) THEN
4345  IF (q(i, j) .LT. q(i, j+1)) THEN
4346  max1 = q(i, j+1)
4347  CALL pushcontrol2b(0)
4348  ELSE
4349  max1 = q(i, j)
4350  CALL pushcontrol2b(1)
4351  END IF
4352  ELSE IF (q(i, j-1) .LT. q(i, j+1)) THEN
4353  max1 = q(i, j+1)
4354  CALL pushcontrol2b(2)
4355  ELSE
4356  max1 = q(i, j-1)
4357  CALL pushcontrol2b(3)
4358  END IF
4359  y3 = max1 - q(i, j)
4360  IF (q(i, j-1) .GT. q(i, j)) THEN
4361  IF (q(i, j) .GT. q(i, j+1)) THEN
4362  min8 = q(i, j+1)
4363  CALL pushcontrol2b(0)
4364  ELSE
4365  min8 = q(i, j)
4366  CALL pushcontrol2b(1)
4367  END IF
4368  ELSE IF (q(i, j-1) .GT. q(i, j+1)) THEN
4369  min8 = q(i, j+1)
4370  CALL pushcontrol2b(2)
4371  ELSE
4372  min8 = q(i, j-1)
4373  CALL pushcontrol2b(3)
4374  END IF
4375  z1 = q(i, j) - min8
4376  IF (x3 .GT. y3) THEN
4377  IF (y3 .GT. z1) THEN
4378  CALL pushrealarray_adm(min3)
4379  min3 = z1
4380  CALL pushcontrol2b(0)
4381  ELSE
4382  CALL pushrealarray_adm(min3)
4383  min3 = y3
4384  CALL pushcontrol2b(1)
4385  END IF
4386  ELSE IF (x3 .GT. z1) THEN
4387  CALL pushrealarray_adm(min3)
4388  min3 = z1
4389  CALL pushcontrol2b(2)
4390  ELSE
4391  CALL pushrealarray_adm(min3)
4392  min3 = x3
4393  CALL pushcontrol2b(3)
4394  END IF
4395  dm(i, j) = sign(min3, xt)
4396  END DO
4397  END DO
4398  DO j=js1,je1+1
4399  DO i=ifirst,ilast
4400  al(i, j) = 0.5*(q(i, j-1)+q(i, j)) + r3*(dm(i, j-1)-dm(i, j))
4401  END DO
4402  END DO
4403  IF (jord .EQ. 8) THEN
4404  DO j=js1,je1
4405  DO i=ifirst,ilast
4406  xt = 2.*dm(i, j)
4407  IF (xt .GE. 0.) THEN
4408  x4 = xt
4409  CALL pushcontrol1b(0)
4410  ELSE
4411  x4 = -xt
4412  CALL pushcontrol1b(1)
4413  END IF
4414  IF (al(i, j) - q(i, j) .GE. 0.) THEN
4415  y4 = al(i, j) - q(i, j)
4416  CALL pushcontrol1b(0)
4417  ELSE
4418  y4 = -(al(i, j)-q(i, j))
4419  CALL pushcontrol1b(1)
4420  END IF
4421  IF (x4 .GT. y4) THEN
4422  CALL pushrealarray_adm(min4)
4423  min4 = y4
4424  CALL pushcontrol1b(0)
4425  ELSE
4426  CALL pushrealarray_adm(min4)
4427  min4 = x4
4428  CALL pushcontrol1b(1)
4429  END IF
4430  bl(i, j) = -sign(min4, xt)
4431  IF (xt .GE. 0.) THEN
4432  x5 = xt
4433  CALL pushcontrol1b(0)
4434  ELSE
4435  x5 = -xt
4436  CALL pushcontrol1b(1)
4437  END IF
4438  IF (al(i, j+1) - q(i, j) .GE. 0.) THEN
4439  y5 = al(i, j+1) - q(i, j)
4440  CALL pushcontrol1b(0)
4441  ELSE
4442  y5 = -(al(i, j+1)-q(i, j))
4443  CALL pushcontrol1b(1)
4444  END IF
4445  IF (x5 .GT. y5) THEN
4446  CALL pushrealarray_adm(min5)
4447  min5 = y5
4448  CALL pushcontrol1b(0)
4449  ELSE
4450  CALL pushrealarray_adm(min5)
4451  min5 = x5
4452  CALL pushcontrol1b(1)
4453  END IF
4454  br(i, j) = sign(min5, xt)
4455  END DO
4456  END DO
4457  CALL pushcontrol2b(0)
4458  ELSE IF (jord .EQ. 11) THEN
4459  DO j=js1,je1
4460  DO i=ifirst,ilast
4461  xt = ppm_fac*dm(i, j)
4462  IF (xt .GE. 0.) THEN
4463  x6 = xt
4464  CALL pushcontrol1b(0)
4465  ELSE
4466  x6 = -xt
4467  CALL pushcontrol1b(1)
4468  END IF
4469  IF (al(i, j) - q(i, j) .GE. 0.) THEN
4470  y6 = al(i, j) - q(i, j)
4471  CALL pushcontrol1b(0)
4472  ELSE
4473  y6 = -(al(i, j)-q(i, j))
4474  CALL pushcontrol1b(1)
4475  END IF
4476  IF (x6 .GT. y6) THEN
4477  CALL pushrealarray_adm(min6)
4478  min6 = y6
4479  CALL pushcontrol1b(0)
4480  ELSE
4481  CALL pushrealarray_adm(min6)
4482  min6 = x6
4483  CALL pushcontrol1b(1)
4484  END IF
4485  bl(i, j) = -sign(min6, xt)
4486  IF (xt .GE. 0.) THEN
4487  x7 = xt
4488  CALL pushcontrol1b(0)
4489  ELSE
4490  x7 = -xt
4491  CALL pushcontrol1b(1)
4492  END IF
4493  IF (al(i, j+1) - q(i, j) .GE. 0.) THEN
4494  y7 = al(i, j+1) - q(i, j)
4495  CALL pushcontrol1b(0)
4496  ELSE
4497  y7 = -(al(i, j+1)-q(i, j))
4498  CALL pushcontrol1b(1)
4499  END IF
4500  IF (x7 .GT. y7) THEN
4501  CALL pushrealarray_adm(min7)
4502  min7 = y7
4503  CALL pushcontrol1b(0)
4504  ELSE
4505  CALL pushrealarray_adm(min7)
4506  min7 = x7
4507  CALL pushcontrol1b(1)
4508  END IF
4509  br(i, j) = sign(min7, xt)
4510  END DO
4511  END DO
4512  CALL pushcontrol2b(1)
4513  ELSE
4514  DO j=js1-2,je1+1
4515  DO i=ifirst,ilast
4516  dq(i, j) = 2.*(q(i, j+1)-q(i, j))
4517  END DO
4518  END DO
4519  DO j=js1,je1
4520  DO i=ifirst,ilast
4521  bl(i, j) = al(i, j) - q(i, j)
4522  br(i, j) = al(i, j+1) - q(i, j)
4523  IF (dm(i, j-1) .GE. 0.) THEN
4524  abs2 = dm(i, j-1)
4525  ELSE
4526  abs2 = -dm(i, j-1)
4527  END IF
4528  IF (dm(i, j) .GE. 0.) THEN
4529  abs5 = dm(i, j)
4530  ELSE
4531  abs5 = -dm(i, j)
4532  END IF
4533  IF (dm(i, j+1) .GE. 0.) THEN
4534  abs7 = dm(i, j+1)
4535  ELSE
4536  abs7 = -dm(i, j+1)
4537  END IF
4538  IF (abs2 + abs5 + abs7 .LT. near_zero) THEN
4539  bl(i, j) = 0.
4540  br(i, j) = 0.
4541  CALL pushcontrol2b(3)
4542  ELSE
4543  IF (3.*(bl(i, j)+br(i, j)) .GE. 0.) THEN
4544  abs3 = 3.*(bl(i, j)+br(i, j))
4545  ELSE
4546  abs3 = -(3.*(bl(i, j)+br(i, j)))
4547  END IF
4548  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
4549  abs6 = bl(i, j) - br(i, j)
4550  ELSE
4551  abs6 = -(bl(i, j)-br(i, j))
4552  END IF
4553  IF (abs3 .GT. abs6) THEN
4554  pmp_2 = dq(i, j-1)
4555  lac_2 = pmp_2 - 0.75*dq(i, j-2)
4556  IF (0. .LT. pmp_2) THEN
4557  IF (pmp_2 .LT. lac_2) THEN
4558  x8 = lac_2
4559  CALL pushcontrol2b(0)
4560  ELSE
4561  x8 = pmp_2
4562  CALL pushcontrol2b(1)
4563  END IF
4564  ELSE IF (0. .LT. lac_2) THEN
4565  x8 = lac_2
4566  CALL pushcontrol2b(2)
4567  ELSE
4568  CALL pushcontrol2b(3)
4569  x8 = 0.
4570  END IF
4571  IF (0. .GT. pmp_2) THEN
4572  IF (pmp_2 .GT. lac_2) THEN
4573  y14 = lac_2
4574  CALL pushcontrol2b(0)
4575  ELSE
4576  y14 = pmp_2
4577  CALL pushcontrol2b(1)
4578  END IF
4579  ELSE IF (0. .GT. lac_2) THEN
4580  y14 = lac_2
4581  CALL pushcontrol2b(2)
4582  ELSE
4583  y14 = 0.
4584  CALL pushcontrol2b(3)
4585  END IF
4586  IF (br(i, j) .LT. y14) THEN
4587  y8 = y14
4588  CALL pushcontrol1b(0)
4589  ELSE
4590  y8 = br(i, j)
4591  CALL pushcontrol1b(1)
4592  END IF
4593  IF (x8 .GT. y8) THEN
4594  br(i, j) = y8
4595  CALL pushcontrol1b(0)
4596  ELSE
4597  br(i, j) = x8
4598  CALL pushcontrol1b(1)
4599  END IF
4600  pmp_1 = -dq(i, j)
4601  lac_1 = pmp_1 + 0.75*dq(i, j+1)
4602  IF (0. .LT. pmp_1) THEN
4603  IF (pmp_1 .LT. lac_1) THEN
4604  x9 = lac_1
4605  CALL pushcontrol2b(0)
4606  ELSE
4607  x9 = pmp_1
4608  CALL pushcontrol2b(1)
4609  END IF
4610  ELSE IF (0. .LT. lac_1) THEN
4611  x9 = lac_1
4612  CALL pushcontrol2b(2)
4613  ELSE
4614  CALL pushcontrol2b(3)
4615  x9 = 0.
4616  END IF
4617  IF (0. .GT. pmp_1) THEN
4618  IF (pmp_1 .GT. lac_1) THEN
4619  y15 = lac_1
4620  CALL pushcontrol2b(0)
4621  ELSE
4622  y15 = pmp_1
4623  CALL pushcontrol2b(1)
4624  END IF
4625  ELSE IF (0. .GT. lac_1) THEN
4626  y15 = lac_1
4627  CALL pushcontrol2b(2)
4628  ELSE
4629  y15 = 0.
4630  CALL pushcontrol2b(3)
4631  END IF
4632  IF (bl(i, j) .LT. y15) THEN
4633  y9 = y15
4634  CALL pushcontrol1b(0)
4635  ELSE
4636  y9 = bl(i, j)
4637  CALL pushcontrol1b(1)
4638  END IF
4639  IF (x9 .GT. y9) THEN
4640  bl(i, j) = y9
4641  CALL pushcontrol2b(1)
4642  ELSE
4643  bl(i, j) = x9
4644  CALL pushcontrol2b(2)
4645  END IF
4646  ELSE
4647  CALL pushcontrol2b(0)
4648  END IF
4649  END IF
4650  END DO
4651  END DO
4652  CALL pushcontrol2b(2)
4653  END IF
4654  IF (jord .EQ. 9 .OR. jord .EQ. 13) THEN
4655 ! Positive definite constraint:
4656  DO j=js1,je1
4657  arg1 = ilast - ifirst + 1
4658  CALL pushrealarray_adm(br(:, j), ilast - ifirst + 1)
4659  CALL pushrealarray_adm(bl(:, j), ilast - ifirst + 1)
4660  CALL pert_ppm(arg1, q(ifirst:ilast, j), bl(ifirst:ilast, j), &
4661 & br(ifirst:ilast, j), 0)
4662  END DO
4663  CALL pushcontrol1b(0)
4664  ELSE
4665  CALL pushcontrol1b(1)
4666  END IF
4667  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
4668  IF (js .EQ. 1) THEN
4669  DO i=ifirst,ilast
4670  bl(i, 0) = s14*dm(i, -1) + s11*(q(i, -1)-q(i, 0))
4671  xt = 0.5*(((2.*dya(i, 0)+dya(i, -1))*q(i, 0)-dya(i, 0)*q(i, &
4672 & -1))/(dya(i, -1)+dya(i, 0))+((2.*dya(i, 1)+dya(i, 2))*q(i&
4673 & , 1)-dya(i, 1)*q(i, 2))/(dya(i, 1)+dya(i, 2)))
4674  IF (q(i, 1) .GT. q(i, 2)) THEN
4675  z2 = q(i, 2)
4676  CALL pushcontrol1b(0)
4677  ELSE
4678  z2 = q(i, 1)
4679  CALL pushcontrol1b(1)
4680  END IF
4681  IF (q(i, -1) .GT. q(i, 0)) THEN
4682  IF (q(i, 0) .GT. z2) THEN
4683  y10 = z2
4684  CALL pushcontrol2b(0)
4685  ELSE
4686  y10 = q(i, 0)
4687  CALL pushcontrol2b(1)
4688  END IF
4689  ELSE IF (q(i, -1) .GT. z2) THEN
4690  y10 = z2
4691  CALL pushcontrol2b(2)
4692  ELSE
4693  y10 = q(i, -1)
4694  CALL pushcontrol2b(3)
4695  END IF
4696  IF (xt .LT. y10) THEN
4697  xt = y10
4698  CALL pushcontrol1b(0)
4699  ELSE
4700  xt = xt
4701  CALL pushcontrol1b(1)
4702  END IF
4703  IF (q(i, 1) .LT. q(i, 2)) THEN
4704  z3 = q(i, 2)
4705  CALL pushcontrol1b(0)
4706  ELSE
4707  z3 = q(i, 1)
4708  CALL pushcontrol1b(1)
4709  END IF
4710  IF (q(i, -1) .LT. q(i, 0)) THEN
4711  IF (q(i, 0) .LT. z3) THEN
4712  y11 = z3
4713  CALL pushcontrol2b(0)
4714  ELSE
4715  y11 = q(i, 0)
4716  CALL pushcontrol2b(1)
4717  END IF
4718  ELSE IF (q(i, -1) .LT. z3) THEN
4719  y11 = z3
4720  CALL pushcontrol2b(2)
4721  ELSE
4722  y11 = q(i, -1)
4723  CALL pushcontrol2b(3)
4724  END IF
4725  IF (xt .GT. y11) THEN
4726  xt = y11
4727  CALL pushcontrol1b(0)
4728  ELSE
4729  xt = xt
4730  CALL pushcontrol1b(1)
4731  END IF
4732 ! endif
4733  br(i, 0) = xt - q(i, 0)
4734  bl(i, 1) = xt - q(i, 1)
4735  xt = s15*q(i, 1) + s11*q(i, 2) - s14*dm(i, 2)
4736  br(i, 1) = xt - q(i, 1)
4737  bl(i, 2) = xt - q(i, 2)
4738  br(i, 2) = al(i, 3) - q(i, 2)
4739  END DO
4740  arg1 = 3*(ilast-ifirst+1)
4741  CALL pushrealarray_adm(br(:, 0:2), (ilast-ifirst+1)*3)
4742  CALL pushrealarray_adm(bl(:, 0:2), (ilast-ifirst+1)*3)
4743  CALL pert_ppm(arg1, q(ifirst:ilast, 0:2), bl(ifirst:ilast, 0:2&
4744 & ), br(ifirst:ilast, 0:2), 1)
4745  CALL pushcontrol1b(0)
4746  ELSE
4747  CALL pushcontrol1b(1)
4748  END IF
4749  IF (je + 1 .EQ. npy) THEN
4750  DO i=ifirst,ilast
4751  bl(i, npy-2) = al(i, npy-2) - q(i, npy-2)
4752  xt = s15*q(i, npy-1) + s11*q(i, npy-2) + s14*dm(i, npy-2)
4753  br(i, npy-2) = xt - q(i, npy-2)
4754  bl(i, npy-1) = xt - q(i, npy-1)
4755  xt = 0.5*(((2.*dya(i, npy-1)+dya(i, npy-2))*q(i, npy-1)-dya(&
4756 & i, npy-1)*q(i, npy-2))/(dya(i, npy-2)+dya(i, npy-1))+((2.*&
4757 & dya(i, npy)+dya(i, npy+1))*q(i, npy)-dya(i, npy)*q(i, npy+&
4758 & 1))/(dya(i, npy)+dya(i, npy+1)))
4759  IF (q(i, npy) .GT. q(i, npy+1)) THEN
4760  z4 = q(i, npy+1)
4761  CALL pushcontrol1b(0)
4762  ELSE
4763  z4 = q(i, npy)
4764  CALL pushcontrol1b(1)
4765  END IF
4766  IF (q(i, npy-2) .GT. q(i, npy-1)) THEN
4767  IF (q(i, npy-1) .GT. z4) THEN
4768  y12 = z4
4769  CALL pushcontrol2b(0)
4770  ELSE
4771  y12 = q(i, npy-1)
4772  CALL pushcontrol2b(1)
4773  END IF
4774  ELSE IF (q(i, npy-2) .GT. z4) THEN
4775  y12 = z4
4776  CALL pushcontrol2b(2)
4777  ELSE
4778  y12 = q(i, npy-2)
4779  CALL pushcontrol2b(3)
4780  END IF
4781  IF (xt .LT. y12) THEN
4782  xt = y12
4783  CALL pushcontrol1b(0)
4784  ELSE
4785  xt = xt
4786  CALL pushcontrol1b(1)
4787  END IF
4788  IF (q(i, npy) .LT. q(i, npy+1)) THEN
4789  z5 = q(i, npy+1)
4790  CALL pushcontrol1b(0)
4791  ELSE
4792  z5 = q(i, npy)
4793  CALL pushcontrol1b(1)
4794  END IF
4795  IF (q(i, npy-2) .LT. q(i, npy-1)) THEN
4796  IF (q(i, npy-1) .LT. z5) THEN
4797  y13 = z5
4798  CALL pushcontrol2b(0)
4799  ELSE
4800  y13 = q(i, npy-1)
4801  CALL pushcontrol2b(1)
4802  END IF
4803  ELSE IF (q(i, npy-2) .LT. z5) THEN
4804  y13 = z5
4805  CALL pushcontrol2b(2)
4806  ELSE
4807  y13 = q(i, npy-2)
4808  CALL pushcontrol2b(3)
4809  END IF
4810  IF (xt .GT. y13) THEN
4811  xt = y13
4812  CALL pushcontrol1b(0)
4813  ELSE
4814  xt = xt
4815  CALL pushcontrol1b(1)
4816  END IF
4817 ! endif
4818  br(i, npy-1) = xt - q(i, npy-1)
4819  bl(i, npy) = xt - q(i, npy)
4820  br(i, npy) = s11*(q(i, npy+1)-q(i, npy)) - s14*dm(i, npy+1)
4821  END DO
4822  arg1 = 3*(ilast-ifirst+1)
4823  CALL pushrealarray_adm(br(:, npy-2:npy), (ilast-ifirst+1)*3)
4824  CALL pushrealarray_adm(bl(:, npy-2:npy), (ilast-ifirst+1)*3)
4825  CALL pert_ppm(arg1, q(ifirst:ilast, npy-2:npy), bl(ifirst:&
4826 & ilast, npy-2:npy), br(ifirst:ilast, npy-2:npy), 1)
4827  CALL pushcontrol2b(2)
4828  ELSE
4829  CALL pushcontrol2b(1)
4830  END IF
4831  ELSE
4832  CALL pushcontrol2b(0)
4833  END IF
4834  DO j=js,je+1
4835  DO i=ifirst,ilast
4836  IF (c(i, j) .GT. 0.) THEN
4837  CALL pushcontrol1b(1)
4838  ELSE
4839  CALL pushcontrol1b(0)
4840  END IF
4841  END DO
4842  END DO
4843  bl_ad = 0.0
4844  br_ad = 0.0
4845  DO j=je+1,js,-1
4846  DO i=ilast,ifirst,-1
4847  CALL popcontrol1b(branch)
4848  IF (branch .EQ. 0) THEN
4849  temp2 = bl(i, j) + br(i, j)
4850  temp_ad23 = (c(i, j)+1.)*flux_ad(i, j)
4851  temp_ad24 = c(i, j)*temp_ad23
4852  q_ad(i, j) = q_ad(i, j) + flux_ad(i, j)
4853  c_ad(i, j) = c_ad(i, j) + temp2*temp_ad23 + (bl(i, j)+c(i, j&
4854 & )*temp2)*flux_ad(i, j)
4855  bl_ad(i, j) = bl_ad(i, j) + temp_ad24 + temp_ad23
4856  br_ad(i, j) = br_ad(i, j) + temp_ad24
4857  flux_ad(i, j) = 0.0
4858  ELSE
4859  temp1 = bl(i, j-1) + br(i, j-1)
4860  temp_ad21 = (1.-c(i, j))*flux_ad(i, j)
4861  temp_ad22 = -(c(i, j)*temp_ad21)
4862  q_ad(i, j-1) = q_ad(i, j-1) + flux_ad(i, j)
4863  c_ad(i, j) = c_ad(i, j) - temp1*temp_ad21 - (br(i, j-1)-c(i&
4864 & , j)*temp1)*flux_ad(i, j)
4865  br_ad(i, j-1) = br_ad(i, j-1) + temp_ad22 + temp_ad21
4866  bl_ad(i, j-1) = bl_ad(i, j-1) + temp_ad22
4867  flux_ad(i, j) = 0.0
4868  END IF
4869  END DO
4870  END DO
4871  CALL popcontrol2b(branch)
4872  IF (branch .EQ. 0) THEN
4873  dm_ad = 0.0
4874  al_ad = 0.0
4875  ELSE
4876  IF (branch .EQ. 1) THEN
4877  dm_ad = 0.0
4878  al_ad = 0.0
4879  ELSE
4880  CALL poprealarray_adm(bl(:, npy-2:npy), (ilast-ifirst+1)*3)
4881  CALL poprealarray_adm(br(:, npy-2:npy), (ilast-ifirst+1)*3)
4882  CALL pert_ppm_adm(arg1, q(ifirst:ilast, npy-2:npy), bl(ifirst:&
4883 & ilast, npy-2:npy), bl_ad(ifirst:ilast, npy-2:npy)&
4884 & , br(ifirst:ilast, npy-2:npy), br_ad(ifirst:ilast&
4885 & , npy-2:npy), 1)
4886  dm_ad = 0.0
4887  al_ad = 0.0
4888  DO i=ilast,ifirst,-1
4889  q_ad(i, npy+1) = q_ad(i, npy+1) + s11*br_ad(i, npy)
4890  q_ad(i, npy) = q_ad(i, npy) - bl_ad(i, npy) - s11*br_ad(i, &
4891 & npy)
4892  dm_ad(i, npy+1) = dm_ad(i, npy+1) - s14*br_ad(i, npy)
4893  br_ad(i, npy) = 0.0
4894  xt_ad = br_ad(i, npy-1) + bl_ad(i, npy)
4895  bl_ad(i, npy) = 0.0
4896  q_ad(i, npy-1) = q_ad(i, npy-1) - br_ad(i, npy-1)
4897  br_ad(i, npy-1) = 0.0
4898  CALL popcontrol1b(branch)
4899  IF (branch .EQ. 0) THEN
4900  y13_ad = xt_ad
4901  xt_ad = 0.0
4902  ELSE
4903  y13_ad = 0.0
4904  END IF
4905  CALL popcontrol2b(branch)
4906  IF (branch .LT. 2) THEN
4907  IF (branch .EQ. 0) THEN
4908  z5_ad = y13_ad
4909  ELSE
4910  q_ad(i, npy-1) = q_ad(i, npy-1) + y13_ad
4911  z5_ad = 0.0
4912  END IF
4913  ELSE IF (branch .EQ. 2) THEN
4914  z5_ad = y13_ad
4915  ELSE
4916  q_ad(i, npy-2) = q_ad(i, npy-2) + y13_ad
4917  z5_ad = 0.0
4918  END IF
4919  CALL popcontrol1b(branch)
4920  IF (branch .EQ. 0) THEN
4921  q_ad(i, npy+1) = q_ad(i, npy+1) + z5_ad
4922  ELSE
4923  q_ad(i, npy) = q_ad(i, npy) + z5_ad
4924  END IF
4925  CALL popcontrol1b(branch)
4926  IF (branch .EQ. 0) THEN
4927  y12_ad = xt_ad
4928  xt_ad = 0.0
4929  ELSE
4930  y12_ad = 0.0
4931  END IF
4932  CALL popcontrol2b(branch)
4933  IF (branch .LT. 2) THEN
4934  IF (branch .EQ. 0) THEN
4935  z4_ad = y12_ad
4936  ELSE
4937  q_ad(i, npy-1) = q_ad(i, npy-1) + y12_ad
4938  z4_ad = 0.0
4939  END IF
4940  ELSE IF (branch .EQ. 2) THEN
4941  z4_ad = y12_ad
4942  ELSE
4943  q_ad(i, npy-2) = q_ad(i, npy-2) + y12_ad
4944  z4_ad = 0.0
4945  END IF
4946  CALL popcontrol1b(branch)
4947  IF (branch .EQ. 0) THEN
4948  q_ad(i, npy+1) = q_ad(i, npy+1) + z4_ad
4949  ELSE
4950  q_ad(i, npy) = q_ad(i, npy) + z4_ad
4951  END IF
4952  temp_ad19 = 0.5*xt_ad/(dya(i, npy-2)+dya(i, npy-1))
4953  temp_ad20 = 0.5*xt_ad/(dya(i, npy)+dya(i, npy+1))
4954  q_ad(i, npy-1) = q_ad(i, npy-1) + (dya(i, npy-1)*2.+dya(i, &
4955 & npy-2))*temp_ad19
4956  q_ad(i, npy-2) = q_ad(i, npy-2) - dya(i, npy-1)*temp_ad19
4957  q_ad(i, npy) = q_ad(i, npy) + (dya(i, npy)*2.+dya(i, npy+1))&
4958 & *temp_ad20
4959  q_ad(i, npy+1) = q_ad(i, npy+1) - dya(i, npy)*temp_ad20
4960  xt_ad = br_ad(i, npy-2) + bl_ad(i, npy-1)
4961  q_ad(i, npy-1) = q_ad(i, npy-1) - bl_ad(i, npy-1)
4962  bl_ad(i, npy-1) = 0.0
4963  q_ad(i, npy-2) = q_ad(i, npy-2) - br_ad(i, npy-2)
4964  br_ad(i, npy-2) = 0.0
4965  q_ad(i, npy-1) = q_ad(i, npy-1) + s15*xt_ad
4966  q_ad(i, npy-2) = q_ad(i, npy-2) + s11*xt_ad - bl_ad(i, npy-2&
4967 & )
4968  dm_ad(i, npy-2) = dm_ad(i, npy-2) + s14*xt_ad
4969  al_ad(i, npy-2) = al_ad(i, npy-2) + bl_ad(i, npy-2)
4970  bl_ad(i, npy-2) = 0.0
4971  END DO
4972  END IF
4973  CALL popcontrol1b(branch)
4974  IF (branch .EQ. 0) THEN
4975  arg1 = 3*(ilast-ifirst+1)
4976  CALL poprealarray_adm(bl(:, 0:2), (ilast-ifirst+1)*3)
4977  CALL poprealarray_adm(br(:, 0:2), (ilast-ifirst+1)*3)
4978  CALL pert_ppm_adm(arg1, q(ifirst:ilast, 0:2), bl(ifirst:ilast&
4979 & , 0:2), bl_ad(ifirst:ilast, 0:2), br(ifirst:ilast&
4980 & , 0:2), br_ad(ifirst:ilast, 0:2), 1)
4981  DO i=ilast,ifirst,-1
4982  al_ad(i, 3) = al_ad(i, 3) + br_ad(i, 2)
4983  q_ad(i, 2) = q_ad(i, 2) - bl_ad(i, 2) - br_ad(i, 2)
4984  br_ad(i, 2) = 0.0
4985  xt_ad = br_ad(i, 1) + bl_ad(i, 2)
4986  bl_ad(i, 2) = 0.0
4987  q_ad(i, 1) = q_ad(i, 1) + s15*xt_ad - br_ad(i, 1)
4988  br_ad(i, 1) = 0.0
4989  q_ad(i, 2) = q_ad(i, 2) + s11*xt_ad
4990  dm_ad(i, 2) = dm_ad(i, 2) - s14*xt_ad
4991  xt_ad = br_ad(i, 0) + bl_ad(i, 1)
4992  q_ad(i, 1) = q_ad(i, 1) - bl_ad(i, 1)
4993  bl_ad(i, 1) = 0.0
4994  q_ad(i, 0) = q_ad(i, 0) - br_ad(i, 0)
4995  br_ad(i, 0) = 0.0
4996  CALL popcontrol1b(branch)
4997  IF (branch .EQ. 0) THEN
4998  y11_ad = xt_ad
4999  xt_ad = 0.0
5000  ELSE
5001  y11_ad = 0.0
5002  END IF
5003  CALL popcontrol2b(branch)
5004  IF (branch .LT. 2) THEN
5005  IF (branch .EQ. 0) THEN
5006  z3_ad = y11_ad
5007  ELSE
5008  q_ad(i, 0) = q_ad(i, 0) + y11_ad
5009  z3_ad = 0.0
5010  END IF
5011  ELSE IF (branch .EQ. 2) THEN
5012  z3_ad = y11_ad
5013  ELSE
5014  q_ad(i, -1) = q_ad(i, -1) + y11_ad
5015  z3_ad = 0.0
5016  END IF
5017  CALL popcontrol1b(branch)
5018  IF (branch .EQ. 0) THEN
5019  q_ad(i, 2) = q_ad(i, 2) + z3_ad
5020  ELSE
5021  q_ad(i, 1) = q_ad(i, 1) + z3_ad
5022  END IF
5023  CALL popcontrol1b(branch)
5024  IF (branch .EQ. 0) THEN
5025  y10_ad = xt_ad
5026  xt_ad = 0.0
5027  ELSE
5028  y10_ad = 0.0
5029  END IF
5030  CALL popcontrol2b(branch)
5031  IF (branch .LT. 2) THEN
5032  IF (branch .EQ. 0) THEN
5033  z2_ad = y10_ad
5034  ELSE
5035  q_ad(i, 0) = q_ad(i, 0) + y10_ad
5036  z2_ad = 0.0
5037  END IF
5038  ELSE IF (branch .EQ. 2) THEN
5039  z2_ad = y10_ad
5040  ELSE
5041  q_ad(i, -1) = q_ad(i, -1) + y10_ad
5042  z2_ad = 0.0
5043  END IF
5044  CALL popcontrol1b(branch)
5045  IF (branch .EQ. 0) THEN
5046  q_ad(i, 2) = q_ad(i, 2) + z2_ad
5047  ELSE
5048  q_ad(i, 1) = q_ad(i, 1) + z2_ad
5049  END IF
5050  temp_ad17 = 0.5*xt_ad/(dya(i, -1)+dya(i, 0))
5051  temp_ad18 = 0.5*xt_ad/(dya(i, 1)+dya(i, 2))
5052  q_ad(i, 0) = q_ad(i, 0) + (dya(i, 0)*2.+dya(i, -1))*&
5053 & temp_ad17
5054  q_ad(i, -1) = q_ad(i, -1) - dya(i, 0)*temp_ad17
5055  q_ad(i, 1) = q_ad(i, 1) + (dya(i, 1)*2.+dya(i, 2))*temp_ad18
5056  q_ad(i, 2) = q_ad(i, 2) - dya(i, 1)*temp_ad18
5057  dm_ad(i, -1) = dm_ad(i, -1) + s14*bl_ad(i, 0)
5058  q_ad(i, -1) = q_ad(i, -1) + s11*bl_ad(i, 0)
5059  q_ad(i, 0) = q_ad(i, 0) - s11*bl_ad(i, 0)
5060  bl_ad(i, 0) = 0.0
5061  END DO
5062  END IF
5063  END IF
5064  CALL popcontrol1b(branch)
5065  IF (branch .EQ. 0) THEN
5066  DO j=je1,js1,-1
5067  arg1 = ilast - ifirst + 1
5068  CALL poprealarray_adm(bl(:, j), ilast - ifirst + 1)
5069  CALL poprealarray_adm(br(:, j), ilast - ifirst + 1)
5070  CALL pert_ppm_adm(arg1, q(ifirst:ilast, j), bl(ifirst:ilast, j&
5071 & ), bl_ad(ifirst:ilast, j), br(ifirst:ilast, j), &
5072 & br_ad(ifirst:ilast, j), 0)
5073  END DO
5074  END IF
5075  CALL popcontrol2b(branch)
5076  IF (branch .EQ. 0) THEN
5077  DO j=je1,js1,-1
5078  DO i=ilast,ifirst,-1
5079  xt = 2.*dm(i, j)
5080  min5_ad = sign(1.d0, min5*xt)*br_ad(i, j)
5081  br_ad(i, j) = 0.0
5082  CALL popcontrol1b(branch)
5083  IF (branch .EQ. 0) THEN
5084  CALL poprealarray_adm(min5)
5085  y5_ad = min5_ad
5086  x5_ad = 0.0
5087  ELSE
5088  CALL poprealarray_adm(min5)
5089  x5_ad = min5_ad
5090  y5_ad = 0.0
5091  END IF
5092  CALL popcontrol1b(branch)
5093  IF (branch .EQ. 0) THEN
5094  al_ad(i, j+1) = al_ad(i, j+1) + y5_ad
5095  q_ad(i, j) = q_ad(i, j) - y5_ad
5096  ELSE
5097  q_ad(i, j) = q_ad(i, j) + y5_ad
5098  al_ad(i, j+1) = al_ad(i, j+1) - y5_ad
5099  END IF
5100  CALL popcontrol1b(branch)
5101  IF (branch .EQ. 0) THEN
5102  xt_ad = x5_ad
5103  ELSE
5104  xt_ad = -x5_ad
5105  END IF
5106  min4_ad = -(sign(1.d0, min4*xt)*bl_ad(i, j))
5107  bl_ad(i, j) = 0.0
5108  CALL popcontrol1b(branch)
5109  IF (branch .EQ. 0) THEN
5110  CALL poprealarray_adm(min4)
5111  y4_ad = min4_ad
5112  x4_ad = 0.0
5113  ELSE
5114  CALL poprealarray_adm(min4)
5115  x4_ad = min4_ad
5116  y4_ad = 0.0
5117  END IF
5118  CALL popcontrol1b(branch)
5119  IF (branch .EQ. 0) THEN
5120  al_ad(i, j) = al_ad(i, j) + y4_ad
5121  q_ad(i, j) = q_ad(i, j) - y4_ad
5122  ELSE
5123  q_ad(i, j) = q_ad(i, j) + y4_ad
5124  al_ad(i, j) = al_ad(i, j) - y4_ad
5125  END IF
5126  CALL popcontrol1b(branch)
5127  IF (branch .EQ. 0) THEN
5128  xt_ad = xt_ad + x4_ad
5129  ELSE
5130  xt_ad = xt_ad - x4_ad
5131  END IF
5132  dm_ad(i, j) = dm_ad(i, j) + 2.*xt_ad
5133  END DO
5134  END DO
5135  ELSE IF (branch .EQ. 1) THEN
5136  DO j=je1,js1,-1
5137  DO i=ilast,ifirst,-1
5138  xt = ppm_fac*dm(i, j)
5139  min7_ad = sign(1.d0, min7*xt)*br_ad(i, j)
5140  br_ad(i, j) = 0.0
5141  CALL popcontrol1b(branch)
5142  IF (branch .EQ. 0) THEN
5143  CALL poprealarray_adm(min7)
5144  y7_ad = min7_ad
5145  x7_ad = 0.0
5146  ELSE
5147  CALL poprealarray_adm(min7)
5148  x7_ad = min7_ad
5149  y7_ad = 0.0
5150  END IF
5151  CALL popcontrol1b(branch)
5152  IF (branch .EQ. 0) THEN
5153  al_ad(i, j+1) = al_ad(i, j+1) + y7_ad
5154  q_ad(i, j) = q_ad(i, j) - y7_ad
5155  ELSE
5156  q_ad(i, j) = q_ad(i, j) + y7_ad
5157  al_ad(i, j+1) = al_ad(i, j+1) - y7_ad
5158  END IF
5159  CALL popcontrol1b(branch)
5160  IF (branch .EQ. 0) THEN
5161  xt_ad = x7_ad
5162  ELSE
5163  xt_ad = -x7_ad
5164  END IF
5165  min6_ad = -(sign(1.d0, min6*xt)*bl_ad(i, j))
5166  bl_ad(i, j) = 0.0
5167  CALL popcontrol1b(branch)
5168  IF (branch .EQ. 0) THEN
5169  CALL poprealarray_adm(min6)
5170  y6_ad = min6_ad
5171  x6_ad = 0.0
5172  ELSE
5173  CALL poprealarray_adm(min6)
5174  x6_ad = min6_ad
5175  y6_ad = 0.0
5176  END IF
5177  CALL popcontrol1b(branch)
5178  IF (branch .EQ. 0) THEN
5179  al_ad(i, j) = al_ad(i, j) + y6_ad
5180  q_ad(i, j) = q_ad(i, j) - y6_ad
5181  ELSE
5182  q_ad(i, j) = q_ad(i, j) + y6_ad
5183  al_ad(i, j) = al_ad(i, j) - y6_ad
5184  END IF
5185  CALL popcontrol1b(branch)
5186  IF (branch .EQ. 0) THEN
5187  xt_ad = xt_ad + x6_ad
5188  ELSE
5189  xt_ad = xt_ad - x6_ad
5190  END IF
5191  dm_ad(i, j) = dm_ad(i, j) + ppm_fac*xt_ad
5192  END DO
5193  END DO
5194  ELSE
5195  dq_ad = 0.0
5196  DO j=je1,js1,-1
5197  DO i=ilast,ifirst,-1
5198  CALL popcontrol2b(branch)
5199  IF (branch .LT. 2) THEN
5200  IF (branch .EQ. 0) THEN
5201  GOTO 110
5202  ELSE
5203  y9_ad = bl_ad(i, j)
5204  bl_ad(i, j) = 0.0
5205  x9_ad = 0.0
5206  END IF
5207  ELSE IF (branch .EQ. 2) THEN
5208  x9_ad = bl_ad(i, j)
5209  bl_ad(i, j) = 0.0
5210  y9_ad = 0.0
5211  ELSE
5212  br_ad(i, j) = 0.0
5213  bl_ad(i, j) = 0.0
5214  GOTO 110
5215  END IF
5216  CALL popcontrol1b(branch)
5217  IF (branch .EQ. 0) THEN
5218  y15_ad = y9_ad
5219  ELSE
5220  bl_ad(i, j) = bl_ad(i, j) + y9_ad
5221  y15_ad = 0.0
5222  END IF
5223  CALL popcontrol2b(branch)
5224  IF (branch .LT. 2) THEN
5225  IF (branch .EQ. 0) THEN
5226  lac_1_ad = y15_ad
5227  pmp_1_ad = 0.0
5228  ELSE
5229  pmp_1_ad = y15_ad
5230  lac_1_ad = 0.0
5231  END IF
5232  ELSE
5233  IF (branch .EQ. 2) THEN
5234  lac_1_ad = y15_ad
5235  ELSE
5236  lac_1_ad = 0.0
5237  END IF
5238  pmp_1_ad = 0.0
5239  END IF
5240  CALL popcontrol2b(branch)
5241  IF (branch .LT. 2) THEN
5242  IF (branch .EQ. 0) THEN
5243  lac_1_ad = lac_1_ad + x9_ad
5244  ELSE
5245  pmp_1_ad = pmp_1_ad + x9_ad
5246  END IF
5247  ELSE IF (branch .EQ. 2) THEN
5248  lac_1_ad = lac_1_ad + x9_ad
5249  END IF
5250  pmp_1_ad = pmp_1_ad + lac_1_ad
5251  dq_ad(i, j+1) = dq_ad(i, j+1) + 0.75*lac_1_ad
5252  dq_ad(i, j) = dq_ad(i, j) - pmp_1_ad
5253  CALL popcontrol1b(branch)
5254  IF (branch .EQ. 0) THEN
5255  y8_ad = br_ad(i, j)
5256  br_ad(i, j) = 0.0
5257  x8_ad = 0.0
5258  ELSE
5259  x8_ad = br_ad(i, j)
5260  br_ad(i, j) = 0.0
5261  y8_ad = 0.0
5262  END IF
5263  CALL popcontrol1b(branch)
5264  IF (branch .EQ. 0) THEN
5265  y14_ad = y8_ad
5266  ELSE
5267  br_ad(i, j) = br_ad(i, j) + y8_ad
5268  y14_ad = 0.0
5269  END IF
5270  CALL popcontrol2b(branch)
5271  IF (branch .LT. 2) THEN
5272  IF (branch .EQ. 0) THEN
5273  lac_2_ad = y14_ad
5274  pmp_2_ad = 0.0
5275  ELSE
5276  pmp_2_ad = y14_ad
5277  lac_2_ad = 0.0
5278  END IF
5279  ELSE
5280  IF (branch .EQ. 2) THEN
5281  lac_2_ad = y14_ad
5282  ELSE
5283  lac_2_ad = 0.0
5284  END IF
5285  pmp_2_ad = 0.0
5286  END IF
5287  CALL popcontrol2b(branch)
5288  IF (branch .LT. 2) THEN
5289  IF (branch .EQ. 0) THEN
5290  lac_2_ad = lac_2_ad + x8_ad
5291  ELSE
5292  pmp_2_ad = pmp_2_ad + x8_ad
5293  END IF
5294  ELSE IF (branch .EQ. 2) THEN
5295  lac_2_ad = lac_2_ad + x8_ad
5296  END IF
5297  pmp_2_ad = pmp_2_ad + lac_2_ad
5298  dq_ad(i, j-2) = dq_ad(i, j-2) - 0.75*lac_2_ad
5299  dq_ad(i, j-1) = dq_ad(i, j-1) + pmp_2_ad
5300  110 al_ad(i, j+1) = al_ad(i, j+1) + br_ad(i, j)
5301  q_ad(i, j) = q_ad(i, j) - bl_ad(i, j) - br_ad(i, j)
5302  br_ad(i, j) = 0.0
5303  al_ad(i, j) = al_ad(i, j) + bl_ad(i, j)
5304  bl_ad(i, j) = 0.0
5305  END DO
5306  END DO
5307  DO j=je1+1,js1-2,-1
5308  DO i=ilast,ifirst,-1
5309  q_ad(i, j+1) = q_ad(i, j+1) + 2.*dq_ad(i, j)
5310  q_ad(i, j) = q_ad(i, j) - 2.*dq_ad(i, j)
5311  dq_ad(i, j) = 0.0
5312  END DO
5313  END DO
5314  END IF
5315  DO j=je1+1,js1,-1
5316  DO i=ilast,ifirst,-1
5317  q_ad(i, j-1) = q_ad(i, j-1) + 0.5*al_ad(i, j)
5318  q_ad(i, j) = q_ad(i, j) + 0.5*al_ad(i, j)
5319  dm_ad(i, j-1) = dm_ad(i, j-1) + r3*al_ad(i, j)
5320  dm_ad(i, j) = dm_ad(i, j) - r3*al_ad(i, j)
5321  al_ad(i, j) = 0.0
5322  END DO
5323  END DO
5324  DO j=je+2,js-2,-1
5325  DO i=ilast,ifirst,-1
5326  xt = 0.25*(q(i, j+1)-q(i, j-1))
5327  min3_ad = sign(1.d0, min3*xt)*dm_ad(i, j)
5328  dm_ad(i, j) = 0.0
5329  CALL popcontrol2b(branch)
5330  IF (branch .LT. 2) THEN
5331  IF (branch .EQ. 0) THEN
5332  CALL poprealarray_adm(min3)
5333  z1_ad = min3_ad
5334  y3_ad = 0.0
5335  ELSE
5336  CALL poprealarray_adm(min3)
5337  y3_ad = min3_ad
5338  z1_ad = 0.0
5339  END IF
5340  x3_ad = 0.0
5341  ELSE
5342  IF (branch .EQ. 2) THEN
5343  CALL poprealarray_adm(min3)
5344  z1_ad = min3_ad
5345  x3_ad = 0.0
5346  ELSE
5347  CALL poprealarray_adm(min3)
5348  x3_ad = min3_ad
5349  z1_ad = 0.0
5350  END IF
5351  y3_ad = 0.0
5352  END IF
5353  q_ad(i, j) = q_ad(i, j) + z1_ad
5354  min8_ad = -z1_ad
5355  CALL popcontrol2b(branch)
5356  IF (branch .LT. 2) THEN
5357  IF (branch .EQ. 0) THEN
5358  q_ad(i, j+1) = q_ad(i, j+1) + min8_ad
5359  ELSE
5360  q_ad(i, j) = q_ad(i, j) + min8_ad
5361  END IF
5362  ELSE IF (branch .EQ. 2) THEN
5363  q_ad(i, j+1) = q_ad(i, j+1) + min8_ad
5364  ELSE
5365  q_ad(i, j-1) = q_ad(i, j-1) + min8_ad
5366  END IF
5367  max1_ad = y3_ad
5368  q_ad(i, j) = q_ad(i, j) - y3_ad
5369  CALL popcontrol2b(branch)
5370  IF (branch .LT. 2) THEN
5371  IF (branch .EQ. 0) THEN
5372  q_ad(i, j+1) = q_ad(i, j+1) + max1_ad
5373  ELSE
5374  q_ad(i, j) = q_ad(i, j) + max1_ad
5375  END IF
5376  ELSE IF (branch .EQ. 2) THEN
5377  q_ad(i, j+1) = q_ad(i, j+1) + max1_ad
5378  ELSE
5379  q_ad(i, j-1) = q_ad(i, j-1) + max1_ad
5380  END IF
5381  CALL popcontrol1b(branch)
5382  IF (branch .EQ. 0) THEN
5383  xt_ad = x3_ad
5384  ELSE
5385  xt_ad = -x3_ad
5386  END IF
5387  q_ad(i, j+1) = q_ad(i, j+1) + 0.25*xt_ad
5388  q_ad(i, j-1) = q_ad(i, j-1) - 0.25*xt_ad
5389  END DO
5390  END DO
5391  END IF
5392  CALL popcontrol1b(branch)
5393  END SUBROUTINE yppm_adm
5394  SUBROUTINE yppm(flux, q, c, jord, ifirst, ilast, isd, ied, js, je, jsd&
5395 & , jed, npx, npy, dya, nested, grid_type)
5396  IMPLICIT NONE
5397 ! Compute domain
5398  INTEGER, INTENT(IN) :: ifirst, ilast
5399  INTEGER, INTENT(IN) :: isd, ied, js, je, jsd, jed
5400  INTEGER, INTENT(IN) :: jord
5401  INTEGER, INTENT(IN) :: npx, npy
5402  REAL, INTENT(IN) :: q(ifirst:ilast, jsd:jed)
5403 ! Courant number
5404  REAL, INTENT(IN) :: c(isd:ied, js:je+1)
5405 ! Flux
5406  REAL, INTENT(OUT) :: flux(ifirst:ilast, js:je+1)
5407  REAL, INTENT(IN) :: dya(isd:ied, jsd:jed)
5408  LOGICAL, INTENT(IN) :: nested
5409  INTEGER, INTENT(IN) :: grid_type
5410 ! Local:
5411  REAL :: dm(ifirst:ilast, js-2:je+2)
5412  REAL :: al(ifirst:ilast, js-1:je+2)
5413  REAL, DIMENSION(ifirst:ilast, js-1:je+1) :: bl, br, b0
5414  REAL :: dq(ifirst:ilast, js-3:je+2)
5415  REAL, DIMENSION(ifirst:ilast) :: fx0, fx1
5416  LOGICAL, DIMENSION(ifirst:ilast, js-1:je+1) :: smt5, smt6
5417  REAL :: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1
5418  INTEGER :: i, j, js1, je3, je1
5419  INTRINSIC max
5420  INTRINSIC min
5421  INTRINSIC abs
5422  INTRINSIC sign
5423  REAL :: min1
5424  REAL :: min2
5425  REAL :: abs0
5426  REAL :: abs1
5427  REAL :: min3
5428  REAL :: min4
5429  REAL :: min5
5430  REAL :: min6
5431  REAL :: min7
5432  REAL :: abs2
5433  REAL :: abs3
5434  REAL :: abs4
5435  REAL :: max1
5436  REAL :: min8
5437  REAL :: abs5
5438  REAL :: abs6
5439  REAL :: abs7
5440  INTEGER :: arg1
5441  REAL :: x9
5442  REAL :: x8
5443  REAL :: x7
5444  REAL :: x6
5445  REAL :: x5
5446  REAL :: x4
5447  REAL :: x3
5448  REAL :: x2
5449  REAL :: x1
5450  REAL :: y15
5451  REAL :: y14
5452  REAL :: y13
5453  REAL :: y12
5454  REAL :: y11
5455  REAL :: y10
5456  REAL :: z5
5457  REAL :: z4
5458  REAL :: z3
5459  REAL :: z2
5460  REAL :: z1
5461  REAL :: y9
5462  REAL :: y8
5463  REAL :: y7
5464  REAL :: y6
5465  REAL :: y5
5466  REAL :: y4
5467  REAL :: y3
5468  REAL :: y2
5469  REAL :: y1
5470  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
5471  IF (3 .LT. js - 1) THEN
5472  js1 = js - 1
5473  ELSE
5474  js1 = 3
5475  END IF
5476  IF (npy - 2 .GT. je + 2) THEN
5477  je3 = je + 2
5478  ELSE
5479  je3 = npy - 2
5480  END IF
5481  IF (npy - 3 .GT. je + 1) THEN
5482  je1 = je + 1
5483  ELSE
5484  je1 = npy - 3
5485  END IF
5486  ELSE
5487 ! Nested grid OR Doubly periodic domain:
5488  js1 = js - 1
5489  je3 = je + 2
5490  je1 = je + 1
5491  END IF
5492  IF (jord .LT. 8 .OR. jord .EQ. 333) THEN
5493  DO j=js1,je3
5494  DO i=ifirst,ilast
5495  al(i, j) = p1*(q(i, j-1)+q(i, j)) + p2*(q(i, j-2)+q(i, j+1))
5496  END DO
5497  END DO
5498  IF (jord .EQ. 7) THEN
5499  DO j=js1,je3
5500  DO i=ifirst,ilast
5501  IF (al(i, j) .LT. 0.) al(i, j) = 0.5*(q(i, j)+q(i, j+1))
5502  END DO
5503  END DO
5504  END IF
5505  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
5506  IF (js .EQ. 1) THEN
5507  DO i=ifirst,ilast
5508  al(i, 0) = c1*q(i, -2) + c2*q(i, -1) + c3*q(i, 0)
5509  al(i, 1) = 0.5*(((2.*dya(i, 0)+dya(i, -1))*q(i, 0)-dya(i, 0)&
5510 & *q(i, -1))/(dya(i, -1)+dya(i, 0))+((2.*dya(i, 1)+dya(i, 2)&
5511 & )*q(i, 1)-dya(i, 1)*q(i, 2))/(dya(i, 1)+dya(i, 2)))
5512  al(i, 2) = c3*q(i, 1) + c2*q(i, 2) + c1*q(i, 3)
5513  END DO
5514  IF (jord .EQ. 7) THEN
5515  DO i=ifirst,ilast
5516  IF (0. .LT. al(i, 0)) THEN
5517  al(i, 0) = al(i, 0)
5518  ELSE
5519  al(i, 0) = 0.
5520  END IF
5521  IF (0. .LT. al(i, 1)) THEN
5522  al(i, 1) = al(i, 1)
5523  ELSE
5524  al(i, 1) = 0.
5525  END IF
5526  IF (0. .LT. al(i, 2)) THEN
5527  al(i, 2) = al(i, 2)
5528  ELSE
5529  al(i, 2) = 0.
5530  END IF
5531  END DO
5532  END IF
5533  END IF
5534  IF (je + 1 .EQ. npy) THEN
5535  DO i=ifirst,ilast
5536  al(i, npy-1) = c1*q(i, npy-3) + c2*q(i, npy-2) + c3*q(i, npy&
5537 & -1)
5538  al(i, npy) = 0.5*(((2.*dya(i, npy-1)+dya(i, npy-2))*q(i, npy&
5539 & -1)-dya(i, npy-1)*q(i, npy-2))/(dya(i, npy-2)+dya(i, npy-1&
5540 & ))+((2.*dya(i, npy)+dya(i, npy+1))*q(i, npy)-dya(i, npy)*q&
5541 & (i, npy+1))/(dya(i, npy)+dya(i, npy+1)))
5542  al(i, npy+1) = c3*q(i, npy) + c2*q(i, npy+1) + c1*q(i, npy+2&
5543 & )
5544  END DO
5545  IF (jord .EQ. 7) THEN
5546  DO i=ifirst,ilast
5547  IF (0. .LT. al(i, npy-1)) THEN
5548  al(i, npy-1) = al(i, npy-1)
5549  ELSE
5550  al(i, npy-1) = 0.
5551  END IF
5552  IF (0. .LT. al(i, npy)) THEN
5553  al(i, npy) = al(i, npy)
5554  ELSE
5555  al(i, npy) = 0.
5556  END IF
5557  IF (0. .LT. al(i, npy+1)) THEN
5558  al(i, npy+1) = al(i, npy+1)
5559  ELSE
5560  al(i, npy+1) = 0.
5561  END IF
5562  END DO
5563  END IF
5564  END IF
5565  END IF
5566  IF (jord .EQ. 1) THEN
5567  DO j=js,je+1
5568  DO i=ifirst,ilast
5569  IF (c(i, j) .GT. 0.) THEN
5570  flux(i, j) = q(i, j-1)
5571  ELSE
5572  flux(i, j) = q(i, j)
5573  END IF
5574  END DO
5575  END DO
5576  ELSE IF (jord .EQ. 2) THEN
5577 ! Perfectly linear scheme
5578 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
5579  DO j=js,je+1
5580 !DEC$ VECTOR ALWAYS
5581  DO i=ifirst,ilast
5582  xt = c(i, j)
5583  IF (xt .GT. 0.) THEN
5584  qtmp = q(i, j-1)
5585  flux(i, j) = qtmp + (1.-xt)*(al(i, j)-qtmp-xt*(al(i, j-1)+&
5586 & al(i, j)-(qtmp+qtmp)))
5587  ELSE
5588  qtmp = q(i, j)
5589  flux(i, j) = qtmp + (1.+xt)*(al(i, j)-qtmp+xt*(al(i, j)+al&
5590 & (i, j+1)-(qtmp+qtmp)))
5591  END IF
5592  END DO
5593  END DO
5594  ELSE IF (jord .EQ. 333) THEN
5595 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
5596  DO j=js,je+1
5597 !DEC$ VECTOR ALWAYS
5598  DO i=ifirst,ilast
5599  xt = c(i, j)
5600  IF (xt .GT. 0.) THEN
5601  flux(i, j) = (2.0*q(i, j)+5.0*q(i, j-1)-q(i, j-2))/6.0 - &
5602 & 0.5*xt*(q(i, j)-q(i, j-1)) + xt*xt/6.0*(q(i, j)-2.0*q(i&
5603 & , j-1)+q(i, j-2))
5604  ELSE
5605  flux(i, j) = (2.0*q(i, j-1)+5.0*q(i, j)-q(i, j+1))/6.0 - &
5606 & 0.5*xt*(q(i, j)-q(i, j-1)) + xt*xt/6.0*(q(i, j+1)-2.0*q(&
5607 & i, j)+q(i, j-1))
5608  END IF
5609  END DO
5610  END DO
5611  ELSE IF (jord .EQ. 3) THEN
5612  DO j=js-1,je+1
5613  DO i=ifirst,ilast
5614  bl(i, j) = al(i, j) - q(i, j)
5615  br(i, j) = al(i, j+1) - q(i, j)
5616  b0(i, j) = bl(i, j) + br(i, j)
5617  IF (b0(i, j) .GE. 0.) THEN
5618  x0 = b0(i, j)
5619  ELSE
5620  x0 = -b0(i, j)
5621  END IF
5622  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5623  xt = bl(i, j) - br(i, j)
5624  ELSE
5625  xt = -(bl(i, j)-br(i, j))
5626  END IF
5627  smt5(i, j) = x0 .LT. xt
5628  smt6(i, j) = 3.*x0 .LT. xt
5629  END DO
5630  END DO
5631  DO j=js,je+1
5632  DO i=ifirst,ilast
5633  fx1(i) = 0.
5634  END DO
5635  DO i=ifirst,ilast
5636  xt = c(i, j)
5637  IF (xt .GT. 0.) THEN
5638  fx0(i) = q(i, j-1)
5639  IF (smt6(i, j-1) .OR. smt5(i, j)) THEN
5640  fx1(i) = br(i, j-1) - xt*b0(i, j-1)
5641  ELSE IF (smt5(i, j-1)) THEN
5642  IF (bl(i, j-1) .GE. 0.) THEN
5643  x1 = bl(i, j-1)
5644  ELSE
5645  x1 = -bl(i, j-1)
5646  END IF
5647  IF (br(i, j-1) .GE. 0.) THEN
5648  y1 = br(i, j-1)
5649  ELSE
5650  y1 = -br(i, j-1)
5651  END IF
5652  IF (x1 .GT. y1) THEN
5653  min1 = y1
5654  ELSE
5655  min1 = x1
5656  END IF
5657 ! both up-downwind sides are noisy; 2nd order, piece-wise linear
5658  fx1(i) = sign(min1, br(i, j-1))
5659  END IF
5660  ELSE
5661  fx0(i) = q(i, j)
5662  IF (smt6(i, j) .OR. smt5(i, j-1)) THEN
5663  fx1(i) = bl(i, j) + xt*b0(i, j)
5664  ELSE IF (smt5(i, j)) THEN
5665  IF (bl(i, j) .GE. 0.) THEN
5666  x2 = bl(i, j)
5667  ELSE
5668  x2 = -bl(i, j)
5669  END IF
5670  IF (br(i, j) .GE. 0.) THEN
5671  y2 = br(i, j)
5672  ELSE
5673  y2 = -br(i, j)
5674  END IF
5675  IF (x2 .GT. y2) THEN
5676  min2 = y2
5677  ELSE
5678  min2 = x2
5679  END IF
5680  fx1(i) = sign(min2, bl(i, j))
5681  END IF
5682  END IF
5683  IF (xt .GE. 0.) THEN
5684  abs0 = xt
5685  ELSE
5686  abs0 = -xt
5687  END IF
5688  flux(i, j) = fx0(i) + (1.-abs0)*fx1(i)
5689  END DO
5690  END DO
5691  ELSE IF (jord .EQ. 4) THEN
5692  DO j=js-1,je+1
5693  DO i=ifirst,ilast
5694  bl(i, j) = al(i, j) - q(i, j)
5695  br(i, j) = al(i, j+1) - q(i, j)
5696  b0(i, j) = bl(i, j) + br(i, j)
5697  IF (b0(i, j) .GE. 0.) THEN
5698  x0 = b0(i, j)
5699  ELSE
5700  x0 = -b0(i, j)
5701  END IF
5702  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5703  xt = bl(i, j) - br(i, j)
5704  ELSE
5705  xt = -(bl(i, j)-br(i, j))
5706  END IF
5707  smt5(i, j) = x0 .LT. xt
5708  smt6(i, j) = 3.*x0 .LT. xt
5709  END DO
5710  END DO
5711  DO j=js,je+1
5712  DO i=ifirst,ilast
5713  fx1(i) = 0.
5714  END DO
5715 !DEC$ VECTOR ALWAYS
5716  DO i=ifirst,ilast
5717  IF (c(i, j) .GT. 0.) THEN
5718  fx0(i) = q(i, j-1)
5719  IF (smt6(i, j-1) .OR. smt5(i, j)) fx1(i) = (1.-c(i, j))*(&
5720 & br(i, j-1)-c(i, j)*b0(i, j-1))
5721  ELSE
5722  fx0(i) = q(i, j)
5723  IF (smt6(i, j) .OR. smt5(i, j-1)) fx1(i) = (1.+c(i, j))*(&
5724 & bl(i, j)+c(i, j)*b0(i, j))
5725  END IF
5726  flux(i, j) = fx0(i) + fx1(i)
5727  END DO
5728  END DO
5729  ELSE
5730 ! jord=5,6,7
5731  IF (jord .EQ. 5) THEN
5732  DO j=js-1,je+1
5733  DO i=ifirst,ilast
5734  bl(i, j) = al(i, j) - q(i, j)
5735  br(i, j) = al(i, j+1) - q(i, j)
5736  b0(i, j) = bl(i, j) + br(i, j)
5737  smt5(i, j) = bl(i, j)*br(i, j) .LT. 0.
5738  END DO
5739  END DO
5740  ELSE
5741  DO j=js-1,je+1
5742  DO i=ifirst,ilast
5743  bl(i, j) = al(i, j) - q(i, j)
5744  br(i, j) = al(i, j+1) - q(i, j)
5745  b0(i, j) = bl(i, j) + br(i, j)
5746  IF (3.*b0(i, j) .GE. 0.) THEN
5747  abs1 = 3.*b0(i, j)
5748  ELSE
5749  abs1 = -(3.*b0(i, j))
5750  END IF
5751  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5752  abs4 = bl(i, j) - br(i, j)
5753  ELSE
5754  abs4 = -(bl(i, j)-br(i, j))
5755  END IF
5756  smt5(i, j) = abs1 .LT. abs4
5757  END DO
5758  END DO
5759  END IF
5760  DO j=js,je+1
5761 !DEC$ VECTOR ALWAYS
5762  DO i=ifirst,ilast
5763  IF (c(i, j) .GT. 0.) THEN
5764  fx1(i) = (1.-c(i, j))*(br(i, j-1)-c(i, j)*b0(i, j-1))
5765  flux(i, j) = q(i, j-1)
5766  ELSE
5767  fx1(i) = (1.+c(i, j))*(bl(i, j)+c(i, j)*b0(i, j))
5768  flux(i, j) = q(i, j)
5769  END IF
5770  IF (smt5(i, j-1) .OR. smt5(i, j)) flux(i, j) = flux(i, j) + &
5771 & fx1(i)
5772  END DO
5773  END DO
5774  END IF
5775  RETURN
5776  ELSE
5777 ! Monotonic constraints:
5778 ! ord = 8: PPM with Lin's PPM fast monotone constraint
5779 ! ord > 8: PPM with Lin's modification of Huynh 2nd constraint
5780  DO j=js-2,je+2
5781  DO i=ifirst,ilast
5782  xt = 0.25*(q(i, j+1)-q(i, j-1))
5783  IF (xt .GE. 0.) THEN
5784  x3 = xt
5785  ELSE
5786  x3 = -xt
5787  END IF
5788  IF (q(i, j-1) .LT. q(i, j)) THEN
5789  IF (q(i, j) .LT. q(i, j+1)) THEN
5790  max1 = q(i, j+1)
5791  ELSE
5792  max1 = q(i, j)
5793  END IF
5794  ELSE IF (q(i, j-1) .LT. q(i, j+1)) THEN
5795  max1 = q(i, j+1)
5796  ELSE
5797  max1 = q(i, j-1)
5798  END IF
5799  y3 = max1 - q(i, j)
5800  IF (q(i, j-1) .GT. q(i, j)) THEN
5801  IF (q(i, j) .GT. q(i, j+1)) THEN
5802  min8 = q(i, j+1)
5803  ELSE
5804  min8 = q(i, j)
5805  END IF
5806  ELSE IF (q(i, j-1) .GT. q(i, j+1)) THEN
5807  min8 = q(i, j+1)
5808  ELSE
5809  min8 = q(i, j-1)
5810  END IF
5811  z1 = q(i, j) - min8
5812  IF (x3 .GT. y3) THEN
5813  IF (y3 .GT. z1) THEN
5814  min3 = z1
5815  ELSE
5816  min3 = y3
5817  END IF
5818  ELSE IF (x3 .GT. z1) THEN
5819  min3 = z1
5820  ELSE
5821  min3 = x3
5822  END IF
5823  dm(i, j) = sign(min3, xt)
5824  END DO
5825  END DO
5826  DO j=js1,je1+1
5827  DO i=ifirst,ilast
5828  al(i, j) = 0.5*(q(i, j-1)+q(i, j)) + r3*(dm(i, j-1)-dm(i, j))
5829  END DO
5830  END DO
5831  IF (jord .EQ. 8) THEN
5832  DO j=js1,je1
5833  DO i=ifirst,ilast
5834  xt = 2.*dm(i, j)
5835  IF (xt .GE. 0.) THEN
5836  x4 = xt
5837  ELSE
5838  x4 = -xt
5839  END IF
5840  IF (al(i, j) - q(i, j) .GE. 0.) THEN
5841  y4 = al(i, j) - q(i, j)
5842  ELSE
5843  y4 = -(al(i, j)-q(i, j))
5844  END IF
5845  IF (x4 .GT. y4) THEN
5846  min4 = y4
5847  ELSE
5848  min4 = x4
5849  END IF
5850  bl(i, j) = -sign(min4, xt)
5851  IF (xt .GE. 0.) THEN
5852  x5 = xt
5853  ELSE
5854  x5 = -xt
5855  END IF
5856  IF (al(i, j+1) - q(i, j) .GE. 0.) THEN
5857  y5 = al(i, j+1) - q(i, j)
5858  ELSE
5859  y5 = -(al(i, j+1)-q(i, j))
5860  END IF
5861  IF (x5 .GT. y5) THEN
5862  min5 = y5
5863  ELSE
5864  min5 = x5
5865  END IF
5866  br(i, j) = sign(min5, xt)
5867  END DO
5868  END DO
5869  ELSE IF (jord .EQ. 11) THEN
5870  DO j=js1,je1
5871  DO i=ifirst,ilast
5872  xt = ppm_fac*dm(i, j)
5873  IF (xt .GE. 0.) THEN
5874  x6 = xt
5875  ELSE
5876  x6 = -xt
5877  END IF
5878  IF (al(i, j) - q(i, j) .GE. 0.) THEN
5879  y6 = al(i, j) - q(i, j)
5880  ELSE
5881  y6 = -(al(i, j)-q(i, j))
5882  END IF
5883  IF (x6 .GT. y6) THEN
5884  min6 = y6
5885  ELSE
5886  min6 = x6
5887  END IF
5888  bl(i, j) = -sign(min6, xt)
5889  IF (xt .GE. 0.) THEN
5890  x7 = xt
5891  ELSE
5892  x7 = -xt
5893  END IF
5894  IF (al(i, j+1) - q(i, j) .GE. 0.) THEN
5895  y7 = al(i, j+1) - q(i, j)
5896  ELSE
5897  y7 = -(al(i, j+1)-q(i, j))
5898  END IF
5899  IF (x7 .GT. y7) THEN
5900  min7 = y7
5901  ELSE
5902  min7 = x7
5903  END IF
5904  br(i, j) = sign(min7, xt)
5905  END DO
5906  END DO
5907  ELSE
5908  DO j=js1-2,je1+1
5909  DO i=ifirst,ilast
5910  dq(i, j) = 2.*(q(i, j+1)-q(i, j))
5911  END DO
5912  END DO
5913  DO j=js1,je1
5914  DO i=ifirst,ilast
5915  bl(i, j) = al(i, j) - q(i, j)
5916  br(i, j) = al(i, j+1) - q(i, j)
5917  IF (dm(i, j-1) .GE. 0.) THEN
5918  abs2 = dm(i, j-1)
5919  ELSE
5920  abs2 = -dm(i, j-1)
5921  END IF
5922  IF (dm(i, j) .GE. 0.) THEN
5923  abs5 = dm(i, j)
5924  ELSE
5925  abs5 = -dm(i, j)
5926  END IF
5927  IF (dm(i, j+1) .GE. 0.) THEN
5928  abs7 = dm(i, j+1)
5929  ELSE
5930  abs7 = -dm(i, j+1)
5931  END IF
5932  IF (abs2 + abs5 + abs7 .LT. near_zero) THEN
5933  bl(i, j) = 0.
5934  br(i, j) = 0.
5935  ELSE
5936  IF (3.*(bl(i, j)+br(i, j)) .GE. 0.) THEN
5937  abs3 = 3.*(bl(i, j)+br(i, j))
5938  ELSE
5939  abs3 = -(3.*(bl(i, j)+br(i, j)))
5940  END IF
5941  IF (bl(i, j) - br(i, j) .GE. 0.) THEN
5942  abs6 = bl(i, j) - br(i, j)
5943  ELSE
5944  abs6 = -(bl(i, j)-br(i, j))
5945  END IF
5946  IF (abs3 .GT. abs6) THEN
5947  pmp_2 = dq(i, j-1)
5948  lac_2 = pmp_2 - 0.75*dq(i, j-2)
5949  IF (0. .LT. pmp_2) THEN
5950  IF (pmp_2 .LT. lac_2) THEN
5951  x8 = lac_2
5952  ELSE
5953  x8 = pmp_2
5954  END IF
5955  ELSE IF (0. .LT. lac_2) THEN
5956  x8 = lac_2
5957  ELSE
5958  x8 = 0.
5959  END IF
5960  IF (0. .GT. pmp_2) THEN
5961  IF (pmp_2 .GT. lac_2) THEN
5962  y14 = lac_2
5963  ELSE
5964  y14 = pmp_2
5965  END IF
5966  ELSE IF (0. .GT. lac_2) THEN
5967  y14 = lac_2
5968  ELSE
5969  y14 = 0.
5970  END IF
5971  IF (br(i, j) .LT. y14) THEN
5972  y8 = y14
5973  ELSE
5974  y8 = br(i, j)
5975  END IF
5976  IF (x8 .GT. y8) THEN
5977  br(i, j) = y8
5978  ELSE
5979  br(i, j) = x8
5980  END IF
5981  pmp_1 = -dq(i, j)
5982  lac_1 = pmp_1 + 0.75*dq(i, j+1)
5983  IF (0. .LT. pmp_1) THEN
5984  IF (pmp_1 .LT. lac_1) THEN
5985  x9 = lac_1
5986  ELSE
5987  x9 = pmp_1
5988  END IF
5989  ELSE IF (0. .LT. lac_1) THEN
5990  x9 = lac_1
5991  ELSE
5992  x9 = 0.
5993  END IF
5994  IF (0. .GT. pmp_1) THEN
5995  IF (pmp_1 .GT. lac_1) THEN
5996  y15 = lac_1
5997  ELSE
5998  y15 = pmp_1
5999  END IF
6000  ELSE IF (0. .GT. lac_1) THEN
6001  y15 = lac_1
6002  ELSE
6003  y15 = 0.
6004  END IF
6005  IF (bl(i, j) .LT. y15) THEN
6006  y9 = y15
6007  ELSE
6008  y9 = bl(i, j)
6009  END IF
6010  IF (x9 .GT. y9) THEN
6011  bl(i, j) = y9
6012  ELSE
6013  bl(i, j) = x9
6014  END IF
6015  END IF
6016  END IF
6017  END DO
6018  END DO
6019  END IF
6020  IF (jord .EQ. 9 .OR. jord .EQ. 13) THEN
6021 ! Positive definite constraint:
6022  DO j=js1,je1
6023  arg1 = ilast - ifirst + 1
6024  CALL pert_ppm(arg1, q(ifirst:ilast, j), bl(ifirst:ilast, j), &
6025 & br(ifirst:ilast, j), 0)
6026  END DO
6027  END IF
6028  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
6029  IF (js .EQ. 1) THEN
6030  DO i=ifirst,ilast
6031  bl(i, 0) = s14*dm(i, -1) + s11*(q(i, -1)-q(i, 0))
6032  xt = 0.5*(((2.*dya(i, 0)+dya(i, -1))*q(i, 0)-dya(i, 0)*q(i, &
6033 & -1))/(dya(i, -1)+dya(i, 0))+((2.*dya(i, 1)+dya(i, 2))*q(i&
6034 & , 1)-dya(i, 1)*q(i, 2))/(dya(i, 1)+dya(i, 2)))
6035  IF (q(i, 1) .GT. q(i, 2)) THEN
6036  z2 = q(i, 2)
6037  ELSE
6038  z2 = q(i, 1)
6039  END IF
6040  IF (q(i, -1) .GT. q(i, 0)) THEN
6041  IF (q(i, 0) .GT. z2) THEN
6042  y10 = z2
6043  ELSE
6044  y10 = q(i, 0)
6045  END IF
6046  ELSE IF (q(i, -1) .GT. z2) THEN
6047  y10 = z2
6048  ELSE
6049  y10 = q(i, -1)
6050  END IF
6051  IF (xt .LT. y10) THEN
6052  xt = y10
6053  ELSE
6054  xt = xt
6055  END IF
6056  IF (q(i, 1) .LT. q(i, 2)) THEN
6057  z3 = q(i, 2)
6058  ELSE
6059  z3 = q(i, 1)
6060  END IF
6061  IF (q(i, -1) .LT. q(i, 0)) THEN
6062  IF (q(i, 0) .LT. z3) THEN
6063  y11 = z3
6064  ELSE
6065  y11 = q(i, 0)
6066  END IF
6067  ELSE IF (q(i, -1) .LT. z3) THEN
6068  y11 = z3
6069  ELSE
6070  y11 = q(i, -1)
6071  END IF
6072  IF (xt .GT. y11) THEN
6073  xt = y11
6074  ELSE
6075  xt = xt
6076  END IF
6077 ! endif
6078  br(i, 0) = xt - q(i, 0)
6079  bl(i, 1) = xt - q(i, 1)
6080  xt = s15*q(i, 1) + s11*q(i, 2) - s14*dm(i, 2)
6081  br(i, 1) = xt - q(i, 1)
6082  bl(i, 2) = xt - q(i, 2)
6083  br(i, 2) = al(i, 3) - q(i, 2)
6084  END DO
6085  arg1 = 3*(ilast-ifirst+1)
6086  CALL pert_ppm(arg1, q(ifirst:ilast, 0:2), bl(ifirst:ilast, 0:2&
6087 & ), br(ifirst:ilast, 0:2), 1)
6088  END IF
6089  IF (je + 1 .EQ. npy) THEN
6090  DO i=ifirst,ilast
6091  bl(i, npy-2) = al(i, npy-2) - q(i, npy-2)
6092  xt = s15*q(i, npy-1) + s11*q(i, npy-2) + s14*dm(i, npy-2)
6093  br(i, npy-2) = xt - q(i, npy-2)
6094  bl(i, npy-1) = xt - q(i, npy-1)
6095  xt = 0.5*(((2.*dya(i, npy-1)+dya(i, npy-2))*q(i, npy-1)-dya(&
6096 & i, npy-1)*q(i, npy-2))/(dya(i, npy-2)+dya(i, npy-1))+((2.*&
6097 & dya(i, npy)+dya(i, npy+1))*q(i, npy)-dya(i, npy)*q(i, npy+&
6098 & 1))/(dya(i, npy)+dya(i, npy+1)))
6099  IF (q(i, npy) .GT. q(i, npy+1)) THEN
6100  z4 = q(i, npy+1)
6101  ELSE
6102  z4 = q(i, npy)
6103  END IF
6104  IF (q(i, npy-2) .GT. q(i, npy-1)) THEN
6105  IF (q(i, npy-1) .GT. z4) THEN
6106  y12 = z4
6107  ELSE
6108  y12 = q(i, npy-1)
6109  END IF
6110  ELSE IF (q(i, npy-2) .GT. z4) THEN
6111  y12 = z4
6112  ELSE
6113  y12 = q(i, npy-2)
6114  END IF
6115  IF (xt .LT. y12) THEN
6116  xt = y12
6117  ELSE
6118  xt = xt
6119  END IF
6120  IF (q(i, npy) .LT. q(i, npy+1)) THEN
6121  z5 = q(i, npy+1)
6122  ELSE
6123  z5 = q(i, npy)
6124  END IF
6125  IF (q(i, npy-2) .LT. q(i, npy-1)) THEN
6126  IF (q(i, npy-1) .LT. z5) THEN
6127  y13 = z5
6128  ELSE
6129  y13 = q(i, npy-1)
6130  END IF
6131  ELSE IF (q(i, npy-2) .LT. z5) THEN
6132  y13 = z5
6133  ELSE
6134  y13 = q(i, npy-2)
6135  END IF
6136  IF (xt .GT. y13) THEN
6137  xt = y13
6138  ELSE
6139  xt = xt
6140  END IF
6141 ! endif
6142  br(i, npy-1) = xt - q(i, npy-1)
6143  bl(i, npy) = xt - q(i, npy)
6144  br(i, npy) = s11*(q(i, npy+1)-q(i, npy)) - s14*dm(i, npy+1)
6145  END DO
6146  arg1 = 3*(ilast-ifirst+1)
6147  CALL pert_ppm(arg1, q(ifirst:ilast, npy-2:npy), bl(ifirst:&
6148 & ilast, npy-2:npy), br(ifirst:ilast, npy-2:npy), 1)
6149  END IF
6150  END IF
6151  DO j=js,je+1
6152  DO i=ifirst,ilast
6153  IF (c(i, j) .GT. 0.) THEN
6154  flux(i, j) = q(i, j-1) + (1.-c(i, j))*(br(i, j-1)-c(i, j)*(&
6155 & bl(i, j-1)+br(i, j-1)))
6156  ELSE
6157  flux(i, j) = q(i, j) + (1.+c(i, j))*(bl(i, j)+c(i, j)*(bl(i&
6158 & , j)+br(i, j)))
6159  END IF
6160  END DO
6161  END DO
6162  END IF
6163  END SUBROUTINE yppm
6164  SUBROUTINE mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
6165 & kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
6166  IMPLICIT NONE
6167 !
6168 ! !INPUT PARAMETERS:
6169  INTEGER, INTENT(IN) :: im, jm, km, nq
6170  INTEGER, INTENT(IN) :: ifirst, ilast
6171  INTEGER, INTENT(IN) :: jfirst, jlast
6172  INTEGER, INTENT(IN) :: kfirst, klast
6173 ! eastern zones to ghost
6174  INTEGER, INTENT(IN) :: ng_e
6175 ! western zones to ghost
6176  INTEGER, INTENT(IN) :: ng_w
6177 ! southern zones to ghost
6178  INTEGER, INTENT(IN) :: ng_s
6179 ! northern zones to ghost
6180  INTEGER, INTENT(IN) :: ng_n
6181  REAL, INTENT(INOUT) :: q_ghst(ifirst-ng_w:ilast+ng_e, jfirst-ng_s:&
6182 & jlast+ng_n, kfirst:klast, nq)
6183  REAL, OPTIONAL, INTENT(IN) :: q(ifirst:ilast, jfirst:jlast, kfirst:&
6184 & klast, nq)
6185 !
6186 ! !DESCRIPTION:
6187 !
6188 ! Ghost 4d east/west
6189 !
6190 ! !REVISION HISTORY:
6191 ! 2005.08.22 Putman
6192 !
6193 !EOP
6194 !------------------------------------------------------------------------------
6195 !BOC
6196  INTEGER :: i, j, k, n
6197  INTRINSIC PRESENT
6198  IF (PRESENT(q)) q_ghst(ifirst:ilast, jfirst:jlast, kfirst:klast, 1:&
6199 & nq) = q(ifirst:ilast, jfirst:jlast, kfirst:klast, 1:nq)
6200 ! Assume Periodicity in X-dir and not overlapping
6201  DO n=1,nq
6202  DO k=kfirst,klast
6203  DO j=jfirst-ng_s,jlast+ng_n
6204  DO i=1,ng_w
6205  q_ghst(ifirst-i, j, k, n) = q_ghst(ilast-i+1, j, k, n)
6206  END DO
6207  DO i=1,ng_e
6208  q_ghst(ilast+i, j, k, n) = q_ghst(ifirst+i-1, j, k, n)
6209  END DO
6210  END DO
6211  END DO
6212  END DO
6213  END SUBROUTINE mp_ghost_ew
6214 ! Differentiation of pert_ppm in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_c
6215 !ore_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_
6216 !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_mo
6217 !d.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamic
6218 !s_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_m
6219 !od.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
6220 !.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.scalar
6221 !_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.steep
6222 !z 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_se
6223 !tup 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.comp
6224 !ute_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
6225 ! 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_solver n
6226 !h_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 sw_
6227 !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_core_
6228 !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.co
6229 !mpute_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_
6230 !fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle
6231 !_dist sw_core_mod.edge_interpolate4)):
6232 ! gradient of useful results: al ar
6233 ! with respect to varying inputs: al ar
6234  SUBROUTINE pert_ppm_adm(im, a0, al, al_ad, ar, ar_ad, iv)
6235  IMPLICIT NONE
6236  INTEGER, INTENT(IN) :: im
6237  INTEGER, INTENT(IN) :: iv
6238  REAL, INTENT(IN) :: a0(im)
6239  REAL, INTENT(INOUT) :: al(im), ar(im)
6240  REAL, INTENT(INOUT) :: al_ad(im), ar_ad(im)
6241 ! Local:
6242  REAL :: a4, da1, da2, a6da, fmin
6243  INTEGER :: i
6244  REAL, PARAMETER :: r12=1./12.
6245  INTRINSIC abs
6246  REAL :: abs0
6247  INTEGER :: branch
6248 !-----------------------------------
6249 ! Optimized PPM in perturbation form:
6250 !-----------------------------------
6251  IF (iv .EQ. 0) THEN
6252 ! Positive definite constraint
6253  DO i=1,im
6254  IF (a0(i) .LE. 0.) THEN
6255  CALL pushcontrol3b(5)
6256  ELSE
6257  a4 = -(3.*(ar(i)+al(i)))
6258  da1 = ar(i) - al(i)
6259  IF (da1 .GE. 0.) THEN
6260  abs0 = da1
6261  ELSE
6262  abs0 = -da1
6263  END IF
6264  IF (abs0 .LT. -a4) THEN
6265  fmin = a0(i) + 0.25/a4*da1**2 + a4*r12
6266  IF (fmin .LT. 0.) THEN
6267  IF (ar(i) .GT. 0. .AND. al(i) .GT. 0.) THEN
6268  CALL pushcontrol3b(4)
6269  ELSE IF (da1 .GT. 0.) THEN
6270  CALL pushcontrol3b(3)
6271  ELSE
6272  CALL pushcontrol3b(2)
6273  END IF
6274  ELSE
6275  CALL pushcontrol3b(1)
6276  END IF
6277  ELSE
6278  CALL pushcontrol3b(0)
6279  END IF
6280  END IF
6281  END DO
6282  DO i=im,1,-1
6283  CALL popcontrol3b(branch)
6284  IF (branch .LT. 3) THEN
6285  IF (branch .NE. 0) THEN
6286  IF (branch .NE. 1) THEN
6287  ar_ad(i) = ar_ad(i) - 2.*al_ad(i)
6288  al_ad(i) = 0.0
6289  END IF
6290  END IF
6291  ELSE IF (branch .EQ. 3) THEN
6292  al_ad(i) = al_ad(i) - 2.*ar_ad(i)
6293  ar_ad(i) = 0.0
6294  ELSE IF (branch .EQ. 4) THEN
6295  al_ad(i) = 0.0
6296  ar_ad(i) = 0.0
6297  ELSE
6298  ar_ad(i) = 0.0
6299  al_ad(i) = 0.0
6300  END IF
6301  END DO
6302  ELSE
6303 ! Standard PPM constraint
6304  DO i=1,im
6305  IF (al(i)*ar(i) .LT. 0.) THEN
6306  da1 = al(i) - ar(i)
6307  da2 = da1**2
6308  a6da = 3.*(al(i)+ar(i))*da1
6309 ! abs(a6da) > da2 --> 3.*abs(al+ar) > abs(al-ar)
6310  IF (a6da .LT. -da2) THEN
6311  CALL pushcontrol2b(3)
6312  ELSE IF (a6da .GT. da2) THEN
6313  CALL pushcontrol2b(2)
6314  ELSE
6315  CALL pushcontrol2b(1)
6316  END IF
6317  ELSE
6318  CALL pushcontrol2b(0)
6319  END IF
6320  END DO
6321  DO i=im,1,-1
6322  CALL popcontrol2b(branch)
6323  IF (branch .LT. 2) THEN
6324  IF (branch .EQ. 0) THEN
6325  ar_ad(i) = 0.0
6326  al_ad(i) = 0.0
6327  END IF
6328  ELSE IF (branch .EQ. 2) THEN
6329  ar_ad(i) = ar_ad(i) - 2.*al_ad(i)
6330  al_ad(i) = 0.0
6331  ELSE
6332  al_ad(i) = al_ad(i) - 2.*ar_ad(i)
6333  ar_ad(i) = 0.0
6334  END IF
6335  END DO
6336  END IF
6337  END SUBROUTINE pert_ppm_adm
6338  SUBROUTINE pert_ppm(im, a0, al, ar, iv)
6339  IMPLICIT NONE
6340  INTEGER, INTENT(IN) :: im
6341  INTEGER, INTENT(IN) :: iv
6342  REAL, INTENT(IN) :: a0(im)
6343  REAL, INTENT(INOUT) :: al(im), ar(im)
6344 ! Local:
6345  REAL :: a4, da1, da2, a6da, fmin
6346  INTEGER :: i
6347  REAL, PARAMETER :: r12=1./12.
6348  INTRINSIC abs
6349  REAL :: abs0
6350 !-----------------------------------
6351 ! Optimized PPM in perturbation form:
6352 !-----------------------------------
6353  IF (iv .EQ. 0) THEN
6354 ! Positive definite constraint
6355  DO i=1,im
6356  IF (a0(i) .LE. 0.) THEN
6357  al(i) = 0.
6358  ar(i) = 0.
6359  ELSE
6360  a4 = -(3.*(ar(i)+al(i)))
6361  da1 = ar(i) - al(i)
6362  IF (da1 .GE. 0.) THEN
6363  abs0 = da1
6364  ELSE
6365  abs0 = -da1
6366  END IF
6367  IF (abs0 .LT. -a4) THEN
6368  fmin = a0(i) + 0.25/a4*da1**2 + a4*r12
6369  IF (fmin .LT. 0.) THEN
6370  IF (ar(i) .GT. 0. .AND. al(i) .GT. 0.) THEN
6371  ar(i) = 0.
6372  al(i) = 0.
6373  ELSE IF (da1 .GT. 0.) THEN
6374  ar(i) = -(2.*al(i))
6375  ELSE
6376  al(i) = -(2.*ar(i))
6377  END IF
6378  END IF
6379  END IF
6380  END IF
6381  END DO
6382  ELSE
6383 ! Standard PPM constraint
6384  DO i=1,im
6385  IF (al(i)*ar(i) .LT. 0.) THEN
6386  da1 = al(i) - ar(i)
6387  da2 = da1**2
6388  a6da = 3.*(al(i)+ar(i))*da1
6389 ! abs(a6da) > da2 --> 3.*abs(al+ar) > abs(al-ar)
6390  IF (a6da .LT. -da2) THEN
6391  ar(i) = -(2.*al(i))
6392  ELSE IF (a6da .GT. da2) THEN
6393  al(i) = -(2.*ar(i))
6394  END IF
6395  ELSE
6396 ! effect of dm=0 included here
6397  al(i) = 0.
6398  ar(i) = 0.
6399  END IF
6400  END DO
6401  END IF
6402  END SUBROUTINE pert_ppm
6403 ! Differentiation of deln_flux in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_
6404 !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 dyn
6405 !_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_m
6406 !od.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynami
6407 !cs_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_
6408 !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_mo
6409 !d.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.scala
6410 !r_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.stee
6411 !pz 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_s
6412 !etup 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.com
6413 !pute_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_
6414 !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_solver
6415 !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 sw
6416 !_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_core
6417 !_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.c
6418 !ompute_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
6419 !_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circl
6420 !e_dist sw_core_mod.edge_interpolate4)):
6421 ! gradient of useful results: q mass fx fy
6422 ! with respect to varying inputs: q mass fx fy
6423  SUBROUTINE deln_flux_adm(nord, is, ie, js, je, npx, npy, damp, q, q_ad&
6424 & , fx, fx_ad, fy, fy_ad, gridstruct, bd, mass, mass_ad)
6425  IMPLICIT NONE
6426 ! Del-n damping for the cell-mean values (A grid)
6427 !------------------
6428 ! nord = 0: del-2
6429 ! nord = 1: del-4
6430 ! nord = 2: del-6
6431 ! nord = 3: del-8 --> requires more ghosting than current
6432 !------------------
6433  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6434 ! del-n
6435  INTEGER, INTENT(IN) :: nord
6436  INTEGER, INTENT(IN) :: is, ie, js, je, npx, npy
6437  REAL, INTENT(IN) :: damp
6438 ! q ghosted on input
6439  REAL, INTENT(IN) :: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
6440  REAL :: q_ad(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
6441  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
6442 ! q ghosted on input
6443  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
6444  REAL, OPTIONAL :: mass_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6445 ! diffusive fluxes:
6446  REAL, INTENT(INOUT) :: fx(bd%is:bd%ie+1, bd%js:bd%je), fy(bd%is:bd%&
6447 & ie, bd%js:bd%je+1)
6448  REAL, INTENT(INOUT) :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je), fy_ad(bd%&
6449 & is:bd%ie, bd%js:bd%je+1)
6450 ! local:
6451  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd:bd%ied, bd%&
6452 & jsd:bd%jed+1)
6453  REAL :: fx2_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2_ad(bd%isd:bd%ied&
6454 & , bd%jsd:bd%jed+1)
6455  REAL :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
6456  REAL :: d2_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6457  REAL :: damp2
6458  INTEGER :: i, j, n, nt, i1, i2, j1, j2
6459  INTRINSIC PRESENT
6460  REAL :: temp_ad
6461  REAL :: temp_ad0
6462  REAL :: temp_ad1
6463  REAL :: temp_ad2
6464  REAL :: temp_ad3
6465  REAL :: temp_ad4
6466  REAL :: temp_ad5
6467  INTEGER :: ad_from
6468  INTEGER :: ad_to
6469  INTEGER :: ad_from0
6470  INTEGER :: ad_to0
6471  INTEGER :: ad_from1
6472  INTEGER :: ad_to1
6473  INTEGER :: ad_from2
6474  INTEGER :: ad_to2
6475  INTEGER :: ad_from3
6476  INTEGER :: ad_to3
6477  INTEGER :: ad_from4
6478  INTEGER :: ad_to4
6479  INTEGER :: branch
6480  i1 = is - 1 - nord
6481  i2 = ie + 1 + nord
6482  j1 = js - 1 - nord
6483  j2 = je + 1 + nord
6484  IF (.NOT.PRESENT(mass)) THEN
6485  DO j=j1,j2
6486  DO i=i1,i2
6487  d2(i, j) = damp*q(i, j)
6488  END DO
6489  END DO
6490  CALL pushcontrol1b(0)
6491  ELSE
6492  DO j=j1,j2
6493  DO i=i1,i2
6494  d2(i, j) = q(i, j)
6495  END DO
6496  END DO
6497  CALL pushcontrol1b(1)
6498  END IF
6499  IF (nord .GT. 0) THEN
6500  CALL copy_corners(d2, npx, npy, 1, gridstruct%nested, bd, &
6501 & gridstruct%sw_corner, gridstruct%se_corner, gridstruct&
6502 & %nw_corner, gridstruct%ne_corner)
6503  CALL pushcontrol1b(1)
6504  ELSE
6505  CALL pushcontrol1b(0)
6506  END IF
6507  DO j=js-nord,je+nord
6508  DO i=is-nord,ie+nord+1
6509  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
6510  END DO
6511  END DO
6512  IF (nord .GT. 0) THEN
6513  CALL copy_corners(d2, npx, npy, 2, gridstruct%nested, bd, &
6514 & gridstruct%sw_corner, gridstruct%se_corner, gridstruct&
6515 & %nw_corner, gridstruct%ne_corner)
6516  CALL pushcontrol1b(1)
6517  ELSE
6518  CALL pushcontrol1b(0)
6519  END IF
6520  DO j=js-nord,je+nord+1
6521  DO i=is-nord,ie+nord
6522  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
6523  END DO
6524  END DO
6525  IF (nord .GT. 0) THEN
6526 !----------
6527 ! high-order
6528 !----------
6529  DO n=1,nord
6530  nt = nord - n
6531  ad_from0 = js - nt - 1
6532  DO j=ad_from0,je+nt+1
6533  ad_from = is - nt - 1
6534  DO i=ad_from,ie+nt+1
6535  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+fy2(i, j)-fy2(i, j+1))*&
6536 & gridstruct%rarea(i, j)
6537  END DO
6538  CALL pushinteger4(i - 1)
6539  CALL pushinteger4(ad_from)
6540  END DO
6541  CALL pushinteger4(j - 1)
6542  CALL pushinteger4(ad_from0)
6543  CALL copy_corners(d2, npx, npy, 1, gridstruct%nested, bd, &
6544 & gridstruct%sw_corner, gridstruct%se_corner, &
6545 & gridstruct%nw_corner, gridstruct%ne_corner)
6546  ad_from2 = js - nt
6547  DO j=ad_from2,je+nt
6548  ad_from1 = is - nt
6549  DO i=ad_from1,ie+nt+1
6550  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
6551  END DO
6552  CALL pushinteger4(i - 1)
6553  CALL pushinteger4(ad_from1)
6554  END DO
6555  CALL pushinteger4(j - 1)
6556  CALL pushinteger4(ad_from2)
6557  CALL copy_corners(d2, npx, npy, 2, gridstruct%nested, bd, &
6558 & gridstruct%sw_corner, gridstruct%se_corner, &
6559 & gridstruct%nw_corner, gridstruct%ne_corner)
6560  ad_from4 = js - nt
6561  DO j=ad_from4,je+nt+1
6562  ad_from3 = is - nt
6563  DO i=ad_from3,ie+nt
6564  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
6565  END DO
6566  CALL pushinteger4(i - 1)
6567  CALL pushinteger4(ad_from3)
6568  END DO
6569  CALL pushinteger4(j - 1)
6570  CALL pushinteger4(ad_from4)
6571  END DO
6572  CALL pushcontrol1b(0)
6573  ELSE
6574  CALL pushcontrol1b(1)
6575  END IF
6576 !---------------------------------------------
6577 ! Add the diffusive fluxes to the flux arrays:
6578 !---------------------------------------------
6579  IF (PRESENT(mass)) THEN
6580 ! Apply mass weighting to diffusive fluxes:
6581  damp2 = 0.5*damp
6582  fy2_ad = 0.0
6583  DO j=je+1,js,-1
6584  DO i=ie,is,-1
6585  temp_ad5 = damp2*fy2(i, j)*fy_ad(i, j)
6586  mass_ad(i, j-1) = mass_ad(i, j-1) + temp_ad5
6587  mass_ad(i, j) = mass_ad(i, j) + temp_ad5
6588  fy2_ad(i, j) = fy2_ad(i, j) + damp2*(mass(i, j-1)+mass(i, j))*&
6589 & fy_ad(i, j)
6590  END DO
6591  END DO
6592  fx2_ad = 0.0
6593  DO j=je,js,-1
6594  DO i=ie+1,is,-1
6595  temp_ad4 = damp2*fx2(i, j)*fx_ad(i, j)
6596  mass_ad(i-1, j) = mass_ad(i-1, j) + temp_ad4
6597  mass_ad(i, j) = mass_ad(i, j) + temp_ad4
6598  fx2_ad(i, j) = fx2_ad(i, j) + damp2*(mass(i-1, j)+mass(i, j))*&
6599 & fx_ad(i, j)
6600  END DO
6601  END DO
6602  ELSE
6603  fy2_ad = 0.0
6604  DO j=je+1,js,-1
6605  DO i=ie,is,-1
6606  fy2_ad(i, j) = fy2_ad(i, j) + fy_ad(i, j)
6607  END DO
6608  END DO
6609  fx2_ad = 0.0
6610  DO j=je,js,-1
6611  DO i=ie+1,is,-1
6612  fx2_ad(i, j) = fx2_ad(i, j) + fx_ad(i, j)
6613  END DO
6614  END DO
6615  END IF
6616  CALL popcontrol1b(branch)
6617  IF (branch .EQ. 0) THEN
6618  d2_ad = 0.0
6619  DO n=nord,1,-1
6620  CALL popinteger4(ad_from4)
6621  CALL popinteger4(ad_to4)
6622  DO j=ad_to4,ad_from4,-1
6623  CALL popinteger4(ad_from3)
6624  CALL popinteger4(ad_to3)
6625  DO i=ad_to3,ad_from3,-1
6626  temp_ad3 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
6627  d2_ad(i, j) = d2_ad(i, j) + temp_ad3
6628  d2_ad(i, j-1) = d2_ad(i, j-1) - temp_ad3
6629  fy2_ad(i, j) = 0.0
6630  END DO
6631  END DO
6632  CALL copy_corners_adm(d2, d2_ad, npx, npy, 2, gridstruct%nested&
6633 & , bd, gridstruct%sw_corner, gridstruct%se_corner&
6634 & , gridstruct%nw_corner, gridstruct%ne_corner)
6635  CALL popinteger4(ad_from2)
6636  CALL popinteger4(ad_to2)
6637  DO j=ad_to2,ad_from2,-1
6638  CALL popinteger4(ad_from1)
6639  CALL popinteger4(ad_to1)
6640  DO i=ad_to1,ad_from1,-1
6641  temp_ad2 = gridstruct%del6_v(i, j)*fx2_ad(i, j)
6642  d2_ad(i, j) = d2_ad(i, j) + temp_ad2
6643  d2_ad(i-1, j) = d2_ad(i-1, j) - temp_ad2
6644  fx2_ad(i, j) = 0.0
6645  END DO
6646  END DO
6647  CALL copy_corners_adm(d2, d2_ad, npx, npy, 1, gridstruct%nested&
6648 & , bd, gridstruct%sw_corner, gridstruct%se_corner&
6649 & , gridstruct%nw_corner, gridstruct%ne_corner)
6650  CALL popinteger4(ad_from0)
6651  CALL popinteger4(ad_to0)
6652  DO j=ad_to0,ad_from0,-1
6653  CALL popinteger4(ad_from)
6654  CALL popinteger4(ad_to)
6655  DO i=ad_to,ad_from,-1
6656  temp_ad1 = gridstruct%rarea(i, j)*d2_ad(i, j)
6657  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad1
6658  fx2_ad(i+1, j) = fx2_ad(i+1, j) - temp_ad1
6659  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad1
6660  fy2_ad(i, j+1) = fy2_ad(i, j+1) - temp_ad1
6661  d2_ad(i, j) = 0.0
6662  END DO
6663  END DO
6664  END DO
6665  ELSE
6666  d2_ad = 0.0
6667  END IF
6668  DO j=je+nord+1,js-nord,-1
6669  DO i=ie+nord,is-nord,-1
6670  temp_ad0 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
6671  d2_ad(i, j-1) = d2_ad(i, j-1) + temp_ad0
6672  d2_ad(i, j) = d2_ad(i, j) - temp_ad0
6673  fy2_ad(i, j) = 0.0
6674  END DO
6675  END DO
6676  CALL popcontrol1b(branch)
6677  IF (branch .NE. 0) CALL copy_corners_adm(d2, d2_ad, npx, npy, 2, &
6678 & gridstruct%nested, bd, gridstruct&
6679 & %sw_corner, gridstruct%se_corner&
6680 & , gridstruct%nw_corner, &
6681 & gridstruct%ne_corner)
6682  DO j=je+nord,js-nord,-1
6683  DO i=ie+nord+1,is-nord,-1
6684  temp_ad = gridstruct%del6_v(i, j)*fx2_ad(i, j)
6685  d2_ad(i-1, j) = d2_ad(i-1, j) + temp_ad
6686  d2_ad(i, j) = d2_ad(i, j) - temp_ad
6687  fx2_ad(i, j) = 0.0
6688  END DO
6689  END DO
6690  CALL popcontrol1b(branch)
6691  IF (branch .NE. 0) CALL copy_corners_adm(d2, d2_ad, npx, npy, 1, &
6692 & gridstruct%nested, bd, gridstruct&
6693 & %sw_corner, gridstruct%se_corner&
6694 & , gridstruct%nw_corner, &
6695 & gridstruct%ne_corner)
6696  CALL popcontrol1b(branch)
6697  IF (branch .EQ. 0) THEN
6698  DO j=j2,j1,-1
6699  DO i=i2,i1,-1
6700  q_ad(i, j) = q_ad(i, j) + damp*d2_ad(i, j)
6701  d2_ad(i, j) = 0.0
6702  END DO
6703  END DO
6704  ELSE
6705  DO j=j2,j1,-1
6706  DO i=i2,i1,-1
6707  q_ad(i, j) = q_ad(i, j) + d2_ad(i, j)
6708  d2_ad(i, j) = 0.0
6709  END DO
6710  END DO
6711  END IF
6712  END SUBROUTINE deln_flux_adm
6713 ! Differentiation of copy_corners in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 d
6714 !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
6715 !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
6716 !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
6717 !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
6718 !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
6719 !_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
6720 !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
6721 !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
6722 !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.
6723 !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
6724 !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
6725 !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
6726 ! 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
6727 !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
6728 !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
6729 !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
6730 !rcle_dist sw_core_mod.edge_interpolate4)):
6731 ! gradient of useful results: q
6732 ! with respect to varying inputs: q
6733 !Weird arguments are because this routine is called in a lot of
6734 !places outside of tp_core, sometimes very deeply nested in the call tree.
6735  SUBROUTINE copy_corners_adm(q, q_ad, npx, npy, dir, nested, bd, &
6736 & sw_corner, se_corner, nw_corner, ne_corner)
6737  IMPLICIT NONE
6738  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
6739  INTEGER, INTENT(IN) :: npx, npy, dir
6740  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
6741  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6742  LOGICAL, INTENT(IN) :: nested, sw_corner, se_corner, nw_corner, &
6743 & ne_corner
6744  INTEGER :: i, j
6745  REAL :: tmp
6746  REAL :: tmp_ad
6747  REAL :: tmp0
6748  REAL :: tmp_ad0
6749  REAL :: tmp1
6750  REAL :: tmp_ad1
6751  REAL :: tmp2
6752  REAL :: tmp_ad2
6753  REAL :: tmp3
6754  REAL :: tmp_ad3
6755  REAL :: tmp4
6756  REAL :: tmp_ad4
6757  REAL :: tmp5
6758  REAL :: tmp_ad5
6759  REAL :: tmp6
6760  REAL :: tmp_ad6
6761  INTEGER :: branch
6762  IF (.NOT.nested) THEN
6763  IF (dir .EQ. 1) THEN
6764 ! XDir:
6765  IF (sw_corner) THEN
6766  CALL pushcontrol1b(0)
6767  ELSE
6768  CALL pushcontrol1b(1)
6769  END IF
6770  IF (se_corner) THEN
6771  CALL pushcontrol1b(0)
6772  ELSE
6773  CALL pushcontrol1b(1)
6774  END IF
6775  IF (ne_corner) THEN
6776  CALL pushcontrol1b(0)
6777  ELSE
6778  CALL pushcontrol1b(1)
6779  END IF
6780  IF (nw_corner) THEN
6781  DO j=npy+ng-1,npy,-1
6782  DO i=0,1-ng,-1
6783  tmp_ad2 = q_ad(i, j)
6784  q_ad(i, j) = 0.0
6785  q_ad(npy-j, i-1+npx) = q_ad(npy-j, i-1+npx) + tmp_ad2
6786  END DO
6787  END DO
6788  END IF
6789  CALL popcontrol1b(branch)
6790  IF (branch .EQ. 0) THEN
6791  DO j=npy+ng-1,npy,-1
6792  DO i=npx+ng-1,npx,-1
6793  tmp_ad1 = q_ad(i, j)
6794  q_ad(i, j) = 0.0
6795  q_ad(j, 2*npx-1-i) = q_ad(j, 2*npx-1-i) + tmp_ad1
6796  END DO
6797  END DO
6798  END IF
6799  CALL popcontrol1b(branch)
6800  IF (branch .EQ. 0) THEN
6801  DO j=0,1-ng,-1
6802  DO i=npx+ng-1,npx,-1
6803  tmp_ad0 = q_ad(i, j)
6804  q_ad(i, j) = 0.0
6805  q_ad(npy-j, i-npx+1) = q_ad(npy-j, i-npx+1) + tmp_ad0
6806  END DO
6807  END DO
6808  END IF
6809  CALL popcontrol1b(branch)
6810  IF (branch .EQ. 0) THEN
6811  DO j=0,1-ng,-1
6812  DO i=0,1-ng,-1
6813  tmp_ad = q_ad(i, j)
6814  q_ad(i, j) = 0.0
6815  q_ad(j, 1-i) = q_ad(j, 1-i) + tmp_ad
6816  END DO
6817  END DO
6818  END IF
6819  ELSE IF (dir .EQ. 2) THEN
6820 ! YDir:
6821  IF (sw_corner) THEN
6822  CALL pushcontrol1b(0)
6823  ELSE
6824  CALL pushcontrol1b(1)
6825  END IF
6826  IF (se_corner) THEN
6827  CALL pushcontrol1b(0)
6828  ELSE
6829  CALL pushcontrol1b(1)
6830  END IF
6831  IF (ne_corner) THEN
6832  CALL pushcontrol1b(0)
6833  ELSE
6834  CALL pushcontrol1b(1)
6835  END IF
6836  IF (nw_corner) THEN
6837  DO j=npy+ng-1,npy,-1
6838  DO i=0,1-ng,-1
6839  tmp_ad6 = q_ad(i, j)
6840  q_ad(i, j) = 0.0
6841  q_ad(j+1-npx, npy-i) = q_ad(j+1-npx, npy-i) + tmp_ad6
6842  END DO
6843  END DO
6844  END IF
6845  CALL popcontrol1b(branch)
6846  IF (branch .EQ. 0) THEN
6847  DO j=npy+ng-1,npy,-1
6848  DO i=npx+ng-1,npx,-1
6849  tmp_ad5 = q_ad(i, j)
6850  q_ad(i, j) = 0.0
6851  q_ad(2*npy-1-j, i) = q_ad(2*npy-1-j, i) + tmp_ad5
6852  END DO
6853  END DO
6854  END IF
6855  CALL popcontrol1b(branch)
6856  IF (branch .EQ. 0) THEN
6857  DO j=0,1-ng,-1
6858  DO i=npx+ng-1,npx,-1
6859  tmp_ad4 = q_ad(i, j)
6860  q_ad(i, j) = 0.0
6861  q_ad(npy+j-1, npx-i) = q_ad(npy+j-1, npx-i) + tmp_ad4
6862  END DO
6863  END DO
6864  END IF
6865  CALL popcontrol1b(branch)
6866  IF (branch .EQ. 0) THEN
6867  DO j=0,1-ng,-1
6868  DO i=0,1-ng,-1
6869  tmp_ad3 = q_ad(i, j)
6870  q_ad(i, j) = 0.0
6871  q_ad(1-j, i) = q_ad(1-j, i) + tmp_ad3
6872  END DO
6873  END DO
6874  END IF
6875  END IF
6876  END IF
6877  END SUBROUTINE copy_corners_adm
6878  SUBROUTINE deln_flux(nord, is, ie, js, je, npx, npy, damp, q, fx, fy, &
6879 & gridstruct, bd, mass)
6880  IMPLICIT NONE
6881 ! Del-n damping for the cell-mean values (A grid)
6882 !------------------
6883 ! nord = 0: del-2
6884 ! nord = 1: del-4
6885 ! nord = 2: del-6
6886 ! nord = 3: del-8 --> requires more ghosting than current
6887 !------------------
6888  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6889 ! del-n
6890  INTEGER, INTENT(IN) :: nord
6891  INTEGER, INTENT(IN) :: is, ie, js, je, npx, npy
6892  REAL, INTENT(IN) :: damp
6893 ! q ghosted on input
6894  REAL, INTENT(IN) :: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
6895  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
6896 ! q ghosted on input
6897  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
6898 ! diffusive fluxes:
6899  REAL, INTENT(INOUT) :: fx(bd%is:bd%ie+1, bd%js:bd%je), fy(bd%is:bd%&
6900 & ie, bd%js:bd%je+1)
6901 ! local:
6902  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd:bd%ied, bd%&
6903 & jsd:bd%jed+1)
6904  REAL :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
6905  REAL :: damp2
6906  INTEGER :: i, j, n, nt, i1, i2, j1, j2
6907  INTRINSIC PRESENT
6908  i1 = is - 1 - nord
6909  i2 = ie + 1 + nord
6910  j1 = js - 1 - nord
6911  j2 = je + 1 + nord
6912  IF (.NOT.PRESENT(mass)) THEN
6913  DO j=j1,j2
6914  DO i=i1,i2
6915  d2(i, j) = damp*q(i, j)
6916  END DO
6917  END DO
6918  ELSE
6919  DO j=j1,j2
6920  DO i=i1,i2
6921  d2(i, j) = q(i, j)
6922  END DO
6923  END DO
6924  END IF
6925  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 1, gridstruct%&
6926 & nested, bd, gridstruct%sw_corner, &
6927 & gridstruct%se_corner, gridstruct%&
6928 & nw_corner, gridstruct%ne_corner)
6929  DO j=js-nord,je+nord
6930  DO i=is-nord,ie+nord+1
6931  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
6932  END DO
6933  END DO
6934  IF (nord .GT. 0) CALL copy_corners(d2, npx, npy, 2, gridstruct%&
6935 & nested, bd, gridstruct%sw_corner, &
6936 & gridstruct%se_corner, gridstruct%&
6937 & nw_corner, gridstruct%ne_corner)
6938  DO j=js-nord,je+nord+1
6939  DO i=is-nord,ie+nord
6940  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
6941  END DO
6942  END DO
6943  IF (nord .GT. 0) THEN
6944 !----------
6945 ! high-order
6946 !----------
6947  DO n=1,nord
6948  nt = nord - n
6949  DO j=js-nt-1,je+nt+1
6950  DO i=is-nt-1,ie+nt+1
6951  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+fy2(i, j)-fy2(i, j+1))*&
6952 & gridstruct%rarea(i, j)
6953  END DO
6954  END DO
6955  CALL copy_corners(d2, npx, npy, 1, gridstruct%nested, bd, &
6956 & gridstruct%sw_corner, gridstruct%se_corner, &
6957 & gridstruct%nw_corner, gridstruct%ne_corner)
6958  DO j=js-nt,je+nt
6959  DO i=is-nt,ie+nt+1
6960  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
6961  END DO
6962  END DO
6963  CALL copy_corners(d2, npx, npy, 2, gridstruct%nested, bd, &
6964 & gridstruct%sw_corner, gridstruct%se_corner, &
6965 & gridstruct%nw_corner, gridstruct%ne_corner)
6966  DO j=js-nt,je+nt+1
6967  DO i=is-nt,ie+nt
6968  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
6969  END DO
6970  END DO
6971  END DO
6972  END IF
6973 !---------------------------------------------
6974 ! Add the diffusive fluxes to the flux arrays:
6975 !---------------------------------------------
6976  IF (PRESENT(mass)) THEN
6977 ! Apply mass weighting to diffusive fluxes:
6978  damp2 = 0.5*damp
6979  DO j=js,je
6980  DO i=is,ie+1
6981  fx(i, j) = fx(i, j) + damp2*(mass(i-1, j)+mass(i, j))*fx2(i, j&
6982 & )
6983  END DO
6984  END DO
6985  DO j=js,je+1
6986  DO i=is,ie
6987  fy(i, j) = fy(i, j) + damp2*(mass(i, j-1)+mass(i, j))*fy2(i, j&
6988 & )
6989  END DO
6990  END DO
6991  ELSE
6992  DO j=js,je
6993  DO i=is,ie+1
6994  fx(i, j) = fx(i, j) + fx2(i, j)
6995  END DO
6996  END DO
6997  DO j=js,je+1
6998  DO i=is,ie
6999  fy(i, j) = fy(i, j) + fy2(i, j)
7000  END DO
7001  END DO
7002  END IF
7003  END SUBROUTINE deln_flux
7004 ! Differentiation of fv_tp_2d in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
7005 !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
7006 !_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.
7007 !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
7008 !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
7009 !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
7010 !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
7011 !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
7012 ! 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_
7013 !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
7014 !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
7015 !_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
7016 !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
7017 !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
7018 !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
7019 !_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
7020 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
7021 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
7022 ! gradient of useful results: xfx q mass mfx mfy ra_x ra_y
7023 ! yfx fx fy crx cry
7024 ! with respect to varying inputs: xfx q mass mfx mfy ra_x ra_y
7025 ! yfx fx fy crx cry
7026  SUBROUTINE fv_tp_2d_fwd(q, crx, cry, npx, npy, hord, fx, fy, xfx, &
7027 & yfx, gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
7028  IMPLICIT NONE
7029  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7030  INTEGER, INTENT(IN) :: npx, npy
7031  INTEGER, INTENT(IN) :: hord
7032 !
7033  REAL, INTENT(IN) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed)
7034 !
7035  REAL, INTENT(IN) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed)
7036 !
7037  REAL, INTENT(IN) :: cry(bd%isd:bd%ied, bd%js:bd%je+1)
7038 !
7039  REAL, INTENT(IN) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1)
7040  REAL, INTENT(IN) :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
7041  REAL, INTENT(IN) :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
7042 ! transported scalar
7043  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
7044 ! Flux in x ( E )
7045  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
7046 ! Flux in y ( N )
7047  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
7048  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
7049 ! optional Arguments:
7050 ! Mass Flux X-Dir
7051  REAL, OPTIONAL, INTENT(IN) :: mfx(bd%is:bd%ie+1, bd%js:bd%je)
7052 ! Mass Flux Y-Dir
7053  REAL, OPTIONAL, INTENT(IN) :: mfy(bd%is:bd%ie, bd%js:bd%je+1)
7054  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
7055  REAL, OPTIONAL, INTENT(IN) :: damp_c
7056  INTEGER, OPTIONAL, INTENT(IN) :: nord
7057 ! Local:
7058  INTEGER :: ord_ou, ord_in
7059  REAL :: q_i(bd%isd:bd%ied, bd%js:bd%je)
7060  REAL :: q_j(bd%is:bd%ie, bd%jsd:bd%jed)
7061  REAL :: fx2(bd%is:bd%ie+1, bd%jsd:bd%jed)
7062  REAL :: fy2(bd%isd:bd%ied, bd%js:bd%je+1)
7063  REAL :: fyy(bd%isd:bd%ied, bd%js:bd%je+1)
7064  REAL :: fx1(bd%is:bd%ie+1, bd%jsd:bd%jed)
7065  REAL :: damp
7066  INTEGER :: i, j
7067  INTEGER :: is, ie, js, je, isd, ied, jsd, jed
7068  INTRINSIC PRESENT
7069  is = bd%is
7070  ie = bd%ie
7071  js = bd%js
7072  je = bd%je
7073  isd = bd%isd
7074  ied = bd%ied
7075  jsd = bd%jsd
7076  jed = bd%jed
7077  IF (hord .EQ. 10) THEN
7078  ord_in = 8
7079  ELSE
7080  ord_in = hord
7081  END IF
7082  ord_ou = hord
7083  IF (.NOT.gridstruct%nested) THEN
7084  CALL copy_corners_fwd(q, npx, npy, 2, gridstruct%nested, bd, &
7085 & gridstruct%sw_corner, gridstruct%se_corner, &
7086 & gridstruct%nw_corner, gridstruct%ne_corner)
7087  CALL pushcontrol(1,0)
7088  ELSE
7089  CALL pushcontrol(1,1)
7090  END IF
7091  CALL yppm_fwd(fy2, q, cry, ord_in, isd, ied, isd, ied, js, je, &
7092 & jsd, jed, npx, npy, gridstruct%dya, gridstruct%nested, &
7093 & gridstruct%grid_type)
7094  DO j=js,je+1
7095  DO i=isd,ied
7096  fyy(i, j) = yfx(i, j)*fy2(i, j)
7097  END DO
7098  END DO
7099  DO j=js,je
7100  DO i=isd,ied
7101  q_i(i, j) = (q(i, j)*gridstruct%area(i, j)+fyy(i, j)-fyy(i, j+1)&
7102 & )/ra_y(i, j)
7103  END DO
7104  END DO
7105  CALL xppm_fwd(fx, q_i, crx(is:ie+1, js:je), ord_ou, is, ie, isd, &
7106 & ied, js, je, jsd, jed, npx, npy, gridstruct%dxa, &
7107 & gridstruct%nested, gridstruct%grid_type)
7108  IF (.NOT.gridstruct%nested) THEN
7109  CALL copy_corners_fwd(q, npx, npy, 1, gridstruct%nested, bd, &
7110 & gridstruct%sw_corner, gridstruct%se_corner, &
7111 & gridstruct%nw_corner, gridstruct%ne_corner)
7112  CALL pushcontrol(1,0)
7113  ELSE
7114  CALL pushcontrol(1,1)
7115  END IF
7116  CALL xppm_fwd(fx2, q, crx, ord_in, is, ie, isd, ied, jsd, jed, &
7117 & jsd, jed, npx, npy, gridstruct%dxa, gridstruct%nested, &
7118 & gridstruct%grid_type)
7119  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7120  DO j=jsd,jed
7121  DO i=is,ie+1
7122  fx1(i, j) = xfx(i, j)*fx2(i, j)
7123  END DO
7124  END DO
7125  DO j=jsd,jed
7126  DO i=is,ie
7127  q_j(i, j) = (q(i, j)*gridstruct%area(i, j)+fx1(i, j)-fx1(i+1, j)&
7128 & )/ra_x(i, j)
7129  END DO
7130  END DO
7131  CALL yppm_fwd(fy, q_j, cry, ord_ou, is, ie, isd, ied, js, je, jsd&
7132 & , jed, npx, npy, gridstruct%dya, gridstruct%nested, &
7133 & gridstruct%grid_type)
7134 !----------------
7135 ! Flux averaging:
7136 !----------------
7137  IF (PRESENT(mfx) .AND. PRESENT(mfy)) THEN
7138  CALL pushrealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
7139 !---------------------------------
7140 ! For transport of pt and tracers
7141 !---------------------------------
7142  DO j=js,je
7143  DO i=is,ie+1
7144  fx(i, j) = 0.5*(fx(i, j)+fx2(i, j))*mfx(i, j)
7145  END DO
7146  END DO
7147  CALL pushrealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
7148  DO j=js,je+1
7149  DO i=is,ie
7150  fy(i, j) = 0.5*(fy(i, j)+fy2(i, j))*mfy(i, j)
7151  END DO
7152  END DO
7153  IF (PRESENT(nord) .AND. PRESENT(damp_c) .AND. PRESENT(mass)) THEN
7154  IF (damp_c .GT. 1.e-4) THEN
7155  damp = (damp_c*gridstruct%da_min)**(nord+1)
7156  CALL deln_flux_fwd(nord, is, ie, js, je, npx, npy, damp, q&
7157 & , fx, fy, gridstruct, bd, mass)
7158  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7159  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7160  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7161  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7162  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7163  CALL pushcontrol(3,2)
7164  ELSE
7165  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7166  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7167  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7168  CALL pushinteger(je)
7169  CALL pushinteger(is)
7170  CALL pushinteger(ie)
7171  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7172  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7173  CALL pushinteger(js)
7174  CALL pushcontrol(3,1)
7175  END IF
7176  ELSE
7177  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7178  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7179  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7180  CALL pushinteger(je)
7181  CALL pushinteger(is)
7182  CALL pushinteger(ie)
7183  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7184  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7185  CALL pushinteger(js)
7186  CALL pushcontrol(3,0)
7187  END IF
7188  ELSE
7189 !---------------------------------
7190 ! For transport of delp, vorticity
7191 !---------------------------------
7192  DO j=js,je
7193  DO i=is,ie+1
7194  CALL pushrealarray(fx(i, j))
7195  fx(i, j) = 0.5*(fx(i, j)+fx2(i, j))*xfx(i, j)
7196  END DO
7197  END DO
7198  DO j=js,je+1
7199  DO i=is,ie
7200  CALL pushrealarray(fy(i, j))
7201  fy(i, j) = 0.5*(fy(i, j)+fy2(i, j))*yfx(i, j)
7202  END DO
7203  END DO
7204  IF (PRESENT(nord) .AND. PRESENT(damp_c)) THEN
7205  IF (damp_c .GT. 1.e-4) THEN
7206  damp = (damp_c*gridstruct%da_min)**(nord+1)
7207  CALL deln_flux_fwd(nord, is, ie, js, je, npx, npy, damp, q&
7208 & , fx, fy, gridstruct, bd)
7209  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7210  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7211  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7212  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7213  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7214  CALL pushcontrol(3,5)
7215  ELSE
7216  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7217  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7218  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7219  CALL pushinteger(je)
7220  CALL pushinteger(is)
7221  CALL pushinteger(ie)
7222  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7223  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7224  CALL pushinteger(js)
7225  CALL pushcontrol(3,4)
7226  END IF
7227  ELSE
7228  CALL pushrealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7229  CALL pushrealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7230  CALL pushrealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7231  CALL pushinteger(je)
7232  CALL pushinteger(is)
7233  CALL pushinteger(ie)
7234  CALL pushrealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7235  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7236  CALL pushinteger(js)
7237  CALL pushcontrol(3,3)
7238  END IF
7239  END IF
7240  END SUBROUTINE fv_tp_2d_fwd
7241 ! Differentiation of fv_tp_2d in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
7242 !_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_cor
7243 !e_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod
7244 !.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Raylei
7245 !gh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_o
7246 !rd4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.
7247 !remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d
7248 ! fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiter
7249 !s fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv
7250 !_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subg
7251 !rid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_util
7252 !s_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_
7253 !mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_m
7254 !od.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.
7255 !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_
7256 !v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_cor
7257 !e_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_uti
7258 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
7259 ! gradient of useful results: xfx q mass mfx mfy ra_x ra_y
7260 ! yfx fx fy crx cry
7261 ! with respect to varying inputs: xfx q mass mfx mfy ra_x ra_y
7262 ! yfx fx fy crx cry
7263  SUBROUTINE fv_tp_2d_bwd(q, q_ad, crx, crx_ad, cry, cry_ad, npx, npy&
7264 & , hord, fx, fx_ad, fy, fy_ad, xfx, xfx_ad, yfx, yfx_ad, gridstruct, &
7265 & bd, ra_x, ra_x_ad, ra_y, ra_y_ad, mfx, mfx_ad, mfy, mfy_ad, mass, &
7266 & mass_ad, nord, damp_c)
7267  IMPLICIT NONE
7268  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
7269  INTEGER, INTENT(IN) :: npx, npy
7270  INTEGER, INTENT(IN) :: hord
7271  REAL, INTENT(IN) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed)
7272  REAL :: crx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
7273  REAL, INTENT(IN) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed)
7274  REAL :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
7275  REAL, INTENT(IN) :: cry(bd%isd:bd%ied, bd%js:bd%je+1)
7276  REAL :: cry_ad(bd%isd:bd%ied, bd%js:bd%je+1)
7277  REAL, INTENT(IN) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1)
7278  REAL :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1)
7279  REAL, INTENT(IN) :: ra_x(bd%is:bd%ie, bd%jsd:bd%jed)
7280  REAL :: ra_x_ad(bd%is:bd%ie, bd%jsd:bd%jed)
7281  REAL, INTENT(IN) :: ra_y(bd%isd:bd%ied, bd%js:bd%je)
7282  REAL :: ra_y_ad(bd%isd:bd%ied, bd%js:bd%je)
7283  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
7284  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
7285  REAL :: fx(bd%is:bd%ie+1, bd%js:bd%je)
7286  REAL :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je)
7287  REAL :: fy(bd%is:bd%ie, bd%js:bd%je+1)
7288  REAL :: fy_ad(bd%is:bd%ie, bd%js:bd%je+1)
7289  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
7290  REAL, OPTIONAL, INTENT(IN) :: mfx(bd%is:bd%ie+1, bd%js:bd%je)
7291  REAL, OPTIONAL :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je)
7292  REAL, OPTIONAL, INTENT(IN) :: mfy(bd%is:bd%ie, bd%js:bd%je+1)
7293  REAL, OPTIONAL :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1)
7294  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
7295  REAL, OPTIONAL :: mass_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
7296  REAL, OPTIONAL, INTENT(IN) :: damp_c
7297  INTEGER, OPTIONAL, INTENT(IN) :: nord
7298  INTEGER :: ord_ou, ord_in
7299  REAL :: q_i(bd%isd:bd%ied, bd%js:bd%je)
7300  REAL :: q_i_ad(bd%isd:bd%ied, bd%js:bd%je)
7301  REAL :: q_j(bd%is:bd%ie, bd%jsd:bd%jed)
7302  REAL :: q_j_ad(bd%is:bd%ie, bd%jsd:bd%jed)
7303  REAL :: fx2(bd%is:bd%ie+1, bd%jsd:bd%jed)
7304  REAL :: fx2_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
7305  REAL :: fy2(bd%isd:bd%ied, bd%js:bd%je+1)
7306  REAL :: fy2_ad(bd%isd:bd%ied, bd%js:bd%je+1)
7307  REAL :: fyy(bd%isd:bd%ied, bd%js:bd%je+1)
7308  REAL :: fyy_ad(bd%isd:bd%ied, bd%js:bd%je+1)
7309  REAL :: fx1(bd%is:bd%ie+1, bd%jsd:bd%jed)
7310  REAL :: fx1_ad(bd%is:bd%ie+1, bd%jsd:bd%jed)
7311  REAL :: damp
7312  INTEGER :: i, j
7313  INTEGER :: is, ie, js, je, isd, ied, jsd, jed
7314  INTRINSIC PRESENT
7315  REAL :: temp_ad
7316  REAL :: temp_ad0
7317  REAL :: temp_ad1
7318  REAL :: temp_ad2
7319  REAL :: temp_ad3
7320  REAL :: temp_ad4
7321  INTEGER :: branch
7322 
7323  ord_ou = 0
7324  ord_in = 0
7325  q_i = 0.0
7326  q_j = 0.0
7327  fx2 = 0.0
7328  fy2 = 0.0
7329  fyy = 0.0
7330  fx1 = 0.0
7331  damp = 0.0
7332  is = 0
7333  ie = 0
7334  js = 0
7335  je = 0
7336  isd = 0
7337  ied = 0
7338  jsd = 0
7339  jed = 0
7340  branch = 0
7341 
7342  CALL popcontrol(3,branch)
7343  IF (branch .LT. 3) THEN
7344  IF (branch .EQ. 0) THEN
7345  CALL popinteger(js)
7346  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7347  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7348  CALL popinteger(ie)
7349  CALL popinteger(is)
7350  CALL popinteger(je)
7351  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7352  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7353  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7354  ELSE IF (branch .EQ. 1) THEN
7355  CALL popinteger(js)
7356  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7357  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7358  CALL popinteger(ie)
7359  CALL popinteger(is)
7360  CALL popinteger(je)
7361  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7362  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7363  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7364  ELSE
7365  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7366  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7367  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7368  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7369  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7370  js = bd%js
7371  damp = (damp_c*gridstruct%da_min)**(nord+1)
7372  ie = bd%ie
7373  is = bd%is
7374  je = bd%je
7375  CALL deln_flux_bwd(nord, is, ie, js, je, npx, npy, damp, q, &
7376 & q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd, mass&
7377 & , mass_ad)
7378  END IF
7379  fy2_ad = 0.0
7380  CALL poprealarray(fy, (bd%ie-bd%is+1)*(bd%je-bd%js+2))
7381  DO j=js,je+1
7382  DO i=ie,is,-1
7383  temp_ad4 = 0.5*mfy(i, j)*fy_ad(i, j)
7384  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad4
7385  mfy_ad(i, j) = mfy_ad(i, j) + 0.5*(fy(i, j)+fy2(i, j))*fy_ad(i&
7386 & , j)
7387  fy_ad(i, j) = temp_ad4
7388  END DO
7389  END DO
7390  fx2_ad = 0.0
7391  CALL poprealarray(fx, (bd%ie-bd%is+2)*(bd%je-bd%js+1))
7392  DO j=js,je
7393  DO i=ie+1,is,-1
7394  temp_ad3 = 0.5*mfx(i, j)*fx_ad(i, j)
7395  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad3
7396  mfx_ad(i, j) = mfx_ad(i, j) + 0.5*(fx(i, j)+fx2(i, j))*fx_ad(i&
7397 & , j)
7398  fx_ad(i, j) = temp_ad3
7399  END DO
7400  END DO
7401  ELSE
7402  IF (branch .EQ. 3) THEN
7403  CALL popinteger(js)
7404  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7405  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7406  CALL popinteger(ie)
7407  CALL popinteger(is)
7408  CALL popinteger(je)
7409  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7410  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7411  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7412  ELSE IF (branch .EQ. 4) THEN
7413  CALL popinteger(js)
7414  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7415  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7416  CALL popinteger(ie)
7417  CALL popinteger(is)
7418  CALL popinteger(je)
7419  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7420  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7421  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7422  ELSE
7423  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7424  CALL poprealarray(q_j, (bd%ie-bd%is+1)*(bd%jed-bd%jsd+1))
7425  CALL poprealarray(fx1, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7426  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7427  CALL poprealarray(fyy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2))
7428  js = bd%js
7429  damp = (damp_c*gridstruct%da_min)**(nord+1)
7430  ie = bd%ie
7431  is = bd%is
7432  je = bd%je
7433  CALL deln_flux_bwd(nord, is, ie, js, je, npx, npy, damp, q, &
7434 & q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd)
7435  END IF
7436  fy2_ad = 0.0
7437  DO j=je+1,js,-1
7438  DO i=ie,is,-1
7439  CALL poprealarray(fy(i, j))
7440  temp_ad2 = 0.5*yfx(i, j)*fy_ad(i, j)
7441  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad2
7442  yfx_ad(i, j) = yfx_ad(i, j) + 0.5*(fy(i, j)+fy2(i, j))*fy_ad(i&
7443 & , j)
7444  fy_ad(i, j) = temp_ad2
7445  END DO
7446  END DO
7447  fx2_ad = 0.0
7448  DO j=je,js,-1
7449  DO i=ie+1,is,-1
7450  CALL poprealarray(fx(i, j))
7451  temp_ad1 = 0.5*xfx(i, j)*fx_ad(i, j)
7452  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad1
7453  xfx_ad(i, j) = xfx_ad(i, j) + 0.5*(fx(i, j)+fx2(i, j))*fx_ad(i&
7454 & , j)
7455  fx_ad(i, j) = temp_ad1
7456  END DO
7457  END DO
7458  END IF
7459  jsd = bd%jsd
7460  ied = bd%ied
7461  isd = bd%isd
7462  jed = bd%jed
7463  q_j_ad = 0.0
7464  CALL yppm_bwd(fy, fy_ad, q_j, q_j_ad, cry, cry_ad, ord_ou, is, ie&
7465 & , isd, ied, js, je, jsd, jed, npx, npy, gridstruct%dya, &
7466 & gridstruct%nested, gridstruct%grid_type)
7467  fx1_ad = 0.0
7468  DO j=jed,jsd,-1
7469  DO i=ie,is,-1
7470  temp_ad0 = q_j_ad(i, j)/ra_x(i, j)
7471  q_ad(i, j) = q_ad(i, j) + gridstruct%area(i, j)*temp_ad0
7472  fx1_ad(i, j) = fx1_ad(i, j) + temp_ad0
7473  fx1_ad(i+1, j) = fx1_ad(i+1, j) - temp_ad0
7474  ra_x_ad(i, j) = ra_x_ad(i, j) - (gridstruct%area(i, j)*q(i, j)+&
7475 & fx1(i, j)-fx1(i+1, j))*temp_ad0/ra_x(i, j)
7476  q_j_ad(i, j) = 0.0
7477  END DO
7478  END DO
7479  CALL poprealarray(fx2, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1))
7480  DO j=jsd,jed
7481  DO i=ie+1,is,-1
7482  xfx_ad(i, j) = xfx_ad(i, j) + fx2(i, j)*fx1_ad(i, j)
7483  fx2_ad(i, j) = fx2_ad(i, j) + xfx(i, j)*fx1_ad(i, j)
7484  fx1_ad(i, j) = 0.0
7485  END DO
7486  END DO
7487  CALL xppm_bwd(fx2, fx2_ad, q, q_ad, crx, crx_ad, ord_in, is, ie, &
7488 & isd, ied, jsd, jed, jsd, jed, npx, npy, gridstruct%dxa, &
7489 & gridstruct%nested, gridstruct%grid_type)
7490  CALL popcontrol(1,branch)
7491  IF (branch .EQ. 0) CALL copy_corners_bwd(q, q_ad, npx, npy, 1, &
7492 & gridstruct%nested, bd, &
7493 & gridstruct%sw_corner, &
7494 & gridstruct%se_corner, &
7495 & gridstruct%nw_corner, &
7496 & gridstruct%ne_corner)
7497  q_i_ad = 0.0
7498  CALL xppm_bwd(fx, fx_ad, q_i, q_i_ad, crx(is:ie+1, js:je), crx_ad&
7499 & (is:ie+1, js:je), ord_ou, is, ie, isd, ied, js, je, jsd, &
7500 & jed, npx, npy, gridstruct%dxa, gridstruct%nested, &
7501 & gridstruct%grid_type)
7502  fyy_ad = 0.0
7503  DO j=je,js,-1
7504  DO i=ied,isd,-1
7505  temp_ad = q_i_ad(i, j)/ra_y(i, j)
7506  q_ad(i, j) = q_ad(i, j) + gridstruct%area(i, j)*temp_ad
7507  fyy_ad(i, j) = fyy_ad(i, j) + temp_ad
7508  fyy_ad(i, j+1) = fyy_ad(i, j+1) - temp_ad
7509  ra_y_ad(i, j) = ra_y_ad(i, j) - (gridstruct%area(i, j)*q(i, j)+&
7510 & fyy(i, j)-fyy(i, j+1))*temp_ad/ra_y(i, j)
7511  q_i_ad(i, j) = 0.0
7512  END DO
7513  END DO
7514  DO j=je+1,js,-1
7515  DO i=ied,isd,-1
7516  yfx_ad(i, j) = yfx_ad(i, j) + fy2(i, j)*fyy_ad(i, j)
7517  fy2_ad(i, j) = fy2_ad(i, j) + yfx(i, j)*fyy_ad(i, j)
7518  fyy_ad(i, j) = 0.0
7519  END DO
7520  END DO
7521  CALL yppm_bwd(fy2, fy2_ad, q, q_ad, cry, cry_ad, ord_in, isd, ied&
7522 & , isd, ied, js, je, jsd, jed, npx, npy, gridstruct%dya, &
7523 & gridstruct%nested, gridstruct%grid_type)
7524  CALL popcontrol(1,branch)
7525  IF (branch .EQ. 0) CALL copy_corners_bwd(q, q_ad, npx, npy, 2, &
7526 & gridstruct%nested, bd, &
7527 & gridstruct%sw_corner, &
7528 & gridstruct%se_corner, &
7529 & gridstruct%nw_corner, &
7530 & gridstruct%ne_corner)
7531  END SUBROUTINE fv_tp_2d_bwd
7532 ! Differentiation of xppm in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.
7533 !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_mod
7534 !.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_
7535 !dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Su
7536 !per fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 f
7537 !v_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
7538 !_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_m
7539 !apz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_
7540 !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_rest
7541 !art_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
7542 ! 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_mod
7543 !.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.S
7544 !IM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.ne
7545 !st_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
7546 !_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
7547 !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_mod
7548 !.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mo
7549 !d.great_circle_dist sw_core_mod.edge_interpolate4)):
7550 ! gradient of useful results: q flux c
7551 ! with respect to varying inputs: q flux c
7552  SUBROUTINE xppm_fwd(flux, q, c, iord, is, ie, isd, ied, jfirst, &
7553 & jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
7554  IMPLICIT NONE
7555  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed
7556 ! compute domain
7557  INTEGER, INTENT(IN) :: jfirst, jlast
7558  INTEGER, INTENT(IN) :: iord
7559  INTEGER, INTENT(IN) :: npx, npy
7560  REAL, INTENT(IN) :: q(isd:ied, jfirst:jlast)
7561 ! Courant N (like FLUX)
7562  REAL, INTENT(IN) :: c(is:ie+1, jfirst:jlast)
7563  REAL, INTENT(IN) :: dxa(isd:ied, jsd:jed)
7564  LOGICAL, INTENT(IN) :: nested
7565  INTEGER, INTENT(IN) :: grid_type
7566 ! !OUTPUT PARAMETERS:
7567 ! Flux
7568  REAL :: flux(is:ie+1, jfirst:jlast)
7569 ! Local
7570  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
7571  REAL :: q1(isd:ied)
7572  REAL, DIMENSION(is:ie+1) :: fx0, fx1
7573  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
7574  REAL :: al(is-1:ie+2)
7575  REAL :: dm(is-2:ie+2)
7576  REAL :: dq(is-3:ie+2)
7577  INTEGER :: i, j, ie3, is1, ie1
7578  REAL :: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2
7579  INTRINSIC max
7580  INTRINSIC min
7581 
7582  bl = 0.0
7583  br = 0.0
7584  b0 = 0.0
7585  q1 = 0.0
7586  fx0 = 0.0
7587  fx1 = 0.0
7588  al = 0.0
7589  dm = 0.0
7590  dq = 0.0
7591  ie3 = 0
7592  is1 = 0
7593  ie1 = 0
7594  x0 = 0.0
7595  x1 = 0.0
7596  xt = 0.0
7597  qtmp = 0.0
7598  pmp_1 = 0.0
7599  lac_1 = 0.0
7600  pmp_2 = 0.0
7601  lac_2 = 0.0
7602 
7603  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
7604  IF (3 .LT. is - 1) THEN
7605  is1 = is - 1
7606  ELSE
7607  is1 = 3
7608  END IF
7609  IF (npx - 2 .GT. ie + 2) THEN
7610  CALL pushcontrol(1,1)
7611  ie3 = ie + 2
7612  ELSE
7613  CALL pushcontrol(1,1)
7614  ie3 = npx - 2
7615  END IF
7616  ELSE
7617  CALL pushcontrol(1,0)
7618  is1 = is - 1
7619  ie3 = ie + 2
7620  END IF
7621  DO j=jfirst,jlast
7622  DO i=isd,ied
7623  CALL pushrealarray(q1(i))
7624  q1(i) = q(i, j)
7625  END DO
7626  IF (iord .LT. 8 .OR. iord .EQ. 333) THEN
7627 ! ord = 2: perfectly linear ppm scheme
7628 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6
7629  DO i=is1,ie3
7630  CALL pushrealarray(al(i))
7631  al(i) = p1*(q1(i-1)+q1(i)) + p2*(q1(i-2)+q1(i+1))
7632  END DO
7633  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
7634  IF (is .EQ. 1) THEN
7635  CALL pushrealarray(al(0))
7636  al(0) = c1*q1(-2) + c2*q1(-1) + c3*q1(0)
7637  CALL pushrealarray(al(1))
7638  al(1) = 0.5*(((2.*dxa(0, j)+dxa(-1, j))*q1(0)-dxa(0, j)*q1(-&
7639 & 1))/(dxa(-1, j)+dxa(0, j))+((2.*dxa(1, j)+dxa(2, j))*q1(1)&
7640 & -dxa(1, j)*q1(2))/(dxa(1, j)+dxa(2, j)))
7641  CALL pushrealarray(al(2))
7642  al(2) = c3*q1(1) + c2*q1(2) + c1*q1(3)
7643  CALL pushcontrol(1,0)
7644  ELSE
7645  CALL pushcontrol(1,1)
7646  END IF
7647  IF (ie + 1 .EQ. npx) THEN
7648  CALL pushrealarray(al(npx-1))
7649  al(npx-1) = c1*q1(npx-3) + c2*q1(npx-2) + c3*q1(npx-1)
7650  CALL pushrealarray(al(npx))
7651  al(npx) = 0.5*(((2.*dxa(npx-1, j)+dxa(npx-2, j))*q1(npx-1)-&
7652 & dxa(npx-1, j)*q1(npx-2))/(dxa(npx-2, j)+dxa(npx-1, j))+((&
7653 & 2.*dxa(npx, j)+dxa(npx+1, j))*q1(npx)-dxa(npx, j)*q1(npx+1&
7654 & ))/(dxa(npx, j)+dxa(npx+1, j)))
7655  CALL pushrealarray(al(npx+1))
7656  al(npx+1) = c3*q1(npx) + c2*q1(npx+1) + c1*q1(npx+2)
7657  CALL pushcontrol(2,0)
7658  ELSE
7659  CALL pushcontrol(2,1)
7660  END IF
7661  ELSE
7662  CALL pushcontrol(2,2)
7663  END IF
7664  IF (iord .EQ. 1) THEN
7665  DO i=is,ie+1
7666  IF (c(i, j) .GT. 0.) THEN
7667  CALL pushrealarray(flux(i, j))
7668  flux(i, j) = q1(i-1)
7669  CALL pushcontrol(1,1)
7670  ELSE
7671  CALL pushrealarray(flux(i, j))
7672  flux(i, j) = q1(i)
7673  CALL pushcontrol(1,0)
7674  END IF
7675  END DO
7676  CALL pushcontrol(3,0)
7677  ELSE IF (iord .EQ. 2) THEN
7678 ! perfectly linear scheme
7679 !DEC$ VECTOR ALWAYS
7680  DO i=is,ie+1
7681  xt = c(i, j)
7682  IF (xt .GT. 0.) THEN
7683  CALL pushrealarray(qtmp)
7684  qtmp = q1(i-1)
7685  CALL pushrealarray(flux(i, j))
7686  flux(i, j) = qtmp + (1.-xt)*(al(i)-qtmp-xt*(al(i-1)+al(i)-&
7687 & (qtmp+qtmp)))
7688  CALL pushcontrol(1,1)
7689  ELSE
7690  CALL pushrealarray(qtmp)
7691  qtmp = q1(i)
7692  CALL pushrealarray(flux(i, j))
7693  flux(i, j) = qtmp + (1.+xt)*(al(i)-qtmp+xt*(al(i)+al(i+1)-&
7694 & (qtmp+qtmp)))
7695  CALL pushcontrol(1,0)
7696  END IF
7697  END DO
7698  CALL pushcontrol(3,1)
7699  ELSE IF (iord .EQ. 333) THEN
7700 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
7701 !DEC$ VECTOR ALWAYS
7702  DO i=is,ie+1
7703  xt = c(i, j)
7704  IF (xt .GT. 0.) THEN
7705  CALL pushrealarray(flux(i, j))
7706  flux(i, j) = (2.0*q1(i)+5.0*q1(i-1)-q1(i-2))/6.0 - 0.5*xt*&
7707 & (q1(i)-q1(i-1)) + xt*xt/6.0*(q1(i)-2.0*q1(i-1)+q1(i-2))
7708  CALL pushcontrol(1,1)
7709  ELSE
7710  CALL pushrealarray(flux(i, j))
7711  flux(i, j) = (2.0*q1(i-1)+5.0*q1(i)-q1(i+1))/6.0 - 0.5*xt*&
7712 & (q1(i)-q1(i-1)) + xt*xt/6.0*(q1(i+1)-2.0*q1(i)+q1(i-1))
7713  CALL pushcontrol(1,0)
7714  END IF
7715  END DO
7716  CALL pushcontrol(3,2)
7717  ELSE
7718  CALL pushcontrol(3,3)
7719  END IF
7720  ELSE
7721  CALL pushcontrol(3,4)
7722  END IF
7723  END DO
7724  CALL pushinteger(ie3)
7725  CALL pushrealarray(q1, ied - isd + 1)
7726  CALL pushrealarray(qtmp)
7727  CALL pushinteger(is1)
7728  CALL pushrealarray(al, ie - is + 4)
7729  END SUBROUTINE xppm_fwd
7730 ! Differentiation of xppm in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
7731 !.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
7732 !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
7733 !_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
7734 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
7735 !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
7736 !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_
7737 !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
7738 !_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
7739 !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_
7740 !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
7741 !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.
7742 !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
7743 !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
7744 !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
7745 ! 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
7746 !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
7747 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
7748 ! gradient of useful results: q flux c
7749 ! with respect to varying inputs: q flux c
7750  SUBROUTINE xppm_bwd(flux, flux_ad, q, q_ad, c, c_ad, iord, is, ie, &
7751 & isd, ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
7752  IMPLICIT NONE
7753  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed
7754  INTEGER, INTENT(IN) :: jfirst, jlast
7755  INTEGER, INTENT(IN) :: iord
7756  INTEGER, INTENT(IN) :: npx, npy
7757  REAL, INTENT(IN) :: q(isd:ied, jfirst:jlast)
7758  REAL :: q_ad(isd:ied, jfirst:jlast)
7759  REAL, INTENT(IN) :: c(is:ie+1, jfirst:jlast)
7760  REAL :: c_ad(is:ie+1, jfirst:jlast)
7761  REAL, INTENT(IN) :: dxa(isd:ied, jsd:jed)
7762  LOGICAL, INTENT(IN) :: nested
7763  INTEGER, INTENT(IN) :: grid_type
7764  REAL :: flux(is:ie+1, jfirst:jlast)
7765  REAL :: flux_ad(is:ie+1, jfirst:jlast)
7766  REAL, DIMENSION(is-1:ie+1) :: bl, br, b0
7767  REAL :: q1(isd:ied)
7768  REAL :: q1_ad(isd:ied)
7769  REAL, DIMENSION(is:ie+1) :: fx0, fx1
7770  LOGICAL, DIMENSION(is-1:ie+1) :: smt5, smt6
7771  REAL :: al(is-1:ie+2)
7772  REAL :: al_ad(is-1:ie+2)
7773  REAL :: dm(is-2:ie+2)
7774  REAL :: dq(is-3:ie+2)
7775  INTEGER :: i, j, ie3, is1, ie1
7776  REAL :: x0, x1, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2
7777  REAL :: xt_ad, qtmp_ad
7778  INTRINSIC max
7779  INTRINSIC min
7780  REAL :: temp_ad
7781  REAL :: temp_ad0
7782  REAL :: temp_ad1
7783  REAL :: temp_ad2
7784  REAL :: temp
7785  REAL :: temp_ad3
7786  REAL :: temp_ad4
7787  REAL :: temp0
7788  REAL :: temp_ad5
7789  REAL :: temp_ad6
7790  REAL :: temp_ad7
7791  REAL :: temp_ad8
7792  REAL :: temp_ad9
7793  REAL :: temp_ad10
7794  REAL :: temp_ad11
7795  REAL :: temp_ad12
7796  INTEGER :: branch
7797 
7798  bl = 0.0
7799  br = 0.0
7800  b0 = 0.0
7801  q1 = 0.0
7802  fx0 = 0.0
7803  fx1 = 0.0
7804  al = 0.0
7805  dm = 0.0
7806  dq = 0.0
7807  ie3 = 0
7808  is1 = 0
7809  ie1 = 0
7810  x0 = 0.0
7811  x1 = 0.0
7812  xt = 0.0
7813  qtmp = 0.0
7814  pmp_1 = 0.0
7815  lac_1 = 0.0
7816  pmp_2 = 0.0
7817  lac_2 = 0.0
7818  branch = 0
7819 
7820  CALL poprealarray(al, ie - is + 4)
7821  CALL popinteger(is1)
7822  CALL poprealarray(qtmp)
7823  CALL poprealarray(q1, ied - isd + 1)
7824  CALL popinteger(ie3)
7825  al_ad = 0.0
7826  q1_ad = 0.0
7827  DO j=jlast,jfirst,-1
7828  CALL popcontrol(3,branch)
7829  IF (branch .LT. 2) THEN
7830  IF (branch .EQ. 0) THEN
7831  DO i=ie+1,is,-1
7832  CALL popcontrol(1,branch)
7833  IF (branch .EQ. 0) THEN
7834  CALL poprealarray(flux(i, j))
7835  q1_ad(i) = q1_ad(i) + flux_ad(i, j)
7836  flux_ad(i, j) = 0.0
7837  ELSE
7838  CALL poprealarray(flux(i, j))
7839  q1_ad(i-1) = q1_ad(i-1) + flux_ad(i, j)
7840  flux_ad(i, j) = 0.0
7841  END IF
7842  END DO
7843  ELSE
7844  DO i=ie+1,is,-1
7845  CALL popcontrol(1,branch)
7846  IF (branch .EQ. 0) THEN
7847  xt = c(i, j)
7848  qtmp = q1(i)
7849  CALL poprealarray(flux(i, j))
7850  temp0 = al(i) + al(i+1) - 2*qtmp
7851  temp_ad5 = (xt+1.)*flux_ad(i, j)
7852  temp_ad6 = xt*temp_ad5
7853  qtmp_ad = flux_ad(i, j) - temp_ad5 - 2*temp_ad6
7854  xt_ad = temp0*temp_ad5 + (al(i)-qtmp+xt*temp0)*flux_ad(i, &
7855 & j)
7856  al_ad(i) = al_ad(i) + temp_ad6 + temp_ad5
7857  al_ad(i+1) = al_ad(i+1) + temp_ad6
7858  flux_ad(i, j) = 0.0
7859  CALL poprealarray(qtmp)
7860  q1_ad(i) = q1_ad(i) + qtmp_ad
7861  ELSE
7862  xt = c(i, j)
7863  qtmp = q1(i-1)
7864  CALL poprealarray(flux(i, j))
7865  temp = al(i-1) + al(i) - 2*qtmp
7866  temp_ad3 = (1.-xt)*flux_ad(i, j)
7867  temp_ad4 = -(xt*temp_ad3)
7868  qtmp_ad = flux_ad(i, j) - temp_ad3 - 2*temp_ad4
7869  xt_ad = -(temp*temp_ad3) - (al(i)-qtmp-xt*temp)*flux_ad(i&
7870 & , j)
7871  al_ad(i) = al_ad(i) + temp_ad4 + temp_ad3
7872  al_ad(i-1) = al_ad(i-1) + temp_ad4
7873  flux_ad(i, j) = 0.0
7874  CALL poprealarray(qtmp)
7875  q1_ad(i-1) = q1_ad(i-1) + qtmp_ad
7876  END IF
7877  c_ad(i, j) = c_ad(i, j) + xt_ad
7878  END DO
7879  END IF
7880  ELSE IF (branch .EQ. 2) THEN
7881  DO i=ie+1,is,-1
7882  CALL popcontrol(1,branch)
7883  IF (branch .EQ. 0) THEN
7884  xt = c(i, j)
7885  CALL poprealarray(flux(i, j))
7886  temp_ad10 = flux_ad(i, j)/6.0
7887  temp_ad11 = -(0.5*xt*flux_ad(i, j))
7888  temp_ad12 = xt**2*flux_ad(i, j)/6.0
7889  q1_ad(i-1) = q1_ad(i-1) + temp_ad12 - temp_ad11 + 2.0*&
7890 & temp_ad10
7891  q1_ad(i) = q1_ad(i) + temp_ad11 - 2.0*temp_ad12 + 5.0*&
7892 & temp_ad10
7893  q1_ad(i+1) = q1_ad(i+1) + temp_ad12 - temp_ad10
7894  xt_ad = ((q1(i+1)-2.0*q1(i)+q1(i-1))*2*xt/6.0-0.5*(q1(i)-q1(&
7895 & i-1)))*flux_ad(i, j)
7896  flux_ad(i, j) = 0.0
7897  ELSE
7898  xt = c(i, j)
7899  CALL poprealarray(flux(i, j))
7900  temp_ad7 = flux_ad(i, j)/6.0
7901  temp_ad8 = -(0.5*xt*flux_ad(i, j))
7902  temp_ad9 = xt**2*flux_ad(i, j)/6.0
7903  q1_ad(i) = q1_ad(i) + temp_ad9 + temp_ad8 + 2.0*temp_ad7
7904  q1_ad(i-1) = q1_ad(i-1) + 5.0*temp_ad7 - temp_ad8 - 2.0*&
7905 & temp_ad9
7906  q1_ad(i-2) = q1_ad(i-2) + temp_ad9 - temp_ad7
7907  xt_ad = ((q1(i)-2.0*q1(i-1)+q1(i-2))*2*xt/6.0-0.5*(q1(i)-q1(&
7908 & i-1)))*flux_ad(i, j)
7909  flux_ad(i, j) = 0.0
7910  END IF
7911  c_ad(i, j) = c_ad(i, j) + xt_ad
7912  END DO
7913  ELSE IF (branch .NE. 3) THEN
7914  GOTO 110
7915  END IF
7916  CALL popcontrol(2,branch)
7917  IF (branch .EQ. 0) THEN
7918  CALL poprealarray(al(npx+1))
7919  q1_ad(npx) = q1_ad(npx) + c3*al_ad(npx+1)
7920  q1_ad(npx+1) = q1_ad(npx+1) + c2*al_ad(npx+1)
7921  q1_ad(npx+2) = q1_ad(npx+2) + c1*al_ad(npx+1)
7922  al_ad(npx+1) = 0.0
7923  CALL poprealarray(al(npx))
7924  temp_ad1 = 0.5*al_ad(npx)/(dxa(npx-2, j)+dxa(npx-1, j))
7925  temp_ad2 = 0.5*al_ad(npx)/(dxa(npx, j)+dxa(npx+1, j))
7926  q1_ad(npx-1) = q1_ad(npx-1) + (dxa(npx-1, j)*2.+dxa(npx-2, j))*&
7927 & temp_ad1
7928  q1_ad(npx-2) = q1_ad(npx-2) - dxa(npx-1, j)*temp_ad1
7929  q1_ad(npx) = q1_ad(npx) + (dxa(npx, j)*2.+dxa(npx+1, j))*&
7930 & temp_ad2
7931  q1_ad(npx+1) = q1_ad(npx+1) - dxa(npx, j)*temp_ad2
7932  al_ad(npx) = 0.0
7933  CALL poprealarray(al(npx-1))
7934  q1_ad(npx-3) = q1_ad(npx-3) + c1*al_ad(npx-1)
7935  q1_ad(npx-2) = q1_ad(npx-2) + c2*al_ad(npx-1)
7936  q1_ad(npx-1) = q1_ad(npx-1) + c3*al_ad(npx-1)
7937  al_ad(npx-1) = 0.0
7938  ELSE IF (branch .NE. 1) THEN
7939  GOTO 100
7940  END IF
7941  CALL popcontrol(1,branch)
7942  IF (branch .EQ. 0) THEN
7943  CALL poprealarray(al(2))
7944  q1_ad(1) = q1_ad(1) + c3*al_ad(2)
7945  q1_ad(2) = q1_ad(2) + c2*al_ad(2)
7946  q1_ad(3) = q1_ad(3) + c1*al_ad(2)
7947  al_ad(2) = 0.0
7948  CALL poprealarray(al(1))
7949  temp_ad = 0.5*al_ad(1)/(dxa(-1, j)+dxa(0, j))
7950  temp_ad0 = 0.5*al_ad(1)/(dxa(1, j)+dxa(2, j))
7951  q1_ad(0) = q1_ad(0) + (dxa(0, j)*2.+dxa(-1, j))*temp_ad
7952  q1_ad(-1) = q1_ad(-1) - dxa(0, j)*temp_ad
7953  q1_ad(1) = q1_ad(1) + (dxa(1, j)*2.+dxa(2, j))*temp_ad0
7954  q1_ad(2) = q1_ad(2) - dxa(1, j)*temp_ad0
7955  al_ad(1) = 0.0
7956  CALL poprealarray(al(0))
7957  q1_ad(-2) = q1_ad(-2) + c1*al_ad(0)
7958  q1_ad(-1) = q1_ad(-1) + c2*al_ad(0)
7959  q1_ad(0) = q1_ad(0) + c3*al_ad(0)
7960  al_ad(0) = 0.0
7961  END IF
7962  100 DO i=ie3,is1,-1
7963  CALL poprealarray(al(i))
7964  q1_ad(i-1) = q1_ad(i-1) + p1*al_ad(i)
7965  q1_ad(i) = q1_ad(i) + p1*al_ad(i)
7966  q1_ad(i-2) = q1_ad(i-2) + p2*al_ad(i)
7967  q1_ad(i+1) = q1_ad(i+1) + p2*al_ad(i)
7968  al_ad(i) = 0.0
7969  END DO
7970  110 DO i=ied,isd,-1
7971  CALL poprealarray(q1(i))
7972  q_ad(i, j) = q_ad(i, j) + q1_ad(i)
7973  q1_ad(i) = 0.0
7974  END DO
7975  END DO
7976  CALL popcontrol(1,branch)
7977  END SUBROUTINE xppm_bwd
7978 ! Differentiation of yppm in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.
7979 !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_mod
7980 !.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_
7981 !dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Su
7982 !per fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 f
7983 !v_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
7984 !_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_m
7985 !apz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_
7986 !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_rest
7987 !art_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
7988 ! 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_mod
7989 !.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.S
7990 !IM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.ne
7991 !st_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
7992 !_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
7993 !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_mod
7994 !.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mo
7995 !d.great_circle_dist sw_core_mod.edge_interpolate4)):
7996 ! gradient of useful results: q flux c
7997 ! with respect to varying inputs: q flux c
7998  SUBROUTINE yppm_fwd(flux, q, c, jord, ifirst, ilast, isd, ied, js, &
7999 & je, jsd, jed, npx, npy, dya, nested, grid_type)
8000  IMPLICIT NONE
8001 ! Compute domain
8002  INTEGER, INTENT(IN) :: ifirst, ilast
8003  INTEGER, INTENT(IN) :: isd, ied, js, je, jsd, jed
8004  INTEGER, INTENT(IN) :: jord
8005  INTEGER, INTENT(IN) :: npx, npy
8006  REAL, INTENT(IN) :: q(ifirst:ilast, jsd:jed)
8007 ! Courant number
8008  REAL, INTENT(IN) :: c(isd:ied, js:je+1)
8009 ! Flux
8010  REAL :: flux(ifirst:ilast, js:je+1)
8011  REAL, INTENT(IN) :: dya(isd:ied, jsd:jed)
8012  LOGICAL, INTENT(IN) :: nested
8013  INTEGER, INTENT(IN) :: grid_type
8014 ! Local:
8015  REAL :: dm(ifirst:ilast, js-2:je+2)
8016  REAL :: al(ifirst:ilast, js-1:je+2)
8017  REAL, DIMENSION(ifirst:ilast, js-1:je+1) :: bl, br, b0
8018  REAL :: dq(ifirst:ilast, js-3:je+2)
8019  REAL, DIMENSION(ifirst:ilast) :: fx0, fx1
8020  LOGICAL, DIMENSION(ifirst:ilast, js-1:je+1) :: smt5, smt6
8021  REAL :: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1
8022  INTEGER :: i, j, js1, je3, je1
8023  INTRINSIC max
8024  INTRINSIC min
8025 
8026  dm = 0.0
8027  al = 0.0
8028  bl = 0.0
8029  br = 0.0
8030  b0 = 0.0
8031  dq = 0.0
8032  fx0 = 0.0
8033  fx1 = 0.0
8034  x0 = 0.0
8035  xt = 0.0
8036  qtmp = 0.0
8037  pmp_1 = 0.0
8038  lac_1 = 0.0
8039  pmp_2 = 0.0
8040  lac_2 = 0.0
8041  r1 = 0.0
8042  js1 = 0
8043  je3 = 0
8044  je1 = 0
8045 
8046  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
8047  IF (3 .LT. js - 1) THEN
8048  js1 = js - 1
8049  ELSE
8050  js1 = 3
8051  END IF
8052  IF (npy - 2 .GT. je + 2) THEN
8053  CALL pushcontrol(1,1)
8054  je3 = je + 2
8055  ELSE
8056  CALL pushcontrol(1,1)
8057  je3 = npy - 2
8058  END IF
8059  ELSE
8060  CALL pushcontrol(1,0)
8061 ! Nested grid OR Doubly periodic domain:
8062  js1 = js - 1
8063  je3 = je + 2
8064  END IF
8065  IF (jord .LT. 8 .OR. jord .EQ. 333) THEN
8066  DO j=js1,je3
8067  DO i=ifirst,ilast
8068  al(i, j) = p1*(q(i, j-1)+q(i, j)) + p2*(q(i, j-2)+q(i, j+1))
8069  END DO
8070  END DO
8071  IF (.NOT.nested .AND. grid_type .LT. 3) THEN
8072  IF (js .EQ. 1) THEN
8073  DO i=ifirst,ilast
8074  al(i, 0) = c1*q(i, -2) + c2*q(i, -1) + c3*q(i, 0)
8075  al(i, 1) = 0.5*(((2.*dya(i, 0)+dya(i, -1))*q(i, 0)-dya(i, 0)&
8076 & *q(i, -1))/(dya(i, -1)+dya(i, 0))+((2.*dya(i, 1)+dya(i, 2)&
8077 & )*q(i, 1)-dya(i, 1)*q(i, 2))/(dya(i, 1)+dya(i, 2)))
8078  al(i, 2) = c3*q(i, 1) + c2*q(i, 2) + c1*q(i, 3)
8079  END DO
8080  CALL pushcontrol(1,0)
8081  ELSE
8082  CALL pushcontrol(1,1)
8083  END IF
8084  IF (je + 1 .EQ. npy) THEN
8085  DO i=ifirst,ilast
8086  al(i, npy-1) = c1*q(i, npy-3) + c2*q(i, npy-2) + c3*q(i, npy&
8087 & -1)
8088  al(i, npy) = 0.5*(((2.*dya(i, npy-1)+dya(i, npy-2))*q(i, npy&
8089 & -1)-dya(i, npy-1)*q(i, npy-2))/(dya(i, npy-2)+dya(i, npy-1&
8090 & ))+((2.*dya(i, npy)+dya(i, npy+1))*q(i, npy)-dya(i, npy)*q&
8091 & (i, npy+1))/(dya(i, npy)+dya(i, npy+1)))
8092  al(i, npy+1) = c3*q(i, npy) + c2*q(i, npy+1) + c1*q(i, npy+2&
8093 & )
8094  END DO
8095  CALL pushcontrol(2,0)
8096  ELSE
8097  CALL pushcontrol(2,1)
8098  END IF
8099  ELSE
8100  CALL pushcontrol(2,2)
8101  END IF
8102  IF (jord .EQ. 1) THEN
8103  DO j=js,je+1
8104  DO i=ifirst,ilast
8105  IF (c(i, j) .GT. 0.) THEN
8106  CALL pushrealarray(flux(i, j))
8107  flux(i, j) = q(i, j-1)
8108  CALL pushcontrol(1,1)
8109  ELSE
8110  CALL pushrealarray(flux(i, j))
8111  flux(i, j) = q(i, j)
8112  CALL pushcontrol(1,0)
8113  END IF
8114  END DO
8115  END DO
8116  CALL pushinteger(js1)
8117  CALL pushinteger(je3)
8118  CALL pushcontrol(3,1)
8119  ELSE IF (jord .EQ. 2) THEN
8120 ! Perfectly linear scheme
8121 ! Diffusivity: ord2 < ord5 < ord3 < ord4 < ord6 < ord7
8122  DO j=js,je+1
8123 !DEC$ VECTOR ALWAYS
8124  DO i=ifirst,ilast
8125  xt = c(i, j)
8126  IF (xt .GT. 0.) THEN
8127  qtmp = q(i, j-1)
8128  CALL pushrealarray(flux(i, j))
8129  flux(i, j) = qtmp + (1.-xt)*(al(i, j)-qtmp-xt*(al(i, j-1)+&
8130 & al(i, j)-(qtmp+qtmp)))
8131  CALL pushcontrol(1,1)
8132  ELSE
8133  qtmp = q(i, j)
8134  CALL pushrealarray(flux(i, j))
8135  flux(i, j) = qtmp + (1.+xt)*(al(i, j)-qtmp+xt*(al(i, j)+al&
8136 & (i, j+1)-(qtmp+qtmp)))
8137  CALL pushcontrol(1,0)
8138  END IF
8139  END DO
8140  END DO
8141  CALL pushinteger(js1)
8142  CALL pushinteger(je3)
8143  CALL pushrealarray(al, (ilast-ifirst+1)*(je-js+4))
8144  CALL pushcontrol(3,2)
8145  ELSE IF (jord .EQ. 333) THEN
8146 ! Perfectly linear scheme, more diffusive than ord=2 (HoldawayKent-2015-TellusA)
8147  DO j=js,je+1
8148 !DEC$ VECTOR ALWAYS
8149  DO i=ifirst,ilast
8150  xt = c(i, j)
8151  IF (xt .GT. 0.) THEN
8152  CALL pushrealarray(flux(i, j))
8153  flux(i, j) = (2.0*q(i, j)+5.0*q(i, j-1)-q(i, j-2))/6.0 - &
8154 & 0.5*xt*(q(i, j)-q(i, j-1)) + xt*xt/6.0*(q(i, j)-2.0*q(i&
8155 & , j-1)+q(i, j-2))
8156  CALL pushcontrol(1,1)
8157  ELSE
8158  CALL pushrealarray(flux(i, j))
8159  flux(i, j) = (2.0*q(i, j-1)+5.0*q(i, j)-q(i, j+1))/6.0 - &
8160 & 0.5*xt*(q(i, j)-q(i, j-1)) + xt*xt/6.0*(q(i, j+1)-2.0*q(&
8161 & i, j)+q(i, j-1))
8162  CALL pushcontrol(1,0)
8163  END IF
8164  END DO
8165  END DO
8166  CALL pushinteger(js1)
8167  CALL pushinteger(je3)
8168  CALL pushcontrol(3,3)
8169  ELSE
8170  CALL pushinteger(js1)
8171  CALL pushinteger(je3)
8172  CALL pushcontrol(3,4)
8173  END IF
8174  ELSE
8175  CALL pushcontrol(3,0)
8176  END IF
8177  END SUBROUTINE yppm_fwd
8178 ! Differentiation of yppm in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
8179 !.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
8180 !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
8181 !_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
8182 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
8183 !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
8184 !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_
8185 !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
8186 !_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
8187 !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_
8188 !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
8189 !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.
8190 !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
8191 !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
8192 !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
8193 ! 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
8194 !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
8195 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
8196 ! gradient of useful results: q flux c
8197 ! with respect to varying inputs: q flux c
8198  SUBROUTINE yppm_bwd(flux, flux_ad, q, q_ad, c, c_ad, jord, ifirst, &
8199 & ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
8200  IMPLICIT NONE
8201  INTEGER, INTENT(IN) :: ifirst, ilast
8202  INTEGER, INTENT(IN) :: isd, ied, js, je, jsd, jed
8203  INTEGER, INTENT(IN) :: jord
8204  INTEGER, INTENT(IN) :: npx, npy
8205  REAL, INTENT(IN) :: q(ifirst:ilast, jsd:jed)
8206  REAL :: q_ad(ifirst:ilast, jsd:jed)
8207  REAL, INTENT(IN) :: c(isd:ied, js:je+1)
8208  REAL :: c_ad(isd:ied, js:je+1)
8209  REAL :: flux(ifirst:ilast, js:je+1)
8210  REAL :: flux_ad(ifirst:ilast, js:je+1)
8211  REAL, INTENT(IN) :: dya(isd:ied, jsd:jed)
8212  LOGICAL, INTENT(IN) :: nested
8213  INTEGER, INTENT(IN) :: grid_type
8214  REAL :: dm(ifirst:ilast, js-2:je+2)
8215  REAL :: al(ifirst:ilast, js-1:je+2)
8216  REAL :: al_ad(ifirst:ilast, js-1:je+2)
8217  REAL, DIMENSION(ifirst:ilast, js-1:je+1) :: bl, br, b0
8218  REAL :: dq(ifirst:ilast, js-3:je+2)
8219  REAL, DIMENSION(ifirst:ilast) :: fx0, fx1
8220  LOGICAL, DIMENSION(ifirst:ilast, js-1:je+1) :: smt5, smt6
8221  REAL :: x0, xt, qtmp, pmp_1, lac_1, pmp_2, lac_2, r1
8222  REAL :: xt_ad, qtmp_ad
8223  INTEGER :: i, j, js1, je3, je1
8224  INTRINSIC max
8225  INTRINSIC min
8226  REAL :: temp_ad
8227  REAL :: temp_ad0
8228  REAL :: temp_ad1
8229  REAL :: temp_ad2
8230  REAL :: temp
8231  REAL :: temp_ad3
8232  REAL :: temp_ad4
8233  REAL :: temp0
8234  REAL :: temp_ad5
8235  REAL :: temp_ad6
8236  REAL :: temp_ad7
8237  REAL :: temp_ad8
8238  REAL :: temp_ad9
8239  REAL :: temp_ad10
8240  REAL :: temp_ad11
8241  REAL :: temp_ad12
8242  INTEGER :: branch
8243 
8244  dm = 0.0
8245  al = 0.0
8246  bl = 0.0
8247  br = 0.0
8248  b0 = 0.0
8249  dq = 0.0
8250  fx0 = 0.0
8251  fx1 = 0.0
8252  x0 = 0.0
8253  xt = 0.0
8254  qtmp = 0.0
8255  pmp_1 = 0.0
8256  lac_1 = 0.0
8257  pmp_2 = 0.0
8258  lac_2 = 0.0
8259  r1 = 0.0
8260  js1 = 0
8261  je3 = 0
8262  je1 = 0
8263  branch = 0
8264 
8265  CALL popcontrol(3,branch)
8266  IF (branch .LT. 2) THEN
8267  IF (branch .EQ. 0) THEN
8268  GOTO 110
8269  ELSE
8270  CALL popinteger(je3)
8271  CALL popinteger(js1)
8272  DO j=je+1,js,-1
8273  DO i=ilast,ifirst,-1
8274  CALL popcontrol(1,branch)
8275  IF (branch .EQ. 0) THEN
8276  CALL poprealarray(flux(i, j))
8277  q_ad(i, j) = q_ad(i, j) + flux_ad(i, j)
8278  flux_ad(i, j) = 0.0
8279  ELSE
8280  CALL poprealarray(flux(i, j))
8281  q_ad(i, j-1) = q_ad(i, j-1) + flux_ad(i, j)
8282  flux_ad(i, j) = 0.0
8283  END IF
8284  END DO
8285  END DO
8286  al_ad = 0.0
8287  END IF
8288  ELSE IF (branch .EQ. 2) THEN
8289  CALL poprealarray(al, (ilast-ifirst+1)*(je-js+4))
8290  CALL popinteger(je3)
8291  CALL popinteger(js1)
8292  al_ad = 0.0
8293  DO j=je+1,js,-1
8294  DO i=ilast,ifirst,-1
8295  CALL popcontrol(1,branch)
8296  IF (branch .EQ. 0) THEN
8297  xt = c(i, j)
8298  qtmp = q(i, j)
8299  CALL poprealarray(flux(i, j))
8300  temp0 = al(i, j) + al(i, j+1) - 2*qtmp
8301  temp_ad5 = (xt+1.)*flux_ad(i, j)
8302  temp_ad6 = xt*temp_ad5
8303  qtmp_ad = flux_ad(i, j) - temp_ad5 - 2*temp_ad6
8304  xt_ad = temp0*temp_ad5 + (al(i, j)-qtmp+xt*temp0)*flux_ad(i&
8305 & , j)
8306  al_ad(i, j) = al_ad(i, j) + temp_ad6 + temp_ad5
8307  al_ad(i, j+1) = al_ad(i, j+1) + temp_ad6
8308  flux_ad(i, j) = 0.0
8309  q_ad(i, j) = q_ad(i, j) + qtmp_ad
8310  ELSE
8311  xt = c(i, j)
8312  qtmp = q(i, j-1)
8313  CALL poprealarray(flux(i, j))
8314  temp = al(i, j-1) + al(i, j) - 2*qtmp
8315  temp_ad3 = (1.-xt)*flux_ad(i, j)
8316  temp_ad4 = -(xt*temp_ad3)
8317  qtmp_ad = flux_ad(i, j) - temp_ad3 - 2*temp_ad4
8318  xt_ad = -(temp*temp_ad3) - (al(i, j)-qtmp-xt*temp)*flux_ad(i&
8319 & , j)
8320  al_ad(i, j) = al_ad(i, j) + temp_ad4 + temp_ad3
8321  al_ad(i, j-1) = al_ad(i, j-1) + temp_ad4
8322  flux_ad(i, j) = 0.0
8323  q_ad(i, j-1) = q_ad(i, j-1) + qtmp_ad
8324  END IF
8325  c_ad(i, j) = c_ad(i, j) + xt_ad
8326  END DO
8327  END DO
8328  ELSE
8329  IF (branch .EQ. 3) THEN
8330  CALL popinteger(je3)
8331  CALL popinteger(js1)
8332  DO j=je+1,js,-1
8333  DO i=ilast,ifirst,-1
8334  CALL popcontrol(1,branch)
8335  IF (branch .EQ. 0) THEN
8336  xt = c(i, j)
8337  CALL poprealarray(flux(i, j))
8338  temp_ad10 = flux_ad(i, j)/6.0
8339  temp_ad11 = -(0.5*xt*flux_ad(i, j))
8340  temp_ad12 = xt**2*flux_ad(i, j)/6.0
8341  q_ad(i, j-1) = q_ad(i, j-1) + temp_ad12 - temp_ad11 + 2.0*&
8342 & temp_ad10
8343  q_ad(i, j) = q_ad(i, j) + temp_ad11 - 2.0*temp_ad12 + 5.0*&
8344 & temp_ad10
8345  q_ad(i, j+1) = q_ad(i, j+1) + temp_ad12 - temp_ad10
8346  xt_ad = ((q(i, j+1)-2.0*q(i, j)+q(i, j-1))*2*xt/6.0-0.5*(q&
8347 & (i, j)-q(i, j-1)))*flux_ad(i, j)
8348  flux_ad(i, j) = 0.0
8349  ELSE
8350  xt = c(i, j)
8351  CALL poprealarray(flux(i, j))
8352  temp_ad7 = flux_ad(i, j)/6.0
8353  temp_ad8 = -(0.5*xt*flux_ad(i, j))
8354  temp_ad9 = xt**2*flux_ad(i, j)/6.0
8355  q_ad(i, j) = q_ad(i, j) + temp_ad9 + temp_ad8 + 2.0*&
8356 & temp_ad7
8357  q_ad(i, j-1) = q_ad(i, j-1) + 5.0*temp_ad7 - temp_ad8 - &
8358 & 2.0*temp_ad9
8359  q_ad(i, j-2) = q_ad(i, j-2) + temp_ad9 - temp_ad7
8360  xt_ad = ((q(i, j)-2.0*q(i, j-1)+q(i, j-2))*2*xt/6.0-0.5*(q&
8361 & (i, j)-q(i, j-1)))*flux_ad(i, j)
8362  flux_ad(i, j) = 0.0
8363  END IF
8364  c_ad(i, j) = c_ad(i, j) + xt_ad
8365  END DO
8366  END DO
8367  ELSE
8368  CALL popinteger(je3)
8369  CALL popinteger(js1)
8370  END IF
8371  al_ad = 0.0
8372  END IF
8373  CALL popcontrol(2,branch)
8374  IF (branch .EQ. 0) THEN
8375  DO i=ilast,ifirst,-1
8376  q_ad(i, npy) = q_ad(i, npy) + c3*al_ad(i, npy+1)
8377  q_ad(i, npy+1) = q_ad(i, npy+1) + c2*al_ad(i, npy+1)
8378  q_ad(i, npy+2) = q_ad(i, npy+2) + c1*al_ad(i, npy+1)
8379  al_ad(i, npy+1) = 0.0
8380  temp_ad1 = 0.5*al_ad(i, npy)/(dya(i, npy-2)+dya(i, npy-1))
8381  temp_ad2 = 0.5*al_ad(i, npy)/(dya(i, npy)+dya(i, npy+1))
8382  q_ad(i, npy-1) = q_ad(i, npy-1) + (dya(i, npy-1)*2.+dya(i, npy-2&
8383 & ))*temp_ad1
8384  q_ad(i, npy-2) = q_ad(i, npy-2) - dya(i, npy-1)*temp_ad1
8385  q_ad(i, npy) = q_ad(i, npy) + (dya(i, npy)*2.+dya(i, npy+1))*&
8386 & temp_ad2
8387  q_ad(i, npy+1) = q_ad(i, npy+1) - dya(i, npy)*temp_ad2
8388  al_ad(i, npy) = 0.0
8389  q_ad(i, npy-3) = q_ad(i, npy-3) + c1*al_ad(i, npy-1)
8390  q_ad(i, npy-2) = q_ad(i, npy-2) + c2*al_ad(i, npy-1)
8391  q_ad(i, npy-1) = q_ad(i, npy-1) + c3*al_ad(i, npy-1)
8392  al_ad(i, npy-1) = 0.0
8393  END DO
8394  ELSE IF (branch .NE. 1) THEN
8395  GOTO 100
8396  END IF
8397  CALL popcontrol(1,branch)
8398  IF (branch .EQ. 0) THEN
8399  DO i=ilast,ifirst,-1
8400  q_ad(i, 1) = q_ad(i, 1) + c3*al_ad(i, 2)
8401  q_ad(i, 2) = q_ad(i, 2) + c2*al_ad(i, 2)
8402  q_ad(i, 3) = q_ad(i, 3) + c1*al_ad(i, 2)
8403  al_ad(i, 2) = 0.0
8404  temp_ad = 0.5*al_ad(i, 1)/(dya(i, -1)+dya(i, 0))
8405  temp_ad0 = 0.5*al_ad(i, 1)/(dya(i, 1)+dya(i, 2))
8406  q_ad(i, 0) = q_ad(i, 0) + (dya(i, 0)*2.+dya(i, -1))*temp_ad
8407  q_ad(i, -1) = q_ad(i, -1) - dya(i, 0)*temp_ad
8408  q_ad(i, 1) = q_ad(i, 1) + (dya(i, 1)*2.+dya(i, 2))*temp_ad0
8409  q_ad(i, 2) = q_ad(i, 2) - dya(i, 1)*temp_ad0
8410  al_ad(i, 1) = 0.0
8411  q_ad(i, -2) = q_ad(i, -2) + c1*al_ad(i, 0)
8412  q_ad(i, -1) = q_ad(i, -1) + c2*al_ad(i, 0)
8413  q_ad(i, 0) = q_ad(i, 0) + c3*al_ad(i, 0)
8414  al_ad(i, 0) = 0.0
8415  END DO
8416  END IF
8417  100 DO j=je3,js1,-1
8418  DO i=ilast,ifirst,-1
8419  q_ad(i, j-1) = q_ad(i, j-1) + p1*al_ad(i, j)
8420  q_ad(i, j) = q_ad(i, j) + p1*al_ad(i, j)
8421  q_ad(i, j-2) = q_ad(i, j-2) + p2*al_ad(i, j)
8422  q_ad(i, j+1) = q_ad(i, j+1) + p2*al_ad(i, j)
8423  al_ad(i, j) = 0.0
8424  END DO
8425  END DO
8426  110 CALL popcontrol(1,branch)
8427  END SUBROUTINE yppm_bwd
8428 ! Differentiation of deln_flux in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
8429 !_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_cor
8430 !e_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod
8431 !.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Raylei
8432 !gh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_o
8433 !rd4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.
8434 !remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d
8435 ! fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiter
8436 !s fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv
8437 !_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subg
8438 !rid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_util
8439 !s_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_
8440 !mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_m
8441 !od.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.
8442 !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_
8443 !v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_cor
8444 !e_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_uti
8445 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
8446 ! gradient of useful results: q mass fx fy
8447 ! with respect to varying inputs: q mass fx fy
8448  SUBROUTINE deln_flux_fwd(nord, is, ie, js, je, npx, npy, damp, q, &
8449 & fx, fy, gridstruct, bd, mass)
8450  IMPLICIT NONE
8451 ! Del-n damping for the cell-mean values (A grid)
8452 !------------------
8453 ! nord = 0: del-2
8454 ! nord = 1: del-4
8455 ! nord = 2: del-6
8456 ! nord = 3: del-8 --> requires more ghosting than current
8457 !------------------
8458  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8459 ! del-n
8460  INTEGER, INTENT(IN) :: nord
8461  INTEGER, INTENT(IN) :: is, ie, js, je, npx, npy
8462  REAL, INTENT(IN) :: damp
8463 ! q ghosted on input
8464  REAL, INTENT(IN) :: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
8465  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8466 ! q ghosted on input
8467  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
8468 ! diffusive fluxes:
8469  REAL, INTENT(INOUT) :: fx(bd%is:bd%ie+1, bd%js:bd%je), fy(bd%is:bd%&
8470 & ie, bd%js:bd%je+1)
8471 ! local:
8472  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd:bd%ied, bd%&
8473 & jsd:bd%jed+1)
8474  REAL :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
8475  REAL :: damp2
8476  INTEGER :: i, j, n, nt, i1, i2, j1, j2
8477  INTRINSIC PRESENT
8478  INTEGER :: ad_from
8479  INTEGER :: ad_from0
8480  INTEGER :: ad_from1
8481  INTEGER :: ad_from2
8482  INTEGER :: ad_from3
8483  INTEGER :: ad_from4
8484 
8485  fx2 = 0.0
8486  fy2 = 0.0
8487  d2 = 0.0
8488  damp2 = 0.0
8489  nt = 0
8490  i1 = 0
8491  i2 = 0
8492  j1 = 0
8493  j2 = 0
8494  ad_from = 0
8495  ad_from0 = 0
8496  ad_from1 = 0
8497  ad_from2 = 0
8498  ad_from3 = 0
8499  ad_from4 = 0
8500 
8501  i1 = is - 1 - nord
8502  i2 = ie + 1 + nord
8503  j1 = js - 1 - nord
8504  j2 = je + 1 + nord
8505  IF (.NOT.PRESENT(mass)) THEN
8506  DO j=j1,j2
8507  DO i=i1,i2
8508  d2(i, j) = damp*q(i, j)
8509  END DO
8510  END DO
8511  CALL pushcontrol(1,0)
8512  ELSE
8513  DO j=j1,j2
8514  DO i=i1,i2
8515  d2(i, j) = q(i, j)
8516  END DO
8517  END DO
8518  CALL pushcontrol(1,1)
8519  END IF
8520  IF (nord .GT. 0) THEN
8521  CALL copy_corners_fwd(d2, npx, npy, 1, gridstruct%nested, bd, &
8522 & gridstruct%sw_corner, gridstruct%se_corner, &
8523 & gridstruct%nw_corner, gridstruct%ne_corner)
8524  CALL pushcontrol(1,1)
8525  ELSE
8526  CALL pushcontrol(1,0)
8527  END IF
8528  DO j=js-nord,je+nord
8529  DO i=is-nord,ie+nord+1
8530  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i-1, j)-d2(i, j))
8531  END DO
8532  END DO
8533  IF (nord .GT. 0) THEN
8534  CALL copy_corners_fwd(d2, npx, npy, 2, gridstruct%nested, bd, &
8535 & gridstruct%sw_corner, gridstruct%se_corner, &
8536 & gridstruct%nw_corner, gridstruct%ne_corner)
8537  CALL pushcontrol(1,1)
8538  ELSE
8539  CALL pushcontrol(1,0)
8540  END IF
8541  DO j=js-nord,je+nord+1
8542  DO i=is-nord,ie+nord
8543  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j-1)-d2(i, j))
8544  END DO
8545  END DO
8546  IF (nord .GT. 0) THEN
8547 !----------
8548 ! high-order
8549 !----------
8550  DO n=1,nord
8551  nt = nord - n
8552  ad_from0 = js - nt - 1
8553  DO j=ad_from0,je+nt+1
8554  ad_from = is - nt - 1
8555  DO i=ad_from,ie+nt+1
8556  d2(i, j) = (fx2(i, j)-fx2(i+1, j)+fy2(i, j)-fy2(i, j+1))*&
8557 & gridstruct%rarea(i, j)
8558  END DO
8559  CALL pushinteger(i - 1)
8560  CALL pushinteger(ad_from)
8561  END DO
8562  CALL pushinteger(j - 1)
8563  CALL pushinteger(ad_from0)
8564  CALL copy_corners_fwd(d2, npx, npy, 1, gridstruct%nested, bd&
8565 & , gridstruct%sw_corner, gridstruct%se_corner&
8566 & , gridstruct%nw_corner, gridstruct%ne_corner)
8567  ad_from2 = js - nt
8568  DO j=ad_from2,je+nt
8569  ad_from1 = is - nt
8570  DO i=ad_from1,ie+nt+1
8571  fx2(i, j) = gridstruct%del6_v(i, j)*(d2(i, j)-d2(i-1, j))
8572  END DO
8573  CALL pushinteger(i - 1)
8574  CALL pushinteger(ad_from1)
8575  END DO
8576  CALL pushinteger(j - 1)
8577  CALL pushinteger(ad_from2)
8578  CALL copy_corners_fwd(d2, npx, npy, 2, gridstruct%nested, bd&
8579 & , gridstruct%sw_corner, gridstruct%se_corner&
8580 & , gridstruct%nw_corner, gridstruct%ne_corner)
8581  ad_from4 = js - nt
8582  DO j=ad_from4,je+nt+1
8583  ad_from3 = is - nt
8584  DO i=ad_from3,ie+nt
8585  fy2(i, j) = gridstruct%del6_u(i, j)*(d2(i, j)-d2(i, j-1))
8586  END DO
8587  CALL pushinteger(i - 1)
8588  CALL pushinteger(ad_from3)
8589  END DO
8590  CALL pushinteger(j - 1)
8591  CALL pushinteger(ad_from4)
8592  END DO
8593  CALL pushcontrol(1,0)
8594  ELSE
8595  CALL pushcontrol(1,1)
8596  END IF
8597 !---------------------------------------------
8598 ! Add the diffusive fluxes to the flux arrays:
8599 !---------------------------------------------
8600  IF (PRESENT(mass)) THEN
8601 ! Apply mass weighting to diffusive fluxes:
8602  damp2 = 0.5*damp
8603  DO j=js,je
8604  DO i=is,ie+1
8605  CALL pushrealarray(fx(i, j))
8606  fx(i, j) = fx(i, j) + damp2*(mass(i-1, j)+mass(i, j))*fx2(i, j&
8607 & )
8608  END DO
8609  END DO
8610  DO j=js,je+1
8611  DO i=is,ie
8612  CALL pushrealarray(fy(i, j))
8613  fy(i, j) = fy(i, j) + damp2*(mass(i, j-1)+mass(i, j))*fy2(i, j&
8614 & )
8615  END DO
8616  END DO
8617  CALL pushrealarray(damp2)
8618  CALL pushrealarray(fx2, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
8619  CALL pushrealarray(fy2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
8620  CALL pushinteger(i1)
8621  CALL pushcontrol(1,0)
8622  ELSE
8623  DO j=js,je
8624  DO i=is,ie+1
8625  CALL pushrealarray(fx(i, j))
8626  fx(i, j) = fx(i, j) + fx2(i, j)
8627  END DO
8628  END DO
8629  DO j=js,je+1
8630  DO i=is,ie
8631  CALL pushrealarray(fy(i, j))
8632  fy(i, j) = fy(i, j) + fy2(i, j)
8633  END DO
8634  END DO
8635  CALL pushinteger(i1)
8636  CALL pushcontrol(1,1)
8637  END IF
8638  END SUBROUTINE deln_flux_fwd
8639 ! Differentiation of deln_flux in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
8640 !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
8641 !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
8642 !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
8643 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
8644 !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
8645 !.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
8646 !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
8647 !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
8648 !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
8649 !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
8650 !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
8651 !_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_
8652 !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
8653 !.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
8654 !_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
8655 !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
8656 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
8657 ! gradient of useful results: q mass fx fy
8658 ! with respect to varying inputs: q mass fx fy
8659  SUBROUTINE deln_flux_bwd(nord, is, ie, js, je, npx, npy, damp, q, &
8660 & q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd, mass, mass_ad)
8661  IMPLICIT NONE
8662  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8663  INTEGER, INTENT(IN) :: nord
8664  INTEGER, INTENT(IN) :: is, ie, js, je, npx, npy
8665  REAL, INTENT(IN) :: damp
8666  REAL, INTENT(IN) :: q(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
8667  REAL :: q_ad(bd%is-ng:bd%ie+ng, bd%js-ng:bd%je+ng)
8668  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8669  REAL, OPTIONAL, INTENT(IN) :: mass(bd%isd:bd%ied, bd%jsd:bd%jed)
8670  REAL, OPTIONAL :: mass_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
8671  REAL, INTENT(INOUT) :: fx(bd%is:bd%ie+1, bd%js:bd%je), fy(bd%is:bd%&
8672 & ie, bd%js:bd%je+1)
8673  REAL, INTENT(INOUT) :: fx_ad(bd%is:bd%ie+1, bd%js:bd%je), fy_ad(bd%&
8674 & is:bd%ie, bd%js:bd%je+1)
8675  REAL :: fx2(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2(bd%isd:bd%ied, bd%&
8676 & jsd:bd%jed+1)
8677  REAL :: fx2_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy2_ad(bd%isd:bd%ied&
8678 & , bd%jsd:bd%jed+1)
8679  REAL :: d2(bd%isd:bd%ied, bd%jsd:bd%jed)
8680  REAL :: d2_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
8681  REAL :: damp2
8682  INTEGER :: i, j, n, nt, i1, i2, j1, j2
8683  INTRINSIC PRESENT
8684  REAL :: temp_ad
8685  REAL :: temp_ad0
8686  REAL :: temp_ad1
8687  REAL :: temp_ad2
8688  REAL :: temp_ad3
8689  REAL :: temp_ad4
8690  REAL :: temp_ad5
8691  INTEGER :: ad_from
8692  INTEGER :: ad_to
8693  INTEGER :: ad_from0
8694  INTEGER :: ad_to0
8695  INTEGER :: ad_from1
8696  INTEGER :: ad_to1
8697  INTEGER :: ad_from2
8698  INTEGER :: ad_to2
8699  INTEGER :: ad_from3
8700  INTEGER :: ad_to3
8701  INTEGER :: ad_from4
8702  INTEGER :: ad_to4
8703  INTEGER :: branch
8704 
8705  fx2 = 0.0
8706  fy2 = 0.0
8707  d2 = 0.0
8708  damp2 = 0.0
8709  nt = 0
8710  i1 = 0
8711  i2 = 0
8712  j1 = 0
8713  j2 = 0
8714  ad_from = 0
8715  ad_from0 = 0
8716  ad_from1 = 0
8717  ad_from2 = 0
8718  ad_from3 = 0
8719  ad_from4 = 0
8720  ad_to = 0
8721  ad_to0 = 0
8722  ad_to1 = 0
8723  ad_to2 = 0
8724  ad_to3 = 0
8725  ad_to4 = 0
8726  branch = 0
8727 
8728  CALL popcontrol(1,branch)
8729  IF (branch .EQ. 0) THEN
8730  CALL popinteger(i1)
8731  CALL poprealarray(fy2, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2))
8732  CALL poprealarray(fx2, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1))
8733  CALL poprealarray(damp2)
8734  fy2_ad = 0.0
8735  DO j=je+1,js,-1
8736  DO i=ie,is,-1
8737  CALL poprealarray(fy(i, j))
8738  temp_ad5 = damp2*fy2(i, j)*fy_ad(i, j)
8739  mass_ad(i, j-1) = mass_ad(i, j-1) + temp_ad5
8740  mass_ad(i, j) = mass_ad(i, j) + temp_ad5
8741  fy2_ad(i, j) = fy2_ad(i, j) + damp2*(mass(i, j-1)+mass(i, j))*&
8742 & fy_ad(i, j)
8743  END DO
8744  END DO
8745  fx2_ad = 0.0
8746  DO j=je,js,-1
8747  DO i=ie+1,is,-1
8748  CALL poprealarray(fx(i, j))
8749  temp_ad4 = damp2*fx2(i, j)*fx_ad(i, j)
8750  mass_ad(i-1, j) = mass_ad(i-1, j) + temp_ad4
8751  mass_ad(i, j) = mass_ad(i, j) + temp_ad4
8752  fx2_ad(i, j) = fx2_ad(i, j) + damp2*(mass(i-1, j)+mass(i, j))*&
8753 & fx_ad(i, j)
8754  END DO
8755  END DO
8756  ELSE
8757  CALL popinteger(i1)
8758  fy2_ad = 0.0
8759  DO j=je+1,js,-1
8760  DO i=ie,is,-1
8761  CALL poprealarray(fy(i, j))
8762  fy2_ad(i, j) = fy2_ad(i, j) + fy_ad(i, j)
8763  END DO
8764  END DO
8765  fx2_ad = 0.0
8766  DO j=je,js,-1
8767  DO i=ie+1,is,-1
8768  CALL poprealarray(fx(i, j))
8769  fx2_ad(i, j) = fx2_ad(i, j) + fx_ad(i, j)
8770  END DO
8771  END DO
8772  END IF
8773  CALL popcontrol(1,branch)
8774  IF (branch .EQ. 0) THEN
8775  d2_ad = 0.0
8776  DO n=nord,1,-1
8777  CALL popinteger(ad_from4)
8778  CALL popinteger(ad_to4)
8779  DO j=ad_to4,ad_from4,-1
8780  CALL popinteger(ad_from3)
8781  CALL popinteger(ad_to3)
8782  DO i=ad_to3,ad_from3,-1
8783  temp_ad3 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
8784  d2_ad(i, j) = d2_ad(i, j) + temp_ad3
8785  d2_ad(i, j-1) = d2_ad(i, j-1) - temp_ad3
8786  fy2_ad(i, j) = 0.0
8787  END DO
8788  END DO
8789  CALL copy_corners_bwd(d2, d2_ad, npx, npy, 2, gridstruct%&
8790 & nested, bd, gridstruct%sw_corner, gridstruct%&
8791 & se_corner, gridstruct%nw_corner, gridstruct%&
8792 & ne_corner)
8793  CALL popinteger(ad_from2)
8794  CALL popinteger(ad_to2)
8795  DO j=ad_to2,ad_from2,-1
8796  CALL popinteger(ad_from1)
8797  CALL popinteger(ad_to1)
8798  DO i=ad_to1,ad_from1,-1
8799  temp_ad2 = gridstruct%del6_v(i, j)*fx2_ad(i, j)
8800  d2_ad(i, j) = d2_ad(i, j) + temp_ad2
8801  d2_ad(i-1, j) = d2_ad(i-1, j) - temp_ad2
8802  fx2_ad(i, j) = 0.0
8803  END DO
8804  END DO
8805  CALL copy_corners_bwd(d2, d2_ad, npx, npy, 1, gridstruct%&
8806 & nested, bd, gridstruct%sw_corner, gridstruct%&
8807 & se_corner, gridstruct%nw_corner, gridstruct%&
8808 & ne_corner)
8809  CALL popinteger(ad_from0)
8810  CALL popinteger(ad_to0)
8811  DO j=ad_to0,ad_from0,-1
8812  CALL popinteger(ad_from)
8813  CALL popinteger(ad_to)
8814  DO i=ad_to,ad_from,-1
8815  temp_ad1 = gridstruct%rarea(i, j)*d2_ad(i, j)
8816  fx2_ad(i, j) = fx2_ad(i, j) + temp_ad1
8817  fx2_ad(i+1, j) = fx2_ad(i+1, j) - temp_ad1
8818  fy2_ad(i, j) = fy2_ad(i, j) + temp_ad1
8819  fy2_ad(i, j+1) = fy2_ad(i, j+1) - temp_ad1
8820  d2_ad(i, j) = 0.0
8821  END DO
8822  END DO
8823  END DO
8824  ELSE
8825  d2_ad = 0.0
8826  END IF
8827  DO j=je+nord+1,js-nord,-1
8828  DO i=ie+nord,is-nord,-1
8829  temp_ad0 = gridstruct%del6_u(i, j)*fy2_ad(i, j)
8830  d2_ad(i, j-1) = d2_ad(i, j-1) + temp_ad0
8831  d2_ad(i, j) = d2_ad(i, j) - temp_ad0
8832  fy2_ad(i, j) = 0.0
8833  END DO
8834  END DO
8835  CALL popcontrol(1,branch)
8836  IF (branch .NE. 0) CALL copy_corners_bwd(d2, d2_ad, npx, npy, 2, &
8837 & gridstruct%nested, bd, &
8838 & gridstruct%sw_corner, &
8839 & gridstruct%se_corner, &
8840 & gridstruct%nw_corner, &
8841 & gridstruct%ne_corner)
8842  DO j=je+nord,js-nord,-1
8843  DO i=ie+nord+1,is-nord,-1
8844  temp_ad = gridstruct%del6_v(i, j)*fx2_ad(i, j)
8845  d2_ad(i-1, j) = d2_ad(i-1, j) + temp_ad
8846  d2_ad(i, j) = d2_ad(i, j) - temp_ad
8847  fx2_ad(i, j) = 0.0
8848  END DO
8849  END DO
8850  CALL popcontrol(1,branch)
8851  IF (branch .NE. 0) CALL copy_corners_bwd(d2, d2_ad, npx, npy, 1, &
8852 & gridstruct%nested, bd, &
8853 & gridstruct%sw_corner, &
8854 & gridstruct%se_corner, &
8855 & gridstruct%nw_corner, &
8856 & gridstruct%ne_corner)
8857  i2 = ie + 1 + nord
8858  j1 = js - 1 - nord
8859  j2 = je + 1 + nord
8860  CALL popcontrol(1,branch)
8861  IF (branch .EQ. 0) THEN
8862  DO j=j2,j1,-1
8863  DO i=i2,i1,-1
8864  q_ad(i, j) = q_ad(i, j) + damp*d2_ad(i, j)
8865  d2_ad(i, j) = 0.0
8866  END DO
8867  END DO
8868  ELSE
8869  DO j=j2,j1,-1
8870  DO i=i2,i1,-1
8871  q_ad(i, j) = q_ad(i, j) + d2_ad(i, j)
8872  d2_ad(i, j) = 0.0
8873  END DO
8874  END DO
8875  END IF
8876  END SUBROUTINE deln_flux_bwd
8877 ! Differentiation of copy_corners in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_e
8878 !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_
8879 !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_
8880 !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
8881 !leigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2
8882 !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
8883 !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
8884 !_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
8885 !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
8886 ! 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
8887 !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
8888 !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
8889 !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
8890 !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
8891 !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
8892 !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_
8893 !core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_
8894 !utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
8895 ! gradient of useful results: q
8896 ! with respect to varying inputs: q
8897 !Weird arguments are because this routine is called in a lot of
8898 !places outside of tp_core, sometimes very deeply nested in the call tree.
8899  SUBROUTINE copy_corners_fwd(q, npx, npy, dir, nested, bd, sw_corner&
8900 & , se_corner, nw_corner, ne_corner)
8901  IMPLICIT NONE
8902  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8903  INTEGER, INTENT(IN) :: npx, npy, dir
8904  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
8905  LOGICAL, INTENT(IN) :: nested, sw_corner, se_corner, nw_corner, &
8906 & ne_corner
8907  INTEGER :: i, j
8908  REAL :: tmp
8909  REAL :: tmp0
8910  REAL :: tmp1
8911  REAL :: tmp2
8912  REAL :: tmp3
8913  REAL :: tmp4
8914  REAL :: tmp5
8915  REAL :: tmp6
8916  IF (nested) THEN
8917  CALL pushcontrol(3,0)
8918  ELSE IF (dir .EQ. 1) THEN
8919 ! XDir:
8920  IF (sw_corner) THEN
8921  DO j=1-ng,0
8922  DO i=1-ng,0
8923  tmp = q(j, 1-i)
8924  CALL pushrealarray(q(i, j))
8925  q(i, j) = tmp
8926  END DO
8927  END DO
8928  CALL pushcontrol(1,0)
8929  ELSE
8930  CALL pushcontrol(1,1)
8931  END IF
8932  IF (se_corner) THEN
8933  DO j=1-ng,0
8934  DO i=npx,npx+ng-1
8935  tmp0 = q(npy-j, i-npx+1)
8936  CALL pushrealarray(q(i, j))
8937  q(i, j) = tmp0
8938  END DO
8939  END DO
8940  CALL pushcontrol(1,0)
8941  ELSE
8942  CALL pushcontrol(1,1)
8943  END IF
8944  IF (ne_corner) THEN
8945  DO j=npy,npy+ng-1
8946  DO i=npx,npx+ng-1
8947  tmp1 = q(j, 2*npx-1-i)
8948  CALL pushrealarray(q(i, j))
8949  q(i, j) = tmp1
8950  END DO
8951  END DO
8952  CALL pushcontrol(1,0)
8953  ELSE
8954  CALL pushcontrol(1,1)
8955  END IF
8956  IF (nw_corner) THEN
8957  DO j=npy,npy+ng-1
8958  DO i=1-ng,0
8959  tmp2 = q(npy-j, i-1+npx)
8960  CALL pushrealarray(q(i, j))
8961  q(i, j) = tmp2
8962  END DO
8963  END DO
8964  CALL pushcontrol(3,2)
8965  ELSE
8966  CALL pushcontrol(3,1)
8967  END IF
8968  ELSE IF (dir .EQ. 2) THEN
8969 ! YDir:
8970  IF (sw_corner) THEN
8971  DO j=1-ng,0
8972  DO i=1-ng,0
8973  tmp3 = q(1-j, i)
8974  CALL pushrealarray(q(i, j))
8975  q(i, j) = tmp3
8976  END DO
8977  END DO
8978  CALL pushcontrol(1,0)
8979  ELSE
8980  CALL pushcontrol(1,1)
8981  END IF
8982  IF (se_corner) THEN
8983  DO j=1-ng,0
8984  DO i=npx,npx+ng-1
8985  tmp4 = q(npy+j-1, npx-i)
8986  CALL pushrealarray(q(i, j))
8987  q(i, j) = tmp4
8988  END DO
8989  END DO
8990  CALL pushcontrol(1,0)
8991  ELSE
8992  CALL pushcontrol(1,1)
8993  END IF
8994  IF (ne_corner) THEN
8995  DO j=npy,npy+ng-1
8996  DO i=npx,npx+ng-1
8997  tmp5 = q(2*npy-1-j, i)
8998  CALL pushrealarray(q(i, j))
8999  q(i, j) = tmp5
9000  END DO
9001  END DO
9002  CALL pushcontrol(1,0)
9003  ELSE
9004  CALL pushcontrol(1,1)
9005  END IF
9006  IF (nw_corner) THEN
9007  DO j=npy,npy+ng-1
9008  DO i=1-ng,0
9009  tmp6 = q(j+1-npx, npy-i)
9010  CALL pushrealarray(q(i, j))
9011  q(i, j) = tmp6
9012  END DO
9013  END DO
9014  CALL pushcontrol(3,5)
9015  ELSE
9016  CALL pushcontrol(3,4)
9017  END IF
9018  ELSE
9019  CALL pushcontrol(3,3)
9020  END IF
9021  END SUBROUTINE copy_corners_fwd
9022 ! Differentiation of copy_corners in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_
9023 !edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn
9024 !_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
9025 !_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Ra
9026 !yleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c
9027 !2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_
9028 !mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rema
9029 !p_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_lim
9030 !iters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubi
9031 !c fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_
9032 !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_
9033 !utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_ut
9034 !ils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_uti
9035 !ls_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_
9036 !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.
9037 !ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp
9038 !_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid
9039 !_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
9040 ! gradient of useful results: q
9041 ! with respect to varying inputs: q
9042 !Weird arguments are because this routine is called in a lot of
9043 !places outside of tp_core, sometimes very deeply nested in the call tree.
9044  SUBROUTINE copy_corners_bwd(q, q_ad, npx, npy, dir, nested, bd, &
9045 & sw_corner, se_corner, nw_corner, ne_corner)
9046  IMPLICIT NONE
9047  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
9048  INTEGER, INTENT(IN) :: npx, npy, dir
9049  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed)
9050  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
9051  LOGICAL, INTENT(IN) :: nested, sw_corner, se_corner, nw_corner, &
9052 & ne_corner
9053  INTEGER :: i, j
9054  REAL :: tmp_ad
9055  REAL :: tmp_ad0
9056  REAL :: tmp_ad1
9057  REAL :: tmp_ad2
9058  REAL :: tmp_ad3
9059  REAL :: tmp_ad4
9060  REAL :: tmp_ad5
9061  REAL :: tmp_ad6
9062  INTEGER :: branch
9063 
9064  branch = 0
9065 
9066  CALL popcontrol(3,branch)
9067  IF (branch .LT. 3) THEN
9068  IF (branch .NE. 0) THEN
9069  IF (branch .NE. 1) THEN
9070  DO j=npy+ng-1,npy,-1
9071  DO i=0,1-ng,-1
9072  CALL poprealarray(q(i, j))
9073  tmp_ad2 = q_ad(i, j)
9074  q_ad(i, j) = 0.0
9075  q_ad(npy-j, i-1+npx) = q_ad(npy-j, i-1+npx) + tmp_ad2
9076  END DO
9077  END DO
9078  END IF
9079  CALL popcontrol(1,branch)
9080  IF (branch .EQ. 0) THEN
9081  DO j=npy+ng-1,npy,-1
9082  DO i=npx+ng-1,npx,-1
9083  CALL poprealarray(q(i, j))
9084  tmp_ad1 = q_ad(i, j)
9085  q_ad(i, j) = 0.0
9086  q_ad(j, 2*npx-1-i) = q_ad(j, 2*npx-1-i) + tmp_ad1
9087  END DO
9088  END DO
9089  END IF
9090  CALL popcontrol(1,branch)
9091  IF (branch .EQ. 0) THEN
9092  DO j=0,1-ng,-1
9093  DO i=npx+ng-1,npx,-1
9094  CALL poprealarray(q(i, j))
9095  tmp_ad0 = q_ad(i, j)
9096  q_ad(i, j) = 0.0
9097  q_ad(npy-j, i-npx+1) = q_ad(npy-j, i-npx+1) + tmp_ad0
9098  END DO
9099  END DO
9100  END IF
9101  CALL popcontrol(1,branch)
9102  IF (branch .EQ. 0) THEN
9103  DO j=0,1-ng,-1
9104  DO i=0,1-ng,-1
9105  CALL poprealarray(q(i, j))
9106  tmp_ad = q_ad(i, j)
9107  q_ad(i, j) = 0.0
9108  q_ad(j, 1-i) = q_ad(j, 1-i) + tmp_ad
9109  END DO
9110  END DO
9111  END IF
9112  END IF
9113  ELSE IF (branch .NE. 3) THEN
9114  IF (branch .NE. 4) THEN
9115  DO j=npy+ng-1,npy,-1
9116  DO i=0,1-ng,-1
9117  CALL poprealarray(q(i, j))
9118  tmp_ad6 = q_ad(i, j)
9119  q_ad(i, j) = 0.0
9120  q_ad(j+1-npx, npy-i) = q_ad(j+1-npx, npy-i) + tmp_ad6
9121  END DO
9122  END DO
9123  END IF
9124  CALL popcontrol(1,branch)
9125  IF (branch .EQ. 0) THEN
9126  DO j=npy+ng-1,npy,-1
9127  DO i=npx+ng-1,npx,-1
9128  CALL poprealarray(q(i, j))
9129  tmp_ad5 = q_ad(i, j)
9130  q_ad(i, j) = 0.0
9131  q_ad(2*npy-1-j, i) = q_ad(2*npy-1-j, i) + tmp_ad5
9132  END DO
9133  END DO
9134  END IF
9135  CALL popcontrol(1,branch)
9136  IF (branch .EQ. 0) THEN
9137  DO j=0,1-ng,-1
9138  DO i=npx+ng-1,npx,-1
9139  CALL poprealarray(q(i, j))
9140  tmp_ad4 = q_ad(i, j)
9141  q_ad(i, j) = 0.0
9142  q_ad(npy+j-1, npx-i) = q_ad(npy+j-1, npx-i) + tmp_ad4
9143  END DO
9144  END DO
9145  END IF
9146  CALL popcontrol(1,branch)
9147  IF (branch .EQ. 0) THEN
9148  DO j=0,1-ng,-1
9149  DO i=0,1-ng,-1
9150  CALL poprealarray(q(i, j))
9151  tmp_ad3 = q_ad(i, j)
9152  q_ad(i, j) = 0.0
9153  q_ad(1-j, i) = q_ad(1-j, i) + tmp_ad3
9154  END DO
9155  END DO
9156  END IF
9157  END IF
9158  END SUBROUTINE copy_corners_bwd
9159 !Weird arguments are because this routine is called in a lot of
9160 !places outside of tp_core, sometimes very deeply nested in the call tree.
9161 end module tp_core_adm_mod
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
tp_core_adm_mod::xppm
subroutine xppm(flux, q, c, iord, is, ie, isd, ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
Definition: tp_core_adm.F90:2677
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
tp_core_adm_mod::c3
real, parameter c3
Definition: tp_core_adm.F90:68
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
tp_core_adm_mod
Definition: tp_core_adm.F90:20
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
tp_core_adm_mod::b2
real, parameter b2
Definition: tp_core_adm.F90:55
tp_core_adm_mod::b4
real, parameter b4
Definition: tp_core_adm.F90:57
popcontrol2b
subroutine popcontrol2b(cc)
Definition: adBuffer.f:146
tp_core_adm_mod::p1
real, parameter p1
Definition: tp_core_adm.F90:72
tp_core_adm_mod::deln_flux_fwd
subroutine deln_flux_fwd(nord, is, ie, js, je, npx, npy, damp, q, fx, fy, gridstruct, bd, mass)
Definition: tp_core_adm.F90:8450
tp_core_adm_mod::c1
real, parameter c1
Definition: tp_core_adm.F90:66
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
tp_core_adm_mod::b5
real, parameter b5
Definition: tp_core_adm.F90:58
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
tp_core_adm_mod::b3
real, parameter b3
Definition: tp_core_adm.F90:56
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
tp_core_adm_mod::mp_ghost_ew
subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
Definition: tp_core_adm.F90:6166
tp_core_adm_mod::near_zero
real, parameter near_zero
Definition: tp_core_adm.F90:41
tp_core_adm_mod::deln_flux_bwd
subroutine deln_flux_bwd(nord, is, ie, js, je, npx, npy, damp, q, q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd, mass, mass_ad)
Definition: tp_core_adm.F90:8661
tp_core_adm_mod::deln_flux_adm
subroutine deln_flux_adm(nord, is, ie, js, je, npx, npy, damp, q, q_ad, fx, fx_ad, fy, fy_ad, gridstruct, bd, mass, mass_ad)
Definition: tp_core_adm.F90:6425
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
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
tp_core_adm_mod::xppm_fwd
subroutine xppm_fwd(flux, q, c, iord, is, ie, isd, ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
Definition: tp_core_adm.F90:7554
tp_core_adm_mod::s14
real, parameter s14
Definition: tp_core_adm.F90:61
fv_grid_utils_nlm_mod
Definition: fv_grid_utils_nlm.F90:20
tp_core_adm_mod::deln_flux
subroutine deln_flux(nord, is, ie, js, je, npx, npy, damp, q, fx, fy, gridstruct, bd, mass)
Definition: tp_core_adm.F90:6880
pushcontrol2b
subroutine pushcontrol2b(cc)
Definition: adBuffer.f:140
fv_grid_utils_nlm_mod::big_number
real, parameter, public big_number
Definition: fv_grid_utils_nlm.F90:49
tp_core_adm_mod::yppm_bwd
subroutine yppm_bwd(flux, flux_ad, q, q_ad, c, c_ad, jord, ifirst, ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
Definition: tp_core_adm.F90:8200
tp_core_adm_mod::r3
real, parameter r3
Definition: tp_core_adm.F90:40
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
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
fv_mp_nlm_mod::ng
integer, parameter, public ng
Definition: fv_mp_nlm_mod.F90:2465
tp_core_adm_mod::copy_corners_fwd
subroutine copy_corners_fwd(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:8901
tapenade_iter
Definition: tapenade_iter.F90:1
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
tp_core_adm_mod::s11
real, parameter s11
Definition: tp_core_adm.F90:61
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
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
tp_core_adm_mod::yppm_adm
subroutine yppm_adm(flux, flux_ad, q, q_ad, c, c_ad, jord, ifirst, ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
Definition: tp_core_adm.F90:3419
popcontrol3b
subroutine popcontrol3b(cc)
Definition: adBuffer.f:175
tp_core_adm_mod::xppm_bwd
subroutine xppm_bwd(flux, flux_ad, q, q_ad, c, c_ad, iord, is, ie, isd, ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
Definition: tp_core_adm.F90:7752
tp_core_adm_mod::yppm
subroutine yppm(flux, q, c, jord, ifirst, ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
Definition: tp_core_adm.F90:5396
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
max
#define max(a, b)
Definition: mosaic_util.h:33
tp_core_adm_mod::c2
real, parameter c2
Definition: tp_core_adm.F90:67
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
tp_core_adm_mod::p2
real, parameter p2
Definition: tp_core_adm.F90:73
tp_core_adm_mod::ppm_limiter
real, parameter ppm_limiter
Definition: tp_core_adm.F90:42
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
tp_core_adm_mod::t12
real, parameter t12
Definition: tp_core_adm.F90:60
tp_core_adm_mod::xppm_adm
subroutine xppm_adm(flux, flux_ad, q, q_ad, c, c_ad, iord, is, ie, isd, ied, jfirst, jlast, jsd, jed, npx, npy, dxa, nested, grid_type)
Definition: tp_core_adm.F90:630
tp_core_adm_mod::copy_corners_bwd
subroutine copy_corners_bwd(q, q_ad, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:9046
pushcontrol3b
subroutine pushcontrol3b(cc)
Definition: adBuffer.f:168
min
#define min(a, b)
Definition: mosaic_util.h:32
tp_core_adm_mod::yppm_fwd
subroutine yppm_fwd(flux, q, c, jord, ifirst, ilast, isd, ied, js, je, jsd, jed, npx, npy, dya, nested, grid_type)
Definition: tp_core_adm.F90:8000
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
tp_core_adm_mod::b1
real, parameter b1
Definition: tp_core_adm.F90:54
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
tp_core_adm_mod::t11
real, parameter t11
Definition: tp_core_adm.F90:60
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484
tp_core_adm_mod::s15
real, parameter s15
Definition: tp_core_adm.F90:61
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
tp_core_adm_mod::t13
real, parameter t13
Definition: tp_core_adm.F90:60
tp_core_adm_mod::ppm_fac
real, parameter ppm_fac
Definition: tp_core_adm.F90:39