FV3 Bundle
fv_mapz_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 ! SJL: Apr 12, 2012
21 ! This revision may actually produce rounding level differences due to the elimination of KS to compute
22 ! pressure level for remapping.
23 module fv_mapz_tlm_mod
24 
25  use constants_mod, only: radius, pi=>pi_8, rvgas, rdgas, grav, hlv, hlf, cp_air, cp_vapor
26  use tracer_manager_mod,only: get_tracer_index
27  use field_manager_mod, only: model_atmos
28  use fv_grid_utils_nlm_mod, only: ptop_min
29  use fv_grid_utils_tlm_mod, only: g_sum
30  use fv_grid_utils_tlm_mod, only: g_sum_tlm
31  use fv_fill_nlm_mod, only: fillz
32  use mpp_domains_mod, only: mpp_update_domains, domain2d
33  use mpp_mod, only: fatal, mpp_error, get_unit, mpp_root_pe, mpp_pe
34  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type
35  use fv_timing_nlm_mod, only: timing_on, timing_off
36  use fv_mp_nlm_mod, only: is_master
37  use fv_cmp_nlm_mod, only: qs_init, fv_sat_adj
38  use fv_diagnostics_nlm_mod, only: prt_mxm
39  use fv_arrays_tlmadm_mod, only: fpp
40 
41  implicit none
42  real, parameter:: consv_min= 0.001 ! below which no correction applies
43  real, parameter:: t_min= 184. ! below which applies stricter constraint
44  real, parameter:: r2=1./2., r0=0.0
45  real, parameter:: r3 = 1./3., r23 = 2./3., r12 = 1./12.
46  real, parameter:: cv_vap = 3.*rvgas ! 1384.5
47  real, parameter:: cv_air = cp_air - rdgas ! = rdgas * (7/2-1) = 2.5*rdgas=717.68
48 ! real, parameter:: c_ice = 2106. ! heat capacity of ice at 0.C
49  real, parameter:: c_ice = 1972. ! heat capacity of ice at -15.C
50  real, parameter:: c_liq = 4.1855e+3 ! GFS: heat capacity of water at 0C
51 ! real, parameter:: c_liq = 4218. ! ECMWF-IFS
52  real, parameter:: cp_vap = cp_vapor ! 1846.
53  real, parameter:: tice = 273.16
54 
55  real :: e_flux = 0.
56  private
57 
58  public compute_total_energy, lagrangian_to_eulerian, moist_cv, moist_cp, &
59  rst_remap, mappm, e_flux, map1_q2
60  public compute_total_energy_tlm, lagrangian_to_eulerian_tlm, &
61  map1_q2_tlm
62 
63 CONTAINS
64 ! Differentiation of lagrangian_to_eulerian in forward (tangent) mode:
65 ! variations of useful results: peln q u v w delp ua delz omga
66 ! te0_2d pkz pe pk ps pt te
67 ! with respect to varying inputs: ws peln q u v w delp ua delz
68 ! omga te0_2d pkz pe pk ps pt te
69  SUBROUTINE lagrangian_to_eulerian_tlm(last_step, consv, ps, ps_tl, pe&
70 & , pe_tl, delp, delp_tl, pkz, pkz_tl, pk, pk_tl, mdt, pdt, km, is, ie&
71 & , js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, u_tl, v, &
72 & v_tl, w, w_tl, delz, delz_tl, pt, pt_tl, q, q_tl, hs, r_vir, cp, &
73 & akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, peln_tl, &
74 & te0_2d, te0_2d_tl, ng, ua, ua_tl, va, omga, omga_tl, te, te_tl, ws, &
75 & ws_tl, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, &
76 & flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, &
77 & do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, &
78 & kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
79  IMPLICIT NONE
80 !$OMP end parallel
81  LOGICAL, INTENT(IN) :: last_step
82 ! remap time step
83  REAL, INTENT(IN) :: mdt
84 ! phys time step
85  REAL, INTENT(IN) :: pdt
86  INTEGER, INTENT(IN) :: km
87 ! number of tracers (including h2o)
88  INTEGER, INTENT(IN) :: nq
89  INTEGER, INTENT(IN) :: nwat
90 ! index for water vapor (specific humidity)
91  INTEGER, INTENT(IN) :: sphum
92  INTEGER, INTENT(IN) :: ng
93 ! starting & ending X-Dir index
94  INTEGER, INTENT(IN) :: is, ie, isd, ied
95 ! starting & ending Y-Dir index
96  INTEGER, INTENT(IN) :: js, je, jsd, jed
97 ! Mapping order for the vector winds
98  INTEGER, INTENT(IN) :: kord_mt
99 ! Mapping order/option for w
100  INTEGER, INTENT(IN) :: kord_wz
101 ! Mapping order for tracers
102  INTEGER, INTENT(IN) :: kord_tr(nq)
103 ! Mapping order for thermodynamics
104  INTEGER, INTENT(IN) :: kord_tm
105 ! Mapping order for the vector winds
106  INTEGER, INTENT(IN) :: kord_mt_pert
107 ! Mapping order/option for w
108  INTEGER, INTENT(IN) :: kord_wz_pert
109 ! Mapping order for tracers
110  INTEGER, INTENT(IN) :: kord_tr_pert(nq)
111 ! Mapping order for thermodynamics
112  INTEGER, INTENT(IN) :: kord_tm_pert
113 ! factor for TE conservation
114  REAL, INTENT(IN) :: consv
115  REAL, INTENT(IN) :: r_vir
116  REAL, INTENT(IN) :: cp
117  REAL, INTENT(IN) :: akap
118 ! surface geopotential
119  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
120  REAL, INTENT(INOUT) :: te0_2d(is:ie, js:je)
121  REAL, INTENT(INOUT) :: te0_2d_tl(is:ie, js:je)
122  REAL, INTENT(IN) :: ws(is:ie, js:je)
123  REAL, INTENT(IN) :: ws_tl(is:ie, js:je)
124  LOGICAL, INTENT(IN) :: do_sat_adj
125 ! fill negative tracers
126  LOGICAL, INTENT(IN) :: fill
127  LOGICAL, INTENT(IN) :: reproduce_sum
128  LOGICAL, INTENT(IN) :: do_omega, adiabatic, do_adiabatic_init
129  REAL, INTENT(IN) :: ptop
130  REAL, INTENT(IN) :: ak(km+1)
131  REAL, INTENT(IN) :: bk(km+1)
132  REAL, INTENT(IN) :: pfull(km)
133  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
134  TYPE(fv_flags_type), INTENT(INOUT) :: flagstruct
135  TYPE(domain2d), INTENT(INOUT) :: domain
136 ! !INPUT/OUTPUT
137 ! pe to the kappa
138  REAL, INTENT(INOUT) :: pk(is:ie, js:je, km+1)
139  REAL, INTENT(INOUT) :: pk_tl(is:ie, js:je, km+1)
140  REAL, INTENT(INOUT) :: q(isd:ied, jsd:jed, km, nq)
141  REAL, INTENT(INOUT) :: q_tl(isd:ied, jsd:jed, km, nq)
142 ! pressure thickness
143  REAL, INTENT(INOUT) :: delp(isd:ied, jsd:jed, km)
144  REAL, INTENT(INOUT) :: delp_tl(isd:ied, jsd:jed, km)
145 ! pressure at layer edges
146  REAL, INTENT(INOUT) :: pe(is-1:ie+1, km+1, js-1:je+1)
147  REAL, INTENT(INOUT) :: pe_tl(is-1:ie+1, km+1, js-1:je+1)
148 ! surface pressure
149  REAL, INTENT(INOUT) :: ps(isd:ied, jsd:jed)
150  REAL, INTENT(INOUT) :: ps_tl(isd:ied, jsd:jed)
151 ! u-wind will be ghosted one latitude to the north upon exit
152 ! u-wind (m/s)
153  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
154  REAL, INTENT(INOUT) :: u_tl(isd:ied, jsd:jed+1, km)
155 ! v-wind (m/s)
156  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
157  REAL, INTENT(INOUT) :: v_tl(isd:ied+1, jsd:jed, km)
158 ! vertical velocity (m/s)
159  REAL, INTENT(INOUT) :: w(isd:ied, jsd:jed, km)
160  REAL, INTENT(INOUT) :: w_tl(isd:ied, jsd:jed, km)
161 ! cp*virtual potential temperature
162  REAL, INTENT(INOUT) :: pt(isd:ied, jsd:jed, km)
163  REAL, INTENT(INOUT) :: pt_tl(isd:ied, jsd:jed, km)
164 ! as input; output: temperature
165  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz
166  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz_tl
167  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: q_con, cappa
168  LOGICAL, INTENT(IN) :: hydrostatic
169  LOGICAL, INTENT(IN) :: hybrid_z
170  LOGICAL, INTENT(IN) :: out_dt
171 ! u-wind (m/s) on physics grid
172  REAL, INTENT(INOUT) :: ua(isd:ied, jsd:jed, km)
173  REAL, INTENT(INOUT) :: ua_tl(isd:ied, jsd:jed, km)
174 ! v-wind (m/s) on physics grid
175  REAL, INTENT(INOUT) :: va(isd:ied, jsd:jed, km)
176 ! vertical press. velocity (pascal/sec)
177  REAL, INTENT(INOUT) :: omga(isd:ied, jsd:jed, km)
178  REAL, INTENT(INOUT) :: omga_tl(isd:ied, jsd:jed, km)
179 ! log(pe)
180  REAL, INTENT(INOUT) :: peln(is:ie, km+1, js:je)
181  REAL, INTENT(INOUT) :: peln_tl(is:ie, km+1, js:je)
182  REAL, INTENT(INOUT) :: dtdt(is:ie, js:je, km)
183 ! layer-mean pk for converting t to pt
184  REAL, INTENT(OUT) :: pkz(is:ie, js:je, km)
185  REAL, INTENT(OUT) :: pkz_tl(is:ie, js:je, km)
186  REAL, INTENT(OUT) :: te(isd:ied, jsd:jed, km)
187  REAL, INTENT(OUT) :: te_tl(isd:ied, jsd:jed, km)
188 ! Mass fluxes
189 ! X-dir Mass Flux
190  REAL, OPTIONAL, INTENT(INOUT) :: mfx(is:ie+1, js:je, km)
191 ! Y-dir Mass Flux
192  REAL, OPTIONAL, INTENT(INOUT) :: mfy(is:ie, js:je+1, km)
193 ! 0: remap T in logP
194  INTEGER, INTENT(IN) :: remap_option
195 ! 1: remap PT in P
196 ! 3: remap TE in logP with GMAO cubic
197 ! !DESCRIPTION:
198 !
199 ! !REVISION HISTORY:
200 ! SJL 03.11.04: Initial version for partial remapping
201 !
202 !-----------------------------------------------------------------------
203  REAL, DIMENSION(is:ie, js:je) :: te_2d, zsum0, zsum1, dpln
204  REAL, DIMENSION(is:ie, js:je) :: te_2d_tl, zsum0_tl, zsum1_tl
205  REAL, DIMENSION(is:ie, km) :: q2, dp2
206  REAL, DIMENSION(is:ie, km) :: q2_tl, dp2_tl
207  REAL, DIMENSION(is:ie, km+1) :: pe1, pe2, pk1, pk2, pn2, phis
208  REAL, DIMENSION(is:ie, km+1) :: pe1_tl, pe2_tl, pk1_tl, pk2_tl, &
209 & pn2_tl, phis_tl
210  REAL, DIMENSION(is:ie+1, km+1) :: pe0, pe3
211  REAL, DIMENSION(is:ie+1, km+1) :: pe0_tl, pe3_tl
212  REAL, DIMENSION(is:ie) :: gz, cvm, qv
213  REAL, DIMENSION(is:ie) :: gz_tl
214  REAL :: rcp, rg, tmp, tpe, rrg, bkh, dtmp, k1k, dlnp
215  REAL :: tmp_tl, tpe_tl, dtmp_tl, dlnp_tl
216  LOGICAL :: fast_mp_consv
217  INTEGER :: i, j, k
218  INTEGER :: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel&
219 & , iq, n, kmp, kp, k_next
220  LOGICAL :: remap_t, remap_pt, remap_te
221  INTEGER :: abs_kord_tm, abs_kord_tm_pert
222  INTEGER :: iep1, jep1, iedp1, jedp1
223  INTRINSIC abs
224  INTRINSIC log
225  INTRINSIC exp
226  INTRINSIC PRESENT
227  REAL :: abs0
228  REAL :: arg1
229  REAL :: arg1_tl
230  REAL :: arg2
231  REAL :: arg2_tl
232  REAL :: result1
233  REAL :: result1_tl
234 
235  REAL :: pt_tj(isd:ied, jsd:jed, km)
236  REAL :: q_tj(isd:ied, jsd:jed, km, nq)
237  REAL :: q2_tj(is:ie, km)
238  REAL :: delz_tj(isd:ied, jsd:jed, km)
239  REAL :: u_tj(isd:ied, jsd:jed+1, km)
240  REAL :: v_tj(isd:ied+1, jsd:jed, km)
241  REAL :: w_tj(isd:ied, jsd:jed, km)
242 
243  IF (kord_tm .GE. 0.) THEN
244  abs_kord_tm = kord_tm
245  ELSE
246  abs_kord_tm = -kord_tm
247  END IF
248  IF (kord_tm_pert .GE. 0.) THEN
249  abs_kord_tm_pert = kord_tm_pert
250  ELSE
251  abs_kord_tm_pert = -kord_tm_pert
252  END IF
253  iep1 = ie + 1
254  jep1 = je + 1
255  iedp1 = ied + 1
256  jedp1 = jed + 1
257  remap_t = .false.
258  remap_pt = .false.
259  remap_te = .false.
260  SELECT CASE (remap_option)
261  CASE (0)
262  remap_t = .true.
263  CASE (1)
264  remap_pt = .true.
265  CASE (2)
266  remap_te = .true.
267  CASE DEFAULT
268  print*, ' INVALID REMAPPING OPTION '
269  stop
270  END SELECT
271  IF (is_master() .AND. flagstruct%fv_debug) THEN
272  print*, ''
273  SELECT CASE (remap_option)
274  CASE (0)
275  print*, ' REMAPPING T in logP '
276  CASE (1)
277  print*, ' REMAPPING PT in P'
278  CASE (2)
279  print*, ' REMAPPING TE in logP with GMAO cubic'
280  END SELECT
281  print*, ' REMAPPING CONSV: ', consv
282  print*, ' REMAPPING CONSV_MIN: ', consv_min
283  print*, ''
284  END IF
285  IF (flagstruct%fv_debug) CALL prt_mxm('remap-0 PT', pt, is, ie, js&
286 & , je, ng, km, 1., gridstruct%area_64&
287 & , domain)
288 ! akap / (1.-akap) = rg/Cv=0.4
289  k1k = rdgas/cv_air
290  rg = rdgas
291  rcp = 1./cp
292  rrg = -(rdgas/grav)
293  IF (fpp%fpp_mapl_mode) THEN
294  liq_wat = 2
295  ice_wat = 3
296  rainwat = -1
297  snowwat = -1
298  graupel = -1
299  cld_amt = -1
300  ELSE
301  liq_wat = get_tracer_index(model_atmos, 'liq_wat')
302  ice_wat = get_tracer_index(model_atmos, 'ice_wat')
303  rainwat = get_tracer_index(model_atmos, 'rainwat')
304  snowwat = get_tracer_index(model_atmos, 'snowwat')
305  graupel = get_tracer_index(model_atmos, 'graupel')
306  cld_amt = get_tracer_index(model_atmos, 'cld_amt')
307  END IF
308  IF (do_sat_adj) THEN
309  fast_mp_consv = .NOT.do_adiabatic_init .AND. consv .GT. consv_min
310  DO k=1,km
311  kmp = k
312  IF (pfull(k) .GT. 10.e2) EXIT
313  END DO
314  CALL qs_init(kmp)
315  phis_tl = 0.0
316  pe0_tl = 0.0
317  pe1_tl = 0.0
318  pe2_tl = 0.0
319  pe3_tl = 0.0
320  dp2_tl = 0.0
321  q2_tl = 0.0
322  pn2_tl = 0.0
323  pk1_tl = 0.0
324  pk2_tl = 0.0
325  ELSE
326  phis_tl = 0.0
327  pe0_tl = 0.0
328  pe1_tl = 0.0
329  pe2_tl = 0.0
330  pe3_tl = 0.0
331  dp2_tl = 0.0
332  q2_tl = 0.0
333  pn2_tl = 0.0
334  pk1_tl = 0.0
335  pk2_tl = 0.0
336  END IF
337 !$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, &
338 !$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, &
339 !$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, &
340 !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, &
341 !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, &
342 !$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,ua) &
343 !$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, &
344 !$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2)
345  DO j=js,je+1
346  DO k=1,km+1
347  DO i=is,ie
348  pe1_tl(i, k) = pe_tl(i, k, j)
349  pe1(i, k) = pe(i, k, j)
350  END DO
351  END DO
352  DO i=is,ie
353  pe2_tl(i, 1) = 0.0
354  pe2(i, 1) = ptop
355  pe2_tl(i, km+1) = pe_tl(i, km+1, j)
356  pe2(i, km+1) = pe(i, km+1, j)
357  END DO
358 !(j < je+1)
359  IF (j .NE. je + 1) THEN
360  IF (remap_t) THEN
361 ! hydro test
362 ! Remap T in logP
363 ! Note: pt at this stage is Theta_v
364  IF (hydrostatic) THEN
365 ! Transform virtual pt to virtual Temp
366  DO k=1,km
367  DO i=is,ie
368  pt_tl(i, j, k) = ((pt_tl(i, j, k)*(pk(i, j, k+1)-pk(i, j&
369 & , k))+pt(i, j, k)*(pk_tl(i, j, k+1)-pk_tl(i, j, k)))*&
370 & akap*(peln(i, k+1, j)-peln(i, k, j))-pt(i, j, k)*(pk(i&
371 & , j, k+1)-pk(i, j, k))*akap*(peln_tl(i, k+1, j)-&
372 & peln_tl(i, k, j)))/(akap*(peln(i, k+1, j)-peln(i, k, j&
373 & )))**2
374  pt(i, j, k) = pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k))/(&
375 & akap*(peln(i, k+1, j)-peln(i, k, j)))
376  END DO
377  END DO
378  ELSE
379 ! Transform "density pt" to "density temp"
380  DO k=1,km
381  DO i=is,ie
382  arg1_tl = (rrg*delp_tl(i, j, k)*delz(i, j, k)-rrg*delp(i&
383 & , j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2&
384 & + rrg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
385  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
386  arg2_tl = k1k*arg1_tl/arg1
387  arg2 = k1k*log(arg1)
388  pt_tl(i, j, k) = pt_tl(i, j, k)*exp(arg2) + pt(i, j, k)*&
389 & arg2_tl*exp(arg2)
390  pt(i, j, k) = pt(i, j, k)*exp(arg2)
391  END DO
392  END DO
393  END IF
394  ELSE IF (.NOT.remap_pt) THEN
395 ! Using dry pressure for the definition of the virtual potential temperature
396 ! pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)* &
397 ! pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
398 ! Remap PT in P
399 ! pt is already virtual PT
400  IF (remap_te) THEN
401 ! Remap TE in logP
402 ! Transform virtual pt to total energy
403  CALL pkez_tlm(km, is, ie, js, je, j, pe, pk, pk_tl, akap, &
404 & peln, peln_tl, pkz, pkz_tl, ptop)
405 ! Compute cp*T + KE
406  DO k=1,km
407  DO i=is,ie
408  te_tl(i, j, k) = 0.25*gridstruct%rsin2(i, j)*(2*u(i, j, &
409 & k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(i&
410 & , j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k)-&
411 & gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl(i, j+1, k&
412 & ))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+1, k))&
413 & *(v_tl(i, j, k)+v_tl(i+1, j, k)))) + cp_air*(pt_tl(i, &
414 & j, k)*pkz(i, j, k)+pt(i, j, k)*pkz_tl(i, j, k))
415  te(i, j, k) = 0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2&
416 & +u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j&
417 & , k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
418 & gridstruct%cosa_s(i, j)) + cp_air*pt(i, j, k)*pkz(i, j&
419 & , k)
420  END DO
421  END DO
422  END IF
423  END IF
424  IF (.NOT.hydrostatic) THEN
425  DO k=1,km
426  DO i=is,ie
427 ! ="specific volume"/grav
428  delz_tl(i, j, k) = -((delz_tl(i, j, k)*delp(i, j, k)-delz(&
429 & i, j, k)*delp_tl(i, j, k))/delp(i, j, k)**2)
430  delz(i, j, k) = -(delz(i, j, k)/delp(i, j, k))
431  END DO
432  END DO
433  END IF
434 ! update ps
435  DO i=is,ie
436  ps_tl(i, j) = pe1_tl(i, km+1)
437  ps(i, j) = pe1(i, km+1)
438  END DO
439 !
440 ! Hybrid sigma-P coordinate:
441 !
442  DO k=2,km
443  DO i=is,ie
444  pe2_tl(i, k) = bk(k)*pe_tl(i, km+1, j)
445  pe2(i, k) = ak(k) + bk(k)*pe(i, km+1, j)
446  END DO
447  END DO
448  DO k=1,km
449  DO i=is,ie
450  dp2_tl(i, k) = pe2_tl(i, k+1) - pe2_tl(i, k)
451  dp2(i, k) = pe2(i, k+1) - pe2(i, k)
452  END DO
453  END DO
454 !------------
455 ! update delp
456 !------------
457  DO k=1,km
458  DO i=is,ie
459  delp_tl(i, j, k) = dp2_tl(i, k)
460  delp(i, j, k) = dp2(i, k)
461  END DO
462  END DO
463 !------------------
464 ! Compute p**Kappa
465 !------------------
466  DO k=1,km+1
467  DO i=is,ie
468  pk1_tl(i, k) = pk_tl(i, j, k)
469  pk1(i, k) = pk(i, j, k)
470  END DO
471  END DO
472  DO i=is,ie
473  pn2_tl(i, 1) = peln_tl(i, 1, j)
474  pn2(i, 1) = peln(i, 1, j)
475  pn2_tl(i, km+1) = peln_tl(i, km+1, j)
476  pn2(i, km+1) = peln(i, km+1, j)
477  pk2_tl(i, 1) = pk1_tl(i, 1)
478  pk2(i, 1) = pk1(i, 1)
479  pk2_tl(i, km+1) = pk1_tl(i, km+1)
480  pk2(i, km+1) = pk1(i, km+1)
481  END DO
482  DO k=2,km
483  DO i=is,ie
484  pn2_tl(i, k) = pe2_tl(i, k)/pe2(i, k)
485  pn2(i, k) = log(pe2(i, k))
486  pk2_tl(i, k) = akap*pn2_tl(i, k)*exp(akap*pn2(i, k))
487  pk2(i, k) = exp(akap*pn2(i, k))
488  END DO
489  END DO
490  IF (remap_t) THEN
491 !----------------------------------
492 ! Map t using logp
493 !----------------------------------
494  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
495  CALL map_scalar_tlm(km, peln(is:ie, 1:km+1, j), peln_tl(&
496 & is:ie, 1:km+1, j), gz, km, pn2, pn2_tl, pt&
497 & , pt_tl, is, ie, j, isd, ied, jsd, jed, 1, &
498 & abs_kord_tm, t_min)
499  ELSE
500 pt_tj = pt
501  CALL map_scalar_tlm(km, peln(is:ie, 1:km+1, j), peln_tl(is:&
502 & ie, 1:km+1, j), gz, km, pn2, pn2_tl, pt_tj, pt_tl&
503 & , is, ie, j, isd, ied, jsd, jed, 1, &
504 & abs_kord_tm_pert, t_min)
505  call map_scalar(km, peln(is:ie,1:km+1,j), gz, &
506  km, pn2, pt, &
507  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm, t_min)
508  END IF
509  ELSE IF (remap_pt) THEN
510 !----------------------------------
511 ! Map pt using pe
512 !----------------------------------
513  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
514  gz_tl = 0.0
515  CALL map1_ppm_tlm(km, pe1, pe1_tl, gz, gz_tl, km, pe2, &
516 & pe2_tl, pt, pt_tl, is, ie, j, isd, ied, jsd, &
517 & jed, 1, abs_kord_tm)
518  ELSE
519  gz_tl = 0.0
520 pt_tj = pt
521  CALL map1_ppm_tlm(km, pe1, pe1_tl, gz, gz_tl, km, pe2, &
522 & pe2_tl, pt_tj, pt_tl, is, ie, j, isd, ied, jsd, jed&
523 & , 1, abs_kord_tm_pert)
524  call map1_ppm (km, pe1, gz, &
525  km, pe2, pt, &
526  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm)
527  END IF
528  ELSE IF (remap_te) THEN
529 !----------------------------------
530 ! map Total Energy using GMAO cubic
531 !----------------------------------
532  DO i=is,ie
533  phis_tl(i, km+1) = 0.0
534  phis(i, km+1) = hs(i, j)
535  END DO
536  DO k=km,1,-1
537  DO i=is,ie
538  phis_tl(i, k) = phis_tl(i, k+1) + cp_air*(pt_tl(i, j, k)*(&
539 & pk1(i, k+1)-pk1(i, k))+pt(i, j, k)*(pk1_tl(i, k+1)-&
540 & pk1_tl(i, k)))
541  phis(i, k) = phis(i, k+1) + cp_air*pt(i, j, k)*(pk1(i, k+1&
542 & )-pk1(i, k))
543  END DO
544  END DO
545  DO k=1,km+1
546  DO i=is,ie
547  phis_tl(i, k) = phis_tl(i, k)*pe1(i, k) + phis(i, k)*&
548 & pe1_tl(i, k)
549  phis(i, k) = phis(i, k)*pe1(i, k)
550  END DO
551  END DO
552  DO k=1,km
553  DO i=is,ie
554  te_tl(i, j, k) = te_tl(i, j, k) + ((phis_tl(i, k+1)-&
555 & phis_tl(i, k))*(pe1(i, k+1)-pe1(i, k))-(phis(i, k+1)-&
556 & phis(i, k))*(pe1_tl(i, k+1)-pe1_tl(i, k)))/(pe1(i, k+1)-&
557 & pe1(i, k))**2
558  te(i, j, k) = te(i, j, k) + (phis(i, k+1)-phis(i, k))/(pe1&
559 & (i, k+1)-pe1(i, k))
560  END DO
561  END DO
562 ! Map te using log P in GMAO cubic
563  CALL map1_cubic_tlm(km, pe1, pe1_tl, km, pe2, pe2_tl, te, &
564 & te_tl, is, ie, j, isd, ied, jsd, jed, akap, &
565 & t_var=1, conserv=.true.)
566  END IF
567 !----------------
568 ! Map constituents
569 !----------------
570  IF (nq .GT. 5) THEN
571  IF (kord_tr(1) .EQ. kord_tr_pert(1)) THEN
572  CALL mapn_tracer_tlm(nq, km, pe1, pe1_tl, pe2, pe2_tl, q&
573 & , q_tl, dp2, dp2_tl, kord_tr, j, is, ie, &
574 & isd, ied, jsd, jed, 0., fill)
575  ELSE
576 q_tj = q
577  CALL mapn_tracer_tlm(nq, km, pe1, pe1_tl, pe2, pe2_tl, q_tj, &
578 & q_tl, dp2, dp2_tl, kord_tr_pert, j, is, ie, &
579 & isd, ied, jsd, jed, 0., fill)
580  call mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, &
581  is, ie, isd, ied, jsd, jed, 0., fill)
582  END IF
583  ELSE IF (nq .GT. 0) THEN
584 ! Remap one tracer at a time
585  DO iq=1,nq
586  IF (kord_tr(iq) .EQ. kord_tr_pert(iq)) THEN
587  CALL map1_q2_tlm(km, pe1, pe1_tl, q(isd:ied, jsd:jed, 1&
588 & :km, iq), q_tl(isd:ied, jsd:jed, 1:km, iq), &
589 & km, pe2, pe2_tl, q2, q2_tl, dp2, dp2_tl, is&
590 & , ie, 0, kord_tr(iq), j, isd, ied, jsd, jed&
591 & , 0.)
592  ELSE
593 q2_tj = q2
594  CALL map1_q2_tlm(km, pe1, pe1_tl, q(isd:ied, jsd:jed, 1:km&
595 & , iq), q_tl(isd:ied, jsd:jed, 1:km, iq), km, &
596 & pe2, pe2_tl, q2_tj, q2_tl, dp2, dp2_tl, is, ie, 0&
597 & , kord_tr_pert(iq), j, isd, ied, jsd, jed, 0.)
598  call map1_q2(km, pe1, q(isd:ied,jsd:jed,1:km,iq), &
599  km, pe2, q2, dp2, &
600  is, ie, 0, kord_tr(iq), j, isd, ied, jsd, jed, 0.)
601  END IF
602  IF (fill) CALL fillz(ie - is + 1, km, 1, q2, dp2)
603  DO k=1,km
604  DO i=is,ie
605  q_tl(i, j, k, iq) = q2_tl(i, k)
606  q(i, j, k, iq) = q2(i, k)
607  END DO
608  END DO
609  END DO
610  END IF
611  IF (.NOT.hydrostatic) THEN
612 ! Remap vertical wind:
613  IF (kord_wz .EQ. kord_wz_pert) THEN
614  CALL map1_ppm_tlm(km, pe1, pe1_tl, ws(is:ie, j), ws_tl(is&
615 & :ie, j), km, pe2, pe2_tl, w, w_tl, is, ie, j&
616 & , isd, ied, jsd, jed, -2, kord_wz)
617  ELSE
618 w_tj = w
619  CALL map1_ppm_tlm(km, pe1, pe1_tl, ws(is:ie, j), ws_tl(is:ie&
620 & , j), km, pe2, pe2_tl, w_tj, w_tl, is, ie, j, isd, &
621 & ied, jsd, jed, -2, kord_wz_pert)
622  call map1_ppm (km, pe1, ws(is:ie,j), &
623  km, pe2, w, &
624  is, ie, j, isd, ied, jsd, jed, -2, kord_wz)
625  END IF
626 ! Remap delz for hybrid sigma-p coordinate
627  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
628  gz_tl = 0.0
629  CALL map1_ppm_tlm(km, pe1, pe1_tl, gz, gz_tl, km, pe2, &
630 & pe2_tl, delz, delz_tl, is, ie, j, isd, ied, &
631 & jsd, jed, 1, abs_kord_tm)
632  ELSE
633  gz_tl = 0.0
634 delz_tj = delz
635  CALL map1_ppm_tlm(km, pe1, pe1_tl, gz, gz_tl, km, pe2, &
636 & pe2_tl, delz_tj, delz_tl, is, ie, j, isd, ied, jsd&
637 & , jed, 1, abs_kord_tm_pert)
638  call map1_ppm (km, pe1, gz, &
639  km, pe2, delz, &
640  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm)
641  END IF
642  DO k=1,km
643  DO i=is,ie
644  delz_tl(i, j, k) = -(delz_tl(i, j, k)*dp2(i, k)+delz(i, j&
645 & , k)*dp2_tl(i, k))
646  delz(i, j, k) = -(delz(i, j, k)*dp2(i, k))
647  END DO
648  END DO
649  END IF
650 !----------
651 ! Update pk
652 !----------
653  DO k=1,km+1
654  DO i=is,ie
655  pk_tl(i, j, k) = pk2_tl(i, k)
656  pk(i, j, k) = pk2(i, k)
657  END DO
658  END DO
659 !----------------
660  IF (do_omega) THEN
661 ! Start do_omega
662 ! Copy omega field to pe3
663  DO i=is,ie
664  pe3_tl(i, 1) = 0.0
665  pe3(i, 1) = 0.
666  END DO
667  DO k=2,km+1
668  DO i=is,ie
669  pe3_tl(i, k) = omga_tl(i, j, k-1)
670  pe3(i, k) = omga(i, j, k-1)
671  END DO
672  END DO
673  END IF
674  DO k=1,km+1
675  DO i=is,ie
676  pe0_tl(i, k) = peln_tl(i, k, j)
677  pe0(i, k) = peln(i, k, j)
678  peln_tl(i, k, j) = pn2_tl(i, k)
679  peln(i, k, j) = pn2(i, k)
680  END DO
681  END DO
682 !------------
683 ! Compute pkz
684 !------------
685  IF (hydrostatic) THEN
686  DO k=1,km
687  DO i=is,ie
688  pkz_tl(i, j, k) = ((pk2_tl(i, k+1)-pk2_tl(i, k))*akap*(&
689 & peln(i, k+1, j)-peln(i, k, j))-(pk2(i, k+1)-pk2(i, k))*&
690 & akap*(peln_tl(i, k+1, j)-peln_tl(i, k, j)))/(akap*(peln(&
691 & i, k+1, j)-peln(i, k, j)))**2
692  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1&
693 & , j)-peln(i, k, j)))
694  END DO
695  END DO
696  ELSE IF (remap_te) THEN
697 ! WMP: note that this is where TE remapping non-hydrostatic is invalid and cannot be run
698  GOTO 120
699  ELSE IF (remap_t) THEN
700 ! Note: pt at this stage is T_v or T_m
701  DO k=1,km
702  DO i=is,ie
703  arg1_tl = (rrg*delp_tl(i, j, k)*delz(i, j, k)-rrg*delp(i, &
704 & j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2 + &
705 & rrg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
706  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
707  arg2_tl = akap*arg1_tl/arg1
708  arg2 = akap*log(arg1)
709  pkz_tl(i, j, k) = arg2_tl*exp(arg2)
710  pkz(i, j, k) = exp(arg2)
711  END DO
712  END DO
713  ELSE
714 ! Using dry pressure for the definition of the virtual potential temperature
715 ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
716 ! Note: pt at this stage is Theta_v
717  DO k=1,km
718  DO i=is,ie
719  arg1_tl = (rrg*delp_tl(i, j, k)*delz(i, j, k)-rrg*delp(i, &
720 & j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2 + &
721 & rrg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
722  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
723  arg2_tl = k1k*arg1_tl/arg1
724  arg2 = k1k*log(arg1)
725  pkz_tl(i, j, k) = arg2_tl*exp(arg2)
726  pkz(i, j, k) = exp(arg2)
727  END DO
728  END DO
729  END IF
730 ! end do_omega
731 ! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
732  IF (do_omega) THEN
733  DO k=1,km
734  DO i=is,ie
735  dp2_tl(i, k) = 0.5*(peln_tl(i, k, j)+peln_tl(i, k+1, j))
736  dp2(i, k) = 0.5*(peln(i, k, j)+peln(i, k+1, j))
737  END DO
738  END DO
739  DO i=is,ie
740  k_next = 1
741  DO 110 n=1,km
742  kp = k_next
743  DO k=kp,km
744  IF (dp2(i, n) .LE. pe0(i, k+1) .AND. dp2(i, n) .GE. pe0(&
745 & i, k)) GOTO 100
746  END DO
747  GOTO 110
748  100 omga_tl(i, j, n) = pe3_tl(i, k) + (((pe3_tl(i, k+1)-pe3_tl&
749 & (i, k))*(dp2(i, n)-pe0(i, k))+(pe3(i, k+1)-pe3(i, k))*(&
750 & dp2_tl(i, n)-pe0_tl(i, k)))*(pe0(i, k+1)-pe0(i, k))-(pe3&
751 & (i, k+1)-pe3(i, k))*(dp2(i, n)-pe0(i, k))*(pe0_tl(i, k+1&
752 & )-pe0_tl(i, k)))/(pe0(i, k+1)-pe0(i, k))**2
753  omga(i, j, n) = pe3(i, k) + (pe3(i, k+1)-pe3(i, k))*(dp2(i&
754 & , n)-pe0(i, k))/(pe0(i, k+1)-pe0(i, k))
755  k_next = k
756  110 CONTINUE
757  END DO
758  END IF
759  END IF
760  DO i=is,ie+1
761  pe0_tl(i, 1) = pe_tl(i, 1, j)
762  pe0(i, 1) = pe(i, 1, j)
763  END DO
764 !------
765 ! map u
766 !------
767  DO k=2,km+1
768  DO i=is,ie
769  pe0_tl(i, k) = 0.5*(pe_tl(i, k, j-1)+pe1_tl(i, k))
770  pe0(i, k) = 0.5*(pe(i, k, j-1)+pe1(i, k))
771  END DO
772  END DO
773  DO k=1,km+1
774  bkh = 0.5*bk(k)
775  DO i=is,ie
776  pe3_tl(i, k) = bkh*(pe_tl(i, km+1, j-1)+pe1_tl(i, km+1))
777  pe3(i, k) = ak(k) + bkh*(pe(i, km+1, j-1)+pe1(i, km+1))
778  END DO
779  END DO
780  IF (kord_mt .EQ. kord_mt_pert) THEN
781  gz_tl = 0.0
782  CALL map1_ppm_tlm(km, pe0(is:ie, :), pe0_tl(is:ie, :), gz, &
783 & gz_tl, km, pe3(is:ie, :), pe3_tl(is:ie, :), u, &
784 & u_tl, is, ie, j, isd, ied, jsd, jedp1, -1, &
785 & kord_mt)
786  ELSE
787  gz_tl = 0.0
788 u_tj = u
789  CALL map1_ppm_tlm(km, pe0(is:ie, :), pe0_tl(is:ie, :), gz, gz_tl&
790 & , km, pe3(is:ie, :), pe3_tl(is:ie, :), u_tj, u_tl, is, &
791 & ie, j, isd, ied, jsd, jedp1, -1, kord_mt_pert)
792  call map1_ppm( km, pe0(is:ie,:), gz, &
793  km, pe3(is:ie,:), u, &
794  is, ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
795  END IF
796  IF (PRESENT(mfy)) CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:&
797 & ie, :), mfy, is, ie, j, is, ie, js, jep1&
798 & , -1, kord_mt)
799 ! (j < je+1)
800  IF (j .LT. je + 1) THEN
801 !------
802 ! map v
803 !------
804  DO i=is,ie+1
805  pe3_tl(i, 1) = 0.0
806  pe3(i, 1) = ak(1)
807  END DO
808  DO k=2,km+1
809  bkh = 0.5*bk(k)
810  DO i=is,ie+1
811  pe0_tl(i, k) = 0.5*(pe_tl(i-1, k, j)+pe_tl(i, k, j))
812  pe0(i, k) = 0.5*(pe(i-1, k, j)+pe(i, k, j))
813  pe3_tl(i, k) = bkh*(pe_tl(i-1, km+1, j)+pe_tl(i, km+1, j))
814  pe3(i, k) = ak(k) + bkh*(pe(i-1, km+1, j)+pe(i, km+1, j))
815  END DO
816  END DO
817  IF (kord_mt .EQ. kord_mt_pert) THEN
818  gz_tl = 0.0
819  CALL map1_ppm_tlm(km, pe0, pe0_tl, gz, gz_tl, km, pe3, &
820 & pe3_tl, v, v_tl, is, iep1, j, isd, iedp1, jsd, &
821 & jed, -1, kord_mt)
822  ELSE
823  gz_tl = 0.0
824 v_tj = v
825  CALL map1_ppm_tlm(km, pe0, pe0_tl, gz, gz_tl, km, pe3, pe3_tl&
826 & , v_tj, v_tl, is, iep1, j, isd, iedp1, jsd, jed, -1, &
827 & kord_mt_pert)
828  call map1_ppm (km, pe0, gz, &
829  km, pe3, v, is, ie+1, &
830  j, isd, iedp1, jsd, jed, -1, kord_mt)
831  END IF
832  IF (PRESENT(mfx)) CALL map1_ppm(km, pe0, gz, km, pe3, mfx, is, &
833 & iep1, j, is, iep1, js, je, -1, kord_mt&
834 & )
835  END IF
836  DO k=1,km
837  DO i=is,ie
838  ua_tl(i, j, k) = pe2_tl(i, k+1)
839  ua(i, j, k) = pe2(i, k+1)
840  END DO
841  END DO
842  END DO
843 !$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, &
844 !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, &
845 !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, &
846 !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, &
847 !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, &
848 !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, &
849 !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, &
850 !$OMP fast_mp_consv,kord_tm) &
851 !$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,tpe,tmp, dpln)
852 !$OMP do
853  DO k=2,km
854  DO j=js,je
855  DO i=is,ie
856  pe_tl(i, k, j) = ua_tl(i, j, k-1)
857  pe(i, k, j) = ua(i, j, k-1)
858  END DO
859  END DO
860  END DO
861  IF (flagstruct%fv_debug) THEN
862  IF (kord_tm .LT. 0) THEN
863  CALL prt_mxm('remap-1 TV', pt, is, ie, js, je, ng, km, 1., &
864 & gridstruct%area_64, domain)
865  ELSE
866  CALL prt_mxm('remap-1 PT', pt, is, ie, js, je, ng, km, 1., &
867 & gridstruct%area_64, domain)
868  END IF
869  END IF
870  dtmp = 0.
871 ! end last_step check
872  IF (last_step .AND. (.NOT.do_adiabatic_init)) THEN
873 ! end consv check
874  IF (consv .GT. consv_min) THEN
875  gz_tl = 0.0
876  te_2d_tl = 0.0
877  zsum0_tl = 0.0
878  zsum1_tl = 0.0
879 !$OMP do
880  DO j=js,je
881  IF (remap_t) THEN
882 ! end non-hydro
883  IF (hydrostatic) THEN
884  DO i=is,ie
885  gz_tl(i) = 0.0
886  gz(i) = hs(i, j)
887  DO k=1,km
888  gz_tl(i) = gz_tl(i) + rg*(pt_tl(i, j, k)*(peln(i, k+1&
889 & , j)-peln(i, k, j))+pt(i, j, k)*(peln_tl(i, k+1, j)-&
890 & peln_tl(i, k, j)))
891  gz(i) = gz(i) + rg*pt(i, j, k)*(peln(i, k+1, j)-peln(i&
892 & , k, j))
893  END DO
894  END DO
895  DO i=is,ie
896  te_2d_tl(i, j) = hs(i, j)*pe_tl(i, km+1, j) - pe_tl(i, 1&
897 & , j)*gz(i) - pe(i, 1, j)*gz_tl(i)
898  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
899 & )
900  END DO
901  DO k=1,km
902  DO i=is,ie
903  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(cp&
904 & *pt(i, j, k)+0.25*gridstruct%rsin2(i, j)*(u(i, j, k)&
905 & **2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u&
906 & (i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
907 & gridstruct%cosa_s(i, j))) + delp(i, j, k)*(cp*pt_tl(&
908 & i, j, k)+0.25*gridstruct%rsin2(i, j)*(2*u(i, j, k)*&
909 & u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(i, &
910 & j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k)-&
911 & gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl(i, j+1&
912 & , k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+1&
913 & , k))*(v_tl(i, j, k)+v_tl(i+1, j, k)))))
914  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*pt(i, j&
915 & , k)+0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i&
916 & , j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, &
917 & k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
918 & gridstruct%cosa_s(i, j)))
919  END DO
920  END DO
921  ELSE
922  DO i=is,ie
923  te_2d_tl(i, j) = 0.0
924  te_2d(i, j) = 0.
925  phis_tl(i, km+1) = 0.0
926  phis(i, km+1) = hs(i, j)
927  END DO
928  DO k=km,1,-1
929  DO i=is,ie
930  phis_tl(i, k) = phis_tl(i, k+1) - grav*delz_tl(i, j, k&
931 & )
932  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
933  END DO
934  END DO
935  DO k=1,km
936  DO i=is,ie
937  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(&
938 & cv_air*pt(i, j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*&
939 & (phis(i, k)+phis(i, k+1)+w(i, j, k)**2+0.5*&
940 & gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i, j+1, k)**&
941 & 2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1&
942 & , k))*(v(i, j, k)+v(i+1, j, k))*gridstruct%cosa_s(i&
943 & , j)))) + delp(i, j, k)*((cv_air*pt_tl(i, j, k)*(1.+&
944 & r_vir*q(i, j, k, sphum))-cv_air*pt(i, j, k)*r_vir*&
945 & q_tl(i, j, k, sphum))/(1.+r_vir*q(i, j, k, sphum))**&
946 & 2+0.5*(phis_tl(i, k)+phis_tl(i, k+1)+2*w(i, j, k)*&
947 & w_tl(i, j, k)+0.5*gridstruct%rsin2(i, j)*(2*u(i, j, &
948 & k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(&
949 & i, j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k&
950 & )-gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl(i, j+&
951 & 1, k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+&
952 & 1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k))))))
953  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
954 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
955 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
956 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
957 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
958 & i+1, j, k))*gridstruct%cosa_s(i, j))))
959  END DO
960  END DO
961  END IF
962  ELSE IF (remap_pt) THEN
963 ! k-loop
964  IF (hydrostatic) THEN
965  DO i=is,ie
966  gz_tl(i) = 0.0
967  gz(i) = hs(i, j)
968  DO k=1,km
969  gz_tl(i) = gz_tl(i) + cp_air*(pt_tl(i, j, k)*(pk(i, j&
970 & , k+1)-pk(i, j, k))+pt(i, j, k)*(pk_tl(i, j, k+1)-&
971 & pk_tl(i, j, k)))
972  gz(i) = gz(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i&
973 & , j, k))
974  END DO
975  END DO
976  DO i=is,ie
977  te_2d_tl(i, j) = hs(i, j)*pe_tl(i, km+1, j) - pe_tl(i, 1&
978 & , j)*gz(i) - pe(i, 1, j)*gz_tl(i)
979  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
980 & )
981  END DO
982  DO k=1,km
983  DO i=is,ie
984  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(&
985 & cp_air*pt(i, j, k)*pkz(i, j, k)+0.25*gridstruct%&
986 & rsin2(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k&
987 & )**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i&
988 & , j, k)+v(i+1, j, k))*gridstruct%cosa_s(i, j))) + &
989 & delp(i, j, k)*(cp_air*(pt_tl(i, j, k)*pkz(i, j, k)+&
990 & pt(i, j, k)*pkz_tl(i, j, k))+0.25*gridstruct%rsin2(i&
991 & , j)*(2*u(i, j, k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl&
992 & (i, j+1, k)+2*v(i, j, k)*v_tl(i, j, k)+2*v(i+1, j, k&
993 & )*v_tl(i+1, j, k)-gridstruct%cosa_s(i, j)*((u_tl(i, &
994 & j, k)+u_tl(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))+(u(&
995 & i, j, k)+u(i, j+1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k&
996 & )))))
997  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp_air*pt(i&
998 & , j, k)*pkz(i, j, k)+0.25*gridstruct%rsin2(i, j)*(u(&
999 & i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, &
1000 & k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j&
1001 & , k))*gridstruct%cosa_s(i, j)))
1002  END DO
1003  END DO
1004  ELSE
1005 !-----------------
1006 ! Non-hydrostatic:
1007 !-----------------
1008  DO i=is,ie
1009  phis_tl(i, km+1) = 0.0
1010  phis(i, km+1) = hs(i, j)
1011  DO k=km,1,-1
1012  phis_tl(i, k) = phis_tl(i, k+1) - grav*delz_tl(i, j, k&
1013 & )
1014  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
1015  END DO
1016  END DO
1017  DO i=is,ie
1018  te_2d_tl(i, j) = 0.0
1019  te_2d(i, j) = 0.
1020  END DO
1021  DO k=1,km
1022  DO i=is,ie
1023  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(&
1024 & cv_air*pt(i, j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*&
1025 & (phis(i, k)+phis(i, k+1)+w(i, j, k)**2+0.5*&
1026 & gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i, j+1, k)**&
1027 & 2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1&
1028 & , k))*(v(i, j, k)+v(i+1, j, k))*gridstruct%cosa_s(i&
1029 & , j)))) + delp(i, j, k)*((cv_air*pt_tl(i, j, k)*(1.+&
1030 & r_vir*q(i, j, k, sphum))-cv_air*pt(i, j, k)*r_vir*&
1031 & q_tl(i, j, k, sphum))/(1.+r_vir*q(i, j, k, sphum))**&
1032 & 2+0.5*(phis_tl(i, k)+phis_tl(i, k+1)+2*w(i, j, k)*&
1033 & w_tl(i, j, k)+0.5*gridstruct%rsin2(i, j)*(2*u(i, j, &
1034 & k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(&
1035 & i, j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k&
1036 & )-gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl(i, j+&
1037 & 1, k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+&
1038 & 1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k))))))
1039  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
1040 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
1041 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
1042 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
1043 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
1044 & i+1, j, k))*gridstruct%cosa_s(i, j))))
1045  END DO
1046  END DO
1047  END IF
1048  ELSE IF (remap_te) THEN
1049  DO i=is,ie
1050  te_2d_tl(i, j) = te_tl(i, j, 1)*delp(i, j, 1) + te(i, j, 1&
1051 & )*delp_tl(i, j, 1)
1052  te_2d(i, j) = te(i, j, 1)*delp(i, j, 1)
1053  END DO
1054  DO k=2,km
1055  DO i=is,ie
1056  te_2d_tl(i, j) = te_2d_tl(i, j) + te_tl(i, j, k)*delp(i&
1057 & , j, k) + te(i, j, k)*delp_tl(i, j, k)
1058  te_2d(i, j) = te_2d(i, j) + te(i, j, k)*delp(i, j, k)
1059  END DO
1060  END DO
1061  END IF
1062  DO i=is,ie
1063  te_2d_tl(i, j) = te0_2d_tl(i, j) - te_2d_tl(i, j)
1064  te_2d(i, j) = te0_2d(i, j) - te_2d(i, j)
1065  zsum1_tl(i, j) = pkz_tl(i, j, 1)*delp(i, j, 1) + pkz(i, j, 1&
1066 & )*delp_tl(i, j, 1)
1067  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
1068  END DO
1069  DO k=2,km
1070  DO i=is,ie
1071  zsum1_tl(i, j) = zsum1_tl(i, j) + pkz_tl(i, j, k)*delp(i, &
1072 & j, k) + pkz(i, j, k)*delp_tl(i, j, k)
1073  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
1074  END DO
1075  END DO
1076  IF (hydrostatic) THEN
1077  DO i=is,ie
1078  zsum0_tl(i, j) = ptop*(pk_tl(i, j, 1)-pk_tl(i, j, km+1)) +&
1079 & zsum1_tl(i, j)
1080  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
1081 & , j)
1082  END DO
1083  END IF
1084  END DO
1085 ! j-loop
1086 !$OMP single
1087  result1_tl = g_sum_tlm(domain, te_2d, te_2d_tl, is, ie, js, je, &
1088 & ng, gridstruct%area_64, 0, reproduce=.true., g_sum=result1)
1089  tpe_tl = consv*result1_tl
1090  tpe = consv*result1
1091 ! unit: W/m**2
1092  e_flux = tpe/(grav*pdt*4.*pi*radius**2)
1093 ! Note pdt is "phys" time step
1094  IF (hydrostatic) THEN
1095  result1_tl = g_sum_tlm(domain, zsum0, zsum0_tl, is, ie, js, je&
1096 & , ng, gridstruct%area_64, 0, reproduce=.true., g_sum=result1&
1097 & )
1098  dtmp_tl = (tpe_tl*cp*result1-tpe*cp*result1_tl)/(cp*result1)**&
1099 & 2
1100  dtmp = tpe/(cp*result1)
1101  ELSE
1102  result1_tl = g_sum_tlm(domain, zsum1, zsum1_tl, is, ie, js, je&
1103 & , ng, gridstruct%area_64, 0, reproduce=.true., g_sum=result1&
1104 & )
1105  dtmp_tl = (tpe_tl*cv_air*result1-tpe*cv_air*result1_tl)/(&
1106 & cv_air*result1)**2
1107  dtmp = tpe/(cv_air*result1)
1108  END IF
1109  ELSE IF (consv .LT. -consv_min) THEN
1110 !$OMP end single
1111  zsum0_tl = 0.0
1112  zsum1_tl = 0.0
1113 !$OMP do
1114  DO j=js,je
1115  DO i=is,ie
1116  zsum1_tl(i, j) = pkz_tl(i, j, 1)*delp(i, j, 1) + pkz(i, j, 1&
1117 & )*delp_tl(i, j, 1)
1118  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
1119  END DO
1120  DO k=2,km
1121  DO i=is,ie
1122  zsum1_tl(i, j) = zsum1_tl(i, j) + pkz_tl(i, j, k)*delp(i, &
1123 & j, k) + pkz(i, j, k)*delp_tl(i, j, k)
1124  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
1125  END DO
1126  END DO
1127  IF (hydrostatic) THEN
1128  DO i=is,ie
1129  zsum0_tl(i, j) = ptop*(pk_tl(i, j, 1)-pk_tl(i, j, km+1)) +&
1130 & zsum1_tl(i, j)
1131  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
1132 & , j)
1133  END DO
1134  END IF
1135  END DO
1136  e_flux = consv
1137 !$OMP single
1138  IF (hydrostatic) THEN
1139  result1_tl = g_sum_tlm(domain, zsum0, zsum0_tl, is, ie, js, je&
1140 & , ng, gridstruct%area_64, 0, reproduce=.true., g_sum=result1&
1141 & )
1142  dtmp_tl = -(e_flux*grav*pdt*4.*pi*radius**2*cp*result1_tl/(cp*&
1143 & result1)**2)
1144  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cp*result1)
1145  gz_tl = 0.0
1146  ELSE
1147  result1_tl = g_sum_tlm(domain, zsum1, zsum1_tl, is, ie, js, je&
1148 & , ng, gridstruct%area_64, 0, reproduce=.true., g_sum=result1&
1149 & )
1150  dtmp_tl = -(e_flux*grav*pdt*4.*pi*radius**2*cv_air*result1_tl/&
1151 & (cv_air*result1)**2)
1152  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cv_air*result1)
1153  gz_tl = 0.0
1154  END IF
1155  ELSE
1156  gz_tl = 0.0
1157  dtmp_tl = 0.0
1158  END IF
1159  ELSE
1160  gz_tl = 0.0
1161  dtmp_tl = 0.0
1162  END IF
1163 !$OMP end single
1164 ! do_sat_adj
1165 ! Note: pt at this stage is T_v
1166  IF (remap_t .AND. (.NOT.do_adiabatic_init) .AND. do_sat_adj) THEN
1167 ! if ( do_sat_adj ) then
1168  CALL timing_on('sat_adj2')
1169 !$OMP do
1170  DO k=kmp,km
1171  DO j=js,je
1172  DO i=is,ie
1173  dpln(i, j) = peln(i, k+1, j) - peln(i, k, j)
1174  END DO
1175  END DO
1176  IF (mdt .GE. 0.) THEN
1177  abs0 = mdt
1178  ELSE
1179  abs0 = -mdt
1180  END IF
1181  CALL fv_sat_adj(abs0, r_vir, is, ie, js, je, ng, hydrostatic, &
1182 & fast_mp_consv, te(isd:ied, jsd:jed, k), q(isd:ied, jsd&
1183 & :jed, k, sphum), q(isd:ied, jsd:jed, k, liq_wat), q(&
1184 & isd:ied, jsd:jed, k, ice_wat), q(isd:ied, jsd:jed, k, &
1185 & rainwat), q(isd:ied, jsd:jed, k, snowwat), q(isd:ied, &
1186 & jsd:jed, k, graupel), dpln, delz(isd:ied, jsd:jed, k)&
1187 & , pt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k), &
1188 & q_con(isd:ied, jsd:jed, k), cappa(isd:ied, jsd:jed, k)&
1189 & , gridstruct%area_64, dtdt(is:ie, js:je, k), out_dt, &
1190 & last_step, cld_amt .GT. 0, q(isd:ied, jsd:jed, k, &
1191 & cld_amt))
1192  IF (.NOT.hydrostatic) THEN
1193  DO j=js,je
1194  DO i=is,ie
1195  arg1_tl = (rrg*delp_tl(i, j, k)*delz(i, j, k)-rrg*delp(i, &
1196 & j, k)*delz_tl(i, j, k))*pt(i, j, k)/delz(i, j, k)**2 + &
1197 & rrg*delp(i, j, k)*pt_tl(i, j, k)/delz(i, j, k)
1198  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1199  arg2_tl = akap*arg1_tl/arg1
1200  arg2 = akap*log(arg1)
1201  pkz_tl(i, j, k) = arg2_tl*exp(arg2)
1202  pkz(i, j, k) = exp(arg2)
1203  END DO
1204  END DO
1205  END IF
1206  END DO
1207 ! OpenMP k-loop
1208  IF (fast_mp_consv) THEN
1209 !$OMP do
1210  DO j=js,je
1211  DO i=is,ie
1212  DO k=kmp,km
1213  te0_2d_tl(i, j) = te0_2d_tl(i, j) + te_tl(i, j, k)
1214  te0_2d(i, j) = te0_2d(i, j) + te(i, j, k)
1215  END DO
1216  END DO
1217  END DO
1218  END IF
1219  CALL timing_off('sat_adj2')
1220  END IF
1221 ! last_step
1222  IF (last_step) THEN
1223 ! Output temperature if last_step
1224  IF (remap_t) THEN
1225 !$OMP do
1226  DO k=1,km
1227  DO j=js,je
1228  IF (.NOT.adiabatic) THEN
1229  DO i=is,ie
1230  pt_tl(i, j, k) = ((pt_tl(i, j, k)+dtmp_tl*pkz(i, j, k)+&
1231 & dtmp*pkz_tl(i, j, k))*(1.+r_vir*q(i, j, k, sphum))-(pt&
1232 & (i, j, k)+dtmp*pkz(i, j, k))*r_vir*q_tl(i, j, k, sphum&
1233 & ))/(1.+r_vir*q(i, j, k, sphum))**2
1234  pt(i, j, k) = (pt(i, j, k)+dtmp*pkz(i, j, k))/(1.+r_vir*&
1235 & q(i, j, k, sphum))
1236  END DO
1237  END IF
1238  END DO
1239  END DO
1240  ELSE IF (remap_pt) THEN
1241 ! j-loop
1242 ! k-loop
1243 !$OMP do
1244  DO k=1,km
1245  DO j=js,je
1246  DO i=is,ie
1247  pt_tl(i, j, k) = (((pt_tl(i, j, k)+dtmp_tl)*pkz(i, j, k)+(&
1248 & pt(i, j, k)+dtmp)*pkz_tl(i, j, k))*(1.+r_vir*q(i, j, k, &
1249 & sphum))-(pt(i, j, k)+dtmp)*pkz(i, j, k)*r_vir*q_tl(i, j&
1250 & , k, sphum))/(1.+r_vir*q(i, j, k, sphum))**2
1251  pt(i, j, k) = (pt(i, j, k)+dtmp)*pkz(i, j, k)/(1.+r_vir*q(&
1252 & i, j, k, sphum))
1253  END DO
1254  END DO
1255  END DO
1256  ELSE IF (remap_te) THEN
1257 !$OMP do
1258  DO j=js,je
1259  DO i=is,ie
1260  gz_tl(i) = 0.0
1261  gz(i) = hs(i, j)
1262  END DO
1263  DO k=km,1,-1
1264  DO i=is,ie
1265  tpe_tl = te_tl(i, j, k) - gz_tl(i) - 0.25*gridstruct%rsin2&
1266 & (i, j)*(2*u(i, j, k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i&
1267 & , j+1, k)+2*v(i, j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl&
1268 & (i+1, j, k)-gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl&
1269 & (i, j+1, k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, &
1270 & j+1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k))))
1271  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
1272 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
1273 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1274 & gridstruct%cosa_s(i, j))
1275  dlnp_tl = rg*(peln_tl(i, k+1, j)-peln_tl(i, k, j))
1276  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
1277  tmp_tl = (tpe_tl*(cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+&
1278 & r_vir*q(i, j, k, sphum))-tpe*((cp-pe(i, k, j)*dlnp/delp(&
1279 & i, j, k))*r_vir*q_tl(i, j, k, sphum)-((pe_tl(i, k, j)*&
1280 & dlnp+pe(i, k, j)*dlnp_tl)*delp(i, j, k)-pe(i, k, j)*dlnp&
1281 & *delp_tl(i, j, k))*(1.+r_vir*q(i, j, k, sphum))/delp(i, &
1282 & j, k)**2))/((cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+&
1283 & r_vir*q(i, j, k, sphum)))**2
1284  tmp = tpe/((cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+r_vir*q&
1285 & (i, j, k, sphum)))
1286  pt_tl(i, j, k) = tmp_tl + ((dtmp_tl*pkz(i, j, k)+dtmp*&
1287 & pkz_tl(i, j, k))*(1.+r_vir*q(i, j, k, sphum))-dtmp*pkz(i&
1288 & , j, k)*r_vir*q_tl(i, j, k, sphum))/(1.+r_vir*q(i, j, k&
1289 & , sphum))**2
1290  pt(i, j, k) = tmp + dtmp*pkz(i, j, k)/(1.+r_vir*q(i, j, k&
1291 & , sphum))
1292  gz_tl(i) = gz_tl(i) + (dlnp_tl*tmp+dlnp*tmp_tl)*(1.+r_vir*&
1293 & q(i, j, k, sphum)) + dlnp*tmp*r_vir*q_tl(i, j, k, sphum)
1294  gz(i) = gz(i) + dlnp*tmp*(1.+r_vir*q(i, j, k, sphum))
1295  END DO
1296  END DO
1297  END DO
1298  END IF
1299 ! end k-loop
1300  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 TA', pt, is, ie, &
1301 & js, je, ng, km, 1., gridstruct%&
1302 & area_64, domain)
1303  ELSE
1304 ! not last_step
1305  IF (remap_t) THEN
1306 !$OMP do
1307  DO k=1,km
1308  DO j=js,je
1309  DO i=is,ie
1310  pt_tl(i, j, k) = (pt_tl(i, j, k)*pkz(i, j, k)-pt(i, j, k)*&
1311 & pkz_tl(i, j, k))/pkz(i, j, k)**2
1312  pt(i, j, k) = pt(i, j, k)/pkz(i, j, k)
1313  END DO
1314  END DO
1315  END DO
1316  ELSE IF (remap_te) THEN
1317 !$OMP do
1318  DO j=js,je
1319  DO i=is,ie
1320  gz_tl(i) = 0.0
1321  gz(i) = hs(i, j)
1322  END DO
1323  DO k=km,1,-1
1324  DO i=is,ie
1325  tpe_tl = te_tl(i, j, k) - gz_tl(i) - 0.25*gridstruct%rsin2&
1326 & (i, j)*(2*u(i, j, k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i&
1327 & , j+1, k)+2*v(i, j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl&
1328 & (i+1, j, k)-gridstruct%cosa_s(i, j)*((u_tl(i, j, k)+u_tl&
1329 & (i, j+1, k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, k)+u(i, &
1330 & j+1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k))))
1331  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
1332 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
1333 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1334 & gridstruct%cosa_s(i, j))
1335  dlnp_tl = rg*(peln_tl(i, k+1, j)-peln_tl(i, k, j))
1336  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
1337  tmp_tl = (tpe_tl*(cp-pe(i, k, j)*dlnp/delp(i, j, k))+tpe*(&
1338 & (pe_tl(i, k, j)*dlnp+pe(i, k, j)*dlnp_tl)*delp(i, j, k)-&
1339 & pe(i, k, j)*dlnp*delp_tl(i, j, k))/delp(i, j, k)**2)/(cp&
1340 & -pe(i, k, j)*dlnp/delp(i, j, k))**2
1341  tmp = tpe/(cp-pe(i, k, j)*dlnp/delp(i, j, k))
1342  pt_tl(i, j, k) = (tmp_tl*pkz(i, j, k)-tmp*pkz_tl(i, j, k))&
1343 & /pkz(i, j, k)**2 + dtmp_tl
1344  pt(i, j, k) = tmp/pkz(i, j, k) + dtmp
1345  gz_tl(i) = gz_tl(i) + dlnp_tl*tmp + dlnp*tmp_tl
1346  gz(i) = gz(i) + dlnp*tmp
1347  END DO
1348  END DO
1349  END DO
1350  END IF
1351 ! end k-loop
1352  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 PT', pt, is, ie, &
1353 & js, je, ng, km, 1., gridstruct%&
1354 & area_64, domain)
1355  END IF
1356  GOTO 130
1357  120 print*, 'TE remapping non-hydrostatic is invalid and cannot be run'
1358  stop
1359  130 CONTINUE
1360  END SUBROUTINE lagrangian_to_eulerian_tlm
1361  SUBROUTINE lagrangian_to_eulerian(last_step, consv, ps, pe, delp, pkz&
1362 & , pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, &
1363 & sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, &
1364 & kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, &
1365 & te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, &
1366 & flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, &
1367 & do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, &
1368 & kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
1369  IMPLICIT NONE
1370 !$OMP end parallel
1371  LOGICAL, INTENT(IN) :: last_step
1372 ! remap time step
1373  REAL, INTENT(IN) :: mdt
1374 ! phys time step
1375  REAL, INTENT(IN) :: pdt
1376  INTEGER, INTENT(IN) :: km
1377 ! number of tracers (including h2o)
1378  INTEGER, INTENT(IN) :: nq
1379  INTEGER, INTENT(IN) :: nwat
1380 ! index for water vapor (specific humidity)
1381  INTEGER, INTENT(IN) :: sphum
1382  INTEGER, INTENT(IN) :: ng
1383 ! starting & ending X-Dir index
1384  INTEGER, INTENT(IN) :: is, ie, isd, ied
1385 ! starting & ending Y-Dir index
1386  INTEGER, INTENT(IN) :: js, je, jsd, jed
1387 ! Mapping order for the vector winds
1388  INTEGER, INTENT(IN) :: kord_mt
1389 ! Mapping order/option for w
1390  INTEGER, INTENT(IN) :: kord_wz
1391 ! Mapping order for tracers
1392  INTEGER, INTENT(IN) :: kord_tr(nq)
1393 ! Mapping order for thermodynamics
1394  INTEGER, INTENT(IN) :: kord_tm
1395 ! Mapping order for the vector winds
1396  INTEGER, INTENT(IN) :: kord_mt_pert
1397 ! Mapping order/option for w
1398  INTEGER, INTENT(IN) :: kord_wz_pert
1399 ! Mapping order for tracers
1400  INTEGER, INTENT(IN) :: kord_tr_pert(nq)
1401 ! Mapping order for thermodynamics
1402  INTEGER, INTENT(IN) :: kord_tm_pert
1403 ! factor for TE conservation
1404  REAL, INTENT(IN) :: consv
1405  REAL, INTENT(IN) :: r_vir
1406  REAL, INTENT(IN) :: cp
1407  REAL, INTENT(IN) :: akap
1408 ! surface geopotential
1409  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
1410  REAL, INTENT(INOUT) :: te0_2d(is:ie, js:je)
1411  REAL, INTENT(IN) :: ws(is:ie, js:je)
1412  LOGICAL, INTENT(IN) :: do_sat_adj
1413 ! fill negative tracers
1414  LOGICAL, INTENT(IN) :: fill
1415  LOGICAL, INTENT(IN) :: reproduce_sum
1416  LOGICAL, INTENT(IN) :: do_omega, adiabatic, do_adiabatic_init
1417  REAL, INTENT(IN) :: ptop
1418  REAL, INTENT(IN) :: ak(km+1)
1419  REAL, INTENT(IN) :: bk(km+1)
1420  REAL, INTENT(IN) :: pfull(km)
1421  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1422  TYPE(fv_flags_type), INTENT(INOUT) :: flagstruct
1423  TYPE(domain2d), INTENT(INOUT) :: domain
1424 ! !INPUT/OUTPUT
1425 ! pe to the kappa
1426  REAL, INTENT(INOUT) :: pk(is:ie, js:je, km+1)
1427  REAL, INTENT(INOUT) :: q(isd:ied, jsd:jed, km, nq)
1428 ! pressure thickness
1429  REAL, INTENT(INOUT) :: delp(isd:ied, jsd:jed, km)
1430 ! pressure at layer edges
1431  REAL, INTENT(INOUT) :: pe(is-1:ie+1, km+1, js-1:je+1)
1432 ! surface pressure
1433  REAL, INTENT(INOUT) :: ps(isd:ied, jsd:jed)
1434 ! u-wind will be ghosted one latitude to the north upon exit
1435 ! u-wind (m/s)
1436  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
1437 ! v-wind (m/s)
1438  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
1439 ! vertical velocity (m/s)
1440  REAL, INTENT(INOUT) :: w(isd:ied, jsd:jed, km)
1441 ! cp*virtual potential temperature
1442  REAL, INTENT(INOUT) :: pt(isd:ied, jsd:jed, km)
1443 ! as input; output: temperature
1444  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: delz
1445  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: q_con, cappa
1446  LOGICAL, INTENT(IN) :: hydrostatic
1447  LOGICAL, INTENT(IN) :: hybrid_z
1448  LOGICAL, INTENT(IN) :: out_dt
1449 ! u-wind (m/s) on physics grid
1450  REAL, INTENT(INOUT) :: ua(isd:ied, jsd:jed, km)
1451 ! v-wind (m/s) on physics grid
1452  REAL, INTENT(INOUT) :: va(isd:ied, jsd:jed, km)
1453 ! vertical press. velocity (pascal/sec)
1454  REAL, INTENT(INOUT) :: omga(isd:ied, jsd:jed, km)
1455 ! log(pe)
1456  REAL, INTENT(INOUT) :: peln(is:ie, km+1, js:je)
1457  REAL, INTENT(INOUT) :: dtdt(is:ie, js:je, km)
1458 ! layer-mean pk for converting t to pt
1459  REAL, INTENT(OUT) :: pkz(is:ie, js:je, km)
1460  REAL, INTENT(OUT) :: te(isd:ied, jsd:jed, km)
1461 ! Mass fluxes
1462 ! X-dir Mass Flux
1463  REAL, OPTIONAL, INTENT(INOUT) :: mfx(is:ie+1, js:je, km)
1464 ! Y-dir Mass Flux
1465  REAL, OPTIONAL, INTENT(INOUT) :: mfy(is:ie, js:je+1, km)
1466 ! 0: remap T in logP
1467  INTEGER, INTENT(IN) :: remap_option
1468 ! 1: remap PT in P
1469 ! 3: remap TE in logP with GMAO cubic
1470 ! !DESCRIPTION:
1471 !
1472 ! !REVISION HISTORY:
1473 ! SJL 03.11.04: Initial version for partial remapping
1474 !
1475 !-----------------------------------------------------------------------
1476  REAL, DIMENSION(is:ie, js:je) :: te_2d, zsum0, zsum1, dpln
1477  REAL, DIMENSION(is:ie, km) :: q2, dp2
1478  REAL, DIMENSION(is:ie, km+1) :: pe1, pe2, pk1, pk2, pn2, phis
1479  REAL, DIMENSION(is:ie+1, km+1) :: pe0, pe3
1480  REAL, DIMENSION(is:ie) :: gz, cvm, qv
1481  REAL :: rcp, rg, tmp, tpe, rrg, bkh, dtmp, k1k, dlnp
1482  LOGICAL :: fast_mp_consv
1483  INTEGER :: i, j, k
1484  INTEGER :: nt, liq_wat, ice_wat, rainwat, snowwat, cld_amt, graupel&
1485 & , iq, n, kmp, kp, k_next
1486  LOGICAL :: remap_t, remap_pt, remap_te
1487  INTEGER :: abs_kord_tm, abs_kord_tm_pert
1488  INTEGER :: iep1, jep1, iedp1, jedp1
1489  INTRINSIC abs
1490  INTRINSIC log
1491  INTRINSIC exp
1492  INTRINSIC PRESENT
1493  REAL :: abs0
1494  REAL :: arg1
1495  REAL :: arg2
1496  REAL :: result1
1497  IF (kord_tm .GE. 0.) THEN
1498  abs_kord_tm = kord_tm
1499  ELSE
1500  abs_kord_tm = -kord_tm
1501  END IF
1502  IF (kord_tm_pert .GE. 0.) THEN
1503  abs_kord_tm_pert = kord_tm_pert
1504  ELSE
1505  abs_kord_tm_pert = -kord_tm_pert
1506  END IF
1507  iep1 = ie + 1
1508  jep1 = je + 1
1509  iedp1 = ied + 1
1510  jedp1 = jed + 1
1511  remap_t = .false.
1512  remap_pt = .false.
1513  remap_te = .false.
1514  SELECT CASE (remap_option)
1515  CASE (0)
1516  remap_t = .true.
1517  CASE (1)
1518  remap_pt = .true.
1519  CASE (2)
1520  remap_te = .true.
1521  CASE DEFAULT
1522  print*, ' INVALID REMAPPING OPTION '
1523  stop
1524  END SELECT
1525  IF (is_master() .AND. flagstruct%fv_debug) THEN
1526  print*, ''
1527  SELECT CASE (remap_option)
1528  CASE (0)
1529  print*, ' REMAPPING T in logP '
1530  CASE (1)
1531  print*, ' REMAPPING PT in P'
1532  CASE (2)
1533  print*, ' REMAPPING TE in logP with GMAO cubic'
1534  END SELECT
1535  print*, ' REMAPPING CONSV: ', consv
1536  print*, ' REMAPPING CONSV_MIN: ', consv_min
1537  print*, ''
1538  END IF
1539  IF (flagstruct%fv_debug) CALL prt_mxm('remap-0 PT', pt, is, ie, js&
1540 & , je, ng, km, 1., gridstruct%area_64&
1541 & , domain)
1542 ! akap / (1.-akap) = rg/Cv=0.4
1543  k1k = rdgas/cv_air
1544  rg = rdgas
1545  rcp = 1./cp
1546  rrg = -(rdgas/grav)
1547  IF (fpp%fpp_mapl_mode) THEN
1548  liq_wat = 2
1549  ice_wat = 3
1550  rainwat = -1
1551  snowwat = -1
1552  graupel = -1
1553  cld_amt = -1
1554  ELSE
1555  liq_wat = get_tracer_index(model_atmos, 'liq_wat')
1556  ice_wat = get_tracer_index(model_atmos, 'ice_wat')
1557  rainwat = get_tracer_index(model_atmos, 'rainwat')
1558  snowwat = get_tracer_index(model_atmos, 'snowwat')
1559  graupel = get_tracer_index(model_atmos, 'graupel')
1560  cld_amt = get_tracer_index(model_atmos, 'cld_amt')
1561  END IF
1562  IF (do_sat_adj) THEN
1563  fast_mp_consv = .NOT.do_adiabatic_init .AND. consv .GT. consv_min
1564  DO k=1,km
1565  kmp = k
1566  IF (pfull(k) .GT. 10.e2) GOTO 100
1567  END DO
1568  100 CALL qs_init(kmp)
1569  END IF
1570 !$OMP parallel do default(none) shared(is,ie,js,je,km,pe,ptop,kord_tm,hydrostatic, &
1571 !$OMP pt,pk,rg,peln,q,nwat,liq_wat,rainwat,ice_wat,snowwat, &
1572 !$OMP graupel,q_con,sphum,cappa,r_vir,rcp,k1k,delp, &
1573 !$OMP delz,akap,pkz,te,u,v,ps, gridstruct, last_step, &
1574 !$OMP ak,bk,nq,isd,ied,jsd,jed,kord_tr,fill, adiabatic, &
1575 !$OMP hs,w,ws,kord_wz,do_omega,omga,rrg,kord_mt,ua) &
1576 !$OMP private(qv,gz,cvm,kp,k_next,bkh,dp2, &
1577 !$OMP pe0,pe1,pe2,pe3,pk1,pk2,pn2,phis,q2)
1578  DO j=js,je+1
1579  DO k=1,km+1
1580  DO i=is,ie
1581  pe1(i, k) = pe(i, k, j)
1582  END DO
1583  END DO
1584  DO i=is,ie
1585  pe2(i, 1) = ptop
1586  pe2(i, km+1) = pe(i, km+1, j)
1587  END DO
1588 !(j < je+1)
1589  IF (j .NE. je + 1) THEN
1590  IF (remap_t) THEN
1591 ! hydro test
1592 ! Remap T in logP
1593 ! Note: pt at this stage is Theta_v
1594  IF (hydrostatic) THEN
1595 ! Transform virtual pt to virtual Temp
1596  DO k=1,km
1597  DO i=is,ie
1598  pt(i, j, k) = pt(i, j, k)*(pk(i, j, k+1)-pk(i, j, k))/(&
1599 & akap*(peln(i, k+1, j)-peln(i, k, j)))
1600  END DO
1601  END DO
1602  ELSE
1603 ! Transform "density pt" to "density temp"
1604  DO k=1,km
1605  DO i=is,ie
1606  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1607  arg2 = k1k*log(arg1)
1608  pt(i, j, k) = pt(i, j, k)*exp(arg2)
1609  END DO
1610  END DO
1611  END IF
1612  ELSE IF (.NOT.remap_pt) THEN
1613 ! Using dry pressure for the definition of the virtual potential temperature
1614 ! pt(i,j,k) = pt(i,j,k)*exp(k1k*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)* &
1615 ! pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
1616 ! Remap PT in P
1617 ! pt is already virtual PT
1618  IF (remap_te) THEN
1619 ! Remap TE in logP
1620 ! Transform virtual pt to total energy
1621  CALL pkez(km, is, ie, js, je, j, pe, pk, akap, peln, pkz, &
1622 & ptop)
1623 ! Compute cp*T + KE
1624  DO k=1,km
1625  DO i=is,ie
1626  te(i, j, k) = 0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2&
1627 & +u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j&
1628 & , k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1629 & gridstruct%cosa_s(i, j)) + cp_air*pt(i, j, k)*pkz(i, j&
1630 & , k)
1631  END DO
1632  END DO
1633  END IF
1634  END IF
1635  IF (.NOT.hydrostatic) THEN
1636  DO k=1,km
1637  DO i=is,ie
1638 ! ="specific volume"/grav
1639  delz(i, j, k) = -(delz(i, j, k)/delp(i, j, k))
1640  END DO
1641  END DO
1642  END IF
1643 ! update ps
1644  DO i=is,ie
1645  ps(i, j) = pe1(i, km+1)
1646  END DO
1647 !
1648 ! Hybrid sigma-P coordinate:
1649 !
1650  DO k=2,km
1651  DO i=is,ie
1652  pe2(i, k) = ak(k) + bk(k)*pe(i, km+1, j)
1653  END DO
1654  END DO
1655  DO k=1,km
1656  DO i=is,ie
1657  dp2(i, k) = pe2(i, k+1) - pe2(i, k)
1658  END DO
1659  END DO
1660 !------------
1661 ! update delp
1662 !------------
1663  DO k=1,km
1664  DO i=is,ie
1665  delp(i, j, k) = dp2(i, k)
1666  END DO
1667  END DO
1668 !------------------
1669 ! Compute p**Kappa
1670 !------------------
1671  DO k=1,km+1
1672  DO i=is,ie
1673  pk1(i, k) = pk(i, j, k)
1674  END DO
1675  END DO
1676  DO i=is,ie
1677  pn2(i, 1) = peln(i, 1, j)
1678  pn2(i, km+1) = peln(i, km+1, j)
1679  pk2(i, 1) = pk1(i, 1)
1680  pk2(i, km+1) = pk1(i, km+1)
1681  END DO
1682  DO k=2,km
1683  DO i=is,ie
1684  pn2(i, k) = log(pe2(i, k))
1685  pk2(i, k) = exp(akap*pn2(i, k))
1686  END DO
1687  END DO
1688  IF (remap_t) THEN
1689 !----------------------------------
1690 ! Map t using logp
1691 !----------------------------------
1692  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
1693  CALL map_scalar(km, peln(is:ie, 1:km+1, j), gz, km, pn2, &
1694 & pt, is, ie, j, isd, ied, jsd, jed, 1, &
1695 & abs_kord_tm, t_min)
1696  ELSE
1697  call map_scalar(km, peln(is:ie,1:km+1,j), gz, &
1698  km, pn2, pt, &
1699  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm, t_min)
1700  END IF
1701  ELSE IF (remap_pt) THEN
1702 !----------------------------------
1703 ! Map pt using pe
1704 !----------------------------------
1705  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
1706  CALL map1_ppm(km, pe1, gz, km, pe2, pt, is, ie, j, isd, &
1707 & ied, jsd, jed, 1, abs_kord_tm)
1708  ELSE
1709  call map1_ppm (km, pe1, gz, &
1710  km, pe2, pt, &
1711  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm)
1712  END IF
1713  ELSE IF (remap_te) THEN
1714 !----------------------------------
1715 ! map Total Energy using GMAO cubic
1716 !----------------------------------
1717  DO i=is,ie
1718  phis(i, km+1) = hs(i, j)
1719  END DO
1720  DO k=km,1,-1
1721  DO i=is,ie
1722  phis(i, k) = phis(i, k+1) + cp_air*pt(i, j, k)*(pk1(i, k+1&
1723 & )-pk1(i, k))
1724  END DO
1725  END DO
1726  DO k=1,km+1
1727  DO i=is,ie
1728  phis(i, k) = phis(i, k)*pe1(i, k)
1729  END DO
1730  END DO
1731  DO k=1,km
1732  DO i=is,ie
1733  te(i, j, k) = te(i, j, k) + (phis(i, k+1)-phis(i, k))/(pe1&
1734 & (i, k+1)-pe1(i, k))
1735  END DO
1736  END DO
1737 ! Map te using log P in GMAO cubic
1738  CALL map1_cubic(km, pe1, km, pe2, te, is, ie, j, isd, ied, jsd&
1739 & , jed, akap, 1, .true.)
1740  END IF
1741 !----------------
1742 ! Map constituents
1743 !----------------
1744  IF (nq .GT. 5) THEN
1745  IF (kord_tr(1) .EQ. kord_tr_pert(1)) THEN
1746  CALL mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, is&
1747 & , ie, isd, ied, jsd, jed, 0., fill)
1748  ELSE
1749  call mapn_tracer(nq, km, pe1, pe2, q, dp2, kord_tr, j, &
1750  is, ie, isd, ied, jsd, jed, 0., fill)
1751  END IF
1752  ELSE IF (nq .GT. 0) THEN
1753 ! Remap one tracer at a time
1754  DO iq=1,nq
1755  IF (kord_tr(iq) .EQ. kord_tr_pert(iq)) THEN
1756  CALL map1_q2(km, pe1, q(isd:ied, jsd:jed, 1:km, iq), km&
1757 & , pe2, q2, dp2, is, ie, 0, kord_tr(iq), j, isd, &
1758 & ied, jsd, jed, 0.)
1759  ELSE
1760  call map1_q2(km, pe1, q(isd:ied,jsd:jed,1:km,iq), &
1761  km, pe2, q2, dp2, &
1762  is, ie, 0, kord_tr(iq), j, isd, ied, jsd, jed, 0.)
1763  END IF
1764  IF (fill) CALL fillz(ie - is + 1, km, 1, q2, dp2)
1765  DO k=1,km
1766  DO i=is,ie
1767  q(i, j, k, iq) = q2(i, k)
1768  END DO
1769  END DO
1770  END DO
1771  END IF
1772  IF (.NOT.hydrostatic) THEN
1773 ! Remap vertical wind:
1774  IF (kord_wz .EQ. kord_wz_pert) THEN
1775  CALL map1_ppm(km, pe1, ws(is:ie, j), km, pe2, w, is, ie, &
1776 & j, isd, ied, jsd, jed, -2, kord_wz)
1777  ELSE
1778  call map1_ppm (km, pe1, ws(is:ie,j), &
1779  km, pe2, w, &
1780  is, ie, j, isd, ied, jsd, jed, -2, kord_wz)
1781  END IF
1782 ! Remap delz for hybrid sigma-p coordinate
1783  IF (abs_kord_tm .EQ. abs_kord_tm_pert) THEN
1784  CALL map1_ppm(km, pe1, gz, km, pe2, delz, is, ie, j, isd&
1785 & , ied, jsd, jed, 1, abs_kord_tm)
1786  ELSE
1787  call map1_ppm (km, pe1, gz, &
1788  km, pe2, delz, &
1789  is, ie, j, isd, ied, jsd, jed, 1, abs_kord_tm)
1790  END IF
1791  DO k=1,km
1792  DO i=is,ie
1793  delz(i, j, k) = -(delz(i, j, k)*dp2(i, k))
1794  END DO
1795  END DO
1796  END IF
1797 !----------
1798 ! Update pk
1799 !----------
1800  DO k=1,km+1
1801  DO i=is,ie
1802  pk(i, j, k) = pk2(i, k)
1803  END DO
1804  END DO
1805 !----------------
1806  IF (do_omega) THEN
1807 ! Start do_omega
1808 ! Copy omega field to pe3
1809  DO i=is,ie
1810  pe3(i, 1) = 0.
1811  END DO
1812  DO k=2,km+1
1813  DO i=is,ie
1814  pe3(i, k) = omga(i, j, k-1)
1815  END DO
1816  END DO
1817  END IF
1818  DO k=1,km+1
1819  DO i=is,ie
1820  pe0(i, k) = peln(i, k, j)
1821  peln(i, k, j) = pn2(i, k)
1822  END DO
1823  END DO
1824 !------------
1825 ! Compute pkz
1826 !------------
1827  IF (hydrostatic) THEN
1828  DO k=1,km
1829  DO i=is,ie
1830  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1&
1831 & , j)-peln(i, k, j)))
1832  END DO
1833  END DO
1834  ELSE IF (remap_te) THEN
1835 ! WMP: note that this is where TE remapping non-hydrostatic is invalid and cannot be run
1836  print*, &
1837 & 'TE remapping non-hydrostatic is invalid and cannot be run'
1838  stop
1839  ELSE IF (remap_t) THEN
1840 ! Note: pt at this stage is T_v or T_m
1841  DO k=1,km
1842  DO i=is,ie
1843  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1844  arg2 = akap*log(arg1)
1845  pkz(i, j, k) = exp(arg2)
1846  END DO
1847  END DO
1848  ELSE
1849 ! Using dry pressure for the definition of the virtual potential temperature
1850 ! pkz(i,j,k) = exp(akap*log(rrg*(1.-q(i,j,k,sphum))*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)/(1.+r_vir*q(i,j,k,sphum))))
1851 ! Note: pt at this stage is Theta_v
1852  DO k=1,km
1853  DO i=is,ie
1854  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
1855  arg2 = k1k*log(arg1)
1856  pkz(i, j, k) = exp(arg2)
1857  END DO
1858  END DO
1859  END IF
1860 ! end do_omega
1861 ! Interpolate omega/pe3 (defined at pe0) to remapped cell center (dp2)
1862  IF (do_omega) THEN
1863  DO k=1,km
1864  DO i=is,ie
1865  dp2(i, k) = 0.5*(peln(i, k, j)+peln(i, k+1, j))
1866  END DO
1867  END DO
1868  DO i=is,ie
1869  k_next = 1
1870  DO 110 n=1,km
1871  kp = k_next
1872  DO k=kp,km
1873  IF (dp2(i, n) .LE. pe0(i, k+1) .AND. dp2(i, n) .GE. pe0(&
1874 & i, k)) THEN
1875  omga(i, j, n) = pe3(i, k) + (pe3(i, k+1)-pe3(i, k))*(&
1876 & dp2(i, n)-pe0(i, k))/(pe0(i, k+1)-pe0(i, k))
1877  k_next = k
1878  GOTO 110
1879  END IF
1880  END DO
1881  110 CONTINUE
1882  END DO
1883  END IF
1884  END IF
1885  DO i=is,ie+1
1886  pe0(i, 1) = pe(i, 1, j)
1887  END DO
1888 !------
1889 ! map u
1890 !------
1891  DO k=2,km+1
1892  DO i=is,ie
1893  pe0(i, k) = 0.5*(pe(i, k, j-1)+pe1(i, k))
1894  END DO
1895  END DO
1896  DO k=1,km+1
1897  bkh = 0.5*bk(k)
1898  DO i=is,ie
1899  pe3(i, k) = ak(k) + bkh*(pe(i, km+1, j-1)+pe1(i, km+1))
1900  END DO
1901  END DO
1902  IF (kord_mt .EQ. kord_mt_pert) THEN
1903  CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:ie, :), u, is&
1904 & , ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
1905  ELSE
1906  call map1_ppm( km, pe0(is:ie,:), gz, &
1907  km, pe3(is:ie,:), u, &
1908  is, ie, j, isd, ied, jsd, jedp1, -1, kord_mt)
1909  END IF
1910  IF (PRESENT(mfy)) CALL map1_ppm(km, pe0(is:ie, :), gz, km, pe3(is:&
1911 & ie, :), mfy, is, ie, j, is, ie, js, jep1&
1912 & , -1, kord_mt)
1913 ! (j < je+1)
1914  IF (j .LT. je + 1) THEN
1915 !------
1916 ! map v
1917 !------
1918  DO i=is,ie+1
1919  pe3(i, 1) = ak(1)
1920  END DO
1921  DO k=2,km+1
1922  bkh = 0.5*bk(k)
1923  DO i=is,ie+1
1924  pe0(i, k) = 0.5*(pe(i-1, k, j)+pe(i, k, j))
1925  pe3(i, k) = ak(k) + bkh*(pe(i-1, km+1, j)+pe(i, km+1, j))
1926  END DO
1927  END DO
1928  IF (kord_mt .EQ. kord_mt_pert) THEN
1929  CALL map1_ppm(km, pe0, gz, km, pe3, v, is, iep1, j, isd, &
1930 & iedp1, jsd, jed, -1, kord_mt)
1931  ELSE
1932  call map1_ppm (km, pe0, gz, &
1933  km, pe3, v, is, ie+1, &
1934  j, isd, iedp1, jsd, jed, -1, kord_mt)
1935  END IF
1936  IF (PRESENT(mfx)) CALL map1_ppm(km, pe0, gz, km, pe3, mfx, is, &
1937 & iep1, j, is, iep1, js, je, -1, kord_mt&
1938 & )
1939  END IF
1940  DO k=1,km
1941  DO i=is,ie
1942  ua(i, j, k) = pe2(i, k+1)
1943  END DO
1944  END DO
1945  END DO
1946 !$OMP parallel default(none) shared(is,ie,js,je,km,kmp,ptop,u,v,pe,ua,isd,ied,jsd,jed,kord_mt, &
1947 !$OMP te_2d,te,delp,hydrostatic,hs,rg,pt,peln, adiabatic, &
1948 !$OMP cp,delz,nwat,rainwat,liq_wat,ice_wat,snowwat, &
1949 !$OMP graupel,q_con,r_vir,sphum,w,pk,pkz,last_step,consv, &
1950 !$OMP do_adiabatic_init,zsum1,zsum0,te0_2d,domain, &
1951 !$OMP ng,gridstruct,E_Flux,pdt,dtmp,reproduce_sum,q, &
1952 !$OMP mdt,cld_amt,cappa,dtdt,out_dt,rrg,akap,do_sat_adj, &
1953 !$OMP fast_mp_consv,kord_tm) &
1954 !$OMP private(pe0,pe1,pe2,pe3,qv,cvm,gz,phis,tpe,tmp, dpln)
1955 !$OMP do
1956  DO k=2,km
1957  DO j=js,je
1958  DO i=is,ie
1959  pe(i, k, j) = ua(i, j, k-1)
1960  END DO
1961  END DO
1962  END DO
1963  IF (flagstruct%fv_debug) THEN
1964  IF (kord_tm .LT. 0) THEN
1965  CALL prt_mxm('remap-1 TV', pt, is, ie, js, je, ng, km, 1., &
1966 & gridstruct%area_64, domain)
1967  ELSE
1968  CALL prt_mxm('remap-1 PT', pt, is, ie, js, je, ng, km, 1., &
1969 & gridstruct%area_64, domain)
1970  END IF
1971  END IF
1972  dtmp = 0.
1973 ! end last_step check
1974  IF (last_step .AND. (.NOT.do_adiabatic_init)) THEN
1975 ! end consv check
1976  IF (consv .GT. consv_min) THEN
1977 !$OMP do
1978  DO j=js,je
1979  IF (remap_t) THEN
1980 ! end non-hydro
1981  IF (hydrostatic) THEN
1982  DO i=is,ie
1983  gz(i) = hs(i, j)
1984  DO k=1,km
1985  gz(i) = gz(i) + rg*pt(i, j, k)*(peln(i, k+1, j)-peln(i&
1986 & , k, j))
1987  END DO
1988  END DO
1989  DO i=is,ie
1990  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
1991 & )
1992  END DO
1993  DO k=1,km
1994  DO i=is,ie
1995  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*pt(i, j&
1996 & , k)+0.25*gridstruct%rsin2(i, j)*(u(i, j, k)**2+u(i&
1997 & , j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)**2-(u(i, j, &
1998 & k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
1999 & gridstruct%cosa_s(i, j)))
2000  END DO
2001  END DO
2002  ELSE
2003  DO i=is,ie
2004  te_2d(i, j) = 0.
2005  phis(i, km+1) = hs(i, j)
2006  END DO
2007  DO k=km,1,-1
2008  DO i=is,ie
2009  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
2010  END DO
2011  END DO
2012  DO k=1,km
2013  DO i=is,ie
2014  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
2015 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
2016 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
2017 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
2018 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
2019 & i+1, j, k))*gridstruct%cosa_s(i, j))))
2020  END DO
2021  END DO
2022  END IF
2023  ELSE IF (remap_pt) THEN
2024 ! k-loop
2025  IF (hydrostatic) THEN
2026  DO i=is,ie
2027  gz(i) = hs(i, j)
2028  DO k=1,km
2029  gz(i) = gz(i) + cp_air*pt(i, j, k)*(pk(i, j, k+1)-pk(i&
2030 & , j, k))
2031  END DO
2032  END DO
2033  DO i=is,ie
2034  te_2d(i, j) = pe(i, km+1, j)*hs(i, j) - pe(i, 1, j)*gz(i&
2035 & )
2036  END DO
2037  DO k=1,km
2038  DO i=is,ie
2039  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp_air*pt(i&
2040 & , j, k)*pkz(i, j, k)+0.25*gridstruct%rsin2(i, j)*(u(&
2041 & i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, &
2042 & k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j&
2043 & , k))*gridstruct%cosa_s(i, j)))
2044  END DO
2045  END DO
2046  ELSE
2047 !-----------------
2048 ! Non-hydrostatic:
2049 !-----------------
2050  DO i=is,ie
2051  phis(i, km+1) = hs(i, j)
2052  DO k=km,1,-1
2053  phis(i, k) = phis(i, k+1) - grav*delz(i, j, k)
2054  END DO
2055  END DO
2056  DO i=is,ie
2057  te_2d(i, j) = 0.
2058  END DO
2059  DO k=1,km
2060  DO i=is,ie
2061  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i&
2062 & , j, k)/(1.+r_vir*q(i, j, k, sphum))+0.5*(phis(i, k)&
2063 & +phis(i, k+1)+w(i, j, k)**2+0.5*gridstruct%rsin2(i, &
2064 & j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+&
2065 & 1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(&
2066 & i+1, j, k))*gridstruct%cosa_s(i, j))))
2067  END DO
2068  END DO
2069  END IF
2070  ELSE IF (remap_te) THEN
2071  DO i=is,ie
2072  te_2d(i, j) = te(i, j, 1)*delp(i, j, 1)
2073  END DO
2074  DO k=2,km
2075  DO i=is,ie
2076  te_2d(i, j) = te_2d(i, j) + te(i, j, k)*delp(i, j, k)
2077  END DO
2078  END DO
2079  END IF
2080  DO i=is,ie
2081  te_2d(i, j) = te0_2d(i, j) - te_2d(i, j)
2082  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
2083  END DO
2084  DO k=2,km
2085  DO i=is,ie
2086  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
2087  END DO
2088  END DO
2089  IF (hydrostatic) THEN
2090  DO i=is,ie
2091  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
2092 & , j)
2093  END DO
2094  END IF
2095  END DO
2096 ! j-loop
2097 !$OMP single
2098  result1 = g_sum(domain, te_2d, is, ie, js, je, ng, gridstruct%&
2099 & area_64, 0, .true.)
2100  tpe = consv*result1
2101 ! unit: W/m**2
2102  e_flux = tpe/(grav*pdt*4.*pi*radius**2)
2103 ! Note pdt is "phys" time step
2104  IF (hydrostatic) THEN
2105  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
2106 & area_64, 0, .true.)
2107  dtmp = tpe/(cp*result1)
2108  ELSE
2109  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
2110 & area_64, 0, .true.)
2111  dtmp = tpe/(cv_air*result1)
2112  END IF
2113  ELSE IF (consv .LT. -consv_min) THEN
2114 !$OMP end single
2115 !$OMP do
2116  DO j=js,je
2117  DO i=is,ie
2118  zsum1(i, j) = pkz(i, j, 1)*delp(i, j, 1)
2119  END DO
2120  DO k=2,km
2121  DO i=is,ie
2122  zsum1(i, j) = zsum1(i, j) + pkz(i, j, k)*delp(i, j, k)
2123  END DO
2124  END DO
2125  IF (hydrostatic) THEN
2126  DO i=is,ie
2127  zsum0(i, j) = ptop*(pk(i, j, 1)-pk(i, j, km+1)) + zsum1(i&
2128 & , j)
2129  END DO
2130  END IF
2131  END DO
2132  e_flux = consv
2133 !$OMP single
2134  IF (hydrostatic) THEN
2135  result1 = g_sum(domain, zsum0, is, ie, js, je, ng, gridstruct%&
2136 & area_64, 0, .true.)
2137  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cp*result1)
2138  ELSE
2139  result1 = g_sum(domain, zsum1, is, ie, js, je, ng, gridstruct%&
2140 & area_64, 0, .true.)
2141  dtmp = e_flux*(grav*pdt*4.*pi*radius**2)/(cv_air*result1)
2142  END IF
2143  END IF
2144  END IF
2145 !$OMP end single
2146 ! do_sat_adj
2147 ! Note: pt at this stage is T_v
2148  IF (remap_t .AND. (.NOT.do_adiabatic_init) .AND. do_sat_adj) THEN
2149 ! if ( do_sat_adj ) then
2150  CALL timing_on('sat_adj2')
2151 !$OMP do
2152  DO k=kmp,km
2153  DO j=js,je
2154  DO i=is,ie
2155  dpln(i, j) = peln(i, k+1, j) - peln(i, k, j)
2156  END DO
2157  END DO
2158  IF (mdt .GE. 0.) THEN
2159  abs0 = mdt
2160  ELSE
2161  abs0 = -mdt
2162  END IF
2163  CALL fv_sat_adj(abs0, r_vir, is, ie, js, je, ng, hydrostatic, &
2164 & fast_mp_consv, te(isd:ied, jsd:jed, k), q(isd:ied, jsd&
2165 & :jed, k, sphum), q(isd:ied, jsd:jed, k, liq_wat), q(&
2166 & isd:ied, jsd:jed, k, ice_wat), q(isd:ied, jsd:jed, k, &
2167 & rainwat), q(isd:ied, jsd:jed, k, snowwat), q(isd:ied, &
2168 & jsd:jed, k, graupel), dpln, delz(isd:ied, jsd:jed, k)&
2169 & , pt(isd:ied, jsd:jed, k), delp(isd:ied, jsd:jed, k), &
2170 & q_con(isd:ied, jsd:jed, k), cappa(isd:ied, jsd:jed, k)&
2171 & , gridstruct%area_64, dtdt(is:ie, js:je, k), out_dt, &
2172 & last_step, cld_amt .GT. 0, q(isd:ied, jsd:jed, k, &
2173 & cld_amt))
2174  IF (.NOT.hydrostatic) THEN
2175  DO j=js,je
2176  DO i=is,ie
2177  arg1 = rrg*delp(i, j, k)/delz(i, j, k)*pt(i, j, k)
2178  arg2 = akap*log(arg1)
2179  pkz(i, j, k) = exp(arg2)
2180  END DO
2181  END DO
2182  END IF
2183  END DO
2184 ! OpenMP k-loop
2185  IF (fast_mp_consv) THEN
2186 !$OMP do
2187  DO j=js,je
2188  DO i=is,ie
2189  DO k=kmp,km
2190  te0_2d(i, j) = te0_2d(i, j) + te(i, j, k)
2191  END DO
2192  END DO
2193  END DO
2194  END IF
2195  CALL timing_off('sat_adj2')
2196  END IF
2197 ! last_step
2198  IF (last_step) THEN
2199 ! Output temperature if last_step
2200  IF (remap_t) THEN
2201 !$OMP do
2202  DO k=1,km
2203  DO j=js,je
2204  IF (.NOT.adiabatic) THEN
2205  DO i=is,ie
2206  pt(i, j, k) = (pt(i, j, k)+dtmp*pkz(i, j, k))/(1.+r_vir*&
2207 & q(i, j, k, sphum))
2208  END DO
2209  END IF
2210  END DO
2211  END DO
2212  ELSE IF (remap_pt) THEN
2213 ! j-loop
2214 ! k-loop
2215 !$OMP do
2216  DO k=1,km
2217  DO j=js,je
2218  DO i=is,ie
2219  pt(i, j, k) = (pt(i, j, k)+dtmp)*pkz(i, j, k)/(1.+r_vir*q(&
2220 & i, j, k, sphum))
2221  END DO
2222  END DO
2223  END DO
2224  ELSE IF (remap_te) THEN
2225 !$OMP do
2226  DO j=js,je
2227  DO i=is,ie
2228  gz(i) = hs(i, j)
2229  END DO
2230  DO k=km,1,-1
2231  DO i=is,ie
2232  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
2233 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
2234 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
2235 & gridstruct%cosa_s(i, j))
2236  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
2237  tmp = tpe/((cp-pe(i, k, j)*dlnp/delp(i, j, k))*(1.+r_vir*q&
2238 & (i, j, k, sphum)))
2239  pt(i, j, k) = tmp + dtmp*pkz(i, j, k)/(1.+r_vir*q(i, j, k&
2240 & , sphum))
2241  gz(i) = gz(i) + dlnp*tmp*(1.+r_vir*q(i, j, k, sphum))
2242  END DO
2243  END DO
2244  END DO
2245  END IF
2246 ! end k-loop
2247  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 TA', pt, is, ie, &
2248 & js, je, ng, km, 1., gridstruct%&
2249 & area_64, domain)
2250  ELSE
2251 ! not last_step
2252  IF (remap_t) THEN
2253 !$OMP do
2254  DO k=1,km
2255  DO j=js,je
2256  DO i=is,ie
2257  pt(i, j, k) = pt(i, j, k)/pkz(i, j, k)
2258  END DO
2259  END DO
2260  END DO
2261  ELSE IF (remap_te) THEN
2262 !$OMP do
2263  DO j=js,je
2264  DO i=is,ie
2265  gz(i) = hs(i, j)
2266  END DO
2267  DO k=km,1,-1
2268  DO i=is,ie
2269  tpe = te(i, j, k) - gz(i) - 0.25*gridstruct%rsin2(i, j)*(u&
2270 & (i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2+v(i+1, j, k)&
2271 & **2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))*&
2272 & gridstruct%cosa_s(i, j))
2273  dlnp = rg*(peln(i, k+1, j)-peln(i, k, j))
2274  tmp = tpe/(cp-pe(i, k, j)*dlnp/delp(i, j, k))
2275  pt(i, j, k) = tmp/pkz(i, j, k) + dtmp
2276  gz(i) = gz(i) + dlnp*tmp
2277  END DO
2278  END DO
2279  END DO
2280  END IF
2281 ! end k-loop
2282  IF (flagstruct%fv_debug) CALL prt_mxm('remap-3 PT', pt, is, ie, &
2283 & js, je, ng, km, 1., gridstruct%&
2284 & area_64, domain)
2285  END IF
2286  END SUBROUTINE lagrangian_to_eulerian
2287 ! Differentiation of compute_total_energy in forward (tangent) mode:
2288 ! variations of useful results: teq te_2d
2289 ! with respect to varying inputs: qc peln q u v w delp delz pe
2290 ! pt
2291  SUBROUTINE compute_total_energy_tlm(is, ie, js, je, isd, ied, jsd, jed&
2292 & , km, u, u_tl, v, v_tl, w, w_tl, delz, delz_tl, pt, pt_tl, delp, &
2293 & delp_tl, q, q_tl, qc, qc_tl, pe, pe_tl, peln, peln_tl, hs, rsin2_l, &
2294 & cosa_s_l, r_vir, cp, rg, hlv, te_2d, te_2d_tl, ua, va, teq, teq_tl, &
2295 & moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel&
2296 & , hydrostatic, id_te)
2297  IMPLICIT NONE
2298 !------------------------------------------------------
2299 ! Compute vertically integrated total energy per column
2300 !------------------------------------------------------
2301 ! !INPUT PARAMETERS:
2302  INTEGER, INTENT(IN) :: km, is, ie, js, je, isd, ied, jsd, jed, id_te
2303  INTEGER, INTENT(IN) :: sphum, liq_wat, ice_wat, rainwat, snowwat, &
2304 & graupel, nwat
2305  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: ua, va
2306  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt, delp
2307  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt_tl, delp_tl
2308  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q
2309  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q_tl
2310  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc
2311  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc_tl
2312  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
2313  REAL, INTENT(INOUT) :: u_tl(isd:ied, jsd:jed+1, km)
2314  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
2315  REAL, INTENT(INOUT) :: v_tl(isd:ied+1, jsd:jed, km)
2316 ! vertical velocity (m/s)
2317  REAL, INTENT(IN) :: w(isd:ied, jsd:jed, km)
2318  REAL, INTENT(IN) :: w_tl(isd:ied, jsd:jed, km)
2319  REAL, INTENT(IN) :: delz(isd:ied, jsd:jed, km)
2320  REAL, INTENT(IN) :: delz_tl(isd:ied, jsd:jed, km)
2321 ! surface geopotential
2322  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
2323 ! pressure at layer edges
2324  REAL, INTENT(IN) :: pe(is-1:ie+1, km+1, js-1:je+1)
2325  REAL, INTENT(IN) :: pe_tl(is-1:ie+1, km+1, js-1:je+1)
2326 ! log(pe)
2327  REAL, INTENT(IN) :: peln(is:ie, km+1, js:je)
2328  REAL, INTENT(IN) :: peln_tl(is:ie, km+1, js:je)
2329  REAL, INTENT(IN) :: cp, rg, r_vir, hlv
2330  REAL, INTENT(IN) :: rsin2_l(isd:ied, jsd:jed)
2331  REAL, INTENT(IN) :: cosa_s_l(isd:ied, jsd:jed)
2332  LOGICAL, INTENT(IN) :: moist_phys, hydrostatic
2333 ! Output:
2334 ! vertically integrated TE
2335  REAL, INTENT(OUT) :: te_2d(is:ie, js:je)
2336  REAL, INTENT(OUT) :: te_2d_tl(is:ie, js:je)
2337 ! Moist TE
2338  REAL, INTENT(OUT) :: teq(is:ie, js:je)
2339  REAL, INTENT(OUT) :: teq_tl(is:ie, js:je)
2340 ! Local
2341  REAL, DIMENSION(is:ie, km) :: tv
2342  REAL, DIMENSION(is:ie, km) :: tv_tl
2343  REAL :: phiz(is:ie, km+1)
2344  REAL :: phiz_tl(is:ie, km+1)
2345  REAL :: cvm(is:ie), qd(is:ie)
2346  INTEGER :: i, j, k
2347  te_2d_tl = 0.0
2348  phiz_tl = 0.0
2349  tv_tl = 0.0
2350 !----------------------
2351 ! Output lat-lon winds:
2352 !----------------------
2353 ! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, flagstruct%c2l_ord)
2354 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,rg,peln,te_2d, &
2355 !$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, &
2356 !$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum) &
2357 !$OMP private(phiz, tv, cvm, qd)
2358  DO j=js,je
2359  IF (hydrostatic) THEN
2360  DO i=is,ie
2361  phiz_tl(i, km+1) = 0.0
2362  phiz(i, km+1) = hs(i, j)
2363  END DO
2364  DO k=km,1,-1
2365  DO i=is,ie
2366  tv_tl(i, k) = pt_tl(i, j, k)*(1.+qc(i, j, k)) + pt(i, j, k)*&
2367 & qc_tl(i, j, k)
2368  tv(i, k) = pt(i, j, k)*(1.+qc(i, j, k))
2369  phiz_tl(i, k) = phiz_tl(i, k+1) + rg*(tv_tl(i, k)*(peln(i, k&
2370 & +1, j)-peln(i, k, j))+tv(i, k)*(peln_tl(i, k+1, j)-peln_tl&
2371 & (i, k, j)))
2372  phiz(i, k) = phiz(i, k+1) + rg*tv(i, k)*(peln(i, k+1, j)-&
2373 & peln(i, k, j))
2374  END DO
2375  END DO
2376  DO i=is,ie
2377  te_2d_tl(i, j) = pe_tl(i, km+1, j)*phiz(i, km+1) + pe(i, km+1&
2378 & , j)*phiz_tl(i, km+1) - pe_tl(i, 1, j)*phiz(i, 1) - pe(i, 1&
2379 & , j)*phiz_tl(i, 1)
2380  te_2d(i, j) = pe(i, km+1, j)*phiz(i, km+1) - pe(i, 1, j)*phiz(&
2381 & i, 1)
2382  END DO
2383  DO k=1,km
2384  DO i=is,ie
2385  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(cp*tv(i&
2386 & , k)+0.25*rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i&
2387 & , j, k)**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i&
2388 & , j, k)+v(i+1, j, k))*cosa_s_l(i, j))) + delp(i, j, k)*(cp&
2389 & *tv_tl(i, k)+0.25*rsin2_l(i, j)*(2*u(i, j, k)*u_tl(i, j, k&
2390 & )+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(i, j, k)*v_tl(i, j, k&
2391 & )+2*v(i+1, j, k)*v_tl(i+1, j, k)-cosa_s_l(i, j)*((u_tl(i, &
2392 & j, k)+u_tl(i, j+1, k))*(v(i, j, k)+v(i+1, j, k))+(u(i, j, &
2393 & k)+u(i, j+1, k))*(v_tl(i, j, k)+v_tl(i+1, j, k)))))
2394  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*tv(i, k)+0.25*&
2395 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2&
2396 & +v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i&
2397 & +1, j, k))*cosa_s_l(i, j)))
2398  END DO
2399  END DO
2400  ELSE
2401 !-----------------
2402 ! Non-hydrostatic:
2403 !-----------------
2404  DO i=is,ie
2405  phiz_tl(i, km+1) = 0.0
2406  phiz(i, km+1) = hs(i, j)
2407  DO k=km,1,-1
2408  phiz_tl(i, k) = phiz_tl(i, k+1) - grav*delz_tl(i, j, k)
2409  phiz(i, k) = phiz(i, k+1) - grav*delz(i, j, k)
2410  END DO
2411  END DO
2412  DO i=is,ie
2413  te_2d_tl(i, j) = 0.0
2414  te_2d(i, j) = 0.
2415  END DO
2416  IF (moist_phys) THEN
2417  DO k=1,km
2418  DO i=is,ie
2419  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(cv_air&
2420 & *pt(i, j, k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+&
2421 & 0.5*rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j&
2422 & , k)**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, &
2423 & j, k)+v(i+1, j, k))*cosa_s_l(i, j)))) + delp(i, j, k)*(&
2424 & cv_air*pt_tl(i, j, k)+0.5*(phiz_tl(i, k)+phiz_tl(i, k+1)&
2425 & +2*w(i, j, k)*w_tl(i, j, k)+0.5*rsin2_l(i, j)*(2*u(i, j&
2426 & , k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(i&
2427 & , j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k)-&
2428 & cosa_s_l(i, j)*((u_tl(i, j, k)+u_tl(i, j+1, k))*(v(i, j&
2429 & , k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+1, k))*(v_tl(i, j&
2430 & , k)+v_tl(i+1, j, k))))))
2431  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
2432 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
2433 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
2434 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
2435 & )+v(i+1, j, k))*cosa_s_l(i, j))))
2436  END DO
2437  END DO
2438  ELSE
2439  DO k=1,km
2440  DO i=is,ie
2441  te_2d_tl(i, j) = te_2d_tl(i, j) + delp_tl(i, j, k)*(cv_air&
2442 & *pt(i, j, k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+&
2443 & 0.5*rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j&
2444 & , k)**2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, &
2445 & j, k)+v(i+1, j, k))*cosa_s_l(i, j)))) + delp(i, j, k)*(&
2446 & cv_air*pt_tl(i, j, k)+0.5*(phiz_tl(i, k)+phiz_tl(i, k+1)&
2447 & +2*w(i, j, k)*w_tl(i, j, k)+0.5*rsin2_l(i, j)*(2*u(i, j&
2448 & , k)*u_tl(i, j, k)+2*u(i, j+1, k)*u_tl(i, j+1, k)+2*v(i&
2449 & , j, k)*v_tl(i, j, k)+2*v(i+1, j, k)*v_tl(i+1, j, k)-&
2450 & cosa_s_l(i, j)*((u_tl(i, j, k)+u_tl(i, j+1, k))*(v(i, j&
2451 & , k)+v(i+1, j, k))+(u(i, j, k)+u(i, j+1, k))*(v_tl(i, j&
2452 & , k)+v_tl(i+1, j, k))))))
2453  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
2454 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
2455 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
2456 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
2457 & )+v(i+1, j, k))*cosa_s_l(i, j))))
2458  END DO
2459  END DO
2460  END IF
2461  END IF
2462  END DO
2463 !-------------------------------------
2464 ! Diganostics computation for moist TE
2465 !-------------------------------------
2466  IF (id_te .GT. 0) THEN
2467  teq_tl = 0.0
2468 !$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp)
2469  DO j=js,je
2470  DO i=is,ie
2471  teq_tl(i, j) = te_2d_tl(i, j)
2472  teq(i, j) = te_2d(i, j)
2473  END DO
2474  IF (moist_phys) THEN
2475  DO k=1,km
2476  DO i=is,ie
2477  teq_tl(i, j) = teq_tl(i, j) + hlv*(q_tl(i, j, k, sphum)*&
2478 & delp(i, j, k)+q(i, j, k, sphum)*delp_tl(i, j, k))
2479  teq(i, j) = teq(i, j) + hlv*q(i, j, k, sphum)*delp(i, j, k&
2480 & )
2481  END DO
2482  END DO
2483  END IF
2484  END DO
2485  ELSE
2486  teq_tl = 0.0
2487  END IF
2488  END SUBROUTINE compute_total_energy_tlm
2489  SUBROUTINE compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km&
2490 & , u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, cosa_s_l, &
2491 & r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, sphum, &
2492 & liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
2493  IMPLICIT NONE
2494 !------------------------------------------------------
2495 ! Compute vertically integrated total energy per column
2496 !------------------------------------------------------
2497 ! !INPUT PARAMETERS:
2498  INTEGER, INTENT(IN) :: km, is, ie, js, je, isd, ied, jsd, jed, id_te
2499  INTEGER, INTENT(IN) :: sphum, liq_wat, ice_wat, rainwat, snowwat, &
2500 & graupel, nwat
2501  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(INOUT) :: ua, va
2502  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: pt, delp
2503  REAL, DIMENSION(isd:ied, jsd:jed, km, *), INTENT(IN) :: q
2504  REAL, DIMENSION(isd:ied, jsd:jed, km), INTENT(IN) :: qc
2505  REAL, INTENT(INOUT) :: u(isd:ied, jsd:jed+1, km)
2506  REAL, INTENT(INOUT) :: v(isd:ied+1, jsd:jed, km)
2507 ! vertical velocity (m/s)
2508  REAL, INTENT(IN) :: w(isd:ied, jsd:jed, km)
2509  REAL, INTENT(IN) :: delz(isd:ied, jsd:jed, km)
2510 ! surface geopotential
2511  REAL, INTENT(IN) :: hs(isd:ied, jsd:jed)
2512 ! pressure at layer edges
2513  REAL, INTENT(IN) :: pe(is-1:ie+1, km+1, js-1:je+1)
2514 ! log(pe)
2515  REAL, INTENT(IN) :: peln(is:ie, km+1, js:je)
2516  REAL, INTENT(IN) :: cp, rg, r_vir, hlv
2517  REAL, INTENT(IN) :: rsin2_l(isd:ied, jsd:jed)
2518  REAL, INTENT(IN) :: cosa_s_l(isd:ied, jsd:jed)
2519  LOGICAL, INTENT(IN) :: moist_phys, hydrostatic
2520 ! Output:
2521 ! vertically integrated TE
2522  REAL, INTENT(OUT) :: te_2d(is:ie, js:je)
2523 ! Moist TE
2524  REAL, INTENT(OUT) :: teq(is:ie, js:je)
2525 ! Local
2526  REAL, DIMENSION(is:ie, km) :: tv
2527  REAL :: phiz(is:ie, km+1)
2528  REAL :: cvm(is:ie), qd(is:ie)
2529  INTEGER :: i, j, k
2530 !----------------------
2531 ! Output lat-lon winds:
2532 !----------------------
2533 ! call cubed_to_latlon(u, v, ua, va, dx, dy, rdxa, rdya, km, flagstruct%c2l_ord)
2534 !$OMP parallel do default(none) shared(is,ie,js,je,isd,ied,jsd,jed,km,hydrostatic,hs,pt,qc,rg,peln,te_2d, &
2535 !$OMP pe,delp,cp,rsin2_l,u,v,cosa_s_l,delz,moist_phys,w, &
2536 !$OMP q,nwat,liq_wat,rainwat,ice_wat,snowwat,graupel,sphum) &
2537 !$OMP private(phiz, tv, cvm, qd)
2538  DO j=js,je
2539  IF (hydrostatic) THEN
2540  DO i=is,ie
2541  phiz(i, km+1) = hs(i, j)
2542  END DO
2543  DO k=km,1,-1
2544  DO i=is,ie
2545  tv(i, k) = pt(i, j, k)*(1.+qc(i, j, k))
2546  phiz(i, k) = phiz(i, k+1) + rg*tv(i, k)*(peln(i, k+1, j)-&
2547 & peln(i, k, j))
2548  END DO
2549  END DO
2550  DO i=is,ie
2551  te_2d(i, j) = pe(i, km+1, j)*phiz(i, km+1) - pe(i, 1, j)*phiz(&
2552 & i, 1)
2553  END DO
2554  DO k=1,km
2555  DO i=is,ie
2556  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cp*tv(i, k)+0.25*&
2557 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)**2&
2558 & +v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k)+v(i&
2559 & +1, j, k))*cosa_s_l(i, j)))
2560  END DO
2561  END DO
2562  ELSE
2563 !-----------------
2564 ! Non-hydrostatic:
2565 !-----------------
2566  DO i=is,ie
2567  phiz(i, km+1) = hs(i, j)
2568  DO k=km,1,-1
2569  phiz(i, k) = phiz(i, k+1) - grav*delz(i, j, k)
2570  END DO
2571  END DO
2572  DO i=is,ie
2573  te_2d(i, j) = 0.
2574  END DO
2575  IF (moist_phys) THEN
2576  DO k=1,km
2577  DO i=is,ie
2578  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
2579 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
2580 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
2581 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
2582 & )+v(i+1, j, k))*cosa_s_l(i, j))))
2583  END DO
2584  END DO
2585  ELSE
2586  DO k=1,km
2587  DO i=is,ie
2588  te_2d(i, j) = te_2d(i, j) + delp(i, j, k)*(cv_air*pt(i, j&
2589 & , k)+0.5*(phiz(i, k)+phiz(i, k+1)+w(i, j, k)**2+0.5*&
2590 & rsin2_l(i, j)*(u(i, j, k)**2+u(i, j+1, k)**2+v(i, j, k)&
2591 & **2+v(i+1, j, k)**2-(u(i, j, k)+u(i, j+1, k))*(v(i, j, k&
2592 & )+v(i+1, j, k))*cosa_s_l(i, j))))
2593  END DO
2594  END DO
2595  END IF
2596  END IF
2597  END DO
2598 !-------------------------------------
2599 ! Diganostics computation for moist TE
2600 !-------------------------------------
2601  IF (id_te .GT. 0) THEN
2602 !$OMP parallel do default(none) shared(is,ie,js,je,teq,te_2d,moist_phys,km,hlv,sphum,q,delp)
2603  DO j=js,je
2604  DO i=is,ie
2605  teq(i, j) = te_2d(i, j)
2606  END DO
2607  IF (moist_phys) THEN
2608  DO k=1,km
2609  DO i=is,ie
2610  teq(i, j) = teq(i, j) + hlv*q(i, j, k, sphum)*delp(i, j, k&
2611 & )
2612  END DO
2613  END DO
2614  END IF
2615  END DO
2616  END IF
2617  END SUBROUTINE compute_total_energy
2618 ! Differentiation of pkez in forward (tangent) mode:
2619 ! variations of useful results: peln pkz
2620 ! with respect to varying inputs: peln pkz pk
2621  SUBROUTINE pkez_tlm(km, ifirst, ilast, jfirst, jlast, j, pe, pk, pk_tl&
2622 & , akap, peln, peln_tl, pkz, pkz_tl, ptop)
2623  IMPLICIT NONE
2624 ! !INPUT PARAMETERS:
2625  INTEGER, INTENT(IN) :: km, j
2626 ! Latitude strip
2627  INTEGER, INTENT(IN) :: ifirst, ilast
2628 ! Latitude strip
2629  INTEGER, INTENT(IN) :: jfirst, jlast
2630  REAL, INTENT(IN) :: akap
2631  REAL, INTENT(IN) :: pe(ifirst-1:ilast+1, km+1, jfirst-1:jlast+1)
2632  REAL, INTENT(IN) :: pk(ifirst:ilast, jfirst:jlast, km+1)
2633  REAL, INTENT(IN) :: pk_tl(ifirst:ilast, jfirst:jlast, km+1)
2634  REAL, INTENT(IN) :: ptop
2635 ! !OUTPUT
2636  REAL, INTENT(OUT) :: pkz(ifirst:ilast, jfirst:jlast, km)
2637  REAL, INTENT(OUT) :: pkz_tl(ifirst:ilast, jfirst:jlast, km)
2638 ! log (pe)
2639  REAL, INTENT(INOUT) :: peln(ifirst:ilast, km+1, jfirst:jlast)
2640  REAL, INTENT(INOUT) :: peln_tl(ifirst:ilast, km+1, jfirst:jlast)
2641 ! Local
2642  REAL :: pk2(ifirst:ilast, km+1)
2643  REAL :: pk2_tl(ifirst:ilast, km+1)
2644  REAL :: pek
2645  REAL :: pek_tl
2646  REAL :: lnp
2647  REAL :: ak1
2648  INTEGER :: i, k
2649  INTRINSIC log
2650  ak1 = (akap+1.)/akap
2651  pek_tl = pk_tl(ifirst, j, 1)
2652  pek = pk(ifirst, j, 1)
2653  pk2_tl = 0.0
2654  DO i=ifirst,ilast
2655  pk2_tl(i, 1) = pek_tl
2656  pk2(i, 1) = pek
2657  END DO
2658  DO k=2,km+1
2659  DO i=ifirst,ilast
2660 ! peln(i,k,j) = log(pe(i,k,j))
2661  pk2_tl(i, k) = pk_tl(i, j, k)
2662  pk2(i, k) = pk(i, j, k)
2663  END DO
2664  END DO
2665 !---- GFDL modification
2666  IF (ptop .LT. ptop_min) THEN
2667  DO i=ifirst,ilast
2668  peln_tl(i, 1, j) = peln_tl(i, 2, j)
2669  peln(i, 1, j) = peln(i, 2, j) - ak1
2670  END DO
2671  ELSE
2672  lnp = log(ptop)
2673  DO i=ifirst,ilast
2674  peln_tl(i, 1, j) = 0.0
2675  peln(i, 1, j) = lnp
2676  END DO
2677  END IF
2678 !---- GFDL modification
2679  DO k=1,km
2680  DO i=ifirst,ilast
2681  pkz_tl(i, j, k) = ((pk2_tl(i, k+1)-pk2_tl(i, k))*akap*(peln(i, k&
2682 & +1, j)-peln(i, k, j))-(pk2(i, k+1)-pk2(i, k))*akap*(peln_tl(i&
2683 & , k+1, j)-peln_tl(i, k, j)))/(akap*(peln(i, k+1, j)-peln(i, k&
2684 & , j)))**2
2685  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1, j)-&
2686 & peln(i, k, j)))
2687  END DO
2688  END DO
2689  END SUBROUTINE pkez_tlm
2690  SUBROUTINE pkez(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap, &
2691 & peln, pkz, ptop)
2692  IMPLICIT NONE
2693 ! !INPUT PARAMETERS:
2694  INTEGER, INTENT(IN) :: km, j
2695 ! Latitude strip
2696  INTEGER, INTENT(IN) :: ifirst, ilast
2697 ! Latitude strip
2698  INTEGER, INTENT(IN) :: jfirst, jlast
2699  REAL, INTENT(IN) :: akap
2700  REAL, INTENT(IN) :: pe(ifirst-1:ilast+1, km+1, jfirst-1:jlast+1)
2701  REAL, INTENT(IN) :: pk(ifirst:ilast, jfirst:jlast, km+1)
2702  REAL, INTENT(IN) :: ptop
2703 ! !OUTPUT
2704  REAL, INTENT(OUT) :: pkz(ifirst:ilast, jfirst:jlast, km)
2705 ! log (pe)
2706  REAL, INTENT(INOUT) :: peln(ifirst:ilast, km+1, jfirst:jlast)
2707 ! Local
2708  REAL :: pk2(ifirst:ilast, km+1)
2709  REAL :: pek
2710  REAL :: lnp
2711  REAL :: ak1
2712  INTEGER :: i, k
2713  INTRINSIC log
2714  ak1 = (akap+1.)/akap
2715  pek = pk(ifirst, j, 1)
2716  DO i=ifirst,ilast
2717  pk2(i, 1) = pek
2718  END DO
2719  DO k=2,km+1
2720  DO i=ifirst,ilast
2721 ! peln(i,k,j) = log(pe(i,k,j))
2722  pk2(i, k) = pk(i, j, k)
2723  END DO
2724  END DO
2725 !---- GFDL modification
2726  IF (ptop .LT. ptop_min) THEN
2727  DO i=ifirst,ilast
2728  peln(i, 1, j) = peln(i, 2, j) - ak1
2729  END DO
2730  ELSE
2731  lnp = log(ptop)
2732  DO i=ifirst,ilast
2733  peln(i, 1, j) = lnp
2734  END DO
2735  END IF
2736 !---- GFDL modification
2737  DO k=1,km
2738  DO i=ifirst,ilast
2739  pkz(i, j, k) = (pk2(i, k+1)-pk2(i, k))/(akap*(peln(i, k+1, j)-&
2740 & peln(i, k, j)))
2741  END DO
2742  END DO
2743  END SUBROUTINE pkez
2744  SUBROUTINE remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
2745  IMPLICIT NONE
2746 ! !INPUT PARAMETERS:
2747 ! Starting longitude
2748  INTEGER, INTENT(IN) :: i1
2749 ! Finishing longitude
2750  INTEGER, INTENT(IN) :: i2
2751 ! Method order
2752  INTEGER, INTENT(IN) :: kord
2753 ! Original vertical dimension
2754  INTEGER, INTENT(IN) :: km
2755 ! Target vertical dimension
2756  INTEGER, INTENT(IN) :: kn
2757  INTEGER, INTENT(IN) :: iv
2758 ! height at layer edges
2759  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
2760 ! (from model top to bottom surface)
2761 ! hieght at layer edges
2762  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
2763 ! (from model top to bottom surface)
2764 ! Field input
2765  REAL, INTENT(IN) :: q1(i1:i2, km)
2766 ! !INPUT/OUTPUT PARAMETERS:
2767 ! Field output
2768  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
2769 ! !LOCAL VARIABLES:
2770  REAL :: qs(i1:i2)
2771  REAL :: dp1(i1:i2, km)
2772  REAL :: q4(4, i1:i2, km)
2773  REAL :: pl, pr, qsum, delp, esl
2774  INTEGER :: i, k, l, m, k0
2775  DO k=1,km
2776  DO i=i1,i2
2777 ! negative
2778  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
2779  q4(1, i, k) = q1(i, k)
2780  END DO
2781  END DO
2782 ! Compute vertical subgrid distribution
2783  IF (kord .GT. 7) THEN
2784  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
2785  ELSE
2786  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
2787  END IF
2788 ! Mapping
2789  DO i=i1,i2
2790  k0 = 1
2791  DO k=1,kn
2792  DO l=k0,km
2793 ! locate the top edge: pe2(i,k)
2794  IF (pe2(i, k) .LE. pe1(i, l) .AND. pe2(i, k) .GE. pe1(i, l+1)&
2795 & ) THEN
2796  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
2797  IF (pe2(i, k+1) .GE. pe1(i, l+1)) THEN
2798 ! entire new grid is within the original grid
2799  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
2800  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
2801 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
2802  k0 = l
2803  GOTO 555
2804  ELSE
2805 ! Fractional area...
2806  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
2807 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
2808 & pl*(1.+pl))))
2809  DO m=l+1,km
2810 ! locate the bottom edge: pe2(i,k+1)
2811  IF (pe2(i, k+1) .LT. pe1(i, m+1)) THEN
2812 ! Whole layer..
2813  qsum = qsum + dp1(i, m)*q4(1, i, m)
2814  ELSE
2815  delp = pe2(i, k+1) - pe1(i, m)
2816  esl = delp/dp1(i, m)
2817  qsum = qsum + delp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-&
2818 & q4(2, i, m)+q4(4, i, m)*(1.-r23*esl)))
2819  k0 = m
2820  GOTO 123
2821  END IF
2822  END DO
2823  GOTO 123
2824  END IF
2825  END IF
2826  END DO
2827  123 q2(i, k) = qsum/(pe2(i, k+1)-pe2(i, k))
2828  555 CONTINUE
2829  END DO
2830  END DO
2831  END SUBROUTINE remap_z
2832  SUBROUTINE map_scalar(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend&
2833 & , jbeg, jend, iv, kord, q_min)
2834  IMPLICIT NONE
2835 ! iv=1
2836 ! Starting longitude
2837  INTEGER, INTENT(IN) :: i1
2838 ! Finishing longitude
2839  INTEGER, INTENT(IN) :: i2
2840 ! Mode: 0 == constituents 1 == temp
2841  INTEGER, INTENT(IN) :: iv
2842 ! 2 == remap temp with cs scheme
2843 ! Method order
2844  INTEGER, INTENT(IN) :: kord
2845 ! Current latitude
2846  INTEGER, INTENT(IN) :: j
2847  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
2848 ! Original vertical dimension
2849  INTEGER, INTENT(IN) :: km
2850 ! Target vertical dimension
2851  INTEGER, INTENT(IN) :: kn
2852 ! bottom BC
2853  REAL, INTENT(IN) :: qs(i1:i2)
2854 ! pressure at layer edges
2855  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
2856 ! (from model top to bottom surface)
2857 ! in the original vertical coordinate
2858 ! pressure at layer edges
2859  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
2860 ! (from model top to bottom surface)
2861 ! in the new vertical coordinate
2862 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
2863 ! !INPUT/OUTPUT PARAMETERS:
2864 ! Field output
2865  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
2866  REAL, INTENT(IN) :: q_min
2867 ! !DESCRIPTION:
2868 ! IV = 0: constituents
2869 ! pe1: pressure at layer edges (from model top to bottom surface)
2870 ! in the original vertical coordinate
2871 ! pe2: pressure at layer edges (from model top to bottom surface)
2872 ! in the new vertical coordinate
2873 ! !LOCAL VARIABLES:
2874  REAL :: dp1(i1:i2, km)
2875  REAL :: q4(4, i1:i2, km)
2876  REAL :: pl, pr, qsum, dp, esl
2877  INTEGER :: i, k, l, m, k0
2878  DO k=1,km
2879  DO i=i1,i2
2880  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
2881  q4(1, i, k) = q2(i, j, k)
2882  END DO
2883  END DO
2884 ! Compute vertical subgrid distribution
2885  IF (kord .GT. 7) THEN
2886  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
2887  ELSE
2888  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
2889  END IF
2890  DO i=i1,i2
2891  k0 = 1
2892  DO k=1,kn
2893  DO l=k0,km
2894 ! locate the top edge: pe2(i,k)
2895  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
2896 & ) THEN
2897  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
2898  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
2899 ! entire new grid is within the original grid
2900  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
2901  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-&
2902 & q4(2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
2903  k0 = l
2904  GOTO 555
2905  ELSE
2906 ! Fractional area...
2907  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
2908 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
2909 & pl*(1.+pl))))
2910  DO m=l+1,km
2911 ! locate the bottom edge: pe2(i,k+1)
2912  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
2913 ! Whole layer
2914  qsum = qsum + dp1(i, m)*q4(1, i, m)
2915  ELSE
2916  dp = pe2(i, k+1) - pe1(i, m)
2917  esl = dp/dp1(i, m)
2918  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
2919 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
2920  k0 = m
2921  GOTO 123
2922  END IF
2923  END DO
2924  GOTO 123
2925  END IF
2926  END IF
2927  END DO
2928  123 q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
2929  555 CONTINUE
2930  END DO
2931  END DO
2932  END SUBROUTINE map_scalar
2933  SUBROUTINE map1_ppm(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, &
2934 & jbeg, jend, iv, kord)
2935  IMPLICIT NONE
2936 ! Starting longitude
2937  INTEGER, INTENT(IN) :: i1
2938 ! Finishing longitude
2939  INTEGER, INTENT(IN) :: i2
2940 ! Mode: 0 == constituents 1 == ???
2941  INTEGER, INTENT(IN) :: iv
2942 ! 2 == remap temp with cs scheme
2943 ! Method order
2944  INTEGER, INTENT(IN) :: kord
2945 ! Current latitude
2946  INTEGER, INTENT(IN) :: j
2947  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
2948 ! Original vertical dimension
2949  INTEGER, INTENT(IN) :: km
2950 ! Target vertical dimension
2951  INTEGER, INTENT(IN) :: kn
2952 ! bottom BC
2953  REAL, INTENT(IN) :: qs(i1:i2)
2954 ! pressure at layer edges
2955  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
2956 ! (from model top to bottom surface)
2957 ! in the original vertical coordinate
2958 ! pressure at layer edges
2959  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
2960 ! (from model top to bottom surface)
2961 ! in the new vertical coordinate
2962 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
2963 ! !INPUT/OUTPUT PARAMETERS:
2964 ! Field output
2965  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
2966 ! !DESCRIPTION:
2967 ! IV = 0: constituents
2968 ! pe1: pressure at layer edges (from model top to bottom surface)
2969 ! in the original vertical coordinate
2970 ! pe2: pressure at layer edges (from model top to bottom surface)
2971 ! in the new vertical coordinate
2972 ! !LOCAL VARIABLES:
2973  REAL :: dp1(i1:i2, km)
2974  REAL :: q4(4, i1:i2, km)
2975  REAL :: pl, pr, qsum, dp, esl
2976  INTEGER :: i, k, l, m, k0
2977  DO k=1,km
2978  DO i=i1,i2
2979  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
2980  q4(1, i, k) = q2(i, j, k)
2981  END DO
2982  END DO
2983 ! Compute vertical subgrid distribution
2984  IF (kord .GT. 7) THEN
2985  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
2986  ELSE
2987  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
2988  END IF
2989  DO i=i1,i2
2990  k0 = 1
2991  DO k=1,kn
2992  DO l=k0,km
2993 ! locate the top edge: pe2(i,k)
2994  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
2995 & ) THEN
2996  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
2997  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
2998 ! entire new grid is within the original grid
2999  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
3000  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-&
3001 & q4(2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
3002  k0 = l
3003  GOTO 555
3004  ELSE
3005 ! Fractional area...
3006  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
3007 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
3008 & pl*(1.+pl))))
3009  DO m=l+1,km
3010 ! locate the bottom edge: pe2(i,k+1)
3011  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
3012 ! Whole layer
3013  qsum = qsum + dp1(i, m)*q4(1, i, m)
3014  ELSE
3015  dp = pe2(i, k+1) - pe1(i, m)
3016  esl = dp/dp1(i, m)
3017  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
3018 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
3019  k0 = m
3020  GOTO 123
3021  END IF
3022  END DO
3023  GOTO 123
3024  END IF
3025  END IF
3026  END DO
3027  123 q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
3028  555 CONTINUE
3029  END DO
3030  END DO
3031  END SUBROUTINE map1_ppm
3032  SUBROUTINE mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, i1, i2, isd&
3033 & , ied, jsd, jed, q_min, fill)
3034  IMPLICIT NONE
3035 ! !INPUT PARAMETERS:
3036 ! vertical dimension
3037  INTEGER, INTENT(IN) :: km
3038  INTEGER, INTENT(IN) :: j, nq, i1, i2
3039  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
3040  INTEGER, INTENT(IN) :: kord(nq)
3041 ! pressure at layer edges
3042  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
3043 ! (from model top to bottom surface)
3044 ! in the original vertical coordinate
3045 ! pressure at layer edges
3046  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
3047 ! (from model top to bottom surface)
3048 ! in the new vertical coordinate
3049  REAL, INTENT(IN) :: dp2(i1:i2, km)
3050  REAL, INTENT(IN) :: q_min
3051  LOGICAL, INTENT(IN) :: fill
3052 ! Field input
3053  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
3054 ! !LOCAL VARIABLES:
3055  REAL :: q4(4, i1:i2, km, nq)
3056 ! Field output
3057  REAL :: q2(i1:i2, km, nq)
3058  REAL :: qsum(nq)
3059  REAL :: dp1(i1:i2, km)
3060  REAL :: qs(i1:i2)
3061  REAL :: pl, pr, dp, esl, fac1, fac2
3062  INTEGER :: i, k, l, m, k0, iq
3063  DO k=1,km
3064  DO i=i1,i2
3065  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
3066  END DO
3067  END DO
3068  DO iq=1,nq
3069  DO k=1,km
3070  DO i=i1,i2
3071  q4(1, i, k, iq) = q1(i, j, k, iq)
3072  END DO
3073  END DO
3074  CALL scalar_profile(qs, q4(1:4, i1:i2, 1:km, iq), dp1, km, i1, i2&
3075 & , 0, kord(iq), q_min)
3076  END DO
3077 ! Mapping
3078  DO i=i1,i2
3079  k0 = 1
3080  DO k=1,km
3081  DO l=k0,km
3082 ! locate the top edge: pe2(i,k)
3083  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
3084 & ) THEN
3085  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
3086  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
3087 ! entire new grid is within the original grid
3088  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
3089  fac1 = pr + pl
3090  fac2 = r3*(pr*fac1+pl*pl)
3091  fac1 = 0.5*fac1
3092  DO iq=1,nq
3093  q2(i, k, iq) = q4(2, i, l, iq) + (q4(4, i, l, iq)+q4(3, &
3094 & i, l, iq)-q4(2, i, l, iq))*fac1 - q4(4, i, l, iq)*fac2
3095  END DO
3096  k0 = l
3097  GOTO 555
3098  ELSE
3099 ! Fractional area...
3100  dp = pe1(i, l+1) - pe2(i, k)
3101  fac1 = 1. + pl
3102  fac2 = r3*(1.+pl*fac1)
3103  fac1 = 0.5*fac1
3104  DO iq=1,nq
3105  qsum(iq) = dp*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, i&
3106 & , l, iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2)
3107  END DO
3108  DO m=l+1,km
3109 ! locate the bottom edge: pe2(i,k+1)
3110  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
3111 ! Whole layer..
3112  DO iq=1,nq
3113  qsum(iq) = qsum(iq) + dp1(i, m)*q4(1, i, m, iq)
3114  END DO
3115  ELSE
3116  dp = pe2(i, k+1) - pe1(i, m)
3117  esl = dp/dp1(i, m)
3118  fac1 = 0.5*esl
3119  fac2 = 1. - r23*esl
3120  DO iq=1,nq
3121  qsum(iq) = qsum(iq) + dp*(q4(2, i, m, iq)+fac1*(q4(3&
3122 & , i, m, iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2))
3123  END DO
3124  k0 = m
3125  GOTO 123
3126  END IF
3127  END DO
3128  GOTO 123
3129  END IF
3130  END IF
3131  END DO
3132  123 CONTINUE
3133  DO iq=1,nq
3134  q2(i, k, iq) = qsum(iq)/dp2(i, k)
3135  END DO
3136  555 CONTINUE
3137  END DO
3138  END DO
3139  IF (fill) CALL fillz(i2 - i1 + 1, km, nq, q2, dp2)
3140  DO iq=1,nq
3141 ! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2)
3142  DO k=1,km
3143  DO i=i1,i2
3144  q1(i, j, k, iq) = q2(i, k, iq)
3145  END DO
3146  END DO
3147  END DO
3148  END SUBROUTINE mapn_tracer
3149  SUBROUTINE map1_q2(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j&
3150 & , ibeg, iend, jbeg, jend, q_min)
3151  IMPLICIT NONE
3152 ! !INPUT PARAMETERS:
3153  INTEGER, INTENT(IN) :: j
3154  INTEGER, INTENT(IN) :: i1, i2
3155  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
3156 ! Mode: 0 == constituents 1 == ???
3157  INTEGER, INTENT(IN) :: iv
3158  INTEGER, INTENT(IN) :: kord
3159 ! Original vertical dimension
3160  INTEGER, INTENT(IN) :: km
3161 ! Target vertical dimension
3162  INTEGER, INTENT(IN) :: kn
3163 ! pressure at layer edges
3164  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
3165 ! (from model top to bottom surface)
3166 ! in the original vertical coordinate
3167 ! pressure at layer edges
3168  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
3169 ! (from model top to bottom surface)
3170 ! in the new vertical coordinate
3171 ! Field input
3172  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
3173  REAL, INTENT(IN) :: dp2(i1:i2, kn)
3174  REAL, INTENT(IN) :: q_min
3175 ! !INPUT/OUTPUT PARAMETERS:
3176 ! Field output
3177  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
3178 ! !LOCAL VARIABLES:
3179  REAL :: qs(i1:i2)
3180  REAL :: dp1(i1:i2, km)
3181  REAL :: q4(4, i1:i2, km)
3182  REAL :: pl, pr, qsum, dp, esl
3183  INTEGER :: i, k, l, m, k0
3184  DO k=1,km
3185  DO i=i1,i2
3186  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
3187  q4(1, i, k) = q1(i, j, k)
3188  END DO
3189  END DO
3190 ! Compute vertical subgrid distribution
3191  IF (kord .GT. 7) THEN
3192  CALL scalar_profile(qs, q4, dp1, km, i1, i2, iv, kord, q_min)
3193  ELSE
3194  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
3195  END IF
3196 ! Mapping
3197  DO i=i1,i2
3198  k0 = 1
3199  DO k=1,kn
3200  DO l=k0,km
3201 ! locate the top edge: pe2(i,k)
3202  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
3203 & ) THEN
3204  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
3205  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
3206 ! entire new grid is within the original grid
3207  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
3208  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
3209 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
3210  k0 = l
3211  GOTO 555
3212  ELSE
3213 ! Fractional area...
3214  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, &
3215 & l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+&
3216 & pl*(1.+pl))))
3217  DO m=l+1,km
3218 ! locate the bottom edge: pe2(i,k+1)
3219  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
3220 ! Whole layer..
3221  qsum = qsum + dp1(i, m)*q4(1, i, m)
3222  ELSE
3223  dp = pe2(i, k+1) - pe1(i, m)
3224  esl = dp/dp1(i, m)
3225  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(&
3226 & 2, i, m)+q4(4, i, m)*(1.-r23*esl)))
3227  k0 = m
3228  GOTO 123
3229  END IF
3230  END DO
3231  GOTO 123
3232  END IF
3233  END IF
3234  END DO
3235  123 q2(i, k) = qsum/dp2(i, k)
3236  555 CONTINUE
3237  END DO
3238  END DO
3239  END SUBROUTINE map1_q2
3240  SUBROUTINE scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
3241  IMPLICIT NONE
3242 ! Optimized vertical profile reconstruction:
3243 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
3244  INTEGER, INTENT(IN) :: i1, i2
3245 ! vertical dimension
3246  INTEGER, INTENT(IN) :: km
3247 ! iv =-1: winds
3248  INTEGER, INTENT(IN) :: iv
3249 ! iv = 0: positive definite scalars
3250 ! iv = 1: others
3251  INTEGER, INTENT(IN) :: kord
3252  REAL, INTENT(IN) :: qs(i1:i2)
3253 ! layer pressure thickness
3254  REAL, INTENT(IN) :: delp(i1:i2, km)
3255 ! Interpolated values
3256  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
3257  REAL, INTENT(IN) :: qmin
3258 !-----------------------------------------------------------------------
3259  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
3260  REAL :: gam(i1:i2, km)
3261  REAL :: q(i1:i2, km+1)
3262  REAL :: d4(i1:i2)
3263  REAL :: bet, a_bot, grat
3264  REAL :: pmp_1, lac_1, pmp_2, lac_2
3265  INTEGER :: i, k, im
3266  INTRINSIC abs
3267  INTRINSIC max
3268  INTRINSIC min
3269  INTEGER :: abs0
3270  INTEGER :: abs1
3271  REAL :: abs2
3272  INTEGER :: abs3
3273  INTEGER :: abs4
3274  REAL :: abs5
3275  INTEGER :: abs6
3276  REAL :: abs7
3277  INTEGER :: abs8
3278  REAL :: abs9
3279  INTEGER :: abs10
3280  INTEGER :: abs11
3281  INTEGER :: abs12
3282  REAL :: abs13
3283  REAL :: abs14
3284  REAL :: abs15
3285  REAL :: abs16
3286  REAL :: x12
3287  REAL :: x11
3288  REAL :: y29
3289  REAL :: x10
3290  REAL :: y28
3291  REAL :: y27
3292  REAL :: y26
3293  REAL :: y25
3294  REAL :: y24
3295  REAL :: y23
3296  REAL :: y22
3297  REAL :: y21
3298  REAL :: y20
3299  REAL :: x9
3300  REAL :: x8
3301  REAL :: x7
3302  REAL :: x6
3303  REAL :: x5
3304  REAL :: x4
3305  REAL :: x3
3306  REAL :: x2
3307  REAL :: x1
3308  REAL :: y19
3309  REAL :: y18
3310  REAL :: y17
3311  REAL :: y16
3312  REAL :: y15
3313  REAL :: y14
3314  REAL :: y13
3315  REAL :: y12
3316  REAL :: y11
3317  REAL :: y10
3318  REAL :: y32
3319  REAL :: y31
3320  REAL :: y30
3321  REAL :: y9
3322  REAL :: y8
3323  REAL :: y7
3324  REAL :: y6
3325  REAL :: y5
3326  REAL :: y4
3327  REAL :: y3
3328  REAL :: y2
3329  REAL :: y1
3330  IF (iv .EQ. -2) THEN
3331  DO i=i1,i2
3332  gam(i, 2) = 0.5
3333  q(i, 1) = 1.5*a4(1, i, 1)
3334  END DO
3335  DO k=2,km-1
3336  DO i=i1,i2
3337  grat = delp(i, k-1)/delp(i, k)
3338  bet = 2. + grat + grat - gam(i, k)
3339  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
3340  gam(i, k+1) = grat/bet
3341  END DO
3342  END DO
3343  DO i=i1,i2
3344  grat = delp(i, km-1)/delp(i, km)
3345  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
3346 & 1))/(2.+grat+grat-gam(i, km))
3347  q(i, km+1) = qs(i)
3348  END DO
3349  DO k=km-1,1,-1
3350  DO i=i1,i2
3351  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
3352  END DO
3353  END DO
3354  ELSE
3355  DO i=i1,i2
3356 ! grid ratio
3357  grat = delp(i, 2)/delp(i, 1)
3358  bet = grat*(grat+0.5)
3359  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
3360  gam(i, 1) = (1.+grat*(grat+1.5))/bet
3361  END DO
3362  DO k=2,km
3363  DO i=i1,i2
3364  d4(i) = delp(i, k-1)/delp(i, k)
3365  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
3366  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
3367  gam(i, k) = d4(i)/bet
3368  END DO
3369  END DO
3370  DO i=i1,i2
3371  a_bot = 1. + d4(i)*(d4(i)+1.5)
3372  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
3373 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
3374  END DO
3375  DO k=km,1,-1
3376  DO i=i1,i2
3377  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
3378  END DO
3379  END DO
3380  END IF
3381  IF (kord .GE. 0.) THEN
3382  abs0 = kord
3383  ELSE
3384  abs0 = -kord
3385  END IF
3386 !----- Perfectly linear scheme --------------------------------
3387  IF (abs0 .GT. 16) THEN
3388  DO k=1,km
3389  DO i=i1,i2
3390  a4(2, i, k) = q(i, k)
3391  a4(3, i, k) = q(i, k+1)
3392  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
3393  END DO
3394  END DO
3395  RETURN
3396  ELSE
3397 !----- Perfectly linear scheme --------------------------------
3398 !------------------
3399 ! Apply constraints
3400 !------------------
3401  im = i2 - i1 + 1
3402 ! Apply *large-scale* constraints
3403  DO i=i1,i2
3404  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
3405  y1 = a4(1, i, 2)
3406  ELSE
3407  y1 = a4(1, i, 1)
3408  END IF
3409  IF (q(i, 2) .GT. y1) THEN
3410  q(i, 2) = y1
3411  ELSE
3412  q(i, 2) = q(i, 2)
3413  END IF
3414  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
3415  y2 = a4(1, i, 2)
3416  ELSE
3417  y2 = a4(1, i, 1)
3418  END IF
3419  IF (q(i, 2) .LT. y2) THEN
3420  q(i, 2) = y2
3421  ELSE
3422  q(i, 2) = q(i, 2)
3423  END IF
3424  END DO
3425  DO k=2,km
3426  DO i=i1,i2
3427  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
3428  END DO
3429  END DO
3430 ! Interior:
3431  DO k=3,km-1
3432  DO i=i1,i2
3433  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
3434  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
3435  y3 = a4(1, i, k)
3436  ELSE
3437  y3 = a4(1, i, k-1)
3438  END IF
3439  IF (q(i, k) .GT. y3) THEN
3440  q(i, k) = y3
3441  ELSE
3442  q(i, k) = q(i, k)
3443  END IF
3444  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
3445  y4 = a4(1, i, k)
3446  ELSE
3447  y4 = a4(1, i, k-1)
3448  END IF
3449  IF (q(i, k) .LT. y4) THEN
3450  q(i, k) = y4
3451  ELSE
3452  q(i, k) = q(i, k)
3453  END IF
3454  ELSE IF (gam(i, k-1) .GT. 0.) THEN
3455  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
3456  y5 = a4(1, i, k)
3457  ELSE
3458  y5 = a4(1, i, k-1)
3459  END IF
3460  IF (q(i, k) .LT. y5) THEN
3461  q(i, k) = y5
3462  ELSE
3463  q(i, k) = q(i, k)
3464  END IF
3465  ELSE
3466  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
3467  y6 = a4(1, i, k)
3468  ELSE
3469  y6 = a4(1, i, k-1)
3470  END IF
3471  IF (q(i, k) .GT. y6) THEN
3472  q(i, k) = y6
3473  ELSE
3474  q(i, k) = q(i, k)
3475  END IF
3476  IF (iv .EQ. 0) THEN
3477  IF (0. .LT. q(i, k)) THEN
3478  q(i, k) = q(i, k)
3479  ELSE
3480  q(i, k) = 0.
3481  END IF
3482  END IF
3483  END IF
3484  END DO
3485  END DO
3486 ! Bottom:
3487  DO i=i1,i2
3488  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
3489  y7 = a4(1, i, km)
3490  ELSE
3491  y7 = a4(1, i, km-1)
3492  END IF
3493  IF (q(i, km) .GT. y7) THEN
3494  q(i, km) = y7
3495  ELSE
3496  q(i, km) = q(i, km)
3497  END IF
3498  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
3499  y8 = a4(1, i, km)
3500  ELSE
3501  y8 = a4(1, i, km-1)
3502  END IF
3503  IF (q(i, km) .LT. y8) THEN
3504  q(i, km) = y8
3505  ELSE
3506  q(i, km) = q(i, km)
3507  END IF
3508  END DO
3509  DO k=1,km
3510  DO i=i1,i2
3511  a4(2, i, k) = q(i, k)
3512  a4(3, i, k) = q(i, k+1)
3513  END DO
3514  END DO
3515  DO k=1,km
3516  IF (k .EQ. 1 .OR. k .EQ. km) THEN
3517  DO i=i1,i2
3518  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
3519 & , k)) .GT. 0.
3520  END DO
3521  ELSE
3522  DO i=i1,i2
3523  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
3524  END DO
3525  END IF
3526  IF (kord .GE. 0.) THEN
3527  abs1 = kord
3528  ELSE
3529  abs1 = -kord
3530  END IF
3531  IF (abs1 .EQ. 16) THEN
3532  DO i=i1,i2
3533  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
3534  IF (a4(4, i, k) .GE. 0.) THEN
3535  abs2 = a4(4, i, k)
3536  ELSE
3537  abs2 = -a4(4, i, k)
3538  END IF
3539  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
3540  abs13 = a4(2, i, k) - a4(3, i, k)
3541  ELSE
3542  abs13 = -(a4(2, i, k)-a4(3, i, k))
3543  END IF
3544  ext6(i, k) = abs2 .GT. abs13
3545  END DO
3546  END IF
3547  END DO
3548 !---------------------------
3549 ! Apply subgrid constraints:
3550 !---------------------------
3551 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
3552 ! Top 2 and bottom 2 layers always use monotonic mapping
3553  IF (iv .EQ. 0) THEN
3554  DO i=i1,i2
3555  IF (0. .LT. a4(2, i, 1)) THEN
3556  a4(2, i, 1) = a4(2, i, 1)
3557  ELSE
3558  a4(2, i, 1) = 0.
3559  END IF
3560  END DO
3561  ELSE IF (iv .EQ. -1) THEN
3562  DO i=i1,i2
3563  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
3564  END DO
3565  ELSE IF (iv .EQ. 2) THEN
3566  DO i=i1,i2
3567  a4(2, i, 1) = a4(1, i, 1)
3568  a4(3, i, 1) = a4(1, i, 1)
3569  a4(4, i, 1) = 0.
3570  END DO
3571  END IF
3572  IF (iv .NE. 2) THEN
3573  DO i=i1,i2
3574  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
3575  END DO
3576  CALL cs_limiters(im, extm(i1, 1), a4(1, i1, 1), 1)
3577  END IF
3578 ! k=2
3579  DO i=i1,i2
3580  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
3581  END DO
3582  CALL cs_limiters(im, extm(i1, 2), a4(1, i1, 2), 2)
3583 !-------------------------------------
3584 ! Huynh's 2nd constraint for interior:
3585 !-------------------------------------
3586  DO k=3,km-2
3587  IF (kord .GE. 0.) THEN
3588  abs3 = kord
3589  ELSE
3590  abs3 = -kord
3591  END IF
3592  IF (abs3 .LT. 9) THEN
3593  DO i=i1,i2
3594 ! Left edges
3595  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
3596  lac_1 = pmp_1 + 1.5*gam(i, k+2)
3597  IF (a4(1, i, k) .GT. pmp_1) THEN
3598  IF (pmp_1 .GT. lac_1) THEN
3599  y21 = lac_1
3600  ELSE
3601  y21 = pmp_1
3602  END IF
3603  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
3604  y21 = lac_1
3605  ELSE
3606  y21 = a4(1, i, k)
3607  END IF
3608  IF (a4(2, i, k) .LT. y21) THEN
3609  x1 = y21
3610  ELSE
3611  x1 = a4(2, i, k)
3612  END IF
3613  IF (a4(1, i, k) .LT. pmp_1) THEN
3614  IF (pmp_1 .LT. lac_1) THEN
3615  y9 = lac_1
3616  ELSE
3617  y9 = pmp_1
3618  END IF
3619  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
3620  y9 = lac_1
3621  ELSE
3622  y9 = a4(1, i, k)
3623  END IF
3624  IF (x1 .GT. y9) THEN
3625  a4(2, i, k) = y9
3626  ELSE
3627  a4(2, i, k) = x1
3628  END IF
3629 ! Right edges
3630  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
3631  lac_2 = pmp_2 - 1.5*gam(i, k-1)
3632  IF (a4(1, i, k) .GT. pmp_2) THEN
3633  IF (pmp_2 .GT. lac_2) THEN
3634  y22 = lac_2
3635  ELSE
3636  y22 = pmp_2
3637  END IF
3638  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
3639  y22 = lac_2
3640  ELSE
3641  y22 = a4(1, i, k)
3642  END IF
3643  IF (a4(3, i, k) .LT. y22) THEN
3644  x2 = y22
3645  ELSE
3646  x2 = a4(3, i, k)
3647  END IF
3648  IF (a4(1, i, k) .LT. pmp_2) THEN
3649  IF (pmp_2 .LT. lac_2) THEN
3650  y10 = lac_2
3651  ELSE
3652  y10 = pmp_2
3653  END IF
3654  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
3655  y10 = lac_2
3656  ELSE
3657  y10 = a4(1, i, k)
3658  END IF
3659  IF (x2 .GT. y10) THEN
3660  a4(3, i, k) = y10
3661  ELSE
3662  a4(3, i, k) = x2
3663  END IF
3664  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
3665  END DO
3666  ELSE
3667  IF (kord .GE. 0.) THEN
3668  abs4 = kord
3669  ELSE
3670  abs4 = -kord
3671  END IF
3672  IF (abs4 .EQ. 9) THEN
3673  DO i=i1,i2
3674  IF (extm(i, k) .AND. extm(i, k-1)) THEN
3675 ! grid-scale 2-delta-z wave detected
3676  a4(2, i, k) = a4(1, i, k)
3677  a4(3, i, k) = a4(1, i, k)
3678  a4(4, i, k) = 0.
3679  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
3680 ! grid-scale 2-delta-z wave detected
3681  a4(2, i, k) = a4(1, i, k)
3682  a4(3, i, k) = a4(1, i, k)
3683  a4(4, i, k) = 0.
3684  ELSE IF (extm(i, k) .AND. a4(1, i, k) .LT. qmin) THEN
3685 ! grid-scale 2-delta-z wave detected
3686  a4(2, i, k) = a4(1, i, k)
3687  a4(3, i, k) = a4(1, i, k)
3688  a4(4, i, k) = 0.
3689  ELSE
3690  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k&
3691 & )))
3692  IF (a4(4, i, k) .GE. 0.) THEN
3693  abs5 = a4(4, i, k)
3694  ELSE
3695  abs5 = -a4(4, i, k)
3696  END IF
3697  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
3698  abs14 = a4(2, i, k) - a4(3, i, k)
3699  ELSE
3700  abs14 = -(a4(2, i, k)-a4(3, i, k))
3701  END IF
3702 ! Check within the smooth region if subgrid profile is non-monotonic
3703  IF (abs5 .GT. abs14) THEN
3704  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
3705  lac_1 = pmp_1 + 1.5*gam(i, k+2)
3706  IF (a4(1, i, k) .GT. pmp_1) THEN
3707  IF (pmp_1 .GT. lac_1) THEN
3708  y23 = lac_1
3709  ELSE
3710  y23 = pmp_1
3711  END IF
3712  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
3713  y23 = lac_1
3714  ELSE
3715  y23 = a4(1, i, k)
3716  END IF
3717  IF (a4(2, i, k) .LT. y23) THEN
3718  x3 = y23
3719  ELSE
3720  x3 = a4(2, i, k)
3721  END IF
3722  IF (a4(1, i, k) .LT. pmp_1) THEN
3723  IF (pmp_1 .LT. lac_1) THEN
3724  y11 = lac_1
3725  ELSE
3726  y11 = pmp_1
3727  END IF
3728  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
3729  y11 = lac_1
3730  ELSE
3731  y11 = a4(1, i, k)
3732  END IF
3733  IF (x3 .GT. y11) THEN
3734  a4(2, i, k) = y11
3735  ELSE
3736  a4(2, i, k) = x3
3737  END IF
3738  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
3739  lac_2 = pmp_2 - 1.5*gam(i, k-1)
3740  IF (a4(1, i, k) .GT. pmp_2) THEN
3741  IF (pmp_2 .GT. lac_2) THEN
3742  y24 = lac_2
3743  ELSE
3744  y24 = pmp_2
3745  END IF
3746  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
3747  y24 = lac_2
3748  ELSE
3749  y24 = a4(1, i, k)
3750  END IF
3751  IF (a4(3, i, k) .LT. y24) THEN
3752  x4 = y24
3753  ELSE
3754  x4 = a4(3, i, k)
3755  END IF
3756  IF (a4(1, i, k) .LT. pmp_2) THEN
3757  IF (pmp_2 .LT. lac_2) THEN
3758  y12 = lac_2
3759  ELSE
3760  y12 = pmp_2
3761  END IF
3762  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
3763  y12 = lac_2
3764  ELSE
3765  y12 = a4(1, i, k)
3766  END IF
3767  IF (x4 .GT. y12) THEN
3768  a4(3, i, k) = y12
3769  ELSE
3770  a4(3, i, k) = x4
3771  END IF
3772  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i&
3773 & , k)))
3774  END IF
3775  END IF
3776  END DO
3777  ELSE
3778  IF (kord .GE. 0.) THEN
3779  abs6 = kord
3780  ELSE
3781  abs6 = -kord
3782  END IF
3783  IF (abs6 .EQ. 10) THEN
3784  DO i=i1,i2
3785  IF (extm(i, k)) THEN
3786  IF ((a4(1, i, k) .LT. qmin .OR. extm(i, k-1)) .OR. &
3787 & extm(i, k+1)) THEN
3788 ! grid-scale 2-delta-z wave detected; or q is too small -> ehance vertical mixing
3789  a4(2, i, k) = a4(1, i, k)
3790  a4(3, i, k) = a4(1, i, k)
3791  a4(4, i, k) = 0.
3792  ELSE
3793 ! True local extremum
3794  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
3795 & , i, k))
3796  END IF
3797  ELSE
3798 ! not a local extremum
3799  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
3800 & , k))
3801  IF (a4(4, i, k) .GE. 0.) THEN
3802  abs7 = a4(4, i, k)
3803  ELSE
3804  abs7 = -a4(4, i, k)
3805  END IF
3806  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
3807  abs15 = a4(2, i, k) - a4(3, i, k)
3808  ELSE
3809  abs15 = -(a4(2, i, k)-a4(3, i, k))
3810  END IF
3811 ! Check within the smooth region if subgrid profile is non-monotonic
3812  IF (abs7 .GT. abs15) THEN
3813  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
3814  lac_1 = pmp_1 + 1.5*gam(i, k+2)
3815  IF (a4(1, i, k) .GT. pmp_1) THEN
3816  IF (pmp_1 .GT. lac_1) THEN
3817  y25 = lac_1
3818  ELSE
3819  y25 = pmp_1
3820  END IF
3821  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
3822  y25 = lac_1
3823  ELSE
3824  y25 = a4(1, i, k)
3825  END IF
3826  IF (a4(2, i, k) .LT. y25) THEN
3827  x5 = y25
3828  ELSE
3829  x5 = a4(2, i, k)
3830  END IF
3831  IF (a4(1, i, k) .LT. pmp_1) THEN
3832  IF (pmp_1 .LT. lac_1) THEN
3833  y13 = lac_1
3834  ELSE
3835  y13 = pmp_1
3836  END IF
3837  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
3838  y13 = lac_1
3839  ELSE
3840  y13 = a4(1, i, k)
3841  END IF
3842  IF (x5 .GT. y13) THEN
3843  a4(2, i, k) = y13
3844  ELSE
3845  a4(2, i, k) = x5
3846  END IF
3847  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
3848  lac_2 = pmp_2 - 1.5*gam(i, k-1)
3849  IF (a4(1, i, k) .GT. pmp_2) THEN
3850  IF (pmp_2 .GT. lac_2) THEN
3851  y26 = lac_2
3852  ELSE
3853  y26 = pmp_2
3854  END IF
3855  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
3856  y26 = lac_2
3857  ELSE
3858  y26 = a4(1, i, k)
3859  END IF
3860  IF (a4(3, i, k) .LT. y26) THEN
3861  x6 = y26
3862  ELSE
3863  x6 = a4(3, i, k)
3864  END IF
3865  IF (a4(1, i, k) .LT. pmp_2) THEN
3866  IF (pmp_2 .LT. lac_2) THEN
3867  y14 = lac_2
3868  ELSE
3869  y14 = pmp_2
3870  END IF
3871  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
3872  y14 = lac_2
3873  ELSE
3874  y14 = a4(1, i, k)
3875  END IF
3876  IF (x6 .GT. y14) THEN
3877  a4(3, i, k) = y14
3878  ELSE
3879  a4(3, i, k) = x6
3880  END IF
3881  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
3882 & , i, k))
3883  END IF
3884  END IF
3885  END DO
3886  ELSE
3887  IF (kord .GE. 0.) THEN
3888  abs8 = kord
3889  ELSE
3890  abs8 = -kord
3891  END IF
3892  IF (abs8 .EQ. 12) THEN
3893  DO i=i1,i2
3894  IF (extm(i, k)) THEN
3895  a4(2, i, k) = a4(1, i, k)
3896  a4(3, i, k) = a4(1, i, k)
3897  a4(4, i, k) = 0.
3898  ELSE
3899 ! not a local extremum
3900  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
3901 & , i, k))
3902  IF (a4(4, i, k) .GE. 0.) THEN
3903  abs9 = a4(4, i, k)
3904  ELSE
3905  abs9 = -a4(4, i, k)
3906  END IF
3907  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
3908  abs16 = a4(2, i, k) - a4(3, i, k)
3909  ELSE
3910  abs16 = -(a4(2, i, k)-a4(3, i, k))
3911  END IF
3912 ! Check within the smooth region if subgrid profile is non-monotonic
3913  IF (abs9 .GT. abs16) THEN
3914  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
3915  lac_1 = pmp_1 + 1.5*gam(i, k+2)
3916  IF (a4(1, i, k) .GT. pmp_1) THEN
3917  IF (pmp_1 .GT. lac_1) THEN
3918  y27 = lac_1
3919  ELSE
3920  y27 = pmp_1
3921  END IF
3922  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
3923  y27 = lac_1
3924  ELSE
3925  y27 = a4(1, i, k)
3926  END IF
3927  IF (a4(2, i, k) .LT. y27) THEN
3928  x7 = y27
3929  ELSE
3930  x7 = a4(2, i, k)
3931  END IF
3932  IF (a4(1, i, k) .LT. pmp_1) THEN
3933  IF (pmp_1 .LT. lac_1) THEN
3934  y15 = lac_1
3935  ELSE
3936  y15 = pmp_1
3937  END IF
3938  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
3939  y15 = lac_1
3940  ELSE
3941  y15 = a4(1, i, k)
3942  END IF
3943  IF (x7 .GT. y15) THEN
3944  a4(2, i, k) = y15
3945  ELSE
3946  a4(2, i, k) = x7
3947  END IF
3948  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
3949  lac_2 = pmp_2 - 1.5*gam(i, k-1)
3950  IF (a4(1, i, k) .GT. pmp_2) THEN
3951  IF (pmp_2 .GT. lac_2) THEN
3952  y28 = lac_2
3953  ELSE
3954  y28 = pmp_2
3955  END IF
3956  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
3957  y28 = lac_2
3958  ELSE
3959  y28 = a4(1, i, k)
3960  END IF
3961  IF (a4(3, i, k) .LT. y28) THEN
3962  x8 = y28
3963  ELSE
3964  x8 = a4(3, i, k)
3965  END IF
3966  IF (a4(1, i, k) .LT. pmp_2) THEN
3967  IF (pmp_2 .LT. lac_2) THEN
3968  y16 = lac_2
3969  ELSE
3970  y16 = pmp_2
3971  END IF
3972  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
3973  y16 = lac_2
3974  ELSE
3975  y16 = a4(1, i, k)
3976  END IF
3977  IF (x8 .GT. y16) THEN
3978  a4(3, i, k) = y16
3979  ELSE
3980  a4(3, i, k) = x8
3981  END IF
3982  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
3983 & 3, i, k))
3984  END IF
3985  END IF
3986  END DO
3987  ELSE
3988  IF (kord .GE. 0.) THEN
3989  abs10 = kord
3990  ELSE
3991  abs10 = -kord
3992  END IF
3993  IF (abs10 .EQ. 13) THEN
3994  DO i=i1,i2
3995  IF (extm(i, k)) THEN
3996  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
3997 ! grid-scale 2-delta-z wave detected
3998  a4(2, i, k) = a4(1, i, k)
3999  a4(3, i, k) = a4(1, i, k)
4000  a4(4, i, k) = 0.
4001  ELSE
4002 ! Left edges
4003  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
4004  lac_1 = pmp_1 + 1.5*gam(i, k+2)
4005  IF (a4(1, i, k) .GT. pmp_1) THEN
4006  IF (pmp_1 .GT. lac_1) THEN
4007  y29 = lac_1
4008  ELSE
4009  y29 = pmp_1
4010  END IF
4011  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
4012  y29 = lac_1
4013  ELSE
4014  y29 = a4(1, i, k)
4015  END IF
4016  IF (a4(2, i, k) .LT. y29) THEN
4017  x9 = y29
4018  ELSE
4019  x9 = a4(2, i, k)
4020  END IF
4021  IF (a4(1, i, k) .LT. pmp_1) THEN
4022  IF (pmp_1 .LT. lac_1) THEN
4023  y17 = lac_1
4024  ELSE
4025  y17 = pmp_1
4026  END IF
4027  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
4028  y17 = lac_1
4029  ELSE
4030  y17 = a4(1, i, k)
4031  END IF
4032  IF (x9 .GT. y17) THEN
4033  a4(2, i, k) = y17
4034  ELSE
4035  a4(2, i, k) = x9
4036  END IF
4037 ! Right edges
4038  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
4039  lac_2 = pmp_2 - 1.5*gam(i, k-1)
4040  IF (a4(1, i, k) .GT. pmp_2) THEN
4041  IF (pmp_2 .GT. lac_2) THEN
4042  y30 = lac_2
4043  ELSE
4044  y30 = pmp_2
4045  END IF
4046  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
4047  y30 = lac_2
4048  ELSE
4049  y30 = a4(1, i, k)
4050  END IF
4051  IF (a4(3, i, k) .LT. y30) THEN
4052  x10 = y30
4053  ELSE
4054  x10 = a4(3, i, k)
4055  END IF
4056  IF (a4(1, i, k) .LT. pmp_2) THEN
4057  IF (pmp_2 .LT. lac_2) THEN
4058  y18 = lac_2
4059  ELSE
4060  y18 = pmp_2
4061  END IF
4062  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
4063  y18 = lac_2
4064  ELSE
4065  y18 = a4(1, i, k)
4066  END IF
4067  IF (x10 .GT. y18) THEN
4068  a4(3, i, k) = y18
4069  ELSE
4070  a4(3, i, k) = x10
4071  END IF
4072  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
4073 & (3, i, k)))
4074  END IF
4075  ELSE
4076  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
4077 & , i, k)))
4078  END IF
4079  END DO
4080  ELSE
4081  IF (kord .GE. 0.) THEN
4082  abs11 = kord
4083  ELSE
4084  abs11 = -kord
4085  END IF
4086  IF (abs11 .EQ. 14) THEN
4087  DO i=i1,i2
4088  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
4089 & , i, k)))
4090  END DO
4091  ELSE
4092  IF (kord .GE. 0.) THEN
4093  abs12 = kord
4094  ELSE
4095  abs12 = -kord
4096  END IF
4097  IF (abs12 .EQ. 16) THEN
4098  DO i=i1,i2
4099  IF (ext6(i, k)) THEN
4100  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
4101 ! Left edges
4102  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
4103  lac_1 = pmp_1 + 1.5*gam(i, k+2)
4104  IF (a4(1, i, k) .GT. pmp_1) THEN
4105  IF (pmp_1 .GT. lac_1) THEN
4106  y31 = lac_1
4107  ELSE
4108  y31 = pmp_1
4109  END IF
4110  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
4111  y31 = lac_1
4112  ELSE
4113  y31 = a4(1, i, k)
4114  END IF
4115  IF (a4(2, i, k) .LT. y31) THEN
4116  x11 = y31
4117  ELSE
4118  x11 = a4(2, i, k)
4119  END IF
4120  IF (a4(1, i, k) .LT. pmp_1) THEN
4121  IF (pmp_1 .LT. lac_1) THEN
4122  y19 = lac_1
4123  ELSE
4124  y19 = pmp_1
4125  END IF
4126  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
4127  y19 = lac_1
4128  ELSE
4129  y19 = a4(1, i, k)
4130  END IF
4131  IF (x11 .GT. y19) THEN
4132  a4(2, i, k) = y19
4133  ELSE
4134  a4(2, i, k) = x11
4135  END IF
4136 ! Right edges
4137  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
4138  lac_2 = pmp_2 - 1.5*gam(i, k-1)
4139  IF (a4(1, i, k) .GT. pmp_2) THEN
4140  IF (pmp_2 .GT. lac_2) THEN
4141  y32 = lac_2
4142  ELSE
4143  y32 = pmp_2
4144  END IF
4145  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
4146  y32 = lac_2
4147  ELSE
4148  y32 = a4(1, i, k)
4149  END IF
4150  IF (a4(3, i, k) .LT. y32) THEN
4151  x12 = y32
4152  ELSE
4153  x12 = a4(3, i, k)
4154  END IF
4155  IF (a4(1, i, k) .LT. pmp_2) THEN
4156  IF (pmp_2 .LT. lac_2) THEN
4157  y20 = lac_2
4158  ELSE
4159  y20 = pmp_2
4160  END IF
4161  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
4162  y20 = lac_2
4163  ELSE
4164  y20 = a4(1, i, k)
4165  END IF
4166  IF (x12 .GT. y20) THEN
4167  a4(3, i, k) = y20
4168  ELSE
4169  a4(3, i, k) = x12
4170  END IF
4171  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k&
4172 & )+a4(3, i, k)))
4173  END IF
4174  END IF
4175  END DO
4176  ELSE
4177 ! kord = 11, 13
4178  DO i=i1,i2
4179  IF (extm(i, k) .AND. ((extm(i, k-1) .OR. extm(i&
4180 & , k+1)) .OR. a4(1, i, k) .LT. qmin)) THEN
4181 ! Noisy region:
4182  a4(2, i, k) = a4(1, i, k)
4183  a4(3, i, k) = a4(1, i, k)
4184  a4(4, i, k) = 0.
4185  ELSE
4186  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+&
4187 & a4(3, i, k)))
4188  END IF
4189  END DO
4190  END IF
4191  END IF
4192  END IF
4193  END IF
4194  END IF
4195  END IF
4196  END IF
4197 ! Additional constraint to ensure positivity
4198  IF (iv .EQ. 0) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 0&
4199 & )
4200  END DO
4201 ! k-loop
4202 !----------------------------------
4203 ! Bottom layer subgrid constraints:
4204 !----------------------------------
4205  IF (iv .EQ. 0) THEN
4206  DO i=i1,i2
4207  IF (0. .LT. a4(3, i, km)) THEN
4208  a4(3, i, km) = a4(3, i, km)
4209  ELSE
4210  a4(3, i, km) = 0.
4211  END IF
4212  END DO
4213  ELSE IF (iv .EQ. -1) THEN
4214  DO i=i1,i2
4215  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) a4(3, i, km) = 0.
4216  END DO
4217  END IF
4218  DO k=km-1,km
4219  DO i=i1,i2
4220  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
4221  END DO
4222  IF (k .EQ. km - 1) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k&
4223 & ), 2)
4224  IF (k .EQ. km) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 1&
4225 & )
4226  END DO
4227  END IF
4228  END SUBROUTINE scalar_profile
4229 ! Differentiation of cs_limiters in forward (tangent) mode:
4230 ! variations of useful results: a4
4231 ! with respect to varying inputs: a4
4232  SUBROUTINE cs_limiters_tlm(im, extm, a4, a4_tl, iv)
4233  IMPLICIT NONE
4234  INTEGER, INTENT(IN) :: im
4235  INTEGER, INTENT(IN) :: iv
4236  LOGICAL, INTENT(IN) :: extm(im)
4237 ! PPM array
4238  REAL, INTENT(INOUT) :: a4(4, im)
4239  REAL, INTENT(INOUT) :: a4_tl(4, im)
4240 ! !LOCAL VARIABLES:
4241  REAL :: da1, da2, a6da
4242  INTEGER :: i
4243  INTRINSIC abs
4244  REAL :: abs0
4245  IF (iv .EQ. 0) THEN
4246 ! Positive definite constraint
4247  DO i=1,im
4248  IF (a4(1, i) .LE. 0.) THEN
4249  a4_tl(2, i) = a4_tl(1, i)
4250  a4(2, i) = a4(1, i)
4251  a4_tl(3, i) = a4_tl(1, i)
4252  a4(3, i) = a4(1, i)
4253  a4_tl(4, i) = 0.0
4254  a4(4, i) = 0.
4255  ELSE
4256  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
4257  abs0 = a4(3, i) - a4(2, i)
4258  ELSE
4259  abs0 = -(a4(3, i)-a4(2, i))
4260  END IF
4261  IF (abs0 .LT. -a4(4, i)) THEN
4262  IF (a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4, &
4263 & i)*r12 .LT. 0.) THEN
4264 ! local minimum is negative
4265  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
4266 & THEN
4267  a4_tl(3, i) = a4_tl(1, i)
4268  a4(3, i) = a4(1, i)
4269  a4_tl(2, i) = a4_tl(1, i)
4270  a4(2, i) = a4(1, i)
4271  a4_tl(4, i) = 0.0
4272  a4(4, i) = 0.
4273  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
4274  a4_tl(4, i) = 3.*(a4_tl(2, i)-a4_tl(1, i))
4275  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
4276  a4_tl(3, i) = a4_tl(2, i) - a4_tl(4, i)
4277  a4(3, i) = a4(2, i) - a4(4, i)
4278  ELSE
4279  a4_tl(4, i) = 3.*(a4_tl(3, i)-a4_tl(1, i))
4280  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
4281  a4_tl(2, i) = a4_tl(3, i) - a4_tl(4, i)
4282  a4(2, i) = a4(3, i) - a4(4, i)
4283  END IF
4284  END IF
4285  END IF
4286  END IF
4287  END DO
4288  ELSE IF (iv .EQ. 1) THEN
4289  DO i=1,im
4290  IF ((a4(1, i)-a4(2, i))*(a4(1, i)-a4(3, i)) .GE. 0.) THEN
4291  a4_tl(2, i) = a4_tl(1, i)
4292  a4(2, i) = a4(1, i)
4293  a4_tl(3, i) = a4_tl(1, i)
4294  a4(3, i) = a4(1, i)
4295  a4_tl(4, i) = 0.0
4296  a4(4, i) = 0.
4297  ELSE
4298  da1 = a4(3, i) - a4(2, i)
4299  da2 = da1**2
4300  a6da = a4(4, i)*da1
4301  IF (a6da .LT. -da2) THEN
4302  a4_tl(4, i) = 3.*(a4_tl(2, i)-a4_tl(1, i))
4303  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
4304  a4_tl(3, i) = a4_tl(2, i) - a4_tl(4, i)
4305  a4(3, i) = a4(2, i) - a4(4, i)
4306  ELSE IF (a6da .GT. da2) THEN
4307  a4_tl(4, i) = 3.*(a4_tl(3, i)-a4_tl(1, i))
4308  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
4309  a4_tl(2, i) = a4_tl(3, i) - a4_tl(4, i)
4310  a4(2, i) = a4(3, i) - a4(4, i)
4311  END IF
4312  END IF
4313  END DO
4314  ELSE
4315 ! Standard PPM constraint
4316  DO i=1,im
4317  IF (extm(i)) THEN
4318  a4_tl(2, i) = a4_tl(1, i)
4319  a4(2, i) = a4(1, i)
4320  a4_tl(3, i) = a4_tl(1, i)
4321  a4(3, i) = a4(1, i)
4322  a4_tl(4, i) = 0.0
4323  a4(4, i) = 0.
4324  ELSE
4325  da1 = a4(3, i) - a4(2, i)
4326  da2 = da1**2
4327  a6da = a4(4, i)*da1
4328  IF (a6da .LT. -da2) THEN
4329  a4_tl(4, i) = 3.*(a4_tl(2, i)-a4_tl(1, i))
4330  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
4331  a4_tl(3, i) = a4_tl(2, i) - a4_tl(4, i)
4332  a4(3, i) = a4(2, i) - a4(4, i)
4333  ELSE IF (a6da .GT. da2) THEN
4334  a4_tl(4, i) = 3.*(a4_tl(3, i)-a4_tl(1, i))
4335  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
4336  a4_tl(2, i) = a4_tl(3, i) - a4_tl(4, i)
4337  a4(2, i) = a4(3, i) - a4(4, i)
4338  END IF
4339  END IF
4340  END DO
4341  END IF
4342  END SUBROUTINE cs_limiters_tlm
4343 ! Differentiation of ppm_profile in forward (tangent) mode:
4344 ! variations of useful results: a4
4345 ! with respect to varying inputs: delp a4
4346  SUBROUTINE ppm_profile_tlm(a4, a4_tl, delp, delp_tl, km, i1, i2, iv, &
4347 & kord)
4348  IMPLICIT NONE
4349 ! !INPUT PARAMETERS:
4350 ! iv =-1: winds
4351  INTEGER, INTENT(IN) :: iv
4352 ! iv = 0: positive definite scalars
4353 ! iv = 1: others
4354 ! iv = 2: w (iv=-2)
4355 ! Starting longitude
4356  INTEGER, INTENT(IN) :: i1
4357 ! Finishing longitude
4358  INTEGER, INTENT(IN) :: i2
4359 ! vertical dimension
4360  INTEGER, INTENT(IN) :: km
4361 ! Order (or more accurately method no.):
4362  INTEGER, INTENT(IN) :: kord
4363 !
4364 ! layer pressure thickness
4365  REAL, INTENT(IN) :: delp(i1:i2, km)
4366  REAL, INTENT(IN) :: delp_tl(i1:i2, km)
4367 ! !INPUT/OUTPUT PARAMETERS:
4368 ! Interpolated values
4369  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
4370  REAL, INTENT(INOUT) :: a4_tl(4, i1:i2, km)
4371 ! DESCRIPTION:
4372 !
4373 ! Perform the piecewise parabolic reconstruction
4374 !
4375 ! !REVISION HISTORY:
4376 ! S.-J. Lin revised at GFDL 2007
4377 !-----------------------------------------------------------------------
4378 ! local arrays:
4379  REAL :: dc(i1:i2, km)
4380  REAL :: dc_tl(i1:i2, km)
4381  REAL :: h2(i1:i2, km)
4382  REAL :: h2_tl(i1:i2, km)
4383  REAL :: delq(i1:i2, km)
4384  REAL :: delq_tl(i1:i2, km)
4385  REAL :: df2(i1:i2, km)
4386  REAL :: df2_tl(i1:i2, km)
4387  REAL :: d4(i1:i2, km)
4388  REAL :: d4_tl(i1:i2, km)
4389 ! local scalars:
4390  INTEGER :: i, k, km1, lmt, it
4391  REAL :: fac
4392  REAL :: a1, a2, c1, c2, c3, d1, d2
4393  REAL :: a1_tl, a2_tl, c1_tl, c2_tl, c3_tl, d1_tl, d2_tl
4394  REAL :: qm, dq, lac, qmp, pmp
4395  REAL :: qm_tl, dq_tl, lac_tl, qmp_tl, pmp_tl
4396  INTRINSIC abs
4397  INTRINSIC max
4398  INTRINSIC min
4399  INTRINSIC sign
4400  REAL :: min1
4401  REAL :: min1_tl
4402  INTEGER :: abs0
4403  REAL :: max1
4404  REAL :: max1_tl
4405  REAL :: min2
4406  REAL :: min2_tl
4407  REAL :: x1_tl
4408  REAL :: y1_tl
4409  REAL :: z1_tl
4410  REAL :: y2_tl
4411  REAL :: y3_tl
4412  REAL :: y4_tl
4413  REAL :: y5_tl
4414  REAL :: y8_tl
4415  REAL :: x2_tl
4416  REAL :: y6_tl
4417  REAL :: y9_tl
4418  REAL :: x3_tl
4419  REAL :: y7_tl
4420  REAL :: x3
4421  REAL :: x2
4422  REAL :: x1
4423  REAL :: z1
4424  REAL :: y9
4425  REAL :: y8
4426  REAL :: y7
4427  REAL :: y6
4428  REAL :: y5
4429  REAL :: y4
4430  REAL :: y3
4431  REAL :: y2
4432  REAL :: y1
4433  km1 = km - 1
4434  it = i2 - i1 + 1
4435  delq_tl = 0.0
4436  d4_tl = 0.0
4437  DO k=2,km
4438  DO i=i1,i2
4439  delq_tl(i, k-1) = a4_tl(1, i, k) - a4_tl(1, i, k-1)
4440  delq(i, k-1) = a4(1, i, k) - a4(1, i, k-1)
4441  d4_tl(i, k) = delp_tl(i, k-1) + delp_tl(i, k)
4442  d4(i, k) = delp(i, k-1) + delp(i, k)
4443  END DO
4444  END DO
4445  df2_tl = 0.0
4446  dc_tl = 0.0
4447  DO k=2,km1
4448  DO i=i1,i2
4449  c1_tl = ((delp_tl(i, k-1)+0.5*delp_tl(i, k))*d4(i, k+1)-(delp(i&
4450 & , k-1)+0.5*delp(i, k))*d4_tl(i, k+1))/d4(i, k+1)**2
4451  c1 = (delp(i, k-1)+0.5*delp(i, k))/d4(i, k+1)
4452  c2_tl = ((delp_tl(i, k+1)+0.5*delp_tl(i, k))*d4(i, k)-(delp(i, k&
4453 & +1)+0.5*delp(i, k))*d4_tl(i, k))/d4(i, k)**2
4454  c2 = (delp(i, k+1)+0.5*delp(i, k))/d4(i, k)
4455  df2_tl(i, k) = ((delp_tl(i, k)*(c1*delq(i, k)+c2*delq(i, k-1))+&
4456 & delp(i, k)*(c1_tl*delq(i, k)+c1*delq_tl(i, k)+c2_tl*delq(i, k-&
4457 & 1)+c2*delq_tl(i, k-1)))*(d4(i, k)+delp(i, k+1))-delp(i, k)*(c1&
4458 & *delq(i, k)+c2*delq(i, k-1))*(d4_tl(i, k)+delp_tl(i, k+1)))/(&
4459 & d4(i, k)+delp(i, k+1))**2
4460  df2(i, k) = delp(i, k)*(c1*delq(i, k)+c2*delq(i, k-1))/(d4(i, k)&
4461 & +delp(i, k+1))
4462  IF (df2(i, k) .GE. 0.) THEN
4463  x1_tl = df2_tl(i, k)
4464  x1 = df2(i, k)
4465  ELSE
4466  x1_tl = -df2_tl(i, k)
4467  x1 = -df2(i, k)
4468  END IF
4469  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
4470  IF (a4(1, i, k) .LT. a4(1, i, k+1)) THEN
4471  max1_tl = a4_tl(1, i, k+1)
4472  max1 = a4(1, i, k+1)
4473  ELSE
4474  max1_tl = a4_tl(1, i, k)
4475  max1 = a4(1, i, k)
4476  END IF
4477  ELSE IF (a4(1, i, k-1) .LT. a4(1, i, k+1)) THEN
4478  max1_tl = a4_tl(1, i, k+1)
4479  max1 = a4(1, i, k+1)
4480  ELSE
4481  max1_tl = a4_tl(1, i, k-1)
4482  max1 = a4(1, i, k-1)
4483  END IF
4484  y1_tl = max1_tl - a4_tl(1, i, k)
4485  y1 = max1 - a4(1, i, k)
4486  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
4487  IF (a4(1, i, k) .GT. a4(1, i, k+1)) THEN
4488  min2_tl = a4_tl(1, i, k+1)
4489  min2 = a4(1, i, k+1)
4490  ELSE
4491  min2_tl = a4_tl(1, i, k)
4492  min2 = a4(1, i, k)
4493  END IF
4494  ELSE IF (a4(1, i, k-1) .GT. a4(1, i, k+1)) THEN
4495  min2_tl = a4_tl(1, i, k+1)
4496  min2 = a4(1, i, k+1)
4497  ELSE
4498  min2_tl = a4_tl(1, i, k-1)
4499  min2 = a4(1, i, k-1)
4500  END IF
4501  z1_tl = a4_tl(1, i, k) - min2_tl
4502  z1 = a4(1, i, k) - min2
4503  IF (x1 .GT. y1) THEN
4504  IF (y1 .GT. z1) THEN
4505  min1_tl = z1_tl
4506  min1 = z1
4507  ELSE
4508  min1_tl = y1_tl
4509  min1 = y1
4510  END IF
4511  ELSE IF (x1 .GT. z1) THEN
4512  min1_tl = z1_tl
4513  min1 = z1
4514  ELSE
4515  min1_tl = x1_tl
4516  min1 = x1
4517  END IF
4518  dc_tl(i, k) = min1_tl*sign(1.d0, min1*df2(i, k))
4519  dc(i, k) = sign(min1, df2(i, k))
4520  END DO
4521  END DO
4522 !-----------------------------------------------------------
4523 ! 4th order interpolation of the provisional cell edge value
4524 !-----------------------------------------------------------
4525  DO k=3,km1
4526  DO i=i1,i2
4527  c1_tl = ((delq_tl(i, k-1)*delp(i, k-1)+delq(i, k-1)*delp_tl(i, k&
4528 & -1))*d4(i, k)-delq(i, k-1)*delp(i, k-1)*d4_tl(i, k))/d4(i, k)&
4529 & **2
4530  c1 = delq(i, k-1)*delp(i, k-1)/d4(i, k)
4531  a1_tl = (d4_tl(i, k-1)*(d4(i, k)+delp(i, k-1))-d4(i, k-1)*(d4_tl&
4532 & (i, k)+delp_tl(i, k-1)))/(d4(i, k)+delp(i, k-1))**2
4533  a1 = d4(i, k-1)/(d4(i, k)+delp(i, k-1))
4534  a2_tl = (d4_tl(i, k+1)*(d4(i, k)+delp(i, k))-d4(i, k+1)*(d4_tl(i&
4535 & , k)+delp_tl(i, k)))/(d4(i, k)+delp(i, k))**2
4536  a2 = d4(i, k+1)/(d4(i, k)+delp(i, k))
4537  a4_tl(2, i, k) = a4_tl(1, i, k-1) + c1_tl + 2.*(delp_tl(i, k)*(&
4538 & c1*(a1-a2)+a2*dc(i, k-1))+delp(i, k)*(c1_tl*(a1-a2)+c1*(a1_tl-&
4539 & a2_tl)+a2_tl*dc(i, k-1)+a2*dc_tl(i, k-1))-delp_tl(i, k-1)*a1*&
4540 & dc(i, k)-delp(i, k-1)*(a1_tl*dc(i, k)+a1*dc_tl(i, k)))/(d4(i, &
4541 & k-1)+d4(i, k+1)) - 2.*(d4_tl(i, k-1)+d4_tl(i, k+1))*(delp(i, k&
4542 & )*(c1*(a1-a2)+a2*dc(i, k-1))-delp(i, k-1)*a1*dc(i, k))/(d4(i, &
4543 & k-1)+d4(i, k+1))**2
4544  a4(2, i, k) = a4(1, i, k-1) + c1 + 2./(d4(i, k-1)+d4(i, k+1))*(&
4545 & delp(i, k)*(c1*(a1-a2)+a2*dc(i, k-1))-delp(i, k-1)*a1*dc(i, k)&
4546 & )
4547  END DO
4548  END DO
4549 ! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4)
4550 ! Area preserving cubic with 2nd deriv. = 0 at the boundaries
4551 ! Top
4552  DO i=i1,i2
4553  d1_tl = delp_tl(i, 1)
4554  d1 = delp(i, 1)
4555  d2_tl = delp_tl(i, 2)
4556  d2 = delp(i, 2)
4557  qm_tl = ((d2_tl*a4(1, i, 1)+d2*a4_tl(1, i, 1)+d1_tl*a4(1, i, 2)+d1&
4558 & *a4_tl(1, i, 2))*(d1+d2)-(d2*a4(1, i, 1)+d1*a4(1, i, 2))*(d1_tl+&
4559 & d2_tl))/(d1+d2)**2
4560  qm = (d2*a4(1, i, 1)+d1*a4(1, i, 2))/(d1+d2)
4561  dq_tl = (2.*(a4_tl(1, i, 2)-a4_tl(1, i, 1))*(d1+d2)-2.*(a4(1, i, 2&
4562 & )-a4(1, i, 1))*(d1_tl+d2_tl))/(d1+d2)**2
4563  dq = 2.*(a4(1, i, 2)-a4(1, i, 1))/(d1+d2)
4564  c1_tl = (4.*(a4_tl(2, i, 3)-qm_tl-d2_tl*dq-d2*dq_tl)*d2*(2.*d2*d2+&
4565 & d1*(d2+3.*d1))-4.*(a4(2, i, 3)-qm-d2*dq)*(d2_tl*(2.*d2*d2+d1*(d2&
4566 & +3.*d1))+d2*(2.*(d2_tl*d2+d2*d2_tl)+d1_tl*(d2+3.*d1)+d1*(d2_tl+&
4567 & 3.*d1_tl))))/(d2*(2.*d2*d2+d1*(d2+3.*d1)))**2
4568  c1 = 4.*(a4(2, i, 3)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
4569  c3_tl = dq_tl - 0.5*(c1_tl*(d2*(5.*d1+d2)-3.*d1*d1)+c1*(d2_tl*(5.*&
4570 & d1+d2)+d2*(5.*d1_tl+d2_tl)-3.*(d1_tl*d1+d1*d1_tl)))
4571  c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
4572  a4_tl(2, i, 2) = qm_tl - 0.25*(((c1_tl*d1+c1*d1_tl)*d2+c1*d1*d2_tl&
4573 & )*(d2+3.*d1)+c1*d1*d2*(d2_tl+3.*d1_tl))
4574  a4(2, i, 2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
4575 ! Top edge:
4576 !-------------------------------------------------------
4577  a4_tl(2, i, 1) = d1_tl*(2.*c1*d1**2-c3) + d1*(2.*(c1_tl*d1**2+c1*2&
4578 & *d1*d1_tl)-c3_tl) + a4_tl(2, i, 2)
4579  a4(2, i, 1) = d1*(2.*c1*d1**2-c3) + a4(2, i, 2)
4580  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
4581  y2_tl = a4_tl(1, i, 2)
4582  y2 = a4(1, i, 2)
4583  ELSE
4584  y2_tl = a4_tl(1, i, 1)
4585  y2 = a4(1, i, 1)
4586  END IF
4587  IF (a4(2, i, 2) .LT. y2) THEN
4588  a4_tl(2, i, 2) = y2_tl
4589  a4(2, i, 2) = y2
4590  ELSE
4591  a4(2, i, 2) = a4(2, i, 2)
4592  END IF
4593  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
4594  y3_tl = a4_tl(1, i, 2)
4595  y3 = a4(1, i, 2)
4596  ELSE
4597  y3_tl = a4_tl(1, i, 1)
4598  y3 = a4(1, i, 1)
4599  END IF
4600  IF (a4(2, i, 2) .GT. y3) THEN
4601  a4_tl(2, i, 2) = y3_tl
4602  a4(2, i, 2) = y3
4603  ELSE
4604  a4(2, i, 2) = a4(2, i, 2)
4605  END IF
4606  dc_tl(i, 1) = 0.5*(a4_tl(2, i, 2)-a4_tl(1, i, 1))
4607  dc(i, 1) = 0.5*(a4(2, i, 2)-a4(1, i, 1))
4608  END DO
4609 ! Enforce monotonicity within the top layer
4610  IF (iv .EQ. 0) THEN
4611  DO i=i1,i2
4612  IF (0. .LT. a4(2, i, 1)) THEN
4613  a4(2, i, 1) = a4(2, i, 1)
4614  ELSE
4615  a4_tl(2, i, 1) = 0.0
4616  a4(2, i, 1) = 0.
4617  END IF
4618  IF (0. .LT. a4(2, i, 2)) THEN
4619  a4(2, i, 2) = a4(2, i, 2)
4620  ELSE
4621  a4_tl(2, i, 2) = 0.0
4622  a4(2, i, 2) = 0.
4623  END IF
4624  END DO
4625  ELSE IF (iv .EQ. -1) THEN
4626  DO i=i1,i2
4627  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) THEN
4628  a4_tl(2, i, 1) = 0.0
4629  a4(2, i, 1) = 0.
4630  END IF
4631  END DO
4632  ELSE
4633  IF (iv .GE. 0.) THEN
4634  abs0 = iv
4635  ELSE
4636  abs0 = -iv
4637  END IF
4638  IF (abs0 .EQ. 2) THEN
4639  DO i=i1,i2
4640  a4_tl(2, i, 1) = a4_tl(1, i, 1)
4641  a4(2, i, 1) = a4(1, i, 1)
4642  a4_tl(3, i, 1) = a4_tl(1, i, 1)
4643  a4(3, i, 1) = a4(1, i, 1)
4644  END DO
4645  END IF
4646  END IF
4647 ! Bottom
4648 ! Area preserving cubic with 2nd deriv. = 0 at the surface
4649  DO i=i1,i2
4650  d1_tl = delp_tl(i, km)
4651  d1 = delp(i, km)
4652  d2_tl = delp_tl(i, km1)
4653  d2 = delp(i, km1)
4654  qm_tl = ((d2_tl*a4(1, i, km)+d2*a4_tl(1, i, km)+d1_tl*a4(1, i, km1&
4655 & )+d1*a4_tl(1, i, km1))*(d1+d2)-(d2*a4(1, i, km)+d1*a4(1, i, km1)&
4656 & )*(d1_tl+d2_tl))/(d1+d2)**2
4657  qm = (d2*a4(1, i, km)+d1*a4(1, i, km1))/(d1+d2)
4658  dq_tl = (2.*(a4_tl(1, i, km1)-a4_tl(1, i, km))*(d1+d2)-2.*(a4(1, i&
4659 & , km1)-a4(1, i, km))*(d1_tl+d2_tl))/(d1+d2)**2
4660  dq = 2.*(a4(1, i, km1)-a4(1, i, km))/(d1+d2)
4661  c1_tl = ((a4_tl(2, i, km1)-qm_tl-d2_tl*dq-d2*dq_tl)*d2*(2.*d2*d2+&
4662 & d1*(d2+3.*d1))-(a4(2, i, km1)-qm-d2*dq)*(d2_tl*(2.*d2*d2+d1*(d2+&
4663 & 3.*d1))+d2*(2.*(d2_tl*d2+d2*d2_tl)+d1_tl*(d2+3.*d1)+d1*(d2_tl+3.&
4664 & *d1_tl))))/(d2*(2.*d2*d2+d1*(d2+3.*d1)))**2
4665  c1 = (a4(2, i, km1)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
4666  c3_tl = dq_tl - 2.0*(c1_tl*(d2*(5.*d1+d2)-3.*d1*d1)+c1*(d2_tl*(5.*&
4667 & d1+d2)+d2*(5.*d1_tl+d2_tl)-3.*(d1_tl*d1+d1*d1_tl)))
4668  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
4669  a4_tl(2, i, km) = qm_tl - ((c1_tl*d1+c1*d1_tl)*d2+c1*d1*d2_tl)*(d2&
4670 & +3.*d1) - c1*d1*d2*(d2_tl+3.*d1_tl)
4671  a4(2, i, km) = qm - c1*d1*d2*(d2+3.*d1)
4672 ! Bottom edge:
4673 !-----------------------------------------------------
4674  a4_tl(3, i, km) = d1_tl*(8.*c1*d1**2-c3) + d1*(8.*(c1_tl*d1**2+c1*&
4675 & 2*d1*d1_tl)-c3_tl) + a4_tl(2, i, km)
4676  a4(3, i, km) = d1*(8.*c1*d1**2-c3) + a4(2, i, km)
4677  IF (a4(1, i, km) .GT. a4(1, i, km1)) THEN
4678  y4_tl = a4_tl(1, i, km1)
4679  y4 = a4(1, i, km1)
4680  ELSE
4681  y4_tl = a4_tl(1, i, km)
4682  y4 = a4(1, i, km)
4683  END IF
4684  IF (a4(2, i, km) .LT. y4) THEN
4685  a4_tl(2, i, km) = y4_tl
4686  a4(2, i, km) = y4
4687  ELSE
4688  a4(2, i, km) = a4(2, i, km)
4689  END IF
4690  IF (a4(1, i, km) .LT. a4(1, i, km1)) THEN
4691  y5_tl = a4_tl(1, i, km1)
4692  y5 = a4(1, i, km1)
4693  ELSE
4694  y5_tl = a4_tl(1, i, km)
4695  y5 = a4(1, i, km)
4696  END IF
4697  IF (a4(2, i, km) .GT. y5) THEN
4698  a4_tl(2, i, km) = y5_tl
4699  a4(2, i, km) = y5
4700  ELSE
4701  a4(2, i, km) = a4(2, i, km)
4702  END IF
4703  dc_tl(i, km) = 0.5*(a4_tl(1, i, km)-a4_tl(2, i, km))
4704  dc(i, km) = 0.5*(a4(1, i, km)-a4(2, i, km))
4705  END DO
4706 ! Enforce constraint on the "slope" at the surface
4707  IF (iv .EQ. 0) THEN
4708  DO i=i1,i2
4709  IF (0. .LT. a4(2, i, km)) THEN
4710  a4(2, i, km) = a4(2, i, km)
4711  ELSE
4712  a4_tl(2, i, km) = 0.0
4713  a4(2, i, km) = 0.
4714  END IF
4715  IF (0. .LT. a4(3, i, km)) THEN
4716  a4(3, i, km) = a4(3, i, km)
4717  ELSE
4718  a4_tl(3, i, km) = 0.0
4719  a4(3, i, km) = 0.
4720  END IF
4721  END DO
4722  ELSE IF (iv .LT. 0) THEN
4723  DO i=i1,i2
4724  IF (a4(1, i, km)*a4(3, i, km) .LE. 0.) THEN
4725  a4_tl(3, i, km) = 0.0
4726  a4(3, i, km) = 0.
4727  END IF
4728  END DO
4729  END IF
4730  DO k=1,km1
4731  DO i=i1,i2
4732  a4_tl(3, i, k) = a4_tl(2, i, k+1)
4733  a4(3, i, k) = a4(2, i, k+1)
4734  END DO
4735  END DO
4736 !-----------------------------------------------------------
4737 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
4738 !-----------------------------------------------------------
4739 ! Top 2 and bottom 2 layers always use monotonic mapping
4740  DO k=1,2
4741  DO i=i1,i2
4742  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(3, i&
4743 & , k))
4744  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
4745  END DO
4746  CALL ppm_limiters_tlm(dc(i1, k), dc_tl(i1, k), a4(1, i1, k), a4_tl&
4747 & (1, i1, k), it, 0)
4748  END DO
4749  IF (kord .GE. 7) THEN
4750  h2_tl = 0.0
4751 !-----------------------
4752 ! Huynh's 2nd constraint
4753 !-----------------------
4754  DO k=2,km1
4755  DO i=i1,i2
4756 ! Method#1
4757 ! h2(i,k) = delq(i,k) - delq(i,k-1)
4758 ! Method#2 - better
4759  h2_tl(i, k) = (2.*((dc_tl(i, k+1)*delp(i, k+1)-dc(i, k+1)*&
4760 & delp_tl(i, k+1))/delp(i, k+1)**2-(dc_tl(i, k-1)*delp(i, k-1)&
4761 & -dc(i, k-1)*delp_tl(i, k-1))/delp(i, k-1)**2)*(delp(i, k)+&
4762 & 0.5*(delp(i, k-1)+delp(i, k+1)))-2.*(dc(i, k+1)/delp(i, k+1)&
4763 & -dc(i, k-1)/delp(i, k-1))*(delp_tl(i, k)+0.5*(delp_tl(i, k-1&
4764 & )+delp_tl(i, k+1))))*delp(i, k)**2/(delp(i, k)+0.5*(delp(i, &
4765 & k-1)+delp(i, k+1)))**2 + 2.*(dc(i, k+1)/delp(i, k+1)-dc(i, k&
4766 & -1)/delp(i, k-1))*2*delp(i, k)*delp_tl(i, k)/(delp(i, k)+0.5&
4767 & *(delp(i, k-1)+delp(i, k+1)))
4768  h2(i, k) = 2.*(dc(i, k+1)/delp(i, k+1)-dc(i, k-1)/delp(i, k-1)&
4769 & )/(delp(i, k)+0.5*(delp(i, k-1)+delp(i, k+1)))*delp(i, k)**2
4770  END DO
4771  END DO
4772 ! Method#3
4773 !!! h2(i,k) = dc(i,k+1) - dc(i,k-1)
4774 ! original quasi-monotone
4775  fac = 1.5
4776  DO k=3,km-2
4777  DO i=i1,i2
4778 ! Right edges
4779 ! qmp = a4(1,i,k) + 2.0*delq(i,k-1)
4780 ! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
4781 !
4782  pmp_tl = 2.*dc_tl(i, k)
4783  pmp = 2.*dc(i, k)
4784  qmp_tl = a4_tl(1, i, k) + pmp_tl
4785  qmp = a4(1, i, k) + pmp
4786  lac_tl = a4_tl(1, i, k) + fac*h2_tl(i, k-1) + dc_tl(i, k)
4787  lac = a4(1, i, k) + fac*h2(i, k-1) + dc(i, k)
4788  IF (a4(1, i, k) .GT. qmp) THEN
4789  IF (qmp .GT. lac) THEN
4790  y8_tl = lac_tl
4791  y8 = lac
4792  ELSE
4793  y8_tl = qmp_tl
4794  y8 = qmp
4795  END IF
4796  ELSE IF (a4(1, i, k) .GT. lac) THEN
4797  y8_tl = lac_tl
4798  y8 = lac
4799  ELSE
4800  y8_tl = a4_tl(1, i, k)
4801  y8 = a4(1, i, k)
4802  END IF
4803  IF (a4(3, i, k) .LT. y8) THEN
4804  x2_tl = y8_tl
4805  x2 = y8
4806  ELSE
4807  x2_tl = a4_tl(3, i, k)
4808  x2 = a4(3, i, k)
4809  END IF
4810  IF (a4(1, i, k) .LT. qmp) THEN
4811  IF (qmp .LT. lac) THEN
4812  y6_tl = lac_tl
4813  y6 = lac
4814  ELSE
4815  y6_tl = qmp_tl
4816  y6 = qmp
4817  END IF
4818  ELSE IF (a4(1, i, k) .LT. lac) THEN
4819  y6_tl = lac_tl
4820  y6 = lac
4821  ELSE
4822  y6_tl = a4_tl(1, i, k)
4823  y6 = a4(1, i, k)
4824  END IF
4825  IF (x2 .GT. y6) THEN
4826  a4_tl(3, i, k) = y6_tl
4827  a4(3, i, k) = y6
4828  ELSE
4829  a4_tl(3, i, k) = x2_tl
4830  a4(3, i, k) = x2
4831  END IF
4832 ! Left edges
4833 ! qmp = a4(1,i,k) - 2.0*delq(i,k)
4834 ! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
4835 !
4836  qmp_tl = a4_tl(1, i, k) - pmp_tl
4837  qmp = a4(1, i, k) - pmp
4838  lac_tl = a4_tl(1, i, k) + fac*h2_tl(i, k+1) - dc_tl(i, k)
4839  lac = a4(1, i, k) + fac*h2(i, k+1) - dc(i, k)
4840  IF (a4(1, i, k) .GT. qmp) THEN
4841  IF (qmp .GT. lac) THEN
4842  y9_tl = lac_tl
4843  y9 = lac
4844  ELSE
4845  y9_tl = qmp_tl
4846  y9 = qmp
4847  END IF
4848  ELSE IF (a4(1, i, k) .GT. lac) THEN
4849  y9_tl = lac_tl
4850  y9 = lac
4851  ELSE
4852  y9_tl = a4_tl(1, i, k)
4853  y9 = a4(1, i, k)
4854  END IF
4855  IF (a4(2, i, k) .LT. y9) THEN
4856  x3_tl = y9_tl
4857  x3 = y9
4858  ELSE
4859  x3_tl = a4_tl(2, i, k)
4860  x3 = a4(2, i, k)
4861  END IF
4862  IF (a4(1, i, k) .LT. qmp) THEN
4863  IF (qmp .LT. lac) THEN
4864  y7_tl = lac_tl
4865  y7 = lac
4866  ELSE
4867  y7_tl = qmp_tl
4868  y7 = qmp
4869  END IF
4870  ELSE IF (a4(1, i, k) .LT. lac) THEN
4871  y7_tl = lac_tl
4872  y7 = lac
4873  ELSE
4874  y7_tl = a4_tl(1, i, k)
4875  y7 = a4(1, i, k)
4876  END IF
4877  IF (x3 .GT. y7) THEN
4878  a4_tl(2, i, k) = y7_tl
4879  a4(2, i, k) = y7
4880  ELSE
4881  a4_tl(2, i, k) = x3_tl
4882  a4(2, i, k) = x3
4883  END IF
4884 !-------------
4885 ! Recompute A6
4886 !-------------
4887  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(3&
4888 & , i, k))
4889  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
4890  END DO
4891 ! Additional constraint to ensure positivity when kord=7
4892  IF (iv .EQ. 0 .AND. kord .GE. 6) CALL ppm_limiters_tlm(dc(i1, k)&
4893 & , dc_tl(i1, k)&
4894 & , a4(1, i1, k)&
4895 & , a4_tl(1, i1, &
4896 & k), it, 2)
4897  END DO
4898  ELSE
4899  lmt = kord - 3
4900  IF (0 .LT. lmt) THEN
4901  lmt = lmt
4902  ELSE
4903  lmt = 0
4904  END IF
4905  IF (iv .EQ. 0) THEN
4906  IF (2 .GT. lmt) THEN
4907  lmt = lmt
4908  ELSE
4909  lmt = 2
4910  END IF
4911  END IF
4912  DO k=3,km-2
4913  IF (kord .NE. 4) THEN
4914  DO i=i1,i2
4915  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(&
4916 & 3, i, k))
4917  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
4918  END DO
4919  END IF
4920  IF (kord .NE. 6) CALL ppm_limiters_tlm(dc(i1, k), dc_tl(i1, k), &
4921 & a4(1, i1, k), a4_tl(1, i1, k), &
4922 & it, lmt)
4923  END DO
4924  END IF
4925  DO k=km1,km
4926  DO i=i1,i2
4927  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(3, i&
4928 & , k))
4929  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
4930  END DO
4931  CALL ppm_limiters_tlm(dc(i1, k), dc_tl(i1, k), a4(1, i1, k), a4_tl&
4932 & (1, i1, k), it, 0)
4933  END DO
4934  END SUBROUTINE ppm_profile_tlm
4935 ! Differentiation of ppm_limiters in forward (tangent) mode:
4936 ! variations of useful results: a4
4937 ! with respect to varying inputs: dm a4
4938  SUBROUTINE ppm_limiters_tlm(dm, dm_tl, a4, a4_tl, itot, lmt)
4939  IMPLICIT NONE
4940 ! !INPUT PARAMETERS:
4941 ! the linear slope
4942  REAL, INTENT(IN) :: dm(*)
4943  REAL, INTENT(IN) :: dm_tl(*)
4944 ! Total Longitudes
4945  INTEGER, INTENT(IN) :: itot
4946 ! 0: Standard PPM constraint
4947  INTEGER, INTENT(IN) :: lmt
4948 ! 1: Improved full monotonicity constraint (Lin)
4949 ! 2: Positive definite constraint
4950 ! 3: do nothing (return immediately)
4951 ! !INPUT/OUTPUT PARAMETERS:
4952 ! PPM array
4953  REAL, INTENT(INOUT) :: a4(4, *)
4954  REAL, INTENT(INOUT) :: a4_tl(4, *)
4955 ! AA <-- a4(1,i)
4956 ! AL <-- a4(2,i)
4957 ! AR <-- a4(3,i)
4958 ! A6 <-- a4(4,i)
4959 ! !LOCAL VARIABLES:
4960  REAL :: qmp
4961  REAL :: qmp_tl
4962  REAL :: da1, da2, a6da
4963  REAL :: fmin
4964  INTEGER :: i
4965  INTRINSIC abs
4966  INTRINSIC min
4967  INTRINSIC sign
4968  REAL :: min1
4969  REAL :: min1_tl
4970  REAL :: min2
4971  REAL :: min2_tl
4972  REAL :: abs0
4973  REAL :: x1_tl
4974  REAL :: y1_tl
4975  REAL :: x2_tl
4976  REAL :: y2_tl
4977  REAL :: x2
4978  REAL :: x1
4979  REAL :: y2
4980  REAL :: y1
4981 ! Developer: S.-J. Lin
4982  IF (lmt .EQ. 3) THEN
4983  RETURN
4984  ELSE IF (lmt .EQ. 0) THEN
4985 ! Standard PPM constraint
4986  DO i=1,itot
4987  IF (dm(i) .EQ. 0.) THEN
4988  a4_tl(2, i) = a4_tl(1, i)
4989  a4(2, i) = a4(1, i)
4990  a4_tl(3, i) = a4_tl(1, i)
4991  a4(3, i) = a4(1, i)
4992  a4_tl(4, i) = 0.0
4993  a4(4, i) = 0.
4994  ELSE
4995  da1 = a4(3, i) - a4(2, i)
4996  da2 = da1**2
4997  a6da = a4(4, i)*da1
4998  IF (a6da .LT. -da2) THEN
4999  a4_tl(4, i) = 3.*(a4_tl(2, i)-a4_tl(1, i))
5000  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
5001  a4_tl(3, i) = a4_tl(2, i) - a4_tl(4, i)
5002  a4(3, i) = a4(2, i) - a4(4, i)
5003  ELSE IF (a6da .GT. da2) THEN
5004  a4_tl(4, i) = 3.*(a4_tl(3, i)-a4_tl(1, i))
5005  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
5006  a4_tl(2, i) = a4_tl(3, i) - a4_tl(4, i)
5007  a4(2, i) = a4(3, i) - a4(4, i)
5008  END IF
5009  END IF
5010  END DO
5011  ELSE IF (lmt .EQ. 1) THEN
5012 ! Improved full monotonicity constraint (Lin 2004)
5013 ! Note: no need to provide first guess of A6 <-- a4(4,i)
5014  DO i=1,itot
5015  qmp_tl = 2.*dm_tl(i)
5016  qmp = 2.*dm(i)
5017  IF (qmp .GE. 0.) THEN
5018  x1_tl = qmp_tl
5019  x1 = qmp
5020  ELSE
5021  x1_tl = -qmp_tl
5022  x1 = -qmp
5023  END IF
5024  IF (a4(2, i) - a4(1, i) .GE. 0.) THEN
5025  y1_tl = a4_tl(2, i) - a4_tl(1, i)
5026  y1 = a4(2, i) - a4(1, i)
5027  ELSE
5028  y1_tl = -(a4_tl(2, i)-a4_tl(1, i))
5029  y1 = -(a4(2, i)-a4(1, i))
5030  END IF
5031  IF (x1 .GT. y1) THEN
5032  min1_tl = y1_tl
5033  min1 = y1
5034  ELSE
5035  min1_tl = x1_tl
5036  min1 = x1
5037  END IF
5038  a4_tl(2, i) = a4_tl(1, i) - min1_tl*sign(1.d0, min1*qmp)
5039  a4(2, i) = a4(1, i) - sign(min1, qmp)
5040  IF (qmp .GE. 0.) THEN
5041  x2_tl = qmp_tl
5042  x2 = qmp
5043  ELSE
5044  x2_tl = -qmp_tl
5045  x2 = -qmp
5046  END IF
5047  IF (a4(3, i) - a4(1, i) .GE. 0.) THEN
5048  y2_tl = a4_tl(3, i) - a4_tl(1, i)
5049  y2 = a4(3, i) - a4(1, i)
5050  ELSE
5051  y2_tl = -(a4_tl(3, i)-a4_tl(1, i))
5052  y2 = -(a4(3, i)-a4(1, i))
5053  END IF
5054  IF (x2 .GT. y2) THEN
5055  min2_tl = y2_tl
5056  min2 = y2
5057  ELSE
5058  min2_tl = x2_tl
5059  min2 = x2
5060  END IF
5061  a4_tl(3, i) = a4_tl(1, i) + min2_tl*sign(1.d0, min2*qmp)
5062  a4(3, i) = a4(1, i) + sign(min2, qmp)
5063  a4_tl(4, i) = 3.*(2.*a4_tl(1, i)-a4_tl(2, i)-a4_tl(3, i))
5064  a4(4, i) = 3.*(2.*a4(1, i)-(a4(2, i)+a4(3, i)))
5065  END DO
5066  ELSE IF (lmt .EQ. 2) THEN
5067 ! Positive definite constraint
5068  DO i=1,itot
5069  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
5070  abs0 = a4(3, i) - a4(2, i)
5071  ELSE
5072  abs0 = -(a4(3, i)-a4(2, i))
5073  END IF
5074  IF (abs0 .LT. -a4(4, i)) THEN
5075  fmin = a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4&
5076 & , i)*r12
5077  IF (fmin .LT. 0.) THEN
5078  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
5079 & THEN
5080  a4_tl(3, i) = a4_tl(1, i)
5081  a4(3, i) = a4(1, i)
5082  a4_tl(2, i) = a4_tl(1, i)
5083  a4(2, i) = a4(1, i)
5084  a4_tl(4, i) = 0.0
5085  a4(4, i) = 0.
5086  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
5087  a4_tl(4, i) = 3.*(a4_tl(2, i)-a4_tl(1, i))
5088  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
5089  a4_tl(3, i) = a4_tl(2, i) - a4_tl(4, i)
5090  a4(3, i) = a4(2, i) - a4(4, i)
5091  ELSE
5092  a4_tl(4, i) = 3.*(a4_tl(3, i)-a4_tl(1, i))
5093  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
5094  a4_tl(2, i) = a4_tl(3, i) - a4_tl(4, i)
5095  a4(2, i) = a4(3, i) - a4(4, i)
5096  END IF
5097  END IF
5098  END IF
5099  END DO
5100  END IF
5101  END SUBROUTINE ppm_limiters_tlm
5102  SUBROUTINE steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
5103  IMPLICIT NONE
5104  INTEGER, INTENT(IN) :: km, i1, i2
5105 ! grid size
5106  REAL, INTENT(IN) :: dp(i1:i2, km)
5107 ! backward diff of q
5108  REAL, INTENT(IN) :: dq(i1:i2, km)
5109 ! backward sum: dp(k)+ dp(k-1)
5110  REAL, INTENT(IN) :: d4(i1:i2, km)
5111 ! first guess mismatch
5112  REAL, INTENT(IN) :: df2(i1:i2, km)
5113 ! monotonic mismatch
5114  REAL, INTENT(IN) :: dm(i1:i2, km)
5115 ! !INPUT/OUTPUT PARAMETERS:
5116 ! first guess/steepened
5117  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
5118 ! !LOCAL VARIABLES:
5119  INTEGER :: i, k
5120  REAL :: alfa(i1:i2, km)
5121  REAL :: f(i1:i2, km)
5122  REAL :: rat(i1:i2, km)
5123  REAL :: dg2
5124  INTRINSIC min
5125  INTRINSIC max
5126  REAL :: y1
5127 ! Compute ratio of dq/dp
5128  DO k=2,km
5129  DO i=i1,i2
5130  rat(i, k) = dq(i, k-1)/d4(i, k)
5131  END DO
5132  END DO
5133 ! Compute F
5134  DO k=2,km-1
5135  DO i=i1,i2
5136  f(i, k) = (rat(i, k+1)-rat(i, k))/(dp(i, k-1)+dp(i, k)+dp(i, k+1&
5137 & ))
5138  END DO
5139  END DO
5140  DO k=3,km-2
5141  DO i=i1,i2
5142  IF (f(i, k+1)*f(i, k-1) .LT. 0. .AND. df2(i, k) .NE. 0.) THEN
5143  dg2 = (f(i, k+1)-f(i, k-1))*((dp(i, k+1)-dp(i, k-1))**2+d4(i, &
5144 & k)*d4(i, k+1))
5145  IF (0.5 .GT. -(0.1875*dg2/df2(i, k))) THEN
5146  y1 = -(0.1875*dg2/df2(i, k))
5147  ELSE
5148  y1 = 0.5
5149  END IF
5150  IF (0. .LT. y1) THEN
5151  alfa(i, k) = y1
5152  ELSE
5153  alfa(i, k) = 0.
5154  END IF
5155  ELSE
5156  alfa(i, k) = 0.
5157  END IF
5158  END DO
5159  END DO
5160  DO k=4,km-2
5161  DO i=i1,i2
5162  a4(2, i, k) = (1.-alfa(i, k-1)-alfa(i, k))*a4(2, i, k) + alfa(i&
5163 & , k-1)*(a4(1, i, k)-dm(i, k)) + alfa(i, k)*(a4(1, i, k-1)+dm(i&
5164 & , k-1))
5165  END DO
5166  END DO
5167  END SUBROUTINE steepz
5168  SUBROUTINE rst_remap(km, kn, is, ie, js, je, isd, ied, jsd, jed, nq, &
5169 & ntp, delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, delp, u, v, &
5170 & w, delz, pt, q, qdiag, ak_r, bk_r, ptop, ak, bk, hydrostatic, &
5171 & make_nh, domain, square_domain)
5172  IMPLICIT NONE
5173 !------------------------------------
5174 ! Assuming hybrid sigma-P coordinate:
5175 !------------------------------------
5176 ! !INPUT PARAMETERS:
5177 ! Restart z-dimension
5178  INTEGER, INTENT(IN) :: km
5179 ! Run time dimension
5180  INTEGER, INTENT(IN) :: kn
5181 ! number of tracers (including h2o)
5182  INTEGER, INTENT(IN) :: nq, ntp
5183 ! starting & ending X-Dir index
5184  INTEGER, INTENT(IN) :: is, ie, isd, ied
5185 ! starting & ending Y-Dir index
5186  INTEGER, INTENT(IN) :: js, je, jsd, jed
5187  LOGICAL, INTENT(IN) :: hydrostatic, make_nh, square_domain
5188  REAL, INTENT(IN) :: ptop
5189  REAL, INTENT(IN) :: ak_r(km+1)
5190  REAL, INTENT(IN) :: bk_r(km+1)
5191  REAL, INTENT(IN) :: ak(kn+1)
5192  REAL, INTENT(IN) :: bk(kn+1)
5193 ! pressure thickness
5194  REAL, INTENT(IN) :: delp_r(is:ie, js:je, km)
5195 ! u-wind (m/s)
5196  REAL, INTENT(IN) :: u_r(is:ie, js:je+1, km)
5197 ! v-wind (m/s)
5198  REAL, INTENT(IN) :: v_r(is:ie+1, js:je, km)
5199  REAL, INTENT(INOUT) :: pt_r(is:ie, js:je, km)
5200  REAL, INTENT(IN) :: w_r(is:ie, js:je, km)
5201  REAL, INTENT(IN) :: q_r(is:ie, js:je, km, ntp)
5202  REAL, INTENT(IN) :: qdiag_r(is:ie, js:je, km, ntp+1:nq)
5203  REAL, INTENT(INOUT) :: delz_r(is:ie, js:je, km)
5204  TYPE(domain2d), INTENT(INOUT) :: domain
5205 ! Output:
5206 ! pressure thickness
5207  REAL, INTENT(OUT) :: delp(isd:ied, jsd:jed, kn)
5208 ! u-wind (m/s)
5209  REAL, INTENT(OUT) :: u(isd:ied, jsd:jed+1, kn)
5210 ! v-wind (m/s)
5211  REAL, INTENT(OUT) :: v(isd:ied+1, jsd:jed, kn)
5212 ! vertical velocity (m/s)
5213  REAL, INTENT(OUT) :: w(isd:, jsd:, :)
5214 ! temperature
5215  REAL, INTENT(OUT) :: pt(isd:ied, jsd:jed, kn)
5216  REAL, INTENT(OUT) :: q(isd:ied, jsd:jed, kn, ntp)
5217  REAL, INTENT(OUT) :: qdiag(isd:ied, jsd:jed, kn, ntp+1:nq)
5218 ! delta-height (m)
5219  REAL, INTENT(OUT) :: delz(isd:, jsd:, :)
5220 !-----------------------------------------------------------------------
5221  REAL :: r_vir, rgrav
5222 ! surface pressure
5223  REAL :: ps(isd:ied, jsd:jed)
5224  REAL :: pe1(is:ie, km+1)
5225  REAL :: pe2(is:ie, kn+1)
5226  REAL :: pv1(is:ie+1, km+1)
5227  REAL :: pv2(is:ie+1, kn+1)
5228  INTEGER :: i, j, k, iq
5229  INTEGER, PARAMETER :: kord=4
5230  INTRINSIC log
5231  r_vir = rvgas/rdgas - 1.
5232  rgrav = 1./grav
5233 !$OMP parallel do default(none) shared(is,ie,js,je,ps,ak_r)
5234  DO j=js,je
5235  DO i=is,ie
5236  ps(i, j) = ak_r(1)
5237  END DO
5238  END DO
5239 ! this OpenMP do-loop setup cannot work in it's current form....
5240 !$OMP parallel do default(none) shared(is,ie,js,je,km,ps,delp_r)
5241  DO j=js,je
5242  DO k=1,km
5243  DO i=is,ie
5244  ps(i, j) = ps(i, j) + delp_r(i, j, k)
5245  END DO
5246  END DO
5247  END DO
5248 ! only one cell is needed
5249  IF (square_domain) THEN
5250  CALL mpp_update_domains(ps, domain, complete=.true., whalo=1, &
5251 & ehalo=1, shalo=1, nhalo=1)
5252  ELSE
5253  CALL mpp_update_domains(ps, domain, complete=.true.)
5254  END IF
5255 ! Compute virtual Temp
5256 !$OMP parallel do default(none) shared(is,ie,js,je,km,pt_r,r_vir,q_r)
5257  DO k=1,km
5258  DO j=js,je
5259  DO i=is,ie
5260  pt_r(i, j, k) = pt_r(i, j, k)*(1.+r_vir*q_r(i, j, k, 1))
5261  END DO
5262  END DO
5263  END DO
5264 !$OMP parallel do default(none) shared(is,ie,js,je,km,ak_r,bk_r,ps,kn,ak,bk,u_r,u,delp, &
5265 !$OMP ntp,nq,hydrostatic,make_nh,w_r,w,delz_r,delp_r,delz, &
5266 !$OMP pt_r,pt,v_r,v,q,q_r,qdiag,qdiag_r) &
5267 !$OMP private(pe1, pe2, pv1, pv2)
5268  DO j=js,je+1
5269 !------
5270 ! map u
5271 !------
5272  DO k=1,km+1
5273  DO i=is,ie
5274  pe1(i, k) = ak_r(k) + 0.5*bk_r(k)*(ps(i, j-1)+ps(i, j))
5275  END DO
5276  END DO
5277  DO k=1,kn+1
5278  DO i=is,ie
5279  pe2(i, k) = ak(k) + 0.5*bk(k)*(ps(i, j-1)+ps(i, j))
5280  END DO
5281  END DO
5282  CALL remap_2d(km, pe1, u_r(is:ie, j:j, 1:km), kn, pe2, u(is:ie, j:&
5283 & j, 1:kn), is, ie, -1, kord)
5284 !(j < je+1)
5285  IF (j .NE. je + 1) THEN
5286 !---------------
5287 ! Hybrid sigma-p
5288 !---------------
5289  DO k=1,km+1
5290  DO i=is,ie
5291  pe1(i, k) = ak_r(k) + bk_r(k)*ps(i, j)
5292  END DO
5293  END DO
5294  DO k=1,kn+1
5295  DO i=is,ie
5296  pe2(i, k) = ak(k) + bk(k)*ps(i, j)
5297  END DO
5298  END DO
5299 !-------------
5300 ! Compute delp
5301 !-------------
5302  DO k=1,kn
5303  DO i=is,ie
5304  delp(i, j, k) = pe2(i, k+1) - pe2(i, k)
5305  END DO
5306  END DO
5307 !----------------
5308 ! Map constituents
5309 !----------------
5310  IF (nq .NE. 0) THEN
5311  DO iq=1,ntp
5312  CALL remap_2d(km, pe1, q_r(is:ie, j:j, 1:km, iq:iq), kn, pe2&
5313 & , q(is:ie, j:j, 1:kn, iq:iq), is, ie, 0, kord)
5314  END DO
5315  DO iq=ntp+1,nq
5316  CALL remap_2d(km, pe1, qdiag_r(is:ie, j:j, 1:km, iq:iq), kn&
5317 & , pe2, qdiag(is:ie, j:j, 1:kn, iq:iq), is, ie, 0, &
5318 & kord)
5319  END DO
5320  END IF
5321  IF (.NOT.hydrostatic .AND. (.NOT.make_nh)) THEN
5322 ! Remap vertical wind:
5323  CALL remap_2d(km, pe1, w_r(is:ie, j:j, 1:km), kn, pe2, w(is:ie&
5324 & , j:j, 1:kn), is, ie, -1, kord)
5325 ! Remap delz for hybrid sigma-p coordinate
5326  DO k=1,km
5327  DO i=is,ie
5328 ! ="specific volume"/grav
5329  delz_r(i, j, k) = -(delz_r(i, j, k)/delp_r(i, j, k))
5330  END DO
5331  END DO
5332  CALL remap_2d(km, pe1, delz_r(is:ie, j:j, 1:km), kn, pe2, delz&
5333 & (is:ie, j:j, 1:kn), is, ie, 1, kord)
5334  DO k=1,kn
5335  DO i=is,ie
5336  delz(i, j, k) = -(delz(i, j, k)*delp(i, j, k))
5337  END DO
5338  END DO
5339  END IF
5340 ! Geopotential conserving remap of virtual temperature:
5341  DO k=1,km+1
5342  DO i=is,ie
5343  pe1(i, k) = log(pe1(i, k))
5344  END DO
5345  END DO
5346  DO k=1,kn+1
5347  DO i=is,ie
5348  pe2(i, k) = log(pe2(i, k))
5349  END DO
5350  END DO
5351  CALL remap_2d(km, pe1, pt_r(is:ie, j:j, 1:km), kn, pe2, pt(is:ie&
5352 & , j:j, 1:kn), is, ie, 1, kord)
5353 !------
5354 ! map v
5355 !------
5356  DO k=1,km+1
5357  DO i=is,ie+1
5358  pv1(i, k) = ak_r(k) + 0.5*bk_r(k)*(ps(i-1, j)+ps(i, j))
5359  END DO
5360  END DO
5361  DO k=1,kn+1
5362  DO i=is,ie+1
5363  pv2(i, k) = ak(k) + 0.5*bk(k)*(ps(i-1, j)+ps(i, j))
5364  END DO
5365  END DO
5366  CALL remap_2d(km, pv1, v_r(is:ie+1, j:j, 1:km), kn, pv2, v(is:ie&
5367 & +1, j:j, 1:kn), is, ie + 1, -1, kord)
5368  END IF
5369  END DO
5370 !$OMP parallel do default(none) shared(is,ie,js,je,kn,pt,r_vir,q)
5371  DO k=1,kn
5372  DO j=js,je
5373  DO i=is,ie
5374  pt(i, j, k) = pt(i, j, k)/(1.+r_vir*q(i, j, k, 1))
5375  END DO
5376  END DO
5377  END DO
5378  END SUBROUTINE rst_remap
5379  SUBROUTINE remap_2d(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
5380  IMPLICIT NONE
5381  INTEGER, INTENT(IN) :: i1, i2
5382 ! Mode: 0 == constituents 1 ==others
5383  INTEGER, INTENT(IN) :: iv
5384  INTEGER, INTENT(IN) :: kord
5385 ! Original vertical dimension
5386  INTEGER, INTENT(IN) :: km
5387 ! Target vertical dimension
5388  INTEGER, INTENT(IN) :: kn
5389 ! pressure at layer edges
5390  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
5391 ! (from model top to bottom surface)
5392 ! in the original vertical coordinate
5393 ! pressure at layer edges
5394  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
5395 ! (from model top to bottom surface)
5396 ! in the new vertical coordinate
5397 ! Field input
5398  REAL, INTENT(IN) :: q1(i1:i2, km)
5399 ! Field output
5400  REAL, INTENT(OUT) :: q2(i1:i2, kn)
5401 ! !LOCAL VARIABLES:
5402  REAL :: qs(i1:i2)
5403  REAL :: dp1(i1:i2, km)
5404  REAL :: q4(4, i1:i2, km)
5405  REAL :: pl, pr, qsum, dp, esl
5406  INTEGER :: i, k, l, m, k0
5407  DO k=1,km
5408  DO i=i1,i2
5409  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5410  q4(1, i, k) = q1(i, k)
5411  END DO
5412  END DO
5413 ! Compute vertical subgrid distribution
5414  IF (kord .GT. 7) THEN
5415  CALL cs_profile(qs, q4, dp1, km, i1, i2, iv, kord)
5416  ELSE
5417  CALL ppm_profile(q4, dp1, km, i1, i2, iv, kord)
5418  END IF
5419  DO i=i1,i2
5420  k0 = 1
5421  DO k=1,kn
5422  IF (pe2(i, k) .LE. pe1(i, 1)) THEN
5423 ! above old ptop:
5424  q2(i, k) = q1(i, 1)
5425  ELSE
5426  DO l=k0,km
5427 ! locate the top edge: pe2(i,k)
5428  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1&
5429 & )) THEN
5430  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5431  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5432 ! entire new grid is within the original grid
5433  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5434  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4&
5435 & (2, i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
5436  k0 = l
5437  GOTO 555
5438  ELSE
5439 ! Fractional area...
5440  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i&
5441 & , l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*&
5442 & (1.+pl*(1.+pl))))
5443  DO m=l+1,km
5444 ! locate the bottom edge: pe2(i,k+1)
5445  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
5446 ! Whole layer..
5447  qsum = qsum + dp1(i, m)*q4(1, i, m)
5448  ELSE
5449  dp = pe2(i, k+1) - pe1(i, m)
5450  esl = dp/dp1(i, m)
5451  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-&
5452 & q4(2, i, m)+q4(4, i, m)*(1.-r23*esl)))
5453  k0 = m
5454  GOTO 123
5455  END IF
5456  END DO
5457  GOTO 123
5458  END IF
5459  END IF
5460  END DO
5461  123 q2(i, k) = qsum/(pe2(i, k+1)-pe2(i, k))
5462  END IF
5463  555 CONTINUE
5464  END DO
5465  END DO
5466  END SUBROUTINE remap_2d
5467  SUBROUTINE mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
5468  IMPLICIT NONE
5469 ! IV = 0: constituents
5470 ! IV = 1: potential temp
5471 ! IV =-1: winds
5472 ! Mass flux preserving mapping: q1(im,km) -> q2(im,kn)
5473 ! pe1: pressure at layer edges (from model top to bottom surface)
5474 ! in the original vertical coordinate
5475 ! pe2: pressure at layer edges (from model top to bottom surface)
5476 ! in the new vertical coordinate
5477  INTEGER, INTENT(IN) :: i1, i2, km, kn, kord, iv
5478  REAL, INTENT(IN) :: pe1(i1:i2, km+1), pe2(i1:i2, kn+1)
5479  REAL, INTENT(IN) :: q1(i1:i2, km)
5480  REAL, INTENT(OUT) :: q2(i1:i2, kn)
5481  REAL, INTENT(IN) :: ptop
5482 ! local
5483  REAL :: qs(i1:i2)
5484  REAL :: dp1(i1:i2, km)
5485  REAL :: a4(4, i1:i2, km)
5486  INTEGER :: i, k, l
5487  INTEGER :: k0, k1
5488  REAL :: pl, pr, tt, delp, qsum, dpsum, esl
5489  DO k=1,km
5490  DO i=i1,i2
5491  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
5492  a4(1, i, k) = q1(i, k)
5493  END DO
5494  END DO
5495  IF (kord .GT. 7) THEN
5496  CALL cs_profile(qs, a4, dp1, km, i1, i2, iv, kord)
5497  ELSE
5498  CALL ppm_profile(a4, dp1, km, i1, i2, iv, kord)
5499  END IF
5500 !------------------------------------
5501 ! Lowest layer: constant distribution
5502 !------------------------------------
5503  DO i=i1,i2
5504  k0 = 1
5505  DO k=1,kn
5506  IF (pe2(i, k) .LE. pe1(i, 1)) THEN
5507 ! above old ptop
5508  q2(i, k) = q1(i, 1)
5509  ELSE IF (pe2(i, k) .GE. pe1(i, km+1)) THEN
5510 ! Entire grid below old ps
5511  q2(i, k) = q1(i, km)
5512  ELSE
5513  DO l=k0,km
5514 ! locate the top edge at pe2(i,k)
5515  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1&
5516 & )) THEN
5517  k0 = l
5518  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
5519  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
5520 ! entire new grid is within the original grid
5521  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
5522  tt = r3*(pr*(pr+pl)+pl**2)
5523  q2(i, k) = a4(2, i, l) + 0.5*(a4(4, i, l)+a4(3, i, l)-a4&
5524 & (2, i, l))*(pr+pl) - a4(4, i, l)*tt
5525  GOTO 555
5526  ELSE
5527 ! Fractional area...
5528  delp = pe1(i, l+1) - pe2(i, k)
5529  tt = r3*(1.+pl*(1.+pl))
5530  qsum = delp*(a4(2, i, l)+0.5*(a4(4, i, l)+a4(3, i, l)-a4&
5531 & (2, i, l))*(1.+pl)-a4(4, i, l)*tt)
5532  dpsum = delp
5533  k1 = l + 1
5534  GOTO 111
5535  END IF
5536  END IF
5537  END DO
5538  111 CONTINUE
5539  DO l=k1,km
5540  IF (pe2(i, k+1) .GT. pe1(i, l+1)) THEN
5541 ! Whole layer..
5542  qsum = qsum + dp1(i, l)*q1(i, l)
5543  dpsum = dpsum + dp1(i, l)
5544  ELSE
5545  delp = pe2(i, k+1) - pe1(i, l)
5546  esl = delp/dp1(i, l)
5547  qsum = qsum + delp*(a4(2, i, l)+0.5*esl*(a4(3, i, l)-a4(2&
5548 & , i, l)+a4(4, i, l)*(1.-r23*esl)))
5549  dpsum = dpsum + delp
5550  k0 = l
5551  GOTO 123
5552  END IF
5553  END DO
5554  delp = pe2(i, k+1) - pe1(i, km+1)
5555  IF (delp .GT. 0.) THEN
5556 ! Extended below old ps
5557  qsum = qsum + delp*q1(i, km)
5558  dpsum = dpsum + delp
5559  END IF
5560  123 q2(i, k) = qsum/dpsum
5561  END IF
5562  555 CONTINUE
5563  END DO
5564  END DO
5565  END SUBROUTINE mappm
5566  SUBROUTINE cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
5567  IMPLICIT NONE
5568 ! Optimized vertical profile reconstruction:
5569 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
5570  INTEGER, INTENT(IN) :: i1, i2
5571 ! vertical dimension
5572  INTEGER, INTENT(IN) :: km
5573 ! iv =-1: winds
5574  INTEGER, INTENT(IN) :: iv
5575 ! iv = 0: positive definite scalars
5576 ! iv = 1: others
5577  INTEGER, INTENT(IN) :: kord
5578  REAL, INTENT(IN) :: qs(i1:i2)
5579 ! layer pressure thickness
5580  REAL, INTENT(IN) :: delp(i1:i2, km)
5581 ! Interpolated values
5582  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
5583 !-----------------------------------------------------------------------
5584  LOGICAL :: extm(i1:i2, km)
5585  REAL :: gam(i1:i2, km)
5586  REAL :: q(i1:i2, km+1)
5587  REAL :: d4(i1:i2)
5588  REAL :: bet, a_bot, grat
5589  REAL :: pmp_1, lac_1, pmp_2, lac_2
5590  INTEGER :: i, k, im
5591  INTRINSIC abs
5592  INTRINSIC max
5593  INTRINSIC min
5594  INTEGER :: abs0
5595  INTEGER :: abs1
5596  INTEGER :: abs2
5597  REAL :: abs3
5598  INTEGER :: abs4
5599  REAL :: abs5
5600  INTEGER :: abs6
5601  REAL :: abs7
5602  INTEGER :: abs8
5603  INTEGER :: abs9
5604  REAL :: abs10
5605  REAL :: abs11
5606  REAL :: abs12
5607  REAL :: x10
5608  REAL :: y28
5609  REAL :: y27
5610  REAL :: y26
5611  REAL :: y25
5612  REAL :: y24
5613  REAL :: y23
5614  REAL :: y22
5615  REAL :: y21
5616  REAL :: y20
5617  REAL :: x9
5618  REAL :: x8
5619  REAL :: x7
5620  REAL :: x6
5621  REAL :: x5
5622  REAL :: x4
5623  REAL :: x3
5624  REAL :: x2
5625  REAL :: x1
5626  REAL :: y19
5627  REAL :: y18
5628  REAL :: y17
5629  REAL :: y16
5630  REAL :: y15
5631  REAL :: y14
5632  REAL :: y13
5633  REAL :: y12
5634  REAL :: y11
5635  REAL :: y10
5636  REAL :: y9
5637  REAL :: y8
5638  REAL :: y7
5639  REAL :: y6
5640  REAL :: y5
5641  REAL :: y4
5642  REAL :: y3
5643  REAL :: y2
5644  REAL :: y1
5645  IF (iv .EQ. -2) THEN
5646  DO i=i1,i2
5647  gam(i, 2) = 0.5
5648  q(i, 1) = 1.5*a4(1, i, 1)
5649  END DO
5650  DO k=2,km-1
5651  DO i=i1,i2
5652  grat = delp(i, k-1)/delp(i, k)
5653  bet = 2. + grat + grat - gam(i, k)
5654  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
5655  gam(i, k+1) = grat/bet
5656  END DO
5657  END DO
5658  DO i=i1,i2
5659  grat = delp(i, km-1)/delp(i, km)
5660  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
5661 & 1))/(2.+grat+grat-gam(i, km))
5662  q(i, km+1) = qs(i)
5663  END DO
5664  DO k=km-1,1,-1
5665  DO i=i1,i2
5666  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
5667  END DO
5668  END DO
5669  ELSE
5670  DO i=i1,i2
5671 ! grid ratio
5672  grat = delp(i, 2)/delp(i, 1)
5673  bet = grat*(grat+0.5)
5674  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
5675  gam(i, 1) = (1.+grat*(grat+1.5))/bet
5676  END DO
5677  DO k=2,km
5678  DO i=i1,i2
5679  d4(i) = delp(i, k-1)/delp(i, k)
5680  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
5681  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
5682  gam(i, k) = d4(i)/bet
5683  END DO
5684  END DO
5685  DO i=i1,i2
5686  a_bot = 1. + d4(i)*(d4(i)+1.5)
5687  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
5688 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
5689  END DO
5690  DO k=km,1,-1
5691  DO i=i1,i2
5692  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
5693  END DO
5694  END DO
5695  END IF
5696  IF (kord .GE. 0.) THEN
5697  abs0 = kord
5698  ELSE
5699  abs0 = -kord
5700  END IF
5701 !----- Perfectly linear scheme --------------------------------
5702  IF (abs0 .GT. 16) THEN
5703  DO k=1,km
5704  DO i=i1,i2
5705  a4(2, i, k) = q(i, k)
5706  a4(3, i, k) = q(i, k+1)
5707  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
5708  END DO
5709  END DO
5710  RETURN
5711  ELSE
5712 !----- Perfectly linear scheme --------------------------------
5713 !------------------
5714 ! Apply constraints
5715 !------------------
5716  im = i2 - i1 + 1
5717 ! Apply *large-scale* constraints
5718  DO i=i1,i2
5719  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
5720  y1 = a4(1, i, 2)
5721  ELSE
5722  y1 = a4(1, i, 1)
5723  END IF
5724  IF (q(i, 2) .GT. y1) THEN
5725  q(i, 2) = y1
5726  ELSE
5727  q(i, 2) = q(i, 2)
5728  END IF
5729  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
5730  y2 = a4(1, i, 2)
5731  ELSE
5732  y2 = a4(1, i, 1)
5733  END IF
5734  IF (q(i, 2) .LT. y2) THEN
5735  q(i, 2) = y2
5736  ELSE
5737  q(i, 2) = q(i, 2)
5738  END IF
5739  END DO
5740  DO k=2,km
5741  DO i=i1,i2
5742  gam(i, k) = a4(1, i, k) - a4(1, i, k-1)
5743  END DO
5744  END DO
5745 ! Interior:
5746  DO k=3,km-1
5747  DO i=i1,i2
5748  IF (gam(i, k-1)*gam(i, k+1) .GT. 0.) THEN
5749  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
5750  y3 = a4(1, i, k)
5751  ELSE
5752  y3 = a4(1, i, k-1)
5753  END IF
5754  IF (q(i, k) .GT. y3) THEN
5755  q(i, k) = y3
5756  ELSE
5757  q(i, k) = q(i, k)
5758  END IF
5759  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
5760  y4 = a4(1, i, k)
5761  ELSE
5762  y4 = a4(1, i, k-1)
5763  END IF
5764  IF (q(i, k) .LT. y4) THEN
5765  q(i, k) = y4
5766  ELSE
5767  q(i, k) = q(i, k)
5768  END IF
5769  ELSE IF (gam(i, k-1) .GT. 0.) THEN
5770  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
5771  y5 = a4(1, i, k)
5772  ELSE
5773  y5 = a4(1, i, k-1)
5774  END IF
5775  IF (q(i, k) .LT. y5) THEN
5776  q(i, k) = y5
5777  ELSE
5778  q(i, k) = q(i, k)
5779  END IF
5780  ELSE
5781  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
5782  y6 = a4(1, i, k)
5783  ELSE
5784  y6 = a4(1, i, k-1)
5785  END IF
5786  IF (q(i, k) .GT. y6) THEN
5787  q(i, k) = y6
5788  ELSE
5789  q(i, k) = q(i, k)
5790  END IF
5791  IF (iv .EQ. 0) THEN
5792  IF (0. .LT. q(i, k)) THEN
5793  q(i, k) = q(i, k)
5794  ELSE
5795  q(i, k) = 0.
5796  END IF
5797  END IF
5798  END IF
5799  END DO
5800  END DO
5801 ! Bottom:
5802  DO i=i1,i2
5803  IF (a4(1, i, km-1) .LT. a4(1, i, km)) THEN
5804  y7 = a4(1, i, km)
5805  ELSE
5806  y7 = a4(1, i, km-1)
5807  END IF
5808  IF (q(i, km) .GT. y7) THEN
5809  q(i, km) = y7
5810  ELSE
5811  q(i, km) = q(i, km)
5812  END IF
5813  IF (a4(1, i, km-1) .GT. a4(1, i, km)) THEN
5814  y8 = a4(1, i, km)
5815  ELSE
5816  y8 = a4(1, i, km-1)
5817  END IF
5818  IF (q(i, km) .LT. y8) THEN
5819  q(i, km) = y8
5820  ELSE
5821  q(i, km) = q(i, km)
5822  END IF
5823  END DO
5824  DO k=1,km
5825  DO i=i1,i2
5826  a4(2, i, k) = q(i, k)
5827  a4(3, i, k) = q(i, k+1)
5828  END DO
5829  END DO
5830  DO k=1,km
5831  IF (k .EQ. 1 .OR. k .EQ. km) THEN
5832  DO i=i1,i2
5833  extm(i, k) = (a4(2, i, k)-a4(1, i, k))*(a4(3, i, k)-a4(1, i&
5834 & , k)) .GT. 0.
5835  END DO
5836  ELSE
5837  DO i=i1,i2
5838  extm(i, k) = gam(i, k)*gam(i, k+1) .LT. 0.
5839  END DO
5840  END IF
5841  END DO
5842 !---------------------------
5843 ! Apply subgrid constraints:
5844 !---------------------------
5845 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
5846 ! Top 2 and bottom 2 layers always use monotonic mapping
5847  IF (iv .EQ. 0) THEN
5848  DO i=i1,i2
5849  IF (0. .LT. a4(2, i, 1)) THEN
5850  a4(2, i, 1) = a4(2, i, 1)
5851  ELSE
5852  a4(2, i, 1) = 0.
5853  END IF
5854  END DO
5855  ELSE IF (iv .EQ. -1) THEN
5856  DO i=i1,i2
5857  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
5858  END DO
5859  ELSE IF (iv .EQ. 2) THEN
5860  DO i=i1,i2
5861  a4(2, i, 1) = a4(1, i, 1)
5862  a4(3, i, 1) = a4(1, i, 1)
5863  a4(4, i, 1) = 0.
5864  END DO
5865  END IF
5866  IF (iv .NE. 2) THEN
5867  DO i=i1,i2
5868  a4(4, i, 1) = 3.*(2.*a4(1, i, 1)-(a4(2, i, 1)+a4(3, i, 1)))
5869  END DO
5870  CALL cs_limiters(im, extm(i1, 1), a4(1, i1, 1), 1)
5871  END IF
5872 ! k=2
5873  DO i=i1,i2
5874  a4(4, i, 2) = 3.*(2.*a4(1, i, 2)-(a4(2, i, 2)+a4(3, i, 2)))
5875  END DO
5876  CALL cs_limiters(im, extm(i1, 2), a4(1, i1, 2), 2)
5877 !-------------------------------------
5878 ! Huynh's 2nd constraint for interior:
5879 !-------------------------------------
5880  DO k=3,km-2
5881  IF (kord .GE. 0.) THEN
5882  abs1 = kord
5883  ELSE
5884  abs1 = -kord
5885  END IF
5886  IF (abs1 .LT. 9) THEN
5887  DO i=i1,i2
5888 ! Left edges
5889  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
5890  lac_1 = pmp_1 + 1.5*gam(i, k+2)
5891  IF (a4(1, i, k) .GT. pmp_1) THEN
5892  IF (pmp_1 .GT. lac_1) THEN
5893  y19 = lac_1
5894  ELSE
5895  y19 = pmp_1
5896  END IF
5897  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
5898  y19 = lac_1
5899  ELSE
5900  y19 = a4(1, i, k)
5901  END IF
5902  IF (a4(2, i, k) .LT. y19) THEN
5903  x1 = y19
5904  ELSE
5905  x1 = a4(2, i, k)
5906  END IF
5907  IF (a4(1, i, k) .LT. pmp_1) THEN
5908  IF (pmp_1 .LT. lac_1) THEN
5909  y9 = lac_1
5910  ELSE
5911  y9 = pmp_1
5912  END IF
5913  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
5914  y9 = lac_1
5915  ELSE
5916  y9 = a4(1, i, k)
5917  END IF
5918  IF (x1 .GT. y9) THEN
5919  a4(2, i, k) = y9
5920  ELSE
5921  a4(2, i, k) = x1
5922  END IF
5923 ! Right edges
5924  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
5925  lac_2 = pmp_2 - 1.5*gam(i, k-1)
5926  IF (a4(1, i, k) .GT. pmp_2) THEN
5927  IF (pmp_2 .GT. lac_2) THEN
5928  y20 = lac_2
5929  ELSE
5930  y20 = pmp_2
5931  END IF
5932  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
5933  y20 = lac_2
5934  ELSE
5935  y20 = a4(1, i, k)
5936  END IF
5937  IF (a4(3, i, k) .LT. y20) THEN
5938  x2 = y20
5939  ELSE
5940  x2 = a4(3, i, k)
5941  END IF
5942  IF (a4(1, i, k) .LT. pmp_2) THEN
5943  IF (pmp_2 .LT. lac_2) THEN
5944  y10 = lac_2
5945  ELSE
5946  y10 = pmp_2
5947  END IF
5948  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
5949  y10 = lac_2
5950  ELSE
5951  y10 = a4(1, i, k)
5952  END IF
5953  IF (x2 .GT. y10) THEN
5954  a4(3, i, k) = y10
5955  ELSE
5956  a4(3, i, k) = x2
5957  END IF
5958  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
5959  END DO
5960  ELSE
5961  IF (kord .GE. 0.) THEN
5962  abs2 = kord
5963  ELSE
5964  abs2 = -kord
5965  END IF
5966  IF (abs2 .EQ. 9) THEN
5967  DO i=i1,i2
5968  IF (extm(i, k) .AND. extm(i, k-1)) THEN
5969 ! c90_mp122
5970 ! grid-scale 2-delta-z wave detected
5971  a4(2, i, k) = a4(1, i, k)
5972  a4(3, i, k) = a4(1, i, k)
5973  a4(4, i, k) = 0.
5974  ELSE IF (extm(i, k) .AND. extm(i, k+1)) THEN
5975 ! c90_mp122
5976 ! grid-scale 2-delta-z wave detected
5977  a4(2, i, k) = a4(1, i, k)
5978  a4(3, i, k) = a4(1, i, k)
5979  a4(4, i, k) = 0.
5980  ELSE
5981  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i, &
5982 & k))
5983  IF (a4(4, i, k) .GE. 0.) THEN
5984  abs3 = a4(4, i, k)
5985  ELSE
5986  abs3 = -a4(4, i, k)
5987  END IF
5988  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
5989  abs10 = a4(2, i, k) - a4(3, i, k)
5990  ELSE
5991  abs10 = -(a4(2, i, k)-a4(3, i, k))
5992  END IF
5993 ! Check within the smooth region if subgrid profile is non-monotonic
5994  IF (abs3 .GT. abs10) THEN
5995  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
5996  lac_1 = pmp_1 + 1.5*gam(i, k+2)
5997  IF (a4(1, i, k) .GT. pmp_1) THEN
5998  IF (pmp_1 .GT. lac_1) THEN
5999  y21 = lac_1
6000  ELSE
6001  y21 = pmp_1
6002  END IF
6003  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
6004  y21 = lac_1
6005  ELSE
6006  y21 = a4(1, i, k)
6007  END IF
6008  IF (a4(2, i, k) .LT. y21) THEN
6009  x3 = y21
6010  ELSE
6011  x3 = a4(2, i, k)
6012  END IF
6013  IF (a4(1, i, k) .LT. pmp_1) THEN
6014  IF (pmp_1 .LT. lac_1) THEN
6015  y11 = lac_1
6016  ELSE
6017  y11 = pmp_1
6018  END IF
6019  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
6020  y11 = lac_1
6021  ELSE
6022  y11 = a4(1, i, k)
6023  END IF
6024  IF (x3 .GT. y11) THEN
6025  a4(2, i, k) = y11
6026  ELSE
6027  a4(2, i, k) = x3
6028  END IF
6029  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
6030  lac_2 = pmp_2 - 1.5*gam(i, k-1)
6031  IF (a4(1, i, k) .GT. pmp_2) THEN
6032  IF (pmp_2 .GT. lac_2) THEN
6033  y22 = lac_2
6034  ELSE
6035  y22 = pmp_2
6036  END IF
6037  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
6038  y22 = lac_2
6039  ELSE
6040  y22 = a4(1, i, k)
6041  END IF
6042  IF (a4(3, i, k) .LT. y22) THEN
6043  x4 = y22
6044  ELSE
6045  x4 = a4(3, i, k)
6046  END IF
6047  IF (a4(1, i, k) .LT. pmp_2) THEN
6048  IF (pmp_2 .LT. lac_2) THEN
6049  y12 = lac_2
6050  ELSE
6051  y12 = pmp_2
6052  END IF
6053  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
6054  y12 = lac_2
6055  ELSE
6056  y12 = a4(1, i, k)
6057  END IF
6058  IF (x4 .GT. y12) THEN
6059  a4(3, i, k) = y12
6060  ELSE
6061  a4(3, i, k) = x4
6062  END IF
6063  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
6064 & , k))
6065  END IF
6066  END IF
6067  END DO
6068  ELSE
6069  IF (kord .GE. 0.) THEN
6070  abs4 = kord
6071  ELSE
6072  abs4 = -kord
6073  END IF
6074  IF (abs4 .EQ. 10) THEN
6075  DO i=i1,i2
6076  IF (extm(i, k)) THEN
6077  IF (extm(i, k-1) .OR. extm(i, k+1)) THEN
6078 ! grid-scale 2-delta-z wave detected
6079  a4(2, i, k) = a4(1, i, k)
6080  a4(3, i, k) = a4(1, i, k)
6081  a4(4, i, k) = 0.
6082  ELSE
6083 ! True local extremum
6084  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
6085 & , i, k))
6086  END IF
6087  ELSE
6088 ! not a local extremum
6089  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3, i&
6090 & , k))
6091  IF (a4(4, i, k) .GE. 0.) THEN
6092  abs5 = a4(4, i, k)
6093  ELSE
6094  abs5 = -a4(4, i, k)
6095  END IF
6096  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
6097  abs11 = a4(2, i, k) - a4(3, i, k)
6098  ELSE
6099  abs11 = -(a4(2, i, k)-a4(3, i, k))
6100  END IF
6101 ! Check within the smooth region if subgrid profile is non-monotonic
6102  IF (abs5 .GT. abs11) THEN
6103  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
6104  lac_1 = pmp_1 + 1.5*gam(i, k+2)
6105  IF (a4(1, i, k) .GT. pmp_1) THEN
6106  IF (pmp_1 .GT. lac_1) THEN
6107  y23 = lac_1
6108  ELSE
6109  y23 = pmp_1
6110  END IF
6111  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
6112  y23 = lac_1
6113  ELSE
6114  y23 = a4(1, i, k)
6115  END IF
6116  IF (a4(2, i, k) .LT. y23) THEN
6117  x5 = y23
6118  ELSE
6119  x5 = a4(2, i, k)
6120  END IF
6121  IF (a4(1, i, k) .LT. pmp_1) THEN
6122  IF (pmp_1 .LT. lac_1) THEN
6123  y13 = lac_1
6124  ELSE
6125  y13 = pmp_1
6126  END IF
6127  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
6128  y13 = lac_1
6129  ELSE
6130  y13 = a4(1, i, k)
6131  END IF
6132  IF (x5 .GT. y13) THEN
6133  a4(2, i, k) = y13
6134  ELSE
6135  a4(2, i, k) = x5
6136  END IF
6137  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
6138  lac_2 = pmp_2 - 1.5*gam(i, k-1)
6139  IF (a4(1, i, k) .GT. pmp_2) THEN
6140  IF (pmp_2 .GT. lac_2) THEN
6141  y24 = lac_2
6142  ELSE
6143  y24 = pmp_2
6144  END IF
6145  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
6146  y24 = lac_2
6147  ELSE
6148  y24 = a4(1, i, k)
6149  END IF
6150  IF (a4(3, i, k) .LT. y24) THEN
6151  x6 = y24
6152  ELSE
6153  x6 = a4(3, i, k)
6154  END IF
6155  IF (a4(1, i, k) .LT. pmp_2) THEN
6156  IF (pmp_2 .LT. lac_2) THEN
6157  y14 = lac_2
6158  ELSE
6159  y14 = pmp_2
6160  END IF
6161  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
6162  y14 = lac_2
6163  ELSE
6164  y14 = a4(1, i, k)
6165  END IF
6166  IF (x6 .GT. y14) THEN
6167  a4(3, i, k) = y14
6168  ELSE
6169  a4(3, i, k) = x6
6170  END IF
6171  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
6172 & , i, k))
6173  END IF
6174  END IF
6175  END DO
6176  ELSE
6177  IF (kord .GE. 0.) THEN
6178  abs6 = kord
6179  ELSE
6180  abs6 = -kord
6181  END IF
6182  IF (abs6 .EQ. 12) THEN
6183  DO i=i1,i2
6184  IF (extm(i, k)) THEN
6185 ! grid-scale 2-delta-z wave detected
6186  a4(2, i, k) = a4(1, i, k)
6187  a4(3, i, k) = a4(1, i, k)
6188  a4(4, i, k) = 0.
6189  ELSE
6190 ! not a local extremum
6191  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(3&
6192 & , i, k))
6193  IF (a4(4, i, k) .GE. 0.) THEN
6194  abs7 = a4(4, i, k)
6195  ELSE
6196  abs7 = -a4(4, i, k)
6197  END IF
6198  IF (a4(2, i, k) - a4(3, i, k) .GE. 0.) THEN
6199  abs12 = a4(2, i, k) - a4(3, i, k)
6200  ELSE
6201  abs12 = -(a4(2, i, k)-a4(3, i, k))
6202  END IF
6203 ! Check within the smooth region if subgrid profile is non-monotonic
6204  IF (abs7 .GT. abs12) THEN
6205  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
6206  lac_1 = pmp_1 + 1.5*gam(i, k+2)
6207  IF (a4(1, i, k) .GT. pmp_1) THEN
6208  IF (pmp_1 .GT. lac_1) THEN
6209  y25 = lac_1
6210  ELSE
6211  y25 = pmp_1
6212  END IF
6213  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
6214  y25 = lac_1
6215  ELSE
6216  y25 = a4(1, i, k)
6217  END IF
6218  IF (a4(2, i, k) .LT. y25) THEN
6219  x7 = y25
6220  ELSE
6221  x7 = a4(2, i, k)
6222  END IF
6223  IF (a4(1, i, k) .LT. pmp_1) THEN
6224  IF (pmp_1 .LT. lac_1) THEN
6225  y15 = lac_1
6226  ELSE
6227  y15 = pmp_1
6228  END IF
6229  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
6230  y15 = lac_1
6231  ELSE
6232  y15 = a4(1, i, k)
6233  END IF
6234  IF (x7 .GT. y15) THEN
6235  a4(2, i, k) = y15
6236  ELSE
6237  a4(2, i, k) = x7
6238  END IF
6239  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
6240  lac_2 = pmp_2 - 1.5*gam(i, k-1)
6241  IF (a4(1, i, k) .GT. pmp_2) THEN
6242  IF (pmp_2 .GT. lac_2) THEN
6243  y26 = lac_2
6244  ELSE
6245  y26 = pmp_2
6246  END IF
6247  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
6248  y26 = lac_2
6249  ELSE
6250  y26 = a4(1, i, k)
6251  END IF
6252  IF (a4(3, i, k) .LT. y26) THEN
6253  x8 = y26
6254  ELSE
6255  x8 = a4(3, i, k)
6256  END IF
6257  IF (a4(1, i, k) .LT. pmp_2) THEN
6258  IF (pmp_2 .LT. lac_2) THEN
6259  y16 = lac_2
6260  ELSE
6261  y16 = pmp_2
6262  END IF
6263  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
6264  y16 = lac_2
6265  ELSE
6266  y16 = a4(1, i, k)
6267  END IF
6268  IF (x8 .GT. y16) THEN
6269  a4(3, i, k) = y16
6270  ELSE
6271  a4(3, i, k) = x8
6272  END IF
6273  a4(4, i, k) = 6.*a4(1, i, k) - 3.*(a4(2, i, k)+a4(&
6274 & 3, i, k))
6275  END IF
6276  END IF
6277  END DO
6278  ELSE
6279  IF (kord .GE. 0.) THEN
6280  abs8 = kord
6281  ELSE
6282  abs8 = -kord
6283  END IF
6284  IF (abs8 .EQ. 13) THEN
6285  DO i=i1,i2
6286  IF (extm(i, k)) THEN
6287  IF (extm(i, k-1) .AND. extm(i, k+1)) THEN
6288 ! grid-scale 2-delta-z wave detected
6289  a4(2, i, k) = a4(1, i, k)
6290  a4(3, i, k) = a4(1, i, k)
6291  a4(4, i, k) = 0.
6292  ELSE
6293 ! Left edges
6294  pmp_1 = a4(1, i, k) - 2.*gam(i, k+1)
6295  lac_1 = pmp_1 + 1.5*gam(i, k+2)
6296  IF (a4(1, i, k) .GT. pmp_1) THEN
6297  IF (pmp_1 .GT. lac_1) THEN
6298  y27 = lac_1
6299  ELSE
6300  y27 = pmp_1
6301  END IF
6302  ELSE IF (a4(1, i, k) .GT. lac_1) THEN
6303  y27 = lac_1
6304  ELSE
6305  y27 = a4(1, i, k)
6306  END IF
6307  IF (a4(2, i, k) .LT. y27) THEN
6308  x9 = y27
6309  ELSE
6310  x9 = a4(2, i, k)
6311  END IF
6312  IF (a4(1, i, k) .LT. pmp_1) THEN
6313  IF (pmp_1 .LT. lac_1) THEN
6314  y17 = lac_1
6315  ELSE
6316  y17 = pmp_1
6317  END IF
6318  ELSE IF (a4(1, i, k) .LT. lac_1) THEN
6319  y17 = lac_1
6320  ELSE
6321  y17 = a4(1, i, k)
6322  END IF
6323  IF (x9 .GT. y17) THEN
6324  a4(2, i, k) = y17
6325  ELSE
6326  a4(2, i, k) = x9
6327  END IF
6328 ! Right edges
6329  pmp_2 = a4(1, i, k) + 2.*gam(i, k)
6330  lac_2 = pmp_2 - 1.5*gam(i, k-1)
6331  IF (a4(1, i, k) .GT. pmp_2) THEN
6332  IF (pmp_2 .GT. lac_2) THEN
6333  y28 = lac_2
6334  ELSE
6335  y28 = pmp_2
6336  END IF
6337  ELSE IF (a4(1, i, k) .GT. lac_2) THEN
6338  y28 = lac_2
6339  ELSE
6340  y28 = a4(1, i, k)
6341  END IF
6342  IF (a4(3, i, k) .LT. y28) THEN
6343  x10 = y28
6344  ELSE
6345  x10 = a4(3, i, k)
6346  END IF
6347  IF (a4(1, i, k) .LT. pmp_2) THEN
6348  IF (pmp_2 .LT. lac_2) THEN
6349  y18 = lac_2
6350  ELSE
6351  y18 = pmp_2
6352  END IF
6353  ELSE IF (a4(1, i, k) .LT. lac_2) THEN
6354  y18 = lac_2
6355  ELSE
6356  y18 = a4(1, i, k)
6357  END IF
6358  IF (x10 .GT. y18) THEN
6359  a4(3, i, k) = y18
6360  ELSE
6361  a4(3, i, k) = x10
6362  END IF
6363  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
6364 & (3, i, k)))
6365  END IF
6366  ELSE
6367  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
6368 & , i, k)))
6369  END IF
6370  END DO
6371  ELSE
6372  IF (kord .GE. 0.) THEN
6373  abs9 = kord
6374  ELSE
6375  abs9 = -kord
6376  END IF
6377  IF (abs9 .EQ. 14) THEN
6378  DO i=i1,i2
6379  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3&
6380 & , i, k)))
6381  END DO
6382  ELSE
6383 ! kord = 11
6384  DO i=i1,i2
6385  IF (extm(i, k) .AND. (extm(i, k-1) .OR. extm(i, k+&
6386 & 1))) THEN
6387 ! Noisy region:
6388  a4(2, i, k) = a4(1, i, k)
6389  a4(3, i, k) = a4(1, i, k)
6390  a4(4, i, k) = 0.
6391  ELSE
6392  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4&
6393 & (3, i, k)))
6394  END IF
6395  END DO
6396  END IF
6397  END IF
6398  END IF
6399  END IF
6400  END IF
6401  END IF
6402 ! Additional constraint to ensure positivity
6403  IF (iv .EQ. 0) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 0&
6404 & )
6405  END DO
6406 ! k-loop
6407 !----------------------------------
6408 ! Bottom layer subgrid constraints:
6409 !----------------------------------
6410  IF (iv .EQ. 0) THEN
6411  DO i=i1,i2
6412  IF (0. .LT. a4(3, i, km)) THEN
6413  a4(3, i, km) = a4(3, i, km)
6414  ELSE
6415  a4(3, i, km) = 0.
6416  END IF
6417  END DO
6418  ELSE IF (iv .EQ. -1) THEN
6419  DO i=i1,i2
6420  IF (a4(3, i, km)*a4(1, i, km) .LE. 0.) a4(3, i, km) = 0.
6421  END DO
6422  END IF
6423  DO k=km-1,km
6424  DO i=i1,i2
6425  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
6426  END DO
6427  IF (k .EQ. km - 1) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k&
6428 & ), 2)
6429  IF (k .EQ. km) CALL cs_limiters(im, extm(i1, k), a4(1, i1, k), 1&
6430 & )
6431  END DO
6432  END IF
6433  END SUBROUTINE cs_profile
6434  SUBROUTINE cs_limiters(im, extm, a4, iv)
6435  IMPLICIT NONE
6436  INTEGER, INTENT(IN) :: im
6437  INTEGER, INTENT(IN) :: iv
6438  LOGICAL, INTENT(IN) :: extm(im)
6439 ! PPM array
6440  REAL, INTENT(INOUT) :: a4(4, im)
6441 ! !LOCAL VARIABLES:
6442  REAL :: da1, da2, a6da
6443  INTEGER :: i
6444  INTRINSIC abs
6445  REAL :: abs0
6446  IF (iv .EQ. 0) THEN
6447 ! Positive definite constraint
6448  DO i=1,im
6449  IF (a4(1, i) .LE. 0.) THEN
6450  a4(2, i) = a4(1, i)
6451  a4(3, i) = a4(1, i)
6452  a4(4, i) = 0.
6453  ELSE
6454  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
6455  abs0 = a4(3, i) - a4(2, i)
6456  ELSE
6457  abs0 = -(a4(3, i)-a4(2, i))
6458  END IF
6459  IF (abs0 .LT. -a4(4, i)) THEN
6460  IF (a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4, &
6461 & i)*r12 .LT. 0.) THEN
6462 ! local minimum is negative
6463  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
6464 & THEN
6465  a4(3, i) = a4(1, i)
6466  a4(2, i) = a4(1, i)
6467  a4(4, i) = 0.
6468  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
6469  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
6470  a4(3, i) = a4(2, i) - a4(4, i)
6471  ELSE
6472  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
6473  a4(2, i) = a4(3, i) - a4(4, i)
6474  END IF
6475  END IF
6476  END IF
6477  END IF
6478  END DO
6479  ELSE IF (iv .EQ. 1) THEN
6480  DO i=1,im
6481  IF ((a4(1, i)-a4(2, i))*(a4(1, i)-a4(3, i)) .GE. 0.) THEN
6482  a4(2, i) = a4(1, i)
6483  a4(3, i) = a4(1, i)
6484  a4(4, i) = 0.
6485  ELSE
6486  da1 = a4(3, i) - a4(2, i)
6487  da2 = da1**2
6488  a6da = a4(4, i)*da1
6489  IF (a6da .LT. -da2) THEN
6490  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
6491  a4(3, i) = a4(2, i) - a4(4, i)
6492  ELSE IF (a6da .GT. da2) THEN
6493  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
6494  a4(2, i) = a4(3, i) - a4(4, i)
6495  END IF
6496  END IF
6497  END DO
6498  ELSE
6499 ! Standard PPM constraint
6500  DO i=1,im
6501  IF (extm(i)) THEN
6502  a4(2, i) = a4(1, i)
6503  a4(3, i) = a4(1, i)
6504  a4(4, i) = 0.
6505  ELSE
6506  da1 = a4(3, i) - a4(2, i)
6507  da2 = da1**2
6508  a6da = a4(4, i)*da1
6509  IF (a6da .LT. -da2) THEN
6510  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
6511  a4(3, i) = a4(2, i) - a4(4, i)
6512  ELSE IF (a6da .GT. da2) THEN
6513  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
6514  a4(2, i) = a4(3, i) - a4(4, i)
6515  END IF
6516  END IF
6517  END DO
6518  END IF
6519  END SUBROUTINE cs_limiters
6520  SUBROUTINE ppm_profile(a4, delp, km, i1, i2, iv, kord)
6521  IMPLICIT NONE
6522 ! !INPUT PARAMETERS:
6523 ! iv =-1: winds
6524  INTEGER, INTENT(IN) :: iv
6525 ! iv = 0: positive definite scalars
6526 ! iv = 1: others
6527 ! iv = 2: w (iv=-2)
6528 ! Starting longitude
6529  INTEGER, INTENT(IN) :: i1
6530 ! Finishing longitude
6531  INTEGER, INTENT(IN) :: i2
6532 ! vertical dimension
6533  INTEGER, INTENT(IN) :: km
6534 ! Order (or more accurately method no.):
6535  INTEGER, INTENT(IN) :: kord
6536 !
6537 ! layer pressure thickness
6538  REAL, INTENT(IN) :: delp(i1:i2, km)
6539 ! !INPUT/OUTPUT PARAMETERS:
6540 ! Interpolated values
6541  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
6542 ! DESCRIPTION:
6543 !
6544 ! Perform the piecewise parabolic reconstruction
6545 !
6546 ! !REVISION HISTORY:
6547 ! S.-J. Lin revised at GFDL 2007
6548 !-----------------------------------------------------------------------
6549 ! local arrays:
6550  REAL :: dc(i1:i2, km)
6551  REAL :: h2(i1:i2, km)
6552  REAL :: delq(i1:i2, km)
6553  REAL :: df2(i1:i2, km)
6554  REAL :: d4(i1:i2, km)
6555 ! local scalars:
6556  INTEGER :: i, k, km1, lmt, it
6557  REAL :: fac
6558  REAL :: a1, a2, c1, c2, c3, d1, d2
6559  REAL :: qm, dq, lac, qmp, pmp
6560  INTRINSIC abs
6561  INTRINSIC max
6562  INTRINSIC min
6563  INTRINSIC sign
6564  REAL :: min1
6565  INTEGER :: abs0
6566  REAL :: max1
6567  REAL :: min2
6568  REAL :: x3
6569  REAL :: x2
6570  REAL :: x1
6571  REAL :: z1
6572  REAL :: y9
6573  REAL :: y8
6574  REAL :: y7
6575  REAL :: y6
6576  REAL :: y5
6577  REAL :: y4
6578  REAL :: y3
6579  REAL :: y2
6580  REAL :: y1
6581  km1 = km - 1
6582  it = i2 - i1 + 1
6583  DO k=2,km
6584  DO i=i1,i2
6585  delq(i, k-1) = a4(1, i, k) - a4(1, i, k-1)
6586  d4(i, k) = delp(i, k-1) + delp(i, k)
6587  END DO
6588  END DO
6589  DO k=2,km1
6590  DO i=i1,i2
6591  c1 = (delp(i, k-1)+0.5*delp(i, k))/d4(i, k+1)
6592  c2 = (delp(i, k+1)+0.5*delp(i, k))/d4(i, k)
6593  df2(i, k) = delp(i, k)*(c1*delq(i, k)+c2*delq(i, k-1))/(d4(i, k)&
6594 & +delp(i, k+1))
6595  IF (df2(i, k) .GE. 0.) THEN
6596  x1 = df2(i, k)
6597  ELSE
6598  x1 = -df2(i, k)
6599  END IF
6600  IF (a4(1, i, k-1) .LT. a4(1, i, k)) THEN
6601  IF (a4(1, i, k) .LT. a4(1, i, k+1)) THEN
6602  max1 = a4(1, i, k+1)
6603  ELSE
6604  max1 = a4(1, i, k)
6605  END IF
6606  ELSE IF (a4(1, i, k-1) .LT. a4(1, i, k+1)) THEN
6607  max1 = a4(1, i, k+1)
6608  ELSE
6609  max1 = a4(1, i, k-1)
6610  END IF
6611  y1 = max1 - a4(1, i, k)
6612  IF (a4(1, i, k-1) .GT. a4(1, i, k)) THEN
6613  IF (a4(1, i, k) .GT. a4(1, i, k+1)) THEN
6614  min2 = a4(1, i, k+1)
6615  ELSE
6616  min2 = a4(1, i, k)
6617  END IF
6618  ELSE IF (a4(1, i, k-1) .GT. a4(1, i, k+1)) THEN
6619  min2 = a4(1, i, k+1)
6620  ELSE
6621  min2 = a4(1, i, k-1)
6622  END IF
6623  z1 = a4(1, i, k) - min2
6624  IF (x1 .GT. y1) THEN
6625  IF (y1 .GT. z1) THEN
6626  min1 = z1
6627  ELSE
6628  min1 = y1
6629  END IF
6630  ELSE IF (x1 .GT. z1) THEN
6631  min1 = z1
6632  ELSE
6633  min1 = x1
6634  END IF
6635  dc(i, k) = sign(min1, df2(i, k))
6636  END DO
6637  END DO
6638 !-----------------------------------------------------------
6639 ! 4th order interpolation of the provisional cell edge value
6640 !-----------------------------------------------------------
6641  DO k=3,km1
6642  DO i=i1,i2
6643  c1 = delq(i, k-1)*delp(i, k-1)/d4(i, k)
6644  a1 = d4(i, k-1)/(d4(i, k)+delp(i, k-1))
6645  a2 = d4(i, k+1)/(d4(i, k)+delp(i, k))
6646  a4(2, i, k) = a4(1, i, k-1) + c1 + 2./(d4(i, k-1)+d4(i, k+1))*(&
6647 & delp(i, k)*(c1*(a1-a2)+a2*dc(i, k-1))-delp(i, k-1)*a1*dc(i, k)&
6648 & )
6649  END DO
6650  END DO
6651 ! if(km>8 .and. kord>4) call steepz(i1, i2, km, a4, df2, dc, delq, delp, d4)
6652 ! Area preserving cubic with 2nd deriv. = 0 at the boundaries
6653 ! Top
6654  DO i=i1,i2
6655  d1 = delp(i, 1)
6656  d2 = delp(i, 2)
6657  qm = (d2*a4(1, i, 1)+d1*a4(1, i, 2))/(d1+d2)
6658  dq = 2.*(a4(1, i, 2)-a4(1, i, 1))/(d1+d2)
6659  c1 = 4.*(a4(2, i, 3)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
6660  c3 = dq - 0.5*c1*(d2*(5.*d1+d2)-3.*d1*d1)
6661  a4(2, i, 2) = qm - 0.25*c1*d1*d2*(d2+3.*d1)
6662 ! Top edge:
6663 !-------------------------------------------------------
6664  a4(2, i, 1) = d1*(2.*c1*d1**2-c3) + a4(2, i, 2)
6665  IF (a4(1, i, 1) .GT. a4(1, i, 2)) THEN
6666  y2 = a4(1, i, 2)
6667  ELSE
6668  y2 = a4(1, i, 1)
6669  END IF
6670  IF (a4(2, i, 2) .LT. y2) THEN
6671  a4(2, i, 2) = y2
6672  ELSE
6673  a4(2, i, 2) = a4(2, i, 2)
6674  END IF
6675  IF (a4(1, i, 1) .LT. a4(1, i, 2)) THEN
6676  y3 = a4(1, i, 2)
6677  ELSE
6678  y3 = a4(1, i, 1)
6679  END IF
6680  IF (a4(2, i, 2) .GT. y3) THEN
6681  a4(2, i, 2) = y3
6682  ELSE
6683  a4(2, i, 2) = a4(2, i, 2)
6684  END IF
6685  dc(i, 1) = 0.5*(a4(2, i, 2)-a4(1, i, 1))
6686  END DO
6687 ! Enforce monotonicity within the top layer
6688  IF (iv .EQ. 0) THEN
6689  DO i=i1,i2
6690  IF (0. .LT. a4(2, i, 1)) THEN
6691  a4(2, i, 1) = a4(2, i, 1)
6692  ELSE
6693  a4(2, i, 1) = 0.
6694  END IF
6695  IF (0. .LT. a4(2, i, 2)) THEN
6696  a4(2, i, 2) = a4(2, i, 2)
6697  ELSE
6698  a4(2, i, 2) = 0.
6699  END IF
6700  END DO
6701  ELSE IF (iv .EQ. -1) THEN
6702  DO i=i1,i2
6703  IF (a4(2, i, 1)*a4(1, i, 1) .LE. 0.) a4(2, i, 1) = 0.
6704  END DO
6705  ELSE
6706  IF (iv .GE. 0.) THEN
6707  abs0 = iv
6708  ELSE
6709  abs0 = -iv
6710  END IF
6711  IF (abs0 .EQ. 2) THEN
6712  DO i=i1,i2
6713  a4(2, i, 1) = a4(1, i, 1)
6714  a4(3, i, 1) = a4(1, i, 1)
6715  END DO
6716  END IF
6717  END IF
6718 ! Bottom
6719 ! Area preserving cubic with 2nd deriv. = 0 at the surface
6720  DO i=i1,i2
6721  d1 = delp(i, km)
6722  d2 = delp(i, km1)
6723  qm = (d2*a4(1, i, km)+d1*a4(1, i, km1))/(d1+d2)
6724  dq = 2.*(a4(1, i, km1)-a4(1, i, km))/(d1+d2)
6725  c1 = (a4(2, i, km1)-qm-d2*dq)/(d2*(2.*d2*d2+d1*(d2+3.*d1)))
6726  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1*d1)
6727  a4(2, i, km) = qm - c1*d1*d2*(d2+3.*d1)
6728 ! Bottom edge:
6729 !-----------------------------------------------------
6730  a4(3, i, km) = d1*(8.*c1*d1**2-c3) + a4(2, i, km)
6731  IF (a4(1, i, km) .GT. a4(1, i, km1)) THEN
6732  y4 = a4(1, i, km1)
6733  ELSE
6734  y4 = a4(1, i, km)
6735  END IF
6736  IF (a4(2, i, km) .LT. y4) THEN
6737  a4(2, i, km) = y4
6738  ELSE
6739  a4(2, i, km) = a4(2, i, km)
6740  END IF
6741  IF (a4(1, i, km) .LT. a4(1, i, km1)) THEN
6742  y5 = a4(1, i, km1)
6743  ELSE
6744  y5 = a4(1, i, km)
6745  END IF
6746  IF (a4(2, i, km) .GT. y5) THEN
6747  a4(2, i, km) = y5
6748  ELSE
6749  a4(2, i, km) = a4(2, i, km)
6750  END IF
6751  dc(i, km) = 0.5*(a4(1, i, km)-a4(2, i, km))
6752  END DO
6753 ! Enforce constraint on the "slope" at the surface
6754  IF (iv .EQ. 0) THEN
6755  DO i=i1,i2
6756  IF (0. .LT. a4(2, i, km)) THEN
6757  a4(2, i, km) = a4(2, i, km)
6758  ELSE
6759  a4(2, i, km) = 0.
6760  END IF
6761  IF (0. .LT. a4(3, i, km)) THEN
6762  a4(3, i, km) = a4(3, i, km)
6763  ELSE
6764  a4(3, i, km) = 0.
6765  END IF
6766  END DO
6767  ELSE IF (iv .LT. 0) THEN
6768  DO i=i1,i2
6769  IF (a4(1, i, km)*a4(3, i, km) .LE. 0.) a4(3, i, km) = 0.
6770  END DO
6771  END IF
6772  DO k=1,km1
6773  DO i=i1,i2
6774  a4(3, i, k) = a4(2, i, k+1)
6775  END DO
6776  END DO
6777 !-----------------------------------------------------------
6778 ! f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
6779 !-----------------------------------------------------------
6780 ! Top 2 and bottom 2 layers always use monotonic mapping
6781  DO k=1,2
6782  DO i=i1,i2
6783  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
6784  END DO
6785  CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, 0)
6786  END DO
6787  IF (kord .GE. 7) THEN
6788 !-----------------------
6789 ! Huynh's 2nd constraint
6790 !-----------------------
6791  DO k=2,km1
6792  DO i=i1,i2
6793 ! Method#1
6794 ! h2(i,k) = delq(i,k) - delq(i,k-1)
6795 ! Method#2 - better
6796  h2(i, k) = 2.*(dc(i, k+1)/delp(i, k+1)-dc(i, k-1)/delp(i, k-1)&
6797 & )/(delp(i, k)+0.5*(delp(i, k-1)+delp(i, k+1)))*delp(i, k)**2
6798  END DO
6799  END DO
6800 ! Method#3
6801 !!! h2(i,k) = dc(i,k+1) - dc(i,k-1)
6802 ! original quasi-monotone
6803  fac = 1.5
6804  DO k=3,km-2
6805  DO i=i1,i2
6806 ! Right edges
6807 ! qmp = a4(1,i,k) + 2.0*delq(i,k-1)
6808 ! lac = a4(1,i,k) + fac*h2(i,k-1) + 0.5*delq(i,k-1)
6809 !
6810  pmp = 2.*dc(i, k)
6811  qmp = a4(1, i, k) + pmp
6812  lac = a4(1, i, k) + fac*h2(i, k-1) + dc(i, k)
6813  IF (a4(1, i, k) .GT. qmp) THEN
6814  IF (qmp .GT. lac) THEN
6815  y8 = lac
6816  ELSE
6817  y8 = qmp
6818  END IF
6819  ELSE IF (a4(1, i, k) .GT. lac) THEN
6820  y8 = lac
6821  ELSE
6822  y8 = a4(1, i, k)
6823  END IF
6824  IF (a4(3, i, k) .LT. y8) THEN
6825  x2 = y8
6826  ELSE
6827  x2 = a4(3, i, k)
6828  END IF
6829  IF (a4(1, i, k) .LT. qmp) THEN
6830  IF (qmp .LT. lac) THEN
6831  y6 = lac
6832  ELSE
6833  y6 = qmp
6834  END IF
6835  ELSE IF (a4(1, i, k) .LT. lac) THEN
6836  y6 = lac
6837  ELSE
6838  y6 = a4(1, i, k)
6839  END IF
6840  IF (x2 .GT. y6) THEN
6841  a4(3, i, k) = y6
6842  ELSE
6843  a4(3, i, k) = x2
6844  END IF
6845 ! Left edges
6846 ! qmp = a4(1,i,k) - 2.0*delq(i,k)
6847 ! lac = a4(1,i,k) + fac*h2(i,k+1) - 0.5*delq(i,k)
6848 !
6849  qmp = a4(1, i, k) - pmp
6850  lac = a4(1, i, k) + fac*h2(i, k+1) - dc(i, k)
6851  IF (a4(1, i, k) .GT. qmp) THEN
6852  IF (qmp .GT. lac) THEN
6853  y9 = lac
6854  ELSE
6855  y9 = qmp
6856  END IF
6857  ELSE IF (a4(1, i, k) .GT. lac) THEN
6858  y9 = lac
6859  ELSE
6860  y9 = a4(1, i, k)
6861  END IF
6862  IF (a4(2, i, k) .LT. y9) THEN
6863  x3 = y9
6864  ELSE
6865  x3 = a4(2, i, k)
6866  END IF
6867  IF (a4(1, i, k) .LT. qmp) THEN
6868  IF (qmp .LT. lac) THEN
6869  y7 = lac
6870  ELSE
6871  y7 = qmp
6872  END IF
6873  ELSE IF (a4(1, i, k) .LT. lac) THEN
6874  y7 = lac
6875  ELSE
6876  y7 = a4(1, i, k)
6877  END IF
6878  IF (x3 .GT. y7) THEN
6879  a4(2, i, k) = y7
6880  ELSE
6881  a4(2, i, k) = x3
6882  END IF
6883 !-------------
6884 ! Recompute A6
6885 !-------------
6886  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
6887  END DO
6888 ! Additional constraint to ensure positivity when kord=7
6889  IF (iv .EQ. 0 .AND. kord .GE. 6) CALL ppm_limiters(dc(i1, k), a4&
6890 & (1, i1, k), it, 2)
6891  END DO
6892  ELSE
6893  lmt = kord - 3
6894  IF (0 .LT. lmt) THEN
6895  lmt = lmt
6896  ELSE
6897  lmt = 0
6898  END IF
6899  IF (iv .EQ. 0) THEN
6900  IF (2 .GT. lmt) THEN
6901  lmt = lmt
6902  ELSE
6903  lmt = 2
6904  END IF
6905  END IF
6906  DO k=3,km-2
6907  IF (kord .NE. 4) THEN
6908  DO i=i1,i2
6909  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
6910  END DO
6911  END IF
6912  IF (kord .NE. 6) CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, &
6913 & lmt)
6914  END DO
6915  END IF
6916  DO k=km1,km
6917  DO i=i1,i2
6918  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
6919  END DO
6920  CALL ppm_limiters(dc(i1, k), a4(1, i1, k), it, 0)
6921  END DO
6922  END SUBROUTINE ppm_profile
6923  SUBROUTINE ppm_limiters(dm, a4, itot, lmt)
6924  IMPLICIT NONE
6925 ! !INPUT PARAMETERS:
6926 ! the linear slope
6927  REAL, INTENT(IN) :: dm(*)
6928 ! Total Longitudes
6929  INTEGER, INTENT(IN) :: itot
6930 ! 0: Standard PPM constraint
6931  INTEGER, INTENT(IN) :: lmt
6932 ! 1: Improved full monotonicity constraint (Lin)
6933 ! 2: Positive definite constraint
6934 ! 3: do nothing (return immediately)
6935 ! !INPUT/OUTPUT PARAMETERS:
6936 ! PPM array
6937  REAL, INTENT(INOUT) :: a4(4, *)
6938 ! AA <-- a4(1,i)
6939 ! AL <-- a4(2,i)
6940 ! AR <-- a4(3,i)
6941 ! A6 <-- a4(4,i)
6942 ! !LOCAL VARIABLES:
6943  REAL :: qmp
6944  REAL :: da1, da2, a6da
6945  REAL :: fmin
6946  INTEGER :: i
6947  INTRINSIC abs
6948  INTRINSIC min
6949  INTRINSIC sign
6950  REAL :: min1
6951  REAL :: min2
6952  REAL :: abs0
6953  REAL :: x2
6954  REAL :: x1
6955  REAL :: y2
6956  REAL :: y1
6957 ! Developer: S.-J. Lin
6958  IF (lmt .EQ. 3) THEN
6959  RETURN
6960  ELSE IF (lmt .EQ. 0) THEN
6961 ! Standard PPM constraint
6962  DO i=1,itot
6963  IF (dm(i) .EQ. 0.) THEN
6964  a4(2, i) = a4(1, i)
6965  a4(3, i) = a4(1, i)
6966  a4(4, i) = 0.
6967  ELSE
6968  da1 = a4(3, i) - a4(2, i)
6969  da2 = da1**2
6970  a6da = a4(4, i)*da1
6971  IF (a6da .LT. -da2) THEN
6972  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
6973  a4(3, i) = a4(2, i) - a4(4, i)
6974  ELSE IF (a6da .GT. da2) THEN
6975  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
6976  a4(2, i) = a4(3, i) - a4(4, i)
6977  END IF
6978  END IF
6979  END DO
6980  ELSE IF (lmt .EQ. 1) THEN
6981 ! Improved full monotonicity constraint (Lin 2004)
6982 ! Note: no need to provide first guess of A6 <-- a4(4,i)
6983  DO i=1,itot
6984  qmp = 2.*dm(i)
6985  IF (qmp .GE. 0.) THEN
6986  x1 = qmp
6987  ELSE
6988  x1 = -qmp
6989  END IF
6990  IF (a4(2, i) - a4(1, i) .GE. 0.) THEN
6991  y1 = a4(2, i) - a4(1, i)
6992  ELSE
6993  y1 = -(a4(2, i)-a4(1, i))
6994  END IF
6995  IF (x1 .GT. y1) THEN
6996  min1 = y1
6997  ELSE
6998  min1 = x1
6999  END IF
7000  a4(2, i) = a4(1, i) - sign(min1, qmp)
7001  IF (qmp .GE. 0.) THEN
7002  x2 = qmp
7003  ELSE
7004  x2 = -qmp
7005  END IF
7006  IF (a4(3, i) - a4(1, i) .GE. 0.) THEN
7007  y2 = a4(3, i) - a4(1, i)
7008  ELSE
7009  y2 = -(a4(3, i)-a4(1, i))
7010  END IF
7011  IF (x2 .GT. y2) THEN
7012  min2 = y2
7013  ELSE
7014  min2 = x2
7015  END IF
7016  a4(3, i) = a4(1, i) + sign(min2, qmp)
7017  a4(4, i) = 3.*(2.*a4(1, i)-(a4(2, i)+a4(3, i)))
7018  END DO
7019  ELSE IF (lmt .EQ. 2) THEN
7020 ! Positive definite constraint
7021  DO i=1,itot
7022  IF (a4(3, i) - a4(2, i) .GE. 0.) THEN
7023  abs0 = a4(3, i) - a4(2, i)
7024  ELSE
7025  abs0 = -(a4(3, i)-a4(2, i))
7026  END IF
7027  IF (abs0 .LT. -a4(4, i)) THEN
7028  fmin = a4(1, i) + 0.25*(a4(3, i)-a4(2, i))**2/a4(4, i) + a4(4&
7029 & , i)*r12
7030  IF (fmin .LT. 0.) THEN
7031  IF (a4(1, i) .LT. a4(3, i) .AND. a4(1, i) .LT. a4(2, i)) &
7032 & THEN
7033  a4(3, i) = a4(1, i)
7034  a4(2, i) = a4(1, i)
7035  a4(4, i) = 0.
7036  ELSE IF (a4(3, i) .GT. a4(2, i)) THEN
7037  a4(4, i) = 3.*(a4(2, i)-a4(1, i))
7038  a4(3, i) = a4(2, i) - a4(4, i)
7039  ELSE
7040  a4(4, i) = 3.*(a4(3, i)-a4(1, i))
7041  a4(2, i) = a4(3, i) - a4(4, i)
7042  END IF
7043  END IF
7044  END IF
7045  END DO
7046  END IF
7047  END SUBROUTINE ppm_limiters
7048  SUBROUTINE moist_cv(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum&
7049 & , liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cvm, t1)
7050  IMPLICIT NONE
7051  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed, km, nwat, j, k
7052  INTEGER, INTENT(IN) :: sphum, liq_wat, rainwat, ice_wat, snowwat, &
7053 & graupel
7054  REAL, DIMENSION(isd:ied, jsd:jed, km, nwat), INTENT(IN) :: q
7055  REAL, DIMENSION(is:ie), INTENT(OUT) :: cvm, qd
7056  REAL, INTENT(IN), OPTIONAL :: t1(is:ie)
7057 !
7058  REAL, PARAMETER :: t_i0=15.
7059  REAL, DIMENSION(is:ie) :: qv, ql, qs
7060  INTEGER :: i
7061  INTRINSIC PRESENT
7062  INTRINSIC max
7063  SELECT CASE (nwat)
7064  CASE (2)
7065  IF (PRESENT(t1)) THEN
7066 ! Special case for GFS physics
7067  DO i=is,ie
7068  IF (0. .LT. q(i, j, k, liq_wat)) THEN
7069  qd(i) = q(i, j, k, liq_wat)
7070  ELSE
7071  qd(i) = 0.
7072  END IF
7073  IF (t1(i) .GT. tice) THEN
7074  qs(i) = 0.
7075  ELSE IF (t1(i) .LT. tice - t_i0) THEN
7076  qs(i) = qd(i)
7077  ELSE
7078  qs(i) = qd(i)*(tice-t1(i))/t_i0
7079  END IF
7080  ql(i) = qd(i) - qs(i)
7081  IF (0. .LT. q(i, j, k, sphum)) THEN
7082  qv(i) = q(i, j, k, sphum)
7083  ELSE
7084  qv(i) = 0.
7085  END IF
7086  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*&
7087 & c_liq + qs(i)*c_ice
7088  END DO
7089  ELSE
7090  DO i=is,ie
7091  IF (0. .LT. q(i, j, k, sphum)) THEN
7092  qv(i) = q(i, j, k, sphum)
7093  ELSE
7094  qv(i) = 0.
7095  END IF
7096  IF (0. .LT. q(i, j, k, liq_wat)) THEN
7097  qs(i) = q(i, j, k, liq_wat)
7098  ELSE
7099  qs(i) = 0.
7100  END IF
7101  qd(i) = qs(i)
7102  cvm(i) = (1.-qv(i))*cv_air + qv(i)*cv_vap
7103  END DO
7104  END IF
7105  CASE (3)
7106  DO i=is,ie
7107  qv(i) = q(i, j, k, sphum)
7108  ql(i) = q(i, j, k, liq_wat)
7109  qs(i) = q(i, j, k, ice_wat)
7110  qd(i) = ql(i) + qs(i)
7111  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq &
7112 & + qs(i)*c_ice
7113  END DO
7114  CASE (4)
7115 ! K_warm_rain with fake ice
7116  DO i=is,ie
7117  qv(i) = q(i, j, k, sphum)
7118  qd(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
7119  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + qd(i)*c_liq
7120  END DO
7121  CASE (6)
7122  DO i=is,ie
7123  qv(i) = q(i, j, k, sphum)
7124  ql(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
7125  qs(i) = q(i, j, k, ice_wat) + q(i, j, k, snowwat) + q(i, j, k, &
7126 & graupel)
7127  qd(i) = ql(i) + qs(i)
7128  cvm(i) = (1.-(qv(i)+qd(i)))*cv_air + qv(i)*cv_vap + ql(i)*c_liq &
7129 & + qs(i)*c_ice
7130  END DO
7131  CASE DEFAULT
7132  DO i=is,ie
7133  qd(i) = 0.
7134  cvm(i) = cv_air
7135  END DO
7136  END SELECT
7137  END SUBROUTINE moist_cv
7138  SUBROUTINE moist_cp(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum&
7139 & , liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cpm, t1)
7140  IMPLICIT NONE
7141  INTEGER, INTENT(IN) :: is, ie, isd, ied, jsd, jed, km, nwat, j, k
7142  INTEGER, INTENT(IN) :: sphum, liq_wat, rainwat, ice_wat, snowwat, &
7143 & graupel
7144  REAL, DIMENSION(isd:ied, jsd:jed, km, nwat), INTENT(IN) :: q
7145  REAL, DIMENSION(is:ie), INTENT(OUT) :: cpm, qd
7146  REAL, INTENT(IN), OPTIONAL :: t1(is:ie)
7147 !
7148  REAL, PARAMETER :: t_i0=15.
7149  REAL, DIMENSION(is:ie) :: qv, ql, qs
7150  INTEGER :: i
7151  INTRINSIC PRESENT
7152  INTRINSIC max
7153  SELECT CASE (nwat)
7154  CASE (2)
7155  IF (PRESENT(t1)) THEN
7156 ! Special case for GFS physics
7157  DO i=is,ie
7158  IF (0. .LT. q(i, j, k, liq_wat)) THEN
7159  qd(i) = q(i, j, k, liq_wat)
7160  ELSE
7161  qd(i) = 0.
7162  END IF
7163  IF (t1(i) .GT. tice) THEN
7164  qs(i) = 0.
7165  ELSE IF (t1(i) .LT. tice - t_i0) THEN
7166  qs(i) = qd(i)
7167  ELSE
7168  qs(i) = qd(i)*(tice-t1(i))/t_i0
7169  END IF
7170  ql(i) = qd(i) - qs(i)
7171  IF (0. .LT. q(i, j, k, sphum)) THEN
7172  qv(i) = q(i, j, k, sphum)
7173  ELSE
7174  qv(i) = 0.
7175  END IF
7176  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
7177 & c_liq + qs(i)*c_ice
7178  END DO
7179  ELSE
7180  DO i=is,ie
7181  IF (0. .LT. q(i, j, k, sphum)) THEN
7182  qv(i) = q(i, j, k, sphum)
7183  ELSE
7184  qv(i) = 0.
7185  END IF
7186  IF (0. .LT. q(i, j, k, liq_wat)) THEN
7187  qs(i) = q(i, j, k, liq_wat)
7188  ELSE
7189  qs(i) = 0.
7190  END IF
7191  qd(i) = qs(i)
7192  cpm(i) = (1.-qv(i))*cp_air + qv(i)*cp_vapor
7193  END DO
7194  END IF
7195  CASE (3)
7196  DO i=is,ie
7197  qv(i) = q(i, j, k, sphum)
7198  ql(i) = q(i, j, k, liq_wat)
7199  qs(i) = q(i, j, k, ice_wat)
7200  qd(i) = ql(i) + qs(i)
7201  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
7202 & c_liq + qs(i)*c_ice
7203  END DO
7204  CASE (4)
7205 ! K_warm_rain scheme with fake ice
7206  DO i=is,ie
7207  qv(i) = q(i, j, k, sphum)
7208  qd(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
7209  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + qd(i)*&
7210 & c_liq
7211  END DO
7212  CASE (6)
7213  DO i=is,ie
7214  qv(i) = q(i, j, k, sphum)
7215  ql(i) = q(i, j, k, liq_wat) + q(i, j, k, rainwat)
7216  qs(i) = q(i, j, k, ice_wat) + q(i, j, k, snowwat) + q(i, j, k, &
7217 & graupel)
7218  qd(i) = ql(i) + qs(i)
7219  cpm(i) = (1.-(qv(i)+qd(i)))*cp_air + qv(i)*cp_vapor + ql(i)*&
7220 & c_liq + qs(i)*c_ice
7221  END DO
7222  CASE DEFAULT
7223  DO i=is,ie
7224  qd(i) = 0.
7225  cpm(i) = cp_air
7226  END DO
7227  END SELECT
7228  END SUBROUTINE moist_cp
7229 ! Differentiation of map1_cubic in forward (tangent) mode:
7230 ! variations of useful results: q2
7231 ! with respect to varying inputs: pe1 pe2 q2
7232 !-----------------------------------------------------------------------
7233 !BOP
7234 ! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping
7235 !
7236 ! !INTERFACE:
7237  SUBROUTINE map1_cubic_tlm(km, pe1, pe1_tl, kn, pe2, pe2_tl, q2, q2_tl&
7238 & , i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
7239  IMPLICIT NONE
7240 !EOC
7241 ! !INPUT PARAMETERS:
7242 ! Starting longitude
7243  INTEGER, INTENT(IN) :: i1
7244 ! Finishing longitude
7245  INTEGER, INTENT(IN) :: i2
7246  REAL, INTENT(IN) :: akap
7247 ! Thermodynamic variable to remap
7248  INTEGER, INTENT(IN) :: t_var
7249 ! 1:TE 2:T 3:PT
7250  LOGICAL, INTENT(IN) :: conserv
7251 ! Current latitude
7252  INTEGER, INTENT(IN) :: j
7253  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
7254 ! Original vertical dimension
7255  INTEGER, INTENT(IN) :: km
7256 ! Target vertical dimension
7257  INTEGER, INTENT(IN) :: kn
7258 ! pressure at layer edges
7259  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
7260  REAL, INTENT(IN) :: pe1_tl(i1:i2, km+1)
7261 ! (from model top to bottom surface)
7262 ! in the original vertical coordinate
7263 ! pressure at layer edges
7264  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
7265  REAL, INTENT(IN) :: pe2_tl(i1:i2, kn+1)
7266 ! (from model top to bottom surface)
7267 ! in the new vertical coordinate
7268 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
7269 ! !INPUT/OUTPUT PARAMETERS:
7270 ! Field output
7271  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
7272  REAL, INTENT(INOUT) :: q2_tl(ibeg:iend, jbeg:jend, kn)
7273 ! !DESCRIPTION:
7274 !
7275 ! Perform Cubic Interpolation a given latitude
7276 ! pe1: pressure at layer edges (from model top to bottom surface)
7277 ! in the original vertical coordinate
7278 ! pe2: pressure at layer edges (from model top to bottom surface)
7279 ! in the new vertical coordinate
7280 !
7281 ! !REVISION HISTORY:
7282 ! 2005.11.14 Takacs Initial Code
7283 ! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable
7284 !
7285 !EOP
7286 !-----------------------------------------------------------------------
7287 !BOC
7288 !
7289 ! !LOCAL VARIABLES:
7290  REAL :: qx(i1:i2, km)
7291  REAL :: qx_tl(i1:i2, km)
7292  REAL :: logpl1(i1:i2, km)
7293  REAL :: logpl1_tl(i1:i2, km)
7294  REAL :: logpl2(i1:i2, kn)
7295  REAL :: logpl2_tl(i1:i2, kn)
7296  REAL :: dlogp1(i1:i2, km)
7297  REAL :: dlogp1_tl(i1:i2, km)
7298  REAL :: vsum1(i1:i2)
7299  REAL :: vsum1_tl(i1:i2)
7300  REAL :: vsum2(i1:i2)
7301  REAL :: vsum2_tl(i1:i2)
7302  REAL :: am2, am1, ap0, ap1, p, plp1, plp0, plm1, plm2, dlp0, dlm1, &
7303 & dlm2
7304  REAL :: am2_tl, am1_tl, ap0_tl, ap1_tl, p_tl, plp1_tl, plp0_tl, &
7305 & plm1_tl, plm2_tl, dlp0_tl, dlm1_tl, dlm2_tl
7306  INTEGER :: i, k, lm2, lm1, lp0, lp1
7307  INTRINSIC log
7308  INTRINSIC exp
7309  INTRINSIC max
7310  INTRINSIC min
7311  REAL, DIMENSION(i2-i1+1) :: arg1
7312  REAL, DIMENSION(i2-i1+1) :: arg1_tl
7313  REAL, DIMENSION(i1:i2) :: arg2
7314  REAL, DIMENSION(i1:i2) :: arg2_tl
7315 ! Initialization
7316 ! --------------
7317  SELECT CASE (t_var)
7318  CASE (1)
7319  qx_tl = 0.0
7320  logpl1_tl = 0.0
7321 ! Total Energy Remapping in Log(P)
7322  DO k=1,km
7323  qx_tl(:, k) = q2_tl(i1:i2, j, k)
7324  qx(:, k) = q2(i1:i2, j, k)
7325  logpl1_tl(:, k) = (pe1_tl(:, k)+pe1_tl(:, k+1))/(pe1(:, k)+pe1(:&
7326 & , k+1))
7327  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
7328  END DO
7329  logpl2_tl = 0.0
7330  DO k=1,kn
7331  logpl2_tl(:, k) = (pe2_tl(:, k)+pe2_tl(:, k+1))/(pe2(:, k)+pe2(:&
7332 & , k+1))
7333  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
7334  END DO
7335  dlogp1_tl = 0.0
7336  DO k=1,km-1
7337  dlogp1_tl(:, k) = logpl1_tl(:, k+1) - logpl1_tl(:, k)
7338  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7339  END DO
7340  CASE (2)
7341  qx_tl = 0.0
7342  logpl1_tl = 0.0
7343 ! Temperature Remapping in Log(P)
7344  DO k=1,km
7345  qx_tl(:, k) = q2_tl(i1:i2, j, k)
7346  qx(:, k) = q2(i1:i2, j, k)
7347  logpl1_tl(:, k) = (pe1_tl(:, k)+pe1_tl(:, k+1))/(pe1(:, k)+pe1(:&
7348 & , k+1))
7349  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
7350  END DO
7351  logpl2_tl = 0.0
7352  DO k=1,kn
7353  logpl2_tl(:, k) = (pe2_tl(:, k)+pe2_tl(:, k+1))/(pe2(:, k)+pe2(:&
7354 & , k+1))
7355  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
7356  END DO
7357  dlogp1_tl = 0.0
7358  DO k=1,km-1
7359  dlogp1_tl(:, k) = logpl1_tl(:, k+1) - logpl1_tl(:, k)
7360  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7361  END DO
7362  CASE (3)
7363  qx_tl = 0.0
7364  logpl1_tl = 0.0
7365 ! Potential Temperature Remapping in P^KAPPA
7366  DO k=1,km
7367  qx_tl(:, k) = q2_tl(i1:i2, j, k)
7368  qx(:, k) = q2(i1:i2, j, k)
7369  arg1_tl(:) = r2*(pe1_tl(:, k)+pe1_tl(:, k+1))
7370  arg1(:) = r2*(pe1(:, k)+pe1(:, k+1))
7371  arg2_tl(:) = akap*arg1_tl(:)/arg1(:)
7372  arg2(:) = akap*log(arg1(:))
7373  logpl1_tl(:, k) = arg2_tl(:)*exp(arg2(:))
7374  logpl1(:, k) = exp(arg2(:))
7375  END DO
7376  logpl2_tl = 0.0
7377  DO k=1,kn
7378  arg1_tl(:) = r2*(pe2_tl(:, k)+pe2_tl(:, k+1))
7379  arg1(:) = r2*(pe2(:, k)+pe2(:, k+1))
7380  arg2_tl(:) = akap*arg1_tl(:)/arg1(:)
7381  arg2(:) = akap*log(arg1(:))
7382  logpl2_tl(:, k) = arg2_tl(:)*exp(arg2(:))
7383  logpl2(:, k) = exp(arg2(:))
7384  END DO
7385  dlogp1_tl = 0.0
7386  DO k=1,km-1
7387  dlogp1_tl(:, k) = logpl1_tl(:, k+1) - logpl1_tl(:, k)
7388  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7389  END DO
7390  CASE DEFAULT
7391  qx_tl = 0.0
7392  logpl1_tl = 0.0
7393  logpl2_tl = 0.0
7394  dlogp1_tl = 0.0
7395  END SELECT
7396  IF (conserv) THEN
7397 ! Compute vertical integral of Input TE
7398 ! -------------------------------------
7399  vsum1(:) = r0
7400  vsum1_tl = 0.0
7401  DO i=i1,i2
7402  DO k=1,km
7403  vsum1_tl(i) = vsum1_tl(i) + qx_tl(i, k)*(pe1(i, k+1)-pe1(i, k)&
7404 & ) + qx(i, k)*(pe1_tl(i, k+1)-pe1_tl(i, k))
7405  vsum1(i) = vsum1(i) + qx(i, k)*(pe1(i, k+1)-pe1(i, k))
7406  END DO
7407  vsum1_tl(i) = (vsum1_tl(i)*(pe1(i, km+1)-pe1(i, 1))-vsum1(i)*(&
7408 & pe1_tl(i, km+1)-pe1_tl(i, 1)))/(pe1(i, km+1)-pe1(i, 1))**2
7409  vsum1(i) = vsum1(i)/(pe1(i, km+1)-pe1(i, 1))
7410  END DO
7411  ELSE
7412  vsum1_tl = 0.0
7413  END IF
7414 ! Interpolate TE onto target Pressures
7415 ! ------------------------------------
7416  DO i=i1,i2
7417  DO k=1,kn
7418  lm1 = 1
7419  lp0 = 1
7420  DO WHILE (lp0 .LE. km)
7421  IF (logpl1(i, lp0) .LT. logpl2(i, k)) THEN
7422  lp0 = lp0 + 1
7423  ELSE
7424  EXIT
7425  END IF
7426  END DO
7427  IF (lp0 - 1 .LT. 1) THEN
7428  lm1 = 1
7429  ELSE
7430  lm1 = lp0 - 1
7431  END IF
7432  IF (lp0 .GT. km) THEN
7433  lp0 = km
7434  ELSE
7435  lp0 = lp0
7436  END IF
7437 ! Extrapolate Linearly in LogP above first model level
7438 ! ----------------------------------------------------
7439  IF (lm1 .EQ. 1 .AND. lp0 .EQ. 1) THEN
7440  q2_tl(i, j, k) = qx_tl(i, 1) + (((qx_tl(i, 2)-qx_tl(i, 1))*(&
7441 & logpl2(i, k)-logpl1(i, 1))+(qx(i, 2)-qx(i, 1))*(logpl2_tl(i&
7442 & , k)-logpl1_tl(i, 1)))*(logpl1(i, 2)-logpl1(i, 1))-(qx(i, 2)&
7443 & -qx(i, 1))*(logpl2(i, k)-logpl1(i, 1))*(logpl1_tl(i, 2)-&
7444 & logpl1_tl(i, 1)))/(logpl1(i, 2)-logpl1(i, 1))**2
7445  q2(i, j, k) = qx(i, 1) + (qx(i, 2)-qx(i, 1))*(logpl2(i, k)-&
7446 & logpl1(i, 1))/(logpl1(i, 2)-logpl1(i, 1))
7447 ! Extrapolate Linearly in LogP below last model level
7448 ! ---------------------------------------------------
7449  ELSE IF (lm1 .EQ. km .AND. lp0 .EQ. km) THEN
7450  q2_tl(i, j, k) = qx_tl(i, km) + (((qx_tl(i, km)-qx_tl(i, km-1)&
7451 & )*(logpl2(i, k)-logpl1(i, km))+(qx(i, km)-qx(i, km-1))*(&
7452 & logpl2_tl(i, k)-logpl1_tl(i, km)))*(logpl1(i, km)-logpl1(i, &
7453 & km-1))-(qx(i, km)-qx(i, km-1))*(logpl2(i, k)-logpl1(i, km))*&
7454 & (logpl1_tl(i, km)-logpl1_tl(i, km-1)))/(logpl1(i, km)-logpl1&
7455 & (i, km-1))**2
7456  q2(i, j, k) = qx(i, km) + (qx(i, km)-qx(i, km-1))*(logpl2(i, k&
7457 & )-logpl1(i, km))/(logpl1(i, km)-logpl1(i, km-1))
7458 ! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km
7459 ! -----------------------------------------------------------------
7460  ELSE IF (lm1 .EQ. 1 .OR. lp0 .EQ. km) THEN
7461  q2_tl(i, j, k) = qx_tl(i, lp0) + (((qx_tl(i, lm1)-qx_tl(i, lp0&
7462 & ))*(logpl2(i, k)-logpl1(i, lp0))+(qx(i, lm1)-qx(i, lp0))*(&
7463 & logpl2_tl(i, k)-logpl1_tl(i, lp0)))*(logpl1(i, lm1)-logpl1(i&
7464 & , lp0))-(qx(i, lm1)-qx(i, lp0))*(logpl2(i, k)-logpl1(i, lp0)&
7465 & )*(logpl1_tl(i, lm1)-logpl1_tl(i, lp0)))/(logpl1(i, lm1)-&
7466 & logpl1(i, lp0))**2
7467  q2(i, j, k) = qx(i, lp0) + (qx(i, lm1)-qx(i, lp0))*(logpl2(i, &
7468 & k)-logpl1(i, lp0))/(logpl1(i, lm1)-logpl1(i, lp0))
7469 ! Interpolate Cubicly in LogP between other model levels
7470 ! ------------------------------------------------------
7471  ELSE
7472  lp1 = lp0 + 1
7473  lm2 = lm1 - 1
7474  p_tl = logpl2_tl(i, k)
7475  p = logpl2(i, k)
7476  plp1_tl = logpl1_tl(i, lp1)
7477  plp1 = logpl1(i, lp1)
7478  plp0_tl = logpl1_tl(i, lp0)
7479  plp0 = logpl1(i, lp0)
7480  plm1_tl = logpl1_tl(i, lm1)
7481  plm1 = logpl1(i, lm1)
7482  plm2_tl = logpl1_tl(i, lm2)
7483  plm2 = logpl1(i, lm2)
7484  dlp0_tl = dlogp1_tl(i, lp0)
7485  dlp0 = dlogp1(i, lp0)
7486  dlm1_tl = dlogp1_tl(i, lm1)
7487  dlm1 = dlogp1(i, lm1)
7488  dlm2_tl = dlogp1_tl(i, lm2)
7489  dlm2 = dlogp1(i, lm2)
7490  ap1_tl = ((((p_tl-plp0_tl)*(p-plm1)+(p-plp0)*(p_tl-plm1_tl))*(&
7491 & p-plm2)+(p-plp0)*(p-plm1)*(p_tl-plm2_tl))*dlp0*(dlp0+dlm1)*(&
7492 & dlp0+dlm1+dlm2)-(p-plp0)*(p-plm1)*(p-plm2)*((dlp0_tl*(dlp0+&
7493 & dlm1)+dlp0*(dlp0_tl+dlm1_tl))*(dlp0+dlm1+dlm2)+dlp0*(dlp0+&
7494 & dlm1)*(dlp0_tl+dlm1_tl+dlm2_tl)))/(dlp0*(dlp0+dlm1)*(dlp0+&
7495 & dlm1+dlm2))**2
7496  ap1 = (p-plp0)*(p-plm1)*(p-plm2)/(dlp0*(dlp0+dlm1)*(dlp0+dlm1+&
7497 & dlm2))
7498  ap0_tl = ((((plp1_tl-p_tl)*(p-plm1)+(plp1-p)*(p_tl-plm1_tl))*(&
7499 & p-plm2)+(plp1-p)*(p-plm1)*(p_tl-plm2_tl))*dlp0*dlm1*(dlm1+&
7500 & dlm2)-(plp1-p)*(p-plm1)*(p-plm2)*((dlp0_tl*dlm1+dlp0*dlm1_tl&
7501 & )*(dlm1+dlm2)+dlp0*dlm1*(dlm1_tl+dlm2_tl)))/(dlp0*dlm1*(dlm1&
7502 & +dlm2))**2
7503  ap0 = (plp1-p)*(p-plm1)*(p-plm2)/(dlp0*dlm1*(dlm1+dlm2))
7504  am1_tl = ((((plp1_tl-p_tl)*(plp0-p)+(plp1-p)*(plp0_tl-p_tl))*(&
7505 & p-plm2)+(plp1-p)*(plp0-p)*(p_tl-plm2_tl))*dlm1*dlm2*(dlp0+&
7506 & dlm1)-(plp1-p)*(plp0-p)*(p-plm2)*((dlm1_tl*dlm2+dlm1*dlm2_tl&
7507 & )*(dlp0+dlm1)+dlm1*dlm2*(dlp0_tl+dlm1_tl)))/(dlm1*dlm2*(dlp0&
7508 & +dlm1))**2
7509  am1 = (plp1-p)*(plp0-p)*(p-plm2)/(dlm1*dlm2*(dlp0+dlm1))
7510  am2_tl = ((((plp1_tl-p_tl)*(plp0-p)+(plp1-p)*(plp0_tl-p_tl))*(&
7511 & plm1-p)+(plp1-p)*(plp0-p)*(plm1_tl-p_tl))*dlm2*(dlm1+dlm2)*(&
7512 & dlp0+dlm1+dlm2)-(plp1-p)*(plp0-p)*(plm1-p)*((dlm2_tl*(dlm1+&
7513 & dlm2)+dlm2*(dlm1_tl+dlm2_tl))*(dlp0+dlm1+dlm2)+dlm2*(dlm1+&
7514 & dlm2)*(dlp0_tl+dlm1_tl+dlm2_tl)))/(dlm2*(dlm1+dlm2)*(dlp0+&
7515 & dlm1+dlm2))**2
7516  am2 = (plp1-p)*(plp0-p)*(plm1-p)/(dlm2*(dlm1+dlm2)*(dlp0+dlm1+&
7517 & dlm2))
7518  q2_tl(i, j, k) = ap1_tl*qx(i, lp1) + ap1*qx_tl(i, lp1) + &
7519 & ap0_tl*qx(i, lp0) + ap0*qx_tl(i, lp0) + am1_tl*qx(i, lm1) + &
7520 & am1*qx_tl(i, lm1) + am2_tl*qx(i, lm2) + am2*qx_tl(i, lm2)
7521  q2(i, j, k) = ap1*qx(i, lp1) + ap0*qx(i, lp0) + am1*qx(i, lm1)&
7522 & + am2*qx(i, lm2)
7523  END IF
7524  END DO
7525  END DO
7526  IF (conserv) THEN
7527 ! Compute vertical integral of Output TE
7528 ! --------------------------------------
7529  vsum2(:) = r0
7530  vsum2_tl = 0.0
7531  DO i=i1,i2
7532  DO k=1,kn
7533  vsum2_tl(i) = vsum2_tl(i) + q2_tl(i, j, k)*(pe2(i, k+1)-pe2(i&
7534 & , k)) + q2(i, j, k)*(pe2_tl(i, k+1)-pe2_tl(i, k))
7535  vsum2(i) = vsum2(i) + q2(i, j, k)*(pe2(i, k+1)-pe2(i, k))
7536  END DO
7537  vsum2_tl(i) = (vsum2_tl(i)*(pe2(i, kn+1)-pe2(i, 1))-vsum2(i)*(&
7538 & pe2_tl(i, kn+1)-pe2_tl(i, 1)))/(pe2(i, kn+1)-pe2(i, 1))**2
7539  vsum2(i) = vsum2(i)/(pe2(i, kn+1)-pe2(i, 1))
7540  END DO
7541 ! Adjust Final TE to conserve
7542 ! ---------------------------
7543  DO i=i1,i2
7544  DO k=1,kn
7545  q2_tl(i, j, k) = q2_tl(i, j, k) + vsum1_tl(i) - vsum2_tl(i)
7546  q2(i, j, k) = q2(i, j, k) + vsum1(i) - vsum2(i)
7547  END DO
7548  END DO
7549  END IF
7550 ! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i)
7551  RETURN
7552  END SUBROUTINE map1_cubic_tlm
7553 !-----------------------------------------------------------------------
7554 !BOP
7555 ! !ROUTINE: map1_cubic --- Cubic Interpolation for vertical re-mapping
7556 !
7557 ! !INTERFACE:
7558  SUBROUTINE map1_cubic(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend, &
7559 & jbeg, jend, akap, t_var, conserv)
7560  IMPLICIT NONE
7561 !EOC
7562 ! !INPUT PARAMETERS:
7563 ! Starting longitude
7564  INTEGER, INTENT(IN) :: i1
7565 ! Finishing longitude
7566  INTEGER, INTENT(IN) :: i2
7567  REAL, INTENT(IN) :: akap
7568 ! Thermodynamic variable to remap
7569  INTEGER, INTENT(IN) :: t_var
7570 ! 1:TE 2:T 3:PT
7571  LOGICAL, INTENT(IN) :: conserv
7572 ! Current latitude
7573  INTEGER, INTENT(IN) :: j
7574  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
7575 ! Original vertical dimension
7576  INTEGER, INTENT(IN) :: km
7577 ! Target vertical dimension
7578  INTEGER, INTENT(IN) :: kn
7579 ! pressure at layer edges
7580  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
7581 ! (from model top to bottom surface)
7582 ! in the original vertical coordinate
7583 ! pressure at layer edges
7584  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
7585 ! (from model top to bottom surface)
7586 ! in the new vertical coordinate
7587 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
7588 ! !INPUT/OUTPUT PARAMETERS:
7589 ! Field output
7590  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
7591 ! !DESCRIPTION:
7592 !
7593 ! Perform Cubic Interpolation a given latitude
7594 ! pe1: pressure at layer edges (from model top to bottom surface)
7595 ! in the original vertical coordinate
7596 ! pe2: pressure at layer edges (from model top to bottom surface)
7597 ! in the new vertical coordinate
7598 !
7599 ! !REVISION HISTORY:
7600 ! 2005.11.14 Takacs Initial Code
7601 ! 2016.07.20 Putman Modified to make genaric for any thermodynamic variable
7602 !
7603 !EOP
7604 !-----------------------------------------------------------------------
7605 !BOC
7606 !
7607 ! !LOCAL VARIABLES:
7608  REAL :: qx(i1:i2, km)
7609  REAL :: logpl1(i1:i2, km)
7610  REAL :: logpl2(i1:i2, kn)
7611  REAL :: dlogp1(i1:i2, km)
7612  REAL :: vsum1(i1:i2)
7613  REAL :: vsum2(i1:i2)
7614  REAL :: am2, am1, ap0, ap1, p, plp1, plp0, plm1, plm2, dlp0, dlm1, &
7615 & dlm2
7616  INTEGER :: i, k, lm2, lm1, lp0, lp1
7617  INTRINSIC log
7618  INTRINSIC exp
7619  INTRINSIC max
7620  INTRINSIC min
7621  REAL, DIMENSION(i2-i1+1) :: arg1
7622  REAL, DIMENSION(i1:i2) :: arg2
7623 ! Initialization
7624 ! --------------
7625  SELECT CASE (t_var)
7626  CASE (1)
7627 ! Total Energy Remapping in Log(P)
7628  DO k=1,km
7629  qx(:, k) = q2(i1:i2, j, k)
7630  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
7631  END DO
7632  DO k=1,kn
7633  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
7634  END DO
7635  DO k=1,km-1
7636  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7637  END DO
7638  CASE (2)
7639 ! Temperature Remapping in Log(P)
7640  DO k=1,km
7641  qx(:, k) = q2(i1:i2, j, k)
7642  logpl1(:, k) = log(r2*(pe1(:, k)+pe1(:, k+1)))
7643  END DO
7644  DO k=1,kn
7645  logpl2(:, k) = log(r2*(pe2(:, k)+pe2(:, k+1)))
7646  END DO
7647  DO k=1,km-1
7648  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7649  END DO
7650  CASE (3)
7651 ! Potential Temperature Remapping in P^KAPPA
7652  DO k=1,km
7653  qx(:, k) = q2(i1:i2, j, k)
7654  arg1(:) = r2*(pe1(:, k)+pe1(:, k+1))
7655  arg2(:) = akap*log(arg1(:))
7656  logpl1(:, k) = exp(arg2(:))
7657  END DO
7658  DO k=1,kn
7659  arg1(:) = r2*(pe2(:, k)+pe2(:, k+1))
7660  arg2(:) = akap*log(arg1(:))
7661  logpl2(:, k) = exp(arg2(:))
7662  END DO
7663  DO k=1,km-1
7664  dlogp1(:, k) = logpl1(:, k+1) - logpl1(:, k)
7665  END DO
7666  END SELECT
7667  IF (conserv) THEN
7668 ! Compute vertical integral of Input TE
7669 ! -------------------------------------
7670  vsum1(:) = r0
7671  DO i=i1,i2
7672  DO k=1,km
7673  vsum1(i) = vsum1(i) + qx(i, k)*(pe1(i, k+1)-pe1(i, k))
7674  END DO
7675  vsum1(i) = vsum1(i)/(pe1(i, km+1)-pe1(i, 1))
7676  END DO
7677  END IF
7678 ! Interpolate TE onto target Pressures
7679 ! ------------------------------------
7680  DO i=i1,i2
7681  DO k=1,kn
7682  lm1 = 1
7683  lp0 = 1
7684  DO WHILE (lp0 .LE. km)
7685  IF (logpl1(i, lp0) .LT. logpl2(i, k)) THEN
7686  lp0 = lp0 + 1
7687  ELSE
7688  GOTO 100
7689  END IF
7690  END DO
7691  100 IF (lp0 - 1 .LT. 1) THEN
7692  lm1 = 1
7693  ELSE
7694  lm1 = lp0 - 1
7695  END IF
7696  IF (lp0 .GT. km) THEN
7697  lp0 = km
7698  ELSE
7699  lp0 = lp0
7700  END IF
7701 ! Extrapolate Linearly in LogP above first model level
7702 ! ----------------------------------------------------
7703  IF (lm1 .EQ. 1 .AND. lp0 .EQ. 1) THEN
7704  q2(i, j, k) = qx(i, 1) + (qx(i, 2)-qx(i, 1))*(logpl2(i, k)-&
7705 & logpl1(i, 1))/(logpl1(i, 2)-logpl1(i, 1))
7706 ! Extrapolate Linearly in LogP below last model level
7707 ! ---------------------------------------------------
7708  ELSE IF (lm1 .EQ. km .AND. lp0 .EQ. km) THEN
7709  q2(i, j, k) = qx(i, km) + (qx(i, km)-qx(i, km-1))*(logpl2(i, k&
7710 & )-logpl1(i, km))/(logpl1(i, km)-logpl1(i, km-1))
7711 ! Interpolate Linearly in LogP between levels 1 => 2 and km-1 => km
7712 ! -----------------------------------------------------------------
7713  ELSE IF (lm1 .EQ. 1 .OR. lp0 .EQ. km) THEN
7714  q2(i, j, k) = qx(i, lp0) + (qx(i, lm1)-qx(i, lp0))*(logpl2(i, &
7715 & k)-logpl1(i, lp0))/(logpl1(i, lm1)-logpl1(i, lp0))
7716 ! Interpolate Cubicly in LogP between other model levels
7717 ! ------------------------------------------------------
7718  ELSE
7719  lp1 = lp0 + 1
7720  lm2 = lm1 - 1
7721  p = logpl2(i, k)
7722  plp1 = logpl1(i, lp1)
7723  plp0 = logpl1(i, lp0)
7724  plm1 = logpl1(i, lm1)
7725  plm2 = logpl1(i, lm2)
7726  dlp0 = dlogp1(i, lp0)
7727  dlm1 = dlogp1(i, lm1)
7728  dlm2 = dlogp1(i, lm2)
7729  ap1 = (p-plp0)*(p-plm1)*(p-plm2)/(dlp0*(dlp0+dlm1)*(dlp0+dlm1+&
7730 & dlm2))
7731  ap0 = (plp1-p)*(p-plm1)*(p-plm2)/(dlp0*dlm1*(dlm1+dlm2))
7732  am1 = (plp1-p)*(plp0-p)*(p-plm2)/(dlm1*dlm2*(dlp0+dlm1))
7733  am2 = (plp1-p)*(plp0-p)*(plm1-p)/(dlm2*(dlm1+dlm2)*(dlp0+dlm1+&
7734 & dlm2))
7735  q2(i, j, k) = ap1*qx(i, lp1) + ap0*qx(i, lp0) + am1*qx(i, lm1)&
7736 & + am2*qx(i, lm2)
7737  END IF
7738  END DO
7739  END DO
7740  IF (conserv) THEN
7741 ! Compute vertical integral of Output TE
7742 ! --------------------------------------
7743  vsum2(:) = r0
7744  DO i=i1,i2
7745  DO k=1,kn
7746  vsum2(i) = vsum2(i) + q2(i, j, k)*(pe2(i, k+1)-pe2(i, k))
7747  END DO
7748  vsum2(i) = vsum2(i)/(pe2(i, kn+1)-pe2(i, 1))
7749  END DO
7750 ! Adjust Final TE to conserve
7751 ! ---------------------------
7752  DO i=i1,i2
7753  DO k=1,kn
7754  q2(i, j, k) = q2(i, j, k) + vsum1(i) - vsum2(i)
7755  END DO
7756  END DO
7757  END IF
7758 ! q2(i,j,k) = q2(i,j,k) * vsum1(i)/vsum2(i)
7759  RETURN
7760  END SUBROUTINE map1_cubic
7761 ! Differentiation of map_scalar in forward (tangent) mode:
7762 ! variations of useful results: q2
7763 ! with respect to varying inputs: pe1 pe2 q2
7764 !-----------------------------------------------------------------------
7765  SUBROUTINE map_scalar_tlm(km, pe1, pe1_tl, qs, kn, pe2, pe2_tl, q2&
7766 & , q2_tl, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
7767  IMPLICIT NONE
7768 ! iv=1
7769 ! Starting longitude
7770  INTEGER, INTENT(IN) :: i1
7771 ! Finishing longitude
7772  INTEGER, INTENT(IN) :: i2
7773 ! Mode: 0 == constituents 1 == temp
7774  INTEGER, INTENT(IN) :: iv
7775 ! 2 == remap temp with cs scheme
7776 ! Method order
7777  INTEGER, INTENT(IN) :: kord
7778 ! Current latitude
7779  INTEGER, INTENT(IN) :: j
7780  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
7781 ! Original vertical dimension
7782  INTEGER, INTENT(IN) :: km
7783 ! Target vertical dimension
7784  INTEGER, INTENT(IN) :: kn
7785 ! bottom BC
7786  REAL, INTENT(IN) :: qs(i1:i2)
7787 ! pressure at layer edges
7788  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
7789  REAL, INTENT(IN) :: pe1_tl(i1:i2, km+1)
7790 ! (from model top to bottom surface)
7791 ! in the original vertical coordinate
7792 ! pressure at layer edges
7793  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
7794  REAL, INTENT(IN) :: pe2_tl(i1:i2, kn+1)
7795 ! (from model top to bottom surface)
7796 ! in the new vertical coordinate
7797 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
7798 ! !INPUT/OUTPUT PARAMETERS:
7799 ! Field output
7800  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
7801  REAL, INTENT(INOUT) :: q2_tl(ibeg:iend, jbeg:jend, kn)
7802  REAL, INTENT(IN) :: q_min
7803 ! !DESCRIPTION:
7804 ! IV = 0: constituents
7805 ! pe1: pressure at layer edges (from model top to bottom surface)
7806 ! in the original vertical coordinate
7807 ! pe2: pressure at layer edges (from model top to bottom surface)
7808 ! in the new vertical coordinate
7809 ! !LOCAL VARIABLES:
7810  REAL :: dp1(i1:i2, km)
7811  REAL :: dp1_tl(i1:i2, km)
7812  REAL :: q4(4, i1:i2, km)
7813  REAL :: q4_tl(4, i1:i2, km)
7814  REAL :: pl, pr, qsum, dp, esl
7815  REAL :: pl_tl, pr_tl, qsum_tl, dp_tl, esl_tl
7816  INTEGER :: i, k, l, m, k0
7817  dp1_tl = 0.0
7818  q4_tl = 0.0
7819  DO k=1,km
7820  DO i=i1,i2
7821  dp1_tl(i, k) = pe1_tl(i, k+1) - pe1_tl(i, k)
7822  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
7823  q4_tl(1, i, k) = q2_tl(i, j, k)
7824  q4(1, i, k) = q2(i, j, k)
7825  END DO
7826  END DO
7827 ! Compute vertical subgrid distribution
7828  IF (kord .GT. 7) THEN
7829  CALL scalar_profile_tlm(qs, q4, q4_tl, dp1, dp1_tl, km, i1, i2&
7830 & , iv, kord, q_min)
7831 !else
7832 ! call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
7833  qsum_tl = 0.0
7834  ELSE
7835  qsum_tl = 0.0
7836  END IF
7837  DO i=i1,i2
7838  k0 = 1
7839  DO 555 k=1,kn
7840  DO l=k0,km
7841 ! locate the top edge: pe2(i,k)
7842  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
7843 & ) GOTO 100
7844  END DO
7845  GOTO 123
7846  100 pl_tl = ((pe2_tl(i, k)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k)-pe1(i&
7847 & , l))*dp1_tl(i, l))/dp1(i, l)**2
7848  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
7849  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
7850 ! entire new grid is within the original grid
7851  pr_tl = ((pe2_tl(i, k+1)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k+1)-&
7852 & pe1(i, l))*dp1_tl(i, l))/dp1(i, l)**2
7853  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
7854  q2_tl(i, j, k) = q4_tl(2, i, l) + 0.5*((q4_tl(4, i, l)+q4_tl(3&
7855 & , i, l)-q4_tl(2, i, l))*(pr+pl)+(q4(4, i, l)+q4(3, i, l)-q4(&
7856 & 2, i, l))*(pr_tl+pl_tl)) - r3*(q4_tl(4, i, l)*(pr*(pr+pl)+pl&
7857 & **2)+q4(4, i, l)*(pr_tl*(pr+pl)+pr*(pr_tl+pl_tl)+2*pl*pl_tl)&
7858 & )
7859  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
7860 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
7861  k0 = l
7862  GOTO 555
7863  ELSE
7864 ! Fractional area...
7865  qsum_tl = (pe1_tl(i, l+1)-pe2_tl(i, k))*(q4(2, i, l)+0.5*(q4(4&
7866 & , i, l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.&
7867 & +pl*(1.+pl)))) + (pe1(i, l+1)-pe2(i, k))*(q4_tl(2, i, l)+0.5&
7868 & *((q4_tl(4, i, l)+q4_tl(3, i, l)-q4_tl(2, i, l))*(1.+pl)+(q4&
7869 & (4, i, l)+q4(3, i, l)-q4(2, i, l))*pl_tl)-r3*(q4_tl(4, i, l)&
7870 & *(1.+pl*(1.+pl))+q4(4, i, l)*(pl_tl*(1.+pl)+pl*pl_tl)))
7871  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
7872 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
7873 & pl))))
7874  DO m=l+1,km
7875 ! locate the bottom edge: pe2(i,k+1)
7876  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
7877 ! Whole layer
7878  qsum_tl = qsum_tl + dp1_tl(i, m)*q4(1, i, m) + dp1(i, m)*&
7879 & q4_tl(1, i, m)
7880  qsum = qsum + dp1(i, m)*q4(1, i, m)
7881  ELSE
7882  GOTO 110
7883  END IF
7884  END DO
7885  GOTO 123
7886  110 dp_tl = pe2_tl(i, k+1) - pe1_tl(i, m)
7887  dp = pe2(i, k+1) - pe1(i, m)
7888  esl_tl = (dp_tl*dp1(i, m)-dp*dp1_tl(i, m))/dp1(i, m)**2
7889  esl = dp/dp1(i, m)
7890  qsum_tl = qsum_tl + dp_tl*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4&
7891 & (2, i, m)+q4(4, i, m)*(1.-r23*esl))) + dp*(q4_tl(2, i, m)+&
7892 & 0.5*(esl_tl*(q4(3, i, m)-q4(2, i, m)+q4(4, i, m)*(1.-r23*esl&
7893 & ))+esl*(q4_tl(3, i, m)-q4_tl(2, i, m)+q4_tl(4, i, m)*(1.-r23&
7894 & *esl)-q4(4, i, m)*r23*esl_tl)))
7895  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
7896 & +q4(4, i, m)*(1.-r23*esl)))
7897  k0 = m
7898  END IF
7899  123 q2_tl(i, j, k) = (qsum_tl*(pe2(i, k+1)-pe2(i, k))-qsum*(pe2_tl(i&
7900 & , k+1)-pe2_tl(i, k)))/(pe2(i, k+1)-pe2(i, k))**2
7901  q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
7902  555 CONTINUE
7903  END DO
7904  END SUBROUTINE map_scalar_tlm
7905 !-----------------------------------------------------------------------
7906 ! Differentiation of map1_ppm in forward (tangent) mode:
7907 ! variations of useful results: q2
7908 ! with respect to varying inputs: pe1 pe2 qs q2
7909  SUBROUTINE map1_ppm_tlm(km, pe1, pe1_tl, qs, qs_tl, kn, pe2, pe2_tl&
7910 & , q2, q2_tl, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
7911  IMPLICIT NONE
7912 ! Starting longitude
7913  INTEGER, INTENT(IN) :: i1
7914 ! Finishing longitude
7915  INTEGER, INTENT(IN) :: i2
7916 ! Mode: 0 == constituents 1 == ???
7917  INTEGER, INTENT(IN) :: iv
7918 ! 2 == remap temp with cs scheme
7919 ! Method order
7920  INTEGER, INTENT(IN) :: kord
7921 ! Current latitude
7922  INTEGER, INTENT(IN) :: j
7923  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
7924 ! Original vertical dimension
7925  INTEGER, INTENT(IN) :: km
7926 ! Target vertical dimension
7927  INTEGER, INTENT(IN) :: kn
7928 ! bottom BC
7929  REAL, INTENT(IN) :: qs(i1:i2)
7930  REAL, INTENT(IN) :: qs_tl(i1:i2)
7931 ! pressure at layer edges
7932  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
7933  REAL, INTENT(IN) :: pe1_tl(i1:i2, km+1)
7934 ! (from model top to bottom surface)
7935 ! in the original vertical coordinate
7936 ! pressure at layer edges
7937  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
7938  REAL, INTENT(IN) :: pe2_tl(i1:i2, kn+1)
7939 ! (from model top to bottom surface)
7940 ! in the new vertical coordinate
7941 ! real, intent(in) :: q1(ibeg:iend,jbeg:jend,km) ! Field input
7942 ! !INPUT/OUTPUT PARAMETERS:
7943 ! Field output
7944  REAL, INTENT(INOUT) :: q2(ibeg:iend, jbeg:jend, kn)
7945  REAL, INTENT(INOUT) :: q2_tl(ibeg:iend, jbeg:jend, kn)
7946 ! !DESCRIPTION:
7947 ! IV = 0: constituents
7948 ! pe1: pressure at layer edges (from model top to bottom surface)
7949 ! in the original vertical coordinate
7950 ! pe2: pressure at layer edges (from model top to bottom surface)
7951 ! in the new vertical coordinate
7952 ! !LOCAL VARIABLES:
7953  REAL :: dp1(i1:i2, km)
7954  REAL :: dp1_tl(i1:i2, km)
7955  REAL :: q4(4, i1:i2, km)
7956  REAL :: q4_tl(4, i1:i2, km)
7957  REAL :: pl, pr, qsum, dp, esl
7958  REAL :: pl_tl, pr_tl, qsum_tl, dp_tl, esl_tl
7959  INTEGER :: i, k, l, m, k0
7960  dp1_tl = 0.0
7961  q4_tl = 0.0
7962  DO k=1,km
7963  DO i=i1,i2
7964  dp1_tl(i, k) = pe1_tl(i, k+1) - pe1_tl(i, k)
7965  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
7966  q4_tl(1, i, k) = q2_tl(i, j, k)
7967  q4(1, i, k) = q2(i, j, k)
7968  END DO
7969  END DO
7970 ! Compute vertical subgrid distribution
7971  IF (kord .GT. 7) THEN
7972  CALL cs_profile_tlm(qs, qs_tl, q4, q4_tl, dp1, dp1_tl, km, i1, &
7973 & i2, iv, kord)
7974 !else
7975 ! call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
7976  qsum_tl = 0.0
7977  ELSE
7978  qsum_tl = 0.0
7979  END IF
7980  DO i=i1,i2
7981  k0 = 1
7982  DO 555 k=1,kn
7983  DO l=k0,km
7984 ! locate the top edge: pe2(i,k)
7985  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
7986 & ) GOTO 100
7987  END DO
7988  GOTO 123
7989  100 pl_tl = ((pe2_tl(i, k)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k)-pe1(i&
7990 & , l))*dp1_tl(i, l))/dp1(i, l)**2
7991  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
7992  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
7993 ! entire new grid is within the original grid
7994  pr_tl = ((pe2_tl(i, k+1)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k+1)-&
7995 & pe1(i, l))*dp1_tl(i, l))/dp1(i, l)**2
7996  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
7997  q2_tl(i, j, k) = q4_tl(2, i, l) + 0.5*((q4_tl(4, i, l)+q4_tl(3&
7998 & , i, l)-q4_tl(2, i, l))*(pr+pl)+(q4(4, i, l)+q4(3, i, l)-q4(&
7999 & 2, i, l))*(pr_tl+pl_tl)) - r3*(q4_tl(4, i, l)*(pr*(pr+pl)+pl&
8000 & **2)+q4(4, i, l)*(pr_tl*(pr+pl)+pr*(pr_tl+pl_tl)+2*pl*pl_tl)&
8001 & )
8002  q2(i, j, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2&
8003 & , i, l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
8004  k0 = l
8005  GOTO 555
8006  ELSE
8007 ! Fractional area...
8008  qsum_tl = (pe1_tl(i, l+1)-pe2_tl(i, k))*(q4(2, i, l)+0.5*(q4(4&
8009 & , i, l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.&
8010 & +pl*(1.+pl)))) + (pe1(i, l+1)-pe2(i, k))*(q4_tl(2, i, l)+0.5&
8011 & *((q4_tl(4, i, l)+q4_tl(3, i, l)-q4_tl(2, i, l))*(1.+pl)+(q4&
8012 & (4, i, l)+q4(3, i, l)-q4(2, i, l))*pl_tl)-r3*(q4_tl(4, i, l)&
8013 & *(1.+pl*(1.+pl))+q4(4, i, l)*(pl_tl*(1.+pl)+pl*pl_tl)))
8014  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
8015 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
8016 & pl))))
8017  DO m=l+1,km
8018 ! locate the bottom edge: pe2(i,k+1)
8019  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
8020 ! Whole layer
8021  qsum_tl = qsum_tl + dp1_tl(i, m)*q4(1, i, m) + dp1(i, m)*&
8022 & q4_tl(1, i, m)
8023  qsum = qsum + dp1(i, m)*q4(1, i, m)
8024  ELSE
8025  GOTO 110
8026  END IF
8027  END DO
8028  GOTO 123
8029  110 dp_tl = pe2_tl(i, k+1) - pe1_tl(i, m)
8030  dp = pe2(i, k+1) - pe1(i, m)
8031  esl_tl = (dp_tl*dp1(i, m)-dp*dp1_tl(i, m))/dp1(i, m)**2
8032  esl = dp/dp1(i, m)
8033  qsum_tl = qsum_tl + dp_tl*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4&
8034 & (2, i, m)+q4(4, i, m)*(1.-r23*esl))) + dp*(q4_tl(2, i, m)+&
8035 & 0.5*(esl_tl*(q4(3, i, m)-q4(2, i, m)+q4(4, i, m)*(1.-r23*esl&
8036 & ))+esl*(q4_tl(3, i, m)-q4_tl(2, i, m)+q4_tl(4, i, m)*(1.-r23&
8037 & *esl)-q4(4, i, m)*r23*esl_tl)))
8038  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
8039 & +q4(4, i, m)*(1.-r23*esl)))
8040  k0 = m
8041  END IF
8042  123 q2_tl(i, j, k) = (qsum_tl*(pe2(i, k+1)-pe2(i, k))-qsum*(pe2_tl(i&
8043 & , k+1)-pe2_tl(i, k)))/(pe2(i, k+1)-pe2(i, k))**2
8044  q2(i, j, k) = qsum/(pe2(i, k+1)-pe2(i, k))
8045  555 CONTINUE
8046  END DO
8047  END SUBROUTINE map1_ppm_tlm
8048 ! Differentiation of mapn_tracer in forward (tangent) mode:
8049 ! variations of useful results: q1
8050 ! with respect to varying inputs: pe1 pe2 dp2 q1
8051  SUBROUTINE mapn_tracer_tlm(nq, km, pe1, pe1_tl, pe2, pe2_tl, q1, &
8052 & q1_tl, dp2, dp2_tl, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill&
8053 & )
8054  IMPLICIT NONE
8055 ! !INPUT PARAMETERS:
8056 ! vertical dimension
8057  INTEGER, INTENT(IN) :: km
8058  INTEGER, INTENT(IN) :: j, nq, i1, i2
8059  INTEGER, INTENT(IN) :: isd, ied, jsd, jed
8060  INTEGER, INTENT(IN) :: kord(nq)
8061 ! pressure at layer edges
8062  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
8063  REAL, INTENT(IN) :: pe1_tl(i1:i2, km+1)
8064 ! (from model top to bottom surface)
8065 ! in the original vertical coordinate
8066 ! pressure at layer edges
8067  REAL, INTENT(IN) :: pe2(i1:i2, km+1)
8068  REAL, INTENT(IN) :: pe2_tl(i1:i2, km+1)
8069 ! (from model top to bottom surface)
8070 ! in the new vertical coordinate
8071  REAL, INTENT(IN) :: dp2(i1:i2, km)
8072  REAL, INTENT(IN) :: dp2_tl(i1:i2, km)
8073  REAL, INTENT(IN) :: q_min
8074  LOGICAL, INTENT(IN) :: fill
8075 ! Field input
8076  REAL, INTENT(INOUT) :: q1(isd:ied, jsd:jed, km, nq)
8077  REAL, INTENT(INOUT) :: q1_tl(isd:ied, jsd:jed, km, nq)
8078 ! !LOCAL VARIABLES:
8079  REAL :: q4(4, i1:i2, km, nq)
8080  REAL :: q4_tl(4, i1:i2, km, nq)
8081 ! Field output
8082  REAL :: q2(i1:i2, km, nq)
8083  REAL :: q2_tl(i1:i2, km, nq)
8084  REAL :: qsum(nq)
8085  REAL :: qsum_tl(nq)
8086  REAL :: dp1(i1:i2, km)
8087  REAL :: dp1_tl(i1:i2, km)
8088  REAL :: qs(i1:i2)
8089  REAL :: pl, pr, dp, esl, fac1, fac2
8090  REAL :: pl_tl, pr_tl, dp_tl, esl_tl, fac1_tl, fac2_tl
8091  INTEGER :: i, k, l, m, k0, iq
8092  dp1_tl = 0.0
8093  DO k=1,km
8094  DO i=i1,i2
8095  dp1_tl(i, k) = pe1_tl(i, k+1) - pe1_tl(i, k)
8096  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
8097  END DO
8098  END DO
8099  q4_tl = 0.0
8100  DO iq=1,nq
8101  DO k=1,km
8102  DO i=i1,i2
8103  q4_tl(1, i, k, iq) = q1_tl(i, j, k, iq)
8104  q4(1, i, k, iq) = q1(i, j, k, iq)
8105  END DO
8106  END DO
8107  CALL scalar_profile_tlm(qs, q4(1:4, i1:i2, 1:km, iq), q4_tl(1:4&
8108 & , i1:i2, 1:km, iq), dp1, dp1_tl, km, i1, i2, &
8109 & 0, kord(iq), q_min)
8110  END DO
8111  qsum_tl = 0.0
8112  q2_tl = 0.0
8113 ! Mapping
8114  DO i=i1,i2
8115  k0 = 1
8116  DO 555 k=1,km
8117  DO l=k0,km
8118 ! locate the top edge: pe2(i,k)
8119  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
8120 & ) GOTO 110
8121  END DO
8122  GOTO 123
8123  110 pl_tl = ((pe2_tl(i, k)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k)-pe1(i&
8124 & , l))*dp1_tl(i, l))/dp1(i, l)**2
8125  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
8126  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
8127 ! entire new grid is within the original grid
8128  pr_tl = ((pe2_tl(i, k+1)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k+1)-&
8129 & pe1(i, l))*dp1_tl(i, l))/dp1(i, l)**2
8130  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
8131  fac1_tl = pr_tl + pl_tl
8132  fac1 = pr + pl
8133  fac2_tl = r3*(pr_tl*fac1+pr*fac1_tl+pl_tl*pl+pl*pl_tl)
8134  fac2 = r3*(pr*fac1+pl*pl)
8135  fac1_tl = 0.5*fac1_tl
8136  fac1 = 0.5*fac1
8137  DO iq=1,nq
8138  q2_tl(i, k, iq) = q4_tl(2, i, l, iq) + (q4_tl(4, i, l, iq)+&
8139 & q4_tl(3, i, l, iq)-q4_tl(2, i, l, iq))*fac1 + (q4(4, i, l&
8140 & , iq)+q4(3, i, l, iq)-q4(2, i, l, iq))*fac1_tl - q4_tl(4, &
8141 & i, l, iq)*fac2 - q4(4, i, l, iq)*fac2_tl
8142  q2(i, k, iq) = q4(2, i, l, iq) + (q4(4, i, l, iq)+q4(3, i, l&
8143 & , iq)-q4(2, i, l, iq))*fac1 - q4(4, i, l, iq)*fac2
8144  END DO
8145  k0 = l
8146  GOTO 555
8147  ELSE
8148 ! Fractional area...
8149  dp_tl = pe1_tl(i, l+1) - pe2_tl(i, k)
8150  dp = pe1(i, l+1) - pe2(i, k)
8151  fac1_tl = pl_tl
8152  fac1 = 1. + pl
8153  fac2_tl = r3*(pl_tl*fac1+pl*fac1_tl)
8154  fac2 = r3*(1.+pl*fac1)
8155  fac1_tl = 0.5*fac1_tl
8156  fac1 = 0.5*fac1
8157  DO iq=1,nq
8158  qsum_tl(iq) = dp_tl*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, &
8159 & i, l, iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2) + dp&
8160 & *(q4_tl(2, i, l, iq)+(q4_tl(4, i, l, iq)+q4_tl(3, i, l, iq&
8161 & )-q4_tl(2, i, l, iq))*fac1+(q4(4, i, l, iq)+q4(3, i, l, iq&
8162 & )-q4(2, i, l, iq))*fac1_tl-q4_tl(4, i, l, iq)*fac2-q4(4, i&
8163 & , l, iq)*fac2_tl)
8164  qsum(iq) = dp*(q4(2, i, l, iq)+(q4(4, i, l, iq)+q4(3, i, l, &
8165 & iq)-q4(2, i, l, iq))*fac1-q4(4, i, l, iq)*fac2)
8166  END DO
8167  DO m=l+1,km
8168 ! locate the bottom edge: pe2(i,k+1)
8169  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
8170 ! Whole layer..
8171  DO iq=1,nq
8172  qsum_tl(iq) = qsum_tl(iq) + dp1_tl(i, m)*q4(1, i, m, iq)&
8173 & + dp1(i, m)*q4_tl(1, i, m, iq)
8174  qsum(iq) = qsum(iq) + dp1(i, m)*q4(1, i, m, iq)
8175  END DO
8176  ELSE
8177  GOTO 120
8178  END IF
8179  END DO
8180  GOTO 123
8181  120 dp_tl = pe2_tl(i, k+1) - pe1_tl(i, m)
8182  dp = pe2(i, k+1) - pe1(i, m)
8183  esl_tl = (dp_tl*dp1(i, m)-dp*dp1_tl(i, m))/dp1(i, m)**2
8184  esl = dp/dp1(i, m)
8185  fac1_tl = 0.5*esl_tl
8186  fac1 = 0.5*esl
8187  fac2_tl = -(r23*esl_tl)
8188  fac2 = 1. - r23*esl
8189  DO iq=1,nq
8190  qsum_tl(iq) = qsum_tl(iq) + dp_tl*(q4(2, i, m, iq)+fac1*(q4(&
8191 & 3, i, m, iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2)) + dp*(&
8192 & q4_tl(2, i, m, iq)+fac1_tl*(q4(3, i, m, iq)-q4(2, i, m, iq&
8193 & )+q4(4, i, m, iq)*fac2)+fac1*(q4_tl(3, i, m, iq)-q4_tl(2, &
8194 & i, m, iq)+q4_tl(4, i, m, iq)*fac2+q4(4, i, m, iq)*fac2_tl)&
8195 & )
8196  qsum(iq) = qsum(iq) + dp*(q4(2, i, m, iq)+fac1*(q4(3, i, m, &
8197 & iq)-q4(2, i, m, iq)+q4(4, i, m, iq)*fac2))
8198  END DO
8199  k0 = m
8200  END IF
8201  123 DO iq=1,nq
8202  q2_tl(i, k, iq) = (qsum_tl(iq)*dp2(i, k)-qsum(iq)*dp2_tl(i, k)&
8203 & )/dp2(i, k)**2
8204  q2(i, k, iq) = qsum(iq)/dp2(i, k)
8205  END DO
8206  555 CONTINUE
8207  END DO
8208  IF (fill) CALL fillz(i2 - i1 + 1, km, nq, q2, dp2)
8209  DO iq=1,nq
8210 ! if (fill) call fillz(i2-i1+1, km, 1, q2(i1,1,iq), dp2)
8211  DO k=1,km
8212  DO i=i1,i2
8213  q1_tl(i, j, k, iq) = q2_tl(i, k, iq)
8214  q1(i, j, k, iq) = q2(i, k, iq)
8215  END DO
8216  END DO
8217  END DO
8218  END SUBROUTINE mapn_tracer_tlm
8219 ! Differentiation of map1_q2 in forward (tangent) mode:
8220 ! variations of useful results: q2
8221 ! with respect to varying inputs: pe1 pe2 dp2 q1 q2
8222  SUBROUTINE map1_q2_tlm(km, pe1, pe1_tl, q1, q1_tl, kn, pe2, pe2_tl&
8223 & , q2, q2_tl, dp2, dp2_tl, i1, i2, iv, kord, j, ibeg, iend, jbeg, &
8224 & jend, q_min)
8225  IMPLICIT NONE
8226 ! !INPUT PARAMETERS:
8227  INTEGER, INTENT(IN) :: j
8228  INTEGER, INTENT(IN) :: i1, i2
8229  INTEGER, INTENT(IN) :: ibeg, iend, jbeg, jend
8230 ! Mode: 0 == constituents 1 == ???
8231  INTEGER, INTENT(IN) :: iv
8232  INTEGER, INTENT(IN) :: kord
8233 ! Original vertical dimension
8234  INTEGER, INTENT(IN) :: km
8235 ! Target vertical dimension
8236  INTEGER, INTENT(IN) :: kn
8237 ! pressure at layer edges
8238  REAL, INTENT(IN) :: pe1(i1:i2, km+1)
8239  REAL, INTENT(IN) :: pe1_tl(i1:i2, km+1)
8240 ! (from model top to bottom surface)
8241 ! in the original vertical coordinate
8242 ! pressure at layer edges
8243  REAL, INTENT(IN) :: pe2(i1:i2, kn+1)
8244  REAL, INTENT(IN) :: pe2_tl(i1:i2, kn+1)
8245 ! (from model top to bottom surface)
8246 ! in the new vertical coordinate
8247 ! Field input
8248  REAL, INTENT(IN) :: q1(ibeg:iend, jbeg:jend, km)
8249  REAL, INTENT(IN) :: q1_tl(ibeg:iend, jbeg:jend, km)
8250  REAL, INTENT(IN) :: dp2(i1:i2, kn)
8251  REAL, INTENT(IN) :: dp2_tl(i1:i2, kn)
8252  REAL, INTENT(IN) :: q_min
8253 ! !INPUT/OUTPUT PARAMETERS:
8254 ! Field output
8255  REAL, INTENT(INOUT) :: q2(i1:i2, kn)
8256  REAL, INTENT(INOUT) :: q2_tl(i1:i2, kn)
8257 ! !LOCAL VARIABLES:
8258  REAL :: qs(i1:i2)
8259  REAL :: dp1(i1:i2, km)
8260  REAL :: dp1_tl(i1:i2, km)
8261  REAL :: q4(4, i1:i2, km)
8262  REAL :: q4_tl(4, i1:i2, km)
8263  REAL :: pl, pr, qsum, dp, esl
8264  REAL :: pl_tl, pr_tl, qsum_tl, dp_tl, esl_tl
8265  INTEGER :: i, k, l, m, k0
8266  dp1_tl = 0.0
8267  q4_tl = 0.0
8268  DO k=1,km
8269  DO i=i1,i2
8270  dp1_tl(i, k) = pe1_tl(i, k+1) - pe1_tl(i, k)
8271  dp1(i, k) = pe1(i, k+1) - pe1(i, k)
8272  q4_tl(1, i, k) = q1_tl(i, j, k)
8273  q4(1, i, k) = q1(i, j, k)
8274  END DO
8275  END DO
8276 ! Compute vertical subgrid distribution
8277  IF (kord .GT. 7) THEN
8278  CALL scalar_profile_tlm(qs, q4, q4_tl, dp1, dp1_tl, km, i1, i2&
8279 & , iv, kord, q_min)
8280 !else
8281 !call ppm_profile( q4, dp1, km, i1, i2, iv, kord )
8282  qsum_tl = 0.0
8283  ELSE
8284  qsum_tl = 0.0
8285  END IF
8286 ! Mapping
8287  DO i=i1,i2
8288  k0 = 1
8289  DO 555 k=1,kn
8290  DO l=k0,km
8291 ! locate the top edge: pe2(i,k)
8292  IF (pe2(i, k) .GE. pe1(i, l) .AND. pe2(i, k) .LE. pe1(i, l+1)&
8293 & ) GOTO 110
8294  END DO
8295  GOTO 123
8296  110 pl_tl = ((pe2_tl(i, k)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k)-pe1(i&
8297 & , l))*dp1_tl(i, l))/dp1(i, l)**2
8298  pl = (pe2(i, k)-pe1(i, l))/dp1(i, l)
8299  IF (pe2(i, k+1) .LE. pe1(i, l+1)) THEN
8300 ! entire new grid is within the original grid
8301  pr_tl = ((pe2_tl(i, k+1)-pe1_tl(i, l))*dp1(i, l)-(pe2(i, k+1)-&
8302 & pe1(i, l))*dp1_tl(i, l))/dp1(i, l)**2
8303  pr = (pe2(i, k+1)-pe1(i, l))/dp1(i, l)
8304  q2_tl(i, k) = q4_tl(2, i, l) + 0.5*((q4_tl(4, i, l)+q4_tl(3, i&
8305 & , l)-q4_tl(2, i, l))*(pr+pl)+(q4(4, i, l)+q4(3, i, l)-q4(2, &
8306 & i, l))*(pr_tl+pl_tl)) - r3*(q4_tl(4, i, l)*(pr*(pr+pl)+pl**2&
8307 & )+q4(4, i, l)*(pr_tl*(pr+pl)+pr*(pr_tl+pl_tl)+2*pl*pl_tl))
8308  q2(i, k) = q4(2, i, l) + 0.5*(q4(4, i, l)+q4(3, i, l)-q4(2, i&
8309 & , l))*(pr+pl) - q4(4, i, l)*r3*(pr*(pr+pl)+pl**2)
8310  k0 = l
8311  GOTO 555
8312  ELSE
8313 ! Fractional area...
8314  qsum_tl = (pe1_tl(i, l+1)-pe2_tl(i, k))*(q4(2, i, l)+0.5*(q4(4&
8315 & , i, l)+q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.&
8316 & +pl*(1.+pl)))) + (pe1(i, l+1)-pe2(i, k))*(q4_tl(2, i, l)+0.5&
8317 & *((q4_tl(4, i, l)+q4_tl(3, i, l)-q4_tl(2, i, l))*(1.+pl)+(q4&
8318 & (4, i, l)+q4(3, i, l)-q4(2, i, l))*pl_tl)-r3*(q4_tl(4, i, l)&
8319 & *(1.+pl*(1.+pl))+q4(4, i, l)*(pl_tl*(1.+pl)+pl*pl_tl)))
8320  qsum = (pe1(i, l+1)-pe2(i, k))*(q4(2, i, l)+0.5*(q4(4, i, l)+&
8321 & q4(3, i, l)-q4(2, i, l))*(1.+pl)-q4(4, i, l)*(r3*(1.+pl*(1.+&
8322 & pl))))
8323  DO m=l+1,km
8324 ! locate the bottom edge: pe2(i,k+1)
8325  IF (pe2(i, k+1) .GT. pe1(i, m+1)) THEN
8326 ! Whole layer..
8327  qsum_tl = qsum_tl + dp1_tl(i, m)*q4(1, i, m) + dp1(i, m)*&
8328 & q4_tl(1, i, m)
8329  qsum = qsum + dp1(i, m)*q4(1, i, m)
8330  ELSE
8331  GOTO 120
8332  END IF
8333  END DO
8334  GOTO 123
8335  120 dp_tl = pe2_tl(i, k+1) - pe1_tl(i, m)
8336  dp = pe2(i, k+1) - pe1(i, m)
8337  esl_tl = (dp_tl*dp1(i, m)-dp*dp1_tl(i, m))/dp1(i, m)**2
8338  esl = dp/dp1(i, m)
8339  qsum_tl = qsum_tl + dp_tl*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4&
8340 & (2, i, m)+q4(4, i, m)*(1.-r23*esl))) + dp*(q4_tl(2, i, m)+&
8341 & 0.5*(esl_tl*(q4(3, i, m)-q4(2, i, m)+q4(4, i, m)*(1.-r23*esl&
8342 & ))+esl*(q4_tl(3, i, m)-q4_tl(2, i, m)+q4_tl(4, i, m)*(1.-r23&
8343 & *esl)-q4(4, i, m)*r23*esl_tl)))
8344  qsum = qsum + dp*(q4(2, i, m)+0.5*esl*(q4(3, i, m)-q4(2, i, m)&
8345 & +q4(4, i, m)*(1.-r23*esl)))
8346  k0 = m
8347  END IF
8348  123 q2_tl(i, k) = (qsum_tl*dp2(i, k)-qsum*dp2_tl(i, k))/dp2(i, k)**2
8349  q2(i, k) = qsum/dp2(i, k)
8350  555 CONTINUE
8351  END DO
8352  END SUBROUTINE map1_q2_tlm
8353 ! Differentiation of scalar_profile in forward (tangent) mode:
8354 ! variations of useful results: a4
8355 ! with respect to varying inputs: delp a4
8356  SUBROUTINE scalar_profile_tlm(qs, a4, a4_tl, delp, delp_tl, km, i1&
8357 & , i2, iv, kord, qmin)
8358  IMPLICIT NONE
8359 ! Optimized vertical profile reconstruction:
8360 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
8361  INTEGER, INTENT(IN) :: i1, i2
8362 ! vertical dimension
8363  INTEGER, INTENT(IN) :: km
8364 ! iv =-1: winds
8365  INTEGER, INTENT(IN) :: iv
8366 ! iv = 0: positive definite scalars
8367 ! iv = 1: others
8368  INTEGER, INTENT(IN) :: kord
8369  REAL, INTENT(IN) :: qs(i1:i2)
8370 ! layer pressure thickness
8371  REAL, INTENT(IN) :: delp(i1:i2, km)
8372  REAL, INTENT(IN) :: delp_tl(i1:i2, km)
8373 ! Interpolated values
8374  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
8375  REAL, INTENT(INOUT) :: a4_tl(4, i1:i2, km)
8376  REAL, INTENT(IN) :: qmin
8377 !-----------------------------------------------------------------------
8378  LOGICAL, DIMENSION(i1:i2, km) :: extm, ext6
8379  REAL :: gam(i1:i2, km)
8380  REAL :: gam_tl(i1:i2, km)
8381  REAL :: q(i1:i2, km+1)
8382  REAL :: q_tl(i1:i2, km+1)
8383  REAL :: d4(i1:i2)
8384  REAL :: d4_tl(i1:i2)
8385  REAL :: bet, a_bot, grat
8386  REAL :: bet_tl, a_bot_tl, grat_tl
8387  REAL :: pmp_1, lac_1, pmp_2, lac_2
8388  INTEGER :: i, k, im
8389  INTRINSIC abs
8390  INTEGER :: abs0
8391  IF (iv .EQ. -2) THEN
8392  q_tl = 0.0
8393  DO i=i1,i2
8394  gam(i, 2) = 0.5
8395  q_tl(i, 1) = 1.5*a4_tl(1, i, 1)
8396  q(i, 1) = 1.5*a4(1, i, 1)
8397  END DO
8398  gam_tl = 0.0
8399  DO k=2,km-1
8400  DO i=i1,i2
8401  grat_tl = (delp_tl(i, k-1)*delp(i, k)-delp(i, k-1)*delp_tl(i, &
8402 & k))/delp(i, k)**2
8403  grat = delp(i, k-1)/delp(i, k)
8404  bet_tl = 2*grat_tl - gam_tl(i, k)
8405  bet = 2. + grat + grat - gam(i, k)
8406  q_tl(i, k) = ((3.*(a4_tl(1, i, k-1)+a4_tl(1, i, k))-q_tl(i, k-&
8407 & 1))*bet-(3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*bet_tl)/&
8408 & bet**2
8409  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
8410  gam_tl(i, k+1) = (grat_tl*bet-grat*bet_tl)/bet**2
8411  gam(i, k+1) = grat/bet
8412  END DO
8413  END DO
8414  DO i=i1,i2
8415  grat_tl = (delp_tl(i, km-1)*delp(i, km)-delp(i, km-1)*delp_tl(i&
8416 & , km))/delp(i, km)**2
8417  grat = delp(i, km-1)/delp(i, km)
8418  q_tl(i, km) = ((3.*(a4_tl(1, i, km-1)+a4_tl(1, i, km))-qs(i)*&
8419 & grat_tl-q_tl(i, km-1))*(2.+grat+grat-gam(i, km))-(3.*(a4(1, i&
8420 & , km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-1))*(2*grat_tl-gam_tl&
8421 & (i, km)))/(2.+grat+grat-gam(i, km))**2
8422  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
8423 & 1))/(2.+grat+grat-gam(i, km))
8424  q_tl(i, km+1) = 0.0
8425  q(i, km+1) = qs(i)
8426  END DO
8427  DO k=km-1,1,-1
8428  DO i=i1,i2
8429  q_tl(i, k) = q_tl(i, k) - gam_tl(i, k+1)*q(i, k+1) - gam(i, k+&
8430 & 1)*q_tl(i, k+1)
8431  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
8432  END DO
8433  END DO
8434  ELSE
8435  q_tl = 0.0
8436  gam_tl = 0.0
8437  DO i=i1,i2
8438 ! grid ratio
8439  grat_tl = (delp_tl(i, 2)*delp(i, 1)-delp(i, 2)*delp_tl(i, 1))/&
8440 & delp(i, 1)**2
8441  grat = delp(i, 2)/delp(i, 1)
8442  bet_tl = grat_tl*(grat+0.5) + grat*grat_tl
8443  bet = grat*(grat+0.5)
8444  q_tl(i, 1) = (((2*grat_tl*(grat+1.)+(grat+grat)*grat_tl)*a4(1, i&
8445 & , 1)+(grat+grat)*(grat+1.)*a4_tl(1, i, 1)+a4_tl(1, i, 2))*bet-&
8446 & ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))*bet_tl)/bet**2
8447  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
8448  gam_tl(i, 1) = ((grat_tl*(grat+1.5)+grat*grat_tl)*bet-(1.+grat*(&
8449 & grat+1.5))*bet_tl)/bet**2
8450  gam(i, 1) = (1.+grat*(grat+1.5))/bet
8451  END DO
8452  d4_tl = 0.0
8453  DO k=2,km
8454  DO i=i1,i2
8455  d4_tl(i) = (delp_tl(i, k-1)*delp(i, k)-delp(i, k-1)*delp_tl(i&
8456 & , k))/delp(i, k)**2
8457  d4(i) = delp(i, k-1)/delp(i, k)
8458  bet_tl = 2*d4_tl(i) - gam_tl(i, k-1)
8459  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
8460  q_tl(i, k) = ((3.*(a4_tl(1, i, k-1)+d4_tl(i)*a4(1, i, k)+d4(i)&
8461 & *a4_tl(1, i, k))-q_tl(i, k-1))*bet-(3.*(a4(1, i, k-1)+d4(i)*&
8462 & a4(1, i, k))-q(i, k-1))*bet_tl)/bet**2
8463  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
8464  gam_tl(i, k) = (d4_tl(i)*bet-d4(i)*bet_tl)/bet**2
8465  gam(i, k) = d4(i)/bet
8466  END DO
8467  END DO
8468  DO i=i1,i2
8469  a_bot_tl = d4_tl(i)*(d4(i)+1.5) + d4(i)*d4_tl(i)
8470  a_bot = 1. + d4(i)*(d4(i)+1.5)
8471  q_tl(i, km+1) = ((2.*((d4_tl(i)*(d4(i)+1.)+d4(i)*d4_tl(i))*a4(1&
8472 & , i, km)+d4(i)*(d4(i)+1.)*a4_tl(1, i, km))+a4_tl(1, i, km-1)-&
8473 & a_bot_tl*q(i, km)-a_bot*q_tl(i, km))*(d4(i)*(d4(i)+0.5)-a_bot*&
8474 & gam(i, km))-(2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
8475 & a_bot*q(i, km))*(d4_tl(i)*(d4(i)+0.5)+d4(i)*d4_tl(i)-a_bot_tl*&
8476 & gam(i, km)-a_bot*gam_tl(i, km)))/(d4(i)*(d4(i)+0.5)-a_bot*gam(&
8477 & i, km))**2
8478  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
8479 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
8480  END DO
8481  DO k=km,1,-1
8482  DO i=i1,i2
8483  q_tl(i, k) = q_tl(i, k) - gam_tl(i, k)*q(i, k+1) - gam(i, k)*&
8484 & q_tl(i, k+1)
8485  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
8486  END DO
8487  END DO
8488  END IF
8489  IF (kord .GE. 0.) THEN
8490  abs0 = kord
8491  ELSE
8492  abs0 = -kord
8493  END IF
8494 !----- Perfectly linear scheme --------------------------------
8495  IF (abs0 .GT. 16) THEN
8496  DO k=1,km
8497  DO i=i1,i2
8498  a4_tl(2, i, k) = q_tl(i, k)
8499  a4(2, i, k) = q(i, k)
8500  a4_tl(3, i, k) = q_tl(i, k+1)
8501  a4(3, i, k) = q(i, k+1)
8502  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(3&
8503 & , i, k))
8504  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
8505  END DO
8506  END DO
8507  RETURN
8508  END IF
8509  END SUBROUTINE scalar_profile_tlm
8510 ! Differentiation of cs_profile in forward (tangent) mode:
8511 ! variations of useful results: a4
8512 ! with respect to varying inputs: qs delp a4
8513  SUBROUTINE cs_profile_tlm(qs, qs_tl, a4, a4_tl, delp, delp_tl, km, &
8514 & i1, i2, iv, kord)
8515  IMPLICIT NONE
8516 !----- Perfectly linear scheme --------------------------------
8517 ! Optimized vertical profile reconstruction:
8518 ! Latest: Apr 2008 S.-J. Lin, NOAA/GFDL
8519  INTEGER, INTENT(IN) :: i1, i2
8520 ! vertical dimension
8521  INTEGER, INTENT(IN) :: km
8522 ! iv =-1: winds
8523  INTEGER, INTENT(IN) :: iv
8524 ! iv = 0: positive definite scalars
8525 ! iv = 1: others
8526  INTEGER, INTENT(IN) :: kord
8527  REAL, INTENT(IN) :: qs(i1:i2)
8528  REAL, INTENT(IN) :: qs_tl(i1:i2)
8529 ! layer pressure thickness
8530  REAL, INTENT(IN) :: delp(i1:i2, km)
8531  REAL, INTENT(IN) :: delp_tl(i1:i2, km)
8532 ! Interpolated values
8533  REAL, INTENT(INOUT) :: a4(4, i1:i2, km)
8534  REAL, INTENT(INOUT) :: a4_tl(4, i1:i2, km)
8535 !-----------------------------------------------------------------------
8536  LOGICAL :: extm(i1:i2, km)
8537  REAL :: gam(i1:i2, km)
8538  REAL :: gam_tl(i1:i2, km)
8539  REAL :: q(i1:i2, km+1)
8540  REAL :: q_tl(i1:i2, km+1)
8541  REAL :: d4(i1:i2)
8542  REAL :: d4_tl(i1:i2)
8543  REAL :: bet, a_bot, grat
8544  REAL :: bet_tl, a_bot_tl, grat_tl
8545  REAL :: pmp_1, lac_1, pmp_2, lac_2
8546  INTEGER :: i, k, im
8547  INTRINSIC abs
8548  INTEGER :: abs0
8549  IF (iv .EQ. -2) THEN
8550  q_tl = 0.0
8551  DO i=i1,i2
8552  gam(i, 2) = 0.5
8553  q_tl(i, 1) = 1.5*a4_tl(1, i, 1)
8554  q(i, 1) = 1.5*a4(1, i, 1)
8555  END DO
8556  gam_tl = 0.0
8557  DO k=2,km-1
8558  DO i=i1,i2
8559  grat_tl = (delp_tl(i, k-1)*delp(i, k)-delp(i, k-1)*delp_tl(i, &
8560 & k))/delp(i, k)**2
8561  grat = delp(i, k-1)/delp(i, k)
8562  bet_tl = 2*grat_tl - gam_tl(i, k)
8563  bet = 2. + grat + grat - gam(i, k)
8564  q_tl(i, k) = ((3.*(a4_tl(1, i, k-1)+a4_tl(1, i, k))-q_tl(i, k-&
8565 & 1))*bet-(3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))*bet_tl)/&
8566 & bet**2
8567  q(i, k) = (3.*(a4(1, i, k-1)+a4(1, i, k))-q(i, k-1))/bet
8568  gam_tl(i, k+1) = (grat_tl*bet-grat*bet_tl)/bet**2
8569  gam(i, k+1) = grat/bet
8570  END DO
8571  END DO
8572  DO i=i1,i2
8573  grat_tl = (delp_tl(i, km-1)*delp(i, km)-delp(i, km-1)*delp_tl(i&
8574 & , km))/delp(i, km)**2
8575  grat = delp(i, km-1)/delp(i, km)
8576  q_tl(i, km) = ((3.*(a4_tl(1, i, km-1)+a4_tl(1, i, km))-grat_tl*&
8577 & qs(i)-grat*qs_tl(i)-q_tl(i, km-1))*(2.+grat+grat-gam(i, km))-(&
8578 & 3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-1))*(2*&
8579 & grat_tl-gam_tl(i, km)))/(2.+grat+grat-gam(i, km))**2
8580  q(i, km) = (3.*(a4(1, i, km-1)+a4(1, i, km))-grat*qs(i)-q(i, km-&
8581 & 1))/(2.+grat+grat-gam(i, km))
8582  q_tl(i, km+1) = qs_tl(i)
8583  q(i, km+1) = qs(i)
8584  END DO
8585  DO k=km-1,1,-1
8586  DO i=i1,i2
8587  q_tl(i, k) = q_tl(i, k) - gam_tl(i, k+1)*q(i, k+1) - gam(i, k+&
8588 & 1)*q_tl(i, k+1)
8589  q(i, k) = q(i, k) - gam(i, k+1)*q(i, k+1)
8590  END DO
8591  END DO
8592  ELSE
8593  q_tl = 0.0
8594  gam_tl = 0.0
8595  DO i=i1,i2
8596 ! grid ratio
8597  grat_tl = (delp_tl(i, 2)*delp(i, 1)-delp(i, 2)*delp_tl(i, 1))/&
8598 & delp(i, 1)**2
8599  grat = delp(i, 2)/delp(i, 1)
8600  bet_tl = grat_tl*(grat+0.5) + grat*grat_tl
8601  bet = grat*(grat+0.5)
8602  q_tl(i, 1) = (((2*grat_tl*(grat+1.)+(grat+grat)*grat_tl)*a4(1, i&
8603 & , 1)+(grat+grat)*(grat+1.)*a4_tl(1, i, 1)+a4_tl(1, i, 2))*bet-&
8604 & ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))*bet_tl)/bet**2
8605  q(i, 1) = ((grat+grat)*(grat+1.)*a4(1, i, 1)+a4(1, i, 2))/bet
8606  gam_tl(i, 1) = ((grat_tl*(grat+1.5)+grat*grat_tl)*bet-(1.+grat*(&
8607 & grat+1.5))*bet_tl)/bet**2
8608  gam(i, 1) = (1.+grat*(grat+1.5))/bet
8609  END DO
8610  d4_tl = 0.0
8611  DO k=2,km
8612  DO i=i1,i2
8613  d4_tl(i) = (delp_tl(i, k-1)*delp(i, k)-delp(i, k-1)*delp_tl(i&
8614 & , k))/delp(i, k)**2
8615  d4(i) = delp(i, k-1)/delp(i, k)
8616  bet_tl = 2*d4_tl(i) - gam_tl(i, k-1)
8617  bet = 2. + d4(i) + d4(i) - gam(i, k-1)
8618  q_tl(i, k) = ((3.*(a4_tl(1, i, k-1)+d4_tl(i)*a4(1, i, k)+d4(i)&
8619 & *a4_tl(1, i, k))-q_tl(i, k-1))*bet-(3.*(a4(1, i, k-1)+d4(i)*&
8620 & a4(1, i, k))-q(i, k-1))*bet_tl)/bet**2
8621  q(i, k) = (3.*(a4(1, i, k-1)+d4(i)*a4(1, i, k))-q(i, k-1))/bet
8622  gam_tl(i, k) = (d4_tl(i)*bet-d4(i)*bet_tl)/bet**2
8623  gam(i, k) = d4(i)/bet
8624  END DO
8625  END DO
8626  DO i=i1,i2
8627  a_bot_tl = d4_tl(i)*(d4(i)+1.5) + d4(i)*d4_tl(i)
8628  a_bot = 1. + d4(i)*(d4(i)+1.5)
8629  q_tl(i, km+1) = ((2.*((d4_tl(i)*(d4(i)+1.)+d4(i)*d4_tl(i))*a4(1&
8630 & , i, km)+d4(i)*(d4(i)+1.)*a4_tl(1, i, km))+a4_tl(1, i, km-1)-&
8631 & a_bot_tl*q(i, km)-a_bot*q_tl(i, km))*(d4(i)*(d4(i)+0.5)-a_bot*&
8632 & gam(i, km))-(2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
8633 & a_bot*q(i, km))*(d4_tl(i)*(d4(i)+0.5)+d4(i)*d4_tl(i)-a_bot_tl*&
8634 & gam(i, km)-a_bot*gam_tl(i, km)))/(d4(i)*(d4(i)+0.5)-a_bot*gam(&
8635 & i, km))**2
8636  q(i, km+1) = (2.*d4(i)*(d4(i)+1.)*a4(1, i, km)+a4(1, i, km-1)-&
8637 & a_bot*q(i, km))/(d4(i)*(d4(i)+0.5)-a_bot*gam(i, km))
8638  END DO
8639  DO k=km,1,-1
8640  DO i=i1,i2
8641  q_tl(i, k) = q_tl(i, k) - gam_tl(i, k)*q(i, k+1) - gam(i, k)*&
8642 & q_tl(i, k+1)
8643  q(i, k) = q(i, k) - gam(i, k)*q(i, k+1)
8644  END DO
8645  END DO
8646  END IF
8647  IF (kord .GE. 0.) THEN
8648  abs0 = kord
8649  ELSE
8650  abs0 = -kord
8651  END IF
8652 !----- Perfectly linear scheme --------------------------------
8653  IF (abs0 .GT. 16) THEN
8654  DO k=1,km
8655  DO i=i1,i2
8656  a4_tl(2, i, k) = q_tl(i, k)
8657  a4(2, i, k) = q(i, k)
8658  a4_tl(3, i, k) = q_tl(i, k+1)
8659  a4(3, i, k) = q(i, k+1)
8660  a4_tl(4, i, k) = 3.*(2.*a4_tl(1, i, k)-a4_tl(2, i, k)-a4_tl(3&
8661 & , i, k))
8662  a4(4, i, k) = 3.*(2.*a4(1, i, k)-(a4(2, i, k)+a4(3, i, k)))
8663  END DO
8664  END DO
8665  RETURN
8666  END IF
8667  END SUBROUTINE cs_profile_tlm
8668 end module fv_mapz_tlm_mod
fv_mapz_tlm_mod::c_ice
real, parameter c_ice
Definition: fv_mapz_tlm.F90:49
tracer_manager_mod::get_tracer_index
Definition: tracer_manager.F90:124
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
fv_mapz_tlm_mod::ppm_profile_tlm
subroutine ppm_profile_tlm(a4, a4_tl, delp, delp_tl, km, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:4348
constants_mod
Definition: constants.F90:24
fv_mapz_tlm_mod::pkez_tlm
subroutine pkez_tlm(km, ifirst, ilast, jfirst, jlast, j, pe, pk, pk_tl, akap, peln, peln_tl, pkz, pkz_tl, ptop)
Definition: fv_mapz_tlm.F90:2623
constants_mod::radius
real, parameter, public radius
Radius of the Earth [m].
Definition: constants.F90:72
field_manager_mod::model_atmos
integer, parameter, public model_atmos
Definition: field_manager.F90:299
fv_mapz_tlm_mod::r0
real, parameter r0
Definition: fv_mapz_tlm.F90:44
fv_mapz_tlm_mod::mappm
subroutine, public mappm(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord, ptop)
Definition: fv_mapz_tlm.F90:5468
fv_grid_utils_tlm_mod
Definition: fv_grid_utils_tlm.F90:20
fv_cmp_nlm_mod
Definition: fv_cmp_nlm.F90:1
field_manager_mod
Definition: field_manager.F90:20
fv_grid_utils_nlm_mod::ptop_min
real, parameter, public ptop_min
Definition: fv_grid_utils_nlm.F90:54
fv_mapz_tlm_mod::moist_cp
subroutine, public moist_cp(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cpm, t1)
Definition: fv_mapz_tlm.F90:7140
fv_cmp_nlm_mod::fv_sat_adj
subroutine, public fv_sat_adj(mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, te0, qv, ql, qi, qr, qs, qg, dpln, delz, pt, dp, q_con, cappa, area, dtdt, out_dt, last_step, do_qa, qa)
Definition: fv_cmp_nlm.F90:47
fv_mapz_tlm_mod::map1_q2
subroutine, public map1_q2(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_tlm.F90:3151
constants_mod::pi_8
real(kind=8), parameter, public pi_8
Ratio of circle circumference to diameter [N/A].
Definition: constants.F90:73
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
fv_mapz_tlm_mod::map1_ppm_tlm
subroutine map1_ppm_tlm(km, pe1, pe1_tl, qs, qs_tl, kn, pe2, pe2_tl, q2, q2_tl, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_tlm.F90:7911
fv_mapz_tlm_mod::cv_air
real, parameter cv_air
Definition: fv_mapz_tlm.F90:47
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
constants_mod::hlv
real, parameter, public hlv
Latent heat of evaporation [J/kg].
Definition: constants.F90:80
fv_mapz_tlm_mod::r12
real, parameter r12
Definition: fv_mapz_tlm.F90:45
fv_mapz_tlm_mod
Definition: fv_mapz_tlm.F90:23
fv_mapz_tlm_mod::scalar_profile_tlm
subroutine scalar_profile_tlm(qs, a4, a4_tl, delp, delp_tl, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_tlm.F90:8358
constants_mod::rdgas
real, parameter, public rdgas
Gas constant for dry air [J/kg/deg].
Definition: constants.F90:77
fv_mapz_tlm_mod::consv_min
real, parameter consv_min
Definition: fv_mapz_tlm.F90:42
constants_mod::cp_vapor
real, parameter, public cp_vapor
Specific heat capacity of water vapor at constant pressure [J/kg/deg].
Definition: constants.F90:89
fv_fill_nlm_mod::fillz
subroutine, public fillz(im, km, nq, q, dp)
Definition: fv_fill_nlm.F90:33
mpp_mod
Definition: mpp.F90:39
fv_mapz_tlm_mod::t_min
real, parameter t_min
Definition: fv_mapz_tlm.F90:43
fv_grid_utils_nlm_mod
Definition: fv_grid_utils_nlm.F90:20
fv_timing_nlm_mod
Definition: fv_timing_nlm.F90:20
fv_mapz_tlm_mod::r2
real, parameter r2
Definition: fv_mapz_tlm.F90:44
fv_mapz_tlm_mod::lagrangian_to_eulerian
subroutine, public lagrangian_to_eulerian(last_step, consv, ps, pe, delp, pkz, pk, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, v, w, delz, pt, q, hs, r_vir, cp, akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, te0_2d, ng, ua, va, omga, te, ws, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
Definition: fv_mapz_tlm.F90:1369
fv_mapz_tlm_mod::ppm_limiters_tlm
subroutine ppm_limiters_tlm(dm, dm_tl, a4, a4_tl, itot, lmt)
Definition: fv_mapz_tlm.F90:4939
fv_mapz_tlm_mod::cs_profile
subroutine cs_profile(qs, a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:5567
mpp_domains_mod
Definition: mpp_domains.F90:128
fv_mapz_tlm_mod::e_flux
real, public e_flux
Definition: fv_mapz_tlm.F90:55
fv_mapz_tlm_mod::map_scalar_tlm
subroutine map_scalar_tlm(km, pe1, pe1_tl, qs, kn, pe2, pe2_tl, q2, q2_tl, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_tlm.F90:7767
fv_mapz_tlm_mod::cs_profile_tlm
subroutine cs_profile_tlm(qs, qs_tl, a4, a4_tl, delp, delp_tl, km, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:8515
fv_mapz_tlm_mod::map1_cubic_tlm
subroutine map1_cubic_tlm(km, pe1, pe1_tl, kn, pe2, pe2_tl, q2, q2_tl, i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
Definition: fv_mapz_tlm.F90:7239
fv_grid_utils_tlm_mod::g_sum
real function, public g_sum(domain, p, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce)
Definition: fv_grid_utils_tlm.F90:596
fv_mapz_tlm_mod::ppm_limiters
subroutine ppm_limiters(dm, a4, itot, lmt)
Definition: fv_mapz_tlm.F90:6924
fv_mapz_tlm_mod::remap_2d
subroutine remap_2d(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:5380
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
constants_mod::rvgas
real, parameter, public rvgas
Gas constant for water vapor [J/kg/deg].
Definition: constants.F90:78
fv_mapz_tlm_mod::lagrangian_to_eulerian_tlm
subroutine, public lagrangian_to_eulerian_tlm(last_step, consv, ps, ps_tl, pe, pe_tl, delp, delp_tl, pkz, pkz_tl, pk, pk_tl, mdt, pdt, km, is, ie, js, je, isd, ied, jsd, jed, nq, nwat, sphum, q_con, u, u_tl, v, v_tl, w, w_tl, delz, delz_tl, pt, pt_tl, q, q_tl, hs, r_vir, cp, akap, cappa, kord_mt, kord_wz, kord_tr, kord_tm, peln, peln_tl, te0_2d, te0_2d_tl, ng, ua, ua_tl, va, omga, omga_tl, te, te_tl, ws, ws_tl, fill, reproduce_sum, out_dt, dtdt, ptop, ak, bk, pfull, flagstruct, gridstruct, domain, do_sat_adj, hydrostatic, hybrid_z, do_omega, adiabatic, do_adiabatic_init, mfx, mfy, remap_option, kord_mt_pert, kord_wz_pert, kord_tr_pert, kord_tm_pert)
Definition: fv_mapz_tlm.F90:79
fv_mapz_tlm_mod::remap_z
subroutine remap_z(km, pe1, q1, kn, pe2, q2, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:2745
fv_timing_nlm_mod::timing_on
subroutine timing_on(blk_name)
Definition: fv_timing_nlm.F90:101
fv_mapz_tlm_mod::cs_limiters
subroutine cs_limiters(im, extm, a4, iv)
Definition: fv_mapz_tlm.F90:6435
fv_mapz_tlm_mod::compute_total_energy
subroutine, public compute_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, u, v, w, delz, pt, delp, q, qc, pe, peln, hs, rsin2_l, cosa_s_l, r_vir, cp, rg, hlv, te_2d, ua, va, teq, moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
Definition: fv_mapz_tlm.F90:2493
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
fv_cmp_nlm_mod::qs_init
subroutine, public qs_init(kmp)
Definition: fv_cmp_nlm.F90:184
constants_mod::cp_air
real, parameter, public cp_air
Specific heat capacity of dry air at constant pressure [J/kg/deg].
Definition: constants.F90:83
fv_mapz_tlm_mod::compute_total_energy_tlm
subroutine, public compute_total_energy_tlm(is, ie, js, je, isd, ied, jsd, jed, km, u, u_tl, v, v_tl, w, w_tl, delz, delz_tl, pt, pt_tl, delp, delp_tl, q, q_tl, qc, qc_tl, pe, pe_tl, peln, peln_tl, hs, rsin2_l, cosa_s_l, r_vir, cp, rg, hlv, te_2d, te_2d_tl, ua, va, teq, teq_tl, moist_phys, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, hydrostatic, id_te)
Definition: fv_mapz_tlm.F90:2297
fv_mapz_tlm_mod::r3
real, parameter r3
Definition: fv_mapz_tlm.F90:45
fv_mapz_tlm_mod::map_scalar
subroutine map_scalar(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord, q_min)
Definition: fv_mapz_tlm.F90:2834
fv_arrays_tlmadm_mod
Definition: fv_arrays_tlmadm.F90:20
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_arrays_tlmadm_mod::fpp
type(fpp_type) fpp
Definition: fv_arrays_tlmadm.F90:35
fv_mapz_tlm_mod::rst_remap
subroutine, public rst_remap(km, kn, is, ie, js, je, isd, ied, jsd, jed, nq, ntp, delp_r, u_r, v_r, w_r, delz_r, pt_r, q_r, qdiag_r, delp, u, v, w, delz, pt, q, qdiag, ak_r, bk_r, ptop, ak, bk, hydrostatic, make_nh, domain, square_domain)
Definition: fv_mapz_tlm.F90:5172
fv_mapz_tlm_mod::map1_q2_tlm
subroutine, public map1_q2_tlm(km, pe1, pe1_tl, q1, q1_tl, kn, pe2, pe2_tl, q2, q2_tl, dp2, dp2_tl, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
Definition: fv_mapz_tlm.F90:8225
fv_mapz_tlm_mod::cp_vap
real, parameter cp_vap
Definition: fv_mapz_tlm.F90:52
fv_mapz_tlm_mod::r23
real, parameter r23
Definition: fv_mapz_tlm.F90:45
fv_mapz_tlm_mod::cv_vap
real, parameter cv_vap
Definition: fv_mapz_tlm.F90:46
constants_mod::hlf
real, parameter, public hlf
Latent heat of fusion [J/kg].
Definition: constants.F90:81
fv_mapz_tlm_mod::cs_limiters_tlm
subroutine cs_limiters_tlm(im, extm, a4, a4_tl, iv)
Definition: fv_mapz_tlm.F90:4233
fv_mapz_tlm_mod::map1_ppm
subroutine map1_ppm(km, pe1, qs, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, iv, kord)
Definition: fv_mapz_tlm.F90:2935
fv_mapz_tlm_mod::map1_cubic
subroutine map1_cubic(km, pe1, kn, pe2, q2, i1, i2, j, ibeg, iend, jbeg, jend, akap, t_var, conserv)
Definition: fv_mapz_tlm.F90:7560
constants_mod::grav
real, parameter, public grav
Acceleration due to gravity [m/s^2].
Definition: constants.F90:76
tracer_manager_mod
Definition: tracer_manager.F90:20
fv_mapz_tlm_mod::moist_cv
subroutine, public moist_cv(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cvm, t1)
Definition: fv_mapz_tlm.F90:7050
mpp_mod::mpp_error
Definition: mpp.F90:402
fv_mapz_tlm_mod::scalar_profile
subroutine scalar_profile(qs, a4, delp, km, i1, i2, iv, kord, qmin)
Definition: fv_mapz_tlm.F90:3241
max
#define max(a, b)
Definition: mosaic_util.h:33
fv_mapz_tlm_mod::pkez
subroutine pkez(km, ifirst, ilast, jfirst, jlast, j, pe, pk, akap, peln, pkz, ptop)
Definition: fv_mapz_tlm.F90:2692
fv_fill_nlm_mod
Definition: fv_fill_nlm.F90:20
fv_diagnostics_nlm_mod::prt_mxm
subroutine, public prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain)
Definition: fv_diagnostics_nlm.F90:2809
fv_mapz_tlm_mod::mapn_tracer_tlm
subroutine mapn_tracer_tlm(nq, km, pe1, pe1_tl, pe2, pe2_tl, q1, q1_tl, dp2, dp2_tl, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_tlm.F90:8054
min
#define min(a, b)
Definition: mosaic_util.h:32
fv_mapz_tlm_mod::tice
real, parameter tice
Definition: fv_mapz_tlm.F90:53
fv_diagnostics_nlm_mod
Definition: fv_diagnostics_nlm.F90:20
fv_mapz_tlm_mod::mapn_tracer
subroutine mapn_tracer(nq, km, pe1, pe2, q1, dp2, kord, j, i1, i2, isd, ied, jsd, jed, q_min, fill)
Definition: fv_mapz_tlm.F90:3034
fv_mapz_tlm_mod::steepz
subroutine steepz(i1, i2, km, a4, df2, dm, dq, dp, d4)
Definition: fv_mapz_tlm.F90:5103
fv_grid_utils_tlm_mod::g_sum_tlm
real function, public g_sum_tlm(domain, p, p_tl, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce, g_sum)
Definition: fv_grid_utils_tlm.F90:532
fv_mapz_tlm_mod::ppm_profile
subroutine ppm_profile(a4, delp, km, i1, i2, iv, kord)
Definition: fv_mapz_tlm.F90:6521
crtm_parameters::pi
real(fp), parameter, public pi
Definition: CRTM_Parameters.f90:86
fv_timing_nlm_mod::timing_off
subroutine timing_off(blk_name)
Definition: fv_timing_nlm.F90:175
fv_mapz_tlm_mod::c_liq
real, parameter c_liq
Definition: fv_mapz_tlm.F90:50