FV3 Bundle
dyn_core_tlm.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_tlm_mod
21 
22  use constants_mod, only: rdgas, radius, cp_air, pi
23  use mpp_mod, only: mpp_pe, mpp_root_pe
24  use mpp_domains_mod, only: cgrid_ne, dgrid_ne, mpp_get_boundary, mpp_update_domains, &
25  domain2d
26  use fv_mp_tlm_mod, only: mpp_get_boundary_tlm, mpp_update_domains_tlm
27  use mpp_parameter_mod, only: corner
28  use fv_mp_nlm_mod, only: is_master
29  use fv_mp_tlm_mod, only: start_group_halo_update, complete_group_halo_update
30  use fv_mp_tlm_mod, only: start_group_halo_update_tlm
31  use fv_mp_nlm_mod, only: group_halo_update_type
32  use sw_core_tlm_mod, only: c_sw, d_sw
33  use sw_core_tlm_mod, only: c_sw_tlm, d_sw_tlm
34  use a2b_edge_tlm_mod, only: a2b_ord2, a2b_ord4
35  use a2b_edge_tlm_mod, only: a2b_ord2_tlm, a2b_ord4_tlm
36  use nh_core_tlm_mod, only: riem_solver3, riem_solver_c, update_dz_c, update_dz_d, nest_halo_nh
37  use nh_core_tlm_mod, only: riem_solver3_tlm, riem_solver_c_tlm, update_dz_c_tlm, update_dz_d_tlm, nest_halo_nh_tlm
38  use tp_core_tlm_mod, only: copy_corners
39  use tp_core_tlm_mod, only: copy_corners_tlm
40  use fv_timing_nlm_mod, only: timing_on, timing_off
41  use fv_diagnostics_nlm_mod, only: prt_maxmin, fv_time, prt_mxm
42 #ifdef ROT3
43  use fv_update_phys_nlm_mod, only: update_dwinds_phys
44 #endif
45 #if defined (ADA_NUDGE)
46  use fv_ada_nudge_mod, only: breed_slp_inline_ada
47 #else
48  use fv_nwp_nudge_nlm_mod, only: breed_slp_inline, do_adiabatic_init
49 #endif
50  use diag_manager_mod, only: send_data
51  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type, fv_nest_type, fv_diag_type, &
52  fv_grid_bounds_type, r_grid
53 
54  use boundary_tlm_mod, only: extrapolation_bc, nested_grid_bc_apply_intt
55  use boundary_tlm_mod, only: nested_grid_bc_apply_intt_tlm
56 
57 #ifdef SW_DYNAMICS
58  use test_cases_nlm_mod, only: test_case, case9_forcing1, case9_forcing2
59 #endif
60 
61  use fv_arrays_tlmadm_mod, only: fv_flags_pert_type, fpp
62 
63 implicit none
64 private
65 
66 public :: dyn_core, del2_cubed, init_ijk_mem
67 public :: dyn_core_tlm, del2_cubed_tlm
68 
69  real :: ptk, peln1, rgrav
70  real :: d3_damp
71 ! real, allocatable, dimension(:,:,:) :: ut, vt, crx, cry, xfx, yfx, divgd, &
72 ! zh, du, dv, pkc, delpc, pk3, ptc, gz
73 ! real, parameter:: delt_max = 1.e-1 ! Max dissipative heating/cooling rate
74  ! 6 deg per 10-min
75  real(kind=R_GRID), parameter :: cnst_0p20=0.20d0
76 
77 ! real, allocatable :: rf(:)
78  logical:: rff_initialized = .false.
79  integer :: kmax=1
80 
81 CONTAINS
82 ! Differentiation of dyn_core in forward (tangent) mode:
83 ! variations of useful results: pk3 xfx ws peln q gz du u dv
84 ! v w delp ua uc ptc mfx delz mfy omga ut divgd
85 ! pkc delpc va vc yfx pkz pe vt pk zh pt cx cy crx
86 ! cry
87 ! with respect to varying inputs: pk3 xfx ws peln q gz du u dv
88 ! v w delp ua uc ptc delz omga ut divgd pkc delpc
89 ! va vc yfx pkz pe vt pk zh pt crx cry
90 !-----------------------------------------------------------------------
91 ! dyn_core :: FV Lagrangian dynamics driver
92 !-----------------------------------------------------------------------
93  SUBROUTINE dyn_core_tlm(npx, npy, npz, ng, sphum, nq, bdt, n_split, &
94 & zvir, cp, akap, cappa, grav, hydrostatic, u, u_tl, v, v_tl, w, w_tl&
95 & , delz, delz_tl, pt, pt_tl, q, q_tl, delp, delp_tl, pe, pe_tl, pk, &
96 & pk_tl, phis, ws, ws_tl, omga, omga_tl, ptop, pfull, ua, ua_tl, va, &
97 & va_tl, uc, uc_tl, vc, vc_tl, mfx, mfx_tl, mfy, mfy_tl, cx, cx_tl, cy&
98 & , cy_tl, pkz, pkz_tl, peln, peln_tl, q_con, ak, bk, dpx, dpx_tl, ks&
99 & , gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain&
100 & , init_step, i_pack, end_step, gz, gz_tl, pkc, pkc_tl, ptc, ptc_tl, &
101 & crx, crx_tl, xfx, xfx_tl, cry, cry_tl, yfx, yfx_tl, divgd, divgd_tl&
102 & , delpc, delpc_tl, ut, ut_tl, vt, vt_tl, zh, zh_tl, pk3, pk3_tl, du&
103 & , du_tl, dv, dv_tl, time_total)
104  IMPLICIT NONE
105 ! end init_step
106 ! Start of the big dynamic time stepping
107 !allocate( gz(isd:ied, jsd:jed ,npz+1) )
108 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, gz, huge_r)
109 !allocate( pkc(isd:ied, jsd:jed ,npz+1) )
110 !allocate( ptc(isd:ied, jsd:jed ,npz ) )
111 !allocate( crx(is :ie+1, jsd:jed, npz) )
112 !allocate( xfx(is :ie+1, jsd:jed, npz) )
113 !allocate( cry(isd:ied, js :je+1, npz) )
114 !allocate( yfx(isd:ied, js :je+1, npz) )
115 !allocate( divgd(isd:ied+1,jsd:jed+1,npz) )
116 !allocate( delpc(isd:ied, jsd:jed ,npz ) )
117 ! call init_ijk_mem(isd,ied, jsd,jed, npz, delpc, 0.)
118 !allocate( ut(isd:ied, jsd:jed, npz) )
119 ! call init_ijk_mem(isd,ied, jsd,jed, npz, ut, 0.)
120 !allocate( vt(isd:ied, jsd:jed, npz) )
121 ! call init_ijk_mem(isd,ied, jsd,jed, npz, vt, 0.)
122 !allocate( zh(isd:ied, jsd:jed, npz+1) )
123 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, zh, huge_r )
124 !allocate ( pk3(isd:ied,jsd:jed,npz+1) )
125 !call init_ijk_mem(isd,ied, jsd,jed, npz+1, pk3, huge_r )
126 !if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier
127 !versions of the code
128 !deallocate( gz )
129 !deallocate( ptc )
130 !deallocate( crx )
131 !deallocate( xfx )
132 !deallocate( cry )
133 !deallocate( yfx )
134 !deallocate( divgd )
135 !deallocate( pkc )
136 !deallocate( delpc )
137 !if( allocated(ut)) deallocate( ut )
138 !if( allocated(vt)) deallocate( vt )
139 !if ( allocated (du) ) deallocate( du )
140 !if ( allocated (dv) ) deallocate( dv )
141 !if ( .not. hydrostatic ) then
142 ! deallocate( zh )
143 ! if( allocated(pk3) ) deallocate ( pk3 )
144 !endif
145 !if( allocated(pem) ) deallocate ( pem )
146  INTEGER, INTENT(IN) :: npx
147  INTEGER, INTENT(IN) :: npy
148  INTEGER, INTENT(IN) :: npz
149  INTEGER, INTENT(IN) :: ng, nq, sphum
150  INTEGER, INTENT(IN) :: n_split
151  REAL, INTENT(IN) :: bdt
152  REAL, INTENT(IN) :: zvir, cp, akap, grav
153  REAL, INTENT(IN) :: ptop
154  LOGICAL, INTENT(IN) :: hydrostatic
155  LOGICAL, INTENT(IN) :: init_step, end_step
156  REAL, INTENT(IN) :: pfull(npz)
157  REAL, DIMENSION(npz+1), INTENT(IN) :: ak, bk
158  INTEGER, INTENT(IN) :: ks
159  TYPE(group_halo_update_type), INTENT(INOUT) :: i_pack(*)
160  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
161 ! D grid zonal wind (m/s)
162  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
163 & :: u
164  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
165 & :: u_tl
166 ! D grid meridional wind (m/s)
167  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
168 & :: v
169  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
170 & :: v_tl
171 ! vertical vel. (m/s)
172  REAL, INTENT(INOUT) :: w(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
173  REAL, INTENT(INOUT) :: w_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
174 ! delta-height (m, negative)
175  REAL, INTENT(INOUT) :: delz(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
176  REAL, INTENT(INOUT) :: delz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
177 ! moist kappa
178  REAL, INTENT(INOUT) :: cappa(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
179 ! temperature (K)
180  REAL, INTENT(INOUT) :: pt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
181  REAL, INTENT(INOUT) :: pt_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
182 ! pressure thickness (pascal)
183  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
184  REAL, INTENT(INOUT) :: delp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
185 !
186  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
187  REAL, INTENT(INOUT) :: q_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
188 ! total time (seconds) since start
189  REAL, INTENT(IN), OPTIONAL :: time_total
190 !-----------------------------------------------------------------------
191 ! Auxilliary pressure arrays:
192 ! The 5 vars below can be re-computed from delp and ptop.
193 !-----------------------------------------------------------------------
194 ! dyn_aux:
195 ! Surface geopotential (g*Z_surf)
196  REAL, INTENT(INOUT) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed)
197 ! edge pressure (pascal)
198  REAL, INTENT(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
199  REAL, INTENT(INOUT) :: pe_tl(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1&
200 & )
201 ! ln(pe)
202  REAL, INTENT(INOUT) :: peln(bd%is:bd%ie, npz+1, bd%js:bd%je)
203  REAL, INTENT(INOUT) :: peln_tl(bd%is:bd%ie, npz+1, bd%js:bd%je)
204 ! pe**kappa
205  REAL, INTENT(INOUT) :: pk(bd%is:bd%ie, bd%js:bd%je, npz+1)
206  REAL, INTENT(INOUT) :: pk_tl(bd%is:bd%ie, bd%js:bd%je, npz+1)
207  REAL(kind=8), INTENT(INOUT) :: dpx(bd%is:bd%ie, bd%js:bd%je)
208  REAL(kind=8), INTENT(INOUT) :: dpx_tl(bd%is:bd%ie, bd%js:bd%je)
209 !-----------------------------------------------------------------------
210 ! Others:
211  REAL, PARAMETER :: near0=1.e-8
212  REAL, PARAMETER :: huge_r=1.e8
213 !-----------------------------------------------------------------------
214 ! w at surface
215  REAL, INTENT(OUT) :: ws(bd%is:bd%ie, bd%js:bd%je)
216  REAL, INTENT(OUT) :: ws_tl(bd%is:bd%ie, bd%js:bd%je)
217 ! Vertical pressure velocity (pa/s)
218  REAL, INTENT(INOUT) :: omga(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
219  REAL, INTENT(INOUT) :: omga_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
220 ! (uc, vc) are mostly used as the C grid winds
221  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
222  REAL, INTENT(INOUT) :: uc_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
223  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
224  REAL, INTENT(INOUT) :: vc_tl(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, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
228 & ua_tl, va_tl
229  REAL, INTENT(INOUT) :: q_con(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
230 ! The Flux capacitors: accumulated Mass flux arrays
231  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
232  REAL, INTENT(INOUT) :: mfx_tl(bd%is:bd%ie+1, bd%js:bd%je, npz)
233  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
234  REAL, INTENT(INOUT) :: mfy_tl(bd%is:bd%ie, bd%js:bd%je+1, npz)
235 ! Accumulated Courant number arrays
236  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
237  REAL, INTENT(INOUT) :: cx_tl(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
238  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
239  REAL, INTENT(INOUT) :: cy_tl(bd%isd:bd%ied, bd%js:bd%je+1, npz)
240  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: pkz
241  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: &
242 & pkz_tl
243  TYPE(fv_grid_type), INTENT(INOUT), TARGET :: gridstruct
244  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
245  TYPE(fv_flags_pert_type), INTENT(IN), TARGET :: flagstructp
246  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
247  TYPE(fv_diag_type), INTENT(IN) :: idiag
248  TYPE(domain2d), INTENT(INOUT) :: domain
249 !real, allocatable, dimension(:,:,:):: pem, heat_source
250  REAL :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), heat_source(bd&
251 & %isd:bd%ied, bd%jsd:bd%jed, npz)
252  REAL :: pem_tl(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), &
253 & heat_source_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
254 ! Auto 1D & 2D arrays:
255  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3, z_rat
256  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3_tl, z_rat_tl
257  REAL :: dp_ref(npz)
258 ! surface height (m)
259  REAL :: zs(bd%isd:bd%ied, bd%jsd:bd%jed)
260  REAL :: p1d(bd%is:bd%ie)
261  REAL :: om2d(bd%is:bd%ie, npz)
262  REAL :: om2d_tl(bd%is:bd%ie, npz)
263  REAL :: wbuffer(npy+2, npz)
264  REAL :: ebuffer(npy+2, npz)
265  REAL :: ebuffer_tl(npy+2, npz)
266  REAL :: nbuffer(npx+2, npz)
267  REAL :: nbuffer_tl(npx+2, npz)
268  REAL :: sbuffer(npx+2, npz)
269 ! ---- For external mode:
270  REAL :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
271  REAL :: divg2_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
272  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
273  REAL :: wk_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
274  REAL :: fz(bd%is:bd%ie+1, bd%js:bd%je+1)
275  REAL :: heat_s(bd%is:bd%ie, bd%js:bd%je)
276  REAL :: heat_s_tl(bd%is:bd%ie, bd%js:bd%je)
277  REAL :: damp_vt(npz+1)
278  INTEGER :: nord_v(npz+1)
279 !-------------------------------------
280  INTEGER :: hord_m, hord_v, hord_t, hord_p
281  INTEGER :: nord_k, nord_w, nord_t
282  INTEGER :: ms
283 !---------------------------------------
284  INTEGER :: hord_m_pert, hord_v_pert, hord_t_pert, hord_p_pert
285  INTEGER :: nord_k_pert, nord_w_pert, nord_t_pert, nord_v_pert(npz+1)
286  REAL :: d2_divg_pert, damp_vt_pert(npz+1), damp_w_pert, damp_t_pert
287 !---------------------------------------
288  INTEGER :: i, j, k, it, iq, n_con, nf_ke
289  INTEGER :: iep1, jep1
290  REAL :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air
291  REAL :: dt, dt2, rdt
292  REAL :: d2_divg
293  REAL :: k1k, rdg, dtmp, delt
294  REAL :: dtmp_tl
295  LOGICAL :: last_step, remap_step
296  LOGICAL :: used
297  REAL :: split_timestep_bc
298  INTEGER :: is, ie, js, je
299  INTEGER :: isd, ied, jsd, jed
300  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
301  REAL, INTENT(INOUT) :: gz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
302  REAL, INTENT(INOUT) :: pkc(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
303  REAL, INTENT(INOUT) :: pkc_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
304  REAL, INTENT(INOUT) :: ptc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
305  REAL, INTENT(INOUT) :: ptc_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
306  REAL, INTENT(INOUT) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
307  REAL, INTENT(INOUT) :: crx_tl(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
308  REAL, INTENT(INOUT) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
309  REAL, INTENT(INOUT) :: xfx_tl(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
310  REAL, INTENT(INOUT) :: cry(bd%isd:bd%ied, bd%js:bd%je+1, npz)
311  REAL, INTENT(INOUT) :: cry_tl(bd%isd:bd%ied, bd%js:bd%je+1, npz)
312  REAL, INTENT(INOUT) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
313  REAL, INTENT(INOUT) :: yfx_tl(bd%isd:bd%ied, bd%js:bd%je+1, npz)
314  REAL, INTENT(INOUT) :: divgd(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, npz)
315  REAL, INTENT(INOUT) :: divgd_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, &
316 & npz)
317  REAL, INTENT(INOUT) :: delpc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
318  REAL, INTENT(INOUT) :: delpc_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
319  REAL, INTENT(INOUT) :: ut(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
320  REAL, INTENT(INOUT) :: ut_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
321  REAL, INTENT(INOUT) :: vt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
322  REAL, INTENT(INOUT) :: vt_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
323  REAL, INTENT(INOUT) :: zh(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
324  REAL, INTENT(INOUT) :: zh_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
325  REAL, INTENT(INOUT) :: pk3(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
326  REAL, INTENT(INOUT) :: pk3_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
327  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
328  REAL, INTENT(INOUT) :: du_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
329  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
330  REAL, INTENT(INOUT) :: dv_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
331  INTRINSIC log
332  INTRINSIC real
333  INTRINSIC max
334  INTRINSIC min
335  INTRINSIC exp
336  INTRINSIC abs
337  INTRINSIC sign
338  INTEGER :: max1
339  INTEGER :: max2
340  REAL :: min1
341  REAL :: min1_tl
342  REAL :: min2
343  REAL :: min2_tl
344  REAL :: abs0
345  REAL :: arg1
346  REAL :: arg1_tl
347  REAL :: arg2
348  REAL :: arg2_tl
349  REAL :: y1_tl
350  REAL :: y2_tl
351  REAL :: x1
352  REAL :: y2
353  REAL :: y1
354  is = bd%is
355  ie = bd%ie
356  js = bd%js
357  je = bd%je
358  isd = bd%isd
359  ied = bd%ied
360  jsd = bd%jsd
361  jed = bd%jed
362  peln1 = log(ptop)
363  ptk = ptop**akap
364  dt = bdt/REAL(n_split)
365  dt2 = 0.5*dt
366  rdt = 1.0/dt
367  IF (1 .LT. flagstruct%m_split/2) THEN
368  ms = flagstruct%m_split/2
369  ELSE
370  ms = 1
371  END IF
372  beta = flagstruct%beta
373  rdg = -(rdgas/grav)
374  cv_air = cp_air - rdgas
375 ! Indexes:
376  iep1 = ie + 1
377  jep1 = je + 1
378  IF (.NOT.hydrostatic) THEN
379  rgrav = 1.0/grav
380 ! rg/Cv=0.4
381  k1k = akap/(1.-akap)
382 !$OMP parallel do default(none) shared(npz,dp_ref,ak,bk)
383  DO k=1,npz
384  dp_ref(k) = ak(k+1) - ak(k) + (bk(k+1)-bk(k))*1.e5
385  END DO
386 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,zs,phis,rgrav)
387  DO j=jsd,jed
388  DO i=isd,ied
389  zs(i, j) = phis(i, j)*rgrav
390  END DO
391  END DO
392  END IF
393 !allocate( du(isd:ied, jsd:jed+1,npz) )
394 !call init_ijk_mem(isd,ied, jsd,jed+1, npz, du, 0.)
395 !allocate( dv(isd:ied+1,jsd:jed, npz) )
396 !call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.)
397 ! Empty the "flux capacitors"
398 !call init_ijk_mem(is, ie+1, js, je, npz, mfx, 0.)
399  mfx = 0.0
400 !call init_ijk_mem(is, ie , js, je+1, npz, mfy, 0.)
401  mfy = 0.0
402 !call init_ijk_mem(is, ie+1, jsd, jed, npz, cx, 0.)
403  cx = 0.0
404 !call init_ijk_mem(isd, ied, js, je+1, npz, cy, 0.)
405  cy = 0.0
406  IF (flagstruct%d_con .GT. 1.0e-5) heat_source = 0.0
407 !allocate( heat_source(isd:ied, jsd:jed, npz) )
408 !call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.)
409  IF (flagstruct%convert_ke .OR. flagstruct%vtdm4 .GT. 1.e-4) THEN
410  n_con = npz
411  mfx_tl = 0.0
412  mfy_tl = 0.0
413  cx_tl = 0.0
414  cy_tl = 0.0
415  om2d_tl = 0.0
416  pem_tl = 0.0
417  ws3_tl = 0.0
418  z_rat_tl = 0.0
419  heat_source_tl = 0.0
420  heat_s_tl = 0.0
421  wk_tl = 0.0
422  divg2_tl = 0.0
423  ELSE IF (flagstruct%d2_bg_k1 .LT. 1.e-3) THEN
424  n_con = 0
425  mfx_tl = 0.0
426  mfy_tl = 0.0
427  cx_tl = 0.0
428  cy_tl = 0.0
429  om2d_tl = 0.0
430  pem_tl = 0.0
431  ws3_tl = 0.0
432  z_rat_tl = 0.0
433  heat_source_tl = 0.0
434  heat_s_tl = 0.0
435  wk_tl = 0.0
436  divg2_tl = 0.0
437  ELSE IF (flagstruct%d2_bg_k2 .LT. 1.e-3) THEN
438  n_con = 1
439  mfx_tl = 0.0
440  mfy_tl = 0.0
441  cx_tl = 0.0
442  cy_tl = 0.0
443  om2d_tl = 0.0
444  pem_tl = 0.0
445  ws3_tl = 0.0
446  z_rat_tl = 0.0
447  heat_source_tl = 0.0
448  heat_s_tl = 0.0
449  wk_tl = 0.0
450  divg2_tl = 0.0
451  ELSE
452  n_con = 2
453  mfx_tl = 0.0
454  mfy_tl = 0.0
455  cx_tl = 0.0
456  cy_tl = 0.0
457  om2d_tl = 0.0
458  pem_tl = 0.0
459  ws3_tl = 0.0
460  z_rat_tl = 0.0
461  heat_source_tl = 0.0
462  heat_s_tl = 0.0
463  wk_tl = 0.0
464  divg2_tl = 0.0
465  END IF
466 !-----------------------------------------------------
467  DO it=1,n_split
468 !-----------------------------------------------------
469  IF (flagstruct%breed_vortex_inline .OR. it .EQ. n_split) THEN
470  remap_step = .true.
471  ELSE
472  remap_step = .false.
473  END IF
474  IF (flagstruct%fv_debug) THEN
475  IF (is_master()) WRITE(*, *) 'n_split loop, it=', it
476  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
477 & ie, js, je, ng, npz, 1.&
478 & , gridstruct%area_64, &
479 & domain)
480  CALL prt_mxm('PT', pt, is, ie, js, je, ng, npz, 1., gridstruct%&
481 & area_64, domain)
482  END IF
483  IF (gridstruct%nested) split_timestep_bc = REAL(n_split*flagstruct&
484 & %k_split + neststruct%nest_timestep)
485 !First split timestep has split_timestep_BC = n_split*k_split
486 ! to do time-extrapolation on BCs.
487  IF (nq .GT. 0) THEN
488  CALL timing_on('COMM_TOTAL')
489  CALL timing_on('COMM_TRACER')
490  IF (flagstruct%inline_q) CALL start_group_halo_update_tlm(i_pack&
491 & (10), q, &
492 & q_tl, domain&
493 & )
494  CALL timing_off('COMM_TRACER')
495  CALL timing_off('COMM_TOTAL')
496  END IF
497  IF (.NOT.hydrostatic) THEN
498  CALL timing_on('COMM_TOTAL')
499  CALL start_group_halo_update_tlm(i_pack(7), w, w_tl, domain)
500  CALL timing_off('COMM_TOTAL')
501  IF (it .EQ. 1) THEN
502  IF (gridstruct%nested) THEN
503 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,gz,zs,delz)
504  DO j=jsd,jed
505  DO i=isd,ied
506  gz_tl(i, j, npz+1) = 0.0
507  gz(i, j, npz+1) = zs(i, j)
508  END DO
509  DO k=npz,1,-1
510  DO i=isd,ied
511  gz_tl(i, j, k) = gz_tl(i, j, k+1) - delz_tl(i, j, k)
512  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
513  END DO
514  END DO
515  END DO
516  ELSE
517 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zs,delz)
518  DO j=js,je
519  DO i=is,ie
520  gz_tl(i, j, npz+1) = 0.0
521  gz(i, j, npz+1) = zs(i, j)
522  END DO
523  DO k=npz,1,-1
524  DO i=is,ie
525  gz_tl(i, j, k) = gz_tl(i, j, k+1) - delz_tl(i, j, k)
526  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
527  END DO
528  END DO
529  END DO
530  END IF
531  CALL timing_on('COMM_TOTAL')
532  CALL start_group_halo_update_tlm(i_pack(5), gz, gz_tl, domain)
533  CALL timing_off('COMM_TOTAL')
534  END IF
535  END IF
536  IF (it .EQ. 1) THEN
537  CALL timing_on('COMM_TOTAL')
538  CALL complete_group_halo_update(i_pack(1), domain)
539  CALL timing_off('COMM_TOTAL')
540  beta_d = 0.
541  ELSE
542  beta_d = beta
543  END IF
544  IF (it .EQ. n_split .AND. end_step) THEN
545  IF (flagstruct%use_old_omega) THEN
546  pem = 0.0
547  pem_tl = 0.0
548 !allocate ( pem(is-1:ie+1,npz+1,js-1:je+1) )
549 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pem,delp,ptop)
550  DO j=js-1,je+1
551  DO i=is-1,ie+1
552  pem_tl(i, 1, j) = 0.0
553  pem(i, 1, j) = ptop
554  END DO
555  DO k=1,npz
556  DO i=is-1,ie+1
557  pem_tl(i, k+1, j) = pem_tl(i, k, j) + delp_tl(i, j, k)
558  pem(i, k+1, j) = pem(i, k, j) + delp(i, j, k)
559  END DO
560  END DO
561  END DO
562  END IF
563  last_step = .true.
564  ELSE
565  last_step = .false.
566  END IF
567  CALL timing_on('COMM_TOTAL')
568  CALL complete_group_halo_update(i_pack(8), domain)
569  IF (.NOT.hydrostatic) CALL complete_group_halo_update(i_pack(7), &
570 & domain)
571  CALL timing_off('COMM_TOTAL')
572  CALL timing_on('c_sw')
573 !$OMP parallel do default(none) shared(npz,isd,jsd,delpc,delp,ptc,pt,u,v,w,uc,vc,ua,va, &
574 !$OMP omga,ut,vt,divgd,flagstruct,dt2,hydrostatic,bd, &
575 !$OMP gridstruct)
576  DO k=1,npz
577  CALL c_sw_tlm(delpc(isd:ied, jsd:jed, k), delpc_tl(isd:ied, jsd:&
578 & jed, k), delp(isd:ied, jsd:jed, k), delp_tl(isd:ied, jsd&
579 & :jed, k), ptc(isd:ied, jsd:jed, k), ptc_tl(isd:ied, jsd:&
580 & jed, k), pt(isd:ied, jsd:jed, k), pt_tl(isd:ied, jsd:jed&
581 & , k), u(isd:ied, jsd:jed+1, k), u_tl(isd:ied, jsd:jed+1&
582 & , k), v(isd:ied+1, jsd:jed, k), v_tl(isd:ied+1, jsd:jed&
583 & , k), w(isd:ied, jsd:jed, k), w_tl(isd:ied, jsd:jed, k)&
584 & , uc(isd:ied+1, jsd:jed, k), uc_tl(isd:ied+1, jsd:jed, k&
585 & ), vc(isd:ied, jsd:jed+1, k), vc_tl(isd:ied, jsd:jed+1, &
586 & k), ua(isd:ied, jsd:jed, k), ua_tl(isd:ied, jsd:jed, k)&
587 & , va(isd:ied, jsd:jed, k), va_tl(isd:ied, jsd:jed, k), &
588 & omga(isd:ied, jsd:jed, k), omga_tl(isd:ied, jsd:jed, k)&
589 & , ut(isd:ied, jsd:jed, k), ut_tl(isd:ied, jsd:jed, k), &
590 & vt(isd:ied, jsd:jed, k), vt_tl(isd:ied, jsd:jed, k), &
591 & divgd(isd:ied+1, jsd:jed+1, k), divgd_tl(isd:ied+1, jsd:&
592 & jed+1, k), flagstruct%nord, dt2, hydrostatic, .true., bd&
593 & , gridstruct, flagstruct)
594  END DO
595  CALL timing_off('c_sw')
596  IF (flagstruct%nord .GT. 0) THEN
597  CALL timing_on('COMM_TOTAL')
598  CALL start_group_halo_update_tlm(i_pack(3), divgd, divgd_tl, &
599 & domain, position=corner)
600  CALL timing_off('COMM_TOTAL')
601  END IF
602  IF (gridstruct%nested) THEN
603  CALL nested_grid_bc_apply_intt_tlm(delpc, delpc_tl, 0, 0, npx, &
604 & npy, npz, bd, split_timestep_bc + &
605 & 0.5, REAL(n_split*flagstruct%& & k_split), neststruct%delp_bc, &
606 & bctype=neststruct%nestbctype)
607  call nested_grid_bc_apply_intt_tlm(ptc, ptc_tl, 0, 0, npx, npy, &
608 & npz, bd, split_timestep_bc + 0.5, &
609 & REAL(n_split*flagstruct%k_split), &
610 & neststruct%pt_bc, bctype=neststruct&
611 & %nestbctype)
612  end if
613 ! end hydro check
614  IF (hydrostatic) THEN
615  CALL geopk_tlm(ptop, pe, pe_tl, peln, peln_tl, delpc, delpc_tl, &
616 & pkc, pkc_tl, gz, gz_tl, phis, ptc, ptc_tl, q_con, pkz, &
617 & pkz_tl, npz, akap, .true., gridstruct%nested, .false., &
618 & npx, npy, flagstruct%a2b_ord, bd)
619  ELSE
620  IF (it .EQ. 1) THEN
621  CALL timing_on('COMM_TOTAL')
622  CALL complete_group_halo_update(i_pack(5), domain)
623  CALL timing_off('COMM_TOTAL')
624 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
625  DO k=1,npz+1
626  DO j=jsd,jed
627  DO i=isd,ied
628 ! Save edge heights for update_dz_d
629  zh_tl(i, j, k) = gz_tl(i, j, k)
630  zh(i, j, k) = gz(i, j, k)
631  END DO
632  END DO
633  END DO
634  ELSE
635 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
636  DO k=1,npz+1
637  DO j=jsd,jed
638  DO i=isd,ied
639  gz_tl(i, j, k) = zh_tl(i, j, k)
640  gz(i, j, k) = zh(i, j, k)
641  END DO
642  END DO
643  END DO
644  END IF
645  CALL timing_on('UPDATE_DZ_C')
646  CALL update_dz_c_tlm(is, ie, js, je, npz, ng, dt2, dp_ref, zs, &
647 & gridstruct%area, ut, ut_tl, vt, vt_tl, gz, gz_tl&
648 & , ws3, ws3_tl, npx, npy, gridstruct%sw_corner, &
649 & gridstruct%se_corner, gridstruct%ne_corner, &
650 & gridstruct%nw_corner, bd, gridstruct%grid_type)
651  CALL timing_off('UPDATE_DZ_C')
652  CALL timing_on('Riem_Solver')
653  CALL riem_solver_c_tlm(ms, dt2, is, ie, js, je, npz, ng, akap, &
654 & cappa, cp, ptop, phis, omga, omga_tl, ptc, &
655 & ptc_tl, q_con, delpc, delpc_tl, gz, gz_tl, pkc&
656 & , pkc_tl, ws3, ws3_tl, flagstruct%p_fac, &
657 & flagstruct%a_imp, flagstruct%scale_z)
658  CALL timing_off('Riem_Solver')
659  IF (gridstruct%nested) THEN
660  CALL nested_grid_bc_apply_intt_tlm(delz, delz_tl, 0, 0, npx, &
661 & npy, npz, bd, split_timestep_bc +&
662 & 0.5, REAL(n_split*flagstruct%& & k_split), neststruct%delz_bc, &
663 & bctype=neststruct%nestbctype)
664 !Compute gz/pkc
665 !NOTE: nominally only need to compute quantities one out in the halo for p_grad_c
666 !(instead of entire halo)
667  CALL nest_halo_nh_tlm(ptop, grav, akap, cp, delpc, delpc_tl, &
668 & delz, delz_tl, ptc, ptc_tl, phis, pkc, pkc_tl&
669 & , gz, gz_tl, pk3, pk3_tl, npx, npy, npz, &
670 & gridstruct%nested, .false., .false., .false., &
671 & bd)
672  END IF
673  END IF
674  CALL p_grad_c_tlm(dt2, npz, delpc, delpc_tl, pkc, pkc_tl, gz, &
675 & gz_tl, uc, uc_tl, vc, vc_tl, bd, gridstruct%rdxc, &
676 & gridstruct%rdyc, hydrostatic)
677  CALL timing_on('COMM_TOTAL')
678  CALL start_group_halo_update_tlm(i_pack(9), uc, uc_tl, vc, vc_tl, &
679 & domain, gridtype=cgrid_ne)
680  CALL timing_off('COMM_TOTAL')
681  CALL timing_on('COMM_TOTAL')
682  IF (flagstruct%inline_q .AND. nq .GT. 0) CALL &
683 & complete_group_halo_update(i_pack(10), domain)
684  IF (flagstruct%nord .GT. 0) CALL complete_group_halo_update(i_pack&
685 & (3), domain)
686  CALL complete_group_halo_update(i_pack(9), domain)
687  CALL timing_off('COMM_TOTAL')
688  IF (gridstruct%nested) THEN
689 !On a nested grid we have to do SOMETHING with uc and vc in
690 ! the boundary halo, particularly at the corners of the
691 ! domain and of each processor element. We must either
692 ! apply an interpolated BC, or extrapolate into the
693 ! boundary halo
694 ! NOTE:
695 !The update_domains calls for uc and vc need to go BEFORE the BCs to ensure cross-restart
696 !bitwise-consistent solutions when doing the spatial extrapolation; should not make a
697 !difference for interpolated BCs from the coarse grid.
698  CALL nested_grid_bc_apply_intt_tlm(vc, vc_tl, 0, 1, npx, npy, &
699 & npz, bd, split_timestep_bc + 0.5, &
700 & REAL(n_split*flagstruct%k_split), &
701 & neststruct%vc_bc, bctype=neststruct&
702 & %nestbctype)
703  call nested_grid_bc_apply_intt_tlm(uc, uc_tl, 1, 0, npx, npy, &
704 & npz, bd, split_timestep_bc + 0.5, &
705 & REAL(n_split*flagstruct%k_split), &
706 & neststruct%uc_bc, bctype=neststruct&
707 & %nestbctype)
708 !QUESTION: What to do with divgd in nested halo?
709  CALL nested_grid_bc_apply_intt_tlm(divgd, divgd_tl, 1, 1, npx, &
710 & npy, npz, bd, split_timestep_bc, &
711 & REAL(n_split*flagstruct%k_split), &
712 & neststruct%divg_bc, bctype=&
713 & neststruct%nestbctype)
714 !!$ if (is == 1 .and. js == 1) then
715 !!$ do j=jsd,5
716 !!$ write(mpp_pe()+2000,*) j, divg(isd:5,j,1)
717 !!$ endif
718  END IF
719  IF (gridstruct%nested .AND. flagstruct%inline_q) THEN
720  DO iq=1,nq
721  CALL nested_grid_bc_apply_intt_tlm(q(isd:ied, jsd:jed, :, iq)&
722 & , q_tl(isd:ied, jsd:jed, :, iq), &
723 & 0, 0, npx, npy, npz, bd, &
724 & split_timestep_bc + 1, REAL(& & n_split*flagstruct%k_split), &
725 & neststruct%q_bc(iq), bctype=&
726 & neststruct%nestbctype)
727  end do
728  END IF
729  CALL timing_on('d_sw')
730 !$OMP parallel do default(none) shared(npz,flagstruct,nord_v,pfull,damp_vt,hydrostatic,last_step, &
731 !$OMP is,ie,js,je,isd,ied,jsd,jed,omga,delp,gridstruct,npx,npy, &
732 !$OMP ng,zh,vt,ptc,pt,u,v,w,uc,vc,ua,va,divgd,mfx,mfy,cx,cy, &
733 !$OMP crx,cry,xfx,yfx,q_con,zvir,sphum,nq,q,dt,bd,rdt,iep1,jep1, &
734 !$OMP heat_source) &
735 !$OMP private(nord_k, nord_w, nord_t, damp_w, damp_t, d2_divg, &
736 !$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, z_rat)
737  DO k=1,npz
738  hord_m = flagstruct%hord_mt
739  hord_t = flagstruct%hord_tm
740  hord_v = flagstruct%hord_vt
741  hord_p = flagstruct%hord_dp
742  nord_k = flagstruct%nord
743 ! if ( k==npz ) then
744  kgb = flagstruct%ke_bg
745  IF (2 .GT. flagstruct%nord) THEN
746  nord_v(k) = flagstruct%nord
747  ELSE
748  nord_v(k) = 2
749  END IF
750  IF (0.20 .GT. flagstruct%d2_bg) THEN
751  d2_divg = flagstruct%d2_bg
752  ELSE
753  d2_divg = 0.20
754  END IF
755  IF (flagstruct%do_vort_damp) THEN
756 ! for delp, delz, and vorticity
757  damp_vt(k) = flagstruct%vtdm4
758  ELSE
759  damp_vt(k) = 0.
760  END IF
761  nord_w = nord_v(k)
762  nord_t = nord_v(k)
763  damp_w = damp_vt(k)
764  damp_t = damp_vt(k)
765  d_con_k = flagstruct%d_con
766  IF (npz .EQ. 1 .OR. flagstruct%n_sponge .LT. 0) THEN
767  d2_divg = flagstruct%d2_bg
768  ELSE IF (k .EQ. 1) THEN
769 ! Sponge layers with del-2 damping on divergence, vorticity, w, z, and air mass (delp).
770 ! no special damping of potential temperature in sponge layers
771 ! Divergence damping:
772  nord_k = 0
773  IF (0.01 .LT. flagstruct%d2_bg) THEN
774  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k1) THEN
775  d2_divg = flagstruct%d2_bg_k1
776  ELSE
777  d2_divg = flagstruct%d2_bg
778  END IF
779  ELSE IF (0.01 .LT. flagstruct%d2_bg_k1) THEN
780  d2_divg = flagstruct%d2_bg_k1
781  ELSE
782  d2_divg = 0.01
783  END IF
784 ! Vertical velocity:
785  nord_w = 0
786  damp_w = d2_divg
787  IF (flagstruct%do_vort_damp) THEN
788 ! damping on delp and vorticity:
789  nord_v(k) = 0
790  damp_vt(k) = 0.5*d2_divg
791  END IF
792  d_con_k = 0.
793  ELSE
794  IF (2 .LT. flagstruct%n_sponge - 1) THEN
795  max1 = flagstruct%n_sponge - 1
796  ELSE
797  max1 = 2
798  END IF
799  IF (k .EQ. max1 .AND. flagstruct%d2_bg_k2 .GT. 0.01) THEN
800  nord_k = 0
801  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k2) THEN
802  d2_divg = flagstruct%d2_bg_k2
803  ELSE
804  d2_divg = flagstruct%d2_bg
805  END IF
806  nord_w = 0
807  damp_w = d2_divg
808  IF (flagstruct%do_vort_damp) THEN
809  nord_v(k) = 0
810  damp_vt(k) = 0.5*d2_divg
811  END IF
812  d_con_k = 0.
813  ELSE
814  IF (3 .LT. flagstruct%n_sponge) THEN
815  max2 = flagstruct%n_sponge
816  ELSE
817  max2 = 3
818  END IF
819  IF (k .EQ. max2 .AND. flagstruct%d2_bg_k2 .GT. 0.05) THEN
820  nord_k = 0
821  IF (flagstruct%d2_bg .LT. 0.2*flagstruct%d2_bg_k2) THEN
822  d2_divg = 0.2*flagstruct%d2_bg_k2
823  ELSE
824  d2_divg = flagstruct%d2_bg
825  END IF
826  nord_w = 0
827  damp_w = d2_divg
828  d_con_k = 0.
829  END IF
830  END IF
831  END IF
832  hord_m_pert = flagstructp%hord_mt_pert
833  hord_t_pert = flagstructp%hord_tm_pert
834  hord_v_pert = flagstructp%hord_vt_pert
835  hord_p_pert = flagstructp%hord_dp_pert
836  nord_k_pert = flagstructp%nord_pert
837  IF (2 .GT. flagstructp%nord_pert) THEN
838  nord_v_pert(k) = flagstructp%nord_pert
839  ELSE
840  nord_v_pert(k) = 2
841  END IF
842  IF (0.20 .GT. flagstructp%d2_bg_pert) THEN
843  d2_divg_pert = flagstructp%d2_bg_pert
844  ELSE
845  d2_divg_pert = 0.20
846  END IF
847  IF (flagstructp%do_vort_damp_pert) THEN
848 ! for delp, delz, and vorticity
849  damp_vt_pert(k) = flagstructp%vtdm4_pert
850  ELSE
851  damp_vt_pert(k) = 0.
852  END IF
853  nord_w_pert = nord_v_pert(k)
854  nord_t_pert = nord_v_pert(k)
855  damp_w_pert = damp_vt_pert(k)
856  damp_t_pert = damp_vt_pert(k)
857 !Sponge layers for the pertuabtiosn
858  IF (k .LE. flagstructp%n_sponge_pert) THEN
859  IF (k .LE. flagstructp%n_sponge_pert - 1) THEN
860  IF (flagstructp%hord_ks_traj) THEN
861  hord_m = flagstructp%hord_mt_ks_traj
862  hord_t = flagstructp%hord_tm_ks_traj
863  hord_v = flagstructp%hord_vt_ks_traj
864  hord_p = flagstructp%hord_dp_ks_traj
865  END IF
866  IF (flagstructp%hord_ks_pert) THEN
867  hord_m_pert = flagstructp%hord_mt_ks_pert
868  hord_t_pert = flagstructp%hord_tm_ks_pert
869  hord_v_pert = flagstructp%hord_vt_ks_pert
870  hord_p_pert = flagstructp%hord_dp_ks_pert
871  END IF
872  END IF
873  nord_k_pert = 0
874  IF (k .EQ. 1) THEN
875  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
876  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k1_pert&
877 & ) THEN
878  d2_divg_pert = flagstructp%d2_bg_k1_pert
879  ELSE
880  d2_divg_pert = flagstructp%d2_bg_pert
881  END IF
882  ELSE IF (0.01 .LT. flagstructp%d2_bg_k1_pert) THEN
883  d2_divg_pert = flagstructp%d2_bg_k1_pert
884  ELSE
885  d2_divg_pert = 0.01
886  END IF
887  ELSE IF (k .EQ. 2) THEN
888  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
889  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k2_pert&
890 & ) THEN
891  d2_divg_pert = flagstructp%d2_bg_k2_pert
892  ELSE
893  d2_divg_pert = flagstructp%d2_bg_pert
894  END IF
895  ELSE IF (0.01 .LT. flagstructp%d2_bg_k2_pert) THEN
896  d2_divg_pert = flagstructp%d2_bg_k2_pert
897  ELSE
898  d2_divg_pert = 0.01
899  END IF
900  ELSE IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
901  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_ks_pert) &
902 & THEN
903  d2_divg_pert = flagstructp%d2_bg_ks_pert
904  ELSE
905  d2_divg_pert = flagstructp%d2_bg_pert
906  END IF
907  ELSE IF (0.01 .LT. flagstructp%d2_bg_ks_pert) THEN
908  d2_divg_pert = flagstructp%d2_bg_ks_pert
909  ELSE
910  d2_divg_pert = 0.01
911  END IF
912  nord_w_pert = 0
913  damp_w_pert = d2_divg_pert
914  IF (flagstructp%do_vort_damp_pert) THEN
915  nord_v_pert(k) = 0
916  damp_vt_pert(k) = 0.5*d2_divg_pert
917  END IF
918  END IF
919 !Tapenade issue if not defined at level npz+1
920  damp_vt(npz+1) = damp_vt(npz)
921  damp_vt_pert(npz+1) = damp_vt_pert(npz)
922  nord_v(npz+1) = nord_v(npz)
923  nord_v_pert(npz+1) = nord_v_pert(npz)
924  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
925 & last_step) THEN
926 ! Average horizontal "convergence" to cell center
927  DO j=js,je
928  DO i=is,ie
929  omga_tl(i, j, k) = delp_tl(i, j, k)
930  omga(i, j, k) = delp(i, j, k)
931  END DO
932  END DO
933  END IF
934 !--- external mode divergence damping ---
935  IF (flagstruct%d_ext .GT. 0.) CALL a2b_ord2_tlm(delp(isd:ied, &
936 & jsd:jed, k), delp_tl(&
937 & isd:ied, jsd:jed, k), &
938 & wk, wk_tl, gridstruct&
939 & , npx, npy, is, ie, js&
940 & , je, ng, .false.)
941  IF (.NOT.hydrostatic .AND. flagstruct%do_f3d) THEN
942 ! Correction factor for 3D Coriolis force
943  DO j=jsd,jed
944  DO i=isd,ied
945  z_rat_tl(i, j) = (zh_tl(i, j, k)+zh_tl(i, j, k+1))/radius
946  z_rat(i, j) = 1. + (zh(i, j, k)+zh(i, j, k+1))/radius
947  END DO
948  END DO
949  END IF
950  CALL d_sw_tlm(vt(isd:ied, jsd:jed, k), vt_tl(isd:ied, jsd:jed, k&
951 & ), delp(isd:ied, jsd:jed, k), delp_tl(isd:ied, jsd:jed, &
952 & k), ptc(isd:ied, jsd:jed, k), ptc_tl(isd:ied, jsd:jed, k&
953 & ), pt(isd:ied, jsd:jed, k), pt_tl(isd:ied, jsd:jed, k), &
954 & u(isd:ied, jsd:jed+1, k), u_tl(isd:ied, jsd:jed+1, k), v&
955 & (isd:ied+1, jsd:jed, k), v_tl(isd:ied+1, jsd:jed, k), w(&
956 & isd:ied, jsd:jed, k), w_tl(isd:ied, jsd:jed, k), uc(isd:&
957 & ied+1, jsd:jed, k), uc_tl(isd:ied+1, jsd:jed, k), vc(isd&
958 & :ied, jsd:jed+1, k), vc_tl(isd:ied, jsd:jed+1, k), ua(&
959 & isd:ied, jsd:jed, k), ua_tl(isd:ied, jsd:jed, k), va(isd&
960 & :ied, jsd:jed, k), va_tl(isd:ied, jsd:jed, k), divgd(isd&
961 & :ied+1, jsd:jed+1, k), divgd_tl(isd:ied+1, jsd:jed+1, k)&
962 & , mfx(is:ie+1, js:je, k), mfx_tl(is:ie+1, js:je, k), mfy&
963 & (is:ie, js:je+1, k), mfy_tl(is:ie, js:je+1, k), cx(is:ie&
964 & +1, jsd:jed, k), cx_tl(is:ie+1, jsd:jed, k), cy(isd:ied&
965 & , js:je+1, k), cy_tl(isd:ied, js:je+1, k), crx(is:ie+1, &
966 & jsd:jed, k), crx_tl(is:ie+1, jsd:jed, k), cry(isd:ied, &
967 & js:je+1, k), cry_tl(isd:ied, js:je+1, k), xfx(is:ie+1, &
968 & jsd:jed, k), xfx_tl(is:ie+1, jsd:jed, k), yfx(isd:ied, &
969 & js:je+1, k), yfx_tl(isd:ied, js:je+1, k), q_con(isd:ied&
970 & , jsd:jed, 1), z_rat(isd:ied, jsd:jed), z_rat_tl(isd:ied&
971 & , jsd:jed), kgb, heat_s, heat_s_tl, dpx, dpx_tl, zvir, &
972 & sphum, nq, q, q_tl, k, npz, flagstruct%inline_q, dt, &
973 & flagstruct%hord_tr, hord_m, hord_v, hord_t, hord_p, &
974 & nord_k, nord_v(k), nord_w, nord_t, flagstruct%dddmp, &
975 & d2_divg, flagstruct%d4_bg, damp_vt(k), damp_w, damp_t, &
976 & d_con_k, hydrostatic, gridstruct, flagstruct, bd, &
977 & flagstructp%hord_tr_pert, hord_m_pert, hord_v_pert, &
978 & hord_t_pert, hord_p_pert, flagstructp%split_damp, &
979 & nord_k_pert, nord_v_pert(k), nord_w_pert, nord_t_pert, &
980 & flagstructp%dddmp_pert, d2_divg_pert, flagstructp%&
981 & d4_bg_pert, damp_vt_pert(k), damp_w_pert, damp_t_pert)
982  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
983 & last_step) THEN
984 ! Average horizontal "convergence" to cell center
985  DO j=js,je
986  DO i=is,ie
987  omga_tl(i, j, k) = gridstruct%rarea(i, j)*rdt*(omga_tl(i, &
988 & j, k)*(xfx(i, j, k)-xfx(i+1, j, k)+yfx(i, j, k)-yfx(i, j&
989 & +1, k))+omga(i, j, k)*(xfx_tl(i, j, k)-xfx_tl(i+1, j, k)&
990 & +yfx_tl(i, j, k)-yfx_tl(i, j+1, k)))
991  omga(i, j, k) = omga(i, j, k)*(xfx(i, j, k)-xfx(i+1, j, k)&
992 & +yfx(i, j, k)-yfx(i, j+1, k))*gridstruct%rarea(i, j)*rdt
993  END DO
994  END DO
995  END IF
996  IF (flagstruct%d_ext .GT. 0.) THEN
997  DO j=js,jep1
998  DO i=is,iep1
999 ! delp at cell corners
1000  ptc_tl(i, j, k) = wk_tl(i, j)
1001  ptc(i, j, k) = wk(i, j)
1002  END DO
1003  END DO
1004  END IF
1005  IF (flagstruct%d_con .GT. 1.0e-5) THEN
1006 ! Average horizontal "convergence" to cell center
1007  DO j=js,je
1008  DO i=is,ie
1009  heat_source_tl(i, j, k) = heat_source_tl(i, j, k) + &
1010 & heat_s_tl(i, j)
1011  heat_source(i, j, k) = heat_source(i, j, k) + heat_s(i, j)
1012  END DO
1013  END DO
1014  END IF
1015  END DO
1016 ! end openMP k-loop
1017  CALL timing_off('d_sw')
1018  IF (flagstruct%fill_dp) CALL mix_dp_tlm(hydrostatic, w, w_tl, delp&
1019 & , delp_tl, pt, pt_tl, npz, ak, &
1020 & bk, .false., flagstruct%fv_debug&
1021 & , bd)
1022  CALL timing_on('COMM_TOTAL')
1023  CALL start_group_halo_update_tlm(i_pack(1), delp, delp_tl, domain&
1024 & , complete=.true.)
1025  CALL start_group_halo_update_tlm(i_pack(1), pt, pt_tl, domain, &
1026 & complete=.true.)
1027  CALL timing_off('COMM_TOTAL')
1028  IF (flagstruct%d_ext .GT. 0.) THEN
1029  d2_divg = flagstruct%d_ext*gridstruct%da_min_c
1030 !$OMP parallel do default(none) shared(is,iep1,js,jep1,npz,wk,ptc,divg2,vt,d2_divg)
1031  DO j=js,jep1
1032  DO i=is,iep1
1033  wk_tl(i, j) = ptc_tl(i, j, 1)
1034  wk(i, j) = ptc(i, j, 1)
1035  divg2_tl(i, j) = wk_tl(i, j)*vt(i, j, 1) + wk(i, j)*vt_tl(i&
1036 & , j, 1)
1037  divg2(i, j) = wk(i, j)*vt(i, j, 1)
1038  END DO
1039  DO k=2,npz
1040  DO i=is,iep1
1041  wk_tl(i, j) = wk_tl(i, j) + ptc_tl(i, j, k)
1042  wk(i, j) = wk(i, j) + ptc(i, j, k)
1043  divg2_tl(i, j) = divg2_tl(i, j) + ptc_tl(i, j, k)*vt(i, j&
1044 & , k) + ptc(i, j, k)*vt_tl(i, j, k)
1045  divg2(i, j) = divg2(i, j) + ptc(i, j, k)*vt(i, j, k)
1046  END DO
1047  END DO
1048  DO i=is,iep1
1049  divg2_tl(i, j) = (d2_divg*divg2_tl(i, j)*wk(i, j)-d2_divg*&
1050 & divg2(i, j)*wk_tl(i, j))/wk(i, j)**2
1051  divg2(i, j) = d2_divg*divg2(i, j)/wk(i, j)
1052  END DO
1053  END DO
1054  ELSE
1055  divg2(:, :) = 0.
1056  divg2_tl = 0.0
1057  END IF
1058  CALL timing_on('COMM_TOTAL')
1059  CALL complete_group_halo_update(i_pack(1), domain)
1060  CALL timing_off('COMM_TOTAL')
1061  IF (flagstruct%fv_debug) THEN
1062  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
1063 & ie, js, je, ng, npz, 1.&
1064 & , gridstruct%area_64, &
1065 & domain)
1066  END IF
1067 !Want to move this block into the hydro/nonhydro branch above and merge the two if structures
1068  IF (gridstruct%nested) THEN
1069  CALL nested_grid_bc_apply_intt_tlm(delp, delp_tl, 0, 0, npx, npy&
1070 & , npz, bd, split_timestep_bc + 1, &
1071 & REAL(n_split*flagstruct%k_split), &
1072 & neststruct%delp_bc, bctype=&
1073 & neststruct%nestbctype)
1074  call nested_grid_bc_apply_intt_tlm(pt, pt_tl, 0, 0, npx, npy, &
1075 & npz, bd, split_timestep_bc + 1, &
1076 & REAL(n_split*flagstruct%k_split), &
1077 & neststruct%pt_bc, bctype=neststruct&
1078 & %nestbctype)
1079  end if
1080 ! end hydro check
1081  IF (hydrostatic) THEN
1082  CALL geopk_tlm(ptop, pe, pe_tl, peln, peln_tl, delp, delp_tl, &
1083 & pkc, pkc_tl, gz, gz_tl, phis, pt, pt_tl, q_con, pkz, &
1084 & pkz_tl, npz, akap, .false., gridstruct%nested, .true., &
1085 & npx, npy, flagstruct%a2b_ord, bd)
1086  ELSE
1087  CALL timing_on('UPDATE_DZ')
1088  CALL update_dz_d_tlm(nord_v, damp_vt, flagstruct%hord_tm, is, ie&
1089 & , js, je, npz, ng, npx, npy, gridstruct%area, &
1090 & gridstruct%rarea, dp_ref, zs, zh, zh_tl, crx, &
1091 & crx_tl, cry, cry_tl, xfx, xfx_tl, yfx, yfx_tl, &
1092 & delz, ws, ws_tl, rdt, gridstruct, bd, flagstructp&
1093 & %hord_tm_pert)
1094  CALL timing_off('UPDATE_DZ')
1095  IF (flagstruct%fv_debug) THEN
1096  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz updated', &
1097 & delz, is, ie, js, je, &
1098 & ng, npz, 1., &
1099 & gridstruct%area_64, &
1100 & domain)
1101  END IF
1102  IF (idiag%id_ws .GT. 0 .AND. last_step) used = send_data(idiag%&
1103 & id_ws, ws, fv_time)
1104 ! call prt_maxmin('WS', ws, is, ie, js, je, 0, 1, 1., master)
1105  CALL timing_on('Riem_Solver')
1106  CALL riem_solver3_tlm(flagstruct%m_split, dt, is, ie, js, je, &
1107 & npz, ng, isd, ied, jsd, jed, akap, cappa, cp, &
1108 & ptop, zs, q_con, w, w_tl, delz, delz_tl, pt, &
1109 & pt_tl, delp, delp_tl, zh, zh_tl, pe, pe_tl, pkc&
1110 & , pkc_tl, pk3, pk3_tl, pk, pk_tl, peln, peln_tl&
1111 & , ws, ws_tl, flagstruct%scale_z, flagstruct%&
1112 & p_fac, flagstruct%a_imp, flagstruct%use_logp, &
1113 & remap_step, beta .LT. -0.1)
1114  CALL timing_off('Riem_Solver')
1115  CALL timing_on('COMM_TOTAL')
1116  IF (gridstruct%square_domain) THEN
1117  CALL start_group_halo_update_tlm(i_pack(4), zh, zh_tl, domain)
1118  CALL start_group_halo_update_tlm(i_pack(5), pkc, pkc_tl, &
1119 & domain, whalo=2, ehalo=2, shalo=2, &
1120 & nhalo=2)
1121  ELSE
1122  CALL start_group_halo_update_tlm(i_pack(4), zh, zh_tl, domain&
1123 & , complete=.true.)
1124  CALL start_group_halo_update_tlm(i_pack(4), pkc, pkc_tl, &
1125 & domain, complete=.true.)
1126  END IF
1127  CALL timing_off('COMM_TOTAL')
1128  IF (remap_step) CALL pe_halo_tlm(is, ie, js, je, isd, ied, jsd, &
1129 & jed, npz, ptop, pe, pe_tl, delp, &
1130 & delp_tl)
1131  IF (flagstruct%use_logp) THEN
1132  CALL pln_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, &
1133 & ptop, pk3, pk3_tl, delp, delp_tl)
1134  ELSE
1135  CALL pk3_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, &
1136 & ptop, akap, pk3, pk3_tl, delp, delp_tl)
1137  END IF
1138  IF (gridstruct%nested) THEN
1139  CALL nested_grid_bc_apply_intt_tlm(delz, delz_tl, 0, 0, npx, &
1140 & npy, npz, bd, split_timestep_bc +&
1141 & 1., REAL(n_split*flagstruct%& & k_split), neststruct%delz_bc, &
1142 & bctype=neststruct%nestbctype)
1143 !Compute gz/pkc/pk3; note that now pkc should be nonhydro pert'n pressure
1144  CALL nest_halo_nh_tlm(ptop, grav, akap, cp, delp, delp_tl, &
1145 & delz, delz_tl, pt, pt_tl, phis, pkc, pkc_tl, &
1146 & gz, gz_tl, pk3, pk3_tl, npx, npy, npz, &
1147 & gridstruct%nested, .true., .true., .true., bd)
1148  END IF
1149  CALL timing_on('COMM_TOTAL')
1150  CALL complete_group_halo_update(i_pack(4), domain)
1151  CALL timing_off('COMM_TOTAL')
1152 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zh,grav)
1153  DO k=1,npz+1
1154  DO j=js-2,je+2
1155  DO i=is-2,ie+2
1156  gz_tl(i, j, k) = grav*zh_tl(i, j, k)
1157  gz(i, j, k) = zh(i, j, k)*grav
1158  END DO
1159  END DO
1160  END DO
1161  IF (gridstruct%square_domain) THEN
1162  CALL timing_on('COMM_TOTAL')
1163  CALL complete_group_halo_update(i_pack(5), domain)
1164  CALL timing_off('COMM_TOTAL')
1165  END IF
1166  END IF
1167  IF (remap_step .AND. hydrostatic) THEN
1168 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,pkc)
1169  DO k=1,npz+1
1170  DO j=js,je
1171  DO i=is,ie
1172  pk_tl(i, j, k) = pkc_tl(i, j, k)
1173  pk(i, j, k) = pkc(i, j, k)
1174  END DO
1175  END DO
1176  END DO
1177  END IF
1178 !----------------------------
1179 ! Compute pressure gradient:
1180 !----------------------------
1181  CALL timing_on('PG_D')
1182  IF (hydrostatic) THEN
1183  IF (beta .GT. 0.) THEN
1184  CALL grad1_p_update_tlm(divg2, divg2_tl, u, u_tl, v, v_tl, pkc&
1185 & , pkc_tl, gz, gz_tl, du, du_tl, dv, dv_tl, &
1186 & dt, ng, gridstruct, bd, npx, npy, npz, ptop&
1187 & , beta_d, flagstruct%a2b_ord)
1188  ELSE
1189  CALL one_grad_p_tlm(u, u_tl, v, v_tl, pkc, pkc_tl, gz, gz_tl, &
1190 & divg2, divg2_tl, delp, delp_tl, dt, ng, &
1191 & gridstruct, bd, npx, npy, npz, ptop, hydrostatic&
1192 & , flagstruct%a2b_ord, flagstruct%d_ext)
1193  END IF
1194  ELSE IF (beta .GT. 0.) THEN
1195  CALL split_p_grad_tlm(u, u_tl, v, v_tl, pkc, pkc_tl, gz, gz_tl, &
1196 & du, du_tl, dv, dv_tl, delp, delp_tl, pk3, pk3_tl&
1197 & , beta_d, dt, ng, gridstruct, bd, npx, npy, npz&
1198 & , flagstruct%use_logp)
1199  ELSE IF (beta .LT. -0.1) THEN
1200  CALL one_grad_p_tlm(u, u_tl, v, v_tl, pkc, pkc_tl, gz, gz_tl, &
1201 & divg2, divg2_tl, delp, delp_tl, dt, ng, gridstruct&
1202 & , bd, npx, npy, npz, ptop, hydrostatic, flagstruct&
1203 & %a2b_ord, flagstruct%d_ext)
1204  ELSE
1205  CALL nh_p_grad_tlm(u, u_tl, v, v_tl, pkc, pkc_tl, gz, gz_tl, &
1206 & delp, delp_tl, pk3, pk3_tl, dt, ng, gridstruct, bd&
1207 & , npx, npy, npz, flagstruct%use_logp)
1208  END IF
1209  CALL timing_off('PG_D')
1210 ! Inline Rayleigh friction here?
1211 !-------------------------------------------------------------------------------------------------------
1212  IF (flagstruct%breed_vortex_inline) THEN
1213  IF (.NOT.hydrostatic) THEN
1214 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k)
1215  DO k=1,npz
1216  DO j=js,je
1217  DO i=is,ie
1218 ! Note: pt at this stage is Theta_m
1219  arg1_tl = (rdg*delp_tl(i, j, k)*delz(i, j, k)-rdg*delp(i&
1220 & , j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2&
1221 & + rdg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
1222  arg1 = rdg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1223  arg2_tl = k1k*arg1_tl/arg1
1224  arg2 = k1k*log(arg1)
1225  pkz_tl(i, j, k) = arg2_tl*exp(arg2)
1226  pkz(i, j, k) = exp(arg2)
1227  END DO
1228  END DO
1229  END DO
1230  END IF
1231  CALL breed_slp_inline(it, dt, npz, ak, bk, phis, pe, pk, peln, &
1232 & pkz, delp, u, v, pt, q, flagstruct%nwat, zvir, &
1233 & gridstruct, ks, domain, bd, hydrostatic)
1234  END IF
1235 !-------------------------------------------------------------------------------------------------------
1236  CALL timing_on('COMM_TOTAL')
1237  IF (it .EQ. n_split .AND. gridstruct%grid_type .LT. 4 .AND. (.NOT.&
1238 & gridstruct%nested)) THEN
1239 ! Prevent accumulation of rounding errors at overlapped domain edges:
1240  CALL mpp_get_boundary_tlm(u, u_tl, v, v_tl, domain, ebuffery=&
1241 & ebuffer, ebuffery_tl=ebuffer_tl, nbufferx=&
1242 & nbuffer, nbufferx_tl=nbuffer_tl, gridtype=&
1243 & dgrid_ne)
1244 !$OMP parallel do default(none) shared(is,ie,js,je,npz,u,nbuffer,v,ebuffer)
1245  DO k=1,npz
1246  DO i=is,ie
1247  u_tl(i, je+1, k) = nbuffer_tl(i-is+1, k)
1248  u(i, je+1, k) = nbuffer(i-is+1, k)
1249  END DO
1250  DO j=js,je
1251  v_tl(ie+1, j, k) = ebuffer_tl(j-js+1, k)
1252  v(ie+1, j, k) = ebuffer(j-js+1, k)
1253  END DO
1254  END DO
1255  END IF
1256  IF (it .NE. n_split) CALL start_group_halo_update_tlm(i_pack(8), u&
1257 & , u_tl, v, v_tl, &
1258 & domain, gridtype=&
1259 & dgrid_ne)
1260  CALL timing_off('COMM_TOTAL')
1261  IF (gridstruct%nested) neststruct%nest_timestep = neststruct%&
1262 & nest_timestep + 1
1263  IF (hydrostatic .AND. last_step) THEN
1264  IF (flagstruct%use_old_omega) THEN
1265 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,pe,pem,rdt)
1266  DO k=1,npz
1267  DO j=js,je
1268  DO i=is,ie
1269  omga_tl(i, j, k) = rdt*(pe_tl(i, k+1, j)-pem_tl(i, k+1, &
1270 & j))
1271  omga(i, j, k) = (pe(i, k+1, j)-pem(i, k+1, j))*rdt
1272  END DO
1273  END DO
1274  END DO
1275 !------------------------------
1276 ! Compute the "advective term"
1277 !------------------------------
1278  CALL adv_pe_tlm(ua, ua_tl, va, va_tl, pem, pem_tl, omga, &
1279 & omga_tl, gridstruct, bd, npx, npy, npz, ng)
1280  ELSE
1281 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga) private(om2d)
1282  DO j=js,je
1283  DO k=1,npz
1284  DO i=is,ie
1285  om2d_tl(i, k) = omga_tl(i, j, k)
1286  om2d(i, k) = omga(i, j, k)
1287  END DO
1288  END DO
1289  DO k=2,npz
1290  DO i=is,ie
1291  om2d_tl(i, k) = om2d_tl(i, k-1) + omga_tl(i, j, k)
1292  om2d(i, k) = om2d(i, k-1) + omga(i, j, k)
1293  END DO
1294  END DO
1295  DO k=2,npz
1296  DO i=is,ie
1297  omga_tl(i, j, k) = om2d_tl(i, k)
1298  omga(i, j, k) = om2d(i, k)
1299  END DO
1300  END DO
1301  END DO
1302  END IF
1303  IF (idiag%id_ws .GT. 0 .AND. hydrostatic) THEN
1304 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ws,delz,delp,omga)
1305  DO j=js,je
1306  DO i=is,ie
1307  ws_tl(i, j) = (delz_tl(i, j, npz)*delp(i, j, npz)-delz(i, &
1308 & j, npz)*delp_tl(i, j, npz))*omga(i, j, npz)/delp(i, j, &
1309 & npz)**2 + delz(i, j, npz)*omga_tl(i, j, npz)/delp(i, j, &
1310 & npz)
1311  ws(i, j) = delz(i, j, npz)/delp(i, j, npz)*omga(i, j, npz)
1312  END DO
1313  END DO
1314  used = send_data(idiag%id_ws, ws, fv_time)
1315  END IF
1316  END IF
1317  IF (gridstruct%nested) THEN
1318  IF (.NOT.hydrostatic) CALL nested_grid_bc_apply_intt_tlm(w, w_tl&
1319 & , 0, 0, npx, &
1320 & npy, npz, bd&
1321 & , &
1322 & split_timestep_bc&
1323 & + 1, REAL(& & n_split*& & flagstruct%& & k_split), &
1324 & neststruct%&
1325 & w_bc, bctype=&
1326 & neststruct%&
1327 & nestbctype)
1328  call nested_grid_bc_apply_intt_tlm(u, u_tl, 0, 1, npx, npy, npz&
1329 & , bd, split_timestep_bc + 1, REAL(&
1330 & n_split*flagstruct%k_split), &
1331 & neststruct%u_bc, bctype=neststruct%&
1332 & nestbctype)
1333  call nested_grid_bc_apply_intt_tlm(v, v_tl, 1, 0, npx, npy, npz&
1334 & , bd, split_timestep_bc + 1, REAL(&
1335 & n_split*flagstruct%k_split), &
1336 & neststruct%v_bc, bctype=neststruct%&
1337 & nestbctype)
1338  end if
1339  END DO
1340 !-----------------------------------------------------
1341 ! time split loop
1342 !-----------------------------------------------------
1343  IF (nq .GT. 0 .AND. (.NOT.flagstruct%inline_q)) THEN
1344  CALL timing_on('COMM_TOTAL')
1345  CALL timing_on('COMM_TRACER')
1346  CALL start_group_halo_update_tlm(i_pack(10), q, q_tl, domain)
1347  CALL timing_off('COMM_TRACER')
1348  CALL timing_off('COMM_TOTAL')
1349  END IF
1350  IF (flagstruct%fv_debug) THEN
1351  IF (is_master()) WRITE(*, *) 'End of n_split loop'
1352  END IF
1353  IF (n_con .NE. 0 .AND. flagstruct%d_con .GT. 1.e-5) THEN
1354  IF (3 .GT. flagstruct%nord + 1) THEN
1355  nf_ke = flagstruct%nord + 1
1356  ELSE
1357  nf_ke = 3
1358  END IF
1359  CALL del2_cubed_tlm(heat_source, heat_source_tl, cnst_0p20*&
1360 & gridstruct%da_min, gridstruct, domain, npx, npy, npz&
1361 & , nf_ke, bd)
1362 ! Note: pt here is cp*(Virtual_Temperature/pkz)
1363  IF (hydrostatic) THEN
1364 !
1365 ! del(Cp*T) = - del(KE)
1366 !
1367 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pt,heat_source,delp,pkz,bdt) &
1368 !$OMP private(dtmp)
1369  DO j=js,je
1370 ! n_con is usually less than 3;
1371  DO k=1,n_con
1372  IF (k .LT. 3) THEN
1373  DO i=is,ie
1374  pt_tl(i, j, k) = pt_tl(i, j, k) + (heat_source_tl(i, j, &
1375 & k)*cp_air*delp(i, j, k)*pkz(i, j, k)-heat_source(i, j&
1376 & , k)*cp_air*(delp_tl(i, j, k)*pkz(i, j, k)+delp(i, j, &
1377 & k)*pkz_tl(i, j, k)))/(cp_air*delp(i, j, k)*pkz(i, j, k&
1378 & ))**2
1379  pt(i, j, k) = pt(i, j, k) + heat_source(i, j, k)/(cp_air&
1380 & *delp(i, j, k)*pkz(i, j, k))
1381  END DO
1382  ELSE
1383  DO i=is,ie
1384  dtmp_tl = (heat_source_tl(i, j, k)*cp_air*delp(i, j, k)-&
1385 & heat_source(i, j, k)*cp_air*delp_tl(i, j, k))/(cp_air*&
1386 & delp(i, j, k))**2
1387  dtmp = heat_source(i, j, k)/(cp_air*delp(i, j, k))
1388  IF (bdt .GE. 0.) THEN
1389  abs0 = bdt
1390  ELSE
1391  abs0 = -bdt
1392  END IF
1393  x1 = abs0*flagstruct%delt_max
1394  IF (dtmp .GE. 0.) THEN
1395  y1_tl = dtmp_tl
1396  y1 = dtmp
1397  ELSE
1398  y1_tl = -dtmp_tl
1399  y1 = -dtmp
1400  END IF
1401  IF (x1 .GT. y1) THEN
1402  min1_tl = y1_tl
1403  min1 = y1
1404  ELSE
1405  min1 = x1
1406  min1_tl = 0.0
1407  END IF
1408  pt_tl(i, j, k) = pt_tl(i, j, k) + (min1_tl*sign(1.d0, &
1409 & min1*dtmp)*pkz(i, j, k)-sign(min1, dtmp)*pkz_tl(i, j, &
1410 & k))/pkz(i, j, k)**2
1411  pt(i, j, k) = pt(i, j, k) + sign(min1, dtmp)/pkz(i, j, k&
1412 & )
1413  END DO
1414  END IF
1415  END DO
1416  END DO
1417  ELSE
1418 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pkz,cappa,rdg,delp,delz,pt, &
1419 !$OMP heat_source,k1k,cv_air,bdt) &
1420 !$OMP private(dtmp, delt)
1421  DO k=1,n_con
1422  IF (bdt*flagstruct%delt_max .GE. 0.) THEN
1423  delt = bdt*flagstruct%delt_max
1424  ELSE
1425  delt = -(bdt*flagstruct%delt_max)
1426  END IF
1427 ! Sponge layers:
1428 ! if ( k == 1 ) delt = 2.0*delt
1429 ! if ( k == 2 ) delt = 1.5*delt
1430  DO j=js,je
1431  DO i=is,ie
1432  arg1_tl = (rdg*delp_tl(i, j, k)*delz(i, j, k)-rdg*delp(i, &
1433 & j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2 + &
1434 & rdg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
1435  arg1 = rdg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1436  arg2_tl = k1k*arg1_tl/arg1
1437  arg2 = k1k*log(arg1)
1438  pkz_tl(i, j, k) = arg2_tl*exp(arg2)
1439  pkz(i, j, k) = exp(arg2)
1440  dtmp_tl = (heat_source_tl(i, j, k)*cv_air*delp(i, j, k)-&
1441 & heat_source(i, j, k)*cv_air*delp_tl(i, j, k))/(cv_air*&
1442 & delp(i, j, k))**2
1443  dtmp = heat_source(i, j, k)/(cv_air*delp(i, j, k))
1444  IF (dtmp .GE. 0.) THEN
1445  y2_tl = dtmp_tl
1446  y2 = dtmp
1447  ELSE
1448  y2_tl = -dtmp_tl
1449  y2 = -dtmp
1450  END IF
1451  IF (delt .GT. y2) THEN
1452  min2_tl = y2_tl
1453  min2 = y2
1454  ELSE
1455  min2 = delt
1456  min2_tl = 0.0
1457  END IF
1458  pt_tl(i, j, k) = pt_tl(i, j, k) + (min2_tl*sign(1.d0, min2&
1459 & *dtmp)*pkz(i, j, k)-sign(min2, dtmp)*pkz_tl(i, j, k))/&
1460 & pkz(i, j, k)**2
1461  pt(i, j, k) = pt(i, j, k) + sign(min2, dtmp)/pkz(i, j, k)
1462  END DO
1463  END DO
1464  END DO
1465  END IF
1466  END IF
1467  END SUBROUTINE dyn_core_tlm
1468 !-----------------------------------------------------------------------
1469 ! dyn_core :: FV Lagrangian dynamics driver
1470 !-----------------------------------------------------------------------
1471  SUBROUTINE dyn_core(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, &
1472 & cp, akap, cappa, grav, hydrostatic, u, v, w, delz, pt, q, delp, pe, &
1473 & pk, phis, ws, omga, ptop, pfull, ua, va, uc, vc, mfx, mfy, cx, cy, &
1474 & pkz, peln, q_con, ak, bk, dpx, ks, gridstruct, flagstruct, &
1475 & flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, &
1476 & end_step, gz, pkc, ptc, crx, xfx, cry, yfx, divgd, delpc, ut, vt, zh&
1477 & , pk3, du, dv, time_total)
1478  IMPLICIT NONE
1479 ! end init_step
1480 ! Start of the big dynamic time stepping
1481 !allocate( gz(isd:ied, jsd:jed ,npz+1) )
1482 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, gz, huge_r)
1483 !allocate( pkc(isd:ied, jsd:jed ,npz+1) )
1484 !allocate( ptc(isd:ied, jsd:jed ,npz ) )
1485 !allocate( crx(is :ie+1, jsd:jed, npz) )
1486 !allocate( xfx(is :ie+1, jsd:jed, npz) )
1487 !allocate( cry(isd:ied, js :je+1, npz) )
1488 !allocate( yfx(isd:ied, js :je+1, npz) )
1489 !allocate( divgd(isd:ied+1,jsd:jed+1,npz) )
1490 !allocate( delpc(isd:ied, jsd:jed ,npz ) )
1491 ! call init_ijk_mem(isd,ied, jsd,jed, npz, delpc, 0.)
1492 !allocate( ut(isd:ied, jsd:jed, npz) )
1493 ! call init_ijk_mem(isd,ied, jsd,jed, npz, ut, 0.)
1494 !allocate( vt(isd:ied, jsd:jed, npz) )
1495 ! call init_ijk_mem(isd,ied, jsd,jed, npz, vt, 0.)
1496 !allocate( zh(isd:ied, jsd:jed, npz+1) )
1497 ! call init_ijk_mem(isd,ied, jsd,jed, npz+1, zh, huge_r )
1498 !allocate ( pk3(isd:ied,jsd:jed,npz+1) )
1499 !call init_ijk_mem(isd,ied, jsd,jed, npz+1, pk3, huge_r )
1500 !if (allocated(heat_source)) deallocate( heat_source ) !If ncon == 0 but d_con > 1.e-5, this would not be deallocated in earlier
1501 !versions of the code
1502 !deallocate( gz )
1503 !deallocate( ptc )
1504 !deallocate( crx )
1505 !deallocate( xfx )
1506 !deallocate( cry )
1507 !deallocate( yfx )
1508 !deallocate( divgd )
1509 !deallocate( pkc )
1510 !deallocate( delpc )
1511 !if( allocated(ut)) deallocate( ut )
1512 !if( allocated(vt)) deallocate( vt )
1513 !if ( allocated (du) ) deallocate( du )
1514 !if ( allocated (dv) ) deallocate( dv )
1515 !if ( .not. hydrostatic ) then
1516 ! deallocate( zh )
1517 ! if( allocated(pk3) ) deallocate ( pk3 )
1518 !endif
1519 !if( allocated(pem) ) deallocate ( pem )
1520  INTEGER, INTENT(IN) :: npx
1521  INTEGER, INTENT(IN) :: npy
1522  INTEGER, INTENT(IN) :: npz
1523  INTEGER, INTENT(IN) :: ng, nq, sphum
1524  INTEGER, INTENT(IN) :: n_split
1525  REAL, INTENT(IN) :: bdt
1526  REAL, INTENT(IN) :: zvir, cp, akap, grav
1527  REAL, INTENT(IN) :: ptop
1528  LOGICAL, INTENT(IN) :: hydrostatic
1529  LOGICAL, INTENT(IN) :: init_step, end_step
1530  REAL, INTENT(IN) :: pfull(npz)
1531  REAL, DIMENSION(npz+1), INTENT(IN) :: ak, bk
1532  INTEGER, INTENT(IN) :: ks
1533  TYPE(group_halo_update_type), INTENT(INOUT) :: i_pack(*)
1534  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
1535 ! D grid zonal wind (m/s)
1536  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz), INTENT(INOUT) &
1537 & :: u
1538 ! D grid meridional wind (m/s)
1539  REAL, DIMENSION(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz), INTENT(INOUT) &
1540 & :: v
1541 ! vertical vel. (m/s)
1542  REAL, INTENT(INOUT) :: w(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1543 ! delta-height (m, negative)
1544  REAL, INTENT(INOUT) :: delz(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1545 ! moist kappa
1546  REAL, INTENT(INOUT) :: cappa(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1547 ! temperature (K)
1548  REAL, INTENT(INOUT) :: pt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1549 ! pressure thickness (pascal)
1550  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1551 !
1552  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, npz, nq)
1553 ! total time (seconds) since start
1554  REAL, INTENT(IN), OPTIONAL :: time_total
1555 !-----------------------------------------------------------------------
1556 ! Auxilliary pressure arrays:
1557 ! The 5 vars below can be re-computed from delp and ptop.
1558 !-----------------------------------------------------------------------
1559 ! dyn_aux:
1560 ! Surface geopotential (g*Z_surf)
1561  REAL, INTENT(INOUT) :: phis(bd%isd:bd%ied, bd%jsd:bd%jed)
1562 ! edge pressure (pascal)
1563  REAL, INTENT(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
1564 ! ln(pe)
1565  REAL, INTENT(INOUT) :: peln(bd%is:bd%ie, npz+1, bd%js:bd%je)
1566 ! pe**kappa
1567  REAL, INTENT(INOUT) :: pk(bd%is:bd%ie, bd%js:bd%je, npz+1)
1568  REAL(kind=8), INTENT(INOUT) :: dpx(bd%is:bd%ie, bd%js:bd%je)
1569 !-----------------------------------------------------------------------
1570 ! Others:
1571  REAL, PARAMETER :: near0=1.e-8
1572  REAL, PARAMETER :: huge_r=1.e8
1573 !-----------------------------------------------------------------------
1574 ! w at surface
1575  REAL, INTENT(OUT) :: ws(bd%is:bd%ie, bd%js:bd%je)
1576 ! Vertical pressure velocity (pa/s)
1577  REAL, INTENT(INOUT) :: omga(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1578 ! (uc, vc) are mostly used as the C grid winds
1579  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1580  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1581  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(INOUT) ::&
1582 & ua, va
1583  REAL, INTENT(INOUT) :: q_con(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1584 ! The Flux capacitors: accumulated Mass flux arrays
1585  REAL, INTENT(INOUT) :: mfx(bd%is:bd%ie+1, bd%js:bd%je, npz)
1586  REAL, INTENT(INOUT) :: mfy(bd%is:bd%ie, bd%js:bd%je+1, npz)
1587 ! Accumulated Courant number arrays
1588  REAL, INTENT(INOUT) :: cx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1589  REAL, INTENT(INOUT) :: cy(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1590  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je, npz), INTENT(INOUT) :: pkz
1591  TYPE(fv_grid_type), INTENT(INOUT), TARGET :: gridstruct
1592  TYPE(fv_flags_type), INTENT(IN), TARGET :: flagstruct
1593  TYPE(fv_flags_pert_type), INTENT(IN), TARGET :: flagstructp
1594  TYPE(fv_nest_type), INTENT(INOUT) :: neststruct
1595  TYPE(fv_diag_type), INTENT(IN) :: idiag
1596  TYPE(domain2d), INTENT(INOUT) :: domain
1597 !real, allocatable, dimension(:,:,:):: pem, heat_source
1598  REAL :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1), heat_source(bd&
1599 & %isd:bd%ied, bd%jsd:bd%jed, npz)
1600 ! Auto 1D & 2D arrays:
1601  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: ws3, z_rat
1602  REAL :: dp_ref(npz)
1603 ! surface height (m)
1604  REAL :: zs(bd%isd:bd%ied, bd%jsd:bd%jed)
1605  REAL :: p1d(bd%is:bd%ie)
1606  REAL :: om2d(bd%is:bd%ie, npz)
1607  REAL :: wbuffer(npy+2, npz)
1608  REAL :: ebuffer(npy+2, npz)
1609  REAL :: nbuffer(npx+2, npz)
1610  REAL :: sbuffer(npx+2, npz)
1611 ! ---- For external mode:
1612  REAL :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
1613  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
1614  REAL :: fz(bd%is:bd%ie+1, bd%js:bd%je+1)
1615  REAL :: heat_s(bd%is:bd%ie, bd%js:bd%je)
1616  REAL :: damp_vt(npz+1)
1617  INTEGER :: nord_v(npz+1)
1618 !-------------------------------------
1619  INTEGER :: hord_m, hord_v, hord_t, hord_p
1620  INTEGER :: nord_k, nord_w, nord_t
1621  INTEGER :: ms
1622 !---------------------------------------
1623  INTEGER :: hord_m_pert, hord_v_pert, hord_t_pert, hord_p_pert
1624  INTEGER :: nord_k_pert, nord_w_pert, nord_t_pert, nord_v_pert(npz+1)
1625  REAL :: d2_divg_pert, damp_vt_pert(npz+1), damp_w_pert, damp_t_pert
1626 !---------------------------------------
1627  INTEGER :: i, j, k, it, iq, n_con, nf_ke
1628  INTEGER :: iep1, jep1
1629  REAL :: beta, beta_d, d_con_k, damp_w, damp_t, kgb, cv_air
1630  REAL :: dt, dt2, rdt
1631  REAL :: d2_divg
1632  REAL :: k1k, rdg, dtmp, delt
1633  LOGICAL :: last_step, remap_step
1634  LOGICAL :: used
1635  REAL :: split_timestep_bc
1636  INTEGER :: is, ie, js, je
1637  INTEGER :: isd, ied, jsd, jed
1638  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1639  REAL, INTENT(INOUT) :: pkc(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1640  REAL, INTENT(INOUT) :: ptc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1641  REAL, INTENT(INOUT) :: crx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1642  REAL, INTENT(INOUT) :: xfx(bd%is:bd%ie+1, bd%jsd:bd%jed, npz)
1643  REAL, INTENT(INOUT) :: cry(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1644  REAL, INTENT(INOUT) :: yfx(bd%isd:bd%ied, bd%js:bd%je+1, npz)
1645  REAL, INTENT(INOUT) :: divgd(bd%isd:bd%ied+1, bd%jsd:bd%jed+1, npz)
1646  REAL, INTENT(INOUT) :: delpc(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1647  REAL, INTENT(INOUT) :: ut(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1648  REAL, INTENT(INOUT) :: vt(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
1649  REAL, INTENT(INOUT) :: zh(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1650  REAL, INTENT(INOUT) :: pk3(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
1651  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
1652  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
1653  INTRINSIC log
1654  INTRINSIC real
1655  INTRINSIC max
1656  INTRINSIC min
1657  INTRINSIC exp
1658  INTRINSIC abs
1659  INTRINSIC sign
1660  INTEGER :: max1
1661  INTEGER :: max2
1662  REAL :: min1
1663  REAL :: min2
1664  REAL :: abs0
1665  REAL :: arg1
1666  REAL :: arg2
1667  REAL :: x1
1668  REAL :: y2
1669  REAL :: y1
1670  is = bd%is
1671  ie = bd%ie
1672  js = bd%js
1673  je = bd%je
1674  isd = bd%isd
1675  ied = bd%ied
1676  jsd = bd%jsd
1677  jed = bd%jed
1678  peln1 = log(ptop)
1679  ptk = ptop**akap
1680  dt = bdt/REAL(n_split)
1681  dt2 = 0.5*dt
1682  rdt = 1.0/dt
1683  IF (1 .LT. flagstruct%m_split/2) THEN
1684  ms = flagstruct%m_split/2
1685  ELSE
1686  ms = 1
1687  END IF
1688  beta = flagstruct%beta
1689  rdg = -(rdgas/grav)
1690  cv_air = cp_air - rdgas
1691 ! Indexes:
1692  iep1 = ie + 1
1693  jep1 = je + 1
1694  IF (.NOT.hydrostatic) THEN
1695  rgrav = 1.0/grav
1696 ! rg/Cv=0.4
1697  k1k = akap/(1.-akap)
1698 !$OMP parallel do default(none) shared(npz,dp_ref,ak,bk)
1699  DO k=1,npz
1700  dp_ref(k) = ak(k+1) - ak(k) + (bk(k+1)-bk(k))*1.e5
1701  END DO
1702 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,zs,phis,rgrav)
1703  DO j=jsd,jed
1704  DO i=isd,ied
1705  zs(i, j) = phis(i, j)*rgrav
1706  END DO
1707  END DO
1708  END IF
1709 !allocate( du(isd:ied, jsd:jed+1,npz) )
1710 !call init_ijk_mem(isd,ied, jsd,jed+1, npz, du, 0.)
1711 !allocate( dv(isd:ied+1,jsd:jed, npz) )
1712 !call init_ijk_mem(isd,ied+1, jsd,jed , npz, dv, 0.)
1713 ! Empty the "flux capacitors"
1714 !call init_ijk_mem(is, ie+1, js, je, npz, mfx, 0.)
1715  mfx = 0.0
1716 !call init_ijk_mem(is, ie , js, je+1, npz, mfy, 0.)
1717  mfy = 0.0
1718 !call init_ijk_mem(is, ie+1, jsd, jed, npz, cx, 0.)
1719  cx = 0.0
1720 !call init_ijk_mem(isd, ied, js, je+1, npz, cy, 0.)
1721  cy = 0.0
1722  IF (flagstruct%d_con .GT. 1.0e-5) heat_source = 0.0
1723 !allocate( heat_source(isd:ied, jsd:jed, npz) )
1724 !call init_ijk_mem(isd, ied, jsd, jed, npz, heat_source, 0.)
1725  IF (flagstruct%convert_ke .OR. flagstruct%vtdm4 .GT. 1.e-4) THEN
1726  n_con = npz
1727  ELSE IF (flagstruct%d2_bg_k1 .LT. 1.e-3) THEN
1728  n_con = 0
1729  ELSE IF (flagstruct%d2_bg_k2 .LT. 1.e-3) THEN
1730  n_con = 1
1731  ELSE
1732  n_con = 2
1733  END IF
1734 !-----------------------------------------------------
1735  DO it=1,n_split
1736 !-----------------------------------------------------
1737  IF (flagstruct%breed_vortex_inline .OR. it .EQ. n_split) THEN
1738  remap_step = .true.
1739  ELSE
1740  remap_step = .false.
1741  END IF
1742  IF (flagstruct%fv_debug) THEN
1743  IF (is_master()) WRITE(*, *) 'n_split loop, it=', it
1744  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
1745 & ie, js, je, ng, npz, 1.&
1746 & , gridstruct%area_64, &
1747 & domain)
1748  CALL prt_mxm('PT', pt, is, ie, js, je, ng, npz, 1., gridstruct%&
1749 & area_64, domain)
1750  END IF
1751  IF (gridstruct%nested) split_timestep_bc = REAL(n_split*flagstruct&
1752 & %k_split + neststruct%nest_timestep)
1753 !First split timestep has split_timestep_BC = n_split*k_split
1754 ! to do time-extrapolation on BCs.
1755  IF (nq .GT. 0) THEN
1756  CALL timing_on('COMM_TOTAL')
1757  CALL timing_on('COMM_TRACER')
1758  IF (flagstruct%inline_q) CALL start_group_halo_update(i_pack(10)&
1759 & , q, domain)
1760  CALL timing_off('COMM_TRACER')
1761  CALL timing_off('COMM_TOTAL')
1762  END IF
1763  IF (.NOT.hydrostatic) THEN
1764  CALL timing_on('COMM_TOTAL')
1765  CALL start_group_halo_update(i_pack(7), w, domain)
1766  CALL timing_off('COMM_TOTAL')
1767  IF (it .EQ. 1) THEN
1768  IF (gridstruct%nested) THEN
1769 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,gz,zs,delz)
1770  DO j=jsd,jed
1771  DO i=isd,ied
1772  gz(i, j, npz+1) = zs(i, j)
1773  END DO
1774  DO k=npz,1,-1
1775  DO i=isd,ied
1776  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
1777  END DO
1778  END DO
1779  END DO
1780  ELSE
1781 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zs,delz)
1782  DO j=js,je
1783  DO i=is,ie
1784  gz(i, j, npz+1) = zs(i, j)
1785  END DO
1786  DO k=npz,1,-1
1787  DO i=is,ie
1788  gz(i, j, k) = gz(i, j, k+1) - delz(i, j, k)
1789  END DO
1790  END DO
1791  END DO
1792  END IF
1793  CALL timing_on('COMM_TOTAL')
1794  CALL start_group_halo_update(i_pack(5), gz, domain)
1795  CALL timing_off('COMM_TOTAL')
1796  END IF
1797  END IF
1798  IF (it .EQ. 1) THEN
1799  CALL timing_on('COMM_TOTAL')
1800  CALL complete_group_halo_update(i_pack(1), domain)
1801  CALL timing_off('COMM_TOTAL')
1802  beta_d = 0.
1803  ELSE
1804  beta_d = beta
1805  END IF
1806  IF (it .EQ. n_split .AND. end_step) THEN
1807  IF (flagstruct%use_old_omega) THEN
1808  pem = 0.0
1809 !allocate ( pem(is-1:ie+1,npz+1,js-1:je+1) )
1810 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pem,delp,ptop)
1811  DO j=js-1,je+1
1812  DO i=is-1,ie+1
1813  pem(i, 1, j) = ptop
1814  END DO
1815  DO k=1,npz
1816  DO i=is-1,ie+1
1817  pem(i, k+1, j) = pem(i, k, j) + delp(i, j, k)
1818  END DO
1819  END DO
1820  END DO
1821  END IF
1822  last_step = .true.
1823  ELSE
1824  last_step = .false.
1825  END IF
1826  CALL timing_on('COMM_TOTAL')
1827  CALL complete_group_halo_update(i_pack(8), domain)
1828  IF (.NOT.hydrostatic) CALL complete_group_halo_update(i_pack(7), &
1829 & domain)
1830  CALL timing_off('COMM_TOTAL')
1831  CALL timing_on('c_sw')
1832 !$OMP parallel do default(none) shared(npz,isd,jsd,delpc,delp,ptc,pt,u,v,w,uc,vc,ua,va, &
1833 !$OMP omga,ut,vt,divgd,flagstruct,dt2,hydrostatic,bd, &
1834 !$OMP gridstruct)
1835  DO k=1,npz
1836  CALL c_sw(delpc(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k)&
1837 & , ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k), u(isd:&
1838 & ied, jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(isd:ied, jsd&
1839 & :jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:ied, jsd:jed+1, &
1840 & k), ua(isd:ied, jsd:jed, k), va(isd:ied, jsd:jed, k), omga(&
1841 & isd:ied, jsd:jed, k), ut(isd:ied, jsd:jed, k), vt(isd:ied, &
1842 & jsd:jed, k), divgd(isd:ied+1, jsd:jed+1, k), flagstruct%nord&
1843 & , dt2, hydrostatic, .true., bd, gridstruct, flagstruct)
1844  END DO
1845  CALL timing_off('c_sw')
1846  IF (flagstruct%nord .GT. 0) THEN
1847  CALL timing_on('COMM_TOTAL')
1848  CALL start_group_halo_update(i_pack(3), divgd, domain, position=&
1849 & corner)
1850  CALL timing_off('COMM_TOTAL')
1851  END IF
1852  IF (gridstruct%nested) THEN
1853  CALL nested_grid_bc_apply_intt(delpc, 0, 0, npx, npy, npz, bd, &
1854 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%delp_bc&
1855 & , neststruct%nestbctype)
1856  call nested_grid_bc_apply_intt(ptc, 0, 0, npx, npy, npz, bd, &
1857 & split_timestep_bc + 0.5, REAL(n_split*&
1858 & flagstruct%k_split), neststruct%pt_bc, &
1859 & neststruct%nestbctype)
1860  end if
1861 ! end hydro check
1862  IF (hydrostatic) THEN
1863  CALL geopk(ptop, pe, peln, delpc, pkc, gz, phis, ptc, q_con, pkz&
1864 & , npz, akap, .true., gridstruct%nested, .false., npx, npy, &
1865 & flagstruct%a2b_ord, bd)
1866  ELSE
1867  IF (it .EQ. 1) THEN
1868  CALL timing_on('COMM_TOTAL')
1869  CALL complete_group_halo_update(i_pack(5), domain)
1870  CALL timing_off('COMM_TOTAL')
1871 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
1872  DO k=1,npz+1
1873  DO j=jsd,jed
1874  DO i=isd,ied
1875 ! Save edge heights for update_dz_d
1876  zh(i, j, k) = gz(i, j, k)
1877  END DO
1878  END DO
1879  END DO
1880  ELSE
1881 !$OMP parallel do default(none) shared(isd,ied,jsd,jed,npz,zh,gz)
1882  DO k=1,npz+1
1883  DO j=jsd,jed
1884  DO i=isd,ied
1885  gz(i, j, k) = zh(i, j, k)
1886  END DO
1887  END DO
1888  END DO
1889  END IF
1890  CALL timing_on('UPDATE_DZ_C')
1891  CALL update_dz_c(is, ie, js, je, npz, ng, dt2, dp_ref, zs, &
1892 & gridstruct%area, ut, vt, gz, ws3, npx, npy, &
1893 & gridstruct%sw_corner, gridstruct%se_corner, &
1894 & gridstruct%ne_corner, gridstruct%nw_corner, bd, &
1895 & gridstruct%grid_type)
1896  CALL timing_off('UPDATE_DZ_C')
1897  CALL timing_on('Riem_Solver')
1898  CALL riem_solver_c(ms, dt2, is, ie, js, je, npz, ng, akap, cappa&
1899 & , cp, ptop, phis, omga, ptc, q_con, delpc, gz, pkc&
1900 & , ws3, flagstruct%p_fac, flagstruct%a_imp, &
1901 & flagstruct%scale_z)
1902  CALL timing_off('Riem_Solver')
1903  IF (gridstruct%nested) THEN
1904  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
1905 & split_timestep_bc + 0.5, REAL(n_split& & *flagstruct%k_split), neststruct%&
1906 & delz_bc, neststruct%nestbctype)
1907 !Compute gz/pkc
1908 !NOTE: nominally only need to compute quantities one out in the halo for p_grad_c
1909 !(instead of entire halo)
1910  CALL nest_halo_nh(ptop, grav, akap, cp, delpc, delz, ptc, phis&
1911 & , pkc, gz, pk3, npx, npy, npz, gridstruct%nested, &
1912 & .false., .false., .false., bd)
1913  END IF
1914  END IF
1915  CALL p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, gridstruct%&
1916 & rdxc, gridstruct%rdyc, hydrostatic)
1917  CALL timing_on('COMM_TOTAL')
1918  CALL start_group_halo_update(i_pack(9), uc, vc, domain, gridtype=&
1919 & cgrid_ne)
1920  CALL timing_off('COMM_TOTAL')
1921  CALL timing_on('COMM_TOTAL')
1922  IF (flagstruct%inline_q .AND. nq .GT. 0) CALL &
1923 & complete_group_halo_update(i_pack(10), domain)
1924  IF (flagstruct%nord .GT. 0) CALL complete_group_halo_update(i_pack&
1925 & (3), domain)
1926  CALL complete_group_halo_update(i_pack(9), domain)
1927  CALL timing_off('COMM_TOTAL')
1928  IF (gridstruct%nested) THEN
1929 !On a nested grid we have to do SOMETHING with uc and vc in
1930 ! the boundary halo, particularly at the corners of the
1931 ! domain and of each processor element. We must either
1932 ! apply an interpolated BC, or extrapolate into the
1933 ! boundary halo
1934 ! NOTE:
1935 !The update_domains calls for uc and vc need to go BEFORE the BCs to ensure cross-restart
1936 !bitwise-consistent solutions when doing the spatial extrapolation; should not make a
1937 !difference for interpolated BCs from the coarse grid.
1938  CALL nested_grid_bc_apply_intt(vc, 0, 1, npx, npy, npz, bd, &
1939 & split_timestep_bc + 0.5, REAL(n_split*& & flagstruct%k_split), neststruct%vc_bc, &
1940 & neststruct%nestbctype)
1941  call nested_grid_bc_apply_intt(uc, 1, 0, npx, npy, npz, bd, &
1942 & split_timestep_bc + 0.5, REAL(n_split*&
1943 & flagstruct%k_split), neststruct%uc_bc, &
1944 & neststruct%nestbctype)
1945 !QUESTION: What to do with divgd in nested halo?
1946  CALL nested_grid_bc_apply_intt(divgd, 1, 1, npx, npy, npz, bd, &
1947 & split_timestep_bc, REAL(n_split*& & flagstruct%k_split), neststruct%divg_bc&
1948 & , neststruct%nestbctype)
1949 !!$ if (is == 1 .and. js == 1) then
1950 !!$ do j=jsd,5
1951 !!$ write(mpp_pe()+2000,*) j, divg(isd:5,j,1)
1952 !!$ endif
1953  END IF
1954  IF (gridstruct%nested .AND. flagstruct%inline_q) THEN
1955  DO iq=1,nq
1956  CALL nested_grid_bc_apply_intt(q(isd:ied, jsd:jed, :, iq), 0, &
1957 & 0, npx, npy, npz, bd, &
1958 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%q_bc(&
1959 & iq), neststruct%nestbctype)
1960  end do
1961  END IF
1962  CALL timing_on('d_sw')
1963 !$OMP parallel do default(none) shared(npz,flagstruct,nord_v,pfull,damp_vt,hydrostatic,last_step, &
1964 !$OMP is,ie,js,je,isd,ied,jsd,jed,omga,delp,gridstruct,npx,npy, &
1965 !$OMP ng,zh,vt,ptc,pt,u,v,w,uc,vc,ua,va,divgd,mfx,mfy,cx,cy, &
1966 !$OMP crx,cry,xfx,yfx,q_con,zvir,sphum,nq,q,dt,bd,rdt,iep1,jep1, &
1967 !$OMP heat_source) &
1968 !$OMP private(nord_k, nord_w, nord_t, damp_w, damp_t, d2_divg, &
1969 !$OMP d_con_k,kgb, hord_m, hord_v, hord_t, hord_p, wk, heat_s, z_rat)
1970  DO k=1,npz
1971  hord_m = flagstruct%hord_mt
1972  hord_t = flagstruct%hord_tm
1973  hord_v = flagstruct%hord_vt
1974  hord_p = flagstruct%hord_dp
1975  nord_k = flagstruct%nord
1976 ! if ( k==npz ) then
1977  kgb = flagstruct%ke_bg
1978  IF (2 .GT. flagstruct%nord) THEN
1979  nord_v(k) = flagstruct%nord
1980  ELSE
1981  nord_v(k) = 2
1982  END IF
1983  IF (0.20 .GT. flagstruct%d2_bg) THEN
1984  d2_divg = flagstruct%d2_bg
1985  ELSE
1986  d2_divg = 0.20
1987  END IF
1988  IF (flagstruct%do_vort_damp) THEN
1989 ! for delp, delz, and vorticity
1990  damp_vt(k) = flagstruct%vtdm4
1991  ELSE
1992  damp_vt(k) = 0.
1993  END IF
1994  nord_w = nord_v(k)
1995  nord_t = nord_v(k)
1996  damp_w = damp_vt(k)
1997  damp_t = damp_vt(k)
1998  d_con_k = flagstruct%d_con
1999  IF (npz .EQ. 1 .OR. flagstruct%n_sponge .LT. 0) THEN
2000  d2_divg = flagstruct%d2_bg
2001  ELSE IF (k .EQ. 1) THEN
2002 ! Sponge layers with del-2 damping on divergence, vorticity, w, z, and air mass (delp).
2003 ! no special damping of potential temperature in sponge layers
2004 ! Divergence damping:
2005  nord_k = 0
2006  IF (0.01 .LT. flagstruct%d2_bg) THEN
2007  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k1) THEN
2008  d2_divg = flagstruct%d2_bg_k1
2009  ELSE
2010  d2_divg = flagstruct%d2_bg
2011  END IF
2012  ELSE IF (0.01 .LT. flagstruct%d2_bg_k1) THEN
2013  d2_divg = flagstruct%d2_bg_k1
2014  ELSE
2015  d2_divg = 0.01
2016  END IF
2017 ! Vertical velocity:
2018  nord_w = 0
2019  damp_w = d2_divg
2020  IF (flagstruct%do_vort_damp) THEN
2021 ! damping on delp and vorticity:
2022  nord_v(k) = 0
2023  damp_vt(k) = 0.5*d2_divg
2024  END IF
2025  d_con_k = 0.
2026  ELSE
2027  IF (2 .LT. flagstruct%n_sponge - 1) THEN
2028  max1 = flagstruct%n_sponge - 1
2029  ELSE
2030  max1 = 2
2031  END IF
2032  IF (k .EQ. max1 .AND. flagstruct%d2_bg_k2 .GT. 0.01) THEN
2033  nord_k = 0
2034  IF (flagstruct%d2_bg .LT. flagstruct%d2_bg_k2) THEN
2035  d2_divg = flagstruct%d2_bg_k2
2036  ELSE
2037  d2_divg = flagstruct%d2_bg
2038  END IF
2039  nord_w = 0
2040  damp_w = d2_divg
2041  IF (flagstruct%do_vort_damp) THEN
2042  nord_v(k) = 0
2043  damp_vt(k) = 0.5*d2_divg
2044  END IF
2045  d_con_k = 0.
2046  ELSE
2047  IF (3 .LT. flagstruct%n_sponge) THEN
2048  max2 = flagstruct%n_sponge
2049  ELSE
2050  max2 = 3
2051  END IF
2052  IF (k .EQ. max2 .AND. flagstruct%d2_bg_k2 .GT. 0.05) THEN
2053  nord_k = 0
2054  IF (flagstruct%d2_bg .LT. 0.2*flagstruct%d2_bg_k2) THEN
2055  d2_divg = 0.2*flagstruct%d2_bg_k2
2056  ELSE
2057  d2_divg = flagstruct%d2_bg
2058  END IF
2059  nord_w = 0
2060  damp_w = d2_divg
2061  d_con_k = 0.
2062  END IF
2063  END IF
2064  END IF
2065  hord_m_pert = flagstructp%hord_mt_pert
2066  hord_t_pert = flagstructp%hord_tm_pert
2067  hord_v_pert = flagstructp%hord_vt_pert
2068  hord_p_pert = flagstructp%hord_dp_pert
2069  nord_k_pert = flagstructp%nord_pert
2070  IF (2 .GT. flagstructp%nord_pert) THEN
2071  nord_v_pert(k) = flagstructp%nord_pert
2072  ELSE
2073  nord_v_pert(k) = 2
2074  END IF
2075  IF (0.20 .GT. flagstructp%d2_bg_pert) THEN
2076  d2_divg_pert = flagstructp%d2_bg_pert
2077  ELSE
2078  d2_divg_pert = 0.20
2079  END IF
2080  IF (flagstructp%do_vort_damp_pert) THEN
2081 ! for delp, delz, and vorticity
2082  damp_vt_pert(k) = flagstructp%vtdm4_pert
2083  ELSE
2084  damp_vt_pert(k) = 0.
2085  END IF
2086  nord_w_pert = nord_v_pert(k)
2087  nord_t_pert = nord_v_pert(k)
2088  damp_w_pert = damp_vt_pert(k)
2089  damp_t_pert = damp_vt_pert(k)
2090 !Sponge layers for the pertuabtiosn
2091  IF (k .LE. flagstructp%n_sponge_pert) THEN
2092  IF (k .LE. flagstructp%n_sponge_pert - 1) THEN
2093  IF (flagstructp%hord_ks_traj) THEN
2094  hord_m = flagstructp%hord_mt_ks_traj
2095  hord_t = flagstructp%hord_tm_ks_traj
2096  hord_v = flagstructp%hord_vt_ks_traj
2097  hord_p = flagstructp%hord_dp_ks_traj
2098  END IF
2099  IF (flagstructp%hord_ks_pert) THEN
2100  hord_m_pert = flagstructp%hord_mt_ks_pert
2101  hord_t_pert = flagstructp%hord_tm_ks_pert
2102  hord_v_pert = flagstructp%hord_vt_ks_pert
2103  hord_p_pert = flagstructp%hord_dp_ks_pert
2104  END IF
2105  END IF
2106  nord_k_pert = 0
2107  IF (k .EQ. 1) THEN
2108  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
2109  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k1_pert&
2110 & ) THEN
2111  d2_divg_pert = flagstructp%d2_bg_k1_pert
2112  ELSE
2113  d2_divg_pert = flagstructp%d2_bg_pert
2114  END IF
2115  ELSE IF (0.01 .LT. flagstructp%d2_bg_k1_pert) THEN
2116  d2_divg_pert = flagstructp%d2_bg_k1_pert
2117  ELSE
2118  d2_divg_pert = 0.01
2119  END IF
2120  ELSE IF (k .EQ. 2) THEN
2121  IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
2122  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_k2_pert&
2123 & ) THEN
2124  d2_divg_pert = flagstructp%d2_bg_k2_pert
2125  ELSE
2126  d2_divg_pert = flagstructp%d2_bg_pert
2127  END IF
2128  ELSE IF (0.01 .LT. flagstructp%d2_bg_k2_pert) THEN
2129  d2_divg_pert = flagstructp%d2_bg_k2_pert
2130  ELSE
2131  d2_divg_pert = 0.01
2132  END IF
2133  ELSE IF (0.01 .LT. flagstructp%d2_bg_pert) THEN
2134  IF (flagstructp%d2_bg_pert .LT. flagstructp%d2_bg_ks_pert) &
2135 & THEN
2136  d2_divg_pert = flagstructp%d2_bg_ks_pert
2137  ELSE
2138  d2_divg_pert = flagstructp%d2_bg_pert
2139  END IF
2140  ELSE IF (0.01 .LT. flagstructp%d2_bg_ks_pert) THEN
2141  d2_divg_pert = flagstructp%d2_bg_ks_pert
2142  ELSE
2143  d2_divg_pert = 0.01
2144  END IF
2145  nord_w_pert = 0
2146  damp_w_pert = d2_divg_pert
2147  IF (flagstructp%do_vort_damp_pert) THEN
2148  nord_v_pert(k) = 0
2149  damp_vt_pert(k) = 0.5*d2_divg_pert
2150  END IF
2151  END IF
2152 !Tapenade issue if not defined at level npz+1
2153  damp_vt(npz+1) = damp_vt(npz)
2154  damp_vt_pert(npz+1) = damp_vt_pert(npz)
2155  nord_v(npz+1) = nord_v(npz)
2156  nord_v_pert(npz+1) = nord_v_pert(npz)
2157  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
2158 & last_step) THEN
2159 ! Average horizontal "convergence" to cell center
2160  DO j=js,je
2161  DO i=is,ie
2162  omga(i, j, k) = delp(i, j, k)
2163  END DO
2164  END DO
2165  END IF
2166 !--- external mode divergence damping ---
2167  IF (flagstruct%d_ext .GT. 0.) CALL a2b_ord2(delp(isd:ied, jsd:&
2168 & jed, k), wk, gridstruct, &
2169 & npx, npy, is, ie, js, je, &
2170 & ng, .false.)
2171  IF (.NOT.hydrostatic .AND. flagstruct%do_f3d) THEN
2172 ! Correction factor for 3D Coriolis force
2173  DO j=jsd,jed
2174  DO i=isd,ied
2175  z_rat(i, j) = 1. + (zh(i, j, k)+zh(i, j, k+1))/radius
2176  END DO
2177  END DO
2178  END IF
2179  CALL d_sw(vt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k), &
2180 & ptc(isd:ied, jsd:jed, k), pt(isd:ied, jsd:jed, k), u(isd:ied&
2181 & , jsd:jed+1, k), v(isd:ied+1, jsd:jed, k), w(isd:ied, jsd:&
2182 & jed, k), uc(isd:ied+1, jsd:jed, k), vc(isd:ied, jsd:jed+1, k&
2183 & ), ua(isd:ied, jsd:jed, k), va(isd:ied, jsd:jed, k), divgd(&
2184 & isd:ied+1, jsd:jed+1, k), mfx(is:ie+1, js:je, k), mfy(is:ie&
2185 & , js:je+1, k), cx(is:ie+1, jsd:jed, k), cy(isd:ied, js:je+1&
2186 & , k), crx(is:ie+1, jsd:jed, k), cry(isd:ied, js:je+1, k), &
2187 & xfx(is:ie+1, jsd:jed, k), yfx(isd:ied, js:je+1, k), q_con(&
2188 & isd:ied, jsd:jed, 1), z_rat(isd:ied, jsd:jed), kgb, heat_s, &
2189 & dpx, zvir, sphum, nq, q, k, npz, flagstruct%inline_q, dt, &
2190 & flagstruct%hord_tr, hord_m, hord_v, hord_t, hord_p, nord_k, &
2191 & nord_v(k), nord_w, nord_t, flagstruct%dddmp, d2_divg, &
2192 & flagstruct%d4_bg, damp_vt(k), damp_w, damp_t, d_con_k, &
2193 & hydrostatic, gridstruct, flagstruct, bd, flagstructp%&
2194 & hord_tr_pert, hord_m_pert, hord_v_pert, hord_t_pert, &
2195 & hord_p_pert, flagstructp%split_damp, nord_k_pert, &
2196 & nord_v_pert(k), nord_w_pert, nord_t_pert, flagstructp%&
2197 & dddmp_pert, d2_divg_pert, flagstructp%d4_bg_pert, &
2198 & damp_vt_pert(k), damp_w_pert, damp_t_pert)
2199  IF (hydrostatic .AND. (.NOT.flagstruct%use_old_omega) .AND. &
2200 & last_step) THEN
2201 ! Average horizontal "convergence" to cell center
2202  DO j=js,je
2203  DO i=is,ie
2204  omga(i, j, k) = omga(i, j, k)*(xfx(i, j, k)-xfx(i+1, j, k)&
2205 & +yfx(i, j, k)-yfx(i, j+1, k))*gridstruct%rarea(i, j)*rdt
2206  END DO
2207  END DO
2208  END IF
2209  IF (flagstruct%d_ext .GT. 0.) THEN
2210  DO j=js,jep1
2211  DO i=is,iep1
2212 ! delp at cell corners
2213  ptc(i, j, k) = wk(i, j)
2214  END DO
2215  END DO
2216  END IF
2217  IF (flagstruct%d_con .GT. 1.0e-5) THEN
2218 ! Average horizontal "convergence" to cell center
2219  DO j=js,je
2220  DO i=is,ie
2221  heat_source(i, j, k) = heat_source(i, j, k) + heat_s(i, j)
2222  END DO
2223  END DO
2224  END IF
2225  END DO
2226 ! end openMP k-loop
2227  CALL timing_off('d_sw')
2228  IF (flagstruct%fill_dp) CALL mix_dp(hydrostatic, w, delp, pt, npz&
2229 & , ak, bk, .false., flagstruct%&
2230 & fv_debug, bd)
2231  CALL timing_on('COMM_TOTAL')
2232  CALL start_group_halo_update(i_pack(1), delp, domain, complete=&
2233 & .true.)
2234  CALL start_group_halo_update(i_pack(1), pt, domain, complete=&
2235 & .true.)
2236  CALL timing_off('COMM_TOTAL')
2237  IF (flagstruct%d_ext .GT. 0.) THEN
2238  d2_divg = flagstruct%d_ext*gridstruct%da_min_c
2239 !$OMP parallel do default(none) shared(is,iep1,js,jep1,npz,wk,ptc,divg2,vt,d2_divg)
2240  DO j=js,jep1
2241  DO i=is,iep1
2242  wk(i, j) = ptc(i, j, 1)
2243  divg2(i, j) = wk(i, j)*vt(i, j, 1)
2244  END DO
2245  DO k=2,npz
2246  DO i=is,iep1
2247  wk(i, j) = wk(i, j) + ptc(i, j, k)
2248  divg2(i, j) = divg2(i, j) + ptc(i, j, k)*vt(i, j, k)
2249  END DO
2250  END DO
2251  DO i=is,iep1
2252  divg2(i, j) = d2_divg*divg2(i, j)/wk(i, j)
2253  END DO
2254  END DO
2255  ELSE
2256  divg2(:, :) = 0.
2257  END IF
2258  CALL timing_on('COMM_TOTAL')
2259  CALL complete_group_halo_update(i_pack(1), domain)
2260  CALL timing_off('COMM_TOTAL')
2261  IF (flagstruct%fv_debug) THEN
2262  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz', delz, is, &
2263 & ie, js, je, ng, npz, 1.&
2264 & , gridstruct%area_64, &
2265 & domain)
2266  END IF
2267 !Want to move this block into the hydro/nonhydro branch above and merge the two if structures
2268  IF (gridstruct%nested) THEN
2269  CALL nested_grid_bc_apply_intt(delp, 0, 0, npx, npy, npz, bd, &
2270 & split_timestep_bc + 1, REAL(n_split*& & flagstruct%k_split), neststruct%delp_bc&
2271 & , neststruct%nestbctype)
2272  call nested_grid_bc_apply_intt(pt, 0, 0, npx, npy, npz, bd, &
2273 & split_timestep_bc + 1, REAL(n_split*&
2274 & flagstruct%k_split), neststruct%pt_bc, &
2275 & neststruct%nestbctype)
2276  end if
2277 ! end hydro check
2278  IF (hydrostatic) THEN
2279  CALL geopk(ptop, pe, peln, delp, pkc, gz, phis, pt, q_con, pkz, &
2280 & npz, akap, .false., gridstruct%nested, .true., npx, npy, &
2281 & flagstruct%a2b_ord, bd)
2282  ELSE
2283  CALL timing_on('UPDATE_DZ')
2284  CALL update_dz_d(nord_v, damp_vt, flagstruct%hord_tm, is, ie, js&
2285 & , je, npz, ng, npx, npy, gridstruct%area, gridstruct%&
2286 & rarea, dp_ref, zs, zh, crx, cry, xfx, yfx, delz, ws, &
2287 & rdt, gridstruct, bd, flagstructp%hord_tm_pert)
2288  CALL timing_off('UPDATE_DZ')
2289  IF (flagstruct%fv_debug) THEN
2290  IF (.NOT.flagstruct%hydrostatic) CALL prt_mxm('delz updated', &
2291 & delz, is, ie, js, je, &
2292 & ng, npz, 1., &
2293 & gridstruct%area_64, &
2294 & domain)
2295  END IF
2296  IF (idiag%id_ws .GT. 0 .AND. last_step) used = send_data(idiag%&
2297 & id_ws, ws, fv_time)
2298 ! call prt_maxmin('WS', ws, is, ie, js, je, 0, 1, 1., master)
2299  CALL timing_on('Riem_Solver')
2300  CALL riem_solver3(flagstruct%m_split, dt, is, ie, js, je, npz, &
2301 & ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, &
2302 & q_con, w, delz, pt, delp, zh, pe, pkc, pk3, pk, peln&
2303 & , ws, flagstruct%scale_z, flagstruct%p_fac, &
2304 & flagstruct%a_imp, flagstruct%use_logp, remap_step, &
2305 & beta .LT. -0.1)
2306  CALL timing_off('Riem_Solver')
2307  CALL timing_on('COMM_TOTAL')
2308  IF (gridstruct%square_domain) THEN
2309  CALL start_group_halo_update(i_pack(4), zh, domain)
2310  CALL start_group_halo_update(i_pack(5), pkc, domain, whalo=2, &
2311 & ehalo=2, shalo=2, nhalo=2)
2312  ELSE
2313  CALL start_group_halo_update(i_pack(4), zh, domain, complete=&
2314 & .true.)
2315  CALL start_group_halo_update(i_pack(4), pkc, domain, complete=&
2316 & .true.)
2317  END IF
2318  CALL timing_off('COMM_TOTAL')
2319  IF (remap_step) CALL pe_halo(is, ie, js, je, isd, ied, jsd, jed&
2320 & , npz, ptop, pe, delp)
2321  IF (flagstruct%use_logp) THEN
2322  CALL pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
2323 & pk3, delp)
2324  ELSE
2325  CALL pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
2326 & akap, pk3, delp)
2327  END IF
2328  IF (gridstruct%nested) THEN
2329  CALL nested_grid_bc_apply_intt(delz, 0, 0, npx, npy, npz, bd, &
2330 & split_timestep_bc + 1., REAL(n_split*& & flagstruct%k_split), neststruct%&
2331 & delz_bc, neststruct%nestbctype)
2332 !Compute gz/pkc/pk3; note that now pkc should be nonhydro pert'n pressure
2333  CALL nest_halo_nh(ptop, grav, akap, cp, delp, delz, pt, phis, &
2334 & pkc, gz, pk3, npx, npy, npz, gridstruct%nested, &
2335 & .true., .true., .true., bd)
2336  END IF
2337  CALL timing_on('COMM_TOTAL')
2338  CALL complete_group_halo_update(i_pack(4), domain)
2339  CALL timing_off('COMM_TOTAL')
2340 !$OMP parallel do default(none) shared(is,ie,js,je,npz,gz,zh,grav)
2341  DO k=1,npz+1
2342  DO j=js-2,je+2
2343  DO i=is-2,ie+2
2344  gz(i, j, k) = zh(i, j, k)*grav
2345  END DO
2346  END DO
2347  END DO
2348  IF (gridstruct%square_domain) THEN
2349  CALL timing_on('COMM_TOTAL')
2350  CALL complete_group_halo_update(i_pack(5), domain)
2351  CALL timing_off('COMM_TOTAL')
2352  END IF
2353  END IF
2354  IF (remap_step .AND. hydrostatic) THEN
2355 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,pkc)
2356  DO k=1,npz+1
2357  DO j=js,je
2358  DO i=is,ie
2359  pk(i, j, k) = pkc(i, j, k)
2360  END DO
2361  END DO
2362  END DO
2363  END IF
2364 !----------------------------
2365 ! Compute pressure gradient:
2366 !----------------------------
2367  CALL timing_on('PG_D')
2368  IF (hydrostatic) THEN
2369  IF (beta .GT. 0.) THEN
2370  CALL grad1_p_update(divg2, u, v, pkc, gz, du, dv, dt, ng, &
2371 & gridstruct, bd, npx, npy, npz, ptop, beta_d, &
2372 & flagstruct%a2b_ord)
2373  ELSE
2374  CALL one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct&
2375 & , bd, npx, npy, npz, ptop, hydrostatic, flagstruct%&
2376 & a2b_ord, flagstruct%d_ext)
2377  END IF
2378  ELSE IF (beta .GT. 0.) THEN
2379  CALL split_p_grad(u, v, pkc, gz, du, dv, delp, pk3, beta_d, dt, &
2380 & ng, gridstruct, bd, npx, npy, npz, flagstruct%&
2381 & use_logp)
2382  ELSE IF (beta .LT. -0.1) THEN
2383  CALL one_grad_p(u, v, pkc, gz, divg2, delp, dt, ng, gridstruct, &
2384 & bd, npx, npy, npz, ptop, hydrostatic, flagstruct%&
2385 & a2b_ord, flagstruct%d_ext)
2386  ELSE
2387  CALL nh_p_grad(u, v, pkc, gz, delp, pk3, dt, ng, gridstruct, bd&
2388 & , npx, npy, npz, flagstruct%use_logp)
2389  END IF
2390  CALL timing_off('PG_D')
2391 ! Inline Rayleigh friction here?
2392 !-------------------------------------------------------------------------------------------------------
2393  IF (flagstruct%breed_vortex_inline) THEN
2394  IF (.NOT.hydrostatic) THEN
2395 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,cappa,rdg,delp,delz,pt,k1k)
2396  DO k=1,npz
2397  DO j=js,je
2398  DO i=is,ie
2399 ! Note: pt at this stage is Theta_m
2400  arg1 = rdg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
2401  arg2 = k1k*log(arg1)
2402  pkz(i, j, k) = exp(arg2)
2403  END DO
2404  END DO
2405  END DO
2406  END IF
2407  CALL breed_slp_inline(it, dt, npz, ak, bk, phis, pe, pk, peln, &
2408 & pkz, delp, u, v, pt, q, flagstruct%nwat, zvir, &
2409 & gridstruct, ks, domain, bd, hydrostatic)
2410  END IF
2411 !-------------------------------------------------------------------------------------------------------
2412  CALL timing_on('COMM_TOTAL')
2413  IF (it .EQ. n_split .AND. gridstruct%grid_type .LT. 4 .AND. (.NOT.&
2414 & gridstruct%nested)) THEN
2415 ! Prevent accumulation of rounding errors at overlapped domain edges:
2416  CALL mpp_get_boundary(u, v, domain, ebuffery=ebuffer, nbufferx=&
2417 & nbuffer, gridtype=dgrid_ne)
2418 !$OMP parallel do default(none) shared(is,ie,js,je,npz,u,nbuffer,v,ebuffer)
2419  DO k=1,npz
2420  DO i=is,ie
2421  u(i, je+1, k) = nbuffer(i-is+1, k)
2422  END DO
2423  DO j=js,je
2424  v(ie+1, j, k) = ebuffer(j-js+1, k)
2425  END DO
2426  END DO
2427  END IF
2428  IF (it .NE. n_split) CALL start_group_halo_update(i_pack(8), u, v&
2429 & , domain, gridtype=&
2430 & dgrid_ne)
2431  CALL timing_off('COMM_TOTAL')
2432  IF (gridstruct%nested) neststruct%nest_timestep = neststruct%&
2433 & nest_timestep + 1
2434  IF (hydrostatic .AND. last_step) THEN
2435  IF (flagstruct%use_old_omega) THEN
2436 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga,pe,pem,rdt)
2437  DO k=1,npz
2438  DO j=js,je
2439  DO i=is,ie
2440  omga(i, j, k) = (pe(i, k+1, j)-pem(i, k+1, j))*rdt
2441  END DO
2442  END DO
2443  END DO
2444 !------------------------------
2445 ! Compute the "advective term"
2446 !------------------------------
2447  CALL adv_pe(ua, va, pem, omga, gridstruct, bd, npx, npy, npz, &
2448 & ng)
2449  ELSE
2450 !$OMP parallel do default(none) shared(is,ie,js,je,npz,omga) private(om2d)
2451  DO j=js,je
2452  DO k=1,npz
2453  DO i=is,ie
2454  om2d(i, k) = omga(i, j, k)
2455  END DO
2456  END DO
2457  DO k=2,npz
2458  DO i=is,ie
2459  om2d(i, k) = om2d(i, k-1) + omga(i, j, k)
2460  END DO
2461  END DO
2462  DO k=2,npz
2463  DO i=is,ie
2464  omga(i, j, k) = om2d(i, k)
2465  END DO
2466  END DO
2467  END DO
2468  END IF
2469  IF (idiag%id_ws .GT. 0 .AND. hydrostatic) THEN
2470 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ws,delz,delp,omga)
2471  DO j=js,je
2472  DO i=is,ie
2473  ws(i, j) = delz(i, j, npz)/delp(i, j, npz)*omga(i, j, npz)
2474  END DO
2475  END DO
2476  used = send_data(idiag%id_ws, ws, fv_time)
2477  END IF
2478  END IF
2479  IF (gridstruct%nested) THEN
2480  IF (.NOT.hydrostatic) CALL nested_grid_bc_apply_intt(w, 0, 0, &
2481 & npx, npy, npz, bd&
2482 & , &
2483 & split_timestep_bc&
2484 & + 1, REAL(n_split& & *flagstruct%& & k_split), &
2485 & neststruct%w_bc, &
2486 & neststruct%&
2487 & nestbctype)
2488  call nested_grid_bc_apply_intt(u, 0, 1, npx, npy, npz, bd, &
2489 & split_timestep_bc + 1, REAL(n_split*&
2490 & flagstruct%k_split), neststruct%u_bc, &
2491 & neststruct%nestbctype)
2492  call nested_grid_bc_apply_intt(v, 1, 0, npx, npy, npz, bd, &
2493 & split_timestep_bc + 1, REAL(n_split*&
2494 & flagstruct%k_split), neststruct%v_bc, &
2495 & neststruct%nestbctype)
2496  end if
2497  END DO
2498 !-----------------------------------------------------
2499 ! time split loop
2500 !-----------------------------------------------------
2501  IF (nq .GT. 0 .AND. (.NOT.flagstruct%inline_q)) THEN
2502  CALL timing_on('COMM_TOTAL')
2503  CALL timing_on('COMM_TRACER')
2504  CALL start_group_halo_update(i_pack(10), q, domain)
2505  CALL timing_off('COMM_TRACER')
2506  CALL timing_off('COMM_TOTAL')
2507  END IF
2508  IF (flagstruct%fv_debug) THEN
2509  IF (is_master()) WRITE(*, *) 'End of n_split loop'
2510  END IF
2511  IF (n_con .NE. 0 .AND. flagstruct%d_con .GT. 1.e-5) THEN
2512  IF (3 .GT. flagstruct%nord + 1) THEN
2513  nf_ke = flagstruct%nord + 1
2514  ELSE
2515  nf_ke = 3
2516  END IF
2517  CALL del2_cubed(heat_source, cnst_0p20*gridstruct%da_min, &
2518 & gridstruct, domain, npx, npy, npz, nf_ke, bd)
2519 ! Note: pt here is cp*(Virtual_Temperature/pkz)
2520  IF (hydrostatic) THEN
2521 !
2522 ! del(Cp*T) = - del(KE)
2523 !
2524 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pt,heat_source,delp,pkz,bdt) &
2525 !$OMP private(dtmp)
2526  DO j=js,je
2527 ! n_con is usually less than 3;
2528  DO k=1,n_con
2529  IF (k .LT. 3) THEN
2530  DO i=is,ie
2531  pt(i, j, k) = pt(i, j, k) + heat_source(i, j, k)/(cp_air&
2532 & *delp(i, j, k)*pkz(i, j, k))
2533  END DO
2534  ELSE
2535  DO i=is,ie
2536  dtmp = heat_source(i, j, k)/(cp_air*delp(i, j, k))
2537  IF (bdt .GE. 0.) THEN
2538  abs0 = bdt
2539  ELSE
2540  abs0 = -bdt
2541  END IF
2542  x1 = abs0*flagstruct%delt_max
2543  IF (dtmp .GE. 0.) THEN
2544  y1 = dtmp
2545  ELSE
2546  y1 = -dtmp
2547  END IF
2548  IF (x1 .GT. y1) THEN
2549  min1 = y1
2550  ELSE
2551  min1 = x1
2552  END IF
2553  pt(i, j, k) = pt(i, j, k) + sign(min1, dtmp)/pkz(i, j, k&
2554 & )
2555  END DO
2556  END IF
2557  END DO
2558  END DO
2559  ELSE
2560 !$OMP parallel do default(none) shared(flagstruct,is,ie,js,je,n_con,pkz,cappa,rdg,delp,delz,pt, &
2561 !$OMP heat_source,k1k,cv_air,bdt) &
2562 !$OMP private(dtmp, delt)
2563  DO k=1,n_con
2564  IF (bdt*flagstruct%delt_max .GE. 0.) THEN
2565  delt = bdt*flagstruct%delt_max
2566  ELSE
2567  delt = -(bdt*flagstruct%delt_max)
2568  END IF
2569 ! Sponge layers:
2570 ! if ( k == 1 ) delt = 2.0*delt
2571 ! if ( k == 2 ) delt = 1.5*delt
2572  DO j=js,je
2573  DO i=is,ie
2574  arg1 = rdg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
2575  arg2 = k1k*log(arg1)
2576  pkz(i, j, k) = exp(arg2)
2577  dtmp = heat_source(i, j, k)/(cv_air*delp(i, j, k))
2578  IF (dtmp .GE. 0.) THEN
2579  y2 = dtmp
2580  ELSE
2581  y2 = -dtmp
2582  END IF
2583  IF (delt .GT. y2) THEN
2584  min2 = y2
2585  ELSE
2586  min2 = delt
2587  END IF
2588  pt(i, j, k) = pt(i, j, k) + sign(min2, dtmp)/pkz(i, j, k)
2589  END DO
2590  END DO
2591  END DO
2592  END IF
2593  END IF
2594  END SUBROUTINE dyn_core
2595 ! Differentiation of pk3_halo in forward (tangent) mode:
2596 ! variations of useful results: pk3
2597 ! with respect to varying inputs: pk3 delp
2598  SUBROUTINE pk3_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
2599 & , akap, pk3, pk3_tl, delp, delp_tl)
2600  IMPLICIT NONE
2601  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2602  REAL, INTENT(IN) :: ptop, akap
2603  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2604  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp_tl
2605  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
2606  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3_tl
2607 ! Local:
2608  REAL :: pei(isd:ied)
2609  REAL :: pei_tl(isd:ied)
2610  REAL :: pej(jsd:jed)
2611  REAL :: pej_tl(jsd:jed)
2612  INTEGER :: i, j, k
2613  INTRINSIC log
2614  INTRINSIC exp
2615  REAL :: arg1
2616  REAL :: arg1_tl
2617  pei_tl = 0.0
2618 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3,akap) &
2619 !$OMP private(pei)
2620  DO j=js,je
2621  pei_tl(is-2) = 0.0
2622  pei(is-2) = ptop
2623  pei_tl(is-1) = 0.0
2624  pei(is-1) = ptop
2625  DO k=1,npz
2626  pei_tl(is-2) = pei_tl(is-2) + delp_tl(is-2, j, k)
2627  pei(is-2) = pei(is-2) + delp(is-2, j, k)
2628  pei_tl(is-1) = pei_tl(is-1) + delp_tl(is-1, j, k)
2629  pei(is-1) = pei(is-1) + delp(is-1, j, k)
2630  arg1_tl = akap*pei_tl(is-2)/pei(is-2)
2631  arg1 = akap*log(pei(is-2))
2632  pk3_tl(is-2, j, k+1) = arg1_tl*exp(arg1)
2633  pk3(is-2, j, k+1) = exp(arg1)
2634  arg1_tl = akap*pei_tl(is-1)/pei(is-1)
2635  arg1 = akap*log(pei(is-1))
2636  pk3_tl(is-1, j, k+1) = arg1_tl*exp(arg1)
2637  pk3(is-1, j, k+1) = exp(arg1)
2638  END DO
2639  pei_tl(ie+1) = 0.0
2640  pei(ie+1) = ptop
2641  pei_tl(ie+2) = 0.0
2642  pei(ie+2) = ptop
2643  DO k=1,npz
2644  pei_tl(ie+1) = pei_tl(ie+1) + delp_tl(ie+1, j, k)
2645  pei(ie+1) = pei(ie+1) + delp(ie+1, j, k)
2646  pei_tl(ie+2) = pei_tl(ie+2) + delp_tl(ie+2, j, k)
2647  pei(ie+2) = pei(ie+2) + delp(ie+2, j, k)
2648  arg1_tl = akap*pei_tl(ie+1)/pei(ie+1)
2649  arg1 = akap*log(pei(ie+1))
2650  pk3_tl(ie+1, j, k+1) = arg1_tl*exp(arg1)
2651  pk3(ie+1, j, k+1) = exp(arg1)
2652  arg1_tl = akap*pei_tl(ie+2)/pei(ie+2)
2653  arg1 = akap*log(pei(ie+2))
2654  pk3_tl(ie+2, j, k+1) = arg1_tl*exp(arg1)
2655  pk3(ie+2, j, k+1) = exp(arg1)
2656  END DO
2657  END DO
2658  pej_tl = 0.0
2659 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3,akap) &
2660 !$OMP private(pej)
2661  DO i=is-2,ie+2
2662  pej_tl(js-2) = 0.0
2663  pej(js-2) = ptop
2664  pej_tl(js-1) = 0.0
2665  pej(js-1) = ptop
2666  DO k=1,npz
2667  pej_tl(js-2) = pej_tl(js-2) + delp_tl(i, js-2, k)
2668  pej(js-2) = pej(js-2) + delp(i, js-2, k)
2669  pej_tl(js-1) = pej_tl(js-1) + delp_tl(i, js-1, k)
2670  pej(js-1) = pej(js-1) + delp(i, js-1, k)
2671  arg1_tl = akap*pej_tl(js-2)/pej(js-2)
2672  arg1 = akap*log(pej(js-2))
2673  pk3_tl(i, js-2, k+1) = arg1_tl*exp(arg1)
2674  pk3(i, js-2, k+1) = exp(arg1)
2675  arg1_tl = akap*pej_tl(js-1)/pej(js-1)
2676  arg1 = akap*log(pej(js-1))
2677  pk3_tl(i, js-1, k+1) = arg1_tl*exp(arg1)
2678  pk3(i, js-1, k+1) = exp(arg1)
2679  END DO
2680  pej_tl(je+1) = 0.0
2681  pej(je+1) = ptop
2682  pej_tl(je+2) = 0.0
2683  pej(je+2) = ptop
2684  DO k=1,npz
2685  pej_tl(je+1) = pej_tl(je+1) + delp_tl(i, je+1, k)
2686  pej(je+1) = pej(je+1) + delp(i, je+1, k)
2687  pej_tl(je+2) = pej_tl(je+2) + delp_tl(i, je+2, k)
2688  pej(je+2) = pej(je+2) + delp(i, je+2, k)
2689  arg1_tl = akap*pej_tl(je+1)/pej(je+1)
2690  arg1 = akap*log(pej(je+1))
2691  pk3_tl(i, je+1, k+1) = arg1_tl*exp(arg1)
2692  pk3(i, je+1, k+1) = exp(arg1)
2693  arg1_tl = akap*pej_tl(je+2)/pej(je+2)
2694  arg1 = akap*log(pej(je+2))
2695  pk3_tl(i, je+2, k+1) = arg1_tl*exp(arg1)
2696  pk3(i, je+2, k+1) = exp(arg1)
2697  END DO
2698  END DO
2699  END SUBROUTINE pk3_halo_tlm
2700  SUBROUTINE pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
2701 & akap, pk3, delp)
2702  IMPLICIT NONE
2703  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2704  REAL, INTENT(IN) :: ptop, akap
2705  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2706  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
2707 ! Local:
2708  REAL :: pei(isd:ied)
2709  REAL :: pej(jsd:jed)
2710  INTEGER :: i, j, k
2711  INTRINSIC log
2712  INTRINSIC exp
2713  REAL :: arg1
2714 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3,akap) &
2715 !$OMP private(pei)
2716  DO j=js,je
2717  pei(is-2) = ptop
2718  pei(is-1) = ptop
2719  DO k=1,npz
2720  pei(is-2) = pei(is-2) + delp(is-2, j, k)
2721  pei(is-1) = pei(is-1) + delp(is-1, j, k)
2722  arg1 = akap*log(pei(is-2))
2723  pk3(is-2, j, k+1) = exp(arg1)
2724  arg1 = akap*log(pei(is-1))
2725  pk3(is-1, j, k+1) = exp(arg1)
2726  END DO
2727  pei(ie+1) = ptop
2728  pei(ie+2) = ptop
2729  DO k=1,npz
2730  pei(ie+1) = pei(ie+1) + delp(ie+1, j, k)
2731  pei(ie+2) = pei(ie+2) + delp(ie+2, j, k)
2732  arg1 = akap*log(pei(ie+1))
2733  pk3(ie+1, j, k+1) = exp(arg1)
2734  arg1 = akap*log(pei(ie+2))
2735  pk3(ie+2, j, k+1) = exp(arg1)
2736  END DO
2737  END DO
2738 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3,akap) &
2739 !$OMP private(pej)
2740  DO i=is-2,ie+2
2741  pej(js-2) = ptop
2742  pej(js-1) = ptop
2743  DO k=1,npz
2744  pej(js-2) = pej(js-2) + delp(i, js-2, k)
2745  pej(js-1) = pej(js-1) + delp(i, js-1, k)
2746  arg1 = akap*log(pej(js-2))
2747  pk3(i, js-2, k+1) = exp(arg1)
2748  arg1 = akap*log(pej(js-1))
2749  pk3(i, js-1, k+1) = exp(arg1)
2750  END DO
2751  pej(je+1) = ptop
2752  pej(je+2) = ptop
2753  DO k=1,npz
2754  pej(je+1) = pej(je+1) + delp(i, je+1, k)
2755  pej(je+2) = pej(je+2) + delp(i, je+2, k)
2756  arg1 = akap*log(pej(je+1))
2757  pk3(i, je+1, k+1) = exp(arg1)
2758  arg1 = akap*log(pej(je+2))
2759  pk3(i, je+2, k+1) = exp(arg1)
2760  END DO
2761  END DO
2762  END SUBROUTINE pk3_halo
2763 ! Differentiation of pln_halo in forward (tangent) mode:
2764 ! variations of useful results: pk3
2765 ! with respect to varying inputs: pk3 delp
2766  SUBROUTINE pln_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop&
2767 & , pk3, pk3_tl, delp, delp_tl)
2768  IMPLICIT NONE
2769  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2770  REAL, INTENT(IN) :: ptop
2771  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2772  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp_tl
2773  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
2774  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3_tl
2775 ! Local:
2776  REAL :: pet
2777  REAL :: pet_tl
2778  INTEGER :: i, j, k
2779  INTRINSIC log
2780 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3) &
2781 !$OMP private(pet)
2782  DO j=js,je
2783  DO i=is-2,is-1
2784  pet = ptop
2785  pet_tl = 0.0
2786  DO k=1,npz
2787  pet_tl = pet_tl + delp_tl(i, j, k)
2788  pet = pet + delp(i, j, k)
2789  pk3_tl(i, j, k+1) = pet_tl/pet
2790  pk3(i, j, k+1) = log(pet)
2791  END DO
2792  END DO
2793  DO i=ie+1,ie+2
2794  pet = ptop
2795  pet_tl = 0.0
2796  DO k=1,npz
2797  pet_tl = pet_tl + delp_tl(i, j, k)
2798  pet = pet + delp(i, j, k)
2799  pk3_tl(i, j, k+1) = pet_tl/pet
2800  pk3(i, j, k+1) = log(pet)
2801  END DO
2802  END DO
2803  END DO
2804 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3) &
2805 !$OMP private(pet)
2806  DO i=is-2,ie+2
2807  DO j=js-2,js-1
2808  pet = ptop
2809  pet_tl = 0.0
2810  DO k=1,npz
2811  pet_tl = pet_tl + delp_tl(i, j, k)
2812  pet = pet + delp(i, j, k)
2813  pk3_tl(i, j, k+1) = pet_tl/pet
2814  pk3(i, j, k+1) = log(pet)
2815  END DO
2816  END DO
2817  DO j=je+1,je+2
2818  pet = ptop
2819  pet_tl = 0.0
2820  DO k=1,npz
2821  pet_tl = pet_tl + delp_tl(i, j, k)
2822  pet = pet + delp(i, j, k)
2823  pk3_tl(i, j, k+1) = pet_tl/pet
2824  pk3(i, j, k+1) = log(pet)
2825  END DO
2826  END DO
2827  END DO
2828  END SUBROUTINE pln_halo_tlm
2829  SUBROUTINE pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3&
2830 & , delp)
2831  IMPLICIT NONE
2832  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2833  REAL, INTENT(IN) :: ptop
2834  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2835  REAL, DIMENSION(isd:ied, jsd:jed, npz+1), INTENT(INOUT) :: pk3
2836 ! Local:
2837  REAL :: pet
2838  INTEGER :: i, j, k
2839  INTRINSIC log
2840 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,npz,ptop,delp,pk3) &
2841 !$OMP private(pet)
2842  DO j=js,je
2843  DO i=is-2,is-1
2844  pet = ptop
2845  DO k=1,npz
2846  pet = pet + delp(i, j, k)
2847  pk3(i, j, k+1) = log(pet)
2848  END DO
2849  END DO
2850  DO i=ie+1,ie+2
2851  pet = ptop
2852  DO k=1,npz
2853  pet = pet + delp(i, j, k)
2854  pk3(i, j, k+1) = log(pet)
2855  END DO
2856  END DO
2857  END DO
2858 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ptop,delp,pk3) &
2859 !$OMP private(pet)
2860  DO i=is-2,ie+2
2861  DO j=js-2,js-1
2862  pet = ptop
2863  DO k=1,npz
2864  pet = pet + delp(i, j, k)
2865  pk3(i, j, k+1) = log(pet)
2866  END DO
2867  END DO
2868  DO j=je+1,je+2
2869  pet = ptop
2870  DO k=1,npz
2871  pet = pet + delp(i, j, k)
2872  pk3(i, j, k+1) = log(pet)
2873  END DO
2874  END DO
2875  END DO
2876  END SUBROUTINE pln_halo
2877 ! Differentiation of pe_halo in forward (tangent) mode:
2878 ! variations of useful results: pe
2879 ! with respect to varying inputs: delp pe
2880  SUBROUTINE pe_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, &
2881 & pe, pe_tl, delp, delp_tl)
2882  IMPLICIT NONE
2883  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2884  REAL, INTENT(IN) :: ptop
2885  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2886  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp_tl
2887  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe
2888  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe_tl
2889 ! Local:
2890  INTEGER :: i, j, k
2891 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
2892  DO j=js,je
2893  pe_tl(is-1, 1, j) = 0.0
2894  pe(is-1, 1, j) = ptop
2895  pe_tl(ie+1, 1, j) = 0.0
2896  pe(ie+1, 1, j) = ptop
2897  DO k=1,npz
2898  pe_tl(is-1, k+1, j) = pe_tl(is-1, k, j) + delp_tl(is-1, j, k)
2899  pe(is-1, k+1, j) = pe(is-1, k, j) + delp(is-1, j, k)
2900  pe_tl(ie+1, k+1, j) = pe_tl(ie+1, k, j) + delp_tl(ie+1, j, k)
2901  pe(ie+1, k+1, j) = pe(ie+1, k, j) + delp(ie+1, j, k)
2902  END DO
2903  END DO
2904 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
2905  DO i=is-1,ie+1
2906  pe_tl(i, 1, js-1) = 0.0
2907  pe(i, 1, js-1) = ptop
2908  pe_tl(i, 1, je+1) = 0.0
2909  pe(i, 1, je+1) = ptop
2910  DO k=1,npz
2911  pe_tl(i, k+1, js-1) = pe_tl(i, k, js-1) + delp_tl(i, js-1, k)
2912  pe(i, k+1, js-1) = pe(i, k, js-1) + delp(i, js-1, k)
2913  pe_tl(i, k+1, je+1) = pe_tl(i, k, je+1) + delp_tl(i, je+1, k)
2914  pe(i, k+1, je+1) = pe(i, k, je+1) + delp(i, je+1, k)
2915  END DO
2916  END DO
2917  END SUBROUTINE pe_halo_tlm
2918  SUBROUTINE pe_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, &
2919 & delp)
2920  IMPLICIT NONE
2921  INTEGER, INTENT(IN) :: is, ie, js, je, isd, ied, jsd, jed, npz
2922  REAL, INTENT(IN) :: ptop
2923  REAL, DIMENSION(isd:ied, jsd:jed, npz), INTENT(IN) :: delp
2924  REAL, DIMENSION(is-1:ie+1, npz+1, js-1:je+1), INTENT(INOUT) :: pe
2925 ! Local:
2926  INTEGER :: i, j, k
2927 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
2928  DO j=js,je
2929  pe(is-1, 1, j) = ptop
2930  pe(ie+1, 1, j) = ptop
2931  DO k=1,npz
2932  pe(is-1, k+1, j) = pe(is-1, k, j) + delp(is-1, j, k)
2933  pe(ie+1, k+1, j) = pe(ie+1, k, j) + delp(ie+1, j, k)
2934  END DO
2935  END DO
2936 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ptop)
2937  DO i=is-1,ie+1
2938  pe(i, 1, js-1) = ptop
2939  pe(i, 1, je+1) = ptop
2940  DO k=1,npz
2941  pe(i, k+1, js-1) = pe(i, k, js-1) + delp(i, js-1, k)
2942  pe(i, k+1, je+1) = pe(i, k, je+1) + delp(i, je+1, k)
2943  END DO
2944  END DO
2945  END SUBROUTINE pe_halo
2946 ! Differentiation of adv_pe in forward (tangent) mode:
2947 ! variations of useful results: om
2948 ! with respect to varying inputs: ua om va pem
2949  SUBROUTINE adv_pe_tlm(ua, ua_tl, va, va_tl, pem, pem_tl, om, om_tl, &
2950 & gridstruct, bd, npx, npy, npz, ng)
2951  IMPLICIT NONE
2952  INTEGER, INTENT(IN) :: npx, npy, npz, ng
2953  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
2954 ! Contra-variant wind components:
2955  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: ua&
2956 & , va
2957  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: &
2958 & ua_tl, va_tl
2959 ! Pressure at edges:
2960  REAL, INTENT(IN) :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
2961  REAL, INTENT(IN) :: pem_tl(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
2962  REAL, INTENT(INOUT) :: om(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2963  REAL, INTENT(INOUT) :: om_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
2964  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
2965 ! Local:
2966  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up, vp
2967  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up_tl, vp_tl
2968  REAL :: v3(3, bd%is:bd%ie, bd%js:bd%je)
2969  REAL :: v3_tl(3, bd%is:bd%ie, bd%js:bd%je)
2970  REAL :: pin(bd%isd:bd%ied, bd%jsd:bd%jed)
2971  REAL :: pin_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
2972  REAL :: pb(bd%isd:bd%ied, bd%jsd:bd%jed)
2973  REAL :: pb_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
2974  REAL :: grad(3, bd%is:bd%ie, bd%js:bd%je)
2975  REAL :: grad_tl(3, bd%is:bd%ie, bd%js:bd%je)
2976  REAL :: pdx(3, bd%is:bd%ie, bd%js:bd%je+1)
2977  REAL :: pdx_tl(3, bd%is:bd%ie, bd%js:bd%je+1)
2978  REAL :: pdy(3, bd%is:bd%ie+1, bd%js:bd%je)
2979  REAL :: pdy_tl(3, bd%is:bd%ie+1, bd%js:bd%je)
2980  INTEGER :: i, j, k, n
2981  INTEGER :: is, ie, js, je
2982  is = bd%is
2983  ie = bd%ie
2984  js = bd%js
2985  je = bd%je
2986  v3_tl = 0.0
2987  grad_tl = 0.0
2988  up_tl = 0.0
2989  pdx_tl = 0.0
2990  pdy_tl = 0.0
2991  pb_tl = 0.0
2992  vp_tl = 0.0
2993  pin_tl = 0.0
2994 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ua,va,gridstruct,pem,npx,npy,ng,om) &
2995 !$OMP private(n, pdx, pdy, pin, pb, up, vp, grad, v3)
2996  DO k=1,npz
2997  IF (k .EQ. npz) THEN
2998  DO j=js,je
2999  DO i=is,ie
3000  up_tl(i, j) = ua_tl(i, j, npz)
3001  up(i, j) = ua(i, j, npz)
3002  vp_tl(i, j) = va_tl(i, j, npz)
3003  vp(i, j) = va(i, j, npz)
3004  END DO
3005  END DO
3006  ELSE
3007  DO j=js,je
3008  DO i=is,ie
3009  up_tl(i, j) = 0.5*(ua_tl(i, j, k)+ua_tl(i, j, k+1))
3010  up(i, j) = 0.5*(ua(i, j, k)+ua(i, j, k+1))
3011  vp_tl(i, j) = 0.5*(va_tl(i, j, k)+va_tl(i, j, k+1))
3012  vp(i, j) = 0.5*(va(i, j, k)+va(i, j, k+1))
3013  END DO
3014  END DO
3015  END IF
3016 ! Compute Vect wind:
3017  DO j=js,je
3018  DO i=is,ie
3019  DO n=1,3
3020  v3_tl(n, i, j) = gridstruct%ec1(n, i, j)*up_tl(i, j) + &
3021 & gridstruct%ec2(n, i, j)*vp_tl(i, j)
3022  v3(n, i, j) = up(i, j)*gridstruct%ec1(n, i, j) + vp(i, j)*&
3023 & gridstruct%ec2(n, i, j)
3024  END DO
3025  END DO
3026  END DO
3027  DO j=js-1,je+1
3028  DO i=is-1,ie+1
3029  pin_tl(i, j) = pem_tl(i, k+1, j)
3030  pin(i, j) = pem(i, k+1, j)
3031  END DO
3032  END DO
3033 ! Compute pe at 4 cell corners:
3034  CALL a2b_ord2_tlm(pin, pin_tl, pb, pb_tl, gridstruct, npx, npy, is&
3035 & , ie, js, je, ng)
3036  DO j=js,je+1
3037  DO i=is,ie
3038  DO n=1,3
3039  pdx_tl(n, i, j) = gridstruct%dx(i, j)*gridstruct%en1(n, i, j&
3040 & )*(pb_tl(i, j)+pb_tl(i+1, j))
3041  pdx(n, i, j) = (pb(i, j)+pb(i+1, j))*gridstruct%dx(i, j)*&
3042 & gridstruct%en1(n, i, j)
3043  END DO
3044  END DO
3045  END DO
3046  DO j=js,je
3047  DO i=is,ie+1
3048  DO n=1,3
3049  pdy_tl(n, i, j) = gridstruct%dy(i, j)*gridstruct%en2(n, i, j&
3050 & )*(pb_tl(i, j)+pb_tl(i, j+1))
3051  pdy(n, i, j) = (pb(i, j)+pb(i, j+1))*gridstruct%dy(i, j)*&
3052 & gridstruct%en2(n, i, j)
3053  END DO
3054  END DO
3055  END DO
3056 ! Compute grad (pe) by Green's theorem
3057  DO j=js,je
3058  DO i=is,ie
3059  DO n=1,3
3060  grad_tl(n, i, j) = pdx_tl(n, i, j+1) - pdx_tl(n, i, j) - &
3061 & pdy_tl(n, i, j) + pdy_tl(n, i+1, j)
3062  grad(n, i, j) = pdx(n, i, j+1) - pdx(n, i, j) - pdy(n, i, j)&
3063 & + pdy(n, i+1, j)
3064  END DO
3065  END DO
3066  END DO
3067 ! Compute inner product: V3 * grad (pe)
3068  DO j=js,je
3069  DO i=is,ie
3070  om_tl(i, j, k) = om_tl(i, j, k) + 0.5*gridstruct%rarea(i, j)*(&
3071 & v3_tl(1, i, j)*grad(1, i, j)+v3(1, i, j)*grad_tl(1, i, j)+&
3072 & v3_tl(2, i, j)*grad(2, i, j)+v3(2, i, j)*grad_tl(2, i, j)+&
3073 & v3_tl(3, i, j)*grad(3, i, j)+v3(3, i, j)*grad_tl(3, i, j))
3074  om(i, j, k) = om(i, j, k) + 0.5*gridstruct%rarea(i, j)*(v3(1, &
3075 & i, j)*grad(1, i, j)+v3(2, i, j)*grad(2, i, j)+v3(3, i, j)*&
3076 & grad(3, i, j))
3077  END DO
3078  END DO
3079  END DO
3080  END SUBROUTINE adv_pe_tlm
3081  SUBROUTINE adv_pe(ua, va, pem, om, gridstruct, bd, npx, npy, npz, ng)
3082  IMPLICIT NONE
3083  INTEGER, INTENT(IN) :: npx, npy, npz, ng
3084  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3085 ! Contra-variant wind components:
3086  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz), INTENT(IN) :: ua&
3087 & , va
3088 ! Pressure at edges:
3089  REAL, INTENT(IN) :: pem(bd%is-1:bd%ie+1, npz+1, bd%js-1:bd%je+1)
3090  REAL, INTENT(INOUT) :: om(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3091  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3092 ! Local:
3093  REAL, DIMENSION(bd%is:bd%ie, bd%js:bd%je) :: up, vp
3094  REAL :: v3(3, bd%is:bd%ie, bd%js:bd%je)
3095  REAL :: pin(bd%isd:bd%ied, bd%jsd:bd%jed)
3096  REAL :: pb(bd%isd:bd%ied, bd%jsd:bd%jed)
3097  REAL :: grad(3, bd%is:bd%ie, bd%js:bd%je)
3098  REAL :: pdx(3, bd%is:bd%ie, bd%js:bd%je+1)
3099  REAL :: pdy(3, bd%is:bd%ie+1, bd%js:bd%je)
3100  INTEGER :: i, j, k, n
3101  INTEGER :: is, ie, js, je
3102  is = bd%is
3103  ie = bd%ie
3104  js = bd%js
3105  je = bd%je
3106 !$OMP parallel do default(none) shared(is,ie,js,je,npz,ua,va,gridstruct,pem,npx,npy,ng,om) &
3107 !$OMP private(n, pdx, pdy, pin, pb, up, vp, grad, v3)
3108  DO k=1,npz
3109  IF (k .EQ. npz) THEN
3110  DO j=js,je
3111  DO i=is,ie
3112  up(i, j) = ua(i, j, npz)
3113  vp(i, j) = va(i, j, npz)
3114  END DO
3115  END DO
3116  ELSE
3117  DO j=js,je
3118  DO i=is,ie
3119  up(i, j) = 0.5*(ua(i, j, k)+ua(i, j, k+1))
3120  vp(i, j) = 0.5*(va(i, j, k)+va(i, j, k+1))
3121  END DO
3122  END DO
3123  END IF
3124 ! Compute Vect wind:
3125  DO j=js,je
3126  DO i=is,ie
3127  DO n=1,3
3128  v3(n, i, j) = up(i, j)*gridstruct%ec1(n, i, j) + vp(i, j)*&
3129 & gridstruct%ec2(n, i, j)
3130  END DO
3131  END DO
3132  END DO
3133  DO j=js-1,je+1
3134  DO i=is-1,ie+1
3135  pin(i, j) = pem(i, k+1, j)
3136  END DO
3137  END DO
3138 ! Compute pe at 4 cell corners:
3139  CALL a2b_ord2(pin, pb, gridstruct, npx, npy, is, ie, js, je, ng)
3140  DO j=js,je+1
3141  DO i=is,ie
3142  DO n=1,3
3143  pdx(n, i, j) = (pb(i, j)+pb(i+1, j))*gridstruct%dx(i, j)*&
3144 & gridstruct%en1(n, i, j)
3145  END DO
3146  END DO
3147  END DO
3148  DO j=js,je
3149  DO i=is,ie+1
3150  DO n=1,3
3151  pdy(n, i, j) = (pb(i, j)+pb(i, j+1))*gridstruct%dy(i, j)*&
3152 & gridstruct%en2(n, i, j)
3153  END DO
3154  END DO
3155  END DO
3156 ! Compute grad (pe) by Green's theorem
3157  DO j=js,je
3158  DO i=is,ie
3159  DO n=1,3
3160  grad(n, i, j) = pdx(n, i, j+1) - pdx(n, i, j) - pdy(n, i, j)&
3161 & + pdy(n, i+1, j)
3162  END DO
3163  END DO
3164  END DO
3165 ! Compute inner product: V3 * grad (pe)
3166  DO j=js,je
3167  DO i=is,ie
3168  om(i, j, k) = om(i, j, k) + 0.5*gridstruct%rarea(i, j)*(v3(1, &
3169 & i, j)*grad(1, i, j)+v3(2, i, j)*grad(2, i, j)+v3(3, i, j)*&
3170 & grad(3, i, j))
3171  END DO
3172  END DO
3173  END DO
3174  END SUBROUTINE adv_pe
3175 ! Differentiation of p_grad_c in forward (tangent) mode:
3176 ! variations of useful results: uc vc
3177 ! with respect to varying inputs: gz uc pkc delpc vc
3178  SUBROUTINE p_grad_c_tlm(dt2, npz, delpc, delpc_tl, pkc, pkc_tl, gz, &
3179 & gz_tl, uc, uc_tl, vc, vc_tl, bd, rdxc, rdyc, hydrostatic)
3180  IMPLICIT NONE
3181  INTEGER, INTENT(IN) :: npz
3182  REAL, INTENT(IN) :: dt2
3183  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3184  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc
3185  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc_tl
3186 ! pkc is pe**cappa if hydrostatic
3187 ! pkc is full pressure if non-hydrostatic
3188  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
3189 & pkc, gz
3190  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
3191 & pkc_tl, gz_tl
3192  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3193  REAL, INTENT(INOUT) :: uc_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3194  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3195  REAL, INTENT(INOUT) :: vc_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3196  REAL, INTENT(IN) :: rdxc(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3197  REAL, INTENT(IN) :: rdyc(bd%isd:bd%ied, bd%jsd:bd%jed)
3198  LOGICAL, INTENT(IN) :: hydrostatic
3199 ! Local:
3200  REAL :: wk(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
3201  REAL :: wk_tl(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
3202  INTEGER :: i, j, k
3203  INTEGER :: is, ie, js, je
3204  is = bd%is
3205  ie = bd%ie
3206  js = bd%js
3207  je = bd%je
3208  wk_tl = 0.0
3209 !$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pkc,delpc,uc,dt2,rdxc,gz,vc,rdyc) &
3210 !$OMP private(wk)
3211  DO k=1,npz
3212  IF (hydrostatic) THEN
3213  DO j=js-1,je+1
3214  DO i=is-1,ie+1
3215  wk_tl(i, j) = pkc_tl(i, j, k+1) - pkc_tl(i, j, k)
3216  wk(i, j) = pkc(i, j, k+1) - pkc(i, j, k)
3217  END DO
3218  END DO
3219  ELSE
3220  DO j=js-1,je+1
3221  DO i=is-1,ie+1
3222  wk_tl(i, j) = delpc_tl(i, j, k)
3223  wk(i, j) = delpc(i, j, k)
3224  END DO
3225  END DO
3226  END IF
3227  DO j=js,je
3228  DO i=is,ie+1
3229  uc_tl(i, j, k) = uc_tl(i, j, k) + dt2*rdxc(i, j)*((gz_tl(i-1, &
3230 & j, k+1)-gz_tl(i, j, k))*(pkc(i, j, k+1)-pkc(i-1, j, k))+(gz(&
3231 & i-1, j, k+1)-gz(i, j, k))*(pkc_tl(i, j, k+1)-pkc_tl(i-1, j, &
3232 & k))+(gz_tl(i-1, j, k)-gz_tl(i, j, k+1))*(pkc(i-1, j, k+1)-&
3233 & pkc(i, j, k))+(gz(i-1, j, k)-gz(i, j, k+1))*(pkc_tl(i-1, j, &
3234 & k+1)-pkc_tl(i, j, k)))/(wk(i-1, j)+wk(i, j)) - dt2*rdxc(i, j&
3235 & )*(wk_tl(i-1, j)+wk_tl(i, j))*((gz(i-1, j, k+1)-gz(i, j, k))&
3236 & *(pkc(i, j, k+1)-pkc(i-1, j, k))+(gz(i-1, j, k)-gz(i, j, k+1&
3237 & ))*(pkc(i-1, j, k+1)-pkc(i, j, k)))/(wk(i-1, j)+wk(i, j))**2
3238  uc(i, j, k) = uc(i, j, k) + dt2*rdxc(i, j)/(wk(i-1, j)+wk(i, j&
3239 & ))*((gz(i-1, j, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i-1, j&
3240 & , k))+(gz(i-1, j, k)-gz(i, j, k+1))*(pkc(i-1, j, k+1)-pkc(i&
3241 & , j, k)))
3242  END DO
3243  END DO
3244  DO j=js,je+1
3245  DO i=is,ie
3246  vc_tl(i, j, k) = vc_tl(i, j, k) + dt2*rdyc(i, j)*((gz_tl(i, j-&
3247 & 1, k+1)-gz_tl(i, j, k))*(pkc(i, j, k+1)-pkc(i, j-1, k))+(gz(&
3248 & i, j-1, k+1)-gz(i, j, k))*(pkc_tl(i, j, k+1)-pkc_tl(i, j-1, &
3249 & k))+(gz_tl(i, j-1, k)-gz_tl(i, j, k+1))*(pkc(i, j-1, k+1)-&
3250 & pkc(i, j, k))+(gz(i, j-1, k)-gz(i, j, k+1))*(pkc_tl(i, j-1, &
3251 & k+1)-pkc_tl(i, j, k)))/(wk(i, j-1)+wk(i, j)) - dt2*rdyc(i, j&
3252 & )*(wk_tl(i, j-1)+wk_tl(i, j))*((gz(i, j-1, k+1)-gz(i, j, k))&
3253 & *(pkc(i, j, k+1)-pkc(i, j-1, k))+(gz(i, j-1, k)-gz(i, j, k+1&
3254 & ))*(pkc(i, j-1, k+1)-pkc(i, j, k)))/(wk(i, j-1)+wk(i, j))**2
3255  vc(i, j, k) = vc(i, j, k) + dt2*rdyc(i, j)/(wk(i, j-1)+wk(i, j&
3256 & ))*((gz(i, j-1, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i, j-1&
3257 & , k))+(gz(i, j-1, k)-gz(i, j, k+1))*(pkc(i, j-1, k+1)-pkc(i&
3258 & , j, k)))
3259  END DO
3260  END DO
3261  END DO
3262  END SUBROUTINE p_grad_c_tlm
3263  SUBROUTINE p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, rdyc, &
3264 & hydrostatic)
3265  IMPLICIT NONE
3266  INTEGER, INTENT(IN) :: npz
3267  REAL, INTENT(IN) :: dt2
3268  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3269  REAL, DIMENSION(bd%isd:, bd%jsd:, :), INTENT(IN) :: delpc
3270 ! pkc is pe**cappa if hydrostatic
3271 ! pkc is full pressure if non-hydrostatic
3272  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1), INTENT(IN) :: &
3273 & pkc, gz
3274  REAL, INTENT(INOUT) :: uc(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3275  REAL, INTENT(INOUT) :: vc(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3276  REAL, INTENT(IN) :: rdxc(bd%isd:bd%ied+1, bd%jsd:bd%jed+1)
3277  REAL, INTENT(IN) :: rdyc(bd%isd:bd%ied, bd%jsd:bd%jed)
3278  LOGICAL, INTENT(IN) :: hydrostatic
3279 ! Local:
3280  REAL :: wk(bd%is-1:bd%ie+1, bd%js-1:bd%je+1)
3281  INTEGER :: i, j, k
3282  INTEGER :: is, ie, js, je
3283  is = bd%is
3284  ie = bd%ie
3285  js = bd%js
3286  je = bd%je
3287 !$OMP parallel do default(none) shared(is,ie,js,je,npz,hydrostatic,pkc,delpc,uc,dt2,rdxc,gz,vc,rdyc) &
3288 !$OMP private(wk)
3289  DO k=1,npz
3290  IF (hydrostatic) THEN
3291  DO j=js-1,je+1
3292  DO i=is-1,ie+1
3293  wk(i, j) = pkc(i, j, k+1) - pkc(i, j, k)
3294  END DO
3295  END DO
3296  ELSE
3297  DO j=js-1,je+1
3298  DO i=is-1,ie+1
3299  wk(i, j) = delpc(i, j, k)
3300  END DO
3301  END DO
3302  END IF
3303  DO j=js,je
3304  DO i=is,ie+1
3305  uc(i, j, k) = uc(i, j, k) + dt2*rdxc(i, j)/(wk(i-1, j)+wk(i, j&
3306 & ))*((gz(i-1, j, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i-1, j&
3307 & , k))+(gz(i-1, j, k)-gz(i, j, k+1))*(pkc(i-1, j, k+1)-pkc(i&
3308 & , j, k)))
3309  END DO
3310  END DO
3311  DO j=js,je+1
3312  DO i=is,ie
3313  vc(i, j, k) = vc(i, j, k) + dt2*rdyc(i, j)/(wk(i, j-1)+wk(i, j&
3314 & ))*((gz(i, j-1, k+1)-gz(i, j, k))*(pkc(i, j, k+1)-pkc(i, j-1&
3315 & , k))+(gz(i, j-1, k)-gz(i, j, k+1))*(pkc(i, j-1, k+1)-pkc(i&
3316 & , j, k)))
3317  END DO
3318  END DO
3319  END DO
3320  END SUBROUTINE p_grad_c
3321 ! Differentiation of nh_p_grad in forward (tangent) mode:
3322 ! variations of useful results: gz u v delp pk pp
3323 ! with respect to varying inputs: gz u v delp pk pp
3324  SUBROUTINE nh_p_grad_tlm(u, u_tl, v, v_tl, pp, pp_tl, gz, gz_tl, delp&
3325 & , delp_tl, pk, pk_tl, dt, ng, gridstruct, bd, npx, npy, npz, &
3326 & use_logp)
3327  IMPLICIT NONE
3328 ! end k-loop
3329  INTEGER, INTENT(IN) :: ng, npx, npy, npz
3330  REAL, INTENT(IN) :: dt
3331  LOGICAL, INTENT(IN) :: use_logp
3332  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3333  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3334  REAL, INTENT(INOUT) :: delp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3335 ! perturbation pressure
3336  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3337  REAL, INTENT(INOUT) :: pp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3338 ! p**kappa
3339  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3340  REAL, INTENT(INOUT) :: pk_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3341 ! g * h
3342  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3343  REAL, INTENT(INOUT) :: gz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3344  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3345  REAL, INTENT(INOUT) :: u_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3346  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3347  REAL, INTENT(INOUT) :: v_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3348  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3349 ! Local:
3350  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
3351  REAL :: wk1_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
3352  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
3353  REAL :: wk_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
3354  REAL :: du1, dv1, top_value
3355  REAL :: du1_tl, dv1_tl
3356  INTEGER :: i, j, k
3357  INTEGER :: is, ie, js, je
3358  INTEGER :: isd, ied, jsd, jed
3359  is = bd%is
3360  ie = bd%ie
3361  js = bd%js
3362  je = bd%je
3363  isd = bd%isd
3364  ied = bd%ied
3365  jsd = bd%jsd
3366  jed = bd%jed
3367  IF (use_logp) THEN
3368  top_value = peln1
3369  ELSE
3370  top_value = ptk
3371  END IF
3372 !Remember that not all compilers set pp to zero by default
3373 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
3374  DO j=js,je+1
3375  DO i=is,ie+1
3376  pp_tl(i, j, 1) = 0.0
3377  pp(i, j, 1) = 0.
3378  pk_tl(i, j, 1) = 0.0
3379  pk(i, j, 1) = top_value
3380  END DO
3381  END DO
3382  wk1_tl = 0.0
3383 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
3384 !$OMP private(wk1)
3385  DO k=1,npz+1
3386  IF (k .NE. 1) THEN
3387  CALL a2b_ord4_tlm(pp(isd:ied, jsd:jed, k), pp_tl(isd:ied, jsd&
3388 & :jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, &
3389 & ie, js, je, ng, .true.)
3390  CALL a2b_ord4_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd&
3391 & :jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, &
3392 & ie, js, je, ng, .true.)
3393  END IF
3394  CALL a2b_ord4_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd:&
3395 & jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, ie&
3396 & , js, je, ng, .true.)
3397  END DO
3398  wk_tl = 0.0
3399 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,gridstruct,npx,npy,ng,isd,jsd, &
3400 !$OMP pk,dt,gz,u,pp,v) &
3401 !$OMP private(wk1, wk, du1, dv1)
3402  DO k=1,npz
3403  CALL a2b_ord4_tlm(delp(isd:ied, jsd:jed, k), delp_tl(isd:ied, &
3404 & jsd:jed, k), wk1, wk1_tl, gridstruct, npx, npy, is&
3405 & , ie, js, je, ng)
3406  DO j=js,je+1
3407  DO i=is,ie+1
3408  wk_tl(i, j) = pk_tl(i, j, k+1) - pk_tl(i, j, k)
3409  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
3410  END DO
3411  END DO
3412  DO j=js,je+1
3413  DO i=is,ie
3414 ! hydrostatic contributions from past time-step already added in the "beta" part
3415 ! Current gradient from "hydrostatic" components:
3416  du1_tl = dt*((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pk(i+1, j, k&
3417 & +1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(pk_tl(i+1, j&
3418 & , k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1, j, k+1))*(&
3419 & pk(i, j, k+1)-pk(i+1, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(&
3420 & pk_tl(i, j, k+1)-pk_tl(i+1, j, k)))/(wk(i, j)+wk(i+1, j)) - &
3421 & dt*(wk_tl(i, j)+wk_tl(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k)&
3422 & )*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1)&
3423 & )*(pk(i, j, k+1)-pk(i+1, j, k)))/(wk(i, j)+wk(i+1, j))**2
3424  du1 = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
3425 & (pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
3426 & (pk(i, j, k+1)-pk(i+1, j, k)))
3427 ! Non-hydrostatic contribution
3428  u_tl(i, j, k) = gridstruct%rdx(i, j)*(u_tl(i, j, k)+du1_tl+dt*&
3429 & ((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, &
3430 & j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(pp_tl(i+1, j, k+1)-&
3431 & pp_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1, j, k+1))*(pp(i, j&
3432 & , k+1)-pp(i+1, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pp_tl(i&
3433 & , j, k+1)-pp_tl(i+1, j, k)))/(wk1(i, j)+wk1(i+1, j))-dt*(&
3434 & wk1_tl(i, j)+wk1_tl(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
3435 & (pp(i+1, j, k+1)-pp(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
3436 & (pp(i, j, k+1)-pp(i+1, j, k)))/(wk1(i, j)+wk1(i+1, j))**2)
3437  u(i, j, k) = (u(i, j, k)+du1+dt/(wk1(i, j)+wk1(i+1, j))*((gz(i&
3438 & , j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, j, k))+(gz(i&
3439 & , j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k))))*&
3440 & gridstruct%rdx(i, j)
3441  END DO
3442  END DO
3443  DO j=js,je
3444  DO i=is,ie+1
3445 ! Current gradient from "hydrostatic" components:
3446  dv1_tl = dt*((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pk(i, j+1, k&
3447 & +1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(pk_tl(i, j+1&
3448 & , k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, j+1, k+1))*(&
3449 & pk(i, j, k+1)-pk(i, j+1, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(&
3450 & pk_tl(i, j, k+1)-pk_tl(i, j+1, k)))/(wk(i, j)+wk(i, j+1)) - &
3451 & dt*(wk_tl(i, j)+wk_tl(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k)&
3452 & )*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1)&
3453 & )*(pk(i, j, k+1)-pk(i, j+1, k)))/(wk(i, j)+wk(i, j+1))**2
3454  dv1 = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
3455 & (pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
3456 & (pk(i, j, k+1)-pk(i, j+1, k)))
3457 ! Non-hydrostatic contribution
3458  v_tl(i, j, k) = gridstruct%rdy(i, j)*(v_tl(i, j, k)+dv1_tl+dt*&
3459 & ((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, &
3460 & j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(pp_tl(i, j+1, k+1)-&
3461 & pp_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, j+1, k+1))*(pp(i, j&
3462 & , k+1)-pp(i, j+1, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pp_tl(i&
3463 & , j, k+1)-pp_tl(i, j+1, k)))/(wk1(i, j)+wk1(i, j+1))-dt*(&
3464 & wk1_tl(i, j)+wk1_tl(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
3465 & (pp(i, j+1, k+1)-pp(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
3466 & (pp(i, j, k+1)-pp(i, j+1, k)))/(wk1(i, j)+wk1(i, j+1))**2)
3467  v(i, j, k) = (v(i, j, k)+dv1+dt/(wk1(i, j)+wk1(i, j+1))*((gz(i&
3468 & , j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, j, k))+(gz(i&
3469 & , j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k))))*&
3470 & gridstruct%rdy(i, j)
3471  END DO
3472  END DO
3473  END DO
3474  END SUBROUTINE nh_p_grad_tlm
3475  SUBROUTINE nh_p_grad(u, v, pp, gz, delp, pk, dt, ng, gridstruct, bd, &
3476 & npx, npy, npz, use_logp)
3477  IMPLICIT NONE
3478 ! end k-loop
3479  INTEGER, INTENT(IN) :: ng, npx, npy, npz
3480  REAL, INTENT(IN) :: dt
3481  LOGICAL, INTENT(IN) :: use_logp
3482  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3483  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3484 ! perturbation pressure
3485  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3486 ! p**kappa
3487  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3488 ! g * h
3489  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3490  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3491  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3492  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3493 ! Local:
3494  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
3495  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
3496  REAL :: du1, dv1, top_value
3497  INTEGER :: i, j, k
3498  INTEGER :: is, ie, js, je
3499  INTEGER :: isd, ied, jsd, jed
3500  is = bd%is
3501  ie = bd%ie
3502  js = bd%js
3503  je = bd%je
3504  isd = bd%isd
3505  ied = bd%ied
3506  jsd = bd%jsd
3507  jed = bd%jed
3508  IF (use_logp) THEN
3509  top_value = peln1
3510  ELSE
3511  top_value = ptk
3512  END IF
3513 !Remember that not all compilers set pp to zero by default
3514 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
3515  DO j=js,je+1
3516  DO i=is,ie+1
3517  pp(i, j, 1) = 0.
3518  pk(i, j, 1) = top_value
3519  END DO
3520  END DO
3521 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
3522 !$OMP private(wk1)
3523  DO k=1,npz+1
3524  IF (k .NE. 1) THEN
3525  CALL a2b_ord4(pp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3526 & npy, is, ie, js, je, ng, .true.)
3527  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3528 & npy, is, ie, js, je, ng, .true.)
3529  END IF
3530  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3531 & npy, is, ie, js, je, ng, .true.)
3532  END DO
3533 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,gridstruct,npx,npy,ng,isd,jsd, &
3534 !$OMP pk,dt,gz,u,pp,v) &
3535 !$OMP private(wk1, wk, du1, dv1)
3536  DO k=1,npz
3537  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3538 & npy, is, ie, js, je, ng)
3539  DO j=js,je+1
3540  DO i=is,ie+1
3541  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
3542  END DO
3543  END DO
3544  DO j=js,je+1
3545  DO i=is,ie
3546 ! hydrostatic contributions from past time-step already added in the "beta" part
3547 ! Current gradient from "hydrostatic" components:
3548  du1 = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
3549 & (pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
3550 & (pk(i, j, k+1)-pk(i+1, j, k)))
3551 ! Non-hydrostatic contribution
3552  u(i, j, k) = (u(i, j, k)+du1+dt/(wk1(i, j)+wk1(i+1, j))*((gz(i&
3553 & , j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, j, k))+(gz(i&
3554 & , j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k))))*&
3555 & gridstruct%rdx(i, j)
3556  END DO
3557  END DO
3558  DO j=js,je
3559  DO i=is,ie+1
3560 ! Current gradient from "hydrostatic" components:
3561  dv1 = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
3562 & (pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
3563 & (pk(i, j, k+1)-pk(i, j+1, k)))
3564 ! Non-hydrostatic contribution
3565  v(i, j, k) = (v(i, j, k)+dv1+dt/(wk1(i, j)+wk1(i, j+1))*((gz(i&
3566 & , j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, j, k))+(gz(i&
3567 & , j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k))))*&
3568 & gridstruct%rdy(i, j)
3569  END DO
3570  END DO
3571  END DO
3572  END SUBROUTINE nh_p_grad
3573 ! Differentiation of split_p_grad in forward (tangent) mode:
3574 ! variations of useful results: gz du u dv v delp pk pp
3575 ! with respect to varying inputs: gz du u dv v delp pk pp
3576  SUBROUTINE split_p_grad_tlm(u, u_tl, v, v_tl, pp, pp_tl, gz, gz_tl, du&
3577 & , du_tl, dv, dv_tl, delp, delp_tl, pk, pk_tl, beta, dt, ng, &
3578 & gridstruct, bd, npx, npy, npz, use_logp)
3579  IMPLICIT NONE
3580 ! end k-loop
3581  INTEGER, INTENT(IN) :: ng, npx, npy, npz
3582  REAL, INTENT(IN) :: beta, dt
3583  LOGICAL, INTENT(IN) :: use_logp
3584  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3585  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3586  REAL, INTENT(INOUT) :: delp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3587 ! perturbation pressure
3588  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3589  REAL, INTENT(INOUT) :: pp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3590 ! p**kappa
3591  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3592  REAL, INTENT(INOUT) :: pk_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3593 ! g * h
3594  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3595  REAL, INTENT(INOUT) :: gz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3596  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3597  REAL, INTENT(INOUT) :: du_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3598  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3599  REAL, INTENT(INOUT) :: dv_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3600  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3601  REAL, INTENT(INOUT) :: u_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3602  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3603  REAL, INTENT(INOUT) :: v_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3604  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3605 ! Local:
3606  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
3607  REAL :: wk1_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
3608  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
3609  REAL :: wk_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
3610  REAL :: alpha, top_value
3611  INTEGER :: i, j, k
3612  INTEGER :: is, ie, js, je
3613  INTEGER :: isd, ied, jsd, jed
3614  is = bd%is
3615  ie = bd%ie
3616  js = bd%js
3617  je = bd%je
3618  isd = bd%isd
3619  ied = bd%ied
3620  jsd = bd%jsd
3621  jed = bd%jed
3622  IF (use_logp) THEN
3623  top_value = peln1
3624  ELSE
3625  top_value = ptk
3626  END IF
3627  alpha = 1. - beta
3628 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
3629  DO j=js,je+1
3630  DO i=is,ie+1
3631  pp_tl(i, j, 1) = 0.0
3632  pp(i, j, 1) = 0.
3633  pk_tl(i, j, 1) = 0.0
3634  pk(i, j, 1) = top_value
3635  END DO
3636  END DO
3637  wk1_tl = 0.0
3638 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
3639 !$OMP private(wk1)
3640  DO k=1,npz+1
3641  IF (k .NE. 1) THEN
3642  CALL a2b_ord4_tlm(pp(isd:ied, jsd:jed, k), pp_tl(isd:ied, jsd&
3643 & :jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, &
3644 & ie, js, je, ng, .true.)
3645  CALL a2b_ord4_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd&
3646 & :jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, &
3647 & ie, js, je, ng, .true.)
3648  END IF
3649  CALL a2b_ord4_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd:&
3650 & jed, k), wk1, wk1_tl, gridstruct, npx, npy, is, ie&
3651 & , js, je, ng, .true.)
3652  END DO
3653  wk_tl = 0.0
3654 !$OMP parallel do default(none) shared(is,ie,js,je,isd,jsd,npz,delp,gridstruct,npx,npy,ng, &
3655 !$OMP pk,u,beta,du,dt,gz,alpha,pp,v,dv) &
3656 !$OMP private(wk1, wk)
3657  DO k=1,npz
3658  CALL a2b_ord4_tlm(delp(isd:ied, jsd:jed, k), delp_tl(isd:ied, &
3659 & jsd:jed, k), wk1, wk1_tl, gridstruct, npx, npy, is&
3660 & , ie, js, je, ng)
3661  DO j=js,je+1
3662  DO i=is,ie+1
3663  wk_tl(i, j) = pk_tl(i, j, k+1) - pk_tl(i, j, k)
3664  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
3665  END DO
3666  END DO
3667  DO j=js,je+1
3668  DO i=is,ie
3669  u_tl(i, j, k) = u_tl(i, j, k) + beta*du_tl(i, j, k)
3670  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
3671 ! hydrostatic contributions from past time-step already added in the "beta" part
3672 ! Current gradient from "hydrostatic" components:
3673 !---------------------------------------------------------------------------------
3674  du_tl(i, j, k) = dt*((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pk(i&
3675 & +1, j, k+1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(&
3676 & pk_tl(i+1, j, k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1&
3677 & , j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k))+(gz(i, j, k)-gz(i+1&
3678 & , j, k+1))*(pk_tl(i, j, k+1)-pk_tl(i+1, j, k)))/(wk(i, j)+wk&
3679 & (i+1, j)) - dt*(wk_tl(i, j)+wk_tl(i+1, j))*((gz(i, j, k+1)-&
3680 & gz(i+1, j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz&
3681 & (i+1, j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))/(wk(i, j)+wk(i&
3682 & +1, j))**2
3683  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
3684 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
3685 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
3686 !---------------------------------------------------------------------------------
3687 ! Non-hydrostatic contribution
3688  u_tl(i, j, k) = gridstruct%rdx(i, j)*(u_tl(i, j, k)+alpha*&
3689 & du_tl(i, j, k)+dt*((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pp(i&
3690 & +1, j, k+1)-pp(i, j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(&
3691 & pp_tl(i+1, j, k+1)-pp_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1&
3692 & , j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k))+(gz(i, j, k)-gz(i+1&
3693 & , j, k+1))*(pp_tl(i, j, k+1)-pp_tl(i+1, j, k)))/(wk1(i, j)+&
3694 & wk1(i+1, j))-dt*(wk1_tl(i, j)+wk1_tl(i+1, j))*((gz(i, j, k+1&
3695 & )-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i, j, k))+(gz(i, j, k)-&
3696 & gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1, j, k)))/(wk1(i, j)+&
3697 & wk1(i+1, j))**2)
3698  u(i, j, k) = (u(i, j, k)+alpha*du(i, j, k)+dt/(wk1(i, j)+wk1(i&
3699 & +1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i&
3700 & , j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1&
3701 & , j, k))))*gridstruct%rdx(i, j)
3702  END DO
3703  END DO
3704  DO j=js,je
3705  DO i=is,ie+1
3706  v_tl(i, j, k) = v_tl(i, j, k) + beta*dv_tl(i, j, k)
3707  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
3708 ! Current gradient from "hydrostatic" components:
3709 !---------------------------------------------------------------------------------
3710  dv_tl(i, j, k) = dt*((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pk(i&
3711 & , j+1, k+1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(&
3712 & pk_tl(i, j+1, k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, &
3713 & j+1, k+1))*(pk(i, j, k+1)-pk(i, j+1, k))+(gz(i, j, k)-gz(i, &
3714 & j+1, k+1))*(pk_tl(i, j, k+1)-pk_tl(i, j+1, k)))/(wk(i, j)+wk&
3715 & (i, j+1)) - dt*(wk_tl(i, j)+wk_tl(i, j+1))*((gz(i, j, k+1)-&
3716 & gz(i, j+1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz&
3717 & (i, j+1, k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))/(wk(i, j)+wk(i&
3718 & , j+1))**2
3719  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
3720 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
3721 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
3722 !---------------------------------------------------------------------------------
3723 ! Non-hydrostatic contribution
3724  v_tl(i, j, k) = gridstruct%rdy(i, j)*(v_tl(i, j, k)+alpha*&
3725 & dv_tl(i, j, k)+dt*((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pp(i&
3726 & , j+1, k+1)-pp(i, j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(&
3727 & pp_tl(i, j+1, k+1)-pp_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, &
3728 & j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k))+(gz(i, j, k)-gz(i, &
3729 & j+1, k+1))*(pp_tl(i, j, k+1)-pp_tl(i, j+1, k)))/(wk1(i, j)+&
3730 & wk1(i, j+1))-dt*(wk1_tl(i, j)+wk1_tl(i, j+1))*((gz(i, j, k+1&
3731 & )-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i, j, k))+(gz(i, j, k)-&
3732 & gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, j+1, k)))/(wk1(i, j)+&
3733 & wk1(i, j+1))**2)
3734  v(i, j, k) = (v(i, j, k)+alpha*dv(i, j, k)+dt/(wk1(i, j)+wk1(i&
3735 & , j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i&
3736 & , j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, &
3737 & j+1, k))))*gridstruct%rdy(i, j)
3738  END DO
3739  END DO
3740  END DO
3741  END SUBROUTINE split_p_grad_tlm
3742  SUBROUTINE split_p_grad(u, v, pp, gz, du, dv, delp, pk, beta, dt, ng, &
3743 & gridstruct, bd, npx, npy, npz, use_logp)
3744  IMPLICIT NONE
3745 ! end k-loop
3746  INTEGER, INTENT(IN) :: ng, npx, npy, npz
3747  REAL, INTENT(IN) :: beta, dt
3748  LOGICAL, INTENT(IN) :: use_logp
3749  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3750  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3751 ! perturbation pressure
3752  REAL, INTENT(INOUT) :: pp(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3753 ! p**kappa
3754  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3755 ! g * h
3756  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3757  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3758  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3759  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3760  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3761  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3762 ! Local:
3763  REAL :: wk1(bd%isd:bd%ied, bd%jsd:bd%jed)
3764  REAL :: wk(bd%is:bd%ie+1, bd%js:bd%je+1)
3765  REAL :: alpha, top_value
3766  INTEGER :: i, j, k
3767  INTEGER :: is, ie, js, je
3768  INTEGER :: isd, ied, jsd, jed
3769  is = bd%is
3770  ie = bd%ie
3771  js = bd%js
3772  je = bd%je
3773  isd = bd%isd
3774  ied = bd%ied
3775  jsd = bd%jsd
3776  jed = bd%jed
3777  IF (use_logp) THEN
3778  top_value = peln1
3779  ELSE
3780  top_value = ptk
3781  END IF
3782  alpha = 1. - beta
3783 !$OMP parallel do default(none) shared(is,ie,js,je,pp,pk,top_value)
3784  DO j=js,je+1
3785  DO i=is,ie+1
3786  pp(i, j, 1) = 0.
3787  pk(i, j, 1) = top_value
3788  END DO
3789  END DO
3790 !$OMP parallel do default(none) shared(isd,jsd,npz,pp,gridstruct,npx,npy,is,ie,js,je,ng,pk,gz) &
3791 !$OMP private(wk1)
3792  DO k=1,npz+1
3793  IF (k .NE. 1) THEN
3794  CALL a2b_ord4(pp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3795 & npy, is, ie, js, je, ng, .true.)
3796  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3797 & npy, is, ie, js, je, ng, .true.)
3798  END IF
3799  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3800 & npy, is, ie, js, je, ng, .true.)
3801  END DO
3802 !$OMP parallel do default(none) shared(is,ie,js,je,isd,jsd,npz,delp,gridstruct,npx,npy,ng, &
3803 !$OMP pk,u,beta,du,dt,gz,alpha,pp,v,dv) &
3804 !$OMP private(wk1, wk)
3805  DO k=1,npz
3806  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk1, gridstruct, npx, &
3807 & npy, is, ie, js, je, ng)
3808  DO j=js,je+1
3809  DO i=is,ie+1
3810  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
3811  END DO
3812  END DO
3813  DO j=js,je+1
3814  DO i=is,ie
3815  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
3816 ! hydrostatic contributions from past time-step already added in the "beta" part
3817 ! Current gradient from "hydrostatic" components:
3818 !---------------------------------------------------------------------------------
3819  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
3820 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
3821 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
3822 !---------------------------------------------------------------------------------
3823 ! Non-hydrostatic contribution
3824  u(i, j, k) = (u(i, j, k)+alpha*du(i, j, k)+dt/(wk1(i, j)+wk1(i&
3825 & +1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pp(i+1, j, k+1)-pp(i&
3826 & , j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pp(i, j, k+1)-pp(i+1&
3827 & , j, k))))*gridstruct%rdx(i, j)
3828  END DO
3829  END DO
3830  DO j=js,je
3831  DO i=is,ie+1
3832  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
3833 ! Current gradient from "hydrostatic" components:
3834 !---------------------------------------------------------------------------------
3835  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
3836 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
3837 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
3838 !---------------------------------------------------------------------------------
3839 ! Non-hydrostatic contribution
3840  v(i, j, k) = (v(i, j, k)+alpha*dv(i, j, k)+dt/(wk1(i, j)+wk1(i&
3841 & , j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pp(i, j+1, k+1)-pp(i&
3842 & , j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pp(i, j, k+1)-pp(i, &
3843 & j+1, k))))*gridstruct%rdy(i, j)
3844  END DO
3845  END DO
3846  END DO
3847  END SUBROUTINE split_p_grad
3848 ! Differentiation of one_grad_p in forward (tangent) mode:
3849 ! variations of useful results: gz u v delp pk
3850 ! with respect to varying inputs: gz u v delp pk divg2
3851  SUBROUTINE one_grad_p_tlm(u, u_tl, v, v_tl, pk, pk_tl, gz, gz_tl, &
3852 & divg2, divg2_tl, delp, delp_tl, dt, ng, gridstruct, bd, npx, npy, &
3853 & npz, ptop, hydrostatic, a2b_ord, d_ext)
3854  IMPLICIT NONE
3855 ! end k-loop
3856  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
3857  REAL, INTENT(IN) :: dt, ptop, d_ext
3858  LOGICAL, INTENT(IN) :: hydrostatic
3859  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
3860  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
3861  REAL, INTENT(IN) :: divg2_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
3862  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3863  REAL, INTENT(INOUT) :: pk_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3864  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3865  REAL, INTENT(INOUT) :: gz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
3866  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3867  REAL, INTENT(INOUT) :: delp_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
3868  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3869  REAL, INTENT(INOUT) :: u_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
3870  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3871  REAL, INTENT(INOUT) :: v_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
3872  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
3873 ! Local:
3874  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk
3875  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk_tl
3876  REAL :: wk1(bd%is:bd%ie+1, bd%js:bd%je+1)
3877  REAL :: wk1_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
3878  REAL :: wk2(bd%is:bd%ie, bd%js:bd%je+1)
3879  REAL :: wk2_tl(bd%is:bd%ie, bd%js:bd%je+1)
3880  REAL :: top_value
3881  INTEGER :: i, j, k
3882  INTEGER :: is, ie, js, je
3883  INTEGER :: isd, ied, jsd, jed
3884  is = bd%is
3885  ie = bd%ie
3886  js = bd%js
3887  je = bd%je
3888  isd = bd%isd
3889  ied = bd%ied
3890  jsd = bd%jsd
3891  jed = bd%jed
3892  IF (hydrostatic) THEN
3893 ! pk is pe**kappa if hydrostatic
3894  top_value = ptk
3895  ELSE
3896 ! pk is full pressure if non-hydrostatic
3897  top_value = ptop
3898  END IF
3899 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
3900  DO j=js,je+1
3901  DO i=is,ie+1
3902  pk_tl(i, j, 1) = 0.0
3903  pk(i, j, 1) = top_value
3904  END DO
3905  END DO
3906  wk_tl = 0.0
3907 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
3908 !$OMP private(wk)
3909  DO k=2,npz+1
3910  IF (a2b_ord .EQ. 4) THEN
3911  CALL a2b_ord4_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd&
3912 & :jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie&
3913 & , js, je, ng, .true.)
3914  ELSE
3915  CALL a2b_ord2_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd:&
3916 & jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie, js&
3917 & , je, ng, .true.)
3918  END IF
3919  END DO
3920 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
3921 !$OMP private(wk)
3922  DO k=1,npz+1
3923  IF (a2b_ord .EQ. 4) THEN
3924  CALL a2b_ord4_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd&
3925 & :jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie&
3926 & , js, je, ng, .true.)
3927  ELSE
3928  CALL a2b_ord2_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd:&
3929 & jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie, js&
3930 & , je, ng, .true.)
3931  END IF
3932  END DO
3933  IF (d_ext .GT. 0.) THEN
3934  wk2_tl = 0.0
3935 !$OMP parallel do default(none) shared(is,ie,js,je,wk2,divg2)
3936  DO j=js,je+1
3937  DO i=is,ie
3938  wk2_tl(i, j) = divg2_tl(i, j) - divg2_tl(i+1, j)
3939  wk2(i, j) = divg2(i, j) - divg2(i+1, j)
3940  END DO
3941  END DO
3942  wk1_tl = 0.0
3943 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,divg2)
3944  DO j=js,je
3945  DO i=is,ie+1
3946  wk1_tl(i, j) = divg2_tl(i, j) - divg2_tl(i, j+1)
3947  wk1(i, j) = divg2(i, j) - divg2(i, j+1)
3948  END DO
3949  END DO
3950  ELSE
3951 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,wk2)
3952  DO j=js,je+1
3953  DO i=is,ie
3954  wk2(i, j) = 0.
3955  END DO
3956  DO i=is,ie+1
3957  wk1(i, j) = 0.
3958  END DO
3959  END DO
3960  wk1_tl = 0.0
3961  wk2_tl = 0.0
3962  END IF
3963 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,a2b_ord,gridstruct, &
3964 !$OMP npx,npy,isd,jsd,ng,u,v,wk2,dt,gz,wk1) &
3965 !$OMP private(wk)
3966  DO k=1,npz
3967  IF (hydrostatic) THEN
3968  DO j=js,je+1
3969  DO i=is,ie+1
3970  wk_tl(i, j) = pk_tl(i, j, k+1) - pk_tl(i, j, k)
3971  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
3972  END DO
3973  END DO
3974  ELSE IF (a2b_ord .EQ. 4) THEN
3975  CALL a2b_ord4_tlm(delp(isd:ied, jsd:jed, k), delp_tl(isd:ied&
3976 & , jsd:jed, k), wk, wk_tl, gridstruct, npx, npy, &
3977 & is, ie, js, je, ng)
3978  ELSE
3979  CALL a2b_ord2_tlm(delp(isd:ied, jsd:jed, k), delp_tl(isd:ied, &
3980 & jsd:jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie&
3981 & , js, je, ng)
3982  END IF
3983  DO j=js,je+1
3984  DO i=is,ie
3985  u_tl(i, j, k) = gridstruct%rdx(i, j)*(wk2_tl(i, j)+u_tl(i, j, &
3986 & k)+dt*((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pk(i+1, j, k+1)-&
3987 & pk(i, j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(pk_tl(i+1, j, k+&
3988 & 1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1, j, k+1))*(pk(i&
3989 & , j, k+1)-pk(i+1, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(&
3990 & pk_tl(i, j, k+1)-pk_tl(i+1, j, k)))/(wk(i, j)+wk(i+1, j))-dt&
3991 & *(wk_tl(i, j)+wk_tl(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*&
3992 & (pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*&
3993 & (pk(i, j, k+1)-pk(i+1, j, k)))/(wk(i, j)+wk(i+1, j))**2)
3994  u(i, j, k) = gridstruct%rdx(i, j)*(wk2(i, j)+u(i, j, k)+dt/(wk&
3995 & (i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pk(i+1, j&
3996 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pk(i, j, &
3997 & k+1)-pk(i+1, j, k))))
3998  END DO
3999  END DO
4000  DO j=js,je
4001  DO i=is,ie+1
4002  v_tl(i, j, k) = gridstruct%rdy(i, j)*(wk1_tl(i, j)+v_tl(i, j, &
4003 & k)+dt*((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pk(i, j+1, k+1)-&
4004 & pk(i, j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(pk_tl(i, j+1, k+&
4005 & 1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, j+1, k+1))*(pk(i&
4006 & , j, k+1)-pk(i, j+1, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(&
4007 & pk_tl(i, j, k+1)-pk_tl(i, j+1, k)))/(wk(i, j)+wk(i, j+1))-dt&
4008 & *(wk_tl(i, j)+wk_tl(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*&
4009 & (pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*&
4010 & (pk(i, j, k+1)-pk(i, j+1, k)))/(wk(i, j)+wk(i, j+1))**2)
4011  v(i, j, k) = gridstruct%rdy(i, j)*(wk1(i, j)+v(i, j, k)+dt/(wk&
4012 & (i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pk(i, j+1&
4013 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pk(i, j, &
4014 & k+1)-pk(i, j+1, k))))
4015  END DO
4016  END DO
4017  END DO
4018  END SUBROUTINE one_grad_p_tlm
4019  SUBROUTINE one_grad_p(u, v, pk, gz, divg2, delp, dt, ng, gridstruct, &
4020 & bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
4021  IMPLICIT NONE
4022 ! end k-loop
4023  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
4024  REAL, INTENT(IN) :: dt, ptop, d_ext
4025  LOGICAL, INTENT(IN) :: hydrostatic
4026  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4027  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
4028  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4029  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4030  REAL, INTENT(INOUT) :: delp(bd%isd:bd%ied, bd%jsd:bd%jed, npz)
4031  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4032  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4033  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4034 ! Local:
4035  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed) :: wk
4036  REAL :: wk1(bd%is:bd%ie+1, bd%js:bd%je+1)
4037  REAL :: wk2(bd%is:bd%ie, bd%js:bd%je+1)
4038  REAL :: top_value
4039  INTEGER :: i, j, k
4040  INTEGER :: is, ie, js, je
4041  INTEGER :: isd, ied, jsd, jed
4042  is = bd%is
4043  ie = bd%ie
4044  js = bd%js
4045  je = bd%je
4046  isd = bd%isd
4047  ied = bd%ied
4048  jsd = bd%jsd
4049  jed = bd%jed
4050  IF (hydrostatic) THEN
4051 ! pk is pe**kappa if hydrostatic
4052  top_value = ptk
4053  ELSE
4054 ! pk is full pressure if non-hydrostatic
4055  top_value = ptop
4056  END IF
4057 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
4058  DO j=js,je+1
4059  DO i=is,ie+1
4060  pk(i, j, 1) = top_value
4061  END DO
4062  END DO
4063 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4064 !$OMP private(wk)
4065  DO k=2,npz+1
4066  IF (a2b_ord .EQ. 4) THEN
4067  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
4068 & npy, is, ie, js, je, ng, .true.)
4069  ELSE
4070  CALL a2b_ord2(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
4071 & , is, ie, js, je, ng, .true.)
4072  END IF
4073  END DO
4074 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4075 !$OMP private(wk)
4076  DO k=1,npz+1
4077  IF (a2b_ord .EQ. 4) THEN
4078  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
4079 & npy, is, ie, js, je, ng, .true.)
4080  ELSE
4081  CALL a2b_ord2(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
4082 & , is, ie, js, je, ng, .true.)
4083  END IF
4084  END DO
4085  IF (d_ext .GT. 0.) THEN
4086 !$OMP parallel do default(none) shared(is,ie,js,je,wk2,divg2)
4087  DO j=js,je+1
4088  DO i=is,ie
4089  wk2(i, j) = divg2(i, j) - divg2(i+1, j)
4090  END DO
4091  END DO
4092 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,divg2)
4093  DO j=js,je
4094  DO i=is,ie+1
4095  wk1(i, j) = divg2(i, j) - divg2(i, j+1)
4096  END DO
4097  END DO
4098  ELSE
4099 !$OMP parallel do default(none) shared(is,ie,js,je,wk1,wk2)
4100  DO j=js,je+1
4101  DO i=is,ie
4102  wk2(i, j) = 0.
4103  END DO
4104  DO i=is,ie+1
4105  wk1(i, j) = 0.
4106  END DO
4107  END DO
4108  END IF
4109 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pk,delp,hydrostatic,a2b_ord,gridstruct, &
4110 !$OMP npx,npy,isd,jsd,ng,u,v,wk2,dt,gz,wk1) &
4111 !$OMP private(wk)
4112  DO k=1,npz
4113  IF (hydrostatic) THEN
4114  DO j=js,je+1
4115  DO i=is,ie+1
4116  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
4117  END DO
4118  END DO
4119  ELSE IF (a2b_ord .EQ. 4) THEN
4120  CALL a2b_ord4(delp(isd:ied, jsd:jed, k), wk, gridstruct, npx&
4121 & , npy, is, ie, js, je, ng)
4122  ELSE
4123  CALL a2b_ord2(delp(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
4124 & npy, is, ie, js, je, ng)
4125  END IF
4126  DO j=js,je+1
4127  DO i=is,ie
4128  u(i, j, k) = gridstruct%rdx(i, j)*(wk2(i, j)+u(i, j, k)+dt/(wk&
4129 & (i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1, j, k))*(pk(i+1, j&
4130 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, j, k+1))*(pk(i, j, &
4131 & k+1)-pk(i+1, j, k))))
4132  END DO
4133  END DO
4134  DO j=js,je
4135  DO i=is,ie+1
4136  v(i, j, k) = gridstruct%rdy(i, j)*(wk1(i, j)+v(i, j, k)+dt/(wk&
4137 & (i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j+1, k))*(pk(i, j+1&
4138 & , k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1, k+1))*(pk(i, j, &
4139 & k+1)-pk(i, j+1, k))))
4140  END DO
4141  END DO
4142  END DO
4143  END SUBROUTINE one_grad_p
4144 ! Differentiation of grad1_p_update in forward (tangent) mode:
4145 ! variations of useful results: gz du u dv v pk
4146 ! with respect to varying inputs: gz du u dv v pk divg2
4147  SUBROUTINE grad1_p_update_tlm(divg2, divg2_tl, u, u_tl, v, v_tl, pk, &
4148 & pk_tl, gz, gz_tl, du, du_tl, dv, dv_tl, dt, ng, gridstruct, bd, npx&
4149 & , npy, npz, ptop, beta, a2b_ord)
4150  IMPLICIT NONE
4151 ! end k-loop
4152  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
4153  REAL, INTENT(IN) :: dt, ptop, beta
4154  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4155  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
4156  REAL, INTENT(IN) :: divg2_tl(bd%is:bd%ie+1, bd%js:bd%je+1)
4157  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4158  REAL, INTENT(INOUT) :: pk_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4159  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4160  REAL, INTENT(INOUT) :: gz_tl(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4161  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4162  REAL, INTENT(INOUT) :: u_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4163  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4164  REAL, INTENT(INOUT) :: v_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4165  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4166  REAL, INTENT(INOUT) :: du_tl(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4167  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4168  REAL, INTENT(INOUT) :: dv_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4169  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4170 ! Local:
4171  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
4172  REAL :: wk_tl(bd%isd:bd%ied, bd%jsd:bd%jed)
4173  REAL :: top_value, alpha
4174  INTEGER :: i, j, k
4175  INTEGER :: is, ie, js, je
4176  INTEGER :: isd, ied, jsd, jed
4177  is = bd%is
4178  ie = bd%ie
4179  js = bd%js
4180  je = bd%je
4181  isd = bd%isd
4182  ied = bd%ied
4183  jsd = bd%jsd
4184  jed = bd%jed
4185  alpha = 1. - beta
4186 ! pk is pe**kappa if hydrostatic
4187  top_value = ptk
4188 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
4189  DO j=js,je+1
4190  DO i=is,ie+1
4191  pk_tl(i, j, 1) = 0.0
4192  pk(i, j, 1) = top_value
4193  END DO
4194  END DO
4195  wk_tl = 0.0
4196 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4197 !$OMP private(wk)
4198  DO k=2,npz+1
4199  IF (a2b_ord .EQ. 4) THEN
4200  CALL a2b_ord4_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd&
4201 & :jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie&
4202 & , js, je, ng, .true.)
4203  ELSE
4204  CALL a2b_ord2_tlm(pk(isd:ied, jsd:jed, k), pk_tl(isd:ied, jsd:&
4205 & jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie, js&
4206 & , je, ng, .true.)
4207  END IF
4208  END DO
4209 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4210 !$OMP private(wk)
4211  DO k=1,npz+1
4212  IF (a2b_ord .EQ. 4) THEN
4213  CALL a2b_ord4_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd&
4214 & :jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie&
4215 & , js, je, ng, .true.)
4216  ELSE
4217  CALL a2b_ord2_tlm(gz(isd:ied, jsd:jed, k), gz_tl(isd:ied, jsd:&
4218 & jed, k), wk, wk_tl, gridstruct, npx, npy, is, ie, js&
4219 & , je, ng, .true.)
4220  END IF
4221  END DO
4222 !$OMP parallel do default(none) shared(npz,is,ie,js,je,pk,u,beta,gz,divg2,alpha, &
4223 !$OMP gridstruct,v,dt,du,dv) &
4224 !$OMP private(wk)
4225  DO k=1,npz
4226  DO j=js,je+1
4227  DO i=is,ie+1
4228  wk_tl(i, j) = pk_tl(i, j, k+1) - pk_tl(i, j, k)
4229  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
4230  END DO
4231  END DO
4232  DO j=js,je+1
4233  DO i=is,ie
4234  u_tl(i, j, k) = u_tl(i, j, k) + beta*du_tl(i, j, k)
4235  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
4236  du_tl(i, j, k) = dt*((gz_tl(i, j, k+1)-gz_tl(i+1, j, k))*(pk(i&
4237 & +1, j, k+1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i+1, j, k))*(&
4238 & pk_tl(i+1, j, k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i+1&
4239 & , j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k))+(gz(i, j, k)-gz(i+1&
4240 & , j, k+1))*(pk_tl(i, j, k+1)-pk_tl(i+1, j, k)))/(wk(i, j)+wk&
4241 & (i+1, j)) - dt*(wk_tl(i, j)+wk_tl(i+1, j))*((gz(i, j, k+1)-&
4242 & gz(i+1, j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz&
4243 & (i+1, j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))/(wk(i, j)+wk(i&
4244 & +1, j))**2
4245  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
4246 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
4247 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
4248  u_tl(i, j, k) = gridstruct%rdx(i, j)*(u_tl(i, j, k)+divg2_tl(i&
4249 & , j)-divg2_tl(i+1, j)+alpha*du_tl(i, j, k))
4250  u(i, j, k) = (u(i, j, k)+divg2(i, j)-divg2(i+1, j)+alpha*du(i&
4251 & , j, k))*gridstruct%rdx(i, j)
4252  END DO
4253  END DO
4254  DO j=js,je
4255  DO i=is,ie+1
4256  v_tl(i, j, k) = v_tl(i, j, k) + beta*dv_tl(i, j, k)
4257  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
4258  dv_tl(i, j, k) = dt*((gz_tl(i, j, k+1)-gz_tl(i, j+1, k))*(pk(i&
4259 & , j+1, k+1)-pk(i, j, k))+(gz(i, j, k+1)-gz(i, j+1, k))*(&
4260 & pk_tl(i, j+1, k+1)-pk_tl(i, j, k))+(gz_tl(i, j, k)-gz_tl(i, &
4261 & j+1, k+1))*(pk(i, j, k+1)-pk(i, j+1, k))+(gz(i, j, k)-gz(i, &
4262 & j+1, k+1))*(pk_tl(i, j, k+1)-pk_tl(i, j+1, k)))/(wk(i, j)+wk&
4263 & (i, j+1)) - dt*(wk_tl(i, j)+wk_tl(i, j+1))*((gz(i, j, k+1)-&
4264 & gz(i, j+1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz&
4265 & (i, j+1, k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))/(wk(i, j)+wk(i&
4266 & , j+1))**2
4267  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
4268 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
4269 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
4270  v_tl(i, j, k) = gridstruct%rdy(i, j)*(v_tl(i, j, k)+divg2_tl(i&
4271 & , j)-divg2_tl(i, j+1)+alpha*dv_tl(i, j, k))
4272  v(i, j, k) = (v(i, j, k)+divg2(i, j)-divg2(i, j+1)+alpha*dv(i&
4273 & , j, k))*gridstruct%rdy(i, j)
4274  END DO
4275  END DO
4276  END DO
4277  END SUBROUTINE grad1_p_update_tlm
4278  SUBROUTINE grad1_p_update(divg2, u, v, pk, gz, du, dv, dt, ng, &
4279 & gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
4280  IMPLICIT NONE
4281 ! end k-loop
4282  INTEGER, INTENT(IN) :: ng, npx, npy, npz, a2b_ord
4283  REAL, INTENT(IN) :: dt, ptop, beta
4284  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4285  REAL, INTENT(IN) :: divg2(bd%is:bd%ie+1, bd%js:bd%je+1)
4286  REAL, INTENT(INOUT) :: pk(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4287  REAL, INTENT(INOUT) :: gz(bd%isd:bd%ied, bd%jsd:bd%jed, npz+1)
4288  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4289  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4290  REAL, INTENT(INOUT) :: du(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
4291  REAL, INTENT(INOUT) :: dv(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
4292  TYPE(FV_GRID_TYPE), INTENT(INOUT), TARGET :: gridstruct
4293 ! Local:
4294  REAL :: wk(bd%isd:bd%ied, bd%jsd:bd%jed)
4295  REAL :: top_value, alpha
4296  INTEGER :: i, j, k
4297  INTEGER :: is, ie, js, je
4298  INTEGER :: isd, ied, jsd, jed
4299  is = bd%is
4300  ie = bd%ie
4301  js = bd%js
4302  je = bd%je
4303  isd = bd%isd
4304  ied = bd%ied
4305  jsd = bd%jsd
4306  jed = bd%jed
4307  alpha = 1. - beta
4308 ! pk is pe**kappa if hydrostatic
4309  top_value = ptk
4310 !$OMP parallel do default(none) shared(is,ie,js,je,pk,top_value)
4311  DO j=js,je+1
4312  DO i=is,ie+1
4313  pk(i, j, 1) = top_value
4314  END DO
4315  END DO
4316 !$OMP parallel do default(none) shared(npz,isd,jsd,pk,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4317 !$OMP private(wk)
4318  DO k=2,npz+1
4319  IF (a2b_ord .EQ. 4) THEN
4320  CALL a2b_ord4(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
4321 & npy, is, ie, js, je, ng, .true.)
4322  ELSE
4323  CALL a2b_ord2(pk(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
4324 & , is, ie, js, je, ng, .true.)
4325  END IF
4326  END DO
4327 !$OMP parallel do default(none) shared(npz,isd,jsd,gz,gridstruct,npx,npy,is,ie,js,je,ng,a2b_ord) &
4328 !$OMP private(wk)
4329  DO k=1,npz+1
4330  IF (a2b_ord .EQ. 4) THEN
4331  CALL a2b_ord4(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, &
4332 & npy, is, ie, js, je, ng, .true.)
4333  ELSE
4334  CALL a2b_ord2(gz(isd:ied, jsd:jed, k), wk, gridstruct, npx, npy&
4335 & , is, ie, js, je, ng, .true.)
4336  END IF
4337  END DO
4338 !$OMP parallel do default(none) shared(npz,is,ie,js,je,pk,u,beta,gz,divg2,alpha, &
4339 !$OMP gridstruct,v,dt,du,dv) &
4340 !$OMP private(wk)
4341  DO k=1,npz
4342  DO j=js,je+1
4343  DO i=is,ie+1
4344  wk(i, j) = pk(i, j, k+1) - pk(i, j, k)
4345  END DO
4346  END DO
4347  DO j=js,je+1
4348  DO i=is,ie
4349  u(i, j, k) = u(i, j, k) + beta*du(i, j, k)
4350  du(i, j, k) = dt/(wk(i, j)+wk(i+1, j))*((gz(i, j, k+1)-gz(i+1&
4351 & , j, k))*(pk(i+1, j, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i+1, &
4352 & j, k+1))*(pk(i, j, k+1)-pk(i+1, j, k)))
4353  u(i, j, k) = (u(i, j, k)+divg2(i, j)-divg2(i+1, j)+alpha*du(i&
4354 & , j, k))*gridstruct%rdx(i, j)
4355  END DO
4356  END DO
4357  DO j=js,je
4358  DO i=is,ie+1
4359  v(i, j, k) = v(i, j, k) + beta*dv(i, j, k)
4360  dv(i, j, k) = dt/(wk(i, j)+wk(i, j+1))*((gz(i, j, k+1)-gz(i, j&
4361 & +1, k))*(pk(i, j+1, k+1)-pk(i, j, k))+(gz(i, j, k)-gz(i, j+1&
4362 & , k+1))*(pk(i, j, k+1)-pk(i, j+1, k)))
4363  v(i, j, k) = (v(i, j, k)+divg2(i, j)-divg2(i, j+1)+alpha*dv(i&
4364 & , j, k))*gridstruct%rdy(i, j)
4365  END DO
4366  END DO
4367  END DO
4368  END SUBROUTINE grad1_p_update
4369 ! Differentiation of mix_dp in forward (tangent) mode:
4370 ! variations of useful results: w delp pt
4371 ! with respect to varying inputs: w delp pt
4372  SUBROUTINE mix_dp_tlm(hydrostatic, w, w_tl, delp, delp_tl, pt, pt_tl, &
4373 & km, ak, bk, cg, fv_debug, bd)
4374  IMPLICIT NONE
4375 ! if ( ip/=0 ) write(*,*) 'Warning: Mix_dp', mpp_pe(), j, ip
4376  INTEGER, INTENT(IN) :: km
4377  REAL, INTENT(IN) :: ak(km+1), bk(km+1)
4378  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4379  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4380 & pt, delp
4381  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4382 & pt_tl, delp_tl
4383  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4384 & w
4385  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4386 & w_tl
4387  LOGICAL, INTENT(IN) :: hydrostatic, cg, fv_debug
4388 ! Local:
4389  REAL :: dp, dpmin
4390  REAL :: dp_tl
4391  INTEGER :: i, j, k, ip
4392  INTEGER :: ifirst, ilast
4393  INTEGER :: jfirst, jlast
4394  INTEGER :: is, ie, js, je
4395  INTEGER :: isd, ied, jsd, jed
4396  is = bd%is
4397  ie = bd%ie
4398  js = bd%js
4399  je = bd%je
4400  isd = bd%isd
4401  ied = bd%ied
4402  jsd = bd%jsd
4403  jed = bd%jed
4404  IF (cg) THEN
4405  ifirst = is - 1
4406  ilast = ie + 1
4407  jfirst = js - 1
4408  jlast = je + 1
4409  ELSE
4410  ifirst = is
4411  ilast = ie
4412  jfirst = js
4413  jlast = je
4414  END IF
4415 !$OMP parallel do default(none) shared(jfirst,jlast,km,ifirst,ilast,delp,ak,bk,pt, &
4416 !$OMP hydrostatic,w,fv_debug) &
4417 !$OMP private(ip, dpmin, dp)
4418  DO j=jfirst,jlast
4419  ip = 0
4420  DO k=1,km-1
4421  dpmin = 0.01*(ak(k+1)-ak(k)+(bk(k+1)-bk(k))*1.e5)
4422  DO i=ifirst,ilast
4423  IF (delp(i, j, k) .LT. dpmin) THEN
4424 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, k, mpp_pe(), delp(i,j,k), pt(i,j,k)
4425 ! Remap from below and mix pt
4426  dp_tl = -delp_tl(i, j, k)
4427  dp = dpmin - delp(i, j, k)
4428  pt_tl(i, j, k) = (pt_tl(i, j, k)*delp(i, j, k)+pt(i, j, k)*&
4429 & delp_tl(i, j, k)+pt_tl(i, j, k+1)*dp+pt(i, j, k+1)*dp_tl)/&
4430 & dpmin
4431  pt(i, j, k) = (pt(i, j, k)*delp(i, j, k)+pt(i, j, k+1)*dp)/&
4432 & dpmin
4433  IF (.NOT.hydrostatic) THEN
4434  w_tl(i, j, k) = (w_tl(i, j, k)*delp(i, j, k)+w(i, j, k)*&
4435 & delp_tl(i, j, k)+w_tl(i, j, k+1)*dp+w(i, j, k+1)*dp_tl)/&
4436 & dpmin
4437  w(i, j, k) = (w(i, j, k)*delp(i, j, k)+w(i, j, k+1)*dp)/&
4438 & dpmin
4439  END IF
4440  delp_tl(i, j, k) = 0.0
4441  delp(i, j, k) = dpmin
4442  delp_tl(i, j, k+1) = delp_tl(i, j, k+1) - dp_tl
4443  delp(i, j, k+1) = delp(i, j, k+1) - dp
4444  ip = ip + 1
4445  END IF
4446  END DO
4447  END DO
4448 ! Bottom (k=km):
4449  dpmin = 0.01*(ak(km+1)-ak(km)+(bk(km+1)-bk(km))*1.e5)
4450  DO i=ifirst,ilast
4451  IF (delp(i, j, km) .LT. dpmin) THEN
4452 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, km, mpp_pe(), delp(i,j,km), pt(i,j,km)
4453 ! Remap from above and mix pt
4454  dp_tl = -delp_tl(i, j, km)
4455  dp = dpmin - delp(i, j, km)
4456  pt_tl(i, j, km) = (pt_tl(i, j, km)*delp(i, j, km)+pt(i, j, km)&
4457 & *delp_tl(i, j, km)+pt_tl(i, j, km-1)*dp+pt(i, j, km-1)*dp_tl&
4458 & )/dpmin
4459  pt(i, j, km) = (pt(i, j, km)*delp(i, j, km)+pt(i, j, km-1)*dp)&
4460 & /dpmin
4461  IF (.NOT.hydrostatic) THEN
4462  w_tl(i, j, km) = (w_tl(i, j, km)*delp(i, j, km)+w(i, j, km)*&
4463 & delp_tl(i, j, km)+w_tl(i, j, km-1)*dp+w(i, j, km-1)*dp_tl)&
4464 & /dpmin
4465  w(i, j, km) = (w(i, j, km)*delp(i, j, km)+w(i, j, km-1)*dp)/&
4466 & dpmin
4467  END IF
4468  delp_tl(i, j, km) = 0.0
4469  delp(i, j, km) = dpmin
4470  delp_tl(i, j, km-1) = delp_tl(i, j, km-1) - dp_tl
4471  delp(i, j, km-1) = delp(i, j, km-1) - dp
4472  ip = ip + 1
4473  END IF
4474  END DO
4475  IF (fv_debug .AND. ip .NE. 0) WRITE(*, *) 'Warning: Mix_dp', &
4476 & mpp_pe(), j, ip
4477  END DO
4478  END SUBROUTINE mix_dp_tlm
4479  SUBROUTINE mix_dp(hydrostatic, w, delp, pt, km, ak, bk, cg, fv_debug, &
4480 & bd)
4481  IMPLICIT NONE
4482 ! if ( ip/=0 ) write(*,*) 'Warning: Mix_dp', mpp_pe(), j, ip
4483  INTEGER, INTENT(IN) :: km
4484  REAL, INTENT(IN) :: ak(km+1), bk(km+1)
4485  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4486  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4487 & pt, delp
4488  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(INOUT) :: &
4489 & w
4490  LOGICAL, INTENT(IN) :: hydrostatic, cg, fv_debug
4491 ! Local:
4492  REAL :: dp, dpmin
4493  INTEGER :: i, j, k, ip
4494  INTEGER :: ifirst, ilast
4495  INTEGER :: jfirst, jlast
4496  INTEGER :: is, ie, js, je
4497  INTEGER :: isd, ied, jsd, jed
4498  is = bd%is
4499  ie = bd%ie
4500  js = bd%js
4501  je = bd%je
4502  isd = bd%isd
4503  ied = bd%ied
4504  jsd = bd%jsd
4505  jed = bd%jed
4506  IF (cg) THEN
4507  ifirst = is - 1
4508  ilast = ie + 1
4509  jfirst = js - 1
4510  jlast = je + 1
4511  ELSE
4512  ifirst = is
4513  ilast = ie
4514  jfirst = js
4515  jlast = je
4516  END IF
4517 !$OMP parallel do default(none) shared(jfirst,jlast,km,ifirst,ilast,delp,ak,bk,pt, &
4518 !$OMP hydrostatic,w,fv_debug) &
4519 !$OMP private(ip, dpmin, dp)
4520  DO j=jfirst,jlast
4521  ip = 0
4522  DO k=1,km-1
4523  dpmin = 0.01*(ak(k+1)-ak(k)+(bk(k+1)-bk(k))*1.e5)
4524  DO i=ifirst,ilast
4525  IF (delp(i, j, k) .LT. dpmin) THEN
4526 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, k, mpp_pe(), delp(i,j,k), pt(i,j,k)
4527 ! Remap from below and mix pt
4528  dp = dpmin - delp(i, j, k)
4529  pt(i, j, k) = (pt(i, j, k)*delp(i, j, k)+pt(i, j, k+1)*dp)/&
4530 & dpmin
4531  IF (.NOT.hydrostatic) w(i, j, k) = (w(i, j, k)*delp(i, j, k)&
4532 & +w(i, j, k+1)*dp)/dpmin
4533  delp(i, j, k) = dpmin
4534  delp(i, j, k+1) = delp(i, j, k+1) - dp
4535  ip = ip + 1
4536  END IF
4537  END DO
4538  END DO
4539 ! Bottom (k=km):
4540  dpmin = 0.01*(ak(km+1)-ak(km)+(bk(km+1)-bk(km))*1.e5)
4541  DO i=ifirst,ilast
4542  IF (delp(i, j, km) .LT. dpmin) THEN
4543 !if (fv_debug) write(*,*) 'Mix_dp: ', i, j, km, mpp_pe(), delp(i,j,km), pt(i,j,km)
4544 ! Remap from above and mix pt
4545  dp = dpmin - delp(i, j, km)
4546  pt(i, j, km) = (pt(i, j, km)*delp(i, j, km)+pt(i, j, km-1)*dp)&
4547 & /dpmin
4548  IF (.NOT.hydrostatic) w(i, j, km) = (w(i, j, km)*delp(i, j, km&
4549 & )+w(i, j, km-1)*dp)/dpmin
4550  delp(i, j, km) = dpmin
4551  delp(i, j, km-1) = delp(i, j, km-1) - dp
4552  ip = ip + 1
4553  END IF
4554  END DO
4555  IF (fv_debug .AND. ip .NE. 0) WRITE(*, *) 'Warning: Mix_dp', &
4556 & mpp_pe(), j, ip
4557  END DO
4558  END SUBROUTINE mix_dp
4559 ! Differentiation of geopk in forward (tangent) mode:
4560 ! variations of useful results: peln gz pkz pe pk
4561 ! with respect to varying inputs: peln gz delp pkz pe pk pt
4562  SUBROUTINE geopk_tlm(ptop, pe, pe_tl, peln, peln_tl, delp, delp_tl, pk&
4563 & , pk_tl, gz, gz_tl, hs, pt, pt_tl, q_con, pkz, pkz_tl, km, akap, cg&
4564 & , nested, computehalo, npx, npy, a2b_ord, bd)
4565  IMPLICIT NONE
4566  INTEGER, INTENT(IN) :: km, npx, npy, a2b_ord
4567  REAL, INTENT(IN) :: akap, ptop
4568  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4569  REAL, INTENT(IN) :: hs(bd%isd:bd%ied, bd%jsd:bd%jed)
4570  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: pt&
4571 & , delp
4572  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
4573 & pt_tl, delp_tl
4574  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
4575 & q_con
4576  LOGICAL, INTENT(IN) :: cg, nested, computehalo
4577 ! !OUTPUT PARAMETERS
4578  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1), INTENT(OUT) :: &
4579 & gz, pk
4580  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1), INTENT(OUT) :: &
4581 & gz_tl, pk_tl
4582  REAL, INTENT(OUT) :: pe(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
4583  REAL, INTENT(OUT) :: pe_tl(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
4584 ! ln(pe)
4585  REAL, INTENT(OUT) :: peln(bd%is:bd%ie, km+1, bd%js:bd%je)
4586  REAL, INTENT(OUT) :: peln_tl(bd%is:bd%ie, km+1, bd%js:bd%je)
4587  REAL, INTENT(OUT) :: pkz(bd%is:bd%ie, bd%js:bd%je, km)
4588  REAL, INTENT(OUT) :: pkz_tl(bd%is:bd%ie, bd%js:bd%je, km)
4589 ! !DESCRIPTION:
4590 ! Calculates geopotential and pressure to the kappa.
4591 ! Local:
4592  REAL :: peg(bd%isd:bd%ied, km+1)
4593  REAL :: pkg(bd%isd:bd%ied, km+1)
4594  REAL(kind=8) :: p1d(bd%isd:bd%ied)
4595  REAL(kind=8) :: p1d_tl(bd%isd:bd%ied)
4596  REAL(kind=8) :: g1d(bd%isd:bd%ied)
4597  REAL(kind=8) :: g1d_tl(bd%isd:bd%ied)
4598  REAL :: logp(bd%isd:bd%ied)
4599  REAL :: logp_tl(bd%isd:bd%ied)
4600  INTEGER :: i, j, k
4601  INTEGER :: ifirst, ilast
4602  INTEGER :: jfirst, jlast
4603  INTEGER :: is, ie, js, je
4604  INTEGER :: isd, ied, jsd, jed
4605  INTRINSIC max
4606  INTRINSIC min
4607  INTRINSIC log
4608  INTRINSIC exp
4609  INTEGER :: max1
4610  INTEGER :: max2
4611  INTEGER :: min1
4612  INTEGER :: min2
4613  is = bd%is
4614  ie = bd%ie
4615  js = bd%js
4616  je = bd%je
4617  isd = bd%isd
4618  ied = bd%ied
4619  jsd = bd%jsd
4620  jed = bd%jed
4621  IF ((.NOT.cg .AND. a2b_ord .EQ. 4) .OR. (nested .AND. (.NOT.cg))) &
4622 & THEN
4623 ! D-Grid
4624  ifirst = is - 2
4625  ilast = ie + 2
4626  jfirst = js - 2
4627  jlast = je + 2
4628  ELSE
4629  ifirst = is - 1
4630  ilast = ie + 1
4631  jfirst = js - 1
4632  jlast = je + 1
4633  END IF
4634  IF (nested .AND. computehalo) THEN
4635  IF (is .EQ. 1) ifirst = isd
4636  IF (ie .EQ. npx - 1) ilast = ied
4637  IF (js .EQ. 1) jfirst = jsd
4638  IF (je .EQ. npy - 1) THEN
4639  jlast = jed
4640  g1d_tl = 0.0_8
4641  logp_tl = 0.0
4642  p1d_tl = 0.0_8
4643  ELSE
4644  g1d_tl = 0.0_8
4645  logp_tl = 0.0
4646  p1d_tl = 0.0_8
4647  END IF
4648  ELSE
4649  g1d_tl = 0.0_8
4650  logp_tl = 0.0
4651  p1d_tl = 0.0_8
4652  END IF
4653 !$OMP parallel do default(none) shared(jfirst,jlast,ifirst,ilast,pk,km,gz,hs,ptop,ptk, &
4654 !$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz,q_con) &
4655 !$OMP private(peg, pkg, p1d, g1d, logp)
4656  DO j=jfirst,jlast
4657  DO i=ifirst,ilast
4658  p1d_tl(i) = 0.0_8
4659  p1d(i) = ptop
4660  pk_tl(i, j, 1) = 0.0
4661  pk(i, j, 1) = ptk
4662  g1d_tl(i) = 0.0_8
4663  g1d(i) = hs(i, j)
4664  gz_tl(i, j, km+1) = 0.0
4665  gz(i, j, km+1) = hs(i, j)
4666  END DO
4667  IF (j .GE. js .AND. j .LE. je) THEN
4668  DO i=is,ie
4669  peln_tl(i, 1, j) = 0.0
4670  peln(i, 1, j) = peln1
4671  END DO
4672  END IF
4673  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
4674  IF (ifirst .LT. is - 1) THEN
4675  max1 = is - 1
4676  ELSE
4677  max1 = ifirst
4678  END IF
4679  IF (ilast .GT. ie + 1) THEN
4680  min1 = ie + 1
4681  ELSE
4682  min1 = ilast
4683  END IF
4684  DO i=max1,min1
4685  pe_tl(i, 1, j) = 0.0
4686  pe(i, 1, j) = ptop
4687  END DO
4688  END IF
4689 ! Top down
4690  DO k=2,km+1
4691  DO i=ifirst,ilast
4692  p1d_tl(i) = p1d_tl(i) + delp_tl(i, j, k-1)
4693  p1d(i) = p1d(i) + delp(i, j, k-1)
4694  logp_tl(i) = p1d_tl(i)/p1d(i)
4695  logp(i) = log(p1d(i))
4696  pk_tl(i, j, k) = akap*logp_tl(i)*exp(akap*logp(i))
4697  pk(i, j, k) = exp(akap*logp(i))
4698  END DO
4699  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
4700  IF (ifirst .LT. is - 1) THEN
4701  max2 = is - 1
4702  ELSE
4703  max2 = ifirst
4704  END IF
4705  IF (ilast .GT. ie + 1) THEN
4706  min2 = ie + 1
4707  ELSE
4708  min2 = ilast
4709  END IF
4710  DO i=max2,min2
4711  pe_tl(i, k, j) = p1d_tl(i)
4712  pe(i, k, j) = p1d(i)
4713  END DO
4714  IF (j .GE. js .AND. j .LE. je) THEN
4715  DO i=is,ie
4716  peln_tl(i, k, j) = logp_tl(i)
4717  peln(i, k, j) = logp(i)
4718  END DO
4719  END IF
4720  END IF
4721  END DO
4722 ! Bottom up
4723  DO k=km,1,-1
4724  DO i=ifirst,ilast
4725  g1d_tl(i) = g1d_tl(i) + cp_air*(pt_tl(i, j, k)*(pk(i, j, k+1)-&
4726 & pk(i, j, k))+pt(i, j, k)*(pk_tl(i, j, k+1)-pk_tl(i, j, k)))
4727  g1d(i) = g1d(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k&
4728 & ))
4729  gz_tl(i, j, k) = g1d_tl(i)
4730  gz(i, j, k) = g1d(i)
4731  END DO
4732  END DO
4733  IF (.NOT.cg .AND. j .GE. js .AND. j .LE. je) THEN
4734  DO k=1,km
4735  DO i=is,ie
4736  pkz_tl(i, j, k) = ((pk_tl(i, j, k+1)-pk_tl(i, j, k))*akap*(&
4737 & peln(i, k+1, j)-peln(i, k, j))-(pk(i, j, k+1)-pk(i, j, k))&
4738 & *akap*(peln_tl(i, k+1, j)-peln_tl(i, k, j)))/(akap*(peln(i&
4739 & , k+1, j)-peln(i, k, j)))**2
4740  pkz(i, j, k) = (pk(i, j, k+1)-pk(i, j, k))/(akap*(peln(i, k+&
4741 & 1, j)-peln(i, k, j)))
4742  END DO
4743  END DO
4744  END IF
4745  END DO
4746  END SUBROUTINE geopk_tlm
4747  SUBROUTINE geopk(ptop, pe, peln, delp, pk, gz, hs, pt, q_con, pkz, km&
4748 & , akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
4749  IMPLICIT NONE
4750  INTEGER, INTENT(IN) :: km, npx, npy, a2b_ord
4751  REAL, INTENT(IN) :: akap, ptop
4752  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4753  REAL, INTENT(IN) :: hs(bd%isd:bd%ied, bd%jsd:bd%jed)
4754  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: pt&
4755 & , delp
4756  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km), INTENT(IN) :: &
4757 & q_con
4758  LOGICAL, INTENT(IN) :: cg, nested, computehalo
4759 ! !OUTPUT PARAMETERS
4760  REAL, DIMENSION(bd%isd:bd%ied, bd%jsd:bd%jed, km+1), INTENT(OUT) :: &
4761 & gz, pk
4762  REAL, INTENT(OUT) :: pe(bd%is-1:bd%ie+1, km+1, bd%js-1:bd%je+1)
4763 ! ln(pe)
4764  REAL, INTENT(OUT) :: peln(bd%is:bd%ie, km+1, bd%js:bd%je)
4765  REAL, INTENT(OUT) :: pkz(bd%is:bd%ie, bd%js:bd%je, km)
4766 ! !DESCRIPTION:
4767 ! Calculates geopotential and pressure to the kappa.
4768 ! Local:
4769  REAL :: peg(bd%isd:bd%ied, km+1)
4770  REAL :: pkg(bd%isd:bd%ied, km+1)
4771  REAL(kind=8) :: p1d(bd%isd:bd%ied)
4772  REAL(kind=8) :: g1d(bd%isd:bd%ied)
4773  REAL :: logp(bd%isd:bd%ied)
4774  INTEGER :: i, j, k
4775  INTEGER :: ifirst, ilast
4776  INTEGER :: jfirst, jlast
4777  INTEGER :: is, ie, js, je
4778  INTEGER :: isd, ied, jsd, jed
4779  INTRINSIC max
4780  INTRINSIC min
4781  INTRINSIC log
4782  INTRINSIC exp
4783  INTEGER :: max1
4784  INTEGER :: max2
4785  INTEGER :: min1
4786  INTEGER :: min2
4787  is = bd%is
4788  ie = bd%ie
4789  js = bd%js
4790  je = bd%je
4791  isd = bd%isd
4792  ied = bd%ied
4793  jsd = bd%jsd
4794  jed = bd%jed
4795  IF ((.NOT.cg .AND. a2b_ord .EQ. 4) .OR. (nested .AND. (.NOT.cg))) &
4796 & THEN
4797 ! D-Grid
4798  ifirst = is - 2
4799  ilast = ie + 2
4800  jfirst = js - 2
4801  jlast = je + 2
4802  ELSE
4803  ifirst = is - 1
4804  ilast = ie + 1
4805  jfirst = js - 1
4806  jlast = je + 1
4807  END IF
4808  IF (nested .AND. computehalo) THEN
4809  IF (is .EQ. 1) ifirst = isd
4810  IF (ie .EQ. npx - 1) ilast = ied
4811  IF (js .EQ. 1) jfirst = jsd
4812  IF (je .EQ. npy - 1) jlast = jed
4813  END IF
4814 !$OMP parallel do default(none) shared(jfirst,jlast,ifirst,ilast,pk,km,gz,hs,ptop,ptk, &
4815 !$OMP js,je,is,ie,peln,peln1,pe,delp,akap,pt,CG,pkz,q_con) &
4816 !$OMP private(peg, pkg, p1d, g1d, logp)
4817  DO j=jfirst,jlast
4818  DO i=ifirst,ilast
4819  p1d(i) = ptop
4820  pk(i, j, 1) = ptk
4821  g1d(i) = hs(i, j)
4822  gz(i, j, km+1) = hs(i, j)
4823  END DO
4824  IF (j .GE. js .AND. j .LE. je) THEN
4825  DO i=is,ie
4826  peln(i, 1, j) = peln1
4827  END DO
4828  END IF
4829  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
4830  IF (ifirst .LT. is - 1) THEN
4831  max1 = is - 1
4832  ELSE
4833  max1 = ifirst
4834  END IF
4835  IF (ilast .GT. ie + 1) THEN
4836  min1 = ie + 1
4837  ELSE
4838  min1 = ilast
4839  END IF
4840  DO i=max1,min1
4841  pe(i, 1, j) = ptop
4842  END DO
4843  END IF
4844 ! Top down
4845  DO k=2,km+1
4846  DO i=ifirst,ilast
4847  p1d(i) = p1d(i) + delp(i, j, k-1)
4848  logp(i) = log(p1d(i))
4849  pk(i, j, k) = exp(akap*logp(i))
4850  END DO
4851  IF (j .GT. js - 2 .AND. j .LT. je + 2) THEN
4852  IF (ifirst .LT. is - 1) THEN
4853  max2 = is - 1
4854  ELSE
4855  max2 = ifirst
4856  END IF
4857  IF (ilast .GT. ie + 1) THEN
4858  min2 = ie + 1
4859  ELSE
4860  min2 = ilast
4861  END IF
4862  DO i=max2,min2
4863  pe(i, k, j) = p1d(i)
4864  END DO
4865  IF (j .GE. js .AND. j .LE. je) THEN
4866  DO i=is,ie
4867  peln(i, k, j) = logp(i)
4868  END DO
4869  END IF
4870  END IF
4871  END DO
4872 ! Bottom up
4873  DO k=km,1,-1
4874  DO i=ifirst,ilast
4875  g1d(i) = g1d(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k&
4876 & ))
4877  gz(i, j, k) = g1d(i)
4878  END DO
4879  END DO
4880  IF (.NOT.cg .AND. j .GE. js .AND. j .LE. je) THEN
4881  DO k=1,km
4882  DO i=is,ie
4883  pkz(i, j, k) = (pk(i, j, k+1)-pk(i, j, k))/(akap*(peln(i, k+&
4884 & 1, j)-peln(i, k, j)))
4885  END DO
4886  END DO
4887  END IF
4888  END DO
4889  END SUBROUTINE geopk
4890 ! Differentiation of del2_cubed in forward (tangent) mode:
4891 ! variations of useful results: q
4892 ! with respect to varying inputs: q
4893  SUBROUTINE del2_cubed_tlm(q, q_tl, cd, gridstruct, domain, npx, npy, &
4894 & km, nmax, bd)
4895  IMPLICIT NONE
4896 !---------------------------------------------------------------
4897 ! This routine is for filtering the omega field for the physics
4898 !---------------------------------------------------------------
4899  INTEGER, INTENT(IN) :: npx, npy, km, nmax
4900 ! cd = K * da_min; 0 < K < 0.25
4901  REAL(kind=r_grid), INTENT(IN) :: cd
4902  TYPE(FV_GRID_BOUNDS_TYPE), INTENT(IN) :: bd
4903  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km)
4904  REAL, INTENT(INOUT) :: q_tl(bd%isd:bd%ied, bd%jsd:bd%jed, km)
4905  TYPE(FV_GRID_TYPE), INTENT(IN), TARGET :: gridstruct
4906  TYPE(DOMAIN2D), INTENT(INOUT) :: domain
4907  REAL, PARAMETER :: r3=1./3.
4908  REAL :: fx(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy(bd%isd:bd%ied, bd%jsd&
4909 & :bd%jed+1)
4910  REAL :: fx_tl(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy_tl(bd%isd:bd%ied, &
4911 & bd%jsd:bd%jed+1)
4912  REAL :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
4913  INTEGER :: i, j, k, n, nt, ntimes
4914  INTEGER :: is, ie, js, je
4915  INTEGER :: isd, ied, jsd, jed
4916  INTRINSIC min
4917 !Local routine pointers
4918 ! real, pointer, dimension(:,:) :: rarea
4919 ! real, pointer, dimension(:,:) :: del6_u, del6_v
4920 ! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner
4921  is = bd%is
4922  ie = bd%ie
4923  js = bd%js
4924  je = bd%je
4925  isd = bd%isd
4926  ied = bd%ied
4927  jsd = bd%jsd
4928  jed = bd%jed
4929  IF (3 .GT. nmax) THEN
4930  ntimes = nmax
4931  ELSE
4932  ntimes = 3
4933  END IF
4934  CALL timing_on('COMM_TOTAL')
4935  CALL mpp_update_domains_tlm(q, q_tl, domain, complete=.true.)
4936  CALL timing_off('COMM_TOTAL')
4937  fx_tl = 0.0
4938  fy_tl = 0.0
4939  DO n=1,ntimes
4940  nt = ntimes - n
4941 !$OMP parallel do default(none) shared(km,q,is,ie,js,je,npx,npy, &
4942 !$OMP nt,isd,jsd,gridstruct,bd, &
4943 !$OMP cd) &
4944 !$OMP private(fx, fy)
4945  DO k=1,km
4946  IF (gridstruct%sw_corner) THEN
4947  q_tl(1, 1, k) = r3*(q_tl(1, 1, k)+q_tl(0, 1, k)+q_tl(1, 0, k))
4948  q(1, 1, k) = (q(1, 1, k)+q(0, 1, k)+q(1, 0, k))*r3
4949  q_tl(0, 1, k) = q_tl(1, 1, k)
4950  q(0, 1, k) = q(1, 1, k)
4951  q_tl(1, 0, k) = q_tl(1, 1, k)
4952  q(1, 0, k) = q(1, 1, k)
4953  END IF
4954  IF (gridstruct%se_corner) THEN
4955  q_tl(ie, 1, k) = r3*(q_tl(ie, 1, k)+q_tl(npx, 1, k)+q_tl(ie, 0&
4956 & , k))
4957  q(ie, 1, k) = (q(ie, 1, k)+q(npx, 1, k)+q(ie, 0, k))*r3
4958  q_tl(npx, 1, k) = q_tl(ie, 1, k)
4959  q(npx, 1, k) = q(ie, 1, k)
4960  q_tl(ie, 0, k) = q_tl(ie, 1, k)
4961  q(ie, 0, k) = q(ie, 1, k)
4962  END IF
4963  IF (gridstruct%ne_corner) THEN
4964  q_tl(ie, je, k) = r3*(q_tl(ie, je, k)+q_tl(npx, je, k)+q_tl(ie&
4965 & , npy, k))
4966  q(ie, je, k) = (q(ie, je, k)+q(npx, je, k)+q(ie, npy, k))*r3
4967  q_tl(npx, je, k) = q_tl(ie, je, k)
4968  q(npx, je, k) = q(ie, je, k)
4969  q_tl(ie, npy, k) = q_tl(ie, je, k)
4970  q(ie, npy, k) = q(ie, je, k)
4971  END IF
4972  IF (gridstruct%nw_corner) THEN
4973  q_tl(1, je, k) = r3*(q_tl(1, je, k)+q_tl(0, je, k)+q_tl(1, npy&
4974 & , k))
4975  q(1, je, k) = (q(1, je, k)+q(0, je, k)+q(1, npy, k))*r3
4976  q_tl(0, je, k) = q_tl(1, je, k)
4977  q(0, je, k) = q(1, je, k)
4978  q_tl(1, npy, k) = q_tl(1, je, k)
4979  q(1, npy, k) = q(1, je, k)
4980  END IF
4981  IF (nt .GT. 0) CALL copy_corners_tlm(q(isd:ied, jsd:jed, k), &
4982 & q_tl(isd:ied, jsd:jed, k), npx, &
4983 & npy, 1, gridstruct%nested, bd, &
4984 & gridstruct%sw_corner, gridstruct%&
4985 & se_corner, gridstruct%nw_corner, &
4986 & gridstruct%ne_corner)
4987  DO j=js-nt,je+nt
4988  DO i=is-nt,ie+1+nt
4989  fx_tl(i, j) = gridstruct%del6_v(i, j)*(q_tl(i-1, j, k)-q_tl(&
4990 & i, j, k))
4991  fx(i, j) = gridstruct%del6_v(i, j)*(q(i-1, j, k)-q(i, j, k))
4992  END DO
4993  END DO
4994  IF (nt .GT. 0) CALL copy_corners_tlm(q(isd:ied, jsd:jed, k), &
4995 & q_tl(isd:ied, jsd:jed, k), npx, &
4996 & npy, 2, gridstruct%nested, bd, &
4997 & gridstruct%sw_corner, gridstruct%&
4998 & se_corner, gridstruct%nw_corner, &
4999 & gridstruct%ne_corner)
5000  DO j=js-nt,je+1+nt
5001  DO i=is-nt,ie+nt
5002  fy_tl(i, j) = gridstruct%del6_u(i, j)*(q_tl(i, j-1, k)-q_tl(&
5003 & i, j, k))
5004  fy(i, j) = gridstruct%del6_u(i, j)*(q(i, j-1, k)-q(i, j, k))
5005  END DO
5006  END DO
5007  DO j=js-nt,je+nt
5008  DO i=is-nt,ie+nt
5009  q_tl(i, j, k) = q_tl(i, j, k) + cd*gridstruct%rarea(i, j)*(&
5010 & fx_tl(i, j)-fx_tl(i+1, j)+fy_tl(i, j)-fy_tl(i, j+1))
5011  q(i, j, k) = q(i, j, k) + cd*gridstruct%rarea(i, j)*(fx(i, j&
5012 & )-fx(i+1, j)+fy(i, j)-fy(i, j+1))
5013  END DO
5014  END DO
5015  END DO
5016  END DO
5017  END SUBROUTINE del2_cubed_tlm
5018  SUBROUTINE del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, &
5019 & bd)
5020  IMPLICIT NONE
5021 !---------------------------------------------------------------
5022 ! This routine is for filtering the omega field for the physics
5023 !---------------------------------------------------------------
5024  INTEGER, INTENT(IN) :: npx, npy, km, nmax
5025 ! cd = K * da_min; 0 < K < 0.25
5026  REAL(kind=r_grid), INTENT(IN) :: cd
5027  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
5028  REAL, INTENT(INOUT) :: q(bd%isd:bd%ied, bd%jsd:bd%jed, km)
5029  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
5030  TYPE(domain2d), INTENT(INOUT) :: domain
5031  REAL, PARAMETER :: r3=1./3.
5032  REAL :: fx(bd%isd:bd%ied+1, bd%jsd:bd%jed), fy(bd%isd:bd%ied, bd%jsd&
5033 & :bd%jed+1)
5034  REAL :: q2(bd%isd:bd%ied, bd%jsd:bd%jed)
5035  INTEGER :: i, j, k, n, nt, ntimes
5036  INTEGER :: is, ie, js, je
5037  INTEGER :: isd, ied, jsd, jed
5038  INTRINSIC min
5039 !Local routine pointers
5040 ! real, pointer, dimension(:,:) :: rarea
5041 ! real, pointer, dimension(:,:) :: del6_u, del6_v
5042 ! logical, pointer :: sw_corner, se_corner, ne_corner, nw_corner
5043  is = bd%is
5044  ie = bd%ie
5045  js = bd%js
5046  je = bd%je
5047  isd = bd%isd
5048  ied = bd%ied
5049  jsd = bd%jsd
5050  jed = bd%jed
5051  IF (3 .GT. nmax) THEN
5052  ntimes = nmax
5053  ELSE
5054  ntimes = 3
5055  END IF
5056  CALL timing_on('COMM_TOTAL')
5057  CALL mpp_update_domains(q, domain, complete=.true.)
5058  CALL timing_off('COMM_TOTAL')
5059  DO n=1,ntimes
5060  nt = ntimes - n
5061 !$OMP parallel do default(none) shared(km,q,is,ie,js,je,npx,npy, &
5062 !$OMP nt,isd,jsd,gridstruct,bd, &
5063 !$OMP cd) &
5064 !$OMP private(fx, fy)
5065  DO k=1,km
5066  IF (gridstruct%sw_corner) THEN
5067  q(1, 1, k) = (q(1, 1, k)+q(0, 1, k)+q(1, 0, k))*r3
5068  q(0, 1, k) = q(1, 1, k)
5069  q(1, 0, k) = q(1, 1, k)
5070  END IF
5071  IF (gridstruct%se_corner) THEN
5072  q(ie, 1, k) = (q(ie, 1, k)+q(npx, 1, k)+q(ie, 0, k))*r3
5073  q(npx, 1, k) = q(ie, 1, k)
5074  q(ie, 0, k) = q(ie, 1, k)
5075  END IF
5076  IF (gridstruct%ne_corner) THEN
5077  q(ie, je, k) = (q(ie, je, k)+q(npx, je, k)+q(ie, npy, k))*r3
5078  q(npx, je, k) = q(ie, je, k)
5079  q(ie, npy, k) = q(ie, je, k)
5080  END IF
5081  IF (gridstruct%nw_corner) THEN
5082  q(1, je, k) = (q(1, je, k)+q(0, je, k)+q(1, npy, k))*r3
5083  q(0, je, k) = q(1, je, k)
5084  q(1, npy, k) = q(1, je, k)
5085  END IF
5086  IF (nt .GT. 0) CALL copy_corners(q(isd:ied, jsd:jed, k), npx, &
5087 & npy, 1, gridstruct%nested, bd, &
5088 & gridstruct%sw_corner, gridstruct%&
5089 & se_corner, gridstruct%nw_corner, &
5090 & gridstruct%ne_corner)
5091  DO j=js-nt,je+nt
5092  DO i=is-nt,ie+1+nt
5093  fx(i, j) = gridstruct%del6_v(i, j)*(q(i-1, j, k)-q(i, j, k))
5094  END DO
5095  END DO
5096  IF (nt .GT. 0) CALL copy_corners(q(isd:ied, jsd:jed, k), npx, &
5097 & npy, 2, gridstruct%nested, bd, &
5098 & gridstruct%sw_corner, gridstruct%&
5099 & se_corner, gridstruct%nw_corner, &
5100 & gridstruct%ne_corner)
5101  DO j=js-nt,je+1+nt
5102  DO i=is-nt,ie+nt
5103  fy(i, j) = gridstruct%del6_u(i, j)*(q(i, j-1, k)-q(i, j, k))
5104  END DO
5105  END DO
5106  DO j=js-nt,je+nt
5107  DO i=is-nt,ie+nt
5108  q(i, j, k) = q(i, j, k) + cd*gridstruct%rarea(i, j)*(fx(i, j&
5109 & )-fx(i+1, j)+fy(i, j)-fy(i, j+1))
5110  END DO
5111  END DO
5112  END DO
5113  END DO
5114  END SUBROUTINE del2_cubed
5115  SUBROUTINE init_ijk_mem(i1, i2, j1, j2, km, array, var)
5116  IMPLICIT NONE
5117  INTEGER, INTENT(IN) :: i1, i2, j1, j2, km
5118  REAL, INTENT(INOUT) :: array(i1:i2, j1:j2, km)
5119  REAL, INTENT(IN) :: var
5120  INTEGER :: i, j, k
5121 !$OMP parallel do default(none) shared(i1,i2,j1,j2,km,array,var)
5122  DO k=1,km
5123  DO j=j1,j2
5124  DO i=i1,i2
5125  array(i, j, k) = var
5126  END DO
5127  END DO
5128  END DO
5129  END SUBROUTINE init_ijk_mem
5130  SUBROUTINE rayleigh_fast(dt, npx, npy, npz, pfull, tau, u, v, w, ptop&
5131 & , hydrostatic, rf_cutoff, bd)
5132  IMPLICIT NONE
5133 ! Simple "inline" version of the Rayleigh friction
5134  REAL, INTENT(IN) :: dt
5135 ! time scale (days)
5136  REAL, INTENT(IN) :: tau
5137  REAL, INTENT(IN) :: ptop, rf_cutoff
5138  INTEGER, INTENT(IN) :: npx, npy, npz
5139  REAL, DIMENSION(npz), INTENT(IN) :: pfull
5140  LOGICAL, INTENT(IN) :: hydrostatic
5141  TYPE(fv_grid_bounds_type), INTENT(IN) :: bd
5142 ! D grid zonal wind (m/s)
5143  REAL, INTENT(INOUT) :: u(bd%isd:bd%ied, bd%jsd:bd%jed+1, npz)
5144 ! D grid meridional wind (m/s)
5145  REAL, INTENT(INOUT) :: v(bd%isd:bd%ied+1, bd%jsd:bd%jed, npz)
5146 ! cell center vertical wind (m/s)
5147  REAL, INTENT(INOUT) :: w(bd%isd:, bd%jsd:, :)
5148 !
5149  REAL(kind=r_grid) :: rff(npz)
5150  REAL, PARAMETER :: sday=86400.
5151  REAL :: tau0
5152  INTEGER :: i, j, k
5153  INTEGER :: is, ie, js, je
5154  INTEGER :: isd, ied, jsd, jed
5155  REAL :: rf(npz)
5156  INTRINSIC log
5157  INTRINSIC sin
5158  REAL :: arg1
5159  is = bd%is
5160  ie = bd%ie
5161  js = bd%js
5162  je = bd%je
5163  isd = bd%isd
5164  ied = bd%ied
5165  jsd = bd%jsd
5166  jed = bd%jed
5167  IF (.NOT.rff_initialized) THEN
5168  tau0 = tau*sday
5169 !allocate( rf(npz) )
5170  rf(:) = 1.
5171  IF (is_master()) WRITE(6, *) &
5172 & 'Fast Rayleigh friction E-folding time (days):'
5173  DO k=1,npz
5174  IF (pfull(k) .LT. rf_cutoff) THEN
5175  arg1 = 0.5*pi*log(rf_cutoff/pfull(k))/log(rf_cutoff/ptop)
5176  rff(k) = dt/tau0*sin(arg1)**2
5177 ! Re-FACTOR rf
5178 !if( is_master() ) write(6,*) k, 0.01*pfull(k), dt/(rff(k)*sday)
5179  kmax = k
5180  rff(k) = 1.d0/(1.0d0+rff(k))
5181  rf(k) = rff(k)
5182  ELSE
5183  GOTO 100
5184  END IF
5185  END DO
5186  100 rff_initialized = .true.
5187  END IF
5188 !$OMP parallel do default(none) shared(is,ie,js,je,kmax,pfull,rf_cutoff,w,rf,u,v,hydrostatic)
5189  DO k=1,kmax
5190  IF (pfull(k) .LT. rf_cutoff) THEN
5191  DO j=js,je+1
5192  DO i=is,ie
5193  u(i, j, k) = rf(k)*u(i, j, k)
5194  END DO
5195  END DO
5196  DO j=js,je
5197  DO i=is,ie+1
5198  v(i, j, k) = rf(k)*v(i, j, k)
5199  END DO
5200  END DO
5201  IF (.NOT.hydrostatic) THEN
5202  DO j=js,je
5203  DO i=is,ie
5204  w(i, j, k) = rf(k)*w(i, j, k)
5205  END DO
5206  END DO
5207  END IF
5208  END IF
5209  END DO
5210  END SUBROUTINE rayleigh_fast
5211 
5212 end module dyn_core_tlm_mod
5213 
dyn_core_tlm_mod::grad1_p_update_tlm
subroutine grad1_p_update_tlm(divg2, divg2_tl, u, u_tl, v, v_tl, pk, pk_tl, gz, gz_tl, du, du_tl, dv, dv_tl, dt, ng, gridstruct, bd, npx, npy, npz, ptop, beta, a2b_ord)
Definition: dyn_core_tlm.F90:4166
boundary_tlm_mod
Definition: boundary_tlm.F90:20
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
constants_mod
Definition: constants.F90:24
constants_mod::radius
real, parameter, public radius
Radius of the Earth [m].
Definition: constants.F90:72
mpp_parameter_mod
Definition: mpp_parameter.F90:19
dyn_core_tlm_mod
Definition: dyn_core_tlm.F90:20
dyn_core_tlm_mod::kmax
integer kmax
Definition: dyn_core_tlm.F90:79
a2b_edge_tlm_mod
Definition: a2b_edge_tlm.F90:20
dyn_core_tlm_mod::pe_halo_tlm
subroutine pe_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, pe_tl, delp, delp_tl)
Definition: dyn_core_tlm.F90:2898
boundary_tlm_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_tlm.F90:1459
fv_mp_tlm_mod
Definition: fv_mp_tlm.F90:20
dyn_core_tlm_mod::rff_initialized
logical rff_initialized
Definition: dyn_core_tlm.F90:78
dyn_core_tlm_mod::d3_damp
real d3_damp
Definition: dyn_core_tlm.F90:70
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
fv_arrays_nlm_mod::fv_diag_type
Definition: fv_arrays_nlm.F90:54
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
fv_nwp_nudge_nlm_mod
Definition: fv_nudge_nlm.F90:26
dyn_core_tlm_mod::p_grad_c
subroutine p_grad_c(dt2, npz, delpc, pkc, gz, uc, vc, bd, rdxc, rdyc, hydrostatic)
Definition: dyn_core_tlm.F90:3281
mpp_parameter_mod::corner
integer, parameter, public corner
Definition: mpp_parameter.F90:95
test_cases_nlm_mod::case9_forcing2
subroutine, public case9_forcing2(phis)
Definition: test_cases_nlm.F90:4122
fv_mp_tlm_mod::mpp_get_boundary_tlm
Definition: fv_mp_tlm.F90:120
dyn_core_tlm_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_tlm.F90:1485
a2b_edge_tlm_mod::a2b_ord4
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_tlm.F90:50
dyn_core_tlm_mod::pk3_halo
subroutine pk3_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, delp)
Definition: dyn_core_tlm.F90:2718
fv_update_phys_nlm_mod
Definition: fv_update_phys_nlm.F90:20
dyn_core_tlm_mod::pe_halo
subroutine pe_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pe, delp)
Definition: dyn_core_tlm.F90:2936
dyn_core_tlm_mod::del2_cubed
subroutine, public del2_cubed(q, cd, gridstruct, domain, npx, npy, km, nmax, bd)
Definition: dyn_core_tlm.F90:5036
constants_mod::rdgas
real, parameter, public rdgas
Gas constant for dry air [J/kg/deg].
Definition: constants.F90:77
dyn_core_tlm_mod::del2_cubed_tlm
subroutine, public del2_cubed_tlm(q, q_tl, cd, gridstruct, domain, npx, npy, km, nmax, bd)
Definition: dyn_core_tlm.F90:4911
fv_mp_tlm_mod::mpp_update_domains_tlm
Definition: fv_mp_tlm.F90:109
tp_core_tlm_mod
Definition: tp_core_tlm.F90:20
diag_manager_mod::send_data
Definition: diag_manager.F90:357
mpp_mod
Definition: mpp.F90:39
nh_core_tlm_mod
Definition: nh_core_tlm.F90:20
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
fv_mp_tlm_mod::complete_group_halo_update
subroutine, public complete_group_halo_update(group, group_tl, domain)
Definition: fv_mp_tlm.F90:815
sw_core_tlm_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_tlm.F90:2542
dyn_core_tlm_mod::peln1
real peln1
Definition: dyn_core_tlm.F90:69
if
l_size ! loop over number of fields ke do je do ie to je n if(.NOT. d_comm%R_do_buf(list)) cycle from_pe
dyn_core_tlm_mod::split_p_grad_tlm
subroutine split_p_grad_tlm(u, u_tl, v, v_tl, pp, pp_tl, gz, gz_tl, du, du_tl, dv, dv_tl, delp, delp_tl, pk, pk_tl, beta, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_tlm.F90:3595
dyn_core_tlm_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_tlm.F90:4296
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_mp_tlm_mod::start_group_halo_update_tlm
Definition: fv_mp_tlm.F90:64
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
dyn_core_tlm_mod::rayleigh_fast
subroutine rayleigh_fast(dt, npx, npy, npz, pfull, tau, u, v, w, ptop, hydrostatic, rf_cutoff, bd)
Definition: dyn_core_tlm.F90:5148
dyn_core_tlm_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_tlm.F90:4765
constants_mod::pi
real, parameter, public pi
Ratio of circle circumference to diameter [N/A].
Definition: constants.F90:74
dyn_core_tlm_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_tlm.F90:4037
dyn_core_tlm_mod::one_grad_p_tlm
subroutine one_grad_p_tlm(u, u_tl, v, v_tl, pk, pk_tl, gz, gz_tl, divg2, divg2_tl, delp, delp_tl, dt, ng, gridstruct, bd, npx, npy, npz, ptop, hydrostatic, a2b_ord, d_ext)
Definition: dyn_core_tlm.F90:3870
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
dyn_core_tlm_mod::pln_halo
subroutine pln_halo(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3, delp)
Definition: dyn_core_tlm.F90:2847
dyn_core_tlm_mod::dyn_core_tlm
subroutine, public dyn_core_tlm(npx, npy, npz, ng, sphum, nq, bdt, n_split, zvir, cp, akap, cappa, grav, hydrostatic, u, u_tl, v, v_tl, w, w_tl, delz, delz_tl, pt, pt_tl, q, q_tl, delp, delp_tl, pe, pe_tl, pk, pk_tl, phis, ws, ws_tl, omga, omga_tl, ptop, pfull, ua, ua_tl, va, va_tl, uc, uc_tl, vc, vc_tl, mfx, mfx_tl, mfy, mfy_tl, cx, cx_tl, cy, cy_tl, pkz, pkz_tl, peln, peln_tl, q_con, ak, bk, dpx, dpx_tl, ks, gridstruct, flagstruct, flagstructp, neststruct, idiag, bd, domain, init_step, i_pack, end_step, gz, gz_tl, pkc, pkc_tl, ptc, ptc_tl, crx, crx_tl, xfx, xfx_tl, cry, cry_tl, yfx, yfx_tl, divgd, divgd_tl, delpc, delpc_tl, ut, ut_tl, vt, vt_tl, zh, zh_tl, pk3, pk3_tl, du, du_tl, dv, dv_tl, time_total)
Definition: dyn_core_tlm.F90:104
dyn_core_tlm_mod::cnst_0p20
real(kind=r_grid), parameter cnst_0p20
Definition: dyn_core_tlm.F90:75
nh_core_tlm_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_tlm.F90:249
dyn_core_tlm_mod::p_grad_c_tlm
subroutine p_grad_c_tlm(dt2, npz, delpc, delpc_tl, pkc, pkc_tl, gz, gz_tl, uc, uc_tl, vc, vc_tl, bd, rdxc, rdyc, hydrostatic)
Definition: dyn_core_tlm.F90:3196
dyn_core_tlm_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_tlm.F90:3760
fv_timing_nlm_mod::timing_on
subroutine timing_on(blk_name)
Definition: fv_timing_nlm.F90:101
sw_core_tlm_mod::c_sw_tlm
subroutine, public c_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, wc, wc_tl, ut, ut_tl, vt, vt_tl, divg_d, divg_d_tl, nord, dt2, hydrostatic, dord4, bd, gridstruct, flagstruct)
Definition: sw_core_tlm.F90:91
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_tlm_mod::pln_halo_tlm
subroutine pln_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, pk3, pk3_tl, delp, delp_tl)
Definition: dyn_core_tlm.F90:2784
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
tp_core_tlm_mod::copy_corners
subroutine, public copy_corners(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_tlm.F90:2048
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
dyn_core_tlm_mod::pk3_halo_tlm
subroutine pk3_halo_tlm(is, ie, js, je, isd, ied, jsd, jed, npz, ptop, akap, pk3, pk3_tl, delp, delp_tl)
Definition: dyn_core_tlm.F90:2616
dyn_core_tlm_mod::init_ijk_mem
subroutine, public init_ijk_mem(i1, i2, j1, j2, km, array, var)
Definition: dyn_core_tlm.F90:5132
sw_core_tlm_mod
Definition: sw_core_tlm.F90:20
test_cases_nlm_mod
Definition: test_cases_nlm.F90:21
mpp_domains_mod::mpp_get_boundary
Definition: mpp_domains.F90:1900
fv_mp_tlm_mod::start_group_halo_update
Definition: fv_mp_tlm.F90:56
dyn_core_tlm_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_tlm.F90:3493
fv_arrays_nlm_mod::fv_nest_type
Definition: fv_arrays_nlm.F90:534
dyn_core_tlm_mod::mix_dp_tlm
subroutine mix_dp_tlm(hydrostatic, w, w_tl, delp, delp_tl, pt, pt_tl, km, ak, bk, cg, fv_debug, bd)
Definition: dyn_core_tlm.F90:4390
a2b_edge_tlm_mod::a2b_ord4_tlm
subroutine, public a2b_ord4_tlm(qin, qin_tl, qout, qout_tl, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_tlm.F90:548
max
#define max(a, b)
Definition: mosaic_util.h:33
boundary_tlm_mod::nested_grid_bc_apply_intt_tlm
subroutine, public nested_grid_bc_apply_intt_tlm(var_nest, var_nest_tl, istag, jstag, npx, npy, npz, bd, step, split, bc, bctype)
Definition: boundary_tlm.F90:1356
dyn_core_tlm_mod::nh_p_grad_tlm
subroutine nh_p_grad_tlm(u, u_tl, v, v_tl, pp, pp_tl, gz, gz_tl, delp, delp_tl, pk, pk_tl, dt, ng, gridstruct, bd, npx, npy, npz, use_logp)
Definition: dyn_core_tlm.F90:3343
boundary_tlm_mod::extrapolation_bc
subroutine, public extrapolation_bc(q, istag, jstag, npx, npy, bd, pd_in, debug_in)
Definition: boundary_tlm.F90:71
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
dyn_core_tlm_mod::adv_pe
subroutine adv_pe(ua, va, pem, om, gridstruct, bd, npx, npy, npz, ng)
Definition: dyn_core_tlm.F90:3098
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
fv_arrays_tlmadm_mod::fv_flags_pert_type
Definition: fv_arrays_tlmadm.F90:37
dyn_core_tlm_mod::adv_pe_tlm
subroutine adv_pe_tlm(ua, ua_tl, va, va_tl, pem, pem_tl, om, om_tl, gridstruct, bd, npx, npy, npz, ng)
Definition: dyn_core_tlm.F90:2967
nh_core_tlm_mod::riem_solver3_tlm
subroutine, public riem_solver3_tlm(ms, dt, is, ie, js, je, km, ng, isd, ied, jsd, jed, akap, cappa, cp, ptop, zs, q_con, w, w_tl, delz, delz_tl, pt, pt_tl, delp, delp_tl, zh, zh_tl, pe, pe_tl, ppe, ppe_tl, pk3, pk3_tl, pk, pk_tl, peln, peln_tl, ws, ws_tl, scale_m, p_fac, a_imp, use_logp, last_call, fp_out)
Definition: nh_core_tlm.F90:54
sw_core_tlm_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_tlm.F90:649
min
#define min(a, b)
Definition: mosaic_util.h:32
sw_core_tlm_mod::d_sw_tlm
subroutine, public d_sw_tlm(delpc, delpc_tl, delp, delp_tl, ptc, ptc_tl, pt, pt_tl, u, u_tl, v, v_tl, w, w_tl, uc, uc_tl, vc, vc_tl, ua, ua_tl, va, va_tl, divg_d, divg_d_tl, xflux, xflux_tl, yflux, yflux_tl, cx, cx_tl, cy, cy_tl, crx_adv, crx_adv_tl, cry_adv, cry_adv_tl, xfx_adv, xfx_adv_tl, yfx_adv, yfx_adv_tl, q_con, z_rat, z_rat_tl, kgb, heat_source, heat_source_tl, dpx, dpx_tl, zvir, sphum, nq, q, q_tl, 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_tlm.F90:1059
tp_core_tlm_mod::copy_corners_tlm
subroutine, public copy_corners_tlm(q, q_tl, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
Definition: tp_core_tlm.F90:2845
dyn_core_tlm_mod::rgrav
real rgrav
Definition: dyn_core_tlm.F90:69
dyn_core_tlm_mod::mix_dp
subroutine mix_dp(hydrostatic, w, delp, pt, km, ak, bk, cg, fv_debug, bd)
Definition: dyn_core_tlm.F90:4497
fv_diagnostics_nlm_mod
Definition: fv_diagnostics_nlm.F90:20
fv_diagnostics_nlm_mod::fv_time
type(time_type), public fv_time
Definition: fv_diagnostics_nlm.F90:61
dyn_core_tlm_mod::ptk
real ptk
Definition: dyn_core_tlm.F90:69
fv_arrays_nlm_mod::fv_grid_bounds_type
Definition: fv_arrays_nlm.F90:601
dyn_core_tlm_mod::geopk_tlm
subroutine geopk_tlm(ptop, pe, pe_tl, peln, peln_tl, delp, delp_tl, pk, pk_tl, gz, gz_tl, hs, pt, pt_tl, q_con, pkz, pkz_tl, km, akap, cg, nested, computehalo, npx, npy, a2b_ord, bd)
Definition: dyn_core_tlm.F90:4581
a2b_edge_tlm_mod::a2b_ord2_tlm
subroutine, public a2b_ord2_tlm(qin, qin_tl, qout, qout_tl, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_tlm.F90:1164
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175