FV3 Bundle
fv_mapz_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 ! SJL: Apr 12, 2012
21 ! This revision may actually produce rounding level differences due to the elimination of KS to compute
22 ! pressure level for remapping.
23 module fv_mapz_adm_mod
24 
25  use constants_mod, only: radius, pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor
26  use tracer_manager_mod,only: get_tracer_index
27  use field_manager_mod, only: model_atmos
28  use fv_grid_utils_nlm_mod, only: ptop_min
29  use fv_grid_utils_adm_mod, only: g_sum
30  use fv_grid_utils_adm_mod, only: g_sum_adm
31  use fv_fill_nlm_mod, only: fillz
32  use mpp_domains_mod, only: mpp_update_domains, domain2d
33  use mpp_mod, only: fatal, mpp_error, get_unit, mpp_root_pe, mpp_pe
34  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type
35  use fv_timing_nlm_mod, only: timing_on, timing_off
36  use fv_mp_nlm_mod, only: is_master
37  use fv_cmp_nlm_mod, only: qs_init, fv_sat_adj
38  use fv_diagnostics_nlm_mod, only: prt_mxm
39 
40  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
41  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
42  use fv_arrays_tlmadm_mod, only: fpp
43 
44  implicit none
45  real, parameter:: consv_min= 0.001 ! below which no correction applies
46  real, parameter:: t_min= 184. ! below which applies stricter constraint
47  real, parameter:: r2=1./2., r0=0.0
48  real, parameter:: r3 = 1./3., r23 = 2./3., r12 = 1./12.
49  real, parameter:: cv_vap = 3.*rvgas ! 1384.5
50  real, parameter:: cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68
51 ! real, parameter:: c_ice = 2106. ! heat capacity of ice at 0.C
52  real, parameter:: c_ice = 1972. ! heat capacity of ice at -15.C
53  real, parameter:: c_liq = 4.1855e+3 ! GFS: heat capacity of water at 0C
54 ! real, parameter:: c_liq = 4218. ! ECMWF-IFS
55  real, parameter:: cp_vap = cp_vapor ! 1846.
56  real, parameter:: tice = 273.16
57 
58  real :: e_flux = 0.
59  private
60 
61  public compute_total_energy, lagrangian_to_eulerian, moist_cv, moist_cp, &
62  rst_remap, mappm, e_flux, map1_q2
63  public compute_total_energy_fwd, lagrangian_to_eulerian_fwd, &
64  map1_q2_fwd
65  public compute_total_energy_bwd, lagrangian_to_eulerian_bwd, &
66  map1_q2_bwd
67 
68 CONTAINS
69 ! Differentiation of lagrangian_to_eulerian in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4_f
70 !b a2b_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_
71 !pe dyn_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dy
72 !n_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_
73 !mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils
74 !_mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv
75 !_mapz_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mo
76 !d.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.p
77 !pm_limiters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map
78 !1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_m
79 !od.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz
80 !_d nh_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver
81 ! nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile
82 !nh_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw
83 !_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_cor
84 !e_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d
85 !_fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner f
86 !v_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
87 ! gradient of useful results: ws peln q u v w delp ua delz
88 ! omga te0_2d pkz pe pk ps pt te
89 ! with respect to varying inputs: ws peln q u v w delp ua delz
90 ! omga te0_2d pkz pe pk ps pt te
91  SUBROUTINE lagrangian_to_eulerian_fwd(last_step, consv, ps, pe, delp, &
92 & pkz, pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat&
93 & , sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, &
94 & kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, &
95 & te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, &
96 & flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, &
97 & do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, &
98 & kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
99  IMPLICIT NONE
100 !$OMP end parallel
101  LOGICAL, INTENT(IN) :: last_step
102 ! remap time step
103  REAL, INTENT(IN) :: mdt
104 ! phys time step
105  REAL, INTENT(IN) :: pdt
106  INTEGER, INTENT(IN) :: km
107 ! number of tracers (including h2o)
108  INTEGER, INTENT(IN) :: nq
109  INTEGER, INTENT(IN) :: nwat
110 ! index for water vapor (specific humidity)
111  INTEGER, INTENT(IN) :: sphum
112  INTEGER, INTENT(IN) :: ng
113 ! starting & ending X-Dir index
114  INTEGER, INTENT(IN) :: is, ie, isd, ied
115 ! starting & ending Y-Dir index
116  INTEGER, INTENT(IN) :: js, je, jsd, jed
117 ! Mapping order for the vector winds
118  INTEGER, INTENT(IN) :: kord_mt
119 ! Mapping order/option for w
120  INTEGER, INTENT(IN) :: kord_wz
121 ! Mapping order for tracers
122  INTEGER, INTENT(IN) :: kord_tr(nq)
123 ! Mapping order for thermodynamics
124  INTEGER, INTENT(IN) :: kord_tm
125 ! Mapping order for the vector winds
126  INTEGER, INTENT(IN) :: kord_mt_pert
127 ! Mapping order/option for w
128  INTEGER, INTENT(IN) :: kord_wz_pert
129 ! Mapping order for tracers
130  INTEGER, INTENT(IN) :: kord_tr_pert(nq)
131 ! Mapping order for thermodynamics
132  INTEGER, INTENT(IN) :: kord_tm_pert
133 ! factor for TE conservation
134  REAL, INTENT(IN) :: consv
135  REAL, INTENT(IN) :: r_vir
136  REAL, INTENT(IN) :: cp
137  REAL, INTENT(IN) :: akap
138 ! surface geopotential
139  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
140  REAL, INTENT(INOUT) :: te0_2d(is:ie, js:je)
141  REAL, INTENT(IN) :: ws(is:ie, js:je)
142  LOGICAL, INTENT(IN) :: do_sat_adj
143 ! fill negative tracers
144  LOGICAL, INTENT(IN) :: fill
145  LOGICAL, INTENT(IN) :: reproduce_sum
146  LOGICAL, INTENT(IN) :: do_omega, adiabatic, do_adiabatic_init
147  REAL, INTENT(IN) :: ptop
148  REAL, INTENT(IN) :: ak(km+1)
149  REAL, INTENT(IN) :: bk(km+1)
150  REAL, INTENT(IN) :: pfull(km)
151  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
152  TYPE(fv_flags_type), INTENT(INOUT) :: flagstruct
153  TYPE(domain2d), INTENT(INOUT) :: domain
154 ! !INPUT/OUTPUT
155 ! pe to the kappa
156  REAL, INTENT(INOUT) :: pk(is:ie, js:je, km+1)
157  REAL, INTENT(INOUT) :: q(isd:ied, jsd:jed, km, nq)
158 ! pressure thickness
159  REAL, INTENT(INOUT) :: delp(isd:ied, jsd:jed, km)
160 ! pressure at layer edges
161  REAL, INTENT(INOUT) :: pe(is-1:ie+1, km+1, js-1:je+1)
162 ! surface pressure
163  REAL, INTENT(INOUT) :: ps(isd:ied, jsd:jed)
164 ! u-wind will be ghosted one latitude to the north upon exit
165 ! u-wind (m/s)
166  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
167 ! v-wind (m/s)
168  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
169 ! vertical velocity (m/s)
170  REAL, INTENT(INOUT) :: w(isd:ied, jsd:jed, km)
171 ! cp*virtual potential temperature
172  REAL, INTENT(INOUT) :: pt(isd:ied, jsd:jed, km)
173 ! as input; output: temperature
174  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz
175  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: q_con, cappa
176  LOGICAL, INTENT(IN) :: hydrostatic
177  LOGICAL, INTENT(IN) :: hybrid_z
178  LOGICAL, INTENT(IN) :: out_dt
179 ! u-wind (m/s) on physics grid
180  REAL, INTENT(INOUT) :: ua(isd:ied, jsd:jed, km)
181 ! v-wind (m/s) on physics grid
182  REAL, INTENT(INOUT) :: va(isd:ied, jsd:jed, km)
183 ! vertical press. velocity (pascal/sec)
184  REAL, INTENT(INOUT) :: omga(isd:ied, jsd:jed, km)
185 ! log(pe)
186  REAL, INTENT(INOUT) :: peln(is:ie, km+1, js:je)
187  REAL, INTENT(INOUT) :: dtdt(is:ie, js:je, km)
188 ! layer-mean pk for converting t to pt
189  REAL :: pkz(is:ie, js:je, km)
190  REAL :: te(isd:ied, jsd:jed, km)
191 ! Mass fluxes
192 ! X-dir Mass Flux
193  REAL, OPTIONAL, INTENT(INOUT) :: mfx(is:ie+1, js:je, km)
194 ! Y-dir Mass Flux
195  REAL, OPTIONAL, INTENT(INOUT) :: mfy(is:ie, js:je+1, km)
196 ! 0: remap T in logP
197  INTEGER, INTENT(IN) :: remap_option
198 ! 1: remap PT in P
199 ! 3: remap TE in logP with GMAO cubic
200 ! !DESCRIPTION:
201 !
202 ! !REVISION HISTORY:
203 ! SJL 03.11.04: Initial version for partial remapping
204 !
205 !-----------------------------------------------------------------------
206  REAL, DIMENSION(is:ie, js:je) :: te_2d, zsum0, zsum1, dpln
207  REAL, DIMENSION(is:ie, km) :: q2, dp2
208  REAL, DIMENSION(is:ie, km+1) :: pe1, pe2, pk1, pk2, pn2, phis
209  REAL, DIMENSION(is:ie+1, km+1) :: pe0, pe3
210  REAL, DIMENSION(is:ie) :: gz, cvm, qv
211  REAL :: rcp, rg, tmp, tpe, rrg, bkh, dtmp, k1k, dlnp
212  LOGICAL :: fast_mp_consv
213  INTEGER :: i, j, k
214  INTEGER :: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel&
215 & , iq, n, kmp, kp, k_next
216  LOGICAL :: remap_t, remap_pt, remap_te
217  INTEGER :: abs_kord_tm, abs_kord_tm_pert
218  INTEGER :: iep1, jep1, iedp1, jedp1
219  INTRINSIC abs
220  INTRINSIC log
221  INTRINSIC exp
222  INTRINSIC PRESENT
223  REAL :: abs0
224  INTEGER :: arg1
225  REAL :: result1
226  LOGICAL :: arg10
227  LOGICAL :: res
228  INTEGER :: ad_count
229  INTEGER :: ad_from
230  INTEGER :: ad_from0
231  INTEGER :: ad_from1
232  INTEGER :: ad_from2
233  INTEGER :: ad_from3
234  INTEGER :: ad_from4
235  INTEGER :: ad_from5
236  INTEGER :: ad_from6
237  INTEGER :: ad_from7
238  INTEGER :: ad_from8
239  INTEGER :: ad_from9
240  INTEGER :: ad_from10
241  INTEGER :: ad_from11
242  INTEGER :: ad_from12
243  INTEGER :: ad_from13
244  INTEGER :: ad_from14
245  INTEGER :: ad_from15
246  INTEGER :: ad_from16
247  INTEGER :: ad_from17
248  INTEGER :: ad_from18
249  INTEGER :: ad_from19
250  INTEGER :: ad_from20
251  INTEGER :: ad_from21
252  INTEGER :: ad_from22
253  INTEGER :: ad_from23
254  INTEGER :: ad_from24
255  INTEGER :: ad_from25
256  INTEGER :: ad_from26
257  INTEGER :: ad_count0
258  INTEGER :: ad_from27
259  INTEGER :: ad_from28
260  INTEGER :: ad_from29
261  INTEGER :: ad_from30
262  INTEGER :: ad_from31
263  INTEGER :: ad_from32
264  INTEGER :: ad_from33
265  INTEGER :: ad_count1
266 
267  te_2d = 0.0
268  zsum0 = 0.0
269  zsum1 = 0.0
270  dpln = 0.0
271  q2 = 0.0
272  dp2 = 0.0
273  pe1 = 0.0
274  pe2 = 0.0
275  pk1 = 0.0
276  pk2 = 0.0
277  pn2 = 0.0
278  phis = 0.0
279  pe0 = 0.0
280  pe3 = 0.0
281  gz = 0.0
282  cvm = 0.0
283  qv = 0.0
284  rcp = 0.0
285  rg = 0.0
286  tmp = 0.0
287  tpe = 0.0
288  rrg = 0.0
289  bkh = 0.0
290  dtmp = 0.0
291  k1k = 0.0
292  dlnp = 0.0
293  result1 = 0.0
294  abs0 = 0.0
295  nt = 0
296  liq_wat = 0
297  ice_wat = 0
298  rainwat = 0
299  snowwat = 0
300  cld_amt = 0
301  graupel = 0
302  iq = 0
303  n = 0
304  kmp = 0
305  kp = 0
306  k_next = 0
307  abs_kord_tm = 0
308  abs_kord_tm_pert = 0
309  iep1 = 0
310  jep1 = 0
311  iedp1 = 0
312  jedp1 = 0
313  arg1 = 0
314  ad_count = 0
315  ad_from = 0
316  ad_from0 = 0
317  ad_from1 = 0
318  ad_from2 = 0
319  ad_from3 = 0
320  ad_from4 = 0
321  ad_from5 = 0
322  ad_from6 = 0
323  ad_from7 = 0
324  ad_from8 = 0
325  ad_from9 = 0
326  ad_from10 = 0
327  ad_from11 = 0
328  ad_from12 = 0
329  ad_from13 = 0
330  ad_from14 = 0
331  ad_from15 = 0
332  ad_from16 = 0
333  ad_from17 = 0
334  ad_from18 = 0
335  ad_from19 = 0
336  ad_from20 = 0
337  ad_from21 = 0
338  ad_from22 = 0
339  ad_from23 = 0
340  ad_from24 = 0
341  ad_from25 = 0
342  ad_from26 = 0
343  ad_count0 = 0
344  ad_from27 = 0
345  ad_from28 = 0
346  ad_from29 = 0
347  ad_from30 = 0
348  ad_from31 = 0
349  ad_from32 = 0
350  ad_from33 = 0
351  ad_count1 = 0
352 
353  IF (kord_tm .GE. 0.) THEN
354  abs_kord_tm = kord_tm
355  ELSE
356  abs_kord_tm = -kord_tm
357  END IF
358  IF (kord_tm_pert .GE. 0.) THEN
359  abs_kord_tm_pert = kord_tm_pert
360  ELSE
361  abs_kord_tm_pert = -kord_tm_pert
362  END IF
363  iep1 = ie + 1
364  iedp1 = ied + 1
365  jedp1 = jed + 1
366  remap_t = .false.
367  remap_pt = .false.
368  remap_te = .false.
369  SELECT CASE (remap_option)
370  CASE (0)
371  remap_t = .true.
372  CASE (1)
373  remap_pt = .true.
374  CASE (2)
375  remap_te = .true.
376  CASE DEFAULT
377  stop
378  END SELECT
379  res = is_master()
380  IF (res .AND. flagstruct%fv_debug) THEN
381  print*, ''
382  SELECT CASE (remap_option)
383  CASE (0)
384  CALL pushcontrol(1,0)
385  print*, ' REMAPPING T in logP '
386  CASE (1)
387  CALL pushcontrol(1,0)
388  print*, ' REMAPPING PT in P'
389  CASE (2)
390  CALL pushcontrol(1,0)
391  print*, ' REMAPPING TE in logP with GMAO cubic'
392  CASE DEFAULT
393  CALL pushcontrol(1,0)
394  END SELECT
395  print*, ' REMAPPING CONSV: ', consv
396  print*, ' REMAPPING CONSV_MIN: ', consv_min
397  print*, ''
398  ELSE
399  CALL pushcontrol(1,1)
400  END IF
401 ! akap / (1.-akap) = rg/Cv=0.4
402  k1k = rdgas/cv_air
403  rg = rdgas
404  rrg = -(rdgas/grav)
405  IF (do_sat_adj) THEN
406  fast_mp_consv = .NOT.do_adiabatic_init .AND. consv .GT. consv_min
407  ad_count = 1
408  DO k=1,km
409  kmp = k
410  IF (pfull(k) .GT. 10.e2) THEN
411  GOTO 100
412  ELSE
413  ad_count = ad_count + 1
414  END IF
415  END DO
416  CALL pushcontrol(1,0)
417  CALL pushinteger(ad_count)
418  CALL pushcontrol(1,1)
419  GOTO 110
420  100 CALL pushcontrol(1,1)
421  CALL pushinteger(ad_count)
422  CALL pushcontrol(1,1)
423  ELSE
424  CALL pushcontrol(1,0)
425  END IF
426  110 CALL pushinteger(j)
427  ad_count1 = 1
428 !$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, &
429 !$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, &
430 !$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, &
431 !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, &
432 !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, &
433 !$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,ua) &
434 !$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, &
435 !$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2)
436  DO j=js,je+1
437  DO k=1,km+1
438  ad_from = is
439  DO i=ad_from,ie
440  CALL pushrealarray(pe1(i, k))
441  pe1(i, k) = pe(i, k, j)
442  END DO
443  CALL pushinteger(i - 1)
444  CALL pushinteger(ad_from)
445  END DO
446  CALL pushinteger(k - 1)
447  ad_from0 = is
448  DO i=ad_from0,ie
449  CALL pushrealarray(pe2(i, 1))
450  pe2(i, 1) = ptop
451  CALL pushrealarray(pe2(i, km+1))
452  pe2(i, km+1) = pe(i, km+1, j)
453  END DO
454  CALL pushinteger(i - 1)
455  CALL pushinteger(ad_from0)
456 !(j < je+1)
457  IF (j .NE. je + 1) THEN
458  IF (remap_t) THEN
459 ! hydro test
460 ! Remap T in logP
461 ! Note: pt at this stage is Theta_v
462  IF (hydrostatic) THEN
463 ! Transform virtual pt to virtual Temp
464  DO k=1,km
465  ad_from1 = is
466  DO i=ad_from1,ie
467  CALL pushrealarray(pt(i, j, k))
468  pt(i, j, k) = pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k))/(&
469 & akap*(peln(i, k+1, j)-peln(i, k, j)))
470  END DO
471  CALL pushinteger(i - 1)
472  CALL pushinteger(ad_from1)
473  END DO
474  CALL pushinteger(k - 1)
475  CALL pushcontrol(3,0)
476  ELSE
477 ! Transform "density pt" to "density temp"
478  DO k=1,km
479  ad_from2 = is
480  DO i=ad_from2,ie
481  CALL pushrealarray(pt(i, j, k))
482  pt(i, j, k) = pt(i, j, k)*exp(k1k*log(rrg*delp(i, j, k)/&
483 & delz(i, j, k)*pt(i, j, k)))
484  END DO
485  CALL pushinteger(i - 1)
486  CALL pushinteger(ad_from2)
487  END DO
488  CALL pushinteger(k - 1)
489  CALL pushcontrol(3,1)
490  END IF
491  ELSE IF (remap_pt) THEN
492 ! Using dry pressure for the definition of the virtual potential temperature
493 ! pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)* &
494 ! pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
495  CALL pushcontrol(3,2)
496  ELSE IF (remap_te) THEN
497 ! Remap PT in P
498 ! pt is already virtual PT
499 ! Remap TE in logP
500 ! Transform virtual pt to total energy
501  CALL pkez_fwd(km, is, ie, js, je, j, pe, pk, akap, peln, pkz, &
502 & ptop)
503 ! Compute cp*T + KE
504  DO k=1,km
505  ad_from3 = is
506  DO i=ad_from3,ie
507  CALL pushrealarray(te(i, j, k))
508  te(i, j, k) = 0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2+u&
509 & (i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, k)&
510 & +u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*gridstruct%&
511 & cosa_s(i, j)) + cp_air*pt(i, j, k)*pkz(i, j, k)
512  END DO
513  CALL pushinteger(i - 1)
514  CALL pushinteger(ad_from3)
515  END DO
516  CALL pushinteger(k - 1)
517  CALL pushcontrol(3,3)
518  ELSE
519  CALL pushcontrol(3,4)
520  END IF
521  IF (.NOT.hydrostatic) THEN
522  DO k=1,km
523  ad_from4 = is
524  DO i=ad_from4,ie
525 ! ="specific volume"/grav
526  CALL pushrealarray(delz(i, j, k))
527  delz(i, j, k) = -(delz(i, j, k)/delp(i, j, k))
528  END DO
529  CALL pushinteger(i - 1)
530  CALL pushinteger(ad_from4)
531  END DO
532  CALL pushinteger(k - 1)
533  CALL pushcontrol(1,1)
534  ELSE
535  CALL pushcontrol(1,0)
536  END IF
537  ad_from5 = is
538 ! update ps
539  DO i=ad_from5,ie
540  ps(i, j) = pe1(i, km+1)
541  END DO
542  CALL pushinteger(i - 1)
543  CALL pushinteger(ad_from5)
544 !
545 ! Hybrid sigma-P coordinate:
546 !
547  DO k=2,km
548  ad_from6 = is
549  DO i=ad_from6,ie
550  CALL pushrealarray(pe2(i, k))
551  pe2(i, k) = ak(k) + bk(k)*pe(i, km+1, j)
552  END DO
553  CALL pushinteger(i - 1)
554  CALL pushinteger(ad_from6)
555  END DO
556  CALL pushinteger(k - 1)
557  DO k=1,km
558  ad_from7 = is
559  DO i=ad_from7,ie
560  CALL pushrealarray(dp2(i, k))
561  dp2(i, k) = pe2(i, k+1) - pe2(i, k)
562  END DO
563  CALL pushinteger(i - 1)
564  CALL pushinteger(ad_from7)
565  END DO
566  CALL pushinteger(k - 1)
567 !------------
568 ! update delp
569 !------------
570  DO k=1,km
571  ad_from8 = is
572  DO i=ad_from8,ie
573  CALL pushrealarray(delp(i, j, k))
574  delp(i, j, k) = dp2(i, k)
575  END DO
576  CALL pushinteger(i - 1)
577  CALL pushinteger(ad_from8)
578  END DO
579  CALL pushinteger(k - 1)
580 !------------------
581 ! Compute p**Kappa
582 !------------------
583  DO k=1,km+1
584  ad_from9 = is
585  DO i=ad_from9,ie
586  CALL pushrealarray(pk1(i, k))
587  pk1(i, k) = pk(i, j, k)
588  END DO
589  CALL pushinteger(i - 1)
590  CALL pushinteger(ad_from9)
591  END DO
592  CALL pushinteger(k - 1)
593  ad_from10 = is
594  DO i=ad_from10,ie
595  CALL pushrealarray(pn2(i, 1))
596  pn2(i, 1) = peln(i, 1, j)
597  CALL pushrealarray(pn2(i, km+1))
598  pn2(i, km+1) = peln(i, km+1, j)
599  CALL pushrealarray(pk2(i, 1))
600  pk2(i, 1) = pk1(i, 1)
601  CALL pushrealarray(pk2(i, km+1))
602  pk2(i, km+1) = pk1(i, km+1)
603  END DO
604  CALL pushinteger(i - 1)
605  CALL pushinteger(ad_from10)
606  DO k=2,km
607  ad_from11 = is
608  DO i=ad_from11,ie
609  CALL pushrealarray(pn2(i, k))
610  pn2(i, k) = log(pe2(i, k))
611  CALL pushrealarray(pk2(i, k))
612  pk2(i, k) = exp(akap*pn2(i, k))
613  END DO
614  CALL pushinteger(i - 1)
615  CALL pushinteger(ad_from11)
616  END DO
617  CALL pushinteger(k - 1)
618  IF (remap_t) THEN
619 !----------------------------------
620 ! Map t using logp
621 !----------------------------------
622  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
623  CALL map_scalar_fwd(km, peln(is:ie, 1:km+1, j), gz, km, &
624 & pn2, pt, is, ie, j, isd, ied, jsd, jed, 1, &
625 & abs_kord_tm, t_min)
626  CALL pushcontrol(3,0)
627  ELSE
628  CALL pushrealarray(pt, (ied-isd+1)*(jed-jsd+1)*km)
629  CALL map_scalar(km, peln(is:ie, 1:km+1, j), gz, km, pn2, pt&
630 & , is, ie, j, isd, ied, jsd, jed, 1, &
631 & abs_kord_tm, t_min)
632  CALL pushcontrol(3,1)
633  END IF
634  ELSE IF (remap_pt) THEN
635 !----------------------------------
636 ! Map pt using pe
637 !----------------------------------
638  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
639  CALL map1_ppm_fwd(km, pe1, gz, km, pe2, pt, is, ie, j, &
640 & isd, ied, jsd, jed, 1, abs_kord_tm)
641  CALL pushcontrol(3,2)
642  ELSE
643  CALL pushrealarray(pt, (ied-isd+1)*(jed-jsd+1)*km)
644  CALL map1_ppm(km, pe1, gz, km, pe2, pt, is, ie, j, isd, ied&
645 & , jsd, jed, 1, abs_kord_tm)
646  CALL pushcontrol(3,3)
647  END IF
648  ELSE IF (remap_te) THEN
649  ad_from12 = is
650 !----------------------------------
651 ! map Total Energy using GMAO cubic
652 !----------------------------------
653  DO i=ad_from12,ie
654  CALL pushrealarray(phis(i, km+1))
655  phis(i, km+1) = hs(i, j)
656  END DO
657  CALL pushinteger(i - 1)
658  CALL pushinteger(ad_from12)
659  ad_from14 = km
660  DO k=ad_from14,1,-1
661  ad_from13 = is
662  DO i=ad_from13,ie
663  CALL pushrealarray(phis(i, k))
664  phis(i, k) = phis(i, k+1) + cp_air*pt(i, j, k)*(pk1(i, k+1&
665 & )-pk1(i, k))
666  END DO
667  CALL pushinteger(i - 1)
668  CALL pushinteger(ad_from13)
669  END DO
670  CALL pushinteger(ad_from14)
671  DO k=1,km+1
672  ad_from15 = is
673  DO i=ad_from15,ie
674  CALL pushrealarray(phis(i, k))
675  phis(i, k) = phis(i, k)*pe1(i, k)
676  END DO
677  CALL pushinteger(i - 1)
678  CALL pushinteger(ad_from15)
679  END DO
680  CALL pushinteger(k - 1)
681  DO k=1,km
682  ad_from16 = is
683  DO i=ad_from16,ie
684  CALL pushrealarray(te(i, j, k))
685  te(i, j, k) = te(i, j, k) + (phis(i, k+1)-phis(i, k))/(pe1&
686 & (i, k+1)-pe1(i, k))
687  END DO
688  CALL pushinteger(i - 1)
689  CALL pushinteger(ad_from16)
690  END DO
691  CALL pushinteger(k - 1)
692 ! Map te using log P in GMAO cubic
693  CALL map1_cubic_fwd(km, pe1, km, pe2, te, is, ie, j, isd, ied&
694 & , jsd, jed, akap, t_var=1, conserv=.true.)
695  CALL pushcontrol(3,4)
696  ELSE
697  CALL pushcontrol(3,5)
698  END IF
699 !----------------
700 ! Map constituents
701 !----------------
702  IF (nq .GT. 5) THEN
703  IF (kord_tr(1) .EQ. kord_tr_pert(1)) THEN
704  CALL mapn_tracer_fwd(nq, km, pe1, pe2, q, dp2, kord_tr, j&
705 & , is, ie, isd, ied, jsd, jed, 0., fill)
706  CALL pushcontrol(2,0)
707  ELSE
708  CALL pushrealarray(q, (ied-isd+1)*(jed-jsd+1)*km*nq)
709  CALL mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, &
710 & is, ie, isd, ied, jsd, jed, 0., fill)
711  CALL pushcontrol(2,1)
712  END IF
713  ELSE IF (nq .GT. 0) THEN
714 ! Remap one tracer at a time
715  DO iq=1,nq
716  IF (kord_tr(iq) .EQ. kord_tr_pert(iq)) THEN
717  CALL map1_q2_fwd(km, pe1, q(isd:ied, jsd:jed, 1:km, iq)&
718 & , km, pe2, q2, dp2, is, ie, 0, kord_tr(iq), &
719 & j, isd, ied, jsd, jed, 0.)
720  CALL pushcontrol(1,0)
721  ELSE
722  CALL map1_q2(km, pe1, q(isd:ied, jsd:jed, 1:km, iq), km, &
723 & pe2, q2, dp2, is, ie, 0, kord_tr(iq), j, isd, &
724 & ied, jsd, jed, 0.)
725  CALL pushcontrol(1,1)
726  END IF
727  DO k=1,km
728  ad_from17 = is
729  DO i=ad_from17,ie
730  CALL pushrealarray(q(i, j, k, iq))
731  q(i, j, k, iq) = q2(i, k)
732  END DO
733  CALL pushinteger(i - 1)
734  CALL pushinteger(ad_from17)
735  END DO
736  CALL pushinteger(k - 1)
737  END DO
738  CALL pushinteger(iq - 1)
739  CALL pushcontrol(2,2)
740  ELSE
741  CALL pushcontrol(2,3)
742  END IF
743  IF (.NOT.hydrostatic) THEN
744 ! Remap vertical wind:
745  IF (kord_wz .EQ. kord_wz_pert) THEN
746  CALL map1_ppm_fwd(km, pe1, ws(is:ie, j), km, pe2, w, is, &
747 & ie, j, isd, ied, jsd, jed, -2, kord_wz)
748  CALL pushcontrol(1,0)
749  ELSE
750  CALL pushrealarray(w, (ied-isd+1)*(jed-jsd+1)*km)
751  CALL map1_ppm(km, pe1, ws(is:ie, j), km, pe2, w, is, ie, j, &
752 & isd, ied, jsd, jed, -2, kord_wz)
753  CALL pushcontrol(1,1)
754  END IF
755 ! Remap delz for hybrid sigma-p coordinate
756  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
757  CALL map1_ppm_fwd(km, pe1, gz, km, pe2, delz, is, ie, j, &
758 & isd, ied, jsd, jed, 1, abs_kord_tm)
759  CALL pushcontrol(1,1)
760  ELSE
761  CALL pushrealarray(delz, (ied-isd+1)*(jed-jsd+1)*km)
762  CALL map1_ppm(km, pe1, gz, km, pe2, delz, is, ie, j, isd, &
763 & ied, jsd, jed, 1, abs_kord_tm)
764  CALL pushcontrol(1,0)
765  END IF
766  DO k=1,km
767  ad_from18 = is
768  DO i=ad_from18,ie
769  CALL pushrealarray(delz(i, j, k))
770  delz(i, j, k) = -(delz(i, j, k)*dp2(i, k))
771  END DO
772  CALL pushinteger(i - 1)
773  CALL pushinteger(ad_from18)
774  END DO
775  CALL pushinteger(k - 1)
776  CALL pushcontrol(1,1)
777  ELSE
778  CALL pushcontrol(1,0)
779  END IF
780 !----------
781 ! Update pk
782 !----------
783  DO k=1,km+1
784  ad_from19 = is
785  DO i=ad_from19,ie
786  CALL pushrealarray(pk(i, j, k))
787  pk(i, j, k) = pk2(i, k)
788  END DO
789  CALL pushinteger(i - 1)
790  CALL pushinteger(ad_from19)
791  END DO
792  CALL pushinteger(k - 1)
793 !----------------
794  IF (do_omega) THEN
795  ad_from20 = is
796 ! Start do_omega
797 ! Copy omega field to pe3
798  DO i=ad_from20,ie
799  CALL pushrealarray(pe3(i, 1))
800  pe3(i, 1) = 0.
801  END DO
802  CALL pushinteger(i - 1)
803  CALL pushinteger(ad_from20)
804  DO k=2,km+1
805  ad_from21 = is
806  DO i=ad_from21,ie
807  CALL pushrealarray(pe3(i, k))
808  pe3(i, k) = omga(i, j, k-1)
809  END DO
810  CALL pushinteger(i - 1)
811  CALL pushinteger(ad_from21)
812  END DO
813  CALL pushinteger(k - 1)
814  CALL pushcontrol(1,1)
815  ELSE
816  CALL pushcontrol(1,0)
817  END IF
818  DO k=1,km+1
819  ad_from22 = is
820  DO i=ad_from22,ie
821  CALL pushrealarray(pe0(i, k))
822  pe0(i, k) = peln(i, k, j)
823  CALL pushrealarray(peln(i, k, j))
824  peln(i, k, j) = pn2(i, k)
825  END DO
826  CALL pushinteger(i - 1)
827  CALL pushinteger(ad_from22)
828  END DO
829  CALL pushinteger(k - 1)
830 !------------
831 ! Compute pkz
832 !------------
833  IF (hydrostatic) THEN
834  DO k=1,km
835  ad_from23 = is
836  DO i=ad_from23,ie
837  CALL pushrealarray(pkz(i, j, k))
838  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1&
839 & , j)-peln(i, k, j)))
840  END DO
841  CALL pushinteger(i - 1)
842  CALL pushinteger(ad_from23)
843  END DO
844  CALL pushinteger(k - 1)
845  CALL pushcontrol(2,0)
846  ELSE IF (remap_te) THEN
847 ! WMP: note that this is where TE remapping non-hydrostatic is invalid and cannot be run
848  GOTO 140
849  ELSE IF (remap_t) THEN
850 ! Note: pt at this stage is T_v or T_m
851  DO k=1,km
852  ad_from24 = is
853  DO i=ad_from24,ie
854  CALL pushrealarray(pkz(i, j, k))
855  pkz(i, j, k) = exp(akap*log(rrg*delp(i, j, k)/delz(i, j, k&
856 & )*pt(i, j, k)))
857  END DO
858  CALL pushinteger(i - 1)
859  CALL pushinteger(ad_from24)
860  END DO
861  CALL pushinteger(k - 1)
862  CALL pushcontrol(2,1)
863  ELSE
864 ! Using dry pressure for the definition of the virtual potential temperature
865 ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
866 ! Note: pt at this stage is Theta_v
867  DO k=1,km
868  ad_from25 = is
869  DO i=ad_from25,ie
870  CALL pushrealarray(pkz(i, j, k))
871  pkz(i, j, k) = exp(k1k*log(rrg*delp(i, j, k)/delz(i, j, k)&
872 & *pt(i, j, k)))
873  END DO
874  CALL pushinteger(i - 1)
875  CALL pushinteger(ad_from25)
876  END DO
877  CALL pushinteger(k - 1)
878  CALL pushcontrol(2,2)
879  END IF
880 ! end do_omega
881 ! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
882  IF (do_omega) THEN
883  DO k=1,km
884  ad_from26 = is
885  DO i=ad_from26,ie
886  CALL pushrealarray(dp2(i, k))
887  dp2(i, k) = 0.5*(peln(i, k, j)+peln(i, k+1, j))
888  END DO
889  CALL pushinteger(i - 1)
890  CALL pushinteger(ad_from26)
891  END DO
892  CALL pushinteger(k - 1)
893  ad_from27 = is
894  DO i=ad_from27,ie
895  k_next = 1
896  DO 130 n=1,km
897  kp = k_next
898  CALL pushinteger(k)
899  ad_count0 = 1
900  DO k=kp,km
901  IF (dp2(i, n) .LE. pe0(i, k+1) .AND. dp2(i, n) .GE. pe0(&
902 & i, k)) THEN
903  GOTO 120
904  ELSE
905  CALL pushinteger(k)
906  ad_count0 = ad_count0 + 1
907  END IF
908  END DO
909  CALL pushcontrol(1,0)
910  CALL pushinteger(ad_count0)
911  CALL pushcontrol(1,1)
912  GOTO 130
913  120 CALL pushcontrol(1,1)
914  CALL pushinteger(ad_count0)
915  CALL pushrealarray(omga(i, j, n))
916  omga(i, j, n) = pe3(i, k) + (pe3(i, k+1)-pe3(i, k))*(dp2(i&
917 & , n)-pe0(i, k))/(pe0(i, k+1)-pe0(i, k))
918  k_next = k
919  CALL pushcontrol(1,0)
920  130 CONTINUE
921  CALL pushinteger(n - 1)
922  END DO
923  CALL pushinteger(i - 1)
924  CALL pushinteger(ad_from27)
925  CALL pushcontrol(2,2)
926  ELSE
927  CALL pushcontrol(2,1)
928  END IF
929  ELSE
930  CALL pushcontrol(2,0)
931  END IF
932  ad_from28 = is
933  DO i=ad_from28,ie+1
934  CALL pushrealarray(pe0(i, 1))
935  pe0(i, 1) = pe(i, 1, j)
936  END DO
937  CALL pushinteger(i - 1)
938  CALL pushinteger(ad_from28)
939  CALL pushinteger(k)
940 !------
941 ! map u
942 !------
943  DO k=2,km+1
944  ad_from29 = is
945  DO i=ad_from29,ie
946  CALL pushrealarray(pe0(i, k))
947  pe0(i, k) = 0.5*(pe(i, k, j-1)+pe1(i, k))
948  END DO
949  CALL pushinteger(i - 1)
950  CALL pushinteger(ad_from29)
951  END DO
952  CALL pushinteger(k - 1)
953  DO k=1,km+1
954  CALL pushrealarray(bkh)
955  bkh = 0.5*bk(k)
956  ad_from30 = is
957  DO i=ad_from30,ie
958  CALL pushrealarray(pe3(i, k))
959  pe3(i, k) = ak(k) + bkh*(pe(i, km+1, j-1)+pe1(i, km+1))
960  END DO
961  CALL pushinteger(i - 1)
962  CALL pushinteger(ad_from30)
963  END DO
964  CALL pushinteger(k - 1)
965  IF (kord_mt .EQ. kord_mt_pert) THEN
966  CALL map1_ppm_fwd(km, pe0(is:ie, :), gz, km, pe3(is:ie, :), u&
967 & , is, ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
968  CALL pushcontrol(1,0)
969  ELSE
970  CALL pushrealarray(u, (ied-isd+1)*(jed-jsd+2)*km)
971  CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:ie, :), u, is, &
972 & ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
973  CALL pushcontrol(1,1)
974  END IF
975 ! (j < je+1)
976  IF (j .LT. je + 1) THEN
977  ad_from31 = is
978 !------
979 ! map v
980 !------
981  DO i=ad_from31,ie+1
982  CALL pushrealarray(pe3(i, 1))
983  pe3(i, 1) = ak(1)
984  END DO
985  CALL pushinteger(i - 1)
986  CALL pushinteger(ad_from31)
987  DO k=2,km+1
988  CALL pushrealarray(bkh)
989  bkh = 0.5*bk(k)
990  ad_from32 = is
991  DO i=ad_from32,ie+1
992  CALL pushrealarray(pe0(i, k))
993  pe0(i, k) = 0.5*(pe(i-1, k, j)+pe(i, k, j))
994  CALL pushrealarray(pe3(i, k))
995  pe3(i, k) = ak(k) + bkh*(pe(i-1, km+1, j)+pe(i, km+1, j))
996  END DO
997  CALL pushinteger(i - 1)
998  CALL pushinteger(ad_from32)
999  END DO
1000  CALL pushinteger(k - 1)
1001  IF (kord_mt .EQ. kord_mt_pert) THEN
1002  CALL map1_ppm_fwd(km, pe0, gz, km, pe3, v, is, iep1, j, isd&
1003 & , iedp1, jsd, jed, -1, kord_mt)
1004  CALL pushcontrol(2,1)
1005  ELSE
1006  CALL pushrealarray(v, (ied-isd+2)*(jed-jsd+1)*km)
1007  CALL map1_ppm(km, pe0, gz, km, pe3, v, is, iep1, j, isd, iedp1&
1008 & , jsd, jed, -1, kord_mt)
1009  CALL pushcontrol(2,2)
1010  END IF
1011  ELSE
1012  CALL pushcontrol(2,0)
1013  END IF
1014  DO k=1,km
1015  ad_from33 = is
1016  DO i=ad_from33,ie
1017  CALL pushrealarray(ua(i, j, k))
1018  ua(i, j, k) = pe2(i, k+1)
1019  END DO
1020  CALL pushinteger(i - 1)
1021  CALL pushinteger(ad_from33)
1022  END DO
1023  CALL pushinteger(k - 1)
1024  CALL pushinteger(j)
1025  ad_count1 = ad_count1 + 1
1026  END DO
1027  CALL pushcontrol(1,0)
1028  CALL pushinteger(ad_count1)
1029 !$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, &
1030 !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, &
1031 !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, &
1032 !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, &
1033 !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, &
1034 !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, &
1035 !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, &
1036 !$OMP fast_mp_consv,kord_tm) &
1037 !$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,tpe,tmp, dpln)
1038 !$OMP do
1039  DO k=2,km
1040  DO j=js,je
1041  DO i=is,ie
1042  CALL pushrealarray(pe(i, k, j))
1043  pe(i, k, j) = ua(i, j, k-1)
1044  END DO
1045  END DO
1046  END DO
1047  dtmp = 0.
1048 ! end last_step check
1049  IF (last_step .AND. (.NOT.do_adiabatic_init)) THEN
1050 ! end consv check
1051  IF (consv .GT. consv_min) THEN
1052 !$OMP do
1053  DO j=js,je
1054  IF (remap_t) THEN
1055 ! end non-hydro
1056  IF (hydrostatic) THEN
1057  DO i=is,ie
1058  CALL pushrealarray(gz(i))
1059  gz(i) = hs(i, j)
1060  DO k=1,km
1061  gz(i) = gz(i) + rg*pt(i, j, k)*(peln(i, k+1, j)-peln(i&
1062 & , k, j))
1063  END DO
1064  END DO
1065  DO i=is,ie
1066  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
1067 & )
1068  END DO
1069  DO k=1,km
1070  DO i=is,ie
1071  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*pt(i, j&
1072 & , k)+0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i&
1073 & , j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, &
1074 & k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1075 & gridstruct%cosa_s(i, j)))
1076  END DO
1077  END DO
1078  CALL pushcontrol(3,5)
1079  ELSE
1080  DO i=is,ie
1081  te_2d(i, j) = 0.
1082  CALL pushrealarray(phis(i, km+1))
1083  phis(i, km+1) = hs(i, j)
1084  END DO
1085  DO k=km,1,-1
1086  DO i=is,ie
1087  CALL pushrealarray(phis(i, k))
1088  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
1089  END DO
1090  END DO
1091  DO k=1,km
1092  DO i=is,ie
1093  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
1094 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
1095 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
1096 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
1097 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
1098 & i+1, j, k))*gridstruct%cosa_s(i, j))))
1099  END DO
1100  END DO
1101  CALL pushcontrol(3,4)
1102  END IF
1103  ELSE IF (remap_pt) THEN
1104 ! k-loop
1105  IF (hydrostatic) THEN
1106  DO i=is,ie
1107  CALL pushrealarray(gz(i))
1108  gz(i) = hs(i, j)
1109  DO k=1,km
1110  gz(i) = gz(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i&
1111 & , j, k))
1112  END DO
1113  END DO
1114  DO i=is,ie
1115  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
1116 & )
1117  END DO
1118  DO k=1,km
1119  DO i=is,ie
1120  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp_air*pt(i&
1121 & , j, k)*pkz(i, j, k)+0.25*gridstruct%rsin2(i, j)*(u(&
1122 & i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, &
1123 & k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j&
1124 & , k))*gridstruct%cosa_s(i, j)))
1125  END DO
1126  END DO
1127  CALL pushcontrol(3,3)
1128  ELSE
1129 !-----------------
1130 ! Non-hydrostatic:
1131 !-----------------
1132  DO i=is,ie
1133  CALL pushrealarray(phis(i, km+1))
1134  phis(i, km+1) = hs(i, j)
1135  DO k=km,1,-1
1136  CALL pushrealarray(phis(i, k))
1137  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
1138  END DO
1139  END DO
1140  DO i=is,ie
1141  te_2d(i, j) = 0.
1142  END DO
1143  DO k=1,km
1144  DO i=is,ie
1145  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
1146 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
1147 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
1148 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
1149 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
1150 & i+1, j, k))*gridstruct%cosa_s(i, j))))
1151  END DO
1152  END DO
1153  CALL pushcontrol(3,2)
1154  END IF
1155  ELSE IF (remap_te) THEN
1156  DO i=is,ie
1157  te_2d(i, j) = te(i, j, 1)*delp(i, j, 1)
1158  END DO
1159  DO k=2,km
1160  DO i=is,ie
1161  te_2d(i, j) = te_2d(i, j) + te(i, j, k)*delp(i, j, k)
1162  END DO
1163  END DO
1164  CALL pushcontrol(3,1)
1165  ELSE
1166  CALL pushcontrol(3,0)
1167  END IF
1168  DO i=is,ie
1169  te_2d(i, j) = te0_2d(i, j) - te_2d(i, j)
1170  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
1171  END DO
1172  DO k=2,km
1173  DO i=is,ie
1174  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
1175  END DO
1176  END DO
1177  IF (hydrostatic) THEN
1178  DO i=is,ie
1179  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
1180 & , j)
1181  END DO
1182  CALL pushcontrol(1,1)
1183  ELSE
1184  CALL pushcontrol(1,0)
1185  END IF
1186  END DO
1187 ! j-loop
1188 !$OMP single
1189  result1 = g_sum(domain, te_2d, is, ie, js, je, ng, gridstruct%&
1190 & area_64, 0, reproduce=.true.)
1191  tpe = consv*result1
1192 ! unit: W/m**2
1193 ! Note pdt is "phys" time step
1194  IF (hydrostatic) THEN
1195  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
1196 & area_64, 0, reproduce=.true.)
1197  dtmp = tpe/(cp*result1)
1198  CALL pushcontrol(3,0)
1199  ELSE
1200  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
1201 & area_64, 0, reproduce=.true.)
1202  dtmp = tpe/(cv_air*result1)
1203  CALL pushcontrol(3,1)
1204  END IF
1205  ELSE IF (consv .LT. -consv_min) THEN
1206 !$OMP end single
1207 !$OMP do
1208  DO j=js,je
1209  DO i=is,ie
1210  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
1211  END DO
1212  DO k=2,km
1213  DO i=is,ie
1214  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
1215  END DO
1216  END DO
1217  IF (hydrostatic) THEN
1218  DO i=is,ie
1219  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
1220 & , j)
1221  END DO
1222  CALL pushcontrol(1,1)
1223  ELSE
1224  CALL pushcontrol(1,0)
1225  END IF
1226  END DO
1227  CALL pushrealarray(e_flux)
1228  e_flux = consv
1229 !$OMP single
1230  IF (hydrostatic) THEN
1231  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
1232 & area_64, 0, reproduce=.true.)
1233  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cp*result1)
1234  CALL pushcontrol(3,2)
1235  ELSE
1236  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
1237 & area_64, 0, reproduce=.true.)
1238  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cv_air*result1)
1239  CALL pushcontrol(3,3)
1240  END IF
1241  ELSE
1242  CALL pushcontrol(3,4)
1243  END IF
1244  ELSE
1245  CALL pushcontrol(3,5)
1246  END IF
1247 !$OMP end single
1248 ! do_sat_adj
1249 ! Note: pt at this stage is T_v
1250  IF (remap_t .AND. (.NOT.do_adiabatic_init) .AND. do_sat_adj) THEN
1251 !$OMP do
1252  DO k=kmp,km
1253  IF (.NOT.hydrostatic) THEN
1254  DO j=js,je
1255  DO i=is,ie
1256  CALL pushrealarray(pkz(i, j, k))
1257  pkz(i, j, k) = exp(akap*log(rrg*delp(i, j, k)/delz(i, j, k&
1258 & )*pt(i, j, k)))
1259  END DO
1260  END DO
1261  CALL pushcontrol(1,1)
1262  ELSE
1263  CALL pushcontrol(1,0)
1264  END IF
1265  END DO
1266 ! OpenMP k-loop
1267  IF (fast_mp_consv) THEN
1268 !$OMP do
1269  DO j=js,je
1270  DO i=is,ie
1271  DO k=kmp,km
1272  te0_2d(i, j) = te0_2d(i, j) + te(i, j, k)
1273  END DO
1274  END DO
1275  END DO
1276  CALL pushcontrol(2,0)
1277  ELSE
1278  CALL pushcontrol(2,1)
1279  END IF
1280  ELSE
1281  CALL pushcontrol(2,2)
1282  END IF
1283 ! last_step
1284  IF (last_step) THEN
1285 ! Output temperature if last_step
1286  IF (remap_t) THEN
1287 !$OMP do
1288  DO k=1,km
1289  DO j=js,je
1290  IF (.NOT.adiabatic) THEN
1291  DO i=is,ie
1292  CALL pushrealarray(pt(i, j, k))
1293  pt(i, j, k) = (pt(i, j, k)+dtmp*pkz(i, j, k))/(1.+r_vir*&
1294 & q(i, j, k, sphum))
1295  END DO
1296  CALL pushcontrol(1,1)
1297  ELSE
1298  CALL pushcontrol(1,0)
1299  END IF
1300  END DO
1301  END DO
1302  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1303  CALL pushrealarray(bkh)
1304  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1305  CALL pushinteger(liq_wat)
1306  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1307  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1308  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1309  CALL pushrealarray(rrg)
1310  CALL pushinteger(ice_wat)
1311  CALL pushrealarray(result1)
1312  CALL pushinteger(rainwat)
1313  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1314  CALL pushinteger(abs_kord_tm_pert)
1315  CALL pushinteger(cld_amt)
1316  CALL pushrealarray(dtmp)
1317  CALL pushinteger(snowwat)
1318  CALL pushrealarray(k1k)
1319  CALL pushrealarray(tpe)
1320  CALL pushrealarray(rg)
1321  CALL pushinteger(iep1)
1322  CALL pushrealarray(dp2, (ie-is+1)*km)
1323  CALL pushinteger(kmp)
1324  CALL pushrealarray(gz, ie - is + 1)
1325  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1326  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1327  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1328  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1329  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1330  CALL pushinteger(graupel)
1331  CALL pushcontrol(3,0)
1332  ELSE IF (remap_pt) THEN
1333 ! j-loop
1334 ! k-loop
1335 !$OMP do
1336  DO k=1,km
1337  DO j=js,je
1338  DO i=is,ie
1339  CALL pushrealarray(pt(i, j, k))
1340  pt(i, j, k) = (pt(i, j, k)+dtmp)*pkz(i, j, k)/(1.+r_vir*q(&
1341 & i, j, k, sphum))
1342  END DO
1343  END DO
1344  END DO
1345  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1346  CALL pushrealarray(bkh)
1347  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1348  CALL pushinteger(liq_wat)
1349  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1350  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1351  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1352  CALL pushrealarray(rrg)
1353  CALL pushinteger(ice_wat)
1354  CALL pushrealarray(result1)
1355  CALL pushinteger(rainwat)
1356  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1357  CALL pushinteger(abs_kord_tm_pert)
1358  CALL pushinteger(cld_amt)
1359  CALL pushrealarray(dtmp)
1360  CALL pushinteger(snowwat)
1361  CALL pushrealarray(k1k)
1362  CALL pushrealarray(tpe)
1363  CALL pushrealarray(rg)
1364  CALL pushinteger(iep1)
1365  CALL pushrealarray(dp2, (ie-is+1)*km)
1366  CALL pushinteger(kmp)
1367  CALL pushrealarray(gz, ie - is + 1)
1368  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1369  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1370  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1371  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1372  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1373  CALL pushinteger(graupel)
1374  CALL pushcontrol(3,1)
1375  ELSE IF (remap_te) THEN
1376 !$OMP do
1377  DO j=js,je
1378  DO i=is,ie
1379  CALL pushrealarray(gz(i))
1380  gz(i) = hs(i, j)
1381  END DO
1382  DO k=km,1,-1
1383  DO i=is,ie
1384  CALL pushrealarray(tpe)
1385  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
1386 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
1387 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1388 & gridstruct%cosa_s(i, j))
1389  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
1390  CALL pushrealarray(tmp)
1391  tmp = tpe/((cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+r_vir*q&
1392 & (i, j, k, sphum)))
1393  CALL pushrealarray(pt(i, j, k))
1394  pt(i, j, k) = tmp + dtmp*pkz(i, j, k)/(1.+r_vir*q(i, j, k&
1395 & , sphum))
1396  CALL pushrealarray(gz(i))
1397  gz(i) = gz(i) + dlnp*tmp*(1.+r_vir*q(i, j, k, sphum))
1398  END DO
1399  END DO
1400  END DO
1401  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1402  CALL pushrealarray(bkh)
1403  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1404  CALL pushinteger(liq_wat)
1405  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1406  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1407  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1408  CALL pushrealarray(rrg)
1409  CALL pushinteger(ice_wat)
1410  CALL pushrealarray(result1)
1411  CALL pushinteger(rainwat)
1412  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1413  CALL pushinteger(abs_kord_tm_pert)
1414  CALL pushinteger(cld_amt)
1415  CALL pushrealarray(tmp)
1416  CALL pushrealarray(dtmp)
1417  CALL pushinteger(snowwat)
1418  CALL pushrealarray(k1k)
1419  CALL pushrealarray(tpe)
1420  CALL pushrealarray(rg)
1421  CALL pushinteger(iep1)
1422  CALL pushrealarray(dp2, (ie-is+1)*km)
1423  CALL pushinteger(kmp)
1424  CALL pushrealarray(gz, ie - is + 1)
1425  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1426  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1427  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1428  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1429  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1430  CALL pushinteger(graupel)
1431  CALL pushcontrol(3,2)
1432  ELSE
1433  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1434  CALL pushrealarray(bkh)
1435  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1436  CALL pushinteger(liq_wat)
1437  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1438  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1439  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1440  CALL pushrealarray(rrg)
1441  CALL pushinteger(ice_wat)
1442  CALL pushrealarray(result1)
1443  CALL pushinteger(rainwat)
1444  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1445  CALL pushinteger(abs_kord_tm_pert)
1446  CALL pushinteger(cld_amt)
1447  CALL pushinteger(snowwat)
1448  CALL pushrealarray(k1k)
1449  CALL pushrealarray(tpe)
1450  CALL pushrealarray(rg)
1451  CALL pushinteger(iep1)
1452  CALL pushrealarray(dp2, (ie-is+1)*km)
1453  CALL pushinteger(kmp)
1454  CALL pushrealarray(gz, ie - is + 1)
1455  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1456  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1457  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1458  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1459  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1460  CALL pushinteger(graupel)
1461  CALL pushcontrol(3,3)
1462  END IF
1463  ELSE IF (remap_t) THEN
1464 ! not last_step
1465 !$OMP do
1466  DO k=1,km
1467  DO j=js,je
1468  DO i=is,ie
1469  CALL pushrealarray(pt(i, j, k))
1470  pt(i, j, k) = pt(i, j, k)/pkz(i, j, k)
1471  END DO
1472  END DO
1473  END DO
1474  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1475  CALL pushrealarray(bkh)
1476  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1477  CALL pushinteger(liq_wat)
1478  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1479  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1480  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1481  CALL pushrealarray(rrg)
1482  CALL pushinteger(ice_wat)
1483  CALL pushrealarray(result1)
1484  CALL pushinteger(rainwat)
1485  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1486  CALL pushinteger(abs_kord_tm_pert)
1487  CALL pushinteger(cld_amt)
1488  CALL pushinteger(snowwat)
1489  CALL pushrealarray(k1k)
1490  CALL pushrealarray(tpe)
1491  CALL pushrealarray(rg)
1492  CALL pushinteger(iep1)
1493  CALL pushrealarray(dp2, (ie-is+1)*km)
1494  CALL pushinteger(kmp)
1495  CALL pushrealarray(gz, ie - is + 1)
1496  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1497  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1498  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1499  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1500  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1501  CALL pushinteger(graupel)
1502  CALL pushcontrol(3,4)
1503  ELSE IF (remap_te) THEN
1504 !$OMP do
1505  DO j=js,je
1506  DO i=is,ie
1507  CALL pushrealarray(gz(i))
1508  gz(i) = hs(i, j)
1509  END DO
1510  DO k=km,1,-1
1511  DO i=is,ie
1512  CALL pushrealarray(tpe)
1513  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u(i&
1514 & , j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(&
1515 & u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1516 & gridstruct%cosa_s(i, j))
1517  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
1518  tmp = tpe/(cp-pe(i, k, j)*dlnp/delp(i, j, k))
1519  CALL pushrealarray(pt(i, j, k))
1520  pt(i, j, k) = tmp/pkz(i, j, k) + dtmp
1521  CALL pushrealarray(gz(i))
1522  gz(i) = gz(i) + dlnp*tmp
1523  END DO
1524  END DO
1525  END DO
1526  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1527  CALL pushrealarray(bkh)
1528  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1529  CALL pushinteger(liq_wat)
1530  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1531  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1532  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1533  CALL pushrealarray(rrg)
1534  CALL pushinteger(ice_wat)
1535  CALL pushrealarray(result1)
1536  CALL pushinteger(rainwat)
1537  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1538  CALL pushinteger(abs_kord_tm_pert)
1539  CALL pushinteger(cld_amt)
1540  CALL pushinteger(snowwat)
1541  CALL pushrealarray(k1k)
1542  CALL pushrealarray(tpe)
1543  CALL pushrealarray(rg)
1544  CALL pushinteger(iep1)
1545  CALL pushrealarray(dp2, (ie-is+1)*km)
1546  CALL pushinteger(kmp)
1547  CALL pushrealarray(gz, ie - is + 1)
1548  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1549  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1550  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1551  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1552  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1553  CALL pushinteger(graupel)
1554  CALL pushcontrol(3,5)
1555  ELSE
1556  CALL pushrealarray(pk2, (ie-is+1)*(km+1))
1557  CALL pushrealarray(bkh)
1558  CALL pushrealarray(pk1, (ie-is+1)*(km+1))
1559  CALL pushinteger(liq_wat)
1560  CALL pushrealarray(zsum1, (ie-is+1)*(je-js+1))
1561  CALL pushrealarray(pn2, (ie-is+1)*(km+1))
1562  CALL pushrealarray(zsum0, (ie-is+1)*(je-js+1))
1563  CALL pushrealarray(rrg)
1564  CALL pushinteger(ice_wat)
1565  CALL pushrealarray(result1)
1566  CALL pushinteger(rainwat)
1567  CALL pushrealarray(te_2d, (ie-is+1)*(je-js+1))
1568  CALL pushinteger(abs_kord_tm_pert)
1569  CALL pushinteger(cld_amt)
1570  CALL pushinteger(snowwat)
1571  CALL pushrealarray(k1k)
1572  CALL pushrealarray(tpe)
1573  CALL pushrealarray(rg)
1574  CALL pushinteger(iep1)
1575  CALL pushrealarray(dp2, (ie-is+1)*km)
1576  CALL pushinteger(kmp)
1577  CALL pushrealarray(gz, ie - is + 1)
1578  CALL pushrealarray(pe3, (ie-is+2)*(km+1))
1579  CALL pushrealarray(pe2, (ie-is+1)*(km+1))
1580  CALL pushrealarray(pe1, (ie-is+1)*(km+1))
1581  CALL pushrealarray(pe0, (ie-is+2)*(km+1))
1582  CALL pushrealarray(phis, (ie-is+1)*(km+1))
1583  CALL pushinteger(graupel)
1584  CALL pushcontrol(3,6)
1585  END IF
1586  GOTO 150
1587  140 CALL pushcontrol(1,1)
1588  CALL pushinteger(ad_count1)
1589  stop
1590  150 CONTINUE
1591  END SUBROUTINE lagrangian_to_eulerian_fwd
1592 ! Differentiation of lagrangian_to_eulerian in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4_
1593 !fb a2b_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv
1594 !_pe dyn_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update d
1595 !yn_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics
1596 !_mod.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_util
1597 !s_mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez f
1598 !v_mapz_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_m
1599 !od.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.
1600 !ppm_limiters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.ma
1601 !p1_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_
1602 !mod.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_d
1603 !z_d nh_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solve
1604 !r nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile
1605 ! nh_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest s
1606 !w_core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_co
1607 !re_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2
1608 !d_fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner
1609 !fv_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1610 ! gradient of useful results: ws peln q u v w delp ua delz
1611 ! omga te0_2d pkz pe pk ps pt te
1612 ! with respect to varying inputs: ws peln q u v w delp ua delz
1613 ! omga te0_2d pkz pe pk ps pt te
1614  SUBROUTINE lagrangian_to_eulerian_bwd(last_step, consv, ps, ps_ad, pe&
1615 & , pe_ad, delp, delp_ad, pkz, pkz_ad, pk, pk_ad, mdt, pdt, km, is, ie&
1616 & , js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, u_ad, v, &
1617 & v_ad, w, w_ad, delz, delz_ad, pt, pt_ad, q, q_ad, hs, r_vir, cp, &
1618 & akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, peln_ad, &
1619 & te0_2d, te0_2d_ad, ng, ua, ua_ad, va, omga, omga_ad, te, te_ad, ws, &
1620 & ws_ad, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, &
1621 & flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, &
1622 & do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, &
1623 & kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
1624  IMPLICIT NONE
1625 !$OMP end parallel
1626  LOGICAL, INTENT(IN) :: last_step
1627  REAL, INTENT(IN) :: mdt
1628  REAL, INTENT(IN) :: pdt
1629  INTEGER, INTENT(IN) :: km
1630  INTEGER, INTENT(IN) :: nq
1631  INTEGER, INTENT(IN) :: nwat
1632  INTEGER, INTENT(IN) :: sphum
1633  INTEGER, INTENT(IN) :: ng
1634  INTEGER, INTENT(IN) :: is, ie, isd, ied
1635  INTEGER, INTENT(IN) :: js, je, jsd, jed
1636  INTEGER, INTENT(IN) :: kord_mt
1637  INTEGER, INTENT(IN) :: kord_wz
1638  INTEGER, INTENT(IN) :: kord_tr(nq)
1639  INTEGER, INTENT(IN) :: kord_tm
1640  INTEGER, INTENT(IN) :: kord_mt_pert
1641  INTEGER, INTENT(IN) :: kord_wz_pert
1642  INTEGER, INTENT(IN) :: kord_tr_pert(nq)
1643  INTEGER, INTENT(IN) :: kord_tm_pert
1644  REAL, INTENT(IN) :: consv
1645  REAL, INTENT(IN) :: r_vir
1646  REAL, INTENT(IN) :: cp
1647  REAL, INTENT(IN) :: akap
1648  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
1649  REAL, INTENT(INOUT) :: te0_2d(is:ie, js:je)
1650  REAL, INTENT(INOUT) :: te0_2d_ad(is:ie, js:je)
1651  REAL, INTENT(IN) :: ws(is:ie, js:je)
1652  REAL :: ws_ad(is:ie, js:je)
1653  LOGICAL, INTENT(IN) :: do_sat_adj
1654  LOGICAL, INTENT(IN) :: fill
1655  LOGICAL, INTENT(IN) :: reproduce_sum
1656  LOGICAL, INTENT(IN) :: do_omega, adiabatic, do_adiabatic_init
1657  REAL, INTENT(IN) :: ptop
1658  REAL, INTENT(IN) :: ak(km+1)
1659  REAL, INTENT(IN) :: bk(km+1)
1660  REAL, INTENT(IN) :: pfull(km)
1661  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1662  TYPE(fv_flags_type), INTENT(INOUT) :: flagstruct
1663  TYPE(domain2d), INTENT(INOUT) :: domain
1664  REAL, INTENT(INOUT) :: pk(is:ie, js:je, km+1)
1665  REAL, INTENT(INOUT) :: pk_ad(is:ie, js:je, km+1)
1666  REAL, INTENT(INOUT) :: q(isd:ied, jsd:jed, km, nq)
1667  REAL, INTENT(INOUT) :: q_ad(isd:ied, jsd:jed, km, nq)
1668  REAL, INTENT(INOUT) :: delp(isd:ied, jsd:jed, km)
1669  REAL, INTENT(INOUT) :: delp_ad(isd:ied, jsd:jed, km)
1670  REAL, INTENT(INOUT) :: pe(is-1:ie+1, km+1, js-1:je+1)
1671  REAL, INTENT(INOUT) :: pe_ad(is-1:ie+1, km+1, js-1:je+1)
1672  REAL, INTENT(INOUT) :: ps(isd:ied, jsd:jed)
1673  REAL, INTENT(INOUT) :: ps_ad(isd:ied, jsd:jed)
1674  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
1675  REAL, INTENT(INOUT) :: u_ad(isd:ied, jsd:jed+1, km)
1676  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
1677  REAL, INTENT(INOUT) :: v_ad(isd:ied+1, jsd:jed, km)
1678  REAL, INTENT(INOUT) :: w(isd:ied, jsd:jed, km)
1679  REAL, INTENT(INOUT) :: w_ad(isd:ied, jsd:jed, km)
1680  REAL, INTENT(INOUT) :: pt(isd:ied, jsd:jed, km)
1681  REAL, INTENT(INOUT) :: pt_ad(isd:ied, jsd:jed, km)
1682  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz
1683  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz_ad
1684  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: q_con, cappa
1685  LOGICAL, INTENT(IN) :: hydrostatic
1686  LOGICAL, INTENT(IN) :: hybrid_z
1687  LOGICAL, INTENT(IN) :: out_dt
1688  REAL, INTENT(INOUT) :: ua(isd:ied, jsd:jed, km)
1689  REAL, INTENT(INOUT) :: ua_ad(isd:ied, jsd:jed, km)
1690  REAL, INTENT(INOUT) :: va(isd:ied, jsd:jed, km)
1691  REAL, INTENT(INOUT) :: omga(isd:ied, jsd:jed, km)
1692  REAL, INTENT(INOUT) :: omga_ad(isd:ied, jsd:jed, km)
1693  REAL, INTENT(INOUT) :: peln(is:ie, km+1, js:je)
1694  REAL, INTENT(INOUT) :: peln_ad(is:ie, km+1, js:je)
1695  REAL, INTENT(INOUT) :: dtdt(is:ie, js:je, km)
1696  REAL :: pkz(is:ie, js:je, km)
1697  REAL :: pkz_ad(is:ie, js:je, km)
1698  REAL :: te(isd:ied, jsd:jed, km)
1699  REAL :: te_ad(isd:ied, jsd:jed, km)
1700  REAL, OPTIONAL, INTENT(INOUT) :: mfx(is:ie+1, js:je, km)
1701  REAL, OPTIONAL, INTENT(INOUT) :: mfy(is:ie, js:je+1, km)
1702  INTEGER, INTENT(IN) :: remap_option
1703  REAL, DIMENSION(is:ie, js:je) :: te_2d, zsum0, zsum1, dpln
1704  REAL, DIMENSION(is:ie, js:je) :: te_2d_ad, zsum0_ad, zsum1_ad
1705  REAL, DIMENSION(is:ie, km) :: q2, dp2
1706  REAL, DIMENSION(is:ie, km) :: q2_ad, dp2_ad
1707  REAL, DIMENSION(is:ie, km+1) :: pe1, pe2, pk1, pk2, pn2, phis
1708  REAL, DIMENSION(is:ie, km+1) :: pe1_ad, pe2_ad, pk1_ad, pk2_ad, &
1709 & pn2_ad, phis_ad
1710  REAL, DIMENSION(is:ie+1, km+1) :: pe0, pe3
1711  REAL, DIMENSION(is:ie+1, km+1) :: pe0_ad, pe3_ad
1712  REAL, DIMENSION(is:ie) :: gz, cvm, qv
1713  REAL, DIMENSION(is:ie) :: gz_ad
1714  REAL :: rcp, rg, tmp, tpe, rrg, bkh, dtmp, k1k, dlnp
1715  REAL :: tmp_ad, tpe_ad, dtmp_ad, dlnp_ad
1716  LOGICAL :: fast_mp_consv
1717  INTEGER :: i, j, k
1718  INTEGER :: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel&
1719 & , iq, n, kmp, kp, k_next
1720  LOGICAL :: remap_t, remap_pt, remap_te
1721  INTEGER :: abs_kord_tm, abs_kord_tm_pert
1722  INTEGER :: iep1, jep1, iedp1, jedp1
1723  INTRINSIC abs
1724  INTRINSIC log
1725  INTRINSIC exp
1726  INTRINSIC PRESENT
1727  REAL :: abs0
1728  INTEGER :: arg1
1729  REAL :: result1
1730  REAL :: result1_ad
1731  LOGICAL :: arg10
1732  REAL :: temp
1733  REAL :: temp0
1734  REAL :: temp1
1735  REAL :: temp_ad
1736  REAL :: temp_ad0
1737  REAL :: temp2
1738  REAL :: temp3
1739  REAL :: temp4
1740  REAL :: temp5
1741  REAL :: temp_ad1
1742  REAL :: temp_ad2
1743  REAL :: temp_ad3
1744  REAL :: temp_ad4
1745  REAL :: temp_ad5
1746  REAL :: temp_ad6
1747  REAL :: temp_ad7
1748  REAL :: temp6
1749  REAL :: temp_ad8
1750  REAL :: temp_ad9
1751  REAL :: temp7
1752  REAL :: temp_ad10
1753  REAL :: temp_ad11
1754  REAL :: temp8
1755  REAL :: temp9
1756  REAL :: temp10
1757  REAL :: temp_ad12
1758  REAL :: temp11
1759  REAL :: temp12
1760  REAL :: temp13
1761  REAL :: temp_ad13
1762  REAL :: temp14
1763  REAL :: temp15
1764  REAL :: temp16
1765  REAL :: temp_ad14
1766  REAL :: temp_ad15
1767  REAL :: temp_ad16
1768  REAL :: temp17
1769  REAL :: temp18
1770  REAL :: temp19
1771  REAL :: temp_ad17
1772  REAL :: temp_ad18
1773  REAL :: temp_ad19
1774  REAL :: temp20
1775  REAL :: temp21
1776  REAL :: temp22
1777  REAL :: temp23
1778  REAL :: temp24
1779  REAL :: temp_ad20
1780  REAL :: temp_ad21
1781  REAL :: temp_ad22
1782  REAL :: temp_ad23
1783  REAL :: temp_ad24
1784  REAL :: temp_ad25
1785  REAL :: temp25
1786  REAL :: temp26
1787  REAL :: temp27
1788  REAL :: temp_ad26
1789  REAL :: temp_ad27
1790  REAL :: temp_ad28
1791  REAL :: temp28
1792  REAL :: temp29
1793  REAL :: temp30
1794  REAL :: temp31
1795  REAL :: temp32
1796  REAL :: temp_ad29
1797  REAL :: temp_ad30
1798  REAL :: temp_ad31
1799  REAL :: temp_ad32
1800  REAL :: temp_ad33
1801  REAL :: temp_ad34
1802  REAL :: temp_ad35
1803  REAL :: temp33
1804  REAL :: temp34
1805  REAL :: temp35
1806  REAL :: temp_ad36
1807  REAL :: temp36
1808  REAL :: temp_ad37
1809  REAL :: temp37
1810  REAL :: temp38
1811  REAL :: temp39
1812  REAL :: temp_ad38
1813  REAL :: temp40
1814  REAL :: temp41
1815  REAL :: temp42
1816  REAL :: temp43
1817  REAL :: temp44
1818  REAL :: temp45
1819  REAL :: temp_ad39
1820  REAL :: temp_ad40
1821  REAL :: temp_ad41
1822  REAL :: temp_ad42
1823  REAL :: temp_ad43
1824  REAL :: temp_ad44
1825  REAL :: temp_ad45
1826  REAL :: temp_ad46
1827  REAL :: temp_ad47
1828  REAL :: temp46
1829  REAL :: temp47
1830  REAL :: temp48
1831  REAL :: temp_ad48
1832  REAL :: temp_ad49
1833  REAL :: temp_ad50
1834  REAL :: temp_ad51
1835  REAL :: temp_ad52
1836  REAL :: temp_ad53
1837  REAL :: temp_ad54
1838  INTEGER :: ad_count
1839  INTEGER :: i0
1840  INTEGER :: branch
1841  INTEGER :: ad_from
1842  INTEGER :: ad_to
1843  INTEGER :: ad_to0
1844  INTEGER :: ad_from0
1845  INTEGER :: ad_to1
1846  INTEGER :: ad_from1
1847  INTEGER :: ad_to2
1848  INTEGER :: ad_to3
1849  INTEGER :: ad_from2
1850  INTEGER :: ad_to4
1851  INTEGER :: ad_to5
1852  INTEGER :: ad_from3
1853  INTEGER :: ad_to6
1854  INTEGER :: ad_to7
1855  INTEGER :: ad_from4
1856  INTEGER :: ad_to8
1857  INTEGER :: ad_to9
1858  INTEGER :: ad_from5
1859  INTEGER :: ad_to10
1860  INTEGER :: ad_from6
1861  INTEGER :: ad_to11
1862  INTEGER :: ad_to12
1863  INTEGER :: ad_from7
1864  INTEGER :: ad_to13
1865  INTEGER :: ad_to14
1866  INTEGER :: ad_from8
1867  INTEGER :: ad_to15
1868  INTEGER :: ad_to16
1869  INTEGER :: ad_from9
1870  INTEGER :: ad_to17
1871  INTEGER :: ad_to18
1872  INTEGER :: ad_from10
1873  INTEGER :: ad_to19
1874  INTEGER :: ad_from11
1875  INTEGER :: ad_to20
1876  INTEGER :: ad_to21
1877  INTEGER :: ad_from12
1878  INTEGER :: ad_to22
1879  INTEGER :: ad_from13
1880  INTEGER :: ad_to23
1881  INTEGER :: ad_from14
1882  INTEGER :: ad_from15
1883  INTEGER :: ad_to24
1884  INTEGER :: ad_to25
1885  INTEGER :: ad_from16
1886  INTEGER :: ad_to26
1887  INTEGER :: ad_to27
1888  INTEGER :: ad_from17
1889  INTEGER :: ad_to28
1890  INTEGER :: ad_to29
1891  INTEGER :: ad_to30
1892  INTEGER :: ad_from18
1893  INTEGER :: ad_to31
1894  INTEGER :: ad_to32
1895  INTEGER :: ad_from19
1896  INTEGER :: ad_to33
1897  INTEGER :: ad_to34
1898  INTEGER :: ad_from20
1899  INTEGER :: ad_to35
1900  INTEGER :: ad_from21
1901  INTEGER :: ad_to36
1902  INTEGER :: ad_to37
1903  INTEGER :: ad_from22
1904  INTEGER :: ad_to38
1905  INTEGER :: ad_to39
1906  INTEGER :: ad_from23
1907  INTEGER :: ad_to40
1908  INTEGER :: ad_to41
1909  INTEGER :: ad_from24
1910  INTEGER :: ad_to42
1911  INTEGER :: ad_to43
1912  INTEGER :: ad_from25
1913  INTEGER :: ad_to44
1914  INTEGER :: ad_to45
1915  INTEGER :: ad_from26
1916  INTEGER :: ad_to46
1917  INTEGER :: ad_to47
1918  INTEGER :: ad_count0
1919  INTEGER :: i1
1920  INTEGER :: ad_to48
1921  INTEGER :: ad_from27
1922  INTEGER :: ad_to49
1923  INTEGER :: ad_from28
1924  INTEGER :: ad_to50
1925  INTEGER :: ad_from29
1926  INTEGER :: ad_to51
1927  INTEGER :: ad_to52
1928  INTEGER :: ad_from30
1929  INTEGER :: ad_to53
1930  INTEGER :: ad_to54
1931  INTEGER :: ad_from31
1932  INTEGER :: ad_to55
1933  INTEGER :: ad_from32
1934  INTEGER :: ad_to56
1935  INTEGER :: ad_to57
1936  INTEGER :: ad_from33
1937  INTEGER :: ad_to58
1938  INTEGER :: ad_to59
1939  INTEGER :: ad_count1
1940  INTEGER :: i2
1941 
1942  te_2d = 0.0
1943  zsum0 = 0.0
1944  zsum1 = 0.0
1945  dpln = 0.0
1946  q2 = 0.0
1947  dp2 = 0.0
1948  pe1 = 0.0
1949  pe2 = 0.0
1950  pk1 = 0.0
1951  pk2 = 0.0
1952  pn2 = 0.0
1953  phis = 0.0
1954  pe0 = 0.0
1955  pe3 = 0.0
1956  gz = 0.0
1957  cvm = 0.0
1958  qv = 0.0
1959  rcp = 0.0
1960  rg = 0.0
1961  tmp = 0.0
1962  tpe = 0.0
1963  rrg = 0.0
1964  bkh = 0.0
1965  dtmp = 0.0
1966  k1k = 0.0
1967  dlnp = 0.0
1968  result1 = 0.0
1969  abs0 = 0.0
1970  nt = 0
1971  liq_wat = 0
1972  ice_wat = 0
1973  rainwat = 0
1974  snowwat = 0
1975  cld_amt = 0
1976  graupel = 0
1977  iq = 0
1978  n = 0
1979  kmp = 0
1980  kp = 0
1981  k_next = 0
1982  abs_kord_tm = 0
1983  abs_kord_tm_pert = 0
1984  iep1 = 0
1985  jep1 = 0
1986  iedp1 = 0
1987  jedp1 = 0
1988  arg1 = 0
1989  ad_count = 0
1990  ad_to = 0
1991  ad_to0 = 0
1992  ad_to1 = 0
1993  ad_to2 = 0
1994  ad_to3 = 0
1995  ad_to4 = 0
1996  ad_to5 = 0
1997  ad_to6 = 0
1998  ad_to7 = 0
1999  ad_to8 = 0
2000  ad_to9 = 0
2001  ad_to10 = 0
2002  ad_to11 = 0
2003  ad_to12 = 0
2004  ad_to13 = 0
2005  ad_to14 = 0
2006  ad_to15 = 0
2007  ad_to16 = 0
2008  ad_to17 = 0
2009  ad_to18 = 0
2010  ad_to19 = 0
2011  ad_to20 = 0
2012  ad_to21 = 0
2013  ad_to22 = 0
2014  ad_to23 = 0
2015  ad_to24 = 0
2016  ad_to25 = 0
2017  ad_to26 = 0
2018  ad_to27 = 0
2019  ad_to28 = 0
2020  ad_to29 = 0
2021  ad_to30 = 0
2022  ad_to31 = 0
2023  ad_to32 = 0
2024  ad_to33 = 0
2025  ad_from = 0
2026  ad_from0 = 0
2027  ad_from1 = 0
2028  ad_from2 = 0
2029  ad_from3 = 0
2030  ad_from4 = 0
2031  ad_from5 = 0
2032  ad_from6 = 0
2033  ad_from7 = 0
2034  ad_from8 = 0
2035  ad_from9 = 0
2036  ad_from10 = 0
2037  ad_from11 = 0
2038  ad_from12 = 0
2039  ad_from13 = 0
2040  ad_from14 = 0
2041  ad_from15 = 0
2042  ad_from16 = 0
2043  ad_from17 = 0
2044  ad_from18 = 0
2045  ad_from19 = 0
2046  ad_from20 = 0
2047  ad_from21 = 0
2048  ad_from22 = 0
2049  ad_from23 = 0
2050  ad_from24 = 0
2051  ad_from25 = 0
2052  ad_from26 = 0
2053  ad_count0 = 0
2054  ad_from27 = 0
2055  ad_from28 = 0
2056  ad_from29 = 0
2057  ad_from30 = 0
2058  ad_from31 = 0
2059  ad_from32 = 0
2060  ad_from33 = 0
2061  ad_count1 = 0
2062  branch = 0
2063 
2064  iep1 = ie + 1
2065  iedp1 = ied + 1
2066  jedp1 = jed + 1
2067  CALL popcontrol(3,branch)
2068  IF (branch .LT. 3) THEN
2069  IF (branch .EQ. 0) THEN
2070  CALL popinteger(graupel)
2071  CALL poprealarray(phis, (ie-is+1)*(km+1))
2072  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2073  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2074  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2075  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2076  CALL poprealarray(gz, ie - is + 1)
2077  CALL popinteger(kmp)
2078  CALL poprealarray(dp2, (ie-is+1)*km)
2079  CALL popinteger(iep1)
2080  CALL poprealarray(rg)
2081  CALL poprealarray(tpe)
2082  CALL poprealarray(k1k)
2083  CALL popinteger(snowwat)
2084  CALL poprealarray(dtmp)
2085  CALL popinteger(cld_amt)
2086  CALL popinteger(abs_kord_tm_pert)
2087  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2088  CALL popinteger(rainwat)
2089  CALL poprealarray(result1)
2090  CALL popinteger(ice_wat)
2091  CALL poprealarray(rrg)
2092  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2093  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2094  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2095  CALL popinteger(liq_wat)
2096  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2097  CALL poprealarray(bkh)
2098  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2099  dtmp_ad = 0.0
2100  DO k=km,1,-1
2101  DO j=je,js,-1
2102  CALL popcontrol(1,branch)
2103  IF (branch .NE. 0) THEN
2104  DO i=ie,is,-1
2105  CALL poprealarray(pt(i, j, k))
2106  temp36 = r_vir*q(i, j, k, sphum) + 1.
2107  temp_ad37 = pt_ad(i, j, k)/temp36
2108  dtmp_ad = dtmp_ad + pkz(i, j, k)*temp_ad37
2109  pkz_ad(i, j, k) = pkz_ad(i, j, k) + dtmp*temp_ad37
2110  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) - (pt(i, j, &
2111 & k)+dtmp*pkz(i, j, k))*r_vir*temp_ad37/temp36
2112  pt_ad(i, j, k) = temp_ad37
2113  END DO
2114  END IF
2115  END DO
2116  END DO
2117  gz_ad = 0.0
2118  ELSE IF (branch .EQ. 1) THEN
2119  CALL popinteger(graupel)
2120  CALL poprealarray(phis, (ie-is+1)*(km+1))
2121  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2122  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2123  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2124  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2125  CALL poprealarray(gz, ie - is + 1)
2126  CALL popinteger(kmp)
2127  CALL poprealarray(dp2, (ie-is+1)*km)
2128  CALL popinteger(iep1)
2129  CALL poprealarray(rg)
2130  CALL poprealarray(tpe)
2131  CALL poprealarray(k1k)
2132  CALL popinteger(snowwat)
2133  CALL poprealarray(dtmp)
2134  CALL popinteger(cld_amt)
2135  CALL popinteger(abs_kord_tm_pert)
2136  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2137  CALL popinteger(rainwat)
2138  CALL poprealarray(result1)
2139  CALL popinteger(ice_wat)
2140  CALL poprealarray(rrg)
2141  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2142  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2143  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2144  CALL popinteger(liq_wat)
2145  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2146  CALL poprealarray(bkh)
2147  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2148  dtmp_ad = 0.0
2149  DO k=km,1,-1
2150  DO j=je,js,-1
2151  DO i=ie,is,-1
2152  CALL poprealarray(pt(i, j, k))
2153  temp39 = r_vir*q(i, j, k, sphum) + 1.
2154  temp_ad38 = pt_ad(i, j, k)/temp39
2155  temp38 = pkz(i, j, k)
2156  temp37 = pt(i, j, k) + dtmp
2157  dtmp_ad = dtmp_ad + temp38*temp_ad38
2158  pkz_ad(i, j, k) = pkz_ad(i, j, k) + temp37*temp_ad38
2159  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) - temp37*&
2160 & temp38*r_vir*temp_ad38/temp39
2161  pt_ad(i, j, k) = temp38*temp_ad38
2162  END DO
2163  END DO
2164  END DO
2165  gz_ad = 0.0
2166  ELSE
2167  CALL popinteger(graupel)
2168  CALL poprealarray(phis, (ie-is+1)*(km+1))
2169  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2170  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2171  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2172  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2173  CALL poprealarray(gz, ie - is + 1)
2174  CALL popinteger(kmp)
2175  CALL poprealarray(dp2, (ie-is+1)*km)
2176  CALL popinteger(iep1)
2177  CALL poprealarray(rg)
2178  CALL poprealarray(tpe)
2179  CALL poprealarray(k1k)
2180  CALL popinteger(snowwat)
2181  CALL poprealarray(dtmp)
2182  CALL poprealarray(tmp)
2183  CALL popinteger(cld_amt)
2184  CALL popinteger(abs_kord_tm_pert)
2185  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2186  CALL popinteger(rainwat)
2187  CALL poprealarray(result1)
2188  CALL popinteger(ice_wat)
2189  CALL poprealarray(rrg)
2190  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2191  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2192  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2193  CALL popinteger(liq_wat)
2194  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2195  CALL poprealarray(bkh)
2196  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2197  gz_ad = 0.0
2198  dtmp_ad = 0.0
2199  DO j=je,js,-1
2200  DO k=1,km,1
2201  DO i=ie,is,-1
2202  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
2203  CALL poprealarray(gz(i))
2204  temp_ad39 = (r_vir*q(i, j, k, sphum)+1.)*gz_ad(i)
2205  tmp_ad = pt_ad(i, j, k) + dlnp*temp_ad39
2206  CALL poprealarray(pt(i, j, k))
2207  temp45 = r_vir*q(i, j, k, sphum) + 1.
2208  temp_ad41 = pt_ad(i, j, k)/temp45
2209  dtmp_ad = dtmp_ad + pkz(i, j, k)*temp_ad41
2210  pkz_ad(i, j, k) = pkz_ad(i, j, k) + dtmp*temp_ad41
2211  pt_ad(i, j, k) = 0.0
2212  temp44 = r_vir*q(i, j, k, sphum) + 1.
2213  temp43 = delp(i, j, k)
2214  temp42 = pe(i, k, j)
2215  temp41 = temp42*dlnp/temp43
2216  temp40 = (cp-temp41)*temp44
2217  temp_ad42 = -(tpe*tmp_ad/temp40**2)
2218  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) + (cp-temp41)*&
2219 & r_vir*temp_ad42 - dtmp*pkz(i, j, k)*r_vir*temp_ad41/&
2220 & temp45 + dlnp*tmp*r_vir*gz_ad(i)
2221  temp_ad40 = -(temp44*temp_ad42/temp43)
2222  dlnp_ad = temp42*temp_ad40 + tmp*temp_ad39
2223  CALL poprealarray(tmp)
2224  tpe_ad = tmp_ad/temp40
2225  pe_ad(i, k, j) = pe_ad(i, k, j) + dlnp*temp_ad40
2226  delp_ad(i, j, k) = delp_ad(i, j, k) - temp41*temp_ad40
2227  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + rg*dlnp_ad
2228  peln_ad(i, k, j) = peln_ad(i, k, j) - rg*dlnp_ad
2229  CALL poprealarray(tpe)
2230  temp_ad43 = -(gridstruct%rsin2(i, j)*0.25*tpe_ad)
2231  temp_ad44 = -(gridstruct%cosa_s(i, j)*temp_ad43)
2232  temp_ad45 = (v(i, j, k)+v(i+1, j, k))*temp_ad44
2233  temp_ad46 = (u(i, j, k)+u(i, j+1, k))*temp_ad44
2234  te_ad(i, j, k) = te_ad(i, j, k) + tpe_ad
2235  gz_ad(i) = gz_ad(i) - tpe_ad
2236  u_ad(i, j, k) = u_ad(i, j, k) + temp_ad45 + 2*u(i, j, k)*&
2237 & temp_ad43
2238  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp_ad45 + 2*u(i, j+1&
2239 & , k)*temp_ad43
2240  v_ad(i, j, k) = v_ad(i, j, k) + temp_ad46 + 2*v(i, j, k)*&
2241 & temp_ad43
2242  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp_ad46 + 2*v(i+1, j&
2243 & , k)*temp_ad43
2244  END DO
2245  END DO
2246  DO i=ie,is,-1
2247  CALL poprealarray(gz(i))
2248  gz_ad(i) = 0.0
2249  END DO
2250  END DO
2251  END IF
2252  ELSE IF (branch .LT. 5) THEN
2253  IF (branch .EQ. 3) THEN
2254  CALL popinteger(graupel)
2255  CALL poprealarray(phis, (ie-is+1)*(km+1))
2256  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2257  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2258  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2259  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2260  CALL poprealarray(gz, ie - is + 1)
2261  CALL popinteger(kmp)
2262  CALL poprealarray(dp2, (ie-is+1)*km)
2263  CALL popinteger(iep1)
2264  CALL poprealarray(rg)
2265  CALL poprealarray(tpe)
2266  CALL poprealarray(k1k)
2267  CALL popinteger(snowwat)
2268  CALL popinteger(cld_amt)
2269  CALL popinteger(abs_kord_tm_pert)
2270  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2271  CALL popinteger(rainwat)
2272  CALL poprealarray(result1)
2273  CALL popinteger(ice_wat)
2274  CALL poprealarray(rrg)
2275  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2276  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2277  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2278  CALL popinteger(liq_wat)
2279  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2280  CALL poprealarray(bkh)
2281  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2282  gz_ad = 0.0
2283  dtmp_ad = 0.0
2284  ELSE
2285  CALL popinteger(graupel)
2286  CALL poprealarray(phis, (ie-is+1)*(km+1))
2287  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2288  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2289  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2290  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2291  CALL poprealarray(gz, ie - is + 1)
2292  CALL popinteger(kmp)
2293  CALL poprealarray(dp2, (ie-is+1)*km)
2294  CALL popinteger(iep1)
2295  CALL poprealarray(rg)
2296  CALL poprealarray(tpe)
2297  CALL poprealarray(k1k)
2298  CALL popinteger(snowwat)
2299  CALL popinteger(cld_amt)
2300  CALL popinteger(abs_kord_tm_pert)
2301  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2302  CALL popinteger(rainwat)
2303  CALL poprealarray(result1)
2304  CALL popinteger(ice_wat)
2305  CALL poprealarray(rrg)
2306  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2307  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2308  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2309  CALL popinteger(liq_wat)
2310  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2311  CALL poprealarray(bkh)
2312  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2313  DO k=km,1,-1
2314  DO j=je,js,-1
2315  DO i=ie,is,-1
2316  CALL poprealarray(pt(i, j, k))
2317  temp_ad47 = pt_ad(i, j, k)/pkz(i, j, k)
2318  pkz_ad(i, j, k) = pkz_ad(i, j, k) - pt(i, j, k)*temp_ad47/&
2319 & pkz(i, j, k)
2320  pt_ad(i, j, k) = temp_ad47
2321  END DO
2322  END DO
2323  END DO
2324  gz_ad = 0.0
2325  dtmp_ad = 0.0
2326  END IF
2327  ELSE IF (branch .EQ. 5) THEN
2328  CALL popinteger(graupel)
2329  CALL poprealarray(phis, (ie-is+1)*(km+1))
2330  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2331  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2332  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2333  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2334  CALL poprealarray(gz, ie - is + 1)
2335  CALL popinteger(kmp)
2336  CALL poprealarray(dp2, (ie-is+1)*km)
2337  CALL popinteger(iep1)
2338  CALL poprealarray(rg)
2339  CALL poprealarray(tpe)
2340  CALL poprealarray(k1k)
2341  CALL popinteger(snowwat)
2342  CALL popinteger(cld_amt)
2343  CALL popinteger(abs_kord_tm_pert)
2344  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2345  CALL popinteger(rainwat)
2346  CALL poprealarray(result1)
2347  CALL popinteger(ice_wat)
2348  CALL poprealarray(rrg)
2349  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2350  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2351  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2352  CALL popinteger(liq_wat)
2353  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2354  CALL poprealarray(bkh)
2355  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2356  gz_ad = 0.0
2357  dtmp_ad = 0.0
2358  DO j=je,js,-1
2359  DO k=1,km,1
2360  DO i=ie,is,-1
2361  temp_ad49 = pt_ad(i, j, k)/pkz(i, j, k)
2362  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
2363  tmp = tpe/(cp-pe(i, k, j)*dlnp/delp(i, j, k))
2364  CALL poprealarray(gz(i))
2365  tmp_ad = temp_ad49 + dlnp*gz_ad(i)
2366  CALL poprealarray(pt(i, j, k))
2367  pkz_ad(i, j, k) = pkz_ad(i, j, k) - tmp*temp_ad49/pkz(i, j, &
2368 & k)
2369  dtmp_ad = dtmp_ad + pt_ad(i, j, k)
2370  pt_ad(i, j, k) = 0.0
2371  temp48 = delp(i, j, k)
2372  temp47 = pe(i, k, j)
2373  temp46 = temp47*dlnp/temp48
2374  temp_ad50 = tmp_ad/(cp-temp46)
2375  temp_ad48 = tpe*temp_ad50/((cp-temp46)*temp48)
2376  dlnp_ad = temp47*temp_ad48 + tmp*gz_ad(i)
2377  tpe_ad = temp_ad50
2378  pe_ad(i, k, j) = pe_ad(i, k, j) + dlnp*temp_ad48
2379  delp_ad(i, j, k) = delp_ad(i, j, k) - temp46*temp_ad48
2380  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + rg*dlnp_ad
2381  peln_ad(i, k, j) = peln_ad(i, k, j) - rg*dlnp_ad
2382  CALL poprealarray(tpe)
2383  temp_ad51 = -(gridstruct%rsin2(i, j)*0.25*tpe_ad)
2384  temp_ad52 = -(gridstruct%cosa_s(i, j)*temp_ad51)
2385  temp_ad53 = (v(i, j, k)+v(i+1, j, k))*temp_ad52
2386  temp_ad54 = (u(i, j, k)+u(i, j+1, k))*temp_ad52
2387  te_ad(i, j, k) = te_ad(i, j, k) + tpe_ad
2388  gz_ad(i) = gz_ad(i) - tpe_ad
2389  u_ad(i, j, k) = u_ad(i, j, k) + temp_ad53 + 2*u(i, j, k)*&
2390 & temp_ad51
2391  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp_ad53 + 2*u(i, j+1, &
2392 & k)*temp_ad51
2393  v_ad(i, j, k) = v_ad(i, j, k) + temp_ad54 + 2*v(i, j, k)*&
2394 & temp_ad51
2395  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp_ad54 + 2*v(i+1, j, &
2396 & k)*temp_ad51
2397  END DO
2398  END DO
2399  DO i=ie,is,-1
2400  CALL poprealarray(gz(i))
2401  gz_ad(i) = 0.0
2402  END DO
2403  END DO
2404  ELSE
2405  CALL popinteger(graupel)
2406  CALL poprealarray(phis, (ie-is+1)*(km+1))
2407  CALL poprealarray(pe0, (ie-is+2)*(km+1))
2408  CALL poprealarray(pe1, (ie-is+1)*(km+1))
2409  CALL poprealarray(pe2, (ie-is+1)*(km+1))
2410  CALL poprealarray(pe3, (ie-is+2)*(km+1))
2411  CALL poprealarray(gz, ie - is + 1)
2412  CALL popinteger(kmp)
2413  CALL poprealarray(dp2, (ie-is+1)*km)
2414  CALL popinteger(iep1)
2415  CALL poprealarray(rg)
2416  CALL poprealarray(tpe)
2417  CALL poprealarray(k1k)
2418  CALL popinteger(snowwat)
2419  CALL popinteger(cld_amt)
2420  CALL popinteger(abs_kord_tm_pert)
2421  CALL poprealarray(te_2d, (ie-is+1)*(je-js+1))
2422  CALL popinteger(rainwat)
2423  CALL poprealarray(result1)
2424  CALL popinteger(ice_wat)
2425  CALL poprealarray(rrg)
2426  CALL poprealarray(zsum0, (ie-is+1)*(je-js+1))
2427  CALL poprealarray(pn2, (ie-is+1)*(km+1))
2428  CALL poprealarray(zsum1, (ie-is+1)*(je-js+1))
2429  CALL popinteger(liq_wat)
2430  CALL poprealarray(pk1, (ie-is+1)*(km+1))
2431  CALL poprealarray(bkh)
2432  CALL poprealarray(pk2, (ie-is+1)*(km+1))
2433  gz_ad = 0.0
2434  dtmp_ad = 0.0
2435  END IF
2436  CALL popcontrol(2,branch)
2437  IF (branch .EQ. 0) THEN
2438  DO j=je,js,-1
2439  DO i=ie,is,-1
2440  DO k=km,kmp,-1
2441  te_ad(i, j, k) = te_ad(i, j, k) + te0_2d_ad(i, j)
2442  END DO
2443  END DO
2444  END DO
2445  ELSE IF (branch .NE. 1) THEN
2446  GOTO 100
2447  END IF
2448  rrg = -(rdgas/grav)
2449  DO k=km,kmp,-1
2450  CALL popcontrol(1,branch)
2451  IF (branch .NE. 0) THEN
2452  DO j=je,js,-1
2453  DO i=ie,is,-1
2454  CALL poprealarray(pkz(i, j, k))
2455  temp35 = delz(i, j, k)
2456  temp34 = delp(i, j, k)*pt(i, j, k)
2457  temp33 = temp34/temp35
2458  temp_ad36 = akap*exp(akap*log(rrg*temp33))*pkz_ad(i, j, k)/(&
2459 & temp33*temp35)
2460  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*temp_ad36
2461  pt_ad(i, j, k) = pt_ad(i, j, k) + delp(i, j, k)*temp_ad36
2462  delz_ad(i, j, k) = delz_ad(i, j, k) - temp33*temp_ad36
2463  pkz_ad(i, j, k) = 0.0
2464  END DO
2465  END DO
2466  END IF
2467  END DO
2468  100 CALL popcontrol(3,branch)
2469  IF (branch .LT. 3) THEN
2470  IF (branch .EQ. 0) THEN
2471  temp_ad34 = dtmp_ad/(cp*result1)
2472  tpe_ad = temp_ad34
2473  result1_ad = -(tpe*temp_ad34/result1)
2474  CALL g_sum_adm(domain, zsum0, zsum0_ad, is, ie, js, je, ng, &
2475 & gridstruct%area_64, 0, reproduce=.true., g_sum_ad=&
2476 & result1_ad)
2477  zsum1_ad = 0.0
2478  ELSE IF (branch .EQ. 1) THEN
2479  temp_ad35 = dtmp_ad/(cv_air*result1)
2480  tpe_ad = temp_ad35
2481  result1_ad = -(tpe*temp_ad35/result1)
2482  CALL g_sum_adm(domain, zsum1, zsum1_ad, is, ie, js, je, ng, &
2483 & gridstruct%area_64, 0, reproduce=.true., g_sum_ad=&
2484 & result1_ad)
2485  zsum0_ad = 0.0
2486  ELSE
2487  result1_ad = -(e_flux*4.*pi*grav*pdt*radius**2*dtmp_ad/(cp*&
2488 & result1**2))
2489  CALL g_sum_adm(domain, zsum0, zsum0_ad, is, ie, js, je, ng, &
2490 & gridstruct%area_64, 0, reproduce=.true., g_sum_ad=&
2491 & result1_ad)
2492  zsum1_ad = 0.0
2493  GOTO 110
2494  END IF
2495  result1_ad = consv*tpe_ad
2496  CALL g_sum_adm(domain, te_2d, te_2d_ad, is, ie, js, je, ng, &
2497 & gridstruct%area_64, 0, reproduce=.true., g_sum_ad=&
2498 & result1_ad)
2499  phis_ad = 0.0
2500  DO j=je,js,-1
2501  CALL popcontrol(1,branch)
2502  IF (branch .NE. 0) THEN
2503  DO i=ie,is,-1
2504  pk_ad(i, j, 1) = pk_ad(i, j, 1) + ptop*zsum0_ad(i, j)
2505  pk_ad(i, j, km+1) = pk_ad(i, j, km+1) - ptop*zsum0_ad(i, j)
2506  zsum1_ad(i, j) = zsum1_ad(i, j) + zsum0_ad(i, j)
2507  zsum0_ad(i, j) = 0.0
2508  END DO
2509  END IF
2510  DO k=km,2,-1
2511  DO i=ie,is,-1
2512  pkz_ad(i, j, k) = pkz_ad(i, j, k) + delp(i, j, k)*zsum1_ad(i&
2513 & , j)
2514  delp_ad(i, j, k) = delp_ad(i, j, k) + pkz(i, j, k)*zsum1_ad(&
2515 & i, j)
2516  END DO
2517  END DO
2518  DO i=ie,is,-1
2519  pkz_ad(i, j, 1) = pkz_ad(i, j, 1) + delp(i, j, 1)*zsum1_ad(i, &
2520 & j)
2521  delp_ad(i, j, 1) = delp_ad(i, j, 1) + pkz(i, j, 1)*zsum1_ad(i&
2522 & , j)
2523  zsum1_ad(i, j) = 0.0
2524  te0_2d_ad(i, j) = te0_2d_ad(i, j) + te_2d_ad(i, j)
2525  te_2d_ad(i, j) = -te_2d_ad(i, j)
2526  END DO
2527  CALL popcontrol(3,branch)
2528  IF (branch .LT. 3) THEN
2529  IF (branch .NE. 0) THEN
2530  IF (branch .EQ. 1) THEN
2531  DO k=km,2,-1
2532  DO i=ie,is,-1
2533  te_ad(i, j, k) = te_ad(i, j, k) + delp(i, j, k)*&
2534 & te_2d_ad(i, j)
2535  delp_ad(i, j, k) = delp_ad(i, j, k) + te(i, j, k)*&
2536 & te_2d_ad(i, j)
2537  END DO
2538  END DO
2539  DO i=ie,is,-1
2540  te_ad(i, j, 1) = te_ad(i, j, 1) + delp(i, j, 1)*te_2d_ad&
2541 & (i, j)
2542  delp_ad(i, j, 1) = delp_ad(i, j, 1) + te(i, j, 1)*&
2543 & te_2d_ad(i, j)
2544  te_2d_ad(i, j) = 0.0
2545  END DO
2546  ELSE
2547  DO k=km,1,-1
2548  DO i=ie,is,-1
2549  temp32 = v(i, j, k) + v(i+1, j, k)
2550  temp31 = u(i, j, k) + u(i, j+1, k)
2551  temp30 = 0.5*gridstruct%rsin2(i, j)
2552  temp29 = r_vir*q(i, j, k, sphum) + 1.
2553  temp28 = pt(i, j, k)/temp29
2554  temp_ad29 = delp(i, j, k)*te_2d_ad(i, j)
2555  temp_ad30 = cv_air*temp_ad29/temp29
2556  temp_ad31 = 0.5*temp_ad29
2557  temp_ad32 = temp30*temp_ad31
2558  temp_ad33 = -(gridstruct%cosa_s(i, j)*temp_ad32)
2559  delp_ad(i, j, k) = delp_ad(i, j, k) + (cv_air*temp28+&
2560 & 0.5*(phis(i, k)+phis(i, k+1)+w(i, j, k)**2+temp30*(u&
2561 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j&
2562 & , k)**2-gridstruct%cosa_s(i, j)*(temp31*temp32))))*&
2563 & te_2d_ad(i, j)
2564  pt_ad(i, j, k) = pt_ad(i, j, k) + temp_ad30
2565  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) - temp28*&
2566 & r_vir*temp_ad30
2567  phis_ad(i, k) = phis_ad(i, k) + temp_ad31
2568  phis_ad(i, k+1) = phis_ad(i, k+1) + temp_ad31
2569  w_ad(i, j, k) = w_ad(i, j, k) + 2*w(i, j, k)*temp_ad31
2570  u_ad(i, j, k) = u_ad(i, j, k) + temp32*temp_ad33 + 2*u&
2571 & (i, j, k)*temp_ad32
2572  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp32*temp_ad33 +&
2573 & 2*u(i, j+1, k)*temp_ad32
2574  v_ad(i, j, k) = v_ad(i, j, k) + temp31*temp_ad33 + 2*v&
2575 & (i, j, k)*temp_ad32
2576  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp31*temp_ad33 +&
2577 & 2*v(i+1, j, k)*temp_ad32
2578  END DO
2579  END DO
2580  DO i=ie,is,-1
2581  te_2d_ad(i, j) = 0.0
2582  END DO
2583  DO i=ie,is,-1
2584  DO k=1,km,1
2585  CALL poprealarray(phis(i, k))
2586  phis_ad(i, k+1) = phis_ad(i, k+1) + phis_ad(i, k)
2587  delz_ad(i, j, k) = delz_ad(i, j, k) - grav*phis_ad(i, &
2588 & k)
2589  phis_ad(i, k) = 0.0
2590  END DO
2591  CALL poprealarray(phis(i, km+1))
2592  phis_ad(i, km+1) = 0.0
2593  END DO
2594  END IF
2595  END IF
2596  ELSE IF (branch .EQ. 3) THEN
2597  DO k=km,1,-1
2598  DO i=ie,is,-1
2599  temp27 = v(i, j, k) + v(i+1, j, k)
2600  temp26 = u(i, j, k) + u(i, j+1, k)
2601  temp25 = 0.25*gridstruct%rsin2(i, j)
2602  temp_ad26 = delp(i, j, k)*te_2d_ad(i, j)
2603  temp_ad27 = temp25*temp_ad26
2604  temp_ad28 = -(gridstruct%cosa_s(i, j)*temp_ad27)
2605  delp_ad(i, j, k) = delp_ad(i, j, k) + (cp_air*(pt(i, j, k)&
2606 & *pkz(i, j, k))+temp25*(u(i, j, k)**2+u(i, j+1, k)**2+v(i&
2607 & , j, k)**2+v(i+1, j, k)**2-gridstruct%cosa_s(i, j)*(&
2608 & temp26*temp27)))*te_2d_ad(i, j)
2609  pt_ad(i, j, k) = pt_ad(i, j, k) + cp_air*pkz(i, j, k)*&
2610 & temp_ad26
2611  pkz_ad(i, j, k) = pkz_ad(i, j, k) + cp_air*pt(i, j, k)*&
2612 & temp_ad26
2613  u_ad(i, j, k) = u_ad(i, j, k) + temp27*temp_ad28 + 2*u(i, &
2614 & j, k)*temp_ad27
2615  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp27*temp_ad28 + 2*u&
2616 & (i, j+1, k)*temp_ad27
2617  v_ad(i, j, k) = v_ad(i, j, k) + temp26*temp_ad28 + 2*v(i, &
2618 & j, k)*temp_ad27
2619  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp26*temp_ad28 + 2*v&
2620 & (i+1, j, k)*temp_ad27
2621  END DO
2622  END DO
2623  DO i=ie,is,-1
2624  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + hs(i, j)*te_2d_ad(i&
2625 & , j)
2626  pe_ad(i, 1, j) = pe_ad(i, 1, j) - gz(i)*te_2d_ad(i, j)
2627  gz_ad(i) = gz_ad(i) - pe(i, 1, j)*te_2d_ad(i, j)
2628  te_2d_ad(i, j) = 0.0
2629  END DO
2630  DO i=ie,is,-1
2631  DO k=km,1,-1
2632  temp_ad25 = cp_air*pt(i, j, k)*gz_ad(i)
2633  pt_ad(i, j, k) = pt_ad(i, j, k) + cp_air*(pk(i, j, k+1)-pk&
2634 & (i, j, k))*gz_ad(i)
2635  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp_ad25
2636  pk_ad(i, j, k) = pk_ad(i, j, k) - temp_ad25
2637  END DO
2638  CALL poprealarray(gz(i))
2639  gz_ad(i) = 0.0
2640  END DO
2641  ELSE IF (branch .EQ. 4) THEN
2642  DO k=km,1,-1
2643  DO i=ie,is,-1
2644  temp24 = v(i, j, k) + v(i+1, j, k)
2645  temp23 = u(i, j, k) + u(i, j+1, k)
2646  temp22 = 0.5*gridstruct%rsin2(i, j)
2647  temp21 = r_vir*q(i, j, k, sphum) + 1.
2648  temp20 = pt(i, j, k)/temp21
2649  temp_ad20 = delp(i, j, k)*te_2d_ad(i, j)
2650  temp_ad21 = cv_air*temp_ad20/temp21
2651  temp_ad22 = 0.5*temp_ad20
2652  temp_ad23 = temp22*temp_ad22
2653  temp_ad24 = -(gridstruct%cosa_s(i, j)*temp_ad23)
2654  delp_ad(i, j, k) = delp_ad(i, j, k) + (cv_air*temp20+0.5*(&
2655 & phis(i, k)+phis(i, k+1)+w(i, j, k)**2+temp22*(u(i, j, k)&
2656 & **2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-&
2657 & gridstruct%cosa_s(i, j)*(temp23*temp24))))*te_2d_ad(i, j&
2658 & )
2659  pt_ad(i, j, k) = pt_ad(i, j, k) + temp_ad21
2660  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) - temp20*r_vir&
2661 & *temp_ad21
2662  phis_ad(i, k) = phis_ad(i, k) + temp_ad22
2663  phis_ad(i, k+1) = phis_ad(i, k+1) + temp_ad22
2664  w_ad(i, j, k) = w_ad(i, j, k) + 2*w(i, j, k)*temp_ad22
2665  u_ad(i, j, k) = u_ad(i, j, k) + temp24*temp_ad24 + 2*u(i, &
2666 & j, k)*temp_ad23
2667  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp24*temp_ad24 + 2*u&
2668 & (i, j+1, k)*temp_ad23
2669  v_ad(i, j, k) = v_ad(i, j, k) + temp23*temp_ad24 + 2*v(i, &
2670 & j, k)*temp_ad23
2671  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp23*temp_ad24 + 2*v&
2672 & (i+1, j, k)*temp_ad23
2673  END DO
2674  END DO
2675  DO k=1,km,1
2676  DO i=ie,is,-1
2677  CALL poprealarray(phis(i, k))
2678  phis_ad(i, k+1) = phis_ad(i, k+1) + phis_ad(i, k)
2679  delz_ad(i, j, k) = delz_ad(i, j, k) - grav*phis_ad(i, k)
2680  phis_ad(i, k) = 0.0
2681  END DO
2682  END DO
2683  DO i=ie,is,-1
2684  CALL poprealarray(phis(i, km+1))
2685  phis_ad(i, km+1) = 0.0
2686  te_2d_ad(i, j) = 0.0
2687  END DO
2688  ELSE
2689  DO k=km,1,-1
2690  DO i=ie,is,-1
2691  temp19 = v(i, j, k) + v(i+1, j, k)
2692  temp18 = u(i, j, k) + u(i, j+1, k)
2693  temp17 = 0.25*gridstruct%rsin2(i, j)
2694  temp_ad17 = delp(i, j, k)*te_2d_ad(i, j)
2695  temp_ad18 = temp17*temp_ad17
2696  temp_ad19 = -(gridstruct%cosa_s(i, j)*temp_ad18)
2697  delp_ad(i, j, k) = delp_ad(i, j, k) + (cp*pt(i, j, k)+&
2698 & temp17*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
2699 & 1, j, k)**2-gridstruct%cosa_s(i, j)*(temp18*temp19)))*&
2700 & te_2d_ad(i, j)
2701  pt_ad(i, j, k) = pt_ad(i, j, k) + cp*temp_ad17
2702  u_ad(i, j, k) = u_ad(i, j, k) + temp19*temp_ad19 + 2*u(i, &
2703 & j, k)*temp_ad18
2704  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp19*temp_ad19 + 2*u&
2705 & (i, j+1, k)*temp_ad18
2706  v_ad(i, j, k) = v_ad(i, j, k) + temp18*temp_ad19 + 2*v(i, &
2707 & j, k)*temp_ad18
2708  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp18*temp_ad19 + 2*v&
2709 & (i+1, j, k)*temp_ad18
2710  END DO
2711  END DO
2712  DO i=ie,is,-1
2713  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + hs(i, j)*te_2d_ad(i&
2714 & , j)
2715  pe_ad(i, 1, j) = pe_ad(i, 1, j) - gz(i)*te_2d_ad(i, j)
2716  gz_ad(i) = gz_ad(i) - pe(i, 1, j)*te_2d_ad(i, j)
2717  te_2d_ad(i, j) = 0.0
2718  END DO
2719  DO i=ie,is,-1
2720  DO k=km,1,-1
2721  temp_ad16 = rg*pt(i, j, k)*gz_ad(i)
2722  pt_ad(i, j, k) = pt_ad(i, j, k) + rg*(peln(i, k+1, j)-peln&
2723 & (i, k, j))*gz_ad(i)
2724  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad16
2725  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad16
2726  END DO
2727  CALL poprealarray(gz(i))
2728  gz_ad(i) = 0.0
2729  END DO
2730  END IF
2731  END DO
2732  GOTO 130
2733  ELSE IF (branch .EQ. 3) THEN
2734  result1_ad = -(e_flux*4.*pi*grav*pdt*radius**2*dtmp_ad/(cv_air*&
2735 & result1**2))
2736  CALL g_sum_adm(domain, zsum1, zsum1_ad, is, ie, js, je, ng, &
2737 & gridstruct%area_64, 0, reproduce=.true., g_sum_ad=&
2738 & result1_ad)
2739  zsum0_ad = 0.0
2740  ELSE IF (branch .EQ. 4) THEN
2741  GOTO 120
2742  ELSE
2743  phis_ad = 0.0
2744  GOTO 130
2745  END IF
2746  110 CALL poprealarray(e_flux)
2747  DO j=je,js,-1
2748  CALL popcontrol(1,branch)
2749  IF (branch .NE. 0) THEN
2750  DO i=ie,is,-1
2751  pk_ad(i, j, 1) = pk_ad(i, j, 1) + ptop*zsum0_ad(i, j)
2752  pk_ad(i, j, km+1) = pk_ad(i, j, km+1) - ptop*zsum0_ad(i, j)
2753  zsum1_ad(i, j) = zsum1_ad(i, j) + zsum0_ad(i, j)
2754  zsum0_ad(i, j) = 0.0
2755  END DO
2756  END IF
2757  DO k=km,2,-1
2758  DO i=ie,is,-1
2759  pkz_ad(i, j, k) = pkz_ad(i, j, k) + delp(i, j, k)*zsum1_ad(i, &
2760 & j)
2761  delp_ad(i, j, k) = delp_ad(i, j, k) + pkz(i, j, k)*zsum1_ad(i&
2762 & , j)
2763  END DO
2764  END DO
2765  DO i=ie,is,-1
2766  pkz_ad(i, j, 1) = pkz_ad(i, j, 1) + delp(i, j, 1)*zsum1_ad(i, j)
2767  delp_ad(i, j, 1) = delp_ad(i, j, 1) + pkz(i, j, 1)*zsum1_ad(i, j&
2768 & )
2769  zsum1_ad(i, j) = 0.0
2770  END DO
2771  END DO
2772  120 phis_ad = 0.0
2773  130 DO k=km,2,-1
2774  DO j=je,js,-1
2775  DO i=ie,is,-1
2776  CALL poprealarray(pe(i, k, j))
2777  ua_ad(i, j, k-1) = ua_ad(i, j, k-1) + pe_ad(i, k, j)
2778  pe_ad(i, k, j) = 0.0
2779  END DO
2780  END DO
2781  END DO
2782  CALL popinteger(ad_count1)
2783  DO i2=1,ad_count1
2784  IF (i2 .EQ. 1) THEN
2785  CALL popcontrol(1,branch)
2786  IF (branch .EQ. 0) THEN
2787  pe0_ad = 0.0
2788  pe1_ad = 0.0
2789  pe2_ad = 0.0
2790  pe3_ad = 0.0
2791  dp2_ad = 0.0
2792  q2_ad = 0.0
2793  pn2_ad = 0.0
2794  pk1_ad = 0.0
2795  pk2_ad = 0.0
2796  GOTO 150
2797  ELSE
2798  ws_ad = 0.0
2799  peln_ad = 0.0
2800  q_ad = 0.0
2801  u_ad = 0.0
2802  v_ad = 0.0
2803  w_ad = 0.0
2804  delp_ad = 0.0
2805  ua_ad = 0.0
2806  delz_ad = 0.0
2807  omga_ad = 0.0
2808  te0_2d_ad = 0.0
2809  pkz_ad = 0.0
2810  pe_ad = 0.0
2811  pk_ad = 0.0
2812  ps_ad = 0.0
2813  pt_ad = 0.0
2814  te_ad = 0.0
2815  phis_ad = 0.0
2816  pe0_ad = 0.0
2817  pe1_ad = 0.0
2818  pe2_ad = 0.0
2819  pe3_ad = 0.0
2820  dp2_ad = 0.0
2821  q2_ad = 0.0
2822  pn2_ad = 0.0
2823  pk1_ad = 0.0
2824  pk2_ad = 0.0
2825  END IF
2826  ELSE
2827  CALL popinteger(ad_to59)
2828  DO k=ad_to59,1,-1
2829  CALL popinteger(ad_from33)
2830  CALL popinteger(ad_to58)
2831  DO i=ad_to58,ad_from33,-1
2832  CALL poprealarray(ua(i, j, k))
2833  pe2_ad(i, k+1) = pe2_ad(i, k+1) + ua_ad(i, j, k)
2834  ua_ad(i, j, k) = 0.0
2835  END DO
2836  END DO
2837  CALL popcontrol(2,branch)
2838  IF (branch .NE. 0) THEN
2839  IF (branch .EQ. 1) THEN
2840  gz_ad = 0.0
2841  CALL map1_ppm_bwd(km, pe0, pe0_ad, gz, gz_ad, km, pe3, &
2842 & pe3_ad, v, v_ad, is, iep1, j, isd, iedp1, jsd&
2843 & , jed, -1, kord_mt)
2844  ELSE
2845  CALL poprealarray(v, (ied-isd+2)*(jed-jsd+1)*km)
2846  gz_ad = 0.0
2847  CALL map1_ppm_adm(km, pe0, pe0_ad, gz, gz_ad, km, pe3, &
2848 & pe3_ad, v, v_ad, is, iep1, j, isd, iedp1, jsd, &
2849 & jed, -1, kord_mt_pert)
2850  END IF
2851  CALL popinteger(ad_to57)
2852  DO k=ad_to57,2,-1
2853  CALL popinteger(ad_from32)
2854  CALL popinteger(ad_to56)
2855  DO i=ad_to56,ad_from32,-1
2856  CALL poprealarray(pe3(i, k))
2857  pe_ad(i-1, km+1, j) = pe_ad(i-1, km+1, j) + bkh*pe3_ad(i, &
2858 & k)
2859  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + bkh*pe3_ad(i, k)
2860  pe3_ad(i, k) = 0.0
2861  CALL poprealarray(pe0(i, k))
2862  pe_ad(i-1, k, j) = pe_ad(i-1, k, j) + 0.5*pe0_ad(i, k)
2863  pe_ad(i, k, j) = pe_ad(i, k, j) + 0.5*pe0_ad(i, k)
2864  pe0_ad(i, k) = 0.0
2865  END DO
2866  CALL poprealarray(bkh)
2867  END DO
2868  CALL popinteger(ad_from31)
2869  CALL popinteger(ad_to55)
2870  DO i=ad_to55,ad_from31,-1
2871  CALL poprealarray(pe3(i, 1))
2872  pe3_ad(i, 1) = 0.0
2873  END DO
2874  END IF
2875  CALL popcontrol(1,branch)
2876  IF (branch .EQ. 0) THEN
2877  gz_ad = 0.0
2878  CALL map1_ppm_bwd(km, pe0(is:ie, :), pe0_ad(is:ie, :), gz, &
2879 & gz_ad, km, pe3(is:ie, :), pe3_ad(is:ie, :), u, &
2880 & u_ad, is, ie, j, isd, ied, jsd, jedp1, -1, &
2881 & kord_mt)
2882  ELSE
2883  CALL poprealarray(u, (ied-isd+1)*(jed-jsd+2)*km)
2884  gz_ad = 0.0
2885  CALL map1_ppm_adm(km, pe0(is:ie, :), pe0_ad(is:ie, :), gz, &
2886 & gz_ad, km, pe3(is:ie, :), pe3_ad(is:ie, :), u, &
2887 & u_ad, is, ie, j, isd, ied, jsd, jedp1, -1, &
2888 & kord_mt_pert)
2889  END IF
2890  CALL popinteger(ad_to54)
2891  DO k=ad_to54,1,-1
2892  CALL popinteger(ad_from30)
2893  CALL popinteger(ad_to53)
2894  DO i=ad_to53,ad_from30,-1
2895  CALL poprealarray(pe3(i, k))
2896  pe_ad(i, km+1, j-1) = pe_ad(i, km+1, j-1) + bkh*pe3_ad(i, k)
2897  pe1_ad(i, km+1) = pe1_ad(i, km+1) + bkh*pe3_ad(i, k)
2898  pe3_ad(i, k) = 0.0
2899  END DO
2900  CALL poprealarray(bkh)
2901  END DO
2902  CALL popinteger(ad_to52)
2903  DO k=ad_to52,2,-1
2904  CALL popinteger(ad_from29)
2905  CALL popinteger(ad_to51)
2906  DO i=ad_to51,ad_from29,-1
2907  CALL poprealarray(pe0(i, k))
2908  pe_ad(i, k, j-1) = pe_ad(i, k, j-1) + 0.5*pe0_ad(i, k)
2909  pe1_ad(i, k) = pe1_ad(i, k) + 0.5*pe0_ad(i, k)
2910  pe0_ad(i, k) = 0.0
2911  END DO
2912  END DO
2913  CALL popinteger(k)
2914  CALL popinteger(ad_from28)
2915  CALL popinteger(ad_to50)
2916  DO i=ad_to50,ad_from28,-1
2917  CALL poprealarray(pe0(i, 1))
2918  pe_ad(i, 1, j) = pe_ad(i, 1, j) + pe0_ad(i, 1)
2919  pe0_ad(i, 1) = 0.0
2920  END DO
2921  CALL popcontrol(2,branch)
2922  IF (branch .EQ. 0) THEN
2923  GOTO 140
2924  ELSE
2925  IF (branch .NE. 1) THEN
2926  CALL popinteger(ad_from27)
2927  CALL popinteger(ad_to49)
2928  DO i=ad_to49,ad_from27,-1
2929  CALL popinteger(ad_to48)
2930  DO n=ad_to48,1,-1
2931  CALL popcontrol(1,branch)
2932  IF (branch .EQ. 0) THEN
2933  CALL poprealarray(omga(i, j, n))
2934  temp14 = pe0(i, k+1) - pe0(i, k)
2935  temp_ad14 = omga_ad(i, j, n)/temp14
2936  temp16 = dp2(i, n) - pe0(i, k)
2937  temp15 = pe3(i, k+1) - pe3(i, k)
2938  temp_ad15 = -(temp15*temp16*temp_ad14/temp14)
2939  pe3_ad(i, k) = pe3_ad(i, k) + omga_ad(i, j, n) - &
2940 & temp16*temp_ad14
2941  pe3_ad(i, k+1) = pe3_ad(i, k+1) + temp16*temp_ad14
2942  dp2_ad(i, n) = dp2_ad(i, n) + temp15*temp_ad14
2943  pe0_ad(i, k) = pe0_ad(i, k) - temp_ad15 - temp15*&
2944 & temp_ad14
2945  pe0_ad(i, k+1) = pe0_ad(i, k+1) + temp_ad15
2946  omga_ad(i, j, n) = 0.0
2947  END IF
2948  CALL popinteger(ad_count0)
2949  DO i1=1,ad_count0
2950  IF (i1 .EQ. 1) CALL popcontrol(1,branch)
2951  CALL popinteger(k)
2952  END DO
2953  END DO
2954  END DO
2955  CALL popinteger(ad_to47)
2956  DO k=ad_to47,1,-1
2957  CALL popinteger(ad_from26)
2958  CALL popinteger(ad_to46)
2959  DO i=ad_to46,ad_from26,-1
2960  CALL poprealarray(dp2(i, k))
2961  peln_ad(i, k, j) = peln_ad(i, k, j) + 0.5*dp2_ad(i, k)
2962  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + 0.5*dp2_ad(i, &
2963 & k)
2964  dp2_ad(i, k) = 0.0
2965  END DO
2966  END DO
2967  END IF
2968  CALL popcontrol(2,branch)
2969  IF (branch .EQ. 0) THEN
2970  CALL popinteger(ad_to41)
2971  DO k=ad_to41,1,-1
2972  CALL popinteger(ad_from23)
2973  CALL popinteger(ad_to40)
2974  DO i=ad_to40,ad_from23,-1
2975  CALL poprealarray(pkz(i, j, k))
2976  temp7 = akap*(peln(i, k+1, j)-peln(i, k, j))
2977  temp_ad10 = pkz_ad(i, j, k)/temp7
2978  temp_ad11 = -((pk2(i, k+1)-pk2(i, k))*akap*temp_ad10/&
2979 & temp7)
2980  pk2_ad(i, k+1) = pk2_ad(i, k+1) + temp_ad10
2981  pk2_ad(i, k) = pk2_ad(i, k) - temp_ad10
2982  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad11
2983  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad11
2984  pkz_ad(i, j, k) = 0.0
2985  END DO
2986  END DO
2987  ELSE IF (branch .EQ. 1) THEN
2988  CALL popinteger(ad_to43)
2989  DO k=ad_to43,1,-1
2990  CALL popinteger(ad_from24)
2991  CALL popinteger(ad_to42)
2992  DO i=ad_to42,ad_from24,-1
2993  CALL poprealarray(pkz(i, j, k))
2994  temp10 = delz(i, j, k)
2995  temp9 = delp(i, j, k)*pt(i, j, k)
2996  temp8 = temp9/temp10
2997  temp_ad12 = akap*exp(akap*log(rrg*temp8))*pkz_ad(i, j, k&
2998 & )/(temp8*temp10)
2999  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*&
3000 & temp_ad12
3001  pt_ad(i, j, k) = pt_ad(i, j, k) + delp(i, j, k)*&
3002 & temp_ad12
3003  delz_ad(i, j, k) = delz_ad(i, j, k) - temp8*temp_ad12
3004  pkz_ad(i, j, k) = 0.0
3005  END DO
3006  END DO
3007  ELSE
3008  CALL popinteger(ad_to45)
3009  DO k=ad_to45,1,-1
3010  CALL popinteger(ad_from25)
3011  CALL popinteger(ad_to44)
3012  DO i=ad_to44,ad_from25,-1
3013  CALL poprealarray(pkz(i, j, k))
3014  temp13 = delz(i, j, k)
3015  temp12 = delp(i, j, k)*pt(i, j, k)
3016  temp11 = temp12/temp13
3017  temp_ad13 = k1k*exp(k1k*log(rrg*temp11))*pkz_ad(i, j, k)&
3018 & /(temp11*temp13)
3019  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*&
3020 & temp_ad13
3021  pt_ad(i, j, k) = pt_ad(i, j, k) + delp(i, j, k)*&
3022 & temp_ad13
3023  delz_ad(i, j, k) = delz_ad(i, j, k) - temp11*temp_ad13
3024  pkz_ad(i, j, k) = 0.0
3025  END DO
3026  END DO
3027  END IF
3028  END IF
3029  END IF
3030  CALL popinteger(ad_to39)
3031  DO k=ad_to39,1,-1
3032  CALL popinteger(ad_from22)
3033  CALL popinteger(ad_to38)
3034  DO i=ad_to38,ad_from22,-1
3035  CALL poprealarray(peln(i, k, j))
3036  pn2_ad(i, k) = pn2_ad(i, k) + peln_ad(i, k, j)
3037  peln_ad(i, k, j) = pe0_ad(i, k)
3038  CALL poprealarray(pe0(i, k))
3039  pe0_ad(i, k) = 0.0
3040  END DO
3041  END DO
3042  CALL popcontrol(1,branch)
3043  IF (branch .NE. 0) THEN
3044  CALL popinteger(ad_to37)
3045  DO k=ad_to37,2,-1
3046  CALL popinteger(ad_from21)
3047  CALL popinteger(ad_to36)
3048  DO i=ad_to36,ad_from21,-1
3049  CALL poprealarray(pe3(i, k))
3050  omga_ad(i, j, k-1) = omga_ad(i, j, k-1) + pe3_ad(i, k)
3051  pe3_ad(i, k) = 0.0
3052  END DO
3053  END DO
3054  CALL popinteger(ad_from20)
3055  CALL popinteger(ad_to35)
3056  DO i=ad_to35,ad_from20,-1
3057  CALL poprealarray(pe3(i, 1))
3058  pe3_ad(i, 1) = 0.0
3059  END DO
3060  END IF
3061  CALL popinteger(ad_to34)
3062  DO k=ad_to34,1,-1
3063  CALL popinteger(ad_from19)
3064  CALL popinteger(ad_to33)
3065  DO i=ad_to33,ad_from19,-1
3066  CALL poprealarray(pk(i, j, k))
3067  pk2_ad(i, k) = pk2_ad(i, k) + pk_ad(i, j, k)
3068  pk_ad(i, j, k) = 0.0
3069  END DO
3070  END DO
3071  CALL popcontrol(1,branch)
3072  IF (branch .NE. 0) THEN
3073  CALL popinteger(ad_to32)
3074  DO k=ad_to32,1,-1
3075  CALL popinteger(ad_from18)
3076  CALL popinteger(ad_to31)
3077  DO i=ad_to31,ad_from18,-1
3078  CALL poprealarray(delz(i, j, k))
3079  dp2_ad(i, k) = dp2_ad(i, k) - delz(i, j, k)*delz_ad(i, j, k)
3080  delz_ad(i, j, k) = -(dp2(i, k)*delz_ad(i, j, k))
3081  END DO
3082  END DO
3083  CALL popcontrol(1,branch)
3084  IF (branch .EQ. 0) THEN
3085  CALL poprealarray(delz, (ied-isd+1)*(jed-jsd+1)*km)
3086  gz_ad = 0.0
3087  CALL map1_ppm_adm(km, pe1, pe1_ad, gz, gz_ad, km, pe2, pe2_ad&
3088 & , delz, delz_ad, is, ie, j, isd, ied, jsd, jed, 1&
3089 & , abs_kord_tm_pert)
3090  ELSE
3091  gz_ad = 0.0
3092  CALL map1_ppm_bwd(km, pe1, pe1_ad, gz, gz_ad, km, pe2, &
3093 & pe2_ad, delz, delz_ad, is, ie, j, isd, ied, jsd&
3094 & , jed, 1, abs_kord_tm)
3095  END IF
3096  CALL popcontrol(1,branch)
3097  IF (branch .EQ. 0) THEN
3098  CALL map1_ppm_bwd(km, pe1, pe1_ad, ws(is:ie, j), ws_ad(is:&
3099 & ie, j), km, pe2, pe2_ad, w, w_ad, is, ie, j, &
3100 & isd, ied, jsd, jed, -2, kord_wz)
3101  ELSE
3102  CALL poprealarray(w, (ied-isd+1)*(jed-jsd+1)*km)
3103  CALL map1_ppm_adm(km, pe1, pe1_ad, ws(is:ie, j), ws_ad(is:ie, &
3104 & j), km, pe2, pe2_ad, w, w_ad, is, ie, j, isd, ied&
3105 & , jsd, jed, -2, kord_wz_pert)
3106  END IF
3107  END IF
3108  CALL popcontrol(2,branch)
3109  IF (branch .LT. 2) THEN
3110  IF (branch .EQ. 0) THEN
3111  CALL mapn_tracer_bwd(nq, km, pe1, pe1_ad, pe2, pe2_ad, q, &
3112 & q_ad, dp2, dp2_ad, kord_tr, j, is, ie, isd, &
3113 & ied, jsd, jed, 0., fill)
3114  ELSE
3115  CALL poprealarray(q, (ied-isd+1)*(jed-jsd+1)*km*nq)
3116  CALL mapn_tracer_adm(nq, km, pe1, pe1_ad, pe2, pe2_ad, q, q_ad&
3117 & , dp2, dp2_ad, kord_tr_pert, j, is, ie, isd, &
3118 & ied, jsd, jed, 0., fill)
3119  END IF
3120  ELSE IF (branch .EQ. 2) THEN
3121  CALL popinteger(ad_to30)
3122  DO iq=ad_to30,1,-1
3123  CALL popinteger(ad_to29)
3124  DO k=ad_to29,1,-1
3125  CALL popinteger(ad_from17)
3126  CALL popinteger(ad_to28)
3127  DO i=ad_to28,ad_from17,-1
3128  CALL poprealarray(q(i, j, k, iq))
3129  q2_ad(i, k) = q2_ad(i, k) + q_ad(i, j, k, iq)
3130  q_ad(i, j, k, iq) = 0.0
3131  END DO
3132  END DO
3133  CALL popcontrol(1,branch)
3134  IF (branch .EQ. 0) THEN
3135  CALL map1_q2_bwd(km, pe1, pe1_ad, q(isd:ied, jsd:jed, 1:&
3136 & km, iq), q_ad(isd:ied, jsd:jed, 1:km, iq), km&
3137 & , pe2, pe2_ad, q2, q2_ad, dp2, dp2_ad, is, ie&
3138 & , 0, kord_tr(iq), j, isd, ied, jsd, jed, 0.)
3139  ELSE
3140  CALL map1_q2_adm(km, pe1, pe1_ad, q(isd:ied, jsd:jed, 1:km, &
3141 & iq), q_ad(isd:ied, jsd:jed, 1:km, iq), km, pe2, &
3142 & pe2_ad, q2, q2_ad, dp2, dp2_ad, is, ie, 0, &
3143 & kord_tr_pert(iq), j, isd, ied, jsd, jed, 0.)
3144  END IF
3145  END DO
3146  END IF
3147  CALL popcontrol(3,branch)
3148  IF (branch .LT. 3) THEN
3149  IF (branch .EQ. 0) THEN
3150  CALL map_scalar_bwd(km, peln(is:ie, 1:km+1, j), peln_ad(is:&
3151 & ie, 1:km+1, j), gz, km, pn2, pn2_ad, pt, &
3152 & pt_ad, is, ie, j, isd, ied, jsd, jed, 1, &
3153 & abs_kord_tm, t_min)
3154  ELSE IF (branch .EQ. 1) THEN
3155  CALL poprealarray(pt, (ied-isd+1)*(jed-jsd+1)*km)
3156  CALL map_scalar_adm(km, peln(is:ie, 1:km+1, j), peln_ad(is:ie&
3157 & , 1:km+1, j), gz, km, pn2, pn2_ad, pt, pt_ad, is&
3158 & , ie, j, isd, ied, jsd, jed, 1, abs_kord_tm_pert&
3159 & , t_min)
3160  ELSE
3161  gz_ad = 0.0
3162  CALL map1_ppm_bwd(km, pe1, pe1_ad, gz, gz_ad, km, pe2, &
3163 & pe2_ad, pt, pt_ad, is, ie, j, isd, ied, jsd, &
3164 & jed, 1, abs_kord_tm)
3165  END IF
3166  ELSE IF (branch .EQ. 3) THEN
3167  CALL poprealarray(pt, (ied-isd+1)*(jed-jsd+1)*km)
3168  gz_ad = 0.0
3169  CALL map1_ppm_adm(km, pe1, pe1_ad, gz, gz_ad, km, pe2, pe2_ad, &
3170 & pt, pt_ad, is, ie, j, isd, ied, jsd, jed, 1, &
3171 & abs_kord_tm_pert)
3172  ELSE IF (branch .EQ. 4) THEN
3173  CALL map1_cubic_bwd(km, pe1, pe1_ad, km, pe2, pe2_ad, te, te_ad&
3174 & , is, ie, j, isd, ied, jsd, jed, akap, t_var=1, &
3175 & conserv=.true.)
3176  CALL popinteger(ad_to27)
3177  DO k=ad_to27,1,-1
3178  CALL popinteger(ad_from16)
3179  CALL popinteger(ad_to26)
3180  DO i=ad_to26,ad_from16,-1
3181  CALL poprealarray(te(i, j, k))
3182  temp6 = pe1(i, k+1) - pe1(i, k)
3183  temp_ad8 = te_ad(i, j, k)/temp6
3184  temp_ad9 = -((phis(i, k+1)-phis(i, k))*temp_ad8/temp6)
3185  phis_ad(i, k+1) = phis_ad(i, k+1) + temp_ad8
3186  phis_ad(i, k) = phis_ad(i, k) - temp_ad8
3187  pe1_ad(i, k+1) = pe1_ad(i, k+1) + temp_ad9
3188  pe1_ad(i, k) = pe1_ad(i, k) - temp_ad9
3189  END DO
3190  END DO
3191  CALL popinteger(ad_to25)
3192  DO k=ad_to25,1,-1
3193  CALL popinteger(ad_from15)
3194  CALL popinteger(ad_to24)
3195  DO i=ad_to24,ad_from15,-1
3196  CALL poprealarray(phis(i, k))
3197  pe1_ad(i, k) = pe1_ad(i, k) + phis(i, k)*phis_ad(i, k)
3198  phis_ad(i, k) = pe1(i, k)*phis_ad(i, k)
3199  END DO
3200  END DO
3201  CALL popinteger(ad_from14)
3202  DO k=1,ad_from14,1
3203  CALL popinteger(ad_from13)
3204  CALL popinteger(ad_to23)
3205  DO i=ad_to23,ad_from13,-1
3206  CALL poprealarray(phis(i, k))
3207  temp_ad7 = cp_air*pt(i, j, k)*phis_ad(i, k)
3208  phis_ad(i, k+1) = phis_ad(i, k+1) + phis_ad(i, k)
3209  pt_ad(i, j, k) = pt_ad(i, j, k) + cp_air*(pk1(i, k+1)-pk1(i&
3210 & , k))*phis_ad(i, k)
3211  pk1_ad(i, k+1) = pk1_ad(i, k+1) + temp_ad7
3212  pk1_ad(i, k) = pk1_ad(i, k) - temp_ad7
3213  phis_ad(i, k) = 0.0
3214  END DO
3215  END DO
3216  CALL popinteger(ad_from12)
3217  CALL popinteger(ad_to22)
3218  DO i=ad_to22,ad_from12,-1
3219  CALL poprealarray(phis(i, km+1))
3220  phis_ad(i, km+1) = 0.0
3221  END DO
3222  END IF
3223  CALL popinteger(ad_to21)
3224  DO k=ad_to21,2,-1
3225  CALL popinteger(ad_from11)
3226  CALL popinteger(ad_to20)
3227  DO i=ad_to20,ad_from11,-1
3228  CALL poprealarray(pk2(i, k))
3229  pn2_ad(i, k) = pn2_ad(i, k) + exp(akap*pn2(i, k))*akap*pk2_ad(&
3230 & i, k)
3231  pk2_ad(i, k) = 0.0
3232  CALL poprealarray(pn2(i, k))
3233  pe2_ad(i, k) = pe2_ad(i, k) + pn2_ad(i, k)/pe2(i, k)
3234  pn2_ad(i, k) = 0.0
3235  END DO
3236  END DO
3237  CALL popinteger(ad_from10)
3238  CALL popinteger(ad_to19)
3239  DO i=ad_to19,ad_from10,-1
3240  CALL poprealarray(pk2(i, km+1))
3241  pk1_ad(i, km+1) = pk1_ad(i, km+1) + pk2_ad(i, km+1)
3242  pk2_ad(i, km+1) = 0.0
3243  CALL poprealarray(pk2(i, 1))
3244  pk1_ad(i, 1) = pk1_ad(i, 1) + pk2_ad(i, 1)
3245  pk2_ad(i, 1) = 0.0
3246  CALL poprealarray(pn2(i, km+1))
3247  peln_ad(i, km+1, j) = peln_ad(i, km+1, j) + pn2_ad(i, km+1)
3248  pn2_ad(i, km+1) = 0.0
3249  CALL poprealarray(pn2(i, 1))
3250  peln_ad(i, 1, j) = peln_ad(i, 1, j) + pn2_ad(i, 1)
3251  pn2_ad(i, 1) = 0.0
3252  END DO
3253  CALL popinteger(ad_to18)
3254  DO k=ad_to18,1,-1
3255  CALL popinteger(ad_from9)
3256  CALL popinteger(ad_to17)
3257  DO i=ad_to17,ad_from9,-1
3258  CALL poprealarray(pk1(i, k))
3259  pk_ad(i, j, k) = pk_ad(i, j, k) + pk1_ad(i, k)
3260  pk1_ad(i, k) = 0.0
3261  END DO
3262  END DO
3263  CALL popinteger(ad_to16)
3264  DO k=ad_to16,1,-1
3265  CALL popinteger(ad_from8)
3266  CALL popinteger(ad_to15)
3267  DO i=ad_to15,ad_from8,-1
3268  CALL poprealarray(delp(i, j, k))
3269  dp2_ad(i, k) = dp2_ad(i, k) + delp_ad(i, j, k)
3270  delp_ad(i, j, k) = 0.0
3271  END DO
3272  END DO
3273  CALL popinteger(ad_to14)
3274  DO k=ad_to14,1,-1
3275  CALL popinteger(ad_from7)
3276  CALL popinteger(ad_to13)
3277  DO i=ad_to13,ad_from7,-1
3278  CALL poprealarray(dp2(i, k))
3279  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp2_ad(i, k)
3280  pe2_ad(i, k) = pe2_ad(i, k) - dp2_ad(i, k)
3281  dp2_ad(i, k) = 0.0
3282  END DO
3283  END DO
3284  CALL popinteger(ad_to12)
3285  DO k=ad_to12,2,-1
3286  CALL popinteger(ad_from6)
3287  CALL popinteger(ad_to11)
3288  DO i=ad_to11,ad_from6,-1
3289  CALL poprealarray(pe2(i, k))
3290  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + bk(k)*pe2_ad(i, k)
3291  pe2_ad(i, k) = 0.0
3292  END DO
3293  END DO
3294  CALL popinteger(ad_from5)
3295  CALL popinteger(ad_to10)
3296  DO i=ad_to10,ad_from5,-1
3297  pe1_ad(i, km+1) = pe1_ad(i, km+1) + ps_ad(i, j)
3298  ps_ad(i, j) = 0.0
3299  END DO
3300  CALL popcontrol(1,branch)
3301  IF (branch .NE. 0) THEN
3302  CALL popinteger(ad_to9)
3303  DO k=ad_to9,1,-1
3304  CALL popinteger(ad_from4)
3305  CALL popinteger(ad_to8)
3306  DO i=ad_to8,ad_from4,-1
3307  CALL poprealarray(delz(i, j, k))
3308  temp_ad6 = -(delz_ad(i, j, k)/delp(i, j, k))
3309  delp_ad(i, j, k) = delp_ad(i, j, k) - delz(i, j, k)*temp_ad6&
3310 & /delp(i, j, k)
3311  delz_ad(i, j, k) = temp_ad6
3312  END DO
3313  END DO
3314  END IF
3315  CALL popcontrol(3,branch)
3316  IF (branch .LT. 2) THEN
3317  IF (branch .EQ. 0) THEN
3318  CALL popinteger(ad_to3)
3319  DO k=ad_to3,1,-1
3320  CALL popinteger(ad_from1)
3321  CALL popinteger(ad_to2)
3322  DO i=ad_to2,ad_from1,-1
3323  CALL poprealarray(pt(i, j, k))
3324  temp1 = akap*(peln(i, k+1, j)-peln(i, k, j))
3325  temp_ad = pt_ad(i, j, k)/temp1
3326  temp0 = pk(i, j, k+1) - pk(i, j, k)
3327  temp = pt(i, j, k)
3328  temp_ad0 = -(temp*temp0*akap*temp_ad/temp1)
3329  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp*temp_ad
3330  pk_ad(i, j, k) = pk_ad(i, j, k) - temp*temp_ad
3331  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad0
3332  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad0
3333  pt_ad(i, j, k) = temp0*temp_ad
3334  END DO
3335  END DO
3336  ELSE
3337  CALL popinteger(ad_to5)
3338  DO k=ad_to5,1,-1
3339  CALL popinteger(ad_from2)
3340  CALL popinteger(ad_to4)
3341  DO i=ad_to4,ad_from2,-1
3342  CALL poprealarray(pt(i, j, k))
3343  temp5 = delz(i, j, k)
3344  temp4 = delp(i, j, k)*pt(i, j, k)
3345  temp2 = temp4/temp5
3346  temp3 = k1k*log(rrg*temp2)
3347  temp_ad1 = k1k*exp(temp3)*pt(i, j, k)*pt_ad(i, j, k)/(&
3348 & temp2*temp5)
3349  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*temp_ad1
3350  delz_ad(i, j, k) = delz_ad(i, j, k) - temp2*temp_ad1
3351  pt_ad(i, j, k) = delp(i, j, k)*temp_ad1 + exp(temp3)*pt_ad&
3352 & (i, j, k)
3353  END DO
3354  END DO
3355  END IF
3356  ELSE IF (branch .NE. 2) THEN
3357  IF (branch .EQ. 3) THEN
3358  CALL popinteger(ad_to7)
3359  DO k=ad_to7,1,-1
3360  CALL popinteger(ad_from3)
3361  CALL popinteger(ad_to6)
3362  DO i=ad_to6,ad_from3,-1
3363  CALL poprealarray(te(i, j, k))
3364  temp_ad2 = gridstruct%rsin2(i, j)*0.25*te_ad(i, j, k)
3365  temp_ad3 = -(gridstruct%cosa_s(i, j)*temp_ad2)
3366  temp_ad4 = (v(i, j, k)+v(i+1, j, k))*temp_ad3
3367  temp_ad5 = (u(i, j, k)+u(i, j+1, k))*temp_ad3
3368  u_ad(i, j, k) = u_ad(i, j, k) + temp_ad4 + 2*u(i, j, k)*&
3369 & temp_ad2
3370  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp_ad4 + 2*u(i, j+1&
3371 & , k)*temp_ad2
3372  v_ad(i, j, k) = v_ad(i, j, k) + temp_ad5 + 2*v(i, j, k)*&
3373 & temp_ad2
3374  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp_ad5 + 2*v(i+1, j&
3375 & , k)*temp_ad2
3376  pt_ad(i, j, k) = pt_ad(i, j, k) + cp_air*pkz(i, j, k)*&
3377 & te_ad(i, j, k)
3378  pkz_ad(i, j, k) = pkz_ad(i, j, k) + cp_air*pt(i, j, k)*&
3379 & te_ad(i, j, k)
3380  te_ad(i, j, k) = 0.0
3381  END DO
3382  END DO
3383  CALL pkez_bwd(km, is, ie, js, je, j, pe, pk, pk_ad, akap, peln&
3384 & , peln_ad, pkz, pkz_ad, ptop)
3385  END IF
3386  END IF
3387  140 CALL popinteger(ad_from0)
3388  CALL popinteger(ad_to1)
3389  DO i=ad_to1,ad_from0,-1
3390  CALL poprealarray(pe2(i, km+1))
3391  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + pe2_ad(i, km+1)
3392  pe2_ad(i, km+1) = 0.0
3393  CALL poprealarray(pe2(i, 1))
3394  pe2_ad(i, 1) = 0.0
3395  END DO
3396  CALL popinteger(ad_to0)
3397  DO k=ad_to0,1,-1
3398  CALL popinteger(ad_from)
3399  CALL popinteger(ad_to)
3400  DO i=ad_to,ad_from,-1
3401  CALL poprealarray(pe1(i, k))
3402  pe_ad(i, k, j) = pe_ad(i, k, j) + pe1_ad(i, k)
3403  pe1_ad(i, k) = 0.0
3404  END DO
3405  END DO
3406  150 CALL popinteger(j)
3407  END DO
3408  CALL popcontrol(1,branch)
3409  IF (branch .NE. 0) THEN
3410  CALL popinteger(ad_count)
3411  DO i0=1,ad_count
3412  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
3413  END DO
3414  END IF
3415  CALL popcontrol(1,branch)
3416  END SUBROUTINE lagrangian_to_eulerian_bwd
3417  SUBROUTINE lagrangian_to_eulerian(last_step, consv, ps, pe, delp, pkz&
3418 & , pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, &
3419 & sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, &
3420 & kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, &
3421 & te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, &
3422 & flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, &
3423 & do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, &
3424 & kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
3425  IMPLICIT NONE
3426 !$OMP end parallel
3427  LOGICAL, INTENT(IN) :: last_step
3428 ! remap time step
3429  REAL, INTENT(IN) :: mdt
3430 ! phys time step
3431  REAL, INTENT(IN) :: pdt
3432  INTEGER, INTENT(IN) :: km
3433 ! number of tracers (including h2o)
3434  INTEGER, INTENT(IN) :: nq
3435  INTEGER, INTENT(IN) :: nwat
3436 ! index for water vapor (specific humidity)
3437  INTEGER, INTENT(IN) :: sphum
3438  INTEGER, INTENT(IN) :: ng
3439 ! starting & ending X-Dir index
3440  INTEGER, INTENT(IN) :: is, ie, isd, ied
3441 ! starting & ending Y-Dir index
3442  INTEGER, INTENT(IN) :: js, je, jsd, jed
3443 ! Mapping order for the vector winds
3444  INTEGER, INTENT(IN) :: kord_mt
3445 ! Mapping order/option for w
3446  INTEGER, INTENT(IN) :: kord_wz
3447 ! Mapping order for tracers
3448  INTEGER, INTENT(IN) :: kord_tr(nq)
3449 ! Mapping order for thermodynamics
3450  INTEGER, INTENT(IN) :: kord_tm
3451 ! Mapping order for the vector winds
3452  INTEGER, INTENT(IN) :: kord_mt_pert
3453 ! Mapping order/option for w
3454  INTEGER, INTENT(IN) :: kord_wz_pert
3455 ! Mapping order for tracers
3456  INTEGER, INTENT(IN) :: kord_tr_pert(nq)
3457 ! Mapping order for thermodynamics
3458  INTEGER, INTENT(IN) :: kord_tm_pert
3459 ! factor for TE conservation
3460  REAL, INTENT(IN) :: consv
3461  REAL, INTENT(IN) :: r_vir
3462  REAL, INTENT(IN) :: cp
3463  REAL, INTENT(IN) :: akap
3464 ! surface geopotential
3465  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
3466  REAL, INTENT(INOUT) :: te0_2d(is:ie, js:je)
3467  REAL, INTENT(IN) :: ws(is:ie, js:je)
3468  LOGICAL, INTENT(IN) :: do_sat_adj
3469 ! fill negative tracers
3470  LOGICAL, INTENT(IN) :: fill
3471  LOGICAL, INTENT(IN) :: reproduce_sum
3472  LOGICAL, INTENT(IN) :: do_omega, adiabatic, do_adiabatic_init
3473  REAL, INTENT(IN) :: ptop
3474  REAL, INTENT(IN) :: ak(km+1)
3475  REAL, INTENT(IN) :: bk(km+1)
3476  REAL, INTENT(IN) :: pfull(km)
3477  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3478  TYPE(fv_flags_type), INTENT(INOUT) :: flagstruct
3479  TYPE(domain2d), INTENT(INOUT) :: domain
3480 ! !INPUT/OUTPUT
3481 ! pe to the kappa
3482  REAL, INTENT(INOUT) :: pk(is:ie, js:je, km+1)
3483  REAL, INTENT(INOUT) :: q(isd:ied, jsd:jed, km, nq)
3484 ! pressure thickness
3485  REAL, INTENT(INOUT) :: delp(isd:ied, jsd:jed, km)
3486 ! pressure at layer edges
3487  REAL, INTENT(INOUT) :: pe(is-1:ie+1, km+1, js-1:je+1)
3488 ! surface pressure
3489  REAL, INTENT(INOUT) :: ps(isd:ied, jsd:jed)
3490 ! u-wind will be ghosted one latitude to the north upon exit
3491 ! u-wind (m/s)
3492  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
3493 ! v-wind (m/s)
3494  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
3495 ! vertical velocity (m/s)
3496  REAL, INTENT(INOUT) :: w(isd:ied, jsd:jed, km)
3497 ! cp*virtual potential temperature
3498  REAL, INTENT(INOUT) :: pt(isd:ied, jsd:jed, km)
3499 ! as input; output: temperature
3500  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz
3501  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: q_con, cappa
3502  LOGICAL, INTENT(IN) :: hydrostatic
3503  LOGICAL, INTENT(IN) :: hybrid_z
3504  LOGICAL, INTENT(IN) :: out_dt
3505 ! u-wind (m/s) on physics grid
3506  REAL, INTENT(INOUT) :: ua(isd:ied, jsd:jed, km)
3507 ! v-wind (m/s) on physics grid
3508  REAL, INTENT(INOUT) :: va(isd:ied, jsd:jed, km)
3509 ! vertical press. velocity (pascal/sec)
3510  REAL, INTENT(INOUT) :: omga(isd:ied, jsd:jed, km)
3511 ! log(pe)
3512  REAL, INTENT(INOUT) :: peln(is:ie, km+1, js:je)
3513  REAL, INTENT(INOUT) :: dtdt(is:ie, js:je, km)
3514 ! layer-mean pk for converting t to pt
3515  REAL, INTENT(OUT) :: pkz(is:ie, js:je, km)
3516  REAL, INTENT(OUT) :: te(isd:ied, jsd:jed, km)
3517 ! Mass fluxes
3518 ! X-dir Mass Flux
3519  REAL, OPTIONAL, INTENT(INOUT) :: mfx(is:ie+1, js:je, km)
3520 ! Y-dir Mass Flux
3521  REAL, OPTIONAL, INTENT(INOUT) :: mfy(is:ie, js:je+1, km)
3522 ! 0: remap T in logP
3523  INTEGER, INTENT(IN) :: remap_option
3524 ! 1: remap PT in P
3525 ! 3: remap TE in logP with GMAO cubic
3526 ! !DESCRIPTION:
3527 !
3528 ! !REVISION HISTORY:
3529 ! SJL 03.11.04: Initial version for partial remapping
3530 !
3531 !-----------------------------------------------------------------------
3532  REAL, DIMENSION(is:ie, js:je) :: te_2d, zsum0, zsum1, dpln
3533  REAL, DIMENSION(is:ie, km) :: q2, dp2
3534  REAL, DIMENSION(is:ie, km+1) :: pe1, pe2, pk1, pk2, pn2, phis
3535  REAL, DIMENSION(is:ie+1, km+1) :: pe0, pe3
3536  REAL, DIMENSION(is:ie) :: gz, cvm, qv
3537  REAL :: rcp, rg, tmp, tpe, rrg, bkh, dtmp, k1k, dlnp
3538  LOGICAL :: fast_mp_consv
3539  INTEGER :: i, j, k
3540  INTEGER :: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel&
3541 & , iq, n, kmp, kp, k_next
3542  LOGICAL :: remap_t, remap_pt, remap_te
3543  INTEGER :: abs_kord_tm, abs_kord_tm_pert
3544  INTEGER :: iep1, jep1, iedp1, jedp1
3545  INTRINSIC abs
3546  INTRINSIC log
3547  INTRINSIC exp
3548  INTRINSIC PRESENT
3549  REAL :: abs0
3550  INTEGER :: arg1
3551  REAL :: result1
3552  LOGICAL :: arg10
3553  IF (kord_tm .GE. 0.) THEN
3554  abs_kord_tm = kord_tm
3555  ELSE
3556  abs_kord_tm = -kord_tm
3557  END IF
3558  IF (kord_tm_pert .GE. 0.) THEN
3559  abs_kord_tm_pert = kord_tm_pert
3560  ELSE
3561  abs_kord_tm_pert = -kord_tm_pert
3562  END IF
3563  iep1 = ie + 1
3564  jep1 = je + 1
3565  iedp1 = ied + 1
3566  jedp1 = jed + 1
3567  remap_t = .false.
3568  remap_pt = .false.
3569  remap_te = .false.
3570  SELECT CASE (remap_option)
3571  CASE (0)
3572  remap_t = .true.
3573  CASE (1)
3574  remap_pt = .true.
3575  CASE (2)
3576  remap_te = .true.
3577  CASE DEFAULT
3578  print*, ' INVALID REMAPPING OPTION '
3579  stop
3580  END SELECT
3581  IF (is_master() .AND. flagstruct%fv_debug) THEN
3582  print*, ''
3583  SELECT CASE (remap_option)
3584  CASE (0)
3585  print*, ' REMAPPING T in logP '
3586  CASE (1)
3587  print*, ' REMAPPING PT in P'
3588  CASE (2)
3589  print*, ' REMAPPING TE in logP with GMAO cubic'
3590  END SELECT
3591  print*, ' REMAPPING CONSV: ', consv
3592  print*, ' REMAPPING CONSV_MIN: ', consv_min
3593  print*, ''
3594  END IF
3595  IF (flagstruct%fv_debug) CALL prt_mxm('remap-0 PT', pt, is, ie, js&
3596 & , je, ng, km, 1., gridstruct%area_64&
3597 & , domain)
3598 ! akap / (1.-akap) = rg/Cv=0.4
3599  k1k = rdgas/cv_air
3600  rg = rdgas
3601  rcp = 1./cp
3602  rrg = -(rdgas/grav)
3603  IF (fpp%fpp_mapl_mode) THEN
3604  liq_wat = 2
3605  ice_wat = 3
3606  rainwat = -1
3607  snowwat = -1
3608  graupel = -1
3609  cld_amt = -1
3610  ELSE
3611  liq_wat = get_tracer_index(model_atmos, 'liq_wat')
3612  ice_wat = get_tracer_index(model_atmos, 'ice_wat')
3613  rainwat = get_tracer_index(model_atmos, 'rainwat')
3614  snowwat = get_tracer_index(model_atmos, 'snowwat')
3615  graupel = get_tracer_index(model_atmos, 'graupel')
3616  cld_amt = get_tracer_index(model_atmos, 'cld_amt')
3617  END IF
3618  IF (do_sat_adj) THEN
3619  fast_mp_consv = .NOT.do_adiabatic_init .AND. consv .GT. consv_min
3620  DO k=1,km
3621  kmp = k
3622  IF (pfull(k) .GT. 10.e2) GOTO 100
3623  END DO
3624  100 CALL qs_init(kmp)
3625  END IF
3626 !$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, &
3627 !$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, &
3628 !$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, &
3629 !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, &
3630 !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, &
3631 !$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,ua) &
3632 !$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, &
3633 !$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2)
3634  DO j=js,je+1
3635  DO k=1,km+1
3636  DO i=is,ie
3637  pe1(i, k) = pe(i, k, j)
3638  END DO
3639  END DO
3640  DO i=is,ie
3641  pe2(i, 1) = ptop
3642  pe2(i, km+1) = pe(i, km+1, j)
3643  END DO
3644 !(j < je+1)
3645  IF (j .NE. je + 1) THEN
3646  IF (remap_t) THEN
3647 ! hydro test
3648 ! Remap T in logP
3649 ! Note: pt at this stage is Theta_v
3650  IF (hydrostatic) THEN
3651 ! Transform virtual pt to virtual Temp
3652  DO k=1,km
3653  DO i=is,ie
3654  pt(i, j, k) = pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k))/(&
3655 & akap*(peln(i, k+1, j)-peln(i, k, j)))
3656  END DO
3657  END DO
3658  ELSE
3659 ! Transform "density pt" to "density temp"
3660  DO k=1,km
3661  DO i=is,ie
3662  pt(i, j, k) = pt(i, j, k)*exp(k1k*log(rrg*delp(i, j, k)/&
3663 & delz(i, j, k)*pt(i, j, k)))
3664  END DO
3665  END DO
3666  END IF
3667  ELSE IF (.NOT.remap_pt) THEN
3668 ! Using dry pressure for the definition of the virtual potential temperature
3669 ! pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)* &
3670 ! pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
3671 ! Remap PT in P
3672 ! pt is already virtual PT
3673  IF (remap_te) THEN
3674 ! Remap TE in logP
3675 ! Transform virtual pt to total energy
3676  CALL pkez(km, is, ie, js, je, j, pe, pk, akap, peln, pkz, &
3677 & ptop)
3678 ! Compute cp*T + KE
3679  DO k=1,km
3680  DO i=is,ie
3681  te(i, j, k) = 0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2&
3682 & +u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j&
3683 & , k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
3684 & gridstruct%cosa_s(i, j)) + cp_air*pt(i, j, k)*pkz(i, j&
3685 & , k)
3686  END DO
3687  END DO
3688  END IF
3689  END IF
3690  IF (.NOT.hydrostatic) THEN
3691  DO k=1,km
3692  DO i=is,ie
3693 ! ="specific volume"/grav
3694  delz(i, j, k) = -(delz(i, j, k)/delp(i, j, k))
3695  END DO
3696  END DO
3697  END IF
3698 ! update ps
3699  DO i=is,ie
3700  ps(i, j) = pe1(i, km+1)
3701  END DO
3702 !
3703 ! Hybrid sigma-P coordinate:
3704 !
3705  DO k=2,km
3706  DO i=is,ie
3707  pe2(i, k) = ak(k) + bk(k)*pe(i, km+1, j)
3708  END DO
3709  END DO
3710  DO k=1,km
3711  DO i=is,ie
3712  dp2(i, k) = pe2(i, k+1) - pe2(i, k)
3713  END DO
3714  END DO
3715 !------------
3716 ! update delp
3717 !------------
3718  DO k=1,km
3719  DO i=is,ie
3720  delp(i, j, k) = dp2(i, k)
3721  END DO
3722  END DO
3723 !------------------
3724 ! Compute p**Kappa
3725 !------------------
3726  DO k=1,km+1
3727  DO i=is,ie
3728  pk1(i, k) = pk(i, j, k)
3729  END DO
3730  END DO
3731  DO i=is,ie
3732  pn2(i, 1) = peln(i, 1, j)
3733  pn2(i, km+1) = peln(i, km+1, j)
3734  pk2(i, 1) = pk1(i, 1)
3735  pk2(i, km+1) = pk1(i, km+1)
3736  END DO
3737  DO k=2,km
3738  DO i=is,ie
3739  pn2(i, k) = log(pe2(i, k))
3740  pk2(i, k) = exp(akap*pn2(i, k))
3741  END DO
3742  END DO
3743  IF (remap_t) THEN
3744 !----------------------------------
3745 ! Map t using logp
3746 !----------------------------------
3747  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
3748  CALL map_scalar(km, peln(is:ie, 1:km+1, j), gz, km, pn2, &
3749 & pt, is, ie, j, isd, ied, jsd, jed, 1, &
3750 & abs_kord_tm, t_min)
3751  ELSE
3752  CALL map_scalar(km, peln(is:ie, 1:km+1, j), gz, km, pn2, pt&
3753 & , is, ie, j, isd, ied, jsd, jed, 1, &
3754 & abs_kord_tm_pert, t_min)
3755  END IF
3756  ELSE IF (remap_pt) THEN
3757 !----------------------------------
3758 ! Map pt using pe
3759 !----------------------------------
3760  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
3761  CALL map1_ppm(km, pe1, gz, km, pe2, pt, is, ie, j, isd, &
3762 & ied, jsd, jed, 1, abs_kord_tm)
3763  ELSE
3764  CALL map1_ppm(km, pe1, gz, km, pe2, pt, is, ie, j, isd, ied&
3765 & , jsd, jed, 1, abs_kord_tm_pert)
3766  END IF
3767  ELSE IF (remap_te) THEN
3768 !----------------------------------
3769 ! map Total Energy using GMAO cubic
3770 !----------------------------------
3771  DO i=is,ie
3772  phis(i, km+1) = hs(i, j)
3773  END DO
3774  DO k=km,1,-1
3775  DO i=is,ie
3776  phis(i, k) = phis(i, k+1) + cp_air*pt(i, j, k)*(pk1(i, k+1&
3777 & )-pk1(i, k))
3778  END DO
3779  END DO
3780  DO k=1,km+1
3781  DO i=is,ie
3782  phis(i, k) = phis(i, k)*pe1(i, k)
3783  END DO
3784  END DO
3785  DO k=1,km
3786  DO i=is,ie
3787  te(i, j, k) = te(i, j, k) + (phis(i, k+1)-phis(i, k))/(pe1&
3788 & (i, k+1)-pe1(i, k))
3789  END DO
3790  END DO
3791 ! Map te using log P in GMAO cubic
3792  CALL map1_cubic(km, pe1, km, pe2, te, is, ie, j, isd, ied, jsd&
3793 & , jed, akap, 1, .true.)
3794  END IF
3795 !----------------
3796 ! Map constituents
3797 !----------------
3798  IF (nq .GT. 5) THEN
3799  IF (kord_tr(1) .EQ. kord_tr_pert(1)) THEN
3800  CALL mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, is&
3801 & , ie, isd, ied, jsd, jed, 0., fill)
3802  ELSE
3803  CALL mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr_pert, j, &
3804 & is, ie, isd, ied, jsd, jed, 0., fill)
3805  END IF
3806  ELSE IF (nq .GT. 0) THEN
3807 ! Remap one tracer at a time
3808  DO iq=1,nq
3809  IF (kord_tr(iq) .EQ. kord_tr_pert(iq)) THEN
3810  CALL map1_q2(km, pe1, q(isd:ied, jsd:jed, 1:km, iq), km&
3811 & , pe2, q2, dp2, is, ie, 0, kord_tr(iq), j, isd, &
3812 & ied, jsd, jed, 0.)
3813  ELSE
3814  CALL map1_q2(km, pe1, q(isd:ied, jsd:jed, 1:km, iq), km, &
3815 & pe2, q2, dp2, is, ie, 0, kord_tr_pert(iq), j, isd, &
3816 & ied, jsd, jed, 0.)
3817  END IF
3818  IF (fill) THEN
3819  arg1 = ie - is + 1
3820  CALL fillz(arg1, km, 1, q2, dp2)
3821  END IF
3822  DO k=1,km
3823  DO i=is,ie
3824  q(i, j, k, iq) = q2(i, k)
3825  END DO
3826  END DO
3827  END DO
3828  END IF
3829  IF (.NOT.hydrostatic) THEN
3830 ! Remap vertical wind:
3831  IF (kord_wz .EQ. kord_wz_pert) THEN
3832  CALL map1_ppm(km, pe1, ws(is:ie, j), km, pe2, w, is, ie, &
3833 & j, isd, ied, jsd, jed, -2, kord_wz)
3834  ELSE
3835  CALL map1_ppm(km, pe1, ws(is:ie, j), km, pe2, w, is, ie, j, &
3836 & isd, ied, jsd, jed, -2, kord_wz_pert)
3837  END IF
3838 ! Remap delz for hybrid sigma-p coordinate
3839  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
3840  CALL map1_ppm(km, pe1, gz, km, pe2, delz, is, ie, j, isd&
3841 & , ied, jsd, jed, 1, abs_kord_tm)
3842  ELSE
3843  CALL map1_ppm(km, pe1, gz, km, pe2, delz, is, ie, j, isd, &
3844 & ied, jsd, jed, 1, abs_kord_tm_pert)
3845  END IF
3846  DO k=1,km
3847  DO i=is,ie
3848  delz(i, j, k) = -(delz(i, j, k)*dp2(i, k))
3849  END DO
3850  END DO
3851  END IF
3852 !----------
3853 ! Update pk
3854 !----------
3855  DO k=1,km+1
3856  DO i=is,ie
3857  pk(i, j, k) = pk2(i, k)
3858  END DO
3859  END DO
3860 !----------------
3861  IF (do_omega) THEN
3862 ! Start do_omega
3863 ! Copy omega field to pe3
3864  DO i=is,ie
3865  pe3(i, 1) = 0.
3866  END DO
3867  DO k=2,km+1
3868  DO i=is,ie
3869  pe3(i, k) = omga(i, j, k-1)
3870  END DO
3871  END DO
3872  END IF
3873  DO k=1,km+1
3874  DO i=is,ie
3875  pe0(i, k) = peln(i, k, j)
3876  peln(i, k, j) = pn2(i, k)
3877  END DO
3878  END DO
3879 !------------
3880 ! Compute pkz
3881 !------------
3882  IF (hydrostatic) THEN
3883  DO k=1,km
3884  DO i=is,ie
3885  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1&
3886 & , j)-peln(i, k, j)))
3887  END DO
3888  END DO
3889  ELSE IF (remap_te) THEN
3890 ! WMP: note that this is where TE remapping non-hydrostatic is invalid and cannot be run
3891  print*, &
3892 & 'TE remapping non-hydrostatic is invalid and cannot be run'
3893  stop
3894  ELSE IF (remap_t) THEN
3895 ! Note: pt at this stage is T_v or T_m
3896  DO k=1,km
3897  DO i=is,ie
3898  pkz(i, j, k) = exp(akap*log(rrg*delp(i, j, k)/delz(i, j, k&
3899 & )*pt(i, j, k)))
3900  END DO
3901  END DO
3902  ELSE
3903 ! Using dry pressure for the definition of the virtual potential temperature
3904 ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
3905 ! Note: pt at this stage is Theta_v
3906  DO k=1,km
3907  DO i=is,ie
3908  pkz(i, j, k) = exp(k1k*log(rrg*delp(i, j, k)/delz(i, j, k)&
3909 & *pt(i, j, k)))
3910  END DO
3911  END DO
3912  END IF
3913 ! end do_omega
3914 ! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
3915  IF (do_omega) THEN
3916  DO k=1,km
3917  DO i=is,ie
3918  dp2(i, k) = 0.5*(peln(i, k, j)+peln(i, k+1, j))
3919  END DO
3920  END DO
3921  DO i=is,ie
3922  k_next = 1
3923  DO 110 n=1,km
3924  kp = k_next
3925  DO k=kp,km
3926  IF (dp2(i, n) .LE. pe0(i, k+1) .AND. dp2(i, n) .GE. pe0(&
3927 & i, k)) THEN
3928  omga(i, j, n) = pe3(i, k) + (pe3(i, k+1)-pe3(i, k))*(&
3929 & dp2(i, n)-pe0(i, k))/(pe0(i, k+1)-pe0(i, k))
3930  k_next = k
3931  GOTO 110
3932  END IF
3933  END DO
3934  110 CONTINUE
3935  END DO
3936  END IF
3937  END IF
3938  DO i=is,ie+1
3939  pe0(i, 1) = pe(i, 1, j)
3940  END DO
3941 !------
3942 ! map u
3943 !------
3944  DO k=2,km+1
3945  DO i=is,ie
3946  pe0(i, k) = 0.5*(pe(i, k, j-1)+pe1(i, k))
3947  END DO
3948  END DO
3949  DO k=1,km+1
3950  bkh = 0.5*bk(k)
3951  DO i=is,ie
3952  pe3(i, k) = ak(k) + bkh*(pe(i, km+1, j-1)+pe1(i, km+1))
3953  END DO
3954  END DO
3955  IF (kord_mt .EQ. kord_mt_pert) THEN
3956  CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:ie, :), u, is&
3957 & , ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
3958  ELSE
3959  CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:ie, :), u, is, &
3960 & ie, j, isd, ied, jsd, jedp1, -1, kord_mt_pert)
3961  END IF
3962  IF (PRESENT(mfy)) CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:&
3963 & ie, :), mfy, is, ie, j, is, ie, js, jep1&
3964 & , -1, kord_mt)
3965 ! (j < je+1)
3966  IF (j .LT. je + 1) THEN
3967 !------
3968 ! map v
3969 !------
3970  DO i=is,ie+1
3971  pe3(i, 1) = ak(1)
3972  END DO
3973  DO k=2,km+1
3974  bkh = 0.5*bk(k)
3975  DO i=is,ie+1
3976  pe0(i, k) = 0.5*(pe(i-1, k, j)+pe(i, k, j))
3977  pe3(i, k) = ak(k) + bkh*(pe(i-1, km+1, j)+pe(i, km+1, j))
3978  END DO
3979  END DO
3980  IF (kord_mt .EQ. kord_mt_pert) THEN
3981  CALL map1_ppm(km, pe0, gz, km, pe3, v, is, iep1, j, isd, &
3982 & iedp1, jsd, jed, -1, kord_mt)
3983  ELSE
3984  CALL map1_ppm(km, pe0, gz, km, pe3, v, is, iep1, j, isd, iedp1&
3985 & , jsd, jed, -1, kord_mt_pert)
3986  END IF
3987  IF (PRESENT(mfx)) CALL map1_ppm(km, pe0, gz, km, pe3, mfx, is, &
3988 & iep1, j, is, iep1, js, je, -1, kord_mt&
3989 & )
3990  END IF
3991  DO k=1,km
3992  DO i=is,ie
3993  ua(i, j, k) = pe2(i, k+1)
3994  END DO
3995  END DO
3996  END DO
3997 !$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, &
3998 !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, &
3999 !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, &
4000 !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, &
4001 !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, &
4002 !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, &
4003 !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, &
4004 !$OMP fast_mp_consv,kord_tm) &
4005 !$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,tpe,tmp, dpln)
4006 !$OMP do
4007  DO k=2,km
4008  DO j=js,je
4009  DO i=is,ie
4010  pe(i, k, j) = ua(i, j, k-1)
4011  END DO
4012  END DO
4013  END DO
4014  IF (flagstruct%fv_debug) THEN
4015  IF (kord_tm .LT. 0) THEN
4016  CALL prt_mxm('remap-1 TV', pt, is, ie, js, je, ng, km, 1., &
4017 & gridstruct%area_64, domain)
4018  ELSE
4019  CALL prt_mxm('remap-1 PT', pt, is, ie, js, je, ng, km, 1., &
4020 & gridstruct%area_64, domain)
4021  END IF
4022  END IF
4023  dtmp = 0.
4024 ! end last_step check
4025  IF (last_step .AND. (.NOT.do_adiabatic_init)) THEN
4026 ! end consv check
4027  IF (consv .GT. consv_min) THEN
4028 !$OMP do
4029  DO j=js,je
4030  IF (remap_t) THEN
4031 ! end non-hydro
4032  IF (hydrostatic) THEN
4033  DO i=is,ie
4034  gz(i) = hs(i, j)
4035  DO k=1,km
4036  gz(i) = gz(i) + rg*pt(i, j, k)*(peln(i, k+1, j)-peln(i&
4037 & , k, j))
4038  END DO
4039  END DO
4040  DO i=is,ie
4041  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
4042 & )
4043  END DO
4044  DO k=1,km
4045  DO i=is,ie
4046  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*pt(i, j&
4047 & , k)+0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i&
4048 & , j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, &
4049 & k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
4050 & gridstruct%cosa_s(i, j)))
4051  END DO
4052  END DO
4053  ELSE
4054  DO i=is,ie
4055  te_2d(i, j) = 0.
4056  phis(i, km+1) = hs(i, j)
4057  END DO
4058  DO k=km,1,-1
4059  DO i=is,ie
4060  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
4061  END DO
4062  END DO
4063  DO k=1,km
4064  DO i=is,ie
4065  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
4066 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
4067 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
4068 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
4069 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
4070 & i+1, j, k))*gridstruct%cosa_s(i, j))))
4071  END DO
4072  END DO
4073  END IF
4074  ELSE IF (remap_pt) THEN
4075 ! k-loop
4076  IF (hydrostatic) THEN
4077  DO i=is,ie
4078  gz(i) = hs(i, j)
4079  DO k=1,km
4080  gz(i) = gz(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i&
4081 & , j, k))
4082  END DO
4083  END DO
4084  DO i=is,ie
4085  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
4086 & )
4087  END DO
4088  DO k=1,km
4089  DO i=is,ie
4090  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp_air*pt(i&
4091 & , j, k)*pkz(i, j, k)+0.25*gridstruct%rsin2(i, j)*(u(&
4092 & i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, &
4093 & k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j&
4094 & , k))*gridstruct%cosa_s(i, j)))
4095  END DO
4096  END DO
4097  ELSE
4098 !-----------------
4099 ! Non-hydrostatic:
4100 !-----------------
4101  DO i=is,ie
4102  phis(i, km+1) = hs(i, j)
4103  DO k=km,1,-1
4104  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
4105  END DO
4106  END DO
4107  DO i=is,ie
4108  te_2d(i, j) = 0.
4109  END DO
4110  DO k=1,km
4111  DO i=is,ie
4112  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
4113 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
4114 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
4115 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
4116 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
4117 & i+1, j, k))*gridstruct%cosa_s(i, j))))
4118  END DO
4119  END DO
4120  END IF
4121  ELSE IF (remap_te) THEN
4122  DO i=is,ie
4123  te_2d(i, j) = te(i, j, 1)*delp(i, j, 1)
4124  END DO
4125  DO k=2,km
4126  DO i=is,ie
4127  te_2d(i, j) = te_2d(i, j) + te(i, j, k)*delp(i, j, k)
4128  END DO
4129  END DO
4130  END IF
4131  DO i=is,ie
4132  te_2d(i, j) = te0_2d(i, j) - te_2d(i, j)
4133  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
4134  END DO
4135  DO k=2,km
4136  DO i=is,ie
4137  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
4138  END DO
4139  END DO
4140  IF (hydrostatic) THEN
4141  DO i=is,ie
4142  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
4143 & , j)
4144  END DO
4145  END IF
4146  END DO
4147 ! j-loop
4148 !$OMP single
4149  result1 = g_sum(domain, te_2d, is, ie, js, je, ng, gridstruct%&
4150 & area_64, 0, .true.)
4151  tpe = consv*result1
4152 ! unit: W/m**2
4153  e_flux = tpe/(grav*pdt*4.*pi*radius**2)
4154 ! Note pdt is "phys" time step
4155  IF (hydrostatic) THEN
4156  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
4157 & area_64, 0, .true.)
4158  dtmp = tpe/(cp*result1)
4159  ELSE
4160  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
4161 & area_64, 0, .true.)
4162  dtmp = tpe/(cv_air*result1)
4163  END IF
4164  ELSE IF (consv .LT. -consv_min) THEN
4165 !$OMP end single
4166 !$OMP do
4167  DO j=js,je
4168  DO i=is,ie
4169  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
4170  END DO
4171  DO k=2,km
4172  DO i=is,ie
4173  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
4174  END DO
4175  END DO
4176  IF (hydrostatic) THEN
4177  DO i=is,ie
4178  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
4179 & , j)
4180  END DO
4181  END IF
4182  END DO
4183  e_flux = consv
4184 !$OMP single
4185  IF (hydrostatic) THEN
4186  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
4187 & area_64, 0, .true.)
4188  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cp*result1)
4189  ELSE
4190  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
4191 & area_64, 0, .true.)
4192  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cv_air*result1)
4193  END IF
4194  END IF
4195  END IF
4196 !$OMP end single
4197 ! do_sat_adj
4198 ! Note: pt at this stage is T_v
4199  IF (remap_t .AND. (.NOT.do_adiabatic_init) .AND. do_sat_adj) THEN
4200 ! if ( do_sat_adj ) then
4201  CALL timing_on('sat_adj2')
4202 !$OMP do
4203  DO k=kmp,km
4204  DO j=js,je
4205  DO i=is,ie
4206  dpln(i, j) = peln(i, k+1, j) - peln(i, k, j)
4207  END DO
4208  END DO
4209  IF (mdt .GE. 0.) THEN
4210  abs0 = mdt
4211  ELSE
4212  abs0 = -mdt
4213  END IF
4214  arg10 = cld_amt .GT. 0
4215  CALL fv_sat_adj(abs0, r_vir, is, ie, js, je, ng, hydrostatic, &
4216 & fast_mp_consv, te(isd:ied, jsd:jed, k), q(isd:ied, jsd&
4217 & :jed, k, sphum), q(isd:ied, jsd:jed, k, liq_wat), q(&
4218 & isd:ied, jsd:jed, k, ice_wat), q(isd:ied, jsd:jed, k, &
4219 & rainwat), q(isd:ied, jsd:jed, k, snowwat), q(isd:ied, &
4220 & jsd:jed, k, graupel), dpln, delz(isd:ied, jsd:jed, k)&
4221 & , pt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k), &
4222 & q_con(isd:ied, jsd:jed, k), cappa(isd:ied, jsd:jed, k)&
4223 & , gridstruct%area_64, dtdt(is:ie, js:je, k), out_dt, &
4224 & last_step, arg10, q(isd:ied, jsd:jed, k, cld_amt))
4225  IF (.NOT.hydrostatic) THEN
4226  DO j=js,je
4227  DO i=is,ie
4228  pkz(i, j, k) = exp(akap*log(rrg*delp(i, j, k)/delz(i, j, k&
4229 & )*pt(i, j, k)))
4230  END DO
4231  END DO
4232  END IF
4233  END DO
4234 ! OpenMP k-loop
4235  IF (fast_mp_consv) THEN
4236 !$OMP do
4237  DO j=js,je
4238  DO i=is,ie
4239  DO k=kmp,km
4240  te0_2d(i, j) = te0_2d(i, j) + te(i, j, k)
4241  END DO
4242  END DO
4243  END DO
4244  END IF
4245  CALL timing_off('sat_adj2')
4246  END IF
4247 ! last_step
4248  IF (last_step) THEN
4249 ! Output temperature if last_step
4250  IF (remap_t) THEN
4251 !$OMP do
4252  DO k=1,km
4253  DO j=js,je
4254  IF (.NOT.adiabatic) THEN
4255  DO i=is,ie
4256  pt(i, j, k) = (pt(i, j, k)+dtmp*pkz(i, j, k))/(1.+r_vir*&
4257 & q(i, j, k, sphum))
4258  END DO
4259  END IF
4260  END DO
4261  END DO
4262  ELSE IF (remap_pt) THEN
4263 ! j-loop
4264 ! k-loop
4265 !$OMP do
4266  DO k=1,km
4267  DO j=js,je
4268  DO i=is,ie
4269  pt(i, j, k) = (pt(i, j, k)+dtmp)*pkz(i, j, k)/(1.+r_vir*q(&
4270 & i, j, k, sphum))
4271  END DO
4272  END DO
4273  END DO
4274  ELSE IF (remap_te) THEN
4275 !$OMP do
4276  DO j=js,je
4277  DO i=is,ie
4278  gz(i) = hs(i, j)
4279  END DO
4280  DO k=km,1,-1
4281  DO i=is,ie
4282  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
4283 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
4284 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
4285 & gridstruct%cosa_s(i, j))
4286  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
4287  tmp = tpe/((cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+r_vir*q&
4288 & (i, j, k, sphum)))
4289  pt(i, j, k) = tmp + dtmp*pkz(i, j, k)/(1.+r_vir*q(i, j, k&
4290 & , sphum))
4291  gz(i) = gz(i) + dlnp*tmp*(1.+r_vir*q(i, j, k, sphum))
4292  END DO
4293  END DO
4294  END DO
4295  END IF
4296 ! end k-loop
4297  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 TA', pt, is, ie, &
4298 & js, je, ng, km, 1., gridstruct%&
4299 & area_64, domain)
4300  ELSE
4301 ! not last_step
4302  IF (remap_t) THEN
4303 !$OMP do
4304  DO k=1,km
4305  DO j=js,je
4306  DO i=is,ie
4307  pt(i, j, k) = pt(i, j, k)/pkz(i, j, k)
4308  END DO
4309  END DO
4310  END DO
4311  ELSE IF (remap_te) THEN
4312 !$OMP do
4313  DO j=js,je
4314  DO i=is,ie
4315  gz(i) = hs(i, j)
4316  END DO
4317  DO k=km,1,-1
4318  DO i=is,ie
4319  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
4320 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
4321 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
4322 & gridstruct%cosa_s(i, j))
4323  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
4324  tmp = tpe/(cp-pe(i, k, j)*dlnp/delp(i, j, k))
4325  pt(i, j, k) = tmp/pkz(i, j, k) + dtmp
4326  gz(i) = gz(i) + dlnp*tmp
4327  END DO
4328  END DO
4329  END DO
4330  END IF
4331 ! end k-loop
4332  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 PT', pt, is, ie, &
4333 & js, je, ng, km, 1., gridstruct%&
4334 & area_64, domain)
4335  END IF
4336  END SUBROUTINE lagrangian_to_eulerian
4337 ! Differentiation of compute_total_energy in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4
4338 !a2b_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe
4339 ! dyn_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_
4340 !core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mo
4341 !d.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_m
4342 !od.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_m
4343 !apz_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.
4344 !remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm
4345 !_limiters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_
4346 !cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod
4347 !.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d
4348 ! nh_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver n
4349 !h_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh
4350 !_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_c
4351 !ore_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_
4352 !mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d_f
4353 !b tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_
4354 !grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
4355 ! gradient of useful results: qc peln q u v w teq delp delz
4356 ! te_2d pe pt
4357 ! with respect to varying inputs: qc peln q u v w delp delz pe
4358 ! pt
4359  SUBROUTINE compute_total_energy_fwd(is, ie, js, je, isd, ied, jsd, jed&
4360 & , km, u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, &
4361 & cosa_s_l, r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, &
4362 & sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, &
4363 & id_te)
4364  IMPLICIT NONE
4365 !------------------------------------------------------
4366 ! Compute vertically integrated total energy per column
4367 !------------------------------------------------------
4368 ! !INPUT PARAMETERS:
4369  INTEGER, INTENT(IN) :: km, is, ie, js, je, isd, ied, jsd, jed, id_te
4370  INTEGER, INTENT(IN) :: sphum, liq_wat, ice_wat, rainwat, snowwat, &
4371 & graupel, nwat
4372  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: ua, va
4373  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt, delp
4374  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q
4375  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc
4376  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
4377  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
4378 ! vertical velocity (m/s)
4379  REAL, INTENT(IN) :: w(isd:ied, jsd:jed, km)
4380  REAL, INTENT(IN) :: delz(isd:ied, jsd:jed, km)
4381 ! surface geopotential
4382  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
4383 ! pressure at layer edges
4384  REAL, INTENT(IN) :: pe(is-1:ie+1, km+1, js-1:je+1)
4385 ! log(pe)
4386  REAL, INTENT(IN) :: peln(is:ie, km+1, js:je)
4387  REAL, INTENT(IN) :: cp, rg, r_vir, hlv
4388  REAL, INTENT(IN) :: rsin2_l(isd:ied, jsd:jed)
4389  REAL, INTENT(IN) :: cosa_s_l(isd:ied, jsd:jed)
4390  LOGICAL, INTENT(IN) :: moist_phys, hydrostatic
4391 ! Output:
4392 ! vertically integrated TE
4393  REAL :: te_2d(is:ie, js:je)
4394 ! Moist TE
4395  REAL :: teq(is:ie, js:je)
4396 ! Local
4397  REAL, DIMENSION(is:ie, km) :: tv
4398  REAL :: phiz(is:ie, km+1)
4399  REAL :: cvm(is:ie), qd(is:ie)
4400  INTEGER :: i, j, k
4401 
4402  tv = 0.0
4403  phiz = 0.0
4404  cvm = 0.0
4405  qd = 0.0
4406 
4407 !----------------------
4408 ! Output lat-lon winds:
4409 !----------------------
4410 ! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, flagstruct%c2l_ord)
4411 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,rg,peln,te_2d, &
4412 !$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, &
4413 !$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum) &
4414 !$OMP private(phiz, tv, cvm, qd)
4415  DO j=js,je
4416  IF (hydrostatic) THEN
4417  DO i=is,ie
4418  CALL pushrealarray(phiz(i, km+1))
4419  phiz(i, km+1) = hs(i, j)
4420  END DO
4421  DO k=km,1,-1
4422  DO i=is,ie
4423  CALL pushrealarray(tv(i, k))
4424  tv(i, k) = pt(i, j, k)*(1.+qc(i, j, k))
4425  CALL pushrealarray(phiz(i, k))
4426  phiz(i, k) = phiz(i, k+1) + rg*tv(i, k)*(peln(i, k+1, j)-&
4427 & peln(i, k, j))
4428  END DO
4429  END DO
4430  DO i=is,ie
4431  te_2d(i, j) = pe(i, km+1, j)*phiz(i, km+1) - pe(i, 1, j)*phiz(&
4432 & i, 1)
4433  END DO
4434  DO k=1,km
4435  DO i=is,ie
4436  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*tv(i, k)+0.25*&
4437 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2&
4438 & +v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i&
4439 & +1, j, k))*cosa_s_l(i, j)))
4440  END DO
4441  END DO
4442  CALL pushcontrol(2,2)
4443  ELSE
4444 !-----------------
4445 ! Non-hydrostatic:
4446 !-----------------
4447  DO i=is,ie
4448  CALL pushrealarray(phiz(i, km+1))
4449  phiz(i, km+1) = hs(i, j)
4450  DO k=km,1,-1
4451  CALL pushrealarray(phiz(i, k))
4452  phiz(i, k) = phiz(i, k+1) - grav*delz(i, j, k)
4453  END DO
4454  END DO
4455  DO i=is,ie
4456  te_2d(i, j) = 0.
4457  END DO
4458  IF (moist_phys) THEN
4459  DO k=1,km
4460  DO i=is,ie
4461  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
4462 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
4463 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
4464 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
4465 & )+v(i+1, j, k))*cosa_s_l(i, j))))
4466  END DO
4467  END DO
4468  CALL pushcontrol(2,1)
4469  ELSE
4470  DO k=1,km
4471  DO i=is,ie
4472  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
4473 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
4474 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
4475 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
4476 & )+v(i+1, j, k))*cosa_s_l(i, j))))
4477  END DO
4478  END DO
4479  CALL pushcontrol(2,0)
4480  END IF
4481  END IF
4482  END DO
4483 !-------------------------------------
4484 ! Diganostics computation for moist TE
4485 !-------------------------------------
4486  IF (id_te .GT. 0) THEN
4487 !$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp)
4488  DO j=js,je
4489  DO i=is,ie
4490  teq(i, j) = te_2d(i, j)
4491  END DO
4492  IF (moist_phys) THEN
4493  DO k=1,km
4494  DO i=is,ie
4495  teq(i, j) = teq(i, j) + hlv*q(i, j, k, sphum)*delp(i, j, k&
4496 & )
4497  END DO
4498  END DO
4499  CALL pushcontrol(1,1)
4500  ELSE
4501  CALL pushcontrol(1,0)
4502  END IF
4503  END DO
4504  CALL pushrealarray(tv, (ie-is+1)*km)
4505  CALL pushrealarray(phiz, (ie-is+1)*(km+1))
4506  CALL pushcontrol(1,1)
4507  ELSE
4508  CALL pushrealarray(tv, (ie-is+1)*km)
4509  CALL pushrealarray(phiz, (ie-is+1)*(km+1))
4510  CALL pushcontrol(1,0)
4511  END IF
4512  END SUBROUTINE compute_total_energy_fwd
4513 ! Differentiation of compute_total_energy in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4
4514 ! a2b_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_p
4515 !e dyn_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn
4516 !_core_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_m
4517 !od.Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_
4518 !mod.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_
4519 !mapz_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod
4520 !.remap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.pp
4521 !m_limiters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1
4522 !_cubic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mo
4523 !d.fv_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_
4524 !d nh_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver
4525 !nh_utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile n
4526 !h_utils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_
4527 !core_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core
4528 !_mod.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d_
4529 !fb tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv
4530 !_grid_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
4531 ! gradient of useful results: qc peln q u v w teq delp delz
4532 ! te_2d pe pt
4533 ! with respect to varying inputs: qc peln q u v w delp delz pe
4534 ! pt
4535  SUBROUTINE compute_total_energy_bwd(is, ie, js, je, isd, ied, jsd, jed&
4536 & , km, u, u_ad, v, v_ad, w, w_ad, delz, delz_ad, pt, pt_ad, delp, &
4537 & delp_ad, q, q_ad, qc, qc_ad, pe, pe_ad, peln, peln_ad, hs, rsin2_l, &
4538 & cosa_s_l, r_vir, cp, rg, hlv, te_2d, te_2d_ad, ua, va, teq, teq_ad, &
4539 & moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel&
4540 & , hydrostatic, id_te)
4541  IMPLICIT NONE
4542  INTEGER, INTENT(IN) :: km, is, ie, js, je, isd, ied, jsd, jed, id_te
4543  INTEGER, INTENT(IN) :: sphum, liq_wat, ice_wat, rainwat, snowwat, &
4544 & graupel, nwat
4545  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: ua, va
4546  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt, delp
4547  REAL, DIMENSION(isd:ied, jsd:jed, km) :: pt_ad, delp_ad
4548  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q
4549  REAL, DIMENSION(isd:ied, jsd:jed, km, *) :: q_ad
4550  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc
4551  REAL, DIMENSION(isd:ied, jsd:jed, km) :: qc_ad
4552  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
4553  REAL, INTENT(INOUT) :: u_ad(isd:ied, jsd:jed+1, km)
4554  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
4555  REAL, INTENT(INOUT) :: v_ad(isd:ied+1, jsd:jed, km)
4556  REAL, INTENT(IN) :: w(isd:ied, jsd:jed, km)
4557  REAL :: w_ad(isd:ied, jsd:jed, km)
4558  REAL, INTENT(IN) :: delz(isd:ied, jsd:jed, km)
4559  REAL :: delz_ad(isd:ied, jsd:jed, km)
4560  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
4561  REAL, INTENT(IN) :: pe(is-1:ie+1, km+1, js-1:je+1)
4562  REAL :: pe_ad(is-1:ie+1, km+1, js-1:je+1)
4563  REAL, INTENT(IN) :: peln(is:ie, km+1, js:je)
4564  REAL :: peln_ad(is:ie, km+1, js:je)
4565  REAL, INTENT(IN) :: cp, rg, r_vir, hlv
4566  REAL, INTENT(IN) :: rsin2_l(isd:ied, jsd:jed)
4567  REAL, INTENT(IN) :: cosa_s_l(isd:ied, jsd:jed)
4568  LOGICAL, INTENT(IN) :: moist_phys, hydrostatic
4569  REAL :: te_2d(is:ie, js:je)
4570  REAL :: te_2d_ad(is:ie, js:je)
4571  REAL :: teq(is:ie, js:je)
4572  REAL :: teq_ad(is:ie, js:je)
4573  REAL, DIMENSION(is:ie, km) :: tv
4574  REAL, DIMENSION(is:ie, km) :: tv_ad
4575  REAL :: phiz(is:ie, km+1)
4576  REAL :: phiz_ad(is:ie, km+1)
4577  REAL :: cvm(is:ie), qd(is:ie)
4578  INTEGER :: i, j, k
4579  REAL :: temp_ad
4580  REAL :: temp
4581  REAL :: temp0
4582  REAL :: temp1
4583  REAL :: temp_ad0
4584  REAL :: temp_ad1
4585  REAL :: temp_ad2
4586  REAL :: temp2
4587  REAL :: temp3
4588  REAL :: temp4
4589  REAL :: temp_ad3
4590  REAL :: temp_ad4
4591  REAL :: temp_ad5
4592  REAL :: temp_ad6
4593  REAL :: temp5
4594  REAL :: temp6
4595  REAL :: temp7
4596  REAL :: temp_ad7
4597  REAL :: temp_ad8
4598  REAL :: temp_ad9
4599  REAL :: temp_ad10
4600  INTEGER :: branch
4601 
4602  tv = 0.0
4603  phiz = 0.0
4604  cvm = 0.0
4605  qd = 0.0
4606  branch = 0
4607 
4608  CALL popcontrol(1,branch)
4609  IF (branch .EQ. 0) THEN
4610  CALL poprealarray(phiz, (ie-is+1)*(km+1))
4611  CALL poprealarray(tv, (ie-is+1)*km)
4612  ELSE
4613  CALL poprealarray(phiz, (ie-is+1)*(km+1))
4614  CALL poprealarray(tv, (ie-is+1)*km)
4615  DO j=je,js,-1
4616  CALL popcontrol(1,branch)
4617  IF (branch .NE. 0) THEN
4618  DO k=km,1,-1
4619  DO i=ie,is,-1
4620  q_ad(i, j, k, sphum) = q_ad(i, j, k, sphum) + hlv*delp(i, &
4621 & j, k)*teq_ad(i, j)
4622  delp_ad(i, j, k) = delp_ad(i, j, k) + hlv*q(i, j, k, sphum&
4623 & )*teq_ad(i, j)
4624  END DO
4625  END DO
4626  END IF
4627  DO i=ie,is,-1
4628  te_2d_ad(i, j) = te_2d_ad(i, j) + teq_ad(i, j)
4629  teq_ad(i, j) = 0.0
4630  END DO
4631  END DO
4632  END IF
4633  phiz_ad = 0.0
4634  tv_ad = 0.0
4635  DO 100 j=je,js,-1
4636  CALL popcontrol(2,branch)
4637  IF (branch .EQ. 0) THEN
4638  DO k=km,1,-1
4639  DO i=ie,is,-1
4640  temp7 = v(i, j, k) + v(i+1, j, k)
4641  temp6 = u(i, j, k) + u(i, j+1, k)
4642  temp5 = 0.5*rsin2_l(i, j)
4643  temp_ad7 = delp(i, j, k)*te_2d_ad(i, j)
4644  temp_ad8 = 0.5*temp_ad7
4645  temp_ad9 = temp5*temp_ad8
4646  temp_ad10 = -(cosa_s_l(i, j)*temp_ad9)
4647  delp_ad(i, j, k) = delp_ad(i, j, k) + (cv_air*pt(i, j, k)+&
4648 & 0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+temp5*(u(i, j, &
4649 & k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-&
4650 & cosa_s_l(i, j)*(temp6*temp7))))*te_2d_ad(i, j)
4651  pt_ad(i, j, k) = pt_ad(i, j, k) + cv_air*temp_ad7
4652  phiz_ad(i, k) = phiz_ad(i, k) + temp_ad8
4653  phiz_ad(i, k+1) = phiz_ad(i, k+1) + temp_ad8
4654  w_ad(i, j, k) = w_ad(i, j, k) + 2*w(i, j, k)*temp_ad8
4655  u_ad(i, j, k) = u_ad(i, j, k) + temp7*temp_ad10 + 2*u(i, j, &
4656 & k)*temp_ad9
4657  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp7*temp_ad10 + 2*u(i&
4658 & , j+1, k)*temp_ad9
4659  v_ad(i, j, k) = v_ad(i, j, k) + temp6*temp_ad10 + 2*v(i, j, &
4660 & k)*temp_ad9
4661  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp6*temp_ad10 + 2*v(i+&
4662 & 1, j, k)*temp_ad9
4663  END DO
4664  END DO
4665  ELSE IF (branch .EQ. 1) THEN
4666  DO k=km,1,-1
4667  DO i=ie,is,-1
4668  temp4 = v(i, j, k) + v(i+1, j, k)
4669  temp3 = u(i, j, k) + u(i, j+1, k)
4670  temp2 = 0.5*rsin2_l(i, j)
4671  temp_ad3 = delp(i, j, k)*te_2d_ad(i, j)
4672  temp_ad4 = 0.5*temp_ad3
4673  temp_ad5 = temp2*temp_ad4
4674  temp_ad6 = -(cosa_s_l(i, j)*temp_ad5)
4675  delp_ad(i, j, k) = delp_ad(i, j, k) + (cv_air*pt(i, j, k)+&
4676 & 0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+temp2*(u(i, j, &
4677 & k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-&
4678 & cosa_s_l(i, j)*(temp3*temp4))))*te_2d_ad(i, j)
4679  pt_ad(i, j, k) = pt_ad(i, j, k) + cv_air*temp_ad3
4680  phiz_ad(i, k) = phiz_ad(i, k) + temp_ad4
4681  phiz_ad(i, k+1) = phiz_ad(i, k+1) + temp_ad4
4682  w_ad(i, j, k) = w_ad(i, j, k) + 2*w(i, j, k)*temp_ad4
4683  u_ad(i, j, k) = u_ad(i, j, k) + temp4*temp_ad6 + 2*u(i, j, k&
4684 & )*temp_ad5
4685  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp4*temp_ad6 + 2*u(i, &
4686 & j+1, k)*temp_ad5
4687  v_ad(i, j, k) = v_ad(i, j, k) + temp3*temp_ad6 + 2*v(i, j, k&
4688 & )*temp_ad5
4689  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp3*temp_ad6 + 2*v(i+1&
4690 & , j, k)*temp_ad5
4691  END DO
4692  END DO
4693  ELSE
4694  DO k=km,1,-1
4695  DO i=ie,is,-1
4696  temp1 = v(i, j, k) + v(i+1, j, k)
4697  temp0 = u(i, j, k) + u(i, j+1, k)
4698  temp = 0.25*rsin2_l(i, j)
4699  temp_ad0 = delp(i, j, k)*te_2d_ad(i, j)
4700  temp_ad1 = temp*temp_ad0
4701  temp_ad2 = -(cosa_s_l(i, j)*temp_ad1)
4702  delp_ad(i, j, k) = delp_ad(i, j, k) + (cp*tv(i, k)+temp*(u(i&
4703 & , j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-&
4704 & cosa_s_l(i, j)*(temp0*temp1)))*te_2d_ad(i, j)
4705  tv_ad(i, k) = tv_ad(i, k) + cp*temp_ad0
4706  u_ad(i, j, k) = u_ad(i, j, k) + temp1*temp_ad2 + 2*u(i, j, k&
4707 & )*temp_ad1
4708  u_ad(i, j+1, k) = u_ad(i, j+1, k) + temp1*temp_ad2 + 2*u(i, &
4709 & j+1, k)*temp_ad1
4710  v_ad(i, j, k) = v_ad(i, j, k) + temp0*temp_ad2 + 2*v(i, j, k&
4711 & )*temp_ad1
4712  v_ad(i+1, j, k) = v_ad(i+1, j, k) + temp0*temp_ad2 + 2*v(i+1&
4713 & , j, k)*temp_ad1
4714  END DO
4715  END DO
4716  DO i=ie,is,-1
4717  pe_ad(i, km+1, j) = pe_ad(i, km+1, j) + phiz(i, km+1)*te_2d_ad&
4718 & (i, j)
4719  phiz_ad(i, km+1) = phiz_ad(i, km+1) + pe(i, km+1, j)*te_2d_ad(&
4720 & i, j)
4721  pe_ad(i, 1, j) = pe_ad(i, 1, j) - phiz(i, 1)*te_2d_ad(i, j)
4722  phiz_ad(i, 1) = phiz_ad(i, 1) - pe(i, 1, j)*te_2d_ad(i, j)
4723  te_2d_ad(i, j) = 0.0
4724  END DO
4725  DO k=1,km,1
4726  DO i=ie,is,-1
4727  CALL poprealarray(phiz(i, k))
4728  temp_ad = rg*tv(i, k)*phiz_ad(i, k)
4729  phiz_ad(i, k+1) = phiz_ad(i, k+1) + phiz_ad(i, k)
4730  tv_ad(i, k) = tv_ad(i, k) + rg*(peln(i, k+1, j)-peln(i, k, j&
4731 & ))*phiz_ad(i, k)
4732  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad
4733  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad
4734  phiz_ad(i, k) = 0.0
4735  CALL poprealarray(tv(i, k))
4736  pt_ad(i, j, k) = pt_ad(i, j, k) + (qc(i, j, k)+1.)*tv_ad(i, &
4737 & k)
4738  qc_ad(i, j, k) = qc_ad(i, j, k) + pt(i, j, k)*tv_ad(i, k)
4739  tv_ad(i, k) = 0.0
4740  END DO
4741  END DO
4742  DO i=ie,is,-1
4743  CALL poprealarray(phiz(i, km+1))
4744  phiz_ad(i, km+1) = 0.0
4745  END DO
4746  GOTO 100
4747  END IF
4748  DO i=ie,is,-1
4749  te_2d_ad(i, j) = 0.0
4750  END DO
4751  DO i=ie,is,-1
4752  DO k=1,km,1
4753  CALL poprealarray(phiz(i, k))
4754  phiz_ad(i, k+1) = phiz_ad(i, k+1) + phiz_ad(i, k)
4755  delz_ad(i, j, k) = delz_ad(i, j, k) - grav*phiz_ad(i, k)
4756  phiz_ad(i, k) = 0.0
4757  END DO
4758  CALL poprealarray(phiz(i, km+1))
4759  phiz_ad(i, km+1) = 0.0
4760  END DO
4761  100 CONTINUE
4762  END SUBROUTINE compute_total_energy_bwd
4763  SUBROUTINE compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km&
4764 & , u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, cosa_s_l, &
4765 & r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, sphum, &
4766 & liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
4767  IMPLICIT NONE
4768 !------------------------------------------------------
4769 ! Compute vertically integrated total energy per column
4770 !------------------------------------------------------
4771 ! !INPUT PARAMETERS:
4772  INTEGER, INTENT(IN) :: km, is, ie, js, je, isd, ied, jsd, jed, id_te
4773  INTEGER, INTENT(IN) :: sphum, liq_wat, ice_wat, rainwat, snowwat, &
4774 & graupel, nwat
4775  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: ua, va
4776  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt, delp
4777  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q
4778  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc
4779  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
4780  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
4781 ! vertical velocity (m/s)
4782  REAL, INTENT(IN) :: w(isd:ied, jsd:jed, km)
4783  REAL, INTENT(IN) :: delz(isd:ied, jsd:jed, km)
4784 ! surface geopotential
4785  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
4786 ! pressure at layer edges
4787  REAL, INTENT(IN) :: pe(is-1:ie+1, km+1, js-1:je+1)
4788 ! log(pe)
4789  REAL, INTENT(IN) :: peln(is:ie, km+1, js:je)
4790  REAL, INTENT(IN) :: cp, rg, r_vir, hlv
4791  REAL, INTENT(IN) :: rsin2_l(isd:ied, jsd:jed)
4792  REAL, INTENT(IN) :: cosa_s_l(isd:ied, jsd:jed)
4793  LOGICAL, INTENT(IN) :: moist_phys, hydrostatic
4794 ! Output:
4795 ! vertically integrated TE
4796  REAL, INTENT(OUT) :: te_2d(is:ie, js:je)
4797 ! Moist TE
4798  REAL, INTENT(OUT) :: teq(is:ie, js:je)
4799 ! Local
4800  REAL, DIMENSION(is:ie, km) :: tv
4801  REAL :: phiz(is:ie, km+1)
4802  REAL :: cvm(is:ie), qd(is:ie)
4803  INTEGER :: i, j, k
4804 !----------------------
4805 ! Output lat-lon winds:
4806 !----------------------
4807 ! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, flagstruct%c2l_ord)
4808 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,rg,peln,te_2d, &
4809 !$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, &
4810 !$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum) &
4811 !$OMP private(phiz, tv, cvm, qd)
4812  DO j=js,je
4813  IF (hydrostatic) THEN
4814  DO i=is,ie
4815  phiz(i, km+1) = hs(i, j)
4816  END DO
4817  DO k=km,1,-1
4818  DO i=is,ie
4819  tv(i, k) = pt(i, j, k)*(1.+qc(i, j, k))
4820  phiz(i, k) = phiz(i, k+1) + rg*tv(i, k)*(peln(i, k+1, j)-&
4821 & peln(i, k, j))
4822  END DO
4823  END DO
4824  DO i=is,ie
4825  te_2d(i, j) = pe(i, km+1, j)*phiz(i, km+1) - pe(i, 1, j)*phiz(&
4826 & i, 1)
4827  END DO
4828  DO k=1,km
4829  DO i=is,ie
4830  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*tv(i, k)+0.25*&
4831 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2&
4832 & +v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i&
4833 & +1, j, k))*cosa_s_l(i, j)))
4834  END DO
4835  END DO
4836  ELSE
4837 !-----------------
4838 ! Non-hydrostatic:
4839 !-----------------
4840  DO i=is,ie
4841  phiz(i, km+1) = hs(i, j)
4842  DO k=km,1,-1
4843  phiz(i, k) = phiz(i, k+1) - grav*delz(i, j, k)
4844  END DO
4845  END DO
4846  DO i=is,ie
4847  te_2d(i, j) = 0.
4848  END DO
4849  IF (moist_phys) THEN
4850  DO k=1,km
4851  DO i=is,ie
4852  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
4853 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
4854 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
4855 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
4856 & )+v(i+1, j, k))*cosa_s_l(i, j))))
4857  END DO
4858  END DO
4859  ELSE
4860  DO k=1,km
4861  DO i=is,ie
4862  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
4863 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
4864 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
4865 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
4866 & )+v(i+1, j, k))*cosa_s_l(i, j))))
4867  END DO
4868  END DO
4869  END IF
4870  END IF
4871  END DO
4872 !-------------------------------------
4873 ! Diganostics computation for moist TE
4874 !-------------------------------------
4875  IF (id_te .GT. 0) THEN
4876 !$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp)
4877  DO j=js,je
4878  DO i=is,ie
4879  teq(i, j) = te_2d(i, j)
4880  END DO
4881  IF (moist_phys) THEN
4882  DO k=1,km
4883  DO i=is,ie
4884  teq(i, j) = teq(i, j) + hlv*q(i, j, k, sphum)*delp(i, j, k&
4885 & )
4886  END DO
4887  END DO
4888  END IF
4889  END DO
4890  END IF
4891  END SUBROUTINE compute_total_energy
4892 ! Differentiation of pkez in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b
4893 !_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p_
4894 !grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp
4895 !dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super
4896 ! fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_g
4897 !rid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
4898 !fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz
4899 !_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_map
4900 !z_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart
4901 !_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z ma
4902 !in_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Ri
4903 !em_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3
4904 !p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_
4905 !halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_ve
4906 !ct sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_
4907 !core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.co
4908 !py_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.g
4909 !reat_circle_dist sw_core_mod.edge_interpolate4)):
4910 ! gradient of useful results: peln pkz pk
4911 ! with respect to varying inputs: peln pkz pk
4912  SUBROUTINE pkez_fwd(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap&
4913 & , peln, pkz, ptop)
4914  IMPLICIT NONE
4915 ! !INPUT PARAMETERS:
4916  INTEGER, INTENT(IN) :: km, j
4917 ! Latitude strip
4918  INTEGER, INTENT(IN) :: ifirst, ilast
4919 ! Latitude strip
4920  INTEGER, INTENT(IN) :: jfirst, jlast
4921  REAL, INTENT(IN) :: akap
4922  REAL, INTENT(IN) :: pe(ifirst-1:ilast+1, km+1, jfirst-1:jlast+1)
4923  REAL, INTENT(IN) :: pk(ifirst:ilast, jfirst:jlast, km+1)
4924  REAL, INTENT(IN) :: ptop
4925 ! !OUTPUT
4926  REAL :: pkz(ifirst:ilast, jfirst:jlast, km)
4927 ! log (pe)
4928  REAL, INTENT(INOUT) :: peln(ifirst:ilast, km+1, jfirst:jlast)
4929 ! Local
4930  REAL :: pk2(ifirst:ilast, km+1)
4931  REAL :: pek
4932  REAL :: lnp
4933  REAL :: ak1
4934  INTEGER :: i, k
4935  INTRINSIC log
4936 
4937  pk2 = 0.0
4938  pek = 0.0
4939  lnp = 0.0
4940  ak1 = 0.0
4941 
4942  ak1 = (akap+1.)/akap
4943  pek = pk(ifirst, j, 1)
4944  DO i=ifirst,ilast
4945  pk2(i, 1) = pek
4946  END DO
4947  DO k=2,km+1
4948  DO i=ifirst,ilast
4949 ! peln(i,k,j) = log(pe(i,k,j))
4950  pk2(i, k) = pk(i, j, k)
4951  END DO
4952  END DO
4953 !---- GFDL modification
4954  IF (ptop .LT. ptop_min) THEN
4955  DO i=ifirst,ilast
4956  CALL pushrealarray(peln(i, 1, j))
4957  peln(i, 1, j) = peln(i, 2, j) - ak1
4958  END DO
4959  CALL pushcontrol(1,1)
4960  ELSE
4961  lnp = log(ptop)
4962  DO i=ifirst,ilast
4963  CALL pushrealarray(peln(i, 1, j))
4964  peln(i, 1, j) = lnp
4965  END DO
4966  CALL pushcontrol(1,0)
4967  END IF
4968 !---- GFDL modification
4969  DO k=1,km
4970  DO i=ifirst,ilast
4971  CALL pushrealarray(pkz(i, j, k))
4972  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1, j)-&
4973 & peln(i, k, j)))
4974  END DO
4975  END DO
4976  CALL pushrealarray(pk2, (ilast-ifirst+1)*(km+1))
4977  END SUBROUTINE pkez_fwd
4978 ! Differentiation of pkez in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2
4979 !b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p
4980 !_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp
4981 ! dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Supe
4982 !r fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_
4983 !grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z
4984 ! fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_map
4985 !z_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_ma
4986 !pz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restar
4987 !t_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z m
4988 !ain_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.R
4989 !iem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM
4990 !3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest
4991 !_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_v
4992 !ect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw
4993 !_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.c
4994 !opy_corners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.
4995 !great_circle_dist sw_core_mod.edge_interpolate4)):
4996 ! gradient of useful results: peln pkz pk
4997 ! with respect to varying inputs: peln pkz pk
4998  SUBROUTINE pkez_bwd(km, ifirst, ilast, jfirst, jlast, j, pe, pk, pk_ad&
4999 & , akap, peln, peln_ad, pkz, pkz_ad, ptop)
5000  IMPLICIT NONE
5001  INTEGER, INTENT(IN) :: km, j
5002  INTEGER, INTENT(IN) :: ifirst, ilast
5003  INTEGER, INTENT(IN) :: jfirst, jlast
5004  REAL, INTENT(IN) :: akap
5005  REAL, INTENT(IN) :: pe(ifirst-1:ilast+1, km+1, jfirst-1:jlast+1)
5006  REAL, INTENT(IN) :: pk(ifirst:ilast, jfirst:jlast, km+1)
5007  REAL :: pk_ad(ifirst:ilast, jfirst:jlast, km+1)
5008  REAL, INTENT(IN) :: ptop
5009  REAL :: pkz(ifirst:ilast, jfirst:jlast, km)
5010  REAL :: pkz_ad(ifirst:ilast, jfirst:jlast, km)
5011  REAL, INTENT(INOUT) :: peln(ifirst:ilast, km+1, jfirst:jlast)
5012  REAL, INTENT(INOUT) :: peln_ad(ifirst:ilast, km+1, jfirst:jlast)
5013  REAL :: pk2(ifirst:ilast, km+1)
5014  REAL :: pk2_ad(ifirst:ilast, km+1)
5015  REAL :: pek
5016  REAL :: pek_ad
5017  REAL :: lnp
5018  REAL :: ak1
5019  INTEGER :: i, k
5020  INTRINSIC log
5021  REAL :: temp
5022  REAL :: temp_ad
5023  REAL :: temp_ad0
5024  INTEGER :: branch
5025 
5026  pk2 = 0.0
5027  pek = 0.0
5028  lnp = 0.0
5029  ak1 = 0.0
5030  branch = 0
5031 
5032  CALL poprealarray(pk2, (ilast-ifirst+1)*(km+1))
5033  pk2_ad = 0.0
5034  DO k=km,1,-1
5035  DO i=ilast,ifirst,-1
5036  CALL poprealarray(pkz(i, j, k))
5037  temp = akap*(peln(i, k+1, j)-peln(i, k, j))
5038  temp_ad = pkz_ad(i, j, k)/temp
5039  temp_ad0 = -((pk2(i, k+1)-pk2(i, k))*akap*temp_ad/temp)
5040  pk2_ad(i, k+1) = pk2_ad(i, k+1) + temp_ad
5041  pk2_ad(i, k) = pk2_ad(i, k) - temp_ad
5042  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad0
5043  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad0
5044  pkz_ad(i, j, k) = 0.0
5045  END DO
5046  END DO
5047  CALL popcontrol(1,branch)
5048  IF (branch .EQ. 0) THEN
5049  DO i=ilast,ifirst,-1
5050  CALL poprealarray(peln(i, 1, j))
5051  peln_ad(i, 1, j) = 0.0
5052  END DO
5053  ELSE
5054  DO i=ilast,ifirst,-1
5055  CALL poprealarray(peln(i, 1, j))
5056  peln_ad(i, 2, j) = peln_ad(i, 2, j) + peln_ad(i, 1, j)
5057  peln_ad(i, 1, j) = 0.0
5058  END DO
5059  END IF
5060  DO k=km+1,2,-1
5061  DO i=ilast,ifirst,-1
5062  pk_ad(i, j, k) = pk_ad(i, j, k) + pk2_ad(i, k)
5063  pk2_ad(i, k) = 0.0
5064  END DO
5065  END DO
5066  pek_ad = 0.0
5067  DO i=ilast,ifirst,-1
5068  pek_ad = pek_ad + pk2_ad(i, 1)
5069  pk2_ad(i, 1) = 0.0
5070  END DO
5071  pk_ad(ifirst, j, 1) = pk_ad(ifirst, j, 1) + pek_ad
5072  END SUBROUTINE pkez_bwd
5073  SUBROUTINE pkez(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap, &
5074 & peln, pkz, ptop)
5075  IMPLICIT NONE
5076 ! !INPUT PARAMETERS:
5077  INTEGER, INTENT(IN) :: km, j
5078 ! Latitude strip
5079  INTEGER, INTENT(IN) :: ifirst, ilast
5080 ! Latitude strip
5081  INTEGER, INTENT(IN) :: jfirst, jlast
5082  REAL, INTENT(IN) :: akap
5083  REAL, INTENT(IN) :: pe(ifirst-1:ilast+1, km+1, jfirst-1:jlast+1)
5084  REAL, INTENT(IN) :: pk(ifirst:ilast, jfirst:jlast, km+1)
5085  REAL, INTENT(IN) :: ptop
5086 ! !OUTPUT
5087  REAL, INTENT(OUT) :: pkz(ifirst:ilast, jfirst:jlast, km)
5088 ! log (pe)
5089  REAL, INTENT(INOUT) :: peln(ifirst:ilast, km+1, jfirst:jlast)
5090 ! Local
5091  REAL :: pk2(ifirst:ilast, km+1)
5092  REAL :: pek
5093  REAL :: lnp
5094  REAL :: ak1
5095  INTEGER :: i, k
5096  INTRINSIC log
5097  ak1 = (akap+1.)/akap
5098  pek = pk(ifirst, j, 1)
5099  DO i=ifirst,ilast
5100  pk2(i, 1) = pek
5101  END DO
5102  DO k=2,km+1
5103  DO i=ifirst,ilast
5104 ! peln(i,k,j) = log(pe(i,k,j))
5105  pk2(i, k) = pk(i, j, k)
5106  END DO
5107  END DO
5108 !---- GFDL modification
5109  IF (ptop .LT. ptop_min) THEN
5110  DO i=ifirst,ilast
5111  peln(i, 1, j) = peln(i, 2, j) - ak1
5112  END DO
5113  ELSE
5114  lnp = log(ptop)
5115  DO i=ifirst,ilast
5116  peln(i, 1, j) = lnp
5117  END DO
5118  END IF
5119 !---- GFDL modification
5120  DO k=1,km
5121  DO i=ifirst,ilast
5122  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1, j)-&
5123 & peln(i, k, j)))
5124  END DO
5125  END DO
5126  END SUBROUTINE pkez
5127  SUBROUTINE remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
5128  IMPLICIT NONE
5129 ! !INPUT PARAMETERS:
5130 ! Starting longitude
5131  INTEGER, INTENT(IN) :: i1
5132 ! Finishing longitude
5133  INTEGER, INTENT(IN) :: i2
5134 ! Method order
5135  INTEGER, INTENT(IN) :: kord
5136 ! Original vertical dimension
5137  INTEGER, INTENT(IN) :: km
5138 ! Target vertical dimension
5139  INTEGER, INTENT(IN) :: kn
5140  INTEGER, INTENT(IN) :: iv
5141 ! height at layer edges
5142  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5143 ! (from model top to bottom surface)
5144 ! hieght at layer edges
5145  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5146 ! (from model top to bottom surface)
5147 ! Field input
5148  REAL, INTENT(IN) :: q1(i1:i2, km)
5149 ! !INPUT/OUTPUT PARAMETERS:
5150 ! Field output
5151  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
5152 ! !LOCAL VARIABLES:
5153  REAL :: qs(i1:i2)
5154  REAL :: dp1(i1:i2, km)
5155  REAL :: q4(4, i1:i2, km)
5156  REAL :: pl, pr, qsum, delp, esl
5157  INTEGER :: i, k, l, m, k0
5158  DO k=1,km
5159  DO i=i1,i2
5160 ! negative
5161  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5162  q4(1, i, k) = q1(i, k)
5163  END DO
5164  END DO
5165 ! Compute vertical subgrid distribution
5166  IF (kord .GT. 7) THEN
5167  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
5168  ELSE
5169  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
5170  END IF
5171 ! Mapping
5172  DO i=i1,i2
5173  k0 = 1
5174  DO k=1,kn
5175  DO l=k0,km
5176 ! locate the top edge: pe2(i,k)
5177  IF (pe2(i, k) .LE. pe1(i, l) .AND. pe2(i, k) .GE. pe1(i, l+1)&
5178 & ) THEN
5179  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5180  IF (pe2(i, k+1) .GE. pe1(i, l+1)) THEN
5181 ! entire new grid is within the original grid
5182  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5183  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
5184 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
5185  k0 = l
5186  GOTO 555
5187  ELSE
5188 ! Fractional area...
5189  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
5190 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
5191 & pl*(1.+pl))))
5192  DO m=l+1,km
5193 ! locate the bottom edge: pe2(i,k+1)
5194  IF (pe2(i, k+1) .LT. pe1(i, m+1)) THEN
5195 ! Whole layer..
5196  qsum = qsum + dp1(i, m)*q4(1, i, m)
5197  ELSE
5198  delp = pe2(i, k+1) - pe1(i, m)
5199  esl = delp/dp1(i, m)
5200  qsum = qsum + delp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-&
5201 & q4(2, i, m)+q4(4, i, m)*(1.-r23*esl)))
5202  k0 = m
5203  GOTO 123
5204  END IF
5205  END DO
5206  GOTO 123
5207  END IF
5208  END IF
5209  END DO
5210  123 q2(i, k) = qsum/(pe2(i, k+1)-pe2(i, k))
5211  555 CONTINUE
5212  END DO
5213  END DO
5214  END SUBROUTINE remap_z
5215 ! Differentiation of map_scalar in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn
5216 !_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 dy
5217 !n_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_
5218 !mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynam
5219 !ics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils
5220 !_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_m
5221 !od.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.scal
5222 !ar_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.ste
5223 !epz 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_
5224 !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.co
5225 !mpute_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
5226 !_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
5227 ! 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 s
5228 !w_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_cor
5229 !e_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.
5230 !compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corner
5231 !s_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circ
5232 !le_dist sw_core_mod.edge_interpolate4)):
5233 ! gradient of useful results: pe1 pe2 q2
5234 ! with respect to varying inputs: pe1 pe2 q2
5235  SUBROUTINE map_scalar_adm(km, pe1, pe1_ad, qs, kn, pe2, pe2_ad, q2, &
5236 & q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
5237  IMPLICIT NONE
5238 ! iv=1
5239 ! Starting longitude
5240  INTEGER, INTENT(IN) :: i1
5241 ! Finishing longitude
5242  INTEGER, INTENT(IN) :: i2
5243 ! Mode: 0 == constituents 1 == temp
5244  INTEGER, INTENT(IN) :: iv
5245 ! 2 == remap temp with cs scheme
5246 ! Method order
5247  INTEGER, INTENT(IN) :: kord
5248 ! Current latitude
5249  INTEGER, INTENT(IN) :: j
5250  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
5251 ! Original vertical dimension
5252  INTEGER, INTENT(IN) :: km
5253 ! Target vertical dimension
5254  INTEGER, INTENT(IN) :: kn
5255 ! bottom BC
5256  REAL, INTENT(IN) :: qs(i1:i2)
5257 ! pressure at layer edges
5258  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5259  REAL :: pe1_ad(i1:i2, km+1)
5260 ! (from model top to bottom surface)
5261 ! in the original vertical coordinate
5262 ! pressure at layer edges
5263  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5264  REAL :: pe2_ad(i1:i2, kn+1)
5265 ! (from model top to bottom surface)
5266 ! in the new vertical coordinate
5267 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
5268 ! !INPUT/OUTPUT PARAMETERS:
5269 ! Field output
5270  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
5271  REAL, INTENT(INOUT) :: q2_ad(ibeg:iend, jbeg:jend, kn)
5272  REAL, INTENT(IN) :: q_min
5273 ! !DESCRIPTION:
5274 ! IV = 0: constituents
5275 ! pe1: pressure at layer edges (from model top to bottom surface)
5276 ! in the original vertical coordinate
5277 ! pe2: pressure at layer edges (from model top to bottom surface)
5278 ! in the new vertical coordinate
5279 ! !LOCAL VARIABLES:
5280  REAL :: dp1(i1:i2, km)
5281  REAL :: dp1_ad(i1:i2, km)
5282  REAL :: q4(4, i1:i2, km)
5283  REAL :: q4_ad(4, i1:i2, km)
5284  REAL :: pl, pr, qsum, dp, esl
5285  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
5286  INTEGER :: i, k, l, m, k0
5287  REAL :: temp_ad
5288  REAL :: temp_ad0
5289  REAL :: temp_ad1
5290  REAL :: temp_ad2
5291  REAL :: temp_ad3
5292  REAL :: temp
5293  REAL :: temp_ad4
5294  REAL :: temp_ad5
5295  REAL :: temp_ad6
5296  REAL :: temp_ad7
5297  REAL :: temp0
5298  REAL :: temp_ad8
5299  REAL :: temp_ad9
5300  REAL :: temp_ad10
5301  REAL :: temp1
5302  REAL :: temp_ad11
5303  INTEGER :: ad_count
5304  INTEGER :: i0
5305  INTEGER :: branch
5306  INTEGER :: ad_count0
5307  INTEGER :: i3
5308  DO k=1,km
5309  DO i=i1,i2
5310  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5311  q4(1, i, k) = q2(i, j, k)
5312  END DO
5313  END DO
5314 ! Compute vertical subgrid distribution
5315  IF (kord .GT. 7) THEN
5316  CALL pushrealarray_adm(q4, 4*(i2-i1+1)*km)
5317  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
5318  CALL pushcontrol1b(1)
5319  ELSE
5320  CALL ppm_profile_fwd(q4, dp1, km, i1, i2, iv, kord)
5321  CALL pushcontrol1b(0)
5322  END IF
5323  DO i=i1,i2
5324  k0 = 1
5325  DO 120 k=1,kn
5326  CALL pushinteger4(l)
5327  ad_count = 1
5328  DO l=k0,km
5329 ! locate the top edge: pe2(i,k)
5330  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
5331 & ) THEN
5332  GOTO 100
5333  ELSE
5334  CALL pushinteger4(l)
5335  ad_count = ad_count + 1
5336  END IF
5337  END DO
5338  CALL pushcontrol1b(0)
5339  CALL pushinteger4(ad_count)
5340  CALL pushcontrol2b(2)
5341  GOTO 123
5342  100 CALL pushcontrol1b(1)
5343  CALL pushinteger4(ad_count)
5344  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5345  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5346 ! entire new grid is within the original grid
5347  k0 = l
5348  CALL pushcontrol1b(0)
5349  GOTO 120
5350  ELSE
5351 ! Fractional area...
5352  CALL pushrealarray_adm(qsum)
5353  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
5354 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
5355 & pl))))
5356  CALL pushinteger4(m)
5357  ad_count0 = 1
5358  DO m=l+1,km
5359 ! locate the bottom edge: pe2(i,k+1)
5360  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
5361 ! Whole layer
5362  qsum = qsum + dp1(i, m)*q4(1, i, m)
5363  CALL pushinteger4(m)
5364  ad_count0 = ad_count0 + 1
5365  ELSE
5366  GOTO 110
5367  END IF
5368  END DO
5369  CALL pushcontrol1b(0)
5370  CALL pushinteger4(ad_count0)
5371  CALL pushcontrol2b(1)
5372  GOTO 123
5373  110 CALL pushcontrol1b(1)
5374  CALL pushinteger4(ad_count0)
5375  dp = pe2(i, k+1) - pe1(i, m)
5376  esl = dp/dp1(i, m)
5377  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
5378 & +q4(4, i, m)*(1.-r23*esl)))
5379  k0 = m
5380  CALL pushcontrol2b(0)
5381  END IF
5382  123 CALL pushcontrol1b(1)
5383  120 CONTINUE
5384  END DO
5385  dp1_ad = 0.0
5386  qsum_ad = 0.0
5387  q4_ad = 0.0
5388  DO i=i2,i1,-1
5389  DO k=kn,1,-1
5390  CALL popcontrol1b(branch)
5391  IF (branch .EQ. 0) THEN
5392  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5393  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5394  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, j, k)
5395  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
5396 & j, k)
5397  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, j, k))
5398  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, j, k) - temp_ad0
5399  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
5400 & **2)*q2_ad(i, j, k)
5401  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
5402  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
5403  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
5404  q2_ad(i, j, k) = 0.0
5405  temp_ad3 = pr_ad/dp1(i, l)
5406  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
5407  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
5408  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
5409 & /dp1(i, l)
5410  ELSE
5411  temp1 = pe2(i, k+1) - pe2(i, k)
5412  temp_ad11 = -(qsum*q2_ad(i, j, k)/temp1**2)
5413  qsum_ad = qsum_ad + q2_ad(i, j, k)/temp1
5414  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad11
5415  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad11
5416  q2_ad(i, j, k) = 0.0
5417  CALL popcontrol2b(branch)
5418  IF (branch .EQ. 0) THEN
5419  dp = pe2(i, k+1) - pe1(i, m)
5420  esl = dp/dp1(i, m)
5421  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
5422 & 1.)
5423  temp_ad8 = dp*qsum_ad
5424  temp_ad9 = 0.5*esl*temp_ad8
5425  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
5426  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
5427  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
5428  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
5429  temp_ad10 = esl_ad/dp1(i, m)
5430  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
5431  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
5432  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
5433  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
5434  ELSE IF (branch .NE. 1) THEN
5435  GOTO 130
5436  END IF
5437  CALL popinteger4(ad_count0)
5438  DO i3=1,ad_count0
5439  IF (i3 .EQ. 1) THEN
5440  CALL popcontrol1b(branch)
5441  ELSE
5442  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
5443  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
5444  END IF
5445  CALL popinteger4(m)
5446  END DO
5447  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5448  CALL poprealarray_adm(qsum)
5449  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
5450  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
5451 & *(pl+1.)+1.)))*qsum_ad
5452  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
5453  temp_ad6 = 0.5*(pl+1.)*temp_ad5
5454  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
5455  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
5456  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
5457  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
5458  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
5459 & )*temp_ad5
5460  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
5461  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
5462  qsum_ad = 0.0
5463  END IF
5464  temp_ad = pl_ad/dp1(i, l)
5465  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
5466  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
5467  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
5468 & i, l)
5469  130 CALL popinteger4(ad_count)
5470  DO i0=1,ad_count
5471  IF (i0 .EQ. 1) CALL popcontrol1b(branch)
5472  CALL popinteger4(l)
5473  END DO
5474  END DO
5475  END DO
5476  CALL popcontrol1b(branch)
5477  IF (branch .EQ. 0) THEN
5478  CALL ppm_profile_bwd(q4, q4_ad, dp1, dp1_ad, km, i1, i2, iv, kord)
5479  ELSE
5480  CALL poprealarray_adm(q4, 4*(i2-i1+1)*km)
5481  CALL scalar_profile_adm(qs, q4, q4_ad, dp1, dp1_ad, km, i1, i2, iv&
5482 & , kord, q_min)
5483  END IF
5484  DO k=km,1,-1
5485  DO i=i2,i1,-1
5486  q2_ad(i, j, k) = q2_ad(i, j, k) + q4_ad(1, i, k)
5487  q4_ad(1, i, k) = 0.0
5488  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
5489  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
5490  dp1_ad(i, k) = 0.0
5491  END DO
5492  END DO
5493  END SUBROUTINE map_scalar_adm
5494  SUBROUTINE map_scalar(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend&
5495 & , jbeg, jend, iv, kord, q_min)
5496  IMPLICIT NONE
5497 ! iv=1
5498 ! Starting longitude
5499  INTEGER, INTENT(IN) :: i1
5500 ! Finishing longitude
5501  INTEGER, INTENT(IN) :: i2
5502 ! Mode: 0 == constituents 1 == temp
5503  INTEGER, INTENT(IN) :: iv
5504 ! 2 == remap temp with cs scheme
5505 ! Method order
5506  INTEGER, INTENT(IN) :: kord
5507 ! Current latitude
5508  INTEGER, INTENT(IN) :: j
5509  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
5510 ! Original vertical dimension
5511  INTEGER, INTENT(IN) :: km
5512 ! Target vertical dimension
5513  INTEGER, INTENT(IN) :: kn
5514 ! bottom BC
5515  REAL, INTENT(IN) :: qs(i1:i2)
5516 ! pressure at layer edges
5517  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5518 ! (from model top to bottom surface)
5519 ! in the original vertical coordinate
5520 ! pressure at layer edges
5521  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5522 ! (from model top to bottom surface)
5523 ! in the new vertical coordinate
5524 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
5525 ! !INPUT/OUTPUT PARAMETERS:
5526 ! Field output
5527  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
5528  REAL, INTENT(IN) :: q_min
5529 ! !DESCRIPTION:
5530 ! IV = 0: constituents
5531 ! pe1: pressure at layer edges (from model top to bottom surface)
5532 ! in the original vertical coordinate
5533 ! pe2: pressure at layer edges (from model top to bottom surface)
5534 ! in the new vertical coordinate
5535 ! !LOCAL VARIABLES:
5536  REAL :: dp1(i1:i2, km)
5537  REAL :: q4(4, i1:i2, km)
5538  REAL :: pl, pr, qsum, dp, esl
5539  INTEGER :: i, k, l, m, k0
5540  DO k=1,km
5541  DO i=i1,i2
5542  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5543  q4(1, i, k) = q2(i, j, k)
5544  END DO
5545  END DO
5546 ! Compute vertical subgrid distribution
5547  IF (kord .GT. 7) THEN
5548  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
5549  ELSE
5550  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
5551  END IF
5552  DO i=i1,i2
5553  k0 = 1
5554  DO k=1,kn
5555  DO l=k0,km
5556 ! locate the top edge: pe2(i,k)
5557  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
5558 & ) THEN
5559  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5560  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5561 ! entire new grid is within the original grid
5562  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5563  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-&
5564 & q4(2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
5565  k0 = l
5566  GOTO 555
5567  ELSE
5568 ! Fractional area...
5569  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
5570 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
5571 & pl*(1.+pl))))
5572  DO m=l+1,km
5573 ! locate the bottom edge: pe2(i,k+1)
5574  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
5575 ! Whole layer
5576  qsum = qsum + dp1(i, m)*q4(1, i, m)
5577  ELSE
5578  dp = pe2(i, k+1) - pe1(i, m)
5579  esl = dp/dp1(i, m)
5580  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
5581 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
5582  k0 = m
5583  GOTO 123
5584  END IF
5585  END DO
5586  GOTO 123
5587  END IF
5588  END IF
5589  END DO
5590  123 q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
5591  555 CONTINUE
5592  END DO
5593  END DO
5594  END SUBROUTINE map_scalar
5595 ! Differentiation of map1_ppm in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_c
5596 !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_
5597 !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
5598 !d.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamic
5599 !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
5600 !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
5601 !.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
5602 !_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
5603 !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
5604 !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
5605 !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
5606 ! 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
5607 !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_
5608 !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_
5609 !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
5610 !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_
5611 !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
5612 !_dist sw_core_mod.edge_interpolate4)):
5613 ! gradient of useful results: pe1 pe2 qs q2
5614 ! with respect to varying inputs: pe1 pe2 qs q2
5615  SUBROUTINE map1_ppm_adm(km, pe1, pe1_ad, qs, qs_ad, kn, pe2, pe2_ad, &
5616 & q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
5617  IMPLICIT NONE
5618 ! Starting longitude
5619  INTEGER, INTENT(IN) :: i1
5620 ! Finishing longitude
5621  INTEGER, INTENT(IN) :: i2
5622 ! Mode: 0 == constituents 1 == ???
5623  INTEGER, INTENT(IN) :: iv
5624 ! 2 == remap temp with cs scheme
5625 ! Method order
5626  INTEGER, INTENT(IN) :: kord
5627 ! Current latitude
5628  INTEGER, INTENT(IN) :: j
5629  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
5630 ! Original vertical dimension
5631  INTEGER, INTENT(IN) :: km
5632 ! Target vertical dimension
5633  INTEGER, INTENT(IN) :: kn
5634 ! bottom BC
5635  REAL, INTENT(IN) :: qs(i1:i2)
5636  REAL :: qs_ad(i1:i2)
5637 ! pressure at layer edges
5638  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5639  REAL :: pe1_ad(i1:i2, km+1)
5640 ! (from model top to bottom surface)
5641 ! in the original vertical coordinate
5642 ! pressure at layer edges
5643  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5644  REAL :: pe2_ad(i1:i2, kn+1)
5645 ! (from model top to bottom surface)
5646 ! in the new vertical coordinate
5647 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
5648 ! !INPUT/OUTPUT PARAMETERS:
5649 ! Field output
5650  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
5651  REAL, INTENT(INOUT) :: q2_ad(ibeg:iend, jbeg:jend, kn)
5652 ! !DESCRIPTION:
5653 ! IV = 0: constituents
5654 ! pe1: pressure at layer edges (from model top to bottom surface)
5655 ! in the original vertical coordinate
5656 ! pe2: pressure at layer edges (from model top to bottom surface)
5657 ! in the new vertical coordinate
5658 ! !LOCAL VARIABLES:
5659  REAL :: dp1(i1:i2, km)
5660  REAL :: dp1_ad(i1:i2, km)
5661  REAL :: q4(4, i1:i2, km)
5662  REAL :: q4_ad(4, i1:i2, km)
5663  REAL :: pl, pr, qsum, dp, esl
5664  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
5665  INTEGER :: i, k, l, m, k0
5666  REAL :: temp_ad
5667  REAL :: temp_ad0
5668  REAL :: temp_ad1
5669  REAL :: temp_ad2
5670  REAL :: temp_ad3
5671  REAL :: temp
5672  REAL :: temp_ad4
5673  REAL :: temp_ad5
5674  REAL :: temp_ad6
5675  REAL :: temp_ad7
5676  REAL :: temp0
5677  REAL :: temp_ad8
5678  REAL :: temp_ad9
5679  REAL :: temp_ad10
5680  REAL :: temp1
5681  REAL :: temp_ad11
5682  INTEGER :: ad_count
5683  INTEGER :: i0
5684  INTEGER :: branch
5685  INTEGER :: ad_count0
5686  INTEGER :: i3
5687  DO k=1,km
5688  DO i=i1,i2
5689  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5690  q4(1, i, k) = q2(i, j, k)
5691  END DO
5692  END DO
5693 ! Compute vertical subgrid distribution
5694  IF (kord .GT. 7) THEN
5695  CALL pushrealarray_adm(q4, 4*(i2-i1+1)*km)
5696  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
5697  CALL pushcontrol1b(1)
5698  ELSE
5699  CALL ppm_profile_fwd(q4, dp1, km, i1, i2, iv, kord)
5700  CALL pushcontrol1b(0)
5701  END IF
5702  DO i=i1,i2
5703  k0 = 1
5704  DO 120 k=1,kn
5705  CALL pushinteger4(l)
5706  ad_count = 1
5707  DO l=k0,km
5708 ! locate the top edge: pe2(i,k)
5709  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
5710 & ) THEN
5711  GOTO 100
5712  ELSE
5713  CALL pushinteger4(l)
5714  ad_count = ad_count + 1
5715  END IF
5716  END DO
5717  CALL pushcontrol1b(0)
5718  CALL pushinteger4(ad_count)
5719  CALL pushcontrol2b(2)
5720  GOTO 123
5721  100 CALL pushcontrol1b(1)
5722  CALL pushinteger4(ad_count)
5723  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5724  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5725 ! entire new grid is within the original grid
5726  k0 = l
5727  CALL pushcontrol1b(0)
5728  GOTO 120
5729  ELSE
5730 ! Fractional area...
5731  CALL pushrealarray_adm(qsum)
5732  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
5733 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
5734 & pl))))
5735  CALL pushinteger4(m)
5736  ad_count0 = 1
5737  DO m=l+1,km
5738 ! locate the bottom edge: pe2(i,k+1)
5739  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
5740 ! Whole layer
5741  qsum = qsum + dp1(i, m)*q4(1, i, m)
5742  CALL pushinteger4(m)
5743  ad_count0 = ad_count0 + 1
5744  ELSE
5745  GOTO 110
5746  END IF
5747  END DO
5748  CALL pushcontrol1b(0)
5749  CALL pushinteger4(ad_count0)
5750  CALL pushcontrol2b(1)
5751  GOTO 123
5752  110 CALL pushcontrol1b(1)
5753  CALL pushinteger4(ad_count0)
5754  dp = pe2(i, k+1) - pe1(i, m)
5755  esl = dp/dp1(i, m)
5756  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
5757 & +q4(4, i, m)*(1.-r23*esl)))
5758  k0 = m
5759  CALL pushcontrol2b(0)
5760  END IF
5761  123 CALL pushcontrol1b(1)
5762  120 CONTINUE
5763  END DO
5764  dp1_ad = 0.0
5765  qsum_ad = 0.0
5766  q4_ad = 0.0
5767  DO i=i2,i1,-1
5768  DO k=kn,1,-1
5769  CALL popcontrol1b(branch)
5770  IF (branch .EQ. 0) THEN
5771  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5772  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5773  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, j, k)
5774  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
5775 & j, k)
5776  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, j, k))
5777  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, j, k) - temp_ad0
5778  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
5779 & **2)*q2_ad(i, j, k)
5780  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
5781  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
5782  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
5783  q2_ad(i, j, k) = 0.0
5784  temp_ad3 = pr_ad/dp1(i, l)
5785  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
5786  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
5787  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
5788 & /dp1(i, l)
5789  ELSE
5790  temp1 = pe2(i, k+1) - pe2(i, k)
5791  temp_ad11 = -(qsum*q2_ad(i, j, k)/temp1**2)
5792  qsum_ad = qsum_ad + q2_ad(i, j, k)/temp1
5793  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad11
5794  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad11
5795  q2_ad(i, j, k) = 0.0
5796  CALL popcontrol2b(branch)
5797  IF (branch .EQ. 0) THEN
5798  dp = pe2(i, k+1) - pe1(i, m)
5799  esl = dp/dp1(i, m)
5800  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
5801 & 1.)
5802  temp_ad8 = dp*qsum_ad
5803  temp_ad9 = 0.5*esl*temp_ad8
5804  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
5805  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
5806  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
5807  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
5808  temp_ad10 = esl_ad/dp1(i, m)
5809  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
5810  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
5811  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
5812  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
5813  ELSE IF (branch .NE. 1) THEN
5814  GOTO 130
5815  END IF
5816  CALL popinteger4(ad_count0)
5817  DO i3=1,ad_count0
5818  IF (i3 .EQ. 1) THEN
5819  CALL popcontrol1b(branch)
5820  ELSE
5821  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
5822  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
5823  END IF
5824  CALL popinteger4(m)
5825  END DO
5826  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5827  CALL poprealarray_adm(qsum)
5828  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
5829  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
5830 & *(pl+1.)+1.)))*qsum_ad
5831  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
5832  temp_ad6 = 0.5*(pl+1.)*temp_ad5
5833  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
5834  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
5835  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
5836  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
5837  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
5838 & )*temp_ad5
5839  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
5840  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
5841  qsum_ad = 0.0
5842  END IF
5843  temp_ad = pl_ad/dp1(i, l)
5844  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
5845  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
5846  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
5847 & i, l)
5848  130 CALL popinteger4(ad_count)
5849  DO i0=1,ad_count
5850  IF (i0 .EQ. 1) CALL popcontrol1b(branch)
5851  CALL popinteger4(l)
5852  END DO
5853  END DO
5854  END DO
5855  CALL popcontrol1b(branch)
5856  IF (branch .EQ. 0) THEN
5857  CALL ppm_profile_bwd(q4, q4_ad, dp1, dp1_ad, km, i1, i2, iv, kord)
5858  ELSE
5859  CALL poprealarray_adm(q4, 4*(i2-i1+1)*km)
5860  CALL cs_profile_adm(qs, qs_ad, q4, q4_ad, dp1, dp1_ad, km, i1, i2&
5861 & , iv, kord)
5862  END IF
5863  DO k=km,1,-1
5864  DO i=i2,i1,-1
5865  q2_ad(i, j, k) = q2_ad(i, j, k) + q4_ad(1, i, k)
5866  q4_ad(1, i, k) = 0.0
5867  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
5868  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
5869  dp1_ad(i, k) = 0.0
5870  END DO
5871  END DO
5872  END SUBROUTINE map1_ppm_adm
5873  SUBROUTINE map1_ppm(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, &
5874 & jbeg, jend, iv, kord)
5875  IMPLICIT NONE
5876 ! Starting longitude
5877  INTEGER, INTENT(IN) :: i1
5878 ! Finishing longitude
5879  INTEGER, INTENT(IN) :: i2
5880 ! Mode: 0 == constituents 1 == ???
5881  INTEGER, INTENT(IN) :: iv
5882 ! 2 == remap temp with cs scheme
5883 ! Method order
5884  INTEGER, INTENT(IN) :: kord
5885 ! Current latitude
5886  INTEGER, INTENT(IN) :: j
5887  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
5888 ! Original vertical dimension
5889  INTEGER, INTENT(IN) :: km
5890 ! Target vertical dimension
5891  INTEGER, INTENT(IN) :: kn
5892 ! bottom BC
5893  REAL, INTENT(IN) :: qs(i1:i2)
5894 ! pressure at layer edges
5895  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5896 ! (from model top to bottom surface)
5897 ! in the original vertical coordinate
5898 ! pressure at layer edges
5899  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5900 ! (from model top to bottom surface)
5901 ! in the new vertical coordinate
5902 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
5903 ! !INPUT/OUTPUT PARAMETERS:
5904 ! Field output
5905  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
5906 ! !DESCRIPTION:
5907 ! IV = 0: constituents
5908 ! pe1: pressure at layer edges (from model top to bottom surface)
5909 ! in the original vertical coordinate
5910 ! pe2: pressure at layer edges (from model top to bottom surface)
5911 ! in the new vertical coordinate
5912 ! !LOCAL VARIABLES:
5913  REAL :: dp1(i1:i2, km)
5914  REAL :: q4(4, i1:i2, km)
5915  REAL :: pl, pr, qsum, dp, esl
5916  INTEGER :: i, k, l, m, k0
5917  DO k=1,km
5918  DO i=i1,i2
5919  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5920  q4(1, i, k) = q2(i, j, k)
5921  END DO
5922  END DO
5923 ! Compute vertical subgrid distribution
5924  IF (kord .GT. 7) THEN
5925  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
5926  ELSE
5927  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
5928  END IF
5929  DO i=i1,i2
5930  k0 = 1
5931  DO k=1,kn
5932  DO l=k0,km
5933 ! locate the top edge: pe2(i,k)
5934  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
5935 & ) THEN
5936  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5937  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5938 ! entire new grid is within the original grid
5939  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5940  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-&
5941 & q4(2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
5942  k0 = l
5943  GOTO 555
5944  ELSE
5945 ! Fractional area...
5946  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
5947 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
5948 & pl*(1.+pl))))
5949  DO m=l+1,km
5950 ! locate the bottom edge: pe2(i,k+1)
5951  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
5952 ! Whole layer
5953  qsum = qsum + dp1(i, m)*q4(1, i, m)
5954  ELSE
5955  dp = pe2(i, k+1) - pe1(i, m)
5956  esl = dp/dp1(i, m)
5957  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
5958 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
5959  k0 = m
5960  GOTO 123
5961  END IF
5962  END DO
5963  GOTO 123
5964  END IF
5965  END IF
5966  END DO
5967  123 q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
5968  555 CONTINUE
5969  END DO
5970  END DO
5971  END SUBROUTINE map1_ppm
5972 ! Differentiation of mapn_tracer in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dy
5973 !n_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p_grad_c d
5974 !yn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp dyn_core
5975 !_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dyna
5976 !mics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_util
5977 !s_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz_
5978 !mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.sca
5979 !lar_profile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.st
5980 !eepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.d2c
5981 !_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.c
5982 !ompute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solve
5983 !r_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3p0_solve
5984 !r nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh
5985 !sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_co
5986 !re_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mod
5987 !.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corne
5988 !rs_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_cir
5989 !cle_dist sw_core_mod.edge_interpolate4)):
5990 ! gradient of useful results: pe1 pe2 dp2 q1
5991 ! with respect to varying inputs: pe1 pe2 dp2 q1
5992  SUBROUTINE mapn_tracer_adm(nq, km, pe1, pe1_ad, pe2, pe2_ad, q1, q1_ad&
5993 & , dp2, dp2_ad, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
5994  IMPLICIT NONE
5995 ! !INPUT PARAMETERS:
5996 ! vertical dimension
5997  INTEGER, INTENT(IN) :: km
5998  INTEGER, INTENT(IN) :: j, nq, i1, i2
5999  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
6000  INTEGER, INTENT(IN) :: kord(nq)
6001 ! pressure at layer edges
6002  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
6003  REAL :: pe1_ad(i1:i2, km+1)
6004 ! (from model top to bottom surface)
6005 ! in the original vertical coordinate
6006 ! pressure at layer edges
6007  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
6008  REAL :: pe2_ad(i1:i2, km+1)
6009 ! (from model top to bottom surface)
6010 ! in the new vertical coordinate
6011  REAL, INTENT(IN) :: dp2(i1:i2, km)
6012  REAL :: dp2_ad(i1:i2, km)
6013  REAL, INTENT(IN) :: q_min
6014  LOGICAL, INTENT(IN) :: fill
6015 ! Field input
6016  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
6017  REAL, INTENT(INOUT) :: q1_ad(isd:ied, jsd:jed, km, nq)
6018 ! !LOCAL VARIABLES:
6019  REAL :: q4(4, i1:i2, km, nq)
6020  REAL :: q4_ad(4, i1:i2, km, nq)
6021 ! Field output
6022  REAL :: q2(i1:i2, km, nq)
6023  REAL :: q2_ad(i1:i2, km, nq)
6024  REAL :: qsum(nq)
6025  REAL :: qsum_ad(nq)
6026  REAL :: dp1(i1:i2, km)
6027  REAL :: dp1_ad(i1:i2, km)
6028  REAL :: qs(i1:i2)
6029  REAL :: pl, pr, dp, esl, fac1, fac2
6030  REAL :: pl_ad, pr_ad, dp_ad, esl_ad, fac1_ad, fac2_ad
6031  INTEGER :: i, k, l, m, k0, iq
6032  INTEGER :: arg1
6033  REAL :: temp_ad
6034  REAL :: temp_ad0
6035  REAL :: temp_ad1
6036  REAL :: temp_ad2
6037  REAL :: temp
6038  REAL :: temp_ad3
6039  REAL :: temp_ad4
6040  REAL :: temp_ad5
6041  REAL :: temp0
6042  REAL :: temp_ad6
6043  REAL :: temp_ad7
6044  REAL :: temp_ad8
6045  INTEGER :: ad_count
6046  INTEGER :: i0
6047  INTEGER :: branch
6048  INTEGER :: ad_count0
6049  INTEGER :: i3
6050  DO k=1,km
6051  DO i=i1,i2
6052  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
6053  END DO
6054  END DO
6055  DO iq=1,nq
6056  DO k=1,km
6057  DO i=i1,i2
6058  q4(1, i, k, iq) = q1(i, j, k, iq)
6059  END DO
6060  END DO
6061  CALL pushrealarray_adm(q4(:, :, :, iq), 4*(i2-i1+1)*km)
6062  CALL scalar_profile(qs, q4(1:4, i1:i2, 1:km, iq), dp1, km, i1, i2&
6063 & , 0, kord(iq), q_min)
6064  END DO
6065 ! Mapping
6066  DO i=i1,i2
6067  k0 = 1
6068  DO 130 k=1,km
6069  CALL pushinteger4(l)
6070  ad_count = 1
6071  DO l=k0,km
6072 ! locate the top edge: pe2(i,k)
6073  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
6074 & ) THEN
6075  GOTO 100
6076  ELSE
6077  CALL pushinteger4(l)
6078  ad_count = ad_count + 1
6079  END IF
6080  END DO
6081  CALL pushcontrol1b(0)
6082  CALL pushinteger4(ad_count)
6083  CALL pushcontrol2b(2)
6084  GOTO 120
6085  100 CALL pushcontrol1b(1)
6086  CALL pushinteger4(ad_count)
6087  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6088  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
6089 ! entire new grid is within the original grid
6090  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
6091  CALL pushrealarray_adm(fac1)
6092  fac1 = pr + pl
6093  CALL pushrealarray_adm(fac2)
6094  fac2 = r3*(pr*fac1+pl*pl)
6095  CALL pushrealarray_adm(fac1)
6096  fac1 = 0.5*fac1
6097  k0 = l
6098  CALL pushcontrol1b(0)
6099  GOTO 130
6100  ELSE
6101 ! Fractional area...
6102  CALL pushrealarray_adm(dp)
6103  dp = pe1(i, l+1) - pe2(i, k)
6104  CALL pushrealarray_adm(fac1)
6105  fac1 = 1. + pl
6106  CALL pushrealarray_adm(fac2)
6107  fac2 = r3*(1.+pl*fac1)
6108  CALL pushrealarray_adm(fac1)
6109  fac1 = 0.5*fac1
6110  DO iq=1,nq
6111  CALL pushrealarray_adm(qsum(iq))
6112  qsum(iq) = dp*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, i, l, &
6113 & iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2)
6114  END DO
6115  CALL pushinteger4(m)
6116  ad_count0 = 1
6117  DO m=l+1,km
6118 ! locate the bottom edge: pe2(i,k+1)
6119  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
6120 ! Whole layer..
6121  DO iq=1,nq
6122  CALL pushrealarray_adm(qsum(iq))
6123  qsum(iq) = qsum(iq) + dp1(i, m)*q4(1, i, m, iq)
6124  END DO
6125  CALL pushinteger4(m)
6126  ad_count0 = ad_count0 + 1
6127  ELSE
6128  GOTO 110
6129  END IF
6130  END DO
6131  CALL pushcontrol1b(0)
6132  CALL pushinteger4(ad_count0)
6133  CALL pushcontrol2b(1)
6134  GOTO 120
6135  110 CALL pushcontrol1b(1)
6136  CALL pushinteger4(ad_count0)
6137  CALL pushrealarray_adm(dp)
6138  dp = pe2(i, k+1) - pe1(i, m)
6139  esl = dp/dp1(i, m)
6140  CALL pushrealarray_adm(fac1)
6141  fac1 = 0.5*esl
6142  CALL pushrealarray_adm(fac2)
6143  fac2 = 1. - r23*esl
6144  DO iq=1,nq
6145  CALL pushrealarray_adm(qsum(iq))
6146  qsum(iq) = qsum(iq) + dp*(q4(2, i, m, iq)+fac1*(q4(3, i, m, &
6147 & iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2))
6148  END DO
6149  k0 = m
6150  CALL pushcontrol2b(0)
6151  END IF
6152  120 CALL pushcontrol1b(1)
6153  130 CONTINUE
6154  END DO
6155  q2_ad = 0.0
6156  DO iq=nq,1,-1
6157  DO k=km,1,-1
6158  DO i=i2,i1,-1
6159  q2_ad(i, k, iq) = q2_ad(i, k, iq) + q1_ad(i, j, k, iq)
6160  q1_ad(i, j, k, iq) = 0.0
6161  END DO
6162  END DO
6163  END DO
6164  dp1_ad = 0.0
6165  qsum_ad = 0.0
6166  q4_ad = 0.0
6167  DO i=i2,i1,-1
6168  DO k=km,1,-1
6169  CALL popcontrol1b(branch)
6170  IF (branch .EQ. 0) THEN
6171  fac1_ad = 0.0
6172  fac2_ad = 0.0
6173  DO iq=nq,1,-1
6174  temp_ad2 = fac1*q2_ad(i, k, iq)
6175  q4_ad(2, i, l, iq) = q4_ad(2, i, l, iq) + q2_ad(i, k, iq) - &
6176 & temp_ad2
6177  q4_ad(4, i, l, iq) = q4_ad(4, i, l, iq) + temp_ad2 - fac2*&
6178 & q2_ad(i, k, iq)
6179  q4_ad(3, i, l, iq) = q4_ad(3, i, l, iq) + temp_ad2
6180  fac1_ad = fac1_ad + (q4(4, i, l, iq)+q4(3, i, l, iq)-q4(2, i&
6181 & , l, iq))*q2_ad(i, k, iq)
6182  fac2_ad = fac2_ad - q4(4, i, l, iq)*q2_ad(i, k, iq)
6183  q2_ad(i, k, iq) = 0.0
6184  END DO
6185  temp_ad0 = r3*fac2_ad
6186  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6187  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
6188  CALL poprealarray_adm(fac1)
6189  fac1_ad = pr*temp_ad0 + 0.5*fac1_ad
6190  CALL poprealarray_adm(fac2)
6191  pr_ad = fac1_ad + fac1*temp_ad0
6192  pl_ad = fac1_ad + 2*pl*temp_ad0
6193  CALL poprealarray_adm(fac1)
6194  temp_ad1 = pr_ad/dp1(i, l)
6195  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad1
6196  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad1
6197  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad1&
6198 & /dp1(i, l)
6199  ELSE
6200  DO iq=nq,1,-1
6201  temp_ad8 = q2_ad(i, k, iq)/dp2(i, k)
6202  qsum_ad(iq) = qsum_ad(iq) + temp_ad8
6203  dp2_ad(i, k) = dp2_ad(i, k) - qsum(iq)*temp_ad8/dp2(i, k)
6204  q2_ad(i, k, iq) = 0.0
6205  END DO
6206  CALL popcontrol2b(branch)
6207  IF (branch .EQ. 0) THEN
6208  dp = pe2(i, k+1) - pe1(i, m)
6209  esl = dp/dp1(i, m)
6210  fac1 = 0.5*esl
6211  fac2 = 1. - r23*esl
6212  dp_ad = 0.0
6213  fac1_ad = 0.0
6214  fac2_ad = 0.0
6215  DO iq=nq,1,-1
6216  CALL poprealarray_adm(qsum(iq))
6217  temp0 = q4(3, i, m, iq) - q4(2, i, m, iq) + q4(4, i, m, iq&
6218 & )*fac2
6219  temp_ad6 = dp*qsum_ad(iq)
6220  temp_ad7 = fac1*temp_ad6
6221  dp_ad = dp_ad + (q4(2, i, m, iq)+fac1*temp0)*qsum_ad(iq)
6222  q4_ad(2, i, m, iq) = q4_ad(2, i, m, iq) + temp_ad6 - &
6223 & temp_ad7
6224  fac1_ad = fac1_ad + temp0*temp_ad6
6225  q4_ad(3, i, m, iq) = q4_ad(3, i, m, iq) + temp_ad7
6226  q4_ad(4, i, m, iq) = q4_ad(4, i, m, iq) + fac2*temp_ad7
6227  fac2_ad = fac2_ad + q4(4, i, m, iq)*temp_ad7
6228  END DO
6229  CALL poprealarray_adm(fac2)
6230  esl_ad = 0.5*fac1_ad - r23*fac2_ad
6231  CALL poprealarray_adm(fac1)
6232  temp_ad5 = esl_ad/dp1(i, m)
6233  dp_ad = dp_ad + temp_ad5
6234  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad5/dp1(i, m)
6235  CALL poprealarray_adm(dp)
6236  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
6237  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
6238  ELSE IF (branch .NE. 1) THEN
6239  GOTO 140
6240  END IF
6241  CALL popinteger4(ad_count0)
6242  DO i3=1,ad_count0
6243  IF (i3 .EQ. 1) THEN
6244  CALL popcontrol1b(branch)
6245  ELSE
6246  DO iq=nq,1,-1
6247  CALL poprealarray_adm(qsum(iq))
6248  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m, iq)*qsum_ad(iq&
6249 & )
6250  q4_ad(1, i, m, iq) = q4_ad(1, i, m, iq) + dp1(i, m)*&
6251 & qsum_ad(iq)
6252  END DO
6253  END IF
6254  CALL popinteger4(m)
6255  END DO
6256  dp_ad = 0.0
6257  fac1_ad = 0.0
6258  fac2_ad = 0.0
6259  DO iq=nq,1,-1
6260  CALL poprealarray_adm(qsum(iq))
6261  temp = q4(4, i, l, iq) + q4(3, i, l, iq) - q4(2, i, l, iq)
6262  temp_ad3 = dp*qsum_ad(iq)
6263  temp_ad4 = fac1*temp_ad3
6264  dp_ad = dp_ad + (q4(2, i, l, iq)+temp*fac1-q4(4, i, l, iq)*&
6265 & fac2)*qsum_ad(iq)
6266  q4_ad(2, i, l, iq) = q4_ad(2, i, l, iq) + temp_ad3 - &
6267 & temp_ad4
6268  q4_ad(4, i, l, iq) = q4_ad(4, i, l, iq) + temp_ad4 - fac2*&
6269 & temp_ad3
6270  q4_ad(3, i, l, iq) = q4_ad(3, i, l, iq) + temp_ad4
6271  fac1_ad = fac1_ad + temp*temp_ad3
6272  fac2_ad = fac2_ad - q4(4, i, l, iq)*temp_ad3
6273  qsum_ad(iq) = 0.0
6274  END DO
6275  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6276  CALL poprealarray_adm(fac1)
6277  fac1_ad = r3*pl*fac2_ad + 0.5*fac1_ad
6278  CALL poprealarray_adm(fac2)
6279  pl_ad = fac1_ad + r3*fac1*fac2_ad
6280  CALL poprealarray_adm(fac1)
6281  CALL poprealarray_adm(dp)
6282  pe1_ad(i, l+1) = pe1_ad(i, l+1) + dp_ad
6283  pe2_ad(i, k) = pe2_ad(i, k) - dp_ad
6284  END IF
6285  temp_ad = pl_ad/dp1(i, l)
6286  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
6287  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
6288  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
6289 & i, l)
6290  140 CALL popinteger4(ad_count)
6291  DO i0=1,ad_count
6292  IF (i0 .EQ. 1) CALL popcontrol1b(branch)
6293  CALL popinteger4(l)
6294  END DO
6295  END DO
6296  END DO
6297  DO iq=nq,1,-1
6298  CALL poprealarray_adm(q4(:, :, :, iq), 4*(i2-i1+1)*km)
6299  CALL scalar_profile_adm(qs, q4(1:4, i1:i2, 1:km, iq), q4_ad(1:4, &
6300 & i1:i2, 1:km, iq), dp1, dp1_ad, km, i1, i2, 0, &
6301 & kord(iq), q_min)
6302  DO k=km,1,-1
6303  DO i=i2,i1,-1
6304  q1_ad(i, j, k, iq) = q1_ad(i, j, k, iq) + q4_ad(1, i, k, iq)
6305  q4_ad(1, i, k, iq) = 0.0
6306  END DO
6307  END DO
6308  END DO
6309  DO k=km,1,-1
6310  DO i=i2,i1,-1
6311  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
6312  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
6313  dp1_ad(i, k) = 0.0
6314  END DO
6315  END DO
6316  END SUBROUTINE mapn_tracer_adm
6317  SUBROUTINE mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, i1, i2, isd&
6318 & , ied, jsd, jed, q_min, fill)
6319  IMPLICIT NONE
6320 ! !INPUT PARAMETERS:
6321 ! vertical dimension
6322  INTEGER, INTENT(IN) :: km
6323  INTEGER, INTENT(IN) :: j, nq, i1, i2
6324  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
6325  INTEGER, INTENT(IN) :: kord(nq)
6326 ! pressure at layer edges
6327  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
6328 ! (from model top to bottom surface)
6329 ! in the original vertical coordinate
6330 ! pressure at layer edges
6331  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
6332 ! (from model top to bottom surface)
6333 ! in the new vertical coordinate
6334  REAL, INTENT(IN) :: dp2(i1:i2, km)
6335  REAL, INTENT(IN) :: q_min
6336  LOGICAL, INTENT(IN) :: fill
6337 ! Field input
6338  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
6339 ! !LOCAL VARIABLES:
6340  REAL :: q4(4, i1:i2, km, nq)
6341 ! Field output
6342  REAL :: q2(i1:i2, km, nq)
6343  REAL :: qsum(nq)
6344  REAL :: dp1(i1:i2, km)
6345  REAL :: qs(i1:i2)
6346  REAL :: pl, pr, dp, esl, fac1, fac2
6347  INTEGER :: i, k, l, m, k0, iq
6348  INTEGER :: arg1
6349  DO k=1,km
6350  DO i=i1,i2
6351  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
6352  END DO
6353  END DO
6354  DO iq=1,nq
6355  DO k=1,km
6356  DO i=i1,i2
6357  q4(1, i, k, iq) = q1(i, j, k, iq)
6358  END DO
6359  END DO
6360  CALL scalar_profile(qs, q4(1:4, i1:i2, 1:km, iq), dp1, km, i1, i2&
6361 & , 0, kord(iq), q_min)
6362  END DO
6363 ! Mapping
6364  DO i=i1,i2
6365  k0 = 1
6366  DO k=1,km
6367  DO l=k0,km
6368 ! locate the top edge: pe2(i,k)
6369  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
6370 & ) THEN
6371  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6372  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
6373 ! entire new grid is within the original grid
6374  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
6375  fac1 = pr + pl
6376  fac2 = r3*(pr*fac1+pl*pl)
6377  fac1 = 0.5*fac1
6378  DO iq=1,nq
6379  q2(i, k, iq) = q4(2, i, l, iq) + (q4(4, i, l, iq)+q4(3, &
6380 & i, l, iq)-q4(2, i, l, iq))*fac1 - q4(4, i, l, iq)*fac2
6381  END DO
6382  k0 = l
6383  GOTO 555
6384  ELSE
6385 ! Fractional area...
6386  dp = pe1(i, l+1) - pe2(i, k)
6387  fac1 = 1. + pl
6388  fac2 = r3*(1.+pl*fac1)
6389  fac1 = 0.5*fac1
6390  DO iq=1,nq
6391  qsum(iq) = dp*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, i&
6392 & , l, iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2)
6393  END DO
6394  DO m=l+1,km
6395 ! locate the bottom edge: pe2(i,k+1)
6396  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
6397 ! Whole layer..
6398  DO iq=1,nq
6399  qsum(iq) = qsum(iq) + dp1(i, m)*q4(1, i, m, iq)
6400  END DO
6401  ELSE
6402  dp = pe2(i, k+1) - pe1(i, m)
6403  esl = dp/dp1(i, m)
6404  fac1 = 0.5*esl
6405  fac2 = 1. - r23*esl
6406  DO iq=1,nq
6407  qsum(iq) = qsum(iq) + dp*(q4(2, i, m, iq)+fac1*(q4(3&
6408 & , i, m, iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2))
6409  END DO
6410  k0 = m
6411  GOTO 123
6412  END IF
6413  END DO
6414  GOTO 123
6415  END IF
6416  END IF
6417  END DO
6418  123 CONTINUE
6419  DO iq=1,nq
6420  q2(i, k, iq) = qsum(iq)/dp2(i, k)
6421  END DO
6422  555 CONTINUE
6423  END DO
6424  END DO
6425  IF (fill) THEN
6426  arg1 = i2 - i1 + 1
6427  CALL fillz(arg1, km, nq, q2, dp2)
6428  END IF
6429  DO iq=1,nq
6430 ! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2)
6431  DO k=1,km
6432  DO i=i1,i2
6433  q1(i, j, k, iq) = q2(i, k, iq)
6434  END DO
6435  END DO
6436  END DO
6437  END SUBROUTINE mapn_tracer
6438 ! Differentiation of map1_q2 in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_co
6439 !re_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_c
6440 !ore_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
6441 !.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamics
6442 !_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_mo
6443 !d.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.
6444 !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_
6445 !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.steepz
6446 ! 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_set
6447 !up 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.compu
6448 !te_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
6449 !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 nh
6450 !_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_c
6451 !ore_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_m
6452 !od.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.com
6453 !pute_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_f
6454 !b tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle_
6455 !dist sw_core_mod.edge_interpolate4)):
6456 ! gradient of useful results: pe1 pe2 dp2 q1 q2
6457 ! with respect to varying inputs: pe1 pe2 dp2 q1 q2
6458  SUBROUTINE map1_q2_adm(km, pe1, pe1_ad, q1, q1_ad, kn, pe2, pe2_ad, q2&
6459 & , q2_ad, dp2, dp2_ad, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, &
6460 & q_min)
6461  IMPLICIT NONE
6462 ! !INPUT PARAMETERS:
6463  INTEGER, INTENT(IN) :: j
6464  INTEGER, INTENT(IN) :: i1, i2
6465  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
6466 ! Mode: 0 == constituents 1 == ???
6467  INTEGER, INTENT(IN) :: iv
6468  INTEGER, INTENT(IN) :: kord
6469 ! Original vertical dimension
6470  INTEGER, INTENT(IN) :: km
6471 ! Target vertical dimension
6472  INTEGER, INTENT(IN) :: kn
6473 ! pressure at layer edges
6474  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
6475  REAL :: pe1_ad(i1:i2, km+1)
6476 ! (from model top to bottom surface)
6477 ! in the original vertical coordinate
6478 ! pressure at layer edges
6479  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
6480  REAL :: pe2_ad(i1:i2, kn+1)
6481 ! (from model top to bottom surface)
6482 ! in the new vertical coordinate
6483 ! Field input
6484  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
6485  REAL :: q1_ad(ibeg:iend, jbeg:jend, km)
6486  REAL, INTENT(IN) :: dp2(i1:i2, kn)
6487  REAL :: dp2_ad(i1:i2, kn)
6488  REAL, INTENT(IN) :: q_min
6489 ! !INPUT/OUTPUT PARAMETERS:
6490 ! Field output
6491  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
6492  REAL, INTENT(INOUT) :: q2_ad(i1:i2, kn)
6493 ! !LOCAL VARIABLES:
6494  REAL :: qs(i1:i2)
6495  REAL :: dp1(i1:i2, km)
6496  REAL :: dp1_ad(i1:i2, km)
6497  REAL :: q4(4, i1:i2, km)
6498  REAL :: q4_ad(4, i1:i2, km)
6499  REAL :: pl, pr, qsum, dp, esl
6500  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
6501  INTEGER :: i, k, l, m, k0
6502  REAL :: temp_ad
6503  REAL :: temp_ad0
6504  REAL :: temp_ad1
6505  REAL :: temp_ad2
6506  REAL :: temp_ad3
6507  REAL :: temp
6508  REAL :: temp_ad4
6509  REAL :: temp_ad5
6510  REAL :: temp_ad6
6511  REAL :: temp_ad7
6512  REAL :: temp0
6513  REAL :: temp_ad8
6514  REAL :: temp_ad9
6515  REAL :: temp_ad10
6516  REAL :: temp_ad11
6517  INTEGER :: ad_count
6518  INTEGER :: i0
6519  INTEGER :: branch
6520  INTEGER :: ad_count0
6521  INTEGER :: i3
6522  DO k=1,km
6523  DO i=i1,i2
6524  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
6525  q4(1, i, k) = q1(i, j, k)
6526  END DO
6527  END DO
6528 ! Compute vertical subgrid distribution
6529  IF (kord .GT. 7) THEN
6530  CALL pushrealarray_adm(q4, 4*(i2-i1+1)*km)
6531  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
6532  CALL pushcontrol1b(1)
6533  ELSE
6534  CALL ppm_profile_fwd(q4, dp1, km, i1, i2, iv, kord)
6535  CALL pushcontrol1b(0)
6536  END IF
6537 ! Mapping
6538  DO i=i1,i2
6539  k0 = 1
6540  DO 120 k=1,kn
6541  CALL pushinteger4(l)
6542  ad_count = 1
6543  DO l=k0,km
6544 ! locate the top edge: pe2(i,k)
6545  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
6546 & ) THEN
6547  GOTO 100
6548  ELSE
6549  CALL pushinteger4(l)
6550  ad_count = ad_count + 1
6551  END IF
6552  END DO
6553  CALL pushcontrol1b(0)
6554  CALL pushinteger4(ad_count)
6555  CALL pushcontrol2b(2)
6556  GOTO 123
6557  100 CALL pushcontrol1b(1)
6558  CALL pushinteger4(ad_count)
6559  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6560  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
6561 ! entire new grid is within the original grid
6562  k0 = l
6563  CALL pushcontrol1b(0)
6564  GOTO 120
6565  ELSE
6566 ! Fractional area...
6567  CALL pushrealarray_adm(qsum)
6568  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
6569 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
6570 & pl))))
6571  CALL pushinteger4(m)
6572  ad_count0 = 1
6573  DO m=l+1,km
6574 ! locate the bottom edge: pe2(i,k+1)
6575  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
6576 ! Whole layer..
6577  qsum = qsum + dp1(i, m)*q4(1, i, m)
6578  CALL pushinteger4(m)
6579  ad_count0 = ad_count0 + 1
6580  ELSE
6581  GOTO 110
6582  END IF
6583  END DO
6584  CALL pushcontrol1b(0)
6585  CALL pushinteger4(ad_count0)
6586  CALL pushcontrol2b(1)
6587  GOTO 123
6588  110 CALL pushcontrol1b(1)
6589  CALL pushinteger4(ad_count0)
6590  dp = pe2(i, k+1) - pe1(i, m)
6591  esl = dp/dp1(i, m)
6592  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
6593 & +q4(4, i, m)*(1.-r23*esl)))
6594  k0 = m
6595  CALL pushcontrol2b(0)
6596  END IF
6597  123 CALL pushcontrol1b(1)
6598  120 CONTINUE
6599  END DO
6600  dp1_ad = 0.0
6601  qsum_ad = 0.0
6602  q4_ad = 0.0
6603  DO i=i2,i1,-1
6604  DO k=kn,1,-1
6605  CALL popcontrol1b(branch)
6606  IF (branch .EQ. 0) THEN
6607  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6608  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
6609  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, k)
6610  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
6611 & k)
6612  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, k))
6613  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, k) - temp_ad0
6614  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
6615 & **2)*q2_ad(i, k)
6616  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
6617  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
6618  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
6619  q2_ad(i, k) = 0.0
6620  temp_ad3 = pr_ad/dp1(i, l)
6621  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
6622  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
6623  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
6624 & /dp1(i, l)
6625  ELSE
6626  temp_ad11 = q2_ad(i, k)/dp2(i, k)
6627  qsum_ad = qsum_ad + temp_ad11
6628  dp2_ad(i, k) = dp2_ad(i, k) - qsum*temp_ad11/dp2(i, k)
6629  q2_ad(i, k) = 0.0
6630  CALL popcontrol2b(branch)
6631  IF (branch .EQ. 0) THEN
6632  dp = pe2(i, k+1) - pe1(i, m)
6633  esl = dp/dp1(i, m)
6634  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
6635 & 1.)
6636  temp_ad8 = dp*qsum_ad
6637  temp_ad9 = 0.5*esl*temp_ad8
6638  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
6639  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
6640  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
6641  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
6642  temp_ad10 = esl_ad/dp1(i, m)
6643  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
6644  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
6645  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
6646  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
6647  ELSE IF (branch .NE. 1) THEN
6648  GOTO 130
6649  END IF
6650  CALL popinteger4(ad_count0)
6651  DO i3=1,ad_count0
6652  IF (i3 .EQ. 1) THEN
6653  CALL popcontrol1b(branch)
6654  ELSE
6655  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
6656  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
6657  END IF
6658  CALL popinteger4(m)
6659  END DO
6660  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6661  CALL poprealarray_adm(qsum)
6662  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
6663  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
6664 & *(pl+1.)+1.)))*qsum_ad
6665  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
6666  temp_ad6 = 0.5*(pl+1.)*temp_ad5
6667  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
6668  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
6669  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
6670  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
6671  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
6672 & )*temp_ad5
6673  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
6674  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
6675  qsum_ad = 0.0
6676  END IF
6677  temp_ad = pl_ad/dp1(i, l)
6678  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
6679  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
6680  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
6681 & i, l)
6682  130 CALL popinteger4(ad_count)
6683  DO i0=1,ad_count
6684  IF (i0 .EQ. 1) CALL popcontrol1b(branch)
6685  CALL popinteger4(l)
6686  END DO
6687  END DO
6688  END DO
6689  CALL popcontrol1b(branch)
6690  IF (branch .EQ. 0) THEN
6691  CALL ppm_profile_bwd(q4, q4_ad, dp1, dp1_ad, km, i1, i2, iv, kord)
6692  ELSE
6693  CALL poprealarray_adm(q4, 4*(i2-i1+1)*km)
6694  CALL scalar_profile_adm(qs, q4, q4_ad, dp1, dp1_ad, km, i1, i2, iv&
6695 & , kord, q_min)
6696  END IF
6697  DO k=km,1,-1
6698  DO i=i2,i1,-1
6699  q1_ad(i, j, k) = q1_ad(i, j, k) + q4_ad(1, i, k)
6700  q4_ad(1, i, k) = 0.0
6701  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
6702  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
6703  dp1_ad(i, k) = 0.0
6704  END DO
6705  END DO
6706  END SUBROUTINE map1_q2_adm
6707  SUBROUTINE map1_q2(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j&
6708 & , ibeg, iend, jbeg, jend, q_min)
6709  IMPLICIT NONE
6710 ! !INPUT PARAMETERS:
6711  INTEGER, INTENT(IN) :: j
6712  INTEGER, INTENT(IN) :: i1, i2
6713  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
6714 ! Mode: 0 == constituents 1 == ???
6715  INTEGER, INTENT(IN) :: iv
6716  INTEGER, INTENT(IN) :: kord
6717 ! Original vertical dimension
6718  INTEGER, INTENT(IN) :: km
6719 ! Target vertical dimension
6720  INTEGER, INTENT(IN) :: kn
6721 ! pressure at layer edges
6722  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
6723 ! (from model top to bottom surface)
6724 ! in the original vertical coordinate
6725 ! pressure at layer edges
6726  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
6727 ! (from model top to bottom surface)
6728 ! in the new vertical coordinate
6729 ! Field input
6730  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
6731  REAL, INTENT(IN) :: dp2(i1:i2, kn)
6732  REAL, INTENT(IN) :: q_min
6733 ! !INPUT/OUTPUT PARAMETERS:
6734 ! Field output
6735  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
6736 ! !LOCAL VARIABLES:
6737  REAL :: qs(i1:i2)
6738  REAL :: dp1(i1:i2, km)
6739  REAL :: q4(4, i1:i2, km)
6740  REAL :: pl, pr, qsum, dp, esl
6741  INTEGER :: i, k, l, m, k0
6742  DO k=1,km
6743  DO i=i1,i2
6744  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
6745  q4(1, i, k) = q1(i, j, k)
6746  END DO
6747  END DO
6748 ! Compute vertical subgrid distribution
6749  IF (kord .GT. 7) THEN
6750  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
6751  ELSE
6752  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
6753  END IF
6754 ! Mapping
6755  DO i=i1,i2
6756  k0 = 1
6757  DO k=1,kn
6758  DO l=k0,km
6759 ! locate the top edge: pe2(i,k)
6760  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
6761 & ) THEN
6762  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
6763  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
6764 ! entire new grid is within the original grid
6765  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
6766  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
6767 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
6768  k0 = l
6769  GOTO 555
6770  ELSE
6771 ! Fractional area...
6772  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
6773 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
6774 & pl*(1.+pl))))
6775  DO m=l+1,km
6776 ! locate the bottom edge: pe2(i,k+1)
6777  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
6778 ! Whole layer..
6779  qsum = qsum + dp1(i, m)*q4(1, i, m)
6780  ELSE
6781  dp = pe2(i, k+1) - pe1(i, m)
6782  esl = dp/dp1(i, m)
6783  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
6784 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
6785  k0 = m
6786  GOTO 123
6787  END IF
6788  END DO
6789  GOTO 123
6790  END IF
6791  END IF
6792  END DO
6793  123 q2(i, k) = qsum/dp2(i, k)
6794  555 CONTINUE
6795  END DO
6796  END DO
6797  END SUBROUTINE map1_q2
6798 ! Differentiation of scalar_profile in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2
6799 ! dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p_grad_
6800 !c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp dyn_c
6801 !ore_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_d
6802 !ynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_u
6803 !tils_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_ma
6804 !pz_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.
6805 !scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod
6806 !.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.
6807 !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 main_mo
6808 !d.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_So
6809 !lver_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_so
6810 !lver 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_
6811 !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_vect sw
6812 !_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_
6813 !mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_co
6814 !rners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_
6815 !circle_dist sw_core_mod.edge_interpolate4)):
6816 ! gradient of useful results: delp a4
6817 ! with respect to varying inputs: delp a4
6818  SUBROUTINE scalar_profile_adm(qs, a4, a4_ad, delp, delp_ad, km, i1, i2&
6819 & , iv, kord, qmin)
6820  IMPLICIT NONE
6821 ! Optimized vertical profile reconstruction:
6822 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
6823  INTEGER, INTENT(IN) :: i1, i2
6824 ! vertical dimension
6825  INTEGER, INTENT(IN) :: km
6826 ! iv =-1: winds
6827  INTEGER, INTENT(IN) :: iv
6828 ! iv = 0: positive definite scalars
6829 ! iv = 1: others
6830  INTEGER, INTENT(IN) :: kord
6831  REAL, INTENT(IN) :: qs(i1:i2)
6832 ! layer pressure thickness
6833  REAL, INTENT(IN) :: delp(i1:i2, km)
6834  REAL :: delp_ad(i1:i2, km)
6835 ! Interpolated values
6836  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
6837  REAL, INTENT(INOUT) :: a4_ad(4, i1:i2, km)
6838  REAL, INTENT(IN) :: qmin
6839 !-----------------------------------------------------------------------
6840  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
6841  REAL :: gam(i1:i2, km)
6842  REAL :: gam_ad(i1:i2, km)
6843  REAL :: q(i1:i2, km+1)
6844  REAL :: q_ad(i1:i2, km+1)
6845  REAL :: d4(i1:i2)
6846  REAL :: d4_ad(i1:i2)
6847  REAL :: bet, a_bot, grat
6848  REAL :: bet_ad, a_bot_ad, grat_ad
6849  REAL :: pmp_1, lac_1, pmp_2, lac_2
6850  REAL :: pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
6851  INTEGER :: i, k, im
6852  INTRINSIC abs
6853  INTRINSIC max
6854  INTRINSIC min
6855  INTEGER :: abs0
6856  INTEGER :: abs1
6857  REAL :: abs2
6858  INTEGER :: abs3
6859  INTEGER :: abs4
6860  REAL :: abs5
6861  INTEGER :: abs6
6862  REAL :: abs7
6863  INTEGER :: abs8
6864  REAL :: abs9
6865  INTEGER :: abs10
6866  INTEGER :: abs11
6867  INTEGER :: abs12
6868  REAL :: abs13
6869  REAL :: abs14
6870  REAL :: abs15
6871  REAL :: abs16
6872  REAL :: temp_ad
6873  REAL :: temp_ad0
6874  REAL :: temp
6875  REAL :: temp_ad1
6876  REAL :: temp_ad2
6877  REAL :: temp_ad3
6878  REAL :: temp0
6879  REAL :: temp_ad4
6880  REAL :: temp_ad5
6881  REAL :: temp_ad6
6882  REAL :: temp_ad7
6883  REAL :: temp_ad8
6884  REAL :: temp_ad9
6885  REAL :: temp_ad10
6886  REAL :: temp1
6887  REAL :: temp2
6888  REAL :: temp_ad11
6889  REAL :: temp_ad12
6890  REAL :: temp_ad13
6891  REAL :: temp_ad14
6892  REAL :: y1_ad
6893  REAL :: y2_ad
6894  REAL :: y3_ad
6895  REAL :: y4_ad
6896  REAL :: y5_ad
6897  REAL :: y6_ad
6898  REAL :: y7_ad
6899  REAL :: y8_ad
6900  REAL :: temp_ad15
6901  REAL :: temp_ad16
6902  REAL :: temp_ad17
6903  REAL :: y21_ad
6904  REAL :: x1_ad
6905  REAL :: y9_ad
6906  REAL :: y22_ad
6907  REAL :: x2_ad
6908  REAL :: y10_ad
6909  REAL :: temp_ad18
6910  REAL :: temp_ad19
6911  REAL :: y23_ad
6912  REAL :: x3_ad
6913  REAL :: y11_ad
6914  REAL :: y24_ad
6915  REAL :: x4_ad
6916  REAL :: y12_ad
6917  REAL :: temp_ad20
6918  REAL :: y25_ad
6919  REAL :: x5_ad
6920  REAL :: y13_ad
6921  REAL :: y26_ad
6922  REAL :: x6_ad
6923  REAL :: y14_ad
6924  REAL :: y27_ad
6925  REAL :: x7_ad
6926  REAL :: y15_ad
6927  REAL :: y28_ad
6928  REAL :: x8_ad
6929  REAL :: y16_ad
6930  REAL :: y29_ad
6931  REAL :: x9_ad
6932  REAL :: y17_ad
6933  REAL :: y30_ad
6934  REAL :: x10_ad
6935  REAL :: y18_ad
6936  REAL :: temp_ad21
6937  REAL :: temp_ad22
6938  REAL :: temp_ad23
6939  REAL :: y31_ad
6940  REAL :: x11_ad
6941  REAL :: y19_ad
6942  REAL :: y32_ad
6943  REAL :: x12_ad
6944  REAL :: y20_ad
6945  REAL :: temp_ad24
6946  REAL :: temp_ad25
6947  REAL :: temp_ad26
6948  INTEGER :: branch
6949  REAL :: x12
6950  REAL :: x11
6951  REAL :: y29
6952  REAL :: x10
6953  REAL :: y28
6954  REAL :: y27
6955  REAL :: y26
6956  REAL :: y25
6957  REAL :: y24
6958  REAL :: y23
6959  REAL :: y22
6960  REAL :: y21
6961  REAL :: y20
6962  REAL :: x9
6963  REAL :: x8
6964  REAL :: x7
6965  REAL :: x6
6966  REAL :: x5
6967  REAL :: x4
6968  REAL :: x3
6969  REAL :: x2
6970  REAL :: x1
6971  REAL :: y19
6972  REAL :: y18
6973  REAL :: y17
6974  REAL :: y16
6975  REAL :: y15
6976  REAL :: y14
6977  REAL :: y13
6978  REAL :: y12
6979  REAL :: y11
6980  REAL :: y10
6981  REAL :: y32
6982  REAL :: y31
6983  REAL :: y30
6984  REAL :: y9
6985  REAL :: y8
6986  REAL :: y7
6987  REAL :: y6
6988  REAL :: y5
6989  REAL :: y4
6990  REAL :: y3
6991  REAL :: y2
6992  REAL :: y1
6993  IF (iv .EQ. -2) THEN
6994  DO i=i1,i2
6995  gam(i, 2) = 0.5
6996  q(i, 1) = 1.5*a4(1, i, 1)
6997  END DO
6998  DO k=2,km-1
6999  DO i=i1,i2
7000  grat = delp(i, k-1)/delp(i, k)
7001  CALL pushrealarray_adm(bet)
7002  bet = 2. + grat + grat - gam(i, k)
7003  CALL pushrealarray_adm(q(i, k))
7004  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
7005  gam(i, k+1) = grat/bet
7006  END DO
7007  END DO
7008  DO i=i1,i2
7009  grat = delp(i, km-1)/delp(i, km)
7010  CALL pushrealarray_adm(q(i, km))
7011  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
7012 & 1))/(2.+grat+grat-gam(i, km))
7013  CALL pushrealarray_adm(q(i, km+1))
7014  q(i, km+1) = qs(i)
7015  END DO
7016  DO k=km-1,1,-1
7017  DO i=i1,i2
7018  CALL pushrealarray_adm(q(i, k))
7019  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
7020  END DO
7021  END DO
7022  CALL pushcontrol1b(1)
7023  ELSE
7024  DO i=i1,i2
7025 ! grid ratio
7026  grat = delp(i, 2)/delp(i, 1)
7027  bet = grat*(grat+0.5)
7028  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
7029  gam(i, 1) = (1.+grat*(grat+1.5))/bet
7030  END DO
7031  DO k=2,km
7032  DO i=i1,i2
7033  CALL pushrealarray_adm(d4(i))
7034  d4(i) = delp(i, k-1)/delp(i, k)
7035  CALL pushrealarray_adm(bet)
7036  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
7037  CALL pushrealarray_adm(q(i, k))
7038  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
7039  gam(i, k) = d4(i)/bet
7040  END DO
7041  END DO
7042  DO i=i1,i2
7043  a_bot = 1. + d4(i)*(d4(i)+1.5)
7044  CALL pushrealarray_adm(q(i, km+1))
7045  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
7046 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
7047  END DO
7048  DO k=km,1,-1
7049  DO i=i1,i2
7050  CALL pushrealarray_adm(q(i, k))
7051  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
7052  END DO
7053  END DO
7054  CALL pushcontrol1b(0)
7055  END IF
7056  IF (kord .GE. 0.) THEN
7057  abs0 = kord
7058  ELSE
7059  abs0 = -kord
7060  END IF
7061 !----- Perfectly linear scheme --------------------------------
7062  IF (abs0 .GT. 16) THEN
7063  q_ad = 0.0
7064  DO k=km,1,-1
7065  DO i=i2,i1,-1
7066  temp_ad14 = 3.*a4_ad(4, i, k)
7067  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad14
7068  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad14
7069  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad14
7070  a4_ad(4, i, k) = 0.0
7071  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
7072  a4_ad(3, i, k) = 0.0
7073  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
7074  a4_ad(2, i, k) = 0.0
7075  END DO
7076  END DO
7077  gam_ad = 0.0
7078  ELSE
7079 !----- Perfectly linear scheme --------------------------------
7080 !------------------
7081 ! Apply constraints
7082 !------------------
7083  im = i2 - i1 + 1
7084 ! Apply *large-scale* constraints
7085  DO i=i1,i2
7086  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
7087  y1 = a4(1, i, 2)
7088  CALL pushcontrol1b(0)
7089  ELSE
7090  y1 = a4(1, i, 1)
7091  CALL pushcontrol1b(1)
7092  END IF
7093  IF (q(i, 2) .GT. y1) THEN
7094  CALL pushrealarray_adm(q(i, 2))
7095  q(i, 2) = y1
7096  CALL pushcontrol1b(0)
7097  ELSE
7098  CALL pushrealarray_adm(q(i, 2))
7099  q(i, 2) = q(i, 2)
7100  CALL pushcontrol1b(1)
7101  END IF
7102  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
7103  y2 = a4(1, i, 2)
7104  CALL pushcontrol1b(0)
7105  ELSE
7106  y2 = a4(1, i, 1)
7107  CALL pushcontrol1b(1)
7108  END IF
7109  IF (q(i, 2) .LT. y2) THEN
7110  q(i, 2) = y2
7111  CALL pushcontrol1b(0)
7112  ELSE
7113  q(i, 2) = q(i, 2)
7114  CALL pushcontrol1b(1)
7115  END IF
7116  END DO
7117  DO k=2,km
7118  DO i=i1,i2
7119  CALL pushrealarray_adm(gam(i, k))
7120  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
7121  END DO
7122  END DO
7123 ! Interior:
7124  DO k=3,km-1
7125  DO i=i1,i2
7126  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
7127  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
7128  y3 = a4(1, i, k)
7129  CALL pushcontrol1b(0)
7130  ELSE
7131  y3 = a4(1, i, k-1)
7132  CALL pushcontrol1b(1)
7133  END IF
7134  IF (q(i, k) .GT. y3) THEN
7135  CALL pushrealarray_adm(q(i, k))
7136  q(i, k) = y3
7137  CALL pushcontrol1b(0)
7138  ELSE
7139  CALL pushrealarray_adm(q(i, k))
7140  q(i, k) = q(i, k)
7141  CALL pushcontrol1b(1)
7142  END IF
7143  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
7144  y4 = a4(1, i, k)
7145  CALL pushcontrol1b(0)
7146  ELSE
7147  y4 = a4(1, i, k-1)
7148  CALL pushcontrol1b(1)
7149  END IF
7150  IF (q(i, k) .LT. y4) THEN
7151  q(i, k) = y4
7152  CALL pushcontrol3b(5)
7153  ELSE
7154  q(i, k) = q(i, k)
7155  CALL pushcontrol3b(6)
7156  END IF
7157  ELSE IF (gam(i, k-1) .GT. 0.) THEN
7158  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
7159  y5 = a4(1, i, k)
7160  CALL pushcontrol1b(0)
7161  ELSE
7162  y5 = a4(1, i, k-1)
7163  CALL pushcontrol1b(1)
7164  END IF
7165  IF (q(i, k) .LT. y5) THEN
7166  CALL pushrealarray_adm(q(i, k))
7167  q(i, k) = y5
7168  CALL pushcontrol3b(3)
7169  ELSE
7170  CALL pushrealarray_adm(q(i, k))
7171  q(i, k) = q(i, k)
7172  CALL pushcontrol3b(4)
7173  END IF
7174  ELSE
7175  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
7176  y6 = a4(1, i, k)
7177  CALL pushcontrol1b(0)
7178  ELSE
7179  y6 = a4(1, i, k-1)
7180  CALL pushcontrol1b(1)
7181  END IF
7182  IF (q(i, k) .GT. y6) THEN
7183  CALL pushrealarray_adm(q(i, k))
7184  q(i, k) = y6
7185  CALL pushcontrol1b(0)
7186  ELSE
7187  CALL pushrealarray_adm(q(i, k))
7188  q(i, k) = q(i, k)
7189  CALL pushcontrol1b(1)
7190  END IF
7191  IF (iv .EQ. 0) THEN
7192  IF (0. .LT. q(i, k)) THEN
7193  CALL pushcontrol3b(0)
7194  q(i, k) = q(i, k)
7195  ELSE
7196  q(i, k) = 0.
7197  CALL pushcontrol3b(2)
7198  END IF
7199  ELSE
7200  CALL pushcontrol3b(1)
7201  END IF
7202  END IF
7203  END DO
7204  END DO
7205 ! Bottom:
7206  DO i=i1,i2
7207  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
7208  y7 = a4(1, i, km)
7209  CALL pushcontrol1b(0)
7210  ELSE
7211  y7 = a4(1, i, km-1)
7212  CALL pushcontrol1b(1)
7213  END IF
7214  IF (q(i, km) .GT. y7) THEN
7215  CALL pushrealarray_adm(q(i, km))
7216  q(i, km) = y7
7217  CALL pushcontrol1b(0)
7218  ELSE
7219  CALL pushrealarray_adm(q(i, km))
7220  q(i, km) = q(i, km)
7221  CALL pushcontrol1b(1)
7222  END IF
7223  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
7224  y8 = a4(1, i, km)
7225  CALL pushcontrol1b(0)
7226  ELSE
7227  y8 = a4(1, i, km-1)
7228  CALL pushcontrol1b(1)
7229  END IF
7230  IF (q(i, km) .LT. y8) THEN
7231  q(i, km) = y8
7232  CALL pushcontrol1b(0)
7233  ELSE
7234  q(i, km) = q(i, km)
7235  CALL pushcontrol1b(1)
7236  END IF
7237  END DO
7238  DO k=1,km
7239  DO i=i1,i2
7240  CALL pushrealarray_adm(a4(2, i, k))
7241  a4(2, i, k) = q(i, k)
7242  CALL pushrealarray_adm(a4(3, i, k))
7243  a4(3, i, k) = q(i, k+1)
7244  END DO
7245  END DO
7246  DO k=1,km
7247  IF (k .EQ. 1 .OR. k .EQ. km) THEN
7248  DO i=i1,i2
7249  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
7250 & , k)) .GT. 0.
7251  END DO
7252  ELSE
7253  DO i=i1,i2
7254  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
7255  END DO
7256  END IF
7257  IF (kord .GE. 0.) THEN
7258  abs1 = kord
7259  ELSE
7260  abs1 = -kord
7261  END IF
7262  IF (abs1 .EQ. 16) THEN
7263  DO i=i1,i2
7264  CALL pushrealarray_adm(a4(4, i, k))
7265  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
7266  IF (a4(4, i, k) .GE. 0.) THEN
7267  abs2 = a4(4, i, k)
7268  ELSE
7269  abs2 = -a4(4, i, k)
7270  END IF
7271  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
7272  abs13 = a4(2, i, k) - a4(3, i, k)
7273  ELSE
7274  abs13 = -(a4(2, i, k)-a4(3, i, k))
7275  END IF
7276  ext6(i, k) = abs2 .GT. abs13
7277  END DO
7278  CALL pushcontrol1b(1)
7279  ELSE
7280  CALL pushcontrol1b(0)
7281  END IF
7282  END DO
7283 !---------------------------
7284 ! Apply subgrid constraints:
7285 !---------------------------
7286 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
7287 ! Top 2 and bottom 2 layers always use monotonic mapping
7288  IF (iv .EQ. 0) THEN
7289  DO i=i1,i2
7290  IF (0. .LT. a4(2, i, 1)) THEN
7291  CALL pushrealarray_adm(a4(2, i, 1))
7292  a4(2, i, 1) = a4(2, i, 1)
7293  CALL pushcontrol1b(0)
7294  ELSE
7295  CALL pushrealarray_adm(a4(2, i, 1))
7296  a4(2, i, 1) = 0.
7297  CALL pushcontrol1b(1)
7298  END IF
7299  END DO
7300  CALL pushcontrol2b(0)
7301  ELSE IF (iv .EQ. -1) THEN
7302  DO i=i1,i2
7303  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) THEN
7304  CALL pushrealarray_adm(a4(2, i, 1))
7305  a4(2, i, 1) = 0.
7306  CALL pushcontrol1b(1)
7307  ELSE
7308  CALL pushcontrol1b(0)
7309  END IF
7310  END DO
7311  CALL pushcontrol2b(1)
7312  ELSE IF (iv .EQ. 2) THEN
7313  DO i=i1,i2
7314  CALL pushrealarray_adm(a4(2, i, 1))
7315  a4(2, i, 1) = a4(1, i, 1)
7316  CALL pushrealarray_adm(a4(3, i, 1))
7317  a4(3, i, 1) = a4(1, i, 1)
7318  CALL pushrealarray_adm(a4(4, i, 1))
7319  a4(4, i, 1) = 0.
7320  END DO
7321  CALL pushcontrol2b(2)
7322  ELSE
7323  CALL pushcontrol2b(3)
7324  END IF
7325  IF (iv .NE. 2) THEN
7326  DO i=i1,i2
7327  CALL pushrealarray_adm(a4(4, i, 1))
7328  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
7329  END DO
7330  CALL cs_limiters_fwd(im, extm(i1, 1), a4(1, i1, 1), 1)
7331  CALL pushcontrol1b(1)
7332  ELSE
7333  CALL pushcontrol1b(0)
7334  END IF
7335 ! k=2
7336  DO i=i1,i2
7337  CALL pushrealarray_adm(a4(4, i, 2))
7338  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
7339  END DO
7340  CALL cs_limiters_fwd(im, extm(i1, 2), a4(1, i1, 2), 2)
7341 !-------------------------------------
7342 ! Huynh's 2nd constraint for interior:
7343 !-------------------------------------
7344  DO k=3,km-2
7345  IF (kord .GE. 0.) THEN
7346  abs3 = kord
7347  ELSE
7348  abs3 = -kord
7349  END IF
7350  IF (abs3 .LT. 9) THEN
7351  DO i=i1,i2
7352 ! Left edges
7353  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
7354  lac_1 = pmp_1 + 1.5*gam(i, k+2)
7355  IF (a4(1, i, k) .GT. pmp_1) THEN
7356  IF (pmp_1 .GT. lac_1) THEN
7357  y21 = lac_1
7358  CALL pushcontrol2b(0)
7359  ELSE
7360  y21 = pmp_1
7361  CALL pushcontrol2b(1)
7362  END IF
7363  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
7364  y21 = lac_1
7365  CALL pushcontrol2b(2)
7366  ELSE
7367  y21 = a4(1, i, k)
7368  CALL pushcontrol2b(3)
7369  END IF
7370  IF (a4(2, i, k) .LT. y21) THEN
7371  x1 = y21
7372  CALL pushcontrol1b(0)
7373  ELSE
7374  x1 = a4(2, i, k)
7375  CALL pushcontrol1b(1)
7376  END IF
7377  IF (a4(1, i, k) .LT. pmp_1) THEN
7378  IF (pmp_1 .LT. lac_1) THEN
7379  y9 = lac_1
7380  CALL pushcontrol2b(0)
7381  ELSE
7382  y9 = pmp_1
7383  CALL pushcontrol2b(1)
7384  END IF
7385  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
7386  y9 = lac_1
7387  CALL pushcontrol2b(2)
7388  ELSE
7389  y9 = a4(1, i, k)
7390  CALL pushcontrol2b(3)
7391  END IF
7392  IF (x1 .GT. y9) THEN
7393  CALL pushrealarray_adm(a4(2, i, k))
7394  a4(2, i, k) = y9
7395  CALL pushcontrol1b(0)
7396  ELSE
7397  CALL pushrealarray_adm(a4(2, i, k))
7398  a4(2, i, k) = x1
7399  CALL pushcontrol1b(1)
7400  END IF
7401 ! Right edges
7402  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
7403  lac_2 = pmp_2 - 1.5*gam(i, k-1)
7404  IF (a4(1, i, k) .GT. pmp_2) THEN
7405  IF (pmp_2 .GT. lac_2) THEN
7406  y22 = lac_2
7407  CALL pushcontrol2b(0)
7408  ELSE
7409  y22 = pmp_2
7410  CALL pushcontrol2b(1)
7411  END IF
7412  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
7413  y22 = lac_2
7414  CALL pushcontrol2b(2)
7415  ELSE
7416  y22 = a4(1, i, k)
7417  CALL pushcontrol2b(3)
7418  END IF
7419  IF (a4(3, i, k) .LT. y22) THEN
7420  x2 = y22
7421  CALL pushcontrol1b(0)
7422  ELSE
7423  x2 = a4(3, i, k)
7424  CALL pushcontrol1b(1)
7425  END IF
7426  IF (a4(1, i, k) .LT. pmp_2) THEN
7427  IF (pmp_2 .LT. lac_2) THEN
7428  y10 = lac_2
7429  CALL pushcontrol2b(0)
7430  ELSE
7431  y10 = pmp_2
7432  CALL pushcontrol2b(1)
7433  END IF
7434  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
7435  y10 = lac_2
7436  CALL pushcontrol2b(2)
7437  ELSE
7438  y10 = a4(1, i, k)
7439  CALL pushcontrol2b(3)
7440  END IF
7441  IF (x2 .GT. y10) THEN
7442  CALL pushrealarray_adm(a4(3, i, k))
7443  a4(3, i, k) = y10
7444  CALL pushcontrol1b(0)
7445  ELSE
7446  CALL pushrealarray_adm(a4(3, i, k))
7447  a4(3, i, k) = x2
7448  CALL pushcontrol1b(1)
7449  END IF
7450  CALL pushrealarray_adm(a4(4, i, k))
7451  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
7452  END DO
7453  CALL pushcontrol3b(0)
7454  ELSE
7455  IF (kord .GE. 0.) THEN
7456  abs4 = kord
7457  ELSE
7458  abs4 = -kord
7459  END IF
7460  IF (abs4 .EQ. 9) THEN
7461  DO i=i1,i2
7462  IF (extm(i, k) .AND. extm(i, k-1)) THEN
7463 ! grid-scale 2-delta-z wave detected
7464  CALL pushrealarray_adm(a4(2, i, k))
7465  a4(2, i, k) = a4(1, i, k)
7466  CALL pushrealarray_adm(a4(3, i, k))
7467  a4(3, i, k) = a4(1, i, k)
7468  CALL pushrealarray_adm(a4(4, i, k))
7469  a4(4, i, k) = 0.
7470  CALL pushcontrol3b(4)
7471  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
7472 ! grid-scale 2-delta-z wave detected
7473  CALL pushrealarray_adm(a4(2, i, k))
7474  a4(2, i, k) = a4(1, i, k)
7475  CALL pushrealarray_adm(a4(3, i, k))
7476  a4(3, i, k) = a4(1, i, k)
7477  CALL pushrealarray_adm(a4(4, i, k))
7478  a4(4, i, k) = 0.
7479  CALL pushcontrol3b(3)
7480  ELSE IF (extm(i, k) .AND. a4(1, i, k) .LT. qmin) THEN
7481 ! grid-scale 2-delta-z wave detected
7482  CALL pushrealarray_adm(a4(2, i, k))
7483  a4(2, i, k) = a4(1, i, k)
7484  CALL pushrealarray_adm(a4(3, i, k))
7485  a4(3, i, k) = a4(1, i, k)
7486  CALL pushrealarray_adm(a4(4, i, k))
7487  a4(4, i, k) = 0.
7488  CALL pushcontrol3b(2)
7489  ELSE
7490  CALL pushrealarray_adm(a4(4, i, k))
7491  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k&
7492 & )))
7493  IF (a4(4, i, k) .GE. 0.) THEN
7494  abs5 = a4(4, i, k)
7495  ELSE
7496  abs5 = -a4(4, i, k)
7497  END IF
7498  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
7499  abs14 = a4(2, i, k) - a4(3, i, k)
7500  ELSE
7501  abs14 = -(a4(2, i, k)-a4(3, i, k))
7502  END IF
7503 ! Check within the smooth region if subgrid profile is non-monotonic
7504  IF (abs5 .GT. abs14) THEN
7505  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
7506  lac_1 = pmp_1 + 1.5*gam(i, k+2)
7507  IF (a4(1, i, k) .GT. pmp_1) THEN
7508  IF (pmp_1 .GT. lac_1) THEN
7509  y23 = lac_1
7510  CALL pushcontrol2b(0)
7511  ELSE
7512  y23 = pmp_1
7513  CALL pushcontrol2b(1)
7514  END IF
7515  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
7516  y23 = lac_1
7517  CALL pushcontrol2b(2)
7518  ELSE
7519  y23 = a4(1, i, k)
7520  CALL pushcontrol2b(3)
7521  END IF
7522  IF (a4(2, i, k) .LT. y23) THEN
7523  x3 = y23
7524  CALL pushcontrol1b(0)
7525  ELSE
7526  x3 = a4(2, i, k)
7527  CALL pushcontrol1b(1)
7528  END IF
7529  IF (a4(1, i, k) .LT. pmp_1) THEN
7530  IF (pmp_1 .LT. lac_1) THEN
7531  y11 = lac_1
7532  CALL pushcontrol2b(0)
7533  ELSE
7534  y11 = pmp_1
7535  CALL pushcontrol2b(1)
7536  END IF
7537  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
7538  y11 = lac_1
7539  CALL pushcontrol2b(2)
7540  ELSE
7541  y11 = a4(1, i, k)
7542  CALL pushcontrol2b(3)
7543  END IF
7544  IF (x3 .GT. y11) THEN
7545  CALL pushrealarray_adm(a4(2, i, k))
7546  a4(2, i, k) = y11
7547  CALL pushcontrol1b(0)
7548  ELSE
7549  CALL pushrealarray_adm(a4(2, i, k))
7550  a4(2, i, k) = x3
7551  CALL pushcontrol1b(1)
7552  END IF
7553  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
7554  lac_2 = pmp_2 - 1.5*gam(i, k-1)
7555  IF (a4(1, i, k) .GT. pmp_2) THEN
7556  IF (pmp_2 .GT. lac_2) THEN
7557  y24 = lac_2
7558  CALL pushcontrol2b(0)
7559  ELSE
7560  y24 = pmp_2
7561  CALL pushcontrol2b(1)
7562  END IF
7563  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
7564  y24 = lac_2
7565  CALL pushcontrol2b(2)
7566  ELSE
7567  y24 = a4(1, i, k)
7568  CALL pushcontrol2b(3)
7569  END IF
7570  IF (a4(3, i, k) .LT. y24) THEN
7571  x4 = y24
7572  CALL pushcontrol1b(0)
7573  ELSE
7574  x4 = a4(3, i, k)
7575  CALL pushcontrol1b(1)
7576  END IF
7577  IF (a4(1, i, k) .LT. pmp_2) THEN
7578  IF (pmp_2 .LT. lac_2) THEN
7579  y12 = lac_2
7580  CALL pushcontrol2b(0)
7581  ELSE
7582  y12 = pmp_2
7583  CALL pushcontrol2b(1)
7584  END IF
7585  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
7586  y12 = lac_2
7587  CALL pushcontrol2b(2)
7588  ELSE
7589  y12 = a4(1, i, k)
7590  CALL pushcontrol2b(3)
7591  END IF
7592  IF (x4 .GT. y12) THEN
7593  CALL pushrealarray_adm(a4(3, i, k))
7594  a4(3, i, k) = y12
7595  CALL pushcontrol1b(0)
7596  ELSE
7597  CALL pushrealarray_adm(a4(3, i, k))
7598  a4(3, i, k) = x4
7599  CALL pushcontrol1b(1)
7600  END IF
7601  CALL pushrealarray_adm(a4(4, i, k))
7602  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i&
7603 & , k)))
7604  CALL pushcontrol3b(1)
7605  ELSE
7606  CALL pushcontrol3b(0)
7607  END IF
7608  END IF
7609  END DO
7610  CALL pushcontrol3b(1)
7611  ELSE
7612  IF (kord .GE. 0.) THEN
7613  abs6 = kord
7614  ELSE
7615  abs6 = -kord
7616  END IF
7617  IF (abs6 .EQ. 10) THEN
7618  DO i=i1,i2
7619  IF (extm(i, k)) THEN
7620  IF ((a4(1, i, k) .LT. qmin .OR. extm(i, k-1)) .OR. &
7621 & extm(i, k+1)) THEN
7622 ! grid-scale 2-delta-z wave detected; or q is too small -> ehance vertical mixing
7623  CALL pushrealarray_adm(a4(2, i, k))
7624  a4(2, i, k) = a4(1, i, k)
7625  CALL pushrealarray_adm(a4(3, i, k))
7626  a4(3, i, k) = a4(1, i, k)
7627  CALL pushrealarray_adm(a4(4, i, k))
7628  a4(4, i, k) = 0.
7629  CALL pushcontrol2b(3)
7630  ELSE
7631 ! True local extremum
7632  CALL pushrealarray_adm(a4(4, i, k))
7633  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
7634 & , i, k))
7635  CALL pushcontrol2b(2)
7636  END IF
7637  ELSE
7638 ! not a local extremum
7639  CALL pushrealarray_adm(a4(4, i, k))
7640  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
7641 & , k))
7642  IF (a4(4, i, k) .GE. 0.) THEN
7643  abs7 = a4(4, i, k)
7644  ELSE
7645  abs7 = -a4(4, i, k)
7646  END IF
7647  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
7648  abs15 = a4(2, i, k) - a4(3, i, k)
7649  ELSE
7650  abs15 = -(a4(2, i, k)-a4(3, i, k))
7651  END IF
7652 ! Check within the smooth region if subgrid profile is non-monotonic
7653  IF (abs7 .GT. abs15) THEN
7654  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
7655  lac_1 = pmp_1 + 1.5*gam(i, k+2)
7656  IF (a4(1, i, k) .GT. pmp_1) THEN
7657  IF (pmp_1 .GT. lac_1) THEN
7658  y25 = lac_1
7659  CALL pushcontrol2b(0)
7660  ELSE
7661  y25 = pmp_1
7662  CALL pushcontrol2b(1)
7663  END IF
7664  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
7665  y25 = lac_1
7666  CALL pushcontrol2b(2)
7667  ELSE
7668  y25 = a4(1, i, k)
7669  CALL pushcontrol2b(3)
7670  END IF
7671  IF (a4(2, i, k) .LT. y25) THEN
7672  x5 = y25
7673  CALL pushcontrol1b(0)
7674  ELSE
7675  x5 = a4(2, i, k)
7676  CALL pushcontrol1b(1)
7677  END IF
7678  IF (a4(1, i, k) .LT. pmp_1) THEN
7679  IF (pmp_1 .LT. lac_1) THEN
7680  y13 = lac_1
7681  CALL pushcontrol2b(0)
7682  ELSE
7683  y13 = pmp_1
7684  CALL pushcontrol2b(1)
7685  END IF
7686  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
7687  y13 = lac_1
7688  CALL pushcontrol2b(2)
7689  ELSE
7690  y13 = a4(1, i, k)
7691  CALL pushcontrol2b(3)
7692  END IF
7693  IF (x5 .GT. y13) THEN
7694  CALL pushrealarray_adm(a4(2, i, k))
7695  a4(2, i, k) = y13
7696  CALL pushcontrol1b(0)
7697  ELSE
7698  CALL pushrealarray_adm(a4(2, i, k))
7699  a4(2, i, k) = x5
7700  CALL pushcontrol1b(1)
7701  END IF
7702  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
7703  lac_2 = pmp_2 - 1.5*gam(i, k-1)
7704  IF (a4(1, i, k) .GT. pmp_2) THEN
7705  IF (pmp_2 .GT. lac_2) THEN
7706  y26 = lac_2
7707  CALL pushcontrol2b(0)
7708  ELSE
7709  y26 = pmp_2
7710  CALL pushcontrol2b(1)
7711  END IF
7712  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
7713  y26 = lac_2
7714  CALL pushcontrol2b(2)
7715  ELSE
7716  y26 = a4(1, i, k)
7717  CALL pushcontrol2b(3)
7718  END IF
7719  IF (a4(3, i, k) .LT. y26) THEN
7720  x6 = y26
7721  CALL pushcontrol1b(0)
7722  ELSE
7723  x6 = a4(3, i, k)
7724  CALL pushcontrol1b(1)
7725  END IF
7726  IF (a4(1, i, k) .LT. pmp_2) THEN
7727  IF (pmp_2 .LT. lac_2) THEN
7728  y14 = lac_2
7729  CALL pushcontrol2b(0)
7730  ELSE
7731  y14 = pmp_2
7732  CALL pushcontrol2b(1)
7733  END IF
7734  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
7735  y14 = lac_2
7736  CALL pushcontrol2b(2)
7737  ELSE
7738  y14 = a4(1, i, k)
7739  CALL pushcontrol2b(3)
7740  END IF
7741  IF (x6 .GT. y14) THEN
7742  CALL pushrealarray_adm(a4(3, i, k))
7743  a4(3, i, k) = y14
7744  CALL pushcontrol1b(0)
7745  ELSE
7746  CALL pushrealarray_adm(a4(3, i, k))
7747  a4(3, i, k) = x6
7748  CALL pushcontrol1b(1)
7749  END IF
7750  CALL pushrealarray_adm(a4(4, i, k))
7751  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
7752 & , i, k))
7753  CALL pushcontrol2b(1)
7754  ELSE
7755  CALL pushcontrol2b(0)
7756  END IF
7757  END IF
7758  END DO
7759  CALL pushcontrol3b(2)
7760  ELSE
7761  IF (kord .GE. 0.) THEN
7762  abs8 = kord
7763  ELSE
7764  abs8 = -kord
7765  END IF
7766  IF (abs8 .EQ. 12) THEN
7767  DO i=i1,i2
7768  IF (extm(i, k)) THEN
7769  CALL pushrealarray_adm(a4(2, i, k))
7770  a4(2, i, k) = a4(1, i, k)
7771  CALL pushrealarray_adm(a4(3, i, k))
7772  a4(3, i, k) = a4(1, i, k)
7773  CALL pushrealarray_adm(a4(4, i, k))
7774  a4(4, i, k) = 0.
7775  CALL pushcontrol2b(2)
7776  ELSE
7777 ! not a local extremum
7778  CALL pushrealarray_adm(a4(4, i, k))
7779  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
7780 & , i, k))
7781  IF (a4(4, i, k) .GE. 0.) THEN
7782  abs9 = a4(4, i, k)
7783  ELSE
7784  abs9 = -a4(4, i, k)
7785  END IF
7786  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
7787  abs16 = a4(2, i, k) - a4(3, i, k)
7788  ELSE
7789  abs16 = -(a4(2, i, k)-a4(3, i, k))
7790  END IF
7791 ! Check within the smooth region if subgrid profile is non-monotonic
7792  IF (abs9 .GT. abs16) THEN
7793  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
7794  lac_1 = pmp_1 + 1.5*gam(i, k+2)
7795  IF (a4(1, i, k) .GT. pmp_1) THEN
7796  IF (pmp_1 .GT. lac_1) THEN
7797  y27 = lac_1
7798  CALL pushcontrol2b(0)
7799  ELSE
7800  y27 = pmp_1
7801  CALL pushcontrol2b(1)
7802  END IF
7803  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
7804  y27 = lac_1
7805  CALL pushcontrol2b(2)
7806  ELSE
7807  y27 = a4(1, i, k)
7808  CALL pushcontrol2b(3)
7809  END IF
7810  IF (a4(2, i, k) .LT. y27) THEN
7811  x7 = y27
7812  CALL pushcontrol1b(0)
7813  ELSE
7814  x7 = a4(2, i, k)
7815  CALL pushcontrol1b(1)
7816  END IF
7817  IF (a4(1, i, k) .LT. pmp_1) THEN
7818  IF (pmp_1 .LT. lac_1) THEN
7819  y15 = lac_1
7820  CALL pushcontrol2b(0)
7821  ELSE
7822  y15 = pmp_1
7823  CALL pushcontrol2b(1)
7824  END IF
7825  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
7826  y15 = lac_1
7827  CALL pushcontrol2b(2)
7828  ELSE
7829  y15 = a4(1, i, k)
7830  CALL pushcontrol2b(3)
7831  END IF
7832  IF (x7 .GT. y15) THEN
7833  CALL pushrealarray_adm(a4(2, i, k))
7834  a4(2, i, k) = y15
7835  CALL pushcontrol1b(0)
7836  ELSE
7837  CALL pushrealarray_adm(a4(2, i, k))
7838  a4(2, i, k) = x7
7839  CALL pushcontrol1b(1)
7840  END IF
7841  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
7842  lac_2 = pmp_2 - 1.5*gam(i, k-1)
7843  IF (a4(1, i, k) .GT. pmp_2) THEN
7844  IF (pmp_2 .GT. lac_2) THEN
7845  y28 = lac_2
7846  CALL pushcontrol2b(0)
7847  ELSE
7848  y28 = pmp_2
7849  CALL pushcontrol2b(1)
7850  END IF
7851  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
7852  y28 = lac_2
7853  CALL pushcontrol2b(2)
7854  ELSE
7855  y28 = a4(1, i, k)
7856  CALL pushcontrol2b(3)
7857  END IF
7858  IF (a4(3, i, k) .LT. y28) THEN
7859  x8 = y28
7860  CALL pushcontrol1b(0)
7861  ELSE
7862  x8 = a4(3, i, k)
7863  CALL pushcontrol1b(1)
7864  END IF
7865  IF (a4(1, i, k) .LT. pmp_2) THEN
7866  IF (pmp_2 .LT. lac_2) THEN
7867  y16 = lac_2
7868  CALL pushcontrol2b(0)
7869  ELSE
7870  y16 = pmp_2
7871  CALL pushcontrol2b(1)
7872  END IF
7873  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
7874  y16 = lac_2
7875  CALL pushcontrol2b(2)
7876  ELSE
7877  y16 = a4(1, i, k)
7878  CALL pushcontrol2b(3)
7879  END IF
7880  IF (x8 .GT. y16) THEN
7881  CALL pushrealarray_adm(a4(3, i, k))
7882  a4(3, i, k) = y16
7883  CALL pushcontrol1b(0)
7884  ELSE
7885  CALL pushrealarray_adm(a4(3, i, k))
7886  a4(3, i, k) = x8
7887  CALL pushcontrol1b(1)
7888  END IF
7889  CALL pushrealarray_adm(a4(4, i, k))
7890  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
7891 & 3, i, k))
7892  CALL pushcontrol2b(1)
7893  ELSE
7894  CALL pushcontrol2b(0)
7895  END IF
7896  END IF
7897  END DO
7898  CALL pushcontrol3b(3)
7899  ELSE
7900  IF (kord .GE. 0.) THEN
7901  abs10 = kord
7902  ELSE
7903  abs10 = -kord
7904  END IF
7905  IF (abs10 .EQ. 13) THEN
7906  DO i=i1,i2
7907  IF (extm(i, k)) THEN
7908  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
7909 ! grid-scale 2-delta-z wave detected
7910  CALL pushrealarray_adm(a4(2, i, k))
7911  a4(2, i, k) = a4(1, i, k)
7912  CALL pushrealarray_adm(a4(3, i, k))
7913  a4(3, i, k) = a4(1, i, k)
7914  CALL pushrealarray_adm(a4(4, i, k))
7915  a4(4, i, k) = 0.
7916  CALL pushcontrol2b(2)
7917  ELSE
7918 ! Left edges
7919  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
7920  lac_1 = pmp_1 + 1.5*gam(i, k+2)
7921  IF (a4(1, i, k) .GT. pmp_1) THEN
7922  IF (pmp_1 .GT. lac_1) THEN
7923  y29 = lac_1
7924  CALL pushcontrol2b(0)
7925  ELSE
7926  y29 = pmp_1
7927  CALL pushcontrol2b(1)
7928  END IF
7929  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
7930  y29 = lac_1
7931  CALL pushcontrol2b(2)
7932  ELSE
7933  y29 = a4(1, i, k)
7934  CALL pushcontrol2b(3)
7935  END IF
7936  IF (a4(2, i, k) .LT. y29) THEN
7937  x9 = y29
7938  CALL pushcontrol1b(0)
7939  ELSE
7940  x9 = a4(2, i, k)
7941  CALL pushcontrol1b(1)
7942  END IF
7943  IF (a4(1, i, k) .LT. pmp_1) THEN
7944  IF (pmp_1 .LT. lac_1) THEN
7945  y17 = lac_1
7946  CALL pushcontrol2b(0)
7947  ELSE
7948  y17 = pmp_1
7949  CALL pushcontrol2b(1)
7950  END IF
7951  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
7952  y17 = lac_1
7953  CALL pushcontrol2b(2)
7954  ELSE
7955  y17 = a4(1, i, k)
7956  CALL pushcontrol2b(3)
7957  END IF
7958  IF (x9 .GT. y17) THEN
7959  CALL pushrealarray_adm(a4(2, i, k))
7960  a4(2, i, k) = y17
7961  CALL pushcontrol1b(0)
7962  ELSE
7963  CALL pushrealarray_adm(a4(2, i, k))
7964  a4(2, i, k) = x9
7965  CALL pushcontrol1b(1)
7966  END IF
7967 ! Right edges
7968  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
7969  lac_2 = pmp_2 - 1.5*gam(i, k-1)
7970  IF (a4(1, i, k) .GT. pmp_2) THEN
7971  IF (pmp_2 .GT. lac_2) THEN
7972  y30 = lac_2
7973  CALL pushcontrol2b(0)
7974  ELSE
7975  y30 = pmp_2
7976  CALL pushcontrol2b(1)
7977  END IF
7978  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
7979  y30 = lac_2
7980  CALL pushcontrol2b(2)
7981  ELSE
7982  y30 = a4(1, i, k)
7983  CALL pushcontrol2b(3)
7984  END IF
7985  IF (a4(3, i, k) .LT. y30) THEN
7986  x10 = y30
7987  CALL pushcontrol1b(0)
7988  ELSE
7989  x10 = a4(3, i, k)
7990  CALL pushcontrol1b(1)
7991  END IF
7992  IF (a4(1, i, k) .LT. pmp_2) THEN
7993  IF (pmp_2 .LT. lac_2) THEN
7994  y18 = lac_2
7995  CALL pushcontrol2b(0)
7996  ELSE
7997  y18 = pmp_2
7998  CALL pushcontrol2b(1)
7999  END IF
8000  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
8001  y18 = lac_2
8002  CALL pushcontrol2b(2)
8003  ELSE
8004  y18 = a4(1, i, k)
8005  CALL pushcontrol2b(3)
8006  END IF
8007  IF (x10 .GT. y18) THEN
8008  CALL pushrealarray_adm(a4(3, i, k))
8009  a4(3, i, k) = y18
8010  CALL pushcontrol1b(0)
8011  ELSE
8012  CALL pushrealarray_adm(a4(3, i, k))
8013  a4(3, i, k) = x10
8014  CALL pushcontrol1b(1)
8015  END IF
8016  CALL pushrealarray_adm(a4(4, i, k))
8017  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
8018 & (3, i, k)))
8019  CALL pushcontrol2b(1)
8020  END IF
8021  ELSE
8022  CALL pushrealarray_adm(a4(4, i, k))
8023  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
8024 & , i, k)))
8025  CALL pushcontrol2b(0)
8026  END IF
8027  END DO
8028  CALL pushcontrol3b(4)
8029  ELSE
8030  IF (kord .GE. 0.) THEN
8031  abs11 = kord
8032  ELSE
8033  abs11 = -kord
8034  END IF
8035  IF (abs11 .EQ. 14) THEN
8036  DO i=i1,i2
8037  CALL pushrealarray_adm(a4(4, i, k))
8038  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
8039 & , i, k)))
8040  END DO
8041  CALL pushcontrol3b(5)
8042  ELSE
8043  IF (kord .GE. 0.) THEN
8044  abs12 = kord
8045  ELSE
8046  abs12 = -kord
8047  END IF
8048  IF (abs12 .EQ. 16) THEN
8049  DO i=i1,i2
8050  IF (ext6(i, k)) THEN
8051  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
8052 ! Left edges
8053  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
8054  lac_1 = pmp_1 + 1.5*gam(i, k+2)
8055  IF (a4(1, i, k) .GT. pmp_1) THEN
8056  IF (pmp_1 .GT. lac_1) THEN
8057  y31 = lac_1
8058  CALL pushcontrol2b(0)
8059  ELSE
8060  y31 = pmp_1
8061  CALL pushcontrol2b(1)
8062  END IF
8063  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
8064  y31 = lac_1
8065  CALL pushcontrol2b(2)
8066  ELSE
8067  y31 = a4(1, i, k)
8068  CALL pushcontrol2b(3)
8069  END IF
8070  IF (a4(2, i, k) .LT. y31) THEN
8071  x11 = y31
8072  CALL pushcontrol1b(0)
8073  ELSE
8074  x11 = a4(2, i, k)
8075  CALL pushcontrol1b(1)
8076  END IF
8077  IF (a4(1, i, k) .LT. pmp_1) THEN
8078  IF (pmp_1 .LT. lac_1) THEN
8079  y19 = lac_1
8080  CALL pushcontrol2b(0)
8081  ELSE
8082  y19 = pmp_1
8083  CALL pushcontrol2b(1)
8084  END IF
8085  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
8086  y19 = lac_1
8087  CALL pushcontrol2b(2)
8088  ELSE
8089  y19 = a4(1, i, k)
8090  CALL pushcontrol2b(3)
8091  END IF
8092  IF (x11 .GT. y19) THEN
8093  CALL pushrealarray_adm(a4(2, i, k))
8094  a4(2, i, k) = y19
8095  CALL pushcontrol1b(0)
8096  ELSE
8097  CALL pushrealarray_adm(a4(2, i, k))
8098  a4(2, i, k) = x11
8099  CALL pushcontrol1b(1)
8100  END IF
8101 ! Right edges
8102  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
8103  lac_2 = pmp_2 - 1.5*gam(i, k-1)
8104  IF (a4(1, i, k) .GT. pmp_2) THEN
8105  IF (pmp_2 .GT. lac_2) THEN
8106  y32 = lac_2
8107  CALL pushcontrol2b(0)
8108  ELSE
8109  y32 = pmp_2
8110  CALL pushcontrol2b(1)
8111  END IF
8112  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
8113  y32 = lac_2
8114  CALL pushcontrol2b(2)
8115  ELSE
8116  y32 = a4(1, i, k)
8117  CALL pushcontrol2b(3)
8118  END IF
8119  IF (a4(3, i, k) .LT. y32) THEN
8120  x12 = y32
8121  CALL pushcontrol1b(0)
8122  ELSE
8123  x12 = a4(3, i, k)
8124  CALL pushcontrol1b(1)
8125  END IF
8126  IF (a4(1, i, k) .LT. pmp_2) THEN
8127  IF (pmp_2 .LT. lac_2) THEN
8128  y20 = lac_2
8129  CALL pushcontrol2b(0)
8130  ELSE
8131  y20 = pmp_2
8132  CALL pushcontrol2b(1)
8133  END IF
8134  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
8135  y20 = lac_2
8136  CALL pushcontrol2b(2)
8137  ELSE
8138  y20 = a4(1, i, k)
8139  CALL pushcontrol2b(3)
8140  END IF
8141  IF (x12 .GT. y20) THEN
8142  CALL pushrealarray_adm(a4(3, i, k))
8143  a4(3, i, k) = y20
8144  CALL pushcontrol1b(0)
8145  ELSE
8146  CALL pushrealarray_adm(a4(3, i, k))
8147  a4(3, i, k) = x12
8148  CALL pushcontrol1b(1)
8149  END IF
8150  CALL pushrealarray_adm(a4(4, i, k))
8151  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k&
8152 & )+a4(3, i, k)))
8153  CALL pushcontrol2b(2)
8154  ELSE
8155  CALL pushcontrol2b(1)
8156  END IF
8157  ELSE
8158  CALL pushcontrol2b(0)
8159  END IF
8160  END DO
8161  CALL pushcontrol3b(6)
8162  ELSE
8163 ! kord = 11, 13
8164  DO i=i1,i2
8165  IF (extm(i, k) .AND. ((extm(i, k-1) .OR. extm(i&
8166 & , k+1)) .OR. a4(1, i, k) .LT. qmin)) THEN
8167 ! Noisy region:
8168  CALL pushrealarray_adm(a4(2, i, k))
8169  a4(2, i, k) = a4(1, i, k)
8170  CALL pushrealarray_adm(a4(3, i, k))
8171  a4(3, i, k) = a4(1, i, k)
8172  CALL pushrealarray_adm(a4(4, i, k))
8173  a4(4, i, k) = 0.
8174  CALL pushcontrol1b(1)
8175  ELSE
8176  CALL pushrealarray_adm(a4(4, i, k))
8177  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+&
8178 & a4(3, i, k)))
8179  CALL pushcontrol1b(0)
8180  END IF
8181  END DO
8182  CALL pushcontrol3b(7)
8183  END IF
8184  END IF
8185  END IF
8186  END IF
8187  END IF
8188  END IF
8189  END IF
8190 ! Additional constraint to ensure positivity
8191  IF (iv .EQ. 0) THEN
8192  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 0)
8193  CALL pushcontrol1b(1)
8194  ELSE
8195  CALL pushcontrol1b(0)
8196  END IF
8197  END DO
8198 ! k-loop
8199 !----------------------------------
8200 ! Bottom layer subgrid constraints:
8201 !----------------------------------
8202  IF (iv .EQ. 0) THEN
8203  DO i=i1,i2
8204  IF (0. .LT. a4(3, i, km)) THEN
8205  CALL pushrealarray_adm(a4(3, i, km))
8206  a4(3, i, km) = a4(3, i, km)
8207  CALL pushcontrol1b(0)
8208  ELSE
8209  CALL pushrealarray_adm(a4(3, i, km))
8210  a4(3, i, km) = 0.
8211  CALL pushcontrol1b(1)
8212  END IF
8213  END DO
8214  CALL pushcontrol2b(2)
8215  ELSE IF (iv .EQ. -1) THEN
8216  DO i=i1,i2
8217  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) THEN
8218  CALL pushrealarray_adm(a4(3, i, km))
8219  a4(3, i, km) = 0.
8220  CALL pushcontrol1b(1)
8221  ELSE
8222  CALL pushcontrol1b(0)
8223  END IF
8224  END DO
8225  CALL pushcontrol2b(1)
8226  ELSE
8227  CALL pushcontrol2b(0)
8228  END IF
8229  DO k=km-1,km
8230  DO i=i1,i2
8231  CALL pushrealarray_adm(a4(4, i, k))
8232  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
8233  END DO
8234  IF (k .EQ. km - 1) THEN
8235  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 2)
8236  CALL pushcontrol1b(0)
8237  ELSE
8238  CALL pushcontrol1b(1)
8239  END IF
8240  IF (k .EQ. km) THEN
8241  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 1)
8242  CALL pushcontrol1b(1)
8243  ELSE
8244  CALL pushcontrol1b(0)
8245  END IF
8246  END DO
8247  DO k=km,km-1,-1
8248  CALL popcontrol1b(branch)
8249  IF (branch .NE. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
8250 & i1, k), a4_ad(1, i1, k), 1)
8251  CALL popcontrol1b(branch)
8252  IF (branch .EQ. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
8253 & i1, k), a4_ad(1, i1, k), 2)
8254  DO i=i2,i1,-1
8255  CALL poprealarray_adm(a4(4, i, k))
8256  temp_ad26 = 3.*a4_ad(4, i, k)
8257  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad26
8258  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad26
8259  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad26
8260  a4_ad(4, i, k) = 0.0
8261  END DO
8262  END DO
8263  CALL popcontrol2b(branch)
8264  IF (branch .NE. 0) THEN
8265  IF (branch .EQ. 1) THEN
8266  DO i=i2,i1,-1
8267  CALL popcontrol1b(branch)
8268  IF (branch .NE. 0) THEN
8269  CALL poprealarray_adm(a4(3, i, km))
8270  a4_ad(3, i, km) = 0.0
8271  END IF
8272  END DO
8273  ELSE
8274  DO i=i2,i1,-1
8275  CALL popcontrol1b(branch)
8276  IF (branch .EQ. 0) THEN
8277  CALL poprealarray_adm(a4(3, i, km))
8278  ELSE
8279  CALL poprealarray_adm(a4(3, i, km))
8280  a4_ad(3, i, km) = 0.0
8281  END IF
8282  END DO
8283  END IF
8284  END IF
8285  gam_ad = 0.0
8286  DO k=km-2,3,-1
8287  CALL popcontrol1b(branch)
8288  IF (branch .NE. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
8289 & i1, k), a4_ad(1, i1, k), 0)
8290  CALL popcontrol3b(branch)
8291  IF (branch .LT. 4) THEN
8292  IF (branch .LT. 2) THEN
8293  IF (branch .EQ. 0) THEN
8294  DO i=i2,i1,-1
8295  CALL poprealarray_adm(a4(4, i, k))
8296  temp_ad18 = 3.*a4_ad(4, i, k)
8297  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad18
8298  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad18
8299  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad18
8300  a4_ad(4, i, k) = 0.0
8301  CALL popcontrol1b(branch)
8302  IF (branch .EQ. 0) THEN
8303  CALL poprealarray_adm(a4(3, i, k))
8304  y10_ad = a4_ad(3, i, k)
8305  a4_ad(3, i, k) = 0.0
8306  x2_ad = 0.0
8307  ELSE
8308  CALL poprealarray_adm(a4(3, i, k))
8309  x2_ad = a4_ad(3, i, k)
8310  a4_ad(3, i, k) = 0.0
8311  y10_ad = 0.0
8312  END IF
8313  CALL popcontrol2b(branch)
8314  IF (branch .LT. 2) THEN
8315  IF (branch .EQ. 0) THEN
8316  lac_2_ad = y10_ad
8317  pmp_2_ad = 0.0
8318  ELSE
8319  pmp_2_ad = y10_ad
8320  lac_2_ad = 0.0
8321  END IF
8322  ELSE
8323  IF (branch .EQ. 2) THEN
8324  lac_2_ad = y10_ad
8325  ELSE
8326  a4_ad(1, i, k) = a4_ad(1, i, k) + y10_ad
8327  lac_2_ad = 0.0
8328  END IF
8329  pmp_2_ad = 0.0
8330  END IF
8331  CALL popcontrol1b(branch)
8332  IF (branch .EQ. 0) THEN
8333  y22_ad = x2_ad
8334  ELSE
8335  a4_ad(3, i, k) = a4_ad(3, i, k) + x2_ad
8336  y22_ad = 0.0
8337  END IF
8338  CALL popcontrol2b(branch)
8339  IF (branch .LT. 2) THEN
8340  IF (branch .EQ. 0) THEN
8341  lac_2_ad = lac_2_ad + y22_ad
8342  ELSE
8343  pmp_2_ad = pmp_2_ad + y22_ad
8344  END IF
8345  ELSE IF (branch .EQ. 2) THEN
8346  lac_2_ad = lac_2_ad + y22_ad
8347  ELSE
8348  a4_ad(1, i, k) = a4_ad(1, i, k) + y22_ad
8349  END IF
8350  pmp_2_ad = pmp_2_ad + lac_2_ad
8351  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
8352  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
8353  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
8354  CALL popcontrol1b(branch)
8355  IF (branch .EQ. 0) THEN
8356  CALL poprealarray_adm(a4(2, i, k))
8357  y9_ad = a4_ad(2, i, k)
8358  a4_ad(2, i, k) = 0.0
8359  x1_ad = 0.0
8360  ELSE
8361  CALL poprealarray_adm(a4(2, i, k))
8362  x1_ad = a4_ad(2, i, k)
8363  a4_ad(2, i, k) = 0.0
8364  y9_ad = 0.0
8365  END IF
8366  CALL popcontrol2b(branch)
8367  IF (branch .LT. 2) THEN
8368  IF (branch .EQ. 0) THEN
8369  lac_1_ad = y9_ad
8370  pmp_1_ad = 0.0
8371  ELSE
8372  pmp_1_ad = y9_ad
8373  lac_1_ad = 0.0
8374  END IF
8375  ELSE
8376  IF (branch .EQ. 2) THEN
8377  lac_1_ad = y9_ad
8378  ELSE
8379  a4_ad(1, i, k) = a4_ad(1, i, k) + y9_ad
8380  lac_1_ad = 0.0
8381  END IF
8382  pmp_1_ad = 0.0
8383  END IF
8384  CALL popcontrol1b(branch)
8385  IF (branch .EQ. 0) THEN
8386  y21_ad = x1_ad
8387  ELSE
8388  a4_ad(2, i, k) = a4_ad(2, i, k) + x1_ad
8389  y21_ad = 0.0
8390  END IF
8391  CALL popcontrol2b(branch)
8392  IF (branch .LT. 2) THEN
8393  IF (branch .EQ. 0) THEN
8394  lac_1_ad = lac_1_ad + y21_ad
8395  ELSE
8396  pmp_1_ad = pmp_1_ad + y21_ad
8397  END IF
8398  ELSE IF (branch .EQ. 2) THEN
8399  lac_1_ad = lac_1_ad + y21_ad
8400  ELSE
8401  a4_ad(1, i, k) = a4_ad(1, i, k) + y21_ad
8402  END IF
8403  pmp_1_ad = pmp_1_ad + lac_1_ad
8404  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
8405  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
8406  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
8407  END DO
8408  ELSE
8409  DO i=i2,i1,-1
8410  CALL popcontrol3b(branch)
8411  IF (branch .LT. 2) THEN
8412  IF (branch .NE. 0) THEN
8413  CALL poprealarray_adm(a4(4, i, k))
8414  temp_ad20 = 3.*a4_ad(4, i, k)
8415  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad20
8416  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad20
8417  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad20
8418  a4_ad(4, i, k) = 0.0
8419  CALL popcontrol1b(branch)
8420  IF (branch .EQ. 0) THEN
8421  CALL poprealarray_adm(a4(3, i, k))
8422  y12_ad = a4_ad(3, i, k)
8423  a4_ad(3, i, k) = 0.0
8424  x4_ad = 0.0
8425  ELSE
8426  CALL poprealarray_adm(a4(3, i, k))
8427  x4_ad = a4_ad(3, i, k)
8428  a4_ad(3, i, k) = 0.0
8429  y12_ad = 0.0
8430  END IF
8431  CALL popcontrol2b(branch)
8432  IF (branch .LT. 2) THEN
8433  IF (branch .EQ. 0) THEN
8434  lac_2_ad = y12_ad
8435  pmp_2_ad = 0.0
8436  ELSE
8437  pmp_2_ad = y12_ad
8438  lac_2_ad = 0.0
8439  END IF
8440  ELSE
8441  IF (branch .EQ. 2) THEN
8442  lac_2_ad = y12_ad
8443  ELSE
8444  a4_ad(1, i, k) = a4_ad(1, i, k) + y12_ad
8445  lac_2_ad = 0.0
8446  END IF
8447  pmp_2_ad = 0.0
8448  END IF
8449  CALL popcontrol1b(branch)
8450  IF (branch .EQ. 0) THEN
8451  y24_ad = x4_ad
8452  ELSE
8453  a4_ad(3, i, k) = a4_ad(3, i, k) + x4_ad
8454  y24_ad = 0.0
8455  END IF
8456  CALL popcontrol2b(branch)
8457  IF (branch .LT. 2) THEN
8458  IF (branch .EQ. 0) THEN
8459  lac_2_ad = lac_2_ad + y24_ad
8460  ELSE
8461  pmp_2_ad = pmp_2_ad + y24_ad
8462  END IF
8463  ELSE IF (branch .EQ. 2) THEN
8464  lac_2_ad = lac_2_ad + y24_ad
8465  ELSE
8466  a4_ad(1, i, k) = a4_ad(1, i, k) + y24_ad
8467  END IF
8468  pmp_2_ad = pmp_2_ad + lac_2_ad
8469  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
8470  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
8471  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
8472  CALL popcontrol1b(branch)
8473  IF (branch .EQ. 0) THEN
8474  CALL poprealarray_adm(a4(2, i, k))
8475  y11_ad = a4_ad(2, i, k)
8476  a4_ad(2, i, k) = 0.0
8477  x3_ad = 0.0
8478  ELSE
8479  CALL poprealarray_adm(a4(2, i, k))
8480  x3_ad = a4_ad(2, i, k)
8481  a4_ad(2, i, k) = 0.0
8482  y11_ad = 0.0
8483  END IF
8484  CALL popcontrol2b(branch)
8485  IF (branch .LT. 2) THEN
8486  IF (branch .EQ. 0) THEN
8487  lac_1_ad = y11_ad
8488  pmp_1_ad = 0.0
8489  ELSE
8490  pmp_1_ad = y11_ad
8491  lac_1_ad = 0.0
8492  END IF
8493  ELSE
8494  IF (branch .EQ. 2) THEN
8495  lac_1_ad = y11_ad
8496  ELSE
8497  a4_ad(1, i, k) = a4_ad(1, i, k) + y11_ad
8498  lac_1_ad = 0.0
8499  END IF
8500  pmp_1_ad = 0.0
8501  END IF
8502  CALL popcontrol1b(branch)
8503  IF (branch .EQ. 0) THEN
8504  y23_ad = x3_ad
8505  ELSE
8506  a4_ad(2, i, k) = a4_ad(2, i, k) + x3_ad
8507  y23_ad = 0.0
8508  END IF
8509  CALL popcontrol2b(branch)
8510  IF (branch .LT. 2) THEN
8511  IF (branch .EQ. 0) THEN
8512  lac_1_ad = lac_1_ad + y23_ad
8513  ELSE
8514  pmp_1_ad = pmp_1_ad + y23_ad
8515  END IF
8516  ELSE IF (branch .EQ. 2) THEN
8517  lac_1_ad = lac_1_ad + y23_ad
8518  ELSE
8519  a4_ad(1, i, k) = a4_ad(1, i, k) + y23_ad
8520  END IF
8521  pmp_1_ad = pmp_1_ad + lac_1_ad
8522  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
8523  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
8524  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
8525  END IF
8526  CALL poprealarray_adm(a4(4, i, k))
8527  temp_ad19 = 3.*a4_ad(4, i, k)
8528  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad19
8529  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad19
8530  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad19
8531  a4_ad(4, i, k) = 0.0
8532  ELSE IF (branch .EQ. 2) THEN
8533  CALL poprealarray_adm(a4(4, i, k))
8534  a4_ad(4, i, k) = 0.0
8535  CALL poprealarray_adm(a4(3, i, k))
8536  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8537  a4_ad(3, i, k) = 0.0
8538  CALL poprealarray_adm(a4(2, i, k))
8539  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8540  a4_ad(2, i, k) = 0.0
8541  ELSE IF (branch .EQ. 3) THEN
8542  CALL poprealarray_adm(a4(4, i, k))
8543  a4_ad(4, i, k) = 0.0
8544  CALL poprealarray_adm(a4(3, i, k))
8545  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8546  a4_ad(3, i, k) = 0.0
8547  CALL poprealarray_adm(a4(2, i, k))
8548  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8549  a4_ad(2, i, k) = 0.0
8550  ELSE
8551  CALL poprealarray_adm(a4(4, i, k))
8552  a4_ad(4, i, k) = 0.0
8553  CALL poprealarray_adm(a4(3, i, k))
8554  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8555  a4_ad(3, i, k) = 0.0
8556  CALL poprealarray_adm(a4(2, i, k))
8557  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8558  a4_ad(2, i, k) = 0.0
8559  END IF
8560  END DO
8561  END IF
8562  ELSE IF (branch .EQ. 2) THEN
8563  DO i=i2,i1,-1
8564  CALL popcontrol2b(branch)
8565  IF (branch .LT. 2) THEN
8566  IF (branch .NE. 0) THEN
8567  CALL poprealarray_adm(a4(4, i, k))
8568  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
8569  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
8570  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
8571  a4_ad(4, i, k) = 0.0
8572  CALL popcontrol1b(branch)
8573  IF (branch .EQ. 0) THEN
8574  CALL poprealarray_adm(a4(3, i, k))
8575  y14_ad = a4_ad(3, i, k)
8576  a4_ad(3, i, k) = 0.0
8577  x6_ad = 0.0
8578  ELSE
8579  CALL poprealarray_adm(a4(3, i, k))
8580  x6_ad = a4_ad(3, i, k)
8581  a4_ad(3, i, k) = 0.0
8582  y14_ad = 0.0
8583  END IF
8584  CALL popcontrol2b(branch)
8585  IF (branch .LT. 2) THEN
8586  IF (branch .EQ. 0) THEN
8587  lac_2_ad = y14_ad
8588  pmp_2_ad = 0.0
8589  ELSE
8590  pmp_2_ad = y14_ad
8591  lac_2_ad = 0.0
8592  END IF
8593  ELSE
8594  IF (branch .EQ. 2) THEN
8595  lac_2_ad = y14_ad
8596  ELSE
8597  a4_ad(1, i, k) = a4_ad(1, i, k) + y14_ad
8598  lac_2_ad = 0.0
8599  END IF
8600  pmp_2_ad = 0.0
8601  END IF
8602  CALL popcontrol1b(branch)
8603  IF (branch .EQ. 0) THEN
8604  y26_ad = x6_ad
8605  ELSE
8606  a4_ad(3, i, k) = a4_ad(3, i, k) + x6_ad
8607  y26_ad = 0.0
8608  END IF
8609  CALL popcontrol2b(branch)
8610  IF (branch .LT. 2) THEN
8611  IF (branch .EQ. 0) THEN
8612  lac_2_ad = lac_2_ad + y26_ad
8613  ELSE
8614  pmp_2_ad = pmp_2_ad + y26_ad
8615  END IF
8616  ELSE IF (branch .EQ. 2) THEN
8617  lac_2_ad = lac_2_ad + y26_ad
8618  ELSE
8619  a4_ad(1, i, k) = a4_ad(1, i, k) + y26_ad
8620  END IF
8621  pmp_2_ad = pmp_2_ad + lac_2_ad
8622  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
8623  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
8624  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
8625  CALL popcontrol1b(branch)
8626  IF (branch .EQ. 0) THEN
8627  CALL poprealarray_adm(a4(2, i, k))
8628  y13_ad = a4_ad(2, i, k)
8629  a4_ad(2, i, k) = 0.0
8630  x5_ad = 0.0
8631  ELSE
8632  CALL poprealarray_adm(a4(2, i, k))
8633  x5_ad = a4_ad(2, i, k)
8634  a4_ad(2, i, k) = 0.0
8635  y13_ad = 0.0
8636  END IF
8637  CALL popcontrol2b(branch)
8638  IF (branch .LT. 2) THEN
8639  IF (branch .EQ. 0) THEN
8640  lac_1_ad = y13_ad
8641  pmp_1_ad = 0.0
8642  ELSE
8643  pmp_1_ad = y13_ad
8644  lac_1_ad = 0.0
8645  END IF
8646  ELSE
8647  IF (branch .EQ. 2) THEN
8648  lac_1_ad = y13_ad
8649  ELSE
8650  a4_ad(1, i, k) = a4_ad(1, i, k) + y13_ad
8651  lac_1_ad = 0.0
8652  END IF
8653  pmp_1_ad = 0.0
8654  END IF
8655  CALL popcontrol1b(branch)
8656  IF (branch .EQ. 0) THEN
8657  y25_ad = x5_ad
8658  ELSE
8659  a4_ad(2, i, k) = a4_ad(2, i, k) + x5_ad
8660  y25_ad = 0.0
8661  END IF
8662  CALL popcontrol2b(branch)
8663  IF (branch .LT. 2) THEN
8664  IF (branch .EQ. 0) THEN
8665  lac_1_ad = lac_1_ad + y25_ad
8666  ELSE
8667  pmp_1_ad = pmp_1_ad + y25_ad
8668  END IF
8669  ELSE IF (branch .EQ. 2) THEN
8670  lac_1_ad = lac_1_ad + y25_ad
8671  ELSE
8672  a4_ad(1, i, k) = a4_ad(1, i, k) + y25_ad
8673  END IF
8674  pmp_1_ad = pmp_1_ad + lac_1_ad
8675  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
8676  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
8677  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
8678  END IF
8679  CALL poprealarray_adm(a4(4, i, k))
8680  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
8681  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
8682  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
8683  a4_ad(4, i, k) = 0.0
8684  ELSE IF (branch .EQ. 2) THEN
8685  CALL poprealarray_adm(a4(4, i, k))
8686  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
8687  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
8688  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
8689  a4_ad(4, i, k) = 0.0
8690  ELSE
8691  CALL poprealarray_adm(a4(4, i, k))
8692  a4_ad(4, i, k) = 0.0
8693  CALL poprealarray_adm(a4(3, i, k))
8694  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8695  a4_ad(3, i, k) = 0.0
8696  CALL poprealarray_adm(a4(2, i, k))
8697  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8698  a4_ad(2, i, k) = 0.0
8699  END IF
8700  END DO
8701  ELSE
8702  DO 100 i=i2,i1,-1
8703  CALL popcontrol2b(branch)
8704  IF (branch .NE. 0) THEN
8705  IF (branch .EQ. 1) THEN
8706  CALL poprealarray_adm(a4(4, i, k))
8707  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
8708  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
8709  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
8710  a4_ad(4, i, k) = 0.0
8711  CALL popcontrol1b(branch)
8712  IF (branch .EQ. 0) THEN
8713  CALL poprealarray_adm(a4(3, i, k))
8714  y16_ad = a4_ad(3, i, k)
8715  a4_ad(3, i, k) = 0.0
8716  x8_ad = 0.0
8717  ELSE
8718  CALL poprealarray_adm(a4(3, i, k))
8719  x8_ad = a4_ad(3, i, k)
8720  a4_ad(3, i, k) = 0.0
8721  y16_ad = 0.0
8722  END IF
8723  CALL popcontrol2b(branch)
8724  IF (branch .LT. 2) THEN
8725  IF (branch .EQ. 0) THEN
8726  lac_2_ad = y16_ad
8727  pmp_2_ad = 0.0
8728  ELSE
8729  pmp_2_ad = y16_ad
8730  lac_2_ad = 0.0
8731  END IF
8732  ELSE
8733  IF (branch .EQ. 2) THEN
8734  lac_2_ad = y16_ad
8735  ELSE
8736  a4_ad(1, i, k) = a4_ad(1, i, k) + y16_ad
8737  lac_2_ad = 0.0
8738  END IF
8739  pmp_2_ad = 0.0
8740  END IF
8741  CALL popcontrol1b(branch)
8742  IF (branch .EQ. 0) THEN
8743  y28_ad = x8_ad
8744  ELSE
8745  a4_ad(3, i, k) = a4_ad(3, i, k) + x8_ad
8746  y28_ad = 0.0
8747  END IF
8748  CALL popcontrol2b(branch)
8749  IF (branch .LT. 2) THEN
8750  IF (branch .EQ. 0) THEN
8751  lac_2_ad = lac_2_ad + y28_ad
8752  ELSE
8753  pmp_2_ad = pmp_2_ad + y28_ad
8754  END IF
8755  ELSE IF (branch .EQ. 2) THEN
8756  lac_2_ad = lac_2_ad + y28_ad
8757  ELSE
8758  a4_ad(1, i, k) = a4_ad(1, i, k) + y28_ad
8759  END IF
8760  pmp_2_ad = pmp_2_ad + lac_2_ad
8761  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
8762  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
8763  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
8764  CALL popcontrol1b(branch)
8765  IF (branch .EQ. 0) THEN
8766  CALL poprealarray_adm(a4(2, i, k))
8767  y15_ad = a4_ad(2, i, k)
8768  a4_ad(2, i, k) = 0.0
8769  x7_ad = 0.0
8770  ELSE
8771  CALL poprealarray_adm(a4(2, i, k))
8772  x7_ad = a4_ad(2, i, k)
8773  a4_ad(2, i, k) = 0.0
8774  y15_ad = 0.0
8775  END IF
8776  CALL popcontrol2b(branch)
8777  IF (branch .LT. 2) THEN
8778  IF (branch .EQ. 0) THEN
8779  lac_1_ad = y15_ad
8780  pmp_1_ad = 0.0
8781  ELSE
8782  pmp_1_ad = y15_ad
8783  lac_1_ad = 0.0
8784  END IF
8785  ELSE
8786  IF (branch .EQ. 2) THEN
8787  lac_1_ad = y15_ad
8788  ELSE
8789  a4_ad(1, i, k) = a4_ad(1, i, k) + y15_ad
8790  lac_1_ad = 0.0
8791  END IF
8792  pmp_1_ad = 0.0
8793  END IF
8794  CALL popcontrol1b(branch)
8795  IF (branch .EQ. 0) THEN
8796  y27_ad = x7_ad
8797  ELSE
8798  a4_ad(2, i, k) = a4_ad(2, i, k) + x7_ad
8799  y27_ad = 0.0
8800  END IF
8801  CALL popcontrol2b(branch)
8802  IF (branch .LT. 2) THEN
8803  IF (branch .EQ. 0) THEN
8804  lac_1_ad = lac_1_ad + y27_ad
8805  ELSE
8806  pmp_1_ad = pmp_1_ad + y27_ad
8807  END IF
8808  ELSE IF (branch .EQ. 2) THEN
8809  lac_1_ad = lac_1_ad + y27_ad
8810  ELSE
8811  a4_ad(1, i, k) = a4_ad(1, i, k) + y27_ad
8812  END IF
8813  pmp_1_ad = pmp_1_ad + lac_1_ad
8814  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
8815  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
8816  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
8817  ELSE
8818  CALL poprealarray_adm(a4(4, i, k))
8819  a4_ad(4, i, k) = 0.0
8820  CALL poprealarray_adm(a4(3, i, k))
8821  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8822  a4_ad(3, i, k) = 0.0
8823  CALL poprealarray_adm(a4(2, i, k))
8824  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8825  a4_ad(2, i, k) = 0.0
8826  GOTO 100
8827  END IF
8828  END IF
8829  CALL poprealarray_adm(a4(4, i, k))
8830  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
8831  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
8832  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
8833  a4_ad(4, i, k) = 0.0
8834  100 CONTINUE
8835  END IF
8836  ELSE IF (branch .LT. 6) THEN
8837  IF (branch .EQ. 4) THEN
8838  DO i=i2,i1,-1
8839  CALL popcontrol2b(branch)
8840  IF (branch .EQ. 0) THEN
8841  CALL poprealarray_adm(a4(4, i, k))
8842  temp_ad22 = 3.*a4_ad(4, i, k)
8843  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad22
8844  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad22
8845  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad22
8846  a4_ad(4, i, k) = 0.0
8847  ELSE IF (branch .EQ. 1) THEN
8848  CALL poprealarray_adm(a4(4, i, k))
8849  temp_ad21 = 3.*a4_ad(4, i, k)
8850  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad21
8851  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad21
8852  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad21
8853  a4_ad(4, i, k) = 0.0
8854  CALL popcontrol1b(branch)
8855  IF (branch .EQ. 0) THEN
8856  CALL poprealarray_adm(a4(3, i, k))
8857  y18_ad = a4_ad(3, i, k)
8858  a4_ad(3, i, k) = 0.0
8859  x10_ad = 0.0
8860  ELSE
8861  CALL poprealarray_adm(a4(3, i, k))
8862  x10_ad = a4_ad(3, i, k)
8863  a4_ad(3, i, k) = 0.0
8864  y18_ad = 0.0
8865  END IF
8866  CALL popcontrol2b(branch)
8867  IF (branch .LT. 2) THEN
8868  IF (branch .EQ. 0) THEN
8869  lac_2_ad = y18_ad
8870  pmp_2_ad = 0.0
8871  ELSE
8872  pmp_2_ad = y18_ad
8873  lac_2_ad = 0.0
8874  END IF
8875  ELSE
8876  IF (branch .EQ. 2) THEN
8877  lac_2_ad = y18_ad
8878  ELSE
8879  a4_ad(1, i, k) = a4_ad(1, i, k) + y18_ad
8880  lac_2_ad = 0.0
8881  END IF
8882  pmp_2_ad = 0.0
8883  END IF
8884  CALL popcontrol1b(branch)
8885  IF (branch .EQ. 0) THEN
8886  y30_ad = x10_ad
8887  ELSE
8888  a4_ad(3, i, k) = a4_ad(3, i, k) + x10_ad
8889  y30_ad = 0.0
8890  END IF
8891  CALL popcontrol2b(branch)
8892  IF (branch .LT. 2) THEN
8893  IF (branch .EQ. 0) THEN
8894  lac_2_ad = lac_2_ad + y30_ad
8895  ELSE
8896  pmp_2_ad = pmp_2_ad + y30_ad
8897  END IF
8898  ELSE IF (branch .EQ. 2) THEN
8899  lac_2_ad = lac_2_ad + y30_ad
8900  ELSE
8901  a4_ad(1, i, k) = a4_ad(1, i, k) + y30_ad
8902  END IF
8903  pmp_2_ad = pmp_2_ad + lac_2_ad
8904  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
8905  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
8906  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
8907  CALL popcontrol1b(branch)
8908  IF (branch .EQ. 0) THEN
8909  CALL poprealarray_adm(a4(2, i, k))
8910  y17_ad = a4_ad(2, i, k)
8911  a4_ad(2, i, k) = 0.0
8912  x9_ad = 0.0
8913  ELSE
8914  CALL poprealarray_adm(a4(2, i, k))
8915  x9_ad = a4_ad(2, i, k)
8916  a4_ad(2, i, k) = 0.0
8917  y17_ad = 0.0
8918  END IF
8919  CALL popcontrol2b(branch)
8920  IF (branch .LT. 2) THEN
8921  IF (branch .EQ. 0) THEN
8922  lac_1_ad = y17_ad
8923  pmp_1_ad = 0.0
8924  ELSE
8925  pmp_1_ad = y17_ad
8926  lac_1_ad = 0.0
8927  END IF
8928  ELSE
8929  IF (branch .EQ. 2) THEN
8930  lac_1_ad = y17_ad
8931  ELSE
8932  a4_ad(1, i, k) = a4_ad(1, i, k) + y17_ad
8933  lac_1_ad = 0.0
8934  END IF
8935  pmp_1_ad = 0.0
8936  END IF
8937  CALL popcontrol1b(branch)
8938  IF (branch .EQ. 0) THEN
8939  y29_ad = x9_ad
8940  ELSE
8941  a4_ad(2, i, k) = a4_ad(2, i, k) + x9_ad
8942  y29_ad = 0.0
8943  END IF
8944  CALL popcontrol2b(branch)
8945  IF (branch .LT. 2) THEN
8946  IF (branch .EQ. 0) THEN
8947  lac_1_ad = lac_1_ad + y29_ad
8948  ELSE
8949  pmp_1_ad = pmp_1_ad + y29_ad
8950  END IF
8951  ELSE IF (branch .EQ. 2) THEN
8952  lac_1_ad = lac_1_ad + y29_ad
8953  ELSE
8954  a4_ad(1, i, k) = a4_ad(1, i, k) + y29_ad
8955  END IF
8956  pmp_1_ad = pmp_1_ad + lac_1_ad
8957  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
8958  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
8959  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
8960  ELSE
8961  CALL poprealarray_adm(a4(4, i, k))
8962  a4_ad(4, i, k) = 0.0
8963  CALL poprealarray_adm(a4(3, i, k))
8964  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
8965  a4_ad(3, i, k) = 0.0
8966  CALL poprealarray_adm(a4(2, i, k))
8967  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
8968  a4_ad(2, i, k) = 0.0
8969  END IF
8970  END DO
8971  ELSE
8972  DO i=i2,i1,-1
8973  CALL poprealarray_adm(a4(4, i, k))
8974  temp_ad23 = 3.*a4_ad(4, i, k)
8975  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad23
8976  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad23
8977  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad23
8978  a4_ad(4, i, k) = 0.0
8979  END DO
8980  END IF
8981  ELSE IF (branch .EQ. 6) THEN
8982  DO i=i2,i1,-1
8983  CALL popcontrol2b(branch)
8984  IF (branch .NE. 0) THEN
8985  IF (branch .NE. 1) THEN
8986  CALL poprealarray_adm(a4(4, i, k))
8987  temp_ad24 = 3.*a4_ad(4, i, k)
8988  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad24
8989  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad24
8990  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad24
8991  a4_ad(4, i, k) = 0.0
8992  CALL popcontrol1b(branch)
8993  IF (branch .EQ. 0) THEN
8994  CALL poprealarray_adm(a4(3, i, k))
8995  y20_ad = a4_ad(3, i, k)
8996  a4_ad(3, i, k) = 0.0
8997  x12_ad = 0.0
8998  ELSE
8999  CALL poprealarray_adm(a4(3, i, k))
9000  x12_ad = a4_ad(3, i, k)
9001  a4_ad(3, i, k) = 0.0
9002  y20_ad = 0.0
9003  END IF
9004  CALL popcontrol2b(branch)
9005  IF (branch .LT. 2) THEN
9006  IF (branch .EQ. 0) THEN
9007  lac_2_ad = y20_ad
9008  pmp_2_ad = 0.0
9009  ELSE
9010  pmp_2_ad = y20_ad
9011  lac_2_ad = 0.0
9012  END IF
9013  ELSE
9014  IF (branch .EQ. 2) THEN
9015  lac_2_ad = y20_ad
9016  ELSE
9017  a4_ad(1, i, k) = a4_ad(1, i, k) + y20_ad
9018  lac_2_ad = 0.0
9019  END IF
9020  pmp_2_ad = 0.0
9021  END IF
9022  CALL popcontrol1b(branch)
9023  IF (branch .EQ. 0) THEN
9024  y32_ad = x12_ad
9025  ELSE
9026  a4_ad(3, i, k) = a4_ad(3, i, k) + x12_ad
9027  y32_ad = 0.0
9028  END IF
9029  CALL popcontrol2b(branch)
9030  IF (branch .LT. 2) THEN
9031  IF (branch .EQ. 0) THEN
9032  lac_2_ad = lac_2_ad + y32_ad
9033  ELSE
9034  pmp_2_ad = pmp_2_ad + y32_ad
9035  END IF
9036  ELSE IF (branch .EQ. 2) THEN
9037  lac_2_ad = lac_2_ad + y32_ad
9038  ELSE
9039  a4_ad(1, i, k) = a4_ad(1, i, k) + y32_ad
9040  END IF
9041  pmp_2_ad = pmp_2_ad + lac_2_ad
9042  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
9043  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
9044  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
9045  CALL popcontrol1b(branch)
9046  IF (branch .EQ. 0) THEN
9047  CALL poprealarray_adm(a4(2, i, k))
9048  y19_ad = a4_ad(2, i, k)
9049  a4_ad(2, i, k) = 0.0
9050  x11_ad = 0.0
9051  ELSE
9052  CALL poprealarray_adm(a4(2, i, k))
9053  x11_ad = a4_ad(2, i, k)
9054  a4_ad(2, i, k) = 0.0
9055  y19_ad = 0.0
9056  END IF
9057  CALL popcontrol2b(branch)
9058  IF (branch .LT. 2) THEN
9059  IF (branch .EQ. 0) THEN
9060  lac_1_ad = y19_ad
9061  pmp_1_ad = 0.0
9062  ELSE
9063  pmp_1_ad = y19_ad
9064  lac_1_ad = 0.0
9065  END IF
9066  ELSE
9067  IF (branch .EQ. 2) THEN
9068  lac_1_ad = y19_ad
9069  ELSE
9070  a4_ad(1, i, k) = a4_ad(1, i, k) + y19_ad
9071  lac_1_ad = 0.0
9072  END IF
9073  pmp_1_ad = 0.0
9074  END IF
9075  CALL popcontrol1b(branch)
9076  IF (branch .EQ. 0) THEN
9077  y31_ad = x11_ad
9078  ELSE
9079  a4_ad(2, i, k) = a4_ad(2, i, k) + x11_ad
9080  y31_ad = 0.0
9081  END IF
9082  CALL popcontrol2b(branch)
9083  IF (branch .LT. 2) THEN
9084  IF (branch .EQ. 0) THEN
9085  lac_1_ad = lac_1_ad + y31_ad
9086  ELSE
9087  pmp_1_ad = pmp_1_ad + y31_ad
9088  END IF
9089  ELSE IF (branch .EQ. 2) THEN
9090  lac_1_ad = lac_1_ad + y31_ad
9091  ELSE
9092  a4_ad(1, i, k) = a4_ad(1, i, k) + y31_ad
9093  END IF
9094  pmp_1_ad = pmp_1_ad + lac_1_ad
9095  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
9096  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
9097  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
9098  END IF
9099  END IF
9100  END DO
9101  ELSE
9102  DO i=i2,i1,-1
9103  CALL popcontrol1b(branch)
9104  IF (branch .EQ. 0) THEN
9105  CALL poprealarray_adm(a4(4, i, k))
9106  temp_ad25 = 3.*a4_ad(4, i, k)
9107  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad25
9108  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad25
9109  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad25
9110  a4_ad(4, i, k) = 0.0
9111  ELSE
9112  CALL poprealarray_adm(a4(4, i, k))
9113  a4_ad(4, i, k) = 0.0
9114  CALL poprealarray_adm(a4(3, i, k))
9115  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
9116  a4_ad(3, i, k) = 0.0
9117  CALL poprealarray_adm(a4(2, i, k))
9118  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
9119  a4_ad(2, i, k) = 0.0
9120  END IF
9121  END DO
9122  END IF
9123  END DO
9124  CALL cs_limiters_bwd(im, extm(i1, 2), a4(1, i1, 2), a4_ad(1, i1, 2&
9125 & ), 2)
9126  DO i=i2,i1,-1
9127  CALL poprealarray_adm(a4(4, i, 2))
9128  temp_ad17 = 3.*a4_ad(4, i, 2)
9129  a4_ad(1, i, 2) = a4_ad(1, i, 2) + 2.*temp_ad17
9130  a4_ad(2, i, 2) = a4_ad(2, i, 2) - temp_ad17
9131  a4_ad(3, i, 2) = a4_ad(3, i, 2) - temp_ad17
9132  a4_ad(4, i, 2) = 0.0
9133  END DO
9134  CALL popcontrol1b(branch)
9135  IF (branch .NE. 0) THEN
9136  CALL cs_limiters_bwd(im, extm(i1, 1), a4(1, i1, 1), a4_ad(1, i1&
9137 & , 1), 1)
9138  DO i=i2,i1,-1
9139  CALL poprealarray_adm(a4(4, i, 1))
9140  temp_ad16 = 3.*a4_ad(4, i, 1)
9141  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 2.*temp_ad16
9142  a4_ad(2, i, 1) = a4_ad(2, i, 1) - temp_ad16
9143  a4_ad(3, i, 1) = a4_ad(3, i, 1) - temp_ad16
9144  a4_ad(4, i, 1) = 0.0
9145  END DO
9146  END IF
9147  CALL popcontrol2b(branch)
9148  IF (branch .LT. 2) THEN
9149  IF (branch .EQ. 0) THEN
9150  DO i=i2,i1,-1
9151  CALL popcontrol1b(branch)
9152  IF (branch .EQ. 0) THEN
9153  CALL poprealarray_adm(a4(2, i, 1))
9154  ELSE
9155  CALL poprealarray_adm(a4(2, i, 1))
9156  a4_ad(2, i, 1) = 0.0
9157  END IF
9158  END DO
9159  ELSE
9160  DO i=i2,i1,-1
9161  CALL popcontrol1b(branch)
9162  IF (branch .NE. 0) THEN
9163  CALL poprealarray_adm(a4(2, i, 1))
9164  a4_ad(2, i, 1) = 0.0
9165  END IF
9166  END DO
9167  END IF
9168  ELSE IF (branch .EQ. 2) THEN
9169  DO i=i2,i1,-1
9170  CALL poprealarray_adm(a4(4, i, 1))
9171  a4_ad(4, i, 1) = 0.0
9172  CALL poprealarray_adm(a4(3, i, 1))
9173  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(3, i, 1)
9174  a4_ad(3, i, 1) = 0.0
9175  CALL poprealarray_adm(a4(2, i, 1))
9176  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(2, i, 1)
9177  a4_ad(2, i, 1) = 0.0
9178  END DO
9179  END IF
9180  DO k=km,1,-1
9181  CALL popcontrol1b(branch)
9182  IF (branch .NE. 0) THEN
9183  DO i=i2,i1,-1
9184  CALL poprealarray_adm(a4(4, i, k))
9185  temp_ad15 = 3.*a4_ad(4, i, k)
9186  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad15
9187  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad15
9188  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad15
9189  a4_ad(4, i, k) = 0.0
9190  END DO
9191  END IF
9192  END DO
9193  q_ad = 0.0
9194  DO k=km,1,-1
9195  DO i=i2,i1,-1
9196  CALL poprealarray_adm(a4(3, i, k))
9197  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
9198  a4_ad(3, i, k) = 0.0
9199  CALL poprealarray_adm(a4(2, i, k))
9200  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
9201  a4_ad(2, i, k) = 0.0
9202  END DO
9203  END DO
9204  DO i=i2,i1,-1
9205  CALL popcontrol1b(branch)
9206  IF (branch .EQ. 0) THEN
9207  y8_ad = q_ad(i, km)
9208  q_ad(i, km) = 0.0
9209  ELSE
9210  y8_ad = 0.0
9211  END IF
9212  CALL popcontrol1b(branch)
9213  IF (branch .EQ. 0) THEN
9214  a4_ad(1, i, km) = a4_ad(1, i, km) + y8_ad
9215  ELSE
9216  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + y8_ad
9217  END IF
9218  CALL popcontrol1b(branch)
9219  IF (branch .EQ. 0) THEN
9220  CALL poprealarray_adm(q(i, km))
9221  y7_ad = q_ad(i, km)
9222  q_ad(i, km) = 0.0
9223  ELSE
9224  CALL poprealarray_adm(q(i, km))
9225  y7_ad = 0.0
9226  END IF
9227  CALL popcontrol1b(branch)
9228  IF (branch .EQ. 0) THEN
9229  a4_ad(1, i, km) = a4_ad(1, i, km) + y7_ad
9230  ELSE
9231  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + y7_ad
9232  END IF
9233  END DO
9234  DO k=km-1,3,-1
9235  DO 120 i=i2,i1,-1
9236  CALL popcontrol3b(branch)
9237  IF (branch .NE. 0) THEN
9238  IF (branch .LT. 4) THEN
9239  IF (branch .EQ. 1) THEN
9240  GOTO 110
9241  ELSE IF (branch .EQ. 2) THEN
9242  q_ad(i, k) = 0.0
9243  GOTO 110
9244  ELSE
9245  CALL poprealarray_adm(q(i, k))
9246  y5_ad = q_ad(i, k)
9247  q_ad(i, k) = 0.0
9248  END IF
9249  ELSE IF (branch .EQ. 4) THEN
9250  CALL poprealarray_adm(q(i, k))
9251  y5_ad = 0.0
9252  ELSE
9253  IF (branch .EQ. 5) THEN
9254  y4_ad = q_ad(i, k)
9255  q_ad(i, k) = 0.0
9256  ELSE
9257  y4_ad = 0.0
9258  END IF
9259  CALL popcontrol1b(branch)
9260  IF (branch .EQ. 0) THEN
9261  a4_ad(1, i, k) = a4_ad(1, i, k) + y4_ad
9262  ELSE
9263  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y4_ad
9264  END IF
9265  CALL popcontrol1b(branch)
9266  IF (branch .EQ. 0) THEN
9267  CALL poprealarray_adm(q(i, k))
9268  y3_ad = q_ad(i, k)
9269  q_ad(i, k) = 0.0
9270  ELSE
9271  CALL poprealarray_adm(q(i, k))
9272  y3_ad = 0.0
9273  END IF
9274  CALL popcontrol1b(branch)
9275  IF (branch .EQ. 0) THEN
9276  a4_ad(1, i, k) = a4_ad(1, i, k) + y3_ad
9277  ELSE
9278  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y3_ad
9279  END IF
9280  GOTO 120
9281  END IF
9282  CALL popcontrol1b(branch)
9283  IF (branch .EQ. 0) THEN
9284  a4_ad(1, i, k) = a4_ad(1, i, k) + y5_ad
9285  ELSE
9286  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y5_ad
9287  END IF
9288  GOTO 120
9289  END IF
9290  110 CALL popcontrol1b(branch)
9291  IF (branch .EQ. 0) THEN
9292  CALL poprealarray_adm(q(i, k))
9293  y6_ad = q_ad(i, k)
9294  q_ad(i, k) = 0.0
9295  ELSE
9296  CALL poprealarray_adm(q(i, k))
9297  y6_ad = 0.0
9298  END IF
9299  CALL popcontrol1b(branch)
9300  IF (branch .EQ. 0) THEN
9301  a4_ad(1, i, k) = a4_ad(1, i, k) + y6_ad
9302  ELSE
9303  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y6_ad
9304  END IF
9305  120 CONTINUE
9306  END DO
9307  DO k=km,2,-1
9308  DO i=i2,i1,-1
9309  CALL poprealarray_adm(gam(i, k))
9310  a4_ad(1, i, k) = a4_ad(1, i, k) + gam_ad(i, k)
9311  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) - gam_ad(i, k)
9312  gam_ad(i, k) = 0.0
9313  END DO
9314  END DO
9315  DO i=i2,i1,-1
9316  CALL popcontrol1b(branch)
9317  IF (branch .EQ. 0) THEN
9318  y2_ad = q_ad(i, 2)
9319  q_ad(i, 2) = 0.0
9320  ELSE
9321  y2_ad = 0.0
9322  END IF
9323  CALL popcontrol1b(branch)
9324  IF (branch .EQ. 0) THEN
9325  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y2_ad
9326  ELSE
9327  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y2_ad
9328  END IF
9329  CALL popcontrol1b(branch)
9330  IF (branch .EQ. 0) THEN
9331  CALL poprealarray_adm(q(i, 2))
9332  y1_ad = q_ad(i, 2)
9333  q_ad(i, 2) = 0.0
9334  ELSE
9335  CALL poprealarray_adm(q(i, 2))
9336  y1_ad = 0.0
9337  END IF
9338  CALL popcontrol1b(branch)
9339  IF (branch .EQ. 0) THEN
9340  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y1_ad
9341  ELSE
9342  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y1_ad
9343  END IF
9344  END DO
9345  END IF
9346  CALL popcontrol1b(branch)
9347  IF (branch .EQ. 0) THEN
9348  DO k=1,km,1
9349  DO i=i2,i1,-1
9350  CALL poprealarray_adm(q(i, k))
9351  gam_ad(i, k) = gam_ad(i, k) - q(i, k+1)*q_ad(i, k)
9352  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k)*q_ad(i, k)
9353  END DO
9354  END DO
9355  d4_ad = 0.0
9356  DO i=i2,i1,-1
9357  a_bot = 1. + d4(i)*(d4(i)+1.5)
9358  CALL poprealarray_adm(q(i, km+1))
9359  temp2 = d4(i)*(d4(i)+0.5) - a_bot*gam(i, km)
9360  temp_ad11 = q_ad(i, km+1)/temp2
9361  temp1 = d4(i)*(d4(i)+1.)
9362  temp_ad12 = 2.*a4(1, i, km)*temp_ad11
9363  temp_ad13 = -((2.*(temp1*a4(1, i, km))+a4(1, i, km-1)-a_bot*q(i&
9364 & , km))*temp_ad11/temp2)
9365  a4_ad(1, i, km) = a4_ad(1, i, km) + 2.*temp1*temp_ad11
9366  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + temp_ad11
9367  a_bot_ad = -(gam(i, km)*temp_ad13) - q(i, km)*temp_ad11
9368  d4_ad(i) = d4_ad(i) + (2*d4(i)+1.5)*a_bot_ad + (2*d4(i)+0.5)*&
9369 & temp_ad13 + (2*d4(i)+1.)*temp_ad12
9370  q_ad(i, km) = q_ad(i, km) - a_bot*temp_ad11
9371  gam_ad(i, km) = gam_ad(i, km) - a_bot*temp_ad13
9372  q_ad(i, km+1) = 0.0
9373  END DO
9374  DO k=km,2,-1
9375  DO i=i2,i1,-1
9376  temp_ad9 = q_ad(i, k)/bet
9377  temp_ad8 = 3.*temp_ad9
9378  CALL poprealarray_adm(q(i, k))
9379  bet_ad = -((3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))*&
9380 & temp_ad9/bet) - d4(i)*gam_ad(i, k)/bet**2
9381  d4_ad(i) = d4_ad(i) + a4(1, i, k)*temp_ad8 + 2*bet_ad + gam_ad&
9382 & (i, k)/bet
9383  gam_ad(i, k) = 0.0
9384  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + temp_ad8
9385  a4_ad(1, i, k) = a4_ad(1, i, k) + d4(i)*temp_ad8
9386  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad9
9387  q_ad(i, k) = 0.0
9388  CALL poprealarray_adm(bet)
9389  gam_ad(i, k-1) = gam_ad(i, k-1) - bet_ad
9390  CALL poprealarray_adm(d4(i))
9391  temp_ad10 = d4_ad(i)/delp(i, k)
9392  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad10
9393  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad10/delp(i&
9394 & , k)
9395  d4_ad(i) = 0.0
9396  END DO
9397  END DO
9398  DO i=i2,i1,-1
9399  grat = delp(i, 2)/delp(i, 1)
9400  bet = grat*(grat+0.5)
9401  temp_ad4 = gam_ad(i, 1)/bet
9402  gam_ad(i, 1) = 0.0
9403  temp_ad6 = q_ad(i, 1)/bet
9404  temp_ad5 = a4(1, i, 1)*temp_ad6
9405  temp0 = 2*grat*(grat+1.)
9406  bet_ad = -((temp0*a4(1, i, 1)+a4(1, i, 2))*temp_ad6/bet) - (grat&
9407 & *(grat+1.5)+1.)*temp_ad4/bet
9408  grat_ad = (4*grat+2*1.)*temp_ad5 + (2*grat+0.5)*bet_ad + (2*grat&
9409 & +1.5)*temp_ad4
9410  a4_ad(1, i, 1) = a4_ad(1, i, 1) + temp0*temp_ad6
9411  a4_ad(1, i, 2) = a4_ad(1, i, 2) + temp_ad6
9412  q_ad(i, 1) = 0.0
9413  temp_ad7 = grat_ad/delp(i, 1)
9414  delp_ad(i, 2) = delp_ad(i, 2) + temp_ad7
9415  delp_ad(i, 1) = delp_ad(i, 1) - delp(i, 2)*temp_ad7/delp(i, 1)
9416  END DO
9417  ELSE
9418  DO k=1,km-1,1
9419  DO i=i2,i1,-1
9420  CALL poprealarray_adm(q(i, k))
9421  gam_ad(i, k+1) = gam_ad(i, k+1) - q(i, k+1)*q_ad(i, k)
9422  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k+1)*q_ad(i, k)
9423  END DO
9424  END DO
9425  DO i=i2,i1,-1
9426  CALL poprealarray_adm(q(i, km+1))
9427  q_ad(i, km+1) = 0.0
9428  grat = delp(i, km-1)/delp(i, km)
9429  CALL poprealarray_adm(q(i, km))
9430  temp = 2*grat - gam(i, km) + 2.
9431  temp_ad1 = q_ad(i, km)/temp
9432  temp_ad2 = -((3.*(a4(1, i, km-1)+a4(1, i, km))-qs(i)*grat-q(i, &
9433 & km-1))*temp_ad1/temp)
9434  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + 3.*temp_ad1
9435  a4_ad(1, i, km) = a4_ad(1, i, km) + 3.*temp_ad1
9436  grat_ad = 2*temp_ad2 - qs(i)*temp_ad1
9437  q_ad(i, km-1) = q_ad(i, km-1) - temp_ad1
9438  gam_ad(i, km) = gam_ad(i, km) - temp_ad2
9439  q_ad(i, km) = 0.0
9440  temp_ad3 = grat_ad/delp(i, km)
9441  delp_ad(i, km-1) = delp_ad(i, km-1) + temp_ad3
9442  delp_ad(i, km) = delp_ad(i, km) - delp(i, km-1)*temp_ad3/delp(i&
9443 & , km)
9444  END DO
9445  DO k=km-1,2,-1
9446  DO i=i2,i1,-1
9447  temp_ad = q_ad(i, k)/bet
9448  CALL poprealarray_adm(q(i, k))
9449  grat = delp(i, k-1)/delp(i, k)
9450  bet_ad = -((3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*temp_ad/&
9451 & bet) - grat*gam_ad(i, k+1)/bet**2
9452  grat_ad = 2*bet_ad + gam_ad(i, k+1)/bet
9453  gam_ad(i, k+1) = 0.0
9454  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + 3.*temp_ad
9455  a4_ad(1, i, k) = a4_ad(1, i, k) + 3.*temp_ad
9456  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad
9457  q_ad(i, k) = 0.0
9458  CALL poprealarray_adm(bet)
9459  gam_ad(i, k) = gam_ad(i, k) - bet_ad
9460  temp_ad0 = grat_ad/delp(i, k)
9461  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad0
9462  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad0/delp(i, &
9463 & k)
9464  END DO
9465  END DO
9466  DO i=i2,i1,-1
9467  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 1.5*q_ad(i, 1)
9468  q_ad(i, 1) = 0.0
9469  END DO
9470  END IF
9471  END SUBROUTINE scalar_profile_adm
9472  SUBROUTINE scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
9473  IMPLICIT NONE
9474 ! Optimized vertical profile reconstruction:
9475 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
9476  INTEGER, INTENT(IN) :: i1, i2
9477 ! vertical dimension
9478  INTEGER, INTENT(IN) :: km
9479 ! iv =-1: winds
9480  INTEGER, INTENT(IN) :: iv
9481 ! iv = 0: positive definite scalars
9482 ! iv = 1: others
9483  INTEGER, INTENT(IN) :: kord
9484  REAL, INTENT(IN) :: qs(i1:i2)
9485 ! layer pressure thickness
9486  REAL, INTENT(IN) :: delp(i1:i2, km)
9487 ! Interpolated values
9488  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
9489  REAL, INTENT(IN) :: qmin
9490 !-----------------------------------------------------------------------
9491  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
9492  REAL :: gam(i1:i2, km)
9493  REAL :: q(i1:i2, km+1)
9494  REAL :: d4(i1:i2)
9495  REAL :: bet, a_bot, grat
9496  REAL :: pmp_1, lac_1, pmp_2, lac_2
9497  INTEGER :: i, k, im
9498  INTRINSIC abs
9499  INTRINSIC max
9500  INTRINSIC min
9501  INTEGER :: abs0
9502  INTEGER :: abs1
9503  REAL :: abs2
9504  INTEGER :: abs3
9505  INTEGER :: abs4
9506  REAL :: abs5
9507  INTEGER :: abs6
9508  REAL :: abs7
9509  INTEGER :: abs8
9510  REAL :: abs9
9511  INTEGER :: abs10
9512  INTEGER :: abs11
9513  INTEGER :: abs12
9514  REAL :: abs13
9515  REAL :: abs14
9516  REAL :: abs15
9517  REAL :: abs16
9518  REAL :: x12
9519  REAL :: x11
9520  REAL :: y29
9521  REAL :: x10
9522  REAL :: y28
9523  REAL :: y27
9524  REAL :: y26
9525  REAL :: y25
9526  REAL :: y24
9527  REAL :: y23
9528  REAL :: y22
9529  REAL :: y21
9530  REAL :: y20
9531  REAL :: x9
9532  REAL :: x8
9533  REAL :: x7
9534  REAL :: x6
9535  REAL :: x5
9536  REAL :: x4
9537  REAL :: x3
9538  REAL :: x2
9539  REAL :: x1
9540  REAL :: y19
9541  REAL :: y18
9542  REAL :: y17
9543  REAL :: y16
9544  REAL :: y15
9545  REAL :: y14
9546  REAL :: y13
9547  REAL :: y12
9548  REAL :: y11
9549  REAL :: y10
9550  REAL :: y32
9551  REAL :: y31
9552  REAL :: y30
9553  REAL :: y9
9554  REAL :: y8
9555  REAL :: y7
9556  REAL :: y6
9557  REAL :: y5
9558  REAL :: y4
9559  REAL :: y3
9560  REAL :: y2
9561  REAL :: y1
9562  IF (iv .EQ. -2) THEN
9563  DO i=i1,i2
9564  gam(i, 2) = 0.5
9565  q(i, 1) = 1.5*a4(1, i, 1)
9566  END DO
9567  DO k=2,km-1
9568  DO i=i1,i2
9569  grat = delp(i, k-1)/delp(i, k)
9570  bet = 2. + grat + grat - gam(i, k)
9571  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
9572  gam(i, k+1) = grat/bet
9573  END DO
9574  END DO
9575  DO i=i1,i2
9576  grat = delp(i, km-1)/delp(i, km)
9577  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
9578 & 1))/(2.+grat+grat-gam(i, km))
9579  q(i, km+1) = qs(i)
9580  END DO
9581  DO k=km-1,1,-1
9582  DO i=i1,i2
9583  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
9584  END DO
9585  END DO
9586  ELSE
9587  DO i=i1,i2
9588 ! grid ratio
9589  grat = delp(i, 2)/delp(i, 1)
9590  bet = grat*(grat+0.5)
9591  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
9592  gam(i, 1) = (1.+grat*(grat+1.5))/bet
9593  END DO
9594  DO k=2,km
9595  DO i=i1,i2
9596  d4(i) = delp(i, k-1)/delp(i, k)
9597  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
9598  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
9599  gam(i, k) = d4(i)/bet
9600  END DO
9601  END DO
9602  DO i=i1,i2
9603  a_bot = 1. + d4(i)*(d4(i)+1.5)
9604  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
9605 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
9606  END DO
9607  DO k=km,1,-1
9608  DO i=i1,i2
9609  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
9610  END DO
9611  END DO
9612  END IF
9613  IF (kord .GE. 0.) THEN
9614  abs0 = kord
9615  ELSE
9616  abs0 = -kord
9617  END IF
9618 !----- Perfectly linear scheme --------------------------------
9619  IF (abs0 .GT. 16) THEN
9620  DO k=1,km
9621  DO i=i1,i2
9622  a4(2, i, k) = q(i, k)
9623  a4(3, i, k) = q(i, k+1)
9624  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
9625  END DO
9626  END DO
9627  RETURN
9628  ELSE
9629 !----- Perfectly linear scheme --------------------------------
9630 !------------------
9631 ! Apply constraints
9632 !------------------
9633  im = i2 - i1 + 1
9634 ! Apply *large-scale* constraints
9635  DO i=i1,i2
9636  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
9637  y1 = a4(1, i, 2)
9638  ELSE
9639  y1 = a4(1, i, 1)
9640  END IF
9641  IF (q(i, 2) .GT. y1) THEN
9642  q(i, 2) = y1
9643  ELSE
9644  q(i, 2) = q(i, 2)
9645  END IF
9646  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
9647  y2 = a4(1, i, 2)
9648  ELSE
9649  y2 = a4(1, i, 1)
9650  END IF
9651  IF (q(i, 2) .LT. y2) THEN
9652  q(i, 2) = y2
9653  ELSE
9654  q(i, 2) = q(i, 2)
9655  END IF
9656  END DO
9657  DO k=2,km
9658  DO i=i1,i2
9659  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
9660  END DO
9661  END DO
9662 ! Interior:
9663  DO k=3,km-1
9664  DO i=i1,i2
9665  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
9666  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
9667  y3 = a4(1, i, k)
9668  ELSE
9669  y3 = a4(1, i, k-1)
9670  END IF
9671  IF (q(i, k) .GT. y3) THEN
9672  q(i, k) = y3
9673  ELSE
9674  q(i, k) = q(i, k)
9675  END IF
9676  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
9677  y4 = a4(1, i, k)
9678  ELSE
9679  y4 = a4(1, i, k-1)
9680  END IF
9681  IF (q(i, k) .LT. y4) THEN
9682  q(i, k) = y4
9683  ELSE
9684  q(i, k) = q(i, k)
9685  END IF
9686  ELSE IF (gam(i, k-1) .GT. 0.) THEN
9687  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
9688  y5 = a4(1, i, k)
9689  ELSE
9690  y5 = a4(1, i, k-1)
9691  END IF
9692  IF (q(i, k) .LT. y5) THEN
9693  q(i, k) = y5
9694  ELSE
9695  q(i, k) = q(i, k)
9696  END IF
9697  ELSE
9698  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
9699  y6 = a4(1, i, k)
9700  ELSE
9701  y6 = a4(1, i, k-1)
9702  END IF
9703  IF (q(i, k) .GT. y6) THEN
9704  q(i, k) = y6
9705  ELSE
9706  q(i, k) = q(i, k)
9707  END IF
9708  IF (iv .EQ. 0) THEN
9709  IF (0. .LT. q(i, k)) THEN
9710  q(i, k) = q(i, k)
9711  ELSE
9712  q(i, k) = 0.
9713  END IF
9714  END IF
9715  END IF
9716  END DO
9717  END DO
9718 ! Bottom:
9719  DO i=i1,i2
9720  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
9721  y7 = a4(1, i, km)
9722  ELSE
9723  y7 = a4(1, i, km-1)
9724  END IF
9725  IF (q(i, km) .GT. y7) THEN
9726  q(i, km) = y7
9727  ELSE
9728  q(i, km) = q(i, km)
9729  END IF
9730  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
9731  y8 = a4(1, i, km)
9732  ELSE
9733  y8 = a4(1, i, km-1)
9734  END IF
9735  IF (q(i, km) .LT. y8) THEN
9736  q(i, km) = y8
9737  ELSE
9738  q(i, km) = q(i, km)
9739  END IF
9740  END DO
9741  DO k=1,km
9742  DO i=i1,i2
9743  a4(2, i, k) = q(i, k)
9744  a4(3, i, k) = q(i, k+1)
9745  END DO
9746  END DO
9747  DO k=1,km
9748  IF (k .EQ. 1 .OR. k .EQ. km) THEN
9749  DO i=i1,i2
9750  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
9751 & , k)) .GT. 0.
9752  END DO
9753  ELSE
9754  DO i=i1,i2
9755  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
9756  END DO
9757  END IF
9758  IF (kord .GE. 0.) THEN
9759  abs1 = kord
9760  ELSE
9761  abs1 = -kord
9762  END IF
9763  IF (abs1 .EQ. 16) THEN
9764  DO i=i1,i2
9765  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
9766  IF (a4(4, i, k) .GE. 0.) THEN
9767  abs2 = a4(4, i, k)
9768  ELSE
9769  abs2 = -a4(4, i, k)
9770  END IF
9771  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
9772  abs13 = a4(2, i, k) - a4(3, i, k)
9773  ELSE
9774  abs13 = -(a4(2, i, k)-a4(3, i, k))
9775  END IF
9776  ext6(i, k) = abs2 .GT. abs13
9777  END DO
9778  END IF
9779  END DO
9780 !---------------------------
9781 ! Apply subgrid constraints:
9782 !---------------------------
9783 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
9784 ! Top 2 and bottom 2 layers always use monotonic mapping
9785  IF (iv .EQ. 0) THEN
9786  DO i=i1,i2
9787  IF (0. .LT. a4(2, i, 1)) THEN
9788  a4(2, i, 1) = a4(2, i, 1)
9789  ELSE
9790  a4(2, i, 1) = 0.
9791  END IF
9792  END DO
9793  ELSE IF (iv .EQ. -1) THEN
9794  DO i=i1,i2
9795  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
9796  END DO
9797  ELSE IF (iv .EQ. 2) THEN
9798  DO i=i1,i2
9799  a4(2, i, 1) = a4(1, i, 1)
9800  a4(3, i, 1) = a4(1, i, 1)
9801  a4(4, i, 1) = 0.
9802  END DO
9803  END IF
9804  IF (iv .NE. 2) THEN
9805  DO i=i1,i2
9806  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
9807  END DO
9808  CALL cs_limiters(im, extm(i1, 1), a4(1, i1, 1), 1)
9809  END IF
9810 ! k=2
9811  DO i=i1,i2
9812  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
9813  END DO
9814  CALL cs_limiters(im, extm(i1, 2), a4(1, i1, 2), 2)
9815 !-------------------------------------
9816 ! Huynh's 2nd constraint for interior:
9817 !-------------------------------------
9818  DO k=3,km-2
9819  IF (kord .GE. 0.) THEN
9820  abs3 = kord
9821  ELSE
9822  abs3 = -kord
9823  END IF
9824  IF (abs3 .LT. 9) THEN
9825  DO i=i1,i2
9826 ! Left edges
9827  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
9828  lac_1 = pmp_1 + 1.5*gam(i, k+2)
9829  IF (a4(1, i, k) .GT. pmp_1) THEN
9830  IF (pmp_1 .GT. lac_1) THEN
9831  y21 = lac_1
9832  ELSE
9833  y21 = pmp_1
9834  END IF
9835  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
9836  y21 = lac_1
9837  ELSE
9838  y21 = a4(1, i, k)
9839  END IF
9840  IF (a4(2, i, k) .LT. y21) THEN
9841  x1 = y21
9842  ELSE
9843  x1 = a4(2, i, k)
9844  END IF
9845  IF (a4(1, i, k) .LT. pmp_1) THEN
9846  IF (pmp_1 .LT. lac_1) THEN
9847  y9 = lac_1
9848  ELSE
9849  y9 = pmp_1
9850  END IF
9851  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
9852  y9 = lac_1
9853  ELSE
9854  y9 = a4(1, i, k)
9855  END IF
9856  IF (x1 .GT. y9) THEN
9857  a4(2, i, k) = y9
9858  ELSE
9859  a4(2, i, k) = x1
9860  END IF
9861 ! Right edges
9862  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
9863  lac_2 = pmp_2 - 1.5*gam(i, k-1)
9864  IF (a4(1, i, k) .GT. pmp_2) THEN
9865  IF (pmp_2 .GT. lac_2) THEN
9866  y22 = lac_2
9867  ELSE
9868  y22 = pmp_2
9869  END IF
9870  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
9871  y22 = lac_2
9872  ELSE
9873  y22 = a4(1, i, k)
9874  END IF
9875  IF (a4(3, i, k) .LT. y22) THEN
9876  x2 = y22
9877  ELSE
9878  x2 = a4(3, i, k)
9879  END IF
9880  IF (a4(1, i, k) .LT. pmp_2) THEN
9881  IF (pmp_2 .LT. lac_2) THEN
9882  y10 = lac_2
9883  ELSE
9884  y10 = pmp_2
9885  END IF
9886  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
9887  y10 = lac_2
9888  ELSE
9889  y10 = a4(1, i, k)
9890  END IF
9891  IF (x2 .GT. y10) THEN
9892  a4(3, i, k) = y10
9893  ELSE
9894  a4(3, i, k) = x2
9895  END IF
9896  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
9897  END DO
9898  ELSE
9899  IF (kord .GE. 0.) THEN
9900  abs4 = kord
9901  ELSE
9902  abs4 = -kord
9903  END IF
9904  IF (abs4 .EQ. 9) THEN
9905  DO i=i1,i2
9906  IF (extm(i, k) .AND. extm(i, k-1)) THEN
9907 ! grid-scale 2-delta-z wave detected
9908  a4(2, i, k) = a4(1, i, k)
9909  a4(3, i, k) = a4(1, i, k)
9910  a4(4, i, k) = 0.
9911  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
9912 ! grid-scale 2-delta-z wave detected
9913  a4(2, i, k) = a4(1, i, k)
9914  a4(3, i, k) = a4(1, i, k)
9915  a4(4, i, k) = 0.
9916  ELSE IF (extm(i, k) .AND. a4(1, i, k) .LT. qmin) THEN
9917 ! grid-scale 2-delta-z wave detected
9918  a4(2, i, k) = a4(1, i, k)
9919  a4(3, i, k) = a4(1, i, k)
9920  a4(4, i, k) = 0.
9921  ELSE
9922  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k&
9923 & )))
9924  IF (a4(4, i, k) .GE. 0.) THEN
9925  abs5 = a4(4, i, k)
9926  ELSE
9927  abs5 = -a4(4, i, k)
9928  END IF
9929  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
9930  abs14 = a4(2, i, k) - a4(3, i, k)
9931  ELSE
9932  abs14 = -(a4(2, i, k)-a4(3, i, k))
9933  END IF
9934 ! Check within the smooth region if subgrid profile is non-monotonic
9935  IF (abs5 .GT. abs14) THEN
9936  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
9937  lac_1 = pmp_1 + 1.5*gam(i, k+2)
9938  IF (a4(1, i, k) .GT. pmp_1) THEN
9939  IF (pmp_1 .GT. lac_1) THEN
9940  y23 = lac_1
9941  ELSE
9942  y23 = pmp_1
9943  END IF
9944  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
9945  y23 = lac_1
9946  ELSE
9947  y23 = a4(1, i, k)
9948  END IF
9949  IF (a4(2, i, k) .LT. y23) THEN
9950  x3 = y23
9951  ELSE
9952  x3 = a4(2, i, k)
9953  END IF
9954  IF (a4(1, i, k) .LT. pmp_1) THEN
9955  IF (pmp_1 .LT. lac_1) THEN
9956  y11 = lac_1
9957  ELSE
9958  y11 = pmp_1
9959  END IF
9960  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
9961  y11 = lac_1
9962  ELSE
9963  y11 = a4(1, i, k)
9964  END IF
9965  IF (x3 .GT. y11) THEN
9966  a4(2, i, k) = y11
9967  ELSE
9968  a4(2, i, k) = x3
9969  END IF
9970  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
9971  lac_2 = pmp_2 - 1.5*gam(i, k-1)
9972  IF (a4(1, i, k) .GT. pmp_2) THEN
9973  IF (pmp_2 .GT. lac_2) THEN
9974  y24 = lac_2
9975  ELSE
9976  y24 = pmp_2
9977  END IF
9978  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
9979  y24 = lac_2
9980  ELSE
9981  y24 = a4(1, i, k)
9982  END IF
9983  IF (a4(3, i, k) .LT. y24) THEN
9984  x4 = y24
9985  ELSE
9986  x4 = a4(3, i, k)
9987  END IF
9988  IF (a4(1, i, k) .LT. pmp_2) THEN
9989  IF (pmp_2 .LT. lac_2) THEN
9990  y12 = lac_2
9991  ELSE
9992  y12 = pmp_2
9993  END IF
9994  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
9995  y12 = lac_2
9996  ELSE
9997  y12 = a4(1, i, k)
9998  END IF
9999  IF (x4 .GT. y12) THEN
10000  a4(3, i, k) = y12
10001  ELSE
10002  a4(3, i, k) = x4
10003  END IF
10004  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i&
10005 & , k)))
10006  END IF
10007  END IF
10008  END DO
10009  ELSE
10010  IF (kord .GE. 0.) THEN
10011  abs6 = kord
10012  ELSE
10013  abs6 = -kord
10014  END IF
10015  IF (abs6 .EQ. 10) THEN
10016  DO i=i1,i2
10017  IF (extm(i, k)) THEN
10018  IF ((a4(1, i, k) .LT. qmin .OR. extm(i, k-1)) .OR. &
10019 & extm(i, k+1)) THEN
10020 ! grid-scale 2-delta-z wave detected; or q is too small -> ehance vertical mixing
10021  a4(2, i, k) = a4(1, i, k)
10022  a4(3, i, k) = a4(1, i, k)
10023  a4(4, i, k) = 0.
10024  ELSE
10025 ! True local extremum
10026  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
10027 & , i, k))
10028  END IF
10029  ELSE
10030 ! not a local extremum
10031  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
10032 & , k))
10033  IF (a4(4, i, k) .GE. 0.) THEN
10034  abs7 = a4(4, i, k)
10035  ELSE
10036  abs7 = -a4(4, i, k)
10037  END IF
10038  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
10039  abs15 = a4(2, i, k) - a4(3, i, k)
10040  ELSE
10041  abs15 = -(a4(2, i, k)-a4(3, i, k))
10042  END IF
10043 ! Check within the smooth region if subgrid profile is non-monotonic
10044  IF (abs7 .GT. abs15) THEN
10045  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
10046  lac_1 = pmp_1 + 1.5*gam(i, k+2)
10047  IF (a4(1, i, k) .GT. pmp_1) THEN
10048  IF (pmp_1 .GT. lac_1) THEN
10049  y25 = lac_1
10050  ELSE
10051  y25 = pmp_1
10052  END IF
10053  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
10054  y25 = lac_1
10055  ELSE
10056  y25 = a4(1, i, k)
10057  END IF
10058  IF (a4(2, i, k) .LT. y25) THEN
10059  x5 = y25
10060  ELSE
10061  x5 = a4(2, i, k)
10062  END IF
10063  IF (a4(1, i, k) .LT. pmp_1) THEN
10064  IF (pmp_1 .LT. lac_1) THEN
10065  y13 = lac_1
10066  ELSE
10067  y13 = pmp_1
10068  END IF
10069  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
10070  y13 = lac_1
10071  ELSE
10072  y13 = a4(1, i, k)
10073  END IF
10074  IF (x5 .GT. y13) THEN
10075  a4(2, i, k) = y13
10076  ELSE
10077  a4(2, i, k) = x5
10078  END IF
10079  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
10080  lac_2 = pmp_2 - 1.5*gam(i, k-1)
10081  IF (a4(1, i, k) .GT. pmp_2) THEN
10082  IF (pmp_2 .GT. lac_2) THEN
10083  y26 = lac_2
10084  ELSE
10085  y26 = pmp_2
10086  END IF
10087  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
10088  y26 = lac_2
10089  ELSE
10090  y26 = a4(1, i, k)
10091  END IF
10092  IF (a4(3, i, k) .LT. y26) THEN
10093  x6 = y26
10094  ELSE
10095  x6 = a4(3, i, k)
10096  END IF
10097  IF (a4(1, i, k) .LT. pmp_2) THEN
10098  IF (pmp_2 .LT. lac_2) THEN
10099  y14 = lac_2
10100  ELSE
10101  y14 = pmp_2
10102  END IF
10103  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
10104  y14 = lac_2
10105  ELSE
10106  y14 = a4(1, i, k)
10107  END IF
10108  IF (x6 .GT. y14) THEN
10109  a4(3, i, k) = y14
10110  ELSE
10111  a4(3, i, k) = x6
10112  END IF
10113  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
10114 & , i, k))
10115  END IF
10116  END IF
10117  END DO
10118  ELSE
10119  IF (kord .GE. 0.) THEN
10120  abs8 = kord
10121  ELSE
10122  abs8 = -kord
10123  END IF
10124  IF (abs8 .EQ. 12) THEN
10125  DO i=i1,i2
10126  IF (extm(i, k)) THEN
10127  a4(2, i, k) = a4(1, i, k)
10128  a4(3, i, k) = a4(1, i, k)
10129  a4(4, i, k) = 0.
10130  ELSE
10131 ! not a local extremum
10132  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
10133 & , i, k))
10134  IF (a4(4, i, k) .GE. 0.) THEN
10135  abs9 = a4(4, i, k)
10136  ELSE
10137  abs9 = -a4(4, i, k)
10138  END IF
10139  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
10140  abs16 = a4(2, i, k) - a4(3, i, k)
10141  ELSE
10142  abs16 = -(a4(2, i, k)-a4(3, i, k))
10143  END IF
10144 ! Check within the smooth region if subgrid profile is non-monotonic
10145  IF (abs9 .GT. abs16) THEN
10146  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
10147  lac_1 = pmp_1 + 1.5*gam(i, k+2)
10148  IF (a4(1, i, k) .GT. pmp_1) THEN
10149  IF (pmp_1 .GT. lac_1) THEN
10150  y27 = lac_1
10151  ELSE
10152  y27 = pmp_1
10153  END IF
10154  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
10155  y27 = lac_1
10156  ELSE
10157  y27 = a4(1, i, k)
10158  END IF
10159  IF (a4(2, i, k) .LT. y27) THEN
10160  x7 = y27
10161  ELSE
10162  x7 = a4(2, i, k)
10163  END IF
10164  IF (a4(1, i, k) .LT. pmp_1) THEN
10165  IF (pmp_1 .LT. lac_1) THEN
10166  y15 = lac_1
10167  ELSE
10168  y15 = pmp_1
10169  END IF
10170  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
10171  y15 = lac_1
10172  ELSE
10173  y15 = a4(1, i, k)
10174  END IF
10175  IF (x7 .GT. y15) THEN
10176  a4(2, i, k) = y15
10177  ELSE
10178  a4(2, i, k) = x7
10179  END IF
10180  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
10181  lac_2 = pmp_2 - 1.5*gam(i, k-1)
10182  IF (a4(1, i, k) .GT. pmp_2) THEN
10183  IF (pmp_2 .GT. lac_2) THEN
10184  y28 = lac_2
10185  ELSE
10186  y28 = pmp_2
10187  END IF
10188  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
10189  y28 = lac_2
10190  ELSE
10191  y28 = a4(1, i, k)
10192  END IF
10193  IF (a4(3, i, k) .LT. y28) THEN
10194  x8 = y28
10195  ELSE
10196  x8 = a4(3, i, k)
10197  END IF
10198  IF (a4(1, i, k) .LT. pmp_2) THEN
10199  IF (pmp_2 .LT. lac_2) THEN
10200  y16 = lac_2
10201  ELSE
10202  y16 = pmp_2
10203  END IF
10204  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
10205  y16 = lac_2
10206  ELSE
10207  y16 = a4(1, i, k)
10208  END IF
10209  IF (x8 .GT. y16) THEN
10210  a4(3, i, k) = y16
10211  ELSE
10212  a4(3, i, k) = x8
10213  END IF
10214  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
10215 & 3, i, k))
10216  END IF
10217  END IF
10218  END DO
10219  ELSE
10220  IF (kord .GE. 0.) THEN
10221  abs10 = kord
10222  ELSE
10223  abs10 = -kord
10224  END IF
10225  IF (abs10 .EQ. 13) THEN
10226  DO i=i1,i2
10227  IF (extm(i, k)) THEN
10228  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
10229 ! grid-scale 2-delta-z wave detected
10230  a4(2, i, k) = a4(1, i, k)
10231  a4(3, i, k) = a4(1, i, k)
10232  a4(4, i, k) = 0.
10233  ELSE
10234 ! Left edges
10235  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
10236  lac_1 = pmp_1 + 1.5*gam(i, k+2)
10237  IF (a4(1, i, k) .GT. pmp_1) THEN
10238  IF (pmp_1 .GT. lac_1) THEN
10239  y29 = lac_1
10240  ELSE
10241  y29 = pmp_1
10242  END IF
10243  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
10244  y29 = lac_1
10245  ELSE
10246  y29 = a4(1, i, k)
10247  END IF
10248  IF (a4(2, i, k) .LT. y29) THEN
10249  x9 = y29
10250  ELSE
10251  x9 = a4(2, i, k)
10252  END IF
10253  IF (a4(1, i, k) .LT. pmp_1) THEN
10254  IF (pmp_1 .LT. lac_1) THEN
10255  y17 = lac_1
10256  ELSE
10257  y17 = pmp_1
10258  END IF
10259  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
10260  y17 = lac_1
10261  ELSE
10262  y17 = a4(1, i, k)
10263  END IF
10264  IF (x9 .GT. y17) THEN
10265  a4(2, i, k) = y17
10266  ELSE
10267  a4(2, i, k) = x9
10268  END IF
10269 ! Right edges
10270  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
10271  lac_2 = pmp_2 - 1.5*gam(i, k-1)
10272  IF (a4(1, i, k) .GT. pmp_2) THEN
10273  IF (pmp_2 .GT. lac_2) THEN
10274  y30 = lac_2
10275  ELSE
10276  y30 = pmp_2
10277  END IF
10278  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
10279  y30 = lac_2
10280  ELSE
10281  y30 = a4(1, i, k)
10282  END IF
10283  IF (a4(3, i, k) .LT. y30) THEN
10284  x10 = y30
10285  ELSE
10286  x10 = a4(3, i, k)
10287  END IF
10288  IF (a4(1, i, k) .LT. pmp_2) THEN
10289  IF (pmp_2 .LT. lac_2) THEN
10290  y18 = lac_2
10291  ELSE
10292  y18 = pmp_2
10293  END IF
10294  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
10295  y18 = lac_2
10296  ELSE
10297  y18 = a4(1, i, k)
10298  END IF
10299  IF (x10 .GT. y18) THEN
10300  a4(3, i, k) = y18
10301  ELSE
10302  a4(3, i, k) = x10
10303  END IF
10304  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
10305 & (3, i, k)))
10306  END IF
10307  ELSE
10308  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
10309 & , i, k)))
10310  END IF
10311  END DO
10312  ELSE
10313  IF (kord .GE. 0.) THEN
10314  abs11 = kord
10315  ELSE
10316  abs11 = -kord
10317  END IF
10318  IF (abs11 .EQ. 14) THEN
10319  DO i=i1,i2
10320  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
10321 & , i, k)))
10322  END DO
10323  ELSE
10324  IF (kord .GE. 0.) THEN
10325  abs12 = kord
10326  ELSE
10327  abs12 = -kord
10328  END IF
10329  IF (abs12 .EQ. 16) THEN
10330  DO i=i1,i2
10331  IF (ext6(i, k)) THEN
10332  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
10333 ! Left edges
10334  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
10335  lac_1 = pmp_1 + 1.5*gam(i, k+2)
10336  IF (a4(1, i, k) .GT. pmp_1) THEN
10337  IF (pmp_1 .GT. lac_1) THEN
10338  y31 = lac_1
10339  ELSE
10340  y31 = pmp_1
10341  END IF
10342  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
10343  y31 = lac_1
10344  ELSE
10345  y31 = a4(1, i, k)
10346  END IF
10347  IF (a4(2, i, k) .LT. y31) THEN
10348  x11 = y31
10349  ELSE
10350  x11 = a4(2, i, k)
10351  END IF
10352  IF (a4(1, i, k) .LT. pmp_1) THEN
10353  IF (pmp_1 .LT. lac_1) THEN
10354  y19 = lac_1
10355  ELSE
10356  y19 = pmp_1
10357  END IF
10358  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
10359  y19 = lac_1
10360  ELSE
10361  y19 = a4(1, i, k)
10362  END IF
10363  IF (x11 .GT. y19) THEN
10364  a4(2, i, k) = y19
10365  ELSE
10366  a4(2, i, k) = x11
10367  END IF
10368 ! Right edges
10369  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
10370  lac_2 = pmp_2 - 1.5*gam(i, k-1)
10371  IF (a4(1, i, k) .GT. pmp_2) THEN
10372  IF (pmp_2 .GT. lac_2) THEN
10373  y32 = lac_2
10374  ELSE
10375  y32 = pmp_2
10376  END IF
10377  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
10378  y32 = lac_2
10379  ELSE
10380  y32 = a4(1, i, k)
10381  END IF
10382  IF (a4(3, i, k) .LT. y32) THEN
10383  x12 = y32
10384  ELSE
10385  x12 = a4(3, i, k)
10386  END IF
10387  IF (a4(1, i, k) .LT. pmp_2) THEN
10388  IF (pmp_2 .LT. lac_2) THEN
10389  y20 = lac_2
10390  ELSE
10391  y20 = pmp_2
10392  END IF
10393  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
10394  y20 = lac_2
10395  ELSE
10396  y20 = a4(1, i, k)
10397  END IF
10398  IF (x12 .GT. y20) THEN
10399  a4(3, i, k) = y20
10400  ELSE
10401  a4(3, i, k) = x12
10402  END IF
10403  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k&
10404 & )+a4(3, i, k)))
10405  END IF
10406  END IF
10407  END DO
10408  ELSE
10409 ! kord = 11, 13
10410  DO i=i1,i2
10411  IF (extm(i, k) .AND. ((extm(i, k-1) .OR. extm(i&
10412 & , k+1)) .OR. a4(1, i, k) .LT. qmin)) THEN
10413 ! Noisy region:
10414  a4(2, i, k) = a4(1, i, k)
10415  a4(3, i, k) = a4(1, i, k)
10416  a4(4, i, k) = 0.
10417  ELSE
10418  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+&
10419 & a4(3, i, k)))
10420  END IF
10421  END DO
10422  END IF
10423  END IF
10424  END IF
10425  END IF
10426  END IF
10427  END IF
10428  END IF
10429 ! Additional constraint to ensure positivity
10430  IF (iv .EQ. 0) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 0&
10431 & )
10432  END DO
10433 ! k-loop
10434 !----------------------------------
10435 ! Bottom layer subgrid constraints:
10436 !----------------------------------
10437  IF (iv .EQ. 0) THEN
10438  DO i=i1,i2
10439  IF (0. .LT. a4(3, i, km)) THEN
10440  a4(3, i, km) = a4(3, i, km)
10441  ELSE
10442  a4(3, i, km) = 0.
10443  END IF
10444  END DO
10445  ELSE IF (iv .EQ. -1) THEN
10446  DO i=i1,i2
10447  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) a4(3, i, km) = 0.
10448  END DO
10449  END IF
10450  DO k=km-1,km
10451  DO i=i1,i2
10452  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
10453  END DO
10454  IF (k .EQ. km - 1) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k&
10455 & ), 2)
10456  IF (k .EQ. km) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 1&
10457 & )
10458  END DO
10459  END IF
10460  END SUBROUTINE scalar_profile
10461 ! Differentiation of cs_profile in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn
10462 !_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 dy
10463 !n_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_
10464 !mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynam
10465 !ics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils
10466 !_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_m
10467 !od.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.scal
10468 !ar_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.ste
10469 !epz 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_
10470 !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.co
10471 !mpute_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
10472 !_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
10473 ! 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 s
10474 !w_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_cor
10475 !e_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.
10476 !compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corner
10477 !s_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circ
10478 !le_dist sw_core_mod.edge_interpolate4)):
10479 ! gradient of useful results: qs delp a4
10480 ! with respect to varying inputs: qs delp a4
10481  SUBROUTINE cs_profile_adm(qs, qs_ad, a4, a4_ad, delp, delp_ad, km, i1&
10482 & , i2, iv, kord)
10483  IMPLICIT NONE
10484 ! Optimized vertical profile reconstruction:
10485 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
10486  INTEGER, INTENT(IN) :: i1, i2
10487 ! vertical dimension
10488  INTEGER, INTENT(IN) :: km
10489 ! iv =-1: winds
10490  INTEGER, INTENT(IN) :: iv
10491 ! iv = 0: positive definite scalars
10492 ! iv = 1: others
10493  INTEGER, INTENT(IN) :: kord
10494  REAL, INTENT(IN) :: qs(i1:i2)
10495  REAL :: qs_ad(i1:i2)
10496 ! layer pressure thickness
10497  REAL, INTENT(IN) :: delp(i1:i2, km)
10498  REAL :: delp_ad(i1:i2, km)
10499 ! Interpolated values
10500  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
10501  REAL, INTENT(INOUT) :: a4_ad(4, i1:i2, km)
10502 !-----------------------------------------------------------------------
10503  LOGICAL :: extm(i1:i2, km)
10504  REAL :: gam(i1:i2, km)
10505  REAL :: gam_ad(i1:i2, km)
10506  REAL :: q(i1:i2, km+1)
10507  REAL :: q_ad(i1:i2, km+1)
10508  REAL :: d4(i1:i2)
10509  REAL :: d4_ad(i1:i2)
10510  REAL :: bet, a_bot, grat
10511  REAL :: bet_ad, a_bot_ad, grat_ad
10512  REAL :: pmp_1, lac_1, pmp_2, lac_2
10513  REAL :: pmp_1_ad, lac_1_ad, pmp_2_ad, lac_2_ad
10514  INTEGER :: i, k, im
10515  INTRINSIC abs
10516  INTRINSIC max
10517  INTRINSIC min
10518  INTEGER :: abs0
10519  INTEGER :: abs1
10520  INTEGER :: abs2
10521  REAL :: abs3
10522  INTEGER :: abs4
10523  REAL :: abs5
10524  INTEGER :: abs6
10525  REAL :: abs7
10526  INTEGER :: abs8
10527  INTEGER :: abs9
10528  REAL :: abs10
10529  REAL :: abs11
10530  REAL :: abs12
10531  REAL :: temp_ad
10532  REAL :: temp_ad0
10533  REAL :: temp
10534  REAL :: temp_ad1
10535  REAL :: temp_ad2
10536  REAL :: temp_ad3
10537  REAL :: temp0
10538  REAL :: temp_ad4
10539  REAL :: temp_ad5
10540  REAL :: temp_ad6
10541  REAL :: temp_ad7
10542  REAL :: temp_ad8
10543  REAL :: temp_ad9
10544  REAL :: temp_ad10
10545  REAL :: temp1
10546  REAL :: temp2
10547  REAL :: temp_ad11
10548  REAL :: temp_ad12
10549  REAL :: temp_ad13
10550  REAL :: temp_ad14
10551  REAL :: y1_ad
10552  REAL :: y2_ad
10553  REAL :: y3_ad
10554  REAL :: y4_ad
10555  REAL :: y5_ad
10556  REAL :: y6_ad
10557  REAL :: y7_ad
10558  REAL :: y8_ad
10559  REAL :: temp_ad15
10560  REAL :: temp_ad16
10561  REAL :: y19_ad
10562  REAL :: x1_ad
10563  REAL :: y9_ad
10564  REAL :: y20_ad
10565  REAL :: x2_ad
10566  REAL :: y10_ad
10567  REAL :: temp_ad17
10568  REAL :: y21_ad
10569  REAL :: x3_ad
10570  REAL :: y11_ad
10571  REAL :: y22_ad
10572  REAL :: x4_ad
10573  REAL :: y12_ad
10574  REAL :: y23_ad
10575  REAL :: x5_ad
10576  REAL :: y13_ad
10577  REAL :: y24_ad
10578  REAL :: x6_ad
10579  REAL :: y14_ad
10580  REAL :: y25_ad
10581  REAL :: x7_ad
10582  REAL :: y15_ad
10583  REAL :: y26_ad
10584  REAL :: x8_ad
10585  REAL :: y16_ad
10586  REAL :: y27_ad
10587  REAL :: x9_ad
10588  REAL :: y17_ad
10589  REAL :: y28_ad
10590  REAL :: x10_ad
10591  REAL :: y18_ad
10592  REAL :: temp_ad18
10593  REAL :: temp_ad19
10594  REAL :: temp_ad20
10595  REAL :: temp_ad21
10596  REAL :: temp_ad22
10597  INTEGER :: branch
10598  REAL :: x10
10599  REAL :: y28
10600  REAL :: y27
10601  REAL :: y26
10602  REAL :: y25
10603  REAL :: y24
10604  REAL :: y23
10605  REAL :: y22
10606  REAL :: y21
10607  REAL :: y20
10608  REAL :: x9
10609  REAL :: x8
10610  REAL :: x7
10611  REAL :: x6
10612  REAL :: x5
10613  REAL :: x4
10614  REAL :: x3
10615  REAL :: x2
10616  REAL :: x1
10617  REAL :: y19
10618  REAL :: y18
10619  REAL :: y17
10620  REAL :: y16
10621  REAL :: y15
10622  REAL :: y14
10623  REAL :: y13
10624  REAL :: y12
10625  REAL :: y11
10626  REAL :: y10
10627  REAL :: y9
10628  REAL :: y8
10629  REAL :: y7
10630  REAL :: y6
10631  REAL :: y5
10632  REAL :: y4
10633  REAL :: y3
10634  REAL :: y2
10635  REAL :: y1
10636  IF (iv .EQ. -2) THEN
10637  DO i=i1,i2
10638  gam(i, 2) = 0.5
10639  q(i, 1) = 1.5*a4(1, i, 1)
10640  END DO
10641  DO k=2,km-1
10642  DO i=i1,i2
10643  grat = delp(i, k-1)/delp(i, k)
10644  CALL pushrealarray_adm(bet)
10645  bet = 2. + grat + grat - gam(i, k)
10646  CALL pushrealarray_adm(q(i, k))
10647  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
10648  gam(i, k+1) = grat/bet
10649  END DO
10650  END DO
10651  DO i=i1,i2
10652  grat = delp(i, km-1)/delp(i, km)
10653  CALL pushrealarray_adm(q(i, km))
10654  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
10655 & 1))/(2.+grat+grat-gam(i, km))
10656  CALL pushrealarray_adm(q(i, km+1))
10657  q(i, km+1) = qs(i)
10658  END DO
10659  DO k=km-1,1,-1
10660  DO i=i1,i2
10661  CALL pushrealarray_adm(q(i, k))
10662  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
10663  END DO
10664  END DO
10665  CALL pushcontrol1b(1)
10666  ELSE
10667  DO i=i1,i2
10668 ! grid ratio
10669  grat = delp(i, 2)/delp(i, 1)
10670  bet = grat*(grat+0.5)
10671  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
10672  gam(i, 1) = (1.+grat*(grat+1.5))/bet
10673  END DO
10674  DO k=2,km
10675  DO i=i1,i2
10676  CALL pushrealarray_adm(d4(i))
10677  d4(i) = delp(i, k-1)/delp(i, k)
10678  CALL pushrealarray_adm(bet)
10679  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
10680  CALL pushrealarray_adm(q(i, k))
10681  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
10682  gam(i, k) = d4(i)/bet
10683  END DO
10684  END DO
10685  DO i=i1,i2
10686  a_bot = 1. + d4(i)*(d4(i)+1.5)
10687  CALL pushrealarray_adm(q(i, km+1))
10688  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
10689 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
10690  END DO
10691  DO k=km,1,-1
10692  DO i=i1,i2
10693  CALL pushrealarray_adm(q(i, k))
10694  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
10695  END DO
10696  END DO
10697  CALL pushcontrol1b(0)
10698  END IF
10699  IF (kord .GE. 0.) THEN
10700  abs0 = kord
10701  ELSE
10702  abs0 = -kord
10703  END IF
10704 !----- Perfectly linear scheme --------------------------------
10705  IF (abs0 .GT. 16) THEN
10706  q_ad = 0.0
10707  DO k=km,1,-1
10708  DO i=i2,i1,-1
10709  temp_ad14 = 3.*a4_ad(4, i, k)
10710  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad14
10711  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad14
10712  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad14
10713  a4_ad(4, i, k) = 0.0
10714  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
10715  a4_ad(3, i, k) = 0.0
10716  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
10717  a4_ad(2, i, k) = 0.0
10718  END DO
10719  END DO
10720  gam_ad = 0.0
10721  ELSE
10722 !----- Perfectly linear scheme --------------------------------
10723 !------------------
10724 ! Apply constraints
10725 !------------------
10726  im = i2 - i1 + 1
10727 ! Apply *large-scale* constraints
10728  DO i=i1,i2
10729  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
10730  y1 = a4(1, i, 2)
10731  CALL pushcontrol1b(0)
10732  ELSE
10733  y1 = a4(1, i, 1)
10734  CALL pushcontrol1b(1)
10735  END IF
10736  IF (q(i, 2) .GT. y1) THEN
10737  CALL pushrealarray_adm(q(i, 2))
10738  q(i, 2) = y1
10739  CALL pushcontrol1b(0)
10740  ELSE
10741  CALL pushrealarray_adm(q(i, 2))
10742  q(i, 2) = q(i, 2)
10743  CALL pushcontrol1b(1)
10744  END IF
10745  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
10746  y2 = a4(1, i, 2)
10747  CALL pushcontrol1b(0)
10748  ELSE
10749  y2 = a4(1, i, 1)
10750  CALL pushcontrol1b(1)
10751  END IF
10752  IF (q(i, 2) .LT. y2) THEN
10753  q(i, 2) = y2
10754  CALL pushcontrol1b(0)
10755  ELSE
10756  q(i, 2) = q(i, 2)
10757  CALL pushcontrol1b(1)
10758  END IF
10759  END DO
10760  DO k=2,km
10761  DO i=i1,i2
10762  CALL pushrealarray_adm(gam(i, k))
10763  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
10764  END DO
10765  END DO
10766 ! Interior:
10767  DO k=3,km-1
10768  DO i=i1,i2
10769  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
10770  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
10771  y3 = a4(1, i, k)
10772  CALL pushcontrol1b(0)
10773  ELSE
10774  y3 = a4(1, i, k-1)
10775  CALL pushcontrol1b(1)
10776  END IF
10777  IF (q(i, k) .GT. y3) THEN
10778  CALL pushrealarray_adm(q(i, k))
10779  q(i, k) = y3
10780  CALL pushcontrol1b(0)
10781  ELSE
10782  CALL pushrealarray_adm(q(i, k))
10783  q(i, k) = q(i, k)
10784  CALL pushcontrol1b(1)
10785  END IF
10786  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
10787  y4 = a4(1, i, k)
10788  CALL pushcontrol1b(0)
10789  ELSE
10790  y4 = a4(1, i, k-1)
10791  CALL pushcontrol1b(1)
10792  END IF
10793  IF (q(i, k) .LT. y4) THEN
10794  q(i, k) = y4
10795  CALL pushcontrol3b(5)
10796  ELSE
10797  q(i, k) = q(i, k)
10798  CALL pushcontrol3b(6)
10799  END IF
10800  ELSE IF (gam(i, k-1) .GT. 0.) THEN
10801  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
10802  y5 = a4(1, i, k)
10803  CALL pushcontrol1b(0)
10804  ELSE
10805  y5 = a4(1, i, k-1)
10806  CALL pushcontrol1b(1)
10807  END IF
10808  IF (q(i, k) .LT. y5) THEN
10809  CALL pushrealarray_adm(q(i, k))
10810  q(i, k) = y5
10811  CALL pushcontrol3b(3)
10812  ELSE
10813  CALL pushrealarray_adm(q(i, k))
10814  q(i, k) = q(i, k)
10815  CALL pushcontrol3b(4)
10816  END IF
10817  ELSE
10818  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
10819  y6 = a4(1, i, k)
10820  CALL pushcontrol1b(0)
10821  ELSE
10822  y6 = a4(1, i, k-1)
10823  CALL pushcontrol1b(1)
10824  END IF
10825  IF (q(i, k) .GT. y6) THEN
10826  CALL pushrealarray_adm(q(i, k))
10827  q(i, k) = y6
10828  CALL pushcontrol1b(0)
10829  ELSE
10830  CALL pushrealarray_adm(q(i, k))
10831  q(i, k) = q(i, k)
10832  CALL pushcontrol1b(1)
10833  END IF
10834  IF (iv .EQ. 0) THEN
10835  IF (0. .LT. q(i, k)) THEN
10836  CALL pushcontrol3b(0)
10837  q(i, k) = q(i, k)
10838  ELSE
10839  q(i, k) = 0.
10840  CALL pushcontrol3b(2)
10841  END IF
10842  ELSE
10843  CALL pushcontrol3b(1)
10844  END IF
10845  END IF
10846  END DO
10847  END DO
10848 ! Bottom:
10849  DO i=i1,i2
10850  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
10851  y7 = a4(1, i, km)
10852  CALL pushcontrol1b(0)
10853  ELSE
10854  y7 = a4(1, i, km-1)
10855  CALL pushcontrol1b(1)
10856  END IF
10857  IF (q(i, km) .GT. y7) THEN
10858  CALL pushrealarray_adm(q(i, km))
10859  q(i, km) = y7
10860  CALL pushcontrol1b(0)
10861  ELSE
10862  CALL pushrealarray_adm(q(i, km))
10863  q(i, km) = q(i, km)
10864  CALL pushcontrol1b(1)
10865  END IF
10866  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
10867  y8 = a4(1, i, km)
10868  CALL pushcontrol1b(0)
10869  ELSE
10870  y8 = a4(1, i, km-1)
10871  CALL pushcontrol1b(1)
10872  END IF
10873  IF (q(i, km) .LT. y8) THEN
10874  q(i, km) = y8
10875  CALL pushcontrol1b(0)
10876  ELSE
10877  q(i, km) = q(i, km)
10878  CALL pushcontrol1b(1)
10879  END IF
10880  END DO
10881  DO k=1,km
10882  DO i=i1,i2
10883  CALL pushrealarray_adm(a4(2, i, k))
10884  a4(2, i, k) = q(i, k)
10885  CALL pushrealarray_adm(a4(3, i, k))
10886  a4(3, i, k) = q(i, k+1)
10887  END DO
10888  END DO
10889  DO k=1,km
10890  IF (k .EQ. 1 .OR. k .EQ. km) THEN
10891  CALL pushcontrol1b(1)
10892  DO i=i1,i2
10893  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
10894 & , k)) .GT. 0.
10895  END DO
10896  ELSE
10897  CALL pushcontrol1b(0)
10898  DO i=i1,i2
10899  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
10900  END DO
10901  END IF
10902  END DO
10903 !---------------------------
10904 ! Apply subgrid constraints:
10905 !---------------------------
10906 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
10907 ! Top 2 and bottom 2 layers always use monotonic mapping
10908  IF (iv .EQ. 0) THEN
10909  DO i=i1,i2
10910  IF (0. .LT. a4(2, i, 1)) THEN
10911  CALL pushrealarray_adm(a4(2, i, 1))
10912  a4(2, i, 1) = a4(2, i, 1)
10913  CALL pushcontrol1b(0)
10914  ELSE
10915  CALL pushrealarray_adm(a4(2, i, 1))
10916  a4(2, i, 1) = 0.
10917  CALL pushcontrol1b(1)
10918  END IF
10919  END DO
10920  CALL pushcontrol2b(0)
10921  ELSE IF (iv .EQ. -1) THEN
10922  DO i=i1,i2
10923  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) THEN
10924  CALL pushrealarray_adm(a4(2, i, 1))
10925  a4(2, i, 1) = 0.
10926  CALL pushcontrol1b(1)
10927  ELSE
10928  CALL pushcontrol1b(0)
10929  END IF
10930  END DO
10931  CALL pushcontrol2b(1)
10932  ELSE IF (iv .EQ. 2) THEN
10933  DO i=i1,i2
10934  CALL pushrealarray_adm(a4(2, i, 1))
10935  a4(2, i, 1) = a4(1, i, 1)
10936  CALL pushrealarray_adm(a4(3, i, 1))
10937  a4(3, i, 1) = a4(1, i, 1)
10938  CALL pushrealarray_adm(a4(4, i, 1))
10939  a4(4, i, 1) = 0.
10940  END DO
10941  CALL pushcontrol2b(2)
10942  ELSE
10943  CALL pushcontrol2b(3)
10944  END IF
10945  IF (iv .NE. 2) THEN
10946  DO i=i1,i2
10947  CALL pushrealarray_adm(a4(4, i, 1))
10948  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
10949  END DO
10950  CALL cs_limiters_fwd(im, extm(i1, 1), a4(1, i1, 1), 1)
10951  CALL pushcontrol1b(1)
10952  ELSE
10953  CALL pushcontrol1b(0)
10954  END IF
10955 ! k=2
10956  DO i=i1,i2
10957  CALL pushrealarray_adm(a4(4, i, 2))
10958  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
10959  END DO
10960  CALL cs_limiters_fwd(im, extm(i1, 2), a4(1, i1, 2), 2)
10961 !-------------------------------------
10962 ! Huynh's 2nd constraint for interior:
10963 !-------------------------------------
10964  DO k=3,km-2
10965  IF (kord .GE. 0.) THEN
10966  abs1 = kord
10967  ELSE
10968  abs1 = -kord
10969  END IF
10970  IF (abs1 .LT. 9) THEN
10971  DO i=i1,i2
10972 ! Left edges
10973  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
10974  lac_1 = pmp_1 + 1.5*gam(i, k+2)
10975  IF (a4(1, i, k) .GT. pmp_1) THEN
10976  IF (pmp_1 .GT. lac_1) THEN
10977  y19 = lac_1
10978  CALL pushcontrol2b(0)
10979  ELSE
10980  y19 = pmp_1
10981  CALL pushcontrol2b(1)
10982  END IF
10983  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
10984  y19 = lac_1
10985  CALL pushcontrol2b(2)
10986  ELSE
10987  y19 = a4(1, i, k)
10988  CALL pushcontrol2b(3)
10989  END IF
10990  IF (a4(2, i, k) .LT. y19) THEN
10991  x1 = y19
10992  CALL pushcontrol1b(0)
10993  ELSE
10994  x1 = a4(2, i, k)
10995  CALL pushcontrol1b(1)
10996  END IF
10997  IF (a4(1, i, k) .LT. pmp_1) THEN
10998  IF (pmp_1 .LT. lac_1) THEN
10999  y9 = lac_1
11000  CALL pushcontrol2b(0)
11001  ELSE
11002  y9 = pmp_1
11003  CALL pushcontrol2b(1)
11004  END IF
11005  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
11006  y9 = lac_1
11007  CALL pushcontrol2b(2)
11008  ELSE
11009  y9 = a4(1, i, k)
11010  CALL pushcontrol2b(3)
11011  END IF
11012  IF (x1 .GT. y9) THEN
11013  CALL pushrealarray_adm(a4(2, i, k))
11014  a4(2, i, k) = y9
11015  CALL pushcontrol1b(0)
11016  ELSE
11017  CALL pushrealarray_adm(a4(2, i, k))
11018  a4(2, i, k) = x1
11019  CALL pushcontrol1b(1)
11020  END IF
11021 ! Right edges
11022  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
11023  lac_2 = pmp_2 - 1.5*gam(i, k-1)
11024  IF (a4(1, i, k) .GT. pmp_2) THEN
11025  IF (pmp_2 .GT. lac_2) THEN
11026  y20 = lac_2
11027  CALL pushcontrol2b(0)
11028  ELSE
11029  y20 = pmp_2
11030  CALL pushcontrol2b(1)
11031  END IF
11032  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
11033  y20 = lac_2
11034  CALL pushcontrol2b(2)
11035  ELSE
11036  y20 = a4(1, i, k)
11037  CALL pushcontrol2b(3)
11038  END IF
11039  IF (a4(3, i, k) .LT. y20) THEN
11040  x2 = y20
11041  CALL pushcontrol1b(0)
11042  ELSE
11043  x2 = a4(3, i, k)
11044  CALL pushcontrol1b(1)
11045  END IF
11046  IF (a4(1, i, k) .LT. pmp_2) THEN
11047  IF (pmp_2 .LT. lac_2) THEN
11048  y10 = lac_2
11049  CALL pushcontrol2b(0)
11050  ELSE
11051  y10 = pmp_2
11052  CALL pushcontrol2b(1)
11053  END IF
11054  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
11055  y10 = lac_2
11056  CALL pushcontrol2b(2)
11057  ELSE
11058  y10 = a4(1, i, k)
11059  CALL pushcontrol2b(3)
11060  END IF
11061  IF (x2 .GT. y10) THEN
11062  CALL pushrealarray_adm(a4(3, i, k))
11063  a4(3, i, k) = y10
11064  CALL pushcontrol1b(0)
11065  ELSE
11066  CALL pushrealarray_adm(a4(3, i, k))
11067  a4(3, i, k) = x2
11068  CALL pushcontrol1b(1)
11069  END IF
11070  CALL pushrealarray_adm(a4(4, i, k))
11071  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
11072  END DO
11073  CALL pushcontrol3b(0)
11074  ELSE
11075  IF (kord .GE. 0.) THEN
11076  abs2 = kord
11077  ELSE
11078  abs2 = -kord
11079  END IF
11080  IF (abs2 .EQ. 9) THEN
11081  DO i=i1,i2
11082  IF (extm(i, k) .AND. extm(i, k-1)) THEN
11083 ! c90_mp122
11084 ! grid-scale 2-delta-z wave detected
11085  CALL pushrealarray_adm(a4(2, i, k))
11086  a4(2, i, k) = a4(1, i, k)
11087  CALL pushrealarray_adm(a4(3, i, k))
11088  a4(3, i, k) = a4(1, i, k)
11089  CALL pushrealarray_adm(a4(4, i, k))
11090  a4(4, i, k) = 0.
11091  CALL pushcontrol2b(3)
11092  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
11093 ! c90_mp122
11094 ! grid-scale 2-delta-z wave detected
11095  CALL pushrealarray_adm(a4(2, i, k))
11096  a4(2, i, k) = a4(1, i, k)
11097  CALL pushrealarray_adm(a4(3, i, k))
11098  a4(3, i, k) = a4(1, i, k)
11099  CALL pushrealarray_adm(a4(4, i, k))
11100  a4(4, i, k) = 0.
11101  CALL pushcontrol2b(2)
11102  ELSE
11103  CALL pushrealarray_adm(a4(4, i, k))
11104  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i, &
11105 & k))
11106  IF (a4(4, i, k) .GE. 0.) THEN
11107  abs3 = a4(4, i, k)
11108  ELSE
11109  abs3 = -a4(4, i, k)
11110  END IF
11111  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
11112  abs10 = a4(2, i, k) - a4(3, i, k)
11113  ELSE
11114  abs10 = -(a4(2, i, k)-a4(3, i, k))
11115  END IF
11116 ! Check within the smooth region if subgrid profile is non-monotonic
11117  IF (abs3 .GT. abs10) THEN
11118  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
11119  lac_1 = pmp_1 + 1.5*gam(i, k+2)
11120  IF (a4(1, i, k) .GT. pmp_1) THEN
11121  IF (pmp_1 .GT. lac_1) THEN
11122  y21 = lac_1
11123  CALL pushcontrol2b(0)
11124  ELSE
11125  y21 = pmp_1
11126  CALL pushcontrol2b(1)
11127  END IF
11128  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
11129  y21 = lac_1
11130  CALL pushcontrol2b(2)
11131  ELSE
11132  y21 = a4(1, i, k)
11133  CALL pushcontrol2b(3)
11134  END IF
11135  IF (a4(2, i, k) .LT. y21) THEN
11136  x3 = y21
11137  CALL pushcontrol1b(0)
11138  ELSE
11139  x3 = a4(2, i, k)
11140  CALL pushcontrol1b(1)
11141  END IF
11142  IF (a4(1, i, k) .LT. pmp_1) THEN
11143  IF (pmp_1 .LT. lac_1) THEN
11144  y11 = lac_1
11145  CALL pushcontrol2b(0)
11146  ELSE
11147  y11 = pmp_1
11148  CALL pushcontrol2b(1)
11149  END IF
11150  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
11151  y11 = lac_1
11152  CALL pushcontrol2b(2)
11153  ELSE
11154  y11 = a4(1, i, k)
11155  CALL pushcontrol2b(3)
11156  END IF
11157  IF (x3 .GT. y11) THEN
11158  CALL pushrealarray_adm(a4(2, i, k))
11159  a4(2, i, k) = y11
11160  CALL pushcontrol1b(0)
11161  ELSE
11162  CALL pushrealarray_adm(a4(2, i, k))
11163  a4(2, i, k) = x3
11164  CALL pushcontrol1b(1)
11165  END IF
11166  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
11167  lac_2 = pmp_2 - 1.5*gam(i, k-1)
11168  IF (a4(1, i, k) .GT. pmp_2) THEN
11169  IF (pmp_2 .GT. lac_2) THEN
11170  y22 = lac_2
11171  CALL pushcontrol2b(0)
11172  ELSE
11173  y22 = pmp_2
11174  CALL pushcontrol2b(1)
11175  END IF
11176  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
11177  y22 = lac_2
11178  CALL pushcontrol2b(2)
11179  ELSE
11180  y22 = a4(1, i, k)
11181  CALL pushcontrol2b(3)
11182  END IF
11183  IF (a4(3, i, k) .LT. y22) THEN
11184  x4 = y22
11185  CALL pushcontrol1b(0)
11186  ELSE
11187  x4 = a4(3, i, k)
11188  CALL pushcontrol1b(1)
11189  END IF
11190  IF (a4(1, i, k) .LT. pmp_2) THEN
11191  IF (pmp_2 .LT. lac_2) THEN
11192  y12 = lac_2
11193  CALL pushcontrol2b(0)
11194  ELSE
11195  y12 = pmp_2
11196  CALL pushcontrol2b(1)
11197  END IF
11198  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
11199  y12 = lac_2
11200  CALL pushcontrol2b(2)
11201  ELSE
11202  y12 = a4(1, i, k)
11203  CALL pushcontrol2b(3)
11204  END IF
11205  IF (x4 .GT. y12) THEN
11206  CALL pushrealarray_adm(a4(3, i, k))
11207  a4(3, i, k) = y12
11208  CALL pushcontrol1b(0)
11209  ELSE
11210  CALL pushrealarray_adm(a4(3, i, k))
11211  a4(3, i, k) = x4
11212  CALL pushcontrol1b(1)
11213  END IF
11214  CALL pushrealarray_adm(a4(4, i, k))
11215  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
11216 & , k))
11217  CALL pushcontrol2b(1)
11218  ELSE
11219  CALL pushcontrol2b(0)
11220  END IF
11221  END IF
11222  END DO
11223  CALL pushcontrol3b(1)
11224  ELSE
11225  IF (kord .GE. 0.) THEN
11226  abs4 = kord
11227  ELSE
11228  abs4 = -kord
11229  END IF
11230  IF (abs4 .EQ. 10) THEN
11231  DO i=i1,i2
11232  IF (extm(i, k)) THEN
11233  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
11234 ! grid-scale 2-delta-z wave detected
11235  CALL pushrealarray_adm(a4(2, i, k))
11236  a4(2, i, k) = a4(1, i, k)
11237  CALL pushrealarray_adm(a4(3, i, k))
11238  a4(3, i, k) = a4(1, i, k)
11239  CALL pushrealarray_adm(a4(4, i, k))
11240  a4(4, i, k) = 0.
11241  CALL pushcontrol2b(3)
11242  ELSE
11243 ! True local extremum
11244  CALL pushrealarray_adm(a4(4, i, k))
11245  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
11246 & , i, k))
11247  CALL pushcontrol2b(2)
11248  END IF
11249  ELSE
11250 ! not a local extremum
11251  CALL pushrealarray_adm(a4(4, i, k))
11252  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
11253 & , k))
11254  IF (a4(4, i, k) .GE. 0.) THEN
11255  abs5 = a4(4, i, k)
11256  ELSE
11257  abs5 = -a4(4, i, k)
11258  END IF
11259  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
11260  abs11 = a4(2, i, k) - a4(3, i, k)
11261  ELSE
11262  abs11 = -(a4(2, i, k)-a4(3, i, k))
11263  END IF
11264 ! Check within the smooth region if subgrid profile is non-monotonic
11265  IF (abs5 .GT. abs11) THEN
11266  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
11267  lac_1 = pmp_1 + 1.5*gam(i, k+2)
11268  IF (a4(1, i, k) .GT. pmp_1) THEN
11269  IF (pmp_1 .GT. lac_1) THEN
11270  y23 = lac_1
11271  CALL pushcontrol2b(0)
11272  ELSE
11273  y23 = pmp_1
11274  CALL pushcontrol2b(1)
11275  END IF
11276  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
11277  y23 = lac_1
11278  CALL pushcontrol2b(2)
11279  ELSE
11280  y23 = a4(1, i, k)
11281  CALL pushcontrol2b(3)
11282  END IF
11283  IF (a4(2, i, k) .LT. y23) THEN
11284  x5 = y23
11285  CALL pushcontrol1b(0)
11286  ELSE
11287  x5 = a4(2, i, k)
11288  CALL pushcontrol1b(1)
11289  END IF
11290  IF (a4(1, i, k) .LT. pmp_1) THEN
11291  IF (pmp_1 .LT. lac_1) THEN
11292  y13 = lac_1
11293  CALL pushcontrol2b(0)
11294  ELSE
11295  y13 = pmp_1
11296  CALL pushcontrol2b(1)
11297  END IF
11298  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
11299  y13 = lac_1
11300  CALL pushcontrol2b(2)
11301  ELSE
11302  y13 = a4(1, i, k)
11303  CALL pushcontrol2b(3)
11304  END IF
11305  IF (x5 .GT. y13) THEN
11306  CALL pushrealarray_adm(a4(2, i, k))
11307  a4(2, i, k) = y13
11308  CALL pushcontrol1b(0)
11309  ELSE
11310  CALL pushrealarray_adm(a4(2, i, k))
11311  a4(2, i, k) = x5
11312  CALL pushcontrol1b(1)
11313  END IF
11314  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
11315  lac_2 = pmp_2 - 1.5*gam(i, k-1)
11316  IF (a4(1, i, k) .GT. pmp_2) THEN
11317  IF (pmp_2 .GT. lac_2) THEN
11318  y24 = lac_2
11319  CALL pushcontrol2b(0)
11320  ELSE
11321  y24 = pmp_2
11322  CALL pushcontrol2b(1)
11323  END IF
11324  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
11325  y24 = lac_2
11326  CALL pushcontrol2b(2)
11327  ELSE
11328  y24 = a4(1, i, k)
11329  CALL pushcontrol2b(3)
11330  END IF
11331  IF (a4(3, i, k) .LT. y24) THEN
11332  x6 = y24
11333  CALL pushcontrol1b(0)
11334  ELSE
11335  x6 = a4(3, i, k)
11336  CALL pushcontrol1b(1)
11337  END IF
11338  IF (a4(1, i, k) .LT. pmp_2) THEN
11339  IF (pmp_2 .LT. lac_2) THEN
11340  y14 = lac_2
11341  CALL pushcontrol2b(0)
11342  ELSE
11343  y14 = pmp_2
11344  CALL pushcontrol2b(1)
11345  END IF
11346  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
11347  y14 = lac_2
11348  CALL pushcontrol2b(2)
11349  ELSE
11350  y14 = a4(1, i, k)
11351  CALL pushcontrol2b(3)
11352  END IF
11353  IF (x6 .GT. y14) THEN
11354  CALL pushrealarray_adm(a4(3, i, k))
11355  a4(3, i, k) = y14
11356  CALL pushcontrol1b(0)
11357  ELSE
11358  CALL pushrealarray_adm(a4(3, i, k))
11359  a4(3, i, k) = x6
11360  CALL pushcontrol1b(1)
11361  END IF
11362  CALL pushrealarray_adm(a4(4, i, k))
11363  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
11364 & , i, k))
11365  CALL pushcontrol2b(1)
11366  ELSE
11367  CALL pushcontrol2b(0)
11368  END IF
11369  END IF
11370  END DO
11371  CALL pushcontrol3b(2)
11372  ELSE
11373  IF (kord .GE. 0.) THEN
11374  abs6 = kord
11375  ELSE
11376  abs6 = -kord
11377  END IF
11378  IF (abs6 .EQ. 12) THEN
11379  DO i=i1,i2
11380  IF (extm(i, k)) THEN
11381 ! grid-scale 2-delta-z wave detected
11382  CALL pushrealarray_adm(a4(2, i, k))
11383  a4(2, i, k) = a4(1, i, k)
11384  CALL pushrealarray_adm(a4(3, i, k))
11385  a4(3, i, k) = a4(1, i, k)
11386  CALL pushrealarray_adm(a4(4, i, k))
11387  a4(4, i, k) = 0.
11388  CALL pushcontrol2b(2)
11389  ELSE
11390 ! not a local extremum
11391  CALL pushrealarray_adm(a4(4, i, k))
11392  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
11393 & , i, k))
11394  IF (a4(4, i, k) .GE. 0.) THEN
11395  abs7 = a4(4, i, k)
11396  ELSE
11397  abs7 = -a4(4, i, k)
11398  END IF
11399  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
11400  abs12 = a4(2, i, k) - a4(3, i, k)
11401  ELSE
11402  abs12 = -(a4(2, i, k)-a4(3, i, k))
11403  END IF
11404 ! Check within the smooth region if subgrid profile is non-monotonic
11405  IF (abs7 .GT. abs12) THEN
11406  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
11407  lac_1 = pmp_1 + 1.5*gam(i, k+2)
11408  IF (a4(1, i, k) .GT. pmp_1) THEN
11409  IF (pmp_1 .GT. lac_1) THEN
11410  y25 = lac_1
11411  CALL pushcontrol2b(0)
11412  ELSE
11413  y25 = pmp_1
11414  CALL pushcontrol2b(1)
11415  END IF
11416  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
11417  y25 = lac_1
11418  CALL pushcontrol2b(2)
11419  ELSE
11420  y25 = a4(1, i, k)
11421  CALL pushcontrol2b(3)
11422  END IF
11423  IF (a4(2, i, k) .LT. y25) THEN
11424  x7 = y25
11425  CALL pushcontrol1b(0)
11426  ELSE
11427  x7 = a4(2, i, k)
11428  CALL pushcontrol1b(1)
11429  END IF
11430  IF (a4(1, i, k) .LT. pmp_1) THEN
11431  IF (pmp_1 .LT. lac_1) THEN
11432  y15 = lac_1
11433  CALL pushcontrol2b(0)
11434  ELSE
11435  y15 = pmp_1
11436  CALL pushcontrol2b(1)
11437  END IF
11438  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
11439  y15 = lac_1
11440  CALL pushcontrol2b(2)
11441  ELSE
11442  y15 = a4(1, i, k)
11443  CALL pushcontrol2b(3)
11444  END IF
11445  IF (x7 .GT. y15) THEN
11446  CALL pushrealarray_adm(a4(2, i, k))
11447  a4(2, i, k) = y15
11448  CALL pushcontrol1b(0)
11449  ELSE
11450  CALL pushrealarray_adm(a4(2, i, k))
11451  a4(2, i, k) = x7
11452  CALL pushcontrol1b(1)
11453  END IF
11454  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
11455  lac_2 = pmp_2 - 1.5*gam(i, k-1)
11456  IF (a4(1, i, k) .GT. pmp_2) THEN
11457  IF (pmp_2 .GT. lac_2) THEN
11458  y26 = lac_2
11459  CALL pushcontrol2b(0)
11460  ELSE
11461  y26 = pmp_2
11462  CALL pushcontrol2b(1)
11463  END IF
11464  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
11465  y26 = lac_2
11466  CALL pushcontrol2b(2)
11467  ELSE
11468  y26 = a4(1, i, k)
11469  CALL pushcontrol2b(3)
11470  END IF
11471  IF (a4(3, i, k) .LT. y26) THEN
11472  x8 = y26
11473  CALL pushcontrol1b(0)
11474  ELSE
11475  x8 = a4(3, i, k)
11476  CALL pushcontrol1b(1)
11477  END IF
11478  IF (a4(1, i, k) .LT. pmp_2) THEN
11479  IF (pmp_2 .LT. lac_2) THEN
11480  y16 = lac_2
11481  CALL pushcontrol2b(0)
11482  ELSE
11483  y16 = pmp_2
11484  CALL pushcontrol2b(1)
11485  END IF
11486  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
11487  y16 = lac_2
11488  CALL pushcontrol2b(2)
11489  ELSE
11490  y16 = a4(1, i, k)
11491  CALL pushcontrol2b(3)
11492  END IF
11493  IF (x8 .GT. y16) THEN
11494  CALL pushrealarray_adm(a4(3, i, k))
11495  a4(3, i, k) = y16
11496  CALL pushcontrol1b(0)
11497  ELSE
11498  CALL pushrealarray_adm(a4(3, i, k))
11499  a4(3, i, k) = x8
11500  CALL pushcontrol1b(1)
11501  END IF
11502  CALL pushrealarray_adm(a4(4, i, k))
11503  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
11504 & 3, i, k))
11505  CALL pushcontrol2b(1)
11506  ELSE
11507  CALL pushcontrol2b(0)
11508  END IF
11509  END IF
11510  END DO
11511  CALL pushcontrol3b(3)
11512  ELSE
11513  IF (kord .GE. 0.) THEN
11514  abs8 = kord
11515  ELSE
11516  abs8 = -kord
11517  END IF
11518  IF (abs8 .EQ. 13) THEN
11519  DO i=i1,i2
11520  IF (extm(i, k)) THEN
11521  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
11522 ! grid-scale 2-delta-z wave detected
11523  CALL pushrealarray_adm(a4(2, i, k))
11524  a4(2, i, k) = a4(1, i, k)
11525  CALL pushrealarray_adm(a4(3, i, k))
11526  a4(3, i, k) = a4(1, i, k)
11527  CALL pushrealarray_adm(a4(4, i, k))
11528  a4(4, i, k) = 0.
11529  CALL pushcontrol2b(2)
11530  ELSE
11531 ! Left edges
11532  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
11533  lac_1 = pmp_1 + 1.5*gam(i, k+2)
11534  IF (a4(1, i, k) .GT. pmp_1) THEN
11535  IF (pmp_1 .GT. lac_1) THEN
11536  y27 = lac_1
11537  CALL pushcontrol2b(0)
11538  ELSE
11539  y27 = pmp_1
11540  CALL pushcontrol2b(1)
11541  END IF
11542  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
11543  y27 = lac_1
11544  CALL pushcontrol2b(2)
11545  ELSE
11546  y27 = a4(1, i, k)
11547  CALL pushcontrol2b(3)
11548  END IF
11549  IF (a4(2, i, k) .LT. y27) THEN
11550  x9 = y27
11551  CALL pushcontrol1b(0)
11552  ELSE
11553  x9 = a4(2, i, k)
11554  CALL pushcontrol1b(1)
11555  END IF
11556  IF (a4(1, i, k) .LT. pmp_1) THEN
11557  IF (pmp_1 .LT. lac_1) THEN
11558  y17 = lac_1
11559  CALL pushcontrol2b(0)
11560  ELSE
11561  y17 = pmp_1
11562  CALL pushcontrol2b(1)
11563  END IF
11564  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
11565  y17 = lac_1
11566  CALL pushcontrol2b(2)
11567  ELSE
11568  y17 = a4(1, i, k)
11569  CALL pushcontrol2b(3)
11570  END IF
11571  IF (x9 .GT. y17) THEN
11572  CALL pushrealarray_adm(a4(2, i, k))
11573  a4(2, i, k) = y17
11574  CALL pushcontrol1b(0)
11575  ELSE
11576  CALL pushrealarray_adm(a4(2, i, k))
11577  a4(2, i, k) = x9
11578  CALL pushcontrol1b(1)
11579  END IF
11580 ! Right edges
11581  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
11582  lac_2 = pmp_2 - 1.5*gam(i, k-1)
11583  IF (a4(1, i, k) .GT. pmp_2) THEN
11584  IF (pmp_2 .GT. lac_2) THEN
11585  y28 = lac_2
11586  CALL pushcontrol2b(0)
11587  ELSE
11588  y28 = pmp_2
11589  CALL pushcontrol2b(1)
11590  END IF
11591  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
11592  y28 = lac_2
11593  CALL pushcontrol2b(2)
11594  ELSE
11595  y28 = a4(1, i, k)
11596  CALL pushcontrol2b(3)
11597  END IF
11598  IF (a4(3, i, k) .LT. y28) THEN
11599  x10 = y28
11600  CALL pushcontrol1b(0)
11601  ELSE
11602  x10 = a4(3, i, k)
11603  CALL pushcontrol1b(1)
11604  END IF
11605  IF (a4(1, i, k) .LT. pmp_2) THEN
11606  IF (pmp_2 .LT. lac_2) THEN
11607  y18 = lac_2
11608  CALL pushcontrol2b(0)
11609  ELSE
11610  y18 = pmp_2
11611  CALL pushcontrol2b(1)
11612  END IF
11613  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
11614  y18 = lac_2
11615  CALL pushcontrol2b(2)
11616  ELSE
11617  y18 = a4(1, i, k)
11618  CALL pushcontrol2b(3)
11619  END IF
11620  IF (x10 .GT. y18) THEN
11621  CALL pushrealarray_adm(a4(3, i, k))
11622  a4(3, i, k) = y18
11623  CALL pushcontrol1b(0)
11624  ELSE
11625  CALL pushrealarray_adm(a4(3, i, k))
11626  a4(3, i, k) = x10
11627  CALL pushcontrol1b(1)
11628  END IF
11629  CALL pushrealarray_adm(a4(4, i, k))
11630  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
11631 & (3, i, k)))
11632  CALL pushcontrol2b(1)
11633  END IF
11634  ELSE
11635  CALL pushrealarray_adm(a4(4, i, k))
11636  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
11637 & , i, k)))
11638  CALL pushcontrol2b(0)
11639  END IF
11640  END DO
11641  CALL pushcontrol3b(4)
11642  ELSE
11643  IF (kord .GE. 0.) THEN
11644  abs9 = kord
11645  ELSE
11646  abs9 = -kord
11647  END IF
11648  IF (abs9 .EQ. 14) THEN
11649  DO i=i1,i2
11650  CALL pushrealarray_adm(a4(4, i, k))
11651  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
11652 & , i, k)))
11653  END DO
11654  CALL pushcontrol3b(5)
11655  ELSE
11656 ! kord = 11
11657  DO i=i1,i2
11658  IF (extm(i, k) .AND. (extm(i, k-1) .OR. extm(i, k+&
11659 & 1))) THEN
11660 ! Noisy region:
11661  CALL pushrealarray_adm(a4(2, i, k))
11662  a4(2, i, k) = a4(1, i, k)
11663  CALL pushrealarray_adm(a4(3, i, k))
11664  a4(3, i, k) = a4(1, i, k)
11665  CALL pushrealarray_adm(a4(4, i, k))
11666  a4(4, i, k) = 0.
11667  CALL pushcontrol1b(1)
11668  ELSE
11669  CALL pushrealarray_adm(a4(4, i, k))
11670  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
11671 & (3, i, k)))
11672  CALL pushcontrol1b(0)
11673  END IF
11674  END DO
11675  CALL pushcontrol3b(6)
11676  END IF
11677  END IF
11678  END IF
11679  END IF
11680  END IF
11681  END IF
11682 ! Additional constraint to ensure positivity
11683  IF (iv .EQ. 0) THEN
11684  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 0)
11685  CALL pushcontrol1b(1)
11686  ELSE
11687  CALL pushcontrol1b(0)
11688  END IF
11689  END DO
11690 ! k-loop
11691 !----------------------------------
11692 ! Bottom layer subgrid constraints:
11693 !----------------------------------
11694  IF (iv .EQ. 0) THEN
11695  DO i=i1,i2
11696  IF (0. .LT. a4(3, i, km)) THEN
11697  CALL pushrealarray_adm(a4(3, i, km))
11698  a4(3, i, km) = a4(3, i, km)
11699  CALL pushcontrol1b(0)
11700  ELSE
11701  CALL pushrealarray_adm(a4(3, i, km))
11702  a4(3, i, km) = 0.
11703  CALL pushcontrol1b(1)
11704  END IF
11705  END DO
11706  CALL pushcontrol2b(2)
11707  ELSE IF (iv .EQ. -1) THEN
11708  DO i=i1,i2
11709  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) THEN
11710  CALL pushrealarray_adm(a4(3, i, km))
11711  a4(3, i, km) = 0.
11712  CALL pushcontrol1b(1)
11713  ELSE
11714  CALL pushcontrol1b(0)
11715  END IF
11716  END DO
11717  CALL pushcontrol2b(1)
11718  ELSE
11719  CALL pushcontrol2b(0)
11720  END IF
11721  DO k=km-1,km
11722  DO i=i1,i2
11723  CALL pushrealarray_adm(a4(4, i, k))
11724  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
11725  END DO
11726  IF (k .EQ. km - 1) THEN
11727  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 2)
11728  CALL pushcontrol1b(0)
11729  ELSE
11730  CALL pushcontrol1b(1)
11731  END IF
11732  IF (k .EQ. km) THEN
11733  CALL cs_limiters_fwd(im, extm(i1, k), a4(1, i1, k), 1)
11734  CALL pushcontrol1b(1)
11735  ELSE
11736  CALL pushcontrol1b(0)
11737  END IF
11738  END DO
11739  DO k=km,km-1,-1
11740  CALL popcontrol1b(branch)
11741  IF (branch .NE. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
11742 & i1, k), a4_ad(1, i1, k), 1)
11743  CALL popcontrol1b(branch)
11744  IF (branch .EQ. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
11745 & i1, k), a4_ad(1, i1, k), 2)
11746  DO i=i2,i1,-1
11747  CALL poprealarray_adm(a4(4, i, k))
11748  temp_ad22 = 3.*a4_ad(4, i, k)
11749  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad22
11750  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad22
11751  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad22
11752  a4_ad(4, i, k) = 0.0
11753  END DO
11754  END DO
11755  CALL popcontrol2b(branch)
11756  IF (branch .NE. 0) THEN
11757  IF (branch .EQ. 1) THEN
11758  DO i=i2,i1,-1
11759  CALL popcontrol1b(branch)
11760  IF (branch .NE. 0) THEN
11761  CALL poprealarray_adm(a4(3, i, km))
11762  a4_ad(3, i, km) = 0.0
11763  END IF
11764  END DO
11765  ELSE
11766  DO i=i2,i1,-1
11767  CALL popcontrol1b(branch)
11768  IF (branch .EQ. 0) THEN
11769  CALL poprealarray_adm(a4(3, i, km))
11770  ELSE
11771  CALL poprealarray_adm(a4(3, i, km))
11772  a4_ad(3, i, km) = 0.0
11773  END IF
11774  END DO
11775  END IF
11776  END IF
11777  gam_ad = 0.0
11778  DO k=km-2,3,-1
11779  CALL popcontrol1b(branch)
11780  IF (branch .NE. 0) CALL cs_limiters_bwd(im, extm(i1, k), a4(1, &
11781 & i1, k), a4_ad(1, i1, k), 0)
11782  CALL popcontrol3b(branch)
11783  IF (branch .LT. 3) THEN
11784  IF (branch .EQ. 0) THEN
11785  DO i=i2,i1,-1
11786  CALL poprealarray_adm(a4(4, i, k))
11787  temp_ad17 = 3.*a4_ad(4, i, k)
11788  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad17
11789  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad17
11790  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad17
11791  a4_ad(4, i, k) = 0.0
11792  CALL popcontrol1b(branch)
11793  IF (branch .EQ. 0) THEN
11794  CALL poprealarray_adm(a4(3, i, k))
11795  y10_ad = a4_ad(3, i, k)
11796  a4_ad(3, i, k) = 0.0
11797  x2_ad = 0.0
11798  ELSE
11799  CALL poprealarray_adm(a4(3, i, k))
11800  x2_ad = a4_ad(3, i, k)
11801  a4_ad(3, i, k) = 0.0
11802  y10_ad = 0.0
11803  END IF
11804  CALL popcontrol2b(branch)
11805  IF (branch .LT. 2) THEN
11806  IF (branch .EQ. 0) THEN
11807  lac_2_ad = y10_ad
11808  pmp_2_ad = 0.0
11809  ELSE
11810  pmp_2_ad = y10_ad
11811  lac_2_ad = 0.0
11812  END IF
11813  ELSE
11814  IF (branch .EQ. 2) THEN
11815  lac_2_ad = y10_ad
11816  ELSE
11817  a4_ad(1, i, k) = a4_ad(1, i, k) + y10_ad
11818  lac_2_ad = 0.0
11819  END IF
11820  pmp_2_ad = 0.0
11821  END IF
11822  CALL popcontrol1b(branch)
11823  IF (branch .EQ. 0) THEN
11824  y20_ad = x2_ad
11825  ELSE
11826  a4_ad(3, i, k) = a4_ad(3, i, k) + x2_ad
11827  y20_ad = 0.0
11828  END IF
11829  CALL popcontrol2b(branch)
11830  IF (branch .LT. 2) THEN
11831  IF (branch .EQ. 0) THEN
11832  lac_2_ad = lac_2_ad + y20_ad
11833  ELSE
11834  pmp_2_ad = pmp_2_ad + y20_ad
11835  END IF
11836  ELSE IF (branch .EQ. 2) THEN
11837  lac_2_ad = lac_2_ad + y20_ad
11838  ELSE
11839  a4_ad(1, i, k) = a4_ad(1, i, k) + y20_ad
11840  END IF
11841  pmp_2_ad = pmp_2_ad + lac_2_ad
11842  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
11843  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
11844  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
11845  CALL popcontrol1b(branch)
11846  IF (branch .EQ. 0) THEN
11847  CALL poprealarray_adm(a4(2, i, k))
11848  y9_ad = a4_ad(2, i, k)
11849  a4_ad(2, i, k) = 0.0
11850  x1_ad = 0.0
11851  ELSE
11852  CALL poprealarray_adm(a4(2, i, k))
11853  x1_ad = a4_ad(2, i, k)
11854  a4_ad(2, i, k) = 0.0
11855  y9_ad = 0.0
11856  END IF
11857  CALL popcontrol2b(branch)
11858  IF (branch .LT. 2) THEN
11859  IF (branch .EQ. 0) THEN
11860  lac_1_ad = y9_ad
11861  pmp_1_ad = 0.0
11862  ELSE
11863  pmp_1_ad = y9_ad
11864  lac_1_ad = 0.0
11865  END IF
11866  ELSE
11867  IF (branch .EQ. 2) THEN
11868  lac_1_ad = y9_ad
11869  ELSE
11870  a4_ad(1, i, k) = a4_ad(1, i, k) + y9_ad
11871  lac_1_ad = 0.0
11872  END IF
11873  pmp_1_ad = 0.0
11874  END IF
11875  CALL popcontrol1b(branch)
11876  IF (branch .EQ. 0) THEN
11877  y19_ad = x1_ad
11878  ELSE
11879  a4_ad(2, i, k) = a4_ad(2, i, k) + x1_ad
11880  y19_ad = 0.0
11881  END IF
11882  CALL popcontrol2b(branch)
11883  IF (branch .LT. 2) THEN
11884  IF (branch .EQ. 0) THEN
11885  lac_1_ad = lac_1_ad + y19_ad
11886  ELSE
11887  pmp_1_ad = pmp_1_ad + y19_ad
11888  END IF
11889  ELSE IF (branch .EQ. 2) THEN
11890  lac_1_ad = lac_1_ad + y19_ad
11891  ELSE
11892  a4_ad(1, i, k) = a4_ad(1, i, k) + y19_ad
11893  END IF
11894  pmp_1_ad = pmp_1_ad + lac_1_ad
11895  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
11896  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
11897  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
11898  END DO
11899  ELSE IF (branch .EQ. 1) THEN
11900  DO i=i2,i1,-1
11901  CALL popcontrol2b(branch)
11902  IF (branch .LT. 2) THEN
11903  IF (branch .NE. 0) THEN
11904  CALL poprealarray_adm(a4(4, i, k))
11905  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
11906  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
11907  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
11908  a4_ad(4, i, k) = 0.0
11909  CALL popcontrol1b(branch)
11910  IF (branch .EQ. 0) THEN
11911  CALL poprealarray_adm(a4(3, i, k))
11912  y12_ad = a4_ad(3, i, k)
11913  a4_ad(3, i, k) = 0.0
11914  x4_ad = 0.0
11915  ELSE
11916  CALL poprealarray_adm(a4(3, i, k))
11917  x4_ad = a4_ad(3, i, k)
11918  a4_ad(3, i, k) = 0.0
11919  y12_ad = 0.0
11920  END IF
11921  CALL popcontrol2b(branch)
11922  IF (branch .LT. 2) THEN
11923  IF (branch .EQ. 0) THEN
11924  lac_2_ad = y12_ad
11925  pmp_2_ad = 0.0
11926  ELSE
11927  pmp_2_ad = y12_ad
11928  lac_2_ad = 0.0
11929  END IF
11930  ELSE
11931  IF (branch .EQ. 2) THEN
11932  lac_2_ad = y12_ad
11933  ELSE
11934  a4_ad(1, i, k) = a4_ad(1, i, k) + y12_ad
11935  lac_2_ad = 0.0
11936  END IF
11937  pmp_2_ad = 0.0
11938  END IF
11939  CALL popcontrol1b(branch)
11940  IF (branch .EQ. 0) THEN
11941  y22_ad = x4_ad
11942  ELSE
11943  a4_ad(3, i, k) = a4_ad(3, i, k) + x4_ad
11944  y22_ad = 0.0
11945  END IF
11946  CALL popcontrol2b(branch)
11947  IF (branch .LT. 2) THEN
11948  IF (branch .EQ. 0) THEN
11949  lac_2_ad = lac_2_ad + y22_ad
11950  ELSE
11951  pmp_2_ad = pmp_2_ad + y22_ad
11952  END IF
11953  ELSE IF (branch .EQ. 2) THEN
11954  lac_2_ad = lac_2_ad + y22_ad
11955  ELSE
11956  a4_ad(1, i, k) = a4_ad(1, i, k) + y22_ad
11957  END IF
11958  pmp_2_ad = pmp_2_ad + lac_2_ad
11959  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
11960  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
11961  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
11962  CALL popcontrol1b(branch)
11963  IF (branch .EQ. 0) THEN
11964  CALL poprealarray_adm(a4(2, i, k))
11965  y11_ad = a4_ad(2, i, k)
11966  a4_ad(2, i, k) = 0.0
11967  x3_ad = 0.0
11968  ELSE
11969  CALL poprealarray_adm(a4(2, i, k))
11970  x3_ad = a4_ad(2, i, k)
11971  a4_ad(2, i, k) = 0.0
11972  y11_ad = 0.0
11973  END IF
11974  CALL popcontrol2b(branch)
11975  IF (branch .LT. 2) THEN
11976  IF (branch .EQ. 0) THEN
11977  lac_1_ad = y11_ad
11978  pmp_1_ad = 0.0
11979  ELSE
11980  pmp_1_ad = y11_ad
11981  lac_1_ad = 0.0
11982  END IF
11983  ELSE
11984  IF (branch .EQ. 2) THEN
11985  lac_1_ad = y11_ad
11986  ELSE
11987  a4_ad(1, i, k) = a4_ad(1, i, k) + y11_ad
11988  lac_1_ad = 0.0
11989  END IF
11990  pmp_1_ad = 0.0
11991  END IF
11992  CALL popcontrol1b(branch)
11993  IF (branch .EQ. 0) THEN
11994  y21_ad = x3_ad
11995  ELSE
11996  a4_ad(2, i, k) = a4_ad(2, i, k) + x3_ad
11997  y21_ad = 0.0
11998  END IF
11999  CALL popcontrol2b(branch)
12000  IF (branch .LT. 2) THEN
12001  IF (branch .EQ. 0) THEN
12002  lac_1_ad = lac_1_ad + y21_ad
12003  ELSE
12004  pmp_1_ad = pmp_1_ad + y21_ad
12005  END IF
12006  ELSE IF (branch .EQ. 2) THEN
12007  lac_1_ad = lac_1_ad + y21_ad
12008  ELSE
12009  a4_ad(1, i, k) = a4_ad(1, i, k) + y21_ad
12010  END IF
12011  pmp_1_ad = pmp_1_ad + lac_1_ad
12012  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
12013  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
12014  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
12015  END IF
12016  CALL poprealarray_adm(a4(4, i, k))
12017  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12018  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12019  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12020  a4_ad(4, i, k) = 0.0
12021  ELSE IF (branch .EQ. 2) THEN
12022  CALL poprealarray_adm(a4(4, i, k))
12023  a4_ad(4, i, k) = 0.0
12024  CALL poprealarray_adm(a4(3, i, k))
12025  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12026  a4_ad(3, i, k) = 0.0
12027  CALL poprealarray_adm(a4(2, i, k))
12028  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12029  a4_ad(2, i, k) = 0.0
12030  ELSE
12031  CALL poprealarray_adm(a4(4, i, k))
12032  a4_ad(4, i, k) = 0.0
12033  CALL poprealarray_adm(a4(3, i, k))
12034  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12035  a4_ad(3, i, k) = 0.0
12036  CALL poprealarray_adm(a4(2, i, k))
12037  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12038  a4_ad(2, i, k) = 0.0
12039  END IF
12040  END DO
12041  ELSE
12042  DO i=i2,i1,-1
12043  CALL popcontrol2b(branch)
12044  IF (branch .LT. 2) THEN
12045  IF (branch .NE. 0) THEN
12046  CALL poprealarray_adm(a4(4, i, k))
12047  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12048  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12049  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12050  a4_ad(4, i, k) = 0.0
12051  CALL popcontrol1b(branch)
12052  IF (branch .EQ. 0) THEN
12053  CALL poprealarray_adm(a4(3, i, k))
12054  y14_ad = a4_ad(3, i, k)
12055  a4_ad(3, i, k) = 0.0
12056  x6_ad = 0.0
12057  ELSE
12058  CALL poprealarray_adm(a4(3, i, k))
12059  x6_ad = a4_ad(3, i, k)
12060  a4_ad(3, i, k) = 0.0
12061  y14_ad = 0.0
12062  END IF
12063  CALL popcontrol2b(branch)
12064  IF (branch .LT. 2) THEN
12065  IF (branch .EQ. 0) THEN
12066  lac_2_ad = y14_ad
12067  pmp_2_ad = 0.0
12068  ELSE
12069  pmp_2_ad = y14_ad
12070  lac_2_ad = 0.0
12071  END IF
12072  ELSE
12073  IF (branch .EQ. 2) THEN
12074  lac_2_ad = y14_ad
12075  ELSE
12076  a4_ad(1, i, k) = a4_ad(1, i, k) + y14_ad
12077  lac_2_ad = 0.0
12078  END IF
12079  pmp_2_ad = 0.0
12080  END IF
12081  CALL popcontrol1b(branch)
12082  IF (branch .EQ. 0) THEN
12083  y24_ad = x6_ad
12084  ELSE
12085  a4_ad(3, i, k) = a4_ad(3, i, k) + x6_ad
12086  y24_ad = 0.0
12087  END IF
12088  CALL popcontrol2b(branch)
12089  IF (branch .LT. 2) THEN
12090  IF (branch .EQ. 0) THEN
12091  lac_2_ad = lac_2_ad + y24_ad
12092  ELSE
12093  pmp_2_ad = pmp_2_ad + y24_ad
12094  END IF
12095  ELSE IF (branch .EQ. 2) THEN
12096  lac_2_ad = lac_2_ad + y24_ad
12097  ELSE
12098  a4_ad(1, i, k) = a4_ad(1, i, k) + y24_ad
12099  END IF
12100  pmp_2_ad = pmp_2_ad + lac_2_ad
12101  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
12102  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
12103  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
12104  CALL popcontrol1b(branch)
12105  IF (branch .EQ. 0) THEN
12106  CALL poprealarray_adm(a4(2, i, k))
12107  y13_ad = a4_ad(2, i, k)
12108  a4_ad(2, i, k) = 0.0
12109  x5_ad = 0.0
12110  ELSE
12111  CALL poprealarray_adm(a4(2, i, k))
12112  x5_ad = a4_ad(2, i, k)
12113  a4_ad(2, i, k) = 0.0
12114  y13_ad = 0.0
12115  END IF
12116  CALL popcontrol2b(branch)
12117  IF (branch .LT. 2) THEN
12118  IF (branch .EQ. 0) THEN
12119  lac_1_ad = y13_ad
12120  pmp_1_ad = 0.0
12121  ELSE
12122  pmp_1_ad = y13_ad
12123  lac_1_ad = 0.0
12124  END IF
12125  ELSE
12126  IF (branch .EQ. 2) THEN
12127  lac_1_ad = y13_ad
12128  ELSE
12129  a4_ad(1, i, k) = a4_ad(1, i, k) + y13_ad
12130  lac_1_ad = 0.0
12131  END IF
12132  pmp_1_ad = 0.0
12133  END IF
12134  CALL popcontrol1b(branch)
12135  IF (branch .EQ. 0) THEN
12136  y23_ad = x5_ad
12137  ELSE
12138  a4_ad(2, i, k) = a4_ad(2, i, k) + x5_ad
12139  y23_ad = 0.0
12140  END IF
12141  CALL popcontrol2b(branch)
12142  IF (branch .LT. 2) THEN
12143  IF (branch .EQ. 0) THEN
12144  lac_1_ad = lac_1_ad + y23_ad
12145  ELSE
12146  pmp_1_ad = pmp_1_ad + y23_ad
12147  END IF
12148  ELSE IF (branch .EQ. 2) THEN
12149  lac_1_ad = lac_1_ad + y23_ad
12150  ELSE
12151  a4_ad(1, i, k) = a4_ad(1, i, k) + y23_ad
12152  END IF
12153  pmp_1_ad = pmp_1_ad + lac_1_ad
12154  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
12155  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
12156  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
12157  END IF
12158  CALL poprealarray_adm(a4(4, i, k))
12159  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12160  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12161  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12162  a4_ad(4, i, k) = 0.0
12163  ELSE IF (branch .EQ. 2) THEN
12164  CALL poprealarray_adm(a4(4, i, k))
12165  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12166  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12167  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12168  a4_ad(4, i, k) = 0.0
12169  ELSE
12170  CALL poprealarray_adm(a4(4, i, k))
12171  a4_ad(4, i, k) = 0.0
12172  CALL poprealarray_adm(a4(3, i, k))
12173  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12174  a4_ad(3, i, k) = 0.0
12175  CALL poprealarray_adm(a4(2, i, k))
12176  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12177  a4_ad(2, i, k) = 0.0
12178  END IF
12179  END DO
12180  END IF
12181  ELSE IF (branch .LT. 5) THEN
12182  IF (branch .EQ. 3) THEN
12183  DO 100 i=i2,i1,-1
12184  CALL popcontrol2b(branch)
12185  IF (branch .NE. 0) THEN
12186  IF (branch .EQ. 1) THEN
12187  CALL poprealarray_adm(a4(4, i, k))
12188  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12189  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12190  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12191  a4_ad(4, i, k) = 0.0
12192  CALL popcontrol1b(branch)
12193  IF (branch .EQ. 0) THEN
12194  CALL poprealarray_adm(a4(3, i, k))
12195  y16_ad = a4_ad(3, i, k)
12196  a4_ad(3, i, k) = 0.0
12197  x8_ad = 0.0
12198  ELSE
12199  CALL poprealarray_adm(a4(3, i, k))
12200  x8_ad = a4_ad(3, i, k)
12201  a4_ad(3, i, k) = 0.0
12202  y16_ad = 0.0
12203  END IF
12204  CALL popcontrol2b(branch)
12205  IF (branch .LT. 2) THEN
12206  IF (branch .EQ. 0) THEN
12207  lac_2_ad = y16_ad
12208  pmp_2_ad = 0.0
12209  ELSE
12210  pmp_2_ad = y16_ad
12211  lac_2_ad = 0.0
12212  END IF
12213  ELSE
12214  IF (branch .EQ. 2) THEN
12215  lac_2_ad = y16_ad
12216  ELSE
12217  a4_ad(1, i, k) = a4_ad(1, i, k) + y16_ad
12218  lac_2_ad = 0.0
12219  END IF
12220  pmp_2_ad = 0.0
12221  END IF
12222  CALL popcontrol1b(branch)
12223  IF (branch .EQ. 0) THEN
12224  y26_ad = x8_ad
12225  ELSE
12226  a4_ad(3, i, k) = a4_ad(3, i, k) + x8_ad
12227  y26_ad = 0.0
12228  END IF
12229  CALL popcontrol2b(branch)
12230  IF (branch .LT. 2) THEN
12231  IF (branch .EQ. 0) THEN
12232  lac_2_ad = lac_2_ad + y26_ad
12233  ELSE
12234  pmp_2_ad = pmp_2_ad + y26_ad
12235  END IF
12236  ELSE IF (branch .EQ. 2) THEN
12237  lac_2_ad = lac_2_ad + y26_ad
12238  ELSE
12239  a4_ad(1, i, k) = a4_ad(1, i, k) + y26_ad
12240  END IF
12241  pmp_2_ad = pmp_2_ad + lac_2_ad
12242  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
12243  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
12244  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
12245  CALL popcontrol1b(branch)
12246  IF (branch .EQ. 0) THEN
12247  CALL poprealarray_adm(a4(2, i, k))
12248  y15_ad = a4_ad(2, i, k)
12249  a4_ad(2, i, k) = 0.0
12250  x7_ad = 0.0
12251  ELSE
12252  CALL poprealarray_adm(a4(2, i, k))
12253  x7_ad = a4_ad(2, i, k)
12254  a4_ad(2, i, k) = 0.0
12255  y15_ad = 0.0
12256  END IF
12257  CALL popcontrol2b(branch)
12258  IF (branch .LT. 2) THEN
12259  IF (branch .EQ. 0) THEN
12260  lac_1_ad = y15_ad
12261  pmp_1_ad = 0.0
12262  ELSE
12263  pmp_1_ad = y15_ad
12264  lac_1_ad = 0.0
12265  END IF
12266  ELSE
12267  IF (branch .EQ. 2) THEN
12268  lac_1_ad = y15_ad
12269  ELSE
12270  a4_ad(1, i, k) = a4_ad(1, i, k) + y15_ad
12271  lac_1_ad = 0.0
12272  END IF
12273  pmp_1_ad = 0.0
12274  END IF
12275  CALL popcontrol1b(branch)
12276  IF (branch .EQ. 0) THEN
12277  y25_ad = x7_ad
12278  ELSE
12279  a4_ad(2, i, k) = a4_ad(2, i, k) + x7_ad
12280  y25_ad = 0.0
12281  END IF
12282  CALL popcontrol2b(branch)
12283  IF (branch .LT. 2) THEN
12284  IF (branch .EQ. 0) THEN
12285  lac_1_ad = lac_1_ad + y25_ad
12286  ELSE
12287  pmp_1_ad = pmp_1_ad + y25_ad
12288  END IF
12289  ELSE IF (branch .EQ. 2) THEN
12290  lac_1_ad = lac_1_ad + y25_ad
12291  ELSE
12292  a4_ad(1, i, k) = a4_ad(1, i, k) + y25_ad
12293  END IF
12294  pmp_1_ad = pmp_1_ad + lac_1_ad
12295  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
12296  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
12297  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
12298  ELSE
12299  CALL poprealarray_adm(a4(4, i, k))
12300  a4_ad(4, i, k) = 0.0
12301  CALL poprealarray_adm(a4(3, i, k))
12302  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12303  a4_ad(3, i, k) = 0.0
12304  CALL poprealarray_adm(a4(2, i, k))
12305  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12306  a4_ad(2, i, k) = 0.0
12307  GOTO 100
12308  END IF
12309  END IF
12310  CALL poprealarray_adm(a4(4, i, k))
12311  a4_ad(1, i, k) = a4_ad(1, i, k) + 6.*a4_ad(4, i, k)
12312  a4_ad(2, i, k) = a4_ad(2, i, k) - 3.*a4_ad(4, i, k)
12313  a4_ad(3, i, k) = a4_ad(3, i, k) - 3.*a4_ad(4, i, k)
12314  a4_ad(4, i, k) = 0.0
12315  100 CONTINUE
12316  ELSE
12317  DO i=i2,i1,-1
12318  CALL popcontrol2b(branch)
12319  IF (branch .EQ. 0) THEN
12320  CALL poprealarray_adm(a4(4, i, k))
12321  temp_ad19 = 3.*a4_ad(4, i, k)
12322  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad19
12323  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad19
12324  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad19
12325  a4_ad(4, i, k) = 0.0
12326  ELSE IF (branch .EQ. 1) THEN
12327  CALL poprealarray_adm(a4(4, i, k))
12328  temp_ad18 = 3.*a4_ad(4, i, k)
12329  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad18
12330  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad18
12331  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad18
12332  a4_ad(4, i, k) = 0.0
12333  CALL popcontrol1b(branch)
12334  IF (branch .EQ. 0) THEN
12335  CALL poprealarray_adm(a4(3, i, k))
12336  y18_ad = a4_ad(3, i, k)
12337  a4_ad(3, i, k) = 0.0
12338  x10_ad = 0.0
12339  ELSE
12340  CALL poprealarray_adm(a4(3, i, k))
12341  x10_ad = a4_ad(3, i, k)
12342  a4_ad(3, i, k) = 0.0
12343  y18_ad = 0.0
12344  END IF
12345  CALL popcontrol2b(branch)
12346  IF (branch .LT. 2) THEN
12347  IF (branch .EQ. 0) THEN
12348  lac_2_ad = y18_ad
12349  pmp_2_ad = 0.0
12350  ELSE
12351  pmp_2_ad = y18_ad
12352  lac_2_ad = 0.0
12353  END IF
12354  ELSE
12355  IF (branch .EQ. 2) THEN
12356  lac_2_ad = y18_ad
12357  ELSE
12358  a4_ad(1, i, k) = a4_ad(1, i, k) + y18_ad
12359  lac_2_ad = 0.0
12360  END IF
12361  pmp_2_ad = 0.0
12362  END IF
12363  CALL popcontrol1b(branch)
12364  IF (branch .EQ. 0) THEN
12365  y28_ad = x10_ad
12366  ELSE
12367  a4_ad(3, i, k) = a4_ad(3, i, k) + x10_ad
12368  y28_ad = 0.0
12369  END IF
12370  CALL popcontrol2b(branch)
12371  IF (branch .LT. 2) THEN
12372  IF (branch .EQ. 0) THEN
12373  lac_2_ad = lac_2_ad + y28_ad
12374  ELSE
12375  pmp_2_ad = pmp_2_ad + y28_ad
12376  END IF
12377  ELSE IF (branch .EQ. 2) THEN
12378  lac_2_ad = lac_2_ad + y28_ad
12379  ELSE
12380  a4_ad(1, i, k) = a4_ad(1, i, k) + y28_ad
12381  END IF
12382  pmp_2_ad = pmp_2_ad + lac_2_ad
12383  gam_ad(i, k-1) = gam_ad(i, k-1) - 1.5*lac_2_ad
12384  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_2_ad
12385  gam_ad(i, k) = gam_ad(i, k) + 2.*pmp_2_ad
12386  CALL popcontrol1b(branch)
12387  IF (branch .EQ. 0) THEN
12388  CALL poprealarray_adm(a4(2, i, k))
12389  y17_ad = a4_ad(2, i, k)
12390  a4_ad(2, i, k) = 0.0
12391  x9_ad = 0.0
12392  ELSE
12393  CALL poprealarray_adm(a4(2, i, k))
12394  x9_ad = a4_ad(2, i, k)
12395  a4_ad(2, i, k) = 0.0
12396  y17_ad = 0.0
12397  END IF
12398  CALL popcontrol2b(branch)
12399  IF (branch .LT. 2) THEN
12400  IF (branch .EQ. 0) THEN
12401  lac_1_ad = y17_ad
12402  pmp_1_ad = 0.0
12403  ELSE
12404  pmp_1_ad = y17_ad
12405  lac_1_ad = 0.0
12406  END IF
12407  ELSE
12408  IF (branch .EQ. 2) THEN
12409  lac_1_ad = y17_ad
12410  ELSE
12411  a4_ad(1, i, k) = a4_ad(1, i, k) + y17_ad
12412  lac_1_ad = 0.0
12413  END IF
12414  pmp_1_ad = 0.0
12415  END IF
12416  CALL popcontrol1b(branch)
12417  IF (branch .EQ. 0) THEN
12418  y27_ad = x9_ad
12419  ELSE
12420  a4_ad(2, i, k) = a4_ad(2, i, k) + x9_ad
12421  y27_ad = 0.0
12422  END IF
12423  CALL popcontrol2b(branch)
12424  IF (branch .LT. 2) THEN
12425  IF (branch .EQ. 0) THEN
12426  lac_1_ad = lac_1_ad + y27_ad
12427  ELSE
12428  pmp_1_ad = pmp_1_ad + y27_ad
12429  END IF
12430  ELSE IF (branch .EQ. 2) THEN
12431  lac_1_ad = lac_1_ad + y27_ad
12432  ELSE
12433  a4_ad(1, i, k) = a4_ad(1, i, k) + y27_ad
12434  END IF
12435  pmp_1_ad = pmp_1_ad + lac_1_ad
12436  gam_ad(i, k+2) = gam_ad(i, k+2) + 1.5*lac_1_ad
12437  a4_ad(1, i, k) = a4_ad(1, i, k) + pmp_1_ad
12438  gam_ad(i, k+1) = gam_ad(i, k+1) - 2.*pmp_1_ad
12439  ELSE
12440  CALL poprealarray_adm(a4(4, i, k))
12441  a4_ad(4, i, k) = 0.0
12442  CALL poprealarray_adm(a4(3, i, k))
12443  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12444  a4_ad(3, i, k) = 0.0
12445  CALL poprealarray_adm(a4(2, i, k))
12446  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12447  a4_ad(2, i, k) = 0.0
12448  END IF
12449  END DO
12450  END IF
12451  ELSE IF (branch .EQ. 5) THEN
12452  DO i=i2,i1,-1
12453  CALL poprealarray_adm(a4(4, i, k))
12454  temp_ad20 = 3.*a4_ad(4, i, k)
12455  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad20
12456  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad20
12457  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad20
12458  a4_ad(4, i, k) = 0.0
12459  END DO
12460  ELSE
12461  DO i=i2,i1,-1
12462  CALL popcontrol1b(branch)
12463  IF (branch .EQ. 0) THEN
12464  CALL poprealarray_adm(a4(4, i, k))
12465  temp_ad21 = 3.*a4_ad(4, i, k)
12466  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad21
12467  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad21
12468  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad21
12469  a4_ad(4, i, k) = 0.0
12470  ELSE
12471  CALL poprealarray_adm(a4(4, i, k))
12472  a4_ad(4, i, k) = 0.0
12473  CALL poprealarray_adm(a4(3, i, k))
12474  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(3, i, k)
12475  a4_ad(3, i, k) = 0.0
12476  CALL poprealarray_adm(a4(2, i, k))
12477  a4_ad(1, i, k) = a4_ad(1, i, k) + a4_ad(2, i, k)
12478  a4_ad(2, i, k) = 0.0
12479  END IF
12480  END DO
12481  END IF
12482  END DO
12483  CALL cs_limiters_bwd(im, extm(i1, 2), a4(1, i1, 2), a4_ad(1, i1, 2&
12484 & ), 2)
12485  DO i=i2,i1,-1
12486  CALL poprealarray_adm(a4(4, i, 2))
12487  temp_ad16 = 3.*a4_ad(4, i, 2)
12488  a4_ad(1, i, 2) = a4_ad(1, i, 2) + 2.*temp_ad16
12489  a4_ad(2, i, 2) = a4_ad(2, i, 2) - temp_ad16
12490  a4_ad(3, i, 2) = a4_ad(3, i, 2) - temp_ad16
12491  a4_ad(4, i, 2) = 0.0
12492  END DO
12493  CALL popcontrol1b(branch)
12494  IF (branch .NE. 0) THEN
12495  CALL cs_limiters_bwd(im, extm(i1, 1), a4(1, i1, 1), a4_ad(1, i1&
12496 & , 1), 1)
12497  DO i=i2,i1,-1
12498  CALL poprealarray_adm(a4(4, i, 1))
12499  temp_ad15 = 3.*a4_ad(4, i, 1)
12500  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 2.*temp_ad15
12501  a4_ad(2, i, 1) = a4_ad(2, i, 1) - temp_ad15
12502  a4_ad(3, i, 1) = a4_ad(3, i, 1) - temp_ad15
12503  a4_ad(4, i, 1) = 0.0
12504  END DO
12505  END IF
12506  CALL popcontrol2b(branch)
12507  IF (branch .LT. 2) THEN
12508  IF (branch .EQ. 0) THEN
12509  DO i=i2,i1,-1
12510  CALL popcontrol1b(branch)
12511  IF (branch .EQ. 0) THEN
12512  CALL poprealarray_adm(a4(2, i, 1))
12513  ELSE
12514  CALL poprealarray_adm(a4(2, i, 1))
12515  a4_ad(2, i, 1) = 0.0
12516  END IF
12517  END DO
12518  ELSE
12519  DO i=i2,i1,-1
12520  CALL popcontrol1b(branch)
12521  IF (branch .NE. 0) THEN
12522  CALL poprealarray_adm(a4(2, i, 1))
12523  a4_ad(2, i, 1) = 0.0
12524  END IF
12525  END DO
12526  END IF
12527  ELSE IF (branch .EQ. 2) THEN
12528  DO i=i2,i1,-1
12529  CALL poprealarray_adm(a4(4, i, 1))
12530  a4_ad(4, i, 1) = 0.0
12531  CALL poprealarray_adm(a4(3, i, 1))
12532  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(3, i, 1)
12533  a4_ad(3, i, 1) = 0.0
12534  CALL poprealarray_adm(a4(2, i, 1))
12535  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(2, i, 1)
12536  a4_ad(2, i, 1) = 0.0
12537  END DO
12538  END IF
12539  DO k=km,1,-1
12540  CALL popcontrol1b(branch)
12541  END DO
12542  q_ad = 0.0
12543  DO k=km,1,-1
12544  DO i=i2,i1,-1
12545  CALL poprealarray_adm(a4(3, i, k))
12546  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
12547  a4_ad(3, i, k) = 0.0
12548  CALL poprealarray_adm(a4(2, i, k))
12549  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
12550  a4_ad(2, i, k) = 0.0
12551  END DO
12552  END DO
12553  DO i=i2,i1,-1
12554  CALL popcontrol1b(branch)
12555  IF (branch .EQ. 0) THEN
12556  y8_ad = q_ad(i, km)
12557  q_ad(i, km) = 0.0
12558  ELSE
12559  y8_ad = 0.0
12560  END IF
12561  CALL popcontrol1b(branch)
12562  IF (branch .EQ. 0) THEN
12563  a4_ad(1, i, km) = a4_ad(1, i, km) + y8_ad
12564  ELSE
12565  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + y8_ad
12566  END IF
12567  CALL popcontrol1b(branch)
12568  IF (branch .EQ. 0) THEN
12569  CALL poprealarray_adm(q(i, km))
12570  y7_ad = q_ad(i, km)
12571  q_ad(i, km) = 0.0
12572  ELSE
12573  CALL poprealarray_adm(q(i, km))
12574  y7_ad = 0.0
12575  END IF
12576  CALL popcontrol1b(branch)
12577  IF (branch .EQ. 0) THEN
12578  a4_ad(1, i, km) = a4_ad(1, i, km) + y7_ad
12579  ELSE
12580  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + y7_ad
12581  END IF
12582  END DO
12583  DO k=km-1,3,-1
12584  DO 120 i=i2,i1,-1
12585  CALL popcontrol3b(branch)
12586  IF (branch .NE. 0) THEN
12587  IF (branch .LT. 4) THEN
12588  IF (branch .EQ. 1) THEN
12589  GOTO 110
12590  ELSE IF (branch .EQ. 2) THEN
12591  q_ad(i, k) = 0.0
12592  GOTO 110
12593  ELSE
12594  CALL poprealarray_adm(q(i, k))
12595  y5_ad = q_ad(i, k)
12596  q_ad(i, k) = 0.0
12597  END IF
12598  ELSE IF (branch .EQ. 4) THEN
12599  CALL poprealarray_adm(q(i, k))
12600  y5_ad = 0.0
12601  ELSE
12602  IF (branch .EQ. 5) THEN
12603  y4_ad = q_ad(i, k)
12604  q_ad(i, k) = 0.0
12605  ELSE
12606  y4_ad = 0.0
12607  END IF
12608  CALL popcontrol1b(branch)
12609  IF (branch .EQ. 0) THEN
12610  a4_ad(1, i, k) = a4_ad(1, i, k) + y4_ad
12611  ELSE
12612  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y4_ad
12613  END IF
12614  CALL popcontrol1b(branch)
12615  IF (branch .EQ. 0) THEN
12616  CALL poprealarray_adm(q(i, k))
12617  y3_ad = q_ad(i, k)
12618  q_ad(i, k) = 0.0
12619  ELSE
12620  CALL poprealarray_adm(q(i, k))
12621  y3_ad = 0.0
12622  END IF
12623  CALL popcontrol1b(branch)
12624  IF (branch .EQ. 0) THEN
12625  a4_ad(1, i, k) = a4_ad(1, i, k) + y3_ad
12626  ELSE
12627  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y3_ad
12628  END IF
12629  GOTO 120
12630  END IF
12631  CALL popcontrol1b(branch)
12632  IF (branch .EQ. 0) THEN
12633  a4_ad(1, i, k) = a4_ad(1, i, k) + y5_ad
12634  ELSE
12635  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y5_ad
12636  END IF
12637  GOTO 120
12638  END IF
12639  110 CALL popcontrol1b(branch)
12640  IF (branch .EQ. 0) THEN
12641  CALL poprealarray_adm(q(i, k))
12642  y6_ad = q_ad(i, k)
12643  q_ad(i, k) = 0.0
12644  ELSE
12645  CALL poprealarray_adm(q(i, k))
12646  y6_ad = 0.0
12647  END IF
12648  CALL popcontrol1b(branch)
12649  IF (branch .EQ. 0) THEN
12650  a4_ad(1, i, k) = a4_ad(1, i, k) + y6_ad
12651  ELSE
12652  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + y6_ad
12653  END IF
12654  120 CONTINUE
12655  END DO
12656  DO k=km,2,-1
12657  DO i=i2,i1,-1
12658  CALL poprealarray_adm(gam(i, k))
12659  a4_ad(1, i, k) = a4_ad(1, i, k) + gam_ad(i, k)
12660  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) - gam_ad(i, k)
12661  gam_ad(i, k) = 0.0
12662  END DO
12663  END DO
12664  DO i=i2,i1,-1
12665  CALL popcontrol1b(branch)
12666  IF (branch .EQ. 0) THEN
12667  y2_ad = q_ad(i, 2)
12668  q_ad(i, 2) = 0.0
12669  ELSE
12670  y2_ad = 0.0
12671  END IF
12672  CALL popcontrol1b(branch)
12673  IF (branch .EQ. 0) THEN
12674  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y2_ad
12675  ELSE
12676  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y2_ad
12677  END IF
12678  CALL popcontrol1b(branch)
12679  IF (branch .EQ. 0) THEN
12680  CALL poprealarray_adm(q(i, 2))
12681  y1_ad = q_ad(i, 2)
12682  q_ad(i, 2) = 0.0
12683  ELSE
12684  CALL poprealarray_adm(q(i, 2))
12685  y1_ad = 0.0
12686  END IF
12687  CALL popcontrol1b(branch)
12688  IF (branch .EQ. 0) THEN
12689  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y1_ad
12690  ELSE
12691  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y1_ad
12692  END IF
12693  END DO
12694  END IF
12695  CALL popcontrol1b(branch)
12696  IF (branch .EQ. 0) THEN
12697  DO k=1,km,1
12698  DO i=i2,i1,-1
12699  CALL poprealarray_adm(q(i, k))
12700  gam_ad(i, k) = gam_ad(i, k) - q(i, k+1)*q_ad(i, k)
12701  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k)*q_ad(i, k)
12702  END DO
12703  END DO
12704  d4_ad = 0.0
12705  DO i=i2,i1,-1
12706  a_bot = 1. + d4(i)*(d4(i)+1.5)
12707  CALL poprealarray_adm(q(i, km+1))
12708  temp2 = d4(i)*(d4(i)+0.5) - a_bot*gam(i, km)
12709  temp_ad11 = q_ad(i, km+1)/temp2
12710  temp1 = d4(i)*(d4(i)+1.)
12711  temp_ad12 = 2.*a4(1, i, km)*temp_ad11
12712  temp_ad13 = -((2.*(temp1*a4(1, i, km))+a4(1, i, km-1)-a_bot*q(i&
12713 & , km))*temp_ad11/temp2)
12714  a4_ad(1, i, km) = a4_ad(1, i, km) + 2.*temp1*temp_ad11
12715  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + temp_ad11
12716  a_bot_ad = -(gam(i, km)*temp_ad13) - q(i, km)*temp_ad11
12717  d4_ad(i) = d4_ad(i) + (2*d4(i)+1.5)*a_bot_ad + (2*d4(i)+0.5)*&
12718 & temp_ad13 + (2*d4(i)+1.)*temp_ad12
12719  q_ad(i, km) = q_ad(i, km) - a_bot*temp_ad11
12720  gam_ad(i, km) = gam_ad(i, km) - a_bot*temp_ad13
12721  q_ad(i, km+1) = 0.0
12722  END DO
12723  DO k=km,2,-1
12724  DO i=i2,i1,-1
12725  temp_ad9 = q_ad(i, k)/bet
12726  temp_ad8 = 3.*temp_ad9
12727  CALL poprealarray_adm(q(i, k))
12728  bet_ad = -((3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))*&
12729 & temp_ad9/bet) - d4(i)*gam_ad(i, k)/bet**2
12730  d4_ad(i) = d4_ad(i) + a4(1, i, k)*temp_ad8 + 2*bet_ad + gam_ad&
12731 & (i, k)/bet
12732  gam_ad(i, k) = 0.0
12733  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + temp_ad8
12734  a4_ad(1, i, k) = a4_ad(1, i, k) + d4(i)*temp_ad8
12735  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad9
12736  q_ad(i, k) = 0.0
12737  CALL poprealarray_adm(bet)
12738  gam_ad(i, k-1) = gam_ad(i, k-1) - bet_ad
12739  CALL poprealarray_adm(d4(i))
12740  temp_ad10 = d4_ad(i)/delp(i, k)
12741  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad10
12742  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad10/delp(i&
12743 & , k)
12744  d4_ad(i) = 0.0
12745  END DO
12746  END DO
12747  DO i=i2,i1,-1
12748  grat = delp(i, 2)/delp(i, 1)
12749  bet = grat*(grat+0.5)
12750  temp_ad4 = gam_ad(i, 1)/bet
12751  gam_ad(i, 1) = 0.0
12752  temp_ad6 = q_ad(i, 1)/bet
12753  temp_ad5 = a4(1, i, 1)*temp_ad6
12754  temp0 = 2*grat*(grat+1.)
12755  bet_ad = -((temp0*a4(1, i, 1)+a4(1, i, 2))*temp_ad6/bet) - (grat&
12756 & *(grat+1.5)+1.)*temp_ad4/bet
12757  grat_ad = (4*grat+2*1.)*temp_ad5 + (2*grat+0.5)*bet_ad + (2*grat&
12758 & +1.5)*temp_ad4
12759  a4_ad(1, i, 1) = a4_ad(1, i, 1) + temp0*temp_ad6
12760  a4_ad(1, i, 2) = a4_ad(1, i, 2) + temp_ad6
12761  q_ad(i, 1) = 0.0
12762  temp_ad7 = grat_ad/delp(i, 1)
12763  delp_ad(i, 2) = delp_ad(i, 2) + temp_ad7
12764  delp_ad(i, 1) = delp_ad(i, 1) - delp(i, 2)*temp_ad7/delp(i, 1)
12765  END DO
12766  ELSE
12767  DO k=1,km-1,1
12768  DO i=i2,i1,-1
12769  CALL poprealarray_adm(q(i, k))
12770  gam_ad(i, k+1) = gam_ad(i, k+1) - q(i, k+1)*q_ad(i, k)
12771  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k+1)*q_ad(i, k)
12772  END DO
12773  END DO
12774  DO i=i2,i1,-1
12775  CALL poprealarray_adm(q(i, km+1))
12776  qs_ad(i) = qs_ad(i) + q_ad(i, km+1)
12777  q_ad(i, km+1) = 0.0
12778  grat = delp(i, km-1)/delp(i, km)
12779  CALL poprealarray_adm(q(i, km))
12780  temp = 2*grat - gam(i, km) + 2.
12781  temp_ad1 = q_ad(i, km)/temp
12782  temp_ad2 = -((3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, &
12783 & km-1))*temp_ad1/temp)
12784  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + 3.*temp_ad1
12785  a4_ad(1, i, km) = a4_ad(1, i, km) + 3.*temp_ad1
12786  grat_ad = 2*temp_ad2 - qs(i)*temp_ad1
12787  qs_ad(i) = qs_ad(i) - grat*temp_ad1
12788  q_ad(i, km-1) = q_ad(i, km-1) - temp_ad1
12789  gam_ad(i, km) = gam_ad(i, km) - temp_ad2
12790  q_ad(i, km) = 0.0
12791  temp_ad3 = grat_ad/delp(i, km)
12792  delp_ad(i, km-1) = delp_ad(i, km-1) + temp_ad3
12793  delp_ad(i, km) = delp_ad(i, km) - delp(i, km-1)*temp_ad3/delp(i&
12794 & , km)
12795  END DO
12796  DO k=km-1,2,-1
12797  DO i=i2,i1,-1
12798  temp_ad = q_ad(i, k)/bet
12799  CALL poprealarray_adm(q(i, k))
12800  grat = delp(i, k-1)/delp(i, k)
12801  bet_ad = -((3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*temp_ad/&
12802 & bet) - grat*gam_ad(i, k+1)/bet**2
12803  grat_ad = 2*bet_ad + gam_ad(i, k+1)/bet
12804  gam_ad(i, k+1) = 0.0
12805  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + 3.*temp_ad
12806  a4_ad(1, i, k) = a4_ad(1, i, k) + 3.*temp_ad
12807  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad
12808  q_ad(i, k) = 0.0
12809  CALL poprealarray_adm(bet)
12810  gam_ad(i, k) = gam_ad(i, k) - bet_ad
12811  temp_ad0 = grat_ad/delp(i, k)
12812  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad0
12813  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad0/delp(i, &
12814 & k)
12815  END DO
12816  END DO
12817  DO i=i2,i1,-1
12818  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 1.5*q_ad(i, 1)
12819  q_ad(i, 1) = 0.0
12820  END DO
12821  END IF
12822  END SUBROUTINE cs_profile_adm
12823  SUBROUTINE cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
12824  IMPLICIT NONE
12825 ! Optimized vertical profile reconstruction:
12826 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
12827  INTEGER, INTENT(IN) :: i1, i2
12828 ! vertical dimension
12829  INTEGER, INTENT(IN) :: km
12830 ! iv =-1: winds
12831  INTEGER, INTENT(IN) :: iv
12832 ! iv = 0: positive definite scalars
12833 ! iv = 1: others
12834  INTEGER, INTENT(IN) :: kord
12835  REAL, INTENT(IN) :: qs(i1:i2)
12836 ! layer pressure thickness
12837  REAL, INTENT(IN) :: delp(i1:i2, km)
12838 ! Interpolated values
12839  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
12840 !-----------------------------------------------------------------------
12841  LOGICAL :: extm(i1:i2, km)
12842  REAL :: gam(i1:i2, km)
12843  REAL :: q(i1:i2, km+1)
12844  REAL :: d4(i1:i2)
12845  REAL :: bet, a_bot, grat
12846  REAL :: pmp_1, lac_1, pmp_2, lac_2
12847  INTEGER :: i, k, im
12848  INTRINSIC abs
12849  INTRINSIC max
12850  INTRINSIC min
12851  INTEGER :: abs0
12852  INTEGER :: abs1
12853  INTEGER :: abs2
12854  REAL :: abs3
12855  INTEGER :: abs4
12856  REAL :: abs5
12857  INTEGER :: abs6
12858  REAL :: abs7
12859  INTEGER :: abs8
12860  INTEGER :: abs9
12861  REAL :: abs10
12862  REAL :: abs11
12863  REAL :: abs12
12864  REAL :: x10
12865  REAL :: y28
12866  REAL :: y27
12867  REAL :: y26
12868  REAL :: y25
12869  REAL :: y24
12870  REAL :: y23
12871  REAL :: y22
12872  REAL :: y21
12873  REAL :: y20
12874  REAL :: x9
12875  REAL :: x8
12876  REAL :: x7
12877  REAL :: x6
12878  REAL :: x5
12879  REAL :: x4
12880  REAL :: x3
12881  REAL :: x2
12882  REAL :: x1
12883  REAL :: y19
12884  REAL :: y18
12885  REAL :: y17
12886  REAL :: y16
12887  REAL :: y15
12888  REAL :: y14
12889  REAL :: y13
12890  REAL :: y12
12891  REAL :: y11
12892  REAL :: y10
12893  REAL :: y9
12894  REAL :: y8
12895  REAL :: y7
12896  REAL :: y6
12897  REAL :: y5
12898  REAL :: y4
12899  REAL :: y3
12900  REAL :: y2
12901  REAL :: y1
12902  IF (iv .EQ. -2) THEN
12903  DO i=i1,i2
12904  gam(i, 2) = 0.5
12905  q(i, 1) = 1.5*a4(1, i, 1)
12906  END DO
12907  DO k=2,km-1
12908  DO i=i1,i2
12909  grat = delp(i, k-1)/delp(i, k)
12910  bet = 2. + grat + grat - gam(i, k)
12911  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
12912  gam(i, k+1) = grat/bet
12913  END DO
12914  END DO
12915  DO i=i1,i2
12916  grat = delp(i, km-1)/delp(i, km)
12917  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
12918 & 1))/(2.+grat+grat-gam(i, km))
12919  q(i, km+1) = qs(i)
12920  END DO
12921  DO k=km-1,1,-1
12922  DO i=i1,i2
12923  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
12924  END DO
12925  END DO
12926  ELSE
12927  DO i=i1,i2
12928 ! grid ratio
12929  grat = delp(i, 2)/delp(i, 1)
12930  bet = grat*(grat+0.5)
12931  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
12932  gam(i, 1) = (1.+grat*(grat+1.5))/bet
12933  END DO
12934  DO k=2,km
12935  DO i=i1,i2
12936  d4(i) = delp(i, k-1)/delp(i, k)
12937  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
12938  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
12939  gam(i, k) = d4(i)/bet
12940  END DO
12941  END DO
12942  DO i=i1,i2
12943  a_bot = 1. + d4(i)*(d4(i)+1.5)
12944  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
12945 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
12946  END DO
12947  DO k=km,1,-1
12948  DO i=i1,i2
12949  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
12950  END DO
12951  END DO
12952  END IF
12953  IF (kord .GE. 0.) THEN
12954  abs0 = kord
12955  ELSE
12956  abs0 = -kord
12957  END IF
12958 !----- Perfectly linear scheme --------------------------------
12959  IF (abs0 .GT. 16) THEN
12960  DO k=1,km
12961  DO i=i1,i2
12962  a4(2, i, k) = q(i, k)
12963  a4(3, i, k) = q(i, k+1)
12964  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
12965  END DO
12966  END DO
12967  RETURN
12968  ELSE
12969 !----- Perfectly linear scheme --------------------------------
12970 !------------------
12971 ! Apply constraints
12972 !------------------
12973  im = i2 - i1 + 1
12974 ! Apply *large-scale* constraints
12975  DO i=i1,i2
12976  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
12977  y1 = a4(1, i, 2)
12978  ELSE
12979  y1 = a4(1, i, 1)
12980  END IF
12981  IF (q(i, 2) .GT. y1) THEN
12982  q(i, 2) = y1
12983  ELSE
12984  q(i, 2) = q(i, 2)
12985  END IF
12986  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
12987  y2 = a4(1, i, 2)
12988  ELSE
12989  y2 = a4(1, i, 1)
12990  END IF
12991  IF (q(i, 2) .LT. y2) THEN
12992  q(i, 2) = y2
12993  ELSE
12994  q(i, 2) = q(i, 2)
12995  END IF
12996  END DO
12997  DO k=2,km
12998  DO i=i1,i2
12999  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
13000  END DO
13001  END DO
13002 ! Interior:
13003  DO k=3,km-1
13004  DO i=i1,i2
13005  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
13006  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
13007  y3 = a4(1, i, k)
13008  ELSE
13009  y3 = a4(1, i, k-1)
13010  END IF
13011  IF (q(i, k) .GT. y3) THEN
13012  q(i, k) = y3
13013  ELSE
13014  q(i, k) = q(i, k)
13015  END IF
13016  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
13017  y4 = a4(1, i, k)
13018  ELSE
13019  y4 = a4(1, i, k-1)
13020  END IF
13021  IF (q(i, k) .LT. y4) THEN
13022  q(i, k) = y4
13023  ELSE
13024  q(i, k) = q(i, k)
13025  END IF
13026  ELSE IF (gam(i, k-1) .GT. 0.) THEN
13027  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
13028  y5 = a4(1, i, k)
13029  ELSE
13030  y5 = a4(1, i, k-1)
13031  END IF
13032  IF (q(i, k) .LT. y5) THEN
13033  q(i, k) = y5
13034  ELSE
13035  q(i, k) = q(i, k)
13036  END IF
13037  ELSE
13038  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
13039  y6 = a4(1, i, k)
13040  ELSE
13041  y6 = a4(1, i, k-1)
13042  END IF
13043  IF (q(i, k) .GT. y6) THEN
13044  q(i, k) = y6
13045  ELSE
13046  q(i, k) = q(i, k)
13047  END IF
13048  IF (iv .EQ. 0) THEN
13049  IF (0. .LT. q(i, k)) THEN
13050  q(i, k) = q(i, k)
13051  ELSE
13052  q(i, k) = 0.
13053  END IF
13054  END IF
13055  END IF
13056  END DO
13057  END DO
13058 ! Bottom:
13059  DO i=i1,i2
13060  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
13061  y7 = a4(1, i, km)
13062  ELSE
13063  y7 = a4(1, i, km-1)
13064  END IF
13065  IF (q(i, km) .GT. y7) THEN
13066  q(i, km) = y7
13067  ELSE
13068  q(i, km) = q(i, km)
13069  END IF
13070  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
13071  y8 = a4(1, i, km)
13072  ELSE
13073  y8 = a4(1, i, km-1)
13074  END IF
13075  IF (q(i, km) .LT. y8) THEN
13076  q(i, km) = y8
13077  ELSE
13078  q(i, km) = q(i, km)
13079  END IF
13080  END DO
13081  DO k=1,km
13082  DO i=i1,i2
13083  a4(2, i, k) = q(i, k)
13084  a4(3, i, k) = q(i, k+1)
13085  END DO
13086  END DO
13087  DO k=1,km
13088  IF (k .EQ. 1 .OR. k .EQ. km) THEN
13089  DO i=i1,i2
13090  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
13091 & , k)) .GT. 0.
13092  END DO
13093  ELSE
13094  DO i=i1,i2
13095  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
13096  END DO
13097  END IF
13098  END DO
13099 !---------------------------
13100 ! Apply subgrid constraints:
13101 !---------------------------
13102 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
13103 ! Top 2 and bottom 2 layers always use monotonic mapping
13104  IF (iv .EQ. 0) THEN
13105  DO i=i1,i2
13106  IF (0. .LT. a4(2, i, 1)) THEN
13107  a4(2, i, 1) = a4(2, i, 1)
13108  ELSE
13109  a4(2, i, 1) = 0.
13110  END IF
13111  END DO
13112  ELSE IF (iv .EQ. -1) THEN
13113  DO i=i1,i2
13114  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
13115  END DO
13116  ELSE IF (iv .EQ. 2) THEN
13117  DO i=i1,i2
13118  a4(2, i, 1) = a4(1, i, 1)
13119  a4(3, i, 1) = a4(1, i, 1)
13120  a4(4, i, 1) = 0.
13121  END DO
13122  END IF
13123  IF (iv .NE. 2) THEN
13124  DO i=i1,i2
13125  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
13126  END DO
13127  CALL cs_limiters(im, extm(i1, 1), a4(1, i1, 1), 1)
13128  END IF
13129 ! k=2
13130  DO i=i1,i2
13131  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
13132  END DO
13133  CALL cs_limiters(im, extm(i1, 2), a4(1, i1, 2), 2)
13134 !-------------------------------------
13135 ! Huynh's 2nd constraint for interior:
13136 !-------------------------------------
13137  DO k=3,km-2
13138  IF (kord .GE. 0.) THEN
13139  abs1 = kord
13140  ELSE
13141  abs1 = -kord
13142  END IF
13143  IF (abs1 .LT. 9) THEN
13144  DO i=i1,i2
13145 ! Left edges
13146  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
13147  lac_1 = pmp_1 + 1.5*gam(i, k+2)
13148  IF (a4(1, i, k) .GT. pmp_1) THEN
13149  IF (pmp_1 .GT. lac_1) THEN
13150  y19 = lac_1
13151  ELSE
13152  y19 = pmp_1
13153  END IF
13154  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
13155  y19 = lac_1
13156  ELSE
13157  y19 = a4(1, i, k)
13158  END IF
13159  IF (a4(2, i, k) .LT. y19) THEN
13160  x1 = y19
13161  ELSE
13162  x1 = a4(2, i, k)
13163  END IF
13164  IF (a4(1, i, k) .LT. pmp_1) THEN
13165  IF (pmp_1 .LT. lac_1) THEN
13166  y9 = lac_1
13167  ELSE
13168  y9 = pmp_1
13169  END IF
13170  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
13171  y9 = lac_1
13172  ELSE
13173  y9 = a4(1, i, k)
13174  END IF
13175  IF (x1 .GT. y9) THEN
13176  a4(2, i, k) = y9
13177  ELSE
13178  a4(2, i, k) = x1
13179  END IF
13180 ! Right edges
13181  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
13182  lac_2 = pmp_2 - 1.5*gam(i, k-1)
13183  IF (a4(1, i, k) .GT. pmp_2) THEN
13184  IF (pmp_2 .GT. lac_2) THEN
13185  y20 = lac_2
13186  ELSE
13187  y20 = pmp_2
13188  END IF
13189  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
13190  y20 = lac_2
13191  ELSE
13192  y20 = a4(1, i, k)
13193  END IF
13194  IF (a4(3, i, k) .LT. y20) THEN
13195  x2 = y20
13196  ELSE
13197  x2 = a4(3, i, k)
13198  END IF
13199  IF (a4(1, i, k) .LT. pmp_2) THEN
13200  IF (pmp_2 .LT. lac_2) THEN
13201  y10 = lac_2
13202  ELSE
13203  y10 = pmp_2
13204  END IF
13205  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
13206  y10 = lac_2
13207  ELSE
13208  y10 = a4(1, i, k)
13209  END IF
13210  IF (x2 .GT. y10) THEN
13211  a4(3, i, k) = y10
13212  ELSE
13213  a4(3, i, k) = x2
13214  END IF
13215  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
13216  END DO
13217  ELSE
13218  IF (kord .GE. 0.) THEN
13219  abs2 = kord
13220  ELSE
13221  abs2 = -kord
13222  END IF
13223  IF (abs2 .EQ. 9) THEN
13224  DO i=i1,i2
13225  IF (extm(i, k) .AND. extm(i, k-1)) THEN
13226 ! c90_mp122
13227 ! grid-scale 2-delta-z wave detected
13228  a4(2, i, k) = a4(1, i, k)
13229  a4(3, i, k) = a4(1, i, k)
13230  a4(4, i, k) = 0.
13231  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
13232 ! c90_mp122
13233 ! grid-scale 2-delta-z wave detected
13234  a4(2, i, k) = a4(1, i, k)
13235  a4(3, i, k) = a4(1, i, k)
13236  a4(4, i, k) = 0.
13237  ELSE
13238  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i, &
13239 & k))
13240  IF (a4(4, i, k) .GE. 0.) THEN
13241  abs3 = a4(4, i, k)
13242  ELSE
13243  abs3 = -a4(4, i, k)
13244  END IF
13245  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
13246  abs10 = a4(2, i, k) - a4(3, i, k)
13247  ELSE
13248  abs10 = -(a4(2, i, k)-a4(3, i, k))
13249  END IF
13250 ! Check within the smooth region if subgrid profile is non-monotonic
13251  IF (abs3 .GT. abs10) THEN
13252  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
13253  lac_1 = pmp_1 + 1.5*gam(i, k+2)
13254  IF (a4(1, i, k) .GT. pmp_1) THEN
13255  IF (pmp_1 .GT. lac_1) THEN
13256  y21 = lac_1
13257  ELSE
13258  y21 = pmp_1
13259  END IF
13260  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
13261  y21 = lac_1
13262  ELSE
13263  y21 = a4(1, i, k)
13264  END IF
13265  IF (a4(2, i, k) .LT. y21) THEN
13266  x3 = y21
13267  ELSE
13268  x3 = a4(2, i, k)
13269  END IF
13270  IF (a4(1, i, k) .LT. pmp_1) THEN
13271  IF (pmp_1 .LT. lac_1) THEN
13272  y11 = lac_1
13273  ELSE
13274  y11 = pmp_1
13275  END IF
13276  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
13277  y11 = lac_1
13278  ELSE
13279  y11 = a4(1, i, k)
13280  END IF
13281  IF (x3 .GT. y11) THEN
13282  a4(2, i, k) = y11
13283  ELSE
13284  a4(2, i, k) = x3
13285  END IF
13286  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
13287  lac_2 = pmp_2 - 1.5*gam(i, k-1)
13288  IF (a4(1, i, k) .GT. pmp_2) THEN
13289  IF (pmp_2 .GT. lac_2) THEN
13290  y22 = lac_2
13291  ELSE
13292  y22 = pmp_2
13293  END IF
13294  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
13295  y22 = lac_2
13296  ELSE
13297  y22 = a4(1, i, k)
13298  END IF
13299  IF (a4(3, i, k) .LT. y22) THEN
13300  x4 = y22
13301  ELSE
13302  x4 = a4(3, i, k)
13303  END IF
13304  IF (a4(1, i, k) .LT. pmp_2) THEN
13305  IF (pmp_2 .LT. lac_2) THEN
13306  y12 = lac_2
13307  ELSE
13308  y12 = pmp_2
13309  END IF
13310  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
13311  y12 = lac_2
13312  ELSE
13313  y12 = a4(1, i, k)
13314  END IF
13315  IF (x4 .GT. y12) THEN
13316  a4(3, i, k) = y12
13317  ELSE
13318  a4(3, i, k) = x4
13319  END IF
13320  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
13321 & , k))
13322  END IF
13323  END IF
13324  END DO
13325  ELSE
13326  IF (kord .GE. 0.) THEN
13327  abs4 = kord
13328  ELSE
13329  abs4 = -kord
13330  END IF
13331  IF (abs4 .EQ. 10) THEN
13332  DO i=i1,i2
13333  IF (extm(i, k)) THEN
13334  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
13335 ! grid-scale 2-delta-z wave detected
13336  a4(2, i, k) = a4(1, i, k)
13337  a4(3, i, k) = a4(1, i, k)
13338  a4(4, i, k) = 0.
13339  ELSE
13340 ! True local extremum
13341  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
13342 & , i, k))
13343  END IF
13344  ELSE
13345 ! not a local extremum
13346  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
13347 & , k))
13348  IF (a4(4, i, k) .GE. 0.) THEN
13349  abs5 = a4(4, i, k)
13350  ELSE
13351  abs5 = -a4(4, i, k)
13352  END IF
13353  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
13354  abs11 = a4(2, i, k) - a4(3, i, k)
13355  ELSE
13356  abs11 = -(a4(2, i, k)-a4(3, i, k))
13357  END IF
13358 ! Check within the smooth region if subgrid profile is non-monotonic
13359  IF (abs5 .GT. abs11) THEN
13360  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
13361  lac_1 = pmp_1 + 1.5*gam(i, k+2)
13362  IF (a4(1, i, k) .GT. pmp_1) THEN
13363  IF (pmp_1 .GT. lac_1) THEN
13364  y23 = lac_1
13365  ELSE
13366  y23 = pmp_1
13367  END IF
13368  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
13369  y23 = lac_1
13370  ELSE
13371  y23 = a4(1, i, k)
13372  END IF
13373  IF (a4(2, i, k) .LT. y23) THEN
13374  x5 = y23
13375  ELSE
13376  x5 = a4(2, i, k)
13377  END IF
13378  IF (a4(1, i, k) .LT. pmp_1) THEN
13379  IF (pmp_1 .LT. lac_1) THEN
13380  y13 = lac_1
13381  ELSE
13382  y13 = pmp_1
13383  END IF
13384  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
13385  y13 = lac_1
13386  ELSE
13387  y13 = a4(1, i, k)
13388  END IF
13389  IF (x5 .GT. y13) THEN
13390  a4(2, i, k) = y13
13391  ELSE
13392  a4(2, i, k) = x5
13393  END IF
13394  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
13395  lac_2 = pmp_2 - 1.5*gam(i, k-1)
13396  IF (a4(1, i, k) .GT. pmp_2) THEN
13397  IF (pmp_2 .GT. lac_2) THEN
13398  y24 = lac_2
13399  ELSE
13400  y24 = pmp_2
13401  END IF
13402  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
13403  y24 = lac_2
13404  ELSE
13405  y24 = a4(1, i, k)
13406  END IF
13407  IF (a4(3, i, k) .LT. y24) THEN
13408  x6 = y24
13409  ELSE
13410  x6 = a4(3, i, k)
13411  END IF
13412  IF (a4(1, i, k) .LT. pmp_2) THEN
13413  IF (pmp_2 .LT. lac_2) THEN
13414  y14 = lac_2
13415  ELSE
13416  y14 = pmp_2
13417  END IF
13418  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
13419  y14 = lac_2
13420  ELSE
13421  y14 = a4(1, i, k)
13422  END IF
13423  IF (x6 .GT. y14) THEN
13424  a4(3, i, k) = y14
13425  ELSE
13426  a4(3, i, k) = x6
13427  END IF
13428  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
13429 & , i, k))
13430  END IF
13431  END IF
13432  END DO
13433  ELSE
13434  IF (kord .GE. 0.) THEN
13435  abs6 = kord
13436  ELSE
13437  abs6 = -kord
13438  END IF
13439  IF (abs6 .EQ. 12) THEN
13440  DO i=i1,i2
13441  IF (extm(i, k)) THEN
13442 ! grid-scale 2-delta-z wave detected
13443  a4(2, i, k) = a4(1, i, k)
13444  a4(3, i, k) = a4(1, i, k)
13445  a4(4, i, k) = 0.
13446  ELSE
13447 ! not a local extremum
13448  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
13449 & , i, k))
13450  IF (a4(4, i, k) .GE. 0.) THEN
13451  abs7 = a4(4, i, k)
13452  ELSE
13453  abs7 = -a4(4, i, k)
13454  END IF
13455  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
13456  abs12 = a4(2, i, k) - a4(3, i, k)
13457  ELSE
13458  abs12 = -(a4(2, i, k)-a4(3, i, k))
13459  END IF
13460 ! Check within the smooth region if subgrid profile is non-monotonic
13461  IF (abs7 .GT. abs12) THEN
13462  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
13463  lac_1 = pmp_1 + 1.5*gam(i, k+2)
13464  IF (a4(1, i, k) .GT. pmp_1) THEN
13465  IF (pmp_1 .GT. lac_1) THEN
13466  y25 = lac_1
13467  ELSE
13468  y25 = pmp_1
13469  END IF
13470  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
13471  y25 = lac_1
13472  ELSE
13473  y25 = a4(1, i, k)
13474  END IF
13475  IF (a4(2, i, k) .LT. y25) THEN
13476  x7 = y25
13477  ELSE
13478  x7 = a4(2, i, k)
13479  END IF
13480  IF (a4(1, i, k) .LT. pmp_1) THEN
13481  IF (pmp_1 .LT. lac_1) THEN
13482  y15 = lac_1
13483  ELSE
13484  y15 = pmp_1
13485  END IF
13486  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
13487  y15 = lac_1
13488  ELSE
13489  y15 = a4(1, i, k)
13490  END IF
13491  IF (x7 .GT. y15) THEN
13492  a4(2, i, k) = y15
13493  ELSE
13494  a4(2, i, k) = x7
13495  END IF
13496  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
13497  lac_2 = pmp_2 - 1.5*gam(i, k-1)
13498  IF (a4(1, i, k) .GT. pmp_2) THEN
13499  IF (pmp_2 .GT. lac_2) THEN
13500  y26 = lac_2
13501  ELSE
13502  y26 = pmp_2
13503  END IF
13504  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
13505  y26 = lac_2
13506  ELSE
13507  y26 = a4(1, i, k)
13508  END IF
13509  IF (a4(3, i, k) .LT. y26) THEN
13510  x8 = y26
13511  ELSE
13512  x8 = a4(3, i, k)
13513  END IF
13514  IF (a4(1, i, k) .LT. pmp_2) THEN
13515  IF (pmp_2 .LT. lac_2) THEN
13516  y16 = lac_2
13517  ELSE
13518  y16 = pmp_2
13519  END IF
13520  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
13521  y16 = lac_2
13522  ELSE
13523  y16 = a4(1, i, k)
13524  END IF
13525  IF (x8 .GT. y16) THEN
13526  a4(3, i, k) = y16
13527  ELSE
13528  a4(3, i, k) = x8
13529  END IF
13530  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
13531 & 3, i, k))
13532  END IF
13533  END IF
13534  END DO
13535  ELSE
13536  IF (kord .GE. 0.) THEN
13537  abs8 = kord
13538  ELSE
13539  abs8 = -kord
13540  END IF
13541  IF (abs8 .EQ. 13) THEN
13542  DO i=i1,i2
13543  IF (extm(i, k)) THEN
13544  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
13545 ! grid-scale 2-delta-z wave detected
13546  a4(2, i, k) = a4(1, i, k)
13547  a4(3, i, k) = a4(1, i, k)
13548  a4(4, i, k) = 0.
13549  ELSE
13550 ! Left edges
13551  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
13552  lac_1 = pmp_1 + 1.5*gam(i, k+2)
13553  IF (a4(1, i, k) .GT. pmp_1) THEN
13554  IF (pmp_1 .GT. lac_1) THEN
13555  y27 = lac_1
13556  ELSE
13557  y27 = pmp_1
13558  END IF
13559  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
13560  y27 = lac_1
13561  ELSE
13562  y27 = a4(1, i, k)
13563  END IF
13564  IF (a4(2, i, k) .LT. y27) THEN
13565  x9 = y27
13566  ELSE
13567  x9 = a4(2, i, k)
13568  END IF
13569  IF (a4(1, i, k) .LT. pmp_1) THEN
13570  IF (pmp_1 .LT. lac_1) THEN
13571  y17 = lac_1
13572  ELSE
13573  y17 = pmp_1
13574  END IF
13575  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
13576  y17 = lac_1
13577  ELSE
13578  y17 = a4(1, i, k)
13579  END IF
13580  IF (x9 .GT. y17) THEN
13581  a4(2, i, k) = y17
13582  ELSE
13583  a4(2, i, k) = x9
13584  END IF
13585 ! Right edges
13586  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
13587  lac_2 = pmp_2 - 1.5*gam(i, k-1)
13588  IF (a4(1, i, k) .GT. pmp_2) THEN
13589  IF (pmp_2 .GT. lac_2) THEN
13590  y28 = lac_2
13591  ELSE
13592  y28 = pmp_2
13593  END IF
13594  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
13595  y28 = lac_2
13596  ELSE
13597  y28 = a4(1, i, k)
13598  END IF
13599  IF (a4(3, i, k) .LT. y28) THEN
13600  x10 = y28
13601  ELSE
13602  x10 = a4(3, i, k)
13603  END IF
13604  IF (a4(1, i, k) .LT. pmp_2) THEN
13605  IF (pmp_2 .LT. lac_2) THEN
13606  y18 = lac_2
13607  ELSE
13608  y18 = pmp_2
13609  END IF
13610  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
13611  y18 = lac_2
13612  ELSE
13613  y18 = a4(1, i, k)
13614  END IF
13615  IF (x10 .GT. y18) THEN
13616  a4(3, i, k) = y18
13617  ELSE
13618  a4(3, i, k) = x10
13619  END IF
13620  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
13621 & (3, i, k)))
13622  END IF
13623  ELSE
13624  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
13625 & , i, k)))
13626  END IF
13627  END DO
13628  ELSE
13629  IF (kord .GE. 0.) THEN
13630  abs9 = kord
13631  ELSE
13632  abs9 = -kord
13633  END IF
13634  IF (abs9 .EQ. 14) THEN
13635  DO i=i1,i2
13636  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
13637 & , i, k)))
13638  END DO
13639  ELSE
13640 ! kord = 11
13641  DO i=i1,i2
13642  IF (extm(i, k) .AND. (extm(i, k-1) .OR. extm(i, k+&
13643 & 1))) THEN
13644 ! Noisy region:
13645  a4(2, i, k) = a4(1, i, k)
13646  a4(3, i, k) = a4(1, i, k)
13647  a4(4, i, k) = 0.
13648  ELSE
13649  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
13650 & (3, i, k)))
13651  END IF
13652  END DO
13653  END IF
13654  END IF
13655  END IF
13656  END IF
13657  END IF
13658  END IF
13659 ! Additional constraint to ensure positivity
13660  IF (iv .EQ. 0) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 0&
13661 & )
13662  END DO
13663 ! k-loop
13664 !----------------------------------
13665 ! Bottom layer subgrid constraints:
13666 !----------------------------------
13667  IF (iv .EQ. 0) THEN
13668  DO i=i1,i2
13669  IF (0. .LT. a4(3, i, km)) THEN
13670  a4(3, i, km) = a4(3, i, km)
13671  ELSE
13672  a4(3, i, km) = 0.
13673  END IF
13674  END DO
13675  ELSE IF (iv .EQ. -1) THEN
13676  DO i=i1,i2
13677  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) a4(3, i, km) = 0.
13678  END DO
13679  END IF
13680  DO k=km-1,km
13681  DO i=i1,i2
13682  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
13683  END DO
13684  IF (k .EQ. km - 1) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k&
13685 & ), 2)
13686  IF (k .EQ. km) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 1&
13687 & )
13688  END DO
13689  END IF
13690  END SUBROUTINE cs_profile
13691 ! Differentiation of cs_limiters in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
13692 !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
13693 !_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.
13694 !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
13695 !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
13696 !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
13697 !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
13698 !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
13699 ! 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_
13700 !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
13701 !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
13702 !_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
13703 !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
13704 !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
13705 !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
13706 !_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
13707 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
13708 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
13709 ! gradient of useful results: a4
13710 ! with respect to varying inputs: a4
13711  SUBROUTINE cs_limiters_fwd(im, extm, a4, iv)
13712  IMPLICIT NONE
13713  INTEGER, INTENT(IN) :: im
13714  INTEGER, INTENT(IN) :: iv
13715  LOGICAL, INTENT(IN) :: extm(im)
13716 ! PPM array
13717  REAL, INTENT(INOUT) :: a4(4, im)
13718 ! !LOCAL VARIABLES:
13719  REAL :: da1, da2, a6da
13720  INTEGER :: i
13721  INTRINSIC abs
13722  REAL :: abs0
13723  IF (iv .EQ. 0) THEN
13724 ! Positive definite constraint
13725  DO i=1,im
13726  IF (a4(1, i) .LE. 0.) THEN
13727  CALL pushrealarray(a4(2, i))
13728  a4(2, i) = a4(1, i)
13729  CALL pushrealarray(a4(3, i))
13730  a4(3, i) = a4(1, i)
13731  CALL pushrealarray(a4(4, i))
13732  a4(4, i) = 0.
13733  CALL pushcontrol(3,5)
13734  ELSE
13735  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
13736  abs0 = a4(3, i) - a4(2, i)
13737  ELSE
13738  abs0 = -(a4(3, i)-a4(2, i))
13739  END IF
13740  IF (abs0 .LT. -a4(4, i)) THEN
13741  IF (a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4, &
13742 & i)*r12 .LT. 0.) THEN
13743 ! local minimum is negative
13744  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
13745 & THEN
13746  CALL pushrealarray(a4(3, i))
13747  a4(3, i) = a4(1, i)
13748  CALL pushrealarray(a4(2, i))
13749  a4(2, i) = a4(1, i)
13750  CALL pushrealarray(a4(4, i))
13751  a4(4, i) = 0.
13752  CALL pushcontrol(3,4)
13753  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
13754  CALL pushrealarray(a4(4, i))
13755  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
13756  CALL pushrealarray(a4(3, i))
13757  a4(3, i) = a4(2, i) - a4(4, i)
13758  CALL pushcontrol(3,3)
13759  ELSE
13760  CALL pushrealarray(a4(4, i))
13761  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
13762  CALL pushrealarray(a4(2, i))
13763  a4(2, i) = a4(3, i) - a4(4, i)
13764  CALL pushcontrol(3,2)
13765  END IF
13766  ELSE
13767  CALL pushcontrol(3,1)
13768  END IF
13769  ELSE
13770  CALL pushcontrol(3,0)
13771  END IF
13772  END IF
13773  END DO
13774  CALL pushcontrol(2,0)
13775  ELSE IF (iv .EQ. 1) THEN
13776  DO i=1,im
13777  IF ((a4(1, i)-a4(2, i))*(a4(1, i)-a4(3, i)) .GE. 0.) THEN
13778  CALL pushrealarray(a4(2, i))
13779  a4(2, i) = a4(1, i)
13780  CALL pushrealarray(a4(3, i))
13781  a4(3, i) = a4(1, i)
13782  CALL pushrealarray(a4(4, i))
13783  a4(4, i) = 0.
13784  CALL pushcontrol(2,3)
13785  ELSE
13786  da1 = a4(3, i) - a4(2, i)
13787  da2 = da1**2
13788  a6da = a4(4, i)*da1
13789  IF (a6da .LT. -da2) THEN
13790  CALL pushrealarray(a4(4, i))
13791  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
13792  CALL pushrealarray(a4(3, i))
13793  a4(3, i) = a4(2, i) - a4(4, i)
13794  CALL pushcontrol(2,2)
13795  ELSE IF (a6da .GT. da2) THEN
13796  CALL pushrealarray(a4(4, i))
13797  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
13798  CALL pushrealarray(a4(2, i))
13799  a4(2, i) = a4(3, i) - a4(4, i)
13800  CALL pushcontrol(2,1)
13801  ELSE
13802  CALL pushcontrol(2,0)
13803  END IF
13804  END IF
13805  END DO
13806  CALL pushcontrol(2,1)
13807  ELSE
13808 ! Standard PPM constraint
13809  DO i=1,im
13810  IF (extm(i)) THEN
13811  CALL pushrealarray(a4(2, i))
13812  a4(2, i) = a4(1, i)
13813  CALL pushrealarray(a4(3, i))
13814  a4(3, i) = a4(1, i)
13815  CALL pushrealarray(a4(4, i))
13816  a4(4, i) = 0.
13817  CALL pushcontrol(2,3)
13818  ELSE
13819  da1 = a4(3, i) - a4(2, i)
13820  da2 = da1**2
13821  a6da = a4(4, i)*da1
13822  IF (a6da .LT. -da2) THEN
13823  CALL pushrealarray(a4(4, i))
13824  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
13825  CALL pushrealarray(a4(3, i))
13826  a4(3, i) = a4(2, i) - a4(4, i)
13827  CALL pushcontrol(2,2)
13828  ELSE IF (a6da .GT. da2) THEN
13829  CALL pushrealarray(a4(4, i))
13830  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
13831  CALL pushrealarray(a4(2, i))
13832  a4(2, i) = a4(3, i) - a4(4, i)
13833  CALL pushcontrol(2,1)
13834  ELSE
13835  CALL pushcontrol(2,0)
13836  END IF
13837  END IF
13838  END DO
13839  CALL pushcontrol(2,2)
13840  END IF
13841  END SUBROUTINE cs_limiters_fwd
13842 ! Differentiation of cs_limiters in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
13843 !_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
13844 !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
13845 !.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
13846 !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
13847 !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.
13848 !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
13849 ! 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
13850 !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
13851 !_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
13852 !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
13853 !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_
13854 !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
13855 !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.
13856 !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_
13857 !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
13858 !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
13859 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
13860 ! gradient of useful results: a4
13861 ! with respect to varying inputs: a4
13862  SUBROUTINE cs_limiters_bwd(im, extm, a4, a4_ad, iv)
13863  IMPLICIT NONE
13864  INTEGER, INTENT(IN) :: im
13865  INTEGER, INTENT(IN) :: iv
13866  LOGICAL, INTENT(IN) :: extm(im)
13867  REAL, INTENT(INOUT) :: a4(4, im)
13868  REAL, INTENT(INOUT) :: a4_ad(4, im)
13869  REAL :: da1, da2, a6da
13870  INTEGER :: i
13871  INTRINSIC abs
13872  REAL :: abs0
13873  INTEGER :: branch
13874  CALL popcontrol(2,branch)
13875  IF (branch .EQ. 0) THEN
13876  DO i=im,1,-1
13877  CALL popcontrol(3,branch)
13878  IF (branch .LT. 3) THEN
13879  IF (branch .NE. 0) THEN
13880  IF (branch .NE. 1) THEN
13881  CALL poprealarray(a4(2, i))
13882  a4_ad(3, i) = a4_ad(3, i) + a4_ad(2, i)
13883  a4_ad(4, i) = a4_ad(4, i) - a4_ad(2, i)
13884  a4_ad(2, i) = 0.0
13885  CALL poprealarray(a4(4, i))
13886  a4_ad(3, i) = a4_ad(3, i) + 3.*a4_ad(4, i)
13887  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13888  a4_ad(4, i) = 0.0
13889  END IF
13890  END IF
13891  ELSE IF (branch .EQ. 3) THEN
13892  CALL poprealarray(a4(3, i))
13893  a4_ad(2, i) = a4_ad(2, i) + a4_ad(3, i)
13894  a4_ad(4, i) = a4_ad(4, i) - a4_ad(3, i)
13895  a4_ad(3, i) = 0.0
13896  CALL poprealarray(a4(4, i))
13897  a4_ad(2, i) = a4_ad(2, i) + 3.*a4_ad(4, i)
13898  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13899  a4_ad(4, i) = 0.0
13900  ELSE IF (branch .EQ. 4) THEN
13901  CALL poprealarray(a4(4, i))
13902  a4_ad(4, i) = 0.0
13903  CALL poprealarray(a4(2, i))
13904  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
13905  a4_ad(2, i) = 0.0
13906  CALL poprealarray(a4(3, i))
13907  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
13908  a4_ad(3, i) = 0.0
13909  ELSE
13910  CALL poprealarray(a4(4, i))
13911  a4_ad(4, i) = 0.0
13912  CALL poprealarray(a4(3, i))
13913  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
13914  a4_ad(3, i) = 0.0
13915  CALL poprealarray(a4(2, i))
13916  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
13917  a4_ad(2, i) = 0.0
13918  END IF
13919  END DO
13920  ELSE IF (branch .EQ. 1) THEN
13921  DO i=im,1,-1
13922  CALL popcontrol(2,branch)
13923  IF (branch .LT. 2) THEN
13924  IF (branch .NE. 0) THEN
13925  CALL poprealarray(a4(2, i))
13926  a4_ad(3, i) = a4_ad(3, i) + a4_ad(2, i)
13927  a4_ad(4, i) = a4_ad(4, i) - a4_ad(2, i)
13928  a4_ad(2, i) = 0.0
13929  CALL poprealarray(a4(4, i))
13930  a4_ad(3, i) = a4_ad(3, i) + 3.*a4_ad(4, i)
13931  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13932  a4_ad(4, i) = 0.0
13933  END IF
13934  ELSE IF (branch .EQ. 2) THEN
13935  CALL poprealarray(a4(3, i))
13936  a4_ad(2, i) = a4_ad(2, i) + a4_ad(3, i)
13937  a4_ad(4, i) = a4_ad(4, i) - a4_ad(3, i)
13938  a4_ad(3, i) = 0.0
13939  CALL poprealarray(a4(4, i))
13940  a4_ad(2, i) = a4_ad(2, i) + 3.*a4_ad(4, i)
13941  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13942  a4_ad(4, i) = 0.0
13943  ELSE
13944  CALL poprealarray(a4(4, i))
13945  a4_ad(4, i) = 0.0
13946  CALL poprealarray(a4(3, i))
13947  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
13948  a4_ad(3, i) = 0.0
13949  CALL poprealarray(a4(2, i))
13950  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
13951  a4_ad(2, i) = 0.0
13952  END IF
13953  END DO
13954  ELSE
13955  DO i=im,1,-1
13956  CALL popcontrol(2,branch)
13957  IF (branch .LT. 2) THEN
13958  IF (branch .NE. 0) THEN
13959  CALL poprealarray(a4(2, i))
13960  a4_ad(3, i) = a4_ad(3, i) + a4_ad(2, i)
13961  a4_ad(4, i) = a4_ad(4, i) - a4_ad(2, i)
13962  a4_ad(2, i) = 0.0
13963  CALL poprealarray(a4(4, i))
13964  a4_ad(3, i) = a4_ad(3, i) + 3.*a4_ad(4, i)
13965  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13966  a4_ad(4, i) = 0.0
13967  END IF
13968  ELSE IF (branch .EQ. 2) THEN
13969  CALL poprealarray(a4(3, i))
13970  a4_ad(2, i) = a4_ad(2, i) + a4_ad(3, i)
13971  a4_ad(4, i) = a4_ad(4, i) - a4_ad(3, i)
13972  a4_ad(3, i) = 0.0
13973  CALL poprealarray(a4(4, i))
13974  a4_ad(2, i) = a4_ad(2, i) + 3.*a4_ad(4, i)
13975  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
13976  a4_ad(4, i) = 0.0
13977  ELSE
13978  CALL poprealarray(a4(4, i))
13979  a4_ad(4, i) = 0.0
13980  CALL poprealarray(a4(3, i))
13981  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
13982  a4_ad(3, i) = 0.0
13983  CALL poprealarray(a4(2, i))
13984  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
13985  a4_ad(2, i) = 0.0
13986  END IF
13987  END DO
13988  END IF
13989  END SUBROUTINE cs_limiters_bwd
13990  SUBROUTINE cs_limiters(im, extm, a4, iv)
13991  IMPLICIT NONE
13992  INTEGER, INTENT(IN) :: im
13993  INTEGER, INTENT(IN) :: iv
13994  LOGICAL, INTENT(IN) :: extm(im)
13995 ! PPM array
13996  REAL, INTENT(INOUT) :: a4(4, im)
13997 ! !LOCAL VARIABLES:
13998  REAL :: da1, da2, a6da
13999  INTEGER :: i
14000  INTRINSIC abs
14001  REAL :: abs0
14002  IF (iv .EQ. 0) THEN
14003 ! Positive definite constraint
14004  DO i=1,im
14005  IF (a4(1, i) .LE. 0.) THEN
14006  a4(2, i) = a4(1, i)
14007  a4(3, i) = a4(1, i)
14008  a4(4, i) = 0.
14009  ELSE
14010  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
14011  abs0 = a4(3, i) - a4(2, i)
14012  ELSE
14013  abs0 = -(a4(3, i)-a4(2, i))
14014  END IF
14015  IF (abs0 .LT. -a4(4, i)) THEN
14016  IF (a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4, &
14017 & i)*r12 .LT. 0.) THEN
14018 ! local minimum is negative
14019  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
14020 & THEN
14021  a4(3, i) = a4(1, i)
14022  a4(2, i) = a4(1, i)
14023  a4(4, i) = 0.
14024  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
14025  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
14026  a4(3, i) = a4(2, i) - a4(4, i)
14027  ELSE
14028  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
14029  a4(2, i) = a4(3, i) - a4(4, i)
14030  END IF
14031  END IF
14032  END IF
14033  END IF
14034  END DO
14035  ELSE IF (iv .EQ. 1) THEN
14036  DO i=1,im
14037  IF ((a4(1, i)-a4(2, i))*(a4(1, i)-a4(3, i)) .GE. 0.) THEN
14038  a4(2, i) = a4(1, i)
14039  a4(3, i) = a4(1, i)
14040  a4(4, i) = 0.
14041  ELSE
14042  da1 = a4(3, i) - a4(2, i)
14043  da2 = da1**2
14044  a6da = a4(4, i)*da1
14045  IF (a6da .LT. -da2) THEN
14046  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
14047  a4(3, i) = a4(2, i) - a4(4, i)
14048  ELSE IF (a6da .GT. da2) THEN
14049  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
14050  a4(2, i) = a4(3, i) - a4(4, i)
14051  END IF
14052  END IF
14053  END DO
14054  ELSE
14055 ! Standard PPM constraint
14056  DO i=1,im
14057  IF (extm(i)) THEN
14058  a4(2, i) = a4(1, i)
14059  a4(3, i) = a4(1, i)
14060  a4(4, i) = 0.
14061  ELSE
14062  da1 = a4(3, i) - a4(2, i)
14063  da2 = da1**2
14064  a6da = a4(4, i)*da1
14065  IF (a6da .LT. -da2) THEN
14066  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
14067  a4(3, i) = a4(2, i) - a4(4, i)
14068  ELSE IF (a6da .GT. da2) THEN
14069  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
14070  a4(2, i) = a4(3, i) - a4(4, i)
14071  END IF
14072  END IF
14073  END DO
14074  END IF
14075  END SUBROUTINE cs_limiters
14076 ! Differentiation of ppm_profile in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
14077 !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
14078 !_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.
14079 !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
14080 !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
14081 !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
14082 !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
14083 !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
14084 ! 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_
14085 !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
14086 !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
14087 !_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
14088 !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
14089 !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
14090 !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
14091 !_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
14092 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
14093 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
14094 ! gradient of useful results: delp a4
14095 ! with respect to varying inputs: delp a4
14096  SUBROUTINE ppm_profile_fwd(a4, delp, km, i1, i2, iv, kord)
14097  IMPLICIT NONE
14098 ! !INPUT PARAMETERS:
14099 ! iv =-1: winds
14100  INTEGER, INTENT(IN) :: iv
14101 ! iv = 0: positive definite scalars
14102 ! iv = 1: others
14103 ! iv = 2: w (iv=-2)
14104 ! Starting longitude
14105  INTEGER, INTENT(IN) :: i1
14106 ! Finishing longitude
14107  INTEGER, INTENT(IN) :: i2
14108 ! vertical dimension
14109  INTEGER, INTENT(IN) :: km
14110 ! Order (or more accurately method no.):
14111  INTEGER, INTENT(IN) :: kord
14112 !
14113 ! layer pressure thickness
14114  REAL, INTENT(IN) :: delp(i1:i2, km)
14115 ! !INPUT/OUTPUT PARAMETERS:
14116 ! Interpolated values
14117  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
14118 ! DESCRIPTION:
14119 !
14120 ! Perform the piecewise parabolic reconstruction
14121 !
14122 ! !REVISION HISTORY:
14123 ! S.-J. Lin revised at GFDL 2007
14124 !-----------------------------------------------------------------------
14125 ! local arrays:
14126  REAL :: dc(i1:i2, km)
14127  REAL :: h2(i1:i2, km)
14128  REAL :: delq(i1:i2, km)
14129  REAL :: df2(i1:i2, km)
14130  REAL :: d4(i1:i2, km)
14131 ! local scalars:
14132  INTEGER :: i, k, km1, lmt, it
14133  REAL :: fac
14134  REAL :: a1, a2, c1, c2, c3, d1, d2
14135  REAL :: qm, dq, lac, qmp, pmp
14136  INTRINSIC abs
14137  INTRINSIC max
14138  INTRINSIC min
14139  INTRINSIC sign
14140  REAL :: min1
14141  INTEGER :: abs0
14142  REAL :: max1
14143  REAL :: min2
14144  REAL :: x3
14145  REAL :: x2
14146  REAL :: x1
14147  REAL :: z1
14148  REAL :: y9
14149  REAL :: y8
14150  REAL :: y7
14151  REAL :: y6
14152  REAL :: y5
14153  REAL :: y4
14154  REAL :: y3
14155  REAL :: y2
14156  REAL :: y1
14157  km1 = km - 1
14158  it = i2 - i1 + 1
14159  DO k=2,km
14160  DO i=i1,i2
14161  delq(i, k-1) = a4(1, i, k) - a4(1, i, k-1)
14162  d4(i, k) = delp(i, k-1) + delp(i, k)
14163  END DO
14164  END DO
14165  DO k=2,km1
14166  DO i=i1,i2
14167  c1 = (delp(i, k-1)+0.5*delp(i, k))/d4(i, k+1)
14168  c2 = (delp(i, k+1)+0.5*delp(i, k))/d4(i, k)
14169  df2(i, k) = delp(i, k)*(c1*delq(i, k)+c2*delq(i, k-1))/(d4(i, k)&
14170 & +delp(i, k+1))
14171  IF (df2(i, k) .GE. 0.) THEN
14172  x1 = df2(i, k)
14173  CALL pushcontrol(1,0)
14174  ELSE
14175  x1 = -df2(i, k)
14176  CALL pushcontrol(1,1)
14177  END IF
14178  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
14179  IF (a4(1, i, k) .LT. a4(1, i, k+1)) THEN
14180  max1 = a4(1, i, k+1)
14181  CALL pushcontrol(2,0)
14182  ELSE
14183  max1 = a4(1, i, k)
14184  CALL pushcontrol(2,1)
14185  END IF
14186  ELSE IF (a4(1, i, k-1) .LT. a4(1, i, k+1)) THEN
14187  max1 = a4(1, i, k+1)
14188  CALL pushcontrol(2,2)
14189  ELSE
14190  max1 = a4(1, i, k-1)
14191  CALL pushcontrol(2,3)
14192  END IF
14193  y1 = max1 - a4(1, i, k)
14194  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
14195  IF (a4(1, i, k) .GT. a4(1, i, k+1)) THEN
14196  min2 = a4(1, i, k+1)
14197  CALL pushcontrol(2,0)
14198  ELSE
14199  min2 = a4(1, i, k)
14200  CALL pushcontrol(2,1)
14201  END IF
14202  ELSE IF (a4(1, i, k-1) .GT. a4(1, i, k+1)) THEN
14203  min2 = a4(1, i, k+1)
14204  CALL pushcontrol(2,2)
14205  ELSE
14206  min2 = a4(1, i, k-1)
14207  CALL pushcontrol(2,3)
14208  END IF
14209  z1 = a4(1, i, k) - min2
14210  IF (x1 .GT. y1) THEN
14211  IF (y1 .GT. z1) THEN
14212  CALL pushrealarray(min1)
14213  min1 = z1
14214  CALL pushcontrol(2,0)
14215  ELSE
14216  CALL pushrealarray(min1)
14217  min1 = y1
14218  CALL pushcontrol(2,1)
14219  END IF
14220  ELSE IF (x1 .GT. z1) THEN
14221  CALL pushrealarray(min1)
14222  min1 = z1
14223  CALL pushcontrol(2,2)
14224  ELSE
14225  CALL pushrealarray(min1)
14226  min1 = x1
14227  CALL pushcontrol(2,3)
14228  END IF
14229  dc(i, k) = sign(min1, df2(i, k))
14230  END DO
14231  END DO
14232 !-----------------------------------------------------------
14233 ! 4th order interpolation of the provisional cell edge value
14234 !-----------------------------------------------------------
14235  DO k=3,km1
14236  DO i=i1,i2
14237  c1 = delq(i, k-1)*delp(i, k-1)/d4(i, k)
14238  a1 = d4(i, k-1)/(d4(i, k)+delp(i, k-1))
14239  a2 = d4(i, k+1)/(d4(i, k)+delp(i, k))
14240  a4(2, i, k) = a4(1, i, k-1) + c1 + 2./(d4(i, k-1)+d4(i, k+1))*(&
14241 & delp(i, k)*(c1*(a1-a2)+a2*dc(i, k-1))-delp(i, k-1)*a1*dc(i, k)&
14242 & )
14243  END DO
14244  END DO
14245 ! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4)
14246 ! Area preserving cubic with 2nd deriv. = 0 at the boundaries
14247 ! Top
14248  DO i=i1,i2
14249  d1 = delp(i, 1)
14250  d2 = delp(i, 2)
14251  CALL pushrealarray(qm)
14252  qm = (d2*a4(1, i, 1)+d1*a4(1, i, 2))/(d1+d2)
14253  CALL pushrealarray(dq)
14254  dq = 2.*(a4(1, i, 2)-a4(1, i, 1))/(d1+d2)
14255  CALL pushrealarray(c1)
14256  c1 = 4.*(a4(2, i, 3)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
14257  c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
14258  CALL pushrealarray(a4(2, i, 2))
14259  a4(2, i, 2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
14260 ! Top edge:
14261 !-------------------------------------------------------
14262  CALL pushrealarray(a4(2, i, 1))
14263  a4(2, i, 1) = d1*(2.*c1*d1**2-c3) + a4(2, i, 2)
14264  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
14265  y2 = a4(1, i, 2)
14266  CALL pushcontrol(1,0)
14267  ELSE
14268  y2 = a4(1, i, 1)
14269  CALL pushcontrol(1,1)
14270  END IF
14271  IF (a4(2, i, 2) .LT. y2) THEN
14272  CALL pushrealarray(a4(2, i, 2))
14273  a4(2, i, 2) = y2
14274  CALL pushcontrol(1,0)
14275  ELSE
14276  CALL pushrealarray(a4(2, i, 2))
14277  a4(2, i, 2) = a4(2, i, 2)
14278  CALL pushcontrol(1,1)
14279  END IF
14280  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
14281  y3 = a4(1, i, 2)
14282  CALL pushcontrol(1,0)
14283  ELSE
14284  y3 = a4(1, i, 1)
14285  CALL pushcontrol(1,1)
14286  END IF
14287  IF (a4(2, i, 2) .GT. y3) THEN
14288  CALL pushrealarray(a4(2, i, 2))
14289  a4(2, i, 2) = y3
14290  CALL pushcontrol(1,0)
14291  ELSE
14292  CALL pushrealarray(a4(2, i, 2))
14293  a4(2, i, 2) = a4(2, i, 2)
14294  CALL pushcontrol(1,1)
14295  END IF
14296  CALL pushrealarray(dc(i, 1))
14297  dc(i, 1) = 0.5*(a4(2, i, 2)-a4(1, i, 1))
14298  END DO
14299 ! Enforce monotonicity within the top layer
14300  IF (iv .EQ. 0) THEN
14301  DO i=i1,i2
14302  IF (0. .LT. a4(2, i, 1)) THEN
14303  CALL pushrealarray(a4(2, i, 1))
14304  a4(2, i, 1) = a4(2, i, 1)
14305  CALL pushcontrol(1,0)
14306  ELSE
14307  CALL pushrealarray(a4(2, i, 1))
14308  a4(2, i, 1) = 0.
14309  CALL pushcontrol(1,1)
14310  END IF
14311  IF (0. .LT. a4(2, i, 2)) THEN
14312  CALL pushrealarray(a4(2, i, 2))
14313  a4(2, i, 2) = a4(2, i, 2)
14314  CALL pushcontrol(1,0)
14315  ELSE
14316  CALL pushrealarray(a4(2, i, 2))
14317  a4(2, i, 2) = 0.
14318  CALL pushcontrol(1,1)
14319  END IF
14320  END DO
14321  CALL pushcontrol(2,3)
14322  ELSE IF (iv .EQ. -1) THEN
14323  DO i=i1,i2
14324  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) THEN
14325  CALL pushrealarray(a4(2, i, 1))
14326  a4(2, i, 1) = 0.
14327  CALL pushcontrol(1,1)
14328  ELSE
14329  CALL pushcontrol(1,0)
14330  END IF
14331  END DO
14332  CALL pushcontrol(2,2)
14333  ELSE
14334  IF (iv .GE. 0.) THEN
14335  abs0 = iv
14336  ELSE
14337  abs0 = -iv
14338  END IF
14339  IF (abs0 .EQ. 2) THEN
14340  DO i=i1,i2
14341  CALL pushrealarray(a4(2, i, 1))
14342  a4(2, i, 1) = a4(1, i, 1)
14343  CALL pushrealarray(a4(3, i, 1))
14344  a4(3, i, 1) = a4(1, i, 1)
14345  END DO
14346  CALL pushcontrol(2,1)
14347  ELSE
14348  CALL pushcontrol(2,0)
14349  END IF
14350  END IF
14351 ! Bottom
14352 ! Area preserving cubic with 2nd deriv. = 0 at the surface
14353  DO i=i1,i2
14354  d1 = delp(i, km)
14355  d2 = delp(i, km1)
14356  CALL pushrealarray(qm)
14357  qm = (d2*a4(1, i, km)+d1*a4(1, i, km1))/(d1+d2)
14358  CALL pushrealarray(dq)
14359  dq = 2.*(a4(1, i, km1)-a4(1, i, km))/(d1+d2)
14360  CALL pushrealarray(c1)
14361  c1 = (a4(2, i, km1)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
14362  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
14363  CALL pushrealarray(a4(2, i, km))
14364  a4(2, i, km) = qm - c1*d1*d2*(d2+3.*d1)
14365 ! Bottom edge:
14366 !-----------------------------------------------------
14367  CALL pushrealarray(a4(3, i, km))
14368  a4(3, i, km) = d1*(8.*c1*d1**2-c3) + a4(2, i, km)
14369  IF (a4(1, i, km) .GT. a4(1, i, km1)) THEN
14370  y4 = a4(1, i, km1)
14371  CALL pushcontrol(1,0)
14372  ELSE
14373  y4 = a4(1, i, km)
14374  CALL pushcontrol(1,1)
14375  END IF
14376  IF (a4(2, i, km) .LT. y4) THEN
14377  CALL pushrealarray(a4(2, i, km))
14378  a4(2, i, km) = y4
14379  CALL pushcontrol(1,0)
14380  ELSE
14381  CALL pushrealarray(a4(2, i, km))
14382  a4(2, i, km) = a4(2, i, km)
14383  CALL pushcontrol(1,1)
14384  END IF
14385  IF (a4(1, i, km) .LT. a4(1, i, km1)) THEN
14386  y5 = a4(1, i, km1)
14387  CALL pushcontrol(1,0)
14388  ELSE
14389  y5 = a4(1, i, km)
14390  CALL pushcontrol(1,1)
14391  END IF
14392  IF (a4(2, i, km) .GT. y5) THEN
14393  CALL pushrealarray(a4(2, i, km))
14394  a4(2, i, km) = y5
14395  CALL pushcontrol(1,0)
14396  ELSE
14397  CALL pushrealarray(a4(2, i, km))
14398  a4(2, i, km) = a4(2, i, km)
14399  CALL pushcontrol(1,1)
14400  END IF
14401  CALL pushrealarray(dc(i, km))
14402  dc(i, km) = 0.5*(a4(1, i, km)-a4(2, i, km))
14403  END DO
14404 ! Enforce constraint on the "slope" at the surface
14405  IF (iv .EQ. 0) THEN
14406  DO i=i1,i2
14407  IF (0. .LT. a4(2, i, km)) THEN
14408  CALL pushrealarray(a4(2, i, km))
14409  a4(2, i, km) = a4(2, i, km)
14410  CALL pushcontrol(1,0)
14411  ELSE
14412  CALL pushrealarray(a4(2, i, km))
14413  a4(2, i, km) = 0.
14414  CALL pushcontrol(1,1)
14415  END IF
14416  IF (0. .LT. a4(3, i, km)) THEN
14417  CALL pushrealarray(a4(3, i, km))
14418  a4(3, i, km) = a4(3, i, km)
14419  CALL pushcontrol(1,0)
14420  ELSE
14421  CALL pushrealarray(a4(3, i, km))
14422  a4(3, i, km) = 0.
14423  CALL pushcontrol(1,1)
14424  END IF
14425  END DO
14426  CALL pushcontrol(2,2)
14427  ELSE IF (iv .LT. 0) THEN
14428  DO i=i1,i2
14429  IF (a4(1, i, km)*a4(3, i, km) .LE. 0.) THEN
14430  CALL pushrealarray(a4(3, i, km))
14431  a4(3, i, km) = 0.
14432  CALL pushcontrol(1,1)
14433  ELSE
14434  CALL pushcontrol(1,0)
14435  END IF
14436  END DO
14437  CALL pushcontrol(2,1)
14438  ELSE
14439  CALL pushcontrol(2,0)
14440  END IF
14441  DO k=1,km1
14442  DO i=i1,i2
14443  CALL pushrealarray(a4(3, i, k))
14444  a4(3, i, k) = a4(2, i, k+1)
14445  END DO
14446  END DO
14447 !-----------------------------------------------------------
14448 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
14449 !-----------------------------------------------------------
14450 ! Top 2 and bottom 2 layers always use monotonic mapping
14451  DO k=1,2
14452  DO i=i1,i2
14453  CALL pushrealarray(a4(4, i, k))
14454  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
14455  END DO
14456  CALL ppm_limiters_fwd(dc(i1, k), a4(1, i1, k), it, 0)
14457  END DO
14458  IF (kord .GE. 7) THEN
14459 !-----------------------
14460 ! Huynh's 2nd constraint
14461 !-----------------------
14462  DO k=2,km1
14463  DO i=i1,i2
14464 ! Method#1
14465 ! h2(i,k) = delq(i,k) - delq(i,k-1)
14466 ! Method#2 - better
14467  h2(i, k) = 2.*(dc(i, k+1)/delp(i, k+1)-dc(i, k-1)/delp(i, k-1)&
14468 & )/(delp(i, k)+0.5*(delp(i, k-1)+delp(i, k+1)))*delp(i, k)**2
14469  END DO
14470  END DO
14471 ! Method#3
14472 !!! h2(i,k) = dc(i,k+1) - dc(i,k-1)
14473 ! original quasi-monotone
14474  fac = 1.5
14475  DO k=3,km-2
14476  DO i=i1,i2
14477 ! Right edges
14478 ! qmp = a4(1,i,k) + 2.0*delq(i,k-1)
14479 ! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
14480 !
14481  pmp = 2.*dc(i, k)
14482  qmp = a4(1, i, k) + pmp
14483  lac = a4(1, i, k) + fac*h2(i, k-1) + dc(i, k)
14484  IF (a4(1, i, k) .GT. qmp) THEN
14485  IF (qmp .GT. lac) THEN
14486  y8 = lac
14487  CALL pushcontrol(2,0)
14488  ELSE
14489  y8 = qmp
14490  CALL pushcontrol(2,1)
14491  END IF
14492  ELSE IF (a4(1, i, k) .GT. lac) THEN
14493  y8 = lac
14494  CALL pushcontrol(2,2)
14495  ELSE
14496  y8 = a4(1, i, k)
14497  CALL pushcontrol(2,3)
14498  END IF
14499  IF (a4(3, i, k) .LT. y8) THEN
14500  x2 = y8
14501  CALL pushcontrol(1,0)
14502  ELSE
14503  x2 = a4(3, i, k)
14504  CALL pushcontrol(1,1)
14505  END IF
14506  IF (a4(1, i, k) .LT. qmp) THEN
14507  IF (qmp .LT. lac) THEN
14508  y6 = lac
14509  CALL pushcontrol(2,0)
14510  ELSE
14511  y6 = qmp
14512  CALL pushcontrol(2,1)
14513  END IF
14514  ELSE IF (a4(1, i, k) .LT. lac) THEN
14515  y6 = lac
14516  CALL pushcontrol(2,2)
14517  ELSE
14518  y6 = a4(1, i, k)
14519  CALL pushcontrol(2,3)
14520  END IF
14521  IF (x2 .GT. y6) THEN
14522  CALL pushrealarray(a4(3, i, k))
14523  a4(3, i, k) = y6
14524  CALL pushcontrol(1,0)
14525  ELSE
14526  CALL pushrealarray(a4(3, i, k))
14527  a4(3, i, k) = x2
14528  CALL pushcontrol(1,1)
14529  END IF
14530 ! Left edges
14531 ! qmp = a4(1,i,k) - 2.0*delq(i,k)
14532 ! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
14533 !
14534  qmp = a4(1, i, k) - pmp
14535  lac = a4(1, i, k) + fac*h2(i, k+1) - dc(i, k)
14536  IF (a4(1, i, k) .GT. qmp) THEN
14537  IF (qmp .GT. lac) THEN
14538  y9 = lac
14539  CALL pushcontrol(2,0)
14540  ELSE
14541  y9 = qmp
14542  CALL pushcontrol(2,1)
14543  END IF
14544  ELSE IF (a4(1, i, k) .GT. lac) THEN
14545  y9 = lac
14546  CALL pushcontrol(2,2)
14547  ELSE
14548  y9 = a4(1, i, k)
14549  CALL pushcontrol(2,3)
14550  END IF
14551  IF (a4(2, i, k) .LT. y9) THEN
14552  x3 = y9
14553  CALL pushcontrol(1,0)
14554  ELSE
14555  x3 = a4(2, i, k)
14556  CALL pushcontrol(1,1)
14557  END IF
14558  IF (a4(1, i, k) .LT. qmp) THEN
14559  IF (qmp .LT. lac) THEN
14560  y7 = lac
14561  CALL pushcontrol(2,0)
14562  ELSE
14563  y7 = qmp
14564  CALL pushcontrol(2,1)
14565  END IF
14566  ELSE IF (a4(1, i, k) .LT. lac) THEN
14567  y7 = lac
14568  CALL pushcontrol(2,2)
14569  ELSE
14570  y7 = a4(1, i, k)
14571  CALL pushcontrol(2,3)
14572  END IF
14573  IF (x3 .GT. y7) THEN
14574  CALL pushrealarray(a4(2, i, k))
14575  a4(2, i, k) = y7
14576  CALL pushcontrol(1,0)
14577  ELSE
14578  CALL pushrealarray(a4(2, i, k))
14579  a4(2, i, k) = x3
14580  CALL pushcontrol(1,1)
14581  END IF
14582 !-------------
14583 ! Recompute A6
14584 !-------------
14585  CALL pushrealarray(a4(4, i, k))
14586  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
14587  END DO
14588 ! Additional constraint to ensure positivity when kord=7
14589  IF (iv .EQ. 0 .AND. kord .GE. 6) THEN
14590  CALL ppm_limiters_fwd(dc(i1, k), a4(1, i1, k), it, 2)
14591  CALL pushcontrol(1,1)
14592  ELSE
14593  CALL pushcontrol(1,0)
14594  END IF
14595  END DO
14596  CALL pushcontrol(1,1)
14597  ELSE
14598  lmt = kord - 3
14599  IF (0 .LT. lmt) THEN
14600  lmt = lmt
14601  ELSE
14602  lmt = 0
14603  END IF
14604  IF (iv .EQ. 0) THEN
14605  IF (2 .GT. lmt) THEN
14606  CALL pushcontrol(1,1)
14607  lmt = lmt
14608  ELSE
14609  CALL pushcontrol(1,1)
14610  lmt = 2
14611  END IF
14612  ELSE
14613  CALL pushcontrol(1,0)
14614  END IF
14615  DO k=3,km-2
14616  IF (kord .NE. 4) THEN
14617  DO i=i1,i2
14618  CALL pushrealarray(a4(4, i, k))
14619  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
14620  END DO
14621  CALL pushcontrol(1,0)
14622  ELSE
14623  CALL pushcontrol(1,1)
14624  END IF
14625  IF (kord .NE. 6) THEN
14626  CALL ppm_limiters_fwd(dc(i1, k), a4(1, i1, k), it, lmt)
14627  CALL pushcontrol(1,1)
14628  ELSE
14629  CALL pushcontrol(1,0)
14630  END IF
14631  END DO
14632  CALL pushcontrol(1,0)
14633  END IF
14634  DO k=km1,km
14635  DO i=i1,i2
14636  CALL pushrealarray(a4(4, i, k))
14637  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
14638  END DO
14639  CALL ppm_limiters_fwd(dc(i1, k), a4(1, i1, k), it, 0)
14640  END DO
14641  CALL pushrealarray(dc, (i2-i1+1)*km)
14642  CALL pushrealarray(min1)
14643  CALL pushinteger(it)
14644  CALL pushinteger(km1)
14645  CALL pushrealarray(d4, (i2-i1+1)*km)
14646  CALL pushrealarray(fac)
14647  CALL pushrealarray(delq, (i2-i1+1)*km)
14648  CALL pushrealarray(c1)
14649  CALL pushrealarray(dq)
14650  CALL pushrealarray(df2, (i2-i1+1)*km)
14651  CALL pushrealarray(qm)
14652  END SUBROUTINE ppm_profile_fwd
14653 ! Differentiation of ppm_profile in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
14654 !_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
14655 !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
14656 !.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
14657 !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
14658 !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.
14659 !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
14660 ! 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
14661 !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
14662 !_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
14663 !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
14664 !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_
14665 !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
14666 !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.
14667 !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_
14668 !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
14669 !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
14670 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
14671 ! gradient of useful results: delp a4
14672 ! with respect to varying inputs: delp a4
14673  SUBROUTINE ppm_profile_bwd(a4, a4_ad, delp, delp_ad, km, i1, i2, iv, &
14674 & kord)
14675  IMPLICIT NONE
14676  INTEGER, INTENT(IN) :: iv
14677  INTEGER, INTENT(IN) :: i1
14678  INTEGER, INTENT(IN) :: i2
14679  INTEGER, INTENT(IN) :: km
14680  INTEGER, INTENT(IN) :: kord
14681  REAL, INTENT(IN) :: delp(i1:i2, km)
14682  REAL :: delp_ad(i1:i2, km)
14683  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
14684  REAL, INTENT(INOUT) :: a4_ad(4, i1:i2, km)
14685  REAL :: dc(i1:i2, km)
14686  REAL :: dc_ad(i1:i2, km)
14687  REAL :: h2(i1:i2, km)
14688  REAL :: h2_ad(i1:i2, km)
14689  REAL :: delq(i1:i2, km)
14690  REAL :: delq_ad(i1:i2, km)
14691  REAL :: df2(i1:i2, km)
14692  REAL :: df2_ad(i1:i2, km)
14693  REAL :: d4(i1:i2, km)
14694  REAL :: d4_ad(i1:i2, km)
14695  INTEGER :: i, k, km1, lmt, it
14696  REAL :: fac
14697  REAL :: a1, a2, c1, c2, c3, d1, d2
14698  REAL :: a1_ad, a2_ad, c1_ad, c2_ad, c3_ad, d1_ad, d2_ad
14699  REAL :: qm, dq, lac, qmp, pmp
14700  REAL :: qm_ad, dq_ad, lac_ad, qmp_ad, pmp_ad
14701  INTRINSIC abs
14702  INTRINSIC max
14703  INTRINSIC min
14704  INTRINSIC sign
14705  REAL :: min1
14706  REAL :: min1_ad
14707  INTEGER :: abs0
14708  REAL :: max1
14709  REAL :: max1_ad
14710  REAL :: min2
14711  REAL :: min2_ad
14712  REAL :: temp
14713  REAL :: temp0
14714  REAL :: temp_ad
14715  REAL :: temp_ad0
14716  REAL :: temp_ad1
14717  REAL :: temp_ad2
14718  REAL :: temp_ad3
14719  REAL :: x1_ad
14720  REAL :: y1_ad
14721  REAL :: z1_ad
14722  REAL :: temp1
14723  REAL :: temp2
14724  REAL :: temp3
14725  REAL :: temp4
14726  REAL :: temp5
14727  REAL :: temp6
14728  REAL :: temp7
14729  REAL :: temp_ad4
14730  REAL :: temp_ad5
14731  REAL :: temp_ad6
14732  REAL :: temp_ad7
14733  REAL :: temp_ad8
14734  REAL :: temp_ad9
14735  REAL :: temp_ad10
14736  REAL :: temp8
14737  REAL :: temp_ad11
14738  REAL :: temp_ad12
14739  REAL :: temp_ad13
14740  REAL :: temp_ad14
14741  REAL :: temp_ad15
14742  REAL :: temp_ad16
14743  REAL :: temp_ad17
14744  REAL :: temp_ad18
14745  REAL :: temp_ad19
14746  REAL :: temp_ad20
14747  REAL :: temp_ad21
14748  REAL :: y2_ad
14749  REAL :: y3_ad
14750  REAL :: temp9
14751  REAL :: temp_ad22
14752  REAL :: temp_ad23
14753  REAL :: temp_ad24
14754  REAL :: temp_ad25
14755  REAL :: temp_ad26
14756  REAL :: temp_ad27
14757  REAL :: temp_ad28
14758  REAL :: temp_ad29
14759  REAL :: temp_ad30
14760  REAL :: temp_ad31
14761  REAL :: temp_ad32
14762  REAL :: y4_ad
14763  REAL :: y5_ad
14764  REAL :: temp_ad33
14765  REAL :: temp10
14766  REAL :: temp11
14767  REAL :: temp12
14768  REAL :: temp13
14769  REAL :: temp14
14770  REAL :: temp15
14771  REAL :: temp16
14772  REAL :: temp_ad34
14773  REAL :: temp_ad35
14774  REAL :: temp_ad36
14775  REAL :: y8_ad
14776  REAL :: x2_ad
14777  REAL :: y6_ad
14778  REAL :: y9_ad
14779  REAL :: x3_ad
14780  REAL :: y7_ad
14781  REAL :: temp_ad37
14782  REAL :: temp_ad38
14783  REAL :: temp_ad39
14784  INTEGER :: branch
14785  REAL :: x3
14786  REAL :: x2
14787  REAL :: x1
14788  REAL :: z1
14789  REAL :: y9
14790  REAL :: y8
14791  REAL :: y7
14792  REAL :: y6
14793  REAL :: y5
14794  REAL :: y4
14795  REAL :: y3
14796  REAL :: y2
14797  REAL :: y1
14798  CALL poprealarray(qm)
14799  CALL poprealarray(df2, (i2-i1+1)*km)
14800  CALL poprealarray(dq)
14801  CALL poprealarray(c1)
14802  CALL poprealarray(delq, (i2-i1+1)*km)
14803  CALL poprealarray(fac)
14804  CALL poprealarray(d4, (i2-i1+1)*km)
14805  CALL popinteger(km1)
14806  CALL popinteger(it)
14807  CALL poprealarray(min1)
14808  CALL poprealarray(dc, (i2-i1+1)*km)
14809  dc_ad = 0.0
14810  DO k=km,km1,-1
14811  CALL ppm_limiters_bwd(dc(i1, k), dc_ad(i1, k), a4(1, i1, k), a4_ad&
14812 & (1, i1, k), it, 0)
14813  DO i=i2,i1,-1
14814  CALL poprealarray(a4(4, i, k))
14815  temp_ad39 = 3.*a4_ad(4, i, k)
14816  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad39
14817  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad39
14818  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad39
14819  a4_ad(4, i, k) = 0.0
14820  END DO
14821  END DO
14822  CALL popcontrol(1,branch)
14823  IF (branch .EQ. 0) THEN
14824  DO k=km-2,3,-1
14825  CALL popcontrol(1,branch)
14826  IF (branch .NE. 0) CALL ppm_limiters_bwd(dc(i1, k), dc_ad(i1, k)&
14827 & , a4(1, i1, k), a4_ad(1, i1, &
14828 & k), it, lmt)
14829  CALL popcontrol(1,branch)
14830  IF (branch .EQ. 0) THEN
14831  DO i=i2,i1,-1
14832  CALL poprealarray(a4(4, i, k))
14833  temp_ad38 = 3.*a4_ad(4, i, k)
14834  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad38
14835  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad38
14836  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad38
14837  a4_ad(4, i, k) = 0.0
14838  END DO
14839  END IF
14840  END DO
14841  CALL popcontrol(1,branch)
14842  ELSE
14843  h2_ad = 0.0
14844  DO k=km-2,3,-1
14845  CALL popcontrol(1,branch)
14846  IF (branch .NE. 0) CALL ppm_limiters_bwd(dc(i1, k), dc_ad(i1, k)&
14847 & , a4(1, i1, k), a4_ad(1, i1, &
14848 & k), it, 2)
14849  DO i=i2,i1,-1
14850  CALL poprealarray(a4(4, i, k))
14851  temp_ad37 = 3.*a4_ad(4, i, k)
14852  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad37
14853  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad37
14854  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad37
14855  a4_ad(4, i, k) = 0.0
14856  CALL popcontrol(1,branch)
14857  IF (branch .EQ. 0) THEN
14858  CALL poprealarray(a4(2, i, k))
14859  y7_ad = a4_ad(2, i, k)
14860  a4_ad(2, i, k) = 0.0
14861  x3_ad = 0.0
14862  ELSE
14863  CALL poprealarray(a4(2, i, k))
14864  x3_ad = a4_ad(2, i, k)
14865  a4_ad(2, i, k) = 0.0
14866  y7_ad = 0.0
14867  END IF
14868  CALL popcontrol(2,branch)
14869  IF (branch .LT. 2) THEN
14870  IF (branch .EQ. 0) THEN
14871  lac_ad = y7_ad
14872  qmp_ad = 0.0
14873  ELSE
14874  qmp_ad = y7_ad
14875  lac_ad = 0.0
14876  END IF
14877  ELSE
14878  IF (branch .EQ. 2) THEN
14879  lac_ad = y7_ad
14880  ELSE
14881  a4_ad(1, i, k) = a4_ad(1, i, k) + y7_ad
14882  lac_ad = 0.0
14883  END IF
14884  qmp_ad = 0.0
14885  END IF
14886  CALL popcontrol(1,branch)
14887  IF (branch .EQ. 0) THEN
14888  y9_ad = x3_ad
14889  ELSE
14890  a4_ad(2, i, k) = a4_ad(2, i, k) + x3_ad
14891  y9_ad = 0.0
14892  END IF
14893  CALL popcontrol(2,branch)
14894  IF (branch .LT. 2) THEN
14895  IF (branch .EQ. 0) THEN
14896  lac_ad = lac_ad + y9_ad
14897  ELSE
14898  qmp_ad = qmp_ad + y9_ad
14899  END IF
14900  ELSE IF (branch .EQ. 2) THEN
14901  lac_ad = lac_ad + y9_ad
14902  ELSE
14903  a4_ad(1, i, k) = a4_ad(1, i, k) + y9_ad
14904  END IF
14905  a4_ad(1, i, k) = a4_ad(1, i, k) + qmp_ad + lac_ad
14906  h2_ad(i, k+1) = h2_ad(i, k+1) + fac*lac_ad
14907  dc_ad(i, k) = dc_ad(i, k) - lac_ad
14908  pmp_ad = -qmp_ad
14909  CALL popcontrol(1,branch)
14910  IF (branch .EQ. 0) THEN
14911  CALL poprealarray(a4(3, i, k))
14912  y6_ad = a4_ad(3, i, k)
14913  a4_ad(3, i, k) = 0.0
14914  x2_ad = 0.0
14915  ELSE
14916  CALL poprealarray(a4(3, i, k))
14917  x2_ad = a4_ad(3, i, k)
14918  a4_ad(3, i, k) = 0.0
14919  y6_ad = 0.0
14920  END IF
14921  CALL popcontrol(2,branch)
14922  IF (branch .LT. 2) THEN
14923  IF (branch .EQ. 0) THEN
14924  lac_ad = y6_ad
14925  qmp_ad = 0.0
14926  ELSE
14927  qmp_ad = y6_ad
14928  lac_ad = 0.0
14929  END IF
14930  ELSE
14931  IF (branch .EQ. 2) THEN
14932  lac_ad = y6_ad
14933  ELSE
14934  a4_ad(1, i, k) = a4_ad(1, i, k) + y6_ad
14935  lac_ad = 0.0
14936  END IF
14937  qmp_ad = 0.0
14938  END IF
14939  CALL popcontrol(1,branch)
14940  IF (branch .EQ. 0) THEN
14941  y8_ad = x2_ad
14942  ELSE
14943  a4_ad(3, i, k) = a4_ad(3, i, k) + x2_ad
14944  y8_ad = 0.0
14945  END IF
14946  CALL popcontrol(2,branch)
14947  IF (branch .LT. 2) THEN
14948  IF (branch .EQ. 0) THEN
14949  lac_ad = lac_ad + y8_ad
14950  ELSE
14951  qmp_ad = qmp_ad + y8_ad
14952  END IF
14953  ELSE IF (branch .EQ. 2) THEN
14954  lac_ad = lac_ad + y8_ad
14955  ELSE
14956  a4_ad(1, i, k) = a4_ad(1, i, k) + y8_ad
14957  END IF
14958  pmp_ad = pmp_ad + qmp_ad
14959  a4_ad(1, i, k) = a4_ad(1, i, k) + qmp_ad + lac_ad
14960  h2_ad(i, k-1) = h2_ad(i, k-1) + fac*lac_ad
14961  dc_ad(i, k) = dc_ad(i, k) + 2.*pmp_ad + lac_ad
14962  END DO
14963  END DO
14964  DO k=km1,2,-1
14965  DO i=i2,i1,-1
14966  temp11 = delp(i, k) + 0.5*(delp(i, k-1)+delp(i, k+1))
14967  temp16 = delp(i, k)**2
14968  temp10 = temp16/temp11
14969  temp15 = delp(i, k-1)
14970  temp14 = dc(i, k-1)/temp15
14971  temp13 = delp(i, k+1)
14972  temp12 = dc(i, k+1)/temp13
14973  temp_ad34 = 2.*temp10*h2_ad(i, k)
14974  temp_ad35 = (temp12-temp14)*2.*h2_ad(i, k)/temp11
14975  temp_ad36 = -(temp10*temp_ad35)
14976  dc_ad(i, k+1) = dc_ad(i, k+1) + temp_ad34/temp13
14977  delp_ad(i, k+1) = delp_ad(i, k+1) + 0.5*temp_ad36 - temp12*&
14978 & temp_ad34/temp13
14979  dc_ad(i, k-1) = dc_ad(i, k-1) - temp_ad34/temp15
14980  delp_ad(i, k-1) = delp_ad(i, k-1) + 0.5*temp_ad36 + temp14*&
14981 & temp_ad34/temp15
14982  delp_ad(i, k) = delp_ad(i, k) + temp_ad36 + 2*delp(i, k)*&
14983 & temp_ad35
14984  h2_ad(i, k) = 0.0
14985  END DO
14986  END DO
14987  END IF
14988  DO k=2,1,-1
14989  CALL ppm_limiters_bwd(dc(i1, k), dc_ad(i1, k), a4(1, i1, k), a4_ad&
14990 & (1, i1, k), it, 0)
14991  DO i=i2,i1,-1
14992  CALL poprealarray(a4(4, i, k))
14993  temp_ad33 = 3.*a4_ad(4, i, k)
14994  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad33
14995  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad33
14996  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad33
14997  a4_ad(4, i, k) = 0.0
14998  END DO
14999  END DO
15000  DO k=km1,1,-1
15001  DO i=i2,i1,-1
15002  CALL poprealarray(a4(3, i, k))
15003  a4_ad(2, i, k+1) = a4_ad(2, i, k+1) + a4_ad(3, i, k)
15004  a4_ad(3, i, k) = 0.0
15005  END DO
15006  END DO
15007  CALL popcontrol(2,branch)
15008  IF (branch .NE. 0) THEN
15009  IF (branch .EQ. 1) THEN
15010  DO i=i2,i1,-1
15011  CALL popcontrol(1,branch)
15012  IF (branch .NE. 0) THEN
15013  CALL poprealarray(a4(3, i, km))
15014  a4_ad(3, i, km) = 0.0
15015  END IF
15016  END DO
15017  ELSE
15018  DO i=i2,i1,-1
15019  CALL popcontrol(1,branch)
15020  IF (branch .EQ. 0) THEN
15021  CALL poprealarray(a4(3, i, km))
15022  ELSE
15023  CALL poprealarray(a4(3, i, km))
15024  a4_ad(3, i, km) = 0.0
15025  END IF
15026  CALL popcontrol(1,branch)
15027  IF (branch .EQ. 0) THEN
15028  CALL poprealarray(a4(2, i, km))
15029  ELSE
15030  CALL poprealarray(a4(2, i, km))
15031  a4_ad(2, i, km) = 0.0
15032  END IF
15033  END DO
15034  END IF
15035  END IF
15036  DO i=i2,i1,-1
15037  CALL poprealarray(dc(i, km))
15038  a4_ad(1, i, km) = a4_ad(1, i, km) + 0.5*dc_ad(i, km)
15039  a4_ad(2, i, km) = a4_ad(2, i, km) - 0.5*dc_ad(i, km)
15040  dc_ad(i, km) = 0.0
15041  CALL popcontrol(1,branch)
15042  IF (branch .EQ. 0) THEN
15043  CALL poprealarray(a4(2, i, km))
15044  y5_ad = a4_ad(2, i, km)
15045  a4_ad(2, i, km) = 0.0
15046  ELSE
15047  CALL poprealarray(a4(2, i, km))
15048  y5_ad = 0.0
15049  END IF
15050  CALL popcontrol(1,branch)
15051  IF (branch .EQ. 0) THEN
15052  a4_ad(1, i, km1) = a4_ad(1, i, km1) + y5_ad
15053  ELSE
15054  a4_ad(1, i, km) = a4_ad(1, i, km) + y5_ad
15055  END IF
15056  CALL popcontrol(1,branch)
15057  IF (branch .EQ. 0) THEN
15058  CALL poprealarray(a4(2, i, km))
15059  y4_ad = a4_ad(2, i, km)
15060  a4_ad(2, i, km) = 0.0
15061  ELSE
15062  CALL poprealarray(a4(2, i, km))
15063  y4_ad = 0.0
15064  END IF
15065  CALL popcontrol(1,branch)
15066  IF (branch .EQ. 0) THEN
15067  a4_ad(1, i, km1) = a4_ad(1, i, km1) + y4_ad
15068  ELSE
15069  a4_ad(1, i, km) = a4_ad(1, i, km) + y4_ad
15070  END IF
15071  d1 = delp(i, km)
15072  d2 = delp(i, km1)
15073  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
15074  CALL poprealarray(a4(3, i, km))
15075  temp_ad22 = d1*a4_ad(3, i, km)
15076  d1_ad = c1*8.*2*d1*temp_ad22 + (8.*(c1*d1**2)-c3)*a4_ad(3, i, km)
15077  c3_ad = -temp_ad22
15078  a4_ad(2, i, km) = a4_ad(2, i, km) + a4_ad(3, i, km)
15079  a4_ad(3, i, km) = 0.0
15080  CALL poprealarray(a4(2, i, km))
15081  temp_ad23 = -((d2+3.*d1)*a4_ad(2, i, km))
15082  c1_ad = d2*d1*temp_ad23 - 2.0*(d2*(5.*d1+d2)-3.*d1**2)*c3_ad + 8.*&
15083 & d1**2*temp_ad22
15084  temp_ad24 = -(c1*d1*d2*a4_ad(2, i, km))
15085  temp_ad26 = -(2.0*c1*c3_ad)
15086  temp9 = 2.*d2**2 + d1*(d2+3.*d1)
15087  temp_ad25 = c1_ad/(d2*temp9)
15088  qm_ad = a4_ad(2, i, km) - temp_ad25
15089  a4_ad(2, i, km) = 0.0
15090  dq_ad = c3_ad - d2*temp_ad25
15091  temp_ad31 = -((a4(2, i, km1)-qm-d2*dq)*temp_ad25/(d2*temp9))
15092  temp_ad30 = d2*temp_ad31
15093  a4_ad(2, i, km1) = a4_ad(2, i, km1) + temp_ad25
15094  temp_ad32 = 2.*dq_ad/(d1+d2)
15095  temp_ad27 = -((a4(1, i, km1)-a4(1, i, km))*temp_ad32/(d1+d2))
15096  a4_ad(1, i, km1) = a4_ad(1, i, km1) + temp_ad32
15097  temp_ad29 = qm_ad/(d1+d2)
15098  a4_ad(1, i, km) = a4_ad(1, i, km) + d2*temp_ad29 - temp_ad32
15099  temp_ad28 = -((d2*a4(1, i, km)+d1*a4(1, i, km1))*temp_ad29/(d1+d2)&
15100 & )
15101  d1_ad = d1_ad + (d2*5.-3.*2*d1)*temp_ad26 + temp_ad27 + temp_ad28 &
15102 & + a4(1, i, km1)*temp_ad29 + (d1*3.+d2+3.*d1)*temp_ad30 + 3.*&
15103 & temp_ad24 + d2*c1*temp_ad23
15104  d2_ad = (2*d2+5.*d1)*temp_ad26 + temp_ad27 + temp_ad28 + a4(1, i, &
15105 & km)*temp_ad29 + (d1+2.*2*d2)*temp_ad30 + temp9*temp_ad31 - dq*&
15106 & temp_ad25 + temp_ad24 + c1*d1*temp_ad23
15107  CALL poprealarray(c1)
15108  CALL poprealarray(dq)
15109  CALL poprealarray(qm)
15110  a4_ad(1, i, km1) = a4_ad(1, i, km1) + d1*temp_ad29
15111  delp_ad(i, km1) = delp_ad(i, km1) + d2_ad
15112  delp_ad(i, km) = delp_ad(i, km) + d1_ad
15113  END DO
15114  CALL popcontrol(2,branch)
15115  IF (branch .LT. 2) THEN
15116  IF (branch .NE. 0) THEN
15117  DO i=i2,i1,-1
15118  CALL poprealarray(a4(3, i, 1))
15119  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(3, i, 1)
15120  a4_ad(3, i, 1) = 0.0
15121  CALL poprealarray(a4(2, i, 1))
15122  a4_ad(1, i, 1) = a4_ad(1, i, 1) + a4_ad(2, i, 1)
15123  a4_ad(2, i, 1) = 0.0
15124  END DO
15125  END IF
15126  ELSE IF (branch .EQ. 2) THEN
15127  DO i=i2,i1,-1
15128  CALL popcontrol(1,branch)
15129  IF (branch .NE. 0) THEN
15130  CALL poprealarray(a4(2, i, 1))
15131  a4_ad(2, i, 1) = 0.0
15132  END IF
15133  END DO
15134  ELSE
15135  DO i=i2,i1,-1
15136  CALL popcontrol(1,branch)
15137  IF (branch .EQ. 0) THEN
15138  CALL poprealarray(a4(2, i, 2))
15139  ELSE
15140  CALL poprealarray(a4(2, i, 2))
15141  a4_ad(2, i, 2) = 0.0
15142  END IF
15143  CALL popcontrol(1,branch)
15144  IF (branch .EQ. 0) THEN
15145  CALL poprealarray(a4(2, i, 1))
15146  ELSE
15147  CALL poprealarray(a4(2, i, 1))
15148  a4_ad(2, i, 1) = 0.0
15149  END IF
15150  END DO
15151  END IF
15152  DO i=i2,i1,-1
15153  CALL poprealarray(dc(i, 1))
15154  a4_ad(2, i, 2) = a4_ad(2, i, 2) + 0.5*dc_ad(i, 1)
15155  a4_ad(1, i, 1) = a4_ad(1, i, 1) - 0.5*dc_ad(i, 1)
15156  dc_ad(i, 1) = 0.0
15157  CALL popcontrol(1,branch)
15158  IF (branch .EQ. 0) THEN
15159  CALL poprealarray(a4(2, i, 2))
15160  y3_ad = a4_ad(2, i, 2)
15161  a4_ad(2, i, 2) = 0.0
15162  ELSE
15163  CALL poprealarray(a4(2, i, 2))
15164  y3_ad = 0.0
15165  END IF
15166  CALL popcontrol(1,branch)
15167  IF (branch .EQ. 0) THEN
15168  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y3_ad
15169  ELSE
15170  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y3_ad
15171  END IF
15172  CALL popcontrol(1,branch)
15173  IF (branch .EQ. 0) THEN
15174  CALL poprealarray(a4(2, i, 2))
15175  y2_ad = a4_ad(2, i, 2)
15176  a4_ad(2, i, 2) = 0.0
15177  ELSE
15178  CALL poprealarray(a4(2, i, 2))
15179  y2_ad = 0.0
15180  END IF
15181  CALL popcontrol(1,branch)
15182  IF (branch .EQ. 0) THEN
15183  a4_ad(1, i, 2) = a4_ad(1, i, 2) + y2_ad
15184  ELSE
15185  a4_ad(1, i, 1) = a4_ad(1, i, 1) + y2_ad
15186  END IF
15187  d1 = delp(i, 1)
15188  d2 = delp(i, 2)
15189  c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
15190  CALL poprealarray(a4(2, i, 1))
15191  temp_ad11 = d1*a4_ad(2, i, 1)
15192  d1_ad = c1*2.*2*d1*temp_ad11 + (2.*(c1*d1**2)-c3)*a4_ad(2, i, 1)
15193  c3_ad = -temp_ad11
15194  a4_ad(2, i, 2) = a4_ad(2, i, 2) + a4_ad(2, i, 1)
15195  a4_ad(2, i, 1) = 0.0
15196  CALL poprealarray(a4(2, i, 2))
15197  temp_ad12 = -(0.25*(d2+3.*d1)*a4_ad(2, i, 2))
15198  c1_ad = d2*d1*temp_ad12 - 0.5*(d2*(5.*d1+d2)-3.*d1**2)*c3_ad + 2.*&
15199 & d1**2*temp_ad11
15200  temp_ad13 = -(0.25*c1*d1*d2*a4_ad(2, i, 2))
15201  temp_ad15 = -(0.5*c1*c3_ad)
15202  temp8 = 2.*d2**2 + d1*(d2+3.*d1)
15203  temp_ad14 = 4.*c1_ad/(d2*temp8)
15204  qm_ad = a4_ad(2, i, 2) - temp_ad14
15205  a4_ad(2, i, 2) = 0.0
15206  dq_ad = c3_ad - d2*temp_ad14
15207  temp_ad20 = -((a4(2, i, 3)-qm-d2*dq)*temp_ad14/(d2*temp8))
15208  temp_ad19 = d2*temp_ad20
15209  a4_ad(2, i, 3) = a4_ad(2, i, 3) + temp_ad14
15210  temp_ad21 = 2.*dq_ad/(d1+d2)
15211  temp_ad16 = -((a4(1, i, 2)-a4(1, i, 1))*temp_ad21/(d1+d2))
15212  a4_ad(1, i, 2) = a4_ad(1, i, 2) + temp_ad21
15213  temp_ad18 = qm_ad/(d1+d2)
15214  a4_ad(1, i, 1) = a4_ad(1, i, 1) + d2*temp_ad18 - temp_ad21
15215  temp_ad17 = -((d2*a4(1, i, 1)+d1*a4(1, i, 2))*temp_ad18/(d1+d2))
15216  d1_ad = d1_ad + (d2*5.-3.*2*d1)*temp_ad15 + temp_ad16 + temp_ad17 &
15217 & + a4(1, i, 2)*temp_ad18 + (d1*3.+d2+3.*d1)*temp_ad19 + 3.*&
15218 & temp_ad13 + d2*c1*temp_ad12
15219  d2_ad = (2*d2+5.*d1)*temp_ad15 + temp_ad16 + temp_ad17 + a4(1, i, &
15220 & 1)*temp_ad18 + (d1+2.*2*d2)*temp_ad19 + temp8*temp_ad20 - dq*&
15221 & temp_ad14 + temp_ad13 + c1*d1*temp_ad12
15222  CALL poprealarray(c1)
15223  CALL poprealarray(dq)
15224  CALL poprealarray(qm)
15225  a4_ad(1, i, 2) = a4_ad(1, i, 2) + d1*temp_ad18
15226  delp_ad(i, 2) = delp_ad(i, 2) + d2_ad
15227  delp_ad(i, 1) = delp_ad(i, 1) + d1_ad
15228  END DO
15229  delq_ad = 0.0
15230  d4_ad = 0.0
15231  DO k=km1,3,-1
15232  DO i=i2,i1,-1
15233  temp2 = d4(i, k)
15234  temp1 = delq(i, k-1)/temp2
15235  temp4 = d4(i, k) + delp(i, k)
15236  c1 = delq(i, k-1)*delp(i, k-1)/d4(i, k)
15237  a1 = d4(i, k-1)/(d4(i, k)+delp(i, k-1))
15238  a2 = d4(i, k+1)/(d4(i, k)+delp(i, k))
15239  temp7 = d4(i, k-1) + d4(i, k+1)
15240  temp6 = a1*dc(i, k)
15241  temp5 = c1*(a1-a2) + a2*dc(i, k-1)
15242  temp_ad4 = 2.*a4_ad(2, i, k)/temp7
15243  temp_ad5 = delp(i, k)*temp_ad4
15244  temp_ad6 = -(delp(i, k-1)*temp_ad4)
15245  temp_ad7 = -((delp(i, k)*temp5-delp(i, k-1)*temp6)*temp_ad4/&
15246 & temp7)
15247  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + a4_ad(2, i, k)
15248  c1_ad = (a1-a2)*temp_ad5 + a4_ad(2, i, k)
15249  delp_ad(i, k) = delp_ad(i, k) + temp5*temp_ad4
15250  a1_ad = dc(i, k)*temp_ad6 + c1*temp_ad5
15251  a2_ad = (dc(i, k-1)-c1)*temp_ad5
15252  dc_ad(i, k-1) = dc_ad(i, k-1) + a2*temp_ad5
15253  delp_ad(i, k-1) = delp_ad(i, k-1) - temp6*temp_ad4
15254  dc_ad(i, k) = dc_ad(i, k) + a1*temp_ad6
15255  d4_ad(i, k-1) = d4_ad(i, k-1) + temp_ad7
15256  d4_ad(i, k+1) = d4_ad(i, k+1) + a2_ad/temp4 + temp_ad7
15257  a4_ad(2, i, k) = 0.0
15258  temp_ad8 = -(d4(i, k+1)*a2_ad/temp4**2)
15259  d4_ad(i, k) = d4_ad(i, k) + temp_ad8
15260  delp_ad(i, k) = delp_ad(i, k) + temp_ad8
15261  temp3 = d4(i, k) + delp(i, k-1)
15262  temp_ad9 = -(d4(i, k-1)*a1_ad/temp3**2)
15263  d4_ad(i, k-1) = d4_ad(i, k-1) + a1_ad/temp3
15264  delp_ad(i, k-1) = delp_ad(i, k-1) + temp1*c1_ad + temp_ad9
15265  temp_ad10 = delp(i, k-1)*c1_ad/temp2
15266  d4_ad(i, k) = d4_ad(i, k) + temp_ad9 - temp1*temp_ad10
15267  delq_ad(i, k-1) = delq_ad(i, k-1) + temp_ad10
15268  END DO
15269  END DO
15270  df2_ad = 0.0
15271  DO k=km1,2,-1
15272  DO i=i2,i1,-1
15273  min1_ad = sign(1.d0, min1*df2(i, k))*dc_ad(i, k)
15274  dc_ad(i, k) = 0.0
15275  CALL popcontrol(2,branch)
15276  IF (branch .LT. 2) THEN
15277  IF (branch .EQ. 0) THEN
15278  CALL poprealarray(min1)
15279  z1_ad = min1_ad
15280  y1_ad = 0.0
15281  ELSE
15282  CALL poprealarray(min1)
15283  y1_ad = min1_ad
15284  z1_ad = 0.0
15285  END IF
15286  x1_ad = 0.0
15287  ELSE
15288  IF (branch .EQ. 2) THEN
15289  CALL poprealarray(min1)
15290  z1_ad = min1_ad
15291  x1_ad = 0.0
15292  ELSE
15293  CALL poprealarray(min1)
15294  x1_ad = min1_ad
15295  z1_ad = 0.0
15296  END IF
15297  y1_ad = 0.0
15298  END IF
15299  a4_ad(1, i, k) = a4_ad(1, i, k) + z1_ad
15300  min2_ad = -z1_ad
15301  CALL popcontrol(2,branch)
15302  IF (branch .LT. 2) THEN
15303  IF (branch .EQ. 0) THEN
15304  a4_ad(1, i, k+1) = a4_ad(1, i, k+1) + min2_ad
15305  ELSE
15306  a4_ad(1, i, k) = a4_ad(1, i, k) + min2_ad
15307  END IF
15308  ELSE IF (branch .EQ. 2) THEN
15309  a4_ad(1, i, k+1) = a4_ad(1, i, k+1) + min2_ad
15310  ELSE
15311  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + min2_ad
15312  END IF
15313  max1_ad = y1_ad
15314  a4_ad(1, i, k) = a4_ad(1, i, k) - y1_ad
15315  CALL popcontrol(2,branch)
15316  IF (branch .LT. 2) THEN
15317  IF (branch .EQ. 0) THEN
15318  a4_ad(1, i, k+1) = a4_ad(1, i, k+1) + max1_ad
15319  ELSE
15320  a4_ad(1, i, k) = a4_ad(1, i, k) + max1_ad
15321  END IF
15322  ELSE IF (branch .EQ. 2) THEN
15323  a4_ad(1, i, k+1) = a4_ad(1, i, k+1) + max1_ad
15324  ELSE
15325  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + max1_ad
15326  END IF
15327  CALL popcontrol(1,branch)
15328  IF (branch .EQ. 0) THEN
15329  df2_ad(i, k) = df2_ad(i, k) + x1_ad
15330  ELSE
15331  df2_ad(i, k) = df2_ad(i, k) - x1_ad
15332  END IF
15333  c1 = (delp(i, k-1)+0.5*delp(i, k))/d4(i, k+1)
15334  c2 = (delp(i, k+1)+0.5*delp(i, k))/d4(i, k)
15335  temp0 = d4(i, k) + delp(i, k+1)
15336  temp = delp(i, k)/temp0
15337  temp_ad = temp*df2_ad(i, k)
15338  temp_ad0 = (c1*delq(i, k)+c2*delq(i, k-1))*df2_ad(i, k)/temp0
15339  temp_ad1 = -(temp*temp_ad0)
15340  c1_ad = delq(i, k)*temp_ad
15341  delq_ad(i, k) = delq_ad(i, k) + c1*temp_ad
15342  c2_ad = delq(i, k-1)*temp_ad
15343  delq_ad(i, k-1) = delq_ad(i, k-1) + c2*temp_ad
15344  delp_ad(i, k) = delp_ad(i, k) + temp_ad0
15345  df2_ad(i, k) = 0.0
15346  temp_ad2 = c2_ad/d4(i, k)
15347  d4_ad(i, k) = d4_ad(i, k) + temp_ad1 - (delp(i, k+1)+0.5*delp(i&
15348 & , k))*temp_ad2/d4(i, k)
15349  delp_ad(i, k+1) = delp_ad(i, k+1) + temp_ad2 + temp_ad1
15350  delp_ad(i, k) = delp_ad(i, k) + 0.5*temp_ad2
15351  temp_ad3 = c1_ad/d4(i, k+1)
15352  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad3
15353  delp_ad(i, k) = delp_ad(i, k) + 0.5*temp_ad3
15354  d4_ad(i, k+1) = d4_ad(i, k+1) - (delp(i, k-1)+0.5*delp(i, k))*&
15355 & temp_ad3/d4(i, k+1)
15356  END DO
15357  END DO
15358  DO k=km,2,-1
15359  DO i=i2,i1,-1
15360  delp_ad(i, k-1) = delp_ad(i, k-1) + d4_ad(i, k)
15361  delp_ad(i, k) = delp_ad(i, k) + d4_ad(i, k)
15362  d4_ad(i, k) = 0.0
15363  a4_ad(1, i, k) = a4_ad(1, i, k) + delq_ad(i, k-1)
15364  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) - delq_ad(i, k-1)
15365  delq_ad(i, k-1) = 0.0
15366  END DO
15367  END DO
15368  END SUBROUTINE ppm_profile_bwd
15369 ! Differentiation of ppm_limiters in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
15370 !_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
15371 !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
15372 !.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
15373 !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
15374 !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.
15375 !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
15376 ! 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
15377 !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
15378 !_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
15379 !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
15380 !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_
15381 !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
15382 !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.
15383 !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_
15384 !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
15385 !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
15386 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15387 ! gradient of useful results: dm a4
15388 ! with respect to varying inputs: dm a4
15389  SUBROUTINE ppm_limiters_fwd(dm, a4, itot, lmt)
15390  IMPLICIT NONE
15391 ! !INPUT PARAMETERS:
15392 ! the linear slope
15393  REAL, INTENT(IN) :: dm(*)
15394 ! Total Longitudes
15395  INTEGER, INTENT(IN) :: itot
15396 ! 0: Standard PPM constraint
15397  INTEGER, INTENT(IN) :: lmt
15398 ! 1: Improved full monotonicity constraint (Lin)
15399 ! 2: Positive definite constraint
15400 ! 3: do nothing (return immediately)
15401 ! !INPUT/OUTPUT PARAMETERS:
15402 ! PPM array
15403  REAL, INTENT(INOUT) :: a4(4, *)
15404 ! AA <-- a4(1,i)
15405 ! AL <-- a4(2,i)
15406 ! AR <-- a4(3,i)
15407 ! A6 <-- a4(4,i)
15408 ! !LOCAL VARIABLES:
15409  REAL :: qmp
15410  REAL :: da1, da2, a6da
15411  REAL :: fmin
15412  INTEGER :: i
15413  INTRINSIC abs
15414  INTRINSIC min
15415  INTRINSIC sign
15416  REAL :: min1
15417  REAL :: min2
15418  REAL :: abs0
15419  REAL :: x2
15420  REAL :: x1
15421  REAL :: y2
15422  REAL :: y1
15423 ! Developer: S.-J. Lin
15424  IF (lmt .EQ. 3) THEN
15425  CALL pushcontrol(3,0)
15426  ELSE IF (lmt .EQ. 0) THEN
15427 ! Standard PPM constraint
15428  DO i=1,itot
15429  IF (dm(i) .EQ. 0.) THEN
15430  CALL pushrealarray(a4(2, i))
15431  a4(2, i) = a4(1, i)
15432  CALL pushrealarray(a4(3, i))
15433  a4(3, i) = a4(1, i)
15434  CALL pushrealarray(a4(4, i))
15435  a4(4, i) = 0.
15436  CALL pushcontrol(2,3)
15437  ELSE
15438  da1 = a4(3, i) - a4(2, i)
15439  da2 = da1**2
15440  a6da = a4(4, i)*da1
15441  IF (a6da .LT. -da2) THEN
15442  CALL pushrealarray(a4(4, i))
15443  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
15444  CALL pushrealarray(a4(3, i))
15445  a4(3, i) = a4(2, i) - a4(4, i)
15446  CALL pushcontrol(2,2)
15447  ELSE IF (a6da .GT. da2) THEN
15448  CALL pushrealarray(a4(4, i))
15449  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
15450  CALL pushrealarray(a4(2, i))
15451  a4(2, i) = a4(3, i) - a4(4, i)
15452  CALL pushcontrol(2,1)
15453  ELSE
15454  CALL pushcontrol(2,0)
15455  END IF
15456  END IF
15457  END DO
15458  CALL pushcontrol(3,1)
15459  ELSE IF (lmt .EQ. 1) THEN
15460 ! Improved full monotonicity constraint (Lin 2004)
15461 ! Note: no need to provide first guess of A6 <-- a4(4,i)
15462  DO i=1,itot
15463  qmp = 2.*dm(i)
15464  IF (qmp .GE. 0.) THEN
15465  x1 = qmp
15466  CALL pushcontrol(1,0)
15467  ELSE
15468  x1 = -qmp
15469  CALL pushcontrol(1,1)
15470  END IF
15471  IF (a4(2, i) - a4(1, i) .GE. 0.) THEN
15472  y1 = a4(2, i) - a4(1, i)
15473  CALL pushcontrol(1,0)
15474  ELSE
15475  y1 = -(a4(2, i)-a4(1, i))
15476  CALL pushcontrol(1,1)
15477  END IF
15478  IF (x1 .GT. y1) THEN
15479  CALL pushrealarray(min1)
15480  min1 = y1
15481  CALL pushcontrol(1,0)
15482  ELSE
15483  CALL pushrealarray(min1)
15484  min1 = x1
15485  CALL pushcontrol(1,1)
15486  END IF
15487  CALL pushrealarray(a4(2, i))
15488  a4(2, i) = a4(1, i) - sign(min1, qmp)
15489  IF (qmp .GE. 0.) THEN
15490  x2 = qmp
15491  CALL pushcontrol(1,0)
15492  ELSE
15493  x2 = -qmp
15494  CALL pushcontrol(1,1)
15495  END IF
15496  IF (a4(3, i) - a4(1, i) .GE. 0.) THEN
15497  y2 = a4(3, i) - a4(1, i)
15498  CALL pushcontrol(1,0)
15499  ELSE
15500  y2 = -(a4(3, i)-a4(1, i))
15501  CALL pushcontrol(1,1)
15502  END IF
15503  IF (x2 .GT. y2) THEN
15504  CALL pushrealarray(min2)
15505  min2 = y2
15506  CALL pushcontrol(1,0)
15507  ELSE
15508  CALL pushrealarray(min2)
15509  min2 = x2
15510  CALL pushcontrol(1,1)
15511  END IF
15512  CALL pushrealarray(a4(3, i))
15513  a4(3, i) = a4(1, i) + sign(min2, qmp)
15514  CALL pushrealarray(a4(4, i))
15515  a4(4, i) = 3.*(2.*a4(1, i)-(a4(2, i)+a4(3, i)))
15516  END DO
15517  CALL pushrealarray(min2)
15518  CALL pushrealarray(min1)
15519  CALL pushcontrol(3,2)
15520  ELSE IF (lmt .EQ. 2) THEN
15521 ! Positive definite constraint
15522  DO i=1,itot
15523  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
15524  abs0 = a4(3, i) - a4(2, i)
15525  ELSE
15526  abs0 = -(a4(3, i)-a4(2, i))
15527  END IF
15528  IF (abs0 .LT. -a4(4, i)) THEN
15529  fmin = a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4&
15530 & , i)*r12
15531  IF (fmin .LT. 0.) THEN
15532  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
15533 & THEN
15534  CALL pushrealarray(a4(3, i))
15535  a4(3, i) = a4(1, i)
15536  CALL pushrealarray(a4(2, i))
15537  a4(2, i) = a4(1, i)
15538  CALL pushrealarray(a4(4, i))
15539  a4(4, i) = 0.
15540  CALL pushcontrol(3,4)
15541  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
15542  CALL pushrealarray(a4(4, i))
15543  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
15544  CALL pushrealarray(a4(3, i))
15545  a4(3, i) = a4(2, i) - a4(4, i)
15546  CALL pushcontrol(3,3)
15547  ELSE
15548  CALL pushrealarray(a4(4, i))
15549  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
15550  CALL pushrealarray(a4(2, i))
15551  a4(2, i) = a4(3, i) - a4(4, i)
15552  CALL pushcontrol(3,2)
15553  END IF
15554  ELSE
15555  CALL pushcontrol(3,1)
15556  END IF
15557  ELSE
15558  CALL pushcontrol(3,0)
15559  END IF
15560  END DO
15561  CALL pushcontrol(3,4)
15562  ELSE
15563  CALL pushcontrol(3,3)
15564  END IF
15565  END SUBROUTINE ppm_limiters_fwd
15566 ! Differentiation of ppm_limiters in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
15567 !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
15568 !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
15569 !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
15570 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
15571 !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
15572 !.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
15573 !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
15574 !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
15575 !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
15576 !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
15577 !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
15578 !_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_
15579 !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
15580 !.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
15581 !_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
15582 !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
15583 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
15584 ! gradient of useful results: dm a4
15585 ! with respect to varying inputs: dm a4
15586  SUBROUTINE ppm_limiters_bwd(dm, dm_ad, a4, a4_ad, itot, lmt)
15587  IMPLICIT NONE
15588  REAL, INTENT(IN) :: dm(*)
15589  REAL :: dm_ad(*)
15590  INTEGER, INTENT(IN) :: itot
15591  INTEGER, INTENT(IN) :: lmt
15592  REAL, INTENT(INOUT) :: a4(4, *)
15593  REAL, INTENT(INOUT) :: a4_ad(4, *)
15594  REAL :: qmp
15595  REAL :: qmp_ad
15596  REAL :: da1, da2, a6da
15597  REAL :: fmin
15598  INTEGER :: i
15599  INTRINSIC abs
15600  INTRINSIC min
15601  INTRINSIC sign
15602  REAL :: min1
15603  REAL :: min1_ad
15604  REAL :: min2
15605  REAL :: min2_ad
15606  REAL :: abs0
15607  REAL :: x1_ad
15608  REAL :: y1_ad
15609  REAL :: x2_ad
15610  REAL :: y2_ad
15611  REAL :: temp_ad
15612  INTEGER :: branch
15613  REAL :: x2
15614  REAL :: x1
15615  REAL :: y2
15616  REAL :: y1
15617  CALL popcontrol(3,branch)
15618  IF (branch .LT. 2) THEN
15619  IF (branch .NE. 0) THEN
15620  DO i=itot,1,-1
15621  CALL popcontrol(2,branch)
15622  IF (branch .LT. 2) THEN
15623  IF (branch .NE. 0) THEN
15624  CALL poprealarray(a4(2, i))
15625  a4_ad(3, i) = a4_ad(3, i) + a4_ad(2, i)
15626  a4_ad(4, i) = a4_ad(4, i) - a4_ad(2, i)
15627  a4_ad(2, i) = 0.0
15628  CALL poprealarray(a4(4, i))
15629  a4_ad(3, i) = a4_ad(3, i) + 3.*a4_ad(4, i)
15630  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
15631  a4_ad(4, i) = 0.0
15632  END IF
15633  ELSE IF (branch .EQ. 2) THEN
15634  CALL poprealarray(a4(3, i))
15635  a4_ad(2, i) = a4_ad(2, i) + a4_ad(3, i)
15636  a4_ad(4, i) = a4_ad(4, i) - a4_ad(3, i)
15637  a4_ad(3, i) = 0.0
15638  CALL poprealarray(a4(4, i))
15639  a4_ad(2, i) = a4_ad(2, i) + 3.*a4_ad(4, i)
15640  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
15641  a4_ad(4, i) = 0.0
15642  ELSE
15643  CALL poprealarray(a4(4, i))
15644  a4_ad(4, i) = 0.0
15645  CALL poprealarray(a4(3, i))
15646  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
15647  a4_ad(3, i) = 0.0
15648  CALL poprealarray(a4(2, i))
15649  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
15650  a4_ad(2, i) = 0.0
15651  END IF
15652  END DO
15653  END IF
15654  ELSE IF (branch .EQ. 2) THEN
15655  CALL poprealarray(min1)
15656  CALL poprealarray(min2)
15657  DO i=itot,1,-1
15658  CALL poprealarray(a4(4, i))
15659  temp_ad = 3.*a4_ad(4, i)
15660  a4_ad(1, i) = a4_ad(1, i) + 2.*temp_ad
15661  a4_ad(2, i) = a4_ad(2, i) - temp_ad
15662  a4_ad(3, i) = a4_ad(3, i) - temp_ad
15663  a4_ad(4, i) = 0.0
15664  qmp = 2.*dm(i)
15665  CALL poprealarray(a4(3, i))
15666  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
15667  min2_ad = sign(1.d0, min2*qmp)*a4_ad(3, i)
15668  a4_ad(3, i) = 0.0
15669  CALL popcontrol(1,branch)
15670  IF (branch .EQ. 0) THEN
15671  CALL poprealarray(min2)
15672  y2_ad = min2_ad
15673  x2_ad = 0.0
15674  ELSE
15675  CALL poprealarray(min2)
15676  x2_ad = min2_ad
15677  y2_ad = 0.0
15678  END IF
15679  CALL popcontrol(1,branch)
15680  IF (branch .EQ. 0) THEN
15681  a4_ad(3, i) = a4_ad(3, i) + y2_ad
15682  a4_ad(1, i) = a4_ad(1, i) - y2_ad
15683  ELSE
15684  a4_ad(1, i) = a4_ad(1, i) + y2_ad
15685  a4_ad(3, i) = a4_ad(3, i) - y2_ad
15686  END IF
15687  CALL popcontrol(1,branch)
15688  IF (branch .EQ. 0) THEN
15689  qmp_ad = x2_ad
15690  ELSE
15691  qmp_ad = -x2_ad
15692  END IF
15693  CALL poprealarray(a4(2, i))
15694  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
15695  min1_ad = -(sign(1.d0, min1*qmp)*a4_ad(2, i))
15696  a4_ad(2, i) = 0.0
15697  CALL popcontrol(1,branch)
15698  IF (branch .EQ. 0) THEN
15699  CALL poprealarray(min1)
15700  y1_ad = min1_ad
15701  x1_ad = 0.0
15702  ELSE
15703  CALL poprealarray(min1)
15704  x1_ad = min1_ad
15705  y1_ad = 0.0
15706  END IF
15707  CALL popcontrol(1,branch)
15708  IF (branch .EQ. 0) THEN
15709  a4_ad(2, i) = a4_ad(2, i) + y1_ad
15710  a4_ad(1, i) = a4_ad(1, i) - y1_ad
15711  ELSE
15712  a4_ad(1, i) = a4_ad(1, i) + y1_ad
15713  a4_ad(2, i) = a4_ad(2, i) - y1_ad
15714  END IF
15715  CALL popcontrol(1,branch)
15716  IF (branch .EQ. 0) THEN
15717  qmp_ad = qmp_ad + x1_ad
15718  ELSE
15719  qmp_ad = qmp_ad - x1_ad
15720  END IF
15721  dm_ad(i) = dm_ad(i) + 2.*qmp_ad
15722  END DO
15723  ELSE IF (branch .NE. 3) THEN
15724  DO i=itot,1,-1
15725  CALL popcontrol(3,branch)
15726  IF (branch .GE. 2) THEN
15727  IF (branch .EQ. 2) THEN
15728  CALL poprealarray(a4(2, i))
15729  a4_ad(3, i) = a4_ad(3, i) + a4_ad(2, i)
15730  a4_ad(4, i) = a4_ad(4, i) - a4_ad(2, i)
15731  a4_ad(2, i) = 0.0
15732  CALL poprealarray(a4(4, i))
15733  a4_ad(3, i) = a4_ad(3, i) + 3.*a4_ad(4, i)
15734  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
15735  a4_ad(4, i) = 0.0
15736  ELSE IF (branch .EQ. 3) THEN
15737  CALL poprealarray(a4(3, i))
15738  a4_ad(2, i) = a4_ad(2, i) + a4_ad(3, i)
15739  a4_ad(4, i) = a4_ad(4, i) - a4_ad(3, i)
15740  a4_ad(3, i) = 0.0
15741  CALL poprealarray(a4(4, i))
15742  a4_ad(2, i) = a4_ad(2, i) + 3.*a4_ad(4, i)
15743  a4_ad(1, i) = a4_ad(1, i) - 3.*a4_ad(4, i)
15744  a4_ad(4, i) = 0.0
15745  ELSE
15746  CALL poprealarray(a4(4, i))
15747  a4_ad(4, i) = 0.0
15748  CALL poprealarray(a4(2, i))
15749  a4_ad(1, i) = a4_ad(1, i) + a4_ad(2, i)
15750  a4_ad(2, i) = 0.0
15751  CALL poprealarray(a4(3, i))
15752  a4_ad(1, i) = a4_ad(1, i) + a4_ad(3, i)
15753  a4_ad(3, i) = 0.0
15754  END IF
15755  END IF
15756  END DO
15757  END IF
15758  END SUBROUTINE ppm_limiters_bwd
15759  SUBROUTINE steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
15760  IMPLICIT NONE
15761  INTEGER, INTENT(IN) :: km, i1, i2
15762 ! grid size
15763  REAL, INTENT(IN) :: dp(i1:i2, km)
15764 ! backward diff of q
15765  REAL, INTENT(IN) :: dq(i1:i2, km)
15766 ! backward sum: dp(k)+ dp(k-1)
15767  REAL, INTENT(IN) :: d4(i1:i2, km)
15768 ! first guess mismatch
15769  REAL, INTENT(IN) :: df2(i1:i2, km)
15770 ! monotonic mismatch
15771  REAL, INTENT(IN) :: dm(i1:i2, km)
15772 ! !INPUT/OUTPUT PARAMETERS:
15773 ! first guess/steepened
15774  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
15775 ! !LOCAL VARIABLES:
15776  INTEGER :: i, k
15777  REAL :: alfa(i1:i2, km)
15778  REAL :: f(i1:i2, km)
15779  REAL :: rat(i1:i2, km)
15780  REAL :: dg2
15781  INTRINSIC min
15782  INTRINSIC max
15783  REAL :: y1
15784 ! Compute ratio of dq/dp
15785  DO k=2,km
15786  DO i=i1,i2
15787  rat(i, k) = dq(i, k-1)/d4(i, k)
15788  END DO
15789  END DO
15790 ! Compute F
15791  DO k=2,km-1
15792  DO i=i1,i2
15793  f(i, k) = (rat(i, k+1)-rat(i, k))/(dp(i, k-1)+dp(i, k)+dp(i, k+1&
15794 & ))
15795  END DO
15796  END DO
15797  DO k=3,km-2
15798  DO i=i1,i2
15799  IF (f(i, k+1)*f(i, k-1) .LT. 0. .AND. df2(i, k) .NE. 0.) THEN
15800  dg2 = (f(i, k+1)-f(i, k-1))*((dp(i, k+1)-dp(i, k-1))**2+d4(i, &
15801 & k)*d4(i, k+1))
15802  IF (0.5 .GT. -(0.1875*dg2/df2(i, k))) THEN
15803  y1 = -(0.1875*dg2/df2(i, k))
15804  ELSE
15805  y1 = 0.5
15806  END IF
15807  IF (0. .LT. y1) THEN
15808  alfa(i, k) = y1
15809  ELSE
15810  alfa(i, k) = 0.
15811  END IF
15812  ELSE
15813  alfa(i, k) = 0.
15814  END IF
15815  END DO
15816  END DO
15817  DO k=4,km-2
15818  DO i=i1,i2
15819  a4(2, i, k) = (1.-alfa(i, k-1)-alfa(i, k))*a4(2, i, k) + alfa(i&
15820 & , k-1)*(a4(1, i, k)-dm(i, k)) + alfa(i, k)*(a4(1, i, k-1)+dm(i&
15821 & , k-1))
15822  END DO
15823  END DO
15824  END SUBROUTINE steepz
15825  SUBROUTINE rst_remap(km, kn, is, ie, js, je, isd, ied, jsd, jed, nq, &
15826 & ntp, delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, delp, u, v, &
15827 & w, delz, pt, q, qdiag, ak_r, bk_r, ptop, ak, bk, hydrostatic, &
15828 & make_nh, domain, square_domain)
15829  IMPLICIT NONE
15830 !------------------------------------
15831 ! Assuming hybrid sigma-P coordinate:
15832 !------------------------------------
15833 ! !INPUT PARAMETERS:
15834 ! Restart z-dimension
15835  INTEGER, INTENT(IN) :: km
15836 ! Run time dimension
15837  INTEGER, INTENT(IN) :: kn
15838 ! number of tracers (including h2o)
15839  INTEGER, INTENT(IN) :: nq, ntp
15840 ! starting & ending X-Dir index
15841  INTEGER, INTENT(IN) :: is, ie, isd, ied
15842 ! starting & ending Y-Dir index
15843  INTEGER, INTENT(IN) :: js, je, jsd, jed
15844  LOGICAL, INTENT(IN) :: hydrostatic, make_nh, square_domain
15845  REAL, INTENT(IN) :: ptop
15846  REAL, INTENT(IN) :: ak_r(km+1)
15847  REAL, INTENT(IN) :: bk_r(km+1)
15848  REAL, INTENT(IN) :: ak(kn+1)
15849  REAL, INTENT(IN) :: bk(kn+1)
15850 ! pressure thickness
15851  REAL, INTENT(IN) :: delp_r(is:ie, js:je, km)
15852 ! u-wind (m/s)
15853  REAL, INTENT(IN) :: u_r(is:ie, js:je+1, km)
15854 ! v-wind (m/s)
15855  REAL, INTENT(IN) :: v_r(is:ie+1, js:je, km)
15856  REAL, INTENT(INOUT) :: pt_r(is:ie, js:je, km)
15857  REAL, INTENT(IN) :: w_r(is:ie, js:je, km)
15858  REAL, INTENT(IN) :: q_r(is:ie, js:je, km, ntp)
15859  REAL, INTENT(IN) :: qdiag_r(is:ie, js:je, km, ntp+1:nq)
15860  REAL, INTENT(INOUT) :: delz_r(is:ie, js:je, km)
15861  TYPE(domain2d), INTENT(INOUT) :: domain
15862 ! Output:
15863 ! pressure thickness
15864  REAL, INTENT(OUT) :: delp(isd:ied, jsd:jed, kn)
15865 ! u-wind (m/s)
15866  REAL, INTENT(OUT) :: u(isd:ied, jsd:jed+1, kn)
15867 ! v-wind (m/s)
15868  REAL, INTENT(OUT) :: v(isd:ied+1, jsd:jed, kn)
15869 ! vertical velocity (m/s)
15870  REAL, INTENT(OUT) :: w(isd:, jsd:, :)
15871 ! temperature
15872  REAL, INTENT(OUT) :: pt(isd:ied, jsd:jed, kn)
15873  REAL, INTENT(OUT) :: q(isd:ied, jsd:jed, kn, ntp)
15874  REAL, INTENT(OUT) :: qdiag(isd:ied, jsd:jed, kn, ntp+1:nq)
15875 ! delta-height (m)
15876  REAL, INTENT(OUT) :: delz(isd:, jsd:, :)
15877 !-----------------------------------------------------------------------
15878  REAL :: r_vir, rgrav
15879 ! surface pressure
15880  REAL :: ps(isd:ied, jsd:jed)
15881  REAL :: pe1(is:ie, km+1)
15882  REAL :: pe2(is:ie, kn+1)
15883  REAL :: pv1(is:ie+1, km+1)
15884  REAL :: pv2(is:ie+1, kn+1)
15885  INTEGER :: i, j, k, iq
15886  INTEGER, PARAMETER :: kord=4
15887  INTRINSIC log
15888  INTEGER :: arg1
15889  r_vir = rvgas/rdgas - 1.
15890  rgrav = 1./grav
15891 !$OMP parallel do default(none) shared(is,ie,js,je,ps,ak_r)
15892  DO j=js,je
15893  DO i=is,ie
15894  ps(i, j) = ak_r(1)
15895  END DO
15896  END DO
15897 ! this OpenMP do-loop setup cannot work in it's current form....
15898 !$OMP parallel do default(none) shared(is,ie,js,je,km,ps,delp_r)
15899  DO j=js,je
15900  DO k=1,km
15901  DO i=is,ie
15902  ps(i, j) = ps(i, j) + delp_r(i, j, k)
15903  END DO
15904  END DO
15905  END DO
15906 ! only one cell is needed
15907  IF (square_domain) THEN
15908  CALL mpp_update_domains(ps, domain, complete=.true., whalo=1, &
15909 & ehalo=1, shalo=1, nhalo=1)
15910  ELSE
15911  CALL mpp_update_domains(ps, domain, complete=.true.)
15912  END IF
15913 ! Compute virtual Temp
15914 !$OMP parallel do default(none) shared(is,ie,js,je,km,pt_r,r_vir,q_r)
15915  DO k=1,km
15916  DO j=js,je
15917  DO i=is,ie
15918  pt_r(i, j, k) = pt_r(i, j, k)*(1.+r_vir*q_r(i, j, k, 1))
15919  END DO
15920  END DO
15921  END DO
15922 !$OMP parallel do default(none) shared(is,ie,js,je,km,ak_r,bk_r,ps,kn,ak,bk,u_r,u,delp, &
15923 !$OMP ntp,nq,hydrostatic,make_nh,w_r,w,delz_r,delp_r,delz, &
15924 !$OMP pt_r,pt,v_r,v,q,q_r,qdiag,qdiag_r) &
15925 !$OMP private(pe1, pe2, pv1, pv2)
15926  DO j=js,je+1
15927 !------
15928 ! map u
15929 !------
15930  DO k=1,km+1
15931  DO i=is,ie
15932  pe1(i, k) = ak_r(k) + 0.5*bk_r(k)*(ps(i, j-1)+ps(i, j))
15933  END DO
15934  END DO
15935  DO k=1,kn+1
15936  DO i=is,ie
15937  pe2(i, k) = ak(k) + 0.5*bk(k)*(ps(i, j-1)+ps(i, j))
15938  END DO
15939  END DO
15940  CALL remap_2d(km, pe1, u_r(is:ie, j:j, 1:km), kn, pe2, u(is:ie, j:&
15941 & j, 1:kn), is, ie, -1, kord)
15942 !(j < je+1)
15943  IF (j .NE. je + 1) THEN
15944 !---------------
15945 ! Hybrid sigma-p
15946 !---------------
15947  DO k=1,km+1
15948  DO i=is,ie
15949  pe1(i, k) = ak_r(k) + bk_r(k)*ps(i, j)
15950  END DO
15951  END DO
15952  DO k=1,kn+1
15953  DO i=is,ie
15954  pe2(i, k) = ak(k) + bk(k)*ps(i, j)
15955  END DO
15956  END DO
15957 !-------------
15958 ! Compute delp
15959 !-------------
15960  DO k=1,kn
15961  DO i=is,ie
15962  delp(i, j, k) = pe2(i, k+1) - pe2(i, k)
15963  END DO
15964  END DO
15965 !----------------
15966 ! Map constituents
15967 !----------------
15968  IF (nq .NE. 0) THEN
15969  DO iq=1,ntp
15970  CALL remap_2d(km, pe1, q_r(is:ie, j:j, 1:km, iq:iq), kn, pe2&
15971 & , q(is:ie, j:j, 1:kn, iq:iq), is, ie, 0, kord)
15972  END DO
15973  DO iq=ntp+1,nq
15974  CALL remap_2d(km, pe1, qdiag_r(is:ie, j:j, 1:km, iq:iq), kn&
15975 & , pe2, qdiag(is:ie, j:j, 1:kn, iq:iq), is, ie, 0, &
15976 & kord)
15977  END DO
15978  END IF
15979  IF (.NOT.hydrostatic .AND. (.NOT.make_nh)) THEN
15980 ! Remap vertical wind:
15981  CALL remap_2d(km, pe1, w_r(is:ie, j:j, 1:km), kn, pe2, w(is:ie&
15982 & , j:j, 1:kn), is, ie, -1, kord)
15983 ! Remap delz for hybrid sigma-p coordinate
15984  DO k=1,km
15985  DO i=is,ie
15986 ! ="specific volume"/grav
15987  delz_r(i, j, k) = -(delz_r(i, j, k)/delp_r(i, j, k))
15988  END DO
15989  END DO
15990  CALL remap_2d(km, pe1, delz_r(is:ie, j:j, 1:km), kn, pe2, delz&
15991 & (is:ie, j:j, 1:kn), is, ie, 1, kord)
15992  DO k=1,kn
15993  DO i=is,ie
15994  delz(i, j, k) = -(delz(i, j, k)*delp(i, j, k))
15995  END DO
15996  END DO
15997  END IF
15998 ! Geopotential conserving remap of virtual temperature:
15999  DO k=1,km+1
16000  DO i=is,ie
16001  pe1(i, k) = log(pe1(i, k))
16002  END DO
16003  END DO
16004  DO k=1,kn+1
16005  DO i=is,ie
16006  pe2(i, k) = log(pe2(i, k))
16007  END DO
16008  END DO
16009  CALL remap_2d(km, pe1, pt_r(is:ie, j:j, 1:km), kn, pe2, pt(is:ie&
16010 & , j:j, 1:kn), is, ie, 1, kord)
16011 !------
16012 ! map v
16013 !------
16014  DO k=1,km+1
16015  DO i=is,ie+1
16016  pv1(i, k) = ak_r(k) + 0.5*bk_r(k)*(ps(i-1, j)+ps(i, j))
16017  END DO
16018  END DO
16019  DO k=1,kn+1
16020  DO i=is,ie+1
16021  pv2(i, k) = ak(k) + 0.5*bk(k)*(ps(i-1, j)+ps(i, j))
16022  END DO
16023  END DO
16024  arg1 = ie + 1
16025  CALL remap_2d(km, pv1, v_r(is:ie+1, j:j, 1:km), kn, pv2, v(is:ie&
16026 & +1, j:j, 1:kn), is, arg1, -1, kord)
16027  END IF
16028  END DO
16029 !$OMP parallel do default(none) shared(is,ie,js,je,kn,pt,r_vir,q)
16030  DO k=1,kn
16031  DO j=js,je
16032  DO i=is,ie
16033  pt(i, j, k) = pt(i, j, k)/(1.+r_vir*q(i, j, k, 1))
16034  END DO
16035  END DO
16036  END DO
16037  END SUBROUTINE rst_remap
16038  SUBROUTINE remap_2d(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
16039  IMPLICIT NONE
16040  INTEGER, INTENT(IN) :: i1, i2
16041 ! Mode: 0 == constituents 1 ==others
16042  INTEGER, INTENT(IN) :: iv
16043  INTEGER, INTENT(IN) :: kord
16044 ! Original vertical dimension
16045  INTEGER, INTENT(IN) :: km
16046 ! Target vertical dimension
16047  INTEGER, INTENT(IN) :: kn
16048 ! pressure at layer edges
16049  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
16050 ! (from model top to bottom surface)
16051 ! in the original vertical coordinate
16052 ! pressure at layer edges
16053  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
16054 ! (from model top to bottom surface)
16055 ! in the new vertical coordinate
16056 ! Field input
16057  REAL, INTENT(IN) :: q1(i1:i2, km)
16058 ! Field output
16059  REAL, INTENT(OUT) :: q2(i1:i2, kn)
16060 ! !LOCAL VARIABLES:
16061  REAL :: qs(i1:i2)
16062  REAL :: dp1(i1:i2, km)
16063  REAL :: q4(4, i1:i2, km)
16064  REAL :: pl, pr, qsum, dp, esl
16065  INTEGER :: i, k, l, m, k0
16066  DO k=1,km
16067  DO i=i1,i2
16068  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
16069  q4(1, i, k) = q1(i, k)
16070  END DO
16071  END DO
16072 ! Compute vertical subgrid distribution
16073  IF (kord .GT. 7) THEN
16074  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
16075  ELSE
16076  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
16077  END IF
16078  DO i=i1,i2
16079  k0 = 1
16080  DO k=1,kn
16081  IF (pe2(i, k) .LE. pe1(i, 1)) THEN
16082 ! above old ptop:
16083  q2(i, k) = q1(i, 1)
16084  ELSE
16085  DO l=k0,km
16086 ! locate the top edge: pe2(i,k)
16087  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1&
16088 & )) THEN
16089  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
16090  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
16091 ! entire new grid is within the original grid
16092  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
16093  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4&
16094 & (2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
16095  k0 = l
16096  GOTO 555
16097  ELSE
16098 ! Fractional area...
16099  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i&
16100 & , l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*&
16101 & (1.+pl*(1.+pl))))
16102  DO m=l+1,km
16103 ! locate the bottom edge: pe2(i,k+1)
16104  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
16105 ! Whole layer..
16106  qsum = qsum + dp1(i, m)*q4(1, i, m)
16107  ELSE
16108  dp = pe2(i, k+1) - pe1(i, m)
16109  esl = dp/dp1(i, m)
16110  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-&
16111 & q4(2, i, m)+q4(4, i, m)*(1.-r23*esl)))
16112  k0 = m
16113  GOTO 123
16114  END IF
16115  END DO
16116  GOTO 123
16117  END IF
16118  END IF
16119  END DO
16120  123 q2(i, k) = qsum/(pe2(i, k+1)-pe2(i, k))
16121  END IF
16122  555 CONTINUE
16123  END DO
16124  END DO
16125  END SUBROUTINE remap_2d
16126  SUBROUTINE mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
16127  IMPLICIT NONE
16128 ! IV = 0: constituents
16129 ! IV = 1: potential temp
16130 ! IV =-1: winds
16131 ! Mass flux preserving mapping: q1(im,km) -> q2(im,kn)
16132 ! pe1: pressure at layer edges (from model top to bottom surface)
16133 ! in the original vertical coordinate
16134 ! pe2: pressure at layer edges (from model top to bottom surface)
16135 ! in the new vertical coordinate
16136  INTEGER, INTENT(IN) :: i1, i2, km, kn, kord, iv
16137  REAL, INTENT(IN) :: pe1(i1:i2, km+1), pe2(i1:i2, kn+1)
16138  REAL, INTENT(IN) :: q1(i1:i2, km)
16139  REAL, INTENT(OUT) :: q2(i1:i2, kn)
16140  REAL, INTENT(IN) :: ptop
16141 ! local
16142  REAL :: qs(i1:i2)
16143  REAL :: dp1(i1:i2, km)
16144  REAL :: a4(4, i1:i2, km)
16145  INTEGER :: i, k, l
16146  INTEGER :: k0, k1
16147  REAL :: pl, pr, tt, delp, qsum, dpsum, esl
16148  DO k=1,km
16149  DO i=i1,i2
16150  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
16151  a4(1, i, k) = q1(i, k)
16152  END DO
16153  END DO
16154  IF (kord .GT. 7) THEN
16155  CALL cs_profile(qs, a4, dp1, km, i1, i2, iv, kord)
16156  ELSE
16157  CALL ppm_profile(a4, dp1, km, i1, i2, iv, kord)
16158  END IF
16159 !------------------------------------
16160 ! Lowest layer: constant distribution
16161 !------------------------------------
16162  DO i=i1,i2
16163  k0 = 1
16164  DO k=1,kn
16165  IF (pe2(i, k) .LE. pe1(i, 1)) THEN
16166 ! above old ptop
16167  q2(i, k) = q1(i, 1)
16168  ELSE IF (pe2(i, k) .GE. pe1(i, km+1)) THEN
16169 ! Entire grid below old ps
16170  q2(i, k) = q1(i, km)
16171  ELSE
16172  DO l=k0,km
16173 ! locate the top edge at pe2(i,k)
16174  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1&
16175 & )) THEN
16176  k0 = l
16177  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
16178  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
16179 ! entire new grid is within the original grid
16180  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
16181  tt = r3*(pr*(pr+pl)+pl**2)
16182  q2(i, k) = a4(2, i, l) + 0.5*(a4(4, i, l)+a4(3, i, l)-a4&
16183 & (2, i, l))*(pr+pl) - a4(4, i, l)*tt
16184  GOTO 555
16185  ELSE
16186 ! Fractional area...
16187  delp = pe1(i, l+1) - pe2(i, k)
16188  tt = r3*(1.+pl*(1.+pl))
16189  qsum = delp*(a4(2, i, l)+0.5*(a4(4, i, l)+a4(3, i, l)-a4&
16190 & (2, i, l))*(1.+pl)-a4(4, i, l)*tt)
16191  dpsum = delp
16192  k1 = l + 1
16193  GOTO 111
16194  END IF
16195  END IF
16196  END DO
16197  111 CONTINUE
16198  DO l=k1,km
16199  IF (pe2(i, k+1) .GT. pe1(i, l+1)) THEN
16200 ! Whole layer..
16201  qsum = qsum + dp1(i, l)*q1(i, l)
16202  dpsum = dpsum + dp1(i, l)
16203  ELSE
16204  delp = pe2(i, k+1) - pe1(i, l)
16205  esl = delp/dp1(i, l)
16206  qsum = qsum + delp*(a4(2, i, l)+0.5*esl*(a4(3, i, l)-a4(2&
16207 & , i, l)+a4(4, i, l)*(1.-r23*esl)))
16208  dpsum = dpsum + delp
16209  k0 = l
16210  GOTO 123
16211  END IF
16212  END DO
16213  delp = pe2(i, k+1) - pe1(i, km+1)
16214  IF (delp .GT. 0.) THEN
16215 ! Extended below old ps
16216  qsum = qsum + delp*q1(i, km)
16217  dpsum = dpsum + delp
16218  END IF
16219  123 q2(i, k) = qsum/dpsum
16220  END IF
16221  555 CONTINUE
16222  END DO
16223  END DO
16224  END SUBROUTINE mappm
16225  SUBROUTINE ppm_profile(a4, delp, km, i1, i2, iv, kord)
16226  IMPLICIT NONE
16227 ! !INPUT PARAMETERS:
16228 ! iv =-1: winds
16229  INTEGER, INTENT(IN) :: iv
16230 ! iv = 0: positive definite scalars
16231 ! iv = 1: others
16232 ! iv = 2: w (iv=-2)
16233 ! Starting longitude
16234  INTEGER, INTENT(IN) :: i1
16235 ! Finishing longitude
16236  INTEGER, INTENT(IN) :: i2
16237 ! vertical dimension
16238  INTEGER, INTENT(IN) :: km
16239 ! Order (or more accurately method no.):
16240  INTEGER, INTENT(IN) :: kord
16241 !
16242 ! layer pressure thickness
16243  REAL, INTENT(IN) :: delp(i1:i2, km)
16244 ! !INPUT/OUTPUT PARAMETERS:
16245 ! Interpolated values
16246  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
16247 ! DESCRIPTION:
16248 !
16249 ! Perform the piecewise parabolic reconstruction
16250 !
16251 ! !REVISION HISTORY:
16252 ! S.-J. Lin revised at GFDL 2007
16253 !-----------------------------------------------------------------------
16254 ! local arrays:
16255  REAL :: dc(i1:i2, km)
16256  REAL :: h2(i1:i2, km)
16257  REAL :: delq(i1:i2, km)
16258  REAL :: df2(i1:i2, km)
16259  REAL :: d4(i1:i2, km)
16260 ! local scalars:
16261  INTEGER :: i, k, km1, lmt, it
16262  REAL :: fac
16263  REAL :: a1, a2, c1, c2, c3, d1, d2
16264  REAL :: qm, dq, lac, qmp, pmp
16265  INTRINSIC abs
16266  INTRINSIC max
16267  INTRINSIC min
16268  INTRINSIC sign
16269  REAL :: min1
16270  INTEGER :: abs0
16271  REAL :: max1
16272  REAL :: min2
16273  REAL :: x3
16274  REAL :: x2
16275  REAL :: x1
16276  REAL :: z1
16277  REAL :: y9
16278  REAL :: y8
16279  REAL :: y7
16280  REAL :: y6
16281  REAL :: y5
16282  REAL :: y4
16283  REAL :: y3
16284  REAL :: y2
16285  REAL :: y1
16286  km1 = km - 1
16287  it = i2 - i1 + 1
16288  DO k=2,km
16289  DO i=i1,i2
16290  delq(i, k-1) = a4(1, i, k) - a4(1, i, k-1)
16291  d4(i, k) = delp(i, k-1) + delp(i, k)
16292  END DO
16293  END DO
16294  DO k=2,km1
16295  DO i=i1,i2
16296  c1 = (delp(i, k-1)+0.5*delp(i, k))/d4(i, k+1)
16297  c2 = (delp(i, k+1)+0.5*delp(i, k))/d4(i, k)
16298  df2(i, k) = delp(i, k)*(c1*delq(i, k)+c2*delq(i, k-1))/(d4(i, k)&
16299 & +delp(i, k+1))
16300  IF (df2(i, k) .GE. 0.) THEN
16301  x1 = df2(i, k)
16302  ELSE
16303  x1 = -df2(i, k)
16304  END IF
16305  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
16306  IF (a4(1, i, k) .LT. a4(1, i, k+1)) THEN
16307  max1 = a4(1, i, k+1)
16308  ELSE
16309  max1 = a4(1, i, k)
16310  END IF
16311  ELSE IF (a4(1, i, k-1) .LT. a4(1, i, k+1)) THEN
16312  max1 = a4(1, i, k+1)
16313  ELSE
16314  max1 = a4(1, i, k-1)
16315  END IF
16316  y1 = max1 - a4(1, i, k)
16317  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
16318  IF (a4(1, i, k) .GT. a4(1, i, k+1)) THEN
16319  min2 = a4(1, i, k+1)
16320  ELSE
16321  min2 = a4(1, i, k)
16322  END IF
16323  ELSE IF (a4(1, i, k-1) .GT. a4(1, i, k+1)) THEN
16324  min2 = a4(1, i, k+1)
16325  ELSE
16326  min2 = a4(1, i, k-1)
16327  END IF
16328  z1 = a4(1, i, k) - min2
16329  IF (x1 .GT. y1) THEN
16330  IF (y1 .GT. z1) THEN
16331  min1 = z1
16332  ELSE
16333  min1 = y1
16334  END IF
16335  ELSE IF (x1 .GT. z1) THEN
16336  min1 = z1
16337  ELSE
16338  min1 = x1
16339  END IF
16340  dc(i, k) = sign(min1, df2(i, k))
16341  END DO
16342  END DO
16343 !-----------------------------------------------------------
16344 ! 4th order interpolation of the provisional cell edge value
16345 !-----------------------------------------------------------
16346  DO k=3,km1
16347  DO i=i1,i2
16348  c1 = delq(i, k-1)*delp(i, k-1)/d4(i, k)
16349  a1 = d4(i, k-1)/(d4(i, k)+delp(i, k-1))
16350  a2 = d4(i, k+1)/(d4(i, k)+delp(i, k))
16351  a4(2, i, k) = a4(1, i, k-1) + c1 + 2./(d4(i, k-1)+d4(i, k+1))*(&
16352 & delp(i, k)*(c1*(a1-a2)+a2*dc(i, k-1))-delp(i, k-1)*a1*dc(i, k)&
16353 & )
16354  END DO
16355  END DO
16356 ! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4)
16357 ! Area preserving cubic with 2nd deriv. = 0 at the boundaries
16358 ! Top
16359  DO i=i1,i2
16360  d1 = delp(i, 1)
16361  d2 = delp(i, 2)
16362  qm = (d2*a4(1, i, 1)+d1*a4(1, i, 2))/(d1+d2)
16363  dq = 2.*(a4(1, i, 2)-a4(1, i, 1))/(d1+d2)
16364  c1 = 4.*(a4(2, i, 3)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
16365  c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
16366  a4(2, i, 2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
16367 ! Top edge:
16368 !-------------------------------------------------------
16369  a4(2, i, 1) = d1*(2.*c1*d1**2-c3) + a4(2, i, 2)
16370  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
16371  y2 = a4(1, i, 2)
16372  ELSE
16373  y2 = a4(1, i, 1)
16374  END IF
16375  IF (a4(2, i, 2) .LT. y2) THEN
16376  a4(2, i, 2) = y2
16377  ELSE
16378  a4(2, i, 2) = a4(2, i, 2)
16379  END IF
16380  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
16381  y3 = a4(1, i, 2)
16382  ELSE
16383  y3 = a4(1, i, 1)
16384  END IF
16385  IF (a4(2, i, 2) .GT. y3) THEN
16386  a4(2, i, 2) = y3
16387  ELSE
16388  a4(2, i, 2) = a4(2, i, 2)
16389  END IF
16390  dc(i, 1) = 0.5*(a4(2, i, 2)-a4(1, i, 1))
16391  END DO
16392 ! Enforce monotonicity within the top layer
16393  IF (iv .EQ. 0) THEN
16394  DO i=i1,i2
16395  IF (0. .LT. a4(2, i, 1)) THEN
16396  a4(2, i, 1) = a4(2, i, 1)
16397  ELSE
16398  a4(2, i, 1) = 0.
16399  END IF
16400  IF (0. .LT. a4(2, i, 2)) THEN
16401  a4(2, i, 2) = a4(2, i, 2)
16402  ELSE
16403  a4(2, i, 2) = 0.
16404  END IF
16405  END DO
16406  ELSE IF (iv .EQ. -1) THEN
16407  DO i=i1,i2
16408  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
16409  END DO
16410  ELSE
16411  IF (iv .GE. 0.) THEN
16412  abs0 = iv
16413  ELSE
16414  abs0 = -iv
16415  END IF
16416  IF (abs0 .EQ. 2) THEN
16417  DO i=i1,i2
16418  a4(2, i, 1) = a4(1, i, 1)
16419  a4(3, i, 1) = a4(1, i, 1)
16420  END DO
16421  END IF
16422  END IF
16423 ! Bottom
16424 ! Area preserving cubic with 2nd deriv. = 0 at the surface
16425  DO i=i1,i2
16426  d1 = delp(i, km)
16427  d2 = delp(i, km1)
16428  qm = (d2*a4(1, i, km)+d1*a4(1, i, km1))/(d1+d2)
16429  dq = 2.*(a4(1, i, km1)-a4(1, i, km))/(d1+d2)
16430  c1 = (a4(2, i, km1)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
16431  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
16432  a4(2, i, km) = qm - c1*d1*d2*(d2+3.*d1)
16433 ! Bottom edge:
16434 !-----------------------------------------------------
16435  a4(3, i, km) = d1*(8.*c1*d1**2-c3) + a4(2, i, km)
16436  IF (a4(1, i, km) .GT. a4(1, i, km1)) THEN
16437  y4 = a4(1, i, km1)
16438  ELSE
16439  y4 = a4(1, i, km)
16440  END IF
16441  IF (a4(2, i, km) .LT. y4) THEN
16442  a4(2, i, km) = y4
16443  ELSE
16444  a4(2, i, km) = a4(2, i, km)
16445  END IF
16446  IF (a4(1, i, km) .LT. a4(1, i, km1)) THEN
16447  y5 = a4(1, i, km1)
16448  ELSE
16449  y5 = a4(1, i, km)
16450  END IF
16451  IF (a4(2, i, km) .GT. y5) THEN
16452  a4(2, i, km) = y5
16453  ELSE
16454  a4(2, i, km) = a4(2, i, km)
16455  END IF
16456  dc(i, km) = 0.5*(a4(1, i, km)-a4(2, i, km))
16457  END DO
16458 ! Enforce constraint on the "slope" at the surface
16459  IF (iv .EQ. 0) THEN
16460  DO i=i1,i2
16461  IF (0. .LT. a4(2, i, km)) THEN
16462  a4(2, i, km) = a4(2, i, km)
16463  ELSE
16464  a4(2, i, km) = 0.
16465  END IF
16466  IF (0. .LT. a4(3, i, km)) THEN
16467  a4(3, i, km) = a4(3, i, km)
16468  ELSE
16469  a4(3, i, km) = 0.
16470  END IF
16471  END DO
16472  ELSE IF (iv .LT. 0) THEN
16473  DO i=i1,i2
16474  IF (a4(1, i, km)*a4(3, i, km) .LE. 0.) a4(3, i, km) = 0.
16475  END DO
16476  END IF
16477  DO k=1,km1
16478  DO i=i1,i2
16479  a4(3, i, k) = a4(2, i, k+1)
16480  END DO
16481  END DO
16482 !-----------------------------------------------------------
16483 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
16484 !-----------------------------------------------------------
16485 ! Top 2 and bottom 2 layers always use monotonic mapping
16486  DO k=1,2
16487  DO i=i1,i2
16488  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
16489  END DO
16490  CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, 0)
16491  END DO
16492  IF (kord .GE. 7) THEN
16493 !-----------------------
16494 ! Huynh's 2nd constraint
16495 !-----------------------
16496  DO k=2,km1
16497  DO i=i1,i2
16498 ! Method#1
16499 ! h2(i,k) = delq(i,k) - delq(i,k-1)
16500 ! Method#2 - better
16501  h2(i, k) = 2.*(dc(i, k+1)/delp(i, k+1)-dc(i, k-1)/delp(i, k-1)&
16502 & )/(delp(i, k)+0.5*(delp(i, k-1)+delp(i, k+1)))*delp(i, k)**2
16503  END DO
16504  END DO
16505 ! Method#3
16506 !!! h2(i,k) = dc(i,k+1) - dc(i,k-1)
16507 ! original quasi-monotone
16508  fac = 1.5
16509  DO k=3,km-2
16510  DO i=i1,i2
16511 ! Right edges
16512 ! qmp = a4(1,i,k) + 2.0*delq(i,k-1)
16513 ! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
16514 !
16515  pmp = 2.*dc(i, k)
16516  qmp = a4(1, i, k) + pmp
16517  lac = a4(1, i, k) + fac*h2(i, k-1) + dc(i, k)
16518  IF (a4(1, i, k) .GT. qmp) THEN
16519  IF (qmp .GT. lac) THEN
16520  y8 = lac
16521  ELSE
16522  y8 = qmp
16523  END IF
16524  ELSE IF (a4(1, i, k) .GT. lac) THEN
16525  y8 = lac
16526  ELSE
16527  y8 = a4(1, i, k)
16528  END IF
16529  IF (a4(3, i, k) .LT. y8) THEN
16530  x2 = y8
16531  ELSE
16532  x2 = a4(3, i, k)
16533  END IF
16534  IF (a4(1, i, k) .LT. qmp) THEN
16535  IF (qmp .LT. lac) THEN
16536  y6 = lac
16537  ELSE
16538  y6 = qmp
16539  END IF
16540  ELSE IF (a4(1, i, k) .LT. lac) THEN
16541  y6 = lac
16542  ELSE
16543  y6 = a4(1, i, k)
16544  END IF
16545  IF (x2 .GT. y6) THEN
16546  a4(3, i, k) = y6
16547  ELSE
16548  a4(3, i, k) = x2
16549  END IF
16550 ! Left edges
16551 ! qmp = a4(1,i,k) - 2.0*delq(i,k)
16552 ! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
16553 !
16554  qmp = a4(1, i, k) - pmp
16555  lac = a4(1, i, k) + fac*h2(i, k+1) - dc(i, k)
16556  IF (a4(1, i, k) .GT. qmp) THEN
16557  IF (qmp .GT. lac) THEN
16558  y9 = lac
16559  ELSE
16560  y9 = qmp
16561  END IF
16562  ELSE IF (a4(1, i, k) .GT. lac) THEN
16563  y9 = lac
16564  ELSE
16565  y9 = a4(1, i, k)
16566  END IF
16567  IF (a4(2, i, k) .LT. y9) THEN
16568  x3 = y9
16569  ELSE
16570  x3 = a4(2, i, k)
16571  END IF
16572  IF (a4(1, i, k) .LT. qmp) THEN
16573  IF (qmp .LT. lac) THEN
16574  y7 = lac
16575  ELSE
16576  y7 = qmp
16577  END IF
16578  ELSE IF (a4(1, i, k) .LT. lac) THEN
16579  y7 = lac
16580  ELSE
16581  y7 = a4(1, i, k)
16582  END IF
16583  IF (x3 .GT. y7) THEN
16584  a4(2, i, k) = y7
16585  ELSE
16586  a4(2, i, k) = x3
16587  END IF
16588 !-------------
16589 ! Recompute A6
16590 !-------------
16591  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
16592  END DO
16593 ! Additional constraint to ensure positivity when kord=7
16594  IF (iv .EQ. 0 .AND. kord .GE. 6) CALL ppm_limiters(dc(i1, k), a4&
16595 & (1, i1, k), it, 2)
16596  END DO
16597  ELSE
16598  lmt = kord - 3
16599  IF (0 .LT. lmt) THEN
16600  lmt = lmt
16601  ELSE
16602  lmt = 0
16603  END IF
16604  IF (iv .EQ. 0) THEN
16605  IF (2 .GT. lmt) THEN
16606  lmt = lmt
16607  ELSE
16608  lmt = 2
16609  END IF
16610  END IF
16611  DO k=3,km-2
16612  IF (kord .NE. 4) THEN
16613  DO i=i1,i2
16614  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
16615  END DO
16616  END IF
16617  IF (kord .NE. 6) CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, &
16618 & lmt)
16619  END DO
16620  END IF
16621  DO k=km1,km
16622  DO i=i1,i2
16623  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
16624  END DO
16625  CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, 0)
16626  END DO
16627  END SUBROUTINE ppm_profile
16628  SUBROUTINE ppm_limiters(dm, a4, itot, lmt)
16629  IMPLICIT NONE
16630 ! !INPUT PARAMETERS:
16631 ! the linear slope
16632  REAL, INTENT(IN) :: dm(*)
16633 ! Total Longitudes
16634  INTEGER, INTENT(IN) :: itot
16635 ! 0: Standard PPM constraint
16636  INTEGER, INTENT(IN) :: lmt
16637 ! 1: Improved full monotonicity constraint (Lin)
16638 ! 2: Positive definite constraint
16639 ! 3: do nothing (return immediately)
16640 ! !INPUT/OUTPUT PARAMETERS:
16641 ! PPM array
16642  REAL, INTENT(INOUT) :: a4(4, *)
16643 ! AA <-- a4(1,i)
16644 ! AL <-- a4(2,i)
16645 ! AR <-- a4(3,i)
16646 ! A6 <-- a4(4,i)
16647 ! !LOCAL VARIABLES:
16648  REAL :: qmp
16649  REAL :: da1, da2, a6da
16650  REAL :: fmin
16651  INTEGER :: i
16652  INTRINSIC abs
16653  INTRINSIC min
16654  INTRINSIC sign
16655  REAL :: min1
16656  REAL :: min2
16657  REAL :: abs0
16658  REAL :: x2
16659  REAL :: x1
16660  REAL :: y2
16661  REAL :: y1
16662 ! Developer: S.-J. Lin
16663  IF (lmt .EQ. 3) THEN
16664  RETURN
16665  ELSE IF (lmt .EQ. 0) THEN
16666 ! Standard PPM constraint
16667  DO i=1,itot
16668  IF (dm(i) .EQ. 0.) THEN
16669  a4(2, i) = a4(1, i)
16670  a4(3, i) = a4(1, i)
16671  a4(4, i) = 0.
16672  ELSE
16673  da1 = a4(3, i) - a4(2, i)
16674  da2 = da1**2
16675  a6da = a4(4, i)*da1
16676  IF (a6da .LT. -da2) THEN
16677  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
16678  a4(3, i) = a4(2, i) - a4(4, i)
16679  ELSE IF (a6da .GT. da2) THEN
16680  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
16681  a4(2, i) = a4(3, i) - a4(4, i)
16682  END IF
16683  END IF
16684  END DO
16685  ELSE IF (lmt .EQ. 1) THEN
16686 ! Improved full monotonicity constraint (Lin 2004)
16687 ! Note: no need to provide first guess of A6 <-- a4(4,i)
16688  DO i=1,itot
16689  qmp = 2.*dm(i)
16690  IF (qmp .GE. 0.) THEN
16691  x1 = qmp
16692  ELSE
16693  x1 = -qmp
16694  END IF
16695  IF (a4(2, i) - a4(1, i) .GE. 0.) THEN
16696  y1 = a4(2, i) - a4(1, i)
16697  ELSE
16698  y1 = -(a4(2, i)-a4(1, i))
16699  END IF
16700  IF (x1 .GT. y1) THEN
16701  min1 = y1
16702  ELSE
16703  min1 = x1
16704  END IF
16705  a4(2, i) = a4(1, i) - sign(min1, qmp)
16706  IF (qmp .GE. 0.) THEN
16707  x2 = qmp
16708  ELSE
16709  x2 = -qmp
16710  END IF
16711  IF (a4(3, i) - a4(1, i) .GE. 0.) THEN
16712  y2 = a4(3, i) - a4(1, i)
16713  ELSE
16714  y2 = -(a4(3, i)-a4(1, i))
16715  END IF
16716  IF (x2 .GT. y2) THEN
16717  min2 = y2
16718  ELSE
16719  min2 = x2
16720  END IF
16721  a4(3, i) = a4(1, i) + sign(min2, qmp)
16722  a4(4, i) = 3.*(2.*a4(1, i)-(a4(2, i)+a4(3, i)))
16723  END DO
16724  ELSE IF (lmt .EQ. 2) THEN
16725 ! Positive definite constraint
16726  DO i=1,itot
16727  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
16728  abs0 = a4(3, i) - a4(2, i)
16729  ELSE
16730  abs0 = -(a4(3, i)-a4(2, i))
16731  END IF
16732  IF (abs0 .LT. -a4(4, i)) THEN
16733  fmin = a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4&
16734 & , i)*r12
16735  IF (fmin .LT. 0.) THEN
16736  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
16737 & THEN
16738  a4(3, i) = a4(1, i)
16739  a4(2, i) = a4(1, i)
16740  a4(4, i) = 0.
16741  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
16742  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
16743  a4(3, i) = a4(2, i) - a4(4, i)
16744  ELSE
16745  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
16746  a4(2, i) = a4(3, i) - a4(4, i)
16747  END IF
16748  END IF
16749  END IF
16750  END DO
16751  END IF
16752  END SUBROUTINE ppm_limiters
16753  SUBROUTINE moist_cv(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum&
16754 & , liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cvm, t1)
16755  IMPLICIT NONE
16756  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed, km, nwat, j, k
16757  INTEGER, INTENT(IN) :: sphum, liq_wat, rainwat, ice_wat, snowwat, &
16758 & graupel
16759  REAL, DIMENSION(isd:ied, jsd:jed, km, nwat), INTENT(IN) :: q
16760  REAL, DIMENSION(is:ie), INTENT(OUT) :: cvm, qd
16761  REAL, INTENT(IN), OPTIONAL :: t1(is:ie)
16762 !
16763  REAL, PARAMETER :: t_i0=15.
16764  REAL, DIMENSION(is:ie) :: qv, ql, qs
16765  INTEGER :: i
16766  INTRINSIC PRESENT
16767  INTRINSIC max
16768  SELECT CASE (nwat)
16769  CASE (2)
16770  IF (PRESENT(t1)) THEN
16771 ! Special case for GFS physics
16772  DO i=is,ie
16773  IF (0. .LT. q(i, j, k, liq_wat)) THEN
16774  qd(i) = q(i, j, k, liq_wat)
16775  ELSE
16776  qd(i) = 0.
16777  END IF
16778  IF (t1(i) .GT. tice) THEN
16779  qs(i) = 0.
16780  ELSE IF (t1(i) .LT. tice - t_i0) THEN
16781  qs(i) = qd(i)
16782  ELSE
16783  qs(i) = qd(i)*(tice-t1(i))/t_i0
16784  END IF
16785  ql(i) = qd(i) - qs(i)
16786  IF (0. .LT. q(i, j, k, sphum)) THEN
16787  qv(i) = q(i, j, k, sphum)
16788  ELSE
16789  qv(i) = 0.
16790  END IF
16791  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*&
16792 & c_liq + qs(i)*c_ice
16793  END DO
16794  ELSE
16795  DO i=is,ie
16796  IF (0. .LT. q(i, j, k, sphum)) THEN
16797  qv(i) = q(i, j, k, sphum)
16798  ELSE
16799  qv(i) = 0.
16800  END IF
16801  IF (0. .LT. q(i, j, k, liq_wat)) THEN
16802  qs(i) = q(i, j, k, liq_wat)
16803  ELSE
16804  qs(i) = 0.
16805  END IF
16806  qd(i) = qs(i)
16807  cvm(i) = (1.-qv(i))*cv_air + qv(i)*cv_vap
16808  END DO
16809  END IF
16810  CASE (3)
16811  DO i=is,ie
16812  qv(i) = q(i, j, k, sphum)
16813  ql(i) = q(i, j, k, liq_wat)
16814  qs(i) = q(i, j, k, ice_wat)
16815  qd(i) = ql(i) + qs(i)
16816  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq &
16817 & + qs(i)*c_ice
16818  END DO
16819  CASE (4)
16820 ! K_warm_rain with fake ice
16821  DO i=is,ie
16822  qv(i) = q(i, j, k, sphum)
16823  qd(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
16824  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + qd(i)*c_liq
16825  END DO
16826  CASE (6)
16827  DO i=is,ie
16828  qv(i) = q(i, j, k, sphum)
16829  ql(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
16830  qs(i) = q(i, j, k, ice_wat) + q(i, j, k, snowwat) + q(i, j, k, &
16831 & graupel)
16832  qd(i) = ql(i) + qs(i)
16833  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq &
16834 & + qs(i)*c_ice
16835  END DO
16836  CASE DEFAULT
16837  DO i=is,ie
16838  qd(i) = 0.
16839  cvm(i) = cv_air
16840  END DO
16841  END SELECT
16842  END SUBROUTINE moist_cv
16843  SUBROUTINE moist_cp(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum&
16844 & , liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cpm, t1)
16845  IMPLICIT NONE
16846  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed, km, nwat, j, k
16847  INTEGER, INTENT(IN) :: sphum, liq_wat, rainwat, ice_wat, snowwat, &
16848 & graupel
16849  REAL, DIMENSION(isd:ied, jsd:jed, km, nwat), INTENT(IN) :: q
16850  REAL, DIMENSION(is:ie), INTENT(OUT) :: cpm, qd
16851  REAL, INTENT(IN), OPTIONAL :: t1(is:ie)
16852 !
16853  REAL, PARAMETER :: t_i0=15.
16854  REAL, DIMENSION(is:ie) :: qv, ql, qs
16855  INTEGER :: i
16856  INTRINSIC PRESENT
16857  INTRINSIC max
16858  SELECT CASE (nwat)
16859  CASE (2)
16860  IF (PRESENT(t1)) THEN
16861 ! Special case for GFS physics
16862  DO i=is,ie
16863  IF (0. .LT. q(i, j, k, liq_wat)) THEN
16864  qd(i) = q(i, j, k, liq_wat)
16865  ELSE
16866  qd(i) = 0.
16867  END IF
16868  IF (t1(i) .GT. tice) THEN
16869  qs(i) = 0.
16870  ELSE IF (t1(i) .LT. tice - t_i0) THEN
16871  qs(i) = qd(i)
16872  ELSE
16873  qs(i) = qd(i)*(tice-t1(i))/t_i0
16874  END IF
16875  ql(i) = qd(i) - qs(i)
16876  IF (0. .LT. q(i, j, k, sphum)) THEN
16877  qv(i) = q(i, j, k, sphum)
16878  ELSE
16879  qv(i) = 0.
16880  END IF
16881  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
16882 & c_liq + qs(i)*c_ice
16883  END DO
16884  ELSE
16885  DO i=is,ie
16886  IF (0. .LT. q(i, j, k, sphum)) THEN
16887  qv(i) = q(i, j, k, sphum)
16888  ELSE
16889  qv(i) = 0.
16890  END IF
16891  IF (0. .LT. q(i, j, k, liq_wat)) THEN
16892  qs(i) = q(i, j, k, liq_wat)
16893  ELSE
16894  qs(i) = 0.
16895  END IF
16896  qd(i) = qs(i)
16897  cpm(i) = (1.-qv(i))*cp_air + qv(i)*cp_vapor
16898  END DO
16899  END IF
16900  CASE (3)
16901  DO i=is,ie
16902  qv(i) = q(i, j, k, sphum)
16903  ql(i) = q(i, j, k, liq_wat)
16904  qs(i) = q(i, j, k, ice_wat)
16905  qd(i) = ql(i) + qs(i)
16906  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
16907 & c_liq + qs(i)*c_ice
16908  END DO
16909  CASE (4)
16910 ! K_warm_rain scheme with fake ice
16911  DO i=is,ie
16912  qv(i) = q(i, j, k, sphum)
16913  qd(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
16914  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + qd(i)*&
16915 & c_liq
16916  END DO
16917  CASE (6)
16918  DO i=is,ie
16919  qv(i) = q(i, j, k, sphum)
16920  ql(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
16921  qs(i) = q(i, j, k, ice_wat) + q(i, j, k, snowwat) + q(i, j, k, &
16922 & graupel)
16923  qd(i) = ql(i) + qs(i)
16924  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
16925 & c_liq + qs(i)*c_ice
16926  END DO
16927  CASE DEFAULT
16928  DO i=is,ie
16929  qd(i) = 0.
16930  cpm(i) = cp_air
16931  END DO
16932  END SELECT
16933  END SUBROUTINE moist_cp
16934 ! Differentiation of map1_cubic in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
16935 !od.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_
16936 !mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.m
16937 !ix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh
16938 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
16939 !4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.re
16940 !map_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d f
16941 !v_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
16942 !fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_r
16943 !estart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgri
16944 !d_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_
16945 !mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mo
16946 !d.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod
16947 !.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2
16948 !a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_
16949 !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_
16950 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
16951 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
16952 ! gradient of useful results: pe1 pe2 q2
16953 ! with respect to varying inputs: pe1 pe2 q2
16954 !-----------------------------------------------------------------------
16955 !BOP
16956 ! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping
16957 !
16958 ! !INTERFACE:
16959  SUBROUTINE map1_cubic_fwd(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend&
16960 & , jbeg, jend, akap, t_var, conserv)
16961  IMPLICIT NONE
16962 !EOC
16963 ! !INPUT PARAMETERS:
16964 ! Starting longitude
16965  INTEGER, INTENT(IN) :: i1
16966 ! Finishing longitude
16967  INTEGER, INTENT(IN) :: i2
16968  REAL, INTENT(IN) :: akap
16969 ! Thermodynamic variable to remap
16970  INTEGER, INTENT(IN) :: t_var
16971 ! 1:TE 2:T 3:PT
16972  LOGICAL, INTENT(IN) :: conserv
16973 ! Current latitude
16974  INTEGER, INTENT(IN) :: j
16975  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
16976 ! Original vertical dimension
16977  INTEGER, INTENT(IN) :: km
16978 ! Target vertical dimension
16979  INTEGER, INTENT(IN) :: kn
16980 ! pressure at layer edges
16981  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
16982 ! (from model top to bottom surface)
16983 ! in the original vertical coordinate
16984 ! pressure at layer edges
16985  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
16986 ! (from model top to bottom surface)
16987 ! in the new vertical coordinate
16988 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
16989 ! !INPUT/OUTPUT PARAMETERS:
16990 ! Field output
16991  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
16992 ! !DESCRIPTION:
16993 !
16994 ! Perform Cubic Interpolation a given latitude
16995 ! pe1: pressure at layer edges (from model top to bottom surface)
16996 ! in the original vertical coordinate
16997 ! pe2: pressure at layer edges (from model top to bottom surface)
16998 ! in the new vertical coordinate
16999 !
17000 ! !REVISION HISTORY:
17001 ! 2005.11.14 Takacs Initial Code
17002 ! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable
17003 !
17004 !EOP
17005 !-----------------------------------------------------------------------
17006 !BOC
17007 !
17008 ! !LOCAL VARIABLES:
17009  REAL :: qx(i1:i2, km)
17010  REAL :: logpl1(i1:i2, km)
17011  REAL :: logpl2(i1:i2, kn)
17012  REAL :: dlogp1(i1:i2, km)
17013  REAL :: vsum1(i1:i2)
17014  REAL :: vsum2(i1:i2)
17015  REAL :: am2, am1, ap0, ap1, p, plp1, plp0, plm1, plm2, dlp0, dlm1, &
17016 & dlm2
17017  INTEGER :: i, k, lm2, lm1, lp0, lp1
17018  INTRINSIC log
17019  INTRINSIC exp
17020  INTRINSIC max
17021  INTRINSIC min
17022  INTEGER :: ad_count
17023 
17024  qx = 0.0
17025  logpl1 = 0.0
17026  logpl2 = 0.0
17027  dlogp1 = 0.0
17028  vsum1 = 0.0
17029  vsum2 = 0.0
17030  am2 = 0.0
17031  am1 = 0.0
17032  ap0 = 0.0
17033  ap1 = 0.0
17034  p = 0.0
17035  plp1 = 0.0
17036  plp0 = 0.0
17037  plm1 = 0.0
17038  plm2 = 0.0
17039  dlp0 = 0.0
17040  dlm1 = 0.0
17041  dlm2 = 0.0
17042  i = 0
17043  k = 0
17044  lm2 = 0
17045  lm1 = 0
17046  lp0 = 0
17047  lp1 = 0
17048  ad_count = 0
17049 
17050 ! Initialization
17051 ! --------------
17052  SELECT CASE (t_var)
17053  CASE (1)
17054 ! Total Energy Remapping in Log(P)
17055  DO k=1,km
17056  qx(:, k) = q2(i1:i2, j, k)
17057  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
17058  END DO
17059  DO k=1,kn
17060  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
17061  END DO
17062  DO k=1,km-1
17063  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17064  END DO
17065  CALL pushcontrol(2,1)
17066  CASE (2)
17067 ! Temperature Remapping in Log(P)
17068  DO k=1,km
17069  qx(:, k) = q2(i1:i2, j, k)
17070  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
17071  END DO
17072  DO k=1,kn
17073  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
17074  END DO
17075  DO k=1,km-1
17076  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17077  END DO
17078  CALL pushcontrol(2,2)
17079  CASE (3)
17080 ! Potential Temperature Remapping in P^KAPPA
17081  DO k=1,km
17082  qx(:, k) = q2(i1:i2, j, k)
17083  logpl1(:, k) = exp(akap*log(r2*(pe1(:, k)+pe1(:, k+1))))
17084  END DO
17085  DO k=1,kn
17086  logpl2(:, k) = exp(akap*log(r2*(pe2(:, k)+pe2(:, k+1))))
17087  END DO
17088  DO k=1,km-1
17089  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17090  END DO
17091  CALL pushcontrol(2,3)
17092  CASE DEFAULT
17093  CALL pushcontrol(2,0)
17094  END SELECT
17095  IF (conserv) THEN
17096 ! Compute vertical integral of Input TE
17097 ! -------------------------------------
17098  vsum1(:) = r0
17099  DO i=i1,i2
17100  DO k=1,km
17101  vsum1(i) = vsum1(i) + qx(i, k)*(pe1(i, k+1)-pe1(i, k))
17102  END DO
17103  CALL pushrealarray(vsum1(i))
17104  vsum1(i) = vsum1(i)/(pe1(i, km+1)-pe1(i, 1))
17105  END DO
17106  CALL pushcontrol(1,1)
17107  ELSE
17108  CALL pushcontrol(1,0)
17109  END IF
17110 ! Interpolate TE onto target Pressures
17111 ! ------------------------------------
17112  DO i=i1,i2
17113  DO k=1,kn
17114  CALL pushinteger(lp0)
17115  lp0 = 1
17116  ad_count = 1
17117  DO WHILE (lp0 .LE. km)
17118  IF (logpl1(i, lp0) .LT. logpl2(i, k)) THEN
17119  lp0 = lp0 + 1
17120  ad_count = ad_count + 1
17121  ELSE
17122  GOTO 100
17123  END IF
17124  END DO
17125  CALL pushcontrol(1,0)
17126  CALL pushinteger(ad_count)
17127  GOTO 110
17128  100 CALL pushcontrol(1,1)
17129  CALL pushinteger(ad_count)
17130  110 IF (lp0 - 1 .LT. 1) THEN
17131  CALL pushinteger(lm1)
17132  lm1 = 1
17133  CALL pushcontrol(1,0)
17134  ELSE
17135  CALL pushinteger(lm1)
17136  lm1 = lp0 - 1
17137  CALL pushcontrol(1,1)
17138  END IF
17139  IF (lp0 .GT. km) THEN
17140  lp0 = km
17141  ELSE
17142  lp0 = lp0
17143  END IF
17144 ! Extrapolate Linearly in LogP above first model level
17145 ! ----------------------------------------------------
17146  IF (lm1 .EQ. 1 .AND. lp0 .EQ. 1) THEN
17147  CALL pushrealarray(q2(i, j, k))
17148  q2(i, j, k) = qx(i, 1) + (qx(i, 2)-qx(i, 1))*(logpl2(i, k)-&
17149 & logpl1(i, 1))/(logpl1(i, 2)-logpl1(i, 1))
17150 ! Extrapolate Linearly in LogP below last model level
17151 ! ---------------------------------------------------
17152  CALL pushcontrol(2,3)
17153  ELSE IF (lm1 .EQ. km .AND. lp0 .EQ. km) THEN
17154  CALL pushrealarray(q2(i, j, k))
17155  q2(i, j, k) = qx(i, km) + (qx(i, km)-qx(i, km-1))*(logpl2(i, k&
17156 & )-logpl1(i, km))/(logpl1(i, km)-logpl1(i, km-1))
17157 ! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km
17158 ! -----------------------------------------------------------------
17159  CALL pushcontrol(2,2)
17160  ELSE IF (lm1 .EQ. 1 .OR. lp0 .EQ. km) THEN
17161  CALL pushrealarray(q2(i, j, k))
17162  q2(i, j, k) = qx(i, lp0) + (qx(i, lm1)-qx(i, lp0))*(logpl2(i, &
17163 & k)-logpl1(i, lp0))/(logpl1(i, lm1)-logpl1(i, lp0))
17164 ! Interpolate Cubicly in LogP between other model levels
17165 ! ------------------------------------------------------
17166  CALL pushcontrol(2,1)
17167  ELSE
17168  CALL pushinteger(lp1)
17169  lp1 = lp0 + 1
17170  CALL pushinteger(lm2)
17171  lm2 = lm1 - 1
17172  CALL pushrealarray(p)
17173  p = logpl2(i, k)
17174  plp1 = logpl1(i, lp1)
17175  plp0 = logpl1(i, lp0)
17176  plm1 = logpl1(i, lm1)
17177  plm2 = logpl1(i, lm2)
17178  CALL pushrealarray(dlp0)
17179  dlp0 = dlogp1(i, lp0)
17180  CALL pushrealarray(dlm1)
17181  dlm1 = dlogp1(i, lm1)
17182  CALL pushrealarray(dlm2)
17183  dlm2 = dlogp1(i, lm2)
17184  CALL pushrealarray(ap1)
17185  ap1 = (p-plp0)*(p-plm1)*(p-plm2)/(dlp0*(dlp0+dlm1)*(dlp0+dlm1+&
17186 & dlm2))
17187  CALL pushrealarray(ap0)
17188  ap0 = (plp1-p)*(p-plm1)*(p-plm2)/(dlp0*dlm1*(dlm1+dlm2))
17189  CALL pushrealarray(am1)
17190  am1 = (plp1-p)*(plp0-p)*(p-plm2)/(dlm1*dlm2*(dlp0+dlm1))
17191  CALL pushrealarray(am2)
17192  am2 = (plp1-p)*(plp0-p)*(plm1-p)/(dlm2*(dlm1+dlm2)*(dlp0+dlm1+&
17193 & dlm2))
17194  CALL pushrealarray(q2(i, j, k))
17195  q2(i, j, k) = ap1*qx(i, lp1) + ap0*qx(i, lp0) + am1*qx(i, lm1)&
17196 & + am2*qx(i, lm2)
17197  CALL pushcontrol(2,0)
17198  END IF
17199  END DO
17200  END DO
17201  IF (conserv) THEN
17202 ! Compute vertical integral of Output TE
17203 ! --------------------------------------
17204  vsum2(:) = r0
17205  DO i=i1,i2
17206  DO k=1,kn
17207  vsum2(i) = vsum2(i) + q2(i, j, k)*(pe2(i, k+1)-pe2(i, k))
17208  END DO
17209  CALL pushrealarray(vsum2(i))
17210  vsum2(i) = vsum2(i)/(pe2(i, kn+1)-pe2(i, 1))
17211  END DO
17212 ! Adjust Final TE to conserve
17213 ! ---------------------------
17214  DO i=i1,i2
17215  DO k=1,kn
17216  CALL pushrealarray(q2(i, j, k))
17217  q2(i, j, k) = q2(i, j, k) + vsum1(i) - vsum2(i)
17218  END DO
17219  END DO
17220  CALL pushrealarray(logpl2, (i2-i1+1)*kn)
17221  CALL pushrealarray(am2)
17222  CALL pushrealarray(logpl1, (i2-i1+1)*km)
17223  CALL pushrealarray(am1)
17224  CALL pushrealarray(ap1)
17225  CALL pushrealarray(ap0)
17226  CALL pushrealarray(qx, (i2-i1+1)*km)
17227  CALL pushrealarray(dlm2)
17228  CALL pushinteger(lm2)
17229  CALL pushrealarray(dlm1)
17230  CALL pushinteger(lm1)
17231  CALL pushrealarray(p)
17232  CALL pushinteger(lp1)
17233  CALL pushrealarray(dlp0)
17234  CALL pushinteger(lp0)
17235  CALL pushcontrol(1,0)
17236  ELSE
17237  CALL pushrealarray(logpl2, (i2-i1+1)*kn)
17238  CALL pushrealarray(am2)
17239  CALL pushrealarray(logpl1, (i2-i1+1)*km)
17240  CALL pushrealarray(am1)
17241  CALL pushrealarray(ap1)
17242  CALL pushrealarray(ap0)
17243  CALL pushrealarray(qx, (i2-i1+1)*km)
17244  CALL pushrealarray(dlm2)
17245  CALL pushinteger(lm2)
17246  CALL pushrealarray(dlm1)
17247  CALL pushinteger(lm1)
17248  CALL pushrealarray(p)
17249  CALL pushinteger(lp1)
17250  CALL pushrealarray(dlp0)
17251  CALL pushinteger(lp0)
17252  CALL pushcontrol(1,1)
17253  END IF
17254  END SUBROUTINE map1_cubic_fwd
17255 ! Differentiation of map1_cubic in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
17256 !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
17257 !_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.
17258 !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
17259 !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
17260 !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
17261 !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
17262 !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
17263 ! 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_
17264 !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
17265 !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
17266 !_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
17267 !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
17268 !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
17269 !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
17270 !_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
17271 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
17272 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
17273 ! gradient of useful results: pe1 pe2 q2
17274 ! with respect to varying inputs: pe1 pe2 q2
17275 !-----------------------------------------------------------------------
17276 !BOP
17277 ! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping
17278 !
17279 ! !INTERFACE:
17280  SUBROUTINE map1_cubic_bwd(km, pe1, pe1_ad, kn, pe2, pe2_ad, q2, q2_ad&
17281 & , i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
17282  IMPLICIT NONE
17283 !EOC
17284  INTEGER, INTENT(IN) :: i1
17285  INTEGER, INTENT(IN) :: i2
17286  REAL, INTENT(IN) :: akap
17287  INTEGER, INTENT(IN) :: t_var
17288  LOGICAL, INTENT(IN) :: conserv
17289  INTEGER, INTENT(IN) :: j
17290  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
17291  INTEGER, INTENT(IN) :: km
17292  INTEGER, INTENT(IN) :: kn
17293  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
17294  REAL :: pe1_ad(i1:i2, km+1)
17295  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
17296  REAL :: pe2_ad(i1:i2, kn+1)
17297  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
17298  REAL, INTENT(INOUT) :: q2_ad(ibeg:iend, jbeg:jend, kn)
17299  REAL :: qx(i1:i2, km)
17300  REAL :: qx_ad(i1:i2, km)
17301  REAL :: logpl1(i1:i2, km)
17302  REAL :: logpl1_ad(i1:i2, km)
17303  REAL :: logpl2(i1:i2, kn)
17304  REAL :: logpl2_ad(i1:i2, kn)
17305  REAL :: dlogp1(i1:i2, km)
17306  REAL :: dlogp1_ad(i1:i2, km)
17307  REAL :: vsum1(i1:i2)
17308  REAL :: vsum1_ad(i1:i2)
17309  REAL :: vsum2(i1:i2)
17310  REAL :: vsum2_ad(i1:i2)
17311  REAL :: am2, am1, ap0, ap1, p, plp1, plp0, plm1, plm2, dlp0, dlm1, &
17312 & dlm2
17313  REAL :: am2_ad, am1_ad, ap0_ad, ap1_ad, p_ad, plp1_ad, plp0_ad, &
17314 & plm1_ad, plm2_ad, dlp0_ad, dlm1_ad, dlm2_ad
17315  INTEGER :: i, k, lm2, lm1, lp0, lp1
17316  INTRINSIC log
17317  INTRINSIC exp
17318  INTRINSIC max
17319  INTRINSIC min
17320  REAL, DIMENSION(i2-i1+1) :: temp_ad
17321  REAL, DIMENSION(i2-i1+1) :: temp_ad0
17322  REAL, DIMENSION(i2-i1+1) :: temp_ad1
17323  REAL, DIMENSION(i2-i1+1) :: temp_ad2
17324  REAL, DIMENSION(i2-i1+1) :: temp
17325  REAL, DIMENSION(i2-i1+1) :: temp_ad3
17326  REAL, DIMENSION(i2-i1+1) :: temp0
17327  REAL, DIMENSION(i2-i1+1) :: temp_ad4
17328  REAL :: temp_ad5
17329  REAL :: temp1
17330  REAL :: temp_ad6
17331  REAL :: temp2
17332  REAL :: temp3
17333  REAL :: temp4
17334  REAL :: temp_ad7
17335  REAL :: temp_ad8
17336  REAL :: temp5
17337  REAL :: temp6
17338  REAL :: temp7
17339  REAL :: temp_ad9
17340  REAL :: temp_ad10
17341  REAL :: temp8
17342  REAL :: temp9
17343  REAL :: temp10
17344  REAL :: temp_ad11
17345  REAL :: temp_ad12
17346  REAL :: temp11
17347  REAL :: temp12
17348  REAL :: temp13
17349  REAL :: temp14
17350  REAL :: temp15
17351  REAL :: temp16
17352  REAL :: temp17
17353  REAL :: temp18
17354  REAL :: temp19
17355  REAL :: temp20
17356  REAL :: temp_ad13
17357  REAL :: temp_ad14
17358  REAL :: temp_ad15
17359  REAL :: temp_ad16
17360  REAL :: temp_ad17
17361  REAL :: temp_ad18
17362  REAL :: temp_ad19
17363  REAL :: temp_ad20
17364  REAL :: temp_ad21
17365  REAL :: temp_ad22
17366  REAL :: temp_ad23
17367  REAL :: temp_ad24
17368  REAL :: temp_ad25
17369  REAL :: temp_ad26
17370  REAL :: temp_ad27
17371  REAL :: temp_ad28
17372  REAL :: temp_ad29
17373  REAL :: temp21
17374  REAL :: temp_ad30
17375  INTEGER :: ad_count
17376  INTEGER :: i0
17377  INTEGER :: branch
17378 
17379  qx = 0.0
17380  logpl1 = 0.0
17381  logpl2 = 0.0
17382  dlogp1 = 0.0
17383  vsum1 = 0.0
17384  vsum2 = 0.0
17385  am2 = 0.0
17386  am1 = 0.0
17387  ap0 = 0.0
17388  ap1 = 0.0
17389  p = 0.0
17390  plp1 = 0.0
17391  plp0 = 0.0
17392  plm1 = 0.0
17393  plm2 = 0.0
17394  dlp0 = 0.0
17395  dlm1 = 0.0
17396  dlm2 = 0.0
17397  i = 0
17398  k = 0
17399  lm2 = 0
17400  lm1 = 0
17401  lp0 = 0
17402  lp1 = 0
17403  ad_count = 0
17404  branch = 0
17405 
17406  CALL popcontrol(1,branch)
17407  IF (branch .EQ. 0) THEN
17408  CALL popinteger(lp0)
17409  CALL poprealarray(dlp0)
17410  CALL popinteger(lp1)
17411  CALL poprealarray(p)
17412  CALL popinteger(lm1)
17413  CALL poprealarray(dlm1)
17414  CALL popinteger(lm2)
17415  CALL poprealarray(dlm2)
17416  CALL poprealarray(qx, (i2-i1+1)*km)
17417  CALL poprealarray(ap0)
17418  CALL poprealarray(ap1)
17419  CALL poprealarray(am1)
17420  CALL poprealarray(logpl1, (i2-i1+1)*km)
17421  CALL poprealarray(am2)
17422  CALL poprealarray(logpl2, (i2-i1+1)*kn)
17423  vsum1_ad = 0.0
17424  vsum2_ad = 0.0
17425  DO i=i2,i1,-1
17426  DO k=kn,1,-1
17427  CALL poprealarray(q2(i, j, k))
17428  vsum1_ad(i) = vsum1_ad(i) + q2_ad(i, j, k)
17429  vsum2_ad(i) = vsum2_ad(i) - q2_ad(i, j, k)
17430  END DO
17431  END DO
17432  DO i=i2,i1,-1
17433  CALL poprealarray(vsum2(i))
17434  temp21 = pe2(i, kn+1) - pe2(i, 1)
17435  temp_ad30 = -(vsum2(i)*vsum2_ad(i)/temp21**2)
17436  pe2_ad(i, kn+1) = pe2_ad(i, kn+1) + temp_ad30
17437  pe2_ad(i, 1) = pe2_ad(i, 1) - temp_ad30
17438  vsum2_ad(i) = vsum2_ad(i)/temp21
17439  DO k=kn,1,-1
17440  temp_ad29 = q2(i, j, k)*vsum2_ad(i)
17441  q2_ad(i, j, k) = q2_ad(i, j, k) + (pe2(i, k+1)-pe2(i, k))*&
17442 & vsum2_ad(i)
17443  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad29
17444  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad29
17445  END DO
17446  END DO
17447  ELSE
17448  CALL popinteger(lp0)
17449  CALL poprealarray(dlp0)
17450  CALL popinteger(lp1)
17451  CALL poprealarray(p)
17452  CALL popinteger(lm1)
17453  CALL poprealarray(dlm1)
17454  CALL popinteger(lm2)
17455  CALL poprealarray(dlm2)
17456  CALL poprealarray(qx, (i2-i1+1)*km)
17457  CALL poprealarray(ap0)
17458  CALL poprealarray(ap1)
17459  CALL poprealarray(am1)
17460  CALL poprealarray(logpl1, (i2-i1+1)*km)
17461  CALL poprealarray(am2)
17462  CALL poprealarray(logpl2, (i2-i1+1)*kn)
17463  vsum1_ad = 0.0
17464  END IF
17465  qx_ad = 0.0
17466  logpl1_ad = 0.0
17467  logpl2_ad = 0.0
17468  dlogp1_ad = 0.0
17469  DO i=i2,i1,-1
17470  DO k=kn,1,-1
17471  CALL popcontrol(2,branch)
17472  IF (branch .LT. 2) THEN
17473  IF (branch .EQ. 0) THEN
17474  CALL poprealarray(q2(i, j, k))
17475  ap1_ad = qx(i, lp1)*q2_ad(i, j, k)
17476  qx_ad(i, lp1) = qx_ad(i, lp1) + ap1*q2_ad(i, j, k)
17477  ap0_ad = qx(i, lp0)*q2_ad(i, j, k)
17478  qx_ad(i, lp0) = qx_ad(i, lp0) + ap0*q2_ad(i, j, k)
17479  am1_ad = qx(i, lm1)*q2_ad(i, j, k)
17480  qx_ad(i, lm1) = qx_ad(i, lm1) + am1*q2_ad(i, j, k)
17481  am2_ad = qx(i, lm2)*q2_ad(i, j, k)
17482  qx_ad(i, lm2) = qx_ad(i, lm2) + am2*q2_ad(i, j, k)
17483  q2_ad(i, j, k) = 0.0
17484  plp0 = logpl1(i, lp0)
17485  plp1 = logpl1(i, lp1)
17486  plm1 = logpl1(i, lm1)
17487  CALL poprealarray(am2)
17488  temp20 = dlm2*(dlm1+dlm2)
17489  temp19 = temp20*(dlp0+dlm1+dlm2)
17490  temp_ad13 = am2_ad/temp19
17491  temp_ad14 = (plm1-p)*temp_ad13
17492  temp18 = (plp1-p)*(plp0-p)
17493  temp_ad15 = -(temp18*(plm1-p)*temp_ad13/temp19)
17494  temp_ad16 = (dlp0+dlm1+dlm2)*temp_ad15
17495  temp_ad17 = temp20*temp_ad15
17496  plm2 = logpl1(i, lm2)
17497  CALL poprealarray(am1)
17498  temp17 = dlm1*dlm2
17499  temp_ad20 = am1_ad/(temp17*(dlp0+dlm1))
17500  temp_ad18 = (p-plm2)*temp_ad20
17501  temp16 = (plp1-p)*(plp0-p)
17502  temp_ad24 = -(temp16*(p-plm2)*temp_ad20/(temp17*(dlp0+dlm1))&
17503 & )
17504  CALL poprealarray(ap0)
17505  temp15 = dlp0*dlm1
17506  temp_ad23 = ap0_ad/(temp15*(dlm1+dlm2))
17507  temp_ad19 = (p-plm2)*temp_ad23
17508  plp1_ad = (plp0-p)*temp_ad18 + (p-plm1)*temp_ad19 + (plp0-p)&
17509 & *temp_ad14
17510  temp14 = (plp1-p)*(p-plm1)
17511  temp_ad26 = -(temp14*(p-plm2)*temp_ad23/(temp15*(dlm1+dlm2))&
17512 & )
17513  CALL poprealarray(ap1)
17514  temp13 = dlp0*(dlp0+dlm1)
17515  temp12 = temp13*(dlp0+dlm1+dlm2)
17516  temp_ad22 = ap1_ad/temp12
17517  temp_ad21 = (p-plm2)*temp_ad22
17518  plp0_ad = (plp1-p)*temp_ad18 - (p-plm1)*temp_ad21 + (plp1-p)&
17519 & *temp_ad14
17520  plm1_ad = temp18*temp_ad13 - (p-plp0)*temp_ad21 - (plp1-p)*&
17521 & temp_ad19
17522  temp11 = (p-plp0)*(p-plm1)
17523  p_ad = (2*p-plp1-plp0)*temp_ad18 + temp16*temp_ad20 + (2*p-&
17524 & plp0-plm1)*temp_ad21 + temp11*temp_ad22 + temp14*temp_ad23&
17525 & + (plp1-2*p+plm1)*temp_ad19 - temp18*temp_ad13 + (2*p-plp1&
17526 & -plp0)*temp_ad14
17527  plm2_ad = -(temp14*temp_ad23) - temp11*temp_ad22 - temp16*&
17528 & temp_ad20
17529  temp_ad28 = -(temp11*(p-plm2)*temp_ad22/temp12)
17530  temp_ad27 = (dlp0+dlm1+dlm2)*temp_ad28
17531  temp_ad25 = temp13*temp_ad28
17532  dlm2_ad = (dlp0+dlm1)*dlm1*temp_ad24 + temp_ad25 + temp15*&
17533 & temp_ad26 + temp_ad17 + (2*dlm2+dlm1)*temp_ad16
17534  dlm1_ad = (temp17+(dlp0+dlm1)*dlm2)*temp_ad24 + dlp0*&
17535 & temp_ad27 + temp_ad25 + (temp15+(dlm1+dlm2)*dlp0)*&
17536 & temp_ad26 + temp_ad17 + dlm2*temp_ad16
17537  dlp0_ad = temp17*temp_ad24 + (2*dlp0+dlm1)*temp_ad27 + &
17538 & temp_ad25 + (dlm1+dlm2)*dlm1*temp_ad26 + temp_ad17
17539  CALL poprealarray(dlm2)
17540  dlogp1_ad(i, lm2) = dlogp1_ad(i, lm2) + dlm2_ad
17541  CALL poprealarray(dlm1)
17542  dlogp1_ad(i, lm1) = dlogp1_ad(i, lm1) + dlm1_ad
17543  CALL poprealarray(dlp0)
17544  dlogp1_ad(i, lp0) = dlogp1_ad(i, lp0) + dlp0_ad
17545  logpl1_ad(i, lm2) = logpl1_ad(i, lm2) + plm2_ad
17546  logpl1_ad(i, lm1) = logpl1_ad(i, lm1) + plm1_ad
17547  logpl1_ad(i, lp0) = logpl1_ad(i, lp0) + plp0_ad
17548  logpl1_ad(i, lp1) = logpl1_ad(i, lp1) + plp1_ad
17549  CALL poprealarray(p)
17550  logpl2_ad(i, k) = logpl2_ad(i, k) + p_ad
17551  CALL popinteger(lm2)
17552  CALL popinteger(lp1)
17553  ELSE
17554  CALL poprealarray(q2(i, j, k))
17555  temp8 = logpl1(i, lm1) - logpl1(i, lp0)
17556  temp_ad11 = q2_ad(i, j, k)/temp8
17557  temp10 = logpl2(i, k) - logpl1(i, lp0)
17558  temp9 = qx(i, lm1) - qx(i, lp0)
17559  temp_ad12 = -(temp9*temp10*temp_ad11/temp8)
17560  qx_ad(i, lp0) = qx_ad(i, lp0) + q2_ad(i, j, k) - temp10*&
17561 & temp_ad11
17562  qx_ad(i, lm1) = qx_ad(i, lm1) + temp10*temp_ad11
17563  logpl2_ad(i, k) = logpl2_ad(i, k) + temp9*temp_ad11
17564  logpl1_ad(i, lp0) = logpl1_ad(i, lp0) - temp_ad12 - temp9*&
17565 & temp_ad11
17566  logpl1_ad(i, lm1) = logpl1_ad(i, lm1) + temp_ad12
17567  q2_ad(i, j, k) = 0.0
17568  END IF
17569  ELSE IF (branch .EQ. 2) THEN
17570  CALL poprealarray(q2(i, j, k))
17571  temp5 = logpl1(i, km) - logpl1(i, km-1)
17572  temp_ad9 = q2_ad(i, j, k)/temp5
17573  temp7 = logpl2(i, k) - logpl1(i, km)
17574  temp6 = qx(i, km) - qx(i, km-1)
17575  temp_ad10 = -(temp6*temp7*temp_ad9/temp5)
17576  qx_ad(i, km) = qx_ad(i, km) + temp7*temp_ad9 + q2_ad(i, j, k)
17577  qx_ad(i, km-1) = qx_ad(i, km-1) - temp7*temp_ad9
17578  logpl2_ad(i, k) = logpl2_ad(i, k) + temp6*temp_ad9
17579  logpl1_ad(i, km) = logpl1_ad(i, km) + temp_ad10 - temp6*&
17580 & temp_ad9
17581  logpl1_ad(i, km-1) = logpl1_ad(i, km-1) - temp_ad10
17582  q2_ad(i, j, k) = 0.0
17583  ELSE
17584  CALL poprealarray(q2(i, j, k))
17585  temp3 = logpl1(i, 2) - logpl1(i, 1)
17586  temp4 = qx(i, 2) - qx(i, 1)
17587  temp2 = temp4/temp3
17588  temp_ad7 = (logpl2(i, k)-logpl1(i, 1))*q2_ad(i, j, k)/temp3
17589  temp_ad8 = -(temp2*temp_ad7)
17590  qx_ad(i, 1) = qx_ad(i, 1) + q2_ad(i, j, k) - temp_ad7
17591  logpl2_ad(i, k) = logpl2_ad(i, k) + temp2*q2_ad(i, j, k)
17592  logpl1_ad(i, 1) = logpl1_ad(i, 1) - temp_ad8 - temp2*q2_ad(i, &
17593 & j, k)
17594  qx_ad(i, 2) = qx_ad(i, 2) + temp_ad7
17595  logpl1_ad(i, 2) = logpl1_ad(i, 2) + temp_ad8
17596  q2_ad(i, j, k) = 0.0
17597  END IF
17598  CALL popcontrol(1,branch)
17599  IF (branch .EQ. 0) THEN
17600  CALL popinteger(lm1)
17601  ELSE
17602  CALL popinteger(lm1)
17603  END IF
17604  CALL popinteger(ad_count)
17605  DO i0=1,ad_count
17606  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
17607  END DO
17608  CALL popinteger(lp0)
17609  END DO
17610  END DO
17611  CALL popcontrol(1,branch)
17612  IF (branch .NE. 0) THEN
17613  DO i=i2,i1,-1
17614  CALL poprealarray(vsum1(i))
17615  temp1 = pe1(i, km+1) - pe1(i, 1)
17616  temp_ad6 = -(vsum1(i)*vsum1_ad(i)/temp1**2)
17617  pe1_ad(i, km+1) = pe1_ad(i, km+1) + temp_ad6
17618  pe1_ad(i, 1) = pe1_ad(i, 1) - temp_ad6
17619  vsum1_ad(i) = vsum1_ad(i)/temp1
17620  DO k=km,1,-1
17621  temp_ad5 = qx(i, k)*vsum1_ad(i)
17622  qx_ad(i, k) = qx_ad(i, k) + (pe1(i, k+1)-pe1(i, k))*vsum1_ad(i&
17623 & )
17624  pe1_ad(i, k+1) = pe1_ad(i, k+1) + temp_ad5
17625  pe1_ad(i, k) = pe1_ad(i, k) - temp_ad5
17626  END DO
17627  END DO
17628  END IF
17629  CALL popcontrol(2,branch)
17630  IF (branch .LT. 2) THEN
17631  IF (branch .NE. 0) THEN
17632  DO k=km-1,1,-1
17633  logpl1_ad(:, k+1) = logpl1_ad(:, k+1) + dlogp1_ad(:, k)
17634  logpl1_ad(:, k) = logpl1_ad(:, k) - dlogp1_ad(:, k)
17635  dlogp1_ad(:, k) = 0.0
17636  END DO
17637  DO k=kn,1,-1
17638  temp_ad0 = logpl2_ad(:, k)/(pe2(:, k)+pe2(:, k+1))
17639  pe2_ad(:, k) = pe2_ad(:, k) + temp_ad0
17640  pe2_ad(:, k+1) = pe2_ad(:, k+1) + temp_ad0
17641  logpl2_ad(:, k) = 0.0
17642  END DO
17643  DO k=km,1,-1
17644  temp_ad = logpl1_ad(:, k)/(pe1(:, k)+pe1(:, k+1))
17645  pe1_ad(:, k) = pe1_ad(:, k) + temp_ad
17646  pe1_ad(:, k+1) = pe1_ad(:, k+1) + temp_ad
17647  logpl1_ad(:, k) = 0.0
17648  q2_ad(i1:i2, j, k) = q2_ad(i1:i2, j, k) + qx_ad(:, k)
17649  qx_ad(:, k) = 0.0
17650  END DO
17651  END IF
17652  ELSE IF (branch .EQ. 2) THEN
17653  DO k=km-1,1,-1
17654  logpl1_ad(:, k+1) = logpl1_ad(:, k+1) + dlogp1_ad(:, k)
17655  logpl1_ad(:, k) = logpl1_ad(:, k) - dlogp1_ad(:, k)
17656  dlogp1_ad(:, k) = 0.0
17657  END DO
17658  DO k=kn,1,-1
17659  temp_ad2 = logpl2_ad(:, k)/(pe2(:, k)+pe2(:, k+1))
17660  pe2_ad(:, k) = pe2_ad(:, k) + temp_ad2
17661  pe2_ad(:, k+1) = pe2_ad(:, k+1) + temp_ad2
17662  logpl2_ad(:, k) = 0.0
17663  END DO
17664  DO k=km,1,-1
17665  temp_ad1 = logpl1_ad(:, k)/(pe1(:, k)+pe1(:, k+1))
17666  pe1_ad(:, k) = pe1_ad(:, k) + temp_ad1
17667  pe1_ad(:, k+1) = pe1_ad(:, k+1) + temp_ad1
17668  logpl1_ad(:, k) = 0.0
17669  q2_ad(i1:i2, j, k) = q2_ad(i1:i2, j, k) + qx_ad(:, k)
17670  qx_ad(:, k) = 0.0
17671  END DO
17672  ELSE
17673  DO k=km-1,1,-1
17674  logpl1_ad(:, k+1) = logpl1_ad(:, k+1) + dlogp1_ad(:, k)
17675  logpl1_ad(:, k) = logpl1_ad(:, k) - dlogp1_ad(:, k)
17676  dlogp1_ad(:, k) = 0.0
17677  END DO
17678  DO k=kn,1,-1
17679  temp0 = r2*(pe2(:, k)+pe2(:, k+1))
17680  temp_ad4 = akap*exp(akap*log(temp0))*r2*logpl2_ad(:, k)/temp0
17681  pe2_ad(:, k) = pe2_ad(:, k) + temp_ad4
17682  pe2_ad(:, k+1) = pe2_ad(:, k+1) + temp_ad4
17683  logpl2_ad(:, k) = 0.0
17684  END DO
17685  DO k=km,1,-1
17686  temp = r2*(pe1(:, k)+pe1(:, k+1))
17687  temp_ad3 = akap*exp(akap*log(temp))*r2*logpl1_ad(:, k)/temp
17688  pe1_ad(:, k) = pe1_ad(:, k) + temp_ad3
17689  pe1_ad(:, k+1) = pe1_ad(:, k+1) + temp_ad3
17690  logpl1_ad(:, k) = 0.0
17691  q2_ad(i1:i2, j, k) = q2_ad(i1:i2, j, k) + qx_ad(:, k)
17692  qx_ad(:, k) = 0.0
17693  END DO
17694  END IF
17695  END SUBROUTINE map1_cubic_bwd
17696 !-----------------------------------------------------------------------
17697 !BOP
17698 ! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping
17699 !
17700 ! !INTERFACE:
17701  SUBROUTINE map1_cubic(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend, &
17702 & jbeg, jend, akap, t_var, conserv)
17703  IMPLICIT NONE
17704 !EOC
17705 ! !INPUT PARAMETERS:
17706 ! Starting longitude
17707  INTEGER, INTENT(IN) :: i1
17708 ! Finishing longitude
17709  INTEGER, INTENT(IN) :: i2
17710  REAL, INTENT(IN) :: akap
17711 ! Thermodynamic variable to remap
17712  INTEGER, INTENT(IN) :: t_var
17713 ! 1:TE 2:T 3:PT
17714  LOGICAL, INTENT(IN) :: conserv
17715 ! Current latitude
17716  INTEGER, INTENT(IN) :: j
17717  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
17718 ! Original vertical dimension
17719  INTEGER, INTENT(IN) :: km
17720 ! Target vertical dimension
17721  INTEGER, INTENT(IN) :: kn
17722 ! pressure at layer edges
17723  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
17724 ! (from model top to bottom surface)
17725 ! in the original vertical coordinate
17726 ! pressure at layer edges
17727  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
17728 ! (from model top to bottom surface)
17729 ! in the new vertical coordinate
17730 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
17731 ! !INPUT/OUTPUT PARAMETERS:
17732 ! Field output
17733  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
17734 ! !DESCRIPTION:
17735 !
17736 ! Perform Cubic Interpolation a given latitude
17737 ! pe1: pressure at layer edges (from model top to bottom surface)
17738 ! in the original vertical coordinate
17739 ! pe2: pressure at layer edges (from model top to bottom surface)
17740 ! in the new vertical coordinate
17741 !
17742 ! !REVISION HISTORY:
17743 ! 2005.11.14 Takacs Initial Code
17744 ! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable
17745 !
17746 !EOP
17747 !-----------------------------------------------------------------------
17748 !BOC
17749 !
17750 ! !LOCAL VARIABLES:
17751  REAL :: qx(i1:i2, km)
17752  REAL :: logpl1(i1:i2, km)
17753  REAL :: logpl2(i1:i2, kn)
17754  REAL :: dlogp1(i1:i2, km)
17755  REAL :: vsum1(i1:i2)
17756  REAL :: vsum2(i1:i2)
17757  REAL :: am2, am1, ap0, ap1, p, plp1, plp0, plm1, plm2, dlp0, dlm1, &
17758 & dlm2
17759  INTEGER :: i, k, lm2, lm1, lp0, lp1
17760  INTRINSIC log
17761  INTRINSIC exp
17762  INTRINSIC max
17763  INTRINSIC min
17764 ! Initialization
17765 ! --------------
17766  SELECT CASE (t_var)
17767  CASE (1)
17768 ! Total Energy Remapping in Log(P)
17769  DO k=1,km
17770  qx(:, k) = q2(i1:i2, j, k)
17771  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
17772  END DO
17773  DO k=1,kn
17774  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
17775  END DO
17776  DO k=1,km-1
17777  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17778  END DO
17779  CASE (2)
17780 ! Temperature Remapping in Log(P)
17781  DO k=1,km
17782  qx(:, k) = q2(i1:i2, j, k)
17783  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
17784  END DO
17785  DO k=1,kn
17786  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
17787  END DO
17788  DO k=1,km-1
17789  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17790  END DO
17791  CASE (3)
17792 ! Potential Temperature Remapping in P^KAPPA
17793  DO k=1,km
17794  qx(:, k) = q2(i1:i2, j, k)
17795  logpl1(:, k) = exp(akap*log(r2*(pe1(:, k)+pe1(:, k+1))))
17796  END DO
17797  DO k=1,kn
17798  logpl2(:, k) = exp(akap*log(r2*(pe2(:, k)+pe2(:, k+1))))
17799  END DO
17800  DO k=1,km-1
17801  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
17802  END DO
17803  END SELECT
17804  IF (conserv) THEN
17805 ! Compute vertical integral of Input TE
17806 ! -------------------------------------
17807  vsum1(:) = r0
17808  DO i=i1,i2
17809  DO k=1,km
17810  vsum1(i) = vsum1(i) + qx(i, k)*(pe1(i, k+1)-pe1(i, k))
17811  END DO
17812  vsum1(i) = vsum1(i)/(pe1(i, km+1)-pe1(i, 1))
17813  END DO
17814  END IF
17815 ! Interpolate TE onto target Pressures
17816 ! ------------------------------------
17817  DO i=i1,i2
17818  DO k=1,kn
17819  lm1 = 1
17820  lp0 = 1
17821  DO WHILE (lp0 .LE. km)
17822  IF (logpl1(i, lp0) .LT. logpl2(i, k)) THEN
17823  lp0 = lp0 + 1
17824  ELSE
17825  GOTO 100
17826  END IF
17827  END DO
17828  100 IF (lp0 - 1 .LT. 1) THEN
17829  lm1 = 1
17830  ELSE
17831  lm1 = lp0 - 1
17832  END IF
17833  IF (lp0 .GT. km) THEN
17834  lp0 = km
17835  ELSE
17836  lp0 = lp0
17837  END IF
17838 ! Extrapolate Linearly in LogP above first model level
17839 ! ----------------------------------------------------
17840  IF (lm1 .EQ. 1 .AND. lp0 .EQ. 1) THEN
17841  q2(i, j, k) = qx(i, 1) + (qx(i, 2)-qx(i, 1))*(logpl2(i, k)-&
17842 & logpl1(i, 1))/(logpl1(i, 2)-logpl1(i, 1))
17843 ! Extrapolate Linearly in LogP below last model level
17844 ! ---------------------------------------------------
17845  ELSE IF (lm1 .EQ. km .AND. lp0 .EQ. km) THEN
17846  q2(i, j, k) = qx(i, km) + (qx(i, km)-qx(i, km-1))*(logpl2(i, k&
17847 & )-logpl1(i, km))/(logpl1(i, km)-logpl1(i, km-1))
17848 ! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km
17849 ! -----------------------------------------------------------------
17850  ELSE IF (lm1 .EQ. 1 .OR. lp0 .EQ. km) THEN
17851  q2(i, j, k) = qx(i, lp0) + (qx(i, lm1)-qx(i, lp0))*(logpl2(i, &
17852 & k)-logpl1(i, lp0))/(logpl1(i, lm1)-logpl1(i, lp0))
17853 ! Interpolate Cubicly in LogP between other model levels
17854 ! ------------------------------------------------------
17855  ELSE
17856  lp1 = lp0 + 1
17857  lm2 = lm1 - 1
17858  p = logpl2(i, k)
17859  plp1 = logpl1(i, lp1)
17860  plp0 = logpl1(i, lp0)
17861  plm1 = logpl1(i, lm1)
17862  plm2 = logpl1(i, lm2)
17863  dlp0 = dlogp1(i, lp0)
17864  dlm1 = dlogp1(i, lm1)
17865  dlm2 = dlogp1(i, lm2)
17866  ap1 = (p-plp0)*(p-plm1)*(p-plm2)/(dlp0*(dlp0+dlm1)*(dlp0+dlm1+&
17867 & dlm2))
17868  ap0 = (plp1-p)*(p-plm1)*(p-plm2)/(dlp0*dlm1*(dlm1+dlm2))
17869  am1 = (plp1-p)*(plp0-p)*(p-plm2)/(dlm1*dlm2*(dlp0+dlm1))
17870  am2 = (plp1-p)*(plp0-p)*(plm1-p)/(dlm2*(dlm1+dlm2)*(dlp0+dlm1+&
17871 & dlm2))
17872  q2(i, j, k) = ap1*qx(i, lp1) + ap0*qx(i, lp0) + am1*qx(i, lm1)&
17873 & + am2*qx(i, lm2)
17874  END IF
17875  END DO
17876  END DO
17877  IF (conserv) THEN
17878 ! Compute vertical integral of Output TE
17879 ! --------------------------------------
17880  vsum2(:) = r0
17881  DO i=i1,i2
17882  DO k=1,kn
17883  vsum2(i) = vsum2(i) + q2(i, j, k)*(pe2(i, k+1)-pe2(i, k))
17884  END DO
17885  vsum2(i) = vsum2(i)/(pe2(i, kn+1)-pe2(i, 1))
17886  END DO
17887 ! Adjust Final TE to conserve
17888 ! ---------------------------
17889  DO i=i1,i2
17890  DO k=1,kn
17891  q2(i, j, k) = q2(i, j, k) + vsum1(i) - vsum2(i)
17892  END DO
17893  END DO
17894  END IF
17895 ! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i)
17896  RETURN
17897  END SUBROUTINE map1_cubic
17898 ! Differentiation of map_scalar in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
17899 !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
17900 !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
17901 !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
17902 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
17903 !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
17904 !.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
17905 !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
17906 !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
17907 !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
17908 !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
17909 !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
17910 !_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_
17911 !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
17912 !.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
17913 !_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
17914 !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
17915 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
17916 ! gradient of useful results: pe1 pe2 q2
17917 ! with respect to varying inputs: pe1 pe2 q2
17918 !-----------------------------------------------------------------------
17919  SUBROUTINE map_scalar_fwd(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg&
17920 & , iend, jbeg, jend, iv, kord, q_min)
17921  IMPLICIT NONE
17922 ! iv=1
17923 ! Starting longitude
17924  INTEGER, INTENT(IN) :: i1
17925 ! Finishing longitude
17926  INTEGER, INTENT(IN) :: i2
17927 ! Mode: 0 == constituents 1 == temp
17928  INTEGER, INTENT(IN) :: iv
17929 ! 2 == remap temp with cs scheme
17930 ! Method order
17931  INTEGER, INTENT(IN) :: kord
17932 ! Current latitude
17933  INTEGER, INTENT(IN) :: j
17934  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
17935 ! Original vertical dimension
17936  INTEGER, INTENT(IN) :: km
17937 ! Target vertical dimension
17938  INTEGER, INTENT(IN) :: kn
17939 ! bottom BC
17940  REAL, INTENT(IN) :: qs(i1:i2)
17941 ! pressure at layer edges
17942  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
17943 ! (from model top to bottom surface)
17944 ! in the original vertical coordinate
17945 ! pressure at layer edges
17946  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
17947 ! (from model top to bottom surface)
17948 ! in the new vertical coordinate
17949 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
17950 ! !INPUT/OUTPUT PARAMETERS:
17951 ! Field output
17952  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
17953  REAL, INTENT(IN) :: q_min
17954 ! !DESCRIPTION:
17955 ! IV = 0: constituents
17956 ! pe1: pressure at layer edges (from model top to bottom surface)
17957 ! in the original vertical coordinate
17958 ! pe2: pressure at layer edges (from model top to bottom surface)
17959 ! in the new vertical coordinate
17960 ! !LOCAL VARIABLES:
17961  REAL :: dp1(i1:i2, km)
17962  REAL :: q4(4, i1:i2, km)
17963  REAL :: pl, pr, qsum, dp, esl
17964  INTEGER :: i, k, l, m, k0
17965  INTEGER :: ad_count
17966  INTEGER :: ad_count0
17967 
17968  dp1 = 0.0
17969  q4 = 0.0
17970  pl = 0.0
17971  pr = 0.0
17972  qsum = 0.0
17973  dp = 0.0
17974  esl = 0.0
17975  i = 0
17976  k = 0
17977  l = 0
17978  m = 0
17979  k0 = 0
17980  ad_count = 0
17981  ad_count0 = 0
17982 
17983  DO k=1,km
17984  DO i=i1,i2
17985  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
17986  q4(1, i, k) = q2(i, j, k)
17987  END DO
17988  END DO
17989 ! Compute vertical subgrid distribution
17990  IF (kord .GT. 7) THEN
17991  CALL scalar_profile_fwd(qs, q4, dp1, km, i1, i2, iv, kord, &
17992 & q_min)
17993 !else
17994 ! call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
17995  CALL pushcontrol(1,1)
17996  ELSE
17997  CALL pushcontrol(1,0)
17998  END IF
17999  DO i=i1,i2
18000  k0 = 1
18001  DO 120 k=1,kn
18002  CALL pushinteger(l)
18003  ad_count = 1
18004  DO l=k0,km
18005 ! locate the top edge: pe2(i,k)
18006  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
18007 & ) THEN
18008  GOTO 100
18009  ELSE
18010  CALL pushinteger(l)
18011  ad_count = ad_count + 1
18012  END IF
18013  END DO
18014  CALL pushcontrol(1,0)
18015  CALL pushinteger(ad_count)
18016  CALL pushcontrol(2,2)
18017  GOTO 123
18018  100 CALL pushcontrol(1,1)
18019  CALL pushinteger(ad_count)
18020  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18021  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
18022 ! entire new grid is within the original grid
18023  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18024  CALL pushrealarray(q2(i, j, k))
18025  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
18026 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
18027  k0 = l
18028  CALL pushcontrol(1,0)
18029  GOTO 120
18030  ELSE
18031 ! Fractional area...
18032  CALL pushrealarray(qsum)
18033  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
18034 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
18035 & pl))))
18036  CALL pushinteger(m)
18037  ad_count0 = 1
18038  DO m=l+1,km
18039 ! locate the bottom edge: pe2(i,k+1)
18040  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
18041 ! Whole layer
18042  qsum = qsum + dp1(i, m)*q4(1, i, m)
18043  CALL pushinteger(m)
18044  ad_count0 = ad_count0 + 1
18045  ELSE
18046  GOTO 110
18047  END IF
18048  END DO
18049  CALL pushcontrol(1,0)
18050  CALL pushinteger(ad_count0)
18051  CALL pushcontrol(2,1)
18052  GOTO 123
18053  110 CALL pushcontrol(1,1)
18054  CALL pushinteger(ad_count0)
18055  dp = pe2(i, k+1) - pe1(i, m)
18056  esl = dp/dp1(i, m)
18057  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
18058 & +q4(4, i, m)*(1.-r23*esl)))
18059  k0 = m
18060  CALL pushcontrol(2,0)
18061  END IF
18062  123 CALL pushrealarray(q2(i, j, k))
18063  q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
18064  CALL pushcontrol(1,1)
18065  120 CONTINUE
18066  END DO
18067  CALL pushrealarray(q4, 4*(i2-i1+1)*km)
18068  CALL pushrealarray(qsum)
18069  CALL pushrealarray(dp1, (i2-i1+1)*km)
18070  CALL pushinteger(m)
18071  CALL pushinteger(l)
18072  END SUBROUTINE map_scalar_fwd
18073 ! Differentiation of map_scalar in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
18074 !ge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_c
18075 !ore_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_m
18076 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
18077 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
18078 !_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mo
18079 !d.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_
18080 !2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limit
18081 !ers fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic
18082 !fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_su
18083 !bgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_ut
18084 !ils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_util
18085 !s_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils
18086 !_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mo
18087 !d.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.yt
18088 !p_v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_c
18089 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
18090 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18091 ! gradient of useful results: pe1 pe2 q2
18092 ! with respect to varying inputs: pe1 pe2 q2
18093 !-----------------------------------------------------------------------
18094  SUBROUTINE map_scalar_bwd(km, pe1, pe1_ad, qs, kn, pe2, pe2_ad, q2&
18095 & , q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
18096  IMPLICIT NONE
18097  INTEGER, INTENT(IN) :: i1
18098  INTEGER, INTENT(IN) :: i2
18099  INTEGER, INTENT(IN) :: iv
18100  INTEGER, INTENT(IN) :: kord
18101  INTEGER, INTENT(IN) :: j
18102  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
18103  INTEGER, INTENT(IN) :: km
18104  INTEGER, INTENT(IN) :: kn
18105  REAL, INTENT(IN) :: qs(i1:i2)
18106  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
18107  REAL :: pe1_ad(i1:i2, km+1)
18108  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
18109  REAL :: pe2_ad(i1:i2, kn+1)
18110  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
18111  REAL, INTENT(INOUT) :: q2_ad(ibeg:iend, jbeg:jend, kn)
18112  REAL, INTENT(IN) :: q_min
18113  REAL :: dp1(i1:i2, km)
18114  REAL :: dp1_ad(i1:i2, km)
18115  REAL :: q4(4, i1:i2, km)
18116  REAL :: q4_ad(4, i1:i2, km)
18117  REAL :: pl, pr, qsum, dp, esl
18118  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
18119  INTEGER :: i, k, l, m, k0
18120  REAL :: temp_ad
18121  REAL :: temp_ad0
18122  REAL :: temp_ad1
18123  REAL :: temp_ad2
18124  REAL :: temp_ad3
18125  REAL :: temp
18126  REAL :: temp_ad4
18127  REAL :: temp_ad5
18128  REAL :: temp_ad6
18129  REAL :: temp_ad7
18130  REAL :: temp0
18131  REAL :: temp_ad8
18132  REAL :: temp_ad9
18133  REAL :: temp_ad10
18134  REAL :: temp1
18135  REAL :: temp_ad11
18136  INTEGER :: ad_count
18137  INTEGER :: i0
18138  INTEGER :: branch
18139  INTEGER :: ad_count0
18140  INTEGER :: i3
18141 
18142  dp1 = 0.0
18143  q4 = 0.0
18144  pl = 0.0
18145  pr = 0.0
18146  qsum = 0.0
18147  dp = 0.0
18148  esl = 0.0
18149  i = 0
18150  k = 0
18151  l = 0
18152  m = 0
18153  k0 = 0
18154  ad_count = 0
18155  ad_count0 = 0
18156  branch = 0
18157 
18158  CALL popinteger(l)
18159  CALL popinteger(m)
18160  CALL poprealarray(dp1, (i2-i1+1)*km)
18161  CALL poprealarray(qsum)
18162  CALL poprealarray(q4, 4*(i2-i1+1)*km)
18163  dp1_ad = 0.0
18164  qsum_ad = 0.0
18165  q4_ad = 0.0
18166  DO i=i2,i1,-1
18167  DO k=kn,1,-1
18168  CALL popcontrol(1,branch)
18169  IF (branch .EQ. 0) THEN
18170  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18171  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18172  CALL poprealarray(q2(i, j, k))
18173  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, j, k)
18174  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
18175 & j, k)
18176  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, j, k))
18177  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, j, k) - temp_ad0
18178  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
18179 & **2)*q2_ad(i, j, k)
18180  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
18181  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
18182  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
18183  q2_ad(i, j, k) = 0.0
18184  temp_ad3 = pr_ad/dp1(i, l)
18185  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
18186  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
18187  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
18188 & /dp1(i, l)
18189  ELSE
18190  CALL poprealarray(q2(i, j, k))
18191  temp1 = pe2(i, k+1) - pe2(i, k)
18192  temp_ad11 = -(qsum*q2_ad(i, j, k)/temp1**2)
18193  qsum_ad = qsum_ad + q2_ad(i, j, k)/temp1
18194  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad11
18195  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad11
18196  q2_ad(i, j, k) = 0.0
18197  CALL popcontrol(2,branch)
18198  IF (branch .EQ. 0) THEN
18199  dp = pe2(i, k+1) - pe1(i, m)
18200  esl = dp/dp1(i, m)
18201  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
18202 & 1.)
18203  temp_ad8 = dp*qsum_ad
18204  temp_ad9 = 0.5*esl*temp_ad8
18205  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
18206  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
18207  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
18208  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
18209  temp_ad10 = esl_ad/dp1(i, m)
18210  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
18211  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
18212  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
18213  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
18214  ELSE IF (branch .NE. 1) THEN
18215  GOTO 100
18216  END IF
18217  CALL popinteger(ad_count0)
18218  DO i3=1,ad_count0
18219  IF (i3 .EQ. 1) THEN
18220  CALL popcontrol(1,branch)
18221  ELSE
18222  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
18223  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
18224  END IF
18225  CALL popinteger(m)
18226  END DO
18227  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18228  CALL poprealarray(qsum)
18229  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
18230  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
18231 & *(pl+1.)+1.)))*qsum_ad
18232  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
18233  temp_ad6 = 0.5*(pl+1.)*temp_ad5
18234  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
18235  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
18236  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
18237  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
18238  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
18239 & )*temp_ad5
18240  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
18241  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
18242  qsum_ad = 0.0
18243  END IF
18244  temp_ad = pl_ad/dp1(i, l)
18245  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
18246  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
18247  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
18248 & i, l)
18249  100 CALL popinteger(ad_count)
18250  DO i0=1,ad_count
18251  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
18252  CALL popinteger(l)
18253  END DO
18254  END DO
18255  END DO
18256  CALL popcontrol(1,branch)
18257  IF (branch .NE. 0) CALL scalar_profile_bwd(qs, q4, q4_ad, dp1, &
18258 & dp1_ad, km, i1, i2, iv, kord&
18259 & , q_min)
18260  DO k=km,1,-1
18261  DO i=i2,i1,-1
18262  q2_ad(i, j, k) = q2_ad(i, j, k) + q4_ad(1, i, k)
18263  q4_ad(1, i, k) = 0.0
18264  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
18265  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
18266  dp1_ad(i, k) = 0.0
18267  END DO
18268  END DO
18269  END SUBROUTINE map_scalar_bwd
18270 !-----------------------------------------------------------------------
18271 ! Differentiation of map1_ppm in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
18272 !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
18273 !_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.
18274 !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
18275 !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
18276 !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
18277 !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
18278 !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
18279 ! 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_
18280 !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
18281 !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
18282 !_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
18283 !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
18284 !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
18285 !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
18286 !_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
18287 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
18288 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18289 ! gradient of useful results: pe1 pe2 qs q2
18290 ! with respect to varying inputs: pe1 pe2 qs q2
18291  SUBROUTINE map1_ppm_fwd(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, &
18292 & iend, jbeg, jend, iv, kord)
18293  IMPLICIT NONE
18294 ! Starting longitude
18295  INTEGER, INTENT(IN) :: i1
18296 ! Finishing longitude
18297  INTEGER, INTENT(IN) :: i2
18298 ! Mode: 0 == constituents 1 == ???
18299  INTEGER, INTENT(IN) :: iv
18300 ! 2 == remap temp with cs scheme
18301 ! Method order
18302  INTEGER, INTENT(IN) :: kord
18303 ! Current latitude
18304  INTEGER, INTENT(IN) :: j
18305  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
18306 ! Original vertical dimension
18307  INTEGER, INTENT(IN) :: km
18308 ! Target vertical dimension
18309  INTEGER, INTENT(IN) :: kn
18310 ! bottom BC
18311  REAL, INTENT(IN) :: qs(i1:i2)
18312 ! pressure at layer edges
18313  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
18314 ! (from model top to bottom surface)
18315 ! in the original vertical coordinate
18316 ! pressure at layer edges
18317  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
18318 ! (from model top to bottom surface)
18319 ! in the new vertical coordinate
18320 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
18321 ! !INPUT/OUTPUT PARAMETERS:
18322 ! Field output
18323  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
18324 ! !DESCRIPTION:
18325 ! IV = 0: constituents
18326 ! pe1: pressure at layer edges (from model top to bottom surface)
18327 ! in the original vertical coordinate
18328 ! pe2: pressure at layer edges (from model top to bottom surface)
18329 ! in the new vertical coordinate
18330 ! !LOCAL VARIABLES:
18331  REAL :: dp1(i1:i2, km)
18332  REAL :: q4(4, i1:i2, km)
18333  REAL :: pl, pr, qsum, dp, esl
18334  INTEGER :: i, k, l, m, k0
18335  INTEGER :: ad_count
18336  INTEGER :: ad_count0
18337 
18338  dp1 = 0.0
18339  q4 = 0.0
18340  pl = 0.0
18341  pr = 0.0
18342  qsum = 0.0
18343  dp = 0.0
18344  esl = 0.0
18345  i = 0
18346  k = 0
18347  l = 0
18348  m = 0
18349  k0 = 0
18350  ad_count = 0
18351  ad_count0 = 0
18352 
18353  DO k=1,km
18354  DO i=i1,i2
18355  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
18356  q4(1, i, k) = q2(i, j, k)
18357  END DO
18358  END DO
18359 ! Compute vertical subgrid distribution
18360  IF (kord .GT. 7) THEN
18361  CALL cs_profile_fwd(qs, q4, dp1, km, i1, i2, iv, kord)
18362 !else
18363 ! call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
18364  CALL pushcontrol(1,1)
18365  ELSE
18366  CALL pushcontrol(1,0)
18367  END IF
18368  DO i=i1,i2
18369  k0 = 1
18370  DO 120 k=1,kn
18371  CALL pushinteger(l)
18372  ad_count = 1
18373  DO l=k0,km
18374 ! locate the top edge: pe2(i,k)
18375  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
18376 & ) THEN
18377  GOTO 100
18378  ELSE
18379  CALL pushinteger(l)
18380  ad_count = ad_count + 1
18381  END IF
18382  END DO
18383  CALL pushcontrol(1,0)
18384  CALL pushinteger(ad_count)
18385  CALL pushcontrol(2,2)
18386  GOTO 123
18387  100 CALL pushcontrol(1,1)
18388  CALL pushinteger(ad_count)
18389  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18390  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
18391 ! entire new grid is within the original grid
18392  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18393  CALL pushrealarray(q2(i, j, k))
18394  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
18395 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
18396  k0 = l
18397  CALL pushcontrol(1,0)
18398  GOTO 120
18399  ELSE
18400 ! Fractional area...
18401  CALL pushrealarray(qsum)
18402  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
18403 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
18404 & pl))))
18405  CALL pushinteger(m)
18406  ad_count0 = 1
18407  DO m=l+1,km
18408 ! locate the bottom edge: pe2(i,k+1)
18409  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
18410 ! Whole layer
18411  qsum = qsum + dp1(i, m)*q4(1, i, m)
18412  CALL pushinteger(m)
18413  ad_count0 = ad_count0 + 1
18414  ELSE
18415  GOTO 110
18416  END IF
18417  END DO
18418  CALL pushcontrol(1,0)
18419  CALL pushinteger(ad_count0)
18420  CALL pushcontrol(2,1)
18421  GOTO 123
18422  110 CALL pushcontrol(1,1)
18423  CALL pushinteger(ad_count0)
18424  dp = pe2(i, k+1) - pe1(i, m)
18425  esl = dp/dp1(i, m)
18426  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
18427 & +q4(4, i, m)*(1.-r23*esl)))
18428  k0 = m
18429  CALL pushcontrol(2,0)
18430  END IF
18431  123 CALL pushrealarray(q2(i, j, k))
18432  q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
18433  CALL pushcontrol(1,1)
18434  120 CONTINUE
18435  END DO
18436  CALL pushrealarray(q4, 4*(i2-i1+1)*km)
18437  CALL pushrealarray(qsum)
18438  CALL pushrealarray(dp1, (i2-i1+1)*km)
18439  CALL pushinteger(m)
18440  CALL pushinteger(l)
18441  END SUBROUTINE map1_ppm_fwd
18442 ! Differentiation of map1_ppm in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
18443 !_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
18444 !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
18445 !.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
18446 !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
18447 !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.
18448 !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
18449 ! 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
18450 !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
18451 !_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
18452 !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
18453 !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_
18454 !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
18455 !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.
18456 !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_
18457 !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
18458 !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
18459 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18460 ! gradient of useful results: pe1 pe2 qs q2
18461 ! with respect to varying inputs: pe1 pe2 qs q2
18462  SUBROUTINE map1_ppm_bwd(km, pe1, pe1_ad, qs, qs_ad, kn, pe2, pe2_ad&
18463 & , q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
18464  IMPLICIT NONE
18465  INTEGER, INTENT(IN) :: i1
18466  INTEGER, INTENT(IN) :: i2
18467  INTEGER, INTENT(IN) :: iv
18468  INTEGER, INTENT(IN) :: kord
18469  INTEGER, INTENT(IN) :: j
18470  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
18471  INTEGER, INTENT(IN) :: km
18472  INTEGER, INTENT(IN) :: kn
18473  REAL, INTENT(IN) :: qs(i1:i2)
18474  REAL :: qs_ad(i1:i2)
18475  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
18476  REAL :: pe1_ad(i1:i2, km+1)
18477  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
18478  REAL :: pe2_ad(i1:i2, kn+1)
18479  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
18480  REAL, INTENT(INOUT) :: q2_ad(ibeg:iend, jbeg:jend, kn)
18481  REAL :: dp1(i1:i2, km)
18482  REAL :: dp1_ad(i1:i2, km)
18483  REAL :: q4(4, i1:i2, km)
18484  REAL :: q4_ad(4, i1:i2, km)
18485  REAL :: pl, pr, qsum, dp, esl
18486  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
18487  INTEGER :: i, k, l, m, k0
18488  REAL :: temp_ad
18489  REAL :: temp_ad0
18490  REAL :: temp_ad1
18491  REAL :: temp_ad2
18492  REAL :: temp_ad3
18493  REAL :: temp
18494  REAL :: temp_ad4
18495  REAL :: temp_ad5
18496  REAL :: temp_ad6
18497  REAL :: temp_ad7
18498  REAL :: temp0
18499  REAL :: temp_ad8
18500  REAL :: temp_ad9
18501  REAL :: temp_ad10
18502  REAL :: temp1
18503  REAL :: temp_ad11
18504  INTEGER :: ad_count
18505  INTEGER :: i0
18506  INTEGER :: branch
18507  INTEGER :: ad_count0
18508  INTEGER :: i3
18509 
18510  dp1 = 0.0
18511  q4 = 0.0
18512  pl = 0.0
18513  pr = 0.0
18514  qsum = 0.0
18515  dp = 0.0
18516  esl = 0.0
18517  i = 0
18518  k = 0
18519  l = 0
18520  m = 0
18521  k0 = 0
18522  ad_count = 0
18523  ad_count0 = 0
18524  branch = 0
18525 
18526  CALL popinteger(l)
18527  CALL popinteger(m)
18528  CALL poprealarray(dp1, (i2-i1+1)*km)
18529  CALL poprealarray(qsum)
18530  CALL poprealarray(q4, 4*(i2-i1+1)*km)
18531  dp1_ad = 0.0
18532  qsum_ad = 0.0
18533  q4_ad = 0.0
18534  DO i=i2,i1,-1
18535  DO k=kn,1,-1
18536  CALL popcontrol(1,branch)
18537  IF (branch .EQ. 0) THEN
18538  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18539  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18540  CALL poprealarray(q2(i, j, k))
18541  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, j, k)
18542  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
18543 & j, k)
18544  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, j, k))
18545  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, j, k) - temp_ad0
18546  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
18547 & **2)*q2_ad(i, j, k)
18548  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
18549  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
18550  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
18551  q2_ad(i, j, k) = 0.0
18552  temp_ad3 = pr_ad/dp1(i, l)
18553  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
18554  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
18555  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
18556 & /dp1(i, l)
18557  ELSE
18558  CALL poprealarray(q2(i, j, k))
18559  temp1 = pe2(i, k+1) - pe2(i, k)
18560  temp_ad11 = -(qsum*q2_ad(i, j, k)/temp1**2)
18561  qsum_ad = qsum_ad + q2_ad(i, j, k)/temp1
18562  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad11
18563  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad11
18564  q2_ad(i, j, k) = 0.0
18565  CALL popcontrol(2,branch)
18566  IF (branch .EQ. 0) THEN
18567  dp = pe2(i, k+1) - pe1(i, m)
18568  esl = dp/dp1(i, m)
18569  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
18570 & 1.)
18571  temp_ad8 = dp*qsum_ad
18572  temp_ad9 = 0.5*esl*temp_ad8
18573  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
18574  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
18575  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
18576  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
18577  temp_ad10 = esl_ad/dp1(i, m)
18578  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
18579  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
18580  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
18581  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
18582  ELSE IF (branch .NE. 1) THEN
18583  GOTO 100
18584  END IF
18585  CALL popinteger(ad_count0)
18586  DO i3=1,ad_count0
18587  IF (i3 .EQ. 1) THEN
18588  CALL popcontrol(1,branch)
18589  ELSE
18590  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
18591  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
18592  END IF
18593  CALL popinteger(m)
18594  END DO
18595  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18596  CALL poprealarray(qsum)
18597  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
18598  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
18599 & *(pl+1.)+1.)))*qsum_ad
18600  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
18601  temp_ad6 = 0.5*(pl+1.)*temp_ad5
18602  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
18603  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
18604  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
18605  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
18606  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
18607 & )*temp_ad5
18608  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
18609  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
18610  qsum_ad = 0.0
18611  END IF
18612  temp_ad = pl_ad/dp1(i, l)
18613  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
18614  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
18615  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
18616 & i, l)
18617  100 CALL popinteger(ad_count)
18618  DO i0=1,ad_count
18619  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
18620  CALL popinteger(l)
18621  END DO
18622  END DO
18623  END DO
18624  CALL popcontrol(1,branch)
18625  IF (branch .NE. 0) CALL cs_profile_bwd(qs, qs_ad, q4, q4_ad, dp1&
18626 & , dp1_ad, km, i1, i2, iv, kord)
18627  DO k=km,1,-1
18628  DO i=i2,i1,-1
18629  q2_ad(i, j, k) = q2_ad(i, j, k) + q4_ad(1, i, k)
18630  q4_ad(1, i, k) = 0.0
18631  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
18632  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
18633  dp1_ad(i, k) = 0.0
18634  END DO
18635  END DO
18636  END SUBROUTINE map1_ppm_bwd
18637 ! Differentiation of mapn_tracer in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
18638 !ge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_c
18639 !ore_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_m
18640 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
18641 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
18642 !_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mo
18643 !d.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_
18644 !2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limit
18645 !ers fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic
18646 !fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_su
18647 !bgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_ut
18648 !ils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_util
18649 !s_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils
18650 !_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mo
18651 !d.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.yt
18652 !p_v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_c
18653 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
18654 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18655 ! gradient of useful results: pe1 pe2 dp2 q1
18656 ! with respect to varying inputs: pe1 pe2 dp2 q1
18657  SUBROUTINE mapn_tracer_fwd(nq, km, pe1, pe2, q1, dp2, kord, j, i1, &
18658 & i2, isd, ied, jsd, jed, q_min, fill)
18659  IMPLICIT NONE
18660 ! !INPUT PARAMETERS:
18661 ! vertical dimension
18662  INTEGER, INTENT(IN) :: km
18663  INTEGER, INTENT(IN) :: j, nq, i1, i2
18664  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
18665  INTEGER, INTENT(IN) :: kord(nq)
18666 ! pressure at layer edges
18667  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
18668 ! (from model top to bottom surface)
18669 ! in the original vertical coordinate
18670 ! pressure at layer edges
18671  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
18672 ! (from model top to bottom surface)
18673 ! in the new vertical coordinate
18674  REAL, INTENT(IN) :: dp2(i1:i2, km)
18675  REAL, INTENT(IN) :: q_min
18676  LOGICAL, INTENT(IN) :: fill
18677 ! Field input
18678  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
18679 ! !LOCAL VARIABLES:
18680  REAL :: q4(4, i1:i2, km, nq)
18681 ! Field output
18682  REAL :: q2(i1:i2, km, nq)
18683  REAL :: qsum(nq)
18684  REAL :: dp1(i1:i2, km)
18685  REAL :: qs(i1:i2)
18686  REAL :: pl, pr, dp, esl, fac1, fac2
18687  INTEGER :: i, k, l, m, k0, iq
18688  INTEGER :: arg1
18689  INTEGER :: ad_count
18690  INTEGER :: ad_count0
18691 
18692  q4 = 0.0
18693  q2 = 0.0
18694  qsum = 0.0
18695  dp1 = 0.0
18696  qs = 0.0
18697  pl = 0.0
18698  pr = 0.0
18699  dp = 0.0
18700  esl = 0.0
18701  fac1 = 0.0
18702  fac2 = 0.0
18703  i = 0
18704  k = 0
18705  l = 0
18706  m = 0
18707  k0 = 0
18708  iq = 0
18709  arg1 = 0
18710  ad_count = 0
18711  ad_count0 = 0
18712 
18713  DO k=1,km
18714  DO i=i1,i2
18715  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
18716  END DO
18717  END DO
18718  DO iq=1,nq
18719  DO k=1,km
18720  DO i=i1,i2
18721  q4(1, i, k, iq) = q1(i, j, k, iq)
18722  END DO
18723  END DO
18724  CALL scalar_profile_fwd(qs, q4(1:4, i1:i2, 1:km, iq), dp1, km, &
18725 & i1, i2, 0, kord(iq), q_min)
18726  END DO
18727 ! Mapping
18728  DO i=i1,i2
18729  k0 = 1
18730  DO 130 k=1,km
18731  CALL pushinteger(l)
18732  ad_count = 1
18733  DO l=k0,km
18734 ! locate the top edge: pe2(i,k)
18735  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
18736 & ) THEN
18737  GOTO 100
18738  ELSE
18739  CALL pushinteger(l)
18740  ad_count = ad_count + 1
18741  END IF
18742  END DO
18743  CALL pushcontrol(1,0)
18744  CALL pushinteger(ad_count)
18745  CALL pushcontrol(2,2)
18746  GOTO 120
18747  100 CALL pushcontrol(1,1)
18748  CALL pushinteger(ad_count)
18749  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18750  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
18751 ! entire new grid is within the original grid
18752  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18753  CALL pushrealarray(fac1)
18754  fac1 = pr + pl
18755  CALL pushrealarray(fac2)
18756  fac2 = r3*(pr*fac1+pl*pl)
18757  CALL pushrealarray(fac1)
18758  fac1 = 0.5*fac1
18759  DO iq=1,nq
18760  q2(i, k, iq) = q4(2, i, l, iq) + (q4(4, i, l, iq)+q4(3, i, l&
18761 & , iq)-q4(2, i, l, iq))*fac1 - q4(4, i, l, iq)*fac2
18762  END DO
18763  k0 = l
18764  CALL pushcontrol(1,0)
18765  GOTO 130
18766  ELSE
18767 ! Fractional area...
18768  CALL pushrealarray(dp)
18769  dp = pe1(i, l+1) - pe2(i, k)
18770  CALL pushrealarray(fac1)
18771  fac1 = 1. + pl
18772  CALL pushrealarray(fac2)
18773  fac2 = r3*(1.+pl*fac1)
18774  CALL pushrealarray(fac1)
18775  fac1 = 0.5*fac1
18776  DO iq=1,nq
18777  CALL pushrealarray(qsum(iq))
18778  qsum(iq) = dp*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, i, l, &
18779 & iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2)
18780  END DO
18781  CALL pushinteger(m)
18782  ad_count0 = 1
18783  DO m=l+1,km
18784 ! locate the bottom edge: pe2(i,k+1)
18785  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
18786 ! Whole layer..
18787  DO iq=1,nq
18788  CALL pushrealarray(qsum(iq))
18789  qsum(iq) = qsum(iq) + dp1(i, m)*q4(1, i, m, iq)
18790  END DO
18791  CALL pushinteger(m)
18792  ad_count0 = ad_count0 + 1
18793  ELSE
18794  GOTO 110
18795  END IF
18796  END DO
18797  CALL pushcontrol(1,0)
18798  CALL pushinteger(ad_count0)
18799  CALL pushcontrol(2,1)
18800  GOTO 120
18801  110 CALL pushcontrol(1,1)
18802  CALL pushinteger(ad_count0)
18803  CALL pushrealarray(dp)
18804  dp = pe2(i, k+1) - pe1(i, m)
18805  esl = dp/dp1(i, m)
18806  CALL pushrealarray(fac1)
18807  fac1 = 0.5*esl
18808  CALL pushrealarray(fac2)
18809  fac2 = 1. - r23*esl
18810  DO iq=1,nq
18811  CALL pushrealarray(qsum(iq))
18812  qsum(iq) = qsum(iq) + dp*(q4(2, i, m, iq)+fac1*(q4(3, i, m, &
18813 & iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2))
18814  END DO
18815  k0 = m
18816  CALL pushcontrol(2,0)
18817  END IF
18818  120 DO iq=1,nq
18819  q2(i, k, iq) = qsum(iq)/dp2(i, k)
18820  END DO
18821  CALL pushcontrol(1,1)
18822  130 CONTINUE
18823  END DO
18824  DO iq=1,nq
18825 ! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2)
18826  DO k=1,km
18827  DO i=i1,i2
18828  CALL pushrealarray(q1(i, j, k, iq))
18829  q1(i, j, k, iq) = q2(i, k, iq)
18830  END DO
18831  END DO
18832  END DO
18833  CALL pushrealarray(q4, 4*(i2-i1+1)*km*nq)
18834  CALL pushrealarray(qsum, nq)
18835  CALL pushrealarray(dp1, (i2-i1+1)*km)
18836  CALL pushrealarray(qs, i2 - i1 + 1)
18837  CALL pushrealarray(fac2)
18838  CALL pushrealarray(fac1)
18839  CALL pushrealarray(dp)
18840  CALL pushinteger(m)
18841  CALL pushinteger(l)
18842  END SUBROUTINE mapn_tracer_fwd
18843 ! Differentiation of mapn_tracer in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_e
18844 !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_
18845 !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_
18846 !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
18847 !leigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2
18848 !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
18849 !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
18850 !_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
18851 !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
18852 ! 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
18853 !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
18854 !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
18855 !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
18856 !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
18857 !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
18858 !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_
18859 !core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_
18860 !utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
18861 ! gradient of useful results: pe1 pe2 dp2 q1
18862 ! with respect to varying inputs: pe1 pe2 dp2 q1
18863  SUBROUTINE mapn_tracer_bwd(nq, km, pe1, pe1_ad, pe2, pe2_ad, q1, &
18864 & q1_ad, dp2, dp2_ad, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill&
18865 & )
18866  IMPLICIT NONE
18867  INTEGER, INTENT(IN) :: km
18868  INTEGER, INTENT(IN) :: j, nq, i1, i2
18869  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
18870  INTEGER, INTENT(IN) :: kord(nq)
18871  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
18872  REAL :: pe1_ad(i1:i2, km+1)
18873  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
18874  REAL :: pe2_ad(i1:i2, km+1)
18875  REAL, INTENT(IN) :: dp2(i1:i2, km)
18876  REAL :: dp2_ad(i1:i2, km)
18877  REAL, INTENT(IN) :: q_min
18878  LOGICAL, INTENT(IN) :: fill
18879  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
18880  REAL, INTENT(INOUT) :: q1_ad(isd:ied, jsd:jed, km, nq)
18881  REAL :: q4(4, i1:i2, km, nq)
18882  REAL :: q4_ad(4, i1:i2, km, nq)
18883  REAL :: q2(i1:i2, km, nq)
18884  REAL :: q2_ad(i1:i2, km, nq)
18885  REAL :: qsum(nq)
18886  REAL :: qsum_ad(nq)
18887  REAL :: dp1(i1:i2, km)
18888  REAL :: dp1_ad(i1:i2, km)
18889  REAL :: qs(i1:i2)
18890  REAL :: pl, pr, dp, esl, fac1, fac2
18891  REAL :: pl_ad, pr_ad, dp_ad, esl_ad, fac1_ad, fac2_ad
18892  INTEGER :: i, k, l, m, k0, iq
18893  INTEGER :: arg1
18894  REAL :: temp_ad
18895  REAL :: temp_ad0
18896  REAL :: temp_ad1
18897  REAL :: temp_ad2
18898  REAL :: temp
18899  REAL :: temp_ad3
18900  REAL :: temp_ad4
18901  REAL :: temp_ad5
18902  REAL :: temp0
18903  REAL :: temp_ad6
18904  REAL :: temp_ad7
18905  REAL :: temp_ad8
18906  INTEGER :: ad_count
18907  INTEGER :: i0
18908  INTEGER :: branch
18909  INTEGER :: ad_count0
18910  INTEGER :: i3
18911 
18912  q4 = 0.0
18913  q2 = 0.0
18914  qsum = 0.0
18915  dp1 = 0.0
18916  qs = 0.0
18917  pl = 0.0
18918  pr = 0.0
18919  dp = 0.0
18920  esl = 0.0
18921  fac1 = 0.0
18922  fac2 = 0.0
18923  i = 0
18924  k = 0
18925  l = 0
18926  m = 0
18927  k0 = 0
18928  iq = 0
18929  arg1 = 0
18930  ad_count = 0
18931  ad_count0 = 0
18932  branch = 0
18933 
18934  CALL popinteger(l)
18935  CALL popinteger(m)
18936  CALL poprealarray(dp)
18937  CALL poprealarray(fac1)
18938  CALL poprealarray(fac2)
18939  CALL poprealarray(qs, i2 - i1 + 1)
18940  CALL poprealarray(dp1, (i2-i1+1)*km)
18941  CALL poprealarray(qsum, nq)
18942  CALL poprealarray(q4, 4*(i2-i1+1)*km*nq)
18943  q2_ad = 0.0
18944  DO iq=nq,1,-1
18945  DO k=km,1,-1
18946  DO i=i2,i1,-1
18947  CALL poprealarray(q1(i, j, k, iq))
18948  q2_ad(i, k, iq) = q2_ad(i, k, iq) + q1_ad(i, j, k, iq)
18949  q1_ad(i, j, k, iq) = 0.0
18950  END DO
18951  END DO
18952  END DO
18953  dp1_ad = 0.0
18954  qsum_ad = 0.0
18955  q4_ad = 0.0
18956  DO i=i2,i1,-1
18957  DO k=km,1,-1
18958  CALL popcontrol(1,branch)
18959  IF (branch .EQ. 0) THEN
18960  fac1_ad = 0.0
18961  fac2_ad = 0.0
18962  DO iq=nq,1,-1
18963  temp_ad2 = fac1*q2_ad(i, k, iq)
18964  q4_ad(2, i, l, iq) = q4_ad(2, i, l, iq) + q2_ad(i, k, iq) - &
18965 & temp_ad2
18966  q4_ad(4, i, l, iq) = q4_ad(4, i, l, iq) + temp_ad2 - fac2*&
18967 & q2_ad(i, k, iq)
18968  q4_ad(3, i, l, iq) = q4_ad(3, i, l, iq) + temp_ad2
18969  fac1_ad = fac1_ad + (q4(4, i, l, iq)+q4(3, i, l, iq)-q4(2, i&
18970 & , l, iq))*q2_ad(i, k, iq)
18971  fac2_ad = fac2_ad - q4(4, i, l, iq)*q2_ad(i, k, iq)
18972  q2_ad(i, k, iq) = 0.0
18973  END DO
18974  temp_ad0 = r3*fac2_ad
18975  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
18976  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
18977  CALL poprealarray(fac1)
18978  fac1_ad = pr*temp_ad0 + 0.5*fac1_ad
18979  CALL poprealarray(fac2)
18980  pr_ad = fac1_ad + fac1*temp_ad0
18981  pl_ad = fac1_ad + 2*pl*temp_ad0
18982  CALL poprealarray(fac1)
18983  temp_ad1 = pr_ad/dp1(i, l)
18984  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad1
18985  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad1
18986  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad1&
18987 & /dp1(i, l)
18988  ELSE
18989  DO iq=nq,1,-1
18990  temp_ad8 = q2_ad(i, k, iq)/dp2(i, k)
18991  qsum_ad(iq) = qsum_ad(iq) + temp_ad8
18992  dp2_ad(i, k) = dp2_ad(i, k) - qsum(iq)*temp_ad8/dp2(i, k)
18993  q2_ad(i, k, iq) = 0.0
18994  END DO
18995  CALL popcontrol(2,branch)
18996  IF (branch .EQ. 0) THEN
18997  dp = pe2(i, k+1) - pe1(i, m)
18998  esl = dp/dp1(i, m)
18999  fac1 = 0.5*esl
19000  fac2 = 1. - r23*esl
19001  dp_ad = 0.0
19002  fac1_ad = 0.0
19003  fac2_ad = 0.0
19004  DO iq=nq,1,-1
19005  CALL poprealarray(qsum(iq))
19006  temp0 = q4(3, i, m, iq) - q4(2, i, m, iq) + q4(4, i, m, iq&
19007 & )*fac2
19008  temp_ad6 = dp*qsum_ad(iq)
19009  temp_ad7 = fac1*temp_ad6
19010  dp_ad = dp_ad + (q4(2, i, m, iq)+fac1*temp0)*qsum_ad(iq)
19011  q4_ad(2, i, m, iq) = q4_ad(2, i, m, iq) + temp_ad6 - &
19012 & temp_ad7
19013  fac1_ad = fac1_ad + temp0*temp_ad6
19014  q4_ad(3, i, m, iq) = q4_ad(3, i, m, iq) + temp_ad7
19015  q4_ad(4, i, m, iq) = q4_ad(4, i, m, iq) + fac2*temp_ad7
19016  fac2_ad = fac2_ad + q4(4, i, m, iq)*temp_ad7
19017  END DO
19018  CALL poprealarray(fac2)
19019  esl_ad = 0.5*fac1_ad - r23*fac2_ad
19020  CALL poprealarray(fac1)
19021  temp_ad5 = esl_ad/dp1(i, m)
19022  dp_ad = dp_ad + temp_ad5
19023  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad5/dp1(i, m)
19024  CALL poprealarray(dp)
19025  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
19026  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
19027  ELSE IF (branch .NE. 1) THEN
19028  GOTO 100
19029  END IF
19030  CALL popinteger(ad_count0)
19031  DO i3=1,ad_count0
19032  IF (i3 .EQ. 1) THEN
19033  CALL popcontrol(1,branch)
19034  ELSE
19035  DO iq=nq,1,-1
19036  CALL poprealarray(qsum(iq))
19037  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m, iq)*qsum_ad(iq&
19038 & )
19039  q4_ad(1, i, m, iq) = q4_ad(1, i, m, iq) + dp1(i, m)*&
19040 & qsum_ad(iq)
19041  END DO
19042  END IF
19043  CALL popinteger(m)
19044  END DO
19045  dp_ad = 0.0
19046  fac1_ad = 0.0
19047  fac2_ad = 0.0
19048  DO iq=nq,1,-1
19049  CALL poprealarray(qsum(iq))
19050  temp = q4(4, i, l, iq) + q4(3, i, l, iq) - q4(2, i, l, iq)
19051  temp_ad3 = dp*qsum_ad(iq)
19052  temp_ad4 = fac1*temp_ad3
19053  dp_ad = dp_ad + (q4(2, i, l, iq)+temp*fac1-q4(4, i, l, iq)*&
19054 & fac2)*qsum_ad(iq)
19055  q4_ad(2, i, l, iq) = q4_ad(2, i, l, iq) + temp_ad3 - &
19056 & temp_ad4
19057  q4_ad(4, i, l, iq) = q4_ad(4, i, l, iq) + temp_ad4 - fac2*&
19058 & temp_ad3
19059  q4_ad(3, i, l, iq) = q4_ad(3, i, l, iq) + temp_ad4
19060  fac1_ad = fac1_ad + temp*temp_ad3
19061  fac2_ad = fac2_ad - q4(4, i, l, iq)*temp_ad3
19062  qsum_ad(iq) = 0.0
19063  END DO
19064  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
19065  CALL poprealarray(fac1)
19066  fac1_ad = r3*pl*fac2_ad + 0.5*fac1_ad
19067  CALL poprealarray(fac2)
19068  pl_ad = fac1_ad + r3*fac1*fac2_ad
19069  CALL poprealarray(fac1)
19070  CALL poprealarray(dp)
19071  pe1_ad(i, l+1) = pe1_ad(i, l+1) + dp_ad
19072  pe2_ad(i, k) = pe2_ad(i, k) - dp_ad
19073  END IF
19074  temp_ad = pl_ad/dp1(i, l)
19075  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
19076  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
19077  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
19078 & i, l)
19079  100 CALL popinteger(ad_count)
19080  DO i0=1,ad_count
19081  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
19082  CALL popinteger(l)
19083  END DO
19084  END DO
19085  END DO
19086  DO iq=nq,1,-1
19087  CALL scalar_profile_bwd(qs, q4(1:4, i1:i2, 1:km, iq), q4_ad(1:4&
19088 & , i1:i2, 1:km, iq), dp1, dp1_ad, km, i1, i2, &
19089 & 0, kord(iq), q_min)
19090  DO k=km,1,-1
19091  DO i=i2,i1,-1
19092  q1_ad(i, j, k, iq) = q1_ad(i, j, k, iq) + q4_ad(1, i, k, iq)
19093  q4_ad(1, i, k, iq) = 0.0
19094  END DO
19095  END DO
19096  END DO
19097  DO k=km,1,-1
19098  DO i=i2,i1,-1
19099  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
19100  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
19101  dp1_ad(i, k) = 0.0
19102  END DO
19103  END DO
19104  END SUBROUTINE mapn_tracer_bwd
19105 ! Differentiation of map1_q2 in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
19106 !od.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_
19107 !mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.m
19108 !ix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh
19109 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
19110 !4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.re
19111 !map_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d f
19112 !v_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
19113 !fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_r
19114 !estart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgri
19115 !d_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_
19116 !mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mo
19117 !d.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod
19118 !.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2
19119 !a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_
19120 !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_
19121 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
19122 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19123 ! gradient of useful results: pe1 pe2 dp2 q1 q2
19124 ! with respect to varying inputs: pe1 pe2 dp2 q1 q2
19125  SUBROUTINE map1_q2_fwd(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, &
19126 & kord, j, ibeg, iend, jbeg, jend, q_min)
19127  IMPLICIT NONE
19128 ! !INPUT PARAMETERS:
19129  INTEGER, INTENT(IN) :: j
19130  INTEGER, INTENT(IN) :: i1, i2
19131  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
19132 ! Mode: 0 == constituents 1 == ???
19133  INTEGER, INTENT(IN) :: iv
19134  INTEGER, INTENT(IN) :: kord
19135 ! Original vertical dimension
19136  INTEGER, INTENT(IN) :: km
19137 ! Target vertical dimension
19138  INTEGER, INTENT(IN) :: kn
19139 ! pressure at layer edges
19140  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
19141 ! (from model top to bottom surface)
19142 ! in the original vertical coordinate
19143 ! pressure at layer edges
19144  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
19145 ! (from model top to bottom surface)
19146 ! in the new vertical coordinate
19147 ! Field input
19148  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
19149  REAL, INTENT(IN) :: dp2(i1:i2, kn)
19150  REAL, INTENT(IN) :: q_min
19151 ! !INPUT/OUTPUT PARAMETERS:
19152 ! Field output
19153  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
19154 ! !LOCAL VARIABLES:
19155  REAL :: qs(i1:i2)
19156  REAL :: dp1(i1:i2, km)
19157  REAL :: q4(4, i1:i2, km)
19158  REAL :: pl, pr, qsum, dp, esl
19159  INTEGER :: i, k, l, m, k0
19160  INTEGER :: ad_count
19161  INTEGER :: ad_count0
19162 
19163  qs = 0.0
19164  dp1 = 0.0
19165  q4 = 0.0
19166  pl = 0.0
19167  pr = 0.0
19168  qsum = 0.0
19169  dp = 0.0
19170  esl = 0.0
19171  i = 0
19172  k = 0
19173  l = 0
19174  m = 0
19175  k0 = 0
19176  ad_count = 0
19177  ad_count0 = 0
19178 
19179  DO k=1,km
19180  DO i=i1,i2
19181  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
19182  q4(1, i, k) = q1(i, j, k)
19183  END DO
19184  END DO
19185 ! Compute vertical subgrid distribution
19186  IF (kord .GT. 7) THEN
19187  CALL scalar_profile_fwd(qs, q4, dp1, km, i1, i2, iv, kord, &
19188 & q_min)
19189 !else
19190 !call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
19191  CALL pushcontrol(1,1)
19192  ELSE
19193  CALL pushcontrol(1,0)
19194  END IF
19195 ! Mapping
19196  DO i=i1,i2
19197  k0 = 1
19198  DO 120 k=1,kn
19199  CALL pushinteger(l)
19200  ad_count = 1
19201  DO l=k0,km
19202 ! locate the top edge: pe2(i,k)
19203  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
19204 & ) THEN
19205  GOTO 100
19206  ELSE
19207  CALL pushinteger(l)
19208  ad_count = ad_count + 1
19209  END IF
19210  END DO
19211  CALL pushcontrol(1,0)
19212  CALL pushinteger(ad_count)
19213  CALL pushcontrol(2,2)
19214  GOTO 123
19215  100 CALL pushcontrol(1,1)
19216  CALL pushinteger(ad_count)
19217  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
19218  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
19219 ! entire new grid is within the original grid
19220  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
19221  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i&
19222 & , l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
19223  k0 = l
19224  CALL pushcontrol(1,0)
19225  GOTO 120
19226  ELSE
19227 ! Fractional area...
19228  CALL pushrealarray(qsum)
19229  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
19230 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
19231 & pl))))
19232  CALL pushinteger(m)
19233  ad_count0 = 1
19234  DO m=l+1,km
19235 ! locate the bottom edge: pe2(i,k+1)
19236  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
19237 ! Whole layer..
19238  qsum = qsum + dp1(i, m)*q4(1, i, m)
19239  CALL pushinteger(m)
19240  ad_count0 = ad_count0 + 1
19241  ELSE
19242  GOTO 110
19243  END IF
19244  END DO
19245  CALL pushcontrol(1,0)
19246  CALL pushinteger(ad_count0)
19247  CALL pushcontrol(2,1)
19248  GOTO 123
19249  110 CALL pushcontrol(1,1)
19250  CALL pushinteger(ad_count0)
19251  dp = pe2(i, k+1) - pe1(i, m)
19252  esl = dp/dp1(i, m)
19253  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
19254 & +q4(4, i, m)*(1.-r23*esl)))
19255  k0 = m
19256  CALL pushcontrol(2,0)
19257  END IF
19258  123 q2(i, k) = qsum/dp2(i, k)
19259  CALL pushcontrol(1,1)
19260  120 CONTINUE
19261  END DO
19262  CALL pushrealarray(q4, 4*(i2-i1+1)*km)
19263  CALL pushrealarray(qsum)
19264  CALL pushrealarray(dp1, (i2-i1+1)*km)
19265  CALL pushrealarray(qs, i2 - i1 + 1)
19266  CALL pushinteger(m)
19267  CALL pushinteger(l)
19268  END SUBROUTINE map1_q2_fwd
19269 ! Differentiation of map1_q2 in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
19270 !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
19271 !_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.
19272 !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
19273 !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
19274 !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
19275 !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
19276 !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
19277 ! 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_
19278 !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
19279 !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
19280 !_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
19281 !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
19282 !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
19283 !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
19284 !_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
19285 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
19286 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19287 ! gradient of useful results: pe1 pe2 dp2 q1 q2
19288 ! with respect to varying inputs: pe1 pe2 dp2 q1 q2
19289  SUBROUTINE map1_q2_bwd(km, pe1, pe1_ad, q1, q1_ad, kn, pe2, pe2_ad&
19290 & , q2, q2_ad, dp2, dp2_ad, i1, i2, iv, kord, j, ibeg, iend, jbeg, &
19291 & jend, q_min)
19292  IMPLICIT NONE
19293  INTEGER, INTENT(IN) :: j
19294  INTEGER, INTENT(IN) :: i1, i2
19295  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
19296  INTEGER, INTENT(IN) :: iv
19297  INTEGER, INTENT(IN) :: kord
19298  INTEGER, INTENT(IN) :: km
19299  INTEGER, INTENT(IN) :: kn
19300  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
19301  REAL :: pe1_ad(i1:i2, km+1)
19302  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
19303  REAL :: pe2_ad(i1:i2, kn+1)
19304  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
19305  REAL :: q1_ad(ibeg:iend, jbeg:jend, km)
19306  REAL, INTENT(IN) :: dp2(i1:i2, kn)
19307  REAL :: dp2_ad(i1:i2, kn)
19308  REAL, INTENT(IN) :: q_min
19309  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
19310  REAL, INTENT(INOUT) :: q2_ad(i1:i2, kn)
19311  REAL :: qs(i1:i2)
19312  REAL :: dp1(i1:i2, km)
19313  REAL :: dp1_ad(i1:i2, km)
19314  REAL :: q4(4, i1:i2, km)
19315  REAL :: q4_ad(4, i1:i2, km)
19316  REAL :: pl, pr, qsum, dp, esl
19317  REAL :: pl_ad, pr_ad, qsum_ad, dp_ad, esl_ad
19318  INTEGER :: i, k, l, m, k0
19319  REAL :: temp_ad
19320  REAL :: temp_ad0
19321  REAL :: temp_ad1
19322  REAL :: temp_ad2
19323  REAL :: temp_ad3
19324  REAL :: temp
19325  REAL :: temp_ad4
19326  REAL :: temp_ad5
19327  REAL :: temp_ad6
19328  REAL :: temp_ad7
19329  REAL :: temp0
19330  REAL :: temp_ad8
19331  REAL :: temp_ad9
19332  REAL :: temp_ad10
19333  REAL :: temp_ad11
19334  INTEGER :: ad_count
19335  INTEGER :: i0
19336  INTEGER :: branch
19337  INTEGER :: ad_count0
19338  INTEGER :: i3
19339 
19340  qs = 0.0
19341  dp1 = 0.0
19342  q4 = 0.0
19343  pl = 0.0
19344  pr = 0.0
19345  qsum = 0.0
19346  dp = 0.0
19347  esl = 0.0
19348  i = 0
19349  k = 0
19350  l = 0
19351  m = 0
19352  k0 = 0
19353  ad_count = 0
19354  ad_count0 = 0
19355  branch = 0
19356 
19357  CALL popinteger(l)
19358  CALL popinteger(m)
19359  CALL poprealarray(qs, i2 - i1 + 1)
19360  CALL poprealarray(dp1, (i2-i1+1)*km)
19361  CALL poprealarray(qsum)
19362  CALL poprealarray(q4, 4*(i2-i1+1)*km)
19363  dp1_ad = 0.0
19364  qsum_ad = 0.0
19365  q4_ad = 0.0
19366  DO i=i2,i1,-1
19367  DO k=kn,1,-1
19368  CALL popcontrol(1,branch)
19369  IF (branch .EQ. 0) THEN
19370  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
19371  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
19372  temp_ad0 = 0.5*(pr+pl)*q2_ad(i, k)
19373  temp_ad1 = 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i, l))*q2_ad(i, &
19374 & k)
19375  temp_ad2 = -(r3*q4(4, i, l)*q2_ad(i, k))
19376  q4_ad(2, i, l) = q4_ad(2, i, l) + q2_ad(i, k) - temp_ad0
19377  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad0 - r3*(pr*(pr+pl)+pl&
19378 & **2)*q2_ad(i, k)
19379  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad0
19380  pr_ad = (2*pr+pl)*temp_ad2 + temp_ad1
19381  pl_ad = (2*pl+pr)*temp_ad2 + temp_ad1
19382  q2_ad(i, k) = 0.0
19383  temp_ad3 = pr_ad/dp1(i, l)
19384  pe2_ad(i, k+1) = pe2_ad(i, k+1) + temp_ad3
19385  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad3
19386  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k+1)-pe1(i, l))*temp_ad3&
19387 & /dp1(i, l)
19388  ELSE
19389  temp_ad11 = q2_ad(i, k)/dp2(i, k)
19390  qsum_ad = qsum_ad + temp_ad11
19391  dp2_ad(i, k) = dp2_ad(i, k) - qsum*temp_ad11/dp2(i, k)
19392  q2_ad(i, k) = 0.0
19393  CALL popcontrol(2,branch)
19394  IF (branch .EQ. 0) THEN
19395  dp = pe2(i, k+1) - pe1(i, m)
19396  esl = dp/dp1(i, m)
19397  temp0 = q4(3, i, m) - q4(2, i, m) + q4(4, i, m)*(-(r23*esl)+&
19398 & 1.)
19399  temp_ad8 = dp*qsum_ad
19400  temp_ad9 = 0.5*esl*temp_ad8
19401  q4_ad(2, i, m) = q4_ad(2, i, m) + temp_ad8 - temp_ad9
19402  esl_ad = 0.5*temp0*temp_ad8 - q4(4, i, m)*r23*temp_ad9
19403  q4_ad(3, i, m) = q4_ad(3, i, m) + temp_ad9
19404  q4_ad(4, i, m) = q4_ad(4, i, m) + (1.-r23*esl)*temp_ad9
19405  temp_ad10 = esl_ad/dp1(i, m)
19406  dp_ad = temp_ad10 + (q4(2, i, m)+0.5*(esl*temp0))*qsum_ad
19407  dp1_ad(i, m) = dp1_ad(i, m) - dp*temp_ad10/dp1(i, m)
19408  pe2_ad(i, k+1) = pe2_ad(i, k+1) + dp_ad
19409  pe1_ad(i, m) = pe1_ad(i, m) - dp_ad
19410  ELSE IF (branch .NE. 1) THEN
19411  GOTO 100
19412  END IF
19413  CALL popinteger(ad_count0)
19414  DO i3=1,ad_count0
19415  IF (i3 .EQ. 1) THEN
19416  CALL popcontrol(1,branch)
19417  ELSE
19418  dp1_ad(i, m) = dp1_ad(i, m) + q4(1, i, m)*qsum_ad
19419  q4_ad(1, i, m) = q4_ad(1, i, m) + dp1(i, m)*qsum_ad
19420  END IF
19421  CALL popinteger(m)
19422  END DO
19423  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
19424  CALL poprealarray(qsum)
19425  temp = q4(4, i, l) + q4(3, i, l) - q4(2, i, l)
19426  temp_ad4 = (q4(2, i, l)+0.5*(temp*(pl+1.))-r3*(q4(4, i, l)*(pl&
19427 & *(pl+1.)+1.)))*qsum_ad
19428  temp_ad5 = (pe1(i, l+1)-pe2(i, k))*qsum_ad
19429  temp_ad6 = 0.5*(pl+1.)*temp_ad5
19430  temp_ad7 = -(r3*q4(4, i, l)*temp_ad5)
19431  pe1_ad(i, l+1) = pe1_ad(i, l+1) + temp_ad4
19432  pe2_ad(i, k) = pe2_ad(i, k) - temp_ad4
19433  q4_ad(2, i, l) = q4_ad(2, i, l) + temp_ad5 - temp_ad6
19434  q4_ad(4, i, l) = q4_ad(4, i, l) + temp_ad6 - r3*(pl*(pl+1.)+1.&
19435 & )*temp_ad5
19436  q4_ad(3, i, l) = q4_ad(3, i, l) + temp_ad6
19437  pl_ad = (2*pl+1.)*temp_ad7 + 0.5*temp*temp_ad5
19438  qsum_ad = 0.0
19439  END IF
19440  temp_ad = pl_ad/dp1(i, l)
19441  pe2_ad(i, k) = pe2_ad(i, k) + temp_ad
19442  pe1_ad(i, l) = pe1_ad(i, l) - temp_ad
19443  dp1_ad(i, l) = dp1_ad(i, l) - (pe2(i, k)-pe1(i, l))*temp_ad/dp1(&
19444 & i, l)
19445  100 CALL popinteger(ad_count)
19446  DO i0=1,ad_count
19447  IF (i0 .EQ. 1) CALL popcontrol(1,branch)
19448  CALL popinteger(l)
19449  END DO
19450  END DO
19451  END DO
19452  CALL popcontrol(1,branch)
19453  IF (branch .NE. 0) CALL scalar_profile_bwd(qs, q4, q4_ad, dp1, &
19454 & dp1_ad, km, i1, i2, iv, kord&
19455 & , q_min)
19456  DO k=km,1,-1
19457  DO i=i2,i1,-1
19458  q1_ad(i, j, k) = q1_ad(i, j, k) + q4_ad(1, i, k)
19459  q4_ad(1, i, k) = 0.0
19460  pe1_ad(i, k+1) = pe1_ad(i, k+1) + dp1_ad(i, k)
19461  pe1_ad(i, k) = pe1_ad(i, k) - dp1_ad(i, k)
19462  dp1_ad(i, k) = 0.0
19463  END DO
19464  END DO
19465  END SUBROUTINE map1_q2_bwd
19466 ! Differentiation of scalar_profile in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b
19467 !_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dy
19468 !n_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_cor
19469 !e_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.R
19470 !ayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.
19471 !c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz
19472 !_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rem
19473 !ap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_li
19474 !miters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cub
19475 !ic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv
19476 !_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
19477 !_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_u
19478 !tils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_ut
19479 !ils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core
19480 !_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
19481 !.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d t
19482 !p_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gri
19483 !d_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19484 ! gradient of useful results: delp a4
19485 ! with respect to varying inputs: delp a4
19486  SUBROUTINE scalar_profile_fwd(qs, a4, delp, km, i1, i2, iv, kord, &
19487 & qmin)
19488  IMPLICIT NONE
19489 ! Optimized vertical profile reconstruction:
19490 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
19491  INTEGER, INTENT(IN) :: i1, i2
19492 ! vertical dimension
19493  INTEGER, INTENT(IN) :: km
19494 ! iv =-1: winds
19495  INTEGER, INTENT(IN) :: iv
19496 ! iv = 0: positive definite scalars
19497 ! iv = 1: others
19498  INTEGER, INTENT(IN) :: kord
19499  REAL, INTENT(IN) :: qs(i1:i2)
19500 ! layer pressure thickness
19501  REAL, INTENT(IN) :: delp(i1:i2, km)
19502 ! Interpolated values
19503  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
19504  REAL, INTENT(IN) :: qmin
19505 !-----------------------------------------------------------------------
19506  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
19507  REAL :: gam(i1:i2, km)
19508  REAL :: q(i1:i2, km+1)
19509  REAL :: d4(i1:i2)
19510  REAL :: bet, a_bot, grat
19511  REAL :: pmp_1, lac_1, pmp_2, lac_2
19512  INTEGER :: i, k, im
19513  INTRINSIC abs
19514  INTEGER :: abs0
19515 
19516  gam = 0.0
19517  q = 0.0
19518  d4 = 0.0
19519  bet = 0.0
19520  a_bot = 0.0
19521  grat = 0.0
19522  pmp_1 = 0.0
19523  lac_1 = 0.0
19524  pmp_2 = 0.0
19525  lac_2 = 0.0
19526  i = 0
19527  k = 0
19528  im = 0
19529  abs0 = 0
19530 
19531  IF (iv .EQ. -2) THEN
19532  DO i=i1,i2
19533  gam(i, 2) = 0.5
19534  q(i, 1) = 1.5*a4(1, i, 1)
19535  END DO
19536  DO k=2,km-1
19537  DO i=i1,i2
19538  grat = delp(i, k-1)/delp(i, k)
19539  CALL pushrealarray(bet)
19540  bet = 2. + grat + grat - gam(i, k)
19541  CALL pushrealarray(q(i, k))
19542  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
19543  gam(i, k+1) = grat/bet
19544  END DO
19545  END DO
19546  DO i=i1,i2
19547  grat = delp(i, km-1)/delp(i, km)
19548  CALL pushrealarray(q(i, km))
19549  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
19550 & 1))/(2.+grat+grat-gam(i, km))
19551  CALL pushrealarray(q(i, km+1))
19552  q(i, km+1) = qs(i)
19553  END DO
19554  DO k=km-1,1,-1
19555  DO i=i1,i2
19556  CALL pushrealarray(q(i, k))
19557  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
19558  END DO
19559  END DO
19560  CALL pushcontrol(1,1)
19561  ELSE
19562  DO i=i1,i2
19563 ! grid ratio
19564  grat = delp(i, 2)/delp(i, 1)
19565  bet = grat*(grat+0.5)
19566  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
19567  gam(i, 1) = (1.+grat*(grat+1.5))/bet
19568  END DO
19569  DO k=2,km
19570  DO i=i1,i2
19571  CALL pushrealarray(d4(i))
19572  d4(i) = delp(i, k-1)/delp(i, k)
19573  CALL pushrealarray(bet)
19574  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
19575  CALL pushrealarray(q(i, k))
19576  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
19577  gam(i, k) = d4(i)/bet
19578  END DO
19579  END DO
19580  DO i=i1,i2
19581  a_bot = 1. + d4(i)*(d4(i)+1.5)
19582  CALL pushrealarray(q(i, km+1))
19583  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
19584 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
19585  END DO
19586  DO k=km,1,-1
19587  DO i=i1,i2
19588  CALL pushrealarray(q(i, k))
19589  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
19590  END DO
19591  END DO
19592  CALL pushcontrol(1,0)
19593  END IF
19594  IF (kord .GE. 0.) THEN
19595  abs0 = kord
19596  ELSE
19597  abs0 = -kord
19598  END IF
19599 !----- Perfectly linear scheme --------------------------------
19600  IF (abs0 .GT. 16) THEN
19601  DO k=1,km
19602  DO i=i1,i2
19603  CALL pushrealarray(a4(2, i, k))
19604  a4(2, i, k) = q(i, k)
19605  CALL pushrealarray(a4(3, i, k))
19606  a4(3, i, k) = q(i, k+1)
19607  CALL pushrealarray(a4(4, i, k))
19608  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
19609  END DO
19610  END DO
19611  CALL pushrealarray(gam, (i2-i1+1)*km)
19612  CALL pushrealarray(d4, i2 - i1 + 1)
19613  CALL pushrealarray(bet)
19614  CALL pushrealarray(q, (i2-i1+1)*(km+1))
19615  CALL pushcontrol(1,1)
19616  ELSE
19617  CALL pushrealarray(gam, (i2-i1+1)*km)
19618  CALL pushrealarray(d4, i2 - i1 + 1)
19619  CALL pushrealarray(bet)
19620  CALL pushrealarray(q, (i2-i1+1)*(km+1))
19621  CALL pushcontrol(1,0)
19622  END IF
19623  END SUBROUTINE scalar_profile_fwd
19624 ! Differentiation of scalar_profile in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2
19625 !b_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe d
19626 !yn_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_co
19627 !re_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.
19628 !Rayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod
19629 !.c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_map
19630 !z_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.re
19631 !map_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_l
19632 !imiters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cu
19633 !bic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.f
19634 !v_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d n
19635 !h_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_
19636 !utils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_u
19637 !tils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_cor
19638 !e_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mo
19639 !d.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d
19640 !tp_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gr
19641 !id_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19642 ! gradient of useful results: delp a4
19643 ! with respect to varying inputs: delp a4
19644  SUBROUTINE scalar_profile_bwd(qs, a4, a4_ad, delp, delp_ad, km, i1&
19645 & , i2, iv, kord, qmin)
19646  IMPLICIT NONE
19647  INTEGER, INTENT(IN) :: i1, i2
19648  INTEGER, INTENT(IN) :: km
19649  INTEGER, INTENT(IN) :: iv
19650  INTEGER, INTENT(IN) :: kord
19651  REAL, INTENT(IN) :: qs(i1:i2)
19652  REAL, INTENT(IN) :: delp(i1:i2, km)
19653  REAL :: delp_ad(i1:i2, km)
19654  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
19655  REAL, INTENT(INOUT) :: a4_ad(4, i1:i2, km)
19656  REAL, INTENT(IN) :: qmin
19657  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
19658  REAL :: gam(i1:i2, km)
19659  REAL :: gam_ad(i1:i2, km)
19660  REAL :: q(i1:i2, km+1)
19661  REAL :: q_ad(i1:i2, km+1)
19662  REAL :: d4(i1:i2)
19663  REAL :: d4_ad(i1:i2)
19664  REAL :: bet, a_bot, grat
19665  REAL :: bet_ad, a_bot_ad, grat_ad
19666  REAL :: pmp_1, lac_1, pmp_2, lac_2
19667  INTEGER :: i, k, im
19668  INTRINSIC abs
19669  INTEGER :: abs0
19670  REAL :: temp_ad
19671  REAL :: temp_ad0
19672  REAL :: temp
19673  REAL :: temp_ad1
19674  REAL :: temp_ad2
19675  REAL :: temp_ad3
19676  REAL :: temp0
19677  REAL :: temp_ad4
19678  REAL :: temp_ad5
19679  REAL :: temp_ad6
19680  REAL :: temp_ad7
19681  REAL :: temp_ad8
19682  REAL :: temp_ad9
19683  REAL :: temp_ad10
19684  REAL :: temp1
19685  REAL :: temp2
19686  REAL :: temp_ad11
19687  REAL :: temp_ad12
19688  REAL :: temp_ad13
19689  REAL :: temp_ad14
19690  INTEGER :: branch
19691 
19692  gam = 0.0
19693  q = 0.0
19694  d4 = 0.0
19695  bet = 0.0
19696  a_bot = 0.0
19697  grat = 0.0
19698  pmp_1 = 0.0
19699  lac_1 = 0.0
19700  pmp_2 = 0.0
19701  lac_2 = 0.0
19702  i = 0
19703  k = 0
19704  im = 0
19705  abs0 = 0
19706  branch = 0
19707 
19708  CALL popcontrol(1,branch)
19709  IF (branch .EQ. 0) THEN
19710  CALL poprealarray(q, (i2-i1+1)*(km+1))
19711  CALL poprealarray(bet)
19712  CALL poprealarray(d4, i2 - i1 + 1)
19713  CALL poprealarray(gam, (i2-i1+1)*km)
19714  q_ad = 0.0
19715  ELSE
19716  CALL poprealarray(q, (i2-i1+1)*(km+1))
19717  CALL poprealarray(bet)
19718  CALL poprealarray(d4, i2 - i1 + 1)
19719  CALL poprealarray(gam, (i2-i1+1)*km)
19720  q_ad = 0.0
19721  DO k=km,1,-1
19722  DO i=i2,i1,-1
19723  CALL poprealarray(a4(4, i, k))
19724  temp_ad14 = 3.*a4_ad(4, i, k)
19725  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad14
19726  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad14
19727  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad14
19728  a4_ad(4, i, k) = 0.0
19729  CALL poprealarray(a4(3, i, k))
19730  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
19731  a4_ad(3, i, k) = 0.0
19732  CALL poprealarray(a4(2, i, k))
19733  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
19734  a4_ad(2, i, k) = 0.0
19735  END DO
19736  END DO
19737  END IF
19738  CALL popcontrol(1,branch)
19739  IF (branch .EQ. 0) THEN
19740  gam_ad = 0.0
19741  DO k=1,km,1
19742  DO i=i2,i1,-1
19743  CALL poprealarray(q(i, k))
19744  gam_ad(i, k) = gam_ad(i, k) - q(i, k+1)*q_ad(i, k)
19745  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k)*q_ad(i, k)
19746  END DO
19747  END DO
19748  d4_ad = 0.0
19749  DO i=i2,i1,-1
19750  a_bot = 1. + d4(i)*(d4(i)+1.5)
19751  CALL poprealarray(q(i, km+1))
19752  temp2 = d4(i)*(d4(i)+0.5) - a_bot*gam(i, km)
19753  temp_ad11 = q_ad(i, km+1)/temp2
19754  temp1 = d4(i)*(d4(i)+1.)
19755  temp_ad12 = 2.*a4(1, i, km)*temp_ad11
19756  temp_ad13 = -((2.*(temp1*a4(1, i, km))+a4(1, i, km-1)-a_bot*q(i&
19757 & , km))*temp_ad11/temp2)
19758  a4_ad(1, i, km) = a4_ad(1, i, km) + 2.*temp1*temp_ad11
19759  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + temp_ad11
19760  a_bot_ad = -(gam(i, km)*temp_ad13) - q(i, km)*temp_ad11
19761  d4_ad(i) = d4_ad(i) + (2*d4(i)+1.5)*a_bot_ad + (2*d4(i)+0.5)*&
19762 & temp_ad13 + (2*d4(i)+1.)*temp_ad12
19763  q_ad(i, km) = q_ad(i, km) - a_bot*temp_ad11
19764  gam_ad(i, km) = gam_ad(i, km) - a_bot*temp_ad13
19765  q_ad(i, km+1) = 0.0
19766  END DO
19767  DO k=km,2,-1
19768  DO i=i2,i1,-1
19769  temp_ad9 = q_ad(i, k)/bet
19770  temp_ad8 = 3.*temp_ad9
19771  CALL poprealarray(q(i, k))
19772  bet_ad = -((3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))*&
19773 & temp_ad9/bet) - d4(i)*gam_ad(i, k)/bet**2
19774  d4_ad(i) = d4_ad(i) + a4(1, i, k)*temp_ad8 + 2*bet_ad + gam_ad&
19775 & (i, k)/bet
19776  gam_ad(i, k) = 0.0
19777  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + temp_ad8
19778  a4_ad(1, i, k) = a4_ad(1, i, k) + d4(i)*temp_ad8
19779  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad9
19780  q_ad(i, k) = 0.0
19781  CALL poprealarray(bet)
19782  gam_ad(i, k-1) = gam_ad(i, k-1) - bet_ad
19783  CALL poprealarray(d4(i))
19784  temp_ad10 = d4_ad(i)/delp(i, k)
19785  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad10
19786  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad10/delp(i&
19787 & , k)
19788  d4_ad(i) = 0.0
19789  END DO
19790  END DO
19791  DO i=i2,i1,-1
19792  grat = delp(i, 2)/delp(i, 1)
19793  bet = grat*(grat+0.5)
19794  temp_ad4 = gam_ad(i, 1)/bet
19795  gam_ad(i, 1) = 0.0
19796  temp_ad6 = q_ad(i, 1)/bet
19797  temp_ad5 = a4(1, i, 1)*temp_ad6
19798  temp0 = 2*grat*(grat+1.)
19799  bet_ad = -((temp0*a4(1, i, 1)+a4(1, i, 2))*temp_ad6/bet) - (grat&
19800 & *(grat+1.5)+1.)*temp_ad4/bet
19801  grat_ad = (4*grat+2*1.)*temp_ad5 + (2*grat+0.5)*bet_ad + (2*grat&
19802 & +1.5)*temp_ad4
19803  a4_ad(1, i, 1) = a4_ad(1, i, 1) + temp0*temp_ad6
19804  a4_ad(1, i, 2) = a4_ad(1, i, 2) + temp_ad6
19805  q_ad(i, 1) = 0.0
19806  temp_ad7 = grat_ad/delp(i, 1)
19807  delp_ad(i, 2) = delp_ad(i, 2) + temp_ad7
19808  delp_ad(i, 1) = delp_ad(i, 1) - delp(i, 2)*temp_ad7/delp(i, 1)
19809  END DO
19810  ELSE
19811  gam_ad = 0.0
19812  DO k=1,km-1,1
19813  DO i=i2,i1,-1
19814  CALL poprealarray(q(i, k))
19815  gam_ad(i, k+1) = gam_ad(i, k+1) - q(i, k+1)*q_ad(i, k)
19816  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k+1)*q_ad(i, k)
19817  END DO
19818  END DO
19819  DO i=i2,i1,-1
19820  CALL poprealarray(q(i, km+1))
19821  q_ad(i, km+1) = 0.0
19822  grat = delp(i, km-1)/delp(i, km)
19823  CALL poprealarray(q(i, km))
19824  temp = 2*grat - gam(i, km) + 2.
19825  temp_ad1 = q_ad(i, km)/temp
19826  temp_ad2 = -((3.*(a4(1, i, km-1)+a4(1, i, km))-qs(i)*grat-q(i, &
19827 & km-1))*temp_ad1/temp)
19828  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + 3.*temp_ad1
19829  a4_ad(1, i, km) = a4_ad(1, i, km) + 3.*temp_ad1
19830  grat_ad = 2*temp_ad2 - qs(i)*temp_ad1
19831  q_ad(i, km-1) = q_ad(i, km-1) - temp_ad1
19832  gam_ad(i, km) = gam_ad(i, km) - temp_ad2
19833  q_ad(i, km) = 0.0
19834  temp_ad3 = grat_ad/delp(i, km)
19835  delp_ad(i, km-1) = delp_ad(i, km-1) + temp_ad3
19836  delp_ad(i, km) = delp_ad(i, km) - delp(i, km-1)*temp_ad3/delp(i&
19837 & , km)
19838  END DO
19839  DO k=km-1,2,-1
19840  DO i=i2,i1,-1
19841  temp_ad = q_ad(i, k)/bet
19842  CALL poprealarray(q(i, k))
19843  grat = delp(i, k-1)/delp(i, k)
19844  bet_ad = -((3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*temp_ad/&
19845 & bet) - grat*gam_ad(i, k+1)/bet**2
19846  grat_ad = 2*bet_ad + gam_ad(i, k+1)/bet
19847  gam_ad(i, k+1) = 0.0
19848  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + 3.*temp_ad
19849  a4_ad(1, i, k) = a4_ad(1, i, k) + 3.*temp_ad
19850  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad
19851  q_ad(i, k) = 0.0
19852  CALL poprealarray(bet)
19853  gam_ad(i, k) = gam_ad(i, k) - bet_ad
19854  temp_ad0 = grat_ad/delp(i, k)
19855  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad0
19856  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad0/delp(i, &
19857 & k)
19858  END DO
19859  END DO
19860  DO i=i2,i1,-1
19861  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 1.5*q_ad(i, 1)
19862  q_ad(i, 1) = 0.0
19863  END DO
19864  END IF
19865  END SUBROUTINE scalar_profile_bwd
19866 ! Differentiation of cs_profile in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
19867 !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
19868 !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
19869 !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
19870 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
19871 !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
19872 !.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
19873 !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
19874 !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
19875 !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
19876 !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
19877 !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
19878 !_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_
19879 !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
19880 !.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
19881 !_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
19882 !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
19883 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
19884 ! gradient of useful results: qs delp a4
19885 ! with respect to varying inputs: qs delp a4
19886  SUBROUTINE cs_profile_fwd(qs, a4, delp, km, i1, i2, iv, kord)
19887  IMPLICIT NONE
19888 !----- Perfectly linear scheme --------------------------------
19889 ! Optimized vertical profile reconstruction:
19890 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
19891  INTEGER, INTENT(IN) :: i1, i2
19892 ! vertical dimension
19893  INTEGER, INTENT(IN) :: km
19894 ! iv =-1: winds
19895  INTEGER, INTENT(IN) :: iv
19896 ! iv = 0: positive definite scalars
19897 ! iv = 1: others
19898  INTEGER, INTENT(IN) :: kord
19899  REAL, INTENT(IN) :: qs(i1:i2)
19900 ! layer pressure thickness
19901  REAL, INTENT(IN) :: delp(i1:i2, km)
19902 ! Interpolated values
19903  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
19904 !-----------------------------------------------------------------------
19905  LOGICAL :: extm(i1:i2, km)
19906  REAL :: gam(i1:i2, km)
19907  REAL :: q(i1:i2, km+1)
19908  REAL :: d4(i1:i2)
19909  REAL :: bet, a_bot, grat
19910  REAL :: pmp_1, lac_1, pmp_2, lac_2
19911  INTEGER :: i, k, im
19912  INTRINSIC abs
19913  INTEGER :: abs0
19914 
19915  gam = 0.0
19916  q = 0.0
19917  d4 = 0.0
19918  bet = 0.0
19919  a_bot = 0.0
19920  grat = 0.0
19921  pmp_1 = 0.0
19922  lac_1 = 0.0
19923  pmp_2 = 0.0
19924  lac_2 = 0.0
19925  i = 0
19926  k = 0
19927  im = 0
19928  abs0 = 0
19929 
19930  IF (iv .EQ. -2) THEN
19931  DO i=i1,i2
19932  gam(i, 2) = 0.5
19933  q(i, 1) = 1.5*a4(1, i, 1)
19934  END DO
19935  DO k=2,km-1
19936  DO i=i1,i2
19937  grat = delp(i, k-1)/delp(i, k)
19938  CALL pushrealarray(bet)
19939  bet = 2. + grat + grat - gam(i, k)
19940  CALL pushrealarray(q(i, k))
19941  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
19942  gam(i, k+1) = grat/bet
19943  END DO
19944  END DO
19945  DO i=i1,i2
19946  grat = delp(i, km-1)/delp(i, km)
19947  CALL pushrealarray(q(i, km))
19948  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
19949 & 1))/(2.+grat+grat-gam(i, km))
19950  CALL pushrealarray(q(i, km+1))
19951  q(i, km+1) = qs(i)
19952  END DO
19953  DO k=km-1,1,-1
19954  DO i=i1,i2
19955  CALL pushrealarray(q(i, k))
19956  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
19957  END DO
19958  END DO
19959  CALL pushcontrol(1,1)
19960  ELSE
19961  DO i=i1,i2
19962 ! grid ratio
19963  grat = delp(i, 2)/delp(i, 1)
19964  bet = grat*(grat+0.5)
19965  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
19966  gam(i, 1) = (1.+grat*(grat+1.5))/bet
19967  END DO
19968  DO k=2,km
19969  DO i=i1,i2
19970  CALL pushrealarray(d4(i))
19971  d4(i) = delp(i, k-1)/delp(i, k)
19972  CALL pushrealarray(bet)
19973  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
19974  CALL pushrealarray(q(i, k))
19975  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
19976  gam(i, k) = d4(i)/bet
19977  END DO
19978  END DO
19979  DO i=i1,i2
19980  a_bot = 1. + d4(i)*(d4(i)+1.5)
19981  CALL pushrealarray(q(i, km+1))
19982  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
19983 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
19984  END DO
19985  DO k=km,1,-1
19986  DO i=i1,i2
19987  CALL pushrealarray(q(i, k))
19988  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
19989  END DO
19990  END DO
19991  CALL pushcontrol(1,0)
19992  END IF
19993  IF (kord .GE. 0.) THEN
19994  abs0 = kord
19995  ELSE
19996  abs0 = -kord
19997  END IF
19998 !----- Perfectly linear scheme --------------------------------
19999  IF (abs0 .GT. 16) THEN
20000  DO k=1,km
20001  DO i=i1,i2
20002  CALL pushrealarray(a4(2, i, k))
20003  a4(2, i, k) = q(i, k)
20004  CALL pushrealarray(a4(3, i, k))
20005  a4(3, i, k) = q(i, k+1)
20006  CALL pushrealarray(a4(4, i, k))
20007  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
20008  END DO
20009  END DO
20010  CALL pushrealarray(gam, (i2-i1+1)*km)
20011  CALL pushrealarray(d4, i2 - i1 + 1)
20012  CALL pushrealarray(bet)
20013  CALL pushrealarray(q, (i2-i1+1)*(km+1))
20014  CALL pushcontrol(1,1)
20015  ELSE
20016  CALL pushrealarray(gam, (i2-i1+1)*km)
20017  CALL pushrealarray(d4, i2 - i1 + 1)
20018  CALL pushrealarray(bet)
20019  CALL pushrealarray(q, (i2-i1+1)*(km+1))
20020  CALL pushcontrol(1,0)
20021  END IF
20022  END SUBROUTINE cs_profile_fwd
20023 ! Differentiation of cs_profile in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
20024 !ge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_c
20025 !ore_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_m
20026 !od.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayl
20027 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
20028 !_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mo
20029 !d.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_
20030 !2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limit
20031 !ers fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic
20032 !fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_su
20033 !bgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_ut
20034 !ils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_util
20035 !s_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils
20036 !_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mo
20037 !d.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.yt
20038 !p_v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_c
20039 !ore_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_u
20040 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
20041 ! gradient of useful results: qs delp a4
20042 ! with respect to varying inputs: qs delp a4
20043  SUBROUTINE cs_profile_bwd(qs, qs_ad, a4, a4_ad, delp, delp_ad, km, &
20044 & i1, i2, iv, kord)
20045  IMPLICIT NONE
20046 !----- Perfectly linear scheme --------------------------------
20047  INTEGER, INTENT(IN) :: i1, i2
20048  INTEGER, INTENT(IN) :: km
20049  INTEGER, INTENT(IN) :: iv
20050  INTEGER, INTENT(IN) :: kord
20051  REAL, INTENT(IN) :: qs(i1:i2)
20052  REAL :: qs_ad(i1:i2)
20053  REAL, INTENT(IN) :: delp(i1:i2, km)
20054  REAL :: delp_ad(i1:i2, km)
20055  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
20056  REAL, INTENT(INOUT) :: a4_ad(4, i1:i2, km)
20057  LOGICAL :: extm(i1:i2, km)
20058  REAL :: gam(i1:i2, km)
20059  REAL :: gam_ad(i1:i2, km)
20060  REAL :: q(i1:i2, km+1)
20061  REAL :: q_ad(i1:i2, km+1)
20062  REAL :: d4(i1:i2)
20063  REAL :: d4_ad(i1:i2)
20064  REAL :: bet, a_bot, grat
20065  REAL :: bet_ad, a_bot_ad, grat_ad
20066  REAL :: pmp_1, lac_1, pmp_2, lac_2
20067  INTEGER :: i, k, im
20068  INTRINSIC abs
20069  INTEGER :: abs0
20070  REAL :: temp_ad
20071  REAL :: temp_ad0
20072  REAL :: temp
20073  REAL :: temp_ad1
20074  REAL :: temp_ad2
20075  REAL :: temp_ad3
20076  REAL :: temp0
20077  REAL :: temp_ad4
20078  REAL :: temp_ad5
20079  REAL :: temp_ad6
20080  REAL :: temp_ad7
20081  REAL :: temp_ad8
20082  REAL :: temp_ad9
20083  REAL :: temp_ad10
20084  REAL :: temp1
20085  REAL :: temp2
20086  REAL :: temp_ad11
20087  REAL :: temp_ad12
20088  REAL :: temp_ad13
20089  REAL :: temp_ad14
20090  INTEGER :: branch
20091 
20092  gam = 0.0
20093  q = 0.0
20094  d4 = 0.0
20095  bet = 0.0
20096  a_bot = 0.0
20097  grat = 0.0
20098  pmp_1 = 0.0
20099  lac_1 = 0.0
20100  pmp_2 = 0.0
20101  lac_2 = 0.0
20102  i = 0
20103  k = 0
20104  im = 0
20105  abs0 = 0
20106  branch = 0
20107 
20108  CALL popcontrol(1,branch)
20109  IF (branch .EQ. 0) THEN
20110  CALL poprealarray(q, (i2-i1+1)*(km+1))
20111  CALL poprealarray(bet)
20112  CALL poprealarray(d4, i2 - i1 + 1)
20113  CALL poprealarray(gam, (i2-i1+1)*km)
20114  q_ad = 0.0
20115  ELSE
20116  CALL poprealarray(q, (i2-i1+1)*(km+1))
20117  CALL poprealarray(bet)
20118  CALL poprealarray(d4, i2 - i1 + 1)
20119  CALL poprealarray(gam, (i2-i1+1)*km)
20120  q_ad = 0.0
20121  DO k=km,1,-1
20122  DO i=i2,i1,-1
20123  CALL poprealarray(a4(4, i, k))
20124  temp_ad14 = 3.*a4_ad(4, i, k)
20125  a4_ad(1, i, k) = a4_ad(1, i, k) + 2.*temp_ad14
20126  a4_ad(2, i, k) = a4_ad(2, i, k) - temp_ad14
20127  a4_ad(3, i, k) = a4_ad(3, i, k) - temp_ad14
20128  a4_ad(4, i, k) = 0.0
20129  CALL poprealarray(a4(3, i, k))
20130  q_ad(i, k+1) = q_ad(i, k+1) + a4_ad(3, i, k)
20131  a4_ad(3, i, k) = 0.0
20132  CALL poprealarray(a4(2, i, k))
20133  q_ad(i, k) = q_ad(i, k) + a4_ad(2, i, k)
20134  a4_ad(2, i, k) = 0.0
20135  END DO
20136  END DO
20137  END IF
20138  CALL popcontrol(1,branch)
20139  IF (branch .EQ. 0) THEN
20140  gam_ad = 0.0
20141  DO k=1,km,1
20142  DO i=i2,i1,-1
20143  CALL poprealarray(q(i, k))
20144  gam_ad(i, k) = gam_ad(i, k) - q(i, k+1)*q_ad(i, k)
20145  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k)*q_ad(i, k)
20146  END DO
20147  END DO
20148  d4_ad = 0.0
20149  DO i=i2,i1,-1
20150  a_bot = 1. + d4(i)*(d4(i)+1.5)
20151  CALL poprealarray(q(i, km+1))
20152  temp2 = d4(i)*(d4(i)+0.5) - a_bot*gam(i, km)
20153  temp_ad11 = q_ad(i, km+1)/temp2
20154  temp1 = d4(i)*(d4(i)+1.)
20155  temp_ad12 = 2.*a4(1, i, km)*temp_ad11
20156  temp_ad13 = -((2.*(temp1*a4(1, i, km))+a4(1, i, km-1)-a_bot*q(i&
20157 & , km))*temp_ad11/temp2)
20158  a4_ad(1, i, km) = a4_ad(1, i, km) + 2.*temp1*temp_ad11
20159  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + temp_ad11
20160  a_bot_ad = -(gam(i, km)*temp_ad13) - q(i, km)*temp_ad11
20161  d4_ad(i) = d4_ad(i) + (2*d4(i)+1.5)*a_bot_ad + (2*d4(i)+0.5)*&
20162 & temp_ad13 + (2*d4(i)+1.)*temp_ad12
20163  q_ad(i, km) = q_ad(i, km) - a_bot*temp_ad11
20164  gam_ad(i, km) = gam_ad(i, km) - a_bot*temp_ad13
20165  q_ad(i, km+1) = 0.0
20166  END DO
20167  DO k=km,2,-1
20168  DO i=i2,i1,-1
20169  temp_ad9 = q_ad(i, k)/bet
20170  temp_ad8 = 3.*temp_ad9
20171  CALL poprealarray(q(i, k))
20172  bet_ad = -((3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))*&
20173 & temp_ad9/bet) - d4(i)*gam_ad(i, k)/bet**2
20174  d4_ad(i) = d4_ad(i) + a4(1, i, k)*temp_ad8 + 2*bet_ad + gam_ad&
20175 & (i, k)/bet
20176  gam_ad(i, k) = 0.0
20177  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + temp_ad8
20178  a4_ad(1, i, k) = a4_ad(1, i, k) + d4(i)*temp_ad8
20179  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad9
20180  q_ad(i, k) = 0.0
20181  CALL poprealarray(bet)
20182  gam_ad(i, k-1) = gam_ad(i, k-1) - bet_ad
20183  CALL poprealarray(d4(i))
20184  temp_ad10 = d4_ad(i)/delp(i, k)
20185  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad10
20186  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad10/delp(i&
20187 & , k)
20188  d4_ad(i) = 0.0
20189  END DO
20190  END DO
20191  DO i=i2,i1,-1
20192  grat = delp(i, 2)/delp(i, 1)
20193  bet = grat*(grat+0.5)
20194  temp_ad4 = gam_ad(i, 1)/bet
20195  gam_ad(i, 1) = 0.0
20196  temp_ad6 = q_ad(i, 1)/bet
20197  temp_ad5 = a4(1, i, 1)*temp_ad6
20198  temp0 = 2*grat*(grat+1.)
20199  bet_ad = -((temp0*a4(1, i, 1)+a4(1, i, 2))*temp_ad6/bet) - (grat&
20200 & *(grat+1.5)+1.)*temp_ad4/bet
20201  grat_ad = (4*grat+2*1.)*temp_ad5 + (2*grat+0.5)*bet_ad + (2*grat&
20202 & +1.5)*temp_ad4
20203  a4_ad(1, i, 1) = a4_ad(1, i, 1) + temp0*temp_ad6
20204  a4_ad(1, i, 2) = a4_ad(1, i, 2) + temp_ad6
20205  q_ad(i, 1) = 0.0
20206  temp_ad7 = grat_ad/delp(i, 1)
20207  delp_ad(i, 2) = delp_ad(i, 2) + temp_ad7
20208  delp_ad(i, 1) = delp_ad(i, 1) - delp(i, 2)*temp_ad7/delp(i, 1)
20209  END DO
20210  ELSE
20211  gam_ad = 0.0
20212  DO k=1,km-1,1
20213  DO i=i2,i1,-1
20214  CALL poprealarray(q(i, k))
20215  gam_ad(i, k+1) = gam_ad(i, k+1) - q(i, k+1)*q_ad(i, k)
20216  q_ad(i, k+1) = q_ad(i, k+1) - gam(i, k+1)*q_ad(i, k)
20217  END DO
20218  END DO
20219  DO i=i2,i1,-1
20220  CALL poprealarray(q(i, km+1))
20221  qs_ad(i) = qs_ad(i) + q_ad(i, km+1)
20222  q_ad(i, km+1) = 0.0
20223  grat = delp(i, km-1)/delp(i, km)
20224  CALL poprealarray(q(i, km))
20225  temp = 2*grat - gam(i, km) + 2.
20226  temp_ad1 = q_ad(i, km)/temp
20227  temp_ad2 = -((3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, &
20228 & km-1))*temp_ad1/temp)
20229  a4_ad(1, i, km-1) = a4_ad(1, i, km-1) + 3.*temp_ad1
20230  a4_ad(1, i, km) = a4_ad(1, i, km) + 3.*temp_ad1
20231  grat_ad = 2*temp_ad2 - qs(i)*temp_ad1
20232  qs_ad(i) = qs_ad(i) - grat*temp_ad1
20233  q_ad(i, km-1) = q_ad(i, km-1) - temp_ad1
20234  gam_ad(i, km) = gam_ad(i, km) - temp_ad2
20235  q_ad(i, km) = 0.0
20236  temp_ad3 = grat_ad/delp(i, km)
20237  delp_ad(i, km-1) = delp_ad(i, km-1) + temp_ad3
20238  delp_ad(i, km) = delp_ad(i, km) - delp(i, km-1)*temp_ad3/delp(i&
20239 & , km)
20240  END DO
20241  DO k=km-1,2,-1
20242  DO i=i2,i1,-1
20243  temp_ad = q_ad(i, k)/bet
20244  CALL poprealarray(q(i, k))
20245  grat = delp(i, k-1)/delp(i, k)
20246  bet_ad = -((3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*temp_ad/&
20247 & bet) - grat*gam_ad(i, k+1)/bet**2
20248  grat_ad = 2*bet_ad + gam_ad(i, k+1)/bet
20249  gam_ad(i, k+1) = 0.0
20250  a4_ad(1, i, k-1) = a4_ad(1, i, k-1) + 3.*temp_ad
20251  a4_ad(1, i, k) = a4_ad(1, i, k) + 3.*temp_ad
20252  q_ad(i, k-1) = q_ad(i, k-1) - temp_ad
20253  q_ad(i, k) = 0.0
20254  CALL poprealarray(bet)
20255  gam_ad(i, k) = gam_ad(i, k) - bet_ad
20256  temp_ad0 = grat_ad/delp(i, k)
20257  delp_ad(i, k-1) = delp_ad(i, k-1) + temp_ad0
20258  delp_ad(i, k) = delp_ad(i, k) - delp(i, k-1)*temp_ad0/delp(i, &
20259 & k)
20260  END DO
20261  END DO
20262  DO i=i2,i1,-1
20263  a4_ad(1, i, 1) = a4_ad(1, i, 1) + 1.5*q_ad(i, 1)
20264  q_ad(i, 1) = 0.0
20265  END DO
20266  END IF
20267  END SUBROUTINE cs_profile_bwd
20268 end module fv_mapz_adm_mod
fv_mapz_adm_mod::r3
real, parameter r3
Definition: fv_mapz_adm.F90:48
tracer_manager_mod::get_tracer_index
Definition: tracer_manager.F90:124
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
fv_mapz_adm_mod::r12
real, parameter r12
Definition: fv_mapz_adm.F90:48
constants_mod
Definition: constants.F90:24
constants_mod::radius
real, parameter, public radius
Radius of the Earth [m].
Definition: constants.F90:72
fv_mapz_adm_mod::map1_ppm_fwd
subroutine map1_ppm_fwd(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_adm.F90:18293
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
field_manager_mod::model_atmos
integer, parameter, public model_atmos
Definition: field_manager.F90:299
fv_mapz_adm_mod::map1_q2_adm
subroutine map1_q2_adm(km, pe1, pe1_ad, q1, q1_ad, kn, pe2, pe2_ad, q2, q2_ad, dp2, dp2_ad, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_adm.F90:6461
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
fv_mapz_adm_mod::cs_limiters_bwd
subroutine cs_limiters_bwd(im, extm, a4, a4_ad, iv)
Definition: fv_mapz_adm.F90:13863
fv_cmp_nlm_mod
Definition: fv_cmp_nlm.F90:1
popcontrol2b
subroutine popcontrol2b(cc)
Definition: adBuffer.f:146
field_manager_mod
Definition: field_manager.F90:20
fv_grid_utils_nlm_mod::ptop_min
real, parameter, public ptop_min
Definition: fv_grid_utils_nlm.F90:54
fv_cmp_nlm_mod::fv_sat_adj
subroutine, public fv_sat_adj(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, te0, qv, ql, qi, qr, qs, qg, dpln, delz, pt, dp, q_con, cappa, area, dtdt, out_dt, last_step, do_qa, qa)
Definition: fv_cmp_nlm.F90:47
fv_mapz_adm_mod::ppm_profile_fwd
subroutine ppm_profile_fwd(a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:14097
fv_mapz_adm_mod::compute_total_energy_bwd
subroutine, public compute_total_energy_bwd(is, ie, js, je, isd, ied, jsd, jed, km, u, u_ad, v, v_ad, w, w_ad, delz, delz_ad, pt, pt_ad, delp, delp_ad, q, q_ad, qc, qc_ad, pe, pe_ad, peln, peln_ad, hs, rsin2_l, cosa_s_l, r_vir, cp, rg, hlv, te_2d, te_2d_ad, ua, va, teq, teq_ad, moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
Definition: fv_mapz_adm.F90:4541
constants_mod::pi_8
real(kind=8), parameter, public pi_8
Ratio of circle circumference to diameter [N/A].
Definition: constants.F90:73
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
fv_mapz_adm_mod::cv_vap
real, parameter cv_vap
Definition: fv_mapz_adm.F90:49
fv_mapz_adm_mod::t_min
real, parameter t_min
Definition: fv_mapz_adm.F90:46
fv_mapz_adm_mod::cs_profile
subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:12824
fv_mapz_adm_mod::cs_limiters_fwd
subroutine cs_limiters_fwd(im, extm, a4, iv)
Definition: fv_mapz_adm.F90:13712
fv_mapz_adm_mod::map1_ppm_bwd
subroutine map1_ppm_bwd(km, pe1, pe1_ad, qs, qs_ad, kn, pe2, pe2_ad, q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_adm.F90:18464
fv_mapz_adm_mod::scalar_profile
subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_adm.F90:9473
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
fv_mapz_adm_mod::cp_vap
real, parameter cp_vap
Definition: fv_mapz_adm.F90:55
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
constants_mod::hlv
real, parameter, public hlv
Latent heat of evaporation [J/kg].
Definition: constants.F90:80
fv_mapz_adm_mod::mapn_tracer_fwd
subroutine mapn_tracer_fwd(nq, km, pe1, pe2, q1, dp2, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_adm.F90:18659
fv_mapz_adm_mod::steepz
subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
Definition: fv_mapz_adm.F90:15760
fv_mapz_adm_mod::map_scalar_adm
subroutine map_scalar_adm(km, pe1, pe1_ad, qs, kn, pe2, pe2_ad, q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_adm.F90:5237
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
fv_mapz_adm_mod::map1_cubic_bwd
subroutine map1_cubic_bwd(km, pe1, pe1_ad, kn, pe2, pe2_ad, q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
Definition: fv_mapz_adm.F90:17282
fv_mapz_adm_mod::r23
real, parameter r23
Definition: fv_mapz_adm.F90:48
fv_grid_utils_adm_mod::g_sum_adm
subroutine, public g_sum_adm(domain, p, p_ad, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce, g_sum_ad)
Definition: fv_grid_utils_adm.F90:676
fv_mapz_adm_mod::c_ice
real, parameter c_ice
Definition: fv_mapz_adm.F90:52
fv_mapz_adm_mod::map1_q2_fwd
subroutine, public map1_q2_fwd(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_adm.F90:19127
constants_mod::rdgas
real, parameter, public rdgas
Gas constant for dry air [J/kg/deg].
Definition: constants.F90:77
fv_mapz_adm_mod::tice
real, parameter tice
Definition: fv_mapz_adm.F90:56
fv_mapz_adm_mod::mapn_tracer
subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_adm.F90:6319
fv_mapz_adm_mod::scalar_profile_fwd
subroutine scalar_profile_fwd(qs, a4, delp, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_adm.F90:19488
fv_mapz_adm_mod::map_scalar
subroutine map_scalar(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_adm.F90:5496
constants_mod::cp_vapor
real, parameter, public cp_vapor
Specific heat capacity of water vapor at constant pressure [J/kg/deg].
Definition: constants.F90:89
fv_mapz_adm_mod::map1_ppm
subroutine map1_ppm(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_adm.F90:5875
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
fv_fill_nlm_mod::fillz
subroutine, public fillz(im, km, nq, q, dp)
Definition: fv_fill_nlm.F90:33
mpp_mod
Definition: mpp.F90:39
fv_mapz_adm_mod::map1_cubic_fwd
subroutine map1_cubic_fwd(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
Definition: fv_mapz_adm.F90:16961
fv_mapz_adm_mod
Definition: fv_mapz_adm.F90:23
fv_grid_utils_nlm_mod
Definition: fv_grid_utils_nlm.F90:20
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
fv_mapz_adm_mod::c_liq
real, parameter c_liq
Definition: fv_mapz_adm.F90:53
fv_mapz_adm_mod::ppm_profile_bwd
subroutine ppm_profile_bwd(a4, a4_ad, delp, delp_ad, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:14675
fv_mapz_adm_mod::compute_total_energy
subroutine, public compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, cosa_s_l, r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
Definition: fv_mapz_adm.F90:4767
pushcontrol2b
subroutine pushcontrol2b(cc)
Definition: adBuffer.f:140
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_mapz_adm_mod::ppm_limiters_bwd
subroutine ppm_limiters_bwd(dm, dm_ad, a4, a4_ad, itot, lmt)
Definition: fv_mapz_adm.F90:15587
fv_mapz_adm_mod::cs_profile_bwd
subroutine cs_profile_bwd(qs, qs_ad, a4, a4_ad, delp, delp_ad, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:20045
fv_mapz_adm_mod::moist_cp
subroutine, public moist_cp(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cpm, t1)
Definition: fv_mapz_adm.F90:16845
fv_mapz_adm_mod::pkez_bwd
subroutine pkez_bwd(km, ifirst, ilast, jfirst, jlast, j, pe, pk, pk_ad, akap, peln, peln_ad, pkz, pkz_ad, ptop)
Definition: fv_mapz_adm.F90:5000
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
fv_mapz_adm_mod::map_scalar_fwd
subroutine map_scalar_fwd(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_adm.F90:17921
fv_mapz_adm_mod::map1_q2_bwd
subroutine, public map1_q2_bwd(km, pe1, pe1_ad, q1, q1_ad, kn, pe2, pe2_ad, q2, q2_ad, dp2, dp2_ad, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_adm.F90:19292
constants_mod::rvgas
real, parameter, public rvgas
Gas constant for water vapor [J/kg/deg].
Definition: constants.F90:78
fv_mapz_adm_mod::map1_ppm_adm
subroutine map1_ppm_adm(km, pe1, pe1_ad, qs, qs_ad, kn, pe2, pe2_ad, q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_adm.F90:5617
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
fv_mapz_adm_mod::lagrangian_to_eulerian_bwd
subroutine, public lagrangian_to_eulerian_bwd(last_step, consv, ps, ps_ad, pe, pe_ad, delp, delp_ad, pkz, pkz_ad, pk, pk_ad, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, u_ad, v, v_ad, w, w_ad, delz, delz_ad, pt, pt_ad, q, q_ad, hs, r_vir, cp, akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, peln_ad, te0_2d, te0_2d_ad, ng, ua, ua_ad, va, omga, omga_ad, te, te_ad, ws, ws_ad, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
Definition: fv_mapz_adm.F90:1624
fv_timing_nlm_mod::timing_on
subroutine timing_on(blk_name)
Definition: fv_timing_nlm.F90:101
fv_mapz_adm_mod::moist_cv
subroutine, public moist_cv(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cvm, t1)
Definition: fv_mapz_adm.F90:16755
tapenade_iter
Definition: tapenade_iter.F90:1
fv_mapz_adm_mod::map_scalar_bwd
subroutine map_scalar_bwd(km, pe1, pe1_ad, qs, kn, pe2, pe2_ad, q2, q2_ad, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_adm.F90:18096
fv_mapz_adm_mod::cs_limiters
subroutine cs_limiters(im, extm, a4, iv)
Definition: fv_mapz_adm.F90:13991
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
fv_cmp_nlm_mod::qs_init
subroutine, public qs_init(kmp)
Definition: fv_cmp_nlm.F90:184
constants_mod::cp_air
real, parameter, public cp_air
Specific heat capacity of dry air at constant pressure [J/kg/deg].
Definition: constants.F90:83
fv_mapz_adm_mod::remap_z
subroutine remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:5128
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_mapz_adm_mod::pkez_fwd
subroutine pkez_fwd(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap, peln, pkz, ptop)
Definition: fv_mapz_adm.F90:4914
fv_mapz_adm_mod::e_flux
real, public e_flux
Definition: fv_mapz_adm.F90:58
fv_arrays_tlmadm_mod::fpp
type(fpp_type) fpp
Definition: fv_arrays_tlmadm.F90:35
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
fv_mapz_adm_mod::lagrangian_to_eulerian_fwd
subroutine, public lagrangian_to_eulerian_fwd(last_step, consv, ps, pe, delp, pkz, pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
Definition: fv_mapz_adm.F90:99
fv_mapz_adm_mod::ppm_limiters
subroutine ppm_limiters(dm, a4, itot, lmt)
Definition: fv_mapz_adm.F90:16629
constants_mod::hlf
real, parameter, public hlf
Latent heat of fusion [J/kg].
Definition: constants.F90:81
popcontrol3b
subroutine popcontrol3b(cc)
Definition: adBuffer.f:175
constants_mod::grav
real, parameter, public grav
Acceleration due to gravity [m/s^2].
Definition: constants.F90:76
tracer_manager_mod
Definition: tracer_manager.F90:20
mpp_mod::mpp_error
Definition: mpp.F90:402
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
fv_grid_utils_adm_mod::g_sum
real function, public g_sum(domain, p, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce)
Definition: fv_grid_utils_adm.F90:733
fv_mapz_adm_mod::cv_air
real, parameter cv_air
Definition: fv_mapz_adm.F90:50
fv_mapz_adm_mod::lagrangian_to_eulerian
subroutine, public lagrangian_to_eulerian(last_step, consv, ps, pe, delp, pkz, pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
Definition: fv_mapz_adm.F90:3425
max
#define max(a, b)
Definition: mosaic_util.h:33
fv_fill_nlm_mod
Definition: fv_fill_nlm.F90:20
fv_mapz_adm_mod::ppm_profile
subroutine ppm_profile(a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:16226
fv_mapz_adm_mod::remap_2d
subroutine remap_2d(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:16039
fv_mapz_adm_mod::cs_profile_fwd
subroutine cs_profile_fwd(qs, a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:19887
fv_diagnostics_nlm_mod::prt_mxm
subroutine, public prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain)
Definition: fv_diagnostics_nlm.F90:2809
fv_mapz_adm_mod::mapn_tracer_adm
subroutine mapn_tracer_adm(nq, km, pe1, pe1_ad, pe2, pe2_ad, q1, q1_ad, dp2, dp2_ad, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_adm.F90:5994
fv_mapz_adm_mod::rst_remap
subroutine, public rst_remap(km, kn, is, ie, js, je, isd, ied, jsd, jed, nq, ntp, delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, delp, u, v, w, delz, pt, q, qdiag, ak_r, bk_r, ptop, ak, bk, hydrostatic, make_nh, domain, square_domain)
Definition: fv_mapz_adm.F90:15829
fv_mapz_adm_mod::cs_profile_adm
subroutine cs_profile_adm(qs, qs_ad, a4, a4_ad, delp, delp_ad, km, i1, i2, iv, kord)
Definition: fv_mapz_adm.F90:10483
fv_mapz_adm_mod::map1_cubic
subroutine map1_cubic(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
Definition: fv_mapz_adm.F90:17703
fv_mapz_adm_mod::consv_min
real, parameter consv_min
Definition: fv_mapz_adm.F90:45
pushcontrol3b
subroutine pushcontrol3b(cc)
Definition: adBuffer.f:168
min
#define min(a, b)
Definition: mosaic_util.h:32
fv_mapz_adm_mod::map1_q2
subroutine, public map1_q2(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_adm.F90:6709
fv_mapz_adm_mod::compute_total_energy_fwd
subroutine, public compute_total_energy_fwd(is, ie, js, je, isd, ied, jsd, jed, km, u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, cosa_s_l, r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
Definition: fv_mapz_adm.F90:4364
fv_mapz_adm_mod::r0
real, parameter r0
Definition: fv_mapz_adm.F90:47
fv_mapz_adm_mod::scalar_profile_bwd
subroutine scalar_profile_bwd(qs, a4, a4_ad, delp, delp_ad, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_adm.F90:19646
fv_mapz_adm_mod::ppm_limiters_fwd
subroutine ppm_limiters_fwd(dm, a4, itot, lmt)
Definition: fv_mapz_adm.F90:15390
fv_mapz_adm_mod::scalar_profile_adm
subroutine scalar_profile_adm(qs, a4, a4_ad, delp, delp_ad, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_adm.F90:6820
fv_diagnostics_nlm_mod
Definition: fv_diagnostics_nlm.F90:20
fv_mapz_adm_mod::mappm
subroutine, public mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
Definition: fv_mapz_adm.F90:16127
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
fv_mapz_adm_mod::pkez
subroutine pkez(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap, peln, pkz, ptop)
Definition: fv_mapz_adm.F90:5075
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484
fv_grid_utils_adm_mod
Definition: fv_grid_utils_adm.F90:20
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
crtm_parameters::pi
real(fp), parameter, public pi
Definition: CRTM_Parameters.f90:86
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175
fv_mapz_adm_mod::r2
real, parameter r2
Definition: fv_mapz_adm.F90:47
fv_mapz_adm_mod::mapn_tracer_bwd
subroutine mapn_tracer_bwd(nq, km, pe1, pe1_ad, pe2, pe2_ad, q1, q1_ad, dp2, dp2_ad, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_adm.F90:18866