Line data Source code
1 : ! Hack shallow convective scheme.
2 : ! The main subroutine was formerly named "cmfmca", and its initialization "mfinti".
3 : !
4 : ! Original Author: J. Hack
5 : ! CCPPized: Haipeng Lin, October 2024
6 : module hack_convect_shallow
7 : use ccpp_kinds, only: kind_phys
8 : implicit none
9 : private
10 : save
11 :
12 : ! public CCPP-compliant subroutines
13 : public :: hack_convect_shallow_init
14 : public :: hack_convect_shallow_run
15 :
16 : ! namelist variables for tuning of hack shallow convective scheme
17 : real(kind_phys) :: cmftau ! characteristic adjustment time scale [s]
18 : real(kind_phys) :: c0 ! rain water autoconversion coefficient [m-1]
19 :
20 : ! host-model physical constants and shorthands
21 : real(kind_phys) :: cp ! specific heat of dry air [J K-1 kg-1]
22 : real(kind_phys) :: rgas ! gas constant for dry air [J K-1 kg-1]
23 : real(kind_phys) :: grav ! gravitational constant [m s-2]
24 : real(kind_phys) :: hlat ! latent heat of vaporization [J kg-1]
25 : real(kind_phys) :: rhoh2o ! density of liquid water at STP [kg m-3]
26 :
27 : real(kind_phys) :: rcp ! reciprocal of cp
28 : real(kind_phys) :: rgrav ! reciprocal of grav
29 : real(kind_phys) :: rhlat ! reciprocal of hlat
30 :
31 : integer :: limcnv ! top vertical interface level limit for convection [index]
32 : ! derived from reference pressures to below 40 mb
33 :
34 : ! internal parameters
35 : real(kind_phys) :: betamn = 0.10_kind_phys ! minimum overshoot parameter [???]
36 : real(kind_phys) :: dzmin = 0.0_kind_phys ! minimum convective depth for precipitation [m]
37 : logical :: rlxclm = .true. ! control for relaxing column versus cloud triplet (default: true)
38 : ! true: relaxation timescale should be applied to column as opposed to triplets individually
39 : real(kind_phys) :: ssfac = 1.001_kind_phys ! detrained air supersaturation bound [???]
40 :
41 : ! internal parameters for tolerance
42 : real(kind_phys) :: tiny = 1.0e-36_kind_phys ! arbitrary small num in scalar transport estimates
43 : real(kind_phys) :: eps = 1.0e-13_kind_phys ! machine dependent convergence criteria
44 : real(kind_phys) :: tpmax = 1.50_kind_phys ! maximum acceptable T perturbation [K]
45 : real(kind_phys) :: shpmax = 1.50e-3_kind_phys ! maximum acceptable Q perturbation [g g-1]
46 :
47 : ! diagnostic only
48 : logical :: debug_verbose = .false. ! control for debug messages
49 :
50 :
51 : contains
52 : ! Initialization of moist convective mass procedure including namelist read.
53 : !> \section arg_table_hack_convect_shallow_init Argument Table
54 : !! \htmlinclude hack_convect_shallow_init.html
55 1024 : subroutine hack_convect_shallow_init( &
56 : pver, &
57 : amIRoot, iulog, &
58 : cmftau_in, c0_in, &
59 : rair, cpair, gravit, latvap, rhoh2o_in, &
60 1024 : pref_edge, &
61 1024 : use_shfrc, shfrc, &
62 : top_lev, &
63 1024 : errmsg, errflg)
64 :
65 : integer, intent(in) :: pver ! number of vertical levels
66 : logical, intent(in) :: amIRoot
67 : integer, intent(in) :: iulog ! log output unit
68 : real(kind_phys), intent(in) :: cmftau_in ! characteristic adjustment time scale [s]
69 : real(kind_phys), intent(in) :: c0_in ! rain water autoconversion coefficient [m-1]
70 : real(kind_phys), intent(in) :: rair ! gas constant for dry air [J K-1 kg-1]
71 : real(kind_phys), intent(in) :: cpair ! specific heat of dry air [J K-1 kg-1]
72 : real(kind_phys), intent(in) :: gravit ! gravitational constant [m s-2]
73 : real(kind_phys), intent(in) :: latvap ! latent heat of vaporization [J kg-1]
74 : real(kind_phys), intent(in) :: rhoh2o_in ! density of liquid water [kg m-3]
75 : real(kind_phys), intent(in) :: pref_edge(:) ! reference pressures at interface [Pa]
76 :
77 : logical, intent(out) :: use_shfrc ! this shallow scheme provides convective cloud fractions? [flag]
78 : real(kind_phys), intent(out) :: shfrc(:,:) ! (dummy) shallow convective cloud fractions calculated in-scheme [fraction]
79 :
80 : integer, intent(out) :: top_lev ! top level for cloud fraction [index]
81 :
82 : character(len=512), intent(out) :: errmsg
83 : integer, intent(out) :: errflg
84 :
85 : ! local variables
86 : integer :: k
87 :
88 1024 : errmsg = ''
89 1024 : errflg = 0
90 :
91 : ! namelist variables
92 1024 : cmftau = cmftau_in
93 1024 : c0 = c0_in
94 :
95 1024 : if(amIRoot) then
96 2 : write(iulog,*) 'tuning parameters hack_convect_shallow: cmftau',cmftau
97 2 : write(iulog,*) 'tuning parameters hack_convect_shallow: c0',c0
98 : endif
99 :
100 : ! host model physical constants
101 1024 : cp = cpair
102 1024 : rcp = 1.0_kind_phys/cp
103 1024 : hlat = latvap
104 1024 : rhlat = 1.0_kind_phys/hlat
105 1024 : grav = gravit
106 1024 : rgrav = 1.0_kind_phys/gravit
107 1024 : rgas = rair
108 1024 : rhoh2o = rhoh2o_in
109 :
110 : ! determine limit of shallow convection: regions below 40 mb
111 : ! logic ported from convect_shallow_init with note that this calculation is repeated in the deep
112 : ! convection interface.
113 1024 : if(pref_edge(1) >= 4.e3_kind_phys) then
114 0 : limcnv = 1
115 : else
116 1024 : limcnv = pver + 1
117 27648 : do k = 1, pver
118 27648 : if(pref_edge(k) < 4.e3_kind_phys .and. pref_edge(k+1) >= 4.e3_kind_phys) then
119 1024 : limcnv = k
120 : endif
121 : enddo
122 : endif
123 :
124 1024 : if(amIRoot) then
125 2 : write(iulog,*) "hack_convect_shallow_init: convection will be capped at interface ", limcnv, &
126 4 : "which is ", pref_edge(limcnv), " pascals"
127 : endif
128 :
129 : ! flags for whether this shallow convection scheme
130 : ! calculates and provides convective cloud fractions
131 : ! to convective cloud cover scheme.
132 : !
133 : ! the Hack scheme does not provide this.
134 : ! a dummy shfrc is provided and is never used.
135 1024 : use_shfrc = .false.
136 453632 : shfrc(:,:) = 0._kind_phys
137 :
138 : ! for Hack shallow convection (CAM4 physics), do not limit cloud fraction
139 : ! (extend all the way to model top)
140 1024 : top_lev = 1
141 1024 : end subroutine hack_convect_shallow_init
142 :
143 : ! Moist convective mass flux procedure.
144 : !
145 : ! If stratification is unstable to nonentraining parcel ascent,
146 : ! complete an adjustment making successive use of a simple cloud model
147 : ! consisting of three layers (sometimes referred to as a triplet)
148 : !
149 : ! Code generalized to allow specification of parcel ("updraft")
150 : ! properties, as well as convective transport of an arbitrary
151 : ! number of passive constituents (see q array). The code
152 : ! is written so the water vapor field is passed independently
153 : ! in the calling list from the block of other transported
154 : ! constituents, even though as currently designed, it is the
155 : ! first component in the constituents field.
156 : !
157 : ! Reports tendencies in cmfdt and dq instead of updating profiles.
158 : !
159 : ! Original author: J. Hack, BAB
160 : !> \section arg_table_hack_convect_shallow_run Argument Table
161 : !! \htmlinclude hack_convect_shallow_run.html
162 70392 : subroutine hack_convect_shallow_run( &
163 : ncol, pver, pcnst, &
164 : iulog, &
165 70392 : const_props, &
166 : ztodt, &
167 140784 : pmid, pmiddry, &
168 140784 : pdel, pdeldry, rpdel, rpdeldry, &
169 70392 : zm, &
170 70392 : qpert_in, &
171 70392 : phis, &
172 70392 : pblh, &
173 70392 : t, &
174 70392 : q, & ! ... below are output arguments:
175 70392 : dq, &
176 70392 : qc_sh, &
177 70392 : cmfdt, &
178 70392 : cmfmc_sh, &
179 70392 : cmfdqr, &
180 70392 : cmfsl, &
181 70392 : cmflq, &
182 70392 : precc, &
183 70392 : cnt_sh, &
184 70392 : cnb_sh, &
185 70392 : icwmr, &
186 70392 : rliq_sh, &
187 0 : scheme_name, &
188 70392 : flx_cnd, &
189 70392 : errmsg, errflg &
190 : )
191 : ! framework dependency for const_props
192 : use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t
193 :
194 : ! dependency to get constituent index
195 : use ccpp_const_utils, only: ccpp_const_get_idx
196 :
197 : ! to_be_ccppized
198 : use wv_saturation, only: qsat
199 :
200 : ! Input arguments
201 : integer, intent(in) :: ncol ! number of atmospheric columns
202 : integer, intent(in) :: pver ! number of vertical levels
203 : integer, intent(in) :: pcnst ! number of ccpp constituents
204 : integer, intent(in) :: iulog ! log output unit
205 : type(ccpp_constituent_prop_ptr_t), &
206 : intent(in) :: const_props(:) ! ccpp constituent properties pointer
207 : real(kind_phys), intent(in) :: ztodt ! physics timestep [s]
208 :
209 : real(kind_phys), intent(in) :: pmid(:,:) ! midpoint pressures [Pa]
210 : real(kind_phys), intent(in) :: pmiddry(:,:) ! dry pressure at midpoints [Pa]
211 : real(kind_phys), intent(in) :: pdel(:,:) ! layer thickness (delta-p) [Pa]
212 : real(kind_phys), intent(in) :: pdeldry(:,:) ! dry layer thickness [Pa]
213 : real(kind_phys), intent(in) :: rpdel(:,:) ! 1.0 / pdel
214 : real(kind_phys), intent(in) :: rpdeldry(:,:) ! 1.0 / pdeldry
215 :
216 : real(kind_phys), intent(in) :: zm(:,:) ! geopotential height at midpoints [m]
217 : real(kind_phys), intent(in) :: qpert_in(:) ! PBL perturbation specific humidity (convective humidity excess) [kg kg-1]
218 : real(kind_phys), intent(in) :: phis(:) ! surface geopotential [m2 s-2]
219 : real(kind_phys), intent(in) :: pblh(:) ! PBL height [m]
220 : real(kind_phys), intent(in) :: t(:,:) ! temperature [K]
221 : real(kind_phys), intent(in) :: q(:,:,:) ! constituents [kg kg-1]
222 :
223 : ! Output arguments
224 : real(kind_phys), intent(out) :: dq(:,:,:) ! constituent tendencies [kg kg-1 s-1]
225 : real(kind_phys), intent(out) :: qc_sh(:,:) ! dq/dt due to export of cloud water / shallow reserved cloud condensate [kg kg-1 s-1]
226 : real(kind_phys), intent(out) :: cmfdt(:,:) ! heating rate (to ptend%s) [J kg-1 s-1]
227 : real(kind_phys), intent(out) :: cmfmc_sh(:,:) ! convective updraft mass flux, shallow [kg s-1 m-2]
228 : real(kind_phys), intent(out) :: cmfdqr(:,:) ! q tendency due to shallow convective rainout [kg kg-1 s-1]
229 : real(kind_phys), intent(out) :: cmfsl(:,:) ! moist shallow convection liquid water static energy flux [W m-2]
230 : real(kind_phys), intent(out) :: cmflq(:,:) ! moist shallow convection total water flux [W m-2]
231 : real(kind_phys), intent(out) :: precc(:) ! shallow convective precipitation rate [m s-1]
232 : integer, intent(out) :: cnt_sh(:) ! top level of shallow convective activity [index]
233 : integer, intent(out) :: cnb_sh(:) ! bottom level of shallow convective activity [index]
234 : real(kind_phys), intent(out) :: icwmr(:,:) ! shallow convection in-cloud water mixing ratio [kg kg-1]
235 : real(kind_phys), intent(out) :: rliq_sh(:) ! vertically-integrated shallow reserved cloud condensate [m s-1]
236 :
237 : character(len=64), intent(out) :: scheme_name ! scheme name
238 : real(kind_phys), intent(out) :: flx_cnd(:) ! net_liquid_and_lwe_ice_fluxes_through_top_and_bottom_of_atmosphere_column [m s-1] for check_energy_chng
239 :
240 : character(len=512), intent(out) :: errmsg
241 : integer, intent(out) :: errflg
242 :
243 : ! Local variables
244 140784 : real(kind_phys) :: tpert(ncol) ! PBL perturbation temperature (convective temperature excess) [K]
245 :
246 : character(len=256) :: const_standard_name ! temp: constituent standard name
247 : logical :: const_is_dry ! temp: constituent is dry flag
248 : integer :: const_wv_idx ! temp: index of water vapor
249 :
250 140784 : real(kind_phys) :: pm(ncol,pver) ! pressure [Pa]
251 140784 : real(kind_phys) :: pd(ncol,pver) ! delta-p [Pa]
252 140784 : real(kind_phys) :: rpd(ncol,pver) ! 1./pdel [Pa-1]
253 140784 : real(kind_phys) :: cmfdq(ncol,pver) ! dq(wv)/dt due to moist convection (later copied to dq(:,:,const_wv_idx)) [kg kg-1 s-1]
254 140784 : real(kind_phys) :: gam(ncol,pver) ! 1/cp (d(qsat)/dT) change in saturation mixing ratio with temp
255 140784 : real(kind_phys) :: sb(ncol,pver) ! dry static energy (s bar) [J kg-1]
256 140784 : real(kind_phys) :: hb(ncol,pver) ! moist static energy (h bar) [J kg-1]
257 140784 : real(kind_phys) :: shbs(ncol,pver) ! sat. specific humidity (sh bar star)
258 140784 : real(kind_phys) :: hbs(ncol,pver) ! sat. moist static energy (h bar star)
259 140784 : real(kind_phys) :: shbh(ncol,pver+1) ! specific humidity on interfaces
260 140784 : real(kind_phys) :: sbh(ncol,pver+1) ! s bar on interfaces
261 140784 : real(kind_phys) :: hbh(ncol,pver+1) ! h bar on interfaces
262 140784 : real(kind_phys) :: cmrh(ncol,pver+1) ! interface constituent mixing ratio
263 140784 : real(kind_phys) :: prec(ncol) ! instantaneous total precipitation
264 140784 : real(kind_phys) :: dzcld(ncol) ! depth of convective layer (m)
265 140784 : real(kind_phys) :: beta(ncol) ! overshoot parameter (fraction)
266 140784 : real(kind_phys) :: betamx(ncol) ! local maximum on overshoot
267 140784 : real(kind_phys) :: eta(ncol) ! convective mass flux (kg/m^2 s)
268 140784 : real(kind_phys) :: etagdt(ncol) ! eta*grav*dt
269 140784 : real(kind_phys) :: cldwtr(ncol) ! cloud water (mass)
270 140784 : real(kind_phys) :: rnwtr(ncol) ! rain water (mass)
271 140784 : real(kind_phys) :: totcond(ncol) ! total condensate; mix of precip and cloud water (mass)
272 140784 : real(kind_phys) :: sc (ncol) ! dry static energy ("in-cloud")
273 140784 : real(kind_phys) :: shc (ncol) ! specific humidity ("in-cloud")
274 140784 : real(kind_phys) :: hc (ncol) ! moist static energy ("in-cloud")
275 140784 : real(kind_phys) :: cmrc(ncol) ! constituent mix rat ("in-cloud")
276 140784 : real(kind_phys) :: dq1(ncol) ! shb convective change (lower lvl)
277 140784 : real(kind_phys) :: dq2(ncol) ! shb convective change (mid level)
278 140784 : real(kind_phys) :: dq3(ncol) ! shb convective change (upper lvl)
279 140784 : real(kind_phys) :: ds1(ncol) ! sb convective change (lower lvl)
280 140784 : real(kind_phys) :: ds2(ncol) ! sb convective change (mid level)
281 140784 : real(kind_phys) :: ds3(ncol) ! sb convective change (upper lvl)
282 140784 : real(kind_phys) :: dcmr1(ncol) ! q convective change (lower lvl)
283 140784 : real(kind_phys) :: dcmr2(ncol) ! q convective change (mid level)
284 140784 : real(kind_phys) :: dcmr3(ncol) ! q convective change (upper lvl)
285 140784 : real(kind_phys) :: estemp(ncol,pver) ! saturation vapor pressure (scratch)
286 140784 : real(kind_phys) :: vtemp1(2*ncol) ! intermediate scratch vector
287 140784 : real(kind_phys) :: vtemp2(2*ncol) ! intermediate scratch vector
288 140784 : real(kind_phys) :: vtemp3(2*ncol) ! intermediate scratch vector
289 140784 : real(kind_phys) :: vtemp4(2*ncol) ! intermediate scratch vector
290 140784 : real(kind_phys) :: vtemp5(2*ncol) ! intermediate scratch vector
291 140784 : integer :: indx1(ncol) ! longitude indices for condition true
292 : logical :: etagt0 ! true if eta > 0.0
293 : real(kind_phys) :: cats ! modified characteristic adj. time
294 : real(kind_phys) :: rtdt ! 1./ztodt
295 : real(kind_phys) :: qprime ! modified specific humidity pert.
296 : real(kind_phys) :: tprime ! modified thermal perturbation
297 : real(kind_phys) :: pblhgt ! bounded pbl height (max[pblh,1m])
298 : real(kind_phys) :: fac1 ! intermediate scratch variable
299 : real(kind_phys) :: shprme ! intermediate specific humidity pert.
300 : real(kind_phys) :: qsattp ! sat mix rat for thermally pert PBL parcels
301 : real(kind_phys) :: dz ! local layer depth
302 : real(kind_phys) :: temp1 ! intermediate scratch variable
303 : real(kind_phys) :: b1 ! bouyancy measure in detrainment lvl
304 : real(kind_phys) :: b2 ! bouyancy measure in condensation lvl
305 : real(kind_phys) :: temp2 ! intermediate scratch variable
306 : real(kind_phys) :: temp3 ! intermediate scratch variable
307 : real(kind_phys) :: g ! bounded vertical gradient of hb
308 : real(kind_phys) :: tmass ! total mass available for convective exch
309 : real(kind_phys) :: denom ! intermediate scratch variable
310 : real(kind_phys) :: qtest1 ! used in negative q test (middle lvl)
311 : real(kind_phys) :: qtest2 ! used in negative q test (lower lvl)
312 : real(kind_phys) :: fslkp ! flux lw static energy (bot interface)
313 : real(kind_phys) :: fslkm ! flux lw static energy (top interface)
314 : real(kind_phys) :: fqlkp ! flux total water (bottom interface)
315 : real(kind_phys) :: fqlkm ! flux total water (top interface)
316 : real(kind_phys) :: botflx ! bottom constituent mixing ratio flux
317 : real(kind_phys) :: topflx ! top constituent mixing ratio flux
318 : real(kind_phys) :: efac1 ! ratio q to convectively induced chg (btm lvl)
319 : real(kind_phys) :: efac2 ! ratio q to convectively induced chg (mid lvl)
320 : real(kind_phys) :: efac3 ! ratio q to convectively induced chg (top lvl)
321 140784 : real(kind_phys) :: tb(ncol,pver) ! working storage for temp (t bar)
322 70392 : real(kind_phys) :: shb(ncol,pver) ! working storage for spec hum (sh bar)
323 : real(kind_phys) :: adjfac ! adjustment factor (relaxation related)
324 : integer :: i,k ! longitude, level indices
325 : integer :: ii ! index on "gathered" vectors
326 : integer :: len1 ! vector length of "gathered" vectors
327 : integer :: m ! constituent index
328 : integer :: ktp ! tmp indx used to track top of convective layer
329 :
330 : ! debug use quantities
331 : real(kind_phys) :: rh ! relative humidity
332 : real(kind_phys) :: es ! sat vapor pressure
333 : real(kind_phys) :: hsum1 ! moist static energy integral
334 : real(kind_phys) :: qsum1 ! total water integral
335 : real(kind_phys) :: hsum2 ! final moist static energy integral
336 : real(kind_phys) :: qsum2 ! final total water integral
337 : real(kind_phys) :: fac ! intermediate scratch variable
338 : integer :: n ! vertical index (diagnostics)
339 : integer :: kp ! vertical index (diagnostics)
340 : integer :: kpp ! index offset, kp+1 (diagnostics)
341 : integer :: kpm1 ! index offset, kp-1 (diagnostics)
342 :
343 70392 : errmsg = ''
344 70392 : errflg = 0
345 :
346 70392 : scheme_name = 'hack_convect_shallow'
347 :
348 : !---------------------------------------------------
349 : ! Initialize output tendencies
350 : !---------------------------------------------------
351 28436184 : cmfdt (:ncol,:) = 0._kind_phys
352 28436184 : cmfdq (:ncol,:) = 0._kind_phys
353 29527176 : cmfmc_sh(:ncol,:) = 0._kind_phys
354 28436184 : cmfdqr (:ncol,:) = 0._kind_phys
355 28436184 : cmfsl (:ncol,:) = 0._kind_phys
356 28436184 : cmflq (:ncol,:) = 0._kind_phys
357 28436184 : qc_sh (:ncol,:) = 0._kind_phys
358 1090992 : rliq_sh (:ncol) = 0._kind_phys
359 :
360 : ! Check constituents list and locate water vapor index
361 : ! (not assumed to be 1)
362 0 : call ccpp_const_get_idx(const_props, &
363 : 'water_vapor_mixing_ratio_wrt_moist_air_and_condensed_water', &
364 70392 : const_wv_idx, errmsg, errflg)
365 :
366 : !---------------------------------------------------
367 : ! copy q to dq for passive tracer transport.
368 : ! this is NOT an initialization. the dq at this point
369 : ! is not physical (used as temporary here) only at the end
370 : ! dq is updated to be an actual tendency.
371 : !---------------------------------------------------
372 70392 : if(pcnst > 1) then
373 : ! set dq for passive tracer transport from q as temporary...
374 85378944 : dq(:ncol,:,:) = q(:ncol,:,:)
375 :
376 : ! except for water vapor
377 28436184 : dq(:ncol,:,const_wv_idx) = 0._kind_phys
378 : endif
379 :
380 : !---------------------------------------------------
381 : ! Quantity preparations from convect_shallow.F90.
382 : !---------------------------------------------------
383 :
384 : ! convect_shallow.F90 is not linked to pbuf tpert and always sets to zero.
385 : ! "This field probably should reference the pbuf tpert field but it doesnt"
386 1090992 : tpert(:ncol) = 0.0_kind_phys
387 :
388 : !---------------------------------------------------
389 : ! Preparation of working arrays
390 : !---------------------------------------------------
391 : ! Ensure that characteristic adjustment time scale (cmftau) assumed
392 : ! in estimate of eta isn't smaller than model time scale (ztodt)
393 : ! The time over which the convection is assumed to act (the adjustment
394 : ! time scale) can be applied with each application of the three-level
395 : ! cloud model, or applied to the column tendencies after a "hard"
396 : ! adjustment (i.e., on a 2-delta t time scale) is evaluated
397 70392 : if (rlxclm) then
398 70392 : cats = ztodt ! relaxation applied to column
399 70392 : adjfac = ztodt/(max(ztodt,cmftau))
400 : else
401 0 : cats = max(ztodt,cmftau) ! relaxation applied to triplet
402 0 : adjfac = 1.0_kind_phys
403 : endif
404 70392 : rtdt = 1.0_kind_phys/ztodt
405 :
406 : ! Move temperature and moisture into working storage
407 1619016 : do k=limcnv,pver
408 24072216 : do i=1,ncol
409 22453200 : tb (i,k) = t(i,k)
410 24001824 : shb(i,k) = q(i,k,const_wv_idx)
411 : end do
412 : end do
413 1900584 : do k=1,pver
414 28436184 : do i=1,ncol
415 28365792 : icwmr(i,k) = 0._kind_phys
416 : end do
417 : end do
418 :
419 : ! Compute sb,hb,shbs,hbs
420 1619016 : do k = limcnv,pver
421 0 : call qsat(tb(1:ncol,k), pmid(1:ncol,k), &
422 0 : estemp(1:ncol,k), shbs(1:ncol,k), ncol, &
423 1619016 : gam=gam(1:ncol,k))
424 : end do
425 :
426 1619016 : do k=limcnv,pver
427 24072216 : do i=1,ncol
428 22453200 : sb (i,k) = cp*tb(i,k) + zm(i,k)*grav + phis(i)
429 22453200 : hb (i,k) = sb(i,k) + hlat*shb(i,k)
430 24001824 : hbs(i,k) = sb(i,k) + hlat*shbs(i,k)
431 : end do
432 : end do
433 :
434 : ! Compute sbh, shbh
435 1548624 : do k=limcnv+1,pver
436 22981224 : do i=1,ncol
437 21432600 : sbh (i,k) = 0.5_kind_phys*(sb(i,k-1) + sb(i,k))
438 21432600 : shbh(i,k) = qhalf(shb(i,k-1),shb(i,k),shbs(i,k-1),shbs(i,k))
439 22910832 : hbh (i,k) = sbh(i,k) + hlat*shbh(i,k)
440 : end do
441 : end do
442 :
443 : ! Specify properties at top of model (not used, but filling anyway)
444 1090992 : do i=1,ncol
445 1020600 : sbh (i,limcnv) = sb(i,limcnv)
446 1020600 : shbh(i,limcnv) = shb(i,limcnv)
447 1090992 : hbh (i,limcnv) = hb(i,limcnv)
448 : end do
449 :
450 : ! Zero vertically independent control, tendency & diagnostic arrays
451 1090992 : do i=1,ncol
452 1020600 : prec(i) = 0.0_kind_phys
453 1020600 : dzcld(i) = 0.0_kind_phys
454 1020600 : cnb_sh(i)= 0
455 1090992 : cnt_sh(i)= pver+1
456 : end do
457 :
458 70392 : if(debug_verbose) then
459 : ! DEBUG DIAGNOSTICS - Output initial thermodynamic profile
460 0 : do i=1,ncol
461 0 : if(i == 1) then
462 : ! Approximate vertical integral of moist static energy
463 : ! and total precipitable water
464 0 : hsum1 = 0.0_kind_phys
465 0 : qsum1 = 0.0_kind_phys
466 0 : do k=limcnv,pver
467 0 : hsum1 = hsum1 + pdel(i,k)*rgrav*hb(i,k)
468 0 : qsum1 = qsum1 + pdel(i,k)*rgrav*shb(i,k)
469 : end do
470 :
471 0 : write(iulog,8010)
472 0 : fac = grav*864._kind_phys
473 0 : do k=limcnv,pver
474 0 : rh = shb(i,k)/shbs(i,k)
475 0 : write(iulog,8020) shbh(i,k),sbh(i,k),hbh(i,k),fac*cmfmc_sh(i,k),cmfsl(i,k), cmflq(i,k)
476 0 : write(iulog,8040) tb(i,k),shb(i,k),rh,sb(i,k),hb(i,k),hbs(i,k),ztodt*cmfdt(i,k), &
477 0 : ztodt*cmfdq(i,k),ztodt*cmfdqr(i,k)
478 : end do
479 0 : write(iulog, 8000) prec(i)
480 : end if
481 : end do
482 : endif
483 :
484 : !---------------------------------------------------
485 : ! Begin moist convective mass flux adjustment procedure.
486 : ! Formalism ensures that negative cloud liquid water can never occur
487 : !---------------------------------------------------
488 1478232 : kloop: do k = pver-1,limcnv+1,-1
489 21819840 : do i = 1, ncol
490 20412000 : etagdt(i) = 0.0_kind_phys
491 20412000 : eta (i) = 0.0_kind_phys
492 20412000 : beta (i) = 0.0_kind_phys
493 20412000 : ds1 (i) = 0.0_kind_phys
494 20412000 : ds2 (i) = 0.0_kind_phys
495 20412000 : ds3 (i) = 0.0_kind_phys
496 20412000 : dq1 (i) = 0.0_kind_phys
497 20412000 : dq2 (i) = 0.0_kind_phys
498 20412000 : dq3 (i) = 0.0_kind_phys
499 : ! Specification of "cloud base" conditions
500 20412000 : qprime = 0.0_kind_phys
501 20412000 : tprime = 0.0_kind_phys
502 :
503 : ! Assign tprime within the PBL to be proportional to the quantity
504 : ! tpert (which will be bounded by tpmax), passed to this routine by
505 : ! the PBL routine. Don't allow perturbation to produce a dry
506 : ! adiabatically unstable parcel. Assign qprime within the PBL to be
507 : ! an appropriately modified value of the quantity qpert (which will be
508 : ! bounded by shpmax) passed to this routine by the PBL routine. The
509 : ! quantity qprime should be less than the local saturation value
510 : ! (qsattp=qsat[t+tprime,p]). In both cases, tpert and qpert are
511 : ! linearly reduced toward zero as the PBL top is approached.
512 20412000 : pblhgt = max(pblh(i),1.0_kind_phys)
513 20412000 : if ( (zm(i,k+1) <= pblhgt) .and. dzcld(i) == 0.0_kind_phys ) then
514 2001755 : fac1 = max(0.0_kind_phys,1.0_kind_phys-zm(i,k+1)/pblhgt)
515 2001755 : tprime = min(tpert(i),tpmax)*fac1
516 2001755 : qsattp = shbs(i,k+1) + cp*rhlat*gam(i,k+1)*tprime
517 2001755 : shprme = min(min(qpert_in(i),shpmax)*fac1,max(qsattp-shb(i,k+1),0.0_kind_phys))
518 2001755 : qprime = max(qprime,shprme)
519 : else
520 18410245 : tprime = 0.0_kind_phys
521 18410245 : qprime = 0.0_kind_phys
522 : end if
523 :
524 : ! Specify "updraft" (in-cloud) thermodynamic properties
525 20412000 : sc (i) = sb (i,k+1) + cp*tprime
526 20412000 : shc(i) = shb(i,k+1) + qprime
527 20412000 : hc (i) = sc (i ) + hlat*shc(i)
528 20412000 : vtemp4(i) = hc(i) - hbs(i,k)
529 20412000 : dz = pdel(i,k)*rgas*tb(i,k)*rgrav/pmid(i,k)
530 21819840 : if (vtemp4(i) > 0.0_kind_phys) then
531 990058 : dzcld(i) = dzcld(i) + dz
532 : else
533 19421942 : dzcld(i) = 0.0_kind_phys
534 : end if
535 : enddo
536 :
537 1407840 : if(debug_verbose) then
538 : ! DEBUG DIAGNOSTICS - output thermodynamic perturbation information
539 0 : do i=1,ncol
540 0 : if(i == 1) then
541 0 : write(iulog,8090) k+1,sc(i),shc(i),hc(i)
542 : end if
543 : enddo
544 : endif
545 :
546 :
547 : ! Check on moist convective instability
548 : ! Build index vector of points where instability exists
549 1407840 : len1 = 0
550 21819840 : do i=1,ncol
551 21819840 : if (vtemp4(i) > 0.0_kind_phys) then
552 990058 : len1 = len1 + 1
553 990058 : indx1(len1) = i
554 : end if
555 : end do
556 :
557 1407840 : if (len1 <= 0) cycle kloop
558 :
559 : ! Current level just below top level => no overshoot
560 177473 : if (k <= limcnv+1) then
561 0 : do ii=1,len1
562 0 : i = indx1(ii)
563 0 : temp1 = vtemp4(i)/(1.0_kind_phys + gam(i,k))
564 0 : cldwtr(i) = max(0.0_kind_phys,(sb(i,k) - sc(i) + temp1))
565 0 : beta(i) = 0.0_kind_phys
566 0 : vtemp3(i) = (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k))
567 : end do
568 : else
569 : ! First guess at overshoot parameter using crude buoyancy closure
570 : ! 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
571 : ! If pre-existing supersaturation in detrainment layer, beta=0
572 : ! cldwtr is temporarily equal to hlat*l (l=> liquid water)
573 1167531 : do ii=1,len1
574 990058 : i = indx1(ii)
575 990058 : temp1 = vtemp4(i)/(1.0_kind_phys + gam(i,k))
576 990058 : cldwtr(i) = max(0.0_kind_phys,(sb(i,k)-sc(i)+temp1))
577 990058 : betamx(i) = 1.0_kind_phys - c0*max(0.0_kind_phys,(dzcld(i)-dzmin))
578 990058 : b1 = (hc(i) - hbs(i,k-1))*pdel(i,k-1)
579 990058 : b2 = (hc(i) - hbs(i,k ))*pdel(i,k )
580 990058 : beta(i) = max(betamn,min(betamx(i), 1.0_kind_phys + b1/b2))
581 990058 : if (hbs(i,k-1) <= hb(i,k-1)) beta(i) = 0.0_kind_phys
582 :
583 : ! Bound maximum beta to ensure physically realistic solutions
584 : !
585 : ! First check constrains beta so that eta remains positive
586 : ! (assuming that eta is already positive for beta equal zero)
587 7920464 : vtemp1(i) = -(hbh(i,k+1) - hc(i))*pdel(i,k)*rpdel(i,k+1)+ &
588 8910522 : (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k+1) + cldwtr(i))
589 990058 : vtemp2(i) = (1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k))
590 990058 : vtemp3(i) = vtemp2(i)
591 1167531 : if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
592 147 : betamx(i) = 0.99_kind_phys*(vtemp1(i)/vtemp2(i))
593 147 : beta(i) = max(0.0_kind_phys,min(betamx(i),beta(i)))
594 : end if
595 : end do
596 :
597 : ! Second check involves supersaturation of "detrainment layer"
598 : ! small amount of supersaturation acceptable (by ssfac factor)
599 1167531 : do ii=1,len1
600 990058 : i = indx1(ii)
601 1167531 : if (hb(i,k-1) < hbs(i,k-1)) then
602 844030 : vtemp1(i) = vtemp1(i)*rpdel(i,k)
603 5064180 : temp2 = gam(i,k-1)*(sbh(i,k) - sc(i) + cldwtr(i)) - &
604 5908210 : hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
605 844030 : temp3 = vtemp3(i)*rpdel(i,k)
606 3376120 : vtemp2(i) = (ztodt/cats)*(hc(i) - hbs(i,k))*temp2/ &
607 4220150 : (pdel(i,k-1)*(hbs(i,k-1) - hb(i,k-1))) + temp3
608 844030 : if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
609 89940 : betamx(i) = ssfac*(vtemp1(i)/vtemp2(i))
610 89940 : beta(i) = max(0.0_kind_phys,min(betamx(i),beta(i)))
611 : end if
612 : else
613 146028 : beta(i) = 0.0_kind_phys
614 : end if
615 : end do
616 :
617 : ! Third check to avoid introducing 2 delta x thermodynamic
618 : ! noise in the vertical ... constrain adjusted h (or theta e)
619 : ! so that the adjustment doesn't contribute to "kinks" in h
620 1167531 : do ii=1,len1
621 990058 : i = indx1(ii)
622 990058 : g = min(0.0_kind_phys,hb(i,k) - hb(i,k-1))
623 990058 : temp1 = (hb(i,k) - hb(i,k-1) - g)*(cats/ztodt)/(hc(i) - hbs(i,k))
624 990058 : vtemp1(i) = temp1*vtemp1(i) + (hc(i) - hbh(i,k+1))*rpdel(i,k)
625 7920464 : vtemp2(i) = temp1*vtemp3(i)*rpdel(i,k) + (hc(i) - hbh(i,k) - cldwtr(i))* &
626 8910522 : (rpdel(i,k) + rpdel(i,k+1))
627 1167531 : if ((beta(i)*vtemp2(i) - vtemp1(i)) > 0._kind_phys) then
628 35611 : if (vtemp2(i) /= 0.0_kind_phys) then
629 35611 : betamx(i) = vtemp1(i)/vtemp2(i)
630 : else
631 0 : betamx(i) = 0.0_kind_phys
632 : end if
633 35611 : beta(i) = max(0.0_kind_phys,min(betamx(i),beta(i)))
634 : end if
635 : end do
636 : end if ! (k <= limcnv+1) Current level just below top level => no overshoot
637 :
638 :
639 : ! Calculate mass flux required for stabilization.
640 : !
641 : ! Ensure that the convective mass flux, eta, is positive by
642 : ! setting negative values of eta to zero..
643 : ! Ensure that estimated mass flux cannot move more than the
644 : ! minimum of total mass contained in either layer k or layer k+1.
645 : ! Also test for other pathological cases that result in non-
646 : ! physical states and adjust eta accordingly.
647 1167531 : do ii=1,len1
648 990058 : i = indx1(ii)
649 990058 : beta(i) = max(0.0_kind_phys,beta(i))
650 990058 : temp1 = hc(i) - hbs(i,k)
651 5940348 : temp2 = ((1.0_kind_phys + gam(i,k))*(sc(i) - sbh(i,k+1) + cldwtr(i)) - &
652 6930406 : beta(i)*vtemp3(i))*rpdel(i,k) - (hbh(i,k+1) - hc(i))*rpdel(i,k+1)
653 990058 : eta(i) = temp1/(temp2*grav*cats)
654 990058 : tmass = min(pdel(i,k),pdel(i,k+1))*rgrav
655 990058 : if (eta(i) > tmass*rtdt .or. eta(i) <= 0.0_kind_phys) eta(i) = 0.0_kind_phys
656 :
657 : ! Check on negative q in top layer (bound beta)
658 990058 : if (shc(i)-shbh(i,k) < 0.0_kind_phys .and. beta(i)*eta(i) /= 0.0_kind_phys) then
659 2533 : denom = eta(i)*grav*ztodt*(shc(i) - shbh(i,k))*rpdel(i,k-1)
660 2533 : beta(i) = max(0.0_kind_phys,min(-0.999_kind_phys*shb(i,k-1)/denom,beta(i)))
661 : end if
662 :
663 : ! Check on negative q in middle layer (zero eta)
664 5940348 : qtest1 = shb(i,k) + eta(i)*grav*ztodt*((shc(i) - shbh(i,k+1)) - &
665 5940348 : (1.0_kind_phys - beta(i))*cldwtr(i)*rhlat - beta(i)*(shc(i) - shbh(i,k)))* &
666 12870754 : rpdel(i,k)
667 990058 : if (qtest1 <= 0.0_kind_phys) eta(i) = 0.0_kind_phys
668 :
669 : ! Check on negative q in lower layer (bound eta)
670 990058 : fac1 = -(shbh(i,k+1) - shc(i))*rpdel(i,k+1)
671 990058 : qtest2 = shb(i,k+1) - eta(i)*grav*ztodt*fac1
672 990058 : if (qtest2 < 0.0_kind_phys) then
673 0 : eta(i) = 0.99_kind_phys*shb(i,k+1)/(grav*ztodt*fac1)
674 : end if
675 1167531 : etagdt(i) = eta(i)*grav*ztodt
676 : end do
677 :
678 177473 : if(debug_verbose) then
679 0 : do i=1,ncol
680 0 : if (i == 1) then
681 0 : write(iulog,8080) beta(i), eta(i)
682 : endif
683 : enddo
684 : endif
685 :
686 : ! Calculate cloud water, rain water, and thermodynamic changes
687 1167531 : do ii=1,len1
688 990058 : i = indx1(ii)
689 990058 : icwmr(i,k) = cldwtr(i)*rhlat
690 990058 : cldwtr(i) = etagdt(i)*cldwtr(i)*rhlat*rgrav
691 :
692 : ! JJH changes to facilitate export of cloud liquid water --------------------------------
693 990058 : totcond(i) = (1.0_kind_phys - beta(i))*cldwtr(i)
694 990058 : rnwtr(i) = min(totcond(i),c0*(dzcld(i)-dzmin)*cldwtr(i))
695 990058 : ds1(i) = etagdt(i)*(sbh(i,k+1) - sc(i))*rpdel(i,k+1)
696 990058 : dq1(i) = etagdt(i)*(shbh(i,k+1) - shc(i))*rpdel(i,k+1)
697 4950290 : ds2(i) = (etagdt(i)*(sc(i) - sbh(i,k+1)) + &
698 5940348 : hlat*grav*cldwtr(i) - beta(i)*etagdt(i)*(sc(i) - sbh(i,k)))*rpdel(i,k)
699 :
700 : ! JJH change for export of cloud liquid water; must use total condensate
701 : ! since rainwater no longer represents total condensate
702 6930406 : dq2(i) = (etagdt(i)*(shc(i) - shbh(i,k+1)) - grav*totcond(i) - beta(i)* &
703 7920464 : etagdt(i)*(shc(i) - shbh(i,k)))*rpdel(i,k)
704 6930406 : ds3(i) = beta(i)*(etagdt(i)*(sc(i) - sbh(i,k)) - hlat*grav*cldwtr(i))* &
705 7920464 : rpdel(i,k-1)
706 990058 : dq3(i) = beta(i)*etagdt(i)*(shc(i) - shbh(i,k))*rpdel(i,k-1)
707 :
708 : ! Isolate convective fluxes for later diagnostics
709 990058 : fslkp = eta(i)*(sc(i) - sbh(i,k+1))
710 990058 : fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) - hlat*cldwtr(i)*rtdt)
711 990058 : fqlkp = eta(i)*(shc(i) - shbh(i,k+1))
712 990058 : fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
713 :
714 : ! Update thermodynamic profile (update sb, hb, & hbs later)
715 990058 : tb (i,k+1) = tb(i,k+1) + ds1(i)*rcp
716 990058 : tb (i,k ) = tb(i,k ) + ds2(i)*rcp
717 990058 : tb (i,k-1) = tb(i,k-1) + ds3(i)*rcp
718 990058 : shb(i,k+1) = shb(i,k+1) + dq1(i)
719 990058 : shb(i,k ) = shb(i,k ) + dq2(i)
720 990058 : shb(i,k-1) = shb(i,k-1) + dq3(i)
721 :
722 : ! ** Update diagnostic information for final budget **
723 : ! Tracking precipitation, temperature & specific humidity tendencies,
724 : ! rainout term, convective mass flux, convective liquid
725 : ! water static energy flux, and convective total water flux
726 : ! The variable afac makes the necessary adjustment to the
727 : ! diagnostic fluxes to account for adjustment time scale based on
728 : ! how relaxation time scale is to be applied (column vs. triplet)
729 990058 : prec(i) = prec(i) + (rnwtr(i)/rhoh2o)*adjfac
730 :
731 : ! The following variables have units of "units"/second
732 990058 : cmfdt (i,k+1) = cmfdt (i,k+1) + ds1(i)*rtdt*adjfac
733 990058 : cmfdt (i,k ) = cmfdt (i,k ) + ds2(i)*rtdt*adjfac
734 990058 : cmfdt (i,k-1) = cmfdt (i,k-1) + ds3(i)*rtdt*adjfac
735 990058 : cmfdq (i,k+1) = cmfdq (i,k+1) + dq1(i)*rtdt*adjfac
736 990058 : cmfdq (i,k ) = cmfdq (i,k ) + dq2(i)*rtdt*adjfac
737 990058 : cmfdq (i,k-1) = cmfdq (i,k-1) + dq3(i)*rtdt*adjfac
738 :
739 : ! JJH changes to export cloud liquid water --------------------------------
740 990058 : qc_sh (i,k ) = (grav*(totcond(i)-rnwtr(i))*rpdel(i,k))*rtdt*adjfac
741 990058 : cmfdqr (i,k ) = cmfdqr(i,k ) + (grav*rnwtr(i)*rpdel(i,k))*rtdt*adjfac
742 990058 : cmfmc_sh(i,k+1) = cmfmc_sh(i,k+1) + eta(i)*adjfac
743 990058 : cmfmc_sh(i,k ) = cmfmc_sh(i,k ) + beta(i)*eta(i)*adjfac
744 :
745 : ! The following variables have units of w/m**2
746 990058 : cmfsl (i,k+1) = cmfsl (i,k+1) + fslkp*adjfac
747 990058 : cmfsl (i,k ) = cmfsl (i,k ) + fslkm*adjfac
748 990058 : cmflq (i,k+1) = cmflq (i,k+1) + hlat*fqlkp*adjfac
749 1167531 : cmflq (i,k ) = cmflq (i,k ) + hlat*fqlkm*adjfac
750 : enddo
751 :
752 : ! Next, convectively modify passive constituents
753 : ! For now, when applying relaxation time scale to thermal fields after
754 : ! entire column has undergone convective overturning, constituents will
755 : ! be mixed using a "relaxed" value of the mass flux determined above
756 : ! Although this will be inconsistant with the treatment of the thermal
757 : ! fields, it's computationally much cheaper, no more-or-less justifiable,
758 : ! and consistent with how the history tape mass fluxes would be used in
759 : ! an off-line mode (i.e., using an off-line transport model)
760 709892 : const_modify_loop: do m = 1, pcnst
761 : ! Water vapor needs to be skipped in the loop.
762 532419 : if (m == const_wv_idx) then
763 177473 : cycle const_modify_loop
764 : endif
765 :
766 : ! assign pd, rpd, pm temporary properties based on constituent dry/moist mixing ratio
767 354946 : call const_props(m)%is_dry(const_is_dry, errflg, errmsg)
768 354946 : if(const_is_dry) then
769 0 : pd (:ncol,:) = pdeldry (:ncol,:)
770 0 : rpd(:ncol,:) = rpdeldry(:ncol,:)
771 0 : pm (:ncol,:) = pmiddry (:ncol,:)
772 : else
773 148875006 : pd (:ncol,:) = pdel (:ncol,:)
774 148875006 : rpd(:ncol,:) = rpdel (:ncol,:)
775 148875006 : pm (:ncol,:) = pmid (:ncol,:)
776 : endif
777 :
778 2512535 : pcl1loop: do ii=1,len1
779 1980116 : i = indx1(ii)
780 :
781 : ! If any of the reported values of the constituent is negative in
782 : ! the three adjacent levels, nothing will be done to the profile
783 1980116 : if ((dq(i,k+1,m) < 0.0_kind_phys) .or. (dq(i,k,m) < 0.0_kind_phys) .or. (dq(i,k-1,m) < 0.0_kind_phys)) cycle pcl1loop
784 :
785 : ! Specify constituent interface values (linear interpolation)
786 1980116 : cmrh(i,k ) = 0.5_kind_phys*(dq(i,k-1,m) + dq(i,k ,m))
787 1980116 : cmrh(i,k+1) = 0.5_kind_phys*(dq(i,k ,m) + dq(i,k+1,m))
788 :
789 : ! Specify perturbation properties of constituents in PBL
790 1980116 : pblhgt = max(pblh(i),1.0_kind_phys)
791 1980116 : if ( (zm(i,k+1) <= pblhgt) .and. dzcld(i) == 0.0_kind_phys ) then
792 0 : fac1 = max(0.0_kind_phys,1.0_kind_phys-zm(i,k+1)/pblhgt)
793 : ! cmrc(i) = dq(i,k+1,m) + qpert(i,m)*fac1
794 : ! hplin - qpert for m>1 is always zero
795 0 : cmrc(i) = dq(i,k+1,m)
796 : else
797 1980116 : cmrc(i) = dq(i,k+1,m)
798 : end if
799 :
800 : ! Determine fluxes, flux divergence => changes due to convection
801 : ! Logic must be included to avoid producing negative values. A bit
802 : ! messy since there are no a priori assumptions about profiles.
803 : ! Tendency is modified (reduced) when pending disaster detected.
804 :
805 1980116 : botflx = etagdt(i)*(cmrc(i) - cmrh(i,k+1))*adjfac
806 1980116 : topflx = beta(i)*etagdt(i)*(cmrc(i)-cmrh(i,k))*adjfac
807 1980116 : dcmr1(i) = -botflx*rpd(i,k+1)
808 1980116 : efac1 = 1.0_kind_phys
809 1980116 : efac2 = 1.0_kind_phys
810 1980116 : efac3 = 1.0_kind_phys
811 :
812 1980116 : if (dq(i,k+1,m)+dcmr1(i) < 0.0_kind_phys) then
813 0 : if ( abs(dcmr1(i)) > 1.e-300_kind_phys ) then
814 0 : efac1 = max(tiny,abs(dq(i,k+1,m)/dcmr1(i)) - eps)
815 : else
816 0 : efac1 = tiny
817 : endif
818 : end if
819 :
820 1980116 : if (efac1 == tiny .or. efac1 > 1.0_kind_phys) efac1 = 0.0_kind_phys
821 1980116 : dcmr1(i) = -efac1*botflx*rpd(i,k+1)
822 1980116 : dcmr2(i) = (efac1*botflx - topflx)*rpd(i,k)
823 :
824 1980116 : if (dq(i,k,m)+dcmr2(i) < 0.0_kind_phys) then
825 50477 : if ( abs(dcmr2(i)) > 1.e-300_kind_phys ) then
826 50477 : efac2 = max(tiny,abs(dq(i,k ,m)/dcmr2(i)) - eps)
827 : else
828 0 : efac2 = tiny
829 : endif
830 : end if
831 :
832 1980116 : if (efac2 == tiny .or. efac2 > 1.0_kind_phys) efac2 = 0.0_kind_phys
833 1980116 : dcmr2(i) = (efac1*botflx - efac2*topflx)*rpd(i,k)
834 1980116 : dcmr3(i) = efac2*topflx*rpd(i,k-1)
835 :
836 1980116 : if ( (dq(i,k-1,m)+dcmr3(i) < 0.0_kind_phys ) ) then
837 219248 : if ( abs(dcmr3(i)) > 1.e-300_kind_phys ) then
838 219248 : efac3 = max(tiny,abs(dq(i,k-1,m)/dcmr3(i)) - eps)
839 : else
840 0 : efac3 = tiny
841 : endif
842 : end if
843 :
844 1980116 : if (efac3 == tiny .or. efac3 > 1.0_kind_phys) efac3 = 0.0_kind_phys
845 1980116 : efac3 = min(efac2,efac3)
846 1980116 : dcmr2(i) = (efac1*botflx - efac3*topflx)*rpd(i,k)
847 1980116 : dcmr3(i) = efac3*topflx*rpd(i,k-1)
848 :
849 1980116 : dq(i,k+1,m) = dq(i,k+1,m) + dcmr1(i)
850 1980116 : dq(i,k ,m) = dq(i,k ,m) + dcmr2(i)
851 2335062 : dq(i,k-1,m) = dq(i,k-1,m) + dcmr3(i)
852 : end do pcl1loop
853 : end do const_modify_loop
854 : ! Constituent modifications complete
855 :
856 : ! This if restructured from a goto
857 177473 : if (k /= limcnv+1) then
858 : ! Complete update of thermodynamic structure at integer levels
859 : ! gather/scatter points that need new values of shbs and gamma
860 1167531 : do ii=1,len1
861 990058 : i = indx1(ii)
862 990058 : vtemp1(ii ) = tb(i,k)
863 990058 : vtemp1(ii+len1) = tb(i,k-1)
864 990058 : vtemp2(ii ) = pmid(i,k)
865 1167531 : vtemp2(ii+len1) = pmid(i,k-1)
866 : end do
867 0 : call qsat(vtemp1(1:2*len1), vtemp2(1:2*len1), &
868 177473 : vtemp5(1:2*len1), vtemp3(1:2*len1), 2*len1, gam=vtemp4(1:2*len1))
869 1167531 : do ii=1,len1
870 990058 : i = indx1(ii)
871 990058 : shbs(i,k ) = vtemp3(ii )
872 990058 : shbs(i,k-1) = vtemp3(ii+len1)
873 990058 : gam(i,k ) = vtemp4(ii )
874 990058 : gam(i,k-1) = vtemp4(ii+len1)
875 990058 : sb (i,k ) = sb(i,k ) + ds2(i)
876 990058 : sb (i,k-1) = sb(i,k-1) + ds3(i)
877 990058 : hb (i,k ) = sb(i,k ) + hlat*shb(i,k )
878 990058 : hb (i,k-1) = sb(i,k-1) + hlat*shb(i,k-1)
879 990058 : hbs(i,k ) = sb(i,k ) + hlat*shbs(i,k )
880 1167531 : hbs(i,k-1) = sb(i,k-1) + hlat*shbs(i,k-1)
881 : end do
882 :
883 : ! Update thermodynamic information at half (i.e., interface) levels
884 1167531 : do ii=1,len1
885 990058 : i = indx1(ii)
886 990058 : sbh (i,k) = 0.5_kind_phys*(sb(i,k) + sb(i,k-1))
887 990058 : shbh(i,k) = qhalf(shb(i,k-1),shb(i,k),shbs(i,k-1),shbs(i,k))
888 990058 : hbh (i,k) = sbh(i,k) + hlat*shbh(i,k)
889 990058 : sbh (i,k-1) = 0.5_kind_phys*(sb(i,k-1) + sb(i,k-2))
890 990058 : shbh(i,k-1) = qhalf(shb(i,k-2),shb(i,k-1),shbs(i,k-2),shbs(i,k-1))
891 1167531 : hbh (i,k-1) = sbh(i,k-1) + hlat*shbh(i,k-1)
892 : end do
893 : end if ! k /= limcnv+1
894 :
895 : ! Ensure that dzcld is reset if convective mass flux zero
896 : ! specify the current vertical extent of the convective activity
897 : ! top of convective layer determined by size of overshoot param.
898 2926547 : do i=1,ncol
899 2678682 : etagt0 = eta(i).gt.0.0_kind_phys
900 2678682 : if ( .not. etagt0) dzcld(i) = 0.0_kind_phys
901 2678682 : if (etagt0 .and. beta(i) > betamn) then
902 421788 : ktp = k-1
903 : else
904 2256894 : ktp = k
905 : end if
906 2856155 : if (etagt0) then
907 983841 : cnt_sh(i) = min(cnt_sh(i),ktp)
908 983841 : cnb_sh(i) = max(cnb_sh(i),k)
909 : end if
910 : end do
911 : end do kloop
912 :
913 : !---------------------------------------------------
914 : ! apply final thermodynamic tendencies
915 : !---------------------------------------------------
916 : ! Set output q tendencies...
917 : ! ...for water vapor
918 28436184 : dq(:ncol,:,const_wv_idx) = cmfdq(:ncol,:)
919 :
920 : ! ...for other tracers from passive tracer transport
921 281568 : do m = 1, pcnst
922 281568 : if (m .ne. const_wv_idx) then
923 56872368 : dq(:ncol,:,m) = (dq(:ncol,:,m) - q(:ncol,:,m))/ztodt
924 : endif
925 : enddo
926 :
927 : ! Kludge to prevent cnb_sh-cnt_sh from being zero (in the event
928 : ! someone decides that they want to divide by this quantity)
929 1090992 : do i=1,ncol
930 1090992 : if (cnb_sh(i) /= 0 .and. cnb_sh(i) == cnt_sh(i)) then
931 234347 : cnt_sh(i) = cnt_sh(i) - 1
932 : end if
933 : end do
934 :
935 1090992 : do i=1,ncol
936 1090992 : precc(i) = prec(i)*rtdt
937 : end do
938 :
939 : ! Compute reserved liquid (not yet in cldliq) for energy integrals.
940 : ! Treat rliq_sh as flux out bottom, to be added back later.
941 1900584 : do k = 1, pver
942 28436184 : do i = 1, ncol
943 28365792 : rliq_sh(i) = rliq_sh(i) + qc_sh(i,k)*pdel(i,k)/grav
944 : end do
945 : end do
946 :
947 : ! rliq_sh is converted to precipitation units [m s-1]
948 1090992 : rliq_sh(:ncol) = rliq_sh(:ncol) / 1000._kind_phys
949 :
950 : ! Prepare boundary fluxes for check_energy [m s-1]
951 1090992 : flx_cnd(:ncol) = precc(:ncol) + rliq_sh(:ncol)
952 :
953 70392 : if(debug_verbose) then
954 : ! DEBUG DIAGNOSTICS - show final result
955 0 : do i=1,ncol
956 0 : if (i == 1) then
957 0 : fac = grav*864._kind_phys
958 0 : write(iulog, 8010)
959 0 : do k=limcnv,pver
960 0 : rh = shb(i,k)/shbs(i,k)
961 0 : write(iulog, 8020) shbh(i,k),sbh(i,k),hbh(i,k),fac*cmfmc_sh(i,k), &
962 0 : cmfsl(i,k), cmflq(i,k)
963 0 : write(iulog, 8040) tb(i,k),shb(i,k),rh ,sb(i,k),hb(i,k), &
964 0 : hbs(i,k), ztodt*cmfdt(i,k),ztodt*cmfdq(i,k), &
965 0 : ztodt*cmfdqr(i,k)
966 : end do
967 0 : write(iulog, 8000) prec(i)
968 :
969 : ! approximate vertical integral of moist static energy and
970 : ! total preciptable water after adjustment and output changes
971 0 : hsum2 = 0.0_kind_phys
972 0 : qsum2 = 0.0_kind_phys
973 0 : do k=limcnv,pver
974 0 : hsum2 = hsum2 + pdel(i,k)*rgrav*hb(i,k)
975 0 : qsum2 = qsum2 + pdel(i,k)*rgrav*shb(i,k)
976 : end do
977 0 : write(iulog,8070) hsum1, hsum2, abs(hsum2-hsum1)/hsum2, &
978 0 : qsum1, qsum2, abs(qsum2-qsum1)/qsum2
979 : end if
980 : enddo
981 : endif
982 :
983 : ! Diagnostic use format strings
984 : 8000 format(///,10x,'PREC = ',3pf12.6,/)
985 : 8010 format('1** TB SHB RH SB', &
986 : ' HB HBS CAH CAM PRECC ', &
987 : ' ETA FSL FLQ **', /)
988 : 8020 format(' ----- ', 9x,3p,f7.3,2x,2p, 9x,-3p,f7.3,2x, &
989 : f7.3, 37x, 0p,2x,f8.2, 0p,2x,f8.2,2x,f8.2, ' ----- ')
990 : 8030 format(' ----- ', 0p,82x,f8.2, 0p,2x,f8.2,2x,f8.2, &
991 : ' ----- ')
992 : 8040 format(' - - - ',f7.3,2x,3p,f7.3,2x,2p,f7.3,2x,-3p,f7.3,2x, &
993 : f7.3, 2x,f8.3,2x,0p,f7.3,3p,2x,f7.3,2x,f7.3,30x, &
994 : ' - - - ')
995 : 8050 format(' ----- ',110x,' ----- ')
996 : 8060 format('1 K =>', i4,/, &
997 : ' TB SHB RH SB', &
998 : ' HB HBS CAH CAM PREC ', &
999 : ' ETA FSL FLQ', /)
1000 : 8070 format(' VERTICALLY INTEGRATED MOIST STATIC ENERGY BEFORE, AFTER', &
1001 : ' AND PERCENTAGE DIFFERENCE => ',1p,2e15.7,2x,2p,f7.3,/, &
1002 : ' VERTICALLY INTEGRATED MOISTURE BEFORE, AFTER', &
1003 : ' AND PERCENTAGE DIFFERENCE => ',1p,2e15.7,2x,2p,f7.3,/)
1004 : 8080 format(' BETA, ETA => ', 1p,2e12.3)
1005 : 8090 format (' k+1, sc, shc, hc => ', 1x, i2, 1p, 3e12.4)
1006 70392 : end subroutine hack_convect_shallow_run
1007 :
1008 : ! qhalf computes the specific humidity at interface levels between two model layers (interpolate moisture)
1009 23412716 : pure function qhalf(sh1,sh2,shbs1,shbs2) result(qh)
1010 : real(kind_phys), intent(in) :: sh1 ! humidity of layer 1 [kg kg-1]
1011 : real(kind_phys), intent(in) :: sh2 ! humidity of layer 2 [kg kg-1]
1012 : real(kind_phys), intent(in) :: shbs1 ! saturation specific humidity of layer 1 [kg kg-1]
1013 : real(kind_phys), intent(in) :: shbs2 ! saturation specific humidity of layer 2 [kg kg-1]
1014 : real(kind_phys) :: qh
1015 23412716 : qh = min(max(sh1,sh2),(shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
1016 23412716 : end function qhalf
1017 : end module hack_convect_shallow
|