FV3 Bundle
dyn_core_adm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20 module dyn_core_adm_mod
21 
22  use constants_mod, only: rdgas, radius, cp_air, pi
23  use mpp_mod, only: mpp_pe
24  use mpp_domains_mod, only: cgrid_ne, dgrid_ne, mpp_get_boundary, mpp_update_domains, &
25  domain2d
26  use fv_mp_adm_mod, only: mpp_get_boundary_adm, mpp_update_domains_adm
27  use mpp_parameter_mod, only: corner
28  use fv_mp_nlm_mod, only: is_master
29  use fv_mp_adm_mod, only: start_group_halo_update, complete_group_halo_update
30  use fv_mp_adm_mod, only: start_group_halo_update_adm
31  use fv_mp_nlm_mod, only: group_halo_update_type
32  use sw_core_adm_mod, only: c_sw, d_sw
33  use sw_core_adm_mod, only: c_sw_fwd, c_sw_bwd, d_sw_fwd, d_sw_bwd
34  use a2b_edge_adm_mod, only: a2b_ord2, a2b_ord4
35  use a2b_edge_adm_mod, only: a2b_ord2_fwd, a2b_ord2_bwd, a2b_ord4_fwd, a2b_ord4_bwd
36  use nh_core_adm_mod, only: riem_solver3, riem_solver_c, update_dz_c, update_dz_d, nest_halo_nh
37  use nh_core_adm_mod, only: riem_solver3_fwd, riem_solver_c_fwd, update_dz_c_fwd, update_dz_d_fwd, nest_halo_nh_fwd
38  use nh_core_adm_mod, only: riem_solver3_bwd, riem_solver_c_bwd, update_dz_c_bwd, update_dz_d_bwd, nest_halo_nh_bwd
39  use tp_core_adm_mod, only: copy_corners
40  use tp_core_adm_mod, only: copy_corners_adm
41  use fv_timing_nlm_mod, only: timing_on, timing_off
42  use fv_diagnostics_nlm_mod, only: prt_maxmin, fv_time, prt_mxm
43 #ifdef ROT3
44  use fv_update_phys_nlm_mod, only: update_dwinds_phys
45 #endif
46 #if defined (ADA_NUDGE)
47  use fv_ada_nudge_mod, only: breed_slp_inline_ada
48 #else
49  use fv_nwp_nudge_nlm_mod, only: breed_slp_inline, do_adiabatic_init
50 #endif
51  use diag_manager_mod, only: send_data
52  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type, &
53  fv_grid_bounds_type, r_grid
54 
55  use boundary_adm_mod, only: extrapolation_bc, nested_grid_bc_apply_intt
56  use boundary_adm_mod, only: nested_grid_bc_apply_intt_adm
57 
58 #ifdef SW_DYNAMICS
59  use test_cases_nlm_mod, only: test_case, case9_forcing1, case9_forcing2
60 #endif
61 
62  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
63  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
64 
65  use fv_arrays_tlmadm_mod, only: fv_flags_pert_type, fpp
66 
67 implicit none
68 private
69 
70 public :: dyn_core, del2_cubed, init_ijk_mem
71 public :: dyn_core_fwd, del2_cubed_fwd
72 public :: dyn_core_bwd, del2_cubed_bwd
73 
74  real :: ptk, peln1, rgrav
75  real :: d3_damp
76 ! real, allocatable, dimension(:,:,:) :: ut, vt, crx, cry, xfx, yfx, divgd, &
77 ! zh, du, dv, pkc, delpc, pk3, ptc, gz
78 ! real, parameter:: delt_max = 1.e-1 ! Max dissipative heating/cooling rate
79  ! 6 deg per 10-min
80  real(kind=R_GRID), parameter :: cnst_0p20=0.20d0
81 
82 ! real, allocatable :: rf(:)
83  logical:: rff_initialized = .false.
84  integer :: kmax=1
85 
86 CONTAINS
87 ! Differentiation of dyn_core in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
88 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
89 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
90 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
91 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
92 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
93 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
94 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
95 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
96 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
97 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
98 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
99 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
100 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
101 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
102 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
103 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
104 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
105 ! gradient of useful results: pk3 xfx ws peln q gz du u dv
106 ! v w delp ua uc ptc mfx delz mfy omga ut divgd
107 ! pkc delpc va vc yfx pkz pe vt pk zh pt cx cy dpx
108 ! crx cry
109 ! with respect to varying inputs: pk3 xfx ws peln q gz du u dv
110 ! v w delp ua uc ptc delz omga ut divgd pkc delpc
111 ! va vc yfx pkz pe vt pk zh pt dpx crx cry
112 !-----------------------------------------------------------------------
113 ! dyn_core :: FV Lagrangian dynamics driver
114 !-----------------------------------------------------------------------
115  SUBROUTINE dyn_core_fwd(npx, npy, npz, ng, sphum, nq, bdt, n_split, &
116 & zvir, cp, akap, cappa, grav, hydrostatic, u, v, w, delz, pt, q, delp&
117 & , pe, pk, phis, ws, omga, ptop, pfull, ua, va, uc, vc, mfx, mfy, cx&
118 & , cy, pkz, peln, q_con, ak, bk, dpx, ks, gridstruct, flagstruct, &
119 & flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, &
120 & end_step, gz, pkc, ptc, crx, xfx, cry, yfx, divgd, delpc, ut, vt, zh&
121 & , pk3, du, dv, time_total)
122  IMPLICIT NONE
123 ! end init_step
124 ! Start of the big dynamic time stepping
125 !allocate( gz(isd:ied, jsd:jed ,npz+1) )
126 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, gz, huge_r)
127 !allocate( pkc(isd:ied, jsd:jed ,npz+1) )
128 !allocate( ptc(isd:ied, jsd:jed ,npz ) )
129 !allocate( crx(is :ie+1, jsd:jed, npz) )
130 !allocate( xfx(is :ie+1, jsd:jed, npz) )
131 !allocate( cry(isd:ied, js :je+1, npz) )
132 !allocate( yfx(isd:ied, js :je+1, npz) )
133 !allocate( divgd(isd:ied+1,jsd:jed+1,npz) )
134 !allocate( delpc(isd:ied, jsd:jed ,npz ) )
135 ! call init_ijk_mem(isd,ied, jsd,jed, npz, delpc, 0.)
136 !allocate( ut(isd:ied, jsd:jed, npz) )
137 ! call init_ijk_mem(isd,ied, jsd,jed, npz, ut, 0.)
138 !allocate( vt(isd:ied, jsd:jed, npz) )
139 ! call init_ijk_mem(isd,ied, jsd,jed, npz, vt, 0.)
140 !allocate( zh(isd:ied, jsd:jed, npz+1) )
141 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, zh, huge_r )
142 !allocate ( pk3(isd:ied,jsd:jed,npz+1) )
143 !call init_ijk_mem(isd,ied, jsd,jed, npz+1, pk3, huge_r )
144 !if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier
145 !versions of the code
146 !deallocate( gz )
147 !deallocate( ptc )
148 !deallocate( crx )
149 !deallocate( xfx )
150 !deallocate( cry )
151 !deallocate( yfx )
152 !deallocate( divgd )
153 !deallocate( pkc )
154 !deallocate( delpc )
155 !if( allocated(ut)) deallocate( ut )
156 !if( allocated(vt)) deallocate( vt )
157 !if ( allocated (du) ) deallocate( du )
158 !if ( allocated (dv) ) deallocate( dv )
159 !if ( .not. hydrostatic ) then
160 ! deallocate( zh )
161 ! if( allocated(pk3) ) deallocate ( pk3 )
162 !endif
163 !if( allocated(pem) ) deallocate ( pem )
164  INTEGER, INTENT(IN) :: npx
165  INTEGER, INTENT(IN) :: npy
166  INTEGER, INTENT(IN) :: npz
167  INTEGER, INTENT(IN) :: ng, nq, sphum
168  INTEGER, INTENT(IN) :: n_split
169  REAL, INTENT(IN) :: bdt
170  REAL, INTENT(IN) :: zvir, cp, akap, grav
171  REAL, INTENT(IN) :: ptop
172  LOGICAL, INTENT(IN) :: hydrostatic
173  LOGICAL, INTENT(IN) :: init_step, end_step
174  REAL, INTENT(IN) :: pfull(npz)
175  REAL, DIMENSION(npz+1), INTENT(IN) :: ak, bk
176  INTEGER, INTENT(IN) :: ks
177  TYPE(group_halo_update_type), INTENT(INOUT) :: i_pack(*)
178  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
179 ! D grid zonal wind (m/s)
180  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
181 & :: u
182 ! D grid meridional wind (m/s)
183  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
184 & :: v
185 ! vertical vel. (m/s)
186  REAL, INTENT(INOUT) :: w(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
187 ! delta-height (m, negative)
188  REAL, INTENT(INOUT) :: delz(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
189 ! moist kappa
190  REAL, INTENT(INOUT) :: cappa(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
191 ! temperature (K)
192  REAL, INTENT(INOUT) :: pt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
193 ! pressure thickness (pascal)
194  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
195 !
196  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
197 ! total time (seconds) since start
198  REAL, INTENT(IN), OPTIONAL :: time_total
199 !-----------------------------------------------------------------------
200 ! Auxilliary pressure arrays:
201 ! The 5 vars below can be re-computed from delp and ptop.
202 !-----------------------------------------------------------------------
203 ! dyn_aux:
204 ! Surface geopotential (g*Z_surf)
205  REAL, INTENT(INOUT) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed)
206 ! edge pressure (pascal)
207  REAL, INTENT(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
208 ! ln(pe)
209  REAL, INTENT(INOUT) :: peln(bd%is:bd%ie, npz+1, bd%js:bd%je)
210 ! pe**kappa
211  REAL, INTENT(INOUT) :: pk(bd%is:bd%ie, bd%js:bd%je, npz+1)
212  REAL(kind=8), INTENT(INOUT) :: dpx(bd%is:bd%ie, bd%js:bd%je)
213 !-----------------------------------------------------------------------
214 ! Others:
215  REAL, PARAMETER :: near0=1.e-8
216  REAL, PARAMETER :: huge_r=1.e8
217 !-----------------------------------------------------------------------
218 ! w at surface
219  REAL :: ws(bd%is:bd%ie, bd%js:bd%je)
220 ! Vertical pressure velocity (pa/s)
221  REAL, INTENT(INOUT) :: omga(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
222 ! (uc, vc) are mostly used as the C grid winds
223  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
224  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
225  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
226 & ua, va
227  REAL, INTENT(INOUT) :: q_con(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
228 ! The Flux capacitors: accumulated Mass flux arrays
229  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
230  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
231 ! Accumulated Courant number arrays
232  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
233  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
234  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: pkz
235  TYPE(fv_grid_type), INTENT(INOUT), TARGET :: gridstruct
236  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
237  TYPE(fv_flags_pert_type), INTENT(IN), TARGET :: flagstructp
238  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
239  TYPE(fv_diag_type), INTENT(IN) :: idiag
240  TYPE(domain2d), INTENT(INOUT) :: domain
241 !real, allocatable, dimension(:,:,:):: pem, heat_source
242  REAL :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), heat_source(bd&
243 & %isd:bd%ied, bd%jsd:bd%jed, npz)
244 ! Auto 1D & 2D arrays:
245  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3, z_rat
246  REAL :: dp_ref(npz)
247 ! surface height (m)
248  REAL :: zs(bd%isd:bd%ied, bd%jsd:bd%jed)
249  REAL :: p1d(bd%is:bd%ie)
250  REAL :: om2d(bd%is:bd%ie, npz)
251  REAL :: wbuffer(npy+2, npz)
252  REAL :: ebuffer(npy+2, npz)
253  REAL :: nbuffer(npx+2, npz)
254  REAL :: sbuffer(npx+2, npz)
255 ! ---- For external mode:
256  REAL :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
257  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
258  REAL :: fz(bd%is:bd%ie+1, bd%js:bd%je+1)
259  REAL :: heat_s(bd%is:bd%ie, bd%js:bd%je)
260  REAL :: damp_vt(npz+1)
261  INTEGER :: nord_v(npz+1)
262 !-------------------------------------
263  INTEGER :: hord_m, hord_v, hord_t, hord_p
264  INTEGER :: nord_k, nord_w, nord_t
265  INTEGER :: ms
266 !---------------------------------------
267  INTEGER :: hord_m_pert, hord_v_pert, hord_t_pert, hord_p_pert
268  INTEGER :: nord_k_pert, nord_w_pert, nord_t_pert, nord_v_pert(npz+1)
269  REAL :: d2_divg_pert, damp_vt_pert(npz+1), damp_w_pert, damp_t_pert
270 !---------------------------------------
271  INTEGER :: i, j, k, it, iq, n_con, nf_ke
272  INTEGER :: iep1, jep1
273  REAL :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air
274  REAL :: dt, dt2, rdt
275  REAL :: d2_divg
276  REAL :: k1k, rdg, dtmp, delt
277  LOGICAL :: last_step, remap_step
278  LOGICAL :: used
279  REAL :: split_timestep_bc
280  INTEGER :: is, ie, js, je
281  INTEGER :: isd, ied, jsd, jed
282  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
283  REAL, INTENT(INOUT) :: pkc(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
284  REAL, INTENT(INOUT) :: ptc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
285  REAL, INTENT(INOUT) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
286  REAL, INTENT(INOUT) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
287  REAL, INTENT(INOUT) :: cry(bd%isd:bd%ied, bd%js:bd%je+1, npz)
288  REAL, INTENT(INOUT) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
289  REAL, INTENT(INOUT) :: divgd(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, npz)
290  REAL, INTENT(INOUT) :: delpc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
291  REAL, INTENT(INOUT) :: ut(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
292  REAL, INTENT(INOUT) :: vt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
293  REAL, INTENT(INOUT) :: zh(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
294  REAL, INTENT(INOUT) :: pk3(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
295  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
296  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
297  INTRINSIC log
298  INTRINSIC real
299  INTRINSIC max
300  INTRINSIC min
301  INTRINSIC exp
302  INTRINSIC abs
303  INTRINSIC sign
304  INTEGER :: max1
305  INTEGER :: max2
306  REAL :: min1
307  REAL :: min2
308  REAL :: abs0
309  REAL :: arg1
310  REAL :: arg2
311  LOGICAL :: arg10
312  REAL*8 :: arg11
313  LOGICAL :: res
314  LOGICAL :: res0
315  REAL :: x1
316  REAL :: y2
317  REAL :: y1
318 
319  pem = 0.0
320  heat_source = 0.0
321  ws3 = 0.0
322  z_rat = 0.0
323  dp_ref = 0.0
324  zs = 0.0
325  p1d = 0.0
326  om2d = 0.0
327  wbuffer = 0.0
328  ebuffer = 0.0
329  nbuffer = 0.0
330  sbuffer = 0.0
331  divg2 = 0.0
332  wk = 0.0
333  fz = 0.0
334  heat_s = 0.0
335  damp_vt = 0.0
336  d2_divg_pert = 0.0
337  damp_vt_pert = 0.0
338  damp_w_pert = 0.0
339  damp_t_pert = 0.0
340  beta = 0.0
341  beta_d = 0.0
342  d_con_k = 0.0
343  damp_w = 0.0
344  damp_t = 0.0
345  kgb = 0.0
346  cv_air = 0.0
347  dt = 0.0
348  dt2 = 0.0
349  rdt = 0.0
350  d2_divg = 0.0
351  k1k = 0.0
352  rdg = 0.0
353  dtmp = 0.0
354  delt = 0.0
355  split_timestep_bc = 0.0
356  min1 = 0.0
357  min2 = 0.0
358  abs0 = 0.0
359  arg1 = 0.0
360  arg2 = 0.0
361  x1 = 0.0
362  y2 = 0.0
363  y1 = 0.0
364  nord_v = 0
365  hord_m = 0
366  hord_v = 0
367  hord_t = 0
368  hord_p = 0
369  nord_k = 0
370  nord_w = 0
371  nord_t = 0
372  ms = 0
373  hord_m_pert = 0
374  hord_v_pert = 0
375  hord_t_pert = 0
376  hord_p_pert = 0
377  nord_k_pert = 0
378  nord_w_pert = 0
379  nord_t_pert = 0
380  nord_v_pert = 0
381  i = 0
382  j = 0
383  k = 0
384  it = 0
385  iq = 0
386  n_con = 0
387  nf_ke = 0
388  iep1 = 0
389  jep1 = 0
390  is = 0
391  ie = 0
392  js = 0
393  je = 0
394  isd = 0
395  ied = 0
396  jsd = 0
397  jed = 0
398 
399  is = bd%is
400  ie = bd%ie
401  js = bd%js
402  je = bd%je
403  isd = bd%isd
404  ied = bd%ied
405  jsd = bd%jsd
406  jed = bd%jed
407  peln1 = log(ptop)
408  ptk = ptop**akap
409  dt = bdt/REAL(n_split)
410  dt2 = 0.5*dt
411  rdt = 1.0/dt
412  IF (1 .LT. flagstruct%m_split/2) THEN
413  ms = flagstruct%m_split/2
414  ELSE
415  ms = 1
416  END IF
417  beta = flagstruct%beta
418  rdg = -(rdgas/grav)
419  cv_air = cp_air - rdgas
420 ! Indexes:
421  iep1 = ie + 1
422  jep1 = je + 1
423  IF (.NOT.hydrostatic) THEN
424  rgrav = 1.0/grav
425 ! rg/Cv=0.4
426  k1k = akap/(1.-akap)
427 !$OMP parallel do default(none) shared(npz,dp_ref,ak,bk)
428  DO k=1,npz
429  dp_ref(k) = ak(k+1) - ak(k) + (bk(k+1)-bk(k))*1.e5
430  END DO
431 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,zs,phis,rgrav)
432  DO j=jsd,jed
433  DO i=isd,ied
434  zs(i, j) = phis(i, j)*rgrav
435  END DO
436  END DO
437  END IF
438 !allocate( du(isd:ied, jsd:jed+1,npz) )
439 !call init_ijk_mem(isd,ied, jsd,jed+1, npz, du, 0.)
440 !allocate( dv(isd:ied+1,jsd:jed, npz) )
441 !call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.)
442 ! Empty the "flux capacitors"
443 !call init_ijk_mem(is, ie+1, js, je, npz, mfx, 0.)
444  CALL pushrealarray(mfx, (bd%ie-bd%is+2)*(bd%je-bd%js+1)*npz)
445  mfx = 0.0
446 !call init_ijk_mem(is, ie , js, je+1, npz, mfy, 0.)
447  CALL pushrealarray(mfy, (bd%ie-bd%is+1)*(bd%je-bd%js+2)*npz)
448  mfy = 0.0
449 !call init_ijk_mem(is, ie+1, jsd, jed, npz, cx, 0.)
450  CALL pushrealarray(cx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
451  cx = 0.0
452 !call init_ijk_mem(isd, ied, js, je+1, npz, cy, 0.)
453  CALL pushrealarray(cy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
454  cy = 0.0
455  IF (flagstruct%d_con .GT. 1.0e-5) heat_source = 0.0
456 !allocate( heat_source(isd:ied, jsd:jed, npz) )
457 !call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.)
458  IF (flagstruct%convert_ke .OR. flagstruct%vtdm4 .GT. 1.e-4) THEN
459  CALL pushcontrol(2,2)
460  n_con = npz
461  ELSE IF (flagstruct%d2_bg_k1 .LT. 1.e-3) THEN
462  CALL pushcontrol(2,1)
463  n_con = 0
464  ELSE IF (flagstruct%d2_bg_k2 .LT. 1.e-3) THEN
465  CALL pushcontrol(2,0)
466  n_con = 1
467  ELSE
468  CALL pushcontrol(2,0)
469  n_con = 2
470  END IF
471 !-----------------------------------------------------
472  DO it=1,n_split
473 !-----------------------------------------------------
474  IF (flagstruct%breed_vortex_inline .OR. it .EQ. n_split) THEN
475  remap_step = .true.
476  ELSE
477  remap_step = .false.
478  END IF
479  IF (flagstruct%fv_debug) THEN
480  res = is_master()
481  IF (res) THEN
482  CALL pushcontrol(1,0)
483  WRITE(*, *) 'n_split loop, it=', it
484  ELSE
485  CALL pushcontrol(1,0)
486  END IF
487  ELSE
488  CALL pushcontrol(1,1)
489  END IF
490  IF (gridstruct%nested) split_timestep_bc = REAL(n_split*flagstruct&
491 & %k_split + neststruct%nest_timestep)
492 !First split timestep has split_timestep_BC = n_split*k_split
493 ! to do time-extrapolation on BCs.
494  IF (nq .GT. 0) THEN
495  IF (flagstruct%inline_q) THEN
496  CALL pushrealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz&
497 & *nq)
498  CALL start_group_halo_update(i_pack(10), q, domain)
499  CALL pushcontrol(2,0)
500  ELSE
501  CALL pushcontrol(2,1)
502  END IF
503  ELSE
504  CALL pushcontrol(2,2)
505  END IF
506  IF (.NOT.hydrostatic) THEN
507  CALL pushrealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
508  CALL start_group_halo_update(i_pack(7), w, domain)
509  IF (it .EQ. 1) THEN
510  IF (gridstruct%nested) THEN
511 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,gz,zs,delz)
512  DO j=jsd,jed
513  DO i=isd,ied
514  CALL pushrealarray(gz(i, j, npz+1))
515  gz(i, j, npz+1) = zs(i, j)
516  END DO
517  DO k=npz,1,-1
518  DO i=isd,ied
519  CALL pushrealarray(gz(i, j, k))
520  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
521  END DO
522  END DO
523  END DO
524  CALL pushcontrol(1,0)
525  ELSE
526 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zs,delz)
527  DO j=js,je
528  DO i=is,ie
529  CALL pushrealarray(gz(i, j, npz+1))
530  gz(i, j, npz+1) = zs(i, j)
531  END DO
532  DO k=npz,1,-1
533  DO i=is,ie
534  CALL pushrealarray(gz(i, j, k))
535  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
536  END DO
537  END DO
538  END DO
539  CALL pushcontrol(1,1)
540  END IF
541  CALL pushrealarray(gz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
542 & npz+1))
543  CALL start_group_halo_update(i_pack(5), gz, domain)
544  CALL pushcontrol(2,0)
545  ELSE
546  CALL pushcontrol(2,1)
547  END IF
548  ELSE
549  CALL pushcontrol(2,2)
550  END IF
551  IF (it .EQ. 1) THEN
552  CALL pushrealarray(beta_d)
553  beta_d = 0.
554  CALL pushcontrol(1,0)
555  ELSE
556  CALL pushrealarray(beta_d)
557  beta_d = beta
558  CALL pushcontrol(1,1)
559  END IF
560  IF (it .EQ. n_split .AND. end_step) THEN
561  IF (flagstruct%use_old_omega) THEN
562  pem = 0.0
563 !allocate ( pem(is-1:ie+1,npz+1,js-1:je+1) )
564 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pem,delp,ptop)
565  DO j=js-1,je+1
566  DO i=is-1,ie+1
567  pem(i, 1, j) = ptop
568  END DO
569  DO k=1,npz
570  DO i=is-1,ie+1
571  pem(i, k+1, j) = pem(i, k, j) + delp(i, j, k)
572  END DO
573  END DO
574  END DO
575  CALL pushcontrol(2,0)
576  ELSE
577  CALL pushcontrol(2,1)
578  END IF
579  last_step = .true.
580  ELSE
581  CALL pushcontrol(2,2)
582  last_step = .false.
583  END IF
584 !$OMP parallel do default(none) shared(npz,isd,jsd,delpc,delp,ptc,pt,u,v,w,uc,vc,ua,va, &
585 !$OMP omga,ut,vt,divgd,flagstruct,dt2,hydrostatic,bd, &
586 !$OMP gridstruct)
587  DO k=1,npz
588  CALL c_sw_fwd(delpc(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed&
589 & , k), ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k)&
590 & , u(isd:ied, jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(&
591 & isd:ied, jsd:jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:&
592 & ied, jsd:jed+1, k), ua(isd:ied, jsd:jed, k), va(isd:ied&
593 & , jsd:jed, k), omga(isd:ied, jsd:jed, k), ut(isd:ied, &
594 & jsd:jed, k), vt(isd:ied, jsd:jed, k), divgd(isd:ied+1, &
595 & jsd:jed+1, k), flagstruct%nord, dt2, hydrostatic, .true.&
596 & , bd, gridstruct, flagstruct)
597  END DO
598  IF (flagstruct%nord .GT. 0) THEN
599  CALL start_group_halo_update(i_pack(3), divgd, domain, position=&
600 & corner)
601  CALL pushcontrol(1,0)
602  ELSE
603  CALL pushcontrol(1,1)
604  END IF
605  IF (gridstruct%nested) THEN
606  arg1 = split_timestep_bc + 0.5
607  arg2 = REAL(n_split*flagstruct%k_split)
608  CALL pushrealarray(delpc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
609 & npz)
610  CALL nested_grid_bc_apply_intt(delpc, 0, 0, npx, npy, npz, bd, &
611 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%delp_bc&
612 & , bctype=neststruct%nestbctype)
613  arg1 = split_timestep_bc + 0.5
614  arg2 = REAL(n_split*flagstruct%k_split)
615  CALL pushrealarray(ptc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz&
616 & )
617  CALL nested_grid_bc_apply_intt(ptc, 0, 0, npx, npy, npz, bd, &
618 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%pt_bc, &
619 & bctype=neststruct%nestbctype)
620  call pushcontrol(1,0)
621  ELSE
622  CALL pushcontrol(1,1)
623  END IF
624 ! end hydro check
625  IF (hydrostatic) THEN
626  CALL geopk_fwd(ptop, pe, peln, delpc, pkc, gz, phis, ptc, q_con&
627 & , pkz, npz, akap, .true., gridstruct%nested, .false., &
628 & npx, npy, flagstruct%a2b_ord, bd)
629  CALL pushcontrol(2,0)
630  ELSE
631  IF (it .EQ. 1) THEN
632 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
633  DO k=1,npz+1
634  DO j=jsd,jed
635  DO i=isd,ied
636 ! Save edge heights for update_dz_d
637  zh(i, j, k) = gz(i, j, k)
638  END DO
639  END DO
640  END DO
641  CALL pushcontrol(1,0)
642  ELSE
643 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
644  DO k=1,npz+1
645  DO j=jsd,jed
646  DO i=isd,ied
647  CALL pushrealarray(gz(i, j, k))
648  gz(i, j, k) = zh(i, j, k)
649  END DO
650  END DO
651  END DO
652  CALL pushcontrol(1,1)
653  END IF
654  CALL update_dz_c_fwd(is, ie, js, je, npz, ng, dt2, dp_ref, zs, &
655 & gridstruct%area, ut, vt, gz, ws3, npx, npy, &
656 & gridstruct%sw_corner, gridstruct%se_corner, &
657 & gridstruct%ne_corner, gridstruct%nw_corner, bd, &
658 & gridstruct%grid_type)
659  CALL riem_solver_c_fwd(ms, dt2, is, ie, js, je, npz, ng, akap, &
660 & cappa, cp, ptop, phis, omga, ptc, q_con, delpc&
661 & , gz, pkc, ws3, flagstruct%p_fac, flagstruct%&
662 & a_imp, flagstruct%scale_z)
663  IF (gridstruct%nested) THEN
664  arg1 = split_timestep_bc + 0.5
665  arg2 = REAL(n_split*flagstruct%k_split)
666  CALL pushrealarray(delz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
667 & npz)
668  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
669 & split_timestep_bc + 0.5, REAL(n_split& & *flagstruct%k_split), neststruct%&
670 & delz_bc, bctype=neststruct%nestbctype&
671 & )
672 !Compute gz/pkc
673 !NOTE: nominally only need to compute quantities one out in the halo for p_grad_c
674 !(instead of entire halo)
675  CALL nest_halo_nh_fwd(ptop, grav, akap, cp, delpc, delz, ptc, &
676 & phis, pkc, gz, pk3, npx, npy, npz, gridstruct%&
677 & nested, .false., .false., .false., bd)
678  CALL pushcontrol(2,1)
679  ELSE
680  CALL pushcontrol(2,2)
681  END IF
682  END IF
683  CALL p_grad_c_fwd(dt2, npz, delpc, pkc, gz, uc, vc, bd, gridstruct&
684 & %rdxc, gridstruct%rdyc, hydrostatic)
685  CALL start_group_halo_update(i_pack(9), uc, vc, domain, gridtype=&
686 & cgrid_ne)
687  IF (gridstruct%nested) THEN
688 !On a nested grid we have to do SOMETHING with uc and vc in
689 ! the boundary halo, particularly at the corners of the
690 ! domain and of each processor element. We must either
691 ! apply an interpolated BC, or extrapolate into the
692 ! boundary halo
693 ! NOTE:
694 !The update_domains calls for uc and vc need to go BEFORE the BCs to ensure cross-restart
695 !bitwise-consistent solutions when doing the spatial extrapolation; should not make a
696 !difference for interpolated BCs from the coarse grid.
697  arg1 = split_timestep_bc + 0.5
698  arg2 = REAL(n_split*flagstruct%k_split)
699  CALL nested_grid_bc_apply_intt(vc, 0, 1, npx, npy, npz, bd, &
700 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%vc_bc, &
701 & bctype=neststruct%nestbctype)
702  arg1 = split_timestep_bc + 0.5
703  arg2 = REAL(n_split*flagstruct%k_split)
704  CALL nested_grid_bc_apply_intt(uc, 1, 0, npx, npy, npz, bd, &
705 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%uc_bc, &
706 & bctype=neststruct%nestbctype)
707 !QUESTION: What to do with divgd in nested halo?
708  arg1 = REAL(n_split*flagstruct%k_split)
709  CALL nested_grid_bc_apply_intt(divgd, 1, 1, npx, npy, npz, bd, &
710 & split_timestep_bc, REAL(n_split*& & flagstruct%k_split), neststruct%divg_bc&
711 & , bctype=neststruct%nestbctype)
712 !!$ if (is == 1 .and. js == 1) then
713 !!$ do j=jsd,5
714 !!$ write(mpp_pe()+2000,*) j, divg(isd:5,j,1)
715 !!$ endif
716  CALL pushcontrol(1,0)
717  ELSE
718  CALL pushcontrol(1,1)
719  END IF
720  IF (gridstruct%nested .AND. flagstruct%inline_q) THEN
721  DO iq=1,nq
722  arg1 = split_timestep_bc + 1
723  arg2 = REAL(n_split*flagstruct%k_split)
724  CALL pushrealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
725 & jed-jsd+1)*npz)
726  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
727 & 0, npx, npy, npz, bd, &
728 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%q_bc(&
729 & iq), bctype=neststruct%nestbctype)
730  end do
731  CALL pushcontrol(1,0)
732  ELSE
733  CALL pushcontrol(1,1)
734  END IF
735 !$OMP parallel do default(none) shared(npz,flagstruct,nord_v,pfull,damp_vt,hydrostatic,last_step, &
736 !$OMP is,ie,js,je,isd,ied,jsd,jed,omga,delp,gridstruct,npx,npy, &
737 !$OMP ng,zh,vt,ptc,pt,u,v,w,uc,vc,ua,va,divgd,mfx,mfy,cx,cy, &
738 !$OMP crx,cry,xfx,yfx,q_con,zvir,sphum,nq,q,dt,bd,rdt,iep1,jep1, &
739 !$OMP heat_source) &
740 !$OMP private(nord_k, nord_w, nord_t, damp_w, damp_t, d2_divg, &
741 !$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, z_rat)
742  DO k=1,npz
743  hord_m = flagstruct%hord_mt
744  hord_t = flagstruct%hord_tm
745  hord_v = flagstruct%hord_vt
746  hord_p = flagstruct%hord_dp
747  CALL pushinteger(nord_k)
748  nord_k = flagstruct%nord
749 ! if ( k==npz ) then
750  kgb = flagstruct%ke_bg
751  IF (2 .GT. flagstruct%nord) THEN
752  CALL pushinteger(nord_v(k))
753  nord_v(k) = flagstruct%nord
754  CALL pushcontrol(1,0)
755  ELSE
756  CALL pushinteger(nord_v(k))
757  nord_v(k) = 2
758  CALL pushcontrol(1,1)
759  END IF
760  IF (0.20 .GT. flagstruct%d2_bg) THEN
761  CALL pushrealarray(d2_divg)
762  d2_divg = flagstruct%d2_bg
763  CALL pushcontrol(1,0)
764  ELSE
765  CALL pushrealarray(d2_divg)
766  d2_divg = 0.20
767  CALL pushcontrol(1,1)
768  END IF
769  IF (flagstruct%do_vort_damp) THEN
770 ! for delp, delz, and vorticity
771  CALL pushrealarray(damp_vt(k))
772  damp_vt(k) = flagstruct%vtdm4
773  CALL pushcontrol(1,0)
774  ELSE
775  CALL pushrealarray(damp_vt(k))
776  damp_vt(k) = 0.
777  CALL pushcontrol(1,1)
778  END IF
779  CALL pushinteger(nord_w)
780  nord_w = nord_v(k)
781  CALL pushinteger(nord_t)
782  nord_t = nord_v(k)
783  damp_w = damp_vt(k)
784  damp_t = damp_vt(k)
785  d_con_k = flagstruct%d_con
786  IF (npz .EQ. 1 .OR. flagstruct%n_sponge .LT. 0) THEN
787  CALL pushcontrol(3,6)
788  d2_divg = flagstruct%d2_bg
789  ELSE IF (k .EQ. 1) THEN
790 ! Sponge layers with del-2 damping on divergence, vorticity, w, z, and air mass (delp).
791 ! no special damping of potential temperature in sponge layers
792 ! Divergence damping:
793  nord_k = 0
794  IF (0.01 .LT. flagstruct%d2_bg) THEN
795  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k1) THEN
796  CALL pushcontrol(1,0)
797  d2_divg = flagstruct%d2_bg_k1
798  ELSE
799  CALL pushcontrol(1,0)
800  d2_divg = flagstruct%d2_bg
801  END IF
802  ELSE IF (0.01 .LT. flagstruct%d2_bg_k1) THEN
803  CALL pushcontrol(1,1)
804  d2_divg = flagstruct%d2_bg_k1
805  ELSE
806  CALL pushcontrol(1,1)
807  d2_divg = 0.01
808  END IF
809 ! Vertical velocity:
810  nord_w = 0
811  damp_w = d2_divg
812  IF (flagstruct%do_vort_damp) THEN
813 ! damping on delp and vorticity:
814  CALL pushinteger(nord_v(k))
815  nord_v(k) = 0
816  CALL pushrealarray(damp_vt(k))
817  damp_vt(k) = 0.5*d2_divg
818  CALL pushcontrol(3,4)
819  ELSE
820  CALL pushcontrol(3,5)
821  END IF
822  d_con_k = 0.
823  ELSE
824  IF (2 .LT. flagstruct%n_sponge - 1) THEN
825  max1 = flagstruct%n_sponge - 1
826  ELSE
827  max1 = 2
828  END IF
829  IF (k .EQ. max1 .AND. flagstruct%d2_bg_k2 .GT. 0.01) THEN
830  nord_k = 0
831  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k2) THEN
832  d2_divg = flagstruct%d2_bg_k2
833  ELSE
834  d2_divg = flagstruct%d2_bg
835  END IF
836  nord_w = 0
837  damp_w = d2_divg
838  IF (flagstruct%do_vort_damp) THEN
839  CALL pushinteger(nord_v(k))
840  nord_v(k) = 0
841  CALL pushrealarray(damp_vt(k))
842  damp_vt(k) = 0.5*d2_divg
843  CALL pushcontrol(3,2)
844  ELSE
845  CALL pushcontrol(3,3)
846  END IF
847  d_con_k = 0.
848  ELSE
849  IF (3 .LT. flagstruct%n_sponge) THEN
850  max2 = flagstruct%n_sponge
851  ELSE
852  max2 = 3
853  END IF
854  IF (k .EQ. max2 .AND. flagstruct%d2_bg_k2 .GT. 0.05) THEN
855  nord_k = 0
856  IF (flagstruct%d2_bg .LT. 0.2*flagstruct%d2_bg_k2) THEN
857  CALL pushcontrol(3,1)
858  d2_divg = 0.2*flagstruct%d2_bg_k2
859  ELSE
860  CALL pushcontrol(3,1)
861  d2_divg = flagstruct%d2_bg
862  END IF
863  nord_w = 0
864  damp_w = d2_divg
865  d_con_k = 0.
866  ELSE
867  CALL pushcontrol(3,0)
868  END IF
869  END IF
870  END IF
871  CALL pushinteger(hord_m_pert)
872  hord_m_pert = flagstructp%hord_mt_pert
873  CALL pushinteger(hord_t_pert)
874  hord_t_pert = flagstructp%hord_tm_pert
875  CALL pushinteger(hord_v_pert)
876  hord_v_pert = flagstructp%hord_vt_pert
877  CALL pushinteger(hord_p_pert)
878  hord_p_pert = flagstructp%hord_dp_pert
879  CALL pushinteger(nord_k_pert)
880  nord_k_pert = flagstructp%nord_pert
881  IF (2 .GT. flagstructp%nord_pert) THEN
882  CALL pushinteger(nord_v_pert(k))
883  nord_v_pert(k) = flagstructp%nord_pert
884  CALL pushcontrol(1,0)
885  ELSE
886  CALL pushinteger(nord_v_pert(k))
887  nord_v_pert(k) = 2
888  CALL pushcontrol(1,1)
889  END IF
890  IF (0.20 .GT. flagstructp%d2_bg_pert) THEN
891  CALL pushrealarray(d2_divg_pert)
892  d2_divg_pert = flagstructp%d2_bg_pert
893  CALL pushcontrol(1,0)
894  ELSE
895  CALL pushrealarray(d2_divg_pert)
896  d2_divg_pert = 0.20
897  CALL pushcontrol(1,1)
898  END IF
899  IF (flagstructp%do_vort_damp_pert) THEN
900 ! for delp, delz, and vorticity
901  CALL pushrealarray(damp_vt_pert(k))
902  damp_vt_pert(k) = flagstructp%vtdm4_pert
903  CALL pushcontrol(1,0)
904  ELSE
905  CALL pushrealarray(damp_vt_pert(k))
906  damp_vt_pert(k) = 0.
907  CALL pushcontrol(1,1)
908  END IF
909  CALL pushinteger(nord_t_pert)
910  nord_t_pert = nord_v_pert(k)
911  CALL pushrealarray(damp_t_pert)
912  damp_t_pert = damp_vt_pert(k)
913 !Sponge layers for the pertuabtiosn
914  IF (k .LE. flagstructp%n_sponge_pert) THEN
915  IF (k .LE. flagstructp%n_sponge_pert - 1) THEN
916  IF (flagstructp%hord_ks_traj) THEN
917  hord_m = flagstructp%hord_mt_ks_traj
918  hord_t = flagstructp%hord_tm_ks_traj
919  hord_v = flagstructp%hord_vt_ks_traj
920  hord_p = flagstructp%hord_dp_ks_traj
921  END IF
922  IF (flagstructp%hord_ks_pert) THEN
923  CALL pushcontrol(1,0)
924  hord_m_pert = flagstructp%hord_mt_ks_pert
925  hord_t_pert = flagstructp%hord_tm_ks_pert
926  hord_v_pert = flagstructp%hord_vt_ks_pert
927  hord_p_pert = flagstructp%hord_dp_ks_pert
928  ELSE
929  CALL pushcontrol(1,0)
930  END IF
931  ELSE
932  CALL pushcontrol(1,1)
933  END IF
934  nord_k_pert = 0
935  IF (k .EQ. 1) THEN
936  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
937  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k1_pert&
938 & ) THEN
939  CALL pushcontrol(3,1)
940  d2_divg_pert = flagstructp%d2_bg_k1_pert
941  ELSE
942  CALL pushcontrol(3,1)
943  d2_divg_pert = flagstructp%d2_bg_pert
944  END IF
945  ELSE IF (0.01 .LT. flagstructp%d2_bg_k1_pert) THEN
946  CALL pushcontrol(3,0)
947  d2_divg_pert = flagstructp%d2_bg_k1_pert
948  ELSE
949  CALL pushcontrol(3,0)
950  d2_divg_pert = 0.01
951  END IF
952  ELSE IF (k .EQ. 2) THEN
953  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
954  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k2_pert&
955 & ) THEN
956  CALL pushcontrol(3,3)
957  d2_divg_pert = flagstructp%d2_bg_k2_pert
958  ELSE
959  CALL pushcontrol(3,3)
960  d2_divg_pert = flagstructp%d2_bg_pert
961  END IF
962  ELSE IF (0.01 .LT. flagstructp%d2_bg_k2_pert) THEN
963  CALL pushcontrol(3,2)
964  d2_divg_pert = flagstructp%d2_bg_k2_pert
965  ELSE
966  CALL pushcontrol(3,2)
967  d2_divg_pert = 0.01
968  END IF
969  ELSE IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
970  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_ks_pert) &
971 & THEN
972  CALL pushcontrol(3,5)
973  d2_divg_pert = flagstructp%d2_bg_ks_pert
974  ELSE
975  CALL pushcontrol(3,5)
976  d2_divg_pert = flagstructp%d2_bg_pert
977  END IF
978  ELSE IF (0.01 .LT. flagstructp%d2_bg_ks_pert) THEN
979  CALL pushcontrol(3,4)
980  d2_divg_pert = flagstructp%d2_bg_ks_pert
981  ELSE
982  CALL pushcontrol(3,4)
983  d2_divg_pert = 0.01
984  END IF
985  IF (flagstructp%do_vort_damp_pert) THEN
986  CALL pushinteger(nord_v_pert(k))
987  nord_v_pert(k) = 0
988  CALL pushrealarray(damp_vt_pert(k))
989  damp_vt_pert(k) = 0.5*d2_divg_pert
990  CALL pushcontrol(2,0)
991  ELSE
992  CALL pushcontrol(2,1)
993  END IF
994  ELSE
995  CALL pushcontrol(2,2)
996  END IF
997 !Tapenade issue if not defined at level npz+1
998  CALL pushrealarray(damp_vt(npz+1))
999  damp_vt(npz+1) = damp_vt(npz)
1000  CALL pushrealarray(damp_vt_pert(npz+1))
1001  damp_vt_pert(npz+1) = damp_vt_pert(npz)
1002  CALL pushinteger(nord_v(npz+1))
1003  nord_v(npz+1) = nord_v(npz)
1004  CALL pushinteger(nord_v_pert(npz+1))
1005  nord_v_pert(npz+1) = nord_v_pert(npz)
1006  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
1007 & last_step) THEN
1008 ! Average horizontal "convergence" to cell center
1009  DO j=js,je
1010  DO i=is,ie
1011  CALL pushrealarray(omga(i, j, k))
1012  omga(i, j, k) = delp(i, j, k)
1013  END DO
1014  END DO
1015  CALL pushcontrol(1,0)
1016  ELSE
1017  CALL pushcontrol(1,1)
1018  END IF
1019 !--- external mode divergence damping ---
1020  IF (flagstruct%d_ext .GT. 0.) THEN
1021  CALL a2b_ord2_fwd(delp(isd:ied, jsd:jed, k), wk, gridstruct, &
1022 & npx, npy, is, ie, js, je, ng, .false.)
1023  CALL pushcontrol(1,0)
1024  ELSE
1025  CALL pushcontrol(1,1)
1026  END IF
1027  IF (.NOT.hydrostatic .AND. flagstruct%do_f3d) THEN
1028 ! Correction factor for 3D Coriolis force
1029  DO j=jsd,jed
1030  DO i=isd,ied
1031  z_rat(i, j) = 1. + (zh(i, j, k)+zh(i, j, k+1))/radius
1032  END DO
1033  END DO
1034  CALL pushcontrol(1,0)
1035  ELSE
1036  CALL pushcontrol(1,1)
1037  END IF
1038  CALL d_sw_fwd(vt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k)&
1039 & , ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k), u(&
1040 & isd:ied, jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(isd:&
1041 & ied, jsd:jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:ied&
1042 & , jsd:jed+1, k), ua(isd:ied, jsd:jed, k), va(isd:ied, &
1043 & jsd:jed, k), divgd(isd:ied+1, jsd:jed+1, k), mfx(is:ie+1&
1044 & , js:je, k), mfy(is:ie, js:je+1, k), cx(is:ie+1, jsd:jed&
1045 & , k), cy(isd:ied, js:je+1, k), crx(is:ie+1, jsd:jed, k)&
1046 & , cry(isd:ied, js:je+1, k), xfx(is:ie+1, jsd:jed, k), &
1047 & yfx(isd:ied, js:je+1, k), q_con(isd:ied, jsd:jed, 1), &
1048 & z_rat(isd:ied, jsd:jed), kgb, heat_s, dpx, zvir, sphum, &
1049 & nq, q, k, npz, flagstruct%inline_q, dt, flagstruct%&
1050 & hord_tr, hord_m, hord_v, hord_t, hord_p, nord_k, nord_v(&
1051 & k), nord_w, nord_t, flagstruct%dddmp, d2_divg, &
1052 & flagstruct%d4_bg, damp_vt(k), damp_w, damp_t, d_con_k, &
1053 & hydrostatic, gridstruct, flagstruct, bd, flagstructp%&
1054 & hord_tr_pert, hord_m_pert, hord_v_pert, hord_t_pert, &
1055 & hord_p_pert, flagstructp%split_damp, nord_k_pert, &
1056 & nord_v_pert(k), nord_w_pert, nord_t_pert, flagstructp%&
1057 & dddmp_pert, d2_divg_pert, flagstructp%d4_bg_pert, &
1058 & damp_vt_pert(k), damp_w_pert, damp_t_pert)
1059  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
1060 & last_step) THEN
1061 ! Average horizontal "convergence" to cell center
1062  DO j=js,je
1063  DO i=is,ie
1064  CALL pushrealarray(omga(i, j, k))
1065  omga(i, j, k) = omga(i, j, k)*(xfx(i, j, k)-xfx(i+1, j, k)&
1066 & +yfx(i, j, k)-yfx(i, j+1, k))*gridstruct%rarea(i, j)*rdt
1067  END DO
1068  END DO
1069  CALL pushcontrol(1,0)
1070  ELSE
1071  CALL pushcontrol(1,1)
1072  END IF
1073  IF (flagstruct%d_ext .GT. 0.) THEN
1074  DO j=js,jep1
1075  DO i=is,iep1
1076 ! delp at cell corners
1077  CALL pushrealarray(ptc(i, j, k))
1078  ptc(i, j, k) = wk(i, j)
1079  END DO
1080  END DO
1081  CALL pushcontrol(1,0)
1082  ELSE
1083  CALL pushcontrol(1,1)
1084  END IF
1085  IF (flagstruct%d_con .GT. 1.0e-5) THEN
1086 ! Average horizontal "convergence" to cell center
1087  DO j=js,je
1088  DO i=is,ie
1089  heat_source(i, j, k) = heat_source(i, j, k) + heat_s(i, j)
1090  END DO
1091  END DO
1092  CALL pushcontrol(1,1)
1093  ELSE
1094  CALL pushcontrol(1,0)
1095  END IF
1096  END DO
1097 ! end openMP k-loop
1098  IF (flagstruct%fill_dp) THEN
1099  CALL mix_dp_fwd(hydrostatic, w, delp, pt, npz, ak, bk, .false., &
1100 & flagstruct%fv_debug, bd)
1101  CALL pushcontrol(1,0)
1102  ELSE
1103  CALL pushcontrol(1,1)
1104  END IF
1105  CALL pushrealarray(delp, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
1106  CALL start_group_halo_update(i_pack(1), delp, domain, complete=&
1107 & .true.)
1108  CALL pushrealarray(pt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
1109  CALL start_group_halo_update(i_pack(1), pt, domain, complete=&
1110 & .true.)
1111  IF (flagstruct%d_ext .GT. 0.) THEN
1112  CALL pushrealarray(d2_divg)
1113  d2_divg = flagstruct%d_ext*gridstruct%da_min_c
1114 !$OMP parallel do default(none) shared(is,iep1,js,jep1,npz,wk,ptc,divg2,vt,d2_divg)
1115  DO j=js,jep1
1116  DO i=is,iep1
1117  CALL pushrealarray(wk(i, j))
1118  wk(i, j) = ptc(i, j, 1)
1119  divg2(i, j) = wk(i, j)*vt(i, j, 1)
1120  END DO
1121  DO k=2,npz
1122  DO i=is,iep1
1123  CALL pushrealarray(wk(i, j))
1124  wk(i, j) = wk(i, j) + ptc(i, j, k)
1125  divg2(i, j) = divg2(i, j) + ptc(i, j, k)*vt(i, j, k)
1126  END DO
1127  END DO
1128  DO i=is,iep1
1129  CALL pushrealarray(divg2(i, j))
1130  divg2(i, j) = d2_divg*divg2(i, j)/wk(i, j)
1131  END DO
1132  END DO
1133  CALL pushcontrol(1,0)
1134  ELSE
1135  divg2(:, :) = 0.
1136  CALL pushcontrol(1,1)
1137  END IF
1138 !Want to move this block into the hydro/nonhydro branch above and merge the two if structures
1139  IF (gridstruct%nested) THEN
1140  arg1 = split_timestep_bc + 1
1141  arg2 = REAL(n_split*flagstruct%k_split)
1142  CALL nested_grid_bc_apply_intt(delp, 0, 0, npx, npy, npz, bd, &
1143 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%delp_bc&
1144 & , bctype=neststruct%nestbctype)
1145  arg1 = split_timestep_bc + 1
1146  arg2 = REAL(n_split*flagstruct%k_split)
1147  CALL nested_grid_bc_apply_intt(pt, 0, 0, npx, npy, npz, bd, &
1148 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%pt_bc, &
1149 & bctype=neststruct%nestbctype)
1150  call pushcontrol(1,0)
1151  ELSE
1152  CALL pushcontrol(1,1)
1153  END IF
1154 ! end hydro check
1155  IF (hydrostatic) THEN
1156  CALL geopk_fwd(ptop, pe, peln, delp, pkc, gz, phis, pt, q_con, &
1157 & pkz, npz, akap, .false., gridstruct%nested, .true., npx&
1158 & , npy, flagstruct%a2b_ord, bd)
1159  CALL pushcontrol(1,0)
1160  ELSE
1161  CALL update_dz_d_fwd(nord_v, damp_vt, flagstruct%hord_tm, is, ie&
1162 & , js, je, npz, ng, npx, npy, gridstruct%area, &
1163 & gridstruct%rarea, dp_ref, zs, zh, crx, cry, xfx, &
1164 & yfx, delz, ws, rdt, gridstruct, bd, flagstructp%&
1165 & hord_tm_pert)
1166  arg10 = beta .LT. -0.1
1167  CALL riem_solver3_fwd(flagstruct%m_split, dt, is, ie, js, je, &
1168 & npz, ng, isd, ied, jsd, jed, akap, cappa, cp, &
1169 & ptop, zs, q_con, w, delz, pt, delp, zh, pe, pkc&
1170 & , pk3, pk, peln, ws, flagstruct%scale_z, &
1171 & flagstruct%p_fac, flagstruct%a_imp, flagstruct%&
1172 & use_logp, remap_step, arg10)
1173  IF (gridstruct%square_domain) THEN
1174  CALL pushrealarray(zh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
1175 & npz+1))
1176  CALL start_group_halo_update(i_pack(4), zh, domain)
1177  CALL pushrealarray(pkc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
1178 & npz+1))
1179  CALL start_group_halo_update(i_pack(5), pkc, domain, whalo=2, &
1180 & ehalo=2, shalo=2, nhalo=2)
1181  CALL pushcontrol(1,0)
1182  ELSE
1183  CALL pushrealarray(zh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
1184 & npz+1))
1185  CALL start_group_halo_update(i_pack(4), zh, domain, complete=&
1186 & .true.)
1187  CALL pushrealarray(pkc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
1188 & npz+1))
1189  CALL start_group_halo_update(i_pack(4), pkc, domain, complete=&
1190 & .true.)
1191  CALL pushcontrol(1,1)
1192  END IF
1193  IF (remap_step) THEN
1194  CALL pe_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
1195 & , pe, delp)
1196  CALL pushcontrol(1,0)
1197  ELSE
1198  CALL pushcontrol(1,1)
1199  END IF
1200  IF (flagstruct%use_logp) THEN
1201  CALL pln_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, &
1202 & ptop, pk3, delp)
1203  CALL pushcontrol(1,0)
1204  ELSE
1205  CALL pk3_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, &
1206 & ptop, akap, pk3, delp)
1207  CALL pushcontrol(1,1)
1208  END IF
1209  IF (gridstruct%nested) THEN
1210  arg1 = split_timestep_bc + 1.
1211  arg2 = REAL(n_split*flagstruct%k_split)
1212  CALL pushrealarray(delz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
1213 & npz)
1214  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
1215 & split_timestep_bc + 1., REAL(n_split*& & flagstruct%k_split), neststruct%&
1216 & delz_bc, bctype=neststruct%nestbctype&
1217 & )
1218 !Compute gz/pkc/pk3; note that now pkc should be nonhydro pert'n pressure
1219  CALL nest_halo_nh_fwd(ptop, grav, akap, cp, delp, delz, pt, &
1220 & phis, pkc, gz, pk3, npx, npy, npz, gridstruct%&
1221 & nested, .true., .true., .true., bd)
1222  CALL pushcontrol(1,0)
1223  ELSE
1224  CALL pushcontrol(1,1)
1225  END IF
1226 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zh,grav)
1227  DO k=1,npz+1
1228  DO j=js-2,je+2
1229  DO i=is-2,ie+2
1230  CALL pushrealarray(gz(i, j, k))
1231  gz(i, j, k) = zh(i, j, k)*grav
1232  END DO
1233  END DO
1234  END DO
1235  CALL pushcontrol(1,1)
1236  END IF
1237  IF (remap_step .AND. hydrostatic) THEN
1238 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,pkc)
1239  DO k=1,npz+1
1240  DO j=js,je
1241  DO i=is,ie
1242  CALL pushrealarray(pk(i, j, k))
1243  pk(i, j, k) = pkc(i, j, k)
1244  END DO
1245  END DO
1246  END DO
1247  CALL pushcontrol(1,0)
1248  ELSE
1249  CALL pushcontrol(1,1)
1250  END IF
1251 !----------------------------
1252 ! Compute pressure gradient:
1253 !----------------------------
1254  IF (hydrostatic) THEN
1255  IF (beta .GT. 0.) THEN
1256  CALL grad1_p_update_fwd(divg2, u, v, pkc, gz, du, dv, dt, ng, &
1257 & gridstruct, bd, npx, npy, npz, ptop, beta_d&
1258 & , flagstruct%a2b_ord)
1259  CALL pushcontrol(3,0)
1260  ELSE
1261  CALL one_grad_p_fwd(u, v, pkc, gz, divg2, delp, dt, ng, &
1262 & gridstruct, bd, npx, npy, npz, ptop, hydrostatic&
1263 & , flagstruct%a2b_ord, flagstruct%d_ext)
1264  CALL pushcontrol(3,1)
1265  END IF
1266  ELSE IF (beta .GT. 0.) THEN
1267  CALL split_p_grad_fwd(u, v, pkc, gz, du, dv, delp, pk3, beta_d, &
1268 & dt, ng, gridstruct, bd, npx, npy, npz, &
1269 & flagstruct%use_logp)
1270  CALL pushcontrol(3,2)
1271  ELSE IF (beta .LT. -0.1) THEN
1272  CALL one_grad_p_fwd(u, v, pkc, gz, divg2, delp, dt, ng, &
1273 & gridstruct, bd, npx, npy, npz, ptop, hydrostatic, &
1274 & flagstruct%a2b_ord, flagstruct%d_ext)
1275  CALL pushcontrol(3,3)
1276  ELSE
1277  CALL nh_p_grad_fwd(u, v, pkc, gz, delp, pk3, dt, ng, gridstruct&
1278 & , bd, npx, npy, npz, flagstruct%use_logp)
1279  CALL pushcontrol(3,4)
1280  END IF
1281 ! Inline Rayleigh friction here?
1282 !-------------------------------------------------------------------------------------------------------
1283  IF (flagstruct%breed_vortex_inline) THEN
1284  IF (.NOT.hydrostatic) THEN
1285 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k)
1286  DO k=1,npz
1287  DO j=js,je
1288  DO i=is,ie
1289 ! Note: pt at this stage is Theta_m
1290  CALL pushrealarray(pkz(i, j, k))
1291  pkz(i, j, k) = exp(k1k*log(rdg*delp(i, j, k)/delz(i, j, &
1292 & k)*pt(i, j, k)))
1293  END DO
1294  END DO
1295  END DO
1296  CALL pushcontrol(2,0)
1297  ELSE
1298  CALL pushcontrol(2,1)
1299  END IF
1300  ELSE
1301  CALL pushcontrol(2,2)
1302  END IF
1303 !-------------------------------------------------------------------------------------------------------
1304  IF (it .EQ. n_split .AND. gridstruct%grid_type .LT. 4 .AND. (.NOT.&
1305 & gridstruct%nested)) THEN
1306 ! Prevent accumulation of rounding errors at overlapped domain edges:
1307  CALL pushrealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
1308  CALL pushrealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
1309  CALL mpp_get_boundary(u, v, domain, ebuffery=ebuffer, nbufferx=&
1310 & nbuffer, gridtype=dgrid_ne)
1311 !$OMP parallel do default(none) shared(is,ie,js,je,npz,u,nbuffer,v,ebuffer)
1312  DO k=1,npz
1313  DO i=is,ie
1314  u(i, je+1, k) = nbuffer(i-is+1, k)
1315  END DO
1316  DO j=js,je
1317  v(ie+1, j, k) = ebuffer(j-js+1, k)
1318  END DO
1319  END DO
1320  CALL pushcontrol(1,0)
1321  ELSE
1322  CALL pushcontrol(1,1)
1323  END IF
1324  IF (it .NE. n_split) THEN
1325  CALL pushrealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
1326  CALL pushrealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
1327  CALL start_group_halo_update(i_pack(8), u, v, domain, gridtype=&
1328 & dgrid_ne)
1329  CALL pushcontrol(1,0)
1330  ELSE
1331  CALL pushcontrol(1,1)
1332  END IF
1333  IF (gridstruct%nested) neststruct%nest_timestep = neststruct%&
1334 & nest_timestep + 1
1335  IF (hydrostatic .AND. last_step) THEN
1336  IF (flagstruct%use_old_omega) THEN
1337 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,pe,pem,rdt)
1338  DO k=1,npz
1339  DO j=js,je
1340  DO i=is,ie
1341  CALL pushrealarray(omga(i, j, k))
1342  omga(i, j, k) = (pe(i, k+1, j)-pem(i, k+1, j))*rdt
1343  END DO
1344  END DO
1345  END DO
1346 !------------------------------
1347 ! Compute the "advective term"
1348 !------------------------------
1349  CALL adv_pe_fwd(ua, va, pem, omga, gridstruct, bd, npx, npy, &
1350 & npz, ng)
1351  CALL pushcontrol(1,0)
1352  ELSE
1353 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga) private(om2d)
1354  DO j=js,je
1355  DO k=1,npz
1356  DO i=is,ie
1357  om2d(i, k) = omga(i, j, k)
1358  END DO
1359  END DO
1360  DO k=2,npz
1361  DO i=is,ie
1362  om2d(i, k) = om2d(i, k-1) + omga(i, j, k)
1363  END DO
1364  END DO
1365  DO k=2,npz
1366  DO i=is,ie
1367  CALL pushrealarray(omga(i, j, k))
1368  omga(i, j, k) = om2d(i, k)
1369  END DO
1370  END DO
1371  END DO
1372  CALL pushcontrol(1,1)
1373  END IF
1374  IF (idiag%id_ws .GT. 0 .AND. hydrostatic) THEN
1375 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ws,delz,delp,omga)
1376  DO j=js,je
1377  DO i=is,ie
1378  CALL pushrealarray(ws(i, j))
1379  ws(i, j) = delz(i, j, npz)/delp(i, j, npz)*omga(i, j, npz)
1380  END DO
1381  END DO
1382  CALL pushcontrol(2,0)
1383  ELSE
1384  CALL pushcontrol(2,1)
1385  END IF
1386  ELSE
1387  CALL pushcontrol(2,2)
1388  END IF
1389  IF (gridstruct%nested) THEN
1390  IF (.NOT.hydrostatic) THEN
1391  arg1 = split_timestep_bc + 1
1392  arg2 = REAL(n_split*flagstruct%k_split)
1393  CALL pushrealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz&
1394 & )
1395  CALL nested_grid_bc_apply_intt(w, 0, 0, npx, npy, npz, bd, &
1396 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%w_bc&
1397 & , bctype=neststruct%nestbctype)
1398  call pushcontrol(1,0)
1399  ELSE
1400  CALL pushcontrol(1,1)
1401  END IF
1402  arg1 = split_timestep_bc + 1
1403  arg2 = REAL(n_split*flagstruct%k_split)
1404  CALL pushrealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
1405  CALL nested_grid_bc_apply_intt(u, 0, 1, npx, npy, npz, bd, &
1406 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%u_bc, &
1407 & bctype=neststruct%nestbctype)
1408  arg1 = split_timestep_bc + 1
1409  arg2 = REAL(n_split*flagstruct%k_split)
1410  CALL pushrealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
1411  CALL nested_grid_bc_apply_intt(v, 1, 0, npx, npy, npz, bd, &
1412 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%v_bc, &
1413 & bctype=neststruct%nestbctype)
1414  call pushcontrol(1,1)
1415  ELSE
1416  CALL pushcontrol(1,0)
1417  END IF
1418  END DO
1419 !-----------------------------------------------------
1420 ! time split loop
1421 !-----------------------------------------------------
1422  IF (nq .GT. 0 .AND. (.NOT.flagstruct%inline_q)) THEN
1423  CALL pushrealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*nq)
1424  CALL start_group_halo_update(i_pack(10), q, domain)
1425  CALL pushcontrol(1,0)
1426  ELSE
1427  CALL pushcontrol(1,1)
1428  END IF
1429  IF (flagstruct%fv_debug) THEN
1430  res0 = is_master()
1431  IF (res0) THEN
1432  CALL pushcontrol(1,0)
1433  WRITE(*, *) 'End of n_split loop'
1434  ELSE
1435  CALL pushcontrol(1,0)
1436  END IF
1437  ELSE
1438  CALL pushcontrol(1,1)
1439  END IF
1440  IF (n_con .NE. 0 .AND. flagstruct%d_con .GT. 1.e-5) THEN
1441  IF (3 .GT. flagstruct%nord + 1) THEN
1442  nf_ke = flagstruct%nord + 1
1443  ELSE
1444  nf_ke = 3
1445  END IF
1446  arg11 = cnst_0p20*gridstruct%da_min
1447  CALL del2_cubed_fwd(heat_source, arg11, gridstruct, domain, npx, &
1448 & npy, npz, nf_ke, bd)
1449 ! Note: pt here is cp*(Virtual_Temperature/pkz)
1450  IF (hydrostatic) THEN
1451 !
1452 ! del(Cp*T) = - del(KE)
1453 !
1454 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pt,heat_source,delp,pkz,bdt) &
1455 !$OMP private(dtmp)
1456  DO j=js,je
1457 ! n_con is usually less than 3;
1458  DO k=1,n_con
1459  IF (k .LT. 3) THEN
1460  DO i=is,ie
1461  CALL pushrealarray(pt(i, j, k))
1462  pt(i, j, k) = pt(i, j, k) + heat_source(i, j, k)/(cp_air&
1463 & *delp(i, j, k)*pkz(i, j, k))
1464  END DO
1465  CALL pushcontrol(1,1)
1466  ELSE
1467  DO i=is,ie
1468  dtmp = heat_source(i, j, k)/(cp_air*delp(i, j, k))
1469  IF (bdt .GE. 0.) THEN
1470  abs0 = bdt
1471  ELSE
1472  abs0 = -bdt
1473  END IF
1474  x1 = abs0*flagstruct%delt_max
1475  IF (dtmp .GE. 0.) THEN
1476  y1 = dtmp
1477  CALL pushcontrol(1,0)
1478  ELSE
1479  y1 = -dtmp
1480  CALL pushcontrol(1,1)
1481  END IF
1482  IF (x1 .GT. y1) THEN
1483  CALL pushrealarray(min1)
1484  min1 = y1
1485  CALL pushcontrol(1,0)
1486  ELSE
1487  CALL pushrealarray(min1)
1488  min1 = x1
1489  CALL pushcontrol(1,1)
1490  END IF
1491  CALL pushrealarray(pt(i, j, k))
1492  pt(i, j, k) = pt(i, j, k) + sign(min1, dtmp)/pkz(i, j, k&
1493 & )
1494  END DO
1495  CALL pushcontrol(1,0)
1496  END IF
1497  END DO
1498  END DO
1499  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1500  CALL pushrealarray(d2_divg)
1501  CALL pushinteger(ms)
1502  CALL pushinteger(hord_v_pert)
1503  CALL pushinteger(hord_t_pert)
1504  CALL pushrealarray(dp_ref, npz)
1505  CALL pushinteger(hord_p_pert)
1506  CALL pushinteger(je)
1507  CALL pushrealarray(heat_source, (bd%ied-bd%isd+1)*(bd%jed-bd%&
1508 & jsd+1)*npz)
1509  CALL pushinteger(nord_w)
1510  CALL pushrealarray(min1)
1511  CALL pushinteger(nord_v, npz + 1)
1512  CALL pushrealarray(damp_vt, npz + 1)
1513  CALL pushinteger(nord_t)
1514  CALL pushrealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1515  CALL pushrealarray(damp_t_pert)
1516  CALL pushinteger(nord_k)
1517  CALL pushinteger(nord_k_pert)
1518  CALL pushrealarray(d2_divg_pert)
1519  CALL pushrealarray(rdt)
1520  CALL pushinteger(is)
1521  CALL pushrealarray(damp_vt_pert, npz + 1)
1522  CALL pushrealarray(rdg)
1523  CALL pushinteger(ie)
1524  CALL pushrealarray(k1k)
1525  CALL pushrealarray(dt2)
1526  CALL pushinteger(n_con)
1527  CALL pushrealarray(beta_d)
1528  CALL pushinteger(hord_m_pert)
1529  CALL pushinteger(nord_v_pert, npz + 1)
1530  CALL pushinteger(nord_t_pert)
1531  CALL pushrealarray(dt)
1532  CALL pushinteger(js)
1533  CALL pushcontrol(2,1)
1534  ELSE
1535 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pkz,cappa,rdg,delp,delz,pt, &
1536 !$OMP heat_source,k1k,cv_air,bdt) &
1537 !$OMP private(dtmp, delt)
1538  DO k=1,n_con
1539  IF (bdt*flagstruct%delt_max .GE. 0.) THEN
1540  delt = bdt*flagstruct%delt_max
1541  ELSE
1542  delt = -(bdt*flagstruct%delt_max)
1543  END IF
1544 ! Sponge layers:
1545 ! if ( k == 1 ) delt = 2.0*delt
1546 ! if ( k == 2 ) delt = 1.5*delt
1547  DO j=js,je
1548  DO i=is,ie
1549  CALL pushrealarray(pkz(i, j, k))
1550  pkz(i, j, k) = exp(k1k*log(rdg*delp(i, j, k)/delz(i, j, k)&
1551 & *pt(i, j, k)))
1552  dtmp = heat_source(i, j, k)/(cv_air*delp(i, j, k))
1553  IF (dtmp .GE. 0.) THEN
1554  y2 = dtmp
1555  CALL pushcontrol(1,0)
1556  ELSE
1557  y2 = -dtmp
1558  CALL pushcontrol(1,1)
1559  END IF
1560  IF (delt .GT. y2) THEN
1561  CALL pushrealarray(min2)
1562  min2 = y2
1563  CALL pushcontrol(1,0)
1564  ELSE
1565  CALL pushrealarray(min2)
1566  min2 = delt
1567  CALL pushcontrol(1,1)
1568  END IF
1569  CALL pushrealarray(pt(i, j, k))
1570  pt(i, j, k) = pt(i, j, k) + sign(min2, dtmp)/pkz(i, j, k)
1571  END DO
1572  END DO
1573  END DO
1574  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1575  CALL pushrealarray(d2_divg)
1576  CALL pushinteger(ms)
1577  CALL pushinteger(hord_v_pert)
1578  CALL pushinteger(hord_t_pert)
1579  CALL pushrealarray(dp_ref, npz)
1580  CALL pushinteger(hord_p_pert)
1581  CALL pushinteger(je)
1582  CALL pushrealarray(heat_source, (bd%ied-bd%isd+1)*(bd%jed-bd%&
1583 & jsd+1)*npz)
1584  CALL pushrealarray(min2)
1585  CALL pushinteger(nord_w)
1586  CALL pushinteger(nord_v, npz + 1)
1587  CALL pushrealarray(damp_vt, npz + 1)
1588  CALL pushinteger(nord_t)
1589  CALL pushrealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1590  CALL pushrealarray(damp_t_pert)
1591  CALL pushinteger(nord_k)
1592  CALL pushinteger(nord_k_pert)
1593  CALL pushrealarray(d2_divg_pert)
1594  CALL pushrealarray(rdt)
1595  CALL pushinteger(is)
1596  CALL pushrealarray(damp_vt_pert, npz + 1)
1597  CALL pushrealarray(cv_air)
1598  CALL pushrealarray(rdg)
1599  CALL pushinteger(ie)
1600  CALL pushrealarray(k1k)
1601  CALL pushrealarray(dt2)
1602  CALL pushinteger(n_con)
1603  CALL pushrealarray(beta_d)
1604  CALL pushinteger(hord_m_pert)
1605  CALL pushinteger(nord_v_pert, npz + 1)
1606  CALL pushinteger(nord_t_pert)
1607  CALL pushrealarray(dt)
1608  CALL pushinteger(js)
1609  CALL pushcontrol(2,2)
1610  END IF
1611  ELSE
1612  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1613  CALL pushrealarray(d2_divg)
1614  CALL pushinteger(ms)
1615  CALL pushinteger(hord_v_pert)
1616  CALL pushinteger(hord_t_pert)
1617  CALL pushrealarray(dp_ref, npz)
1618  CALL pushinteger(hord_p_pert)
1619  CALL pushinteger(je)
1620  CALL pushinteger(nord_w)
1621  CALL pushinteger(nord_v, npz + 1)
1622  CALL pushrealarray(damp_vt, npz + 1)
1623  CALL pushinteger(nord_t)
1624  CALL pushrealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
1625  CALL pushrealarray(damp_t_pert)
1626  CALL pushinteger(nord_k)
1627  CALL pushinteger(nord_k_pert)
1628  CALL pushrealarray(d2_divg_pert)
1629  CALL pushrealarray(rdt)
1630  CALL pushinteger(is)
1631  CALL pushrealarray(damp_vt_pert, npz + 1)
1632  CALL pushrealarray(rdg)
1633  CALL pushinteger(ie)
1634  CALL pushrealarray(k1k)
1635  CALL pushrealarray(dt2)
1636  CALL pushrealarray(beta_d)
1637  CALL pushinteger(hord_m_pert)
1638  CALL pushinteger(nord_v_pert, npz + 1)
1639  CALL pushinteger(nord_t_pert)
1640  CALL pushrealarray(dt)
1641  CALL pushinteger(js)
1642  CALL pushcontrol(2,0)
1643  END IF
1644  END SUBROUTINE dyn_core_fwd
1645 ! Differentiation of dyn_core in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
1646 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
1647 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
1648 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
1649 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
1650 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
1651 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
1652 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
1653 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
1654 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
1655 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
1656 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
1657 !.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.
1658 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
1659 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
1660 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
1661 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
1662 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1663 ! gradient of useful results: pk3 xfx ws peln q gz du u dv
1664 ! v w delp ua uc ptc mfx delz mfy omga ut divgd
1665 ! pkc delpc va vc yfx pkz pe vt pk zh pt cx cy dpx
1666 ! crx cry
1667 ! with respect to varying inputs: pk3 xfx ws peln q gz du u dv
1668 ! v w delp ua uc ptc delz omga ut divgd pkc delpc
1669 ! va vc yfx pkz pe vt pk zh pt dpx crx cry
1670 !-----------------------------------------------------------------------
1671 ! dyn_core :: FV Lagrangian dynamics driver
1672 !-----------------------------------------------------------------------
1673  SUBROUTINE dyn_core_bwd(npx, npy, npz, ng, sphum, nq, bdt, n_split, &
1674 & zvir, cp, akap, cappa, grav, hydrostatic, u, u_ad, v, v_ad, w, w_ad&
1675 & , delz, delz_ad, pt, pt_ad, q, q_ad, delp, delp_ad, pe, pe_ad, pk, &
1676 & pk_ad, phis, ws, ws_ad, omga, omga_ad, ptop, pfull, ua, ua_ad, va, &
1677 & va_ad, uc, uc_ad, vc, vc_ad, mfx, mfx_ad, mfy, mfy_ad, cx, cx_ad, cy&
1678 & , cy_ad, pkz, pkz_ad, peln, peln_ad, q_con, ak, bk, dpx, dpx_ad, ks&
1679 & , gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain&
1680 & , init_step, i_pack, end_step, gz, gz_ad, pkc, pkc_ad, ptc, ptc_ad, &
1681 & crx, crx_ad, xfx, xfx_ad, cry, cry_ad, yfx, yfx_ad, divgd, divgd_ad&
1682 & , delpc, delpc_ad, ut, ut_ad, vt, vt_ad, zh, zh_ad, pk3, pk3_ad, du&
1683 & , du_ad, dv, dv_ad, time_total)
1684  IMPLICIT NONE
1685 ! end init_step
1686 ! Start of the big dynamic time stepping
1687 !allocate( gz(isd:ied, jsd:jed ,npz+1) )
1688 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, gz, huge_r)
1689 !allocate( pkc(isd:ied, jsd:jed ,npz+1) )
1690 !allocate( ptc(isd:ied, jsd:jed ,npz ) )
1691 !allocate( crx(is :ie+1, jsd:jed, npz) )
1692 !allocate( xfx(is :ie+1, jsd:jed, npz) )
1693 !allocate( cry(isd:ied, js :je+1, npz) )
1694 !allocate( yfx(isd:ied, js :je+1, npz) )
1695 !allocate( divgd(isd:ied+1,jsd:jed+1,npz) )
1696 !allocate( delpc(isd:ied, jsd:jed ,npz ) )
1697 ! call init_ijk_mem(isd,ied, jsd,jed, npz, delpc, 0.)
1698 !allocate( ut(isd:ied, jsd:jed, npz) )
1699 ! call init_ijk_mem(isd,ied, jsd,jed, npz, ut, 0.)
1700 !allocate( vt(isd:ied, jsd:jed, npz) )
1701 ! call init_ijk_mem(isd,ied, jsd,jed, npz, vt, 0.)
1702 !allocate( zh(isd:ied, jsd:jed, npz+1) )
1703 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, zh, huge_r )
1704 !allocate ( pk3(isd:ied,jsd:jed,npz+1) )
1705 !call init_ijk_mem(isd,ied, jsd,jed, npz+1, pk3, huge_r )
1706 !if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier
1707 !versions of the code
1708 !deallocate( gz )
1709 !deallocate( ptc )
1710 !deallocate( crx )
1711 !deallocate( xfx )
1712 !deallocate( cry )
1713 !deallocate( yfx )
1714 !deallocate( divgd )
1715 !deallocate( pkc )
1716 !deallocate( delpc )
1717 !if( allocated(ut)) deallocate( ut )
1718 !if( allocated(vt)) deallocate( vt )
1719 !if ( allocated (du) ) deallocate( du )
1720 !if ( allocated (dv) ) deallocate( dv )
1721 !if ( .not. hydrostatic ) then
1722 ! deallocate( zh )
1723 ! if( allocated(pk3) ) deallocate ( pk3 )
1724 !endif
1725 !if( allocated(pem) ) deallocate ( pem )
1726  INTEGER, INTENT(IN) :: npx
1727  INTEGER, INTENT(IN) :: npy
1728  INTEGER, INTENT(IN) :: npz
1729  INTEGER, INTENT(IN) :: ng, nq, sphum
1730  INTEGER, INTENT(IN) :: n_split
1731  REAL, INTENT(IN) :: bdt
1732  REAL, INTENT(IN) :: zvir, cp, akap, grav
1733  REAL, INTENT(IN) :: ptop
1734  LOGICAL, INTENT(IN) :: hydrostatic
1735  LOGICAL, INTENT(IN) :: init_step, end_step
1736  REAL, INTENT(IN) :: pfull(npz)
1737  REAL, DIMENSION(npz+1), INTENT(IN) :: ak, bk
1738  INTEGER, INTENT(IN) :: ks
1739  TYPE(group_halo_update_type), INTENT(INOUT) :: i_pack(*)
1740  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1741  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
1742 & :: u
1743  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
1744 & :: u_ad
1745  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
1746 & :: v
1747  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
1748 & :: v_ad
1749  REAL, INTENT(INOUT) :: w(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1750  REAL, INTENT(INOUT) :: w_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1751  REAL, INTENT(INOUT) :: delz(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1752  REAL, INTENT(INOUT) :: delz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1753  REAL, INTENT(INOUT) :: cappa(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1754  REAL, INTENT(INOUT) :: pt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1755  REAL, INTENT(INOUT) :: pt_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1756  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1757  REAL, INTENT(INOUT) :: delp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1758  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1759  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1760  REAL, INTENT(IN), OPTIONAL :: time_total
1761  REAL, INTENT(INOUT) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed)
1762  REAL, INTENT(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
1763  REAL, INTENT(INOUT) :: pe_ad(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1&
1764 & )
1765  REAL, INTENT(INOUT) :: peln(bd%is:bd%ie, npz+1, bd%js:bd%je)
1766  REAL, INTENT(INOUT) :: peln_ad(bd%is:bd%ie, npz+1, bd%js:bd%je)
1767  REAL, INTENT(INOUT) :: pk(bd%is:bd%ie, bd%js:bd%je, npz+1)
1768  REAL, INTENT(INOUT) :: pk_ad(bd%is:bd%ie, bd%js:bd%je, npz+1)
1769  REAL(kind=8), INTENT(INOUT) :: dpx(bd%is:bd%ie, bd%js:bd%je)
1770  REAL(kind=8), INTENT(INOUT) :: dpx_ad(bd%is:bd%ie, bd%js:bd%je)
1771  REAL, PARAMETER :: near0=1.e-8
1772  REAL, PARAMETER :: huge_r=1.e8
1773  REAL :: ws(bd%is:bd%ie, bd%js:bd%je)
1774  REAL :: ws_ad(bd%is:bd%ie, bd%js:bd%je)
1775  REAL, INTENT(INOUT) :: omga(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1776  REAL, INTENT(INOUT) :: omga_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1777  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1778  REAL, INTENT(INOUT) :: uc_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1779  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1780  REAL, INTENT(INOUT) :: vc_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1781  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
1782 & ua, va
1783  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
1784 & ua_ad, va_ad
1785  REAL, INTENT(INOUT) :: q_con(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1786  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
1787  REAL, INTENT(INOUT) :: mfx_ad(bd%is:bd%ie+1, bd%js:bd%je, npz)
1788  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
1789  REAL, INTENT(INOUT) :: mfy_ad(bd%is:bd%ie, bd%js:bd%je+1, npz)
1790  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1791  REAL, INTENT(INOUT) :: cx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1792  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1793  REAL, INTENT(INOUT) :: cy_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1794  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: pkz
1795  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: &
1796 & pkz_ad
1797  TYPE(fv_grid_type), INTENT(INOUT), TARGET :: gridstruct
1798  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
1799  TYPE(fv_flags_pert_type), INTENT(IN), TARGET :: flagstructp
1800  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
1801  TYPE(fv_diag_type), INTENT(IN) :: idiag
1802  TYPE(domain2d), INTENT(INOUT) :: domain
1803  REAL :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), heat_source(bd&
1804 & %isd:bd%ied, bd%jsd:bd%jed, npz)
1805  REAL :: pem_ad(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), &
1806 & heat_source_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1807  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3, z_rat
1808  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3_ad, z_rat_ad
1809  REAL :: dp_ref(npz)
1810  REAL :: zs(bd%isd:bd%ied, bd%jsd:bd%jed)
1811  REAL :: p1d(bd%is:bd%ie)
1812  REAL :: om2d(bd%is:bd%ie, npz)
1813  REAL :: om2d_ad(bd%is:bd%ie, npz)
1814  REAL :: wbuffer(npy+2, npz)
1815  REAL :: ebuffer(npy+2, npz)
1816  REAL :: ebuffer_ad(npy+2, npz)
1817  REAL :: nbuffer(npx+2, npz)
1818  REAL :: nbuffer_ad(npx+2, npz)
1819  REAL :: sbuffer(npx+2, npz)
1820  REAL :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
1821  REAL :: divg2_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
1822  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
1823  REAL :: wk_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
1824  REAL :: fz(bd%is:bd%ie+1, bd%js:bd%je+1)
1825  REAL :: heat_s(bd%is:bd%ie, bd%js:bd%je)
1826  REAL :: heat_s_ad(bd%is:bd%ie, bd%js:bd%je)
1827  REAL :: damp_vt(npz+1)
1828  INTEGER :: nord_v(npz+1)
1829  INTEGER :: hord_m, hord_v, hord_t, hord_p
1830  INTEGER :: nord_k, nord_w, nord_t
1831  INTEGER :: ms
1832  INTEGER :: hord_m_pert, hord_v_pert, hord_t_pert, hord_p_pert
1833  INTEGER :: nord_k_pert, nord_w_pert, nord_t_pert, nord_v_pert(npz+1)
1834  REAL :: d2_divg_pert, damp_vt_pert(npz+1), damp_w_pert, damp_t_pert
1835  INTEGER :: i, j, k, it, iq, n_con, nf_ke
1836  INTEGER :: iep1, jep1
1837  REAL :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air
1838  REAL :: dt, dt2, rdt
1839  REAL :: d2_divg
1840  REAL :: k1k, rdg, dtmp, delt
1841  REAL :: dtmp_ad
1842  LOGICAL :: last_step, remap_step
1843  LOGICAL :: used
1844  REAL :: split_timestep_bc
1845  INTEGER :: is, ie, js, je
1846  INTEGER :: isd, ied, jsd, jed
1847  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1848  REAL, INTENT(INOUT) :: gz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1849  REAL, INTENT(INOUT) :: pkc(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1850  REAL, INTENT(INOUT) :: pkc_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1851  REAL, INTENT(INOUT) :: ptc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1852  REAL, INTENT(INOUT) :: ptc_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1853  REAL, INTENT(INOUT) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1854  REAL, INTENT(INOUT) :: crx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1855  REAL, INTENT(INOUT) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1856  REAL, INTENT(INOUT) :: xfx_ad(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1857  REAL, INTENT(INOUT) :: cry(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1858  REAL, INTENT(INOUT) :: cry_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1859  REAL, INTENT(INOUT) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1860  REAL, INTENT(INOUT) :: yfx_ad(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1861  REAL, INTENT(INOUT) :: divgd(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, npz)
1862  REAL, INTENT(INOUT) :: divgd_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, &
1863 & npz)
1864  REAL, INTENT(INOUT) :: delpc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1865  REAL, INTENT(INOUT) :: delpc_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1866  REAL, INTENT(INOUT) :: ut(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1867  REAL, INTENT(INOUT) :: ut_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1868  REAL, INTENT(INOUT) :: vt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1869  REAL, INTENT(INOUT) :: vt_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1870  REAL, INTENT(INOUT) :: zh(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1871  REAL, INTENT(INOUT) :: zh_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1872  REAL, INTENT(INOUT) :: pk3(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1873  REAL, INTENT(INOUT) :: pk3_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1874  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1875  REAL, INTENT(INOUT) :: du_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1876  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1877  REAL, INTENT(INOUT) :: dv_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1878  INTRINSIC log
1879  INTRINSIC real
1880  INTRINSIC max
1881  INTRINSIC min
1882  INTRINSIC exp
1883  INTRINSIC abs
1884  INTRINSIC sign
1885  INTEGER :: max1
1886  INTEGER :: max2
1887  REAL :: min1
1888  REAL :: min1_ad
1889  REAL :: min2
1890  REAL :: min2_ad
1891  REAL :: abs0
1892  REAL :: arg1
1893  REAL :: arg2
1894  LOGICAL :: arg10
1895  REAL*8 :: arg11
1896  REAL :: temp_ad
1897  REAL :: temp_ad0
1898  REAL :: temp_ad1
1899  REAL :: temp
1900  REAL :: temp0
1901  REAL :: temp1
1902  REAL :: temp_ad2
1903  REAL :: temp_ad3
1904  REAL :: temp2
1905  REAL :: temp3
1906  REAL :: temp_ad4
1907  REAL :: temp4
1908  REAL :: y1_ad
1909  REAL :: temp_ad5
1910  REAL :: temp5
1911  REAL :: temp6
1912  REAL :: temp7
1913  REAL :: temp8
1914  REAL :: temp_ad6
1915  REAL :: y2_ad
1916  REAL :: temp_ad7
1917  INTEGER :: branch
1918  REAL :: x1
1919  REAL :: y2
1920  REAL :: y1
1921 
1922  pem = 0.0
1923  heat_source = 0.0
1924  ws3 = 0.0
1925  z_rat = 0.0
1926  dp_ref = 0.0
1927  zs = 0.0
1928  p1d = 0.0
1929  om2d = 0.0
1930  wbuffer = 0.0
1931  ebuffer = 0.0
1932  nbuffer = 0.0
1933  sbuffer = 0.0
1934  divg2 = 0.0
1935  wk = 0.0
1936  fz = 0.0
1937  heat_s = 0.0
1938  damp_vt = 0.0
1939  d2_divg_pert = 0.0
1940  damp_vt_pert = 0.0
1941  damp_w_pert = 0.0
1942  damp_t_pert = 0.0
1943  beta = 0.0
1944  beta_d = 0.0
1945  d_con_k = 0.0
1946  damp_w = 0.0
1947  damp_t = 0.0
1948  kgb = 0.0
1949  cv_air = 0.0
1950  dt = 0.0
1951  dt2 = 0.0
1952  rdt = 0.0
1953  d2_divg = 0.0
1954  k1k = 0.0
1955  rdg = 0.0
1956  dtmp = 0.0
1957  delt = 0.0
1958  split_timestep_bc = 0.0
1959  min1 = 0.0
1960  min2 = 0.0
1961  abs0 = 0.0
1962  arg1 = 0.0
1963  arg2 = 0.0
1964  x1 = 0.0
1965  y2 = 0.0
1966  y1 = 0.0
1967  nord_v = 0
1968  hord_m = 0
1969  hord_v = 0
1970  hord_t = 0
1971  hord_p = 0
1972  nord_k = 0
1973  nord_w = 0
1974  nord_t = 0
1975  ms = 0
1976  hord_m_pert = 0
1977  hord_v_pert = 0
1978  hord_t_pert = 0
1979  hord_p_pert = 0
1980  nord_k_pert = 0
1981  nord_w_pert = 0
1982  nord_t_pert = 0
1983  nord_v_pert = 0
1984  i = 0
1985  j = 0
1986  k = 0
1987  it = 0
1988  iq = 0
1989  n_con = 0
1990  nf_ke = 0
1991  iep1 = 0
1992  jep1 = 0
1993  is = 0
1994  ie = 0
1995  js = 0
1996  je = 0
1997  isd = 0
1998  ied = 0
1999  jsd = 0
2000  jed = 0
2001  branch = 0
2002 
2003  CALL popcontrol(2,branch)
2004  IF (branch .EQ. 0) THEN
2005  CALL popinteger(js)
2006  CALL poprealarray(dt)
2007  CALL popinteger(nord_t_pert)
2008  CALL popinteger(nord_v_pert, npz + 1)
2009  CALL popinteger(hord_m_pert)
2010  CALL poprealarray(beta_d)
2011  CALL poprealarray(dt2)
2012  CALL poprealarray(k1k)
2013  CALL popinteger(ie)
2014  CALL poprealarray(rdg)
2015  CALL poprealarray(damp_vt_pert, npz + 1)
2016  CALL popinteger(is)
2017  CALL poprealarray(rdt)
2018  CALL poprealarray(d2_divg_pert)
2019  CALL popinteger(nord_k_pert)
2020  CALL popinteger(nord_k)
2021  CALL poprealarray(damp_t_pert)
2022  CALL poprealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2023  CALL popinteger(nord_t)
2024  CALL poprealarray(damp_vt, npz + 1)
2025  CALL popinteger(nord_v, npz + 1)
2026  CALL popinteger(nord_w)
2027  CALL popinteger(je)
2028  CALL popinteger(hord_p_pert)
2029  CALL poprealarray(dp_ref, npz)
2030  CALL popinteger(hord_t_pert)
2031  CALL popinteger(hord_v_pert)
2032  CALL popinteger(ms)
2033  CALL poprealarray(d2_divg)
2034  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2035  heat_source_ad = 0.0
2036  ELSE
2037  IF (branch .EQ. 1) THEN
2038  CALL popinteger(js)
2039  CALL poprealarray(dt)
2040  CALL popinteger(nord_t_pert)
2041  CALL popinteger(nord_v_pert, npz + 1)
2042  CALL popinteger(hord_m_pert)
2043  CALL poprealarray(beta_d)
2044  CALL popinteger(n_con)
2045  CALL poprealarray(dt2)
2046  CALL poprealarray(k1k)
2047  CALL popinteger(ie)
2048  CALL poprealarray(rdg)
2049  CALL poprealarray(damp_vt_pert, npz + 1)
2050  CALL popinteger(is)
2051  CALL poprealarray(rdt)
2052  CALL poprealarray(d2_divg_pert)
2053  CALL popinteger(nord_k_pert)
2054  CALL popinteger(nord_k)
2055  CALL poprealarray(damp_t_pert)
2056  CALL poprealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2057  CALL popinteger(nord_t)
2058  CALL poprealarray(damp_vt, npz + 1)
2059  CALL popinteger(nord_v, npz + 1)
2060  CALL poprealarray(min1)
2061  CALL popinteger(nord_w)
2062  CALL poprealarray(heat_source, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd&
2063 & +1)*npz)
2064  CALL popinteger(je)
2065  CALL popinteger(hord_p_pert)
2066  CALL poprealarray(dp_ref, npz)
2067  CALL popinteger(hord_t_pert)
2068  CALL popinteger(hord_v_pert)
2069  CALL popinteger(ms)
2070  CALL poprealarray(d2_divg)
2071  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2072  heat_source_ad = 0.0
2073  DO j=je,js,-1
2074  DO k=n_con,1,-1
2075  CALL popcontrol(1,branch)
2076  IF (branch .EQ. 0) THEN
2077  DO i=ie,is,-1
2078  dtmp = heat_source(i, j, k)/(cp_air*delp(i, j, k))
2079  CALL poprealarray(pt(i, j, k))
2080  temp_ad5 = pt_ad(i, j, k)/pkz(i, j, k)
2081  min1_ad = sign(1.d0, min1*dtmp)*temp_ad5
2082  pkz_ad(i, j, k) = pkz_ad(i, j, k) - sign(min1, dtmp)*&
2083 & temp_ad5/pkz(i, j, k)
2084  CALL popcontrol(1,branch)
2085  IF (branch .EQ. 0) THEN
2086  CALL poprealarray(min1)
2087  y1_ad = min1_ad
2088  ELSE
2089  CALL poprealarray(min1)
2090  y1_ad = 0.0
2091  END IF
2092  CALL popcontrol(1,branch)
2093  IF (branch .EQ. 0) THEN
2094  dtmp_ad = y1_ad
2095  ELSE
2096  dtmp_ad = -y1_ad
2097  END IF
2098  temp4 = cp_air*delp(i, j, k)
2099  heat_source_ad(i, j, k) = heat_source_ad(i, j, k) + &
2100 & dtmp_ad/temp4
2101  delp_ad(i, j, k) = delp_ad(i, j, k) - heat_source(i, j, &
2102 & k)*cp_air*dtmp_ad/temp4**2
2103  END DO
2104  ELSE
2105  DO i=ie,is,-1
2106  CALL poprealarray(pt(i, j, k))
2107  temp3 = cp_air*delp(i, j, k)
2108  temp2 = temp3*pkz(i, j, k)
2109  temp_ad4 = -(heat_source(i, j, k)*pt_ad(i, j, k)/temp2**&
2110 & 2)
2111  heat_source_ad(i, j, k) = heat_source_ad(i, j, k) + &
2112 & pt_ad(i, j, k)/temp2
2113  delp_ad(i, j, k) = delp_ad(i, j, k) + pkz(i, j, k)*&
2114 & cp_air*temp_ad4
2115  pkz_ad(i, j, k) = pkz_ad(i, j, k) + temp3*temp_ad4
2116  END DO
2117  END IF
2118  END DO
2119  END DO
2120  ELSE
2121  CALL popinteger(js)
2122  CALL poprealarray(dt)
2123  CALL popinteger(nord_t_pert)
2124  CALL popinteger(nord_v_pert, npz + 1)
2125  CALL popinteger(hord_m_pert)
2126  CALL poprealarray(beta_d)
2127  CALL popinteger(n_con)
2128  CALL poprealarray(dt2)
2129  CALL poprealarray(k1k)
2130  CALL popinteger(ie)
2131  CALL poprealarray(rdg)
2132  CALL poprealarray(cv_air)
2133  CALL poprealarray(damp_vt_pert, npz + 1)
2134  CALL popinteger(is)
2135  CALL poprealarray(rdt)
2136  CALL poprealarray(d2_divg_pert)
2137  CALL popinteger(nord_k_pert)
2138  CALL popinteger(nord_k)
2139  CALL poprealarray(damp_t_pert)
2140  CALL poprealarray(ws3, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2141  CALL popinteger(nord_t)
2142  CALL poprealarray(damp_vt, npz + 1)
2143  CALL popinteger(nord_v, npz + 1)
2144  CALL popinteger(nord_w)
2145  CALL poprealarray(min2)
2146  CALL poprealarray(heat_source, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd&
2147 & +1)*npz)
2148  CALL popinteger(je)
2149  CALL popinteger(hord_p_pert)
2150  CALL poprealarray(dp_ref, npz)
2151  CALL popinteger(hord_t_pert)
2152  CALL popinteger(hord_v_pert)
2153  CALL popinteger(ms)
2154  CALL poprealarray(d2_divg)
2155  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
2156  heat_source_ad = 0.0
2157  DO k=n_con,1,-1
2158  DO j=je,js,-1
2159  DO i=ie,is,-1
2160  dtmp = heat_source(i, j, k)/(cv_air*delp(i, j, k))
2161  CALL poprealarray(pt(i, j, k))
2162  temp_ad7 = pt_ad(i, j, k)/pkz(i, j, k)
2163  min2_ad = sign(1.d0, min2*dtmp)*temp_ad7
2164  pkz_ad(i, j, k) = pkz_ad(i, j, k) - sign(min2, dtmp)*&
2165 & temp_ad7/pkz(i, j, k)
2166  CALL popcontrol(1,branch)
2167  IF (branch .EQ. 0) THEN
2168  CALL poprealarray(min2)
2169  y2_ad = min2_ad
2170  ELSE
2171  CALL poprealarray(min2)
2172  y2_ad = 0.0
2173  END IF
2174  CALL popcontrol(1,branch)
2175  IF (branch .EQ. 0) THEN
2176  dtmp_ad = y2_ad
2177  ELSE
2178  dtmp_ad = -y2_ad
2179  END IF
2180  temp7 = delz(i, j, k)
2181  temp6 = delp(i, j, k)*pt(i, j, k)
2182  temp5 = temp6/temp7
2183  temp_ad6 = k1k*exp(k1k*log(rdg*temp5))*pkz_ad(i, j, k)/(&
2184 & temp5*temp7)
2185  temp8 = cv_air*delp(i, j, k)
2186  heat_source_ad(i, j, k) = heat_source_ad(i, j, k) + &
2187 & dtmp_ad/temp8
2188  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*temp_ad6&
2189 & - heat_source(i, j, k)*cv_air*dtmp_ad/temp8**2
2190  CALL poprealarray(pkz(i, j, k))
2191  pt_ad(i, j, k) = pt_ad(i, j, k) + delp(i, j, k)*temp_ad6
2192  delz_ad(i, j, k) = delz_ad(i, j, k) - temp5*temp_ad6
2193  pkz_ad(i, j, k) = 0.0
2194  END DO
2195  END DO
2196  END DO
2197  END IF
2198  arg11 = cnst_0p20*gridstruct%da_min
2199  CALL del2_cubed_bwd(heat_source, heat_source_ad, arg11, gridstruct&
2200 & , domain, npx, npy, npz, nf_ke, bd)
2201  END IF
2202  CALL popcontrol(1,branch)
2203  CALL popcontrol(1,branch)
2204  IF (branch .EQ. 0) THEN
2205  CALL poprealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*nq)
2206  CALL start_group_halo_update_adm(i_pack(10), q, q_ad, domain)
2207  END IF
2208  jep1 = je + 1
2209  jsd = bd%jsd
2210  ied = bd%ied
2211  iep1 = ie + 1
2212  isd = bd%isd
2213  jed = bd%jed
2214  om2d_ad = 0.0
2215  pem_ad = 0.0
2216  ws3_ad = 0.0
2217  z_rat_ad = 0.0
2218  heat_s_ad = 0.0
2219  wk_ad = 0.0
2220  divg2_ad = 0.0
2221  DO it=n_split,1,-1
2222  CALL popcontrol(1,branch)
2223  IF (branch .NE. 0) THEN
2224  CALL poprealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
2225  CALL nested_grid_bc_apply_intt_adm(v, v_ad, 1, 0, npx, npy, npz&
2226 & , bd, arg1, arg2, neststruct%v_bc, &
2227 & neststruct%nestbctype)
2228  CALL poprealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
2229  CALL nested_grid_bc_apply_intt_adm(u, u_ad, 0, 1, npx, npy, npz&
2230 & , bd, arg1, arg2, neststruct%u_bc, &
2231 & neststruct%nestbctype)
2232  CALL popcontrol(1,branch)
2233  IF (branch .EQ. 0) THEN
2234  CALL poprealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
2235  CALL nested_grid_bc_apply_intt_adm(w, w_ad, 0, 0, npx, npy, &
2236 & npz, bd, arg1, arg2, neststruct%&
2237 & w_bc, neststruct%nestbctype)
2238  END IF
2239  END IF
2240  CALL popcontrol(2,branch)
2241  IF (branch .EQ. 0) THEN
2242  DO j=je,js,-1
2243  DO i=ie,is,-1
2244  CALL poprealarray(ws(i, j))
2245  temp_ad3 = ws_ad(i, j)/delp(i, j, npz)
2246  delz_ad(i, j, npz) = delz_ad(i, j, npz) + omga(i, j, npz)*&
2247 & temp_ad3
2248  omga_ad(i, j, npz) = omga_ad(i, j, npz) + delz(i, j, npz)*&
2249 & temp_ad3
2250  delp_ad(i, j, npz) = delp_ad(i, j, npz) - delz(i, j, npz)*&
2251 & omga(i, j, npz)*temp_ad3/delp(i, j, npz)
2252  ws_ad(i, j) = 0.0
2253  END DO
2254  END DO
2255  ELSE IF (branch .NE. 1) THEN
2256  GOTO 100
2257  END IF
2258  CALL popcontrol(1,branch)
2259  IF (branch .EQ. 0) THEN
2260  CALL adv_pe_bwd(ua, ua_ad, va, va_ad, pem, pem_ad, omga, omga_ad&
2261 & , gridstruct, bd, npx, npy, npz, ng)
2262  DO k=npz,1,-1
2263  DO j=je,js,-1
2264  DO i=ie,is,-1
2265  CALL poprealarray(omga(i, j, k))
2266  pe_ad(i, k+1, j) = pe_ad(i, k+1, j) + rdt*omga_ad(i, j, k)
2267  pem_ad(i, k+1, j) = pem_ad(i, k+1, j) - rdt*omga_ad(i, j, &
2268 & k)
2269  omga_ad(i, j, k) = 0.0
2270  END DO
2271  END DO
2272  END DO
2273  ELSE
2274  DO j=je,js,-1
2275  DO k=npz,2,-1
2276  DO i=ie,is,-1
2277  CALL poprealarray(omga(i, j, k))
2278  om2d_ad(i, k) = om2d_ad(i, k) + omga_ad(i, j, k)
2279  omga_ad(i, j, k) = 0.0
2280  END DO
2281  END DO
2282  DO k=npz,2,-1
2283  DO i=ie,is,-1
2284  om2d_ad(i, k-1) = om2d_ad(i, k-1) + om2d_ad(i, k)
2285  omga_ad(i, j, k) = omga_ad(i, j, k) + om2d_ad(i, k)
2286  om2d_ad(i, k) = 0.0
2287  END DO
2288  END DO
2289  DO k=npz,1,-1
2290  DO i=ie,is,-1
2291  omga_ad(i, j, k) = omga_ad(i, j, k) + om2d_ad(i, k)
2292  om2d_ad(i, k) = 0.0
2293  END DO
2294  END DO
2295  END DO
2296  END IF
2297  100 CALL popcontrol(1,branch)
2298  IF (branch .EQ. 0) THEN
2299  CALL poprealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
2300  CALL poprealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
2301  CALL start_group_halo_update_adm(i_pack(8), u, u_ad, v, v_ad, &
2302 & domain, gridtype=dgrid_ne)
2303  END IF
2304  CALL popcontrol(1,branch)
2305  IF (branch .EQ. 0) THEN
2306  nbuffer_ad = 0.0
2307  ebuffer_ad = 0.0
2308  DO k=npz,1,-1
2309  DO j=je,js,-1
2310  ebuffer_ad(j-js+1, k) = ebuffer_ad(j-js+1, k) + v_ad(ie+1, j&
2311 & , k)
2312  v_ad(ie+1, j, k) = 0.0
2313  END DO
2314  DO i=ie,is,-1
2315  nbuffer_ad(i-is+1, k) = nbuffer_ad(i-is+1, k) + u_ad(i, je+1&
2316 & , k)
2317  u_ad(i, je+1, k) = 0.0
2318  END DO
2319  END DO
2320  CALL poprealarray(u, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+2)*npz)
2321  CALL poprealarray(v, (bd%ied-bd%isd+2)*(bd%jed-bd%jsd+1)*npz)
2322  CALL mpp_get_boundary_adm(u, u_ad, v, v_ad, domain, ebuffery=&
2323 & ebuffer, ebuffery_ad=ebuffer_ad, nbufferx=&
2324 & nbuffer, nbufferx_ad=nbuffer_ad, gridtype=&
2325 & dgrid_ne)
2326  END IF
2327  CALL popcontrol(2,branch)
2328  IF (branch .EQ. 0) THEN
2329  DO k=npz,1,-1
2330  DO j=je,js,-1
2331  DO i=ie,is,-1
2332  CALL poprealarray(pkz(i, j, k))
2333  temp1 = delz(i, j, k)
2334  temp0 = delp(i, j, k)*pt(i, j, k)
2335  temp = temp0/temp1
2336  temp_ad2 = k1k*exp(k1k*log(rdg*temp))*pkz_ad(i, j, k)/(&
2337 & temp*temp1)
2338  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*temp_ad2
2339  pt_ad(i, j, k) = pt_ad(i, j, k) + delp(i, j, k)*temp_ad2
2340  delz_ad(i, j, k) = delz_ad(i, j, k) - temp*temp_ad2
2341  pkz_ad(i, j, k) = 0.0
2342  END DO
2343  END DO
2344  END DO
2345  END IF
2346  CALL popcontrol(3,branch)
2347  IF (branch .LT. 2) THEN
2348  IF (branch .EQ. 0) THEN
2349  CALL grad1_p_update_bwd(divg2, divg2_ad, u, u_ad, v, v_ad, pkc&
2350 & , pkc_ad, gz, gz_ad, du, du_ad, dv, dv_ad, &
2351 & dt, ng, gridstruct, bd, npx, npy, npz, ptop&
2352 & , beta_d, flagstruct%a2b_ord)
2353  ELSE
2354  CALL one_grad_p_bwd(u, u_ad, v, v_ad, pkc, pkc_ad, gz, gz_ad, &
2355 & divg2, divg2_ad, delp, delp_ad, dt, ng, &
2356 & gridstruct, bd, npx, npy, npz, ptop, hydrostatic&
2357 & , flagstruct%a2b_ord, flagstruct%d_ext)
2358  END IF
2359  ELSE IF (branch .EQ. 2) THEN
2360  CALL split_p_grad_bwd(u, u_ad, v, v_ad, pkc, pkc_ad, gz, gz_ad, &
2361 & du, du_ad, dv, dv_ad, delp, delp_ad, pk3, pk3_ad&
2362 & , beta_d, dt, ng, gridstruct, bd, npx, npy, npz&
2363 & , flagstruct%use_logp)
2364  ELSE IF (branch .EQ. 3) THEN
2365  CALL one_grad_p_bwd(u, u_ad, v, v_ad, pkc, pkc_ad, gz, gz_ad, &
2366 & divg2, divg2_ad, delp, delp_ad, dt, ng, gridstruct&
2367 & , bd, npx, npy, npz, ptop, hydrostatic, flagstruct&
2368 & %a2b_ord, flagstruct%d_ext)
2369  ELSE
2370  CALL nh_p_grad_bwd(u, u_ad, v, v_ad, pkc, pkc_ad, gz, gz_ad, &
2371 & delp, delp_ad, pk3, pk3_ad, dt, ng, gridstruct, bd&
2372 & , npx, npy, npz, flagstruct%use_logp)
2373  END IF
2374  CALL popcontrol(1,branch)
2375  IF (branch .EQ. 0) THEN
2376  DO k=npz+1,1,-1
2377  DO j=je,js,-1
2378  DO i=ie,is,-1
2379  CALL poprealarray(pk(i, j, k))
2380  pkc_ad(i, j, k) = pkc_ad(i, j, k) + pk_ad(i, j, k)
2381  pk_ad(i, j, k) = 0.0
2382  END DO
2383  END DO
2384  END DO
2385  END IF
2386  CALL popcontrol(1,branch)
2387  IF (branch .EQ. 0) THEN
2388  CALL geopk_bwd(ptop, pe, pe_ad, peln, peln_ad, delp, delp_ad, &
2389 & pkc, pkc_ad, gz, gz_ad, phis, pt, pt_ad, q_con, pkz, &
2390 & pkz_ad, npz, akap, .false., gridstruct%nested, .true., &
2391 & npx, npy, flagstruct%a2b_ord, bd)
2392  ELSE
2393  DO k=npz+1,1,-1
2394  DO j=je+2,js-2,-1
2395  DO i=ie+2,is-2,-1
2396  CALL poprealarray(gz(i, j, k))
2397  zh_ad(i, j, k) = zh_ad(i, j, k) + grav*gz_ad(i, j, k)
2398  gz_ad(i, j, k) = 0.0
2399  END DO
2400  END DO
2401  END DO
2402  CALL popcontrol(1,branch)
2403  IF (branch .EQ. 0) THEN
2404  CALL nest_halo_nh_bwd(ptop, grav, akap, cp, delp, delp_ad, &
2405 & delz, delz_ad, pt, pt_ad, phis, pkc, pkc_ad, &
2406 & gz, gz_ad, pk3, pk3_ad, npx, npy, npz, &
2407 & gridstruct%nested, .true., .true., .true., bd)
2408  CALL poprealarray(delz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
2409 & npz)
2410  CALL nested_grid_bc_apply_intt_adm(delz, delz_ad, 0, 0, npx, &
2411 & npy, npz, bd, arg1, arg2, &
2412 & neststruct%delz_bc, neststruct%&
2413 & nestbctype)
2414  END IF
2415  CALL popcontrol(1,branch)
2416  IF (branch .EQ. 0) THEN
2417  CALL pln_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, &
2418 & ptop, pk3, pk3_ad, delp, delp_ad)
2419  ELSE
2420  CALL pk3_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, &
2421 & ptop, akap, pk3, pk3_ad, delp, delp_ad)
2422  END IF
2423  CALL popcontrol(1,branch)
2424  IF (branch .EQ. 0) CALL pe_halo_bwd(is, ie, js, je, isd, ied, &
2425 & jsd, jed, npz, ptop, pe, pe_ad, &
2426 & delp, delp_ad)
2427  CALL popcontrol(1,branch)
2428  IF (branch .EQ. 0) THEN
2429  CALL poprealarray(pkc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
2430 & npz+1))
2431  CALL start_group_halo_update_adm(i_pack(5), pkc, pkc_ad, &
2432 & domain, whalo=2, ehalo=2, shalo=2, &
2433 & nhalo=2)
2434  CALL poprealarray(zh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
2435 & npz+1))
2436  CALL start_group_halo_update_adm(i_pack(4), zh, zh_ad, domain)
2437  ELSE
2438  CALL poprealarray(pkc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
2439 & npz+1))
2440  CALL start_group_halo_update_adm(i_pack(4), pkc, pkc_ad, &
2441 & domain, complete=.true.)
2442  CALL poprealarray(zh, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(&
2443 & npz+1))
2444  CALL start_group_halo_update_adm(i_pack(4), zh, zh_ad, domain&
2445 & , complete=.true.)
2446  END IF
2447  CALL riem_solver3_bwd(flagstruct%m_split, dt, is, ie, js, je, &
2448 & npz, ng, isd, ied, jsd, jed, akap, cappa, cp, &
2449 & ptop, zs, q_con, w, w_ad, delz, delz_ad, pt, &
2450 & pt_ad, delp, delp_ad, zh, zh_ad, pe, pe_ad, pkc&
2451 & , pkc_ad, pk3, pk3_ad, pk, pk_ad, peln, peln_ad&
2452 & , ws, ws_ad, flagstruct%scale_z, flagstruct%&
2453 & p_fac, flagstruct%a_imp, flagstruct%use_logp, &
2454 & remap_step, arg10)
2455  CALL update_dz_d_bwd(nord_v, damp_vt, flagstruct%hord_tm, is, ie&
2456 & , js, je, npz, ng, npx, npy, gridstruct%area, &
2457 & gridstruct%rarea, dp_ref, zs, zh, zh_ad, crx, &
2458 & crx_ad, cry, cry_ad, xfx, xfx_ad, yfx, yfx_ad, &
2459 & delz, ws, ws_ad, rdt, gridstruct, bd, flagstructp&
2460 & %hord_tm_pert)
2461  END IF
2462  CALL popcontrol(1,branch)
2463  IF (branch .EQ. 0) THEN
2464  CALL nested_grid_bc_apply_intt_adm(pt, pt_ad, 0, 0, npx, npy, &
2465 & npz, bd, arg1, arg2, neststruct%&
2466 & pt_bc, neststruct%nestbctype)
2467  CALL nested_grid_bc_apply_intt_adm(delp, delp_ad, 0, 0, npx, npy&
2468 & , npz, bd, arg1, arg2, neststruct%&
2469 & delp_bc, neststruct%nestbctype)
2470  END IF
2471  CALL popcontrol(1,branch)
2472  IF (branch .EQ. 0) THEN
2473  DO j=jep1,js,-1
2474  DO i=iep1,is,-1
2475  CALL poprealarray(divg2(i, j))
2476  temp_ad1 = d2_divg*divg2_ad(i, j)/wk(i, j)
2477  wk_ad(i, j) = wk_ad(i, j) - divg2(i, j)*temp_ad1/wk(i, j)
2478  divg2_ad(i, j) = temp_ad1
2479  END DO
2480  DO k=npz,2,-1
2481  DO i=iep1,is,-1
2482  ptc_ad(i, j, k) = ptc_ad(i, j, k) + wk_ad(i, j) + vt(i, j&
2483 & , k)*divg2_ad(i, j)
2484  vt_ad(i, j, k) = vt_ad(i, j, k) + ptc(i, j, k)*divg2_ad(i&
2485 & , j)
2486  CALL poprealarray(wk(i, j))
2487  END DO
2488  END DO
2489  DO i=iep1,is,-1
2490  wk_ad(i, j) = wk_ad(i, j) + vt(i, j, 1)*divg2_ad(i, j)
2491  vt_ad(i, j, 1) = vt_ad(i, j, 1) + wk(i, j)*divg2_ad(i, j)
2492  divg2_ad(i, j) = 0.0
2493  CALL poprealarray(wk(i, j))
2494  ptc_ad(i, j, 1) = ptc_ad(i, j, 1) + wk_ad(i, j)
2495  wk_ad(i, j) = 0.0
2496  END DO
2497  END DO
2498  CALL poprealarray(d2_divg)
2499  ELSE
2500  divg2_ad = 0.0
2501  END IF
2502  CALL poprealarray(pt, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
2503  CALL start_group_halo_update_adm(i_pack(1), pt, pt_ad, domain, &
2504 & complete=.true.)
2505  CALL poprealarray(delp, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
2506  CALL start_group_halo_update_adm(i_pack(1), delp, delp_ad, domain&
2507 & , complete=.true.)
2508  CALL popcontrol(1,branch)
2509  IF (branch .EQ. 0) CALL mix_dp_bwd(hydrostatic, w, w_ad, delp, &
2510 & delp_ad, pt, pt_ad, npz, ak, bk, &
2511 & .false., flagstruct%fv_debug, bd)
2512  DO k=npz,1,-1
2513  CALL popcontrol(1,branch)
2514  IF (branch .NE. 0) THEN
2515  DO j=je,js,-1
2516  DO i=ie,is,-1
2517  heat_s_ad(i, j) = heat_s_ad(i, j) + heat_source_ad(i, j, k&
2518 & )
2519  END DO
2520  END DO
2521  END IF
2522  CALL popcontrol(1,branch)
2523  IF (branch .EQ. 0) THEN
2524  DO j=jep1,js,-1
2525  DO i=iep1,is,-1
2526  CALL poprealarray(ptc(i, j, k))
2527  wk_ad(i, j) = wk_ad(i, j) + ptc_ad(i, j, k)
2528  ptc_ad(i, j, k) = 0.0
2529  END DO
2530  END DO
2531  END IF
2532  CALL popcontrol(1,branch)
2533  IF (branch .EQ. 0) THEN
2534  DO j=je,js,-1
2535  DO i=ie,is,-1
2536  CALL poprealarray(omga(i, j, k))
2537  temp_ad = gridstruct%rarea(i, j)*rdt*omga_ad(i, j, k)
2538  temp_ad0 = omga(i, j, k)*temp_ad
2539  xfx_ad(i, j, k) = xfx_ad(i, j, k) + temp_ad0
2540  xfx_ad(i+1, j, k) = xfx_ad(i+1, j, k) - temp_ad0
2541  yfx_ad(i, j, k) = yfx_ad(i, j, k) + temp_ad0
2542  yfx_ad(i, j+1, k) = yfx_ad(i, j+1, k) - temp_ad0
2543  omga_ad(i, j, k) = (xfx(i, j, k)-xfx(i+1, j, k)+yfx(i, j, &
2544 & k)-yfx(i, j+1, k))*temp_ad
2545  END DO
2546  END DO
2547  END IF
2548  CALL d_sw_bwd(vt(isd:ied, jsd:jed, k), vt_ad(isd:ied, jsd:jed, k&
2549 & ), delp(isd:ied, jsd:jed, k), delp_ad(isd:ied, jsd:jed, &
2550 & k), ptc(isd:ied, jsd:jed, k), ptc_ad(isd:ied, jsd:jed, k&
2551 & ), pt(isd:ied, jsd:jed, k), pt_ad(isd:ied, jsd:jed, k), &
2552 & u(isd:ied, jsd:jed+1, k), u_ad(isd:ied, jsd:jed+1, k), v&
2553 & (isd:ied+1, jsd:jed, k), v_ad(isd:ied+1, jsd:jed, k), w(&
2554 & isd:ied, jsd:jed, k), w_ad(isd:ied, jsd:jed, k), uc(isd:&
2555 & ied+1, jsd:jed, k), uc_ad(isd:ied+1, jsd:jed, k), vc(isd&
2556 & :ied, jsd:jed+1, k), vc_ad(isd:ied, jsd:jed+1, k), ua(&
2557 & isd:ied, jsd:jed, k), ua_ad(isd:ied, jsd:jed, k), va(isd&
2558 & :ied, jsd:jed, k), va_ad(isd:ied, jsd:jed, k), divgd(isd&
2559 & :ied+1, jsd:jed+1, k), divgd_ad(isd:ied+1, jsd:jed+1, k)&
2560 & , mfx(is:ie+1, js:je, k), mfx_ad(is:ie+1, js:je, k), mfy&
2561 & (is:ie, js:je+1, k), mfy_ad(is:ie, js:je+1, k), cx(is:ie&
2562 & +1, jsd:jed, k), cx_ad(is:ie+1, jsd:jed, k), cy(isd:ied&
2563 & , js:je+1, k), cy_ad(isd:ied, js:je+1, k), crx(is:ie+1, &
2564 & jsd:jed, k), crx_ad(is:ie+1, jsd:jed, k), cry(isd:ied, &
2565 & js:je+1, k), cry_ad(isd:ied, js:je+1, k), xfx(is:ie+1, &
2566 & jsd:jed, k), xfx_ad(is:ie+1, jsd:jed, k), yfx(isd:ied, &
2567 & js:je+1, k), yfx_ad(isd:ied, js:je+1, k), q_con(isd:ied&
2568 & , jsd:jed, 1), z_rat(isd:ied, jsd:jed), z_rat_ad(isd:ied&
2569 & , jsd:jed), kgb, heat_s, heat_s_ad, dpx, dpx_ad, zvir, &
2570 & sphum, nq, q, q_ad, k, npz, flagstruct%inline_q, dt, &
2571 & flagstruct%hord_tr, hord_m, hord_v, hord_t, hord_p, &
2572 & nord_k, nord_v(k), nord_w, nord_t, flagstruct%dddmp, &
2573 & d2_divg, flagstruct%d4_bg, damp_vt(k), damp_w, damp_t, &
2574 & d_con_k, hydrostatic, gridstruct, flagstruct, bd, &
2575 & flagstructp%hord_tr_pert, hord_m_pert, hord_v_pert, &
2576 & hord_t_pert, hord_p_pert, flagstructp%split_damp, &
2577 & nord_k_pert, nord_v_pert(k), nord_w_pert, nord_t_pert, &
2578 & flagstructp%dddmp_pert, d2_divg_pert, flagstructp%&
2579 & d4_bg_pert, damp_vt_pert(k), damp_w_pert, damp_t_pert)
2580  CALL popcontrol(1,branch)
2581  IF (branch .EQ. 0) THEN
2582  DO j=jed,jsd,-1
2583  DO i=ied,isd,-1
2584  zh_ad(i, j, k) = zh_ad(i, j, k) + z_rat_ad(i, j)/radius
2585  zh_ad(i, j, k+1) = zh_ad(i, j, k+1) + z_rat_ad(i, j)/&
2586 & radius
2587  z_rat_ad(i, j) = 0.0
2588  END DO
2589  END DO
2590  END IF
2591  CALL popcontrol(1,branch)
2592  IF (branch .EQ. 0) CALL a2b_ord2_bwd(delp(isd:ied, jsd:jed, k), &
2593 & delp_ad(isd:ied, jsd:jed, k), wk&
2594 & , wk_ad, gridstruct, npx, npy, is&
2595 & , ie, js, je, ng, .false.)
2596  CALL popcontrol(1,branch)
2597  IF (branch .EQ. 0) THEN
2598  DO j=je,js,-1
2599  DO i=ie,is,-1
2600  CALL poprealarray(omga(i, j, k))
2601  delp_ad(i, j, k) = delp_ad(i, j, k) + omga_ad(i, j, k)
2602  omga_ad(i, j, k) = 0.0
2603  END DO
2604  END DO
2605  END IF
2606  CALL popinteger(nord_v_pert(npz+1))
2607  CALL popinteger(nord_v(npz+1))
2608  CALL poprealarray(damp_vt_pert(npz+1))
2609  CALL poprealarray(damp_vt(npz+1))
2610  CALL popcontrol(2,branch)
2611  IF (branch .EQ. 0) THEN
2612  CALL poprealarray(damp_vt_pert(k))
2613  CALL popinteger(nord_v_pert(k))
2614  ELSE IF (branch .NE. 1) THEN
2615  GOTO 110
2616  END IF
2617  CALL popcontrol(3,branch)
2618  CALL popcontrol(1,branch)
2619  110 CALL poprealarray(damp_t_pert)
2620  CALL popinteger(nord_t_pert)
2621  CALL popcontrol(1,branch)
2622  IF (branch .EQ. 0) THEN
2623  CALL poprealarray(damp_vt_pert(k))
2624  ELSE
2625  CALL poprealarray(damp_vt_pert(k))
2626  END IF
2627  CALL popcontrol(1,branch)
2628  IF (branch .EQ. 0) THEN
2629  CALL poprealarray(d2_divg_pert)
2630  ELSE
2631  CALL poprealarray(d2_divg_pert)
2632  END IF
2633  CALL popcontrol(1,branch)
2634  IF (branch .EQ. 0) THEN
2635  CALL popinteger(nord_v_pert(k))
2636  ELSE
2637  CALL popinteger(nord_v_pert(k))
2638  END IF
2639  CALL popinteger(nord_k_pert)
2640  CALL popinteger(hord_p_pert)
2641  CALL popinteger(hord_v_pert)
2642  CALL popinteger(hord_t_pert)
2643  CALL popinteger(hord_m_pert)
2644  CALL popcontrol(3,branch)
2645  IF (branch .LT. 3) THEN
2646  IF (branch .NE. 0) THEN
2647  IF (branch .NE. 1) THEN
2648  CALL poprealarray(damp_vt(k))
2649  CALL popinteger(nord_v(k))
2650  END IF
2651  END IF
2652  ELSE
2653  IF (branch .LT. 5) THEN
2654  IF (branch .EQ. 3) THEN
2655  GOTO 120
2656  ELSE
2657  CALL poprealarray(damp_vt(k))
2658  CALL popinteger(nord_v(k))
2659  END IF
2660  ELSE IF (branch .NE. 5) THEN
2661  GOTO 120
2662  END IF
2663  CALL popcontrol(1,branch)
2664  END IF
2665  120 CALL popinteger(nord_t)
2666  CALL popinteger(nord_w)
2667  CALL popcontrol(1,branch)
2668  IF (branch .EQ. 0) THEN
2669  CALL poprealarray(damp_vt(k))
2670  ELSE
2671  CALL poprealarray(damp_vt(k))
2672  END IF
2673  CALL popcontrol(1,branch)
2674  IF (branch .EQ. 0) THEN
2675  CALL poprealarray(d2_divg)
2676  ELSE
2677  CALL poprealarray(d2_divg)
2678  END IF
2679  CALL popcontrol(1,branch)
2680  IF (branch .EQ. 0) THEN
2681  CALL popinteger(nord_v(k))
2682  ELSE
2683  CALL popinteger(nord_v(k))
2684  END IF
2685  CALL popinteger(nord_k)
2686  END DO
2687  CALL popcontrol(1,branch)
2688  IF (branch .EQ. 0) THEN
2689  DO iq=nq,1,-1
2690  CALL poprealarray(q(isd:ied, jsd:jed, :, iq), (ied-isd+1)*(&
2691 & jed-jsd+1)*npz)
2692  CALL nested_grid_bc_apply_intt_adm(q(isd:ied, jsd:jed, :, iq)&
2693 & , q_ad(isd:ied, jsd:jed, :, iq), &
2694 & 0, 0, npx, npy, npz, bd, arg1, &
2695 & arg2, neststruct%q_bc(iq), &
2696 & neststruct%nestbctype)
2697  END DO
2698  END IF
2699  CALL popcontrol(1,branch)
2700  IF (branch .EQ. 0) THEN
2701  CALL nested_grid_bc_apply_intt_adm(divgd, divgd_ad, 1, 1, npx, &
2702 & npy, npz, bd, split_timestep_bc, &
2703 & arg1, neststruct%divg_bc, &
2704 & neststruct%nestbctype)
2705  CALL nested_grid_bc_apply_intt_adm(uc, uc_ad, 1, 0, npx, npy, &
2706 & npz, bd, arg1, arg2, neststruct%&
2707 & uc_bc, neststruct%nestbctype)
2708  CALL nested_grid_bc_apply_intt_adm(vc, vc_ad, 0, 1, npx, npy, &
2709 & npz, bd, arg1, arg2, neststruct%&
2710 & vc_bc, neststruct%nestbctype)
2711  END IF
2712  CALL start_group_halo_update_adm(i_pack(9), uc, uc_ad, vc, vc_ad, &
2713 & domain, gridtype=cgrid_ne)
2714  CALL p_grad_c_bwd(dt2, npz, delpc, delpc_ad, pkc, pkc_ad, gz, &
2715 & gz_ad, uc, uc_ad, vc, vc_ad, bd, gridstruct%rdxc, &
2716 & gridstruct%rdyc, hydrostatic)
2717  CALL popcontrol(2,branch)
2718  IF (branch .EQ. 0) THEN
2719  CALL geopk_bwd(ptop, pe, pe_ad, peln, peln_ad, delpc, delpc_ad, &
2720 & pkc, pkc_ad, gz, gz_ad, phis, ptc, ptc_ad, q_con, pkz, &
2721 & pkz_ad, npz, akap, .true., gridstruct%nested, .false., &
2722 & npx, npy, flagstruct%a2b_ord, bd)
2723  ELSE
2724  IF (branch .EQ. 1) THEN
2725  CALL nest_halo_nh_bwd(ptop, grav, akap, cp, delpc, delpc_ad, &
2726 & delz, delz_ad, ptc, ptc_ad, phis, pkc, pkc_ad&
2727 & , gz, gz_ad, pk3, pk3_ad, npx, npy, npz, &
2728 & gridstruct%nested, .false., .false., .false., &
2729 & bd)
2730  CALL poprealarray(delz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
2731 & npz)
2732  CALL nested_grid_bc_apply_intt_adm(delz, delz_ad, 0, 0, npx, &
2733 & npy, npz, bd, arg1, arg2, &
2734 & neststruct%delz_bc, neststruct%&
2735 & nestbctype)
2736  END IF
2737  CALL riem_solver_c_bwd(ms, dt2, is, ie, js, je, npz, ng, akap, &
2738 & cappa, cp, ptop, phis, omga, omga_ad, ptc, &
2739 & ptc_ad, q_con, delpc, delpc_ad, gz, gz_ad, pkc&
2740 & , pkc_ad, ws3, ws3_ad, flagstruct%p_fac, &
2741 & flagstruct%a_imp, flagstruct%scale_z)
2742  CALL update_dz_c_bwd(is, ie, js, je, npz, ng, dt2, dp_ref, zs, &
2743 & gridstruct%area, ut, ut_ad, vt, vt_ad, gz, gz_ad&
2744 & , ws3, ws3_ad, npx, npy, gridstruct%sw_corner, &
2745 & gridstruct%se_corner, gridstruct%ne_corner, &
2746 & gridstruct%nw_corner, bd, gridstruct%grid_type)
2747  CALL popcontrol(1,branch)
2748  IF (branch .EQ. 0) THEN
2749  DO k=npz+1,1,-1
2750  DO j=jed,jsd,-1
2751  DO i=ied,isd,-1
2752  gz_ad(i, j, k) = gz_ad(i, j, k) + zh_ad(i, j, k)
2753  zh_ad(i, j, k) = 0.0
2754  END DO
2755  END DO
2756  END DO
2757  ELSE
2758  DO k=npz+1,1,-1
2759  DO j=jed,jsd,-1
2760  DO i=ied,isd,-1
2761  CALL poprealarray(gz(i, j, k))
2762  zh_ad(i, j, k) = zh_ad(i, j, k) + gz_ad(i, j, k)
2763  gz_ad(i, j, k) = 0.0
2764  END DO
2765  END DO
2766  END DO
2767  END IF
2768  END IF
2769  CALL popcontrol(1,branch)
2770  IF (branch .EQ. 0) THEN
2771  CALL poprealarray(ptc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
2772  CALL nested_grid_bc_apply_intt_adm(ptc, ptc_ad, 0, 0, npx, npy, &
2773 & npz, bd, arg1, arg2, neststruct%&
2774 & pt_bc, neststruct%nestbctype)
2775  CALL poprealarray(delpc, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*&
2776 & npz)
2777  CALL nested_grid_bc_apply_intt_adm(delpc, delpc_ad, 0, 0, npx, &
2778 & npy, npz, bd, arg1, arg2, &
2779 & neststruct%delp_bc, neststruct%&
2780 & nestbctype)
2781  END IF
2782  CALL popcontrol(1,branch)
2783  IF (branch .EQ. 0) CALL start_group_halo_update_adm(i_pack(3), &
2784 & divgd, divgd_ad, &
2785 & domain, position=&
2786 & corner)
2787  DO k=npz,1,-1
2788  CALL c_sw_bwd(delpc(isd:ied, jsd:jed, k), delpc_ad(isd:ied, jsd:&
2789 & jed, k), delp(isd:ied, jsd:jed, k), delp_ad(isd:ied, jsd&
2790 & :jed, k), ptc(isd:ied, jsd:jed, k), ptc_ad(isd:ied, jsd:&
2791 & jed, k), pt(isd:ied, jsd:jed, k), pt_ad(isd:ied, jsd:jed&
2792 & , k), u(isd:ied, jsd:jed+1, k), u_ad(isd:ied, jsd:jed+1&
2793 & , k), v(isd:ied+1, jsd:jed, k), v_ad(isd:ied+1, jsd:jed&
2794 & , k), w(isd:ied, jsd:jed, k), w_ad(isd:ied, jsd:jed, k)&
2795 & , uc(isd:ied+1, jsd:jed, k), uc_ad(isd:ied+1, jsd:jed, k&
2796 & ), vc(isd:ied, jsd:jed+1, k), vc_ad(isd:ied, jsd:jed+1, &
2797 & k), ua(isd:ied, jsd:jed, k), ua_ad(isd:ied, jsd:jed, k)&
2798 & , va(isd:ied, jsd:jed, k), va_ad(isd:ied, jsd:jed, k), &
2799 & omga(isd:ied, jsd:jed, k), omga_ad(isd:ied, jsd:jed, k)&
2800 & , ut(isd:ied, jsd:jed, k), ut_ad(isd:ied, jsd:jed, k), &
2801 & vt(isd:ied, jsd:jed, k), vt_ad(isd:ied, jsd:jed, k), &
2802 & divgd(isd:ied+1, jsd:jed+1, k), divgd_ad(isd:ied+1, jsd:&
2803 & jed+1, k), flagstruct%nord, dt2, hydrostatic, .true., bd&
2804 & , gridstruct, flagstruct)
2805  END DO
2806  CALL popcontrol(2,branch)
2807  IF (branch .EQ. 0) THEN
2808  DO j=je+1,js-1,-1
2809  DO k=npz,1,-1
2810  DO i=ie+1,is-1,-1
2811  pem_ad(i, k, j) = pem_ad(i, k, j) + pem_ad(i, k+1, j)
2812  delp_ad(i, j, k) = delp_ad(i, j, k) + pem_ad(i, k+1, j)
2813  pem_ad(i, k+1, j) = 0.0
2814  END DO
2815  END DO
2816  DO i=ie+1,is-1,-1
2817  pem_ad(i, 1, j) = 0.0
2818  END DO
2819  END DO
2820  pem_ad = 0.0
2821  END IF
2822  CALL popcontrol(1,branch)
2823  IF (branch .EQ. 0) THEN
2824  CALL poprealarray(beta_d)
2825  ELSE
2826  CALL poprealarray(beta_d)
2827  END IF
2828  CALL popcontrol(2,branch)
2829  IF (branch .EQ. 0) THEN
2830  CALL poprealarray(gz, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*(npz+&
2831 & 1))
2832  CALL start_group_halo_update_adm(i_pack(5), gz, gz_ad, domain)
2833  CALL popcontrol(1,branch)
2834  IF (branch .EQ. 0) THEN
2835  DO j=jed,jsd,-1
2836  DO k=1,npz,1
2837  DO i=ied,isd,-1
2838  CALL poprealarray(gz(i, j, k))
2839  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + gz_ad(i, j, k)
2840  delz_ad(i, j, k) = delz_ad(i, j, k) - gz_ad(i, j, k)
2841  gz_ad(i, j, k) = 0.0
2842  END DO
2843  END DO
2844  DO i=ied,isd,-1
2845  CALL poprealarray(gz(i, j, npz+1))
2846  gz_ad(i, j, npz+1) = 0.0
2847  END DO
2848  END DO
2849  ELSE
2850  DO j=je,js,-1
2851  DO k=1,npz,1
2852  DO i=ie,is,-1
2853  CALL poprealarray(gz(i, j, k))
2854  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + gz_ad(i, j, k)
2855  delz_ad(i, j, k) = delz_ad(i, j, k) - gz_ad(i, j, k)
2856  gz_ad(i, j, k) = 0.0
2857  END DO
2858  END DO
2859  DO i=ie,is,-1
2860  CALL poprealarray(gz(i, j, npz+1))
2861  gz_ad(i, j, npz+1) = 0.0
2862  END DO
2863  END DO
2864  END IF
2865  ELSE IF (branch .NE. 1) THEN
2866  GOTO 130
2867  END IF
2868  CALL poprealarray(w, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz)
2869  CALL start_group_halo_update_adm(i_pack(7), w, w_ad, domain)
2870  130 CALL popcontrol(2,branch)
2871  IF (branch .EQ. 0) THEN
2872  CALL poprealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*npz*nq&
2873 & )
2874  CALL start_group_halo_update_adm(i_pack(10), q, q_ad, domain)
2875  END IF
2876  CALL popcontrol(1,branch)
2877  END DO
2878  CALL popcontrol(2,branch)
2879  CALL poprealarray(cy, (bd%ied-bd%isd+1)*(bd%je-bd%js+2)*npz)
2880  CALL poprealarray(cx, (bd%ie-bd%is+2)*(bd%jed-bd%jsd+1)*npz)
2881  CALL poprealarray(mfy, (bd%ie-bd%is+1)*(bd%je-bd%js+2)*npz)
2882  CALL poprealarray(mfx, (bd%ie-bd%is+2)*(bd%je-bd%js+1)*npz)
2883  END SUBROUTINE dyn_core_bwd
2884 !-----------------------------------------------------------------------
2885 ! dyn_core :: FV Lagrangian dynamics driver
2886 !-----------------------------------------------------------------------
2887  SUBROUTINE dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, &
2888 & cp, akap, cappa, grav, hydrostatic, u, v, w, delz, pt, q, delp, pe, &
2889 & pk, phis, ws, omga, ptop, pfull, ua, va, uc, vc, mfx, mfy, cx, cy, &
2890 & pkz, peln, q_con, ak, bk, dpx, ks, gridstruct, flagstruct, &
2891 & flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, &
2892 & end_step, gz, pkc, ptc, crx, xfx, cry, yfx, divgd, delpc, ut, vt, zh&
2893 & , pk3, du, dv, time_total)
2894  IMPLICIT NONE
2895 ! end init_step
2896 ! Start of the big dynamic time stepping
2897 !allocate( gz(isd:ied, jsd:jed ,npz+1) )
2898 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, gz, huge_r)
2899 !allocate( pkc(isd:ied, jsd:jed ,npz+1) )
2900 !allocate( ptc(isd:ied, jsd:jed ,npz ) )
2901 !allocate( crx(is :ie+1, jsd:jed, npz) )
2902 !allocate( xfx(is :ie+1, jsd:jed, npz) )
2903 !allocate( cry(isd:ied, js :je+1, npz) )
2904 !allocate( yfx(isd:ied, js :je+1, npz) )
2905 !allocate( divgd(isd:ied+1,jsd:jed+1,npz) )
2906 !allocate( delpc(isd:ied, jsd:jed ,npz ) )
2907 ! call init_ijk_mem(isd,ied, jsd,jed, npz, delpc, 0.)
2908 !allocate( ut(isd:ied, jsd:jed, npz) )
2909 ! call init_ijk_mem(isd,ied, jsd,jed, npz, ut, 0.)
2910 !allocate( vt(isd:ied, jsd:jed, npz) )
2911 ! call init_ijk_mem(isd,ied, jsd,jed, npz, vt, 0.)
2912 !allocate( zh(isd:ied, jsd:jed, npz+1) )
2913 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, zh, huge_r )
2914 !allocate ( pk3(isd:ied,jsd:jed,npz+1) )
2915 !call init_ijk_mem(isd,ied, jsd,jed, npz+1, pk3, huge_r )
2916 !if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier
2917 !versions of the code
2918 !deallocate( gz )
2919 !deallocate( ptc )
2920 !deallocate( crx )
2921 !deallocate( xfx )
2922 !deallocate( cry )
2923 !deallocate( yfx )
2924 !deallocate( divgd )
2925 !deallocate( pkc )
2926 !deallocate( delpc )
2927 !if( allocated(ut)) deallocate( ut )
2928 !if( allocated(vt)) deallocate( vt )
2929 !if ( allocated (du) ) deallocate( du )
2930 !if ( allocated (dv) ) deallocate( dv )
2931 !if ( .not. hydrostatic ) then
2932 ! deallocate( zh )
2933 ! if( allocated(pk3) ) deallocate ( pk3 )
2934 !endif
2935 !if( allocated(pem) ) deallocate ( pem )
2936  INTEGER, INTENT(IN) :: npx
2937  INTEGER, INTENT(IN) :: npy
2938  INTEGER, INTENT(IN) :: npz
2939  INTEGER, INTENT(IN) :: ng, nq, sphum
2940  INTEGER, INTENT(IN) :: n_split
2941  REAL, INTENT(IN) :: bdt
2942  REAL, INTENT(IN) :: zvir, cp, akap, grav
2943  REAL, INTENT(IN) :: ptop
2944  LOGICAL, INTENT(IN) :: hydrostatic
2945  LOGICAL, INTENT(IN) :: init_step, end_step
2946  REAL, INTENT(IN) :: pfull(npz)
2947  REAL, DIMENSION(npz+1), INTENT(IN) :: ak, bk
2948  INTEGER, INTENT(IN) :: ks
2949  TYPE(group_halo_update_type), INTENT(INOUT) :: i_pack(*)
2950  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
2951 ! D grid zonal wind (m/s)
2952  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
2953 & :: u
2954 ! D grid meridional wind (m/s)
2955  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
2956 & :: v
2957 ! vertical vel. (m/s)
2958  REAL, INTENT(INOUT) :: w(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2959 ! delta-height (m, negative)
2960  REAL, INTENT(INOUT) :: delz(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2961 ! moist kappa
2962  REAL, INTENT(INOUT) :: cappa(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2963 ! temperature (K)
2964  REAL, INTENT(INOUT) :: pt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2965 ! pressure thickness (pascal)
2966  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2967 !
2968  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
2969 ! total time (seconds) since start
2970  REAL, INTENT(IN), OPTIONAL :: time_total
2971 !-----------------------------------------------------------------------
2972 ! Auxilliary pressure arrays:
2973 ! The 5 vars below can be re-computed from delp and ptop.
2974 !-----------------------------------------------------------------------
2975 ! dyn_aux:
2976 ! Surface geopotential (g*Z_surf)
2977  REAL, INTENT(INOUT) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed)
2978 ! edge pressure (pascal)
2979  REAL, INTENT(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
2980 ! ln(pe)
2981  REAL, INTENT(INOUT) :: peln(bd%is:bd%ie, npz+1, bd%js:bd%je)
2982 ! pe**kappa
2983  REAL, INTENT(INOUT) :: pk(bd%is:bd%ie, bd%js:bd%je, npz+1)
2984  REAL(kind=8), INTENT(INOUT) :: dpx(bd%is:bd%ie, bd%js:bd%je)
2985 !-----------------------------------------------------------------------
2986 ! Others:
2987  REAL, PARAMETER :: near0=1.e-8
2988  REAL, PARAMETER :: huge_r=1.e8
2989 !-----------------------------------------------------------------------
2990 ! w at surface
2991  REAL, INTENT(OUT) :: ws(bd%is:bd%ie, bd%js:bd%je)
2992 ! Vertical pressure velocity (pa/s)
2993  REAL, INTENT(INOUT) :: omga(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2994 ! (uc, vc) are mostly used as the C grid winds
2995  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
2996  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
2997  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
2998 & ua, va
2999  REAL, INTENT(INOUT) :: q_con(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3000 ! The Flux capacitors: accumulated Mass flux arrays
3001  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
3002  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
3003 ! Accumulated Courant number arrays
3004  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
3005  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
3006  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: pkz
3007  TYPE(fv_grid_type), INTENT(INOUT), TARGET :: gridstruct
3008  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
3009  TYPE(fv_flags_pert_type), INTENT(IN), TARGET :: flagstructp
3010  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
3011  TYPE(fv_diag_type), INTENT(IN) :: idiag
3012  TYPE(domain2d), INTENT(INOUT) :: domain
3013 !real, allocatable, dimension(:,:,:):: pem, heat_source
3014  REAL :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), heat_source(bd&
3015 & %isd:bd%ied, bd%jsd:bd%jed, npz)
3016 ! Auto 1D & 2D arrays:
3017  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3, z_rat
3018  REAL :: dp_ref(npz)
3019 ! surface height (m)
3020  REAL :: zs(bd%isd:bd%ied, bd%jsd:bd%jed)
3021  REAL :: p1d(bd%is:bd%ie)
3022  REAL :: om2d(bd%is:bd%ie, npz)
3023  REAL :: wbuffer(npy+2, npz)
3024  REAL :: ebuffer(npy+2, npz)
3025  REAL :: nbuffer(npx+2, npz)
3026  REAL :: sbuffer(npx+2, npz)
3027 ! ---- For external mode:
3028  REAL :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
3029  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
3030  REAL :: fz(bd%is:bd%ie+1, bd%js:bd%je+1)
3031  REAL :: heat_s(bd%is:bd%ie, bd%js:bd%je)
3032  REAL :: damp_vt(npz+1)
3033  INTEGER :: nord_v(npz+1)
3034 !-------------------------------------
3035  INTEGER :: hord_m, hord_v, hord_t, hord_p
3036  INTEGER :: nord_k, nord_w, nord_t
3037  INTEGER :: ms
3038 !---------------------------------------
3039  INTEGER :: hord_m_pert, hord_v_pert, hord_t_pert, hord_p_pert
3040  INTEGER :: nord_k_pert, nord_w_pert, nord_t_pert, nord_v_pert(npz+1)
3041  REAL :: d2_divg_pert, damp_vt_pert(npz+1), damp_w_pert, damp_t_pert
3042 !---------------------------------------
3043  INTEGER :: i, j, k, it, iq, n_con, nf_ke
3044  INTEGER :: iep1, jep1
3045  REAL :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air
3046  REAL :: dt, dt2, rdt
3047  REAL :: d2_divg
3048  REAL :: k1k, rdg, dtmp, delt
3049  LOGICAL :: last_step, remap_step
3050  LOGICAL :: used
3051  REAL :: split_timestep_bc
3052  INTEGER :: is, ie, js, je
3053  INTEGER :: isd, ied, jsd, jed
3054  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3055  REAL, INTENT(INOUT) :: pkc(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3056  REAL, INTENT(INOUT) :: ptc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3057  REAL, INTENT(INOUT) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
3058  REAL, INTENT(INOUT) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
3059  REAL, INTENT(INOUT) :: cry(bd%isd:bd%ied, bd%js:bd%je+1, npz)
3060  REAL, INTENT(INOUT) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
3061  REAL, INTENT(INOUT) :: divgd(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, npz)
3062  REAL, INTENT(INOUT) :: delpc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3063  REAL, INTENT(INOUT) :: ut(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3064  REAL, INTENT(INOUT) :: vt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3065  REAL, INTENT(INOUT) :: zh(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3066  REAL, INTENT(INOUT) :: pk3(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3067  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3068  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3069  INTRINSIC log
3070  INTRINSIC real
3071  INTRINSIC max
3072  INTRINSIC min
3073  INTRINSIC exp
3074  INTRINSIC abs
3075  INTRINSIC sign
3076  INTEGER :: max1
3077  INTEGER :: max2
3078  REAL :: min1
3079  REAL :: min2
3080  REAL :: abs0
3081  REAL :: arg1
3082  REAL :: arg2
3083  LOGICAL :: arg10
3084  REAL*8 :: arg11
3085  REAL :: x1
3086  REAL :: y2
3087  REAL :: y1
3088  is = bd%is
3089  ie = bd%ie
3090  js = bd%js
3091  je = bd%je
3092  isd = bd%isd
3093  ied = bd%ied
3094  jsd = bd%jsd
3095  jed = bd%jed
3096  peln1 = log(ptop)
3097  ptk = ptop**akap
3098  dt = bdt/REAL(n_split)
3099  dt2 = 0.5*dt
3100  rdt = 1.0/dt
3101  IF (1 .LT. flagstruct%m_split/2) THEN
3102  ms = flagstruct%m_split/2
3103  ELSE
3104  ms = 1
3105  END IF
3106  beta = flagstruct%beta
3107  rdg = -(rdgas/grav)
3108  cv_air = cp_air - rdgas
3109 ! Indexes:
3110  iep1 = ie + 1
3111  jep1 = je + 1
3112  IF (.NOT.hydrostatic) THEN
3113  rgrav = 1.0/grav
3114 ! rg/Cv=0.4
3115  k1k = akap/(1.-akap)
3116 !$OMP parallel do default(none) shared(npz,dp_ref,ak,bk)
3117  DO k=1,npz
3118  dp_ref(k) = ak(k+1) - ak(k) + (bk(k+1)-bk(k))*1.e5
3119  END DO
3120 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,zs,phis,rgrav)
3121  DO j=jsd,jed
3122  DO i=isd,ied
3123  zs(i, j) = phis(i, j)*rgrav
3124  END DO
3125  END DO
3126  END IF
3127 !allocate( du(isd:ied, jsd:jed+1,npz) )
3128 !call init_ijk_mem(isd,ied, jsd,jed+1, npz, du, 0.)
3129 !allocate( dv(isd:ied+1,jsd:jed, npz) )
3130 !call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.)
3131 ! Empty the "flux capacitors"
3132 !call init_ijk_mem(is, ie+1, js, je, npz, mfx, 0.)
3133  mfx = 0.0
3134 !call init_ijk_mem(is, ie , js, je+1, npz, mfy, 0.)
3135  mfy = 0.0
3136 !call init_ijk_mem(is, ie+1, jsd, jed, npz, cx, 0.)
3137  cx = 0.0
3138 !call init_ijk_mem(isd, ied, js, je+1, npz, cy, 0.)
3139  cy = 0.0
3140  IF (flagstruct%d_con .GT. 1.0e-5) heat_source = 0.0
3141 !allocate( heat_source(isd:ied, jsd:jed, npz) )
3142 !call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.)
3143  IF (flagstruct%convert_ke .OR. flagstruct%vtdm4 .GT. 1.e-4) THEN
3144  n_con = npz
3145  ELSE IF (flagstruct%d2_bg_k1 .LT. 1.e-3) THEN
3146  n_con = 0
3147  ELSE IF (flagstruct%d2_bg_k2 .LT. 1.e-3) THEN
3148  n_con = 1
3149  ELSE
3150  n_con = 2
3151  END IF
3152 !-----------------------------------------------------
3153  DO it=1,n_split
3154 !-----------------------------------------------------
3155  IF (flagstruct%breed_vortex_inline .OR. it .EQ. n_split) THEN
3156  remap_step = .true.
3157  ELSE
3158  remap_step = .false.
3159  END IF
3160  IF (flagstruct%fv_debug) THEN
3161  IF (is_master()) WRITE(*, *) 'n_split loop, it=', it
3162  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
3163 & ie, js, je, ng, npz, 1.&
3164 & , gridstruct%area_64, &
3165 & domain)
3166  CALL prt_mxm('PT', pt, is, ie, js, je, ng, npz, 1., gridstruct%&
3167 & area_64, domain)
3168  END IF
3169  IF (gridstruct%nested) split_timestep_bc = REAL(n_split*flagstruct&
3170 & %k_split + neststruct%nest_timestep)
3171 !First split timestep has split_timestep_BC = n_split*k_split
3172 ! to do time-extrapolation on BCs.
3173  IF (nq .GT. 0) THEN
3174  CALL timing_on('COMM_TOTAL')
3175  CALL timing_on('COMM_TRACER')
3176  IF (flagstruct%inline_q) CALL start_group_halo_update(i_pack(10)&
3177 & , q, domain)
3178  CALL timing_off('COMM_TRACER')
3179  CALL timing_off('COMM_TOTAL')
3180  END IF
3181  IF (.NOT.hydrostatic) THEN
3182  CALL timing_on('COMM_TOTAL')
3183  CALL start_group_halo_update(i_pack(7), w, domain)
3184  CALL timing_off('COMM_TOTAL')
3185  IF (it .EQ. 1) THEN
3186  IF (gridstruct%nested) THEN
3187 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,gz,zs,delz)
3188  DO j=jsd,jed
3189  DO i=isd,ied
3190  gz(i, j, npz+1) = zs(i, j)
3191  END DO
3192  DO k=npz,1,-1
3193  DO i=isd,ied
3194  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
3195  END DO
3196  END DO
3197  END DO
3198  ELSE
3199 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zs,delz)
3200  DO j=js,je
3201  DO i=is,ie
3202  gz(i, j, npz+1) = zs(i, j)
3203  END DO
3204  DO k=npz,1,-1
3205  DO i=is,ie
3206  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
3207  END DO
3208  END DO
3209  END DO
3210  END IF
3211  CALL timing_on('COMM_TOTAL')
3212  CALL start_group_halo_update(i_pack(5), gz, domain)
3213  CALL timing_off('COMM_TOTAL')
3214  END IF
3215  END IF
3216  IF (it .EQ. 1) THEN
3217  CALL timing_on('COMM_TOTAL')
3218  CALL complete_group_halo_update(i_pack(1), domain)
3219  CALL timing_off('COMM_TOTAL')
3220  beta_d = 0.
3221  ELSE
3222  beta_d = beta
3223  END IF
3224  IF (it .EQ. n_split .AND. end_step) THEN
3225  IF (flagstruct%use_old_omega) THEN
3226  pem = 0.0
3227 !allocate ( pem(is-1:ie+1,npz+1,js-1:je+1) )
3228 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pem,delp,ptop)
3229  DO j=js-1,je+1
3230  DO i=is-1,ie+1
3231  pem(i, 1, j) = ptop
3232  END DO
3233  DO k=1,npz
3234  DO i=is-1,ie+1
3235  pem(i, k+1, j) = pem(i, k, j) + delp(i, j, k)
3236  END DO
3237  END DO
3238  END DO
3239  END IF
3240  last_step = .true.
3241  ELSE
3242  last_step = .false.
3243  END IF
3244  CALL timing_on('COMM_TOTAL')
3245  CALL complete_group_halo_update(i_pack(8), domain)
3246  IF (.NOT.hydrostatic) CALL complete_group_halo_update(i_pack(7), &
3247 & domain)
3248  CALL timing_off('COMM_TOTAL')
3249  CALL timing_on('c_sw')
3250 !$OMP parallel do default(none) shared(npz,isd,jsd,delpc,delp,ptc,pt,u,v,w,uc,vc,ua,va, &
3251 !$OMP omga,ut,vt,divgd,flagstruct,dt2,hydrostatic,bd, &
3252 !$OMP gridstruct)
3253  DO k=1,npz
3254  CALL c_sw(delpc(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k)&
3255 & , ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k), u(isd:&
3256 & ied, jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(isd:ied, jsd&
3257 & :jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:ied, jsd:jed+1, &
3258 & k), ua(isd:ied, jsd:jed, k), va(isd:ied, jsd:jed, k), omga(&
3259 & isd:ied, jsd:jed, k), ut(isd:ied, jsd:jed, k), vt(isd:ied, &
3260 & jsd:jed, k), divgd(isd:ied+1, jsd:jed+1, k), flagstruct%nord&
3261 & , dt2, hydrostatic, .true., bd, gridstruct, flagstruct)
3262  END DO
3263  CALL timing_off('c_sw')
3264  IF (flagstruct%nord .GT. 0) THEN
3265  CALL timing_on('COMM_TOTAL')
3266  CALL start_group_halo_update(i_pack(3), divgd, domain, position=&
3267 & corner)
3268  CALL timing_off('COMM_TOTAL')
3269  END IF
3270  IF (gridstruct%nested) THEN
3271  arg1 = split_timestep_bc + 0.5
3272  arg2 = REAL(n_split*flagstruct%k_split)
3273  CALL nested_grid_bc_apply_intt(delpc, 0, 0, npx, npy, npz, bd, &
3274 & arg1, arg2, neststruct%delp_bc, &
3275 & neststruct%nestbctype)
3276  arg1 = split_timestep_bc + 0.5
3277  arg2 = REAL(n_split*flagstruct%k_split)
3278  CALL nested_grid_bc_apply_intt(ptc, 0, 0, npx, npy, npz, bd, &
3279 & arg1, arg2, neststruct%pt_bc, &
3280 & neststruct%nestbctype)
3281  END IF
3282 ! end hydro check
3283  IF (hydrostatic) THEN
3284  CALL geopk(ptop, pe, peln, delpc, pkc, gz, phis, ptc, q_con, pkz&
3285 & , npz, akap, .true., gridstruct%nested, .false., npx, npy, &
3286 & flagstruct%a2b_ord, bd)
3287  ELSE
3288  IF (it .EQ. 1) THEN
3289  CALL timing_on('COMM_TOTAL')
3290  CALL complete_group_halo_update(i_pack(5), domain)
3291  CALL timing_off('COMM_TOTAL')
3292 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
3293  DO k=1,npz+1
3294  DO j=jsd,jed
3295  DO i=isd,ied
3296 ! Save edge heights for update_dz_d
3297  zh(i, j, k) = gz(i, j, k)
3298  END DO
3299  END DO
3300  END DO
3301  ELSE
3302 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
3303  DO k=1,npz+1
3304  DO j=jsd,jed
3305  DO i=isd,ied
3306  gz(i, j, k) = zh(i, j, k)
3307  END DO
3308  END DO
3309  END DO
3310  END IF
3311  CALL timing_on('UPDATE_DZ_C')
3312  CALL update_dz_c(is, ie, js, je, npz, ng, dt2, dp_ref, zs, &
3313 & gridstruct%area, ut, vt, gz, ws3, npx, npy, &
3314 & gridstruct%sw_corner, gridstruct%se_corner, &
3315 & gridstruct%ne_corner, gridstruct%nw_corner, bd, &
3316 & gridstruct%grid_type)
3317  CALL timing_off('UPDATE_DZ_C')
3318  CALL timing_on('Riem_Solver')
3319  CALL riem_solver_c(ms, dt2, is, ie, js, je, npz, ng, akap, cappa&
3320 & , cp, ptop, phis, omga, ptc, q_con, delpc, gz, pkc&
3321 & , ws3, flagstruct%p_fac, flagstruct%a_imp, &
3322 & flagstruct%scale_z)
3323  CALL timing_off('Riem_Solver')
3324  IF (gridstruct%nested) THEN
3325  arg1 = split_timestep_bc + 0.5
3326  arg2 = REAL(n_split*flagstruct%k_split)
3327  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
3328 & arg1, arg2, neststruct%delz_bc, &
3329 & neststruct%nestbctype)
3330 !Compute gz/pkc
3331 !NOTE: nominally only need to compute quantities one out in the halo for p_grad_c
3332 !(instead of entire halo)
3333  CALL nest_halo_nh(ptop, grav, akap, cp, delpc, delz, ptc, phis&
3334 & , pkc, gz, pk3, npx, npy, npz, gridstruct%nested, &
3335 & .false., .false., .false., bd)
3336  END IF
3337  END IF
3338  CALL p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, gridstruct%&
3339 & rdxc, gridstruct%rdyc, hydrostatic)
3340  CALL timing_on('COMM_TOTAL')
3341  CALL start_group_halo_update(i_pack(9), uc, vc, domain, gridtype=&
3342 & cgrid_ne)
3343  CALL timing_off('COMM_TOTAL')
3344  CALL timing_on('COMM_TOTAL')
3345  IF (flagstruct%inline_q .AND. nq .GT. 0) CALL &
3346 & complete_group_halo_update(i_pack(10), domain)
3347  IF (flagstruct%nord .GT. 0) CALL complete_group_halo_update(i_pack&
3348 & (3), domain)
3349  CALL complete_group_halo_update(i_pack(9), domain)
3350  CALL timing_off('COMM_TOTAL')
3351  IF (gridstruct%nested) THEN
3352 !On a nested grid we have to do SOMETHING with uc and vc in
3353 ! the boundary halo, particularly at the corners of the
3354 ! domain and of each processor element. We must either
3355 ! apply an interpolated BC, or extrapolate into the
3356 ! boundary halo
3357 ! NOTE:
3358 !The update_domains calls for uc and vc need to go BEFORE the BCs to ensure cross-restart
3359 !bitwise-consistent solutions when doing the spatial extrapolation; should not make a
3360 !difference for interpolated BCs from the coarse grid.
3361  arg1 = split_timestep_bc + 0.5
3362  arg2 = REAL(n_split*flagstruct%k_split)
3363  CALL nested_grid_bc_apply_intt(vc, 0, 1, npx, npy, npz, bd, arg1&
3364 & , arg2, neststruct%vc_bc, neststruct%&
3365 & nestbctype)
3366  arg1 = split_timestep_bc + 0.5
3367  arg2 = REAL(n_split*flagstruct%k_split)
3368  CALL nested_grid_bc_apply_intt(uc, 1, 0, npx, npy, npz, bd, arg1&
3369 & , arg2, neststruct%uc_bc, neststruct%&
3370 & nestbctype)
3371 !QUESTION: What to do with divgd in nested halo?
3372  arg1 = REAL(n_split*flagstruct%k_split)
3373  CALL nested_grid_bc_apply_intt(divgd, 1, 1, npx, npy, npz, bd, &
3374 & split_timestep_bc, arg1, neststruct%&
3375 & divg_bc, neststruct%nestbctype)
3376 !!$ if (is == 1 .and. js == 1) then
3377 !!$ do j=jsd,5
3378 !!$ write(mpp_pe()+2000,*) j, divg(isd:5,j,1)
3379 !!$ endif
3380  END IF
3381  IF (gridstruct%nested .AND. flagstruct%inline_q) THEN
3382  DO iq=1,nq
3383  arg1 = split_timestep_bc + 1
3384  arg2 = REAL(n_split*flagstruct%k_split)
3385  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
3386 & 0, npx, npy, npz, bd, arg1, arg2, &
3387 & neststruct%q_bc(iq), neststruct%&
3388 & nestbctype)
3389  END DO
3390  END IF
3391  CALL timing_on('d_sw')
3392 !$OMP parallel do default(none) shared(npz,flagstruct,nord_v,pfull,damp_vt,hydrostatic,last_step, &
3393 !$OMP is,ie,js,je,isd,ied,jsd,jed,omga,delp,gridstruct,npx,npy, &
3394 !$OMP ng,zh,vt,ptc,pt,u,v,w,uc,vc,ua,va,divgd,mfx,mfy,cx,cy, &
3395 !$OMP crx,cry,xfx,yfx,q_con,zvir,sphum,nq,q,dt,bd,rdt,iep1,jep1, &
3396 !$OMP heat_source) &
3397 !$OMP private(nord_k, nord_w, nord_t, damp_w, damp_t, d2_divg, &
3398 !$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, z_rat)
3399  DO k=1,npz
3400  hord_m = flagstruct%hord_mt
3401  hord_t = flagstruct%hord_tm
3402  hord_v = flagstruct%hord_vt
3403  hord_p = flagstruct%hord_dp
3404  nord_k = flagstruct%nord
3405 ! if ( k==npz ) then
3406  kgb = flagstruct%ke_bg
3407  IF (2 .GT. flagstruct%nord) THEN
3408  nord_v(k) = flagstruct%nord
3409  ELSE
3410  nord_v(k) = 2
3411  END IF
3412  IF (0.20 .GT. flagstruct%d2_bg) THEN
3413  d2_divg = flagstruct%d2_bg
3414  ELSE
3415  d2_divg = 0.20
3416  END IF
3417  IF (flagstruct%do_vort_damp) THEN
3418 ! for delp, delz, and vorticity
3419  damp_vt(k) = flagstruct%vtdm4
3420  ELSE
3421  damp_vt(k) = 0.
3422  END IF
3423  nord_w = nord_v(k)
3424  nord_t = nord_v(k)
3425  damp_w = damp_vt(k)
3426  damp_t = damp_vt(k)
3427  d_con_k = flagstruct%d_con
3428  IF (npz .EQ. 1 .OR. flagstruct%n_sponge .LT. 0) THEN
3429  d2_divg = flagstruct%d2_bg
3430  ELSE IF (k .EQ. 1) THEN
3431 ! Sponge layers with del-2 damping on divergence, vorticity, w, z, and air mass (delp).
3432 ! no special damping of potential temperature in sponge layers
3433 ! Divergence damping:
3434  nord_k = 0
3435  IF (0.01 .LT. flagstruct%d2_bg) THEN
3436  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k1) THEN
3437  d2_divg = flagstruct%d2_bg_k1
3438  ELSE
3439  d2_divg = flagstruct%d2_bg
3440  END IF
3441  ELSE IF (0.01 .LT. flagstruct%d2_bg_k1) THEN
3442  d2_divg = flagstruct%d2_bg_k1
3443  ELSE
3444  d2_divg = 0.01
3445  END IF
3446 ! Vertical velocity:
3447  nord_w = 0
3448  damp_w = d2_divg
3449  IF (flagstruct%do_vort_damp) THEN
3450 ! damping on delp and vorticity:
3451  nord_v(k) = 0
3452  damp_vt(k) = 0.5*d2_divg
3453  END IF
3454  d_con_k = 0.
3455  ELSE
3456  IF (2 .LT. flagstruct%n_sponge - 1) THEN
3457  max1 = flagstruct%n_sponge - 1
3458  ELSE
3459  max1 = 2
3460  END IF
3461  IF (k .EQ. max1 .AND. flagstruct%d2_bg_k2 .GT. 0.01) THEN
3462  nord_k = 0
3463  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k2) THEN
3464  d2_divg = flagstruct%d2_bg_k2
3465  ELSE
3466  d2_divg = flagstruct%d2_bg
3467  END IF
3468  nord_w = 0
3469  damp_w = d2_divg
3470  IF (flagstruct%do_vort_damp) THEN
3471  nord_v(k) = 0
3472  damp_vt(k) = 0.5*d2_divg
3473  END IF
3474  d_con_k = 0.
3475  ELSE
3476  IF (3 .LT. flagstruct%n_sponge) THEN
3477  max2 = flagstruct%n_sponge
3478  ELSE
3479  max2 = 3
3480  END IF
3481  IF (k .EQ. max2 .AND. flagstruct%d2_bg_k2 .GT. 0.05) THEN
3482  nord_k = 0
3483  IF (flagstruct%d2_bg .LT. 0.2*flagstruct%d2_bg_k2) THEN
3484  d2_divg = 0.2*flagstruct%d2_bg_k2
3485  ELSE
3486  d2_divg = flagstruct%d2_bg
3487  END IF
3488  nord_w = 0
3489  damp_w = d2_divg
3490  d_con_k = 0.
3491  END IF
3492  END IF
3493  END IF
3494  hord_m_pert = flagstructp%hord_mt_pert
3495  hord_t_pert = flagstructp%hord_tm_pert
3496  hord_v_pert = flagstructp%hord_vt_pert
3497  hord_p_pert = flagstructp%hord_dp_pert
3498  nord_k_pert = flagstructp%nord_pert
3499  IF (2 .GT. flagstructp%nord_pert) THEN
3500  nord_v_pert(k) = flagstructp%nord_pert
3501  ELSE
3502  nord_v_pert(k) = 2
3503  END IF
3504  IF (0.20 .GT. flagstructp%d2_bg_pert) THEN
3505  d2_divg_pert = flagstructp%d2_bg_pert
3506  ELSE
3507  d2_divg_pert = 0.20
3508  END IF
3509  IF (flagstructp%do_vort_damp_pert) THEN
3510 ! for delp, delz, and vorticity
3511  damp_vt_pert(k) = flagstructp%vtdm4_pert
3512  ELSE
3513  damp_vt_pert(k) = 0.
3514  END IF
3515  nord_w_pert = nord_v_pert(k)
3516  nord_t_pert = nord_v_pert(k)
3517  damp_w_pert = damp_vt_pert(k)
3518  damp_t_pert = damp_vt_pert(k)
3519 !Sponge layers for the pertuabtiosn
3520  IF (k .LE. flagstructp%n_sponge_pert) THEN
3521  IF (k .LE. flagstructp%n_sponge_pert - 1) THEN
3522  IF (flagstructp%hord_ks_traj) THEN
3523  hord_m = flagstructp%hord_mt_ks_traj
3524  hord_t = flagstructp%hord_tm_ks_traj
3525  hord_v = flagstructp%hord_vt_ks_traj
3526  hord_p = flagstructp%hord_dp_ks_traj
3527  END IF
3528  IF (flagstructp%hord_ks_pert) THEN
3529  hord_m_pert = flagstructp%hord_mt_ks_pert
3530  hord_t_pert = flagstructp%hord_tm_ks_pert
3531  hord_v_pert = flagstructp%hord_vt_ks_pert
3532  hord_p_pert = flagstructp%hord_dp_ks_pert
3533  END IF
3534  END IF
3535  nord_k_pert = 0
3536  IF (k .EQ. 1) THEN
3537  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
3538  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k1_pert&
3539 & ) THEN
3540  d2_divg_pert = flagstructp%d2_bg_k1_pert
3541  ELSE
3542  d2_divg_pert = flagstructp%d2_bg_pert
3543  END IF
3544  ELSE IF (0.01 .LT. flagstructp%d2_bg_k1_pert) THEN
3545  d2_divg_pert = flagstructp%d2_bg_k1_pert
3546  ELSE
3547  d2_divg_pert = 0.01
3548  END IF
3549  ELSE IF (k .EQ. 2) THEN
3550  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
3551  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k2_pert&
3552 & ) THEN
3553  d2_divg_pert = flagstructp%d2_bg_k2_pert
3554  ELSE
3555  d2_divg_pert = flagstructp%d2_bg_pert
3556  END IF
3557  ELSE IF (0.01 .LT. flagstructp%d2_bg_k2_pert) THEN
3558  d2_divg_pert = flagstructp%d2_bg_k2_pert
3559  ELSE
3560  d2_divg_pert = 0.01
3561  END IF
3562  ELSE IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
3563  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_ks_pert) &
3564 & THEN
3565  d2_divg_pert = flagstructp%d2_bg_ks_pert
3566  ELSE
3567  d2_divg_pert = flagstructp%d2_bg_pert
3568  END IF
3569  ELSE IF (0.01 .LT. flagstructp%d2_bg_ks_pert) THEN
3570  d2_divg_pert = flagstructp%d2_bg_ks_pert
3571  ELSE
3572  d2_divg_pert = 0.01
3573  END IF
3574  nord_w_pert = 0
3575  damp_w_pert = d2_divg_pert
3576  IF (flagstructp%do_vort_damp_pert) THEN
3577  nord_v_pert(k) = 0
3578  damp_vt_pert(k) = 0.5*d2_divg_pert
3579  END IF
3580  END IF
3581 !Tapenade issue if not defined at level npz+1
3582  damp_vt(npz+1) = damp_vt(npz)
3583  damp_vt_pert(npz+1) = damp_vt_pert(npz)
3584  nord_v(npz+1) = nord_v(npz)
3585  nord_v_pert(npz+1) = nord_v_pert(npz)
3586  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
3587 & last_step) THEN
3588 ! Average horizontal "convergence" to cell center
3589  DO j=js,je
3590  DO i=is,ie
3591  omga(i, j, k) = delp(i, j, k)
3592  END DO
3593  END DO
3594  END IF
3595 !--- external mode divergence damping ---
3596  IF (flagstruct%d_ext .GT. 0.) CALL a2b_ord2(delp(isd:ied, jsd:&
3597 & jed, k), wk, gridstruct, &
3598 & npx, npy, is, ie, js, je, &
3599 & ng, .false.)
3600  IF (.NOT.hydrostatic .AND. flagstruct%do_f3d) THEN
3601 ! Correction factor for 3D Coriolis force
3602  DO j=jsd,jed
3603  DO i=isd,ied
3604  z_rat(i, j) = 1. + (zh(i, j, k)+zh(i, j, k+1))/radius
3605  END DO
3606  END DO
3607  END IF
3608  CALL d_sw(vt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k), &
3609 & ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k), u(isd:ied&
3610 & , jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(isd:ied, jsd:&
3611 & jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:ied, jsd:jed+1, k&
3612 & ), ua(isd:ied, jsd:jed, k), va(isd:ied, jsd:jed, k), divgd(&
3613 & isd:ied+1, jsd:jed+1, k), mfx(is:ie+1, js:je, k), mfy(is:ie&
3614 & , js:je+1, k), cx(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+1&
3615 & , k), crx(is:ie+1, jsd:jed, k), cry(isd:ied, js:je+1, k), &
3616 & xfx(is:ie+1, jsd:jed, k), yfx(isd:ied, js:je+1, k), q_con(&
3617 & isd:ied, jsd:jed, 1), z_rat(isd:ied, jsd:jed), kgb, heat_s, &
3618 & dpx, zvir, sphum, nq, q, k, npz, flagstruct%inline_q, dt, &
3619 & flagstruct%hord_tr, hord_m, hord_v, hord_t, hord_p, nord_k, &
3620 & nord_v(k), nord_w, nord_t, flagstruct%dddmp, d2_divg, &
3621 & flagstruct%d4_bg, damp_vt(k), damp_w, damp_t, d_con_k, &
3622 & hydrostatic, gridstruct, flagstruct, bd, flagstructp%&
3623 & hord_tr_pert, hord_m_pert, hord_v_pert, hord_t_pert, &
3624 & hord_p_pert, flagstructp%split_damp, nord_k_pert, &
3625 & nord_v_pert(k), nord_w_pert, nord_t_pert, flagstructp%&
3626 & dddmp_pert, d2_divg_pert, flagstructp%d4_bg_pert, &
3627 & damp_vt_pert(k), damp_w_pert, damp_t_pert)
3628  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
3629 & last_step) THEN
3630 ! Average horizontal "convergence" to cell center
3631  DO j=js,je
3632  DO i=is,ie
3633  omga(i, j, k) = omga(i, j, k)*(xfx(i, j, k)-xfx(i+1, j, k)&
3634 & +yfx(i, j, k)-yfx(i, j+1, k))*gridstruct%rarea(i, j)*rdt
3635  END DO
3636  END DO
3637  END IF
3638  IF (flagstruct%d_ext .GT. 0.) THEN
3639  DO j=js,jep1
3640  DO i=is,iep1
3641 ! delp at cell corners
3642  ptc(i, j, k) = wk(i, j)
3643  END DO
3644  END DO
3645  END IF
3646  IF (flagstruct%d_con .GT. 1.0e-5) THEN
3647 ! Average horizontal "convergence" to cell center
3648  DO j=js,je
3649  DO i=is,ie
3650  heat_source(i, j, k) = heat_source(i, j, k) + heat_s(i, j)
3651  END DO
3652  END DO
3653  END IF
3654  END DO
3655 ! end openMP k-loop
3656  CALL timing_off('d_sw')
3657  IF (flagstruct%fill_dp) CALL mix_dp(hydrostatic, w, delp, pt, npz&
3658 & , ak, bk, .false., flagstruct%&
3659 & fv_debug, bd)
3660  CALL timing_on('COMM_TOTAL')
3661  CALL start_group_halo_update(i_pack(1), delp, domain, complete=&
3662 & .true.)
3663  CALL start_group_halo_update(i_pack(1), pt, domain, complete=&
3664 & .true.)
3665  CALL timing_off('COMM_TOTAL')
3666  IF (flagstruct%d_ext .GT. 0.) THEN
3667  d2_divg = flagstruct%d_ext*gridstruct%da_min_c
3668 !$OMP parallel do default(none) shared(is,iep1,js,jep1,npz,wk,ptc,divg2,vt,d2_divg)
3669  DO j=js,jep1
3670  DO i=is,iep1
3671  wk(i, j) = ptc(i, j, 1)
3672  divg2(i, j) = wk(i, j)*vt(i, j, 1)
3673  END DO
3674  DO k=2,npz
3675  DO i=is,iep1
3676  wk(i, j) = wk(i, j) + ptc(i, j, k)
3677  divg2(i, j) = divg2(i, j) + ptc(i, j, k)*vt(i, j, k)
3678  END DO
3679  END DO
3680  DO i=is,iep1
3681  divg2(i, j) = d2_divg*divg2(i, j)/wk(i, j)
3682  END DO
3683  END DO
3684  ELSE
3685  divg2(:, :) = 0.
3686  END IF
3687  CALL timing_on('COMM_TOTAL')
3688  CALL complete_group_halo_update(i_pack(1), domain)
3689  CALL timing_off('COMM_TOTAL')
3690  IF (flagstruct%fv_debug) THEN
3691  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
3692 & ie, js, je, ng, npz, 1.&
3693 & , gridstruct%area_64, &
3694 & domain)
3695  END IF
3696 !Want to move this block into the hydro/nonhydro branch above and merge the two if structures
3697  IF (gridstruct%nested) THEN
3698  arg1 = split_timestep_bc + 1
3699  arg2 = REAL(n_split*flagstruct%k_split)
3700  CALL nested_grid_bc_apply_intt(delp, 0, 0, npx, npy, npz, bd, &
3701 & arg1, arg2, neststruct%delp_bc, &
3702 & neststruct%nestbctype)
3703  arg1 = split_timestep_bc + 1
3704  arg2 = REAL(n_split*flagstruct%k_split)
3705  CALL nested_grid_bc_apply_intt(pt, 0, 0, npx, npy, npz, bd, arg1&
3706 & , arg2, neststruct%pt_bc, neststruct%&
3707 & nestbctype)
3708  END IF
3709 ! end hydro check
3710  IF (hydrostatic) THEN
3711  CALL geopk(ptop, pe, peln, delp, pkc, gz, phis, pt, q_con, pkz, &
3712 & npz, akap, .false., gridstruct%nested, .true., npx, npy, &
3713 & flagstruct%a2b_ord, bd)
3714  ELSE
3715  CALL timing_on('UPDATE_DZ')
3716  CALL update_dz_d(nord_v, damp_vt, flagstruct%hord_tm, is, ie, js&
3717 & , je, npz, ng, npx, npy, gridstruct%area, gridstruct%&
3718 & rarea, dp_ref, zs, zh, crx, cry, xfx, yfx, delz, ws, &
3719 & rdt, gridstruct, bd, flagstructp%hord_tm_pert)
3720  CALL timing_off('UPDATE_DZ')
3721  IF (flagstruct%fv_debug) THEN
3722  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz updated', &
3723 & delz, is, ie, js, je, &
3724 & ng, npz, 1., &
3725 & gridstruct%area_64, &
3726 & domain)
3727  END IF
3728  IF (idiag%id_ws .GT. 0 .AND. last_step) used = send_data(idiag%&
3729 & id_ws, ws, fv_time)
3730 ! call prt_maxmin('WS', ws, is, ie, js, je, 0, 1, 1., master)
3731  CALL timing_on('Riem_Solver')
3732  arg10 = beta .LT. -0.1
3733  CALL riem_solver3(flagstruct%m_split, dt, is, ie, js, je, npz, &
3734 & ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, &
3735 & q_con, w, delz, pt, delp, zh, pe, pkc, pk3, pk, peln&
3736 & , ws, flagstruct%scale_z, flagstruct%p_fac, &
3737 & flagstruct%a_imp, flagstruct%use_logp, remap_step, &
3738 & arg10)
3739  CALL timing_off('Riem_Solver')
3740  CALL timing_on('COMM_TOTAL')
3741  IF (gridstruct%square_domain) THEN
3742  CALL start_group_halo_update(i_pack(4), zh, domain)
3743  CALL start_group_halo_update(i_pack(5), pkc, domain, whalo=2, &
3744 & ehalo=2, shalo=2, nhalo=2)
3745  ELSE
3746  CALL start_group_halo_update(i_pack(4), zh, domain, complete=&
3747 & .true.)
3748  CALL start_group_halo_update(i_pack(4), pkc, domain, complete=&
3749 & .true.)
3750  END IF
3751  CALL timing_off('COMM_TOTAL')
3752  IF (remap_step) CALL pe_halo(is, ie, js, je, isd, ied, jsd, jed&
3753 & , npz, ptop, pe, delp)
3754  IF (flagstruct%use_logp) THEN
3755  CALL pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
3756 & pk3, delp)
3757  ELSE
3758  CALL pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
3759 & akap, pk3, delp)
3760  END IF
3761  IF (gridstruct%nested) THEN
3762  arg1 = split_timestep_bc + 1.
3763  arg2 = REAL(n_split*flagstruct%k_split)
3764  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
3765 & arg1, arg2, neststruct%delz_bc, &
3766 & neststruct%nestbctype)
3767 !Compute gz/pkc/pk3; note that now pkc should be nonhydro pert'n pressure
3768  CALL nest_halo_nh(ptop, grav, akap, cp, delp, delz, pt, phis, &
3769 & pkc, gz, pk3, npx, npy, npz, gridstruct%nested, &
3770 & .true., .true., .true., bd)
3771  END IF
3772  CALL timing_on('COMM_TOTAL')
3773  CALL complete_group_halo_update(i_pack(4), domain)
3774  CALL timing_off('COMM_TOTAL')
3775 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zh,grav)
3776  DO k=1,npz+1
3777  DO j=js-2,je+2
3778  DO i=is-2,ie+2
3779  gz(i, j, k) = zh(i, j, k)*grav
3780  END DO
3781  END DO
3782  END DO
3783  IF (gridstruct%square_domain) THEN
3784  CALL timing_on('COMM_TOTAL')
3785  CALL complete_group_halo_update(i_pack(5), domain)
3786  CALL timing_off('COMM_TOTAL')
3787  END IF
3788  END IF
3789  IF (remap_step .AND. hydrostatic) THEN
3790 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,pkc)
3791  DO k=1,npz+1
3792  DO j=js,je
3793  DO i=is,ie
3794  pk(i, j, k) = pkc(i, j, k)
3795  END DO
3796  END DO
3797  END DO
3798  END IF
3799 !----------------------------
3800 ! Compute pressure gradient:
3801 !----------------------------
3802  CALL timing_on('PG_D')
3803  IF (hydrostatic) THEN
3804  IF (beta .GT. 0.) THEN
3805  CALL grad1_p_update(divg2, u, v, pkc, gz, du, dv, dt, ng, &
3806 & gridstruct, bd, npx, npy, npz, ptop, beta_d, &
3807 & flagstruct%a2b_ord)
3808  ELSE
3809  CALL one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct&
3810 & , bd, npx, npy, npz, ptop, hydrostatic, flagstruct%&
3811 & a2b_ord, flagstruct%d_ext)
3812  END IF
3813  ELSE IF (beta .GT. 0.) THEN
3814  CALL split_p_grad(u, v, pkc, gz, du, dv, delp, pk3, beta_d, dt, &
3815 & ng, gridstruct, bd, npx, npy, npz, flagstruct%&
3816 & use_logp)
3817  ELSE IF (beta .LT. -0.1) THEN
3818  CALL one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, &
3819 & bd, npx, npy, npz, ptop, hydrostatic, flagstruct%&
3820 & a2b_ord, flagstruct%d_ext)
3821  ELSE
3822  CALL nh_p_grad(u, v, pkc, gz, delp, pk3, dt, ng, gridstruct, bd&
3823 & , npx, npy, npz, flagstruct%use_logp)
3824  END IF
3825  CALL timing_off('PG_D')
3826 ! Inline Rayleigh friction here?
3827 !-------------------------------------------------------------------------------------------------------
3828  IF (flagstruct%breed_vortex_inline) THEN
3829  IF (.NOT.hydrostatic) THEN
3830 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k)
3831  DO k=1,npz
3832  DO j=js,je
3833  DO i=is,ie
3834 ! Note: pt at this stage is Theta_m
3835  pkz(i, j, k) = exp(k1k*log(rdg*delp(i, j, k)/delz(i, j, &
3836 & k)*pt(i, j, k)))
3837  END DO
3838  END DO
3839  END DO
3840  END IF
3841  CALL breed_slp_inline(it, dt, npz, ak, bk, phis, pe, pk, peln, &
3842 & pkz, delp, u, v, pt, q, flagstruct%nwat, zvir, &
3843 & gridstruct, ks, domain, bd, hydrostatic)
3844  END IF
3845 !-------------------------------------------------------------------------------------------------------
3846  CALL timing_on('COMM_TOTAL')
3847  IF (it .EQ. n_split .AND. gridstruct%grid_type .LT. 4 .AND. (.NOT.&
3848 & gridstruct%nested)) THEN
3849 ! Prevent accumulation of rounding errors at overlapped domain edges:
3850  CALL mpp_get_boundary(u, v, domain, ebuffery=ebuffer, nbufferx=&
3851 & nbuffer, gridtype=dgrid_ne)
3852 !$OMP parallel do default(none) shared(is,ie,js,je,npz,u,nbuffer,v,ebuffer)
3853  DO k=1,npz
3854  DO i=is,ie
3855  u(i, je+1, k) = nbuffer(i-is+1, k)
3856  END DO
3857  DO j=js,je
3858  v(ie+1, j, k) = ebuffer(j-js+1, k)
3859  END DO
3860  END DO
3861  END IF
3862  IF (it .NE. n_split) CALL start_group_halo_update(i_pack(8), u, v&
3863 & , domain, gridtype=&
3864 & dgrid_ne)
3865  CALL timing_off('COMM_TOTAL')
3866  IF (gridstruct%nested) neststruct%nest_timestep = neststruct%&
3867 & nest_timestep + 1
3868  IF (hydrostatic .AND. last_step) THEN
3869  IF (flagstruct%use_old_omega) THEN
3870 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,pe,pem,rdt)
3871  DO k=1,npz
3872  DO j=js,je
3873  DO i=is,ie
3874  omga(i, j, k) = (pe(i, k+1, j)-pem(i, k+1, j))*rdt
3875  END DO
3876  END DO
3877  END DO
3878 !------------------------------
3879 ! Compute the "advective term"
3880 !------------------------------
3881  CALL adv_pe(ua, va, pem, omga, gridstruct, bd, npx, npy, npz, &
3882 & ng)
3883  ELSE
3884 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga) private(om2d)
3885  DO j=js,je
3886  DO k=1,npz
3887  DO i=is,ie
3888  om2d(i, k) = omga(i, j, k)
3889  END DO
3890  END DO
3891  DO k=2,npz
3892  DO i=is,ie
3893  om2d(i, k) = om2d(i, k-1) + omga(i, j, k)
3894  END DO
3895  END DO
3896  DO k=2,npz
3897  DO i=is,ie
3898  omga(i, j, k) = om2d(i, k)
3899  END DO
3900  END DO
3901  END DO
3902  END IF
3903  IF (idiag%id_ws .GT. 0 .AND. hydrostatic) THEN
3904 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ws,delz,delp,omga)
3905  DO j=js,je
3906  DO i=is,ie
3907  ws(i, j) = delz(i, j, npz)/delp(i, j, npz)*omga(i, j, npz)
3908  END DO
3909  END DO
3910  used = send_data(idiag%id_ws, ws, fv_time)
3911  END IF
3912  END IF
3913  IF (gridstruct%nested) THEN
3914  IF (.NOT.hydrostatic) THEN
3915  arg1 = split_timestep_bc + 1
3916  arg2 = REAL(n_split*flagstruct%k_split)
3917  CALL nested_grid_bc_apply_intt(w, 0, 0, npx, npy, npz, bd, &
3918 & arg1, arg2, neststruct%w_bc, &
3919 & neststruct%nestbctype)
3920  END IF
3921  arg1 = split_timestep_bc + 1
3922  arg2 = REAL(n_split*flagstruct%k_split)
3923  CALL nested_grid_bc_apply_intt(u, 0, 1, npx, npy, npz, bd, arg1&
3924 & , arg2, neststruct%u_bc, neststruct%&
3925 & nestbctype)
3926  arg1 = split_timestep_bc + 1
3927  arg2 = REAL(n_split*flagstruct%k_split)
3928  CALL nested_grid_bc_apply_intt(v, 1, 0, npx, npy, npz, bd, arg1&
3929 & , arg2, neststruct%v_bc, neststruct%&
3930 & nestbctype)
3931  END IF
3932  END DO
3933 !-----------------------------------------------------
3934 ! time split loop
3935 !-----------------------------------------------------
3936  IF (nq .GT. 0 .AND. (.NOT.flagstruct%inline_q)) THEN
3937  CALL timing_on('COMM_TOTAL')
3938  CALL timing_on('COMM_TRACER')
3939  CALL start_group_halo_update(i_pack(10), q, domain)
3940  CALL timing_off('COMM_TRACER')
3941  CALL timing_off('COMM_TOTAL')
3942  END IF
3943  IF (flagstruct%fv_debug) THEN
3944  IF (is_master()) WRITE(*, *) 'End of n_split loop'
3945  END IF
3946  IF (n_con .NE. 0 .AND. flagstruct%d_con .GT. 1.e-5) THEN
3947  IF (3 .GT. flagstruct%nord + 1) THEN
3948  nf_ke = flagstruct%nord + 1
3949  ELSE
3950  nf_ke = 3
3951  END IF
3952  arg11 = cnst_0p20*gridstruct%da_min
3953  CALL del2_cubed(heat_source, arg11, gridstruct, domain, npx, npy, &
3954 & npz, nf_ke, bd)
3955 ! Note: pt here is cp*(Virtual_Temperature/pkz)
3956  IF (hydrostatic) THEN
3957 !
3958 ! del(Cp*T) = - del(KE)
3959 !
3960 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pt,heat_source,delp,pkz,bdt) &
3961 !$OMP private(dtmp)
3962  DO j=js,je
3963 ! n_con is usually less than 3;
3964  DO k=1,n_con
3965  IF (k .LT. 3) THEN
3966  DO i=is,ie
3967  pt(i, j, k) = pt(i, j, k) + heat_source(i, j, k)/(cp_air&
3968 & *delp(i, j, k)*pkz(i, j, k))
3969  END DO
3970  ELSE
3971  DO i=is,ie
3972  dtmp = heat_source(i, j, k)/(cp_air*delp(i, j, k))
3973  IF (bdt .GE. 0.) THEN
3974  abs0 = bdt
3975  ELSE
3976  abs0 = -bdt
3977  END IF
3978  x1 = abs0*flagstruct%delt_max
3979  IF (dtmp .GE. 0.) THEN
3980  y1 = dtmp
3981  ELSE
3982  y1 = -dtmp
3983  END IF
3984  IF (x1 .GT. y1) THEN
3985  min1 = y1
3986  ELSE
3987  min1 = x1
3988  END IF
3989  pt(i, j, k) = pt(i, j, k) + sign(min1, dtmp)/pkz(i, j, k&
3990 & )
3991  END DO
3992  END IF
3993  END DO
3994  END DO
3995  ELSE
3996 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pkz,cappa,rdg,delp,delz,pt, &
3997 !$OMP heat_source,k1k,cv_air,bdt) &
3998 !$OMP private(dtmp, delt)
3999  DO k=1,n_con
4000  IF (bdt*flagstruct%delt_max .GE. 0.) THEN
4001  delt = bdt*flagstruct%delt_max
4002  ELSE
4003  delt = -(bdt*flagstruct%delt_max)
4004  END IF
4005 ! Sponge layers:
4006 ! if ( k == 1 ) delt = 2.0*delt
4007 ! if ( k == 2 ) delt = 1.5*delt
4008  DO j=js,je
4009  DO i=is,ie
4010  pkz(i, j, k) = exp(k1k*log(rdg*delp(i, j, k)/delz(i, j, k)&
4011 & *pt(i, j, k)))
4012  dtmp = heat_source(i, j, k)/(cv_air*delp(i, j, k))
4013  IF (dtmp .GE. 0.) THEN
4014  y2 = dtmp
4015  ELSE
4016  y2 = -dtmp
4017  END IF
4018  IF (delt .GT. y2) THEN
4019  min2 = y2
4020  ELSE
4021  min2 = delt
4022  END IF
4023  pt(i, j, k) = pt(i, j, k) + sign(min2, dtmp)/pkz(i, j, k)
4024  END DO
4025  END DO
4026  END DO
4027  END IF
4028  END IF
4029  END SUBROUTINE dyn_core
4030 ! Differentiation of pk3_halo in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
4031 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
4032 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
4033 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
4034 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
4035 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
4036 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
4037 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
4038 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
4039 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
4040 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
4041 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
4042 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
4043 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
4044 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
4045 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
4046 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
4047 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
4048 ! gradient of useful results: pk3 delp
4049 ! with respect to varying inputs: pk3 delp
4050  SUBROUTINE pk3_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
4051 & , akap, pk3, delp)
4052  IMPLICIT NONE
4053  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4054  REAL, INTENT(IN) :: ptop, akap
4055  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4056  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4057 ! Local:
4058  REAL :: pei(isd:ied)
4059  REAL :: pej(jsd:jed)
4060  INTEGER :: i, j, k
4061  INTRINSIC log
4062  INTRINSIC exp
4063 
4064  pei = 0.0
4065  pej = 0.0
4066 
4067 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3,akap) &
4068 !$OMP private(pei)
4069  DO j=js,je
4070  CALL pushrealarray(pei(is-2))
4071  pei(is-2) = ptop
4072  CALL pushrealarray(pei(is-1))
4073  pei(is-1) = ptop
4074  DO k=1,npz
4075  CALL pushrealarray(pei(is-2))
4076  pei(is-2) = pei(is-2) + delp(is-2, j, k)
4077  CALL pushrealarray(pei(is-1))
4078  pei(is-1) = pei(is-1) + delp(is-1, j, k)
4079  CALL pushrealarray(pk3(is-2, j, k+1))
4080  pk3(is-2, j, k+1) = exp(akap*log(pei(is-2)))
4081  CALL pushrealarray(pk3(is-1, j, k+1))
4082  pk3(is-1, j, k+1) = exp(akap*log(pei(is-1)))
4083  END DO
4084  CALL pushrealarray(pei(ie+1))
4085  pei(ie+1) = ptop
4086  CALL pushrealarray(pei(ie+2))
4087  pei(ie+2) = ptop
4088  DO k=1,npz
4089  CALL pushrealarray(pei(ie+1))
4090  pei(ie+1) = pei(ie+1) + delp(ie+1, j, k)
4091  CALL pushrealarray(pei(ie+2))
4092  pei(ie+2) = pei(ie+2) + delp(ie+2, j, k)
4093  CALL pushrealarray(pk3(ie+1, j, k+1))
4094  pk3(ie+1, j, k+1) = exp(akap*log(pei(ie+1)))
4095  CALL pushrealarray(pk3(ie+2, j, k+1))
4096  pk3(ie+2, j, k+1) = exp(akap*log(pei(ie+2)))
4097  END DO
4098  END DO
4099 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3,akap) &
4100 !$OMP private(pej)
4101  DO i=is-2,ie+2
4102  CALL pushrealarray(pej(js-2))
4103  pej(js-2) = ptop
4104  CALL pushrealarray(pej(js-1))
4105  pej(js-1) = ptop
4106  DO k=1,npz
4107  CALL pushrealarray(pej(js-2))
4108  pej(js-2) = pej(js-2) + delp(i, js-2, k)
4109  CALL pushrealarray(pej(js-1))
4110  pej(js-1) = pej(js-1) + delp(i, js-1, k)
4111  CALL pushrealarray(pk3(i, js-2, k+1))
4112  pk3(i, js-2, k+1) = exp(akap*log(pej(js-2)))
4113  CALL pushrealarray(pk3(i, js-1, k+1))
4114  pk3(i, js-1, k+1) = exp(akap*log(pej(js-1)))
4115  END DO
4116  CALL pushrealarray(pej(je+1))
4117  pej(je+1) = ptop
4118  CALL pushrealarray(pej(je+2))
4119  pej(je+2) = ptop
4120  DO k=1,npz
4121  CALL pushrealarray(pej(je+1))
4122  pej(je+1) = pej(je+1) + delp(i, je+1, k)
4123  CALL pushrealarray(pej(je+2))
4124  pej(je+2) = pej(je+2) + delp(i, je+2, k)
4125  CALL pushrealarray(pk3(i, je+1, k+1))
4126  pk3(i, je+1, k+1) = exp(akap*log(pej(je+1)))
4127  CALL pushrealarray(pk3(i, je+2, k+1))
4128  pk3(i, je+2, k+1) = exp(akap*log(pej(je+2)))
4129  END DO
4130  END DO
4131  CALL pushrealarray(pej, jed - jsd + 1)
4132  CALL pushrealarray(pei, ied - isd + 1)
4133  END SUBROUTINE pk3_halo_fwd
4134 ! Differentiation of pk3_halo in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
4135 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
4136 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
4137 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
4138 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
4139 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
4140 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
4141 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
4142 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
4143 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
4144 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
4145 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
4146 !.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.
4147 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
4148 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
4149 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
4150 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
4151 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
4152 ! gradient of useful results: pk3 delp
4153 ! with respect to varying inputs: pk3 delp
4154  SUBROUTINE pk3_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
4155 & , akap, pk3, pk3_ad, delp, delp_ad)
4156  IMPLICIT NONE
4157  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4158  REAL, INTENT(IN) :: ptop, akap
4159  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4160  REAL, DIMENSION(isd:ied, jsd:jed, npz) :: delp_ad
4161  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4162  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3_ad
4163  REAL :: pei(isd:ied)
4164  REAL :: pei_ad(isd:ied)
4165  REAL :: pej(jsd:jed)
4166  REAL :: pej_ad(jsd:jed)
4167  INTEGER :: i, j, k
4168  INTRINSIC log
4169  INTRINSIC exp
4170 
4171  pei = 0.0
4172  pej = 0.0
4173 
4174  CALL poprealarray(pei, ied - isd + 1)
4175  CALL poprealarray(pej, jed - jsd + 1)
4176  pej_ad = 0.0
4177  DO i=ie+2,is-2,-1
4178  DO k=npz,1,-1
4179  CALL poprealarray(pk3(i, je+2, k+1))
4180  pej_ad(je+2) = pej_ad(je+2) + akap*exp(akap*log(pej(je+2)))*&
4181 & pk3_ad(i, je+2, k+1)/pej(je+2)
4182  pk3_ad(i, je+2, k+1) = 0.0
4183  CALL poprealarray(pk3(i, je+1, k+1))
4184  pej_ad(je+1) = pej_ad(je+1) + akap*exp(akap*log(pej(je+1)))*&
4185 & pk3_ad(i, je+1, k+1)/pej(je+1)
4186  pk3_ad(i, je+1, k+1) = 0.0
4187  CALL poprealarray(pej(je+2))
4188  delp_ad(i, je+2, k) = delp_ad(i, je+2, k) + pej_ad(je+2)
4189  CALL poprealarray(pej(je+1))
4190  delp_ad(i, je+1, k) = delp_ad(i, je+1, k) + pej_ad(je+1)
4191  END DO
4192  CALL poprealarray(pej(je+2))
4193  pej_ad(je+2) = 0.0
4194  CALL poprealarray(pej(je+1))
4195  pej_ad(je+1) = 0.0
4196  DO k=npz,1,-1
4197  CALL poprealarray(pk3(i, js-1, k+1))
4198  pej_ad(js-1) = pej_ad(js-1) + akap*exp(akap*log(pej(js-1)))*&
4199 & pk3_ad(i, js-1, k+1)/pej(js-1)
4200  pk3_ad(i, js-1, k+1) = 0.0
4201  CALL poprealarray(pk3(i, js-2, k+1))
4202  pej_ad(js-2) = pej_ad(js-2) + akap*exp(akap*log(pej(js-2)))*&
4203 & pk3_ad(i, js-2, k+1)/pej(js-2)
4204  pk3_ad(i, js-2, k+1) = 0.0
4205  CALL poprealarray(pej(js-1))
4206  delp_ad(i, js-1, k) = delp_ad(i, js-1, k) + pej_ad(js-1)
4207  CALL poprealarray(pej(js-2))
4208  delp_ad(i, js-2, k) = delp_ad(i, js-2, k) + pej_ad(js-2)
4209  END DO
4210  CALL poprealarray(pej(js-1))
4211  pej_ad(js-1) = 0.0
4212  CALL poprealarray(pej(js-2))
4213  pej_ad(js-2) = 0.0
4214  END DO
4215  pei_ad = 0.0
4216  DO j=je,js,-1
4217  DO k=npz,1,-1
4218  CALL poprealarray(pk3(ie+2, j, k+1))
4219  pei_ad(ie+2) = pei_ad(ie+2) + akap*exp(akap*log(pei(ie+2)))*&
4220 & pk3_ad(ie+2, j, k+1)/pei(ie+2)
4221  pk3_ad(ie+2, j, k+1) = 0.0
4222  CALL poprealarray(pk3(ie+1, j, k+1))
4223  pei_ad(ie+1) = pei_ad(ie+1) + akap*exp(akap*log(pei(ie+1)))*&
4224 & pk3_ad(ie+1, j, k+1)/pei(ie+1)
4225  pk3_ad(ie+1, j, k+1) = 0.0
4226  CALL poprealarray(pei(ie+2))
4227  delp_ad(ie+2, j, k) = delp_ad(ie+2, j, k) + pei_ad(ie+2)
4228  CALL poprealarray(pei(ie+1))
4229  delp_ad(ie+1, j, k) = delp_ad(ie+1, j, k) + pei_ad(ie+1)
4230  END DO
4231  CALL poprealarray(pei(ie+2))
4232  pei_ad(ie+2) = 0.0
4233  CALL poprealarray(pei(ie+1))
4234  pei_ad(ie+1) = 0.0
4235  DO k=npz,1,-1
4236  CALL poprealarray(pk3(is-1, j, k+1))
4237  pei_ad(is-1) = pei_ad(is-1) + akap*exp(akap*log(pei(is-1)))*&
4238 & pk3_ad(is-1, j, k+1)/pei(is-1)
4239  pk3_ad(is-1, j, k+1) = 0.0
4240  CALL poprealarray(pk3(is-2, j, k+1))
4241  pei_ad(is-2) = pei_ad(is-2) + akap*exp(akap*log(pei(is-2)))*&
4242 & pk3_ad(is-2, j, k+1)/pei(is-2)
4243  pk3_ad(is-2, j, k+1) = 0.0
4244  CALL poprealarray(pei(is-1))
4245  delp_ad(is-1, j, k) = delp_ad(is-1, j, k) + pei_ad(is-1)
4246  CALL poprealarray(pei(is-2))
4247  delp_ad(is-2, j, k) = delp_ad(is-2, j, k) + pei_ad(is-2)
4248  END DO
4249  CALL poprealarray(pei(is-1))
4250  pei_ad(is-1) = 0.0
4251  CALL poprealarray(pei(is-2))
4252  pei_ad(is-2) = 0.0
4253  END DO
4254  END SUBROUTINE pk3_halo_bwd
4255  SUBROUTINE pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
4256 & akap, pk3, delp)
4257  IMPLICIT NONE
4258  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4259  REAL, INTENT(IN) :: ptop, akap
4260  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4261  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4262 ! Local:
4263  REAL :: pei(isd:ied)
4264  REAL :: pej(jsd:jed)
4265  INTEGER :: i, j, k
4266  INTRINSIC log
4267  INTRINSIC exp
4268 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3,akap) &
4269 !$OMP private(pei)
4270  DO j=js,je
4271  pei(is-2) = ptop
4272  pei(is-1) = ptop
4273  DO k=1,npz
4274  pei(is-2) = pei(is-2) + delp(is-2, j, k)
4275  pei(is-1) = pei(is-1) + delp(is-1, j, k)
4276  pk3(is-2, j, k+1) = exp(akap*log(pei(is-2)))
4277  pk3(is-1, j, k+1) = exp(akap*log(pei(is-1)))
4278  END DO
4279  pei(ie+1) = ptop
4280  pei(ie+2) = ptop
4281  DO k=1,npz
4282  pei(ie+1) = pei(ie+1) + delp(ie+1, j, k)
4283  pei(ie+2) = pei(ie+2) + delp(ie+2, j, k)
4284  pk3(ie+1, j, k+1) = exp(akap*log(pei(ie+1)))
4285  pk3(ie+2, j, k+1) = exp(akap*log(pei(ie+2)))
4286  END DO
4287  END DO
4288 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3,akap) &
4289 !$OMP private(pej)
4290  DO i=is-2,ie+2
4291  pej(js-2) = ptop
4292  pej(js-1) = ptop
4293  DO k=1,npz
4294  pej(js-2) = pej(js-2) + delp(i, js-2, k)
4295  pej(js-1) = pej(js-1) + delp(i, js-1, k)
4296  pk3(i, js-2, k+1) = exp(akap*log(pej(js-2)))
4297  pk3(i, js-1, k+1) = exp(akap*log(pej(js-1)))
4298  END DO
4299  pej(je+1) = ptop
4300  pej(je+2) = ptop
4301  DO k=1,npz
4302  pej(je+1) = pej(je+1) + delp(i, je+1, k)
4303  pej(je+2) = pej(je+2) + delp(i, je+2, k)
4304  pk3(i, je+1, k+1) = exp(akap*log(pej(je+1)))
4305  pk3(i, je+2, k+1) = exp(akap*log(pej(je+2)))
4306  END DO
4307  END DO
4308  END SUBROUTINE pk3_halo
4309 ! Differentiation of pln_halo in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
4310 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
4311 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
4312 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
4313 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
4314 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
4315 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
4316 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
4317 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
4318 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
4319 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
4320 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
4321 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
4322 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
4323 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
4324 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
4325 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
4326 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
4327 ! gradient of useful results: pk3 delp
4328 ! with respect to varying inputs: pk3 delp
4329  SUBROUTINE pln_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
4330 & , pk3, delp)
4331  IMPLICIT NONE
4332  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4333  REAL, INTENT(IN) :: ptop
4334  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4335  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4336 ! Local:
4337  REAL :: pet
4338  INTEGER :: i, j, k
4339  INTRINSIC log
4340 
4341  pet = 0.0
4342 
4343 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3) &
4344 !$OMP private(pet)
4345  DO j=js,je
4346  DO i=is-2,is-1
4347  CALL pushrealarray(pet)
4348  pet = ptop
4349  DO k=1,npz
4350  CALL pushrealarray(pet)
4351  pet = pet + delp(i, j, k)
4352  CALL pushrealarray(pk3(i, j, k+1))
4353  pk3(i, j, k+1) = log(pet)
4354  END DO
4355  END DO
4356  DO i=ie+1,ie+2
4357  CALL pushrealarray(pet)
4358  pet = ptop
4359  DO k=1,npz
4360  CALL pushrealarray(pet)
4361  pet = pet + delp(i, j, k)
4362  CALL pushrealarray(pk3(i, j, k+1))
4363  pk3(i, j, k+1) = log(pet)
4364  END DO
4365  END DO
4366  END DO
4367 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3) &
4368 !$OMP private(pet)
4369  DO i=is-2,ie+2
4370  DO j=js-2,js-1
4371  CALL pushrealarray(pet)
4372  pet = ptop
4373  DO k=1,npz
4374  CALL pushrealarray(pet)
4375  pet = pet + delp(i, j, k)
4376  CALL pushrealarray(pk3(i, j, k+1))
4377  pk3(i, j, k+1) = log(pet)
4378  END DO
4379  END DO
4380  DO j=je+1,je+2
4381  CALL pushrealarray(pet)
4382  pet = ptop
4383  DO k=1,npz
4384  CALL pushrealarray(pet)
4385  pet = pet + delp(i, j, k)
4386  CALL pushrealarray(pk3(i, j, k+1))
4387  pk3(i, j, k+1) = log(pet)
4388  END DO
4389  END DO
4390  END DO
4391  CALL pushrealarray(pet)
4392  END SUBROUTINE pln_halo_fwd
4393 ! Differentiation of pln_halo in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
4394 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
4395 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
4396 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
4397 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
4398 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
4399 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
4400 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
4401 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
4402 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
4403 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
4404 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
4405 !.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.
4406 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
4407 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
4408 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
4409 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
4410 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
4411 ! gradient of useful results: pk3 delp
4412 ! with respect to varying inputs: pk3 delp
4413  SUBROUTINE pln_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
4414 & , pk3, pk3_ad, delp, delp_ad)
4415  IMPLICIT NONE
4416  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4417  REAL, INTENT(IN) :: ptop
4418  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4419  REAL, DIMENSION(isd:ied, jsd:jed, npz) :: delp_ad
4420  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4421  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3_ad
4422  REAL :: pet
4423  REAL :: pet_ad
4424  INTEGER :: i, j, k
4425  INTRINSIC log
4426 
4427  pet = 0.0
4428 
4429  CALL poprealarray(pet)
4430  DO i=ie+2,is-2,-1
4431  DO j=je+2,je+1,-1
4432  pet_ad = 0.0
4433  DO k=npz,1,-1
4434  CALL poprealarray(pk3(i, j, k+1))
4435  pet_ad = pet_ad + pk3_ad(i, j, k+1)/pet
4436  pk3_ad(i, j, k+1) = 0.0
4437  CALL poprealarray(pet)
4438  delp_ad(i, j, k) = delp_ad(i, j, k) + pet_ad
4439  END DO
4440  CALL poprealarray(pet)
4441  END DO
4442  DO j=js-1,js-2,-1
4443  pet_ad = 0.0
4444  DO k=npz,1,-1
4445  CALL poprealarray(pk3(i, j, k+1))
4446  pet_ad = pet_ad + pk3_ad(i, j, k+1)/pet
4447  pk3_ad(i, j, k+1) = 0.0
4448  CALL poprealarray(pet)
4449  delp_ad(i, j, k) = delp_ad(i, j, k) + pet_ad
4450  END DO
4451  CALL poprealarray(pet)
4452  END DO
4453  END DO
4454  DO j=je,js,-1
4455  DO i=ie+2,ie+1,-1
4456  pet_ad = 0.0
4457  DO k=npz,1,-1
4458  CALL poprealarray(pk3(i, j, k+1))
4459  pet_ad = pet_ad + pk3_ad(i, j, k+1)/pet
4460  pk3_ad(i, j, k+1) = 0.0
4461  CALL poprealarray(pet)
4462  delp_ad(i, j, k) = delp_ad(i, j, k) + pet_ad
4463  END DO
4464  CALL poprealarray(pet)
4465  END DO
4466  DO i=is-1,is-2,-1
4467  pet_ad = 0.0
4468  DO k=npz,1,-1
4469  CALL poprealarray(pk3(i, j, k+1))
4470  pet_ad = pet_ad + pk3_ad(i, j, k+1)/pet
4471  pk3_ad(i, j, k+1) = 0.0
4472  CALL poprealarray(pet)
4473  delp_ad(i, j, k) = delp_ad(i, j, k) + pet_ad
4474  END DO
4475  CALL poprealarray(pet)
4476  END DO
4477  END DO
4478  END SUBROUTINE pln_halo_bwd
4479  SUBROUTINE pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3&
4480 & , delp)
4481  IMPLICIT NONE
4482  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4483  REAL, INTENT(IN) :: ptop
4484  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4485  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
4486 ! Local:
4487  REAL :: pet
4488  INTEGER :: i, j, k
4489  INTRINSIC log
4490 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3) &
4491 !$OMP private(pet)
4492  DO j=js,je
4493  DO i=is-2,is-1
4494  pet = ptop
4495  DO k=1,npz
4496  pet = pet + delp(i, j, k)
4497  pk3(i, j, k+1) = log(pet)
4498  END DO
4499  END DO
4500  DO i=ie+1,ie+2
4501  pet = ptop
4502  DO k=1,npz
4503  pet = pet + delp(i, j, k)
4504  pk3(i, j, k+1) = log(pet)
4505  END DO
4506  END DO
4507  END DO
4508 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3) &
4509 !$OMP private(pet)
4510  DO i=is-2,ie+2
4511  DO j=js-2,js-1
4512  pet = ptop
4513  DO k=1,npz
4514  pet = pet + delp(i, j, k)
4515  pk3(i, j, k+1) = log(pet)
4516  END DO
4517  END DO
4518  DO j=je+1,je+2
4519  pet = ptop
4520  DO k=1,npz
4521  pet = pet + delp(i, j, k)
4522  pk3(i, j, k+1) = log(pet)
4523  END DO
4524  END DO
4525  END DO
4526  END SUBROUTINE pln_halo
4527 ! Differentiation of pe_halo in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.
4528 !a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod
4529 !.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_
4530 !dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Su
4531 !per fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 f
4532 !v_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap
4533 !_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_m
4534 !apz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_
4535 !mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_rest
4536 !art_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z
4537 ! main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod
4538 !.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.S
4539 !IM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.ne
4540 !st_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c
4541 !_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
4542 !sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod
4543 !.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mo
4544 !d.great_circle_dist sw_core_mod.edge_interpolate4)):
4545 ! gradient of useful results: delp pe
4546 ! with respect to varying inputs: delp pe
4547  SUBROUTINE pe_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
4548 & pe, delp)
4549  IMPLICIT NONE
4550  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4551  REAL, INTENT(IN) :: ptop
4552  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4553  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe
4554 ! Local:
4555  INTEGER :: i, j, k
4556 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
4557  DO j=js,je
4558  CALL pushrealarray(pe(is-1, 1, j))
4559  pe(is-1, 1, j) = ptop
4560  CALL pushrealarray(pe(ie+1, 1, j))
4561  pe(ie+1, 1, j) = ptop
4562  DO k=1,npz
4563  CALL pushrealarray(pe(is-1, k+1, j))
4564  pe(is-1, k+1, j) = pe(is-1, k, j) + delp(is-1, j, k)
4565  CALL pushrealarray(pe(ie+1, k+1, j))
4566  pe(ie+1, k+1, j) = pe(ie+1, k, j) + delp(ie+1, j, k)
4567  END DO
4568  END DO
4569 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
4570  DO i=is-1,ie+1
4571  CALL pushrealarray(pe(i, 1, js-1))
4572  pe(i, 1, js-1) = ptop
4573  CALL pushrealarray(pe(i, 1, je+1))
4574  pe(i, 1, je+1) = ptop
4575  DO k=1,npz
4576  CALL pushrealarray(pe(i, k+1, js-1))
4577  pe(i, k+1, js-1) = pe(i, k, js-1) + delp(i, js-1, k)
4578  CALL pushrealarray(pe(i, k+1, je+1))
4579  pe(i, k+1, je+1) = pe(i, k, je+1) + delp(i, je+1, k)
4580  END DO
4581  END DO
4582  END SUBROUTINE pe_halo_fwd
4583 ! Differentiation of pe_halo in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
4584 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
4585 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
4586 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
4587 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
4588 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
4589 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
4590 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
4591 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
4592 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
4593 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
4594 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
4595 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
4596 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
4597 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
4598 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
4599 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
4600 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
4601 ! gradient of useful results: delp pe
4602 ! with respect to varying inputs: delp pe
4603  SUBROUTINE pe_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
4604 & pe, pe_ad, delp, delp_ad)
4605  IMPLICIT NONE
4606  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4607  REAL, INTENT(IN) :: ptop
4608  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4609  REAL, DIMENSION(isd:ied, jsd:jed, npz) :: delp_ad
4610  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe
4611  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe_ad
4612  INTEGER :: i, j, k
4613  DO i=ie+1,is-1,-1
4614  DO k=npz,1,-1
4615  CALL poprealarray(pe(i, k+1, je+1))
4616  pe_ad(i, k, je+1) = pe_ad(i, k, je+1) + pe_ad(i, k+1, je+1)
4617  delp_ad(i, je+1, k) = delp_ad(i, je+1, k) + pe_ad(i, k+1, je+1)
4618  pe_ad(i, k+1, je+1) = 0.0
4619  CALL poprealarray(pe(i, k+1, js-1))
4620  pe_ad(i, k, js-1) = pe_ad(i, k, js-1) + pe_ad(i, k+1, js-1)
4621  delp_ad(i, js-1, k) = delp_ad(i, js-1, k) + pe_ad(i, k+1, js-1)
4622  pe_ad(i, k+1, js-1) = 0.0
4623  END DO
4624  CALL poprealarray(pe(i, 1, je+1))
4625  pe_ad(i, 1, je+1) = 0.0
4626  CALL poprealarray(pe(i, 1, js-1))
4627  pe_ad(i, 1, js-1) = 0.0
4628  END DO
4629  DO j=je,js,-1
4630  DO k=npz,1,-1
4631  CALL poprealarray(pe(ie+1, k+1, j))
4632  pe_ad(ie+1, k, j) = pe_ad(ie+1, k, j) + pe_ad(ie+1, k+1, j)
4633  delp_ad(ie+1, j, k) = delp_ad(ie+1, j, k) + pe_ad(ie+1, k+1, j)
4634  pe_ad(ie+1, k+1, j) = 0.0
4635  CALL poprealarray(pe(is-1, k+1, j))
4636  pe_ad(is-1, k, j) = pe_ad(is-1, k, j) + pe_ad(is-1, k+1, j)
4637  delp_ad(is-1, j, k) = delp_ad(is-1, j, k) + pe_ad(is-1, k+1, j)
4638  pe_ad(is-1, k+1, j) = 0.0
4639  END DO
4640  CALL poprealarray(pe(ie+1, 1, j))
4641  pe_ad(ie+1, 1, j) = 0.0
4642  CALL poprealarray(pe(is-1, 1, j))
4643  pe_ad(is-1, 1, j) = 0.0
4644  END DO
4645  END SUBROUTINE pe_halo_bwd
4646  SUBROUTINE pe_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, &
4647 & delp)
4648  IMPLICIT NONE
4649  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
4650  REAL, INTENT(IN) :: ptop
4651  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
4652  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe
4653 ! Local:
4654  INTEGER :: i, j, k
4655 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
4656  DO j=js,je
4657  pe(is-1, 1, j) = ptop
4658  pe(ie+1, 1, j) = ptop
4659  DO k=1,npz
4660  pe(is-1, k+1, j) = pe(is-1, k, j) + delp(is-1, j, k)
4661  pe(ie+1, k+1, j) = pe(ie+1, k, j) + delp(ie+1, j, k)
4662  END DO
4663  END DO
4664 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
4665  DO i=is-1,ie+1
4666  pe(i, 1, js-1) = ptop
4667  pe(i, 1, je+1) = ptop
4668  DO k=1,npz
4669  pe(i, k+1, js-1) = pe(i, k, js-1) + delp(i, js-1, k)
4670  pe(i, k+1, je+1) = pe(i, k, je+1) + delp(i, je+1, k)
4671  END DO
4672  END DO
4673  END SUBROUTINE pe_halo
4674 ! Differentiation of adv_pe in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a
4675 !2b_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.
4676 !p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_d
4677 !p dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Sup
4678 !er fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv
4679 !_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_
4680 !z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_ma
4681 !pz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_m
4682 !apz_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_resta
4683 !rt_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
4684 !main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.
4685 !Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SI
4686 !M3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nes
4687 !t_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_
4688 !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 s
4689 !w_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.
4690 !copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod
4691 !.great_circle_dist sw_core_mod.edge_interpolate4)):
4692 ! gradient of useful results: ua om va pem
4693 ! with respect to varying inputs: ua om va pem
4694  SUBROUTINE adv_pe_fwd(ua, va, pem, om, gridstruct, bd, npx, npy, npz, &
4695 & ng)
4696  IMPLICIT NONE
4697  INTEGER, INTENT(IN) :: npx, npy, npz, ng
4698  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4699 ! Contra-variant wind components:
4700  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: ua&
4701 & , va
4702 ! Pressure at edges:
4703  REAL, INTENT(IN) :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
4704  REAL, INTENT(INOUT) :: om(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
4705  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4706 ! Local:
4707  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up, vp
4708  REAL :: v3(3, bd%is:bd%ie, bd%js:bd%je)
4709  REAL :: pin(bd%isd:bd%ied, bd%jsd:bd%jed)
4710  REAL :: pb(bd%isd:bd%ied, bd%jsd:bd%jed)
4711  REAL :: grad(3, bd%is:bd%ie, bd%js:bd%je)
4712  REAL :: pdx(3, bd%is:bd%ie, bd%js:bd%je+1)
4713  REAL :: pdy(3, bd%is:bd%ie+1, bd%js:bd%je)
4714  INTEGER :: i, j, k, n
4715  INTEGER :: is, ie, js, je
4716 
4717  up = 0.0
4718  vp = 0.0
4719  v3 = 0.0
4720  pin = 0.0
4721  pb = 0.0
4722  grad = 0.0
4723  pdx = 0.0
4724  pdy = 0.0
4725  is = 0
4726  ie = 0
4727  js = 0
4728  je = 0
4729 
4730  is = bd%is
4731  ie = bd%ie
4732  js = bd%js
4733  je = bd%je
4734 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ua,va,gridstruct,pem,npx,npy,ng,om) &
4735 !$OMP private(n, pdx, pdy, pin, pb, up, vp, grad, v3)
4736  DO k=1,npz
4737  IF (k .EQ. npz) THEN
4738  DO j=js,je
4739  DO i=is,ie
4740  up(i, j) = ua(i, j, npz)
4741  vp(i, j) = va(i, j, npz)
4742  END DO
4743  END DO
4744  CALL pushcontrol(1,1)
4745  ELSE
4746  DO j=js,je
4747  DO i=is,ie
4748  up(i, j) = 0.5*(ua(i, j, k)+ua(i, j, k+1))
4749  vp(i, j) = 0.5*(va(i, j, k)+va(i, j, k+1))
4750  END DO
4751  END DO
4752  CALL pushcontrol(1,0)
4753  END IF
4754 ! Compute Vect wind:
4755  DO j=js,je
4756  DO i=is,ie
4757  DO n=1,3
4758  CALL pushrealarray(v3(n, i, j))
4759  v3(n, i, j) = up(i, j)*gridstruct%ec1(n, i, j) + vp(i, j)*&
4760 & gridstruct%ec2(n, i, j)
4761  END DO
4762  END DO
4763  END DO
4764  DO j=js-1,je+1
4765  DO i=is-1,ie+1
4766  pin(i, j) = pem(i, k+1, j)
4767  END DO
4768  END DO
4769 ! Compute pe at 4 cell corners:
4770  CALL a2b_ord2_fwd(pin, pb, gridstruct, npx, npy, is, ie, js, je, &
4771 & ng)
4772  DO j=js,je+1
4773  DO i=is,ie
4774  DO n=1,3
4775  pdx(n, i, j) = (pb(i, j)+pb(i+1, j))*gridstruct%dx(i, j)*&
4776 & gridstruct%en1(n, i, j)
4777  END DO
4778  END DO
4779  END DO
4780  DO j=js,je
4781  DO i=is,ie+1
4782  DO n=1,3
4783  pdy(n, i, j) = (pb(i, j)+pb(i, j+1))*gridstruct%dy(i, j)*&
4784 & gridstruct%en2(n, i, j)
4785  END DO
4786  END DO
4787  END DO
4788 ! Compute grad (pe) by Green's theorem
4789  DO j=js,je
4790  DO i=is,ie
4791  DO n=1,3
4792  CALL pushrealarray(grad(n, i, j))
4793  grad(n, i, j) = pdx(n, i, j+1) - pdx(n, i, j) - pdy(n, i, j)&
4794 & + pdy(n, i+1, j)
4795  END DO
4796  END DO
4797  END DO
4798 ! Compute inner product: V3 * grad (pe)
4799  DO j=js,je
4800  DO i=is,ie
4801  CALL pushrealarray(om(i, j, k))
4802  om(i, j, k) = om(i, j, k) + 0.5*gridstruct%rarea(i, j)*(v3(1, &
4803 & i, j)*grad(1, i, j)+v3(2, i, j)*grad(2, i, j)+v3(3, i, j)*&
4804 & grad(3, i, j))
4805  END DO
4806  END DO
4807  END DO
4808  CALL pushinteger(je)
4809  CALL pushinteger(is)
4810  CALL pushinteger(ie)
4811  CALL pushrealarray(grad, 3*(bd%ie-bd%is+1)*(bd%je-bd%js+1))
4812  CALL pushrealarray(v3, 3*(bd%ie-bd%is+1)*(bd%je-bd%js+1))
4813  CALL pushinteger(js)
4814  END SUBROUTINE adv_pe_fwd
4815 ! Differentiation of adv_pe in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.
4816 !a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod
4817 !.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_
4818 !dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Su
4819 !per fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 f
4820 !v_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap
4821 !_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_m
4822 !apz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_
4823 !mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_rest
4824 !art_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z
4825 ! main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod
4826 !.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.S
4827 !IM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.ne
4828 !st_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c
4829 !_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
4830 !sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod
4831 !.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mo
4832 !d.great_circle_dist sw_core_mod.edge_interpolate4)):
4833 ! gradient of useful results: ua om va pem
4834 ! with respect to varying inputs: ua om va pem
4835  SUBROUTINE adv_pe_bwd(ua, ua_ad, va, va_ad, pem, pem_ad, om, om_ad, &
4836 & gridstruct, bd, npx, npy, npz, ng)
4837  IMPLICIT NONE
4838  INTEGER, INTENT(IN) :: npx, npy, npz, ng
4839  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4840  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: ua&
4841 & , va
4842  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: ua_ad, va_ad
4843  REAL, INTENT(IN) :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
4844  REAL :: pem_ad(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
4845  REAL, INTENT(INOUT) :: om(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
4846  REAL, INTENT(INOUT) :: om_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
4847  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4848  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up, vp
4849  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up_ad, vp_ad
4850  REAL :: v3(3, bd%is:bd%ie, bd%js:bd%je)
4851  REAL :: v3_ad(3, bd%is:bd%ie, bd%js:bd%je)
4852  REAL :: pin(bd%isd:bd%ied, bd%jsd:bd%jed)
4853  REAL :: pin_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
4854  REAL :: pb(bd%isd:bd%ied, bd%jsd:bd%jed)
4855  REAL :: pb_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
4856  REAL :: grad(3, bd%is:bd%ie, bd%js:bd%je)
4857  REAL :: grad_ad(3, bd%is:bd%ie, bd%js:bd%je)
4858  REAL :: pdx(3, bd%is:bd%ie, bd%js:bd%je+1)
4859  REAL :: pdx_ad(3, bd%is:bd%ie, bd%js:bd%je+1)
4860  REAL :: pdy(3, bd%is:bd%ie+1, bd%js:bd%je)
4861  REAL :: pdy_ad(3, bd%is:bd%ie+1, bd%js:bd%je)
4862  INTEGER :: i, j, k, n
4863  INTEGER :: is, ie, js, je
4864  REAL :: temp_ad
4865  REAL :: temp_ad0
4866  REAL :: temp_ad1
4867  INTEGER :: branch
4868 
4869  up = 0.0
4870  vp = 0.0
4871  v3 = 0.0
4872  pin = 0.0
4873  pb = 0.0
4874  grad = 0.0
4875  pdx = 0.0
4876  pdy = 0.0
4877  is = 0
4878  ie = 0
4879  js = 0
4880  je = 0
4881  branch = 0
4882 
4883  CALL popinteger(js)
4884  CALL poprealarray(v3, 3*(bd%ie-bd%is+1)*(bd%je-bd%js+1))
4885  CALL poprealarray(grad, 3*(bd%ie-bd%is+1)*(bd%je-bd%js+1))
4886  CALL popinteger(ie)
4887  CALL popinteger(is)
4888  CALL popinteger(je)
4889  v3_ad = 0.0
4890  grad_ad = 0.0
4891  up_ad = 0.0
4892  pdx_ad = 0.0
4893  pdy_ad = 0.0
4894  pb_ad = 0.0
4895  vp_ad = 0.0
4896  pin_ad = 0.0
4897  DO k=npz,1,-1
4898  DO j=je,js,-1
4899  DO i=ie,is,-1
4900  CALL poprealarray(om(i, j, k))
4901  temp_ad1 = gridstruct%rarea(i, j)*0.5*om_ad(i, j, k)
4902  v3_ad(1, i, j) = v3_ad(1, i, j) + grad(1, i, j)*temp_ad1
4903  grad_ad(1, i, j) = grad_ad(1, i, j) + v3(1, i, j)*temp_ad1
4904  v3_ad(2, i, j) = v3_ad(2, i, j) + grad(2, i, j)*temp_ad1
4905  grad_ad(2, i, j) = grad_ad(2, i, j) + v3(2, i, j)*temp_ad1
4906  v3_ad(3, i, j) = v3_ad(3, i, j) + grad(3, i, j)*temp_ad1
4907  grad_ad(3, i, j) = grad_ad(3, i, j) + v3(3, i, j)*temp_ad1
4908  END DO
4909  END DO
4910  DO j=je,js,-1
4911  DO i=ie,is,-1
4912  DO n=3,1,-1
4913  CALL poprealarray(grad(n, i, j))
4914  pdx_ad(n, i, j+1) = pdx_ad(n, i, j+1) + grad_ad(n, i, j)
4915  pdx_ad(n, i, j) = pdx_ad(n, i, j) - grad_ad(n, i, j)
4916  pdy_ad(n, i+1, j) = pdy_ad(n, i+1, j) + grad_ad(n, i, j)
4917  pdy_ad(n, i, j) = pdy_ad(n, i, j) - grad_ad(n, i, j)
4918  grad_ad(n, i, j) = 0.0
4919  END DO
4920  END DO
4921  END DO
4922  DO j=je,js,-1
4923  DO i=ie+1,is,-1
4924  DO n=3,1,-1
4925  temp_ad0 = gridstruct%dy(i, j)*gridstruct%en2(n, i, j)*&
4926 & pdy_ad(n, i, j)
4927  pb_ad(i, j) = pb_ad(i, j) + temp_ad0
4928  pb_ad(i, j+1) = pb_ad(i, j+1) + temp_ad0
4929  pdy_ad(n, i, j) = 0.0
4930  END DO
4931  END DO
4932  END DO
4933  DO j=je+1,js,-1
4934  DO i=ie,is,-1
4935  DO n=3,1,-1
4936  temp_ad = gridstruct%dx(i, j)*gridstruct%en1(n, i, j)*pdx_ad&
4937 & (n, i, j)
4938  pb_ad(i, j) = pb_ad(i, j) + temp_ad
4939  pb_ad(i+1, j) = pb_ad(i+1, j) + temp_ad
4940  pdx_ad(n, i, j) = 0.0
4941  END DO
4942  END DO
4943  END DO
4944  CALL a2b_ord2_bwd(pin, pin_ad, pb, pb_ad, gridstruct, npx, npy, is&
4945 & , ie, js, je, ng)
4946  DO j=je+1,js-1,-1
4947  DO i=ie+1,is-1,-1
4948  pem_ad(i, k+1, j) = pem_ad(i, k+1, j) + pin_ad(i, j)
4949  pin_ad(i, j) = 0.0
4950  END DO
4951  END DO
4952  DO j=je,js,-1
4953  DO i=ie,is,-1
4954  DO n=3,1,-1
4955  CALL poprealarray(v3(n, i, j))
4956  up_ad(i, j) = up_ad(i, j) + gridstruct%ec1(n, i, j)*v3_ad(n&
4957 & , i, j)
4958  vp_ad(i, j) = vp_ad(i, j) + gridstruct%ec2(n, i, j)*v3_ad(n&
4959 & , i, j)
4960  v3_ad(n, i, j) = 0.0
4961  END DO
4962  END DO
4963  END DO
4964  CALL popcontrol(1,branch)
4965  IF (branch .EQ. 0) THEN
4966  DO j=je,js,-1
4967  DO i=ie,is,-1
4968  va_ad(i, j, k) = va_ad(i, j, k) + 0.5*vp_ad(i, j)
4969  va_ad(i, j, k+1) = va_ad(i, j, k+1) + 0.5*vp_ad(i, j)
4970  vp_ad(i, j) = 0.0
4971  ua_ad(i, j, k) = ua_ad(i, j, k) + 0.5*up_ad(i, j)
4972  ua_ad(i, j, k+1) = ua_ad(i, j, k+1) + 0.5*up_ad(i, j)
4973  up_ad(i, j) = 0.0
4974  END DO
4975  END DO
4976  ELSE
4977  DO j=je,js,-1
4978  DO i=ie,is,-1
4979  va_ad(i, j, npz) = va_ad(i, j, npz) + vp_ad(i, j)
4980  vp_ad(i, j) = 0.0
4981  ua_ad(i, j, npz) = ua_ad(i, j, npz) + up_ad(i, j)
4982  up_ad(i, j) = 0.0
4983  END DO
4984  END DO
4985  END IF
4986  END DO
4987  END SUBROUTINE adv_pe_bwd
4988  SUBROUTINE adv_pe(ua, va, pem, om, gridstruct, bd, npx, npy, npz, ng)
4989  IMPLICIT NONE
4990  INTEGER, INTENT(IN) :: npx, npy, npz, ng
4991  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4992 ! Contra-variant wind components:
4993  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: ua&
4994 & , va
4995 ! Pressure at edges:
4996  REAL, INTENT(IN) :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
4997  REAL, INTENT(INOUT) :: om(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
4998  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4999 ! Local:
5000  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up, vp
5001  REAL :: v3(3, bd%is:bd%ie, bd%js:bd%je)
5002  REAL :: pin(bd%isd:bd%ied, bd%jsd:bd%jed)
5003  REAL :: pb(bd%isd:bd%ied, bd%jsd:bd%jed)
5004  REAL :: grad(3, bd%is:bd%ie, bd%js:bd%je)
5005  REAL :: pdx(3, bd%is:bd%ie, bd%js:bd%je+1)
5006  REAL :: pdy(3, bd%is:bd%ie+1, bd%js:bd%je)
5007  INTEGER :: i, j, k, n
5008  INTEGER :: is, ie, js, je
5009  is = bd%is
5010  ie = bd%ie
5011  js = bd%js
5012  je = bd%je
5013 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ua,va,gridstruct,pem,npx,npy,ng,om) &
5014 !$OMP private(n, pdx, pdy, pin, pb, up, vp, grad, v3)
5015  DO k=1,npz
5016  IF (k .EQ. npz) THEN
5017  DO j=js,je
5018  DO i=is,ie
5019  up(i, j) = ua(i, j, npz)
5020  vp(i, j) = va(i, j, npz)
5021  END DO
5022  END DO
5023  ELSE
5024  DO j=js,je
5025  DO i=is,ie
5026  up(i, j) = 0.5*(ua(i, j, k)+ua(i, j, k+1))
5027  vp(i, j) = 0.5*(va(i, j, k)+va(i, j, k+1))
5028  END DO
5029  END DO
5030  END IF
5031 ! Compute Vect wind:
5032  DO j=js,je
5033  DO i=is,ie
5034  DO n=1,3
5035  v3(n, i, j) = up(i, j)*gridstruct%ec1(n, i, j) + vp(i, j)*&
5036 & gridstruct%ec2(n, i, j)
5037  END DO
5038  END DO
5039  END DO
5040  DO j=js-1,je+1
5041  DO i=is-1,ie+1
5042  pin(i, j) = pem(i, k+1, j)
5043  END DO
5044  END DO
5045 ! Compute pe at 4 cell corners:
5046  CALL a2b_ord2(pin, pb, gridstruct, npx, npy, is, ie, js, je, ng)
5047  DO j=js,je+1
5048  DO i=is,ie
5049  DO n=1,3
5050  pdx(n, i, j) = (pb(i, j)+pb(i+1, j))*gridstruct%dx(i, j)*&
5051 & gridstruct%en1(n, i, j)
5052  END DO
5053  END DO
5054  END DO
5055  DO j=js,je
5056  DO i=is,ie+1
5057  DO n=1,3
5058  pdy(n, i, j) = (pb(i, j)+pb(i, j+1))*gridstruct%dy(i, j)*&
5059 & gridstruct%en2(n, i, j)
5060  END DO
5061  END DO
5062  END DO
5063 ! Compute grad (pe) by Green's theorem
5064  DO j=js,je
5065  DO i=is,ie
5066  DO n=1,3
5067  grad(n, i, j) = pdx(n, i, j+1) - pdx(n, i, j) - pdy(n, i, j)&
5068 & + pdy(n, i+1, j)
5069  END DO
5070  END DO
5071  END DO
5072 ! Compute inner product: V3 * grad (pe)
5073  DO j=js,je
5074  DO i=is,ie
5075  om(i, j, k) = om(i, j, k) + 0.5*gridstruct%rarea(i, j)*(v3(1, &
5076 & i, j)*grad(1, i, j)+v3(2, i, j)*grad(2, i, j)+v3(3, i, j)*&
5077 & grad(3, i, j))
5078  END DO
5079  END DO
5080  END DO
5081  END SUBROUTINE adv_pe
5082 ! Differentiation of p_grad_c in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
5083 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
5084 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
5085 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
5086 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
5087 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
5088 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
5089 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
5090 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
5091 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
5092 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
5093 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
5094 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
5095 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
5096 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
5097 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
5098 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
5099 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
5100 ! gradient of useful results: gz uc pkc delpc vc
5101 ! with respect to varying inputs: gz uc pkc delpc vc
5102  SUBROUTINE p_grad_c_fwd(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, &
5103 & rdyc, hydrostatic)
5104  IMPLICIT NONE
5105  INTEGER, INTENT(IN) :: npz
5106  REAL, INTENT(IN) :: dt2
5107  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5108  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc
5109 ! pkc is pe**cappa if hydrostatic
5110 ! pkc is full pressure if non-hydrostatic
5111  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
5112 & pkc, gz
5113  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5114  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5115  REAL, INTENT(IN) :: rdxc(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5116  REAL, INTENT(IN) :: rdyc(bd%isd:bd%ied, bd%jsd:bd%jed)
5117  LOGICAL, INTENT(IN) :: hydrostatic
5118 ! Local:
5119  REAL :: wk(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
5120  INTEGER :: i, j, k
5121  INTEGER :: is, ie, js, je
5122 
5123  wk = 0.0
5124  is = 0
5125  ie = 0
5126  js = 0
5127  je = 0
5128 
5129  is = bd%is
5130  ie = bd%ie
5131  js = bd%js
5132  je = bd%je
5133 !$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pkc,delpc,uc,dt2,rdxc,gz,vc,rdyc) &
5134 !$OMP private(wk)
5135  DO k=1,npz
5136  IF (hydrostatic) THEN
5137  DO j=js-1,je+1
5138  DO i=is-1,ie+1
5139  CALL pushrealarray(wk(i, j))
5140  wk(i, j) = pkc(i, j, k+1) - pkc(i, j, k)
5141  END DO
5142  END DO
5143  CALL pushcontrol(1,1)
5144  ELSE
5145  DO j=js-1,je+1
5146  DO i=is-1,ie+1
5147  CALL pushrealarray(wk(i, j))
5148  wk(i, j) = delpc(i, j, k)
5149  END DO
5150  END DO
5151  CALL pushcontrol(1,0)
5152  END IF
5153  DO j=js,je
5154  DO i=is,ie+1
5155  uc(i, j, k) = uc(i, j, k) + dt2*rdxc(i, j)/(wk(i-1, j)+wk(i, j&
5156 & ))*((gz(i-1, j, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i-1, j&
5157 & , k))+(gz(i-1, j, k)-gz(i, j, k+1))*(pkc(i-1, j, k+1)-pkc(i&
5158 & , j, k)))
5159  END DO
5160  END DO
5161  DO j=js,je+1
5162  DO i=is,ie
5163  vc(i, j, k) = vc(i, j, k) + dt2*rdyc(i, j)/(wk(i, j-1)+wk(i, j&
5164 & ))*((gz(i, j-1, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i, j-1&
5165 & , k))+(gz(i, j-1, k)-gz(i, j, k+1))*(pkc(i, j-1, k+1)-pkc(i&
5166 & , j, k)))
5167  END DO
5168  END DO
5169  END DO
5170  CALL pushrealarray(wk, (bd%ie-bd%is+3)*(bd%je-bd%js+3))
5171  CALL pushinteger(je)
5172  CALL pushinteger(is)
5173  CALL pushinteger(ie)
5174  CALL pushinteger(js)
5175  END SUBROUTINE p_grad_c_fwd
5176 ! Differentiation of p_grad_c in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
5177 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
5178 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
5179 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
5180 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
5181 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
5182 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
5183 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
5184 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
5185 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
5186 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
5187 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
5188 !.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.
5189 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
5190 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
5191 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
5192 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
5193 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
5194 ! gradient of useful results: gz uc pkc delpc vc
5195 ! with respect to varying inputs: gz uc pkc delpc vc
5196  SUBROUTINE p_grad_c_bwd(dt2, npz, delpc, delpc_ad, pkc, pkc_ad, gz, &
5197 & gz_ad, uc, uc_ad, vc, vc_ad, bd, rdxc, rdyc, hydrostatic)
5198  IMPLICIT NONE
5199  INTEGER, INTENT(IN) :: npz
5200  REAL, INTENT(IN) :: dt2
5201  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5202  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc
5203  REAL, DIMENSION(bd%isd:, bd%jsd:, :) :: delpc_ad
5204  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
5205 & pkc, gz
5206  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1) :: pkc_ad, &
5207 & gz_ad
5208  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5209  REAL, INTENT(INOUT) :: uc_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5210  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5211  REAL, INTENT(INOUT) :: vc_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5212  REAL, INTENT(IN) :: rdxc(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5213  REAL, INTENT(IN) :: rdyc(bd%isd:bd%ied, bd%jsd:bd%jed)
5214  LOGICAL, INTENT(IN) :: hydrostatic
5215  REAL :: wk(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
5216  REAL :: wk_ad(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
5217  INTEGER :: i, j, k
5218  INTEGER :: is, ie, js, je
5219  REAL :: temp
5220  REAL :: temp0
5221  REAL :: temp1
5222  REAL :: temp2
5223  REAL :: temp3
5224  REAL :: temp_ad
5225  REAL :: temp_ad0
5226  REAL :: temp4
5227  REAL :: temp5
5228  REAL :: temp6
5229  REAL :: temp7
5230  REAL :: temp8
5231  REAL :: temp_ad1
5232  REAL :: temp_ad2
5233  INTEGER :: branch
5234 
5235  wk = 0.0
5236  is = 0
5237  ie = 0
5238  js = 0
5239  je = 0
5240  branch = 0
5241 
5242  CALL popinteger(js)
5243  CALL popinteger(ie)
5244  CALL popinteger(is)
5245  CALL popinteger(je)
5246  CALL poprealarray(wk, (bd%ie-bd%is+3)*(bd%je-bd%js+3))
5247  wk_ad = 0.0
5248  DO k=npz,1,-1
5249  DO j=je+1,js,-1
5250  DO i=ie,is,-1
5251  temp4 = wk(i, j-1) + wk(i, j)
5252  temp8 = pkc(i, j-1, k+1) - pkc(i, j, k)
5253  temp7 = gz(i, j-1, k) - gz(i, j, k+1)
5254  temp6 = pkc(i, j, k+1) - pkc(i, j-1, k)
5255  temp5 = gz(i, j-1, k+1) - gz(i, j, k)
5256  temp_ad1 = dt2*rdyc(i, j)*vc_ad(i, j, k)/temp4
5257  temp_ad2 = -((temp5*temp6+temp7*temp8)*temp_ad1/temp4)
5258  gz_ad(i, j-1, k+1) = gz_ad(i, j-1, k+1) + temp6*temp_ad1
5259  gz_ad(i, j, k) = gz_ad(i, j, k) - temp6*temp_ad1
5260  pkc_ad(i, j, k+1) = pkc_ad(i, j, k+1) + temp5*temp_ad1
5261  pkc_ad(i, j-1, k) = pkc_ad(i, j-1, k) - temp5*temp_ad1
5262  gz_ad(i, j-1, k) = gz_ad(i, j-1, k) + temp8*temp_ad1
5263  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) - temp8*temp_ad1
5264  pkc_ad(i, j-1, k+1) = pkc_ad(i, j-1, k+1) + temp7*temp_ad1
5265  pkc_ad(i, j, k) = pkc_ad(i, j, k) - temp7*temp_ad1
5266  wk_ad(i, j-1) = wk_ad(i, j-1) + temp_ad2
5267  wk_ad(i, j) = wk_ad(i, j) + temp_ad2
5268  END DO
5269  END DO
5270  DO j=je,js,-1
5271  DO i=ie+1,is,-1
5272  temp = wk(i-1, j) + wk(i, j)
5273  temp3 = pkc(i-1, j, k+1) - pkc(i, j, k)
5274  temp2 = gz(i-1, j, k) - gz(i, j, k+1)
5275  temp1 = pkc(i, j, k+1) - pkc(i-1, j, k)
5276  temp0 = gz(i-1, j, k+1) - gz(i, j, k)
5277  temp_ad = dt2*rdxc(i, j)*uc_ad(i, j, k)/temp
5278  temp_ad0 = -((temp0*temp1+temp2*temp3)*temp_ad/temp)
5279  gz_ad(i-1, j, k+1) = gz_ad(i-1, j, k+1) + temp1*temp_ad
5280  gz_ad(i, j, k) = gz_ad(i, j, k) - temp1*temp_ad
5281  pkc_ad(i, j, k+1) = pkc_ad(i, j, k+1) + temp0*temp_ad
5282  pkc_ad(i-1, j, k) = pkc_ad(i-1, j, k) - temp0*temp_ad
5283  gz_ad(i-1, j, k) = gz_ad(i-1, j, k) + temp3*temp_ad
5284  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) - temp3*temp_ad
5285  pkc_ad(i-1, j, k+1) = pkc_ad(i-1, j, k+1) + temp2*temp_ad
5286  pkc_ad(i, j, k) = pkc_ad(i, j, k) - temp2*temp_ad
5287  wk_ad(i-1, j) = wk_ad(i-1, j) + temp_ad0
5288  wk_ad(i, j) = wk_ad(i, j) + temp_ad0
5289  END DO
5290  END DO
5291  CALL popcontrol(1,branch)
5292  IF (branch .EQ. 0) THEN
5293  DO j=je+1,js-1,-1
5294  DO i=ie+1,is-1,-1
5295  CALL poprealarray(wk(i, j))
5296  delpc_ad(i, j, k) = delpc_ad(i, j, k) + wk_ad(i, j)
5297  wk_ad(i, j) = 0.0
5298  END DO
5299  END DO
5300  ELSE
5301  DO j=je+1,js-1,-1
5302  DO i=ie+1,is-1,-1
5303  CALL poprealarray(wk(i, j))
5304  pkc_ad(i, j, k+1) = pkc_ad(i, j, k+1) + wk_ad(i, j)
5305  pkc_ad(i, j, k) = pkc_ad(i, j, k) - wk_ad(i, j)
5306  wk_ad(i, j) = 0.0
5307  END DO
5308  END DO
5309  END IF
5310  END DO
5311  END SUBROUTINE p_grad_c_bwd
5312  SUBROUTINE p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, rdyc, &
5313 & hydrostatic)
5314  IMPLICIT NONE
5315  INTEGER, INTENT(IN) :: npz
5316  REAL, INTENT(IN) :: dt2
5317  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5318  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc
5319 ! pkc is pe**cappa if hydrostatic
5320 ! pkc is full pressure if non-hydrostatic
5321  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
5322 & pkc, gz
5323  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5324  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5325  REAL, INTENT(IN) :: rdxc(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
5326  REAL, INTENT(IN) :: rdyc(bd%isd:bd%ied, bd%jsd:bd%jed)
5327  LOGICAL, INTENT(IN) :: hydrostatic
5328 ! Local:
5329  REAL :: wk(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
5330  INTEGER :: i, j, k
5331  INTEGER :: is, ie, js, je
5332  is = bd%is
5333  ie = bd%ie
5334  js = bd%js
5335  je = bd%je
5336 !$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pkc,delpc,uc,dt2,rdxc,gz,vc,rdyc) &
5337 !$OMP private(wk)
5338  DO k=1,npz
5339  IF (hydrostatic) THEN
5340  DO j=js-1,je+1
5341  DO i=is-1,ie+1
5342  wk(i, j) = pkc(i, j, k+1) - pkc(i, j, k)
5343  END DO
5344  END DO
5345  ELSE
5346  DO j=js-1,je+1
5347  DO i=is-1,ie+1
5348  wk(i, j) = delpc(i, j, k)
5349  END DO
5350  END DO
5351  END IF
5352  DO j=js,je
5353  DO i=is,ie+1
5354  uc(i, j, k) = uc(i, j, k) + dt2*rdxc(i, j)/(wk(i-1, j)+wk(i, j&
5355 & ))*((gz(i-1, j, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i-1, j&
5356 & , k))+(gz(i-1, j, k)-gz(i, j, k+1))*(pkc(i-1, j, k+1)-pkc(i&
5357 & , j, k)))
5358  END DO
5359  END DO
5360  DO j=js,je+1
5361  DO i=is,ie
5362  vc(i, j, k) = vc(i, j, k) + dt2*rdyc(i, j)/(wk(i, j-1)+wk(i, j&
5363 & ))*((gz(i, j-1, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i, j-1&
5364 & , k))+(gz(i, j-1, k)-gz(i, j, k+1))*(pkc(i, j-1, k+1)-pkc(i&
5365 & , j, k)))
5366  END DO
5367  END DO
5368  END DO
5369  END SUBROUTINE p_grad_c
5370 ! Differentiation of nh_p_grad in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
5371 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
5372 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
5373 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
5374 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
5375 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
5376 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
5377 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
5378 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
5379 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
5380 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
5381 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
5382 !.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.
5383 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
5384 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
5385 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
5386 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
5387 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
5388 ! gradient of useful results: gz u v delp pk pp
5389 ! with respect to varying inputs: gz u v delp pk pp
5390  SUBROUTINE nh_p_grad_fwd(u, v, pp, gz, delp, pk, dt, ng, gridstruct, &
5391 & bd, npx, npy, npz, use_logp)
5392  IMPLICIT NONE
5393 ! end k-loop
5394  INTEGER, INTENT(IN) :: ng, npx, npy, npz
5395  REAL, INTENT(IN) :: dt
5396  LOGICAL, INTENT(IN) :: use_logp
5397  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5398  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
5399 ! perturbation pressure
5400  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5401 ! p**kappa
5402  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5403 ! g * h
5404  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5405  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5406  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5407  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
5408 ! Local:
5409  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
5410  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
5411  REAL :: du1, dv1, top_value
5412  INTEGER :: i, j, k
5413  INTEGER :: is, ie, js, je
5414  INTEGER :: isd, ied, jsd, jed
5415 
5416  wk1 = 0.0
5417  wk = 0.0
5418  du1 = 0.0
5419  dv1 = 0.0
5420  top_value = 0.0
5421  is = 0
5422  ie = 0
5423  js = 0
5424  je = 0
5425  isd = 0
5426  ied = 0
5427  jsd = 0
5428  jed = 0
5429 
5430  is = bd%is
5431  ie = bd%ie
5432  js = bd%js
5433  je = bd%je
5434  isd = bd%isd
5435  ied = bd%ied
5436  jsd = bd%jsd
5437  jed = bd%jed
5438  IF (use_logp) THEN
5439  top_value = peln1
5440  ELSE
5441  top_value = ptk
5442  END IF
5443 !Remember that not all compilers set pp to zero by default
5444 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
5445  DO j=js,je+1
5446  DO i=is,ie+1
5447  CALL pushrealarray(pp(i, j, 1))
5448  pp(i, j, 1) = 0.
5449  CALL pushrealarray(pk(i, j, 1))
5450  pk(i, j, 1) = top_value
5451  END DO
5452  END DO
5453 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
5454 !$OMP private(wk1)
5455  DO k=1,npz+1
5456  IF (k .NE. 1) THEN
5457  CALL a2b_ord4_fwd(pp(isd:ied, jsd:jed, k), wk1, gridstruct, &
5458 & npx, npy, is, ie, js, je, ng, .true.)
5459  CALL a2b_ord4_fwd(pk(isd:ied, jsd:jed, k), wk1, gridstruct, &
5460 & npx, npy, is, ie, js, je, ng, .true.)
5461  CALL pushcontrol(1,0)
5462  ELSE
5463  CALL pushcontrol(1,1)
5464  END IF
5465  CALL a2b_ord4_fwd(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx&
5466 & , npy, is, ie, js, je, ng, .true.)
5467  END DO
5468 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,gridstruct,npx,npy,ng,isd,jsd, &
5469 !$OMP pk,dt,gz,u,pp,v) &
5470 !$OMP private(wk1, wk, du1, dv1)
5471  DO k=1,npz
5472  CALL a2b_ord4_fwd(delp(isd:ied, jsd:jed, k), wk1, gridstruct, &
5473 & npx, npy, is, ie, js, je, ng)
5474  DO j=js,je+1
5475  DO i=is,ie+1
5476  CALL pushrealarray(wk(i, j))
5477  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
5478  END DO
5479  END DO
5480  DO j=js,je+1
5481  DO i=is,ie
5482 ! hydrostatic contributions from past time-step already added in the "beta" part
5483 ! Current gradient from "hydrostatic" components:
5484  du1 = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
5485 & (pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
5486 & (pk(i, j, k+1)-pk(i+1, j, k)))
5487 ! Non-hydrostatic contribution
5488  CALL pushrealarray(u(i, j, k))
5489  u(i, j, k) = (u(i, j, k)+du1+dt/(wk1(i, j)+wk1(i+1, j))*((gz(i&
5490 & , j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, j, k))+(gz(i&
5491 & , j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k))))*&
5492 & gridstruct%rdx(i, j)
5493  END DO
5494  END DO
5495  DO j=js,je
5496  DO i=is,ie+1
5497 ! Current gradient from "hydrostatic" components:
5498  dv1 = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
5499 & (pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
5500 & (pk(i, j, k+1)-pk(i, j+1, k)))
5501 ! Non-hydrostatic contribution
5502  CALL pushrealarray(v(i, j, k))
5503  v(i, j, k) = (v(i, j, k)+dv1+dt/(wk1(i, j)+wk1(i, j+1))*((gz(i&
5504 & , j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, j, k))+(gz(i&
5505 & , j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k))))*&
5506 & gridstruct%rdy(i, j)
5507  END DO
5508  END DO
5509  END DO
5510  CALL pushinteger(jed)
5511  CALL pushrealarray(wk, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
5512  CALL pushinteger(je)
5513  CALL pushinteger(is)
5514  CALL pushinteger(isd)
5515  CALL pushinteger(ie)
5516  CALL pushinteger(ied)
5517  CALL pushinteger(jsd)
5518  CALL pushrealarray(wk1, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
5519  CALL pushinteger(js)
5520  END SUBROUTINE nh_p_grad_fwd
5521 ! Differentiation of nh_p_grad in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
5522 !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_
5523 !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
5524 !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
5525 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
5526 !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
5527 !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
5528 !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
5529 !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
5530 !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
5531 !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_
5532 !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
5533 !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
5534 !.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
5535 !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_
5536 !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_
5537 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
5538 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
5539 ! gradient of useful results: gz u v delp pk pp
5540 ! with respect to varying inputs: gz u v delp pk pp
5541  SUBROUTINE nh_p_grad_bwd(u, u_ad, v, v_ad, pp, pp_ad, gz, gz_ad, delp&
5542 & , delp_ad, pk, pk_ad, dt, ng, gridstruct, bd, npx, npy, npz, &
5543 & use_logp)
5544  IMPLICIT NONE
5545 ! end k-loop
5546  INTEGER, INTENT(IN) :: ng, npx, npy, npz
5547  REAL, INTENT(IN) :: dt
5548  LOGICAL, INTENT(IN) :: use_logp
5549  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5550  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
5551  REAL, INTENT(INOUT) :: delp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
5552  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5553  REAL, INTENT(INOUT) :: pp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5554  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5555  REAL, INTENT(INOUT) :: pk_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5556  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5557  REAL, INTENT(INOUT) :: gz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5558  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5559  REAL, INTENT(INOUT) :: u_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5560  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5561  REAL, INTENT(INOUT) :: v_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5562  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
5563  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
5564  REAL :: wk1_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
5565  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
5566  REAL :: wk_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
5567  REAL :: du1, dv1, top_value
5568  REAL :: du1_ad, dv1_ad
5569  INTEGER :: i, j, k
5570  INTEGER :: is, ie, js, je
5571  INTEGER :: isd, ied, jsd, jed
5572  REAL :: temp
5573  REAL :: temp0
5574  REAL :: temp1
5575  REAL :: temp2
5576  REAL :: temp3
5577  REAL :: temp4
5578  REAL :: temp5
5579  REAL :: temp6
5580  REAL :: temp7
5581  REAL :: temp8
5582  REAL :: temp_ad
5583  REAL :: temp_ad0
5584  REAL :: temp_ad1
5585  REAL :: temp_ad2
5586  REAL :: temp_ad3
5587  REAL :: temp9
5588  REAL :: temp10
5589  REAL :: temp11
5590  REAL :: temp12
5591  REAL :: temp13
5592  REAL :: temp14
5593  REAL :: temp15
5594  REAL :: temp16
5595  REAL :: temp17
5596  REAL :: temp18
5597  REAL :: temp_ad4
5598  REAL :: temp_ad5
5599  REAL :: temp_ad6
5600  REAL :: temp_ad7
5601  REAL :: temp_ad8
5602  INTEGER :: branch
5603 
5604  wk1 = 0.0
5605  wk = 0.0
5606  du1 = 0.0
5607  dv1 = 0.0
5608  top_value = 0.0
5609  is = 0
5610  ie = 0
5611  js = 0
5612  je = 0
5613  isd = 0
5614  ied = 0
5615  jsd = 0
5616  jed = 0
5617  branch = 0
5618 
5619  CALL popinteger(js)
5620  CALL poprealarray(wk1, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
5621  CALL popinteger(jsd)
5622  CALL popinteger(ied)
5623  CALL popinteger(ie)
5624  CALL popinteger(isd)
5625  CALL popinteger(is)
5626  CALL popinteger(je)
5627  CALL poprealarray(wk, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
5628  CALL popinteger(jed)
5629  wk1_ad = 0.0
5630  wk_ad = 0.0
5631  DO k=npz,1,-1
5632  DO j=je,js,-1
5633  DO i=ie+1,is,-1
5634  CALL poprealarray(v(i, j, k))
5635  temp14 = wk1(i, j) + wk1(i, j+1)
5636  temp18 = pp(i, j, k+1) - pp(i, j+1, k)
5637  temp17 = gz(i, j, k) - gz(i, j+1, k+1)
5638  temp16 = pp(i, j+1, k+1) - pp(i, j, k)
5639  temp15 = gz(i, j, k+1) - gz(i, j+1, k)
5640  temp_ad4 = gridstruct%rdy(i, j)*v_ad(i, j, k)
5641  temp_ad5 = dt*temp_ad4/temp14
5642  temp_ad6 = -((temp15*temp16+temp17*temp18)*temp_ad5/temp14)
5643  dv1_ad = temp_ad4
5644  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp16*temp_ad5
5645  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp16*temp_ad5
5646  pp_ad(i, j+1, k+1) = pp_ad(i, j+1, k+1) + temp15*temp_ad5
5647  pp_ad(i, j, k) = pp_ad(i, j, k) - temp15*temp_ad5
5648  gz_ad(i, j, k) = gz_ad(i, j, k) + temp18*temp_ad5
5649  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp18*temp_ad5
5650  pp_ad(i, j, k+1) = pp_ad(i, j, k+1) + temp17*temp_ad5
5651  pp_ad(i, j+1, k) = pp_ad(i, j+1, k) - temp17*temp_ad5
5652  wk1_ad(i, j) = wk1_ad(i, j) + temp_ad6
5653  wk1_ad(i, j+1) = wk1_ad(i, j+1) + temp_ad6
5654  v_ad(i, j, k) = temp_ad4
5655  temp9 = wk(i, j) + wk(i, j+1)
5656  temp13 = pk(i, j, k+1) - pk(i, j+1, k)
5657  temp12 = gz(i, j, k) - gz(i, j+1, k+1)
5658  temp11 = pk(i, j+1, k+1) - pk(i, j, k)
5659  temp10 = gz(i, j, k+1) - gz(i, j+1, k)
5660  temp_ad7 = dt*dv1_ad/temp9
5661  temp_ad8 = -((temp10*temp11+temp12*temp13)*temp_ad7/temp9)
5662  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp11*temp_ad7
5663  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp11*temp_ad7
5664  pk_ad(i, j+1, k+1) = pk_ad(i, j+1, k+1) + temp10*temp_ad7
5665  pk_ad(i, j, k) = pk_ad(i, j, k) - temp10*temp_ad7
5666  gz_ad(i, j, k) = gz_ad(i, j, k) + temp13*temp_ad7
5667  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp13*temp_ad7
5668  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp12*temp_ad7
5669  pk_ad(i, j+1, k) = pk_ad(i, j+1, k) - temp12*temp_ad7
5670  wk_ad(i, j) = wk_ad(i, j) + temp_ad8
5671  wk_ad(i, j+1) = wk_ad(i, j+1) + temp_ad8
5672  END DO
5673  END DO
5674  DO j=je+1,js,-1
5675  DO i=ie,is,-1
5676  CALL poprealarray(u(i, j, k))
5677  temp4 = wk1(i, j) + wk1(i+1, j)
5678  temp8 = pp(i, j, k+1) - pp(i+1, j, k)
5679  temp7 = gz(i, j, k) - gz(i+1, j, k+1)
5680  temp6 = pp(i+1, j, k+1) - pp(i, j, k)
5681  temp5 = gz(i, j, k+1) - gz(i+1, j, k)
5682  temp_ad = gridstruct%rdx(i, j)*u_ad(i, j, k)
5683  temp_ad0 = dt*temp_ad/temp4
5684  temp_ad1 = -((temp5*temp6+temp7*temp8)*temp_ad0/temp4)
5685  du1_ad = temp_ad
5686  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp6*temp_ad0
5687  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp6*temp_ad0
5688  pp_ad(i+1, j, k+1) = pp_ad(i+1, j, k+1) + temp5*temp_ad0
5689  pp_ad(i, j, k) = pp_ad(i, j, k) - temp5*temp_ad0
5690  gz_ad(i, j, k) = gz_ad(i, j, k) + temp8*temp_ad0
5691  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp8*temp_ad0
5692  pp_ad(i, j, k+1) = pp_ad(i, j, k+1) + temp7*temp_ad0
5693  pp_ad(i+1, j, k) = pp_ad(i+1, j, k) - temp7*temp_ad0
5694  wk1_ad(i, j) = wk1_ad(i, j) + temp_ad1
5695  wk1_ad(i+1, j) = wk1_ad(i+1, j) + temp_ad1
5696  u_ad(i, j, k) = temp_ad
5697  temp = wk(i, j) + wk(i+1, j)
5698  temp3 = pk(i, j, k+1) - pk(i+1, j, k)
5699  temp2 = gz(i, j, k) - gz(i+1, j, k+1)
5700  temp1 = pk(i+1, j, k+1) - pk(i, j, k)
5701  temp0 = gz(i, j, k+1) - gz(i+1, j, k)
5702  temp_ad2 = dt*du1_ad/temp
5703  temp_ad3 = -((temp0*temp1+temp2*temp3)*temp_ad2/temp)
5704  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp1*temp_ad2
5705  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp1*temp_ad2
5706  pk_ad(i+1, j, k+1) = pk_ad(i+1, j, k+1) + temp0*temp_ad2
5707  pk_ad(i, j, k) = pk_ad(i, j, k) - temp0*temp_ad2
5708  gz_ad(i, j, k) = gz_ad(i, j, k) + temp3*temp_ad2
5709  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp3*temp_ad2
5710  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp2*temp_ad2
5711  pk_ad(i+1, j, k) = pk_ad(i+1, j, k) - temp2*temp_ad2
5712  wk_ad(i, j) = wk_ad(i, j) + temp_ad3
5713  wk_ad(i+1, j) = wk_ad(i+1, j) + temp_ad3
5714  END DO
5715  END DO
5716  DO j=je+1,js,-1
5717  DO i=ie+1,is,-1
5718  CALL poprealarray(wk(i, j))
5719  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + wk_ad(i, j)
5720  pk_ad(i, j, k) = pk_ad(i, j, k) - wk_ad(i, j)
5721  wk_ad(i, j) = 0.0
5722  END DO
5723  END DO
5724  CALL a2b_ord4_bwd(delp(isd:ied, jsd:jed, k), delp_ad(isd:ied, &
5725 & jsd:jed, k), wk1, wk1_ad, gridstruct, npx, npy, is&
5726 & , ie, js, je, ng)
5727  END DO
5728  DO k=npz+1,1,-1
5729  CALL a2b_ord4_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd:&
5730 & jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, ie&
5731 & , js, je, ng, .true.)
5732  CALL popcontrol(1,branch)
5733  IF (branch .EQ. 0) THEN
5734  CALL a2b_ord4_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd&
5735 & :jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, &
5736 & ie, js, je, ng, .true.)
5737  CALL a2b_ord4_bwd(pp(isd:ied, jsd:jed, k), pp_ad(isd:ied, jsd&
5738 & :jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, &
5739 & ie, js, je, ng, .true.)
5740  END IF
5741  END DO
5742  DO j=je+1,js,-1
5743  DO i=ie+1,is,-1
5744  CALL poprealarray(pk(i, j, 1))
5745  pk_ad(i, j, 1) = 0.0
5746  CALL poprealarray(pp(i, j, 1))
5747  pp_ad(i, j, 1) = 0.0
5748  END DO
5749  END DO
5750  END SUBROUTINE nh_p_grad_bwd
5751  SUBROUTINE nh_p_grad(u, v, pp, gz, delp, pk, dt, ng, gridstruct, bd, &
5752 & npx, npy, npz, use_logp)
5753  IMPLICIT NONE
5754 ! end k-loop
5755  INTEGER, INTENT(IN) :: ng, npx, npy, npz
5756  REAL, INTENT(IN) :: dt
5757  LOGICAL, INTENT(IN) :: use_logp
5758  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5759  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
5760 ! perturbation pressure
5761  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5762 ! p**kappa
5763  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5764 ! g * h
5765  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5766  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5767  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5768  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
5769 ! Local:
5770  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
5771  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
5772  REAL :: du1, dv1, top_value
5773  INTEGER :: i, j, k
5774  INTEGER :: is, ie, js, je
5775  INTEGER :: isd, ied, jsd, jed
5776  is = bd%is
5777  ie = bd%ie
5778  js = bd%js
5779  je = bd%je
5780  isd = bd%isd
5781  ied = bd%ied
5782  jsd = bd%jsd
5783  jed = bd%jed
5784  IF (use_logp) THEN
5785  top_value = peln1
5786  ELSE
5787  top_value = ptk
5788  END IF
5789 !Remember that not all compilers set pp to zero by default
5790 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
5791  DO j=js,je+1
5792  DO i=is,ie+1
5793  pp(i, j, 1) = 0.
5794  pk(i, j, 1) = top_value
5795  END DO
5796  END DO
5797 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
5798 !$OMP private(wk1)
5799  DO k=1,npz+1
5800  IF (k .NE. 1) THEN
5801  CALL a2b_ord4(pp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
5802 & npy, is, ie, js, je, ng, .true.)
5803  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
5804 & npy, is, ie, js, je, ng, .true.)
5805  END IF
5806  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
5807 & npy, is, ie, js, je, ng, .true.)
5808  END DO
5809 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,gridstruct,npx,npy,ng,isd,jsd, &
5810 !$OMP pk,dt,gz,u,pp,v) &
5811 !$OMP private(wk1, wk, du1, dv1)
5812  DO k=1,npz
5813  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
5814 & npy, is, ie, js, je, ng)
5815  DO j=js,je+1
5816  DO i=is,ie+1
5817  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
5818  END DO
5819  END DO
5820  DO j=js,je+1
5821  DO i=is,ie
5822 ! hydrostatic contributions from past time-step already added in the "beta" part
5823 ! Current gradient from "hydrostatic" components:
5824  du1 = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
5825 & (pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
5826 & (pk(i, j, k+1)-pk(i+1, j, k)))
5827 ! Non-hydrostatic contribution
5828  u(i, j, k) = (u(i, j, k)+du1+dt/(wk1(i, j)+wk1(i+1, j))*((gz(i&
5829 & , j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, j, k))+(gz(i&
5830 & , j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k))))*&
5831 & gridstruct%rdx(i, j)
5832  END DO
5833  END DO
5834  DO j=js,je
5835  DO i=is,ie+1
5836 ! Current gradient from "hydrostatic" components:
5837  dv1 = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
5838 & (pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
5839 & (pk(i, j, k+1)-pk(i, j+1, k)))
5840 ! Non-hydrostatic contribution
5841  v(i, j, k) = (v(i, j, k)+dv1+dt/(wk1(i, j)+wk1(i, j+1))*((gz(i&
5842 & , j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, j, k))+(gz(i&
5843 & , j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k))))*&
5844 & gridstruct%rdy(i, j)
5845  END DO
5846  END DO
5847  END DO
5848  END SUBROUTINE nh_p_grad
5849 ! Differentiation of split_p_grad in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
5850 !_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
5851 !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
5852 !.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
5853 !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
5854 !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.
5855 !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
5856 ! 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
5857 !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
5858 !_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
5859 !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
5860 !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_
5861 !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
5862 !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.
5863 !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_
5864 !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
5865 !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
5866 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
5867 ! gradient of useful results: gz du u dv v delp pk pp
5868 ! with respect to varying inputs: gz du u dv v delp pk pp
5869  SUBROUTINE split_p_grad_fwd(u, v, pp, gz, du, dv, delp, pk, beta, dt, &
5870 & ng, gridstruct, bd, npx, npy, npz, use_logp)
5871  IMPLICIT NONE
5872 ! end k-loop
5873  INTEGER, INTENT(IN) :: ng, npx, npy, npz
5874  REAL, INTENT(IN) :: beta, dt
5875  LOGICAL, INTENT(IN) :: use_logp
5876  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
5877  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
5878 ! perturbation pressure
5879  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5880 ! p**kappa
5881  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5882 ! g * h
5883  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
5884  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5885  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5886  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5887  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5888  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
5889 ! Local:
5890  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
5891  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
5892  REAL :: alpha, top_value
5893  INTEGER :: i, j, k
5894  INTEGER :: is, ie, js, je
5895  INTEGER :: isd, ied, jsd, jed
5896 
5897  wk1 = 0.0
5898  wk = 0.0
5899  alpha = 0.0
5900  top_value = 0.0
5901  is = 0
5902  ie = 0
5903  js = 0
5904  je = 0
5905  isd = 0
5906  ied = 0
5907  jsd = 0
5908  jed = 0
5909 
5910  is = bd%is
5911  ie = bd%ie
5912  js = bd%js
5913  je = bd%je
5914  isd = bd%isd
5915  ied = bd%ied
5916  jsd = bd%jsd
5917  jed = bd%jed
5918  IF (use_logp) THEN
5919  top_value = peln1
5920  ELSE
5921  top_value = ptk
5922  END IF
5923  alpha = 1. - beta
5924 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
5925  DO j=js,je+1
5926  DO i=is,ie+1
5927  CALL pushrealarray(pp(i, j, 1))
5928  pp(i, j, 1) = 0.
5929  CALL pushrealarray(pk(i, j, 1))
5930  pk(i, j, 1) = top_value
5931  END DO
5932  END DO
5933 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
5934 !$OMP private(wk1)
5935  DO k=1,npz+1
5936  IF (k .NE. 1) THEN
5937  CALL a2b_ord4_fwd(pp(isd:ied, jsd:jed, k), wk1, gridstruct, &
5938 & npx, npy, is, ie, js, je, ng, .true.)
5939  CALL a2b_ord4_fwd(pk(isd:ied, jsd:jed, k), wk1, gridstruct, &
5940 & npx, npy, is, ie, js, je, ng, .true.)
5941  CALL pushcontrol(1,0)
5942  ELSE
5943  CALL pushcontrol(1,1)
5944  END IF
5945  CALL a2b_ord4_fwd(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx&
5946 & , npy, is, ie, js, je, ng, .true.)
5947  END DO
5948 !$OMP parallel do default(none) shared(is,ie,js,je,isd,jsd,npz,delp,gridstruct,npx,npy,ng, &
5949 !$OMP pk,u,beta,du,dt,gz,alpha,pp,v,dv) &
5950 !$OMP private(wk1, wk)
5951  DO k=1,npz
5952  CALL a2b_ord4_fwd(delp(isd:ied, jsd:jed, k), wk1, gridstruct, &
5953 & npx, npy, is, ie, js, je, ng)
5954  DO j=js,je+1
5955  DO i=is,ie+1
5956  CALL pushrealarray(wk(i, j))
5957  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
5958  END DO
5959  END DO
5960  DO j=js,je+1
5961  DO i=is,ie
5962  CALL pushrealarray(u(i, j, k))
5963  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
5964 ! hydrostatic contributions from past time-step already added in the "beta" part
5965 ! Current gradient from "hydrostatic" components:
5966 !---------------------------------------------------------------------------------
5967  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
5968 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
5969 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
5970 !---------------------------------------------------------------------------------
5971 ! Non-hydrostatic contribution
5972  u(i, j, k) = (u(i, j, k)+alpha*du(i, j, k)+dt/(wk1(i, j)+wk1(i&
5973 & +1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i&
5974 & , j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1&
5975 & , j, k))))*gridstruct%rdx(i, j)
5976  END DO
5977  END DO
5978  DO j=js,je
5979  DO i=is,ie+1
5980  CALL pushrealarray(v(i, j, k))
5981  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
5982 ! Current gradient from "hydrostatic" components:
5983 !---------------------------------------------------------------------------------
5984  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
5985 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
5986 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
5987 !---------------------------------------------------------------------------------
5988 ! Non-hydrostatic contribution
5989  v(i, j, k) = (v(i, j, k)+alpha*dv(i, j, k)+dt/(wk1(i, j)+wk1(i&
5990 & , j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i&
5991 & , j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, &
5992 & j+1, k))))*gridstruct%rdy(i, j)
5993  END DO
5994  END DO
5995  END DO
5996  CALL pushinteger(jed)
5997  CALL pushrealarray(wk, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
5998  CALL pushinteger(je)
5999  CALL pushinteger(is)
6000  CALL pushinteger(isd)
6001  CALL pushinteger(ie)
6002  CALL pushinteger(ied)
6003  CALL pushinteger(jsd)
6004  CALL pushrealarray(wk1, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
6005  CALL pushrealarray(alpha)
6006  CALL pushinteger(js)
6007  END SUBROUTINE split_p_grad_fwd
6008 ! Differentiation of split_p_grad in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edg
6009 !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
6010 !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
6011 !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
6012 !igh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_
6013 !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
6014 !.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
6015 !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
6016 !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
6017 !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
6018 !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
6019 !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
6020 !_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_
6021 !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
6022 !.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
6023 !_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
6024 !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
6025 !ils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6026 ! gradient of useful results: gz du u dv v delp pk pp
6027 ! with respect to varying inputs: gz du u dv v delp pk pp
6028  SUBROUTINE split_p_grad_bwd(u, u_ad, v, v_ad, pp, pp_ad, gz, gz_ad, du&
6029 & , du_ad, dv, dv_ad, delp, delp_ad, pk, pk_ad, beta, dt, ng, &
6030 & gridstruct, bd, npx, npy, npz, use_logp)
6031  IMPLICIT NONE
6032 ! end k-loop
6033  INTEGER, INTENT(IN) :: ng, npx, npy, npz
6034  REAL, INTENT(IN) :: beta, dt
6035  LOGICAL, INTENT(IN) :: use_logp
6036  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6037  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6038  REAL, INTENT(INOUT) :: delp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6039  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6040  REAL, INTENT(INOUT) :: pp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6041  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6042  REAL, INTENT(INOUT) :: pk_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6043  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6044  REAL, INTENT(INOUT) :: gz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6045  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6046  REAL, INTENT(INOUT) :: du_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6047  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6048  REAL, INTENT(INOUT) :: dv_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6049  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6050  REAL, INTENT(INOUT) :: u_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6051  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6052  REAL, INTENT(INOUT) :: v_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6053  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6054  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
6055  REAL :: wk1_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
6056  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
6057  REAL :: wk_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
6058  REAL :: alpha, top_value
6059  INTEGER :: i, j, k
6060  INTEGER :: is, ie, js, je
6061  INTEGER :: isd, ied, jsd, jed
6062  REAL :: temp
6063  REAL :: temp0
6064  REAL :: temp1
6065  REAL :: temp2
6066  REAL :: temp3
6067  REAL :: temp4
6068  REAL :: temp5
6069  REAL :: temp6
6070  REAL :: temp7
6071  REAL :: temp8
6072  REAL :: temp_ad
6073  REAL :: temp_ad0
6074  REAL :: temp_ad1
6075  REAL :: temp_ad2
6076  REAL :: temp_ad3
6077  REAL :: temp9
6078  REAL :: temp10
6079  REAL :: temp11
6080  REAL :: temp12
6081  REAL :: temp13
6082  REAL :: temp14
6083  REAL :: temp15
6084  REAL :: temp16
6085  REAL :: temp17
6086  REAL :: temp18
6087  REAL :: temp_ad4
6088  REAL :: temp_ad5
6089  REAL :: temp_ad6
6090  REAL :: temp_ad7
6091  REAL :: temp_ad8
6092  INTEGER :: branch
6093 
6094  wk1 = 0.0
6095  wk = 0.0
6096  alpha = 0.0
6097  top_value = 0.0
6098  is = 0
6099  ie = 0
6100  js = 0
6101  je = 0
6102  isd = 0
6103  ied = 0
6104  jsd = 0
6105  jed = 0
6106  branch = 0
6107 
6108  CALL popinteger(js)
6109  CALL poprealarray(alpha)
6110  CALL poprealarray(wk1, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
6111  CALL popinteger(jsd)
6112  CALL popinteger(ied)
6113  CALL popinteger(ie)
6114  CALL popinteger(isd)
6115  CALL popinteger(is)
6116  CALL popinteger(je)
6117  CALL poprealarray(wk, (bd%ie-bd%is+2)*(bd%je-bd%js+2))
6118  CALL popinteger(jed)
6119  wk1_ad = 0.0
6120  wk_ad = 0.0
6121  DO k=npz,1,-1
6122  DO j=je,js,-1
6123  DO i=ie+1,is,-1
6124  temp14 = wk1(i, j) + wk1(i, j+1)
6125  temp18 = pp(i, j, k+1) - pp(i, j+1, k)
6126  temp17 = gz(i, j, k) - gz(i, j+1, k+1)
6127  temp16 = pp(i, j+1, k+1) - pp(i, j, k)
6128  temp15 = gz(i, j, k+1) - gz(i, j+1, k)
6129  temp_ad4 = gridstruct%rdy(i, j)*v_ad(i, j, k)
6130  temp_ad5 = dt*temp_ad4/temp14
6131  temp_ad6 = -((temp15*temp16+temp17*temp18)*temp_ad5/temp14)
6132  dv_ad(i, j, k) = dv_ad(i, j, k) + alpha*temp_ad4
6133  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp16*temp_ad5
6134  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp16*temp_ad5
6135  pp_ad(i, j+1, k+1) = pp_ad(i, j+1, k+1) + temp15*temp_ad5
6136  pp_ad(i, j, k) = pp_ad(i, j, k) - temp15*temp_ad5
6137  gz_ad(i, j, k) = gz_ad(i, j, k) + temp18*temp_ad5
6138  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp18*temp_ad5
6139  pp_ad(i, j, k+1) = pp_ad(i, j, k+1) + temp17*temp_ad5
6140  pp_ad(i, j+1, k) = pp_ad(i, j+1, k) - temp17*temp_ad5
6141  wk1_ad(i, j) = wk1_ad(i, j) + temp_ad6
6142  wk1_ad(i, j+1) = wk1_ad(i, j+1) + temp_ad6
6143  v_ad(i, j, k) = temp_ad4
6144  temp9 = wk(i, j) + wk(i, j+1)
6145  temp13 = pk(i, j, k+1) - pk(i, j+1, k)
6146  temp12 = gz(i, j, k) - gz(i, j+1, k+1)
6147  temp11 = pk(i, j+1, k+1) - pk(i, j, k)
6148  temp10 = gz(i, j, k+1) - gz(i, j+1, k)
6149  temp_ad7 = dt*dv_ad(i, j, k)/temp9
6150  temp_ad8 = -((temp10*temp11+temp12*temp13)*temp_ad7/temp9)
6151  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp11*temp_ad7
6152  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp11*temp_ad7
6153  pk_ad(i, j+1, k+1) = pk_ad(i, j+1, k+1) + temp10*temp_ad7
6154  pk_ad(i, j, k) = pk_ad(i, j, k) - temp10*temp_ad7
6155  gz_ad(i, j, k) = gz_ad(i, j, k) + temp13*temp_ad7
6156  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp13*temp_ad7
6157  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp12*temp_ad7
6158  pk_ad(i, j+1, k) = pk_ad(i, j+1, k) - temp12*temp_ad7
6159  wk_ad(i, j) = wk_ad(i, j) + temp_ad8
6160  wk_ad(i, j+1) = wk_ad(i, j+1) + temp_ad8
6161  dv_ad(i, j, k) = beta*v_ad(i, j, k)
6162  CALL poprealarray(v(i, j, k))
6163  END DO
6164  END DO
6165  DO j=je+1,js,-1
6166  DO i=ie,is,-1
6167  temp4 = wk1(i, j) + wk1(i+1, j)
6168  temp8 = pp(i, j, k+1) - pp(i+1, j, k)
6169  temp7 = gz(i, j, k) - gz(i+1, j, k+1)
6170  temp6 = pp(i+1, j, k+1) - pp(i, j, k)
6171  temp5 = gz(i, j, k+1) - gz(i+1, j, k)
6172  temp_ad = gridstruct%rdx(i, j)*u_ad(i, j, k)
6173  temp_ad0 = dt*temp_ad/temp4
6174  temp_ad1 = -((temp5*temp6+temp7*temp8)*temp_ad0/temp4)
6175  du_ad(i, j, k) = du_ad(i, j, k) + alpha*temp_ad
6176  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp6*temp_ad0
6177  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp6*temp_ad0
6178  pp_ad(i+1, j, k+1) = pp_ad(i+1, j, k+1) + temp5*temp_ad0
6179  pp_ad(i, j, k) = pp_ad(i, j, k) - temp5*temp_ad0
6180  gz_ad(i, j, k) = gz_ad(i, j, k) + temp8*temp_ad0
6181  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp8*temp_ad0
6182  pp_ad(i, j, k+1) = pp_ad(i, j, k+1) + temp7*temp_ad0
6183  pp_ad(i+1, j, k) = pp_ad(i+1, j, k) - temp7*temp_ad0
6184  wk1_ad(i, j) = wk1_ad(i, j) + temp_ad1
6185  wk1_ad(i+1, j) = wk1_ad(i+1, j) + temp_ad1
6186  u_ad(i, j, k) = temp_ad
6187  temp = wk(i, j) + wk(i+1, j)
6188  temp3 = pk(i, j, k+1) - pk(i+1, j, k)
6189  temp2 = gz(i, j, k) - gz(i+1, j, k+1)
6190  temp1 = pk(i+1, j, k+1) - pk(i, j, k)
6191  temp0 = gz(i, j, k+1) - gz(i+1, j, k)
6192  temp_ad2 = dt*du_ad(i, j, k)/temp
6193  temp_ad3 = -((temp0*temp1+temp2*temp3)*temp_ad2/temp)
6194  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp1*temp_ad2
6195  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp1*temp_ad2
6196  pk_ad(i+1, j, k+1) = pk_ad(i+1, j, k+1) + temp0*temp_ad2
6197  pk_ad(i, j, k) = pk_ad(i, j, k) - temp0*temp_ad2
6198  gz_ad(i, j, k) = gz_ad(i, j, k) + temp3*temp_ad2
6199  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp3*temp_ad2
6200  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp2*temp_ad2
6201  pk_ad(i+1, j, k) = pk_ad(i+1, j, k) - temp2*temp_ad2
6202  wk_ad(i, j) = wk_ad(i, j) + temp_ad3
6203  wk_ad(i+1, j) = wk_ad(i+1, j) + temp_ad3
6204  du_ad(i, j, k) = beta*u_ad(i, j, k)
6205  CALL poprealarray(u(i, j, k))
6206  END DO
6207  END DO
6208  DO j=je+1,js,-1
6209  DO i=ie+1,is,-1
6210  CALL poprealarray(wk(i, j))
6211  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + wk_ad(i, j)
6212  pk_ad(i, j, k) = pk_ad(i, j, k) - wk_ad(i, j)
6213  wk_ad(i, j) = 0.0
6214  END DO
6215  END DO
6216  CALL a2b_ord4_bwd(delp(isd:ied, jsd:jed, k), delp_ad(isd:ied, &
6217 & jsd:jed, k), wk1, wk1_ad, gridstruct, npx, npy, is&
6218 & , ie, js, je, ng)
6219  END DO
6220  DO k=npz+1,1,-1
6221  CALL a2b_ord4_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd:&
6222 & jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, ie&
6223 & , js, je, ng, .true.)
6224  CALL popcontrol(1,branch)
6225  IF (branch .EQ. 0) THEN
6226  CALL a2b_ord4_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd&
6227 & :jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, &
6228 & ie, js, je, ng, .true.)
6229  CALL a2b_ord4_bwd(pp(isd:ied, jsd:jed, k), pp_ad(isd:ied, jsd&
6230 & :jed, k), wk1, wk1_ad, gridstruct, npx, npy, is, &
6231 & ie, js, je, ng, .true.)
6232  END IF
6233  END DO
6234  DO j=je+1,js,-1
6235  DO i=ie+1,is,-1
6236  CALL poprealarray(pk(i, j, 1))
6237  pk_ad(i, j, 1) = 0.0
6238  CALL poprealarray(pp(i, j, 1))
6239  pp_ad(i, j, 1) = 0.0
6240  END DO
6241  END DO
6242  END SUBROUTINE split_p_grad_bwd
6243  SUBROUTINE split_p_grad(u, v, pp, gz, du, dv, delp, pk, beta, dt, ng, &
6244 & gridstruct, bd, npx, npy, npz, use_logp)
6245  IMPLICIT NONE
6246 ! end k-loop
6247  INTEGER, INTENT(IN) :: ng, npx, npy, npz
6248  REAL, INTENT(IN) :: beta, dt
6249  LOGICAL, INTENT(IN) :: use_logp
6250  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6251  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6252 ! perturbation pressure
6253  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6254 ! p**kappa
6255  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6256 ! g * h
6257  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6258  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6259  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6260  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6261  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6262  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6263 ! Local:
6264  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
6265  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
6266  REAL :: alpha, top_value
6267  INTEGER :: i, j, k
6268  INTEGER :: is, ie, js, je
6269  INTEGER :: isd, ied, jsd, jed
6270  is = bd%is
6271  ie = bd%ie
6272  js = bd%js
6273  je = bd%je
6274  isd = bd%isd
6275  ied = bd%ied
6276  jsd = bd%jsd
6277  jed = bd%jed
6278  IF (use_logp) THEN
6279  top_value = peln1
6280  ELSE
6281  top_value = ptk
6282  END IF
6283  alpha = 1. - beta
6284 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
6285  DO j=js,je+1
6286  DO i=is,ie+1
6287  pp(i, j, 1) = 0.
6288  pk(i, j, 1) = top_value
6289  END DO
6290  END DO
6291 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
6292 !$OMP private(wk1)
6293  DO k=1,npz+1
6294  IF (k .NE. 1) THEN
6295  CALL a2b_ord4(pp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
6296 & npy, is, ie, js, je, ng, .true.)
6297  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
6298 & npy, is, ie, js, je, ng, .true.)
6299  END IF
6300  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
6301 & npy, is, ie, js, je, ng, .true.)
6302  END DO
6303 !$OMP parallel do default(none) shared(is,ie,js,je,isd,jsd,npz,delp,gridstruct,npx,npy,ng, &
6304 !$OMP pk,u,beta,du,dt,gz,alpha,pp,v,dv) &
6305 !$OMP private(wk1, wk)
6306  DO k=1,npz
6307  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
6308 & npy, is, ie, js, je, ng)
6309  DO j=js,je+1
6310  DO i=is,ie+1
6311  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
6312  END DO
6313  END DO
6314  DO j=js,je+1
6315  DO i=is,ie
6316  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
6317 ! hydrostatic contributions from past time-step already added in the "beta" part
6318 ! Current gradient from "hydrostatic" components:
6319 !---------------------------------------------------------------------------------
6320  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
6321 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
6322 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
6323 !---------------------------------------------------------------------------------
6324 ! Non-hydrostatic contribution
6325  u(i, j, k) = (u(i, j, k)+alpha*du(i, j, k)+dt/(wk1(i, j)+wk1(i&
6326 & +1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i&
6327 & , j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1&
6328 & , j, k))))*gridstruct%rdx(i, j)
6329  END DO
6330  END DO
6331  DO j=js,je
6332  DO i=is,ie+1
6333  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
6334 ! Current gradient from "hydrostatic" components:
6335 !---------------------------------------------------------------------------------
6336  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
6337 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
6338 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
6339 !---------------------------------------------------------------------------------
6340 ! Non-hydrostatic contribution
6341  v(i, j, k) = (v(i, j, k)+alpha*dv(i, j, k)+dt/(wk1(i, j)+wk1(i&
6342 & , j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i&
6343 & , j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, &
6344 & j+1, k))))*gridstruct%rdy(i, j)
6345  END DO
6346  END DO
6347  END DO
6348  END SUBROUTINE split_p_grad
6349 ! Differentiation of one_grad_p in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
6350 !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_
6351 !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
6352 !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
6353 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
6354 !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
6355 !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
6356 !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
6357 !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
6358 !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
6359 !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_
6360 !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
6361 !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
6362 !.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
6363 !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_
6364 !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_
6365 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
6366 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6367 ! gradient of useful results: gz u v delp pk divg2
6368 ! with respect to varying inputs: gz u v delp pk divg2
6369  SUBROUTINE one_grad_p_fwd(u, v, pk, gz, divg2, delp, dt, ng, &
6370 & gridstruct, bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
6371  IMPLICIT NONE
6372 ! end k-loop
6373  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
6374  REAL, INTENT(IN) :: dt, ptop, d_ext
6375  LOGICAL, INTENT(IN) :: hydrostatic
6376  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6377  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
6378  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6379  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6380  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6381  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6382  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6383  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6384 ! Local:
6385  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk
6386  REAL :: wk1(bd%is:bd%ie+1, bd%js:bd%je+1)
6387  REAL :: wk2(bd%is:bd%ie, bd%js:bd%je+1)
6388  REAL :: top_value
6389  INTEGER :: i, j, k
6390  INTEGER :: is, ie, js, je
6391  INTEGER :: isd, ied, jsd, jed
6392 
6393  wk = 0.0
6394  wk1 = 0.0
6395  wk2 = 0.0
6396  top_value = 0.0
6397  is = 0
6398  ie = 0
6399  js = 0
6400  je = 0
6401  isd = 0
6402  ied = 0
6403  jsd = 0
6404  jed = 0
6405 
6406  is = bd%is
6407  ie = bd%ie
6408  js = bd%js
6409  je = bd%je
6410  isd = bd%isd
6411  ied = bd%ied
6412  jsd = bd%jsd
6413  jed = bd%jed
6414  IF (hydrostatic) THEN
6415 ! pk is pe**kappa if hydrostatic
6416  top_value = ptk
6417  ELSE
6418 ! pk is full pressure if non-hydrostatic
6419  top_value = ptop
6420  END IF
6421 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
6422  DO j=js,je+1
6423  DO i=is,ie+1
6424  CALL pushrealarray(pk(i, j, 1))
6425  pk(i, j, 1) = top_value
6426  END DO
6427  END DO
6428 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6429 !$OMP private(wk)
6430  DO k=2,npz+1
6431  IF (a2b_ord .EQ. 4) THEN
6432  CALL a2b_ord4_fwd(pk(isd:ied, jsd:jed, k), wk, gridstruct, &
6433 & npx, npy, is, ie, js, je, ng, .true.)
6434  CALL pushcontrol(1,1)
6435  ELSE
6436  CALL a2b_ord2_fwd(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6437 & npy, is, ie, js, je, ng, .true.)
6438  CALL pushcontrol(1,0)
6439  END IF
6440  END DO
6441 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6442 !$OMP private(wk)
6443  DO k=1,npz+1
6444  IF (a2b_ord .EQ. 4) THEN
6445  CALL a2b_ord4_fwd(gz(isd:ied, jsd:jed, k), wk, gridstruct, &
6446 & npx, npy, is, ie, js, je, ng, .true.)
6447  CALL pushcontrol(1,1)
6448  ELSE
6449  CALL a2b_ord2_fwd(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6450 & npy, is, ie, js, je, ng, .true.)
6451  CALL pushcontrol(1,0)
6452  END IF
6453  END DO
6454  IF (d_ext .GT. 0.) THEN
6455 !$OMP parallel do default(none) shared(is,ie,js,je,wk2,divg2)
6456  DO j=js,je+1
6457  DO i=is,ie
6458  wk2(i, j) = divg2(i, j) - divg2(i+1, j)
6459  END DO
6460  END DO
6461 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,divg2)
6462  DO j=js,je
6463  DO i=is,ie+1
6464  wk1(i, j) = divg2(i, j) - divg2(i, j+1)
6465  END DO
6466  END DO
6467  CALL pushcontrol(1,1)
6468  ELSE
6469  CALL pushcontrol(1,0)
6470 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,wk2)
6471  DO j=js,je+1
6472  DO i=is,ie
6473  wk2(i, j) = 0.
6474  END DO
6475  DO i=is,ie+1
6476  wk1(i, j) = 0.
6477  END DO
6478  END DO
6479  END IF
6480 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,a2b_ord,gridstruct, &
6481 !$OMP npx,npy,isd,jsd,ng,u,v,wk2,dt,gz,wk1) &
6482 !$OMP private(wk)
6483  DO k=1,npz
6484  IF (hydrostatic) THEN
6485  DO j=js,je+1
6486  DO i=is,ie+1
6487  CALL pushrealarray(wk(i, j))
6488  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
6489  END DO
6490  END DO
6491  CALL pushcontrol(2,2)
6492  ELSE IF (a2b_ord .EQ. 4) THEN
6493  CALL a2b_ord4_fwd(delp(isd:ied, jsd:jed, k), wk, gridstruct, &
6494 & npx, npy, is, ie, js, je, ng)
6495  CALL pushcontrol(2,1)
6496  ELSE
6497  CALL a2b_ord2_fwd(delp(isd:ied, jsd:jed, k), wk, gridstruct, npx&
6498 & , npy, is, ie, js, je, ng)
6499  CALL pushcontrol(2,0)
6500  END IF
6501  DO j=js,je+1
6502  DO i=is,ie
6503  CALL pushrealarray(u(i, j, k))
6504  u(i, j, k) = gridstruct%rdx(i, j)*(wk2(i, j)+u(i, j, k)+dt/(wk&
6505 & (i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pk(i+1, j&
6506 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pk(i, j, &
6507 & k+1)-pk(i+1, j, k))))
6508  END DO
6509  END DO
6510  DO j=js,je
6511  DO i=is,ie+1
6512  CALL pushrealarray(v(i, j, k))
6513  v(i, j, k) = gridstruct%rdy(i, j)*(wk1(i, j)+v(i, j, k)+dt/(wk&
6514 & (i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pk(i, j+1&
6515 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pk(i, j, &
6516 & k+1)-pk(i, j+1, k))))
6517  END DO
6518  END DO
6519  END DO
6520  CALL pushinteger(jed)
6521  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
6522  CALL pushinteger(je)
6523  CALL pushinteger(is)
6524  CALL pushinteger(isd)
6525  CALL pushinteger(ie)
6526  CALL pushinteger(ied)
6527  CALL pushinteger(jsd)
6528  CALL pushinteger(js)
6529  END SUBROUTINE one_grad_p_fwd
6530 ! Differentiation of one_grad_p in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
6531 !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
6532 !_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.
6533 !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
6534 !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
6535 !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
6536 !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
6537 !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
6538 ! 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_
6539 !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
6540 !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
6541 !_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
6542 !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
6543 !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
6544 !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
6545 !_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
6546 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
6547 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6548 ! gradient of useful results: gz u v delp pk divg2
6549 ! with respect to varying inputs: gz u v delp pk divg2
6550  SUBROUTINE one_grad_p_bwd(u, u_ad, v, v_ad, pk, pk_ad, gz, gz_ad, &
6551 & divg2, divg2_ad, delp, delp_ad, dt, ng, gridstruct, bd, npx, npy, &
6552 & npz, ptop, hydrostatic, a2b_ord, d_ext)
6553  IMPLICIT NONE
6554 ! end k-loop
6555  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
6556  REAL, INTENT(IN) :: dt, ptop, d_ext
6557  LOGICAL, INTENT(IN) :: hydrostatic
6558  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6559  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
6560  REAL :: divg2_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
6561  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6562  REAL, INTENT(INOUT) :: pk_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6563  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6564  REAL, INTENT(INOUT) :: gz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6565  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6566  REAL, INTENT(INOUT) :: delp_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6567  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6568  REAL, INTENT(INOUT) :: u_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6569  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6570  REAL, INTENT(INOUT) :: v_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6571  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6572  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk
6573  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk_ad
6574  REAL :: wk1(bd%is:bd%ie+1, bd%js:bd%je+1)
6575  REAL :: wk1_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
6576  REAL :: wk2(bd%is:bd%ie, bd%js:bd%je+1)
6577  REAL :: wk2_ad(bd%is:bd%ie, bd%js:bd%je+1)
6578  REAL :: top_value
6579  INTEGER :: i, j, k
6580  INTEGER :: is, ie, js, je
6581  INTEGER :: isd, ied, jsd, jed
6582  REAL :: temp
6583  REAL :: temp0
6584  REAL :: temp1
6585  REAL :: temp2
6586  REAL :: temp3
6587  REAL :: temp_ad
6588  REAL :: temp_ad0
6589  REAL :: temp_ad1
6590  REAL :: temp4
6591  REAL :: temp5
6592  REAL :: temp6
6593  REAL :: temp7
6594  REAL :: temp8
6595  REAL :: temp_ad2
6596  REAL :: temp_ad3
6597  REAL :: temp_ad4
6598  INTEGER :: branch
6599 
6600  wk = 0.0
6601  wk1 = 0.0
6602  wk2 = 0.0
6603  top_value = 0.0
6604  is = 0
6605  ie = 0
6606  js = 0
6607  je = 0
6608  isd = 0
6609  ied = 0
6610  jsd = 0
6611  jed = 0
6612  branch = 0
6613 
6614  CALL popinteger(js)
6615  CALL popinteger(jsd)
6616  CALL popinteger(ied)
6617  CALL popinteger(ie)
6618  CALL popinteger(isd)
6619  CALL popinteger(is)
6620  CALL popinteger(je)
6621  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
6622  CALL popinteger(jed)
6623  wk1_ad = 0.0
6624  wk2_ad = 0.0
6625  wk_ad = 0.0
6626  DO k=npz,1,-1
6627  DO j=je,js,-1
6628  DO i=ie+1,is,-1
6629  CALL poprealarray(v(i, j, k))
6630  temp4 = wk(i, j) + wk(i, j+1)
6631  temp8 = pk(i, j, k+1) - pk(i, j+1, k)
6632  temp7 = gz(i, j, k) - gz(i, j+1, k+1)
6633  temp6 = pk(i, j+1, k+1) - pk(i, j, k)
6634  temp5 = gz(i, j, k+1) - gz(i, j+1, k)
6635  temp_ad2 = gridstruct%rdy(i, j)*v_ad(i, j, k)
6636  temp_ad3 = dt*temp_ad2/temp4
6637  temp_ad4 = -((temp5*temp6+temp7*temp8)*temp_ad3/temp4)
6638  wk1_ad(i, j) = wk1_ad(i, j) + temp_ad2
6639  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp6*temp_ad3
6640  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp6*temp_ad3
6641  pk_ad(i, j+1, k+1) = pk_ad(i, j+1, k+1) + temp5*temp_ad3
6642  pk_ad(i, j, k) = pk_ad(i, j, k) - temp5*temp_ad3
6643  gz_ad(i, j, k) = gz_ad(i, j, k) + temp8*temp_ad3
6644  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp8*temp_ad3
6645  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp7*temp_ad3
6646  pk_ad(i, j+1, k) = pk_ad(i, j+1, k) - temp7*temp_ad3
6647  wk_ad(i, j) = wk_ad(i, j) + temp_ad4
6648  wk_ad(i, j+1) = wk_ad(i, j+1) + temp_ad4
6649  v_ad(i, j, k) = temp_ad2
6650  END DO
6651  END DO
6652  DO j=je+1,js,-1
6653  DO i=ie,is,-1
6654  CALL poprealarray(u(i, j, k))
6655  temp = wk(i, j) + wk(i+1, j)
6656  temp3 = pk(i, j, k+1) - pk(i+1, j, k)
6657  temp2 = gz(i, j, k) - gz(i+1, j, k+1)
6658  temp1 = pk(i+1, j, k+1) - pk(i, j, k)
6659  temp0 = gz(i, j, k+1) - gz(i+1, j, k)
6660  temp_ad = gridstruct%rdx(i, j)*u_ad(i, j, k)
6661  temp_ad0 = dt*temp_ad/temp
6662  temp_ad1 = -((temp0*temp1+temp2*temp3)*temp_ad0/temp)
6663  wk2_ad(i, j) = wk2_ad(i, j) + temp_ad
6664  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp1*temp_ad0
6665  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp1*temp_ad0
6666  pk_ad(i+1, j, k+1) = pk_ad(i+1, j, k+1) + temp0*temp_ad0
6667  pk_ad(i, j, k) = pk_ad(i, j, k) - temp0*temp_ad0
6668  gz_ad(i, j, k) = gz_ad(i, j, k) + temp3*temp_ad0
6669  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp3*temp_ad0
6670  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp2*temp_ad0
6671  pk_ad(i+1, j, k) = pk_ad(i+1, j, k) - temp2*temp_ad0
6672  wk_ad(i, j) = wk_ad(i, j) + temp_ad1
6673  wk_ad(i+1, j) = wk_ad(i+1, j) + temp_ad1
6674  u_ad(i, j, k) = temp_ad
6675  END DO
6676  END DO
6677  CALL popcontrol(2,branch)
6678  IF (branch .EQ. 0) THEN
6679  CALL a2b_ord2_bwd(delp(isd:ied, jsd:jed, k), delp_ad(isd:ied, &
6680 & jsd:jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie&
6681 & , js, je, ng)
6682  ELSE IF (branch .EQ. 1) THEN
6683  CALL a2b_ord4_bwd(delp(isd:ied, jsd:jed, k), delp_ad(isd:ied&
6684 & , jsd:jed, k), wk, wk_ad, gridstruct, npx, npy, &
6685 & is, ie, js, je, ng)
6686  ELSE
6687  DO j=je+1,js,-1
6688  DO i=ie+1,is,-1
6689  CALL poprealarray(wk(i, j))
6690  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + wk_ad(i, j)
6691  pk_ad(i, j, k) = pk_ad(i, j, k) - wk_ad(i, j)
6692  wk_ad(i, j) = 0.0
6693  END DO
6694  END DO
6695  END IF
6696  END DO
6697  CALL popcontrol(1,branch)
6698  IF (branch .NE. 0) THEN
6699  DO j=je,js,-1
6700  DO i=ie+1,is,-1
6701  divg2_ad(i, j) = divg2_ad(i, j) + wk1_ad(i, j)
6702  divg2_ad(i, j+1) = divg2_ad(i, j+1) - wk1_ad(i, j)
6703  wk1_ad(i, j) = 0.0
6704  END DO
6705  END DO
6706  DO j=je+1,js,-1
6707  DO i=ie,is,-1
6708  divg2_ad(i, j) = divg2_ad(i, j) + wk2_ad(i, j)
6709  divg2_ad(i+1, j) = divg2_ad(i+1, j) - wk2_ad(i, j)
6710  wk2_ad(i, j) = 0.0
6711  END DO
6712  END DO
6713  END IF
6714  DO k=npz+1,1,-1
6715  CALL popcontrol(1,branch)
6716  IF (branch .EQ. 0) THEN
6717  CALL a2b_ord2_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd:&
6718 & jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie, js&
6719 & , je, ng, .true.)
6720  ELSE
6721  CALL a2b_ord4_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd&
6722 & :jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie&
6723 & , js, je, ng, .true.)
6724  END IF
6725  END DO
6726  DO k=npz+1,2,-1
6727  CALL popcontrol(1,branch)
6728  IF (branch .EQ. 0) THEN
6729  CALL a2b_ord2_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd:&
6730 & jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie, js&
6731 & , je, ng, .true.)
6732  ELSE
6733  CALL a2b_ord4_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd&
6734 & :jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie&
6735 & , js, je, ng, .true.)
6736  END IF
6737  END DO
6738  DO j=je+1,js,-1
6739  DO i=ie+1,is,-1
6740  CALL poprealarray(pk(i, j, 1))
6741  pk_ad(i, j, 1) = 0.0
6742  END DO
6743  END DO
6744  END SUBROUTINE one_grad_p_bwd
6745  SUBROUTINE one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, &
6746 & bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
6747  IMPLICIT NONE
6748 ! end k-loop
6749  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
6750  REAL, INTENT(IN) :: dt, ptop, d_ext
6751  LOGICAL, INTENT(IN) :: hydrostatic
6752  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6753  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
6754  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6755  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6756  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
6757  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6758  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6759  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6760 ! Local:
6761  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk
6762  REAL :: wk1(bd%is:bd%ie+1, bd%js:bd%je+1)
6763  REAL :: wk2(bd%is:bd%ie, bd%js:bd%je+1)
6764  REAL :: top_value
6765  INTEGER :: i, j, k
6766  INTEGER :: is, ie, js, je
6767  INTEGER :: isd, ied, jsd, jed
6768  is = bd%is
6769  ie = bd%ie
6770  js = bd%js
6771  je = bd%je
6772  isd = bd%isd
6773  ied = bd%ied
6774  jsd = bd%jsd
6775  jed = bd%jed
6776  IF (hydrostatic) THEN
6777 ! pk is pe**kappa if hydrostatic
6778  top_value = ptk
6779  ELSE
6780 ! pk is full pressure if non-hydrostatic
6781  top_value = ptop
6782  END IF
6783 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
6784  DO j=js,je+1
6785  DO i=is,ie+1
6786  pk(i, j, 1) = top_value
6787  END DO
6788  END DO
6789 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6790 !$OMP private(wk)
6791  DO k=2,npz+1
6792  IF (a2b_ord .EQ. 4) THEN
6793  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6794 & npy, is, ie, js, je, ng, .true.)
6795  ELSE
6796  CALL a2b_ord2(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
6797 & , is, ie, js, je, ng, .true.)
6798  END IF
6799  END DO
6800 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6801 !$OMP private(wk)
6802  DO k=1,npz+1
6803  IF (a2b_ord .EQ. 4) THEN
6804  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6805 & npy, is, ie, js, je, ng, .true.)
6806  ELSE
6807  CALL a2b_ord2(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
6808 & , is, ie, js, je, ng, .true.)
6809  END IF
6810  END DO
6811  IF (d_ext .GT. 0.) THEN
6812 !$OMP parallel do default(none) shared(is,ie,js,je,wk2,divg2)
6813  DO j=js,je+1
6814  DO i=is,ie
6815  wk2(i, j) = divg2(i, j) - divg2(i+1, j)
6816  END DO
6817  END DO
6818 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,divg2)
6819  DO j=js,je
6820  DO i=is,ie+1
6821  wk1(i, j) = divg2(i, j) - divg2(i, j+1)
6822  END DO
6823  END DO
6824  ELSE
6825 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,wk2)
6826  DO j=js,je+1
6827  DO i=is,ie
6828  wk2(i, j) = 0.
6829  END DO
6830  DO i=is,ie+1
6831  wk1(i, j) = 0.
6832  END DO
6833  END DO
6834  END IF
6835 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,a2b_ord,gridstruct, &
6836 !$OMP npx,npy,isd,jsd,ng,u,v,wk2,dt,gz,wk1) &
6837 !$OMP private(wk)
6838  DO k=1,npz
6839  IF (hydrostatic) THEN
6840  DO j=js,je+1
6841  DO i=is,ie+1
6842  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
6843  END DO
6844  END DO
6845  ELSE IF (a2b_ord .EQ. 4) THEN
6846  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk, gridstruct, npx&
6847 & , npy, is, ie, js, je, ng)
6848  ELSE
6849  CALL a2b_ord2(delp(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6850 & npy, is, ie, js, je, ng)
6851  END IF
6852  DO j=js,je+1
6853  DO i=is,ie
6854  u(i, j, k) = gridstruct%rdx(i, j)*(wk2(i, j)+u(i, j, k)+dt/(wk&
6855 & (i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pk(i+1, j&
6856 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pk(i, j, &
6857 & k+1)-pk(i+1, j, k))))
6858  END DO
6859  END DO
6860  DO j=js,je
6861  DO i=is,ie+1
6862  v(i, j, k) = gridstruct%rdy(i, j)*(wk1(i, j)+v(i, j, k)+dt/(wk&
6863 & (i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pk(i, j+1&
6864 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pk(i, j, &
6865 & k+1)-pk(i, j+1, k))))
6866  END DO
6867  END DO
6868  END DO
6869  END SUBROUTINE one_grad_p
6870 ! Differentiation of grad1_p_update in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_ed
6871 !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
6872 !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
6873 !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
6874 !eigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l
6875 !_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
6876 !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_
6877 !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
6878 !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
6879 !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
6880 !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
6881 !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
6882 !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
6883 !_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
6884 !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
6885 !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
6886 !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
6887 !tils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
6888 ! gradient of useful results: gz du u dv v pk divg2
6889 ! with respect to varying inputs: gz du u dv v pk divg2
6890  SUBROUTINE grad1_p_update_fwd(divg2, u, v, pk, gz, du, dv, dt, ng, &
6891 & gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
6892  IMPLICIT NONE
6893 ! end k-loop
6894  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
6895  REAL, INTENT(IN) :: dt, ptop, beta
6896  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
6897  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
6898  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6899  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
6900  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6901  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6902  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
6903  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
6904  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
6905 ! Local:
6906  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
6907  REAL :: top_value, alpha
6908  INTEGER :: i, j, k
6909  INTEGER :: is, ie, js, je
6910  INTEGER :: isd, ied, jsd, jed
6911 
6912  wk = 0.0
6913  top_value = 0.0
6914  alpha = 0.0
6915  is = 0
6916  ie = 0
6917  js = 0
6918  je = 0
6919  isd = 0
6920  ied = 0
6921  jsd = 0
6922  jed = 0
6923 
6924  is = bd%is
6925  ie = bd%ie
6926  js = bd%js
6927  je = bd%je
6928  isd = bd%isd
6929  ied = bd%ied
6930  jsd = bd%jsd
6931  jed = bd%jed
6932  alpha = 1. - beta
6933 ! pk is pe**kappa if hydrostatic
6934  top_value = ptk
6935 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
6936  DO j=js,je+1
6937  DO i=is,ie+1
6938  CALL pushrealarray(pk(i, j, 1))
6939  pk(i, j, 1) = top_value
6940  END DO
6941  END DO
6942 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6943 !$OMP private(wk)
6944  DO k=2,npz+1
6945  IF (a2b_ord .EQ. 4) THEN
6946  CALL a2b_ord4_fwd(pk(isd:ied, jsd:jed, k), wk, gridstruct, &
6947 & npx, npy, is, ie, js, je, ng, .true.)
6948  CALL pushcontrol(1,1)
6949  ELSE
6950  CALL a2b_ord2_fwd(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6951 & npy, is, ie, js, je, ng, .true.)
6952  CALL pushcontrol(1,0)
6953  END IF
6954  END DO
6955 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
6956 !$OMP private(wk)
6957  DO k=1,npz+1
6958  IF (a2b_ord .EQ. 4) THEN
6959  CALL a2b_ord4_fwd(gz(isd:ied, jsd:jed, k), wk, gridstruct, &
6960 & npx, npy, is, ie, js, je, ng, .true.)
6961  CALL pushcontrol(1,1)
6962  ELSE
6963  CALL a2b_ord2_fwd(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
6964 & npy, is, ie, js, je, ng, .true.)
6965  CALL pushcontrol(1,0)
6966  END IF
6967  END DO
6968 !$OMP parallel do default(none) shared(npz,is,ie,js,je,pk,u,beta,gz,divg2,alpha, &
6969 !$OMP gridstruct,v,dt,du,dv) &
6970 !$OMP private(wk)
6971  DO k=1,npz
6972  DO j=js,je+1
6973  DO i=is,ie+1
6974  CALL pushrealarray(wk(i, j))
6975  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
6976  END DO
6977  END DO
6978  DO j=js,je+1
6979  DO i=is,ie
6980  CALL pushrealarray(u(i, j, k))
6981  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
6982  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
6983 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
6984 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
6985  u(i, j, k) = (u(i, j, k)+divg2(i, j)-divg2(i+1, j)+alpha*du(i&
6986 & , j, k))*gridstruct%rdx(i, j)
6987  END DO
6988  END DO
6989  DO j=js,je
6990  DO i=is,ie+1
6991  CALL pushrealarray(v(i, j, k))
6992  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
6993  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
6994 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
6995 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
6996  v(i, j, k) = (v(i, j, k)+divg2(i, j)-divg2(i, j+1)+alpha*dv(i&
6997 & , j, k))*gridstruct%rdy(i, j)
6998  END DO
6999  END DO
7000  END DO
7001  CALL pushinteger(jed)
7002  CALL pushrealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
7003  CALL pushinteger(je)
7004  CALL pushinteger(is)
7005  CALL pushinteger(isd)
7006  CALL pushinteger(ie)
7007  CALL pushinteger(ied)
7008  CALL pushinteger(jsd)
7009  CALL pushrealarray(alpha)
7010  CALL pushinteger(js)
7011  END SUBROUTINE grad1_p_update_fwd
7012 ! Differentiation of grad1_p_update in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_e
7013 !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_
7014 !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_
7015 !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
7016 !leigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2
7017 !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
7018 !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
7019 !_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
7020 !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
7021 ! 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
7022 !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
7023 !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
7024 !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
7025 !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
7026 !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
7027 !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_
7028 !core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_
7029 !utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
7030 ! gradient of useful results: gz du u dv v pk divg2
7031 ! with respect to varying inputs: gz du u dv v pk divg2
7032  SUBROUTINE grad1_p_update_bwd(divg2, divg2_ad, u, u_ad, v, v_ad, pk, &
7033 & pk_ad, gz, gz_ad, du, du_ad, dv, dv_ad, dt, ng, gridstruct, bd, npx&
7034 & , npy, npz, ptop, beta, a2b_ord)
7035  IMPLICIT NONE
7036 ! end k-loop
7037  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
7038  REAL, INTENT(IN) :: dt, ptop, beta
7039  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7040  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
7041  REAL :: divg2_ad(bd%is:bd%ie+1, bd%js:bd%je+1)
7042  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7043  REAL, INTENT(INOUT) :: pk_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7044  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7045  REAL, INTENT(INOUT) :: gz_ad(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7046  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7047  REAL, INTENT(INOUT) :: u_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7048  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7049  REAL, INTENT(INOUT) :: v_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7050  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7051  REAL, INTENT(INOUT) :: du_ad(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7052  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7053  REAL, INTENT(INOUT) :: dv_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7054  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
7055  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
7056  REAL :: wk_ad(bd%isd:bd%ied, bd%jsd:bd%jed)
7057  REAL :: top_value, alpha
7058  INTEGER :: i, j, k
7059  INTEGER :: is, ie, js, je
7060  INTEGER :: isd, ied, jsd, jed
7061  REAL :: temp
7062  REAL :: temp0
7063  REAL :: temp1
7064  REAL :: temp2
7065  REAL :: temp3
7066  REAL :: temp_ad
7067  REAL :: temp_ad0
7068  REAL :: temp_ad1
7069  REAL :: temp4
7070  REAL :: temp5
7071  REAL :: temp6
7072  REAL :: temp7
7073  REAL :: temp8
7074  REAL :: temp_ad2
7075  REAL :: temp_ad3
7076  REAL :: temp_ad4
7077  INTEGER :: branch
7078 
7079  wk = 0.0
7080  top_value = 0.0
7081  alpha = 0.0
7082  is = 0
7083  ie = 0
7084  js = 0
7085  je = 0
7086  isd = 0
7087  ied = 0
7088  jsd = 0
7089  jed = 0
7090  branch = 0
7091 
7092  CALL popinteger(js)
7093  CALL poprealarray(alpha)
7094  CALL popinteger(jsd)
7095  CALL popinteger(ied)
7096  CALL popinteger(ie)
7097  CALL popinteger(isd)
7098  CALL popinteger(is)
7099  CALL popinteger(je)
7100  CALL poprealarray(wk, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1))
7101  CALL popinteger(jed)
7102  wk_ad = 0.0
7103  DO k=npz,1,-1
7104  DO j=je,js,-1
7105  DO i=ie+1,is,-1
7106  temp_ad2 = gridstruct%rdy(i, j)*v_ad(i, j, k)
7107  divg2_ad(i, j) = divg2_ad(i, j) + temp_ad2
7108  dv_ad(i, j, k) = dv_ad(i, j, k) + alpha*temp_ad2
7109  divg2_ad(i, j+1) = divg2_ad(i, j+1) - temp_ad2
7110  v_ad(i, j, k) = temp_ad2
7111  temp4 = wk(i, j) + wk(i, j+1)
7112  temp8 = pk(i, j, k+1) - pk(i, j+1, k)
7113  temp7 = gz(i, j, k) - gz(i, j+1, k+1)
7114  temp6 = pk(i, j+1, k+1) - pk(i, j, k)
7115  temp5 = gz(i, j, k+1) - gz(i, j+1, k)
7116  temp_ad3 = dt*dv_ad(i, j, k)/temp4
7117  temp_ad4 = -((temp5*temp6+temp7*temp8)*temp_ad3/temp4)
7118  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp6*temp_ad3
7119  gz_ad(i, j+1, k) = gz_ad(i, j+1, k) - temp6*temp_ad3
7120  pk_ad(i, j+1, k+1) = pk_ad(i, j+1, k+1) + temp5*temp_ad3
7121  pk_ad(i, j, k) = pk_ad(i, j, k) - temp5*temp_ad3
7122  gz_ad(i, j, k) = gz_ad(i, j, k) + temp8*temp_ad3
7123  gz_ad(i, j+1, k+1) = gz_ad(i, j+1, k+1) - temp8*temp_ad3
7124  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp7*temp_ad3
7125  pk_ad(i, j+1, k) = pk_ad(i, j+1, k) - temp7*temp_ad3
7126  wk_ad(i, j) = wk_ad(i, j) + temp_ad4
7127  wk_ad(i, j+1) = wk_ad(i, j+1) + temp_ad4
7128  dv_ad(i, j, k) = beta*v_ad(i, j, k)
7129  CALL poprealarray(v(i, j, k))
7130  END DO
7131  END DO
7132  DO j=je+1,js,-1
7133  DO i=ie,is,-1
7134  temp_ad = gridstruct%rdx(i, j)*u_ad(i, j, k)
7135  divg2_ad(i, j) = divg2_ad(i, j) + temp_ad
7136  du_ad(i, j, k) = du_ad(i, j, k) + alpha*temp_ad
7137  divg2_ad(i+1, j) = divg2_ad(i+1, j) - temp_ad
7138  u_ad(i, j, k) = temp_ad
7139  temp = wk(i, j) + wk(i+1, j)
7140  temp3 = pk(i, j, k+1) - pk(i+1, j, k)
7141  temp2 = gz(i, j, k) - gz(i+1, j, k+1)
7142  temp1 = pk(i+1, j, k+1) - pk(i, j, k)
7143  temp0 = gz(i, j, k+1) - gz(i+1, j, k)
7144  temp_ad0 = dt*du_ad(i, j, k)/temp
7145  temp_ad1 = -((temp0*temp1+temp2*temp3)*temp_ad0/temp)
7146  gz_ad(i, j, k+1) = gz_ad(i, j, k+1) + temp1*temp_ad0
7147  gz_ad(i+1, j, k) = gz_ad(i+1, j, k) - temp1*temp_ad0
7148  pk_ad(i+1, j, k+1) = pk_ad(i+1, j, k+1) + temp0*temp_ad0
7149  pk_ad(i, j, k) = pk_ad(i, j, k) - temp0*temp_ad0
7150  gz_ad(i, j, k) = gz_ad(i, j, k) + temp3*temp_ad0
7151  gz_ad(i+1, j, k+1) = gz_ad(i+1, j, k+1) - temp3*temp_ad0
7152  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp2*temp_ad0
7153  pk_ad(i+1, j, k) = pk_ad(i+1, j, k) - temp2*temp_ad0
7154  wk_ad(i, j) = wk_ad(i, j) + temp_ad1
7155  wk_ad(i+1, j) = wk_ad(i+1, j) + temp_ad1
7156  du_ad(i, j, k) = beta*u_ad(i, j, k)
7157  CALL poprealarray(u(i, j, k))
7158  END DO
7159  END DO
7160  DO j=je+1,js,-1
7161  DO i=ie+1,is,-1
7162  CALL poprealarray(wk(i, j))
7163  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + wk_ad(i, j)
7164  pk_ad(i, j, k) = pk_ad(i, j, k) - wk_ad(i, j)
7165  wk_ad(i, j) = 0.0
7166  END DO
7167  END DO
7168  END DO
7169  DO k=npz+1,1,-1
7170  CALL popcontrol(1,branch)
7171  IF (branch .EQ. 0) THEN
7172  CALL a2b_ord2_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd:&
7173 & jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie, js&
7174 & , je, ng, .true.)
7175  ELSE
7176  CALL a2b_ord4_bwd(gz(isd:ied, jsd:jed, k), gz_ad(isd:ied, jsd&
7177 & :jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie&
7178 & , js, je, ng, .true.)
7179  END IF
7180  END DO
7181  DO k=npz+1,2,-1
7182  CALL popcontrol(1,branch)
7183  IF (branch .EQ. 0) THEN
7184  CALL a2b_ord2_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd:&
7185 & jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie, js&
7186 & , je, ng, .true.)
7187  ELSE
7188  CALL a2b_ord4_bwd(pk(isd:ied, jsd:jed, k), pk_ad(isd:ied, jsd&
7189 & :jed, k), wk, wk_ad, gridstruct, npx, npy, is, ie&
7190 & , js, je, ng, .true.)
7191  END IF
7192  END DO
7193  DO j=je+1,js,-1
7194  DO i=ie+1,is,-1
7195  CALL poprealarray(pk(i, j, 1))
7196  pk_ad(i, j, 1) = 0.0
7197  END DO
7198  END DO
7199  END SUBROUTINE grad1_p_update_bwd
7200  SUBROUTINE grad1_p_update(divg2, u, v, pk, gz, du, dv, dt, ng, &
7201 & gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
7202  IMPLICIT NONE
7203 ! end k-loop
7204  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
7205  REAL, INTENT(IN) :: dt, ptop, beta
7206  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7207  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
7208  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7209  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
7210  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7211  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7212  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
7213  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
7214  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
7215 ! Local:
7216  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
7217  REAL :: top_value, alpha
7218  INTEGER :: i, j, k
7219  INTEGER :: is, ie, js, je
7220  INTEGER :: isd, ied, jsd, jed
7221  is = bd%is
7222  ie = bd%ie
7223  js = bd%js
7224  je = bd%je
7225  isd = bd%isd
7226  ied = bd%ied
7227  jsd = bd%jsd
7228  jed = bd%jed
7229  alpha = 1. - beta
7230 ! pk is pe**kappa if hydrostatic
7231  top_value = ptk
7232 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
7233  DO j=js,je+1
7234  DO i=is,ie+1
7235  pk(i, j, 1) = top_value
7236  END DO
7237  END DO
7238 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
7239 !$OMP private(wk)
7240  DO k=2,npz+1
7241  IF (a2b_ord .EQ. 4) THEN
7242  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
7243 & npy, is, ie, js, je, ng, .true.)
7244  ELSE
7245  CALL a2b_ord2(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
7246 & , is, ie, js, je, ng, .true.)
7247  END IF
7248  END DO
7249 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
7250 !$OMP private(wk)
7251  DO k=1,npz+1
7252  IF (a2b_ord .EQ. 4) THEN
7253  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
7254 & npy, is, ie, js, je, ng, .true.)
7255  ELSE
7256  CALL a2b_ord2(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
7257 & , is, ie, js, je, ng, .true.)
7258  END IF
7259  END DO
7260 !$OMP parallel do default(none) shared(npz,is,ie,js,je,pk,u,beta,gz,divg2,alpha, &
7261 !$OMP gridstruct,v,dt,du,dv) &
7262 !$OMP private(wk)
7263  DO k=1,npz
7264  DO j=js,je+1
7265  DO i=is,ie+1
7266  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
7267  END DO
7268  END DO
7269  DO j=js,je+1
7270  DO i=is,ie
7271  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
7272  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
7273 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
7274 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
7275  u(i, j, k) = (u(i, j, k)+divg2(i, j)-divg2(i+1, j)+alpha*du(i&
7276 & , j, k))*gridstruct%rdx(i, j)
7277  END DO
7278  END DO
7279  DO j=js,je
7280  DO i=is,ie+1
7281  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
7282  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
7283 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
7284 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
7285  v(i, j, k) = (v(i, j, k)+divg2(i, j)-divg2(i, j+1)+alpha*dv(i&
7286 & , j, k))*gridstruct%rdy(i, j)
7287  END DO
7288  END DO
7289  END DO
7290  END SUBROUTINE grad1_p_update
7291 ! Differentiation of mix_dp in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a
7292 !2b_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.
7293 !p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_d
7294 !p dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Sup
7295 !er fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv
7296 !_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_
7297 !z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_ma
7298 !pz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_m
7299 !apz_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_resta
7300 !rt_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
7301 !main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.
7302 !Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SI
7303 !M3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nes
7304 !t_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_
7305 !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 s
7306 !w_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.
7307 !copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod
7308 !.great_circle_dist sw_core_mod.edge_interpolate4)):
7309 ! gradient of useful results: w delp pt
7310 ! with respect to varying inputs: w delp pt
7311  SUBROUTINE mix_dp_fwd(hydrostatic, w, delp, pt, km, ak, bk, cg, &
7312 & fv_debug, bd)
7313  IMPLICIT NONE
7314 ! if ( ip/=0 ) write(*,*) 'Warning: Mix_dp', mpp_pe(), j, ip
7315  INTEGER, INTENT(IN) :: km
7316  REAL, INTENT(IN) :: ak(km+1), bk(km+1)
7317  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7318  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7319 & pt, delp
7320  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7321 & w
7322  LOGICAL, INTENT(IN) :: hydrostatic, cg, fv_debug
7323 ! Local:
7324  REAL :: dp, dpmin
7325  INTEGER :: i, j, k, ip
7326  INTEGER :: ifirst, ilast
7327  INTEGER :: jfirst, jlast
7328  INTEGER :: is, ie, js, je
7329  INTEGER :: isd, ied, jsd, jed
7330  INTEGER :: res
7331 
7332  dp = 0.0
7333  dpmin = 0.0
7334  ifirst = 0
7335  ilast = 0
7336  jfirst = 0
7337  jlast = 0
7338  is = 0
7339  ie = 0
7340  js = 0
7341  je = 0
7342  isd = 0
7343  ied = 0
7344  jsd = 0
7345  jed = 0
7346  res = 0
7347 
7348  is = bd%is
7349  ie = bd%ie
7350  js = bd%js
7351  je = bd%je
7352  IF (cg) THEN
7353  ifirst = is - 1
7354  ilast = ie + 1
7355  jfirst = js - 1
7356  jlast = je + 1
7357  ELSE
7358  ifirst = is
7359  ilast = ie
7360  jfirst = js
7361  jlast = je
7362  END IF
7363 !$OMP parallel do default(none) shared(jfirst,jlast,km,ifirst,ilast,delp,ak,bk,pt, &
7364 !$OMP hydrostatic,w,fv_debug) &
7365 !$OMP private(ip, dpmin, dp)
7366  DO j=jfirst,jlast
7367  ip = 0
7368  DO k=1,km-1
7369  CALL pushrealarray(dpmin)
7370  dpmin = 0.01*(ak(k+1)-ak(k)+(bk(k+1)-bk(k))*1.e5)
7371  DO i=ifirst,ilast
7372  IF (delp(i, j, k) .LT. dpmin) THEN
7373 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, k, mpp_pe(), delp(i,j,k), pt(i,j,k)
7374 ! Remap from below and mix pt
7375  CALL pushrealarray(dp)
7376  dp = dpmin - delp(i, j, k)
7377  CALL pushrealarray(pt(i, j, k))
7378  pt(i, j, k) = (pt(i, j, k)*delp(i, j, k)+pt(i, j, k+1)*dp)/&
7379 & dpmin
7380  IF (.NOT.hydrostatic) THEN
7381  CALL pushrealarray(w(i, j, k))
7382  w(i, j, k) = (w(i, j, k)*delp(i, j, k)+w(i, j, k+1)*dp)/&
7383 & dpmin
7384  CALL pushcontrol(1,0)
7385  ELSE
7386  CALL pushcontrol(1,1)
7387  END IF
7388  CALL pushrealarray(delp(i, j, k))
7389  delp(i, j, k) = dpmin
7390  CALL pushrealarray(delp(i, j, k+1))
7391  delp(i, j, k+1) = delp(i, j, k+1) - dp
7392  ip = ip + 1
7393  CALL pushcontrol(1,1)
7394  ELSE
7395  CALL pushcontrol(1,0)
7396  END IF
7397  END DO
7398  END DO
7399 ! Bottom (k=km):
7400  CALL pushrealarray(dpmin)
7401  dpmin = 0.01*(ak(km+1)-ak(km)+(bk(km+1)-bk(km))*1.e5)
7402  DO i=ifirst,ilast
7403  IF (delp(i, j, km) .LT. dpmin) THEN
7404 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, km, mpp_pe(), delp(i,j,km), pt(i,j,km)
7405 ! Remap from above and mix pt
7406  CALL pushrealarray(dp)
7407  dp = dpmin - delp(i, j, km)
7408  CALL pushrealarray(pt(i, j, km))
7409  pt(i, j, km) = (pt(i, j, km)*delp(i, j, km)+pt(i, j, km-1)*dp)&
7410 & /dpmin
7411  IF (.NOT.hydrostatic) THEN
7412  CALL pushrealarray(w(i, j, km))
7413  w(i, j, km) = (w(i, j, km)*delp(i, j, km)+w(i, j, km-1)*dp)/&
7414 & dpmin
7415  CALL pushcontrol(1,0)
7416  ELSE
7417  CALL pushcontrol(1,1)
7418  END IF
7419  CALL pushrealarray(delp(i, j, km))
7420  delp(i, j, km) = dpmin
7421  CALL pushrealarray(delp(i, j, km-1))
7422  delp(i, j, km-1) = delp(i, j, km-1) - dp
7423  ip = ip + 1
7424  CALL pushcontrol(1,1)
7425  ELSE
7426  CALL pushcontrol(1,0)
7427  END IF
7428  END DO
7429  IF (fv_debug .AND. ip .NE. 0) THEN
7430  CALL pushcontrol(1,0)
7431  res = mpp_pe()
7432  WRITE(*, *) 'Warning: Mix_dp', res, j, ip
7433  ELSE
7434  CALL pushcontrol(1,1)
7435  END IF
7436  END DO
7437  CALL pushinteger(ifirst)
7438  CALL pushinteger(jlast)
7439  CALL pushinteger(jfirst)
7440  CALL pushinteger(ilast)
7441  CALL pushrealarray(dp)
7442  END SUBROUTINE mix_dp_fwd
7443 ! Differentiation of mix_dp in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.
7444 !a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod
7445 !.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_
7446 !dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Su
7447 !per fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 f
7448 !v_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap
7449 !_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_m
7450 !apz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_
7451 !mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_rest
7452 !art_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z
7453 ! main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod
7454 !.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.S
7455 !IM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.ne
7456 !st_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c
7457 !_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
7458 !sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod
7459 !.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mo
7460 !d.great_circle_dist sw_core_mod.edge_interpolate4)):
7461 ! gradient of useful results: w delp pt
7462 ! with respect to varying inputs: w delp pt
7463  SUBROUTINE mix_dp_bwd(hydrostatic, w, w_ad, delp, delp_ad, pt, pt_ad, &
7464 & km, ak, bk, cg, fv_debug, bd)
7465  IMPLICIT NONE
7466 ! if ( ip/=0 ) write(*,*) 'Warning: Mix_dp', mpp_pe(), j, ip
7467  INTEGER, INTENT(IN) :: km
7468  REAL, INTENT(IN) :: ak(km+1), bk(km+1)
7469  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7470  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7471 & pt, delp
7472  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7473 & pt_ad, delp_ad
7474  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7475 & w
7476  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7477 & w_ad
7478  LOGICAL, INTENT(IN) :: hydrostatic, cg, fv_debug
7479  REAL :: dp, dpmin
7480  REAL :: dp_ad
7481  INTEGER :: i, j, k, ip
7482  INTEGER :: ifirst, ilast
7483  INTEGER :: jfirst, jlast
7484  INTEGER :: is, ie, js, je
7485  INTEGER :: isd, ied, jsd, jed
7486  REAL :: temp_ad
7487  REAL :: temp_ad0
7488  REAL :: temp_ad1
7489  REAL :: temp_ad2
7490  INTEGER :: branch
7491 
7492  dp = 0.0
7493  dpmin = 0.0
7494  ifirst = 0
7495  ilast = 0
7496  jfirst = 0
7497  jlast = 0
7498  is = 0
7499  ie = 0
7500  js = 0
7501  je = 0
7502  isd = 0
7503  ied = 0
7504  jsd = 0
7505  jed = 0
7506  branch = 0
7507 
7508  CALL poprealarray(dp)
7509  CALL popinteger(ilast)
7510  CALL popinteger(jfirst)
7511  CALL popinteger(jlast)
7512  CALL popinteger(ifirst)
7513  DO j=jlast,jfirst,-1
7514  CALL popcontrol(1,branch)
7515  dpmin = 0.01*(ak(km+1)-ak(km)+(bk(km+1)-bk(km))*1.e5)
7516  DO i=ilast,ifirst,-1
7517  CALL popcontrol(1,branch)
7518  IF (branch .NE. 0) THEN
7519  CALL poprealarray(delp(i, j, km-1))
7520  dp_ad = -delp_ad(i, j, km-1)
7521  CALL poprealarray(delp(i, j, km))
7522  delp_ad(i, j, km) = 0.0
7523  CALL popcontrol(1,branch)
7524  IF (branch .EQ. 0) THEN
7525  CALL poprealarray(w(i, j, km))
7526  temp_ad2 = w_ad(i, j, km)/dpmin
7527  delp_ad(i, j, km) = delp_ad(i, j, km) + w(i, j, km)*temp_ad2
7528  w_ad(i, j, km-1) = w_ad(i, j, km-1) + dp*temp_ad2
7529  dp_ad = dp_ad + w(i, j, km-1)*temp_ad2
7530  w_ad(i, j, km) = delp(i, j, km)*temp_ad2
7531  END IF
7532  CALL poprealarray(pt(i, j, km))
7533  temp_ad1 = pt_ad(i, j, km)/dpmin
7534  pt_ad(i, j, km-1) = pt_ad(i, j, km-1) + dp*temp_ad1
7535  dp_ad = dp_ad + pt(i, j, km-1)*temp_ad1
7536  delp_ad(i, j, km) = delp_ad(i, j, km) + pt(i, j, km)*temp_ad1 &
7537 & - dp_ad
7538  pt_ad(i, j, km) = delp(i, j, km)*temp_ad1
7539  CALL poprealarray(dp)
7540  END IF
7541  END DO
7542  CALL poprealarray(dpmin)
7543  DO k=km-1,1,-1
7544  DO i=ilast,ifirst,-1
7545  CALL popcontrol(1,branch)
7546  IF (branch .NE. 0) THEN
7547  CALL poprealarray(delp(i, j, k+1))
7548  dp_ad = -delp_ad(i, j, k+1)
7549  CALL poprealarray(delp(i, j, k))
7550  delp_ad(i, j, k) = 0.0
7551  CALL popcontrol(1,branch)
7552  IF (branch .EQ. 0) THEN
7553  CALL poprealarray(w(i, j, k))
7554  temp_ad0 = w_ad(i, j, k)/dpmin
7555  delp_ad(i, j, k) = delp_ad(i, j, k) + w(i, j, k)*temp_ad0
7556  w_ad(i, j, k+1) = w_ad(i, j, k+1) + dp*temp_ad0
7557  dp_ad = dp_ad + w(i, j, k+1)*temp_ad0
7558  w_ad(i, j, k) = delp(i, j, k)*temp_ad0
7559  END IF
7560  CALL poprealarray(pt(i, j, k))
7561  temp_ad = pt_ad(i, j, k)/dpmin
7562  pt_ad(i, j, k+1) = pt_ad(i, j, k+1) + dp*temp_ad
7563  dp_ad = dp_ad + pt(i, j, k+1)*temp_ad
7564  delp_ad(i, j, k) = delp_ad(i, j, k) + pt(i, j, k)*temp_ad - &
7565 & dp_ad
7566  pt_ad(i, j, k) = delp(i, j, k)*temp_ad
7567  CALL poprealarray(dp)
7568  END IF
7569  END DO
7570  CALL poprealarray(dpmin)
7571  END DO
7572  END DO
7573  END SUBROUTINE mix_dp_bwd
7574  SUBROUTINE mix_dp(hydrostatic, w, delp, pt, km, ak, bk, cg, fv_debug, &
7575 & bd)
7576  IMPLICIT NONE
7577 ! if ( ip/=0 ) write(*,*) 'Warning: Mix_dp', mpp_pe(), j, ip
7578  INTEGER, INTENT(IN) :: km
7579  REAL, INTENT(IN) :: ak(km+1), bk(km+1)
7580  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7581  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7582 & pt, delp
7583  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
7584 & w
7585  LOGICAL, INTENT(IN) :: hydrostatic, cg, fv_debug
7586 ! Local:
7587  REAL :: dp, dpmin
7588  INTEGER :: i, j, k, ip
7589  INTEGER :: ifirst, ilast
7590  INTEGER :: jfirst, jlast
7591  INTEGER :: is, ie, js, je
7592  INTEGER :: isd, ied, jsd, jed
7593  is = bd%is
7594  ie = bd%ie
7595  js = bd%js
7596  je = bd%je
7597  isd = bd%isd
7598  ied = bd%ied
7599  jsd = bd%jsd
7600  jed = bd%jed
7601  IF (cg) THEN
7602  ifirst = is - 1
7603  ilast = ie + 1
7604  jfirst = js - 1
7605  jlast = je + 1
7606  ELSE
7607  ifirst = is
7608  ilast = ie
7609  jfirst = js
7610  jlast = je
7611  END IF
7612 !$OMP parallel do default(none) shared(jfirst,jlast,km,ifirst,ilast,delp,ak,bk,pt, &
7613 !$OMP hydrostatic,w,fv_debug) &
7614 !$OMP private(ip, dpmin, dp)
7615  DO j=jfirst,jlast
7616  ip = 0
7617  DO k=1,km-1
7618  dpmin = 0.01*(ak(k+1)-ak(k)+(bk(k+1)-bk(k))*1.e5)
7619  DO i=ifirst,ilast
7620  IF (delp(i, j, k) .LT. dpmin) THEN
7621 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, k, mpp_pe(), delp(i,j,k), pt(i,j,k)
7622 ! Remap from below and mix pt
7623  dp = dpmin - delp(i, j, k)
7624  pt(i, j, k) = (pt(i, j, k)*delp(i, j, k)+pt(i, j, k+1)*dp)/&
7625 & dpmin
7626  IF (.NOT.hydrostatic) w(i, j, k) = (w(i, j, k)*delp(i, j, k)&
7627 & +w(i, j, k+1)*dp)/dpmin
7628  delp(i, j, k) = dpmin
7629  delp(i, j, k+1) = delp(i, j, k+1) - dp
7630  ip = ip + 1
7631  END IF
7632  END DO
7633  END DO
7634 ! Bottom (k=km):
7635  dpmin = 0.01*(ak(km+1)-ak(km)+(bk(km+1)-bk(km))*1.e5)
7636  DO i=ifirst,ilast
7637  IF (delp(i, j, km) .LT. dpmin) THEN
7638 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, km, mpp_pe(), delp(i,j,km), pt(i,j,km)
7639 ! Remap from above and mix pt
7640  dp = dpmin - delp(i, j, km)
7641  pt(i, j, km) = (pt(i, j, km)*delp(i, j, km)+pt(i, j, km-1)*dp)&
7642 & /dpmin
7643  IF (.NOT.hydrostatic) w(i, j, km) = (w(i, j, km)*delp(i, j, km&
7644 & )+w(i, j, km-1)*dp)/dpmin
7645  delp(i, j, km) = dpmin
7646  delp(i, j, km-1) = delp(i, j, km-1) - dp
7647  ip = ip + 1
7648  END IF
7649  END DO
7650  IF (fv_debug .AND. ip .NE. 0) WRITE(*, *) 'Warning: Mix_dp', &
7651 & mpp_pe(), j, ip
7652  END DO
7653  END SUBROUTINE mix_dp
7654 ! Differentiation of geopk in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2
7655 !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
7656 !_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
7657 ! dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Supe
7658 !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_
7659 !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
7660 ! 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
7661 !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
7662 !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
7663 !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
7664 !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
7665 !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
7666 !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
7667 !_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
7668 !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
7669 !_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
7670 !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.
7671 !great_circle_dist sw_core_mod.edge_interpolate4)):
7672 ! gradient of useful results: peln gz delp pkz pe pk pt
7673 ! with respect to varying inputs: peln gz delp pkz pe pk pt
7674  SUBROUTINE geopk_fwd(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz&
7675 & , km, akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
7676  IMPLICIT NONE
7677  INTEGER, INTENT(IN) :: km, npx, npy, a2b_ord
7678  REAL, INTENT(IN) :: akap, ptop
7679  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7680  REAL, INTENT(IN) :: hs(bd%isd:bd%ied, bd%jsd:bd%jed)
7681  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: pt&
7682 & , delp
7683  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
7684 & q_con
7685  LOGICAL, INTENT(IN) :: cg, nested, computehalo
7686 ! !OUTPUT PARAMETERS
7687  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1) :: gz, pk
7688  REAL :: pe(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
7689 ! ln(pe)
7690  REAL :: peln(bd%is:bd%ie, km+1, bd%js:bd%je)
7691  REAL :: pkz(bd%is:bd%ie, bd%js:bd%je, km)
7692 ! !DESCRIPTION:
7693 ! Calculates geopotential and pressure to the kappa.
7694 ! Local:
7695  REAL :: peg(bd%isd:bd%ied, km+1)
7696  REAL :: pkg(bd%isd:bd%ied, km+1)
7697  REAL(kind=8) :: p1d(bd%isd:bd%ied)
7698  REAL(kind=8) :: g1d(bd%isd:bd%ied)
7699  REAL :: logp(bd%isd:bd%ied)
7700  INTEGER :: i, j, k
7701  INTEGER :: ifirst, ilast
7702  INTEGER :: jfirst, jlast
7703  INTEGER :: is, ie, js, je
7704  INTEGER :: isd, ied, jsd, jed
7705  INTRINSIC max
7706  INTRINSIC min
7707  INTRINSIC log
7708  INTRINSIC exp
7709  INTEGER :: max1
7710  INTEGER :: max2
7711  INTEGER :: min1
7712  INTEGER :: min2
7713  INTEGER :: ad_from
7714  INTEGER :: ad_from0
7715 
7716  peg = 0.0
7717  pkg = 0.0
7718  p1d = 0.0
7719  logp = 0.0
7720  ifirst = 0
7721  ilast = 0
7722  jfirst = 0
7723  jlast = 0
7724  is = 0
7725  ie = 0
7726  js = 0
7727  je = 0
7728  isd = 0
7729  ied = 0
7730  jsd = 0
7731  jed = 0
7732  max1 = 0
7733  max2 = 0
7734  min1 = 0
7735  min2 = 0
7736  ad_from = 0
7737  ad_from0 = 0
7738 
7739  is = bd%is
7740  ie = bd%ie
7741  js = bd%js
7742  je = bd%je
7743  isd = bd%isd
7744  ied = bd%ied
7745  jsd = bd%jsd
7746  jed = bd%jed
7747  IF ((.NOT.cg .AND. a2b_ord .EQ. 4) .OR. (nested .AND. (.NOT.cg))) &
7748 & THEN
7749 ! D-Grid
7750  ifirst = is - 2
7751  ilast = ie + 2
7752  jfirst = js - 2
7753  jlast = je + 2
7754  ELSE
7755  ifirst = is - 1
7756  ilast = ie + 1
7757  jfirst = js - 1
7758  jlast = je + 1
7759  END IF
7760  IF (nested .AND. computehalo) THEN
7761  IF (is .EQ. 1) ifirst = isd
7762  IF (ie .EQ. npx - 1) ilast = ied
7763  IF (js .EQ. 1) jfirst = jsd
7764  IF (je .EQ. npy - 1) THEN
7765  CALL pushcontrol(1,1)
7766  jlast = jed
7767  ELSE
7768  CALL pushcontrol(1,1)
7769  END IF
7770  ELSE
7771  CALL pushcontrol(1,0)
7772  END IF
7773 !$OMP parallel do default(none) shared(jfirst,jlast,ifirst,ilast,pk,km,gz,hs,ptop,ptk, &
7774 !$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz,q_con) &
7775 !$OMP private(peg, pkg, p1d, g1d, logp)
7776  DO j=jfirst,jlast
7777  DO i=ifirst,ilast
7778  CALL pushrealarray(p1d(i))
7779  p1d(i) = ptop
7780  CALL pushrealarray(pk(i, j, 1))
7781  pk(i, j, 1) = ptk
7782  g1d(i) = hs(i, j)
7783  CALL pushrealarray(gz(i, j, km+1))
7784  gz(i, j, km+1) = hs(i, j)
7785  END DO
7786  IF (j .GE. js .AND. j .LE. je) THEN
7787  DO i=is,ie
7788  CALL pushrealarray(peln(i, 1, j))
7789  peln(i, 1, j) = peln1
7790  END DO
7791  CALL pushcontrol(1,0)
7792  ELSE
7793  CALL pushcontrol(1,1)
7794  END IF
7795  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
7796  IF (ifirst .LT. is - 1) THEN
7797  max1 = is - 1
7798  ELSE
7799  max1 = ifirst
7800  END IF
7801  IF (ilast .GT. ie + 1) THEN
7802  min1 = ie + 1
7803  ELSE
7804  min1 = ilast
7805  END IF
7806  ad_from = max1
7807  DO i=ad_from,min1
7808  CALL pushrealarray(pe(i, 1, j))
7809  pe(i, 1, j) = ptop
7810  END DO
7811  CALL pushinteger(i - 1)
7812  CALL pushinteger(ad_from)
7813  CALL pushcontrol(1,1)
7814  ELSE
7815  CALL pushcontrol(1,0)
7816  END IF
7817 ! Top down
7818  DO k=2,km+1
7819  DO i=ifirst,ilast
7820  CALL pushrealarray(p1d(i))
7821  p1d(i) = p1d(i) + delp(i, j, k-1)
7822  CALL pushrealarray(logp(i))
7823  logp(i) = log(p1d(i))
7824  CALL pushrealarray(pk(i, j, k))
7825  pk(i, j, k) = exp(akap*logp(i))
7826  END DO
7827  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
7828  IF (ifirst .LT. is - 1) THEN
7829  max2 = is - 1
7830  ELSE
7831  max2 = ifirst
7832  END IF
7833  IF (ilast .GT. ie + 1) THEN
7834  min2 = ie + 1
7835  ELSE
7836  min2 = ilast
7837  END IF
7838  ad_from0 = max2
7839  DO i=ad_from0,min2
7840  CALL pushrealarray(pe(i, k, j))
7841  pe(i, k, j) = p1d(i)
7842  END DO
7843  CALL pushinteger(i - 1)
7844  CALL pushinteger(ad_from0)
7845  IF (j .GE. js .AND. j .LE. je) THEN
7846  DO i=is,ie
7847  CALL pushrealarray(peln(i, k, j))
7848  peln(i, k, j) = logp(i)
7849  END DO
7850  CALL pushcontrol(2,2)
7851  ELSE
7852  CALL pushcontrol(2,1)
7853  END IF
7854  ELSE
7855  CALL pushcontrol(2,0)
7856  END IF
7857  END DO
7858 ! Bottom up
7859  DO k=km,1,-1
7860  DO i=ifirst,ilast
7861  g1d(i) = g1d(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k&
7862 & ))
7863  CALL pushrealarray(gz(i, j, k))
7864  gz(i, j, k) = g1d(i)
7865  END DO
7866  END DO
7867  IF (.NOT.cg .AND. j .GE. js .AND. j .LE. je) THEN
7868  DO k=1,km
7869  DO i=is,ie
7870  CALL pushrealarray(pkz(i, j, k))
7871  pkz(i, j, k) = (pk(i, j, k+1)-pk(i, j, k))/(akap*(peln(i, k+&
7872 & 1, j)-peln(i, k, j)))
7873  END DO
7874  END DO
7875  CALL pushcontrol(1,0)
7876  ELSE
7877  CALL pushcontrol(1,1)
7878  END IF
7879  END DO
7880  CALL pushinteger(ifirst)
7881  CALL pushinteger(is)
7882  CALL pushinteger(ie)
7883  CALL pushinteger(jlast)
7884  CALL pushrealarray(p1d, bd%ied - bd%isd + 1)
7885  CALL pushinteger(jfirst)
7886  CALL pushinteger(ilast)
7887  CALL pushrealarray(logp, bd%ied - bd%isd + 1)
7888  END SUBROUTINE geopk_fwd
7889 ! Differentiation of geopk in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a
7890 !2b_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.
7891 !p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_d
7892 !p dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Sup
7893 !er fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv
7894 !_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_
7895 !z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_ma
7896 !pz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_m
7897 !apz_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_resta
7898 !rt_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
7899 !main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.
7900 !Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SI
7901 !M3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nes
7902 !t_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_
7903 !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 s
7904 !w_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.
7905 !copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod
7906 !.great_circle_dist sw_core_mod.edge_interpolate4)):
7907 ! gradient of useful results: peln gz delp pkz pe pk pt
7908 ! with respect to varying inputs: peln gz delp pkz pe pk pt
7909  SUBROUTINE geopk_bwd(ptop, pe, pe_ad, peln, peln_ad, delp, delp_ad, pk&
7910 & , pk_ad, gz, gz_ad, hs, pt, pt_ad, q_con, pkz, pkz_ad, km, akap, cg&
7911 & , nested, computehalo, npx, npy, a2b_ord, bd)
7912  IMPLICIT NONE
7913  INTEGER, INTENT(IN) :: km, npx, npy, a2b_ord
7914  REAL, INTENT(IN) :: akap, ptop
7915  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
7916  REAL, INTENT(IN) :: hs(bd%isd:bd%ied, bd%jsd:bd%jed)
7917  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: pt&
7918 & , delp
7919  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km) :: pt_ad, delp_ad
7920  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
7921 & q_con
7922  LOGICAL, INTENT(IN) :: cg, nested, computehalo
7923  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1) :: gz, pk
7924  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1) :: gz_ad, pk_ad
7925  REAL :: pe(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
7926  REAL :: pe_ad(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
7927  REAL :: peln(bd%is:bd%ie, km+1, bd%js:bd%je)
7928  REAL :: peln_ad(bd%is:bd%ie, km+1, bd%js:bd%je)
7929  REAL :: pkz(bd%is:bd%ie, bd%js:bd%je, km)
7930  REAL :: pkz_ad(bd%is:bd%ie, bd%js:bd%je, km)
7931  REAL :: peg(bd%isd:bd%ied, km+1)
7932  REAL :: pkg(bd%isd:bd%ied, km+1)
7933  REAL(kind=8) :: p1d(bd%isd:bd%ied)
7934  REAL(kind=8) :: p1d_ad(bd%isd:bd%ied)
7935  REAL(kind=8) :: g1d(bd%isd:bd%ied)
7936  REAL(kind=8) :: g1d_ad(bd%isd:bd%ied)
7937  REAL :: logp(bd%isd:bd%ied)
7938  REAL :: logp_ad(bd%isd:bd%ied)
7939  INTEGER :: i, j, k
7940  INTEGER :: ifirst, ilast
7941  INTEGER :: jfirst, jlast
7942  INTEGER :: is, ie, js, je
7943  INTEGER :: isd, ied, jsd, jed
7944  INTRINSIC max
7945  INTRINSIC min
7946  INTRINSIC log
7947  INTRINSIC exp
7948  INTEGER :: max1
7949  INTEGER :: max2
7950  INTEGER :: min1
7951  INTEGER :: min2
7952  REAL :: temp_ad
7953  REAL :: temp
7954  REAL :: temp_ad0
7955  REAL :: temp_ad1
7956  INTEGER :: ad_from
7957  INTEGER :: ad_to
7958  INTEGER :: ad_from0
7959  INTEGER :: ad_to0
7960  INTEGER :: branch
7961 
7962  peg = 0.0
7963  pkg = 0.0
7964  p1d = 0.0
7965  logp = 0.0
7966  ifirst = 0
7967  ilast = 0
7968  jfirst = 0
7969  jlast = 0
7970  is = 0
7971  ie = 0
7972  js = 0
7973  je = 0
7974  isd = 0
7975  ied = 0
7976  jsd = 0
7977  jed = 0
7978  max1 = 0
7979  max2 = 0
7980  min1 = 0
7981  min2 = 0
7982  ad_from = 0
7983  ad_from0 = 0
7984  ad_to = 0
7985  ad_to0 = 0
7986  branch = 0
7987 
7988  CALL poprealarray(logp, bd%ied - bd%isd + 1)
7989  CALL popinteger(ilast)
7990  CALL popinteger(jfirst)
7991  CALL poprealarray(p1d, bd%ied - bd%isd + 1)
7992  CALL popinteger(jlast)
7993  CALL popinteger(ie)
7994  CALL popinteger(is)
7995  CALL popinteger(ifirst)
7996  g1d_ad = 0.0_8
7997  logp_ad = 0.0
7998  p1d_ad = 0.0_8
7999  DO j=jlast,jfirst,-1
8000  CALL popcontrol(1,branch)
8001  IF (branch .EQ. 0) THEN
8002  DO k=km,1,-1
8003  DO i=ie,is,-1
8004  CALL poprealarray(pkz(i, j, k))
8005  temp = akap*(peln(i, k+1, j)-peln(i, k, j))
8006  temp_ad0 = pkz_ad(i, j, k)/temp
8007  temp_ad1 = -((pk(i, j, k+1)-pk(i, j, k))*akap*temp_ad0/temp)
8008  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp_ad0
8009  pk_ad(i, j, k) = pk_ad(i, j, k) - temp_ad0
8010  peln_ad(i, k+1, j) = peln_ad(i, k+1, j) + temp_ad1
8011  peln_ad(i, k, j) = peln_ad(i, k, j) - temp_ad1
8012  pkz_ad(i, j, k) = 0.0
8013  END DO
8014  END DO
8015  END IF
8016  DO k=1,km,1
8017  DO i=ilast,ifirst,-1
8018  CALL poprealarray(gz(i, j, k))
8019  g1d_ad(i) = g1d_ad(i) + gz_ad(i, j, k)
8020  gz_ad(i, j, k) = 0.0
8021  temp_ad = cp_air*pt(i, j, k)*g1d_ad(i)
8022  pt_ad(i, j, k) = pt_ad(i, j, k) + cp_air*(pk(i, j, k+1)-pk(i, &
8023 & j, k))*g1d_ad(i)
8024  pk_ad(i, j, k+1) = pk_ad(i, j, k+1) + temp_ad
8025  pk_ad(i, j, k) = pk_ad(i, j, k) - temp_ad
8026  END DO
8027  END DO
8028  DO k=km+1,2,-1
8029  CALL popcontrol(2,branch)
8030  IF (branch .NE. 0) THEN
8031  IF (branch .NE. 1) THEN
8032  DO i=ie,is,-1
8033  CALL poprealarray(peln(i, k, j))
8034  logp_ad(i) = logp_ad(i) + peln_ad(i, k, j)
8035  peln_ad(i, k, j) = 0.0
8036  END DO
8037  END IF
8038  CALL popinteger(ad_from0)
8039  CALL popinteger(ad_to0)
8040  DO i=ad_to0,ad_from0,-1
8041  CALL poprealarray(pe(i, k, j))
8042  p1d_ad(i) = p1d_ad(i) + pe_ad(i, k, j)
8043  pe_ad(i, k, j) = 0.0
8044  END DO
8045  END IF
8046  DO i=ilast,ifirst,-1
8047  CALL poprealarray(pk(i, j, k))
8048  logp_ad(i) = logp_ad(i) + exp(akap*logp(i))*akap*pk_ad(i, j, k&
8049 & )
8050  pk_ad(i, j, k) = 0.0
8051  CALL poprealarray(logp(i))
8052  p1d_ad(i) = p1d_ad(i) + logp_ad(i)/p1d(i)
8053  logp_ad(i) = 0.0
8054  CALL poprealarray(p1d(i))
8055  delp_ad(i, j, k-1) = delp_ad(i, j, k-1) + p1d_ad(i)
8056  END DO
8057  END DO
8058  CALL popcontrol(1,branch)
8059  IF (branch .NE. 0) THEN
8060  CALL popinteger(ad_from)
8061  CALL popinteger(ad_to)
8062  DO i=ad_to,ad_from,-1
8063  CALL poprealarray(pe(i, 1, j))
8064  pe_ad(i, 1, j) = 0.0
8065  END DO
8066  END IF
8067  CALL popcontrol(1,branch)
8068  IF (branch .EQ. 0) THEN
8069  DO i=ie,is,-1
8070  CALL poprealarray(peln(i, 1, j))
8071  peln_ad(i, 1, j) = 0.0
8072  END DO
8073  END IF
8074  DO i=ilast,ifirst,-1
8075  CALL poprealarray(gz(i, j, km+1))
8076  gz_ad(i, j, km+1) = 0.0
8077  g1d_ad(i) = 0.0_8
8078  CALL poprealarray(pk(i, j, 1))
8079  pk_ad(i, j, 1) = 0.0
8080  CALL poprealarray(p1d(i))
8081  p1d_ad(i) = 0.0_8
8082  END DO
8083  END DO
8084  CALL popcontrol(1,branch)
8085  END SUBROUTINE geopk_bwd
8086  SUBROUTINE geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km&
8087 & , akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
8088  IMPLICIT NONE
8089  INTEGER, INTENT(IN) :: km, npx, npy, a2b_ord
8090  REAL, INTENT(IN) :: akap, ptop
8091  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8092  REAL, INTENT(IN) :: hs(bd%isd:bd%ied, bd%jsd:bd%jed)
8093  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: pt&
8094 & , delp
8095  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
8096 & q_con
8097  LOGICAL, INTENT(IN) :: cg, nested, computehalo
8098 ! !OUTPUT PARAMETERS
8099  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1), INTENT(OUT) :: &
8100 & gz, pk
8101  REAL, INTENT(OUT) :: pe(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
8102 ! ln(pe)
8103  REAL, INTENT(OUT) :: peln(bd%is:bd%ie, km+1, bd%js:bd%je)
8104  REAL, INTENT(OUT) :: pkz(bd%is:bd%ie, bd%js:bd%je, km)
8105 ! !DESCRIPTION:
8106 ! Calculates geopotential and pressure to the kappa.
8107 ! Local:
8108  REAL :: peg(bd%isd:bd%ied, km+1)
8109  REAL :: pkg(bd%isd:bd%ied, km+1)
8110  REAL(kind=8) :: p1d(bd%isd:bd%ied)
8111  REAL(kind=8) :: g1d(bd%isd:bd%ied)
8112  REAL :: logp(bd%isd:bd%ied)
8113  INTEGER :: i, j, k
8114  INTEGER :: ifirst, ilast
8115  INTEGER :: jfirst, jlast
8116  INTEGER :: is, ie, js, je
8117  INTEGER :: isd, ied, jsd, jed
8118  INTRINSIC max
8119  INTRINSIC min
8120  INTRINSIC log
8121  INTRINSIC exp
8122  INTEGER :: max1
8123  INTEGER :: max2
8124  INTEGER :: min1
8125  INTEGER :: min2
8126  is = bd%is
8127  ie = bd%ie
8128  js = bd%js
8129  je = bd%je
8130  isd = bd%isd
8131  ied = bd%ied
8132  jsd = bd%jsd
8133  jed = bd%jed
8134  IF ((.NOT.cg .AND. a2b_ord .EQ. 4) .OR. (nested .AND. (.NOT.cg))) &
8135 & THEN
8136 ! D-Grid
8137  ifirst = is - 2
8138  ilast = ie + 2
8139  jfirst = js - 2
8140  jlast = je + 2
8141  ELSE
8142  ifirst = is - 1
8143  ilast = ie + 1
8144  jfirst = js - 1
8145  jlast = je + 1
8146  END IF
8147  IF (nested .AND. computehalo) THEN
8148  IF (is .EQ. 1) ifirst = isd
8149  IF (ie .EQ. npx - 1) ilast = ied
8150  IF (js .EQ. 1) jfirst = jsd
8151  IF (je .EQ. npy - 1) jlast = jed
8152  END IF
8153 !$OMP parallel do default(none) shared(jfirst,jlast,ifirst,ilast,pk,km,gz,hs,ptop,ptk, &
8154 !$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz,q_con) &
8155 !$OMP private(peg, pkg, p1d, g1d, logp)
8156  DO j=jfirst,jlast
8157  DO i=ifirst,ilast
8158  p1d(i) = ptop
8159  pk(i, j, 1) = ptk
8160  g1d(i) = hs(i, j)
8161  gz(i, j, km+1) = hs(i, j)
8162  END DO
8163  IF (j .GE. js .AND. j .LE. je) THEN
8164  DO i=is,ie
8165  peln(i, 1, j) = peln1
8166  END DO
8167  END IF
8168  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
8169  IF (ifirst .LT. is - 1) THEN
8170  max1 = is - 1
8171  ELSE
8172  max1 = ifirst
8173  END IF
8174  IF (ilast .GT. ie + 1) THEN
8175  min1 = ie + 1
8176  ELSE
8177  min1 = ilast
8178  END IF
8179  DO i=max1,min1
8180  pe(i, 1, j) = ptop
8181  END DO
8182  END IF
8183 ! Top down
8184  DO k=2,km+1
8185  DO i=ifirst,ilast
8186  p1d(i) = p1d(i) + delp(i, j, k-1)
8187  logp(i) = log(p1d(i))
8188  pk(i, j, k) = exp(akap*logp(i))
8189  END DO
8190  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
8191  IF (ifirst .LT. is - 1) THEN
8192  max2 = is - 1
8193  ELSE
8194  max2 = ifirst
8195  END IF
8196  IF (ilast .GT. ie + 1) THEN
8197  min2 = ie + 1
8198  ELSE
8199  min2 = ilast
8200  END IF
8201  DO i=max2,min2
8202  pe(i, k, j) = p1d(i)
8203  END DO
8204  IF (j .GE. js .AND. j .LE. je) THEN
8205  DO i=is,ie
8206  peln(i, k, j) = logp(i)
8207  END DO
8208  END IF
8209  END IF
8210  END DO
8211 ! Bottom up
8212  DO k=km,1,-1
8213  DO i=ifirst,ilast
8214  g1d(i) = g1d(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k&
8215 & ))
8216  gz(i, j, k) = g1d(i)
8217  END DO
8218  END DO
8219  IF (.NOT.cg .AND. j .GE. js .AND. j .LE. je) THEN
8220  DO k=1,km
8221  DO i=is,ie
8222  pkz(i, j, k) = (pk(i, j, k+1)-pk(i, j, k))/(akap*(peln(i, k+&
8223 & 1, j)-peln(i, k, j)))
8224  END DO
8225  END DO
8226  END IF
8227  END DO
8228  END SUBROUTINE geopk
8229 ! Differentiation of del2_cubed in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_m
8230 !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_
8231 !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
8232 !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
8233 !_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord
8234 !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
8235 !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
8236 !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
8237 !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
8238 !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
8239 !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_
8240 !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
8241 !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
8242 !.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
8243 !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_
8244 !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_
8245 !mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils
8246 !_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
8247 ! gradient of useful results: q
8248 ! with respect to varying inputs: q
8249  SUBROUTINE del2_cubed_fwd(q, cd, gridstruct, domain, npx, npy, km, &
8250 & nmax, bd)
8251  IMPLICIT NONE
8252 !---------------------------------------------------------------
8253 ! This routine is for filtering the omega field for the physics
8254 !---------------------------------------------------------------
8255  INTEGER, INTENT(IN) :: npx, npy, km, nmax
8256 ! cd = K * da_min; 0 < K < 0.25
8257  REAL(kind=r_grid), INTENT(IN) :: cd
8258  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
8259  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km)
8260  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
8261  TYPE(DOMAIN2D), INTENT(INOUT) :: domain
8262  REAL, PARAMETER :: r3=1./3.
8263  REAL :: fx(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy(bd%isd:bd%ied, bd%jsd&
8264 & :bd%jed+1)
8265  REAL :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
8266  INTEGER :: i, j, k, n, nt, ntimes
8267  INTEGER :: is, ie, js, je
8268  INTEGER :: isd, ied, jsd, jed
8269  INTRINSIC min
8270  INTEGER :: ad_from
8271  INTEGER :: ad_from0
8272  INTEGER :: ad_from1
8273  INTEGER :: ad_from2
8274  INTEGER :: ad_from3
8275  INTEGER :: ad_from4
8276  REAL :: tmp
8277  REAL :: tmp0
8278  REAL :: tmp1
8279  REAL :: tmp2
8280  REAL :: tmp3
8281  REAL :: tmp4
8282  REAL :: tmp5
8283 
8284  fx = 0.0
8285  fy = 0.0
8286  q2 = 0.0
8287  nt = 0
8288  ntimes = 0
8289  is = 0
8290  ie = 0
8291  js = 0
8292  je = 0
8293  isd = 0
8294  ied = 0
8295  jsd = 0
8296  jed = 0
8297  ad_from = 0
8298  ad_from0 = 0
8299  ad_from1 = 0
8300  ad_from2 = 0
8301  ad_from3 = 0
8302  ad_from4 = 0
8303  tmp = 0.0
8304  tmp0 = 0.0
8305  tmp1 = 0.0
8306  tmp2 = 0.0
8307  tmp3 = 0.0
8308  tmp4 = 0.0
8309  tmp5 = 0.0
8310 
8311 !Local routine pointers
8312 ! real, pointer, dimension(:,:) :: rarea
8313 ! real, pointer, dimension(:,:) :: del6_u, del6_v
8314 ! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner
8315  is = bd%is
8316  ie = bd%ie
8317  js = bd%js
8318  je = bd%je
8319  isd = bd%isd
8320  ied = bd%ied
8321  jsd = bd%jsd
8322  jed = bd%jed
8323  IF (3 .GT. nmax) THEN
8324  ntimes = nmax
8325  ELSE
8326  ntimes = 3
8327  END IF
8328  CALL pushrealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*km)
8329  CALL mpp_update_domains(q, domain, complete=.true.)
8330  DO n=1,ntimes
8331  nt = ntimes - n
8332 !$OMP parallel do default(none) shared(km,q,is,ie,js,je,npx,npy, &
8333 !$OMP nt,isd,jsd,gridstruct,bd, &
8334 !$OMP cd) &
8335 !$OMP private(fx, fy)
8336  DO k=1,km
8337  IF (gridstruct%sw_corner) THEN
8338  q(1, 1, k) = (q(1, 1, k)+q(0, 1, k)+q(1, 0, k))*r3
8339  q(0, 1, k) = q(1, 1, k)
8340  q(1, 0, k) = q(1, 1, k)
8341  CALL pushcontrol(1,0)
8342  ELSE
8343  CALL pushcontrol(1,1)
8344  END IF
8345  IF (gridstruct%se_corner) THEN
8346  tmp0 = (q(ie, 1, k)+q(npx, 1, k)+q(ie, 0, k))*r3
8347  q(ie, 1, k) = tmp0
8348  tmp = q(ie, 1, k)
8349  q(npx, 1, k) = tmp
8350  q(ie, 0, k) = q(ie, 1, k)
8351  CALL pushcontrol(1,0)
8352  ELSE
8353  CALL pushcontrol(1,1)
8354  END IF
8355  IF (gridstruct%ne_corner) THEN
8356  tmp3 = (q(ie, je, k)+q(npx, je, k)+q(ie, npy, k))*r3
8357  q(ie, je, k) = tmp3
8358  tmp2 = q(ie, je, k)
8359  q(npx, je, k) = tmp2
8360  tmp1 = q(ie, je, k)
8361  q(ie, npy, k) = tmp1
8362  CALL pushcontrol(1,0)
8363  ELSE
8364  CALL pushcontrol(1,1)
8365  END IF
8366  IF (gridstruct%nw_corner) THEN
8367  tmp5 = (q(1, je, k)+q(0, je, k)+q(1, npy, k))*r3
8368  q(1, je, k) = tmp5
8369  q(0, je, k) = q(1, je, k)
8370  tmp4 = q(1, je, k)
8371  q(1, npy, k) = tmp4
8372  CALL pushcontrol(1,0)
8373  ELSE
8374  CALL pushcontrol(1,1)
8375  END IF
8376  IF (nt .GT. 0) THEN
8377  CALL copy_corners(q(isd:ied, jsd:jed, k), npx, npy, 1, &
8378 & gridstruct%nested, bd, gridstruct%sw_corner, &
8379 & gridstruct%se_corner, gridstruct%nw_corner, &
8380 & gridstruct%ne_corner)
8381  CALL pushcontrol(1,1)
8382  ELSE
8383  CALL pushcontrol(1,0)
8384  END IF
8385  ad_from0 = js - nt
8386  DO j=ad_from0,je+nt
8387  ad_from = is - nt
8388  DO i=ad_from,ie+1+nt
8389  fx(i, j) = gridstruct%del6_v(i, j)*(q(i-1, j, k)-q(i, j, k))
8390  END DO
8391  CALL pushinteger(i - 1)
8392  CALL pushinteger(ad_from)
8393  END DO
8394  CALL pushinteger(j - 1)
8395  CALL pushinteger(ad_from0)
8396  IF (nt .GT. 0) THEN
8397  CALL copy_corners(q(isd:ied, jsd:jed, k), npx, npy, 2, &
8398 & gridstruct%nested, bd, gridstruct%sw_corner, &
8399 & gridstruct%se_corner, gridstruct%nw_corner, &
8400 & gridstruct%ne_corner)
8401  CALL pushcontrol(1,1)
8402  ELSE
8403  CALL pushcontrol(1,0)
8404  END IF
8405  ad_from2 = js - nt
8406  DO j=ad_from2,je+1+nt
8407  ad_from1 = is - nt
8408  DO i=ad_from1,ie+nt
8409  fy(i, j) = gridstruct%del6_u(i, j)*(q(i, j-1, k)-q(i, j, k))
8410  END DO
8411  CALL pushinteger(i - 1)
8412  CALL pushinteger(ad_from1)
8413  END DO
8414  CALL pushinteger(j - 1)
8415  CALL pushinteger(ad_from2)
8416  ad_from4 = js - nt
8417  DO j=ad_from4,je+nt
8418  ad_from3 = is - nt
8419  DO i=ad_from3,ie+nt
8420  q(i, j, k) = q(i, j, k) + cd*gridstruct%rarea(i, j)*(fx(i, j&
8421 & )-fx(i+1, j)+fy(i, j)-fy(i, j+1))
8422  END DO
8423  CALL pushinteger(i - 1)
8424  CALL pushinteger(ad_from3)
8425  END DO
8426  CALL pushinteger(j - 1)
8427  CALL pushinteger(ad_from4)
8428  END DO
8429  END DO
8430  CALL pushinteger(jed)
8431  CALL pushinteger(je)
8432  CALL pushinteger(isd)
8433  CALL pushinteger(ie)
8434  CALL pushinteger(ied)
8435  CALL pushinteger(jsd)
8436  CALL pushinteger(ntimes)
8437  END SUBROUTINE del2_cubed_fwd
8438 ! Differentiation of del2_cubed in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
8439 !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
8440 !_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.
8441 !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
8442 !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
8443 !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
8444 !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
8445 !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
8446 ! 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_
8447 !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
8448 !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
8449 !_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
8450 !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
8451 !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
8452 !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
8453 !_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
8454 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
8455 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
8456 ! gradient of useful results: q
8457 ! with respect to varying inputs: q
8458  SUBROUTINE del2_cubed_bwd(q, q_ad, cd, gridstruct, domain, npx, npy, &
8459 & km, nmax, bd)
8460  IMPLICIT NONE
8461  INTEGER, INTENT(IN) :: npx, npy, km, nmax
8462  REAL(kind=r_grid), INTENT(IN) :: cd
8463  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
8464  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km)
8465  REAL, INTENT(INOUT) :: q_ad(bd%isd:bd%ied, bd%jsd:bd%jed, km)
8466  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
8467  TYPE(domain2d), INTENT(INOUT) :: domain
8468  REAL, PARAMETER :: r3=1./3.
8469  REAL :: fx(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy(bd%isd:bd%ied, bd%jsd&
8470 & :bd%jed+1)
8471  REAL :: fx_ad(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy_ad(bd%isd:bd%ied, &
8472 & bd%jsd:bd%jed+1)
8473  REAL :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
8474  INTEGER :: i, j, k, n, nt, ntimes
8475  INTEGER :: is, ie, js, je
8476  INTEGER :: isd, ied, jsd, jed
8477  INTRINSIC min
8478  REAL :: temp_ad
8479  REAL :: tmp_ad
8480  REAL :: tmp_ad0
8481  REAL :: temp_ad0
8482  REAL :: tmp_ad1
8483  REAL :: tmp_ad2
8484  REAL :: tmp_ad3
8485  REAL :: temp_ad1
8486  REAL :: tmp_ad4
8487  REAL :: tmp_ad5
8488  REAL :: temp_ad2
8489  REAL :: temp_ad3
8490  REAL :: temp_ad4
8491  REAL :: temp_ad5
8492  INTEGER :: ad_from
8493  INTEGER :: ad_to
8494  INTEGER :: ad_from0
8495  INTEGER :: ad_to0
8496  INTEGER :: ad_from1
8497  INTEGER :: ad_to1
8498  INTEGER :: ad_from2
8499  INTEGER :: ad_to2
8500  INTEGER :: ad_from3
8501  INTEGER :: ad_to3
8502  INTEGER :: ad_from4
8503  INTEGER :: ad_to4
8504  INTEGER :: branch
8505 
8506  fx = 0.0
8507  fy = 0.0
8508  q2 = 0.0
8509  nt = 0
8510  ntimes = 0
8511  is = 0
8512  ie = 0
8513  js = 0
8514  je = 0
8515  isd = 0
8516  ied = 0
8517  jsd = 0
8518  jed = 0
8519  ad_from = 0
8520  ad_from0 = 0
8521  ad_from1 = 0
8522  ad_from2 = 0
8523  ad_from3 = 0
8524  ad_from4 = 0
8525  ad_to = 0
8526  ad_to0 = 0
8527  ad_to1 = 0
8528  ad_to2 = 0
8529  ad_to3 = 0
8530  ad_to4 = 0
8531  branch = 0
8532 
8533  CALL popinteger(ntimes)
8534  CALL popinteger(jsd)
8535  CALL popinteger(ied)
8536  CALL popinteger(ie)
8537  CALL popinteger(isd)
8538  CALL popinteger(je)
8539  CALL popinteger(jed)
8540  fx_ad = 0.0
8541  fy_ad = 0.0
8542  DO n=ntimes,1,-1
8543  DO k=km,1,-1
8544  CALL popinteger(ad_from4)
8545  CALL popinteger(ad_to4)
8546  DO j=ad_to4,ad_from4,-1
8547  CALL popinteger(ad_from3)
8548  CALL popinteger(ad_to3)
8549  DO i=ad_to3,ad_from3,-1
8550  temp_ad5 = cd*gridstruct%rarea(i, j)*q_ad(i, j, k)
8551  fx_ad(i, j) = fx_ad(i, j) + temp_ad5
8552  fx_ad(i+1, j) = fx_ad(i+1, j) - temp_ad5
8553  fy_ad(i, j) = fy_ad(i, j) + temp_ad5
8554  fy_ad(i, j+1) = fy_ad(i, j+1) - temp_ad5
8555  END DO
8556  END DO
8557  CALL popinteger(ad_from2)
8558  CALL popinteger(ad_to2)
8559  DO j=ad_to2,ad_from2,-1
8560  CALL popinteger(ad_from1)
8561  CALL popinteger(ad_to1)
8562  DO i=ad_to1,ad_from1,-1
8563  temp_ad4 = gridstruct%del6_u(i, j)*fy_ad(i, j)
8564  q_ad(i, j-1, k) = q_ad(i, j-1, k) + temp_ad4
8565  q_ad(i, j, k) = q_ad(i, j, k) - temp_ad4
8566  fy_ad(i, j) = 0.0
8567  END DO
8568  END DO
8569  CALL popcontrol(1,branch)
8570  IF (branch .NE. 0) CALL copy_corners_adm(q(isd:ied, jsd:jed, k)&
8571 & , q_ad(isd:ied, jsd:jed, k), &
8572 & npx, npy, 2, gridstruct%&
8573 & nested, bd, gridstruct%&
8574 & sw_corner, gridstruct%&
8575 & se_corner, gridstruct%&
8576 & nw_corner, gridstruct%&
8577 & ne_corner)
8578  CALL popinteger(ad_from0)
8579  CALL popinteger(ad_to0)
8580  DO j=ad_to0,ad_from0,-1
8581  CALL popinteger(ad_from)
8582  CALL popinteger(ad_to)
8583  DO i=ad_to,ad_from,-1
8584  temp_ad3 = gridstruct%del6_v(i, j)*fx_ad(i, j)
8585  q_ad(i-1, j, k) = q_ad(i-1, j, k) + temp_ad3
8586  q_ad(i, j, k) = q_ad(i, j, k) - temp_ad3
8587  fx_ad(i, j) = 0.0
8588  END DO
8589  END DO
8590  CALL popcontrol(1,branch)
8591  IF (branch .NE. 0) CALL copy_corners_adm(q(isd:ied, jsd:jed, k)&
8592 & , q_ad(isd:ied, jsd:jed, k), &
8593 & npx, npy, 1, gridstruct%&
8594 & nested, bd, gridstruct%&
8595 & sw_corner, gridstruct%&
8596 & se_corner, gridstruct%&
8597 & nw_corner, gridstruct%&
8598 & ne_corner)
8599  CALL popcontrol(1,branch)
8600  IF (branch .EQ. 0) THEN
8601  tmp_ad4 = q_ad(1, npy, k)
8602  q_ad(1, npy, k) = 0.0
8603  q_ad(1, je, k) = q_ad(1, je, k) + q_ad(0, je, k) + tmp_ad4
8604  q_ad(0, je, k) = 0.0
8605  tmp_ad5 = q_ad(1, je, k)
8606  temp_ad2 = r3*tmp_ad5
8607  q_ad(1, je, k) = temp_ad2
8608  q_ad(0, je, k) = q_ad(0, je, k) + temp_ad2
8609  q_ad(1, npy, k) = q_ad(1, npy, k) + temp_ad2
8610  END IF
8611  CALL popcontrol(1,branch)
8612  IF (branch .EQ. 0) THEN
8613  tmp_ad1 = q_ad(ie, npy, k)
8614  q_ad(ie, npy, k) = 0.0
8615  q_ad(ie, je, k) = q_ad(ie, je, k) + tmp_ad1
8616  tmp_ad2 = q_ad(npx, je, k)
8617  q_ad(npx, je, k) = 0.0
8618  q_ad(ie, je, k) = q_ad(ie, je, k) + tmp_ad2
8619  tmp_ad3 = q_ad(ie, je, k)
8620  temp_ad1 = r3*tmp_ad3
8621  q_ad(ie, je, k) = temp_ad1
8622  q_ad(npx, je, k) = q_ad(npx, je, k) + temp_ad1
8623  q_ad(ie, npy, k) = q_ad(ie, npy, k) + temp_ad1
8624  END IF
8625  CALL popcontrol(1,branch)
8626  IF (branch .EQ. 0) THEN
8627  q_ad(ie, 1, k) = q_ad(ie, 1, k) + q_ad(ie, 0, k)
8628  q_ad(ie, 0, k) = 0.0
8629  tmp_ad = q_ad(npx, 1, k)
8630  q_ad(npx, 1, k) = 0.0
8631  q_ad(ie, 1, k) = q_ad(ie, 1, k) + tmp_ad
8632  tmp_ad0 = q_ad(ie, 1, k)
8633  temp_ad0 = r3*tmp_ad0
8634  q_ad(ie, 1, k) = temp_ad0
8635  q_ad(npx, 1, k) = q_ad(npx, 1, k) + temp_ad0
8636  q_ad(ie, 0, k) = q_ad(ie, 0, k) + temp_ad0
8637  END IF
8638  CALL popcontrol(1,branch)
8639  IF (branch .EQ. 0) THEN
8640  q_ad(1, 1, k) = q_ad(1, 1, k) + q_ad(1, 0, k)
8641  q_ad(1, 0, k) = 0.0
8642  q_ad(1, 1, k) = q_ad(1, 1, k) + q_ad(0, 1, k)
8643  q_ad(0, 1, k) = 0.0
8644  temp_ad = r3*q_ad(1, 1, k)
8645  q_ad(0, 1, k) = q_ad(0, 1, k) + temp_ad
8646  q_ad(1, 0, k) = q_ad(1, 0, k) + temp_ad
8647  q_ad(1, 1, k) = temp_ad
8648  END IF
8649  END DO
8650  END DO
8651  CALL poprealarray(q, (bd%ied-bd%isd+1)*(bd%jed-bd%jsd+1)*km)
8652  CALL mpp_update_domains_adm(q, q_ad, domain, complete=.true.)
8653  END SUBROUTINE del2_cubed_bwd
8654  SUBROUTINE del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, &
8655 & bd)
8656  IMPLICIT NONE
8657 !---------------------------------------------------------------
8658 ! This routine is for filtering the omega field for the physics
8659 !---------------------------------------------------------------
8660  INTEGER, INTENT(IN) :: npx, npy, km, nmax
8661 ! cd = K * da_min; 0 < K < 0.25
8662  REAL(kind=r_grid), INTENT(IN) :: cd
8663  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
8664  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km)
8665  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
8666  TYPE(domain2d), INTENT(INOUT) :: domain
8667  REAL, PARAMETER :: r3=1./3.
8668  REAL :: fx(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy(bd%isd:bd%ied, bd%jsd&
8669 & :bd%jed+1)
8670  REAL :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
8671  INTEGER :: i, j, k, n, nt, ntimes
8672  INTEGER :: is, ie, js, je
8673  INTEGER :: isd, ied, jsd, jed
8674  INTRINSIC min
8675 !Local routine pointers
8676 ! real, pointer, dimension(:,:) :: rarea
8677 ! real, pointer, dimension(:,:) :: del6_u, del6_v
8678 ! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner
8679  is = bd%is
8680  ie = bd%ie
8681  js = bd%js
8682  je = bd%je
8683  isd = bd%isd
8684  ied = bd%ied
8685  jsd = bd%jsd
8686  jed = bd%jed
8687  IF (3 .GT. nmax) THEN
8688  ntimes = nmax
8689  ELSE
8690  ntimes = 3
8691  END IF
8692  CALL timing_on('COMM_TOTAL')
8693  CALL mpp_update_domains(q, domain, complete=.true.)
8694  CALL timing_off('COMM_TOTAL')
8695  DO n=1,ntimes
8696  nt = ntimes - n
8697 !$OMP parallel do default(none) shared(km,q,is,ie,js,je,npx,npy, &
8698 !$OMP nt,isd,jsd,gridstruct,bd, &
8699 !$OMP cd) &
8700 !$OMP private(fx, fy)
8701  DO k=1,km
8702  IF (gridstruct%sw_corner) THEN
8703  q(1, 1, k) = (q(1, 1, k)+q(0, 1, k)+q(1, 0, k))*r3
8704  q(0, 1, k) = q(1, 1, k)
8705  q(1, 0, k) = q(1, 1, k)
8706  END IF
8707  IF (gridstruct%se_corner) THEN
8708  q(ie, 1, k) = (q(ie, 1, k)+q(npx, 1, k)+q(ie, 0, k))*r3
8709  q(npx, 1, k) = q(ie, 1, k)
8710  q(ie, 0, k) = q(ie, 1, k)
8711  END IF
8712  IF (gridstruct%ne_corner) THEN
8713  q(ie, je, k) = (q(ie, je, k)+q(npx, je, k)+q(ie, npy, k))*r3
8714  q(npx, je, k) = q(ie, je, k)
8715  q(ie, npy, k) = q(ie, je, k)
8716  END IF
8717  IF (gridstruct%nw_corner) THEN
8718  q(1, je, k) = (q(1, je, k)+q(0, je, k)+q(1, npy, k))*r3
8719  q(0, je, k) = q(1, je, k)
8720  q(1, npy, k) = q(1, je, k)
8721  END IF
8722  IF (nt .GT. 0) CALL copy_corners(q(isd:ied, jsd:jed, k), npx, &
8723 & npy, 1, gridstruct%nested, bd, &
8724 & gridstruct%sw_corner, gridstruct%&
8725 & se_corner, gridstruct%nw_corner, &
8726 & gridstruct%ne_corner)
8727  DO j=js-nt,je+nt
8728  DO i=is-nt,ie+1+nt
8729  fx(i, j) = gridstruct%del6_v(i, j)*(q(i-1, j, k)-q(i, j, k))
8730  END DO
8731  END DO
8732  IF (nt .GT. 0) CALL copy_corners(q(isd:ied, jsd:jed, k), npx, &
8733 & npy, 2, gridstruct%nested, bd, &
8734 & gridstruct%sw_corner, gridstruct%&
8735 & se_corner, gridstruct%nw_corner, &
8736 & gridstruct%ne_corner)
8737  DO j=js-nt,je+1+nt
8738  DO i=is-nt,ie+nt
8739  fy(i, j) = gridstruct%del6_u(i, j)*(q(i, j-1, k)-q(i, j, k))
8740  END DO
8741  END DO
8742  DO j=js-nt,je+nt
8743  DO i=is-nt,ie+nt
8744  q(i, j, k) = q(i, j, k) + cd*gridstruct%rarea(i, j)*(fx(i, j&
8745 & )-fx(i+1, j)+fy(i, j)-fy(i, j+1))
8746  END DO
8747  END DO
8748  END DO
8749  END DO
8750  END SUBROUTINE del2_cubed
8751  SUBROUTINE init_ijk_mem(i1, i2, j1, j2, km, array, var)
8752  IMPLICIT NONE
8753  INTEGER, INTENT(IN) :: i1, i2, j1, j2, km
8754  REAL, INTENT(INOUT) :: array(i1:i2, j1:j2, km)
8755  REAL, INTENT(IN) :: var
8756  INTEGER :: i, j, k
8757 !$OMP parallel do default(none) shared(i1,i2,j1,j2,km,array,var)
8758  DO k=1,km
8759  DO j=j1,j2
8760  DO i=i1,i2
8761  array(i, j, k) = var
8762  END DO
8763  END DO
8764  END DO
8765  END SUBROUTINE init_ijk_mem
8766  SUBROUTINE rayleigh_fast(dt, npx, npy, npz, pfull, tau, u, v, w, ptop&
8767 & , hydrostatic, rf_cutoff, bd)
8768  IMPLICIT NONE
8769 ! Simple "inline" version of the Rayleigh friction
8770  REAL, INTENT(IN) :: dt
8771 ! time scale (days)
8772  REAL, INTENT(IN) :: tau
8773  REAL, INTENT(IN) :: ptop, rf_cutoff
8774  INTEGER, INTENT(IN) :: npx, npy, npz
8775  REAL, DIMENSION(npz), INTENT(IN) :: pfull
8776  LOGICAL, INTENT(IN) :: hydrostatic
8777  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
8778 ! D grid zonal wind (m/s)
8779  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
8780 ! D grid meridional wind (m/s)
8781  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
8782 ! cell center vertical wind (m/s)
8783  REAL, INTENT(INOUT) :: w(bd%isd:, bd%jsd:, :)
8784 !
8785  REAL(kind=r_grid) :: rff(npz)
8786  REAL, PARAMETER :: sday=86400.
8787  REAL :: tau0
8788  INTEGER :: i, j, k
8789  INTEGER :: is, ie, js, je
8790  INTEGER :: isd, ied, jsd, jed
8791  REAL :: rf(npz)
8792  INTRINSIC log
8793  INTRINSIC sin
8794  is = bd%is
8795  ie = bd%ie
8796  js = bd%js
8797  je = bd%je
8798  isd = bd%isd
8799  ied = bd%ied
8800  jsd = bd%jsd
8801  jed = bd%jed
8802  IF (.NOT.rff_initialized) THEN
8803  tau0 = tau*sday
8804 !allocate( rf(npz) )
8805  rf(:) = 1.
8806  IF (is_master()) WRITE(6, *) &
8807 & 'Fast Rayleigh friction E-folding time (days):'
8808  DO k=1,npz
8809  IF (pfull(k) .LT. rf_cutoff) THEN
8810  rff(k) = dt/tau0*sin(0.5*pi*log(rf_cutoff/pfull(k))/log(&
8811 & rf_cutoff/ptop))**2
8812 ! Re-FACTOR rf
8813 !if( is_master() ) write(6,*) k, 0.01*pfull(k), dt/(rff(k)*sday)
8814  kmax = k
8815  rff(k) = 1.d0/(1.0d0+rff(k))
8816  rf(k) = rff(k)
8817  ELSE
8818  GOTO 100
8819  END IF
8820  END DO
8821  100 rff_initialized = .true.
8822  END IF
8823 !$OMP parallel do default(none) shared(is,ie,js,je,kmax,pfull,rf_cutoff,w,rf,u,v,hydrostatic)
8824  DO k=1,kmax
8825  IF (pfull(k) .LT. rf_cutoff) THEN
8826  DO j=js,je+1
8827  DO i=is,ie
8828  u(i, j, k) = rf(k)*u(i, j, k)
8829  END DO
8830  END DO
8831  DO j=js,je
8832  DO i=is,ie+1
8833  v(i, j, k) = rf(k)*v(i, j, k)
8834  END DO
8835  END DO
8836  IF (.NOT.hydrostatic) THEN
8837  DO j=js,je
8838  DO i=is,ie
8839  w(i, j, k) = rf(k)*w(i, j, k)
8840  END DO
8841  END DO
8842  END IF
8843  END IF
8844  END DO
8845  END SUBROUTINE rayleigh_fast
8846 end module dyn_core_adm_mod
8847 
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
boundary_adm_mod::nested_grid_bc_apply_intt
subroutine, public nested_grid_bc_apply_intt(var_nest, istag, jstag, npx, npy, npz, bd, step, split, bc, bctype)
Definition: boundary_adm.F90:1493
constants_mod
Definition: constants.F90:24
constants_mod::radius
real, parameter, public radius
Radius of the Earth [m].
Definition: constants.F90:72
dyn_core_adm_mod::one_grad_p_fwd
subroutine one_grad_p_fwd(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
Definition: dyn_core_adm.F90:6384
mpp_parameter_mod
Definition: mpp_parameter.F90:19
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
fv_mp_adm_mod::mpp_update_domains_adm
Definition: fv_mp_adm.F90:91
a2b_edge_adm_mod::a2b_ord2_fwd
subroutine, public a2b_ord2_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:2854
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
tp_core_adm_mod
Definition: tp_core_adm.F90:20
dyn_core_adm_mod::p_grad_c_fwd
subroutine p_grad_c_fwd(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, rdyc, hydrostatic)
Definition: dyn_core_adm.F90:5117
dyn_core_adm_mod::grad1_p_update_bwd
subroutine grad1_p_update_bwd(divg2, divg2_ad, u, u_ad, v, v_ad, pk, pk_ad, gz, gz_ad, du, du_ad, dv, dv_ad, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
Definition: dyn_core_adm.F90:7048
dyn_core_adm_mod::geopk_fwd
subroutine geopk_fwd(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
Definition: dyn_core_adm.F90:7689
dyn_core_adm_mod::grad1_p_update
subroutine grad1_p_update(divg2, u, v, pk, gz, du, dv, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
Definition: dyn_core_adm.F90:7215
dyn_core_adm_mod::geopk
subroutine geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km, akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
Definition: dyn_core_adm.F90:8101
dyn_core_adm_mod::mix_dp_fwd
subroutine mix_dp_fwd(hydrostatic, w, delp, pt, km, ak, bk, cg, fv_debug, bd)
Definition: dyn_core_adm.F90:7326
a2b_edge_adm_mod::a2b_ord4
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:898
nh_core_adm_mod
Definition: nh_core_adm.F90:20
a2b_edge_adm_mod
Definition: a2b_edge_adm.F90:20
dyn_core_adm_mod::del2_cubed
subroutine, public del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, bd)
Definition: dyn_core_adm.F90:8669
test_cases_nlm_mod::case9_forcing1
subroutine, public case9_forcing1(phis, time_since_start)
Definition: test_cases_nlm.F90:4087
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
dyn_core_adm_mod::del2_cubed_bwd
subroutine, public del2_cubed_bwd(q, q_ad, cd, gridstruct, domain, npx, npy, km, nmax, bd)
Definition: dyn_core_adm.F90:8473
fv_arrays_nlm_mod::fv_diag_type
Definition: fv_arrays_nlm.F90:54
a2b_edge_adm_mod::a2b_ord2_bwd
subroutine, public a2b_ord2_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:3086
dyn_core_adm_mod::grad1_p_update_fwd
subroutine grad1_p_update_fwd(divg2, u, v, pk, gz, du, dv, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
Definition: dyn_core_adm.F90:6905
dyn_core_adm_mod::p_grad_c_bwd
subroutine p_grad_c_bwd(dt2, npz, delpc, delpc_ad, pkc, pkc_ad, gz, gz_ad, uc, uc_ad, vc, vc_ad, bd, rdxc, rdyc, hydrostatic)
Definition: dyn_core_adm.F90:5211
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
sw_core_adm_mod::c_sw_fwd
subroutine, public c_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:115
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
fv_nwp_nudge_nlm_mod
Definition: fv_nudge_nlm.F90:26
mpp_parameter_mod::corner
integer, parameter, public corner
Definition: mpp_parameter.F90:95
dyn_core_adm_mod::rgrav
real rgrav
Definition: dyn_core_adm.F90:74
test_cases_nlm_mod::case9_forcing2
subroutine, public case9_forcing2(phis)
Definition: test_cases_nlm.F90:4122
boundary_adm_mod::nested_grid_bc_apply_intt_adm
subroutine, public nested_grid_bc_apply_intt_adm(var_nest, var_nest_ad, istag, jstag, npx, npy, npz, bd, step, split, bc, bctype)
Definition: boundary_adm.F90:1376
dyn_core_adm_mod
Definition: dyn_core_adm.F90:20
dyn_core_adm_mod::adv_pe_bwd
subroutine adv_pe_bwd(ua, ua_ad, va, va_ad, pem, pem_ad, om, om_ad, gridstruct, bd, npx, npy, npz, ng)
Definition: dyn_core_adm.F90:4850
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
fv_update_phys_nlm_mod
Definition: fv_update_phys_nlm.F90:20
tp_core_adm_mod::copy_corners
subroutine, public copy_corners(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:537
dyn_core_adm_mod::pln_halo
subroutine pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3, delp)
Definition: dyn_core_adm.F90:4494
dyn_core_adm_mod::pe_halo_fwd
subroutine pe_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, delp)
Definition: dyn_core_adm.F90:4562
constants_mod::rdgas
real, parameter, public rdgas
Gas constant for dry air [J/kg/deg].
Definition: constants.F90:77
dyn_core_adm_mod::split_p_grad_bwd
subroutine split_p_grad_bwd(u, u_ad, v, v_ad, pp, pp_ad, gz, gz_ad, du, du_ad, dv, dv_ad, delp, delp_ad, pk, pk_ad, beta, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:6044
dyn_core_adm_mod::mix_dp
subroutine mix_dp(hydrostatic, w, delp, pt, km, ak, bk, cg, fv_debug, bd)
Definition: dyn_core_adm.F90:7589
dyn_core_adm_mod::adv_pe
subroutine adv_pe(ua, va, pem, om, gridstruct, bd, npx, npy, npz, ng)
Definition: dyn_core_adm.F90:5002
dyn_core_adm_mod::dyn_core_bwd
subroutine, public dyn_core_bwd(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, grav, hydrostatic, u, u_ad, v, v_ad, w, w_ad, delz, delz_ad, pt, pt_ad, q, q_ad, delp, delp_ad, pe, pe_ad, pk, pk_ad, phis, ws, ws_ad, omga, omga_ad, ptop, pfull, ua, ua_ad, va, va_ad, uc, uc_ad, vc, vc_ad, mfx, mfx_ad, mfy, mfy_ad, cx, cx_ad, cy, cy_ad, pkz, pkz_ad, peln, peln_ad, q_con, ak, bk, dpx, dpx_ad, ks, gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, end_step, gz, gz_ad, pkc, pkc_ad, ptc, ptc_ad, crx, crx_ad, xfx, xfx_ad, cry, cry_ad, yfx, yfx_ad, divgd, divgd_ad, delpc, delpc_ad, ut, ut_ad, vt, vt_ad, zh, zh_ad, pk3, pk3_ad, du, du_ad, dv, dv_ad, time_total)
Definition: dyn_core_adm.F90:1697
sw_core_adm_mod::c_sw
subroutine, public c_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, wc, ut, vt, divg_d, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:1358
dyn_core_adm_mod::pe_halo
subroutine pe_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, delp)
Definition: dyn_core_adm.F90:4661
dyn_core_adm_mod::pk3_halo_bwd
subroutine pk3_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, pk3_ad, delp, delp_ad)
Definition: dyn_core_adm.F90:4169
diag_manager_mod::send_data
Definition: diag_manager.F90:357
mpp_mod
Definition: mpp.F90:39
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
a2b_ord2
void a2b_ord2(int nx, int ny, const double *qin, const double *edge_w, const double *edge_e, const double *edge_s, const double *edge_n, double *qout, int on_west_edge, int on_east_edge, int on_south_edge, int on_north_edge)
Definition: gradient_c2l.c:119
dyn_core_adm_mod::pln_halo_bwd
subroutine pln_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3, pk3_ad, delp, delp_ad)
Definition: dyn_core_adm.F90:4428
fv_mp_adm_mod::start_group_halo_update_adm
Definition: fv_mp_adm.F90:53
sw_core_adm_mod::c_sw_bwd
subroutine, public c_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, wc, wc_ad, ut, ut_ad, vt, vt_ad, divg_d, divg_d_ad, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_adm.F90:708
mpp_domains_mod
Definition: mpp_domains.F90:128
sw_core_adm_mod
Definition: sw_core_adm.F90:20
nh_core_adm_mod::riem_solver3
subroutine, public riem_solver3(ms, dt, is, ie, js, je, km, ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, q_con, w, delz, pt, delp, zh, pe, ppe, pk3, pk, peln, ws, scale_m, p_fac, a_imp, use_logp, last_call, fp_out)
Definition: nh_core_adm.F90:539
fv_nwp_nudge_nlm_mod::breed_slp_inline
subroutine, public breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, delp, u, v, pt, q, nwat, zvir, gridstruct, ks, domain_local, bd, hydrostatic)
Definition: fv_nudge_nlm.F90:2019
a2b_edge_adm_mod::a2b_ord4_bwd
subroutine, public a2b_ord4_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:2153
constants_mod::pi
real, parameter, public pi
Ratio of circle circumference to diameter [N/A].
Definition: constants.F90:74
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
nh_core_adm_mod::riem_solver3_fwd
subroutine, public riem_solver3_fwd(ms, dt, is, ie, js, je, km, ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, q_con, w, delz, pt, delp, zh, pe, ppe, pk3, pk, peln, ws, scale_m, p_fac, a_imp, use_logp, last_call, fp_out)
Definition: nh_core_adm.F90:79
fv_timing_nlm_mod::timing_on
subroutine timing_on(blk_name)
Definition: fv_timing_nlm.F90:101
dyn_core_adm_mod::mix_dp_bwd
subroutine mix_dp_bwd(hydrostatic, w, w_ad, delp, delp_ad, pt, pt_ad, km, ak, bk, cg, fv_debug, bd)
Definition: dyn_core_adm.F90:7478
dyn_core_adm_mod::nh_p_grad_bwd
subroutine nh_p_grad_bwd(u, u_ad, v, v_ad, pp, pp_ad, gz, gz_ad, delp, delp_ad, pk, pk_ad, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:5557
tapenade_iter
Definition: tapenade_iter.F90:1
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
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
dyn_core_adm_mod::pk3_halo_fwd
subroutine pk3_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, delp)
Definition: dyn_core_adm.F90:4065
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
dyn_core_adm_mod::init_ijk_mem
subroutine, public init_ijk_mem(i1, i2, j1, j2, km, array, var)
Definition: dyn_core_adm.F90:8765
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
dyn_core_adm_mod::rff_initialized
logical rff_initialized
Definition: dyn_core_adm.F90:83
nh_core_adm_mod::riem_solver3_bwd
subroutine, public riem_solver3_bwd(ms, dt, is, ie, js, je, km, ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, q_con, w, w_ad, delz, delz_ad, pt, pt_ad, delp, delp_ad, zh, zh_ad, pe, pe_ad, ppe, ppe_ad, pk3, pk3_ad, pk, pk_ad, peln, peln_ad, ws, ws_ad, scale_m, p_fac, a_imp, use_logp, last_call, fp_out)
Definition: nh_core_adm.F90:307
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
fv_arrays_tlmadm_mod::fpp
type(fpp_type) fpp
Definition: fv_arrays_tlmadm.F90:35
diag_manager_mod
Definition: diag_manager.F90:20
fv_nwp_nudge_nlm_mod::do_adiabatic_init
logical, public do_adiabatic_init
Definition: fv_nudge_nlm.F90:57
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
fv_mp_adm_mod
Definition: fv_mp_adm.F90:1
dyn_core_adm_mod::nh_p_grad
subroutine nh_p_grad(u, v, pp, gz, delp, pk, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:5766
test_cases_nlm_mod
Definition: test_cases_nlm.F90:21
mpp_domains_mod::mpp_get_boundary
Definition: mpp_domains.F90:1900
dyn_core_adm_mod::split_p_grad_fwd
subroutine split_p_grad_fwd(u, v, pp, gz, du, dv, delp, pk, beta, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:5884
fv_mp_adm_mod::complete_group_halo_update
subroutine, public complete_group_halo_update(group, groupp, domain)
Definition: fv_mp_adm.F90:436
fv_mp_adm_mod::mpp_get_boundary_adm
Definition: fv_mp_adm.F90:102
fv_arrays_nlm_mod::fv_nest_type
Definition: fv_arrays_nlm.F90:534
dyn_core_adm_mod::rayleigh_fast
subroutine rayleigh_fast(dt, npx, npy, npz, pfull, tau, u, v, w, ptop, hydrostatic, rf_cutoff, bd)
Definition: dyn_core_adm.F90:8781
dyn_core_adm_mod::p_grad_c
subroutine p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, rdyc, hydrostatic)
Definition: dyn_core_adm.F90:5327
dyn_core_adm_mod::dyn_core_fwd
subroutine, public dyn_core_fwd(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, grav, hydrostatic, u, v, w, delz, pt, q, delp, pe, pk, phis, ws, omga, ptop, pfull, ua, va, uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, dpx, ks, gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, end_step, gz, pkc, ptc, crx, xfx, cry, yfx, divgd, delpc, ut, vt, zh, pk3, du, dv, time_total)
Definition: dyn_core_adm.F90:122
dyn_core_adm_mod::peln1
real peln1
Definition: dyn_core_adm.F90:74
sw_core_adm_mod::d_sw_bwd
subroutine, public d_sw_bwd(delpc, delpc_ad, delp, delp_ad, ptc, ptc_ad, pt, pt_ad, u, u_ad, v, v_ad, w, w_ad, uc, uc_ad, vc, vc_ad, ua, ua_ad, va, va_ad, divg_d, divg_d_ad, xflux, xflux_ad, yflux, yflux_ad, cx, cx_ad, cy, cy_ad, crx_adv, crx_adv_ad, cry_adv, cry_adv_ad, xfx_adv, xfx_adv_ad, yfx_adv, yfx_adv_ad, q_con, z_rat, z_rat_ad, kgb, heat_source, heat_source_ad, dpx, dpx_ad, zvir, sphum, nq, q, q_ad, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:3281
fv_mp_adm_mod::start_group_halo_update
Definition: fv_mp_adm.F90:45
max
#define max(a, b)
Definition: mosaic_util.h:33
dyn_core_adm_mod::geopk_bwd
subroutine geopk_bwd(ptop, pe, pe_ad, peln, peln_ad, delp, delp_ad, pk, pk_ad, gz, gz_ad, hs, pt, pt_ad, q_con, pkz, pkz_ad, km, akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
Definition: dyn_core_adm.F90:7925
dyn_core_adm_mod::ptk
real ptk
Definition: dyn_core_adm.F90:74
sw_core_adm_mod::d_sw
subroutine, public d_sw(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:4985
dyn_core_adm_mod::cnst_0p20
real(kind=r_grid), parameter cnst_0p20
Definition: dyn_core_adm.F90:80
sw_core_adm_mod::d_sw_fwd
subroutine, public d_sw_fwd(delpc, delp, ptc, pt, u, v, w, uc, vc, ua, va, divg_d, xflux, yflux, cx, cy, crx_adv, cry_adv, xfx_adv, yfx_adv, q_con, z_rat, kgb, heat_source, dpx, zvir, sphum, nq, q, k, km, inline_q, dt, hord_tr, hord_mt, hord_vt, hord_tm, hord_dp, nord, nord_v, nord_w, nord_t, dddmp, d2_bg, d4_bg, damp_v, damp_w, damp_t, d_con, hydrostatic, gridstruct, flagstruct, bd, hord_tr_pert, hord_mt_pert, hord_vt_pert, hord_tm_pert, hord_dp_pert, split_damp, nord_pert, nord_v_pert, nord_w_pert, nord_t_pert, dddmp_pert, d2_bg_pert, d4_bg_pert, damp_v_pert, damp_w_pert, damp_t_pert)
Definition: sw_core_adm.F90:1782
fv_update_phys_nlm_mod::update_dwinds_phys
subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt, u, v, gridstruct, npx, npy, npz, domain)
Definition: fv_update_phys_nlm.F90:677
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
tp_core_adm_mod::copy_corners_adm
subroutine, public copy_corners_adm(q, q_ad, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_adm.F90:6737
dyn_core_adm_mod::split_p_grad
subroutine split_p_grad(u, v, pp, gz, du, dv, delp, pk, beta, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:6258
fv_diagnostics_nlm_mod::prt_maxmin
subroutine, public prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
Definition: fv_diagnostics_nlm.F90:2771
test_cases_nlm_mod::test_case
integer, public test_case
Definition: test_cases_nlm.F90:96
boundary_adm_mod
Definition: boundary_adm.F90:20
dyn_core_adm_mod::adv_pe_fwd
subroutine adv_pe_fwd(ua, va, pem, om, gridstruct, bd, npx, npy, npz, ng)
Definition: dyn_core_adm.F90:4709
boundary_adm_mod::extrapolation_bc
subroutine, public extrapolation_bc(q, istag, jstag, npx, npy, bd, pd_in, debug_in)
Definition: boundary_adm.F90:74
fv_arrays_tlmadm_mod::fv_flags_pert_type
Definition: fv_arrays_tlmadm.F90:37
dyn_core_adm_mod::nh_p_grad_fwd
subroutine nh_p_grad_fwd(u, v, pp, gz, delp, pk, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_adm.F90:5405
dyn_core_adm_mod::one_grad_p_bwd
subroutine one_grad_p_bwd(u, u_ad, v, v_ad, pk, pk_ad, gz, gz_ad, divg2, divg2_ad, delp, delp_ad, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
Definition: dyn_core_adm.F90:6566
min
#define min(a, b)
Definition: mosaic_util.h:32
dyn_core_adm_mod::one_grad_p
subroutine one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
Definition: dyn_core_adm.F90:6760
dyn_core_adm_mod::del2_cubed_fwd
subroutine, public del2_cubed_fwd(q, cd, gridstruct, domain, npx, npy, km, nmax, bd)
Definition: dyn_core_adm.F90:8264
fv_diagnostics_nlm_mod
Definition: fv_diagnostics_nlm.F90:20
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
fv_diagnostics_nlm_mod::fv_time
type(time_type), public fv_time
Definition: fv_diagnostics_nlm.F90:61
fv_arrays_nlm_mod::fv_grid_bounds_type
Definition: fv_arrays_nlm.F90:601
dyn_core_adm_mod::pln_halo_fwd
subroutine pln_halo_fwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3, delp)
Definition: dyn_core_adm.F90:4344
dyn_core_adm_mod::dyn_core
subroutine, public dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, grav, hydrostatic, u, v, w, delz, pt, q, delp, pe, pk, phis, ws, omga, ptop, pfull, ua, va, uc, vc, mfx, mfy, cx, cy, pkz, peln, q_con, ak, bk, dpx, ks, gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, end_step, gz, pkc, ptc, crx, xfx, cry, yfx, divgd, delpc, ut, vt, zh, pk3, du, dv, time_total)
Definition: dyn_core_adm.F90:2907
dyn_core_adm_mod::pe_halo_bwd
subroutine pe_halo_bwd(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, pe_ad, delp, delp_ad)
Definition: dyn_core_adm.F90:4618
dyn_core_adm_mod::kmax
integer kmax
Definition: dyn_core_adm.F90:84
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
dyn_core_adm_mod::d3_damp
real d3_damp
Definition: dyn_core_adm.F90:75
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175
dyn_core_adm_mod::pk3_halo
subroutine pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, delp)
Definition: dyn_core_adm.F90:4270
a2b_edge_adm_mod::a2b_ord4_fwd
subroutine, public a2b_ord4_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:1413