CCPP SciDoc v7.0.x  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
gfdl_cloud_microphys_v3_mod.F90
1
3
4!***********************************************************************
5!* GNU Lesser General Public License
6!*
7!* This file is part of the FV3 dynamical core.
8!*
9!* The FV3 dynamical core is free software: you can redistribute it
10!* and/or modify it under the terms of the
11!* GNU Lesser General Public License as published by the
12!* Free Software Foundation, either version 3 of the License, or
13!* (at your option) any later version.
14!*
15!* The FV3 dynamical core is distributed in the hope that it will be
16!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty
17!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
18!* See the GNU General Public License for more details.
19!*
20!* You should have received a copy of the GNU Lesser General Public
21!* License along with the FV3 dynamical core.
22!* If not, see <http://www.gnu.org/licenses/>.
23!***********************************************************************
24
25! =======================================================================
26! GFDL Cloud Microphysics Package (GFDL MP) Version 3
27! The algorithms are originally derived from Lin et al. (1983).
28! Most of the key elements have been simplified / improved.
29! This code at this stage bears little to no similarity to the original Lin MP in ZETAC.
30! Developers: Linjiong Zhou and the GFDL FV3 Team
31! References:
32! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1)
33! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1)
34! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96)
35! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971)
36! =======================================================================
37
38module gfdl_cloud_microphys_v3_mod
39 use machine, only: kind_phys, r8 => kind_dbl_prec
40 use module_gfdlmp_param, only: read_gfdlmp_nml, &
41 t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, &
42 vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, &
43 vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, rh_inc, rh_ins,&
44 rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, ccn_l, ccn_o, &
45 igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, &
46 do_hail, inflag, c_psacw, c_psaci, c_pracs, c_psacr, c_pgacr, c_pgacs, c_pgacw, &
47 c_pgaci, z_slope_liq, z_slope_ice, prog_ccn, c_pracw, c_praci, rad_snow, &
48 rad_graupel, rad_rain, cld_min, sedflag, sed_fac, do_sedi_uv, do_sedi_w, &
49 do_sedi_heat, icloud_f, irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, &
50 do_cond_timescale, mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, &
51 use_rhc_revap, tau_wbf, do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, &
52 rhc_cevap, rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, &
53 regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, resmax, regmin, &
54 regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, radr_flag, rads_flag, &
55 radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, n0w_sig, n0i_sig, n0r_sig, &
56 n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, n0r_exp, n0s_exp, n0g_exp, n0h_exp, &
57 muw, mui, mur, mus, mug, muh, alinw, alini, alinr, alins, aling, alinh, blinw, &
58 blini, blinr, blins, bling, blinh, do_new_acc_water, do_new_acc_ice, is_fac, &
59 ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, snow_grauple_combine, do_psd_water_num, &
60 do_psd_ice_num, vdiffflag, rewfac, reifac, cp_heating, nconds, do_evap_timescale, &
61 delay_cond_evap, do_subgrid_proc, fast_fr_mlt, fast_dep_sub, qi_gen, tice
62 use physcons, only: grav => con_g, &
63 rgrav => con_1ovg, &
64 pi => con_pi, &
65 boltzmann => con_boltz, &
66 avogadro => con_sbc, &
67 rdgas => con_rd, &
68 rvgas => con_rv, &
69 zvir => con_fvirt, &
70 runiver => con_runiver, &
71 cp_air => con_cp, &
72 c_ice => con_csol, &
73 !c_liq => con_cliq, &
74 !e00 => con_psat, &
75 hlv => con_hvap, &
76 hlf => con_hfus, &
77 rho0 => rhoair_ifs, &
78 rhos => rhosnow, &
79 one_r8 => con_one, &
80 con_amd, con_amw, visd, &
81 visk, vdifu, tcond, cdg, &
82 cdh, rhow => rhocw, &
83 rhoi => rhoci, &
84 rhor => rhocr, &
85 rhog => rhocg, &
86 rhoh => rhoch, qcmin, qfmin
87 private
88
89 ! -----------------------------------------------------------------------
90 ! interface functions
91 ! -----------------------------------------------------------------------
92
93 interface wqs
94 procedure wes_t
95 procedure wqs_trho
96 procedure wqs_ptqv
97 end interface wqs
98
99 interface mqs
100 procedure mes_t
101 procedure mqs_trho
102 procedure mqs_ptqv
103 end interface mqs
104
105 interface iqs
106 procedure ies_t
107 procedure iqs_trho
108 procedure iqs_ptqv
109 end interface iqs
110
111 interface mhc
112 procedure mhc3
113 procedure mhc4
114 procedure mhc6
115 end interface mhc
116
117 interface wet_bulb
118 procedure wet_bulb_dry
119 procedure wet_bulb_moist
120 end interface wet_bulb
121
122 ! -----------------------------------------------------------------------
123 ! public subroutines and functions
124 ! -----------------------------------------------------------------------
125
126 public :: gfdl_cloud_microphys_v3_mod_init
127 public :: gfdl_cloud_microphys_v3_mod_driver
128 public :: gfdl_cloud_microphys_v3_mod_end
129 public :: cld_sat_adj, cld_eff_rad, rad_ref
130 public :: qs_init, wqs, mqs, mqs3d
131 public :: wet_bulb
132 public :: mtetw
133
134 ! -----------------------------------------------------------------------
135 ! initialization conditions
136 ! -----------------------------------------------------------------------
137
138 logical :: tables_are_initialized = .false. ! initialize satuation tables
139
140 ! -----------------------------------------------------------------------
141 ! Physical constants that differ from physcons
142 ! -----------------------------------------------------------------------
143 real(kind_phys), parameter :: c_liq = 4.218e3
144 real(kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS
145
146 ! -----------------------------------------------------------------------
147 ! derived physics constants
148 ! -----------------------------------------------------------------------
149 real(kind_phys), parameter :: mmd = con_amd*1e-3 ! (g/mol) -> (kg/mol)
150 real(kind_phys), parameter :: mmv = con_amw*1e-3 ! (g/mol) -> (kg/mol)
151 real(kind_phys), parameter :: cv_air = cp_air - rdgas
152 real(kind_phys), parameter :: cp_vap = 4.0 * rvgas
153 real(kind_phys), parameter :: cv_vap = 3.0 * rvgas
154 real(kind_phys), parameter :: dc_vap = cp_vap - c_liq
155 real(kind_phys), parameter :: dc_ice = c_liq - c_ice
156 real(kind_phys), parameter :: d2_ice = cp_vap - c_ice
157
158 ! -----------------------------------------------------------------------
159 ! predefined parameters
160 ! -----------------------------------------------------------------------
161
162 integer, parameter :: length = 2621 ! length of the saturation table
163 real(kind_phys), parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m)
164 real(kind_phys), parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011)
165 integer :: cfflag = 1 ! cloud fraction scheme
166 ! 1: GFDL cloud scheme
167 ! 2: Xu and Randall (1996)
168 ! 3: Park et al. (2016)
169 ! 4: Gultepe and Isaac (2007)
170
171 ! -----------------------------------------------------------------------
172 ! local shared variables
173 ! -----------------------------------------------------------------------
174 ! Set during init.
175 real(kind = r8) :: lv0
176 real(kind = r8) :: li0
177 real(kind = r8) :: li2
178
179 real(kind_phys) :: acco (3, 10), acc (20)
180 real(kind_phys) :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw
181 real(kind_phys) :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4)
182
183 real(kind_phys) :: t_wfr, fac_rc, c_air, c_vap, d0_vap
184
185 real (kind = r8) :: lv00, li00, li20, cpaut
186 real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice
187 real (kind = r8) :: normw, normr, normi, norms, normg, normh
188 real (kind = r8) :: expow, expor, expoi, expos, expog, expoh
189 real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah
190 real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh
191 real (kind = r8) :: edaw, edar, edai, edas, edag, edah
192 real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh
193 real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah
194 real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh
195 real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah
196 real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh
197 real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah
198 real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh
199
200 real(kind_phys), allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:)
201 real(kind_phys), allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:)
202
203contains
204
205! =======================================================================
206! GFDL cloud microphysics initialization
207! =======================================================================
208
209subroutine gfdl_cloud_microphys_v3_mod_init (me, master, nlunit, input_nml_file, logunit, &
210 fn_nml, hydrostatic, errmsg, errflg)
211
212 implicit none
213
214 ! -----------------------------------------------------------------------
215 ! input / output arguments
216 ! -----------------------------------------------------------------------
217
218 integer, intent (in) :: me
219 integer, intent (in) :: master
220 integer, intent (in) :: nlunit
221 integer, intent (in) :: logunit
222
223 character (len = 64), intent (in) :: fn_nml
224 character (len = *), intent (in) :: input_nml_file (:)
225 logical, intent (in) :: hydrostatic
226 character(len=*), intent(out) :: errmsg
227 integer, intent(out) :: errflg
228
229
230 ! -----------------------------------------------------------------------
231 ! local variables
232 ! -----------------------------------------------------------------------
233
234 integer :: ios
235 logical :: exists
236
237 ! Initialize CCPP error-handling
238 errflg = 0
239 errmsg = ''
240
241 ! -----------------------------------------------------------------------
242 ! Read namelist
243 ! -----------------------------------------------------------------------
244 call read_gfdlmp_nml(errmsg = errmsg, errflg = errflg, unit = nlunit, &
245 input_nml_file = input_nml_file, fn_nml = fn_nml, version=3, &
246 iostat = ios)
247
248 ! Initialize scheme parameters
249 lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg)
250 li0 = hlf - dc_ice * tice ! 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg)
251 li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg)
252
253 ! -----------------------------------------------------------------------
254 ! write version number and namelist to log file
255 ! -----------------------------------------------------------------------
256 if (me == master) then
257 write (logunit, *) " ================================================================== "
258 write (logunit, *) "gfdl_cloud_microphysics_nml_v3"
259 endif
260
261 ! -----------------------------------------------------------------------
262 ! initialize microphysics variables
263 ! -----------------------------------------------------------------------
264
265 if (.not. tables_are_initialized) call qs_init
266
267 call setup_mp
268
269 ! -----------------------------------------------------------------------
270 ! define various heat capacities and latent heat coefficients at 0 deg K
271 ! -----------------------------------------------------------------------
272
273 call setup_mhc_lhc (hydrostatic)
274
275end subroutine gfdl_cloud_microphys_v3_mod_init
276
277! =======================================================================
278! GFDL cloud microphysics driver
279! =======================================================================
280
281subroutine gfdl_cloud_microphys_v3_mod_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, &
282 ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, &
283 hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, &
284 prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, last_step, do_inline_mp)
285
286 implicit none
287
288 ! -----------------------------------------------------------------------
289 ! input / output arguments
290 ! -----------------------------------------------------------------------
291
292 integer, intent (in) :: is, ie, ks, ke
293
294 logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp
295
296 real(kind_phys), intent (in) :: dtm
297
298 real(kind_phys), intent (in), dimension (is:ie) :: hs, gsize
299
300 real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni
301
302 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa, te
303 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
304 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
305
306 real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa
307
308 real(kind_phys), intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel
309
310 real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: adj_vmr
311
312 real (kind = r8), intent (out), dimension (is:ie) :: dte
313
314 ! -----------------------------------------------------------------------
315 ! major cloud microphysics driver
316 ! -----------------------------------------------------------------------
317
318 call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, &
319 qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
320 gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, &
321 prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, .false., .true.)
322
323end subroutine gfdl_cloud_microphys_v3_mod_driver
324
325! =======================================================================
326! GFDL cloud microphysics end
327! =======================================================================
328
329subroutine gfdl_cloud_microphys_v3_mod_end
330
331 implicit none
332
333 ! -----------------------------------------------------------------------
334 ! free up memory
335 ! -----------------------------------------------------------------------
336
337 deallocate (table0)
338 deallocate (table1)
339 deallocate (table2)
340 deallocate (table3)
341 deallocate (table4)
342 deallocate (des0)
343 deallocate (des1)
344 deallocate (des2)
345 deallocate (des3)
346 deallocate (des4)
347
348 tables_are_initialized = .false.
349
350end subroutine gfdl_cloud_microphys_v3_mod_end
351
352! =======================================================================
353! setup cloud microphysics parameters
354! =======================================================================
355
356subroutine setup_mp
357
358 implicit none
359
360 integer :: i, k
361
362 real(kind_phys) :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone
363
364 ! -----------------------------------------------------------------------
365 ! complete freezing temperature
366 ! -----------------------------------------------------------------------
367
368 if (do_warm_rain_mp) then
369 t_wfr = t_min
370 else
371 t_wfr = tice - 40.0
372 endif
373
374 ! -----------------------------------------------------------------------
375 ! cloud water autoconversion, Hong et al. (2004)
376 ! -----------------------------------------------------------------------
377
378 fac_rc = (4. / 3.) * pi * rhow * rthresh ** 3
379
380 aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.)
381 cpaut = c_paut * aone * grav / visd
382
383 ! -----------------------------------------------------------------------
384 ! terminal velocities parameters, Lin et al. (1983)
385 ! -----------------------------------------------------------------------
386
387 gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5
388 hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5
389
390 ! -----------------------------------------------------------------------
391 ! part of the slope parameters
392 ! -----------------------------------------------------------------------
393
394 normw = pi * rhow * n0w_sig * gamma(muw + 3)
395 normi = pi * rhoi * n0i_sig * gamma(mui + 3)
396 normr = pi * rhor * n0r_sig * gamma(mur + 3)
397 norms = pi * rhos * n0s_sig * gamma(mus + 3)
398 normg = pi * rhog * n0g_sig * gamma(mug + 3)
399 normh = pi * rhoh * n0h_sig * gamma(muh + 3)
400
401 expow = exp(n0w_exp / (muw + 3) * log(10.))
402 expoi = exp(n0i_exp / (mui + 3) * log(10.))
403 expor = exp(n0r_exp / (mur + 3) * log(10.))
404 expos = exp(n0s_exp / (mus + 3) * log(10.))
405 expog = exp(n0g_exp / (mug + 3) * log(10.))
406 expoh = exp(n0h_exp / (muh + 3) * log(10.))
407
408 ! -----------------------------------------------------------------------
409 ! parameters for particle concentration (pc), effective diameter (ed),
410 ! optical extinction (oe), radar reflectivity factor (rr), and
411 ! mass-weighted terminal velocity (tv)
412 ! -----------------------------------------------------------------------
413
414 pcaw = exp(3 / (muw + 3) * log(n0w_sig)) * gamma(muw) * exp(3 * n0w_exp / (muw + 3) * log(10.))
415 pcai = exp(3 / (mui + 3) * log(n0i_sig)) * gamma(mui) * exp(3 * n0i_exp / (mui + 3) * log(10.))
416 pcar = exp(3 / (mur + 3) * log(n0r_sig)) * gamma(mur) * exp(3 * n0r_exp / (mur + 3) * log(10.))
417 pcas = exp(3 / (mus + 3) * log(n0s_sig)) * gamma(mus) * exp(3 * n0s_exp / (mus + 3) * log(10.))
418 pcag = exp(3 / (mug + 3) * log(n0g_sig)) * gamma(mug) * exp(3 * n0g_exp / (mug + 3) * log(10.))
419 pcah = exp(3 / (muh + 3) * log(n0h_sig)) * gamma(muh) * exp(3 * n0h_exp / (muh + 3) * log(10.))
420
421 pcbw = exp(muw / (muw + 3) * log(pi * rhow * gamma(muw + 3)))
422 pcbi = exp(mui / (mui + 3) * log(pi * rhoi * gamma(mui + 3)))
423 pcbr = exp(mur / (mur + 3) * log(pi * rhor * gamma(mur + 3)))
424 pcbs = exp(mus / (mus + 3) * log(pi * rhos * gamma(mus + 3)))
425 pcbg = exp(mug / (mug + 3) * log(pi * rhog * gamma(mug + 3)))
426 pcbh = exp(muh / (muh + 3) * log(pi * rhoh * gamma(muh + 3)))
427
428 edaw = exp(- 1. / (muw + 3) * log(n0w_sig)) * (muw + 2) * exp(- n0w_exp / (muw + 3) * log(10.))
429 edai = exp(- 1. / (mui + 3) * log(n0i_sig)) * (mui + 2) * exp(- n0i_exp / (mui + 3) * log(10.))
430 edar = exp(- 1. / (mur + 3) * log(n0r_sig)) * (mur + 2) * exp(- n0r_exp / (mur + 3) * log(10.))
431 edas = exp(- 1. / (mus + 3) * log(n0s_sig)) * (mus + 2) * exp(- n0s_exp / (mus + 3) * log(10.))
432 edag = exp(- 1. / (mug + 3) * log(n0g_sig)) * (mug + 2) * exp(- n0g_exp / (mug + 3) * log(10.))
433 edah = exp(- 1. / (muh + 3) * log(n0h_sig)) * (muh + 2) * exp(- n0h_exp / (muh + 3) * log(10.))
434
435 edbw = exp(1. / (muw + 3) * log(pi * rhow * gamma(muw + 3)))
436 edbi = exp(1. / (mui + 3) * log(pi * rhoi * gamma(mui + 3)))
437 edbr = exp(1. / (mur + 3) * log(pi * rhor * gamma(mur + 3)))
438 edbs = exp(1. / (mus + 3) * log(pi * rhos * gamma(mus + 3)))
439 edbg = exp(1. / (mug + 3) * log(pi * rhog * gamma(mug + 3)))
440 edbh = exp(1. / (muh + 3) * log(pi * rhoh * gamma(muh + 3)))
441
442 oeaw = exp(1. / (muw + 3) * log(n0w_sig)) * pi * gamma(muw + 2) * &
443 exp(n0w_exp / (muw + 3) * log(10.))
444 oeai = exp(1. / (mui + 3) * log(n0i_sig)) * pi * gamma(mui + 2) * &
445 exp(n0i_exp / (mui + 3) * log(10.))
446 oear = exp(1. / (mur + 3) * log(n0r_sig)) * pi * gamma(mur + 2) * &
447 exp(n0r_exp / (mur + 3) * log(10.))
448 oeas = exp(1. / (mus + 3) * log(n0s_sig)) * pi * gamma(mus + 2) * &
449 exp(n0s_exp / (mus + 3) * log(10.))
450 oeag = exp(1. / (mug + 3) * log(n0g_sig)) * pi * gamma(mug + 2) * &
451 exp(n0g_exp / (mug + 3) * log(10.))
452 oeah = exp(1. / (muh + 3) * log(n0h_sig)) * pi * gamma(muh + 2) * &
453 exp(n0h_exp / (muh + 3) * log(10.))
454
455 oebw = 2 * exp((muw + 2) / (muw + 3) * log(pi * rhow * gamma(muw + 3)))
456 oebi = 2 * exp((mui + 2) / (mui + 3) * log(pi * rhoi * gamma(mui + 3)))
457 oebr = 2 * exp((mur + 2) / (mur + 3) * log(pi * rhor * gamma(mur + 3)))
458 oebs = 2 * exp((mus + 2) / (mus + 3) * log(pi * rhos * gamma(mus + 3)))
459 oebg = 2 * exp((mug + 2) / (mug + 3) * log(pi * rhog * gamma(mug + 3)))
460 oebh = 2 * exp((muh + 2) / (muh + 3) * log(pi * rhoh * gamma(muh + 3)))
461
462 rraw = exp(- 3 / (muw + 3) * log(n0w_sig)) * gamma(muw + 6) * &
463 exp(- 3 * n0w_exp / (muw + 3) * log(10.))
464 rrai = exp(- 3 / (mui + 3) * log(n0i_sig)) * gamma(mui + 6) * &
465 exp(- 3 * n0i_exp / (mui + 3) * log(10.))
466 rrar = exp(- 3 / (mur + 3) * log(n0r_sig)) * gamma(mur + 6) * &
467 exp(- 3 * n0r_exp / (mur + 3) * log(10.))
468 rras = exp(- 3 / (mus + 3) * log(n0s_sig)) * gamma(mus + 6) * &
469 exp(- 3 * n0s_exp / (mus + 3) * log(10.))
470 rrag = exp(- 3 / (mug + 3) * log(n0g_sig)) * gamma(mug + 6) * &
471 exp(- 3 * n0g_exp / (mug + 3) * log(10.))
472 rrah = exp(- 3 / (muh + 3) * log(n0h_sig)) * gamma(muh + 6) * &
473 exp(- 3 * n0h_exp / (muh + 3) * log(10.))
474
475 rrbw = exp((muw + 6) / (muw + 3) * log(pi * rhow * gamma(muw + 3)))
476 rrbi = exp((mui + 6) / (mui + 3) * log(pi * rhoi * gamma(mui + 3)))
477 rrbr = exp((mur + 6) / (mur + 3) * log(pi * rhor * gamma(mur + 3)))
478 rrbs = exp((mus + 6) / (mus + 3) * log(pi * rhos * gamma(mus + 3)))
479 rrbg = exp((mug + 6) / (mug + 3) * log(pi * rhog * gamma(mug + 3)))
480 rrbh = exp((muh + 6) / (muh + 3) * log(pi * rhoh * gamma(muh + 3)))
481
482 tvaw = exp(- blinw / (muw + 3) * log(n0w_sig)) * alinw * gamma(muw + blinw + 3) * &
483 exp(- blinw * n0w_exp / (muw + 3) * log(10.))
484 tvai = exp(- blini / (mui + 3) * log(n0i_sig)) * alini * gamma(mui + blini + 3) * &
485 exp(- blini * n0i_exp / (mui + 3) * log(10.))
486 tvar = exp(- blinr / (mur + 3) * log(n0r_sig)) * alinr * gamma(mur + blinr + 3) * &
487 exp(- blinr * n0r_exp / (mur + 3) * log(10.))
488 tvas = exp(- blins / (mus + 3) * log(n0s_sig)) * alins * gamma(mus + blins + 3) * &
489 exp(- blins * n0s_exp / (mus + 3) * log(10.))
490 tvag = exp(- bling / (mug + 3) * log(n0g_sig)) * aling * gamma(mug + bling + 3) * &
491 exp(- bling * n0g_exp / (mug + 3) * log(10.)) * gcon
492 tvah = exp(- blinh / (muh + 3) * log(n0h_sig)) * alinh * gamma(muh + blinh + 3) * &
493 exp(- blinh * n0h_exp / (muh + 3) * log(10.)) * hcon
494
495 tvbw = exp(blinw / (muw + 3) * log(pi * rhow * gamma(muw + 3))) * gamma(muw + 3)
496 tvbi = exp(blini / (mui + 3) * log(pi * rhoi * gamma(mui + 3))) * gamma(mui + 3)
497 tvbr = exp(blinr / (mur + 3) * log(pi * rhor * gamma(mur + 3))) * gamma(mur + 3)
498 tvbs = exp(blins / (mus + 3) * log(pi * rhos * gamma(mus + 3))) * gamma(mus + 3)
499 tvbg = exp(bling / (mug + 3) * log(pi * rhog * gamma(mug + 3))) * gamma(mug + 3)
500 tvbh = exp(blinh / (muh + 3) * log(pi * rhoh * gamma(muh + 3))) * gamma(muh + 3)
501
502 ! -----------------------------------------------------------------------
503 ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983)
504 ! -----------------------------------------------------------------------
505
506 scm3 = exp(1. / 3. * log(visk / vdifu))
507
508 pisq = pi * pi
509
510 ! -----------------------------------------------------------------------
511 ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983)
512 ! -----------------------------------------------------------------------
513
514 cracw = pi * n0r_sig * alinr * gamma(2 + mur + blinr) / &
515 (4. * exp((2 + mur + blinr) / (mur + 3) * log(normr))) * &
516 exp((1 - blinr) * log(expor))
517 craci = pi * n0r_sig * alinr * gamma(2 + mur + blinr) / &
518 (4. * exp((2 + mur + blinr) / (mur + 3) * log(normr))) * &
519 exp((1 - blinr) * log(expor))
520 csacw = pi * n0s_sig * alins * gamma(2 + mus + blins) / &
521 (4. * exp((2 + mus + blins) / (mus + 3) * log(norms))) * &
522 exp((1 - blins) * log(expos))
523 csaci = pi * n0s_sig * alins * gamma(2 + mus + blins) / &
524 (4. * exp((2 + mus + blins) / (mus + 3) * log(norms))) * &
525 exp((1 - blins) * log(expos))
526 if (do_hail) then
527 cgacw = pi * n0h_sig * alinh * gamma(2 + muh + blinh) * hcon / &
528 (4. * exp((2 + muh + blinh) / (muh + 3) * log(normh))) * &
529 exp((1 - blinh) * log(expoh))
530 cgaci = pi * n0h_sig * alinh * gamma(2 + muh + blinh) * hcon / &
531 (4. * exp((2 + muh + blinh) / (muh + 3) * log(normh))) * &
532 exp((1 - blinh) * log(expoh))
533 else
534 cgacw = pi * n0g_sig * aling * gamma(2 + mug + bling) * gcon / &
535 (4. * exp((2 + mug + bling) / (mug + 3) * log(normg))) * &
536 exp((1 - bling) * log(expog))
537 cgaci = pi * n0g_sig * aling * gamma(2 + mug + bling) * gcon / &
538 (4. * exp((2 + mug + bling) / (mug + 3) * log(normg))) * &
539 exp((1 - bling) * log(expog))
540 endif
541
542 if (do_new_acc_water) then
543
544 cracw = pisq * n0r_sig * n0w_sig * rhow / 24.
545 csacw = pisq * n0s_sig * n0w_sig * rhow / 24.
546 if (do_hail) then
547 cgacw = pisq * n0h_sig * n0w_sig * rhow / 24.
548 else
549 cgacw = pisq * n0g_sig * n0w_sig * rhow / 24.
550 endif
551
552 endif
553
554 if (do_new_acc_ice) then
555
556 craci = pisq * n0r_sig * n0i_sig * rhoi / 24.
557 csaci = pisq * n0s_sig * n0i_sig * rhoi / 24.
558 if (do_hail) then
559 cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24.
560 else
561 cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24.
562 endif
563
564 endif
565
566 cracw = cracw * c_pracw
567 craci = craci * c_praci
568 csacw = csacw * c_psacw
569 csaci = csaci * c_psaci
570 cgacw = cgacw * c_pgacw
571 cgaci = cgaci * c_pgaci
572
573 ! -----------------------------------------------------------------------
574 ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983)
575 ! -----------------------------------------------------------------------
576
577 cracs = pisq * n0r_sig * n0s_sig * rhos / 24.
578 csacr = pisq * n0s_sig * n0r_sig * rhor / 24.
579 if (do_hail) then
580 cgacr = pisq * n0h_sig * n0r_sig * rhor / 24.
581 cgacs = pisq * n0h_sig * n0s_sig * rhos / 24.
582 else
583 cgacr = pisq * n0g_sig * n0r_sig * rhor / 24.
584 cgacs = pisq * n0g_sig * n0s_sig * rhos / 24.
585 endif
586
587 cracs = cracs * c_pracs
588 csacr = csacr * c_psacr
589 cgacr = cgacr * c_pgacr
590 cgacs = cgacs * c_pgacs
591
592 ! act / ace / acc:
593 ! 1 - 2: racs (s - r)
594 ! 3 - 4: sacr (r - s)
595 ! 5 - 6: gacr (r - g)
596 ! 7 - 8: gacs (s - g)
597 ! 9 - 10: racw (w - r)
598 ! 11 - 12: raci (i - r)
599 ! 13 - 14: sacw (w - s)
600 ! 15 - 16: saci (i - s)
601 ! 17 - 18: sacw (w - g)
602 ! 19 - 20: saci (i - g)
603
604 act(1) = norms
605 act(2) = normr
606 act(3) = act(2)
607 act(4) = act(1)
608 act(5) = act(2)
609 if (do_hail) then
610 act(6) = normh
611 else
612 act(6) = normg
613 endif
614 act(7) = act(1)
615 act(8) = act(6)
616 act(9) = normw
617 act(10) = act(2)
618 act(11) = normi
619 act(12) = act(2)
620 act(13) = act(9)
621 act(14) = act(1)
622 act(15) = act(11)
623 act(16) = act(1)
624 act(17) = act(9)
625 act(18) = act(6)
626 act(19) = act(11)
627 act(20) = act(6)
628
629 ace(1) = expos
630 ace(2) = expor
631 ace(3) = ace(2)
632 ace(4) = ace(1)
633 ace(5) = ace(2)
634 if (do_hail) then
635 ace(6) = expoh
636 else
637 ace(6) = expog
638 endif
639 ace(7) = ace(1)
640 ace(8) = ace(6)
641 ace(9) = expow
642 ace(10) = ace(2)
643 ace(11) = expoi
644 ace(12) = ace(2)
645 ace(13) = ace(9)
646 ace(14) = ace(1)
647 ace(15) = ace(11)
648 ace(16) = ace(1)
649 ace(17) = ace(9)
650 ace(18) = ace(6)
651 ace(19) = ace(11)
652 ace(20) = ace(6)
653
654 acc(1) = mus
655 acc(2) = mur
656 acc(3) = acc(2)
657 acc(4) = acc(1)
658 acc(5) = acc(2)
659 if (do_hail) then
660 acc(6) = muh
661 else
662 acc(6) = mug
663 endif
664 acc(7) = acc(1)
665 acc(8) = acc(6)
666 acc(9) = muw
667 acc(10) = acc(2)
668 acc(11) = mui
669 acc(12) = acc(2)
670 acc(13) = acc(9)
671 acc(14) = acc(1)
672 acc(15) = acc(11)
673 acc(16) = acc(1)
674 acc(17) = acc(9)
675 acc(18) = acc(6)
676 acc(19) = acc(11)
677 acc(20) = acc(6)
678
679 occ(1) = 1.
680 occ(2) = 2.
681 occ(3) = 1.
682
683 do i = 1, 3
684 do k = 1, 10
685 acco(i, k) = occ(i) * gamma(6 + acc(2 * k - 1) - i) * gamma(acc(2 * k) + i - 1) / &
686 (exp((6 + acc(2 * k - 1) - i) / (acc(2 * k - 1) + 3) * log(act(2 * k - 1))) * &
687 exp((acc(2 * k) + i - 1) / (acc(2 * k) + 3) * log(act(2 * k)))) * &
688 exp((i - 3) * log(ace(2 * k - 1))) * exp((4 - i) * log(ace(2 * k)))
689 enddo
690 enddo
691
692 ! -----------------------------------------------------------------------
693 ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983)
694 ! -----------------------------------------------------------------------
695
696 crevp(1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma(1 + mur) / &
697 exp((1 + mur) / (mur + 3) * log(normr)) * exp(2.0 * log(expor))
698 crevp(2) = 0.78
699 crevp(3) = 0.31 * scm3 * sqrt(alinr / visk) * gamma((3 + 2 * mur + blinr) / 2) / &
700 exp((3 + 2 * mur + blinr) / (mur + 3) / 2 * log(normr)) * &
701 exp((1 + mur) / (mur + 3) * log(normr)) / gamma(1 + mur) * &
702 exp((- 1 - blinr) / 2. * log(expor))
703 crevp(4) = tcond * rvgas
704 crevp(5) = vdifu
705
706 cssub(1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma(1 + mus) / &
707 exp((1 + mus) / (mus + 3) * log(norms)) * exp(2.0 * log(expos))
708 cssub(2) = 0.78
709 cssub(3) = 0.31 * scm3 * sqrt(alins / visk) * gamma((3 + 2 * mus + blins) / 2) / &
710 exp((3 + 2 * mus + blins) / (mus + 3) / 2 * log(norms)) * &
711 exp((1 + mus) / (mus + 3) * log(norms)) / gamma(1 + mus) * &
712 exp((- 1 - blins) / 2. * log(expos))
713 cssub(4) = tcond * rvgas
714 cssub(5) = vdifu
715
716 if (do_hail) then
717 cgsub(1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma(1 + muh) / &
718 exp((1 + muh) / (muh + 3) * log(normh)) * exp(2.0 * log(expoh))
719 cgsub(2) = 0.78
720 cgsub(3) = 0.31 * scm3 * sqrt(alinh * hcon / visk) * gamma((3 + 2 * muh + blinh) / 2) / &
721 exp(1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log(normh)) * &
722 exp(1. / (muh + 3) * (1 + muh) * log(normh)) / gamma(1 + muh) * &
723 exp((- 1 - blinh) / 2. * log(expoh))
724 else
725 cgsub(1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma(1 + mug) / &
726 exp((1 + mug) / (mug + 3) * log(normg)) * exp(2.0 * log(expog))
727 cgsub(2) = 0.78
728 cgsub(3) = 0.31 * scm3 * sqrt(aling * gcon / visk) * gamma((3 + 2 * mug + bling) / 2) / &
729 exp((3 + 2 * mug + bling) / (mug + 3) / 2 * log(normg)) * &
730 exp((1 + mug) / (mug + 3) * log(normg)) / gamma(1 + mug) * &
731 exp((- 1 - bling) / 2. * log(expog))
732 endif
733 cgsub(4) = tcond * rvgas
734 cgsub(5) = vdifu
735
736 ! -----------------------------------------------------------------------
737 ! snow melting, Lin et al. (1983)
738 ! -----------------------------------------------------------------------
739
740 csmlt(1) = 2. * pi * tcond * n0s_sig * gamma(1 + mus) / &
741 exp((1 + mus) / (mus + 3) * log(norms)) * exp(2.0 * log(expos))
742 csmlt(2) = 2. * pi * vdifu * n0s_sig * gamma(1 + mus) / &
743 exp((1 + mus) / (mus + 3) * log(norms)) * exp(2.0 * log(expos))
744 csmlt(3) = cssub(2)
745 csmlt(4) = cssub(3)
746
747 ! -----------------------------------------------------------------------
748 ! graupel or hail melting, Lin et al. (1983)
749 ! -----------------------------------------------------------------------
750
751 if (do_hail) then
752 cgmlt(1) = 2. * pi * tcond * n0h_sig * gamma(1 + muh) / &
753 exp((1 + muh) / (muh + 3) * log(normh)) * exp(2.0 * log(expoh))
754 cgmlt(2) = 2. * pi * vdifu * n0h_sig * gamma(1 + muh) / &
755 exp((1 + muh) / (muh + 3) * log(normh)) * exp(2.0 * log(expoh))
756 else
757 cgmlt(1) = 2. * pi * tcond * n0g_sig * gamma(1 + mug) / &
758 exp((1 + mug) / (mug + 3) * log(normg)) * exp(2.0 * log(expog))
759 cgmlt(2) = 2. * pi * vdifu * n0g_sig * gamma(1 + mug) / &
760 exp((1 + mug) / (mug + 3) * log(normg)) * exp(2.0 * log(expog))
761 endif
762 cgmlt(3) = cgsub(2)
763 cgmlt(4) = cgsub(3)
764
765 ! -----------------------------------------------------------------------
766 ! rain freezing, Lin et al. (1983)
767 ! -----------------------------------------------------------------------
768
769 cgfr(1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma(6 + mur) / &
770 exp((6 + mur) / (mur + 3) * log(normr)) * exp(- 3.0 * log(expor))
771 cgfr(2) = 0.66
772
773end subroutine setup_mp
774
775! =======================================================================
776! define various heat capacities and latent heat coefficients at 0 deg K
777! =======================================================================
778
779subroutine setup_mhc_lhc (hydrostatic)
780
781 implicit none
782
783 ! -----------------------------------------------------------------------
784 ! input / output arguments
785 ! -----------------------------------------------------------------------
786
787 logical, intent (in) :: hydrostatic
788
789 if (hydrostatic) then
790 c_air = cp_air
791 c_vap = cp_vap
792 do_sedi_w = .false.
793 else
794 c_air = cv_air
795 c_vap = cv_vap
796 endif
797 d0_vap = c_vap - c_liq
798
799 ! scaled constants (to reduce float point errors for 32-bit)
800
801 d1_vap = d0_vap / c_air
802 d1_ice = dc_ice / c_air
803
804 lv00 = (hlv - d0_vap * tice) / c_air
805 li00 = (hlf - dc_ice * tice) / c_air
806 li20 = lv00 + li00
807
808 c1_vap = c_vap / c_air
809 c1_liq = c_liq / c_air
810 c1_ice = c_ice / c_air
811
812end subroutine setup_mhc_lhc
813
814! =======================================================================
815! major cloud microphysics driver
816! =======================================================================
817
818subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, &
819 qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
820 gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, &
821 prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, do_mp_fast, do_mp_full)
822
823 implicit none
824
825 ! -----------------------------------------------------------------------
826 ! input / output arguments
827 ! -----------------------------------------------------------------------
828
829 integer, intent (in) :: is, ie, ks, ke
830
831 logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp
832 logical, intent (in) :: do_mp_fast, do_mp_full
833
834 real(kind_phys), intent (in) :: dtm
835
836 real(kind_phys), intent (in), dimension (is:ie) :: gsize, hs
837
838 real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni
839
840 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa
841 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
842 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
843
844 real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa
845
846 real(kind_phys), intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel
847
848 real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr
849
850 real (kind = r8), intent (out), dimension (is:ie) :: dte
851
852 ! -----------------------------------------------------------------------
853 ! local variables
854 ! -----------------------------------------------------------------------
855
856 integer :: i, k
857
858 real(kind_phys) :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2
859 real(kind_phys) :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni
860
861 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0
862 real(kind_phys), dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz
863 real(kind_phys), dimension (ks:ke) :: den, pz, denfac, ccn, cin
864 real(kind_phys), dimension (ks:ke) :: u, v, w
865
866 real(kind_phys), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw
867 real(kind_phys), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi
868 real(kind_phys), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr
869 real(kind_phys), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs
870 real(kind_phys), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg
871
872 real(kind_phys), dimension (is:ie) :: condensation, deposition
873 real(kind_phys), dimension (is:ie) :: evaporation, sublimation
874
875 real (kind = r8) :: con_r8, c8, cp8
876
877 real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d
878 real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m
879
880 real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss
881 real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m
882
883 real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw
884
885 ! -----------------------------------------------------------------------
886 ! time steps
887 ! -----------------------------------------------------------------------
888
889 ntimes = max(ntimes, int(dtm / min(dtm, mp_time)))
890 dts = dtm / real(ntimes, kind=kind_phys)
891
892 ! -----------------------------------------------------------------------
893 ! initialization of total energy difference and condensation diag
894 ! -----------------------------------------------------------------------
895
896 dte = 0.0
897 cond = 0.0
898 adj_vmr = 1.0
899
900 condensation = 0.0
901 deposition = 0.0
902 evaporation = 0.0
903 sublimation = 0.0
904
905 ! -----------------------------------------------------------------------
906 ! unit convert to mm/day
907 ! -----------------------------------------------------------------------
908
909 convt = 86400. * rgrav / dtm
910
911 do i = is, ie
912
913 ! -----------------------------------------------------------------------
914 ! conversion of temperature
915 ! -----------------------------------------------------------------------
916
917 if (do_inline_mp) then
918 do k = ks, ke
919 q_cond = ql(i, k) + qr(i, k) + qi(i, k) + qs(i, k) + qg(i, k)
920 tz(k) = pt(i, k) / ((1. + zvir * qv(i, k)) * (1. - q_cond))
921 enddo
922 else
923 do k = ks, ke
924 tz(k) = pt(i, k)
925 enddo
926 endif
927
928 ! -----------------------------------------------------------------------
929 ! calculate base total energy
930 ! -----------------------------------------------------------------------
931
932 if (consv_te) then
933 if (hydrostatic) then
934 do k = ks, ke
935 te(i, k) = - c_air * tz(k) * delp(i, k)
936 enddo
937 else
938 do k = ks, ke
939 te(i, k) = - mte(qv(i, k), ql(i, k), qr(i, k), qi(i, k), &
940 qs(i, k), qg(i, k), tz(k), delp(i, k), .true.) * grav
941 enddo
942 endif
943 endif
944
945 ! -----------------------------------------------------------------------
946 ! total energy checker
947 ! -----------------------------------------------------------------------
948
949 if (consv_checker) then
950 call mtetw (ks, ke, qv(i, :), ql(i, :), qr(i, :), qi(i, :), &
951 qs(i, :), qg(i, :), tz, ua(i, :), va(i, :), wa(i, :), &
952 delp(i, :), dte(i), 0.0, water(i), rain(i), ice(i), &
953 snow(i), graupel(i), 0.0, 0.0, dtm, te_beg_m(i, :), &
954 tw_beg_m(i, :), te_b_beg_m(i), tw_b_beg_m(i), .true., hydrostatic)
955 endif
956
957 do k = ks, ke
958
959 ! -----------------------------------------------------------------------
960 ! convert specific ratios to mass mixing ratios
961 ! -----------------------------------------------------------------------
962
963 qvz(k) = qv(i, k)
964 qlz(k) = ql(i, k)
965 qrz(k) = qr(i, k)
966 qiz(k) = qi(i, k)
967 qsz(k) = qs(i, k)
968 qgz(k) = qg(i, k)
969 qaz(k) = qa(i, k)
970
971 if (do_inline_mp) then
972 q_cond = qlz(k) + qrz(k) + qiz(k) + qsz(k) + qgz(k)
973 con_r8 = one_r8 - (qvz(k) + q_cond)
974 else
975 con_r8 = one_r8 - qvz(k)
976 endif
977
978 dp0(k) = delp(i, k)
979 dp(k) = delp(i, k) * con_r8
980 con_r8 = one_r8 / con_r8
981 qvz(k) = qvz(k) * con_r8
982 qlz(k) = qlz(k) * con_r8
983 qrz(k) = qrz(k) * con_r8
984 qiz(k) = qiz(k) * con_r8
985 qsz(k) = qsz(k) * con_r8
986 qgz(k) = qgz(k) * con_r8
987
988 ! -----------------------------------------------------------------------
989 ! dry air density and layer-mean pressure thickness
990 ! -----------------------------------------------------------------------
991
992 dz(k) = delz(i, k)
993 den(k) = - dp(k) / (grav * dz(k))
994 pz(k) = den(k) * rdgas * tz(k)
995
996 ! -----------------------------------------------------------------------
997 ! for sedi_momentum transport
998 ! -----------------------------------------------------------------------
999
1000 u(k) = ua(i, k)
1001 v(k) = va(i, k)
1002 if (.not. hydrostatic) then
1003 w(k) = wa(i, k)
1004 endif
1005
1006 enddo
1007
1008 do k = ks, ke
1009 denfac(k) = sqrt(den(ke) / den(k))
1010 enddo
1011
1012 ! -----------------------------------------------------------------------
1013 ! total energy checker
1014 ! -----------------------------------------------------------------------
1015
1016 if (consv_checker) then
1017 call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, &
1018 dp, dte(i), 0.0, water(i), rain(i), ice(i), snow(i), &
1019 graupel(i), 0.0, 0.0, dtm, te_beg_d(i, :), tw_beg_d(i, :), &
1020 te_b_beg_d(i), tw_b_beg_d(i), .false., hydrostatic)
1021 endif
1022
1023 ! -----------------------------------------------------------------------
1024 ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN)
1025 ! -----------------------------------------------------------------------
1026
1027 if (prog_ccn) then
1028 do k = ks, ke
1029 ! boucher and lohmann (1995)
1030 nl = min(1., abs(hs(i)) / (10. * grav)) * &
1031 (10. ** 2.24 * (qnl(i, k) * den(k) * 1.e9) ** 0.257) + &
1032 (1. - min(1., abs(hs(i)) / (10. * grav))) * &
1033 (10. ** 2.06 * (qnl(i, k) * den(k) * 1.e9) ** 0.48)
1034 ni = qni(i, k)
1035 ccn(k) = max(10.0, nl) * 1.e6
1036 cin(k) = max(10.0, ni) * 1.e6
1037 ccn(k) = ccn(k) / den(k)
1038 cin(k) = cin(k) / den(k)
1039 enddo
1040 else
1041 ccn0 = (ccn_l * min(1., abs(hs(i)) / (10. * grav)) + &
1042 ccn_o * (1. - min(1., abs(hs(i)) / (10. * grav)))) * 1.e6
1043 cin0 = 0.0
1044 do k = ks, ke
1045 ccn(k) = ccn0 / den(k)
1046 cin(k) = cin0 / den(k)
1047 enddo
1048 endif
1049
1050 ! -----------------------------------------------------------------------
1051 ! subgrid deviation in horizontal direction
1052 ! default area dependent form: use dx ~ 100 km as the base
1053 ! -----------------------------------------------------------------------
1054
1055 t_lnd = dw_land * sqrt(gsize(i) / 1.e5)
1056 t_ocn = dw_ocean * sqrt(gsize(i) / 1.e5)
1057 tmp = min(1., abs(hs(i)) / (10. * grav))
1058 h_var = t_lnd * tmp + t_ocn * (1. - tmp)
1059 h_var = min(0.20, max(0.01, h_var))
1060
1061 ! -----------------------------------------------------------------------
1062 ! relative humidity thresholds
1063 ! -----------------------------------------------------------------------
1064
1065 rh_adj = 1. - h_var - rh_inc
1066 rh_rain = max(0.35, rh_adj - rh_inr)
1067
1068 ! -----------------------------------------------------------------------
1069 ! fix negative water species from outside
1070 ! -----------------------------------------------------------------------
1071
1072 if (fix_negative) &
1073 call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, cond)
1074
1075 condensation(i) = condensation(i) + cond * convt
1076
1077 ! -----------------------------------------------------------------------
1078 ! fast microphysics loop
1079 ! -----------------------------------------------------------------------
1080
1081 if (do_mp_fast) then
1082
1083 call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, &
1084 ccn, cin, condensation(i), deposition(i), evaporation(i), &
1085 sublimation(i), denfac, convt, last_step)
1086
1087 endif
1088
1089 ! -----------------------------------------------------------------------
1090 ! full microphysics loop
1091 ! -----------------------------------------------------------------------
1092
1093 if (do_mp_full) then
1094
1095 call mp_full (ks, ke, ntimes, tz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, &
1096 u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte(i), &
1097 water(i), rain(i), ice(i), snow(i), graupel(i), prefluxw(i, :), &
1098 prefluxr(i, :), prefluxi(i, :), prefluxs(i, :), prefluxg(i, :), &
1099 condensation(i), deposition(i), evaporation(i), sublimation(i), &
1100 convt, last_step)
1101
1102 endif
1103
1104 ! -----------------------------------------------------------------------
1105 ! cloud fraction diagnostic
1106 ! -----------------------------------------------------------------------
1107
1108 if (do_qa .and. last_step) then
1109 call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, &
1110 tz, h_var, gsize(i))
1111 endif
1112
1113 ! =======================================================================
1114 ! calculation of particle concentration (pc), effective diameter (ed),
1115 ! optical extinction (oe), radar reflectivity factor (rr), and
1116 ! mass-weighted terminal velocity (tv)
1117 ! =======================================================================
1118
1119 pcw(i, :) = 0.0
1120 edw(i, :) = 0.0
1121 oew(i, :) = 0.0
1122 rrw(i, :) = 0.0
1123 tvw(i, :) = 0.0
1124 pci(i, :) = 0.0
1125 edi(i, :) = 0.0
1126 oei(i, :) = 0.0
1127 rri(i, :) = 0.0
1128 tvi(i, :) = 0.0
1129 pcr(i, :) = 0.0
1130 edr(i, :) = 0.0
1131 oer(i, :) = 0.0
1132 rrr(i, :) = 0.0
1133 tvr(i, :) = 0.0
1134 pcs(i, :) = 0.0
1135 eds(i, :) = 0.0
1136 oes(i, :) = 0.0
1137 rrs(i, :) = 0.0
1138 tvs(i, :) = 0.0
1139 pcg(i, :) = 0.0
1140 edg(i, :) = 0.0
1141 oeg(i, :) = 0.0
1142 rrg(i, :) = 0.0
1143 tvg(i, :) = 0.0
1144
1145 do k = ks, ke
1146 if (qlz(k) .gt. qcmin) then
1147 call cal_pc_ed_oe_rr_tv (qlz(k), den(k), blinw, muw, pcaw, pcbw, pcw(i, k), &
1148 edaw, edbw, edw(i, k), oeaw, oebw, oew(i, k), rraw, rrbw, rrw(i, k), &
1149 tvaw, tvbw, tvw(i, k))
1150 endif
1151 if (qiz(k) .gt. qcmin) then
1152 call cal_pc_ed_oe_rr_tv (qiz(k), den(k), blini, mui, pcai, pcbi, pci(i, k), &
1153 edai, edbi, edi(i, k), oeai, oebi, oei(i, k), rrai, rrbi, rri(i, k), &
1154 tvai, tvbi, tvi(i, k))
1155 endif
1156 if (qrz(k) .gt. qcmin) then
1157 call cal_pc_ed_oe_rr_tv (qrz(k), den(k), blinr, mur, pcar, pcbr, pcr(i, k), &
1158 edar, edbr, edr(i, k), oear, oebr, oer(i, k), rrar, rrbr, rrr(i, k), &
1159 tvar, tvbr, tvr(i, k))
1160 endif
1161 if (qsz(k) .gt. qcmin) then
1162 call cal_pc_ed_oe_rr_tv (qsz(k), den(k), blins, mus, pcas, pcbs, pcs(i, k), &
1163 edas, edbs, eds(i, k), oeas, oebs, oes(i, k), rras, rrbs, rrs(i, k), &
1164 tvas, tvbs, tvs(i, k))
1165 endif
1166 if (do_hail) then
1167 if (qgz(k) .gt. qcmin) then
1168 call cal_pc_ed_oe_rr_tv (qgz(k), den(k), blinh, muh, pcah, pcbh, pcg(i, k), &
1169 edah, edbh, edg(i, k), oeah, oebh, oeg(i, k), rrah, rrbh, rrg(i, k), &
1170 tvah, tvbh, tvg(i, k))
1171 endif
1172 else
1173 if (qgz(k) .gt. qcmin) then
1174 call cal_pc_ed_oe_rr_tv (qgz(k), den(k), bling, mug, pcag, pcbg, pcg(i, k), &
1175 edag, edbg, edg(i, k), oeag, oebg, oeg(i, k), rrag, rrbg, rrg(i, k), &
1176 tvag, tvbg, tvg(i, k))
1177 endif
1178 endif
1179 enddo
1180
1181 ! -----------------------------------------------------------------------
1182 ! momentum transportation during sedimentation
1183 ! update temperature before delp and q update
1184 ! -----------------------------------------------------------------------
1185
1186 if (do_sedi_uv) then
1187 do k = ks, ke
1188 c8 = mhc(qvz(k), qlz(k), qrz(k), qiz(k), qsz(k), qgz(k)) * c_air
1189 tzuv(k) = 0.5 * (ua(i, k) ** 2 + va(i, k) ** 2 - (u(k) ** 2 + v(k) ** 2)) / c8
1190 tz(k) = tz(k) + tzuv(k)
1191 enddo
1192 endif
1193
1194 if (do_sedi_w) then
1195 do k = ks, ke
1196 c8 = mhc(qvz(k), qlz(k), qrz(k), qiz(k), qsz(k), qgz(k)) * c_air
1197 tzw(k) = 0.5 * (wa(i, k) ** 2 - w(k) ** 2) / c8
1198 tz(k) = tz(k) + tzw(k)
1199 enddo
1200 endif
1201
1202 ! -----------------------------------------------------------------------
1203 ! total energy checker
1204 ! -----------------------------------------------------------------------
1205
1206 if (consv_checker) then
1207 call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, &
1208 dp, dte(i), 0.0, water(i), rain(i), ice(i), snow(i), &
1209 graupel(i), 0.0, 0.0, dtm, te_end_d(i, :), tw_end_d(i, :), &
1210 te_b_end_d(i), tw_b_end_d(i), .false., hydrostatic, te_loss(i))
1211 endif
1212
1213 do k = ks, ke
1214
1215 ! -----------------------------------------------------------------------
1216 ! convert mass mixing ratios back to specific ratios
1217 ! -----------------------------------------------------------------------
1218
1219 if (do_inline_mp) then
1220 q_cond = qlz(k) + qrz(k) + qiz(k) + qsz(k) + qgz(k)
1221 con_r8 = one_r8 + qvz(k) + q_cond
1222 else
1223 con_r8 = one_r8 + qvz(k)
1224 endif
1225
1226 delp(i, k) = dp(k) * con_r8
1227 con_r8 = one_r8 / con_r8
1228 qvz(k) = qvz(k) * con_r8
1229 qlz(k) = qlz(k) * con_r8
1230 qrz(k) = qrz(k) * con_r8
1231 qiz(k) = qiz(k) * con_r8
1232 qsz(k) = qsz(k) * con_r8
1233 qgz(k) = qgz(k) * con_r8
1234
1235 q1 = qv(i, k) + ql(i, k) + qr(i, k) + qi(i, k) + qs(i, k) + qg(i, k)
1236 q2 = qvz(k) + qlz(k) + qrz(k) + qiz(k) + qsz(k) + qgz(k)
1237 adj_vmr(i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1)
1238
1239 qv(i, k) = qvz(k)
1240 ql(i, k) = qlz(k)
1241 qr(i, k) = qrz(k)
1242 qi(i, k) = qiz(k)
1243 qs(i, k) = qsz(k)
1244 qg(i, k) = qgz(k)
1245 qa(i, k) = qaz(k)
1246
1247 ! -----------------------------------------------------------------------
1248 ! calculate some more variables needed outside
1249 ! -----------------------------------------------------------------------
1250
1251 q_liq(k) = qlz(k) + qrz(k)
1252 q_sol(k) = qiz(k) + qsz(k) + qgz(k)
1253 q_cond = q_liq(k) + q_sol(k)
1254 con_r8 = one_r8 - (qvz(k) + q_cond)
1255 c8 = mhc(con_r8, qvz(k), q_liq(k), q_sol(k)) * c_air
1256
1257#ifdef USE_COND
1258 q_con(i, k) = q_cond
1259#endif
1260#ifdef MOIST_CAPPA
1261 tmp = rdgas * (1. + zvir * qvz(k))
1262 cappa(i, k) = tmp / (tmp + c8)
1263#endif
1264
1265 enddo
1266
1267 ! -----------------------------------------------------------------------
1268 ! momentum transportation during sedimentation
1269 ! update temperature after delp and q update
1270 ! -----------------------------------------------------------------------
1271
1272 if (do_sedi_uv) then
1273 do k = ks, ke
1274 tz(k) = tz(k) - tzuv(k)
1275 q_liq(k) = qlz(k) + qrz(k)
1276 q_sol(k) = qiz(k) + qsz(k) + qgz(k)
1277 q_cond = q_liq(k) + q_sol(k)
1278 con_r8 = one_r8 - (qvz(k) + q_cond)
1279 c8 = mhc(con_r8, qvz(k), q_liq(k), q_sol(k)) * c_air
1280 tzuv(k) = (0.5 * (ua(i, k) ** 2 + va(i, k) ** 2) * dp0(k) - &
1281 0.5 * (u(k) ** 2 + v(k) ** 2) * delp(i, k)) / c8 / delp(i, k)
1282 tz(k) = tz(k) + tzuv(k)
1283 enddo
1284 do k = ks, ke
1285 ua(i, k) = u(k)
1286 va(i, k) = v(k)
1287 enddo
1288 endif
1289
1290 if (do_sedi_w) then
1291 do k = ks, ke
1292 tz(k) = tz(k) - tzw(k)
1293 q_liq(k) = qlz(k) + qrz(k)
1294 q_sol(k) = qiz(k) + qsz(k) + qgz(k)
1295 q_cond = q_liq(k) + q_sol(k)
1296 con_r8 = one_r8 - (qvz(k) + q_cond)
1297 c8 = mhc(con_r8, qvz(k), q_liq(k), q_sol(k)) * c_air
1298 tzw(k) = (0.5 * (wa(i, k) ** 2) * dp0(k) - &
1299 0.5 * (w(k) ** 2) * delp(i, k)) / c8 / delp(i, k)
1300 tz(k) = tz(k) + tzw(k)
1301 enddo
1302 do k = ks, ke
1303 wa(i, k) = w(k)
1304 enddo
1305 endif
1306
1307 ! -----------------------------------------------------------------------
1308 ! total energy checker
1309 ! -----------------------------------------------------------------------
1310
1311 if (consv_checker) then
1312 call mtetw (ks, ke, qv(i, :), ql(i, :), qr(i, :), qi(i, :), &
1313 qs(i, :), qg(i, :), tz, ua(i, :), va(i, :), wa(i, :), &
1314 delp(i, :), dte(i), 0.0, water(i), rain(i), ice(i), &
1315 snow(i), graupel(i), 0.0, 0.0, dtm, te_end_m(i, :), &
1316 tw_end_m(i, :), te_b_end_m(i), tw_b_end_m(i), .true., hydrostatic)
1317 endif
1318
1319 ! -----------------------------------------------------------------------
1320 ! calculate total energy loss or gain
1321 ! -----------------------------------------------------------------------
1322
1323 if (consv_te) then
1324 if (hydrostatic) then
1325 do k = ks, ke
1326 te(i, k) = te(i, k) + c_air * tz(k) * delp(i, k)
1327 enddo
1328 else
1329 do k = ks, ke
1330 te(i, k) = te(i, k) + mte(qv(i, k), ql(i, k), qr(i, k), qi(i, k), &
1331 qs(i, k), qg(i, k), tz(k), delp(i, k), .true.) * grav
1332 enddo
1333 endif
1334 endif
1335
1336 ! -----------------------------------------------------------------------
1337 ! conversion of temperature
1338 ! -----------------------------------------------------------------------
1339
1340 if (do_inline_mp) then
1341 do k = ks, ke
1342 q_cond = qlz(k) + qrz(k) + qiz(k) + qsz(k) + qgz(k)
1343 if (cp_heating) then
1344 con_r8 = one_r8 - (qvz(k) + q_cond)
1345 c8 = mhc(con_r8, qvz(k), q_liq(k), q_sol(k)) * c_air
1346 cp8 = con_r8 * cp_air + qvz(k) * cp_vap + q_liq(k) * c_liq + q_sol(k) * c_ice
1347 delz(i, k) = delz(i, k) / pt(i, k)
1348 pt(i, k) = pt(i, k) + (tz(k) * ((1. + zvir * qvz(k)) * (1. - q_cond)) - pt(i, k)) * c8 / cp8
1349 delz(i, k) = delz(i, k) * pt(i, k)
1350 else
1351 pt(i, k) = tz(k) * ((1. + zvir * qvz(k)) * (1. - q_cond))
1352 endif
1353 enddo
1354 else
1355 do k = ks, ke
1356 q_liq(k) = qlz(k) + qrz(k)
1357 q_sol(k) = qiz(k) + qsz(k) + qgz(k)
1358 q_cond = q_liq(k) + q_sol(k)
1359 con_r8 = one_r8 - (qvz(k) + q_cond)
1360 c8 = mhc(con_r8, qvz(k), q_liq(k), q_sol(k)) * c_air
1361 pt(i, k) = pt(i, k) + (tz(k) - pt(i, k)) * c8 / cp_air
1362 enddo
1363 endif
1364
1365 ! -----------------------------------------------------------------------
1366 ! total energy checker
1367 ! -----------------------------------------------------------------------
1368
1369 if (consv_checker) then
1370 if (abs(sum(te_end_d(i, :)) + te_b_end_d(i) - sum(te_beg_d(i, :)) - te_b_beg_d(i)) / &
1371 (sum(te_beg_d(i, :)) + te_b_beg_d(i)) .gt. te_err) then
1372 print*, "GFDL-MP-DRY TE: ", &
1373 !(sum (te_beg_d (i, :)) + te_b_beg_d (i)), &
1374 !(sum (te_end_d (i, :)) + te_b_end_d (i)), &
1375 (sum(te_end_d(i, :)) + te_b_end_d(i) - sum(te_beg_d(i, :)) - te_b_beg_d(i)) / &
1376 (sum(te_beg_d(i, :)) + te_b_beg_d(i))
1377 endif
1378 if (abs(sum(tw_end_d(i, :)) + tw_b_end_d(i) - sum(tw_beg_d(i, :)) - tw_b_beg_d(i)) / &
1379 (sum(tw_beg_d(i, :)) + tw_b_beg_d(i)) .gt. tw_err) then
1380 print*, "GFDL-MP-DRY TW: ", &
1381 !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)), &
1382 !(sum (tw_end_d (i, :)) + tw_b_end_d (i)), &
1383 (sum(tw_end_d(i, :)) + tw_b_end_d(i) - sum(tw_beg_d(i, :)) - tw_b_beg_d(i)) / &
1384 (sum(tw_beg_d(i, :)) + tw_b_beg_d(i))
1385 endif
1386 !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0
1387 if (abs(sum(te_end_m(i, :)) + te_b_end_m(i) - sum(te_beg_m(i, :)) - te_b_beg_m(i)) / &
1388 (sum(te_beg_m(i, :)) + te_b_beg_m(i)) .gt. te_err) then
1389 print*, "GFDL-MP-WET TE: ", &
1390 !(sum (te_beg_m (i, :)) + te_b_beg_m (i)), &
1391 !(sum (te_end_m (i, :)) + te_b_end_m (i)), &
1392 (sum(te_end_m(i, :)) + te_b_end_m(i) - sum(te_beg_m(i, :)) - te_b_beg_m(i)) / &
1393 (sum(te_beg_m(i, :)) + te_b_beg_m(i))
1394 endif
1395 if (abs(sum(tw_end_m(i, :)) + tw_b_end_m(i) - sum(tw_beg_m(i, :)) - tw_b_beg_m(i)) / &
1396 (sum(tw_beg_m(i, :)) + tw_b_beg_m(i)) .gt. tw_err) then
1397 print*, "GFDL-MP-WET TW: ", &
1398 !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)), &
1399 !(sum (tw_end_m (i, :)) + tw_b_end_m (i)), &
1400 (sum(tw_end_m(i, :)) + tw_b_end_m(i) - sum(tw_beg_m(i, :)) - tw_b_beg_m(i)) / &
1401 (sum(tw_beg_m(i, :)) + tw_b_beg_m(i))
1402 endif
1403 !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0
1404 endif
1405
1406 enddo ! i loop
1407
1408end subroutine mpdrv
1409
1410! =======================================================================
1411! fix negative water species
1412! =======================================================================
1413
1414subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond)
1415
1416 implicit none
1417
1418 ! -----------------------------------------------------------------------
1419 ! input / output arguments
1420 ! -----------------------------------------------------------------------
1421
1422 integer, intent (in) :: ks, ke
1423
1424 real(kind_phys), intent (in), dimension (ks:ke) :: dp
1425
1426 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
1427
1428 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
1429
1430 real(kind_phys), intent (out) :: cond
1431
1432 ! -----------------------------------------------------------------------
1433 ! local variables
1434 ! -----------------------------------------------------------------------
1435
1436 integer :: k
1437
1438 real(kind_phys) :: dq, sink
1439
1440 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
1441
1442 real (kind = r8), dimension (ks:ke) :: cvm, te8
1443
1444 ! -----------------------------------------------------------------------
1445 ! initialization
1446 ! -----------------------------------------------------------------------
1447
1448 cond = 0
1449
1450 ! -----------------------------------------------------------------------
1451 ! calculate moist heat capacity and latent heat coefficients
1452 ! -----------------------------------------------------------------------
1453
1454 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
1455 lcpk, icpk, tcpk, tcp3)
1456
1457 do k = ks, ke
1458
1459 ! -----------------------------------------------------------------------
1460 ! fix negative solid-phase hydrometeors
1461 ! -----------------------------------------------------------------------
1462
1463 ! if cloud ice < 0, borrow from snow
1464 if (qi(k) .lt. 0.) then
1465 sink = min(- qi(k), max(0., qs(k)))
1466 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
1467 0., 0., 0., sink, - sink, 0.)
1468 endif
1469
1470 ! if snow < 0, borrow from graupel
1471 if (qs(k) .lt. 0.) then
1472 sink = min(- qs(k), max(0., qg(k)))
1473 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
1474 0., 0., 0., 0., sink, - sink)
1475 endif
1476
1477 ! if graupel < 0, borrow from rain
1478 if (qg(k) .lt. 0.) then
1479 sink = min(- qg(k), max(0., qr(k)))
1480 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
1481 0., 0., - sink, 0., 0., sink, te8(k), cvm(k), tz(k), &
1482 lcpk(k), icpk(k), tcpk(k), tcp3(k))
1483 endif
1484
1485 ! -----------------------------------------------------------------------
1486 ! fix negative liquid-phase hydrometeors
1487 ! -----------------------------------------------------------------------
1488
1489 ! if rain < 0, borrow from cloud water
1490 if (qr(k) .lt. 0.) then
1491 sink = min(- qr(k), max(0., ql(k)))
1492 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
1493 0., - sink, sink, 0., 0., 0.)
1494 endif
1495
1496 ! if cloud water < 0, borrow from water vapor
1497 if (ql(k) .lt. 0.) then
1498 sink = min(- ql(k), max(0., qv(k)))
1499 cond = cond + sink * dp(k)
1500 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
1501 - sink, sink, 0., 0., 0., 0., te8(k), cvm(k), tz(k), &
1502 lcpk(k), icpk(k), tcpk(k), tcp3(k))
1503 endif
1504
1505 enddo
1506
1507 ! -----------------------------------------------------------------------
1508 ! fix negative water vapor
1509 ! -----------------------------------------------------------------------
1510
1511 ! if water vapor < 0, borrow water vapor from below
1512 do k = ks, ke - 1
1513 if (qv(k) .lt. 0.) then
1514 qv(k + 1) = qv(k + 1) + qv(k) * dp(k) / dp(k + 1)
1515 qv(k) = 0.
1516 endif
1517 enddo
1518
1519 ! if water vapor < 0, borrow water vapor from above
1520 if (qv(ke) .lt. 0. .and. qv(ke - 1) .gt. 0.) then
1521 dq = min(- qv(ke) * dp(ke), qv(ke - 1) * dp(ke - 1))
1522 qv(ke - 1) = qv(ke - 1) - dq / dp(ke - 1)
1523 qv(ke) = qv(ke) + dq / dp(ke)
1524 endif
1525
1526end subroutine neg_adj
1527
1528! =======================================================================
1529! full microphysics loop
1530! =======================================================================
1531
1532subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, &
1533 den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, &
1534 snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, &
1535 condensation, deposition, evaporation, sublimation, convt, last_step)
1536
1537 implicit none
1538
1539 ! -----------------------------------------------------------------------
1540 ! input / output arguments
1541 ! -----------------------------------------------------------------------
1542
1543 logical, intent (in) :: last_step
1544
1545 integer, intent (in) :: ks, ke, ntimes
1546
1547 real(kind_phys), intent (in) :: dts, rh_adj, rh_rain, h_var, convt
1548
1549 real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac
1550
1551 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin
1552 real(kind_phys), intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
1553
1554 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
1555
1556 real(kind_phys), intent (inout) :: water, rain, ice, snow, graupel
1557 real(kind_phys), intent (inout) :: condensation, deposition
1558 real(kind_phys), intent (inout) :: evaporation, sublimation
1559
1560 real (kind = r8), intent (inout) :: dte
1561
1562 ! -----------------------------------------------------------------------
1563 ! local variables
1564 ! -----------------------------------------------------------------------
1565
1566 integer :: n
1567
1568 real(kind_phys) :: w1, r1, i1, s1, g1, cond, dep, reevap, sub
1569
1570 real(kind_phys), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg
1571
1572 do n = 1, ntimes
1573
1574 ! -----------------------------------------------------------------------
1575 ! sedimentation of cloud ice, snow, graupel or hail, and rain
1576 ! -----------------------------------------------------------------------
1577
1578 call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, &
1579 dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, &
1580 u, v, w, den, denfac, dte)
1581
1582 water = water + w1 * convt
1583 rain = rain + r1 * convt
1584 ice = ice + i1 * convt
1585 snow = snow + s1 * convt
1586 graupel = graupel + g1 * convt
1587
1588 prefluxw = prefluxw + pfw * convt
1589 prefluxr = prefluxr + pfr * convt
1590 prefluxi = prefluxi + pfi * convt
1591 prefluxs = prefluxs + pfs * convt
1592 prefluxg = prefluxg + pfg * convt
1593
1594 ! -----------------------------------------------------------------------
1595 ! warm rain cloud microphysics
1596 ! -----------------------------------------------------------------------
1597
1598 call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
1599 den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap)
1600
1601 evaporation = evaporation + reevap * convt
1602
1603 ! -----------------------------------------------------------------------
1604 ! ice cloud microphysics
1605 ! -----------------------------------------------------------------------
1606
1607 call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, &
1608 denfac, vtw, vtr, vti, vts, vtg, dts, h_var)
1609
1610 if (do_subgrid_proc) then
1611
1612 ! -----------------------------------------------------------------------
1613 ! temperature sentive high vertical resolution processes
1614 ! -----------------------------------------------------------------------
1615
1616 call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, &
1617 qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step)
1618
1619 condensation = condensation + cond * convt
1620 deposition = deposition + dep * convt
1621 evaporation = evaporation + reevap * convt
1622 sublimation = sublimation + sub * convt
1623
1624 endif
1625
1626 enddo
1627
1628end subroutine mp_full
1629
1630! =======================================================================
1631! fast microphysics loop
1632! =======================================================================
1633
1634subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, &
1635 ccn, cin, condensation, deposition, evaporation, sublimation, &
1636 denfac, convt, last_step)
1637
1638 implicit none
1639
1640 ! -----------------------------------------------------------------------
1641 ! input / output arguments
1642 ! -----------------------------------------------------------------------
1643
1644 logical, intent (in) :: last_step
1645
1646 integer, intent (in) :: ks, ke
1647
1648 real(kind_phys), intent (in) :: dtm, convt
1649
1650 real(kind_phys), intent (in), dimension (ks:ke) :: dp, den, denfac
1651
1652 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin
1653
1654 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
1655
1656 real(kind_phys), intent (inout) :: condensation, deposition
1657 real(kind_phys), intent (inout) :: evaporation, sublimation
1658
1659 ! -----------------------------------------------------------------------
1660 ! local variables
1661 ! -----------------------------------------------------------------------
1662
1663 logical :: cond_evap
1664
1665 integer :: n
1666
1667 real(kind_phys) :: cond, dep, reevap, sub
1668
1669 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
1670
1671 real (kind = r8), dimension (ks:ke) :: cvm, te8
1672
1673 ! -----------------------------------------------------------------------
1674 ! initialization
1675 ! -----------------------------------------------------------------------
1676
1677 cond = 0
1678 dep = 0
1679 reevap = 0
1680 sub = 0
1681
1682 ! -----------------------------------------------------------------------
1683 ! calculate heat capacities and latent heat coefficients
1684 ! -----------------------------------------------------------------------
1685
1686 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
1687 lcpk, icpk, tcpk, tcp3)
1688
1689 if (.not. do_warm_rain_mp .and. fast_fr_mlt) then
1690
1691 ! -----------------------------------------------------------------------
1692 ! cloud ice melting to form cloud water and rain
1693 ! -----------------------------------------------------------------------
1694
1695 call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
1696 lcpk, icpk, tcpk, tcp3)
1697
1698 ! -----------------------------------------------------------------------
1699 ! enforce complete freezing below t_wfr
1700 ! -----------------------------------------------------------------------
1701
1702 call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
1703 lcpk, icpk, tcpk, tcp3)
1704
1705 endif
1706
1707 ! -----------------------------------------------------------------------
1708 ! cloud water condensation and evaporation
1709 ! -----------------------------------------------------------------------
1710
1711 if (delay_cond_evap) then
1712 cond_evap = last_step
1713 else
1714 cond_evap = .true.
1715 endif
1716
1717 if (cond_evap) then
1718 do n = 1, nconds
1719 call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
1720 lcpk, icpk, tcpk, tcp3, cond, reevap)
1721 enddo
1722 endif
1723
1724 condensation = condensation + cond * convt
1725 evaporation = evaporation + reevap * convt
1726
1727 if (.not. do_warm_rain_mp .and. fast_fr_mlt) then
1728
1729 ! -----------------------------------------------------------------------
1730 ! cloud water freezing to form cloud ice and snow
1731 ! -----------------------------------------------------------------------
1732
1733 call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, &
1734 lcpk, icpk, tcpk, tcp3)
1735
1736 ! -----------------------------------------------------------------------
1737 ! Wegener Bergeron Findeisen process
1738 ! -----------------------------------------------------------------------
1739
1740 call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, &
1741 lcpk, icpk, tcpk, tcp3)
1742
1743 ! -----------------------------------------------------------------------
1744 ! Bigg freezing mechanism
1745 ! -----------------------------------------------------------------------
1746
1747 call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, &
1748 lcpk, icpk, tcpk, tcp3)
1749
1750 ! -----------------------------------------------------------------------
1751 ! rain freezing to form graupel
1752 ! -----------------------------------------------------------------------
1753
1754 call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
1755 lcpk, icpk, tcpk, tcp3)
1756
1757 ! -----------------------------------------------------------------------
1758 ! snow melting to form cloud water and rain
1759 ! -----------------------------------------------------------------------
1760
1761 call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
1762 lcpk, icpk, tcpk, tcp3)
1763
1764 endif
1765
1766 ! -----------------------------------------------------------------------
1767 ! cloud water to rain autoconversion
1768 ! -----------------------------------------------------------------------
1769
1770 call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg)
1771
1772 if (.not. do_warm_rain_mp .and. fast_dep_sub) then
1773
1774 ! -----------------------------------------------------------------------
1775 ! cloud ice deposition and sublimation
1776 ! -----------------------------------------------------------------------
1777
1778 call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
1779 lcpk, icpk, tcpk, tcp3, cin, dep, sub)
1780
1781 deposition = deposition + dep * convt
1782 sublimation = sublimation + sub * convt
1783
1784 ! -----------------------------------------------------------------------
1785 ! cloud ice to snow autoconversion
1786 ! -----------------------------------------------------------------------
1787
1788 call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den)
1789
1790 ! -----------------------------------------------------------------------
1791 ! snow deposition and sublimation
1792 ! -----------------------------------------------------------------------
1793
1794 call psdep_pssub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
1795 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
1796
1797 ! -----------------------------------------------------------------------
1798 ! graupel deposition and sublimation
1799 ! -----------------------------------------------------------------------
1800
1801 call pgdep_pgsub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
1802 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
1803
1804 endif
1805
1806end subroutine mp_fast
1807
1808! =======================================================================
1809! sedimentation of cloud ice, snow, graupel or hail, and rain
1810! =======================================================================
1811
1812subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1813 vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, &
1814 u, v, w, den, denfac, dte)
1815
1816 implicit none
1817
1818 ! -----------------------------------------------------------------------
1819 ! input / output arguments
1820 ! -----------------------------------------------------------------------
1821
1822 integer, intent (in) :: ks, ke
1823
1824 real(kind_phys), intent (in) :: dts
1825
1826 real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac
1827
1828 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w
1829
1830 real(kind_phys), intent (out) :: w1, r1, i1, s1, g1
1831
1832 real(kind_phys), intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg
1833
1834 real (kind = r8), intent (inout) :: dte
1835
1836 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
1837
1838 ! -----------------------------------------------------------------------
1839 ! local variables
1840 ! -----------------------------------------------------------------------
1841
1842 integer :: k
1843
1844 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
1845
1846 real (kind = r8), dimension (ks:ke) :: te8, cvm
1847
1848 w1 = 0.
1849 r1 = 0.
1850 i1 = 0.
1851 s1 = 0.
1852 g1 = 0.
1853
1854 vtw = 0.
1855 vtr = 0.
1856 vti = 0.
1857 vts = 0.
1858 vtg = 0.
1859
1860 pfw = 0.
1861 pfr = 0.
1862 pfi = 0.
1863 pfs = 0.
1864 pfg = 0.
1865
1866 ! -----------------------------------------------------------------------
1867 ! calculate heat capacities and latent heat coefficients
1868 ! -----------------------------------------------------------------------
1869
1870 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
1871 lcpk, icpk, tcpk, tcp3)
1872
1873 ! -----------------------------------------------------------------------
1874 ! terminal fall and melting of falling cloud ice into rain
1875 ! -----------------------------------------------------------------------
1876
1877 if (do_psd_ice_fall) then
1878 call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_max, const_vi, vti)
1879 else
1880 call term_ice (ks, ke, tz, qi, den, vi_fac, vi_max, const_vi, vti)
1881 endif
1882
1883 if (do_sedi_melt) then
1884 call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1885 vti, r1, tau_imlt, icpk, "qi")
1886 endif
1887
1888 call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1889 vti, i1, pfi, u, v, w, dte, "qi")
1890
1891 pfi(ks) = max(0.0, pfi(ks))
1892 do k = ke, ks + 1, -1
1893 pfi(k) = max(0.0, pfi(k) - pfi(k - 1))
1894 enddo
1895
1896 ! -----------------------------------------------------------------------
1897 ! terminal fall and melting of falling snow into rain
1898 ! -----------------------------------------------------------------------
1899
1900 call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_max, const_vs, vts)
1901
1902 if (do_sedi_melt) then
1903 call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1904 vts, r1, tau_smlt, icpk, "qs")
1905 endif
1906
1907 call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1908 vts, s1, pfs, u, v, w, dte, "qs")
1909
1910 pfs(ks) = max(0.0, pfs(ks))
1911 do k = ke, ks + 1, -1
1912 pfs(k) = max(0.0, pfs(k) - pfs(k - 1))
1913 enddo
1914
1915 ! -----------------------------------------------------------------------
1916 ! terminal fall and melting of falling graupel into rain
1917 ! -----------------------------------------------------------------------
1918
1919 if (do_hail) then
1920 call term_rsg (ks, ke, qg, den, denfac, vg_fac, blinh, muh, tvah, tvbh, vg_max, const_vg, vtg)
1921 else
1922 call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_max, const_vg, vtg)
1923 endif
1924
1925 if (do_sedi_melt) then
1926 call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1927 vtg, r1, tau_gmlt, icpk, "qg")
1928 endif
1929
1930 call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1931 vtg, g1, pfg, u, v, w, dte, "qg")
1932
1933 pfg(ks) = max(0.0, pfg(ks))
1934 do k = ke, ks + 1, -1
1935 pfg(k) = max(0.0, pfg(k) - pfg(k - 1))
1936 enddo
1937
1938 ! -----------------------------------------------------------------------
1939 ! terminal fall of cloud water
1940 ! -----------------------------------------------------------------------
1941
1942 if (do_psd_water_fall) then
1943
1944 call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_max, const_vw, vtw)
1945
1946 call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1947 vtw, w1, pfw, u, v, w, dte, "ql")
1948
1949 pfw(ks) = max(0.0, pfw(ks))
1950 do k = ke, ks + 1, -1
1951 pfw(k) = max(0.0, pfw(k) - pfw(k - 1))
1952 enddo
1953
1954 endif
1955
1956 ! -----------------------------------------------------------------------
1957 ! terminal fall of rain
1958 ! -----------------------------------------------------------------------
1959
1960 call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_max, const_vr, vtr)
1961
1962 call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
1963 vtr, r1, pfr, u, v, w, dte, "qr")
1964
1965 pfr(ks) = max(0.0, pfr(ks))
1966 do k = ke, ks + 1, -1
1967 pfr(k) = max(0.0, pfr(k) - pfr(k - 1))
1968 enddo
1969
1970end subroutine sedimentation
1971
1972! =======================================================================
1973! terminal velocity for cloud ice
1974! =======================================================================
1975
1976subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt)
1977
1978 implicit none
1979
1980 ! -----------------------------------------------------------------------
1981 ! input / output arguments
1982 ! -----------------------------------------------------------------------
1983
1984 integer, intent (in) :: ks, ke
1985
1986 logical, intent (in) :: const_v
1987
1988 real(kind_phys), intent (in) :: v_fac, v_max
1989
1990 real(kind_phys), intent (in), dimension (ks:ke) :: q, den
1991
1992 real (kind = r8), intent (in), dimension (ks:ke) :: tz
1993
1994 real(kind_phys), intent (out), dimension (ks:ke) :: vt
1995
1996 ! -----------------------------------------------------------------------
1997 ! local variables
1998 ! -----------------------------------------------------------------------
1999
2000 integer :: k
2001
2002 real(kind_phys) :: qden
2003
2004 real(kind_phys), parameter :: aa = - 4.14122e-5
2005 real(kind_phys), parameter :: bb = - 0.00538922
2006 real(kind_phys), parameter :: cc = - 0.0516344
2007 real(kind_phys), parameter :: dd = 0.00216078
2008 real(kind_phys), parameter :: ee = 1.9714
2009
2010 real(kind_phys), dimension (ks:ke) :: tc
2011
2012 if (const_v) then
2013 vt(:) = v_fac
2014 else
2015 do k = ks, ke
2016 qden = q(k) * den(k)
2017 if (q(k) .lt. qfmin) then
2018 vt(k) = 0.0
2019 else
2020 tc(k) = tz(k) - tice
2021 if (ifflag .eq. 1) then
2022 vt(k) = (3. + log10(qden)) * (tc(k) * (aa * tc(k) + bb) + cc) + &
2023 dd * tc(k) + ee
2024 vt(k) = 0.01 * v_fac * exp(vt(k) * log(10.))
2025 endif
2026 if (ifflag .eq. 2) &
2027 vt(k) = v_fac * 3.29 * exp(0.16 * log(qden))
2028 vt(k) = min(v_max, max(0.0, vt(k)))
2029 endif
2030 enddo
2031 endif
2032
2033end subroutine term_ice
2034
2035! =======================================================================
2036! terminal velocity for rain, snow, and graupel, Lin et al. (1983)
2037! =======================================================================
2038
2039subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, const_v, vt)
2040
2041 implicit none
2042
2043 ! -----------------------------------------------------------------------
2044 ! input / output arguments
2045 ! -----------------------------------------------------------------------
2046
2047 integer, intent (in) :: ks, ke
2048
2049 logical, intent (in) :: const_v
2050
2051 real(kind_phys), intent (in) :: v_fac, blin, v_max, mu
2052
2053 real (kind = r8), intent (in) :: tva, tvb
2054
2055 real(kind_phys), intent (in), dimension (ks:ke) :: q, den, denfac
2056
2057 real(kind_phys), intent (out), dimension (ks:ke) :: vt
2058
2059 ! -----------------------------------------------------------------------
2060 ! local variables
2061 ! -----------------------------------------------------------------------
2062
2063 integer :: k
2064
2065 if (const_v) then
2066 vt(:) = v_fac
2067 else
2068 do k = ks, ke
2069 if (q(k) .lt. qfmin) then
2070 vt(k) = 0.0
2071 else
2072 call cal_pc_ed_oe_rr_tv (q(k), den(k), blin, mu, &
2073 tva = tva, tvb = tvb, tv = vt(k))
2074 vt(k) = v_fac * vt(k) * denfac(k)
2075 vt(k) = min(v_max, max(0.0, vt(k)))
2076 endif
2077 enddo
2078 endif
2079
2080end subroutine term_rsg
2081
2082! =======================================================================
2083! melting during sedimentation
2084! =======================================================================
2085
2086subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
2087 vt, r1, tau_mlt, icpk, qflag)
2088
2089 implicit none
2090
2091 ! -----------------------------------------------------------------------
2092 ! input / output arguments
2093 ! -----------------------------------------------------------------------
2094
2095 integer, intent (in) :: ks, ke
2096
2097 real(kind_phys), intent (in) :: dts, tau_mlt
2098
2099 real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp, dz, icpk
2100
2101 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
2102
2103 real(kind_phys), intent (inout) :: r1
2104
2105 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2106
2107 character (len = 2), intent (in) :: qflag
2108
2109 ! -----------------------------------------------------------------------
2110 ! local variables
2111 ! -----------------------------------------------------------------------
2112
2113 integer :: k, m
2114
2115 real(kind_phys) :: dtime, sink, zs
2116
2117 real(kind_phys), dimension (ks:ke) :: q
2118
2119 real(kind_phys), dimension (ks:ke + 1) :: ze, zt
2120
2121 real (kind = r8), dimension (ks:ke) :: cvm
2122
2123 call zezt (ks, ke, dts, zs, dz, vt, ze, zt)
2124
2125 select case (qflag)
2126 case ("qi")
2127 q = qi
2128 case ("qs")
2129 q = qs
2130 case ("qg")
2131 q = qg
2132 case default
2133 print *, "gfdl_mp: qflag error!"
2134 end select
2135
2136 ! -----------------------------------------------------------------------
2137 ! melting to rain
2138 ! -----------------------------------------------------------------------
2139
2140 do k = ke - 1, ks, - 1
2141 if (vt(k) .lt. 1.e-10) cycle
2142 if (q(k) .gt. qcmin) then
2143 do m = k + 1, ke
2144 if (zt(k + 1) .ge. ze(m)) exit
2145 if (zt(k) .lt. ze(m + 1) .and. tz(m) .gt. tice) then
2146 cvm(k) = mhc(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k))
2147 cvm(m) = mhc(qv(m), ql(m), qr(m), qi(m), qs(m), qg(m))
2148 dtime = min(dts, (ze(m) - ze(m + 1)) / vt(k))
2149 dtime = min(1.0, dtime / tau_mlt)
2150 sink = min(q(k) * dp(k) / dp(m), dtime * (tz(m) - tice) / icpk(m))
2151 q(k) = q(k) - sink * dp(m) / dp(k)
2152 if (zt(k) .lt. zs) then
2153 r1 = r1 + sink * dp(m)
2154 else
2155 qr(m) = qr(m) + sink
2156 endif
2157 select case (qflag)
2158 case ("qi")
2159 qi(k) = q(k)
2160 case ("qs")
2161 qs(k) = q(k)
2162 case ("qg")
2163 qg(k) = q(k)
2164 case default
2165 print *, "gfdl_mp: qflag error!"
2166 end select
2167 tz(k) = (tz(k) * cvm(k) - li00 * sink * dp(m) / dp(k)) / &
2168 mhc(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k))
2169 tz(m) = (tz(m) * cvm(m)) / &
2170 mhc(qv(m), ql(m), qr(m), qi(m), qs(m), qg(m))
2171 endif
2172 if (q(k) .lt. qcmin) exit
2173 enddo
2174 endif
2175 enddo
2176
2177end subroutine sedi_melt
2178
2179! =======================================================================
2180! melting during sedimentation
2181! =======================================================================
2182
2183subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, &
2184 vt, x1, m1, u, v, w, dte, qflag)
2185
2186 implicit none
2187
2188 ! -----------------------------------------------------------------------
2189 ! input / output arguments
2190 ! -----------------------------------------------------------------------
2191
2192 integer, intent (in) :: ks, ke
2193
2194 real(kind_phys), intent (in) :: dts
2195
2196 real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp, dz
2197
2198 character (len = 2), intent (in) :: qflag
2199
2200 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w
2201
2202 real(kind_phys), intent (inout) :: x1
2203
2204 real (kind = r8), intent (inout) :: dte
2205
2206 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2207
2208 real(kind_phys), intent (out), dimension (ks:ke) :: m1
2209
2210 ! -----------------------------------------------------------------------
2211 ! local variables
2212 ! -----------------------------------------------------------------------
2213
2214 integer :: k
2215
2216 logical :: no_fall
2217
2218 real(kind_phys) :: zs
2219
2220 real(kind_phys), dimension (ks:ke) :: dm, q
2221
2222 real(kind_phys), dimension (ks:ke + 1) :: ze, zt
2223
2224 real (kind = r8), dimension (ks:ke) :: te1, te2
2225
2226 m1 = 0.0
2227
2228 call zezt (ks, ke, dts, zs, dz, vt, ze, zt)
2229
2230 select case (qflag)
2231 case ("ql")
2232 q = ql
2233 case ("qr")
2234 q = qr
2235 case ("qi")
2236 q = qi
2237 case ("qs")
2238 q = qs
2239 case ("qg")
2240 q = qg
2241 case default
2242 print *, "gfdl_mp: qflag error!"
2243 end select
2244
2245 call check_column (ks, ke, q, no_fall)
2246
2247 if (no_fall) return
2248
2249 ! -----------------------------------------------------------------------
2250 ! momentum transportation during sedimentation
2251 ! -----------------------------------------------------------------------
2252
2253 if (do_sedi_w) then
2254 do k = ks, ke
2255 dm(k) = dp(k) * (1. + qv(k) + ql(k) + qr(k) + qi(k) + qs(k) + qg(k))
2256 enddo
2257 endif
2258
2259 ! -----------------------------------------------------------------------
2260 ! energy change during sedimentation
2261 ! -----------------------------------------------------------------------
2262
2263 do k = ks, ke
2264 te1(k) = mte(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), tz(k), dp(k), .false.)
2265 enddo
2266
2267 ! -----------------------------------------------------------------------
2268 ! sedimentation
2269 ! -----------------------------------------------------------------------
2270
2271 select case (qflag)
2272 case ("ql")
2273 q = ql
2274 case ("qr")
2275 q = qr
2276 case ("qi")
2277 q = qi
2278 case ("qs")
2279 q = qs
2280 case ("qg")
2281 q = qg
2282 case default
2283 print *, "gfdl_mp: qflag error!"
2284 end select
2285
2286 if (sedflag .eq. 1) &
2287 call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1)
2288 if (sedflag .eq. 2) &
2289 call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1)
2290 if (sedflag .eq. 3) &
2291 call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1)
2292 if (sedflag .eq. 4) &
2293 call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, &
2294 x1, m1, sed_fac)
2295
2296 select case (qflag)
2297 case ("ql")
2298 ql = q
2299 case ("qr")
2300 qr = q
2301 case ("qi")
2302 qi = q
2303 case ("qs")
2304 qs = q
2305 case ("qg")
2306 qg = q
2307 case default
2308 print *, "gfdl_mp: qflag error!"
2309 end select
2310
2311 ! -----------------------------------------------------------------------
2312 ! energy change during sedimentation
2313 ! -----------------------------------------------------------------------
2314
2315 do k = ks, ke
2316 te2(k) = mte(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), tz(k), dp(k), .false.)
2317 enddo
2318 dte = dte + sum(te1) - sum(te2)
2319
2320 ! -----------------------------------------------------------------------
2321 ! momentum transportation during sedimentation
2322 ! -----------------------------------------------------------------------
2323
2324 if (do_sedi_uv) then
2325 call sedi_uv (ks, ke, m1, dp, u, v)
2326 endif
2327
2328 if (do_sedi_w) then
2329 call sedi_w (ks, ke, m1, w, vt, dm)
2330 endif
2331
2332 ! -----------------------------------------------------------------------
2333 ! energy change during sedimentation heating
2334 ! -----------------------------------------------------------------------
2335
2336 do k = ks, ke
2337 te1(k) = mte(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), tz(k), dp(k), .false.)
2338 enddo
2339
2340 ! -----------------------------------------------------------------------
2341 ! heat exchanges during sedimentation
2342 ! -----------------------------------------------------------------------
2343
2344 if (do_sedi_heat) then
2345 call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice)
2346 endif
2347
2348 ! -----------------------------------------------------------------------
2349 ! energy change during sedimentation heating
2350 ! -----------------------------------------------------------------------
2351
2352 do k = ks, ke
2353 te2(k) = mte(qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), tz(k), dp(k), .false.)
2354 enddo
2355 dte = dte + sum(te1) - sum(te2)
2356
2357end subroutine terminal_fall
2358
2359! =======================================================================
2360! calculate ze zt for sedimentation
2361! =======================================================================
2362
2363subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt)
2364
2365 implicit none
2366
2367 ! -----------------------------------------------------------------------
2368 ! input / output arguments
2369 ! -----------------------------------------------------------------------
2370
2371 integer, intent (in) :: ks, ke
2372
2373 real(kind_phys), intent (in) :: dts
2374
2375 real(kind_phys), intent (in), dimension (ks:ke) :: dz, vt
2376
2377 real(kind_phys), intent (out) :: zs
2378
2379 real(kind_phys), intent (out), dimension (ks:ke + 1) :: ze, zt
2380
2381 ! -----------------------------------------------------------------------
2382 ! local variables
2383 ! -----------------------------------------------------------------------
2384
2385 integer :: k
2386
2387 real(kind_phys) :: dt5
2388
2389 dt5 = 0.5 * dts
2390 zs = 0.0
2391 ze(ke + 1) = zs
2392 do k = ke, ks, - 1
2393 ze(k) = ze(k + 1) - dz(k)
2394 enddo
2395 zt(ks) = ze(ks)
2396 do k = ks + 1, ke
2397 zt(k) = ze(k) - dt5 * (vt(k - 1) + vt(k))
2398 enddo
2399 zt(ke + 1) = zs - dts * vt(ke)
2400 do k = ks, ke
2401 if (zt(k + 1) .ge. zt(k)) zt(k + 1) = zt(k) - dz_min
2402 enddo
2403
2404end subroutine zezt
2405
2406! =======================================================================
2407! check if water species is large enough to fall
2408! =======================================================================
2409
2410subroutine check_column (ks, ke, q, no_fall)
2411
2412 implicit none
2413
2414 ! -----------------------------------------------------------------------
2415 ! input / output arguments
2416 ! -----------------------------------------------------------------------
2417
2418 integer, intent (in) :: ks, ke
2419
2420 real(kind_phys), intent (in) :: q (ks:ke)
2421
2422 logical, intent (out) :: no_fall
2423
2424 ! -----------------------------------------------------------------------
2425 ! local variables
2426 ! -----------------------------------------------------------------------
2427
2428 integer :: k
2429
2430 no_fall = .true.
2431
2432 do k = ks, ke
2433 if (q(k) .gt. qfmin) then
2434 no_fall = .false.
2435 exit
2436 endif
2437 enddo
2438
2439end subroutine check_column
2440
2441! =======================================================================
2442! warm rain cloud microphysics
2443! =======================================================================
2444
2445subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, &
2446 den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap)
2447
2448 implicit none
2449
2450 ! -----------------------------------------------------------------------
2451 ! input / output arguments
2452 ! -----------------------------------------------------------------------
2453
2454 integer, intent (in) :: ks, ke
2455
2456 real(kind_phys), intent (in) :: dts, rh_rain, h_var
2457
2458 real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr
2459
2460 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
2461
2462 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2463
2464 real(kind_phys), intent (out) :: reevap
2465
2466 ! -----------------------------------------------------------------------
2467 ! initialization
2468 ! -----------------------------------------------------------------------
2469
2470 reevap = 0
2471
2472 ! -----------------------------------------------------------------------
2473 ! rain evaporation to form water vapor
2474 ! -----------------------------------------------------------------------
2475
2476 call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
2477
2478 ! -----------------------------------------------------------------------
2479 ! rain accretion with cloud water
2480 ! -----------------------------------------------------------------------
2481
2482 call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr)
2483
2484 ! -----------------------------------------------------------------------
2485 ! cloud water to rain autoconversion
2486 ! -----------------------------------------------------------------------
2487
2488 call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var)
2489
2490end subroutine warm_rain
2491
2492! =======================================================================
2493! rain evaporation to form water vapor, Lin et al. (1983)
2494! =======================================================================
2495
2496subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap)
2497
2498 implicit none
2499
2500 ! -----------------------------------------------------------------------
2501 ! input / output arguments
2502 ! -----------------------------------------------------------------------
2503
2504 integer, intent (in) :: ks, ke
2505
2506 real(kind_phys), intent (in) :: dts, rh_rain, h_var
2507
2508 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, dp
2509
2510 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2511
2512 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
2513
2514 real(kind_phys), intent (out) :: reevap
2515
2516 ! -----------------------------------------------------------------------
2517 ! local variables
2518 ! -----------------------------------------------------------------------
2519
2520 integer :: k
2521
2522 real(kind_phys) :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink
2523 real(kind_phys) :: qpz, dq, dqh, tin, fac_revp, rh_tem
2524
2525 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
2526
2527 real (kind = r8), dimension (ks:ke) :: cvm, te8
2528
2529 ! -----------------------------------------------------------------------
2530 ! initialization
2531 ! -----------------------------------------------------------------------
2532
2533 reevap = 0
2534
2535 ! -----------------------------------------------------------------------
2536 ! time-scale factor
2537 ! -----------------------------------------------------------------------
2538
2539 fac_revp = 1.
2540 if (tau_revp .gt. 1.e-6) then
2541 fac_revp = 1. - exp(- dts / tau_revp)
2542 endif
2543
2544 ! -----------------------------------------------------------------------
2545 ! calculate heat capacities and latent heat coefficients
2546 ! -----------------------------------------------------------------------
2547
2548 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
2549 lcpk, icpk, tcpk, tcp3)
2550
2551 do k = ks, ke
2552
2553 tin = (tz(k) * cvm(k) - lv00 * ql(k)) / mhc(qv(k) + ql(k), qr(k), q_sol(k))
2554
2555 ! -----------------------------------------------------------------------
2556 ! calculate supersaturation and subgrid variability of water
2557 ! -----------------------------------------------------------------------
2558
2559 qpz = qv(k) + ql(k)
2560 qsat = wqs(tin, den(k), dqdt)
2561 dqv = qsat - qv(k)
2562
2563 dqh = max(ql(k), h_var * max(qpz, qcmin))
2564 dqh = min(dqh, 0.2 * qpz)
2565 q_minus = qpz - dqh
2566 q_plus = qpz + dqh
2567
2568 ! -----------------------------------------------------------------------
2569 ! rain evaporation
2570 ! -----------------------------------------------------------------------
2571
2572 rh_tem = qpz / qsat
2573
2574 if (tz(k) .gt. t_wfr .and. qr(k) .gt. qcmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then
2575
2576 if (qsat .gt. q_plus) then
2577 dq = qsat - qpz
2578 else
2579 dq = 0.25 * (qsat - q_minus) ** 2 / dqh
2580 endif
2581 qden = qr(k) * den(k)
2582 t2 = tin * tin
2583 sink = psub(t2, dq, qden, qsat, crevp, den(k), denfac(k), blinr, mur, lcpk(k), cvm(k))
2584 sink = min(qr(k), dts * fac_revp * sink, dqv / (1. + lcpk(k) * dqdt))
2585 if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then
2586 sink = 0.0
2587 endif
2588
2589 ! -----------------------------------------------------------------------
2590 ! alternative minimum evaporation in dry environmental air
2591 ! -----------------------------------------------------------------------
2592 ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt))
2593 ! sink = max (sink, tmp)
2594
2595 reevap = reevap + sink * dp(k)
2596
2597 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2598 sink, 0., - sink, 0., 0., 0., te8(k), cvm(k), tz(k), &
2599 lcpk(k), icpk(k), tcpk(k), tcp3(k))
2600
2601 endif
2602
2603 enddo ! k loop
2604
2605end subroutine prevp
2606
2607! =======================================================================
2608! rain accretion with cloud water, Lin et al. (1983)
2609! =======================================================================
2610
2611subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr)
2612
2613 implicit none
2614
2615 ! -----------------------------------------------------------------------
2616 ! input / output arguments
2617 ! -----------------------------------------------------------------------
2618
2619 integer, intent (in) :: ks, ke
2620
2621 real(kind_phys), intent (in) :: dts
2622
2623 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr
2624
2625 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2626
2627 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg
2628
2629 ! -----------------------------------------------------------------------
2630 ! local variables
2631 ! -----------------------------------------------------------------------
2632
2633 integer :: k
2634
2635 real(kind_phys) :: qden, sink
2636
2637 do k = ks, ke
2638
2639 if (tz(k) .gt. t_wfr .and. qr(k) .gt. qcmin .and. ql(k) .gt. qcmin) then
2640
2641 qden = qr(k) * den(k)
2642 if (do_new_acc_water) then
2643 sink = dts * acr3d(vtr(k), vtw(k), ql(k), qr(k), cracw, acco(:, 5), &
2644 acc(9), acc(10), den(k))
2645 else
2646 sink = dts * acr2d(qden, cracw, denfac(k), blinr, mur)
2647 sink = sink / (1. + sink) * ql(k)
2648 endif
2649
2650 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2651 0., - sink, sink, 0., 0., 0.)
2652
2653 endif
2654
2655 enddo
2656
2657end subroutine pracw
2658
2659! =======================================================================
2660! cloud water to rain autoconversion, Hong et al. (2004)
2661! =======================================================================
2662
2663subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var)
2664
2665 implicit none
2666
2667 ! -----------------------------------------------------------------------
2668 ! input / output arguments
2669 ! -----------------------------------------------------------------------
2670
2671 integer, intent (in) :: ks, ke
2672
2673 real(kind_phys), intent (in) :: dts, h_var
2674
2675 real(kind_phys), intent (in), dimension (ks:ke) :: den
2676
2677 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
2678
2679 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2680
2681 ! -----------------------------------------------------------------------
2682 ! local variables
2683 ! -----------------------------------------------------------------------
2684
2685 real(kind_phys), parameter :: so3 = 7.0 / 3.0
2686 real(kind_phys), parameter :: so1 = - 1.0 / 3.0
2687
2688 integer :: k
2689
2690 real(kind_phys) :: sink, dq, qc
2691
2692 real(kind_phys), dimension (ks:ke) :: dl, c_praut
2693
2694 if (irain_f .eq. 0) then
2695
2696 call linear_prof (ke - ks + 1, ql(ks), dl(ks), z_slope_liq, h_var)
2697
2698 do k = ks, ke
2699
2700 if (tz(k) .gt. t_wfr .and. ql(k) .gt. qcmin) then
2701
2702 if (do_psd_water_num) then
2703 call cal_pc_ed_oe_rr_tv (ql(k), den(k), blinw, muw, &
2704 pca = pcaw, pcb = pcbw, pc = ccn(k))
2705 ccn(k) = ccn(k) / den(k)
2706 endif
2707
2708 qc = fac_rc * ccn(k)
2709 dl(k) = min(max(qcmin, dl(k)), 0.5 * ql(k))
2710 dq = 0.5 * (ql(k) + dl(k) - qc)
2711
2712 if (dq .gt. 0.) then
2713
2714 c_praut(k) = cpaut * exp(so1 * log(ccn(k) * rhow))
2715 sink = min(1., dq / dl(k)) * dts * c_praut(k) * den(k) * &
2716 exp(so3 * log(ql(k)))
2717 sink = min(ql(k), sink)
2718
2719 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2720 0., - sink, sink, 0., 0., 0.)
2721
2722 endif
2723
2724 endif
2725
2726 enddo
2727
2728 endif
2729
2730 if (irain_f .eq. 1) then
2731
2732 do k = ks, ke
2733
2734 if (tz(k) .gt. t_wfr .and. ql(k) .gt. qcmin) then
2735
2736 if (do_psd_water_num) then
2737 call cal_pc_ed_oe_rr_tv (ql(k), den(k), blinw, muw, &
2738 pca = pcaw, pcb = pcbw, pc = ccn(k))
2739 ccn(k) = ccn(k) / den(k)
2740 endif
2741
2742 qc = fac_rc * ccn(k)
2743 dq = ql(k) - qc
2744
2745 if (dq .gt. 0.) then
2746
2747 c_praut(k) = cpaut * exp(so1 * log(ccn(k) * rhow))
2748 sink = min(dq, dts * c_praut(k) * den(k) * exp(so3 * log(ql(k))))
2749 sink = min(ql(k), sink)
2750
2751 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2752 0., - sink, sink, 0., 0., 0.)
2753
2754 endif
2755
2756 endif
2757
2758 enddo
2759
2760 endif
2761
2762end subroutine praut
2763
2764! =======================================================================
2765! ice cloud microphysics
2766! =======================================================================
2767
2768subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, &
2769 denfac, vtw, vtr, vti, vts, vtg, dts, h_var)
2770
2771 implicit none
2772
2773 ! -----------------------------------------------------------------------
2774 ! input / output arguments
2775 ! -----------------------------------------------------------------------
2776
2777 integer, intent (in) :: ks, ke
2778
2779 real(kind_phys), intent (in) :: dts, h_var
2780
2781 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg
2782
2783 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
2784
2785 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
2786
2787 ! -----------------------------------------------------------------------
2788 ! local variables
2789 ! -----------------------------------------------------------------------
2790
2791 real(kind_phys), dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3
2792
2793 real (kind = r8), dimension (ks:ke) :: cvm, te8
2794
2795 ! -----------------------------------------------------------------------
2796 ! calculate heat capacities and latent heat coefficients
2797 ! -----------------------------------------------------------------------
2798
2799 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
2800 lcpk, icpk, tcpk, tcp3)
2801
2802 if (.not. do_warm_rain_mp) then
2803
2804 ! -----------------------------------------------------------------------
2805 ! cloud ice melting to form cloud water and rain
2806 ! -----------------------------------------------------------------------
2807
2808 call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
2809
2810 ! -----------------------------------------------------------------------
2811 ! cloud water freezing to form cloud ice and snow
2812 ! -----------------------------------------------------------------------
2813
2814 call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
2815
2816 ! -----------------------------------------------------------------------
2817 ! vertical subgrid variability
2818 ! -----------------------------------------------------------------------
2819
2820 call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var)
2821
2822 ! -----------------------------------------------------------------------
2823 ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain
2824 ! -----------------------------------------------------------------------
2825
2826 call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
2827 vtw, vtr, vts, lcpk, icpk, tcpk, tcp3)
2828
2829 ! -----------------------------------------------------------------------
2830 ! graupel melting (includes graupel accretion with cloud water and rain) to form rain
2831 ! -----------------------------------------------------------------------
2832
2833 call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
2834 vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3)
2835
2836 ! -----------------------------------------------------------------------
2837 ! snow accretion with cloud ice
2838 ! -----------------------------------------------------------------------
2839
2840 call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts)
2841
2842 ! -----------------------------------------------------------------------
2843 ! cloud ice to snow autoconversion
2844 ! -----------------------------------------------------------------------
2845
2846 call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di)
2847
2848 ! -----------------------------------------------------------------------
2849 ! graupel accretion with cloud ice
2850 ! -----------------------------------------------------------------------
2851
2852 call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg)
2853
2854 ! -----------------------------------------------------------------------
2855 ! snow accretion with rain and rain freezing to form graupel
2856 ! -----------------------------------------------------------------------
2857
2858 call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
2859 vtr, vts, lcpk, icpk, tcpk, tcp3)
2860
2861 ! -----------------------------------------------------------------------
2862 ! graupel accretion with snow
2863 ! -----------------------------------------------------------------------
2864
2865 call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg)
2866
2867 ! -----------------------------------------------------------------------
2868 ! snow to graupel autoconversion
2869 ! -----------------------------------------------------------------------
2870
2871 call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
2872
2873 ! -----------------------------------------------------------------------
2874 ! graupel accretion with cloud water and rain
2875 ! -----------------------------------------------------------------------
2876
2877 call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
2878 vtr, vtg, lcpk, icpk, tcpk, tcp3)
2879
2880 endif ! do_warm_rain_mp
2881
2882end subroutine ice_cloud
2883
2884! =======================================================================
2885! cloud ice melting to form cloud water and rain, Lin et al. (1983)
2886! =======================================================================
2887
2888subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
2889
2890 implicit none
2891
2892 ! -----------------------------------------------------------------------
2893 ! input / output arguments
2894 ! -----------------------------------------------------------------------
2895
2896 integer, intent (in) :: ks, ke
2897
2898 real(kind_phys), intent (in) :: dts
2899
2900 real (kind = r8), intent (in), dimension (ks:ke) :: te8
2901
2902 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
2903 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
2904
2905 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
2906
2907 ! -----------------------------------------------------------------------
2908 ! local variables
2909 ! -----------------------------------------------------------------------
2910
2911 integer :: k
2912
2913 real(kind_phys) :: tc, tmp, sink, fac_imlt
2914
2915 fac_imlt = 1. - exp(- dts / tau_imlt)
2916
2917 do k = ks, ke
2918
2919 tc = tz(k) - tice_mlt
2920
2921 if (tc .gt. 0 .and. qi(k) .gt. qcmin) then
2922
2923 sink = fac_imlt * tc / icpk(k)
2924 sink = min(qi(k), sink)
2925 tmp = min(sink, dim(ql_mlt, ql(k)))
2926
2927 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2928 0., tmp, sink - tmp, - sink, 0., 0., te8(k), cvm(k), tz(k), &
2929 lcpk(k), icpk(k), tcpk(k), tcp3(k))
2930
2931 endif
2932
2933 enddo
2934
2935end subroutine pimlt
2936
2937! =======================================================================
2938! cloud water freezing to form cloud ice and snow, Lin et al. (1983)
2939! =======================================================================
2940
2941subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
2942
2943 implicit none
2944
2945 ! -----------------------------------------------------------------------
2946 ! input / output arguments
2947 ! -----------------------------------------------------------------------
2948
2949 integer, intent (in) :: ks, ke
2950
2951 real(kind_phys), intent (in), dimension (ks:ke) :: den
2952
2953 real (kind = r8), intent (in), dimension (ks:ke) :: te8
2954
2955 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
2956 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
2957
2958 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
2959
2960 ! -----------------------------------------------------------------------
2961 ! local variables
2962 ! -----------------------------------------------------------------------
2963
2964 integer :: k
2965
2966 real(kind_phys) :: tc, tmp, sink, qim
2967
2968 do k = ks, ke
2969
2970 tc = t_wfr - tz(k)
2971
2972 if (tc .gt. 0. .and. ql(k) .gt. qcmin) then
2973
2974 sink = ql(k) * tc / dt_fr
2975 sink = min(ql(k), sink, tc / icpk(k))
2976 qim = qi0_crt / den(k)
2977 tmp = min(sink, dim(qim, qi(k)))
2978
2979 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
2980 0., - sink, 0., tmp, sink - tmp, 0., te8(k), cvm(k), tz(k), &
2981 lcpk(k), icpk(k), tcpk(k), tcp3(k))
2982
2983 endif
2984
2985 enddo
2986
2987end subroutine pifr
2988
2989! =======================================================================
2990! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain
2991! Lin et al. (1983)
2992! =======================================================================
2993
2994subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
2995 vtw, vtr, vts, lcpk, icpk, tcpk, tcp3)
2996
2997 implicit none
2998
2999 ! -----------------------------------------------------------------------
3000 ! input / output arguments
3001 ! -----------------------------------------------------------------------
3002
3003 integer, intent (in) :: ks, ke
3004
3005 real(kind_phys), intent (in) :: dts
3006
3007 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts
3008
3009 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3010
3011 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3012 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3013
3014 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3015
3016 ! -----------------------------------------------------------------------
3017 ! local variables
3018 ! -----------------------------------------------------------------------
3019
3020 integer :: k
3021
3022 real(kind_phys) :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi
3023 real(kind_phys) :: psacw, psacr, pracs
3024
3025 do k = ks, ke
3026
3027 tc = tz(k) - tice
3028
3029 if (tc .ge. 0. .and. qs(k) .gt. qcmin) then
3030
3031 psacw = 0.
3032 qden = qs(k) * den(k)
3033 if (ql(k) .gt. qcmin) then
3034 if (do_new_acc_water) then
3035 psacw = acr3d(vts(k), vtw(k), ql(k), qs(k), csacw, acco(:, 7), &
3036 acc(13), acc(14), den(k))
3037 else
3038 factor = acr2d(qden, csacw, denfac(k), blins, mus)
3039 psacw = factor / (1. + dts * factor) * ql(k)
3040 endif
3041 endif
3042
3043 psacr = 0.
3044 pracs = 0.
3045 if (qr(k) .gt. qcmin) then
3046 psacr = min(acr3d(vts(k), vtr(k), qr(k), qs(k), csacr, acco(:, 2), &
3047 acc(3), acc(4), den(k)), qr(k) / dts)
3048 pracs = acr3d(vtr(k), vts(k), qs(k), qr(k), cracs, acco(:, 1), &
3049 acc(1), acc(2), den(k))
3050 endif
3051
3052 tin = tz(k)
3053 qsi = iqs(tin, den(k), dqdt)
3054 dq = qsi - qv(k)
3055 sink = max(0., pmlt(tc, dq, qden, psacw, psacr, csmlt, den(k), denfac(k), blins, mus, &
3056 lcpk(k), icpk(k), cvm(k)))
3057
3058 sink = min(qs(k), (sink + pracs) * dts, tc / icpk(k))
3059 tmp = min(sink, dim(qs_mlt, ql(k)))
3060
3061 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3062 0., tmp, sink - tmp, 0., - sink, 0., te8(k), cvm(k), tz(k), &
3063 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3064
3065 endif
3066
3067 enddo
3068
3069end subroutine psmlt
3070
3071! =======================================================================
3072! graupel melting (includes graupel accretion with cloud water and rain) to form rain
3073! Lin et al. (1983)
3074! =======================================================================
3075
3076subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
3077 vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3)
3078
3079 implicit none
3080
3081 ! -----------------------------------------------------------------------
3082 ! input / output arguments
3083 ! -----------------------------------------------------------------------
3084
3085 integer, intent (in) :: ks, ke
3086
3087 real(kind_phys), intent (in) :: dts
3088
3089 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg
3090
3091 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3092
3093 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3094 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3095
3096 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3097
3098 ! -----------------------------------------------------------------------
3099 ! local variables
3100 ! -----------------------------------------------------------------------
3101
3102 integer :: k
3103
3104 real(kind_phys) :: tc, factor, sink, qden, dqdt, tin, dq, qsi
3105 real(kind_phys) :: pgacw, pgacr
3106
3107 do k = ks, ke
3108
3109 tc = tz(k) - tice
3110
3111 if (tc .ge. 0. .and. qg(k) .gt. qcmin) then
3112
3113 pgacw = 0.
3114 qden = qg(k) * den(k)
3115 if (ql(k) .gt. qcmin) then
3116 if (do_new_acc_water) then
3117 pgacw = acr3d(vtg(k), vtw(k), ql(k), qg(k), cgacw, acco(:, 9), &
3118 acc(17), acc(18), den(k))
3119 else
3120 if (do_hail) then
3121 factor = acr2d(qden, cgacw, denfac(k), blinh, muh)
3122 else
3123 factor = acr2d(qden, cgacw, denfac(k), bling, mug)
3124 endif
3125 pgacw = factor / (1. + dts * factor) * ql(k)
3126 endif
3127 endif
3128
3129 pgacr = 0.
3130 if (qr(k) .gt. qcmin) then
3131 pgacr = min(acr3d(vtg(k), vtr(k), qr(k), qg(k), cgacr, acco(:, 3), &
3132 acc(5), acc(6), den(k)), qr(k) / dts)
3133 endif
3134
3135 tin = tz(k)
3136 qsi = iqs(tin, den(k), dqdt)
3137 dq = qsi - qv(k)
3138 if (do_hail) then
3139 sink = max(0., pmlt(tc, dq, qden, pgacw, pgacr, cgmlt, den(k), denfac(k), &
3140 blinh, muh, lcpk(k), icpk(k), cvm(k)))
3141 else
3142 sink = max(0., pmlt(tc, dq, qden, pgacw, pgacr, cgmlt, den(k), denfac(k), &
3143 bling, mug, lcpk(k), icpk(k), cvm(k)))
3144 endif
3145
3146 sink = min(qg(k), sink * dts, tc / icpk(k))
3147
3148 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3149 0., 0., sink, 0., 0., - sink, te8(k), cvm(k), tz(k), &
3150 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3151
3152 endif
3153
3154 enddo
3155
3156end subroutine pgmlt
3157
3158! =======================================================================
3159! snow accretion with cloud ice, Lin et al. (1983)
3160! =======================================================================
3161
3162subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts)
3163
3164 implicit none
3165
3166 ! -----------------------------------------------------------------------
3167 ! input / output arguments
3168 ! -----------------------------------------------------------------------
3169
3170 integer, intent (in) :: ks, ke
3171
3172 real(kind_phys), intent (in) :: dts
3173
3174 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vti, vts
3175
3176 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3177
3178 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3179
3180 ! -----------------------------------------------------------------------
3181 ! local variables
3182 ! -----------------------------------------------------------------------
3183
3184 integer :: k
3185
3186 real(kind_phys) :: tc, factor, sink, qden
3187
3188 do k = ks, ke
3189
3190 tc = tz(k) - tice
3191
3192 if (tc .lt. 0. .and. qi(k) .gt. qcmin) then
3193
3194 sink = 0.
3195 qden = qs(k) * den(k)
3196 if (qs(k) .gt. qcmin) then
3197 if (do_new_acc_ice) then
3198 sink = dts * acr3d(vts(k), vti(k), qi(k), qs(k), csaci, acco(:, 8), &
3199 acc(15), acc(16), den(k))
3200 else
3201 factor = dts * acr2d(qden, csaci, denfac(k), blins, mus)
3202 sink = factor / (1. + factor) * qi(k)
3203 endif
3204 endif
3205
3206 sink = min(fi2s_fac * qi(k), sink)
3207
3208 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3209 0., 0., 0., - sink, sink, 0.)
3210
3211 endif
3212
3213 enddo
3214
3215end subroutine psaci
3216
3217! =======================================================================
3218! cloud ice to snow autoconversion, Lin et al. (1983)
3219! =======================================================================
3220
3221subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di)
3222
3223 implicit none
3224
3225 ! -----------------------------------------------------------------------
3226 ! input / output arguments
3227 ! -----------------------------------------------------------------------
3228
3229 integer, intent (in) :: ks, ke
3230
3231 real(kind_phys), intent (in) :: dts
3232
3233 real(kind_phys), intent (in), dimension (ks:ke) :: den
3234
3235 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di
3236
3237 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3238
3239 ! -----------------------------------------------------------------------
3240 ! local variables
3241 ! -----------------------------------------------------------------------
3242
3243 integer :: k
3244
3245 real(kind_phys) :: tc, sink, fac_i2s, q_plus, qim, dq, tmp
3246
3247 fac_i2s = 1. - exp(- dts / tau_i2s)
3248
3249 do k = ks, ke
3250
3251 tc = tz(k) - tice
3252
3253 if (tc .lt. 0. .and. qi(k) .gt. qcmin) then
3254
3255 sink = 0.
3256 tmp = fac_i2s * exp(0.025 * tc)
3257 di(k) = max(di(k), qcmin)
3258 q_plus = qi(k) + di(k)
3259 qim = qi0_crt / den(k)
3260 if (q_plus .gt. (qim + qcmin)) then
3261 if (qim .gt. (qi(k) - di(k))) then
3262 dq = (0.25 * (q_plus - qim) ** 2) / di(k)
3263 else
3264 dq = qi(k) - qim
3265 endif
3266 sink = tmp * dq
3267 endif
3268
3269 sink = min(fi2s_fac * qi(k), sink)
3270
3271 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3272 0., 0., 0., - sink, sink, 0.)
3273
3274 endif
3275
3276 enddo
3277
3278end subroutine psaut
3279
3280! =======================================================================
3281! graupel accretion with cloud ice, Lin et al. (1983)
3282! =======================================================================
3283
3284subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg)
3285
3286 implicit none
3287
3288 ! -----------------------------------------------------------------------
3289 ! input / output arguments
3290 ! -----------------------------------------------------------------------
3291
3292 integer, intent (in) :: ks, ke
3293
3294 real(kind_phys), intent (in) :: dts
3295
3296 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vti, vtg
3297
3298 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3299
3300 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3301
3302 ! -----------------------------------------------------------------------
3303 ! local variables
3304 ! -----------------------------------------------------------------------
3305
3306 integer :: k
3307
3308 real(kind_phys) :: tc, factor, sink, qden
3309
3310 do k = ks, ke
3311
3312 tc = tz(k) - tice
3313
3314 if (tc .lt. 0. .and. qi(k) .gt. qcmin) then
3315
3316 sink = 0.
3317 qden = qg(k) * den(k)
3318 if (qg(k) .gt. qcmin) then
3319 if (do_new_acc_ice) then
3320 sink = dts * acr3d(vtg(k), vti(k), qi(k), qg(k), cgaci, acco(:, 10), &
3321 acc(19), acc(20), den(k))
3322 else
3323 if (do_hail) then
3324 factor = dts * acr2d(qden, cgaci, denfac(k), blinh, muh)
3325 else
3326 factor = dts * acr2d(qden, cgaci, denfac(k), bling, mug)
3327 endif
3328 sink = factor / (1. + factor) * qi(k)
3329 endif
3330 endif
3331
3332 sink = min(fi2g_fac * qi(k), sink)
3333
3334 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3335 0., 0., 0., - sink, 0., sink)
3336
3337 endif
3338
3339 enddo
3340
3341end subroutine pgaci
3342
3343! =======================================================================
3344! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983)
3345! =======================================================================
3346
3347subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
3348 vtr, vts, lcpk, icpk, tcpk, tcp3)
3349
3350 implicit none
3351
3352 ! -----------------------------------------------------------------------
3353 ! input / output arguments
3354 ! -----------------------------------------------------------------------
3355
3356 integer, intent (in) :: ks, ke
3357
3358 real(kind_phys), intent (in) :: dts
3359
3360 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtr, vts
3361
3362 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3363
3364 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3365 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3366
3367 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3368
3369 ! -----------------------------------------------------------------------
3370 ! local variables
3371 ! -----------------------------------------------------------------------
3372
3373 integer :: k
3374
3375 real(kind_phys) :: tc, factor, sink
3376 real(kind_phys) :: psacr, pgfr
3377
3378 do k = ks, ke
3379
3380 tc = tz(k) - tice
3381
3382 if (tc .lt. 0. .and. qr(k) .gt. qcmin) then
3383
3384 psacr = 0.
3385 if (qs(k) .gt. qcmin) then
3386 psacr = dts * acr3d(vts(k), vtr(k), qr(k), qs(k), csacr, acco(:, 2), &
3387 acc(3), acc(4), den(k))
3388 endif
3389
3390 pgfr = dts * cgfr(1) / den(k) * (exp(- cgfr(2) * tc) - 1.) * &
3391 exp((6 + mur) / (mur + 3) * log(6 * qr(k) * den(k)))
3392
3393 sink = psacr + pgfr
3394 factor = min(sink, qr(k), - tc / icpk(k)) / max(sink, qcmin)
3395 psacr = factor * psacr
3396 pgfr = factor * pgfr
3397
3398 sink = min(qr(k), psacr + pgfr)
3399
3400 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3401 0., 0., - sink, 0., psacr, pgfr, te8(k), cvm(k), tz(k), &
3402 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3403
3404 endif
3405
3406 enddo
3407
3408end subroutine psacr_pgfr
3409
3410! =======================================================================
3411! graupel accretion with snow, Lin et al. (1983)
3412! =======================================================================
3413
3414subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg)
3415
3416 implicit none
3417
3418 ! -----------------------------------------------------------------------
3419 ! input / output arguments
3420 ! -----------------------------------------------------------------------
3421
3422 integer, intent (in) :: ks, ke
3423
3424 real(kind_phys), intent (in) :: dts
3425
3426 real(kind_phys), intent (in), dimension (ks:ke) :: den, vts, vtg
3427
3428 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3429
3430 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3431
3432 ! -----------------------------------------------------------------------
3433 ! local variables
3434 ! -----------------------------------------------------------------------
3435
3436 integer :: k
3437
3438 real(kind_phys) :: sink
3439
3440 do k = ks, ke
3441
3442 if (tz(k) .lt. tice .and. qs(k) .gt. qcmin .and. qg(k) .gt. qcmin) then
3443
3444 sink = dts * acr3d(vtg(k), vts(k), qs(k), qg(k), cgacs, acco(:, 4), &
3445 acc(7), acc(8), den(k))
3446 sink = min(fs2g_fac * qs(k), sink)
3447
3448 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3449 0., 0., 0., 0., - sink, sink)
3450
3451 endif
3452
3453 enddo
3454
3455end subroutine pgacs
3456
3457! =======================================================================
3458! snow to graupel autoconversion, Lin et al. (1983)
3459! =======================================================================
3460
3461subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
3462
3463 implicit none
3464
3465 ! -----------------------------------------------------------------------
3466 ! input / output arguments
3467 ! -----------------------------------------------------------------------
3468
3469 integer, intent (in) :: ks, ke
3470
3471 real(kind_phys), intent (in) :: dts
3472
3473 real(kind_phys), intent (in), dimension (ks:ke) :: den
3474
3475 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3476
3477 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3478
3479 ! -----------------------------------------------------------------------
3480 ! local variables
3481 ! -----------------------------------------------------------------------
3482
3483 integer :: k
3484
3485 real(kind_phys) :: tc, factor, sink, qsm
3486
3487 do k = ks, ke
3488
3489 tc = tz(k) - tice
3490
3491 if (tc .lt. 0. .and. qs(k) .gt. qcmin) then
3492
3493 sink = 0
3494 qsm = qs0_crt / den(k)
3495 if (qs(k) .gt. qsm) then
3496 factor = dts * 1.e-3 * exp(0.09 * (tz(k) - tice))
3497 sink = factor / (1. + factor) * (qs(k) - qsm)
3498 endif
3499
3500 sink = min(fs2g_fac * qs(k), sink)
3501
3502 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3503 0., 0., 0., 0., - sink, sink)
3504
3505 endif
3506
3507 enddo
3508
3509end subroutine pgaut
3510
3511! =======================================================================
3512! graupel accretion with cloud water and rain, Lin et al. (1983)
3513! =======================================================================
3514
3515subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, &
3516 vtr, vtg, lcpk, icpk, tcpk, tcp3)
3517
3518 implicit none
3519
3520 ! -----------------------------------------------------------------------
3521 ! input / output arguments
3522 ! -----------------------------------------------------------------------
3523
3524 integer, intent (in) :: ks, ke
3525
3526 real(kind_phys), intent (in) :: dts
3527
3528 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg
3529
3530 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3531
3532 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3533 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3534
3535 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3536
3537 ! -----------------------------------------------------------------------
3538 ! local variables
3539 ! -----------------------------------------------------------------------
3540
3541 integer :: k
3542
3543 real(kind_phys) :: tc, factor, sink, qden
3544 real(kind_phys) :: pgacw, pgacr
3545
3546 do k = ks, ke
3547
3548 tc = tz(k) - tice
3549
3550 if (tc .lt. 0. .and. qg(k) .gt. qcmin) then
3551
3552 pgacw = 0.
3553 if (ql(k) .gt. qcmin) then
3554 qden = qg(k) * den(k)
3555 if (do_hail) then
3556 factor = dts * acr2d(qden, cgacw, denfac(k), blinh, muh)
3557 else
3558 factor = dts * acr2d(qden, cgacw, denfac(k), bling, mug)
3559 endif
3560 pgacw = factor / (1. + factor) * ql(k)
3561 endif
3562
3563 pgacr = 0.
3564 if (qr(k) .gt. qcmin) then
3565 pgacr = min(dts * acr3d(vtg(k), vtr(k), qr(k), qg(k), cgacr, acco(:, 3), &
3566 acc(5), acc(6), den(k)), qr(k))
3567 endif
3568
3569 sink = pgacr + pgacw
3570 factor = min(sink, dim(tice, tz(k)) / icpk(k)) / max(sink, qcmin)
3571 pgacr = factor * pgacr
3572 pgacw = factor * pgacw
3573
3574 sink = pgacr + pgacw
3575
3576 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3577 0., - pgacw, - pgacr, 0., 0., sink, te8(k), cvm(k), tz(k), &
3578 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3579
3580 endif
3581
3582 enddo
3583
3584end subroutine pgacw_pgacr
3585
3586! =======================================================================
3587! temperature sentive high vertical resolution processes
3588! =======================================================================
3589
3590subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, &
3591 qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step)
3592
3593 implicit none
3594
3595 ! -----------------------------------------------------------------------
3596 ! input / output arguments
3597 ! -----------------------------------------------------------------------
3598
3599 logical, intent (in) :: last_step
3600
3601 integer, intent (in) :: ks, ke
3602
3603 real(kind_phys), intent (in) :: dts, rh_adj
3604
3605 real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, dp
3606
3607 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin
3608
3609 real(kind_phys), intent (out) :: cond, dep, reevap, sub
3610
3611 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
3612
3613 ! -----------------------------------------------------------------------
3614 ! local variables
3615 ! -----------------------------------------------------------------------
3616
3617 logical :: cond_evap
3618
3619 integer :: n
3620
3621 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3
3622
3623 real (kind = r8), dimension (ks:ke) :: cvm, te8
3624
3625 ! -----------------------------------------------------------------------
3626 ! initialization
3627 ! -----------------------------------------------------------------------
3628
3629 cond = 0
3630 dep = 0
3631 reevap = 0
3632 sub = 0
3633
3634 ! -----------------------------------------------------------------------
3635 ! calculate heat capacities and latent heat coefficients
3636 ! -----------------------------------------------------------------------
3637
3638 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
3639 lcpk, icpk, tcpk, tcp3)
3640
3641 ! -----------------------------------------------------------------------
3642 ! instant processes (include deposition, evaporation, and sublimation)
3643 ! -----------------------------------------------------------------------
3644
3645 if (.not. do_warm_rain_mp) then
3646
3647 call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3648 lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap)
3649
3650 endif
3651
3652 ! -----------------------------------------------------------------------
3653 ! cloud water condensation and evaporation
3654 ! -----------------------------------------------------------------------
3655
3656 if (delay_cond_evap) then
3657 cond_evap = last_step
3658 else
3659 cond_evap = .true.
3660 endif
3661
3662 if (cond_evap) then
3663 do n = 1, nconds
3664 call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3665 lcpk, icpk, tcpk, tcp3, cond, reevap)
3666 enddo
3667 endif
3668
3669 if (.not. do_warm_rain_mp) then
3670
3671 ! -----------------------------------------------------------------------
3672 ! enforce complete freezing below t_wfr
3673 ! -----------------------------------------------------------------------
3674
3675 call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
3676
3677 ! -----------------------------------------------------------------------
3678 ! Wegener Bergeron Findeisen process
3679 ! -----------------------------------------------------------------------
3680
3681 call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
3682
3683 ! -----------------------------------------------------------------------
3684 ! Bigg freezing mechanism
3685 ! -----------------------------------------------------------------------
3686
3687 call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3)
3688
3689 ! -----------------------------------------------------------------------
3690 ! cloud ice deposition and sublimation
3691 ! -----------------------------------------------------------------------
3692
3693 call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3694 lcpk, icpk, tcpk, tcp3, cin, dep, sub)
3695
3696 ! -----------------------------------------------------------------------
3697 ! snow deposition and sublimation
3698 ! -----------------------------------------------------------------------
3699
3700 call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3701 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
3702
3703 ! -----------------------------------------------------------------------
3704 ! graupel deposition and sublimation
3705 ! -----------------------------------------------------------------------
3706
3707 call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3708 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
3709
3710 endif
3711
3712end subroutine subgrid_z_proc
3713
3714! =======================================================================
3715! instant processes (include deposition, evaporation, and sublimation)
3716! =======================================================================
3717
3718subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3719 lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap)
3720
3721 implicit none
3722
3723 ! -----------------------------------------------------------------------
3724 ! input / output arguments
3725 ! -----------------------------------------------------------------------
3726
3727 integer, intent (in) :: ks, ke
3728
3729 real(kind_phys), intent (in) :: rh_adj
3730
3731 real(kind_phys), intent (in), dimension (ks:ke) :: den, dp
3732
3733 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3734
3735 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3736 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3737
3738 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3739
3740 real(kind_phys), intent (out) :: dep, reevap, sub
3741
3742 ! -----------------------------------------------------------------------
3743 ! local variables
3744 ! -----------------------------------------------------------------------
3745
3746 integer :: k
3747
3748 real(kind_phys) :: sink, tin, qpz, rh, dqdt, tmp, qsi
3749
3750 do k = ks, ke
3751
3752 ! -----------------------------------------------------------------------
3753 ! instant deposit all water vapor to cloud ice when temperature is super low
3754 ! -----------------------------------------------------------------------
3755
3756 if (tz(k) .lt. t_min) then
3757
3758 sink = dim(qv(k), qcmin)
3759 dep = dep + sink * dp(k)
3760
3761 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3762 - sink, 0., 0., sink, 0., 0., te8(k), cvm(k), tz(k), &
3763 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3764
3765 endif
3766
3767 ! -----------------------------------------------------------------------
3768 ! instant evaporation / sublimation of all clouds when rh < rh_adj
3769 ! -----------------------------------------------------------------------
3770
3771 qpz = qv(k) + ql(k) + qi(k)
3772 tin = (te8(k) - lv00 * qpz + li00 * (qs(k) + qg(k))) / &
3773 mhc(qpz, qr(k), qs(k) + qg(k))
3774
3775 if (tin .gt. t_sub + 6.) then
3776
3777 qsi = iqs(tin, den(k), dqdt)
3778 rh = qpz / qsi
3779 if (rh .lt. rh_adj) then
3780
3781 sink = ql(k)
3782 tmp = qi(k)
3783
3784 reevap = reevap + sink * dp(k)
3785 sub = sub + tmp * dp(k)
3786
3787 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3788 sink + tmp, - sink, 0., - tmp, 0., 0., te8(k), cvm(k), tz(k), &
3789 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3790
3791 endif
3792
3793 endif
3794
3795 enddo
3796
3797end subroutine pinst
3798
3799! =======================================================================
3800! cloud water condensation and evaporation, Hong and Lim (2006)
3801! =======================================================================
3802
3803subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
3804 lcpk, icpk, tcpk, tcp3, cond, reevap)
3805
3806 implicit none
3807
3808 ! -----------------------------------------------------------------------
3809 ! input / output arguments
3810 ! -----------------------------------------------------------------------
3811
3812 integer, intent (in) :: ks, ke
3813
3814 real(kind_phys), intent (in) :: dts
3815
3816 real(kind_phys), intent (in), dimension (ks:ke) :: den, dp
3817
3818 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3819
3820 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3821 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3822
3823 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3824
3825 real(kind_phys), intent (out) :: cond, reevap
3826
3827 ! -----------------------------------------------------------------------
3828 ! local variables
3829 ! -----------------------------------------------------------------------
3830
3831 integer :: k
3832
3833 real(kind_phys) :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l
3834
3835 fac_l2v = 1. - exp(- dts / tau_l2v)
3836 fac_v2l = 1. - exp(- dts / tau_v2l)
3837
3838 do k = ks, ke
3839
3840 tin = tz(k)
3841 qsw = wqs(tin, den(k), dqdt)
3842 qpz = qv(k) + ql(k) + qi(k)
3843 rh_tem = qpz / qsw
3844 dq = qsw - qv(k)
3845 if (dq .gt. 0.) then
3846 if (do_evap_timescale) then
3847 factor = min(1., fac_l2v * (rh_fac_evap * dq / qsw))
3848 else
3849 factor = 1.
3850 endif
3851 sink = min(ql(k), factor * dq / (1. + tcp3(k) * dqdt))
3852 if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then
3853 sink = 0.
3854 endif
3855 reevap = reevap + sink * dp(k)
3856 else
3857 if (do_cond_timescale) then
3858 factor = min(1., fac_v2l * (rh_fac_cond * (- dq) / qsw))
3859 else
3860 factor = 1.
3861 endif
3862 sink = - min(qv(k), factor * (- dq) / (1. + tcp3(k) * dqdt))
3863 cond = cond - sink * dp(k)
3864 endif
3865
3866 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3867 sink, - sink, 0., 0., 0., 0., te8(k), cvm(k), tz(k), &
3868 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3869
3870 enddo
3871
3872end subroutine pcond_pevap
3873
3874! =======================================================================
3875! enforce complete freezing below t_wfr, Lin et al. (1983)
3876! =======================================================================
3877
3878subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3)
3879
3880 implicit none
3881
3882 ! -----------------------------------------------------------------------
3883 ! input / output arguments
3884 ! -----------------------------------------------------------------------
3885
3886 integer, intent (in) :: ks, ke
3887
3888 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3889
3890 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3891 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3892
3893 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3894
3895 ! -----------------------------------------------------------------------
3896 ! local variables
3897 ! -----------------------------------------------------------------------
3898
3899 integer :: k
3900
3901 real(kind_phys) :: tc, sink
3902
3903 do k = ks, ke
3904
3905 tc = t_wfr - tz(k)
3906
3907 if (tc .gt. 0. .and. ql(k) .gt. qcmin) then
3908
3909 sink = ql(k) * tc / dt_fr
3910 sink = min(ql(k), sink, tc / icpk(k))
3911
3912 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3913 0., - sink, 0., sink, 0., 0., te8(k), cvm(k), tz(k), &
3914 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3915
3916 endif
3917
3918 enddo
3919
3920end subroutine pcomp
3921
3922! =======================================================================
3923! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015)
3924! =======================================================================
3925
3926subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3)
3927
3928 implicit none
3929
3930 ! -----------------------------------------------------------------------
3931 ! input / output arguments
3932 ! -----------------------------------------------------------------------
3933
3934 integer, intent (in) :: ks, ke
3935
3936 real(kind_phys), intent (in) :: dts
3937
3938 real(kind_phys), intent (in), dimension (ks:ke) :: den
3939
3940 real (kind = r8), intent (in), dimension (ks:ke) :: te8
3941
3942 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
3943 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
3944
3945 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
3946
3947 ! -----------------------------------------------------------------------
3948 ! local variables
3949 ! -----------------------------------------------------------------------
3950
3951 integer :: k
3952
3953 real(kind_phys) :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf
3954
3955 if (.not. do_wbf) return
3956
3957 fac_wbf = 1. - exp(- dts / tau_wbf)
3958
3959 do k = ks, ke
3960
3961 tc = tice - tz(k)
3962
3963 tin = tz(k)
3964 qsw = wqs(tin, den(k), dqdt)
3965 qsi = iqs(tin, den(k), dqdt)
3966
3967 if (tc .gt. 0. .and. ql(k) .gt. qcmin .and. qi(k) .gt. qcmin .and. &
3968 qv(k) .gt. qsi .and. qv(k) .lt. qsw) then
3969
3970 sink = min(fac_wbf * ql(k), tc / icpk(k))
3971 qim = qi0_crt / den(k)
3972 tmp = min(sink, dim(qim, qi(k)))
3973
3974 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
3975 0., - sink, 0., tmp, sink - tmp, 0., te8(k), cvm(k), tz(k), &
3976 lcpk(k), icpk(k), tcpk(k), tcp3(k))
3977
3978 endif
3979
3980 enddo
3981
3982end subroutine pwbf
3983
3984! =======================================================================
3985! Bigg freezing mechanism, Bigg (1953)
3986! =======================================================================
3987
3988subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3)
3989
3990 implicit none
3991
3992 ! -----------------------------------------------------------------------
3993 ! input / output arguments
3994 ! -----------------------------------------------------------------------
3995
3996 integer, intent (in) :: ks, ke
3997
3998 real(kind_phys), intent (in) :: dts
3999
4000 real(kind_phys), intent (in), dimension (ks:ke) :: den
4001
4002 real (kind = r8), intent (in), dimension (ks:ke) :: te8
4003
4004 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn
4005 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
4006
4007 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
4008
4009 ! -----------------------------------------------------------------------
4010 ! local variables
4011 ! -----------------------------------------------------------------------
4012
4013 integer :: k
4014
4015 real(kind_phys) :: sink, tc
4016
4017 do k = ks, ke
4018
4019 tc = tice - tz(k)
4020
4021 if (tc .gt. 0 .and. ql(k) .gt. qcmin) then
4022
4023 if (do_psd_water_num) then
4024 call cal_pc_ed_oe_rr_tv (ql(k), den(k), blinw, muw, &
4025 pca = pcaw, pcb = pcbw, pc = ccn(k))
4026 ccn(k) = ccn(k) / den(k)
4027 endif
4028
4029 sink = 100. / (rhow * ccn(k)) * dts * (exp(0.66 * tc) - 1.) * ql(k) ** 2
4030 sink = min(ql(k), sink, tc / icpk(k))
4031
4032 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
4033 0., - sink, 0., sink, 0., 0., te8(k), cvm(k), tz(k), &
4034 lcpk(k), icpk(k), tcpk(k), tcp3(k))
4035
4036 endif
4037
4038 enddo
4039
4040end subroutine pbigg
4041
4042! =======================================================================
4043! cloud ice deposition and sublimation, Hong et al. (2004)
4044! =======================================================================
4045
4046subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
4047 lcpk, icpk, tcpk, tcp3, cin, dep, sub)
4048
4049 implicit none
4050
4051 ! -----------------------------------------------------------------------
4052 ! input / output arguments
4053 ! -----------------------------------------------------------------------
4054
4055 integer, intent (in) :: ks, ke
4056
4057 real(kind_phys), intent (in) :: dts
4058
4059 real(kind_phys), intent (in), dimension (ks:ke) :: den, dp
4060
4061 real (kind = r8), intent (in), dimension (ks:ke) :: te8
4062
4063 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, cin
4064 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
4065
4066 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
4067
4068 real(kind_phys), intent (out) :: dep, sub
4069
4070 ! -----------------------------------------------------------------------
4071 ! local variables
4072 ! -----------------------------------------------------------------------
4073
4074 integer :: k
4075
4076 real(kind_phys) :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_crt!,qi_gen
4077
4078 do k = ks, ke
4079
4080 if (tz(k) .lt. tice) then
4081
4082 pidep = 0.
4083 tin = tz(k)
4084 qsi = iqs(tin, den(k), dqdt)
4085 dq = qv(k) - qsi
4086 tmp = dq / (1. + tcpk(k) * dqdt)
4087
4088 if (qi(k) .gt. qcmin) then
4089 if (.not. prog_ccn) then
4090 if (inflag .eq. 1) &
4091 cin(k) = 5.38e7 * exp(0.75 * log(qi(k) * den(k)))
4092 if (inflag .eq. 2) &
4093 cin(k) = exp(- 2.80 + 0.262 * (tice - tz(k))) * 1000.0
4094 if (inflag .eq. 3) &
4095 cin(k) = exp(- 0.639 + 12.96 * (qv(k) / qsi - 1.0)) * 1000.0
4096 if (inflag .eq. 4) &
4097 cin(k) = 5.e-3 * exp(0.304 * (tice - tz(k))) * 1000.0
4098 if (inflag .eq. 5) &
4099 cin(k) = 1.e-5 * exp(0.5 * (tice - tz(k))) * 1000.0
4100 endif
4101 if (do_psd_ice_num) then
4102 call cal_pc_ed_oe_rr_tv (qi(k), den(k), blini, mui, &
4103 pca = pcai, pcb = pcbi, pc = cin(k))
4104 cin(k) = cin(k) / den(k)
4105 endif
4106 pidep = dts * dq * 4.0 * 11.9 * exp(0.5 * log(qi(k) * den(k) * cin(k))) / &
4107 (qsi * den(k) * (tcpk(k) * cvm(k)) ** 2 / (tcond * rvgas * tz(k) ** 2) + &
4108 1. / vdifu)
4109 endif
4110
4111 if (dq .gt. 0.) then
4112 tc = tice - tz(k)
4113 !qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc)))
4114 if (igflag .eq. 1) &
4115 qi_crt = qi_gen / den(k)
4116 if (igflag .eq. 2) &
4117 qi_crt = qi_gen * min(qi_lim, 0.1 * tc) / den(k)
4118 if (igflag .eq. 3) &
4119 qi_crt = 1.82e-6 * min(qi_lim, 0.1 * tc) / den(k)
4120 if (igflag .eq. 4) &
4121 qi_crt = max(qi_gen, 1.82e-6) * min(qi_lim, 0.1 * tc) / den(k)
4122 sink = min(tmp, max(qi_crt - qi(k), pidep), tc / tcpk(k))
4123 dep = dep + sink * dp(k)
4124 else
4125 pidep = pidep * min(1., dim(tz(k), t_sub) * is_fac)
4126 sink = max(pidep, tmp, - qi(k))
4127 sub = sub - sink * dp(k)
4128 endif
4129
4130 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
4131 - sink, 0., 0., sink, 0., 0., te8(k), cvm(k), tz(k), &
4132 lcpk(k), icpk(k), tcpk(k), tcp3(k))
4133
4134 endif
4135
4136 enddo
4137
4138end subroutine pidep_pisub
4139
4140! =======================================================================
4141! snow deposition and sublimation, Lin et al. (1983)
4142! =======================================================================
4143
4144subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
4145 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
4146
4147 implicit none
4148
4149 ! -----------------------------------------------------------------------
4150 ! input / output arguments
4151 ! -----------------------------------------------------------------------
4152
4153 integer, intent (in) :: ks, ke
4154
4155 real(kind_phys), intent (in) :: dts
4156
4157 real(kind_phys), intent (in), dimension (ks:ke) :: den, dp, denfac
4158
4159 real (kind = r8), intent (in), dimension (ks:ke) :: te8
4160
4161 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
4162 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
4163
4164 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
4165
4166 real(kind_phys), intent (out) :: dep, sub
4167
4168 ! -----------------------------------------------------------------------
4169 ! local variables
4170 ! -----------------------------------------------------------------------
4171
4172 integer :: k
4173
4174 real(kind_phys) :: sink, tin, dqdt, qsi, qden, t2, dq, pssub
4175
4176 do k = ks, ke
4177
4178 if (qs(k) .gt. qcmin) then
4179
4180 tin = tz(k)
4181 qsi = iqs(tin, den(k), dqdt)
4182 qden = qs(k) * den(k)
4183 t2 = tz(k) * tz(k)
4184 dq = qsi - qv(k)
4185 pssub = psub(t2, dq, qden, qsi, cssub, den(k), denfac(k), blins, mus, tcpk(k), cvm(k))
4186 pssub = dts * pssub
4187 dq = dq / (1. + tcpk(k) * dqdt)
4188 if (pssub .gt. 0.) then
4189 sink = min(pssub * min(1., dim(tz(k), t_sub) * ss_fac), qs(k))
4190 sub = sub + sink * dp(k)
4191 else
4192 sink = 0.
4193 if (tz(k) .le. tice) then
4194 sink = max(pssub, dq, (tz(k) - tice) / tcpk(k))
4195 endif
4196 dep = dep - sink * dp(k)
4197 endif
4198
4199 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
4200 sink, 0., 0., 0., - sink, 0., te8(k), cvm(k), tz(k), &
4201 lcpk(k), icpk(k), tcpk(k), tcp3(k))
4202
4203 endif
4204
4205 enddo
4206
4207end subroutine psdep_pssub
4208
4209! =======================================================================
4210! graupel deposition and sublimation, Lin et al. (1983)
4211! =======================================================================
4212
4213subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, &
4214 denfac, lcpk, icpk, tcpk, tcp3, dep, sub)
4215
4216 implicit none
4217
4218 ! -----------------------------------------------------------------------
4219 ! input / output arguments
4220 ! -----------------------------------------------------------------------
4221
4222 integer, intent (in) :: ks, ke
4223
4224 real(kind_phys), intent (in) :: dts
4225
4226 real(kind_phys), intent (in), dimension (ks:ke) :: den, dp, denfac
4227
4228 real (kind = r8), intent (in), dimension (ks:ke) :: te8
4229
4230 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
4231 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
4232
4233 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
4234
4235 real(kind_phys), intent (out) :: dep, sub
4236
4237 ! -----------------------------------------------------------------------
4238 ! local variables
4239 ! -----------------------------------------------------------------------
4240
4241 integer :: k
4242
4243 real(kind_phys) :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub
4244
4245 do k = ks, ke
4246
4247 if (qg(k) .gt. qcmin) then
4248
4249 tin = tz(k)
4250 qsi = iqs(tin, den(k), dqdt)
4251 qden = qg(k) * den(k)
4252 t2 = tz(k) * tz(k)
4253 dq = qsi - qv(k)
4254 if (do_hail) then
4255 pgsub = psub(t2, dq, qden, qsi, cgsub, den(k), denfac(k), &
4256 blinh, muh, tcpk(k), cvm(k))
4257 else
4258 pgsub = psub(t2, dq, qden, qsi, cgsub, den(k), denfac(k), &
4259 bling, mug, tcpk(k), cvm(k))
4260 endif
4261 pgsub = dts * pgsub
4262 dq = dq / (1. + tcpk(k) * dqdt)
4263 if (pgsub .gt. 0.) then
4264 sink = min(pgsub * min(1., dim(tz(k), t_sub) * gs_fac), qg(k))
4265 sub = sub + sink * dp(k)
4266 else
4267 sink = 0.
4268 if (tz(k) .le. tice) then
4269 sink = max(pgsub, dq, (tz(k) - tice) / tcpk(k))
4270 endif
4271 dep = dep - sink * dp(k)
4272 endif
4273
4274 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
4275 sink, 0., 0., 0., 0., - sink, te8(k), cvm(k), tz(k), &
4276 lcpk(k), icpk(k), tcpk(k), tcp3(k))
4277
4278 endif
4279
4280 enddo
4281
4282end subroutine pgdep_pgsub
4283
4284! =======================================================================
4285! cloud fraction diagnostic
4286! =======================================================================
4287
4288subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_var, gsize)
4289
4290 implicit none
4291
4292 ! -----------------------------------------------------------------------
4293 ! input / output arguments
4294 ! -----------------------------------------------------------------------
4295
4296 integer, intent (in) :: ks, ke
4297
4298 real(kind_phys), intent (in) :: h_var, gsize
4299
4300 real(kind_phys), intent (in), dimension (ks:ke) :: pz, den
4301
4302 real (kind = r8), intent (in), dimension (ks:ke) :: tz
4303
4304 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa
4305
4306 ! -----------------------------------------------------------------------
4307 ! local variables
4308 ! -----------------------------------------------------------------------
4309
4310 integer :: k
4311
4312 real(kind_phys) :: q_plus, q_minus
4313 real(kind_phys) :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam
4314 real(kind_phys) :: dqdt, dq, liq, ice
4315 real(kind_phys) :: qa10, qa100
4316
4317 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3
4318
4319 real (kind = r8), dimension (ks:ke) :: cvm, te8
4320
4321 ! -----------------------------------------------------------------------
4322 ! calculate heat capacities and latent heat coefficients
4323 ! -----------------------------------------------------------------------
4324
4325 call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, &
4326 lcpk, icpk, tcpk, tcp3)
4327
4328 do k = ks, ke
4329
4330 ! combine water species
4331
4332 ice = q_sol(k)
4333 q_sol(k) = qi(k)
4334 if (rad_snow) then
4335 q_sol(k) = qi(k) + qs(k)
4336 if (rad_graupel) then
4337 q_sol(k) = qi(k) + qs(k) + qg(k)
4338 endif
4339 endif
4340
4341 liq = q_liq(k)
4342 q_liq(k) = ql(k)
4343 if (rad_rain) then
4344 q_liq(k) = ql(k) + qr(k)
4345 endif
4346
4347 q_cond(k) = q_liq(k) + q_sol(k)
4348 qpz = qv(k) + q_cond(k)
4349
4350 ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity
4351
4352 ice = ice - q_sol(k)
4353 liq = liq - q_liq(k)
4354 tin = (te8(k) - lv00 * qpz + li00 * ice) / mhc(qpz, liq, ice)
4355
4356 ! calculate saturated specific humidity
4357
4358 if (tin .le. t_wfr) then
4359 qstar = iqs(tin, den(k), dqdt)
4360 elseif (tin .ge. tice) then
4361 qstar = wqs(tin, den(k), dqdt)
4362 else
4363 qsi = iqs(tin, den(k), dqdt)
4364 qsw = wqs(tin, den(k), dqdt)
4365 if (q_cond(k) .gt. qcmin) then
4366 rqi = q_sol(k) / q_cond(k)
4367 else
4368 rqi = (tice - tin) / (tice - t_wfr)
4369 endif
4370 qstar = rqi * qsi + (1. - rqi) * qsw
4371 endif
4372
4373 ! cloud schemes
4374
4375 rh = qpz / qstar
4376
4377 if (cfflag .eq. 1) then
4378 if (rh .gt. rh_thres .and. qpz .gt. qcmin) then
4379
4380 dq = h_var * qpz
4381 if (do_cld_adj) then
4382 q_plus = qpz + dq * f_dq_p * min(1.0, max(0.0, (pz(k) - 200.e2) / &
4383 (1000.e2 - 200.e2)))
4384 else
4385 q_plus = qpz + dq * f_dq_p
4386 endif
4387 q_minus = qpz - dq * f_dq_m
4388
4389 if (icloud_f .eq. 2) then
4390 if (qstar .lt. qpz) then
4391 qa(k) = 1.
4392 else
4393 qa(k) = 0.
4394 endif
4395 elseif (icloud_f .eq. 3) then
4396 if (qstar .lt. qpz) then
4397 qa(k) = 1.
4398 else
4399 if (qstar .lt. q_plus) then
4400 qa(k) = (q_plus - qstar) / (dq * f_dq_p)
4401 else
4402 qa(k) = 0.
4403 endif
4404 if (q_cond(k) .gt. qcmin) then
4405 qa(k) = max(cld_min, qa(k))
4406 endif
4407 qa(k) = min(1., qa(k))
4408 endif
4409 else
4410 if (qstar .lt. q_minus) then
4411 qa(k) = 1.
4412 else
4413 if (qstar .lt. q_plus) then
4414 if (icloud_f .eq. 0) then
4415 qa(k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m)
4416 else
4417 qa(k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * &
4418 (1. - q_cond(k)))
4419 endif
4420 else
4421 qa(k) = 0.
4422 endif
4423 if (q_cond(k) .gt. qcmin) then
4424 qa(k) = max(cld_min, qa(k))
4425 endif
4426 qa(k) = min(1., qa(k))
4427 endif
4428 endif
4429 else
4430 qa(k) = 0.
4431 endif
4432 endif
4433
4434 if (cfflag .eq. 2) then
4435 if (rh .ge. 1.0) then
4436 qa(k) = 1.0
4437 elseif (rh .gt. rh_thres .and. q_cond(k) .gt. qcmin) then
4438 qa(k) = exp(xr_a * log(rh)) * (1.0 - exp(- xr_b * max(0.0, q_cond(k)) / &
4439 max(1.e-5, exp(xr_c * log(max(1.e-10, 1.0 - rh) * qstar)))))
4440 qa(k) = max(0.0, min(1., qa(k)))
4441 else
4442 qa(k) = 0.0
4443 endif
4444 endif
4445
4446 if (cfflag .eq. 3) then
4447 if (q_cond(k) .gt. qcmin) then
4448 qa(k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * &
4449 exp(1.07 * log(max(qcmin * 1000., q_cond(k) * 1000.))) + &
4450 4.82 * (gsize / 1000. - 50.) * &
4451 exp(0.94 * log(max(qcmin * 1000., q_cond(k) * 1000.))))
4452 qa(k) = qa(k) * (0.92 / 0.96 * q_liq(k) / q_cond(k) + &
4453 1.0 / 0.96 * q_sol(k) / q_cond(k))
4454 qa(k) = max(0.0, min(1., qa(k)))
4455 else
4456 qa(k) = 0.0
4457 endif
4458 endif
4459
4460 if (cfflag .eq. 4) then
4461 sigma = 0.28 + exp(0.49 * log(max(qcmin * 1000., q_cond(k) * 1000.)))
4462 gam = max(0.0, q_cond(k) * 1000.) / sigma
4463 if (gam .lt. 0.18) then
4464 qa10 = 0.
4465 elseif (gam .gt. 2.0) then
4466 qa10 = 1.0
4467 else
4468 qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3
4469 qa10 = max(0.0, min(1., qa10))
4470 endif
4471 if (gam .lt. 0.12) then
4472 qa100 = 0.
4473 elseif (gam .gt. 1.85) then
4474 qa100 = 1.0
4475 else
4476 qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3
4477 qa100 = max(0.0, min(1., qa100))
4478 endif
4479 qa(k) = qa10 + (log10(gsize / 1000.) - 1) * (qa100 - qa10)
4480 qa(k) = max(0.0, min(1., qa(k)))
4481 endif
4482
4483 enddo
4484
4485end subroutine cloud_fraction
4486
4487! =======================================================================
4488! piecewise parabolic lagrangian scheme
4489! this subroutine is the same as map1_q2 in fv_mapz_mod.
4490! =======================================================================
4491
4492subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1)
4493
4494 implicit none
4495
4496 ! -----------------------------------------------------------------------
4497 ! input / output arguments
4498 ! -----------------------------------------------------------------------
4499
4500 integer, intent (in) :: ks, ke
4501
4502 real(kind_phys), intent (in) :: zs
4503
4504 real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze, zt
4505
4506 real(kind_phys), intent (in), dimension (ks:ke) :: dp
4507
4508 real(kind_phys), intent (inout), dimension (ks:ke) :: q
4509
4510 real(kind_phys), intent (inout) :: precip
4511
4512 real(kind_phys), intent (out), dimension (ks:ke) :: m1
4513
4514 ! -----------------------------------------------------------------------
4515 ! local variables
4516 ! -----------------------------------------------------------------------
4517
4518 integer :: k, k0, n, m
4519
4520 real(kind_phys) :: a4 (4, ks:ke), pl, pr, delz, esl
4521
4522 real(kind_phys), parameter :: r3 = 1. / 3., r23 = 2. / 3.
4523
4524 real(kind_phys), dimension (ks:ke) :: qm, dz
4525
4526 ! -----------------------------------------------------------------------
4527 ! density:
4528 ! -----------------------------------------------------------------------
4529
4530 do k = ks, ke
4531 dz(k) = zt(k) - zt(k + 1)
4532 q(k) = q(k) * dp(k)
4533 a4(1, k) = q(k) / dz(k)
4534 qm(k) = 0.
4535 enddo
4536
4537 ! -----------------------------------------------------------------------
4538 ! construct vertical profile with zt as coordinate
4539 ! -----------------------------------------------------------------------
4540
4541 call cs_profile (a4(1, ks), dz(ks), ke - ks + 1)
4542
4543 k0 = ks
4544 do k = ks, ke
4545 do n = k0, ke
4546 if (ze(k) .le. zt(n) .and. ze(k) .ge. zt(n + 1)) then
4547 pl = (zt(n) - ze(k)) / dz(n)
4548 if (zt(n + 1) .le. ze(k + 1)) then
4549 ! entire new grid is within the original grid
4550 pr = (zt(n) - ze(k + 1)) / dz(n)
4551 qm(k) = a4(2, n) + 0.5 * (a4(4, n) + a4(3, n) - a4(2, n)) * (pr + pl) - &
4552 a4(4, n) * r3 * (pr * (pr + pl) + pl ** 2)
4553 qm(k) = qm(k) * (ze(k) - ze(k + 1))
4554 k0 = n
4555 goto 555
4556 else
4557 qm(k) = (ze(k) - zt(n + 1)) * (a4(2, n) + 0.5 * (a4(4, n) + &
4558 a4(3, n) - a4(2, n)) * (1. + pl) - a4(4, n) * (r3 * (1. + pl * (1. + pl))))
4559 if (n .lt. ke) then
4560 do m = n + 1, ke
4561 ! locate the bottom edge: ze (k + 1)
4562 if (ze(k + 1) .lt. zt(m + 1)) then
4563 qm(k) = qm(k) + q(m)
4564 else
4565 delz = zt(m) - ze(k + 1)
4566 esl = delz / dz(m)
4567 qm(k) = qm(k) + delz * (a4(2, m) + 0.5 * esl * &
4568 (a4(3, m) - a4(2, m) + a4(4, m) * (1. - r23 * esl)))
4569 k0 = m
4570 goto 555
4571 endif
4572 enddo
4573 endif
4574 goto 555
4575 endif
4576 endif
4577 enddo
4578 555 continue
4579 enddo
4580
4581 m1(ks) = q(ks) - qm(ks)
4582 do k = ks + 1, ke
4583 m1(k) = m1(k - 1) + q(k) - qm(k)
4584 enddo
4585 precip = precip + m1(ke)
4586
4587 ! -----------------------------------------------------------------------
4588 ! convert back to * dry * mixing ratio:
4589 ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) .
4590 ! -----------------------------------------------------------------------
4591
4592 do k = ks, ke
4593 q(k) = qm(k) / dp(k)
4594 enddo
4595
4596end subroutine lagrangian_fall
4597
4598! =======================================================================
4599! vertical profile reconstruction
4600! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9
4601! =======================================================================
4602
4603subroutine cs_profile (a4, del, km)
4604
4605 implicit none
4606
4607 ! -----------------------------------------------------------------------
4608 ! input / output arguments
4609 ! -----------------------------------------------------------------------
4610
4611 integer, intent (in) :: km
4612
4613 real(kind_phys), intent (in) :: del (km)
4614
4615 real(kind_phys), intent (inout) :: a4 (4, km)
4616
4617 ! -----------------------------------------------------------------------
4618 ! local variables
4619 ! -----------------------------------------------------------------------
4620
4621 integer :: k
4622
4623 logical :: extm (km)
4624
4625 real(kind_phys) :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac
4626 real(kind_phys) :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da
4627
4628 grat = del(2) / del(1) ! grid ratio
4629 bet = grat * (grat + 0.5)
4630 q(1) = (2. * grat * (grat + 1.) * a4(1, 1) + a4(1, 2)) / bet
4631 gam(1) = (1. + grat * (grat + 1.5)) / bet
4632
4633 do k = 2, km
4634 d4 = del(k - 1) / del(k)
4635 bet = 2. + 2. * d4 - gam(k - 1)
4636 q(k) = (3. * (a4(1, k - 1) + d4 * a4(1, k)) - q(k - 1)) / bet
4637 gam(k) = d4 / bet
4638 enddo
4639
4640 a_bot = 1. + d4 * (d4 + 1.5)
4641 q(km + 1) = (2. * d4 * (d4 + 1.) * a4(1, km) + a4(1, km - 1) - a_bot * q(km)) &
4642 / (d4 * (d4 + 0.5) - a_bot * gam(km))
4643
4644 do k = km, 1, - 1
4645 q(k) = q(k) - gam(k) * q(k + 1)
4646 enddo
4647
4648 ! -----------------------------------------------------------------------
4649 ! apply constraints
4650 ! -----------------------------------------------------------------------
4651
4652 do k = 2, km
4653 gam(k) = a4(1, k) - a4(1, k - 1)
4654 enddo
4655
4656 ! -----------------------------------------------------------------------
4657 ! top:
4658 ! -----------------------------------------------------------------------
4659
4660 q(1) = max(q(1), 0.)
4661 q(2) = min(q(2), max(a4(1, 1), a4(1, 2)))
4662 q(2) = max(q(2), min(a4(1, 1), a4(1, 2)), 0.)
4663
4664 ! -----------------------------------------------------------------------
4665 ! interior:
4666 ! -----------------------------------------------------------------------
4667
4668 do k = 3, km - 1
4669 if (gam(k - 1) * gam(k + 1) .gt. 0.) then
4670 ! apply large - scale constraints to all fields if not local max / min
4671 q(k) = min(q(k), max(a4(1, k - 1), a4(1, k)))
4672 q(k) = max(q(k), min(a4(1, k - 1), a4(1, k)))
4673 else
4674 if (gam(k - 1) .gt. 0.) then
4675 ! there exists a local max
4676 q(k) = max(q(k), min(a4(1, k - 1), a4(1, k)))
4677 else
4678 ! there exists a local min
4679 q(k) = min(q(k), max(a4(1, k - 1), a4(1, k)))
4680 ! positive-definite
4681 q(k) = max(q(k), 0.0)
4682 endif
4683 endif
4684 enddo
4685
4686 ! -----------------------------------------------------------------------
4687 ! bottom:
4688 ! -----------------------------------------------------------------------
4689
4690 q(km) = min(q(km), max(a4(1, km - 1), a4(1, km)))
4691 q(km) = max(q(km), min(a4(1, km - 1), a4(1, km)), 0.)
4692 q(km + 1) = max(q(km + 1), 0.)
4693
4694 do k = 1, km
4695 a4(2, k) = q(k)
4696 a4(3, k) = q(k + 1)
4697 enddo
4698
4699 do k = 1, km
4700 if (k .eq. 1 .or. k .eq. km) then
4701 extm(k) = (a4(2, k) - a4(1, k)) * (a4(3, k) - a4(1, k)) .gt. 0.
4702 else
4703 extm(k) = gam(k) * gam(k + 1) .lt. 0.
4704 endif
4705 enddo
4706
4707 ! -----------------------------------------------------------------------
4708 ! apply constraints
4709 ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1)
4710 ! always use monotonic mapping
4711 ! -----------------------------------------------------------------------
4712
4713 ! -----------------------------------------------------------------------
4714 ! top:
4715 ! -----------------------------------------------------------------------
4716
4717 a4(2, 1) = max(0., a4(2, 1))
4718
4719 ! -----------------------------------------------------------------------
4720 ! Huynh's 2nd constraint for interior:
4721 ! -----------------------------------------------------------------------
4722
4723 do k = 3, km - 2
4724 if (extm(k)) then
4725 ! positive definite constraint only if true local extrema
4726 if (a4(1, k) .lt. qcmin .or. extm(k - 1) .or. extm(k + 1)) then
4727 a4(2, k) = a4(1, k)
4728 a4(3, k) = a4(1, k)
4729 endif
4730 else
4731 a4(4, k) = 6. * a4(1, k) - 3. * (a4(2, k) + a4(3, k))
4732 if (abs(a4(4, k)) .gt. abs(a4(2, k) - a4(3, k))) then
4733 ! check within the smooth region if subgrid profile is non - monotonic
4734 pmp_1 = a4(1, k) - 2.0 * gam(k + 1)
4735 lac_1 = pmp_1 + 1.5 * gam(k + 2)
4736 a4(2, k) = min(max(a4(2, k), min(a4(1, k), pmp_1, lac_1)), &
4737 max(a4(1, k), pmp_1, lac_1))
4738 pmp_2 = a4(1, k) + 2.0 * gam(k)
4739 lac_2 = pmp_2 - 1.5 * gam(k - 1)
4740 a4(3, k) = min(max(a4(3, k), min(a4(1, k), pmp_2, lac_2)), &
4741 max(a4(1, k), pmp_2, lac_2))
4742 endif
4743 endif
4744 enddo
4745
4746 do k = 1, km - 1
4747 a4(4, k) = 6. * a4(1, k) - 3. * (a4(2, k) + a4(3, k))
4748 enddo
4749
4750 k = km - 1
4751 if (extm(k)) then
4752 a4(2, k) = a4(1, k)
4753 a4(3, k) = a4(1, k)
4754 a4(4, k) = 0.
4755 else
4756 da1 = a4(3, k) - a4(2, k)
4757 da2 = da1 ** 2
4758 a6da = a4(4, k) * da1
4759 if (a6da .lt. - da2) then
4760 a4(4, k) = 3. * (a4(2, k) - a4(1, k))
4761 a4(3, k) = a4(2, k) - a4(4, k)
4762 elseif (a6da .gt. da2) then
4763 a4(4, k) = 3. * (a4(3, k) - a4(1, k))
4764 a4(2, k) = a4(3, k) - a4(4, k)
4765 endif
4766 endif
4767
4768 call cs_limiters (km - 1, a4)
4769
4770 ! -----------------------------------------------------------------------
4771 ! bottom:
4772 ! -----------------------------------------------------------------------
4773
4774 a4(2, km) = a4(1, km)
4775 a4(3, km) = a4(1, km)
4776 a4(4, km) = 0.
4777
4778end subroutine cs_profile
4779
4780! =======================================================================
4781! cubic spline (cs) limiters or boundary conditions
4782! a positive-definite constraint (iv = 0) is applied to tracers in every layer,
4783! adjusting the top-most and bottom-most interface values to enforce positive.
4784! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0.
4785! =======================================================================
4786
4787subroutine cs_limiters (km, a4)
4788
4789 implicit none
4790
4791 ! -----------------------------------------------------------------------
4792 ! input / output arguments
4793 ! -----------------------------------------------------------------------
4794
4795 integer, intent (in) :: km
4796
4797 real(kind_phys), intent (inout) :: a4 (4, km) ! ppm array
4798
4799 ! -----------------------------------------------------------------------
4800 ! local variables
4801 ! -----------------------------------------------------------------------
4802
4803 integer :: k
4804
4805 real(kind_phys), parameter :: r12 = 1. / 12.
4806
4807 do k = 1, km
4808 if (a4(1, k) .le. 0.) then
4809 a4(2, k) = a4(1, k)
4810 a4(3, k) = a4(1, k)
4811 a4(4, k) = 0.
4812 else
4813 if (abs(a4(3, k) - a4(2, k)) .lt. - a4(4, k)) then
4814 if ((a4(1, k) + 0.25 * (a4(3, k) - a4(2, k)) ** 2 / a4(4, k) + &
4815 a4(4, k) * r12) .lt. 0.) then
4816 ! local minimum is negative
4817 if (a4(1, k) .lt. a4(3, k) .and. a4(1, k) .lt. a4(2, k)) then
4818 a4(3, k) = a4(1, k)
4819 a4(2, k) = a4(1, k)
4820 a4(4, k) = 0.
4821 elseif (a4(3, k) .gt. a4(2, k)) then
4822 a4(4, k) = 3. * (a4(2, k) - a4(1, k))
4823 a4(3, k) = a4(2, k) - a4(4, k)
4824 else
4825 a4(4, k) = 3. * (a4(3, k) - a4(1, k))
4826 a4(2, k) = a4(3, k) - a4(4, k)
4827 endif
4828 endif
4829 endif
4830 endif
4831 enddo
4832
4833end subroutine cs_limiters
4834
4835! =======================================================================
4836! time-implicit monotonic scheme
4837! =======================================================================
4838
4839subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1)
4840
4841 implicit none
4842
4843 ! -----------------------------------------------------------------------
4844 ! input / output arguments
4845 ! -----------------------------------------------------------------------
4846
4847 integer, intent (in) :: ks, ke
4848
4849 real(kind_phys), intent (in) :: dts
4850
4851 real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze
4852
4853 real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp
4854
4855 real(kind_phys), intent (inout), dimension (ks:ke) :: q
4856
4857 real(kind_phys), intent (inout) :: precip
4858
4859 real(kind_phys), intent (out), dimension (ks:ke) :: m1
4860
4861 ! -----------------------------------------------------------------------
4862 ! local variables
4863 ! -----------------------------------------------------------------------
4864
4865 integer :: k
4866
4867 real(kind_phys), dimension (ks:ke) :: dz, qm, dd
4868
4869 do k = ks, ke
4870 dz(k) = ze(k) - ze(k + 1)
4871 dd(k) = dts * vt(k)
4872 q(k) = q(k) * dp(k)
4873 enddo
4874
4875 qm(ks) = q(ks) / (dz(ks) + dd(ks))
4876 do k = ks + 1, ke
4877 qm(k) = (q(k) + qm(k - 1) * dd(k - 1)) / (dz(k) + dd(k))
4878 enddo
4879
4880 do k = ks, ke
4881 qm(k) = qm(k) * dz(k)
4882 enddo
4883
4884 m1(ks) = q(ks) - qm(ks)
4885 do k = ks + 1, ke
4886 m1(k) = m1(k - 1) + q(k) - qm(k)
4887 enddo
4888 precip = precip + m1(ke)
4889
4890 do k = ks, ke
4891 q(k) = qm(k) / dp(k)
4892 enddo
4893
4894end subroutine implicit_fall
4895
4896! =======================================================================
4897! time-explicit monotonic scheme
4898! =======================================================================
4899
4900subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1)
4901
4902 implicit none
4903
4904 ! -----------------------------------------------------------------------
4905 ! input / output arguments
4906 ! -----------------------------------------------------------------------
4907
4908 integer, intent (in) :: ks, ke
4909
4910 real(kind_phys), intent (in) :: dts
4911
4912 real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze
4913
4914 real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp
4915
4916 real(kind_phys), intent (inout), dimension (ks:ke) :: q
4917
4918 real(kind_phys), intent (inout) :: precip
4919
4920 real(kind_phys), intent (out), dimension (ks:ke) :: m1
4921
4922 ! -----------------------------------------------------------------------
4923 ! local variables
4924 ! -----------------------------------------------------------------------
4925
4926 integer :: n, k, nstep
4927
4928 real(kind_phys), dimension (ks:ke) :: dz, qm, q0, dd
4929
4930 do k = ks, ke
4931 dz(k) = ze(k) - ze(k + 1)
4932 dd(k) = dts * vt(k)
4933 q0(k) = q(k) * dp(k)
4934 enddo
4935
4936 nstep = 1 + int(maxval(dd / dz))
4937 do k = ks, ke
4938 dd(k) = dd(k) / nstep
4939 q(k) = q0(k)
4940 enddo
4941
4942 do n = 1, nstep
4943 qm(ks) = q(ks) - q(ks) * dd(ks) / dz(ks)
4944 do k = ks + 1, ke
4945 qm(k) = q(k) - q(k) * dd(k) / dz(k) + q(k - 1) * dd(k - 1) / dz(k - 1)
4946 enddo
4947 q = qm
4948 enddo
4949
4950 m1(ks) = q0(ks) - qm(ks)
4951 do k = ks + 1, ke
4952 m1(k) = m1(k - 1) + q0(k) - qm(k)
4953 enddo
4954 precip = precip + m1(ke)
4955
4956 do k = ks, ke
4957 q(k) = qm(k) / dp(k)
4958 enddo
4959
4960end subroutine explicit_fall
4961
4962! =======================================================================
4963! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme
4964! =======================================================================
4965
4966subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, &
4967 precip, flux, sed_fac)
4968
4969 implicit none
4970
4971 ! -----------------------------------------------------------------------
4972 ! input / output arguments
4973 ! -----------------------------------------------------------------------
4974
4975 integer, intent (in) :: ks, ke
4976
4977 real(kind_phys), intent (in) :: zs, dts, sed_fac
4978
4979 real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze, zt
4980
4981 real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp
4982
4983 real(kind_phys), intent (inout), dimension (ks:ke) :: q
4984
4985 real(kind_phys), intent (inout) :: precip
4986
4987 real(kind_phys), intent (out), dimension (ks:ke) :: flux
4988
4989 ! -----------------------------------------------------------------------
4990 ! local variables
4991 ! -----------------------------------------------------------------------
4992
4993 real(kind_phys) :: pre0, pre1
4994
4995 real(kind_phys), dimension (ks:ke) :: q0, q1, m0, m1
4996
4997 q0 = q
4998 pre0 = precip
4999
5000 call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0)
5001
5002 q1 = q
5003 pre1 = precip
5004
5005 call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1)
5006
5007 q = q0 * sed_fac + q1 * (1.0 - sed_fac)
5008 flux = m0 * sed_fac + m1 * (1.0 - sed_fac)
5009 precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac)
5010
5011end subroutine implicit_lagrangian_fall
5012
5013! =======================================================================
5014! vertical subgrid variability used for cloud ice and cloud water autoconversion
5015! edges: qe == qbar + / - dm
5016! =======================================================================
5017
5018subroutine linear_prof (km, q, dm, z_var, h_var)
5019
5020 implicit none
5021
5022 ! -----------------------------------------------------------------------
5023 ! input / output arguments
5024 ! -----------------------------------------------------------------------
5025
5026 integer, intent (in) :: km
5027
5028 logical, intent (in) :: z_var
5029
5030 real(kind_phys), intent (in) :: q (km), h_var
5031
5032 real(kind_phys), intent (out) :: dm (km)
5033
5034 ! -----------------------------------------------------------------------
5035 ! local variables
5036 ! -----------------------------------------------------------------------
5037
5038 integer :: k
5039
5040 real(kind_phys) :: dq (km)
5041
5042 if (z_var) then
5043 do k = 2, km
5044 dq(k) = 0.5 * (q(k) - q(k - 1))
5045 enddo
5046 dm(1) = 0.
5047 ! -----------------------------------------------------------------------
5048 ! use twice the strength of the positive definiteness limiter (Lin et al. 1994)
5049 ! -----------------------------------------------------------------------
5050 do k = 2, km - 1
5051 dm(k) = 0.5 * min(abs(dq(k) + dq(k + 1)), 0.5 * q(k))
5052 if (dq(k) * dq(k + 1) .le. 0.) then
5053 if (dq(k) .gt. 0.) then
5054 dm(k) = min(dm(k), dq(k), - dq(k + 1))
5055 else
5056 dm(k) = 0.
5057 endif
5058 endif
5059 enddo
5060 dm(km) = 0.
5061 ! -----------------------------------------------------------------------
5062 ! impose a presumed background horizontal variability that is proportional to the value itself
5063 ! -----------------------------------------------------------------------
5064 do k = 1, km
5065 dm(k) = max(dm(k), 0.0, h_var * q(k))
5066 enddo
5067 else
5068 do k = 1, km
5069 dm(k) = max(0.0, h_var * q(k))
5070 enddo
5071 endif
5072
5073end subroutine linear_prof
5074
5075! =======================================================================
5076! accretion function, Lin et al. (1983)
5077! =======================================================================
5078
5079function acr2d (qden, c, denfac, blin, mu)
5080
5081 implicit none
5082
5083 real(kind_phys) :: acr2d
5084
5085 ! -----------------------------------------------------------------------
5086 ! input / output arguments
5087 ! -----------------------------------------------------------------------
5088
5089 real(kind_phys), intent (in) :: qden, c, denfac, blin, mu
5090
5091 acr2d = denfac * c * exp((2 + mu + blin) / (mu + 3) * log(6 * qden))
5092
5093end function acr2d
5094
5095! =======================================================================
5096! accretion function, Lin et al. (1983)
5097! =======================================================================
5098
5099function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den)
5100
5101 implicit none
5102
5103 real(kind_phys) :: acr3d
5104
5105 ! -----------------------------------------------------------------------
5106 ! input / output arguments
5107 ! -----------------------------------------------------------------------
5108
5109 real(kind_phys), intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2
5110
5111 ! -----------------------------------------------------------------------
5112 ! local variables
5113 ! -----------------------------------------------------------------------
5114
5115 integer :: i
5116
5117 real(kind_phys) :: t1, t2, tmp, vdiff
5118
5119 t1 = exp(1. / (acc1 + 3) * log(6 * q1 * den))
5120 t2 = exp(1. / (acc2 + 3) * log(6 * q2 * den))
5121
5122 if (vdiffflag .eq. 1) vdiff = abs(v1 - v2)
5123 if (vdiffflag .eq. 2) vdiff = sqrt((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2)
5124 if (vdiffflag .eq. 3) vdiff = sqrt((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2)
5125
5126 acr3d = c * vdiff / den
5127
5128 tmp = 0
5129 do i = 1, 3
5130 tmp = tmp + acco(i) * exp((6 + acc1 - i) * log(t1)) * exp((acc2 + i - 1) * log(t2))
5131 enddo
5132
5133 acr3d = acr3d * tmp
5134
5135end function acr3d
5136
5137! =======================================================================
5138! ventilation coefficient, Lin et al. (1983)
5139! =======================================================================
5140
5141function vent_coeff (qden, c1, c2, denfac, blin, mu)
5142
5143 implicit none
5144
5145 real(kind_phys) :: vent_coeff
5146
5147 ! -----------------------------------------------------------------------
5148 ! input / output arguments
5149 ! -----------------------------------------------------------------------
5150
5151 real(kind_phys), intent (in) :: qden, c1, c2, denfac, blin, mu
5152
5153 vent_coeff = c1 + c2 * exp((3 + 2 * mu + blin) / (mu + 3) / 2 * log(6 * qden)) * &
5154 sqrt(denfac) / exp((1 + mu) / (mu + 3) * log(6 * qden))
5155
5156end function vent_coeff
5157
5158! =======================================================================
5159! sublimation or evaporation function, Lin et al. (1983)
5160! =======================================================================
5161
5162function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm)
5163
5164 implicit none
5165
5166 real(kind_phys) :: psub
5167
5168 ! -----------------------------------------------------------------------
5169 ! input / output arguments
5170 ! -----------------------------------------------------------------------
5171
5172 real(kind_phys), intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu
5173
5174 real (kind = r8), intent (in) :: cvm
5175
5176 psub = c(1) * t2 * dq * exp((1 + mu) / (mu + 3) * log(6 * qden)) * &
5177 vent_coeff(qden, c(2), c(3), denfac, blin, mu) / &
5178 (c(4) * t2 + c(5) * (cpk * cvm) ** 2 * qsat * den)
5179
5180end function psub
5181
5182! =======================================================================
5183! melting function, Lin et al. (1983)
5184! =======================================================================
5185
5186function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm)
5187
5188 implicit none
5189
5190 real(kind_phys) :: pmlt
5191
5192 ! -----------------------------------------------------------------------
5193 ! input / output arguments
5194 ! -----------------------------------------------------------------------
5195
5196 real(kind_phys), intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu
5197
5198 real (kind = r8), intent (in) :: cvm
5199
5200 pmlt = (c(1) / (icpk * cvm) * tc / den - c(2) * lcpk / icpk * dq) * &
5201 exp((1 + mu) / (mu + 3) * log(6 * qden)) * &
5202 vent_coeff(qden, c(3), c(4), denfac, blin, mu) + &
5203 c_liq / (icpk * cvm) * tc * (pxacw + pxacr)
5204
5205end function pmlt
5206
5207! =======================================================================
5208! sedimentation of horizontal momentum
5209! =======================================================================
5210
5211subroutine sedi_uv (ks, ke, m1, dp, u, v)
5212
5213 implicit none
5214
5215 ! -----------------------------------------------------------------------
5216 ! input / output arguments
5217 ! -----------------------------------------------------------------------
5218
5219 integer, intent (in) :: ks, ke
5220
5221 real(kind_phys), intent (in), dimension (ks:ke) :: m1, dp
5222
5223 real(kind_phys), intent (inout), dimension (ks:ke) :: u, v
5224
5225 ! -----------------------------------------------------------------------
5226 ! local variables
5227 ! -----------------------------------------------------------------------
5228
5229 integer :: k
5230
5231 do k = ks + 1, ke
5232 u(k) = (dp(k) * u(k) + m1(k - 1) * u(k - 1)) / (dp(k) + m1(k - 1))
5233 v(k) = (dp(k) * v(k) + m1(k - 1) * v(k - 1)) / (dp(k) + m1(k - 1))
5234 enddo
5235
5236end subroutine sedi_uv
5237
5238! =======================================================================
5239! sedimentation of vertical momentum
5240! =======================================================================
5241
5242subroutine sedi_w (ks, ke, m1, w, vt, dm)
5243
5244 implicit none
5245
5246 ! -----------------------------------------------------------------------
5247 ! input / output arguments
5248 ! -----------------------------------------------------------------------
5249
5250 integer, intent (in) :: ks, ke
5251
5252 real(kind_phys), intent (in), dimension (ks:ke) :: m1, vt, dm
5253
5254 real(kind_phys), intent (inout), dimension (ks:ke) :: w
5255
5256 ! -----------------------------------------------------------------------
5257 ! local variables
5258 ! -----------------------------------------------------------------------
5259
5260 integer :: k
5261
5262 w(ks) = w(ks) + m1(ks) * vt(ks) / dm(ks)
5263 do k = ks + 1, ke
5264 w(k) = (dm(k) * w(k) + m1(k - 1) * (w(k - 1) - vt(k - 1)) + m1(k) * vt(k)) / &
5265 (dm(k) + m1(k - 1))
5266 enddo
5267
5268end subroutine sedi_w
5269
5270! =======================================================================
5271! sedimentation of heat
5272! =======================================================================
5273
5274subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw)
5275
5276 implicit none
5277
5278 ! -----------------------------------------------------------------------
5279 ! input / output arguments
5280 ! -----------------------------------------------------------------------
5281
5282 integer, intent (in) :: ks, ke
5283
5284 real(kind_phys), intent (in) :: cw
5285
5286 real(kind_phys), intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg
5287
5288 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
5289
5290 ! -----------------------------------------------------------------------
5291 ! local variables
5292 ! -----------------------------------------------------------------------
5293
5294 integer :: k
5295
5296 real(kind_phys), dimension (ks:ke) :: dgz, cv0
5297
5298 do k = ks + 1, ke
5299 dgz(k) = - 0.5 * grav * (dz(k - 1) + dz(k))
5300 cv0(k) = dm(k) * (cv_air + qv(k) * cv_vap + (qr(k) + ql(k)) * c_liq + &
5301 (qi(k) + qs(k) + qg(k)) * c_ice) + cw * (m1(k) - m1(k - 1))
5302 enddo
5303
5304 do k = ks + 1, ke
5305 tz(k) = (cv0(k) * tz(k) + m1(k - 1) * (cw * tz(k - 1) + dgz(k))) / &
5306 (cv0(k) + cw * m1(k - 1))
5307 enddo
5308
5309end subroutine sedi_heat
5310
5311! =======================================================================
5312! fast saturation adjustments
5313! =======================================================================
5314
5315subroutine cld_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, &
5316 adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, &
5317 pt, delp, q_con, cappa, gsize, last_step, do_sat_adj)
5318
5319 implicit none
5320
5321 ! -----------------------------------------------------------------------
5322 ! input / output arguments
5323 ! -----------------------------------------------------------------------
5324
5325 integer, intent (in) :: is, ie, ks, ke
5326
5327 logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj
5328
5329 real(kind_phys), intent (in) :: dtm
5330
5331 real(kind_phys), intent (in), dimension (is:ie) :: hs, gsize
5332
5333 real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni
5334
5335 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te
5336 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa
5337
5338 real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa
5339
5340 real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: adj_vmr
5341
5342 real (kind = r8), intent (out), dimension (is:ie) :: dte
5343
5344 ! -----------------------------------------------------------------------
5345 ! local variables
5346 ! -----------------------------------------------------------------------
5347
5348 real(kind_phys), dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg
5349
5350 real(kind_phys), dimension (is:ie) :: water, rain, ice, snow, graupel
5351
5352 ! -----------------------------------------------------------------------
5353 ! initialization
5354 ! -----------------------------------------------------------------------
5355
5356 ua = 0.0
5357 va = 0.0
5358 wa = 0.0
5359
5360 water = 0.0
5361 rain = 0.0
5362 ice = 0.0
5363 snow = 0.0
5364 graupel = 0.0
5365
5366 prefluxw = 0.0
5367 prefluxr = 0.0
5368 prefluxi = 0.0
5369 prefluxs = 0.0
5370 prefluxg = 0.0
5371
5372 ! -----------------------------------------------------------------------
5373 ! major cloud microphysics driver
5374 ! -----------------------------------------------------------------------
5375
5376 call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, &
5377 qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, &
5378 gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, &
5379 prefluxi, prefluxs, prefluxg, last_step, .false., do_sat_adj, .false.)
5380
5381end subroutine cld_sat_adj
5382
5383! =======================================================================
5384! rain freezing to form graupel, simple version
5385! =======================================================================
5386
5387subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
5388 lcpk, icpk, tcpk, tcp3)
5389
5390 implicit none
5391
5392 ! -----------------------------------------------------------------------
5393 ! input / output arguments
5394 ! -----------------------------------------------------------------------
5395
5396 integer, intent (in) :: ks, ke
5397
5398 real(kind_phys), intent (in) :: dts
5399
5400 real (kind = r8), intent (in), dimension (ks:ke) :: te8
5401
5402 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
5403 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
5404
5405 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
5406
5407 ! -----------------------------------------------------------------------
5408 ! local variables
5409 ! -----------------------------------------------------------------------
5410
5411 integer :: k
5412
5413 real(kind_phys) :: tc, sink, fac_r2g
5414
5415 fac_r2g = 1. - exp(- dts / tau_r2g)
5416
5417 do k = ks, ke
5418
5419 tc = tz(k) - tice
5420
5421 if (tc .lt. 0. .and. qr(k) .gt. qcmin) then
5422
5423 sink = (- tc * 0.025) ** 2 * qr(k)
5424 sink = min(qr(k), sink, - fac_r2g * tc / icpk(k))
5425
5426 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
5427 0., 0., - sink, 0., 0., sink, te8(k), cvm(k), tz(k), &
5428 lcpk(k), icpk(k), tcpk(k), tcp3(k))
5429
5430 endif
5431
5432 enddo
5433
5434end subroutine pgfr_simp
5435
5436! =======================================================================
5437! snow melting to form cloud water and rain, simple version
5438! =======================================================================
5439
5440subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, &
5441 lcpk, icpk, tcpk, tcp3)
5442
5443 implicit none
5444
5445 ! -----------------------------------------------------------------------
5446 ! input / output arguments
5447 ! -----------------------------------------------------------------------
5448
5449 integer, intent (in) :: ks, ke
5450
5451 real(kind_phys), intent (in) :: dts
5452
5453 real (kind = r8), intent (in), dimension (ks:ke) :: te8
5454
5455 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
5456 real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3
5457
5458 real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz
5459
5460 ! -----------------------------------------------------------------------
5461 ! local variables
5462 ! -----------------------------------------------------------------------
5463
5464 integer :: k
5465
5466 real(kind_phys) :: tc, tmp, sink, fac_smlt
5467
5468 fac_smlt = 1. - exp(- dts / tau_smlt)
5469
5470 do k = ks, ke
5471
5472 tc = tz(k) - tice
5473
5474 if (tc .ge. 0. .and. qs(k) .gt. qcmin) then
5475
5476 sink = (tc * 0.1) ** 2 * qs(k)
5477 sink = min(qs(k), sink, fac_smlt * tc / icpk(k))
5478 tmp = min(sink, dim(qs_mlt, ql(k)))
5479
5480 call update_qt (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
5481 0., tmp, sink - tmp, 0., - sink, 0., te8(k), cvm(k), tz(k), &
5482 lcpk(k), icpk(k), tcpk(k), tcp3(k))
5483
5484 endif
5485
5486 enddo
5487
5488end subroutine psmlt_simp
5489
5490! =======================================================================
5491! cloud water to rain autoconversion, simple version
5492! =======================================================================
5493
5494subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg)
5495
5496 implicit none
5497
5498 ! -----------------------------------------------------------------------
5499 ! input / output arguments
5500 ! -----------------------------------------------------------------------
5501
5502 integer, intent (in) :: ks, ke
5503
5504 real(kind_phys), intent (in) :: dts
5505
5506 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
5507
5508 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
5509
5510 ! -----------------------------------------------------------------------
5511 ! local variables
5512 ! -----------------------------------------------------------------------
5513
5514 integer :: k
5515
5516 real(kind_phys) :: tc, sink, fac_l2r
5517
5518 fac_l2r = 1. - exp(- dts / tau_l2r)
5519
5520 do k = ks, ke
5521
5522 tc = tz(k) - t_wfr
5523
5524 if (tc .gt. 0 .and. ql(k) .gt. ql0_max) then
5525
5526 sink = fac_l2r * (ql(k) - ql0_max)
5527
5528 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
5529 0., - sink, sink, 0., 0., 0.)
5530
5531 endif
5532
5533 enddo
5534
5535end subroutine praut_simp
5536
5537! =======================================================================
5538! cloud ice to snow autoconversion, simple version
5539! =======================================================================
5540
5541subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den)
5542
5543 implicit none
5544
5545 ! -----------------------------------------------------------------------
5546 ! input / output arguments
5547 ! -----------------------------------------------------------------------
5548
5549 integer, intent (in) :: ks, ke
5550
5551 real(kind_phys), intent (in) :: dts
5552
5553 real(kind_phys), intent (in), dimension (ks:ke) :: den
5554
5555 real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
5556
5557 real (kind = r8), intent (inout), dimension (ks:ke) :: tz
5558
5559 ! -----------------------------------------------------------------------
5560 ! local variables
5561 ! -----------------------------------------------------------------------
5562
5563 integer :: k
5564
5565 real(kind_phys) :: tc, sink, fac_i2s, qim
5566
5567 fac_i2s = 1. - exp(- dts / tau_i2s)
5568
5569 do k = ks, ke
5570
5571 tc = tz(k) - tice
5572
5573 qim = qi0_max / den(k)
5574
5575 if (tc .lt. 0. .and. qi(k) .gt. qim) then
5576
5577 sink = fac_i2s * (qi(k) - qim)
5578
5579 call update_qq (qv(k), ql(k), qr(k), qi(k), qs(k), qg(k), &
5580 0., 0., 0., - sink, sink, 0.)
5581
5582 endif
5583
5584 enddo
5585
5586end subroutine psaut_simp
5587
5588! =======================================================================
5589! cloud radii diagnosis built for gfdl cloud microphysics
5590! =======================================================================
5591
5592subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, &
5593 rew, rei, rer, res, reg, snowd, cnvw, cnvi)
5594
5595 implicit none
5596
5597 ! -----------------------------------------------------------------------
5598 ! input / output arguments
5599 ! -----------------------------------------------------------------------
5600
5601 integer, intent (in) :: is, ie, ks, ke
5602
5603 real(kind_phys), intent (in), dimension (is:ie) :: lsm, snowd
5604
5605 real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: delp, t, p
5606 real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa
5607
5608 real(kind_phys), intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi
5609
5610 real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg
5611
5612 ! -----------------------------------------------------------------------
5613 ! local variables
5614 ! -----------------------------------------------------------------------
5615
5616 integer :: i, k, ind
5617
5618 real(kind_phys), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg
5619 real(kind_phys), dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg
5620
5621 real(kind_phys) :: dpg, rho, ccnw, mask, cor, tc, bw
5622 real(kind_phys) :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac
5623
5624 real(kind_phys) :: retab (138) = (/ &
5625 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, &
5626 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, &
5627 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, &
5628 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, &
5629 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, &
5630 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, &
5631 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, &
5632 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
5633 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
5634 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
5635 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
5636 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
5637 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
5638 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
5639 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
5640 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
5641 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
5642 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
5643 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
5644 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
5645 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
5646 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
5647 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /)
5648
5649 qmw = qw
5650 qmi = qi
5651 qmr = qr
5652 qms = qs
5653 qmg = qg
5654
5655 ! -----------------------------------------------------------------------
5656 ! merge convective cloud to total cloud
5657 ! -----------------------------------------------------------------------
5658
5659 if (present (cnvw)) then
5660 qmw = qmw + cnvw
5661 endif
5662 if (present (cnvi)) then
5663 qmi = qmi + cnvi
5664 endif
5665
5666 ! -----------------------------------------------------------------------
5667 ! combine liquid and solid phases
5668 ! -----------------------------------------------------------------------
5669
5670 if (liq_ice_combine) then
5671 do i = is, ie
5672 do k = ks, ke
5673 qmw(i, k) = qmw(i, k) + qmr(i, k)
5674 qmr(i, k) = 0.0
5675 qmi(i, k) = qmi(i, k) + qms(i, k) + qmg(i, k)
5676 qms(i, k) = 0.0
5677 qmg(i, k) = 0.0
5678 enddo
5679 enddo
5680 endif
5681
5682 ! -----------------------------------------------------------------------
5683 ! combine snow and graupel
5684 ! -----------------------------------------------------------------------
5685
5686 if (snow_grauple_combine) then
5687 do i = is, ie
5688 do k = ks, ke
5689 qms(i, k) = qms(i, k) + qmg(i, k)
5690 qmg(i, k) = 0.0
5691 enddo
5692 enddo
5693 endif
5694
5695 do i = is, ie
5696
5697 do k = ks, ke
5698
5699 qmw(i, k) = max(qmw(i, k), qcmin)
5700 qmi(i, k) = max(qmi(i, k), qcmin)
5701 qmr(i, k) = max(qmr(i, k), qcmin)
5702 qms(i, k) = max(qms(i, k), qcmin)
5703 qmg(i, k) = max(qmg(i, k), qcmin)
5704
5705
5706 mask = min(max(lsm(i), 0.0), 2.0)
5707
5708 dpg = abs(delp(i, k)) / grav
5709 rho = p(i, k) / (rdgas * t(i, k) * (1. + zvir * qv(i, k)))
5710
5711 tc = t(i, k) - tice
5712
5713 if (rewflag .eq. 1) then
5714
5715 ! -----------------------------------------------------------------------
5716 ! cloud water (Martin et al. 1994)
5717 ! -----------------------------------------------------------------------
5718
5719 if (prog_ccn) then
5720 ! boucher and lohmann (1995)
5721 ccnw = (1.0 - abs(mask - 1.0)) * &
5722 (10. ** 2.24 * (qa(i, k) * rho * 1.e9) ** 0.257) + &
5723 abs(mask - 1.0) * &
5724 (10. ** 2.06 * (qa(i, k) * rho * 1.e9) ** 0.48)
5725 else
5726 ccnw = ccn_o * abs(mask - 1.0) + ccn_l * (1.0 - abs(mask - 1.0))
5727 endif
5728
5729 if (qmw(i, k) .gt. qcmin) then
5730 qcw(i, k) = dpg * qmw(i, k) * 1.0e3
5731 rew(i, k) = exp(1.0 / 3.0 * log((3.0 * qmw(i, k) * rho) / &
5732 (4.0 * pi * rhow * ccnw))) * 1.0e4
5733 rew(i, k) = max(rewmin, min(rewmax, rew(i, k)))
5734 else
5735 qcw(i, k) = 0.0
5736 rew(i, k) = rewmin
5737 endif
5738
5739 endif
5740
5741 if (rewflag .eq. 2) then
5742
5743 ! -----------------------------------------------------------------------
5744 ! cloud water (Martin et al. 1994, gfdl revision)
5745 ! -----------------------------------------------------------------------
5746
5747 if (prog_ccn) then
5748 ! boucher and lohmann (1995)
5749 ccnw = (1.0 - abs(mask - 1.0)) * &
5750 (10. ** 2.24 * (qa(i, k) * rho * 1.e9) ** 0.257) + &
5751 abs(mask - 1.0) * &
5752 (10. ** 2.06 * (qa(i, k) * rho * 1.e9) ** 0.48)
5753 else
5754 ccnw = 1.077 * ccn_o * abs(mask - 1.0) + 1.143 * ccn_l * (1.0 - abs(mask - 1.0))
5755 endif
5756
5757 if (qmw(i, k) .gt. qcmin) then
5758 qcw(i, k) = dpg * qmw(i, k) * 1.0e3
5759 rew(i, k) = exp(1.0 / 3.0 * log((3.0 * qmw(i, k) * rho) / &
5760 (4.0 * pi * rhow * ccnw))) * 1.0e4
5761 rew(i, k) = max(rewmin, min(rewmax, rew(i, k)))
5762 else
5763 qcw(i, k) = 0.0
5764 rew(i, k) = rewmin
5765 endif
5766
5767 endif
5768
5769 if (rewflag .eq. 3) then
5770
5771 ! -----------------------------------------------------------------------
5772 ! cloud water (Kiehl et al. 1994)
5773 ! -----------------------------------------------------------------------
5774
5775 if (qmw(i, k) .gt. qcmin) then
5776 qcw(i, k) = dpg * qmw(i, k) * 1.0e3
5777 rew(i, k) = 14.0 * abs(mask - 1.0) + &
5778 (8.0 + (14.0 - 8.0) * min(1.0, max(0.0, - tc / 30.0))) * &
5779 (1.0 - abs(mask - 1.0))
5780 rew(i, k) = rew(i, k) + (14.0 - rew(i, k)) * &
5781 min(1.0, max(0.0, snowd(i) / 1000.0)) ! snowd is in mm
5782 rew(i, k) = max(rewmin, min(rewmax, rew(i, k)))
5783 else
5784 qcw(i, k) = 0.0
5785 rew(i, k) = rewmin
5786 endif
5787
5788 endif
5789
5790 if (rewflag .eq. 4) then
5791
5792 ! -----------------------------------------------------------------------
5793 ! cloud water derived from PSD
5794 ! -----------------------------------------------------------------------
5795
5796 if (qmw(i, k) .gt. qcmin) then
5797 qcw(i, k) = dpg * qmw(i, k) * 1.0e3
5798 call cal_pc_ed_oe_rr_tv (qmw(i, k), rho, blinw, muw, &
5799 eda = edaw, edb = edbw, ed = rew(i, k))
5800 rew(i, k) = rewfac * 0.5 * rew(i, k) * 1.0e6
5801 rew(i, k) = max(rewmin, min(rewmax, rew(i, k)))
5802 else
5803 qcw(i, k) = 0.0
5804 rew(i, k) = rewmin
5805 endif
5806
5807 endif
5808
5809 if (reiflag .eq. 1) then
5810
5811 ! -----------------------------------------------------------------------
5812 ! cloud ice (Heymsfield and Mcfarquhar 1996)
5813 ! -----------------------------------------------------------------------
5814
5815 if (qmi(i, k) .gt. qcmin) then
5816 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5817 rei_fac = log(1.0e3 * qmi(i, k) * rho)
5818 if (tc .lt. - 50) then
5819 rei(i, k) = beta / 9.917 * exp(0.109 * rei_fac) * 1.0e3
5820 elseif (tc .lt. - 40) then
5821 rei(i, k) = beta / 9.337 * exp(0.080 * rei_fac) * 1.0e3
5822 elseif (tc .lt. - 30) then
5823 rei(i, k) = beta / 9.208 * exp(0.055 * rei_fac) * 1.0e3
5824 else
5825 rei(i, k) = beta / 9.387 * exp(0.031 * rei_fac) * 1.0e3
5826 endif
5827 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5828 else
5829 qci(i, k) = 0.0
5830 rei(i, k) = reimin
5831 endif
5832
5833 endif
5834
5835 if (reiflag .eq. 2) then
5836
5837 ! -----------------------------------------------------------------------
5838 ! cloud ice (Donner et al. 1997)
5839 ! -----------------------------------------------------------------------
5840
5841 if (qmi(i, k) .gt. qcmin) then
5842 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5843 if (tc .le. - 55) then
5844 rei(i, k) = 15.41627
5845 elseif (tc .le. - 50) then
5846 rei(i, k) = 16.60895
5847 elseif (tc .le. - 45) then
5848 rei(i, k) = 32.89967
5849 elseif (tc .le. - 40) then
5850 rei(i, k) = 35.29989
5851 elseif (tc .le. - 35) then
5852 rei(i, k) = 55.65818
5853 elseif (tc .le. - 30) then
5854 rei(i, k) = 85.19071
5855 elseif (tc .le. - 25) then
5856 rei(i, k) = 72.35392
5857 else
5858 rei(i, k) = 92.46298
5859 endif
5860 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5861 else
5862 qci(i, k) = 0.0
5863 rei(i, k) = reimin
5864 endif
5865
5866 endif
5867
5868 if (reiflag .eq. 3) then
5869
5870 ! -----------------------------------------------------------------------
5871 ! cloud ice (Fu 2007)
5872 ! -----------------------------------------------------------------------
5873
5874 if (qmi(i, k) .gt. qcmin) then
5875 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5876 rei(i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc)
5877 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5878 else
5879 qci(i, k) = 0.0
5880 rei(i, k) = reimin
5881 endif
5882
5883 endif
5884
5885 if (reiflag .eq. 4) then
5886
5887 ! -----------------------------------------------------------------------
5888 ! cloud ice (Kristjansson et al. 2000)
5889 ! -----------------------------------------------------------------------
5890
5891 if (qmi(i, k) .gt. qcmin) then
5892 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5893 ind = min(max(int(t(i, k) - 136.0), 44), 138 - 1)
5894 cor = t(i, k) - int(t(i, k))
5895 rei(i, k) = retab(ind) * (1. - cor) + retab(ind + 1) * cor
5896 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5897 else
5898 qci(i, k) = 0.0
5899 rei(i, k) = reimin
5900 endif
5901
5902 endif
5903
5904 if (reiflag .eq. 5) then
5905
5906 ! -----------------------------------------------------------------------
5907 ! cloud ice (Wyser 1998)
5908 ! -----------------------------------------------------------------------
5909
5910 if (qmi(i, k) .gt. qcmin) then
5911 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5912 bw = - 2. + 1.e-3 * log10(rho * qmi(i, k) / 50.e-3) * &
5913 exp(1.5 * log(max(1.e-10, - tc)))
5914 rei(i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw))
5915 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5916 else
5917 qci(i, k) = 0.0
5918 rei(i, k) = reimin
5919 endif
5920
5921 endif
5922
5923 if (reiflag .eq. 6) then
5924
5925 ! -----------------------------------------------------------------------
5926 ! cloud ice (Sun and Rikus 1999, Sun 2001)
5927 ! -----------------------------------------------------------------------
5928
5929 if (qmi(i, k) .gt. qcmin) then
5930 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5931 rei_fac = log(1.0e3 * qmi(i, k) * rho)
5932 rei(i, k) = 45.8966 * exp(0.2214 * rei_fac) + &
5933 0.7957 * exp(0.2535 * rei_fac) * (tc + 190.0)
5934 rei(i, k) = (1.2351 + 0.0105 * tc) * rei(i, k)
5935 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5936 else
5937 qci(i, k) = 0.0
5938 rei(i, k) = reimin
5939 endif
5940
5941 endif
5942
5943 if (reiflag .eq. 7) then
5944
5945 ! -----------------------------------------------------------------------
5946 ! cloud ice derived from PSD
5947 ! -----------------------------------------------------------------------
5948
5949 if (qmi(i, k) .gt. qcmin) then
5950 qci(i, k) = dpg * qmi(i, k) * 1.0e3
5951 call cal_pc_ed_oe_rr_tv (qmi(i, k), rho, blini, mui, &
5952 eda = edai, edb = edbi, ed = rei(i, k))
5953 rei(i, k) = reifac * 0.5 * rei(i, k) * 1.0e6
5954 rei(i, k) = max(reimin, min(reimax, rei(i, k)))
5955 else
5956 qci(i, k) = 0.0
5957 rei(i, k) = reimin
5958 endif
5959
5960 endif
5961
5962 if (rerflag .eq. 1) then
5963
5964 ! -----------------------------------------------------------------------
5965 ! rain derived from PSD
5966 ! -----------------------------------------------------------------------
5967
5968 if (qmr(i, k) .gt. qcmin) then
5969 qcr(i, k) = dpg * qmr(i, k) * 1.0e3
5970 call cal_pc_ed_oe_rr_tv (qmr(i, k), rho, blinr, mur, &
5971 eda = edar, edb = edbr, ed = rer(i, k))
5972 rer(i, k) = 0.5 * rer(i, k) * 1.0e6
5973 rer(i, k) = max(rermin, min(rermax, rer(i, k)))
5974 else
5975 qcr(i, k) = 0.0
5976 rer(i, k) = rermin
5977 endif
5978
5979 endif
5980
5981 if (resflag .eq. 1) then
5982
5983 ! -----------------------------------------------------------------------
5984 ! snow derived from PSD
5985 ! -----------------------------------------------------------------------
5986
5987 if (qms(i, k) .gt. qcmin) then
5988 qcs(i, k) = dpg * qms(i, k) * 1.0e3
5989 call cal_pc_ed_oe_rr_tv (qms(i, k), rho, blins, mus, &
5990 eda = edas, edb = edbs, ed = res(i, k))
5991 res(i, k) = 0.5 * res(i, k) * 1.0e6
5992 res(i, k) = max(resmin, min(resmax, res(i, k)))
5993 else
5994 qcs(i, k) = 0.0
5995 res(i, k) = resmin
5996 endif
5997
5998 endif
5999
6000 if (regflag .eq. 1) then
6001
6002 ! -----------------------------------------------------------------------
6003 ! graupel derived from PSD
6004 ! -----------------------------------------------------------------------
6005
6006 if (qmg(i, k) .gt. qcmin) then
6007 qcg(i, k) = dpg * qmg(i, k) * 1.0e3
6008 if (do_hail) then
6009 call cal_pc_ed_oe_rr_tv (qmg(i, k), rho, blinh, muh, &
6010 eda = edah, edb = edbh, ed = reg(i, k))
6011 else
6012 call cal_pc_ed_oe_rr_tv (qmg(i, k), rho, bling, mug, &
6013 eda = edag, edb = edbg, ed = reg(i, k))
6014 endif
6015 reg(i, k) = 0.5 * reg(i, k) * 1.0e6
6016 reg(i, k) = max(regmin, min(regmax, reg(i, k)))
6017 else
6018 qcg(i, k) = 0.0
6019 reg(i, k) = regmin
6020 endif
6021
6022 endif
6023
6024 enddo
6025
6026 enddo
6027
6028end subroutine cld_eff_rad
6029
6030! =======================================================================
6031! radar reflectivity
6032! =======================================================================
6033
6034subroutine rad_ref (is, ie, js, je, qv, qr, qs, qg, pt, delp, &
6035 delz, dbz, npz, hydrostatic, do_inline_mp, mp_top)
6036
6037 implicit none
6038
6039 ! -----------------------------------------------------------------------
6040 ! input / output arguments
6041 ! -----------------------------------------------------------------------
6042
6043 logical, intent (in) :: hydrostatic, do_inline_mp
6044
6045 integer, intent (in) :: is, ie, js, je
6046 integer, intent (in) :: npz, mp_top
6047 !integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel
6048
6049 !real(kind_phys), intent (in) :: zvir
6050
6051 real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: delz
6052
6053 real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: pt, delp
6054
6055 real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: qv, qr, qs, qg
6056
6057 !real(kind_phys), intent (in), dimension (is:ie, npz + 1, js:je) :: peln
6058
6059 !real(kind_phys), intent (out) :: allmax
6060
6061 !real(kind_phys), intent (out), dimension (is:ie, js:je) :: maxdbz
6062
6063 real(kind_phys), intent (out), dimension (is:ie, js:je, npz) :: dbz
6064
6065 ! -----------------------------------------------------------------------
6066 ! local variables
6067 ! -----------------------------------------------------------------------
6068
6069 integer :: i, j, k
6070
6071 real(kind_phys), parameter :: alpha = 0.224, mp_const = 200 * exp(1.6 * log(3.6e6))
6072
6073 real (kind = r8) :: qden, z_e
6074 real(kind_phys) :: fac_r, fac_s, fac_g
6075 real(kind_phys) :: allmax
6076 real(kind_phys), dimension (is:ie, js:je) :: maxdbz
6077
6078 real(kind_phys), dimension (npz) :: den, denfac, qmr, qms, qmg, vtr, vts, vtg
6079
6080 ! -----------------------------------------------------------------------
6081 ! return if the microphysics scheme doesn't include rain
6082 ! -----------------------------------------------------------------------
6083
6084 !if (rainwat .lt. 1) return
6085
6086 ! -----------------------------------------------------------------------
6087 ! initialization
6088 ! -----------------------------------------------------------------------
6089
6090 dbz = - 20.
6091 maxdbz = - 20.
6092 allmax = - 20.
6093
6094 ! -----------------------------------------------------------------------
6095 ! calculate radar reflectivity
6096 ! -----------------------------------------------------------------------
6097
6098 do j = js, je
6099 do i = is, ie
6100
6101 ! -----------------------------------------------------------------------
6102 ! air density
6103 ! -----------------------------------------------------------------------
6104
6105 do k = 1, npz
6106 !if (hydrostatic) then
6107 ! den (k) = delp (i, j, k) / ((peln (i, k + 1, j) - peln (i, k, j)) * &
6108 ! rdgas * pt (i, j, k) * (1. + zvir * qv (i, j, k)))
6109 !else
6110 ! den (k) = - delp (i, j, k) / (grav * delz (i, j, k))
6111 !endif
6112
6113 den(k) = - delp(i, j, k) / (grav * delz(i, j, k))
6114 qmr(k) = max(qcmin, qr(i, j, k))
6115 qms(k) = max(qcmin, qs(i, j, k))
6116 qmg(k) = max(qcmin, qg(i, j, k))
6117 enddo
6118
6119 do k = 1, npz
6120 denfac(k) = sqrt(den(npz) / den(k))
6121 enddo
6122
6123 ! -----------------------------------------------------------------------
6124 ! fall speed
6125 ! -----------------------------------------------------------------------
6126
6127 if (radr_flag .eq. 3) then
6128 call term_rsg (1, npz, qmr, den, denfac, vr_fac, blinr, &
6129 mur, tvar, tvbr, vr_max, const_vr, vtr)
6130 vtr = vtr / rhor
6131 endif
6132
6133 if (rads_flag .eq. 3) then
6134 call term_rsg (1, npz, qms, den, denfac, vs_fac, blins, &
6135 mus, tvas, tvbs, vs_max, const_vs, vts)
6136 vts = vts / rhos
6137 endif
6138
6139 if (radg_flag .eq. 3) then
6140 if (do_hail .and. .not. do_inline_mp) then
6141 call term_rsg (1, npz, qmg, den, denfac, vg_fac, blinh, &
6142 muh, tvah, tvbh, vg_max, const_vg, vtg)
6143 vtg = vtg / rhoh
6144 else
6145 call term_rsg (1, npz, qmg, den, denfac, vg_fac, bling, &
6146 mug, tvag, tvbg, vg_max, const_vg, vtg)
6147 vtg = vtg / rhog
6148 endif
6149 endif
6150
6151 ! -----------------------------------------------------------------------
6152 ! radar reflectivity
6153 ! -----------------------------------------------------------------------
6154
6155 do k = mp_top + 1, npz
6156 z_e = 0.
6157
6158 !if (rainwat .gt. 0) then
6159 qden = den(k) * qmr(k)
6160 if (qmr(k) .gt. qcmin) then
6161 call cal_pc_ed_oe_rr_tv (qmr(k), den(k), blinr, mur, &
6162 rra = rrar, rrb = rrbr, rr = fac_r)
6163 else
6164 fac_r = 0.0
6165 endif
6166 if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then
6167 z_e = z_e + fac_r * 1.e18
6168 endif
6169 if (radr_flag .eq. 3) then
6170 z_e = z_e + mp_const * exp(1.6 * log(qden * vtr(k)))
6171 endif
6172 !endif
6173
6174 !if (snowwat .gt. 0) then
6175 qden = den(k) * qms(k)
6176 if (qms(k) .gt. qcmin) then
6177 call cal_pc_ed_oe_rr_tv (qms(k), den(k), blins, mus, &
6178 rra = rras, rrb = rrbs, rr = fac_s)
6179 else
6180 fac_s = 0.0
6181 endif
6182 if (rads_flag .eq. 1) then
6183 if (pt(i, j, k) .lt. tice) then
6184 z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2
6185 else
6186 z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 / alpha
6187 endif
6188 endif
6189 if (rads_flag .eq. 2) then
6190 if (pt(i, j, k) .lt. tice) then
6191 z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2
6192 else
6193 z_e = z_e + fac_s * 1.e18
6194 endif
6195 endif
6196 if (rads_flag .eq. 3) then
6197 z_e = z_e + mp_const * exp(1.6 * log(qden * vts(k)))
6198 endif
6199 !endif
6200
6201 !if (graupel .gt. 0) then
6202 qden = den(k) * qmg(k)
6203 if (do_hail .and. .not. do_inline_mp) then
6204 if (qmg(k) .gt. qcmin) then
6205 call cal_pc_ed_oe_rr_tv (qmg(k), den(k), blinh, muh, &
6206 rra = rrah, rrb = rrbh, rr = fac_g)
6207 else
6208 fac_g = 0.0
6209 endif
6210 if (radg_flag .eq. 1) then
6211 if (pt(i, j, k) .lt. tice) then
6212 z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2
6213 else
6214 z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 / alpha
6215 endif
6216 endif
6217 if (radg_flag .eq. 2) then
6218 z_e = z_e + fac_g * 1.e18
6219 endif
6220 else
6221 if (qmg(k) .gt. qcmin) then
6222 call cal_pc_ed_oe_rr_tv (qmg(k), den(k), bling, mug, &
6223 rra = rrag, rrb = rrbg, rr = fac_g)
6224 else
6225 fac_g = 0.0
6226 endif
6227 if (radg_flag .eq. 1) then
6228 if (pt(i, j, k) .lt. tice) then
6229 z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2
6230 else
6231 z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 / alpha
6232 endif
6233 endif
6234 if (radg_flag .eq. 2) then
6235 z_e = z_e + fac_g * 1.e18
6236 endif
6237 endif
6238 if (radg_flag .eq. 3) then
6239 z_e = z_e + mp_const * exp(1.6 * log(qden * vtg(k)))
6240 endif
6241 !endif
6242
6243 dbz(i, j, k) = 10. * log10(max(0.01, z_e))
6244 enddo
6245
6246 do k = mp_top + 1, npz
6247 maxdbz(i, j) = max(dbz(i, j, k), maxdbz(i, j))
6248 enddo
6249
6250 allmax = max(maxdbz(i, j), allmax)
6251
6252 enddo
6253 enddo
6254
6255end subroutine rad_ref
6256
6257! =======================================================================
6258! moist heat capacity, 3 input variables
6259! =======================================================================
6260
6261function mhc3 (qv, q_liq, q_sol)
6262
6263 implicit none
6264
6265 real (kind = r8) :: mhc3
6266
6267 ! -----------------------------------------------------------------------
6268 ! input / output arguments
6269 ! -----------------------------------------------------------------------
6270
6271 real(kind_phys), intent (in) :: qv, q_liq, q_sol
6272
6273 ! -----------------------------------------------------------------------
6274 ! local variables
6275 ! -----------------------------------------------------------------------
6276
6277 mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice
6278
6279end function mhc3
6280
6281! =======================================================================
6282! moist heat capacity, 4 input variables
6283! =======================================================================
6284
6285function mhc4 (qd, qv, q_liq, q_sol)
6286
6287 implicit none
6288
6289 real (kind = r8) :: mhc4
6290
6291 ! -----------------------------------------------------------------------
6292 ! input / output arguments
6293 ! -----------------------------------------------------------------------
6294
6295 real(kind_phys), intent (in) :: qv, q_liq, q_sol
6296
6297 real (kind = r8), intent (in) :: qd
6298
6299 ! -----------------------------------------------------------------------
6300 ! local variables
6301 ! -----------------------------------------------------------------------
6302
6303 mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice
6304
6305end function mhc4
6306
6307! =======================================================================
6308! moist heat capacity, 6 input variables
6309! =======================================================================
6310
6311function mhc6 (qv, ql, qr, qi, qs, qg)
6312
6313 implicit none
6314
6315 real (kind = r8) :: mhc6
6316
6317 ! -----------------------------------------------------------------------
6318 ! input / output arguments
6319 ! -----------------------------------------------------------------------
6320
6321 real(kind_phys), intent (in) :: qv, ql, qr, qi, qs, qg
6322
6323 ! -----------------------------------------------------------------------
6324 ! local variables
6325 ! -----------------------------------------------------------------------
6326
6327 real(kind_phys) :: q_liq, q_sol
6328
6329 q_liq = ql + qr
6330 q_sol = qi + qs + qg
6331 mhc6 = mhc(qv, q_liq, q_sol)
6332
6333end function mhc6
6334
6335! =======================================================================
6336! moist total energy
6337! =======================================================================
6338
6339function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q)
6340
6341 implicit none
6342
6343 real (kind = r8) :: mte
6344
6345 ! -----------------------------------------------------------------------
6346 ! input / output arguments
6347 ! -----------------------------------------------------------------------
6348
6349 logical, intent (in) :: moist_q
6350
6351 real(kind_phys), intent (in) :: qv, ql, qr, qi, qs, qg, dp
6352
6353 real (kind = r8), intent (in) :: tk
6354
6355 ! -----------------------------------------------------------------------
6356 ! local variables
6357 ! -----------------------------------------------------------------------
6358
6359 real(kind_phys) :: q_liq, q_sol, q_cond
6360
6361 real (kind = r8) :: cvm, con_r8
6362
6363 q_liq = ql + qr
6364 q_sol = qi + qs + qg
6365 q_cond = q_liq + q_sol
6366 con_r8 = one_r8 - (qv + q_cond)
6367 if (moist_q) then
6368 cvm = mhc(con_r8, qv, q_liq, q_sol)
6369 else
6370 cvm = mhc(qv, q_liq, q_sol)
6371 endif
6372 mte = rgrav * cvm * c_air * tk * dp
6373
6374end function mte
6375
6376! =======================================================================
6377! moist total energy and total water
6378! =======================================================================
6379
6380subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, &
6381 dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, &
6382 te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss)
6383
6384 implicit none
6385
6386 ! -----------------------------------------------------------------------
6387 ! input / output arguments
6388 ! -----------------------------------------------------------------------
6389
6390 integer, intent (in) :: ks, ke
6391
6392 logical, intent (in) :: moist_q, hydrostatic
6393
6394 real(kind_phys), intent (in) :: vapor, water, rain, ice, snow, graupel, dts, sen, stress
6395
6396 real(kind_phys), intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp
6397
6398 real (kind = r8), intent (in) :: dte
6399
6400 real (kind = r8), intent (in), dimension (ks:ke) :: tz
6401
6402 real (kind = r8), intent (out) :: te_b, tw_b
6403
6404 real (kind = r8), intent (out), optional :: te_loss
6405
6406 real (kind = r8), intent (out), dimension (ks:ke) :: te, tw
6407
6408 ! -----------------------------------------------------------------------
6409 ! local variables
6410 ! -----------------------------------------------------------------------
6411
6412 integer :: k
6413
6414 real(kind_phys) :: q_cond
6415
6416 real (kind = r8) :: con_r8
6417
6418 real(kind_phys), dimension (ks:ke) :: q_liq, q_sol
6419
6420 real (kind = r8), dimension (ks:ke) :: cvm
6421
6422 do k = ks, ke
6423 q_liq(k) = ql(k) + qr(k)
6424 q_sol(k) = qi(k) + qs(k) + qg(k)
6425 q_cond = q_liq(k) + q_sol(k)
6426 con_r8 = one_r8 - (qv(k) + q_cond)
6427 if (moist_q) then
6428 cvm(k) = mhc(con_r8, qv(k), q_liq(k), q_sol(k))
6429 else
6430 cvm(k) = mhc(qv(k), q_liq(k), q_sol(k))
6431 endif
6432 te(k) = (cvm(k) * tz(k) + lv00 * qv(k) - li00 * q_sol(k)) * c_air
6433 if (hydrostatic) then
6434 te(k) = te(k) + 0.5 * (ua(k) ** 2 + va(k) ** 2)
6435 else
6436 te(k) = te(k) + 0.5 * (ua(k) ** 2 + va(k) ** 2 + wa(k) ** 2)
6437 endif
6438 te(k) = rgrav * te(k) * delp(k)
6439 tw(k) = rgrav * (qv(k) + q_cond) * delp(k)
6440 enddo
6441 te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts)
6442 tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400
6443
6444 if (present (te_loss)) then
6445 ! total energy change due to sedimentation and its heating
6446 te_loss = dte
6447 endif
6448
6449end subroutine mtetw
6450
6451! =======================================================================
6452! calculate heat capacities and latent heat coefficients
6453! =======================================================================
6454
6455subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, &
6456 cvm, te8, tz, lcpk, icpk, tcpk, tcp3)
6457
6458 implicit none
6459
6460 ! -----------------------------------------------------------------------
6461 ! input / output arguments
6462 ! -----------------------------------------------------------------------
6463
6464 integer, intent (in) :: ks, ke
6465
6466 real(kind_phys), intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg
6467
6468 real (kind = r8), intent (in), dimension (ks:ke) :: tz
6469
6470 real(kind_phys), intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3
6471
6472 real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8
6473
6474 ! -----------------------------------------------------------------------
6475 ! local variables
6476 ! -----------------------------------------------------------------------
6477
6478 integer :: k
6479
6480 do k = ks, ke
6481 q_liq(k) = ql(k) + qr(k)
6482 q_sol(k) = qi(k) + qs(k) + qg(k)
6483 cvm(k) = mhc(qv(k), q_liq(k), q_sol(k))
6484 te8(k) = cvm(k) * tz(k) + lv00 * qv(k) - li00 * q_sol(k)
6485 lcpk(k) = (lv00 + d1_vap * tz(k)) / cvm(k)
6486 icpk(k) = (li00 + d1_ice * tz(k)) / cvm(k)
6487 tcpk(k) = (li20 + (d1_vap + d1_ice) * tz(k)) / cvm(k)
6488 tcp3(k) = lcpk(k) + icpk(k) * min(1., dim(tice, tz(k)) / (tice - t_wfr))
6489 enddo
6490
6491end subroutine cal_mhc_lhc
6492
6493! =======================================================================
6494! update hydrometeors
6495! =======================================================================
6496
6497subroutine update_qq (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg)
6498
6499 implicit none
6500
6501 ! -----------------------------------------------------------------------
6502 ! input / output arguments
6503 ! -----------------------------------------------------------------------
6504
6505 real(kind_phys), intent (in) :: dqv, dql, dqr, dqi, dqs, dqg
6506
6507 real(kind_phys), intent (inout) :: qv, ql, qr, qi, qs, qg
6508
6509 qv = qv + dqv
6510 ql = ql + dql
6511 qr = qr + dqr
6512 qi = qi + dqi
6513 qs = qs + dqs
6514 qg = qg + dqg
6515
6516end subroutine update_qq
6517
6518! =======================================================================
6519! update hydrometeors and temperature
6520! =======================================================================
6521
6522subroutine update_qt (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, &
6523 cvm, tk, lcpk, icpk, tcpk, tcp3)
6524
6525 implicit none
6526
6527 ! -----------------------------------------------------------------------
6528 ! input / output arguments
6529 ! -----------------------------------------------------------------------
6530
6531 real(kind_phys), intent (in) :: dqv, dql, dqr, dqi, dqs, dqg
6532
6533 real (kind = r8), intent (in) :: te8
6534
6535 real(kind_phys), intent (inout) :: qv, ql, qr, qi, qs, qg
6536
6537 real(kind_phys), intent (out) :: lcpk, icpk, tcpk, tcp3
6538
6539 real (kind = r8), intent (out) :: cvm, tk
6540
6541 ! -----------------------------------------------------------------------
6542 ! local variables
6543 ! -----------------------------------------------------------------------
6544
6545 qv = qv + dqv
6546 ql = ql + dql
6547 qr = qr + dqr
6548 qi = qi + dqi
6549 qs = qs + dqs
6550 qg = qg + dqg
6551
6552 cvm = mhc(qv, ql, qr, qi, qs, qg)
6553 tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm
6554
6555 lcpk = (lv00 + d1_vap * tk) / cvm
6556 icpk = (li00 + d1_ice * tk) / cvm
6557 tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm
6558 tcp3 = lcpk + icpk * min(1., dim(tice, tk) / (tice - t_wfr))
6559
6560end subroutine update_qt
6561
6562! =======================================================================
6563! calculation of particle concentration (pc), effective diameter (ed),
6564! optical extinction (oe), radar reflectivity factor (rr), and
6565! mass-weighted terminal velocity (tv)
6566! =======================================================================
6567
6568subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, &
6569 oea, oeb, oe, rra, rrb, rr, tva, tvb, tv)
6570
6571 implicit none
6572
6573 ! -----------------------------------------------------------------------
6574 ! input / output arguments
6575 ! -----------------------------------------------------------------------
6576
6577 real(kind_phys), intent (in) :: blin, mu
6578
6579 real(kind_phys), intent (in) :: q, den
6580
6581 real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb
6582
6583 real(kind_phys), intent (out), optional :: pc, ed, oe, rr, tv
6584
6585 if (present (pca) .and. present (pcb) .and. present (pc)) then
6586 pc = pca / pcb * exp(mu / (mu + 3) * log(6 * den * q))
6587 endif
6588 if (present (eda) .and. present (edb) .and. present (ed)) then
6589 ed = eda / edb * exp(1. / (mu + 3) * log(6 * den * q))
6590 endif
6591 if (present (oea) .and. present (oeb) .and. present (oe)) then
6592 oe = oea / oeb * exp((mu + 2) / (mu + 3) * log(6 * den * q))
6593 endif
6594 if (present (rra) .and. present (rrb) .and. present (rr)) then
6595 rr = rra / rrb * exp((mu + 6) / (mu + 3) * log(6 * den * q))
6596 endif
6597 if (present (tva) .and. present (tvb) .and. present (tv)) then
6598 tv = tva / tvb * exp(blin / (mu + 3) * log(6 * den * q))
6599 endif
6600
6601end subroutine cal_pc_ed_oe_rr_tv
6602
6603! =======================================================================
6604! prepare saturation water vapor pressure tables
6605! =======================================================================
6606
6607subroutine qs_init
6608
6609 implicit none
6610
6611 integer :: i
6612
6613 if (.not. tables_are_initialized) then
6614
6615 allocate (table0(length))
6616 allocate (table1(length))
6617 allocate (table2(length))
6618 allocate (table3(length))
6619 allocate (table4(length))
6620
6621 allocate (des0(length))
6622 allocate (des1(length))
6623 allocate (des2(length))
6624 allocate (des3(length))
6625 allocate (des4(length))
6626
6627 call qs_table0 (length)
6628 call qs_table1 (length)
6629 call qs_table2 (length)
6630 call qs_table3 (length)
6631 call qs_table4 (length)
6632
6633 do i = 1, length - 1
6634 des0(i) = max(0., table0(i + 1) - table0(i))
6635 des1(i) = max(0., table1(i + 1) - table1(i))
6636 des2(i) = max(0., table2(i + 1) - table2(i))
6637 des3(i) = max(0., table3(i + 1) - table3(i))
6638 des4(i) = max(0., table4(i + 1) - table4(i))
6639 enddo
6640 des0(length) = des0(length - 1)
6641 des1(length) = des1(length - 1)
6642 des2(length) = des2(length - 1)
6643 des3(length) = des3(length - 1)
6644 des4(length) = des4(length - 1)
6645
6646 tables_are_initialized = .true.
6647
6648 endif
6649
6650end subroutine qs_init
6651
6652! =======================================================================
6653! saturation water vapor pressure table, core function
6654! =======================================================================
6655
6656subroutine qs_table_core (n, n_blend, do_smith_table, table)
6657
6658 implicit none
6659
6660 ! -----------------------------------------------------------------------
6661 ! input / output arguments
6662 ! -----------------------------------------------------------------------
6663
6664 integer, intent (in) :: n, n_blend
6665
6666 logical, intent (in) :: do_smith_table
6667
6668 real(kind_phys), intent (out), dimension (n) :: table
6669
6670 ! -----------------------------------------------------------------------
6671 ! local variables
6672 ! -----------------------------------------------------------------------
6673
6674 integer :: i
6675 integer, parameter :: n_min = 1600
6676
6677 real (kind = r8) :: delt = 0.1
6678 real (kind = r8) :: tmin, tem, esh
6679 real (kind = r8) :: wice, wh2o, fac0, fac1, fac2
6680 real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e
6681 real (kind = r8) :: esupc(n_blend)
6682
6683 esbasw = 1013246.0
6684 tbasw = tice + 100.
6685 esbasi = 6107.1
6686 tmin = tice - n_min * delt
6687
6688 ! -----------------------------------------------------------------------
6689 ! compute es over ice between - (n_min * delt) deg C and 0 deg C
6690 ! -----------------------------------------------------------------------
6691
6692 if (do_smith_table) then
6693 do i = 1, n_min
6694 tem = tmin + delt * real(i - 1, kind=kind_phys)
6695 a = - 9.09718 * (tice / tem - 1.)
6696 b = - 3.56654 * log10(tice / tem)
6697 c = 0.876793 * (1. - tem / tice)
6698 e = log10(esbasi)
6699 table(i) = 0.1 * exp((a + b + c + e) * log(10.))
6700 enddo
6701 else
6702 do i = 1, n_min
6703 tem = tmin + delt * real(i - 1, kind=kind_phys)
6704 fac0 = (tem - tice) / (tem * tice)
6705 fac1 = fac0 * li2
6706 fac2 = (d2_ice * log(tem / tice) + fac1) / rvgas
6707 table(i) = e00 * exp(fac2)
6708 enddo
6709 endif
6710
6711 ! -----------------------------------------------------------------------
6712 ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C
6713 ! -----------------------------------------------------------------------
6714
6715 if (do_smith_table) then
6716 do i = 1, n - n_min + n_blend
6717 tem = tice + delt * (real(i - 1, kind=kind_phys) - n_blend)
6718 a = - 7.90298 * (tbasw / tem - 1.)
6719 b = 5.02808 * log10(tbasw / tem)
6720 c = - 1.3816e-7 * (exp((1. - tem / tbasw) * 11.344 * log(10.)) - 1.)
6721 d = 8.1328e-3 * (exp((tbasw / tem - 1.) * (- 3.49149) * log(10.)) - 1.)
6722 e = log10(esbasw)
6723 esh = 0.1 * exp((a + b + c + d + e) * log(10.))
6724 if (i .le. n_blend) then
6725 esupc(i) = esh
6726 else
6727 table(i + n_min - n_blend) = esh
6728 endif
6729 enddo
6730 else
6731 do i = 1, n - n_min + n_blend
6732 tem = tice + delt * (real(i - 1, kind=kind_phys) - n_blend)
6733 fac0 = (tem - tice) / (tem * tice)
6734 fac1 = fac0 * lv0
6735 fac2 = (dc_vap * log(tem / tice) + fac1) / rvgas
6736 esh = e00 * exp(fac2)
6737 if (i .le. n_blend) then
6738 esupc(i) = esh
6739 else
6740 table(i + n_min - n_blend) = esh
6741 endif
6742 enddo
6743 endif
6744
6745 ! -----------------------------------------------------------------------
6746 ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C
6747 ! -----------------------------------------------------------------------
6748
6749 do i = 1, n_blend
6750 tem = tice + delt * (real(i - 1, kind=kind_phys) - n_blend)
6751 wice = 1.0 / (delt * n_blend) * (tice - tem)
6752 wh2o = 1.0 / (delt * n_blend) * (tem - tice + delt * n_blend)
6753 table(i + n_min - n_blend) = wice * table(i + n_min - n_blend) + wh2o * esupc(i)
6754 enddo
6755
6756end subroutine qs_table_core
6757
6758! =======================================================================
6759! saturation water vapor pressure table 0, water only
6760! useful for idealized experiments
6761! it can also be used in warm rain microphyscis only
6762! =======================================================================
6763
6764subroutine qs_table0 (n)
6765
6766 implicit none
6767
6768 ! -----------------------------------------------------------------------
6769 ! input / output arguments
6770 ! -----------------------------------------------------------------------
6771
6772 integer, intent (in) :: n
6773
6774 ! -----------------------------------------------------------------------
6775 ! local variables
6776 ! -----------------------------------------------------------------------
6777
6778 integer :: i
6779
6780 real (kind = r8) :: delt = 0.1
6781 real (kind = r8) :: tmin, tem, fac0, fac1, fac2
6782
6783 tmin = tice - 160.
6784
6785 ! -----------------------------------------------------------------------
6786 ! compute es over water only
6787 ! -----------------------------------------------------------------------
6788
6789 do i = 1, n
6790 tem = tmin + delt * real(i - 1, kind=kind_phys)
6791 fac0 = (tem - tice) / (tem * tice)
6792 fac1 = fac0 * lv0
6793 fac2 = (dc_vap * log(tem / tice) + fac1) / rvgas
6794 table0(i) = e00 * exp(fac2)
6795 enddo
6796
6797end subroutine qs_table0
6798
6799! =======================================================================
6800! saturation water vapor pressure table 1, water and ice
6801! blended between -20 deg C and 0 deg C
6802! the most realistic saturation water vapor pressure for the full temperature range
6803! =======================================================================
6804
6805subroutine qs_table1 (n)
6806
6807 implicit none
6808
6809 ! -----------------------------------------------------------------------
6810 ! input / output arguments
6811 ! -----------------------------------------------------------------------
6812
6813 integer, intent (in) :: n
6814
6815 call qs_table_core (n, 200, .false., table1)
6816
6817end subroutine qs_table1
6818
6819! =======================================================================
6820! saturation water vapor pressure table 2, water and ice
6821! same as table 1, but the blending is replaced with smoothing around 0 deg C
6822! it is not designed for mixed-phase cloud microphysics
6823! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
6824! =======================================================================
6825
6826subroutine qs_table2 (n)
6827
6828 implicit none
6829
6830 ! -----------------------------------------------------------------------
6831 ! input / output arguments
6832 ! -----------------------------------------------------------------------
6833
6834 integer, intent (in) :: n
6835
6836 call qs_table_core (n, 0, .false., table2)
6837
6838end subroutine qs_table2
6839
6840! =======================================================================
6841! saturation water vapor pressure table 3, water and ice
6842! blended between -20 deg C and 0 deg C
6843! the same as table 1, but from smithsonian meteorological tables page 350
6844! =======================================================================
6845
6846subroutine qs_table3 (n)
6847
6848 implicit none
6849
6850 ! -----------------------------------------------------------------------
6851 ! input / output arguments
6852 ! -----------------------------------------------------------------------
6853
6854 integer, intent (in) :: n
6855
6856 call qs_table_core (n, 200, .true., table3)
6857
6858end subroutine qs_table3
6859
6860! =======================================================================
6861! saturation water vapor pressure table 4, water and ice
6862! same as table 3, but the blending is replaced with smoothing around 0 deg C
6863! the same as table 2, but from smithsonian meteorological tables page 350
6864! =======================================================================
6865
6866subroutine qs_table4 (n)
6867
6868 implicit none
6869
6870 ! -----------------------------------------------------------------------
6871 ! input / output arguments
6872 ! -----------------------------------------------------------------------
6873
6874 integer, intent (in) :: n
6875
6876 call qs_table_core (n, 0, .true., table4)
6877
6878end subroutine qs_table4
6879
6880! =======================================================================
6881! compute the saturated water pressure, core function
6882! =======================================================================
6883
6884function es_core (length, tk, table, des)
6885
6886 implicit none
6887
6888 real(kind_phys) :: es_core
6889
6890 ! -----------------------------------------------------------------------
6891 ! input / output arguments
6892 ! -----------------------------------------------------------------------
6893
6894 integer, intent (in) :: length
6895
6896 real(kind_phys), intent (in) :: tk
6897
6898 real(kind_phys), intent (in), dimension (length) :: table, des
6899
6900 ! -----------------------------------------------------------------------
6901 ! local variables
6902 ! -----------------------------------------------------------------------
6903
6904 integer :: it
6905
6906 real(kind_phys) :: ap1, tmin
6907
6908 if (.not. tables_are_initialized) call qs_init
6909
6910 tmin = tice - 160.
6911 ap1 = 10. * dim(tk, tmin) + 1.
6912 ap1 = min(2621., ap1)
6913 it = ap1
6914 es_core = table(it) + (ap1 - it) * des(it)
6915
6916end function es_core
6917
6918! =======================================================================
6919! compute the saturated specific humidity, core function
6920! =======================================================================
6921
6922function qs_core (length, tk, den, dqdt, table, des)
6923
6924 implicit none
6925
6926 real(kind_phys) :: qs_core
6927
6928 ! -----------------------------------------------------------------------
6929 ! input / output arguments
6930 ! -----------------------------------------------------------------------
6931
6932 integer, intent (in) :: length
6933
6934 real(kind_phys), intent (in) :: tk, den
6935
6936 real(kind_phys), intent (in), dimension (length) :: table, des
6937
6938 real(kind_phys), intent (out) :: dqdt
6939
6940 ! -----------------------------------------------------------------------
6941 ! local variables
6942 ! -----------------------------------------------------------------------
6943
6944 integer :: it
6945
6946 real(kind_phys) :: ap1, tmin
6947
6948 tmin = tice - 160.
6949 ap1 = 10. * dim(tk, tmin) + 1.
6950 ap1 = min(2621., ap1)
6951 qs_core = es_core(length, tk, table, des) / (rvgas * tk * den)
6952 it = ap1 - 0.5
6953 dqdt = 10. * (des(it) + (ap1 - it) * (des(it + 1) - des(it))) / (rvgas * tk * den)
6954
6955end function qs_core
6956
6957! =======================================================================
6958! compute the saturated water pressure based on table 0, water only
6959! useful for idealized experiments
6960! it can also be used in warm rain microphyscis only
6961! =======================================================================
6962
6963function wes_t (tk)
6964
6965 implicit none
6966
6967 real(kind_phys) :: wes_t
6968
6969 ! -----------------------------------------------------------------------
6970 ! input / output arguments
6971 ! -----------------------------------------------------------------------
6972
6973 real(kind_phys), intent (in) :: tk
6974
6975 wes_t = es_core(length, tk, table0, des0)
6976
6977end function wes_t
6978
6979! =======================================================================
6980! compute the saturated water pressure based on table 1, water and ice
6981! the most realistic saturation water vapor pressure for the full temperature range
6982! =======================================================================
6983
6984function mes_t (tk)
6985
6986 implicit none
6987
6988 real(kind_phys) :: mes_t
6989
6990 ! -----------------------------------------------------------------------
6991 ! input / output arguments
6992 ! -----------------------------------------------------------------------
6993
6994 real(kind_phys), intent (in) :: tk
6995
6996 mes_t = es_core(length, tk, table1, des1)
6997
6998end function mes_t
6999
7000! =======================================================================
7001! compute the saturated water pressure based on table 2, water and ice
7002! it is not designed for mixed-phase cloud microphysics
7003! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
7004! =======================================================================
7005
7006function ies_t (tk)
7007
7008 implicit none
7009
7010 real(kind_phys) :: ies_t
7011
7012 ! -----------------------------------------------------------------------
7013 ! input / output arguments
7014 ! -----------------------------------------------------------------------
7015
7016 real(kind_phys), intent (in) :: tk
7017
7018 ies_t = es_core(length, tk, table2, des2)
7019
7020end function ies_t
7021
7022! =======================================================================
7023! compute the saturated specific humidity based on table 0, water only
7024! useful for idealized experiments
7025! it can also be used in warm rain microphyscis only
7026! =======================================================================
7027
7028function wqs_trho (tk, den, dqdt)
7029
7030 implicit none
7031
7032 real(kind_phys) :: wqs_trho
7033
7034 ! -----------------------------------------------------------------------
7035 ! input / output arguments
7036 ! -----------------------------------------------------------------------
7037
7038 real(kind_phys), intent (in) :: tk, den
7039
7040 real(kind_phys), intent (out) :: dqdt
7041
7042 wqs_trho = qs_core(length, tk, den, dqdt, table0, des0)
7043
7044end function wqs_trho
7045
7046! =======================================================================
7047! compute the saturated specific humidity based on table 1, water and ice
7048! the most realistic saturation water vapor pressure for the full temperature range
7049! =======================================================================
7050
7051function mqs_trho (tk, den, dqdt)
7052
7053 implicit none
7054
7055 real(kind_phys) :: mqs_trho
7056
7057 ! -----------------------------------------------------------------------
7058 ! input / output arguments
7059 ! -----------------------------------------------------------------------
7060
7061 real(kind_phys), intent (in) :: tk, den
7062
7063 real(kind_phys), intent (out) :: dqdt
7064
7065 mqs_trho = qs_core(length, tk, den, dqdt, table1, des1)
7066
7067end function mqs_trho
7068
7069! =======================================================================
7070! compute the saturated specific humidity based on table 2, water and ice
7071! it is not designed for mixed-phase cloud microphysics
7072! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
7073! =======================================================================
7074
7075function iqs_trho (tk, den, dqdt)
7076
7077 implicit none
7078
7079 real(kind_phys) :: iqs_trho
7080
7081 ! -----------------------------------------------------------------------
7082 ! input / output arguments
7083 ! -----------------------------------------------------------------------
7084
7085 real(kind_phys), intent (in) :: tk, den
7086
7087 real(kind_phys), intent (out) :: dqdt
7088
7089 iqs_trho = qs_core(length, tk, den, dqdt, table2, des2)
7090
7091end function iqs_trho
7092
7093! =======================================================================
7094! compute the saturated specific humidity based on table 0, water only
7095! useful for idealized experiments
7096! it can also be used in warm rain microphyscis only
7097! =======================================================================
7098
7099function wqs_ptqv (tk, pa, qv, dqdt)
7100
7101 implicit none
7102
7103 real(kind_phys) :: wqs_ptqv
7104
7105 ! -----------------------------------------------------------------------
7106 ! input / output arguments
7107 ! -----------------------------------------------------------------------
7108
7109 real(kind_phys), intent (in) :: tk, pa, qv
7110
7111 real(kind_phys), intent (out) :: dqdt
7112
7113 ! -----------------------------------------------------------------------
7114 ! local variables
7115 ! -----------------------------------------------------------------------
7116
7117 real(kind_phys) :: den
7118
7119 den = pa / (rdgas * tk * (1. + zvir * qv))
7120
7121 wqs_ptqv = wqs(tk, den, dqdt)
7122
7123end function wqs_ptqv
7124
7125! =======================================================================
7126! compute the saturated specific humidity based on table 1, water and ice
7127! the most realistic saturation water vapor pressure for the full temperature range
7128! =======================================================================
7129
7130function mqs_ptqv (tk, pa, qv, dqdt)
7131
7132 implicit none
7133
7134 real(kind_phys) :: mqs_ptqv
7135
7136 ! -----------------------------------------------------------------------
7137 ! input / output arguments
7138 ! -----------------------------------------------------------------------
7139
7140 real(kind_phys), intent (in) :: tk, pa, qv
7141
7142 real(kind_phys), intent (out) :: dqdt
7143
7144 ! -----------------------------------------------------------------------
7145 ! local variables
7146 ! -----------------------------------------------------------------------
7147
7148 real(kind_phys) :: den
7149
7150 den = pa / (rdgas * tk * (1. + zvir * qv))
7151
7152 mqs_ptqv = mqs(tk, den, dqdt)
7153
7154end function mqs_ptqv
7155
7156! =======================================================================
7157! compute the saturated specific humidity based on table 2, water and ice
7158! it is not designed for mixed-phase cloud microphysics
7159! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C)
7160! =======================================================================
7161
7162function iqs_ptqv (tk, pa, qv, dqdt)
7163
7164 implicit none
7165
7166 real(kind_phys) :: iqs_ptqv
7167
7168 ! -----------------------------------------------------------------------
7169 ! input / output arguments
7170 ! -----------------------------------------------------------------------
7171
7172 real(kind_phys), intent (in) :: tk, pa, qv
7173
7174 real(kind_phys), intent (out) :: dqdt
7175
7176 ! -----------------------------------------------------------------------
7177 ! local variables
7178 ! -----------------------------------------------------------------------
7179
7180 real(kind_phys) :: den
7181
7182 den = pa / (rdgas * tk * (1. + zvir * qv))
7183
7184 iqs_ptqv = iqs(tk, den, dqdt)
7185
7186end function iqs_ptqv
7187
7188! =======================================================================
7189! compute the saturated specific humidity based on table 1, water and ice
7190! the most realistic saturation water vapor pressure for the full temperature range
7191! it is the 3d version of "mqs"
7192! =======================================================================
7193
7194subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt)
7195
7196 implicit none
7197
7198 ! -----------------------------------------------------------------------
7199 ! input / output arguments
7200 ! -----------------------------------------------------------------------
7201
7202 integer, intent (in) :: im, km, ks
7203
7204 real(kind_phys), intent (in), dimension (im, ks:km) :: tk, pa, qv
7205
7206 real(kind_phys), intent (out), dimension (im, ks:km) :: qs
7207
7208 real(kind_phys), intent (out), dimension (im, ks:km), optional :: dqdt
7209
7210 ! -----------------------------------------------------------------------
7211 ! local variables
7212 ! -----------------------------------------------------------------------
7213
7214 integer :: i, k
7215
7216 real(kind_phys) :: dqdt0
7217
7218 if (present (dqdt)) then
7219 do k = ks, km
7220 do i = 1, im
7221 qs(i, k) = mqs(tk(i, k), pa(i, k), qv(i, k), dqdt(i, k))
7222 enddo
7223 enddo
7224 else
7225 do k = ks, km
7226 do i = 1, im
7227 qs(i, k) = mqs(tk(i, k), pa(i, k), qv(i, k), dqdt0)
7228 enddo
7229 enddo
7230 endif
7231
7232end subroutine mqs3d
7233
7234! =======================================================================
7235! compute wet buld temperature, core function
7236! Knox et al. (2017)
7237! =======================================================================
7238
7239function wet_bulb_core (qv, tk, den, lcp)
7240
7241 implicit none
7242
7243 real(kind_phys) :: wet_bulb_core
7244
7245 ! -----------------------------------------------------------------------
7246 ! input / output arguments
7247 ! -----------------------------------------------------------------------
7248
7249 real(kind_phys), intent (in) :: qv, tk, den, lcp
7250
7251 ! -----------------------------------------------------------------------
7252 ! local variables
7253 ! -----------------------------------------------------------------------
7254
7255 logical :: do_adjust = .false.
7256
7257 real(kind_phys) :: factor = 1. / 3.
7258 real(kind_phys) :: qsat, tp, dqdt
7259
7260 wet_bulb_core = tk
7261 qsat = wqs(wet_bulb_core, den, dqdt)
7262 tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp
7263 wet_bulb_core = wet_bulb_core - tp
7264
7265 if (do_adjust .and. tp .gt. 0.0) then
7266 qsat = wqs(wet_bulb_core, den, dqdt)
7267 tp = (qsat - qv) / (1. + lcp * dqdt) * lcp
7268 wet_bulb_core = wet_bulb_core - tp
7269 endif
7270
7271end function wet_bulb_core
7272
7273! =======================================================================
7274! compute wet buld temperature, dry air case
7275! =======================================================================
7276
7277function wet_bulb_dry (qv, tk, den)
7278
7279 implicit none
7280
7281 real(kind_phys) :: wet_bulb_dry
7282
7283 ! -----------------------------------------------------------------------
7284 ! input / output arguments
7285 ! -----------------------------------------------------------------------
7286
7287 real(kind_phys), intent (in) :: qv, tk, den
7288
7289 ! -----------------------------------------------------------------------
7290 ! local variables
7291 ! -----------------------------------------------------------------------
7292
7293 real(kind_phys) :: lcp
7294
7295 lcp = hlv / cp_air
7296
7297 wet_bulb_dry = wet_bulb_core(qv, tk, den, lcp)
7298
7299end function wet_bulb_dry
7300
7301! =======================================================================
7302! compute wet buld temperature, moist air case
7303! =======================================================================
7304
7305function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den)
7306
7307 implicit none
7308
7309 real(kind_phys) :: wet_bulb_moist
7310
7311 ! -----------------------------------------------------------------------
7312 ! input / output arguments
7313 ! -----------------------------------------------------------------------
7314
7315 real(kind_phys), intent (in) :: qv, ql, qi, qr, qs, qg, tk, den
7316
7317 ! -----------------------------------------------------------------------
7318 ! local variables
7319 ! -----------------------------------------------------------------------
7320
7321 real(kind_phys) :: lcp, q_liq, q_sol
7322
7323 real (kind = r8) :: cvm
7324
7325 q_liq = ql + qr
7326 q_sol = qi + qs + qg
7327 cvm = mhc(qv, q_liq, q_sol)
7328 lcp = (lv00 + d1_vap * tk) / cvm
7329
7330 wet_bulb_moist = wet_bulb_core(qv, tk, den, lcp)
7331
7332end function wet_bulb_moist
7333
7334end module gfdl_cloud_microphys_v3_mod
water
subroutine water(parameters, vegtyp, nsnow, nsoil, imelt, dt, uu, vv, fcev, fctr, qprecc, qprecl, elai, esai, sfctmp, qvap, qdew, zsoil, btrani, ficeold, ponding, tg, ist, fveg, iloc, jloc, smceq, bdfall, fp, rain, snow, qsnow, qrain, snowhin, latheav, latheag, frozen_canopy, frozen_ground, isnow, canliq, canice, tv, snowh, sneqv, snice, snliq, stc, zsnso, sh2o, smc, sice, zwt, wa, wt, dzsnso, wslake, smcwtd, deeprech, rech, cmc, ecan, etran, fwet, runsrf, runsub, qin, qdis, ponding1, ponding2, qsnbot, esnow)
compute water budgets (water storages, et components, and runoff)
Definition module_sf_noahmplsm.F90:7047
gfdl_cloud_microphys_v3_mod::iqs
Definition gfdl_cloud_microphys_v3_mod.F90:105
gfdl_cloud_microphys_v3_mod::mhc
Definition gfdl_cloud_microphys_v3_mod.F90:111
gfdl_cloud_microphys_v3_mod::mqs
Definition gfdl_cloud_microphys_v3_mod.F90:99
gfdl_cloud_microphys_v3_mod::wet_bulb
Definition gfdl_cloud_microphys_v3_mod.F90:117
gfdl_cloud_microphys_v3_mod::wqs
Definition gfdl_cloud_microphys_v3_mod.F90:93
gfdl_cloud_microphys_v3_mod
Definition gfdl_cloud_microphys_v3_mod.F90:38
module_gfdlmp_param
Definition module_gfdlmp_param.F90:3