Line data Source code
1 : module micro_pumas_v1
2 : !---------------------------------------------------------------------------------
3 : ! Parameterization of Unified Microphysics Across Scales version 1 (PUMASv1)
4 : !
5 : ! References:
6 : !
7 : ! Gettelman, A., H. Morrison, T. Eidhammer, K. Thayer-Calder, J. Sun,
8 : !
9 : ! R. Forbes, Z. McGraw, J. Zhu, T. Storelvmo, and J. Dennis (2023):
10 : !
11 : ! Importance of Ice Nucleation and Precipitation on Climate with the
12 : !
13 : ! Parameterization of Unified Microphysics Across Scales version 1
14 : !
15 : ! (PUMASv1). Geosci. Model Dev., 16, 1735-1754.
16 : !
17 : ! https://doi.org/10.5194/gmd-16-1735-2023
18 : !
19 : !
20 : ! for questions contact Hugh Morrison, Andrew Gettelman
21 : ! e-mail: morrison@ucar.edu, andrew@ucar.edu
22 : !---------------------------------------------------------------------------------
23 : !
24 : ! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice
25 : ! microphysics in cooperation with the MG liquid microphysics. This is
26 : ! controlled by the do_cldice variable.
27 : !
28 : ! If do_cldice is false, then MG microphysics should not update CLDICE or
29 : ! NUMICE; it is assumed that the other microphysics scheme will have updated
30 : ! CLDICE and NUMICE. The other microphysics should handle the following
31 : ! processes that would have been done by MG:
32 : ! - Detrainment (liquid and ice)
33 : ! - Homogeneous ice nucleation
34 : ! - Heterogeneous ice nucleation
35 : ! - Bergeron process
36 : ! - Melting of ice
37 : ! - Freezing of cloud drops
38 : ! - Autoconversion (ice -> snow)
39 : ! - Growth/Sublimation of ice
40 : ! - Sedimentation of ice
41 : !
42 : ! This option has not been updated since the introduction of prognostic
43 : ! precipitation, and probably should be adjusted to cover snow as well.
44 : !
45 : !---------------------------------------------------------------------------------
46 : ! Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F
47 : !---------------------------------------------------------------------------------
48 : ! Based on micro_mg (restructuring of former cldwat2m_micro)
49 : ! Author: Andrew Gettelman, Hugh Morrison.
50 : ! Contributions from: Xiaohong Liu and Steve Ghan
51 : ! December 2005-May 2010
52 : ! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008)
53 : ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010)
54 : ! for questions contact Hugh Morrison, Andrew Gettelman
55 : ! e-mail: morrison@ucar.edu, andrew@ucar.edu
56 : !---------------------------------------------------------------------------------
57 : ! Code comments added by HM, 093011
58 : ! General code structure:
59 : !
60 : ! Code is divided into two main subroutines:
61 : ! subroutine micro_pumas_init --> initializes microphysics routine, should be called
62 : ! once at start of simulation
63 : ! subroutine micro_pumas_tend --> main microphysics routine to be called each time step
64 : ! this also calls several smaller subroutines to calculate
65 : ! microphysical processes and other utilities
66 : !
67 : ! List of external functions:
68 : ! qsat_water --> for calculating saturation vapor pressure with respect to liquid water
69 : ! qsat_ice --> for calculating saturation vapor pressure with respect to ice
70 : ! gamma --> standard mathematical gamma function
71 : ! .........................................................................
72 : ! List of inputs through use statement in fortran90:
73 : ! Variable Name Description Units
74 : ! .........................................................................
75 : ! gravit acceleration due to gravity m s-2
76 : ! rair dry air gas constant for air J kg-1 K-1
77 : ! tmelt temperature of melting point for water K
78 : ! cpair specific heat at constant pressure for dry air J kg-1 K-1
79 : ! rh2o gas constant for water vapor J kg-1 K-1
80 : ! latvap latent heat of vaporization J kg-1
81 : ! latice latent heat of fusion J kg-1
82 : ! qsat_water external function for calculating liquid water
83 : ! saturation vapor pressure/humidity -
84 : ! qsat_ice external function for calculating ice
85 : ! saturation vapor pressure/humidity pa
86 : ! rhmini relative humidity threshold parameter for
87 : ! nucleating ice -
88 : ! .........................................................................
89 : ! NOTE: List of all inputs/outputs passed through the call/subroutine statement
90 : ! for micro_pumas_tend is given below at the start of subroutine micro_pumas_tend.
91 : !---------------------------------------------------------------------------------
92 :
93 : ! Procedures required:
94 : ! 1) An implementation of the gamma function (if not intrinsic).
95 : ! 2) saturation vapor pressure and specific humidity over water
96 : ! 3) svp over ice
97 :
98 : #ifndef HAVE_GAMMA_INTRINSICS
99 : use shr_spfn_mod, only: gamma => shr_spfn_gamma
100 : #endif
101 :
102 : use wv_sat_methods, only: &
103 : qsat_water => wv_sat_qsat_water_vect, &
104 : qsat_ice => wv_sat_qsat_ice_vect
105 :
106 : ! Parameters from the utilities module.
107 : use micro_pumas_utils, only: &
108 : r8, &
109 : pi, &
110 : omsm, &
111 : qsmall, &
112 : mincld, &
113 : rhosn, &
114 : rhoi, &
115 : rhow, &
116 : rhows, &
117 : ac, bc, &
118 : ai, bi, &
119 : aj, bj, &
120 : ar, br, &
121 : as, bs, &
122 : ag, bg, &
123 : ah, bh, &
124 : rhog,rhoh, &
125 : mi0, &
126 : rising_factorial, &
127 : VLENS
128 :
129 : implicit none
130 : private
131 : save
132 :
133 : public :: &
134 : micro_pumas_init, &
135 : micro_pumas_get_cols, &
136 : micro_pumas_tend
137 :
138 : ! Switches for specification rather than prediction of droplet and crystal number
139 : ! note: number will be adjusted as needed to keep mean size within bounds,
140 : ! even when specified droplet or ice number is used
141 : !
142 : ! If constant cloud ice number is set (nicons = .true.),
143 : ! then all microphysical processes except mass transfer due to ice nucleation
144 : ! (mnuccd) are based on the fixed cloud ice number. Calculation of
145 : ! mnuccd follows from the prognosed ice crystal number ni.
146 :
147 : logical :: nccons ! nccons = .true. to specify constant cloud droplet number
148 : logical :: nicons ! nicons = .true. to specify constant cloud ice number
149 : logical :: ngcons ! ngcons = .true. to specify constant graupel number
150 : logical :: nrcons ! constant rain number
151 : logical :: nscons ! constant snow number
152 :
153 : ! specified ice and droplet number concentrations
154 : ! note: these are local in-cloud values, not grid-mean
155 : real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3)
156 : real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3)
157 : real(r8) :: ngnst ! graupel num concentration when ngcons=.true. (m-3)
158 : real(r8) :: nrnst
159 : real(r8) :: nsnst
160 :
161 : ! IFS Switches....
162 : ! Switch to turn off evaporation of sedimenting condensate
163 : ! Found to interact badly in some models with diagnostic cloud fraction
164 : logical :: evap_sed_off
165 :
166 : ! Remove RH conditional from ice nucleation
167 : logical :: icenuc_rh_off
168 :
169 : ! Internally: Meyers Ice Nucleation
170 : logical :: icenuc_use_meyers
171 :
172 : ! Scale evaporation as IFS does (*0.3)
173 : logical :: evap_scl_ifs
174 :
175 : ! Evap RH threhold following ifs
176 : logical :: evap_rhthrsh_ifs
177 :
178 : ! Rain freezing at 0C following ifs
179 :
180 : logical :: rainfreeze_ifs
181 :
182 : ! Snow sedimentation = 1 m/s
183 :
184 : logical :: ifs_sed
185 :
186 : ! Precipitation fall speed, prevent zero velocity if precip above
187 :
188 : logical :: precip_fall_corr
189 :
190 : !--ag
191 :
192 : !=========================================================
193 : ! Private module parameters
194 : !=========================================================
195 :
196 : !Range of cloudsat reflectivities (dBz) for analytic simulator
197 : real(r8), parameter :: csmin = -30._r8
198 : real(r8), parameter :: csmax = 26._r8
199 : real(r8), parameter :: mindbz = -99._r8
200 : real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8)
201 :
202 : integer, parameter :: MG_PRECIP_FRAC_INCLOUD = 101
203 : integer, parameter :: MG_PRECIP_FRAC_OVERLAP = 102
204 :
205 : ! Reflectivity min for 10cm (Rain) radar reflectivity
206 : real(r8), parameter :: minrefl10 = 1.e-26_r8
207 :
208 : ! autoconversion size threshold for cloud ice to snow (m)
209 : real(r8) :: dcs
210 :
211 : ! minimum mass of new crystal due to freezing of cloud droplets done
212 : ! externally (kg)
213 : real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3
214 :
215 : ! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation.
216 : real(r8), parameter :: sublim_factor =0.0_r8 !number sublimation factor.
217 :
218 : ! Parameters related to GPU computing
219 : integer, parameter :: RQUEUE = 101 ! GPU stream ID for rain
220 : integer, parameter :: SQUEUE = 102 ! GPU stream ID for snow
221 : integer, parameter :: LQUEUE = 103 ! GPU stream ID for liquid
222 : integer, parameter :: IQUEUE = 104 ! GPU stream ID for ice
223 : integer, parameter :: GQUEUE = 105 ! GPU stream ID for hail/graupel
224 :
225 : !=========================================================
226 : ! Constants set in initialization
227 : !=========================================================
228 :
229 : ! Set using arguments to micro_pumas_init
230 : real(r8) :: g ! gravity
231 : real(r8) :: r ! dry air gas constant
232 : real(r8) :: rv ! water vapor gas constant
233 : real(r8) :: cpp ! specific heat of dry air
234 : real(r8) :: tmelt ! freezing point of water (K)
235 :
236 : ! latent heats of:
237 : real(r8) :: xxlv ! vaporization
238 : real(r8) :: xlf ! freezing
239 : real(r8) :: xxls ! sublimation
240 :
241 : real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0.
242 :
243 : ! flags
244 : logical :: microp_uniform
245 : logical :: do_cldice
246 : logical :: use_hetfrz_classnuc
247 : logical :: do_hail
248 : logical :: do_graupel
249 :
250 : real(r8) :: rhosu ! typical 850mn air density
251 :
252 : real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C
253 :
254 : real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C
255 : real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C
256 :
257 : ! additional constants to help speed up code
258 : real(r8) :: gamma_br_plus1
259 : real(r8) :: gamma_br_plus4
260 : real(r8) :: gamma_bs_plus1
261 : real(r8) :: gamma_bs_plus4
262 : real(r8) :: gamma_bi_plus1
263 : real(r8) :: gamma_bi_plus4
264 : real(r8) :: gamma_bj_plus1
265 : real(r8) :: gamma_bj_plus4
266 : real(r8) :: gamma_bg_plus1
267 : real(r8) :: gamma_bg_plus4
268 : real(r8) :: xxlv_squared
269 : real(r8) :: xxls_squared
270 :
271 : character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method
272 : real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor
273 :
274 : real(r8) :: micro_mg_accre_enhan_fact ! accretion enhancment factor
275 : real(r8) :: micro_mg_autocon_fact ! autoconversion prefactor
276 : real(r8) :: micro_mg_autocon_nd_exp ! autoconversion Nd exponent factor
277 : real(r8) :: micro_mg_autocon_lwp_exp !autoconversion LWP exponent
278 : real(r8) :: micro_mg_homog_size ! size of freezing homogeneous ice
279 : real(r8) :: micro_mg_vtrmi_factor
280 : real(r8) :: micro_mg_vtrms_factor
281 : real(r8) :: micro_mg_effi_factor
282 : real(r8) :: micro_mg_iaccr_factor
283 : real(r8) :: micro_mg_max_nicons
284 :
285 : logical :: remove_supersat ! If true, remove supersaturation after sedimentation loop
286 : character(len=16) :: warm_rain ! 'tau','emulated','sb2001' or 'kk2000'
287 :
288 : !Parameters for Implicit Sedimentation Calculation
289 : real(r8), parameter :: vfactor = 1.0 ! Rain/Snow/Graupel Factor
290 : real(r8), parameter :: vfac_drop = 1.0 ! Cloud Liquid Factor
291 : real(r8), parameter :: vfac_ice = 1.0 ! Cloud Ice Factor
292 :
293 : logical :: do_implicit_fall ! = .true.
294 :
295 : logical :: accre_sees_auto != .true.
296 :
297 : !$acc declare create (nccons,nicons,ngcons,nrcons,nscons,ncnst,ninst,ngnst, &
298 : !$acc nrnst,nsnst,evap_sed_off,icenuc_rh_off,evap_scl_ifs, &
299 : !$acc icenuc_use_meyers,evap_rhthrsh_ifs,rainfreeze_ifs, &
300 : !$acc ifs_sed,precip_fall_corr,dcs, &
301 : !$acc g,r,rv,cpp,tmelt,xxlv,xlf,xxls,rhmini,microp_uniform, &
302 : !$acc do_cldice,use_hetfrz_classnuc,do_hail,do_graupel,rhosu, &
303 : !$acc icenuct,snowmelt,rainfrze,xxlv_squared,xxls_squared, &
304 : !$acc gamma_br_plus1,gamma_br_plus4,gamma_bs_plus1, &
305 : !$acc gamma_bs_plus4,gamma_bi_plus1,gamma_bi_plus4, &
306 : !$acc gamma_bj_plus1,gamma_bj_plus4,gamma_bg_plus1, &
307 : !$acc gamma_bg_plus4,micro_mg_berg_eff_factor, &
308 : !$acc micro_mg_accre_enhan_fact,micro_mg_autocon_fact, &
309 : !$acc micro_mg_autocon_nd_exp,micro_mg_autocon_lwp_exp, &
310 : !$acc micro_mg_homog_size,micro_mg_vtrmi_factor, &
311 : !$acc micro_mg_vtrms_factor, &
312 : !$acc micro_mg_effi_factor,micro_mg_iaccr_factor, &
313 : !$acc micro_mg_max_nicons,remove_supersat,do_implicit_fall, &
314 : !$acc accre_sees_auto)
315 :
316 : !===============================================================================
317 : contains
318 : !===============================================================================
319 :
320 1536 : subroutine micro_pumas_init( &
321 : kind, gravit, rair, rh2o, cpair, &
322 : tmelt_in, latvap, latice, &
323 : rhmini_in, micro_mg_dcs, &
324 : micro_mg_do_hail_in,micro_mg_do_graupel_in, &
325 : microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, &
326 0 : micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, &
327 : micro_mg_accre_enhan_fact_in, micro_mg_autocon_fact_in, &
328 : micro_mg_autocon_nd_exp_in, micro_mg_autocon_lwp_exp_in, micro_mg_homog_size_in, &
329 : micro_mg_vtrmi_factor_in, micro_mg_vtrms_factor_in, micro_mg_effi_factor_in, &
330 : micro_mg_iaccr_factor_in, micro_mg_max_nicons_in, &
331 : remove_supersat_in, warm_rain_in, &
332 : micro_mg_evap_sed_off_in, micro_mg_icenuc_rh_off_in, micro_mg_icenuc_use_meyers_in, &
333 : micro_mg_evap_scl_ifs_in, micro_mg_evap_rhthrsh_ifs_in, &
334 : micro_mg_rainfreeze_ifs_in, micro_mg_ifs_sed_in, micro_mg_precip_fall_corr, &
335 : micro_mg_accre_sees_auto_in, micro_mg_implicit_fall_in, &
336 : nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, &
337 : nrcons_in, nrnst_in, nscons_in, nsnst_in, &
338 : stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, &
339 : stochastic_emulated_filename_output_scale, &
340 1536 : iulog, errstring)
341 :
342 : use micro_pumas_utils, only: micro_pumas_utils_init
343 : use pumas_stochastic_collect_tau, only: pumas_stochastic_kernel_init
344 : use tau_neural_net_quantile, only: initialize_tau_emulators
345 :
346 : !-----------------------------------------------------------------------
347 : !
348 : ! Purpose:
349 : ! initialize constants for MG microphysics
350 : !
351 : ! Author: Andrew Gettelman Dec 2005
352 : !
353 : !-----------------------------------------------------------------------
354 :
355 : integer, intent(in) :: kind ! Kind used for reals
356 : real(r8), intent(in) :: gravit
357 : real(r8), intent(in) :: rair
358 : real(r8), intent(in) :: rh2o
359 : real(r8), intent(in) :: cpair
360 : real(r8), intent(in) :: tmelt_in ! Freezing point of water (K)
361 : real(r8), intent(in) :: latvap
362 : real(r8), intent(in) :: latice
363 : real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0.
364 : real(r8), intent(in) :: micro_mg_dcs
365 :
366 : !MG3 dense precipitating ice. Note, only 1 can be true, or both false.
367 : logical, intent(in) :: micro_mg_do_graupel_in ! .true. = configure with graupel
368 : ! .false. = no graupel (hail possible)
369 : logical, intent(in) :: micro_mg_do_hail_in ! .true. = configure with hail
370 : ! .false. = no hail (graupel possible)
371 : logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns
372 : ! .false. = use w/o sub-columns (standard)
373 : logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard)
374 : ! .false. = skip all processes affecting
375 : ! cloud ice
376 : logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing
377 :
378 : character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method
379 : real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor
380 : real(r8), intent(in) :: micro_mg_accre_enhan_fact_in !accretion enhancment factor
381 : real(r8), intent(in) :: micro_mg_autocon_fact_in !autconversion prefactor
382 : real(r8), intent(in) :: micro_mg_autocon_nd_exp_in !autconversion exponent factor
383 : real(r8), intent(in) :: micro_mg_autocon_lwp_exp_in !autconversion exponent factor
384 : real(r8), intent(in) :: micro_mg_homog_size_in ! size of homoegenous freezing ice
385 : real(r8), intent(in) :: micro_mg_vtrmi_factor_in !factor for ice fall velocity
386 : real(r8), intent(in) :: micro_mg_vtrms_factor_in !factor for snow fall velocity
387 : real(r8), intent(in) :: micro_mg_effi_factor_in !factor for ice effective radius
388 : real(r8), intent(in) :: micro_mg_iaccr_factor_in ! ice accretion factor
389 : real(r8), intent(in) :: micro_mg_max_nicons_in ! maximum number ice crystal allowed
390 :
391 : logical, intent(in) :: remove_supersat_in ! If true, remove supersaturation after sedimentation loop
392 : character(len=*), intent(in) :: warm_rain_in
393 :
394 : ! IFS-like Switches
395 :
396 : logical, intent(in) :: micro_mg_evap_sed_off_in ! Turn off evaporation/sublimation based on cloud fraction for sedimenting condensate
397 :
398 : logical, intent(in) :: micro_mg_icenuc_rh_off_in ! Remove RH conditional from ice nucleation
399 : logical, intent(in) :: micro_mg_icenuc_use_meyers_in ! Internally: Meyers Ice Nucleation
400 : logical, intent(in) :: micro_mg_evap_scl_ifs_in ! Scale evaporation as IFS does (*0.3)
401 : logical, intent(in) :: micro_mg_evap_rhthrsh_ifs_in ! Evap RH threhold following ifs
402 : logical, intent(in) :: micro_mg_rainfreeze_ifs_in ! Rain freezing temp following ifs
403 : logical, intent(in) :: micro_mg_ifs_sed_in ! snow sedimentation = 1m/s following ifs
404 : logical, intent(in) :: micro_mg_precip_fall_corr ! ensure rain fall speed non-zero if rain above in column
405 :
406 : logical, intent(in) :: micro_mg_accre_sees_auto_in ! autoconverted rain is passed to accretion
407 :
408 : logical, intent(in) :: micro_mg_implicit_fall_in !Implicit fall speed (sedimentation) calculation for hydrometors
409 :
410 :
411 :
412 : logical, intent(in) :: nccons_in
413 : logical, intent(in) :: nicons_in
414 : real(r8), intent(in) :: ncnst_in
415 : real(r8), intent(in) :: ninst_in
416 :
417 : logical, intent(in) :: ngcons_in
418 : real(r8), intent(in) :: ngnst_in
419 : logical, intent(in) :: nrcons_in
420 : real(r8), intent(in) :: nrnst_in
421 : logical, intent(in) :: nscons_in
422 : real(r8), intent(in) :: nsnst_in
423 :
424 : character(len=*), intent(in) :: stochastic_emulated_filename_quantile, &
425 : stochastic_emulated_filename_input_scale, &
426 : stochastic_emulated_filename_output_scale ! Files for emulated machine learning
427 :
428 : integer, intent(in) :: iulog
429 : character(128), intent(out) :: errstring ! Output status (non-blank for error return)
430 :
431 : !-----------------------------------------------------------------------
432 :
433 1536 : dcs = micro_mg_dcs
434 :
435 : ! Initialize subordinate utilities module.
436 : call micro_pumas_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, &
437 1536 : dcs, errstring)
438 :
439 1536 : if (trim(errstring) /= "") return
440 :
441 : ! declarations for MG code (transforms variable names)
442 :
443 1536 : g= gravit ! gravity
444 1536 : r= rair ! dry air gas constant: note units(phys_constants are in J/K/kmol)
445 1536 : rv= rh2o ! water vapor gas constant
446 1536 : cpp = cpair ! specific heat of dry air
447 1536 : tmelt = tmelt_in
448 1536 : rhmini = rhmini_in
449 1536 : micro_mg_precip_frac_method = micro_mg_precip_frac_method_in
450 1536 : micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in
451 1536 : micro_mg_accre_enhan_fact = micro_mg_accre_enhan_fact_in
452 1536 : micro_mg_autocon_fact = micro_mg_autocon_fact_in
453 1536 : micro_mg_autocon_nd_exp = micro_mg_autocon_nd_exp_in
454 1536 : micro_mg_autocon_lwp_exp = micro_mg_autocon_lwp_exp_in
455 1536 : micro_mg_homog_size = micro_mg_homog_size_in
456 1536 : micro_mg_vtrmi_factor = micro_mg_vtrmi_factor_in
457 1536 : micro_mg_vtrms_factor = micro_mg_vtrms_factor_in
458 1536 : micro_mg_effi_factor = micro_mg_effi_factor_in
459 1536 : micro_mg_iaccr_factor = micro_mg_iaccr_factor_in
460 1536 : micro_mg_max_nicons = micro_mg_max_nicons_in
461 1536 : remove_supersat = remove_supersat_in
462 1536 : warm_rain = warm_rain_in
463 1536 : do_implicit_fall = micro_mg_implicit_fall_in
464 1536 : accre_sees_auto = micro_mg_accre_sees_auto_in
465 :
466 1536 : nccons = nccons_in
467 1536 : nicons = nicons_in
468 1536 : ncnst = ncnst_in
469 1536 : ninst = ninst_in
470 1536 : ngcons = ngcons_in
471 1536 : ngnst = ngnst_in
472 1536 : nscons = nscons_in
473 1536 : nsnst = nsnst_in
474 1536 : nrcons = nrcons_in
475 1536 : nrnst = nrnst_in
476 :
477 : ! latent heats
478 :
479 1536 : xxlv = latvap ! latent heat vaporization
480 1536 : xlf = latice ! latent heat freezing
481 1536 : xxls = xxlv + xlf ! latent heat of sublimation
482 :
483 : ! flags
484 1536 : microp_uniform = microp_uniform_in
485 1536 : do_cldice = do_cldice_in
486 1536 : use_hetfrz_classnuc = use_hetfrz_classnuc_in
487 1536 : do_hail = micro_mg_do_hail_in
488 1536 : do_graupel = micro_mg_do_graupel_in
489 1536 : evap_sed_off = micro_mg_evap_sed_off_in
490 1536 : icenuc_rh_off = micro_mg_icenuc_rh_off_in
491 1536 : icenuc_use_meyers = micro_mg_icenuc_use_meyers_in
492 1536 : evap_scl_ifs = micro_mg_evap_scl_ifs_in
493 1536 : evap_rhthrsh_ifs = micro_mg_evap_rhthrsh_ifs_in
494 1536 : rainfreeze_ifs = micro_mg_rainfreeze_ifs_in
495 1536 : ifs_sed = micro_mg_ifs_sed_in
496 1536 : precip_fall_corr = micro_mg_precip_fall_corr
497 : ! typical air density at 850 mb
498 :
499 1536 : rhosu = 85000._r8/(rair * tmelt)
500 :
501 : ! Maximum temperature at which snow is allowed to exist
502 1536 : snowmelt = tmelt + 2._r8
503 : ! Minimum temperature at which rain is allowed to exist
504 1536 : if (rainfreeze_ifs) then
505 0 : rainfrze = tmelt
506 : else
507 1536 : rainfrze = tmelt - 40._r8
508 : end if
509 :
510 :
511 : ! Ice nucleation temperature
512 1536 : icenuct = tmelt - 5._r8
513 :
514 : ! Define constants to help speed up code (this limits calls to gamma function)
515 1536 : gamma_br_plus1=gamma(1._r8+br)
516 1536 : gamma_br_plus4=gamma(4._r8+br)
517 1536 : gamma_bs_plus1=gamma(1._r8+bs)
518 1536 : gamma_bs_plus4=gamma(4._r8+bs)
519 1536 : gamma_bi_plus1=gamma(1._r8+bi)
520 1536 : gamma_bi_plus4=gamma(4._r8+bi)
521 1536 : gamma_bj_plus1=gamma(1._r8+bj)
522 1536 : gamma_bj_plus4=gamma(4._r8+bj)
523 1536 : gamma_bg_plus1=gamma(1._r8)
524 1536 : gamma_bg_plus4=gamma(4._r8)
525 1536 : if (do_hail) then
526 0 : gamma_bg_plus1 = gamma(1._r8+bh)
527 0 : gamma_bg_plus4 = gamma(4._r8+bh)
528 : end if
529 1536 : if (do_graupel) then
530 1536 : gamma_bg_plus1 = gamma(1._r8+bg)
531 1536 : gamma_bg_plus4 = gamma(4._r8+bg)
532 : end if
533 :
534 1536 : xxlv_squared=xxlv**2
535 1536 : xxls_squared=xxls**2
536 :
537 : !$acc update device (nccons,nicons,ngcons,nrcons,nscons,ncnst,ninst,ngnst, &
538 : !$acc nrnst,nsnst,evap_sed_off,icenuc_rh_off,evap_scl_ifs, &
539 : !$acc icenuc_use_meyers,evap_rhthrsh_ifs,rainfreeze_ifs, &
540 : !$acc ifs_sed,precip_fall_corr,dcs, &
541 : !$acc g,r,rv,cpp,tmelt,xxlv,xlf,xxls,rhmini,microp_uniform, &
542 : !$acc do_cldice,use_hetfrz_classnuc,do_hail,do_graupel,rhosu, &
543 : !$acc icenuct,snowmelt,rainfrze,xxlv_squared,xxls_squared, &
544 : !$acc gamma_br_plus1,gamma_br_plus4,gamma_bs_plus1, &
545 : !$acc gamma_bs_plus4,gamma_bi_plus1,gamma_bi_plus4, &
546 : !$acc gamma_bj_plus1,gamma_bj_plus4,gamma_bg_plus1, &
547 : !$acc gamma_bg_plus4,micro_mg_berg_eff_factor, &
548 : !$acc micro_mg_accre_enhan_fact,micro_mg_autocon_fact, &
549 : !$acc micro_mg_autocon_nd_exp,micro_mg_autocon_lwp_exp, &
550 : !$acc micro_mg_homog_size,micro_mg_vtrmi_factor, &
551 : !$acc micro_mg_vtrms_factor, &
552 : !$acc micro_mg_effi_factor,micro_mg_iaccr_factor, &
553 : !$acc micro_mg_max_nicons,remove_supersat,do_implicit_fall, &
554 : !$acc accre_sees_auto)
555 :
556 1536 : if (trim(warm_rain) == 'emulated') then
557 : call initialize_tau_emulators(stochastic_emulated_filename_quantile, stochastic_emulated_filename_input_scale, &
558 0 : stochastic_emulated_filename_output_scale, iulog, errstring)
559 : end if
560 :
561 3072 : end subroutine micro_pumas_init
562 :
563 : !===============================================================================
564 : !microphysics routine for each timestep goes here...
565 :
566 4467528 : subroutine micro_pumas_tend ( &
567 : mgncol, nlev, deltatin, &
568 4467528 : t, q, &
569 4467528 : qcn, qin, &
570 4467528 : ncn, nin, &
571 4467528 : qrn, qsn, &
572 4467528 : nrn, nsn, &
573 4467528 : qgr, ngr, &
574 8935056 : relvar, accre_enhan, &
575 8935056 : p, pdel, pint, &
576 4467528 : cldn, liqcldf, icecldf, qsatfac, &
577 4467528 : qcsinksum_rate1ord, &
578 4467528 : naai, npccn, &
579 4467528 : rndst, nacon, &
580 4467528 : tlat, qvlat, &
581 4467528 : qctend, qitend, &
582 4467528 : nctend, nitend, &
583 4467528 : qrtend, qstend, &
584 4467528 : nrtend, nstend, &
585 4467528 : qgtend, ngtend, &
586 4467528 : effc, effc_fn, effi, &
587 4467528 : sadice, sadsnow, &
588 4467528 : prect, preci, &
589 4467528 : nevapr, am_evp_st, &
590 4467528 : prain, &
591 4467528 : cmeout, deffi, &
592 4467528 : pgamrad, lamcrad, &
593 4467528 : qsout, dsout, &
594 8935056 : qgout, ngout, dgout, &
595 4467528 : lflx, iflx, &
596 4467528 : gflx, &
597 4467528 : rflx, sflx, qrout, &
598 4467528 : reff_rain, reff_snow, reff_grau, &
599 4467528 : nrout, nsout, &
600 4467528 : refl, arefl, areflz, &
601 4467528 : frefl, csrfl, acsrfl, &
602 4467528 : fcsrfl, refl10cm, reflz10cm, rercld, &
603 4467528 : ncai, ncal, &
604 4467528 : qrout2, qsout2, &
605 4467528 : nrout2, nsout2, &
606 4467528 : drout2, dsout2, &
607 8935056 : qgout2, ngout2, dgout2, freqg, &
608 4467528 : freqs, freqr, &
609 4467528 : nfice, qcrat, &
610 : proc_rates, &
611 0 : errstring, & ! Below arguments are "optional" (pass null pointers to omit).
612 4467528 : tnd_qsnow, tnd_nsnow, re_ice, &
613 4467528 : prer_evap, &
614 4467528 : frzimm, frzcnt, frzdep)
615 :
616 1536 : use pumas_stochastic_collect_tau, only: ncd, pumas_stochastic_collect_tau_tend
617 : use tau_neural_net_quantile, only: tau_emulated_cloud_rain_interactions
618 : use cam_logfile, only: iulog
619 : use ML_fixer_check, only: ML_fixer_calc
620 :
621 : ! Constituent properties.
622 : use micro_pumas_utils, only: &
623 : mg_liq_props, &
624 : mg_ice_props, &
625 : mg_rain_props, &
626 : mg_graupel_props, &
627 : mg_hail_props, &
628 : mg_snow_props
629 :
630 : ! Size calculation functions.
631 : use micro_pumas_utils, only: &
632 : size_dist_param_liq, &
633 : size_dist_param_basic, &
634 : avg_diameter, &
635 : avg_diameter_vec
636 :
637 : ! Microphysical processes.
638 : use micro_pumas_utils, only: &
639 : ice_deposition_sublimation, &
640 : sb2001v2_liq_autoconversion,&
641 : sb2001v2_accre_cld_water_rain,&
642 : kk2000_liq_autoconversion, &
643 : ice_autoconversion, &
644 : immersion_freezing, &
645 : contact_freezing, &
646 : snow_self_aggregation, &
647 : accrete_cloud_water_snow, &
648 : secondary_ice_production, &
649 : accrete_rain_snow, &
650 : heterogeneous_rain_freezing, &
651 : accrete_cloud_water_rain, &
652 : self_collection_rain, &
653 : accrete_cloud_ice_snow, &
654 : evaporate_sublimate_precip, &
655 : bergeron_process_snow, &
656 : graupel_collecting_snow, &
657 : graupel_collecting_rain, &
658 : graupel_collecting_cld_water, &
659 : graupel_riming_liquid_snow, &
660 : graupel_rain_riming_snow, &
661 : graupel_rime_splintering, &
662 : vapor_deposition_onto_snow, &
663 : evaporate_sublimate_precip_graupel
664 :
665 : use micro_pumas_diags, only: proc_rates_type
666 :
667 : !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL
668 : ! e-mail: morrison@ucar.edu, andrew@ucar.edu
669 :
670 : ! input arguments
671 : integer, intent(in) :: mgncol ! number of microphysics columns
672 : integer, intent(in) :: nlev ! number of layers
673 : real(r8), intent(in) :: deltatin ! time step (s)
674 : real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K)
675 : real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg)
676 :
677 : ! note: all input cloud variables are grid-averaged
678 : real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg)
679 : real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg)
680 : real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg)
681 : real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg)
682 :
683 : real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg)
684 : real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg)
685 : real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg)
686 : real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg)
687 : real(r8), intent(in) :: qgr(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg)
688 : real(r8), intent(in) :: ngr(mgncol,nlev) ! graupel/hail number conc (1/kg)
689 :
690 : real(r8), intent(in) :: relvar(mgncol,nlev) ! cloud water relative variance (-)
691 : real(r8), intent(in) :: accre_enhan(mgncol,nlev) ! optional accretion
692 : ! enhancement factor (-)
693 :
694 : real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa)
695 : real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa)
696 : real(r8), intent(in) :: pint(mgncol,nlev+1) ! pressure at interfaces
697 :
698 : real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units)
699 : real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units)
700 : real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units)
701 : real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units)
702 :
703 : ! used for scavenging
704 : ! Inputs for aerosol activation
705 : real(r8), intent(in) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg*s)
706 : real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s)
707 :
708 : ! Note that for these variables, the dust bin is assumed to be the last index.
709 : ! (For example, in CAM, the last dimension is always size 4.)
710 : real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m)
711 : real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3)
712 :
713 : ! output arguments
714 :
715 : real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for
716 : ! direct cw to precip conversion
717 : real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg)
718 : real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s)
719 : real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s)
720 : real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s)
721 : real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s))
722 : real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s))
723 :
724 : real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s)
725 : real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s)
726 : real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s))
727 : real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s))
728 : real(r8), intent(out) :: qgtend(mgncol,nlev) ! microphysical tendency qg (1/s)
729 : real(r8), intent(out) :: ngtend(mgncol,nlev) ! microphysical tendency ng (1/(kg*s))
730 :
731 : real(r8), intent(out) :: effc(mgncol,nlev) ! droplet effective radius (micron)
732 : real(r8), intent(out) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1
733 : real(r8), intent(out) :: effi(mgncol,nlev) ! cloud ice effective radius (micron)
734 : real(r8), intent(out) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3)
735 : real(r8), intent(out) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3)
736 : real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s)
737 : real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s)
738 : real(r8), intent(out) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s)
739 : real(r8), intent(out) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac)
740 : real(r8), intent(out) :: prain(mgncol,nlev) ! production of rain + snow (1/s)
741 : real(r8), intent(out) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s)
742 : real(r8), intent(out) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron)
743 : real(r8), intent(out) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units)
744 : real(r8), intent(out) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m)
745 : real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg)
746 : real(r8), intent(out) :: dsout(mgncol,nlev) ! snow diameter (m)
747 : real(r8), intent(out) :: lflx(mgncol,nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1)
748 : real(r8), intent(out) :: iflx(mgncol,nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1)
749 : real(r8), intent(out) :: rflx(mgncol,nlev+1) ! grid-box average rain flux (kg m^-2 s^-1)
750 : real(r8), intent(out) :: sflx(mgncol,nlev+1) ! grid-box average snow flux (kg m^-2 s^-1)
751 : real(r8), intent(out) :: gflx(mgncol,nlev+1) ! grid-box average graupel/hail flux (kg m^-2 s^-1)
752 :
753 : real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg)
754 : real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron)
755 : real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron)
756 : real(r8), intent(out) :: reff_grau(mgncol,nlev) ! graupel effective radius (micron)
757 :
758 : real(r8), intent(out) :: nrout(mgncol,nlev) ! rain number concentration (1/m3)
759 : real(r8), intent(out) :: nsout(mgncol,nlev) ! snow number concentration (1/m3)
760 : real(r8), intent(out) :: refl(mgncol,nlev) ! analytic radar reflectivity (94GHZ, cloud radar)
761 : real(r8), intent(out) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range
762 : real(r8), intent(out) :: areflz(mgncol,nlev) ! average reflectivity in z.
763 : real(r8), intent(out) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity
764 : real(r8), intent(out) :: csrfl(mgncol,nlev) ! cloudsat reflectivity
765 : real(r8), intent(out) :: acsrfl(mgncol,nlev) ! cloudsat average
766 : real(r8), intent(out) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity
767 : real(r8), intent(out) :: refl10cm(mgncol,nlev) ! 10cm (rain) analytic radar reflectivity
768 : real(r8), intent(out) :: reflz10cm(mgncol,nlev) ! 10cm (rain) analytic radar reflectivity
769 : real(r8), intent(out) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud
770 : real(r8), intent(out) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3)
771 : real(r8), intent(out) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3)
772 : real(r8), intent(out) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2
773 : real(r8), intent(out) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2
774 : real(r8), intent(out) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2
775 : real(r8), intent(out) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2
776 : real(r8), intent(out) :: drout2(mgncol,nlev) ! mean rain particle diameter (m)
777 : real(r8), intent(out) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m)
778 : real(r8), intent(out) :: freqs(mgncol,nlev) ! fractional occurrence of snow
779 : real(r8), intent(out) :: freqr(mgncol,nlev) ! fractional occurrence of rain
780 : real(r8), intent(out) :: nfice(mgncol,nlev) ! fractional occurrence of ice
781 : real(r8), intent(out) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc)
782 : real(r8), intent(out) :: qgout(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg)
783 : real(r8), intent(out) :: dgout(mgncol,nlev) ! graupel/hail diameter (m)
784 : real(r8), intent(out) :: ngout(mgncol,nlev) ! graupel/hail number concentration (1/m3)
785 : real(r8), intent(out) :: qgout2(mgncol,nlev) ! copy of qgout as used to compute dgout2
786 : real(r8), intent(out) :: ngout2(mgncol,nlev) ! copy of ngout as used to compute dgout2
787 : real(r8), intent(out) :: dgout2(mgncol,nlev) ! mean graupel/hail particle diameter (m)
788 : real(r8), intent(out) :: freqg(mgncol,nlev) ! fractional occurrence of graupel
789 :
790 : real(r8), intent(out) :: prer_evap(mgncol,nlev)
791 :
792 : type (proc_rates_type), intent(inout) :: proc_rates
793 :
794 : character(128), intent(out) :: errstring ! output status (non-blank for error return)
795 :
796 : ! Tendencies calculated by external schemes that can replace MG's native
797 : ! process tendencies.
798 :
799 : ! Used with CARMA cirrus microphysics
800 : ! (or similar external microphysics model)
801 : real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s)
802 : real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s)
803 : real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m)
804 :
805 : ! From external ice nucleation.
806 : real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3)
807 : real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3)
808 : real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3)
809 :
810 : ! local workspace
811 : ! all units mks unless otherwise stated
812 :
813 : ! local copies of input variables
814 8935056 : real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg)
815 8935056 : real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg)
816 8935056 : real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg)
817 8935056 : real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg)
818 8935056 : real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg)
819 8935056 : real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg)
820 8935056 : real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg)
821 8935056 : real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg)
822 8935056 : real(r8) :: qg(mgncol,nlev) ! graupel mixing ratio (kg/kg)
823 8935056 : real(r8) :: ng(mgncol,nlev) ! graupel number concentration (1/kg)
824 : real(r8) :: rhogtmp ! hail or graupel density (kg m-3)
825 :
826 : ! general purpose variables
827 : real(r8) :: deltat ! sub-time step (s)
828 : real(r8) :: rdeltat ! reciprocal of sub-time step (1/s)
829 :
830 : ! physical properties of the air at a given point
831 8935056 : real(r8) :: rho(mgncol,nlev) ! density (kg m-3)
832 8935056 : real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor
833 8935056 : real(r8) :: mu(mgncol,nlev) ! viscosity
834 8935056 : real(r8) :: sc(mgncol,nlev) ! schmidt number
835 8935056 : real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed
836 :
837 : ! cloud fractions
838 8935056 : real(r8) :: precip_frac(mgncol,nlev) ! precip fraction assuming maximum overlap
839 8935056 : real(r8) :: cldm(mgncol,nlev) ! cloud fraction
840 8935056 : real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction
841 8935056 : real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction
842 8935056 : real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor
843 :
844 : ! mass mixing ratios
845 8935056 : real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid
846 8935056 : real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice
847 8935056 : real(r8) :: qsic(mgncol,nlev) ! in-precip snow
848 8935056 : real(r8) :: qric(mgncol,nlev) ! in-precip rain
849 8935056 : real(r8) :: qgic(mgncol,nlev) ! in-precip graupel/hail
850 :
851 : ! number concentrations
852 8935056 : real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet
853 8935056 : real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice
854 8935056 : real(r8) :: nsic(mgncol,nlev) ! in-precip snow
855 8935056 : real(r8) :: nric(mgncol,nlev) ! in-precip rain
856 8935056 : real(r8) :: ngic(mgncol,nlev) ! in-precip graupel/hail
857 :
858 : ! Size distribution parameters for:
859 : ! cloud ice
860 8935056 : real(r8) :: lami(mgncol,nlev) ! slope
861 8935056 : real(r8) :: n0i(mgncol,nlev) ! intercept
862 : ! cloud liquid
863 8935056 : real(r8) :: lamc(mgncol,nlev) ! slope
864 8935056 : real(r8) :: pgam(mgncol,nlev) ! spectral width parameter
865 : ! snow
866 8935056 : real(r8) :: lams(mgncol,nlev) ! slope
867 8935056 : real(r8) :: n0s(mgncol,nlev) ! intercept
868 : ! rain
869 8935056 : real(r8) :: lamr(mgncol,nlev) ! slope
870 8935056 : real(r8) :: n0r(mgncol,nlev) ! intercept
871 : ! graupel/hail
872 8935056 : real(r8) :: lamg(mgncol,nlev) ! slope
873 8935056 : real(r8) :: n0g(mgncol,nlev) ! intercept
874 : real(r8) :: bgtmp ! tmp fall speed parameter
875 :
876 : ! Rates/tendencies due to:
877 :
878 : ! Instantaneous snow melting
879 8935056 : real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio
880 8935056 : real(r8) :: ninstsm(mgncol,nlev) ! number concentration
881 : ! Instantaneous graupel melting
882 8935056 : real(r8) :: minstgm(mgncol,nlev) ! mass mixing ratio
883 8935056 : real(r8) :: ninstgm(mgncol,nlev) ! number concentration
884 :
885 : ! Instantaneous rain freezing
886 8935056 : real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio
887 8935056 : real(r8) :: ninstrf(mgncol,nlev) ! number concentration
888 :
889 : ! deposition of cloud ice
890 8935056 : real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12
891 : ! sublimation of cloud ice
892 8935056 : real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12
893 : ! vapor deposition onto
894 8935056 : real(r8) :: vap_deps(mgncol,nlev) ! Vapor deposition onto snow.
895 :
896 : ! ice nucleation
897 8935056 : real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing
898 8935056 : real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio
899 : ! freezing of cloud water
900 8935056 : real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio
901 8935056 : real(r8) :: nnuccc(mgncol,nlev) ! number concentration
902 : ! contact freezing of cloud water
903 8935056 : real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio
904 8935056 : real(r8) :: nnucct(mgncol,nlev) ! number concentration
905 : ! deposition nucleation in mixed-phase clouds (from external scheme)
906 8935056 : real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio
907 8935056 : real(r8) :: nnudep(mgncol,nlev) ! number concentration
908 : ! ice multiplication
909 8935056 : real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio
910 8935056 : real(r8) :: nsacwi(mgncol,nlev) ! number concentration
911 : ! autoconversion of cloud droplets
912 8935056 : real(r8) :: prc(mgncol,nlev) ! mass mixing ratio
913 8935056 : real(r8) :: nprc(mgncol,nlev) ! number concentration (rain)
914 8935056 : real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets)
915 : ! self-aggregation of snow
916 8935056 : real(r8) :: nsagg(mgncol,nlev) ! number concentration
917 : ! self-collection of rain
918 8935056 : real(r8) :: nragg(mgncol,nlev) ! number concentration
919 : ! collection of droplets by snow
920 8935056 : real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio
921 8935056 : real(r8) :: npsacws(mgncol,nlev) ! number concentration
922 : ! collection of rain by snow
923 8935056 : real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio
924 8935056 : real(r8) :: npracs(mgncol,nlev) ! number concentration
925 : ! freezing of rain
926 8935056 : real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio
927 8935056 : real(r8) :: nnuccr(mgncol,nlev) ! number concentration
928 : ! freezing of rain to form ice (mg add 4/26/13)
929 8935056 : real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio
930 8935056 : real(r8) :: nnuccri(mgncol,nlev) ! number concentration
931 : ! accretion of droplets by rain
932 8935056 : real(r8) :: pra(mgncol,nlev) ! mass mixing ratio
933 8935056 : real(r8) :: npra(mgncol,nlev) ! number concentration
934 : ! autoconversion of cloud ice to snow
935 8935056 : real(r8) :: prci(mgncol,nlev) ! mass mixing ratio
936 8935056 : real(r8) :: nprci(mgncol,nlev) ! number concentration
937 : ! accretion of cloud ice by snow
938 8935056 : real(r8) :: prai(mgncol,nlev) ! mass mixing ratio
939 8935056 : real(r8) :: nprai(mgncol,nlev) ! number concentration
940 : ! evaporation of rain
941 8935056 : real(r8) :: pre(mgncol,nlev) ! mass mixing ratio
942 : ! sublimation of snow
943 8935056 : real(r8) :: prds(mgncol,nlev) ! mass mixing ratio
944 : ! number evaporation
945 8935056 : real(r8) :: nsubi(mgncol,nlev) ! cloud ice
946 8935056 : real(r8) :: nsubc(mgncol,nlev) ! droplet
947 8935056 : real(r8) :: nsubs(mgncol,nlev) ! snow
948 8935056 : real(r8) :: nsubr(mgncol,nlev) ! rain
949 : ! bergeron process
950 8935056 : real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice)
951 8935056 : real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow)
952 :
953 : !graupel/hail processes
954 8935056 : real(r8) :: npracg(mgncol,nlev) ! change n collection rain by graupel (precipf)
955 8935056 : real(r8) :: nscng(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm)
956 8935056 : real(r8) :: ngracs(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf)
957 8935056 : real(r8) :: nmultg(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm)
958 8935056 : real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel (precipf)
959 8935056 : real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm)
960 :
961 8935056 : real(r8) :: psacr(mgncol,nlev) ! conversion due to coll of snow by rain (precipf)
962 8935056 : real(r8) :: pracg(mgncol,nlev) ! change in q collection rain by graupel (precipf)
963 8935056 : real(r8) :: psacwg(mgncol,nlev) ! change in q collection droplets by graupel (lcldm)
964 8935056 : real(r8) :: pgsacw(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm)
965 8935056 : real(r8) :: pgracs(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf)
966 8935056 : real(r8) :: prdg(mgncol,nlev) ! dep of graupel (precipf)
967 8935056 : real(r8) :: qmultg(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm)
968 8935056 : real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf)
969 :
970 :
971 : ! fallspeeds
972 : ! number-weighted
973 8935056 : real(r8) :: uns(mgncol,nlev) ! snow
974 8935056 : real(r8) :: unr(mgncol,nlev) ! rain
975 8935056 : real(r8) :: ung(mgncol,nlev) ! graupel/hail
976 :
977 : ! air density corrected fallspeed parameters
978 8935056 : real(r8) :: arn(mgncol,nlev) ! rain
979 8935056 : real(r8) :: asn(mgncol,nlev) ! snow
980 8935056 : real(r8) :: agn(mgncol,nlev) ! graupel
981 8935056 : real(r8) :: acn(mgncol,nlev) ! cloud droplet
982 8935056 : real(r8) :: ain(mgncol,nlev) ! cloud ice
983 8935056 : real(r8) :: ajn(mgncol,nlev) ! cloud small ice
984 :
985 : ! Mass of liquid droplets used with external heterogeneous freezing.
986 8935056 : real(r8) :: mi0l(mgncol,nlev)
987 :
988 : ! saturation vapor pressures
989 8935056 : real(r8) :: esl(mgncol,nlev) ! liquid
990 8935056 : real(r8) :: esi(mgncol,nlev) ! ice
991 8935056 : real(r8) :: esnA(mgncol,nlev) ! checking for RH after rain evap
992 :
993 : ! saturation vapor mixing ratios
994 8935056 : real(r8) :: qvl(mgncol,nlev) ! liquid
995 8935056 : real(r8) :: qvi(mgncol,nlev) ! ice
996 8935056 : real(r8) :: qvnA(mgncol,nlev), qvnAI(mgncol,nlev) ! checking for RH after rain evap
997 :
998 : ! relative humidity
999 8935056 : real(r8) :: relhum(mgncol,nlev)
1000 :
1001 : ! parameters for cloud water and cloud ice sedimentation calculations
1002 8935056 : real(r8) :: fc(mgncol,nlev)
1003 8935056 : real(r8) :: fnc(mgncol,nlev)
1004 8935056 : real(r8) :: fi(mgncol,nlev)
1005 8935056 : real(r8) :: fni(mgncol,nlev)
1006 8935056 : real(r8) :: fg(mgncol,nlev)
1007 8935056 : real(r8) :: fng(mgncol,nlev)
1008 8935056 : real(r8) :: fr(mgncol,nlev)
1009 8935056 : real(r8) :: fnr(mgncol,nlev)
1010 8935056 : real(r8) :: fs(mgncol,nlev)
1011 8935056 : real(r8) :: fns(mgncol,nlev)
1012 :
1013 : real(r8) :: rthrsh ! rain rate threshold for reflectivity calculation
1014 :
1015 : ! dummy variables
1016 : real(r8) :: dum, dum1, dum2, dum3, dum4, qtmp
1017 8935056 : real(r8) :: dum1A(mgncol,nlev), dum2A(mgncol,nlev), dum3A(mgncol,nlev)
1018 8935056 : real(r8) :: dumni0, dumni0A2D(mgncol,nlev)
1019 8935056 : real(r8) :: dumns0, dumns0A2D(mgncol,nlev)
1020 : ! dummies for checking RH
1021 8935056 : real(r8) :: ttmpA(mgncol,nlev), qtmpAI(mgncol,nlev)
1022 : ! dummies for conservation check
1023 : real(r8) :: ratio, tmpnr,tmpp
1024 : real(r8) :: tmpfrz
1025 : ! dummies for in-cloud variables
1026 8935056 : real(r8) :: dumc(mgncol,nlev) ! qc
1027 8935056 : real(r8) :: dumnc(mgncol,nlev) ! nc
1028 8935056 : real(r8) :: dumi(mgncol,nlev) ! qi
1029 8935056 : real(r8) :: dumni(mgncol,nlev) ! ni
1030 8935056 : real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio
1031 8935056 : real(r8) :: dumnr(mgncol,nlev) ! rain number concentration
1032 8935056 : real(r8) :: dums(mgncol,nlev) ! snow mixing ratio
1033 8935056 : real(r8) :: dumns(mgncol,nlev) ! snow number concentration
1034 8935056 : real(r8) :: dumg(mgncol,nlev) ! graupel mixing ratio
1035 8935056 : real(r8) :: dumng(mgncol,nlev) ! graupel number concentration
1036 : ! Array dummy variable
1037 8935056 : real(r8) :: dum_2D(mgncol,nlev)
1038 8935056 : real(r8) :: pdel_inv(mgncol,nlev)
1039 :
1040 : ! loop array variables
1041 : ! "i" and "k" are column/level iterators for internal (MG) variables
1042 : ! "n" is used for other looping (currently just sedimentation)
1043 : integer i, k, n
1044 :
1045 : integer mdust
1046 : integer :: precip_frac_method
1047 :
1048 : ! Varaibles to scale fall velocity between small and regular ice regimes.
1049 : real(r8) :: irad
1050 : real(r8) :: ifrac
1051 :
1052 : !Variables for accretion seeing autoconverted liquid
1053 8935056 : real(r8) :: rtmp(mgncol,nlev) ! dummy for rain + autoconversion
1054 8935056 : real(r8) :: ctmp(mgncol,nlev) ! dummy for liq - autoconversion
1055 8935056 : real(r8) :: ntmp(mgncol,nlev) ! dummy for liq - autoconversion number
1056 :
1057 : ! Variables for height calculation (used in Implicit Fall Speed)
1058 8935056 : real(r8) :: zint(mgncol,nlev+1) ! interface height
1059 : real(r8) :: H !Scale height
1060 :
1061 : ! temporary local variables for asynchronous GPU run
1062 : ! ice
1063 8935056 : real(r8) :: prect_i(mgncol)
1064 8935056 : real(r8) :: tlat_i(mgncol,nlev)
1065 8935056 : real(r8) :: qvlat_i(mgncol,nlev)
1066 8935056 : real(r8) :: preci_i(mgncol)
1067 : ! liq
1068 8935056 : real(r8) :: prect_l(mgncol)
1069 8935056 : real(r8) :: tlat_l(mgncol,nlev)
1070 8935056 : real(r8) :: qvlat_l(mgncol,nlev)
1071 : ! rain
1072 8935056 : real(r8) :: prect_r(mgncol)
1073 : ! snow
1074 8935056 : real(r8) :: prect_s(mgncol)
1075 8935056 : real(r8) :: preci_s(mgncol)
1076 : ! graupel
1077 8935056 : real(r8) :: prect_g(mgncol)
1078 8935056 : real(r8) :: preci_g(mgncol)
1079 :
1080 : ! number of sub-steps for loops over "n" (for sedimentation)
1081 : ! ice
1082 8935056 : integer nstep_i(mgncol)
1083 8935056 : real(r8) :: rnstep_i(mgncol)
1084 : ! liq
1085 8935056 : integer nstep_l(mgncol)
1086 8935056 : real(r8) :: rnstep_l(mgncol)
1087 : ! rain
1088 8935056 : integer nstep_r(mgncol)
1089 8935056 : real(r8) :: rnstep_r(mgncol)
1090 : ! snow
1091 8935056 : integer nstep_s(mgncol)
1092 8935056 : real(r8) :: rnstep_s(mgncol)
1093 : ! graupel
1094 8935056 : integer nstep_g(mgncol)
1095 4467528 : real(r8) :: rnstep_g(mgncol)
1096 :
1097 : !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
1098 :
1099 : ! Initialize scale height (H) for interface height calculation
1100 : ! needed for Implicit Fall Speed
1101 4467528 : H=0._r8
1102 :
1103 : ! Return error message
1104 4467528 : errstring = ' '
1105 :
1106 : ! Process inputs
1107 :
1108 : ! assign variable deltat to deltatin
1109 4467528 : deltat = deltatin
1110 4467528 : rdeltat = 1._r8 / deltat
1111 :
1112 4467528 : if (trim(micro_mg_precip_frac_method) == 'in_cloud') then
1113 : precip_frac_method = MG_PRECIP_FRAC_INCLOUD
1114 0 : else if(trim(micro_mg_precip_frac_method) == 'max_overlap') then
1115 : precip_frac_method = MG_PRECIP_FRAC_OVERLAP
1116 : endif
1117 :
1118 : !......................................................................
1119 : ! graupel/hail density set (Hail = 400, Graupel = 500 from M2005)
1120 4467528 : bgtmp=0._r8
1121 4467528 : rhogtmp=0._r8
1122 4467528 : if (do_hail) then
1123 0 : bgtmp = bh
1124 0 : rhogtmp = rhoh
1125 : end if
1126 4467528 : if (do_graupel) then
1127 4467528 : bgtmp = bg
1128 4467528 : rhogtmp = rhog
1129 : end if
1130 :
1131 : ! set mdust as the number of dust bins for use later in contact freezing subroutine
1132 4467528 : mdust = size(rndst,3)
1133 :
1134 : !$acc data copyin (t,q,qcn,qin,ncn,nin,qrn,qsn,nrn,nsn,qgr,ngr,relvar, &
1135 : !$acc accre_enhan,p,pdel,pint,cldn,liqcldf,icecldf,qsatfac, &
1136 : !$acc naai,npccn,rndst,nacon,tnd_qsnow,tnd_nsnow,re_ice, &
1137 : !$acc frzimm,frzcnt,frzdep,mg_liq_props,mg_ice_props, &
1138 : !$acc mg_rain_props,mg_graupel_props,mg_hail_props, &
1139 : !$acc mg_snow_props,proc_rates) &
1140 : !$acc copyout (qcsinksum_rate1ord,tlat,qvlat,qctend,qitend,nctend, &
1141 : !$acc nitend,qrtend,qstend,nrtend,nstend,qgtend,ngtend, &
1142 : !$acc effc,effc_fn,effi,sadice,sadsnow,prect,preci, &
1143 : !$acc nevapr,proc_rates%evapsnow,am_evp_st,prain, &
1144 : !$acc proc_rates%prodsnow,cmeout, &
1145 : !$acc deffi,pgamrad,lamcrad,qsout,dsout,lflx,iflx,rflx, &
1146 : !$acc sflx,gflx,qrout,reff_rain,reff_snow,reff_grau, &
1147 : !$acc proc_rates%qcsevap,proc_rates%qisevap,proc_rates%qvres, &
1148 : !$acc proc_rates%cmeitot,proc_rates%vtrmc,proc_rates%vtrmi, &
1149 : !$acc proc_rates%umr,proc_rates%ums, &
1150 : !$acc proc_rates%umg,proc_rates%qgsedten,proc_rates%qcsedten, &
1151 : !$acc proc_rates%qisedten,proc_rates%qrsedten, &
1152 : !$acc proc_rates%qssedten,proc_rates%pratot, &
1153 : !$acc proc_rates%prctot,proc_rates%mnuccctot, &
1154 : !$acc proc_rates%mnuccttot,proc_rates%msacwitot, &
1155 : !$acc proc_rates%psacwstot,proc_rates%bergstot, &
1156 : !$acc proc_rates%vapdepstot,proc_rates%bergtot, &
1157 : !$acc proc_rates%melttot,proc_rates%meltstot, &
1158 : !$acc proc_rates%meltgtot,proc_rates%mnudeptot, &
1159 : !$acc proc_rates%homotot, &
1160 : !$acc proc_rates%qcrestot,proc_rates%prcitot, &
1161 : !$acc proc_rates%praitot,proc_rates%qirestot, &
1162 : !$acc proc_rates%mnuccrtot,proc_rates%mnuccritot, &
1163 : !$acc proc_rates%pracstot,proc_rates%meltsdttot, &
1164 : !$acc proc_rates%frzrdttot,proc_rates%mnuccdtot, &
1165 : !$acc proc_rates%pracgtot,proc_rates%psacwgtot, &
1166 : !$acc proc_rates%pgsacwtot,proc_rates%pgracstot, &
1167 : !$acc proc_rates%prdgtot,proc_rates%qmultgtot, &
1168 : !$acc proc_rates%qmultrgtot,proc_rates%psacrtot, &
1169 : !$acc proc_rates%npracgtot,proc_rates%nscngtot, &
1170 : !$acc proc_rates%ngracstot,proc_rates%nmultgtot, &
1171 : !$acc proc_rates%nmultrgtot,proc_rates%npsacwgtot, &
1172 : !$acc nrout,nsout,refl,arefl, &
1173 : !$acc areflz,frefl,csrfl,acsrfl,fcsrfl,refl10cm,reflz10cm, &
1174 : !$acc rercld,ncai,ncal,qrout2,qsout2,nrout2,nsout2,drout2, &
1175 : !$acc dsout2,freqs,freqr,nfice,qcrat,qgout,dgout,ngout, &
1176 : !$acc qgout2,ngout2,dgout2,freqg,prer_evap, &
1177 : !$acc proc_rates%nnuccctot,proc_rates%nnuccttot, &
1178 : !$acc proc_rates%nnuccdtot,proc_rates%nnudeptot, &
1179 : !$acc proc_rates%nhomotot,proc_rates%nnuccrtot, &
1180 : !$acc proc_rates%nnuccritot,proc_rates%nsacwitot, &
1181 : !$acc proc_rates%npratot,proc_rates%npsacwstot, &
1182 : !$acc proc_rates%npraitot,proc_rates%npracstot, &
1183 : !$acc proc_rates%nprctot,proc_rates%nprcitot, &
1184 : !$acc proc_rates%ncsedten,proc_rates%nisedten, &
1185 : !$acc proc_rates%nrsedten,proc_rates%nssedten, &
1186 : !$acc proc_rates%ngsedten,proc_rates%nmelttot, &
1187 : !$acc proc_rates%nmeltstot,proc_rates%nmeltgtot, &
1188 : !$acc proc_rates%nraggtot,proc_rates%scale_qc, &
1189 : !$acc proc_rates%scale_nc,proc_rates%scale_qr, &
1190 : !$acc proc_rates%scale_nr,proc_rates%amk_c,proc_rates%ank_c, &
1191 : !$acc proc_rates%amk_r,proc_rates%ank_r,proc_rates%amk, &
1192 : !$acc proc_rates%ank,proc_rates%amk_out,proc_rates%ank_out, &
1193 : !$acc proc_rates%qc_out_TAU,proc_rates%nc_out_TAU, &
1194 : !$acc proc_rates%qr_out_TAU,proc_rates%nr_out_TAU, &
1195 : !$acc proc_rates%qc_in_TAU,proc_rates%nc_in_TAU, &
1196 : !$acc proc_rates%qr_in_TAU,proc_rates%nr_in_TAU, &
1197 : !$acc proc_rates%lamc_out,proc_rates%lamr_out, &
1198 : !$acc proc_rates%pgam_out,proc_rates%n0r_out, &
1199 : !$acc proc_rates%qctend_KK2000,proc_rates%nctend_KK2000, &
1200 : !$acc proc_rates%qrtend_KK2000,proc_rates%nrtend_KK2000, &
1201 : !$acc proc_rates%qctend_SB2001,proc_rates%nctend_SB2001, &
1202 : !$acc proc_rates%qrtend_SB2001,proc_rates%nrtend_SB2001, &
1203 : !$acc proc_rates%qctend_TAU,proc_rates%nctend_TAU, &
1204 : !$acc proc_rates%qrtend_TAU,proc_rates%nrtend_TAU, &
1205 : !$acc proc_rates%gmnnn_lmnnn_TAU) &
1206 : !$acc create (qc,qi,nc,ni,qr,qs,nr,ns,qg,ng,rho,dv,mu,sc,rhof, &
1207 : !$acc precip_frac,cldm,icldm,lcldm,qsfm,qcic,qiic,qsic,qric, &
1208 : !$acc qgic,ncic,niic,nsic,nric,ngic,lami,n0i,lamc,pgam,lams, &
1209 : !$acc n0s,lamr,n0r,lamg,n0g,minstsm,ninstsm,minstgm,ninstgm, &
1210 : !$acc minstrf,ninstrf,vap_dep,ice_sublim,vap_deps,nnuccd, &
1211 : !$acc mnuccd,mnuccc,nnuccc,mnucct,nnucct,mnudep,nnudep, &
1212 : !$acc msacwi,nsacwi,prc,nprc,nprc1,nsagg,nragg,psacws, &
1213 : !$acc npsacws,pracs,npracs,mnuccr,nnuccr,mnuccri,nnuccri,pra, &
1214 : !$acc npra,prci,nprci,prai,nprai,pre,prds,nsubi,nsubc,nsubs, &
1215 : !$acc nsubr,berg,bergs,npracg,nscng,ngracs,nmultg,nmultrg, &
1216 : !$acc npsacwg,psacr,pracg,psacwg,pgsacw,pgracs,prdg,qmultg, &
1217 : !$acc qmultrg,uns,unr,ung,arn,asn,agn,acn,ain,ajn,mi0l,esl, &
1218 : !$acc esi,esnA,qvl,qvi,qvnA,qvnAI,relhum,fc,fnc,fi,fni,fg, &
1219 : !$acc fng,fr,fnr,fs,fns,dum1A,dum2A,dum3A,dumni0A2D, &
1220 : !$acc dumns0A2D,ttmpA,qtmpAI,dumc,dumnc,dumi,dumni,dumr, &
1221 : !$acc dumnr,dums,dumns,dumg,dumng,dum_2D,pdel_inv,rtmp,ctmp, &
1222 : !$acc ntmp,zint,nstep_i,rnstep_i,nstep_l,rnstep_l,nstep_r, &
1223 : !$acc rnstep_r,nstep_s,rnstep_s,nstep_g,rnstep_g,prect_i, &
1224 : !$acc tlat_i,qvlat_i,preci_i,prect_l,tlat_l,qvlat_l,prect_r, &
1225 : !$acc prect_s,preci_s,prect_g,preci_g)
1226 :
1227 : ! Copies of input concentrations that may be changed internally.
1228 :
1229 : !$acc parallel vector_length(VLENS) default(present)
1230 : !$acc loop gang vector collapse(2)
1231 379739880 : do k = 1,nlev
1232 6270643080 : do i = 1,mgncol
1233 5890903200 : qc(i,k) = qcn(i,k)
1234 5890903200 : nc(i,k) = ncn(i,k)
1235 5890903200 : qi(i,k) = qin(i,k)
1236 5890903200 : ni(i,k) = nin(i,k)
1237 5890903200 : qr(i,k) = qrn(i,k)
1238 5890903200 : nr(i,k) = nrn(i,k)
1239 5890903200 : qs(i,k) = qsn(i,k)
1240 5890903200 : ns(i,k) = nsn(i,k)
1241 5890903200 : qg(i,k) = qgr(i,k)
1242 6266175552 : ng(i,k) = ngr(i,k)
1243 : end do
1244 : end do
1245 : !$acc end parallel
1246 :
1247 : ! cldn: used to set cldm, unused for subcolumns
1248 : ! liqcldf: used to set lcldm, unused for subcolumns
1249 : ! icecldf: used to set icldm, unused for subcolumns
1250 :
1251 4467528 : if (microp_uniform) then
1252 : ! subcolumns, set cloud fraction variables to one
1253 : ! if cloud water or ice is present, if not present
1254 : ! set to mincld (mincld used instead of zero, to prevent
1255 : ! possible division by zero errors).
1256 :
1257 : !$acc parallel vector_length(VLENS) default(present)
1258 : !$acc loop gang vector collapse(2)
1259 0 : do k=1,nlev
1260 0 : do i=1,mgncol
1261 0 : if (qc(i,k) >= qsmall) then
1262 0 : lcldm(i,k) = 1._r8
1263 : else
1264 0 : lcldm(i,k) = mincld
1265 : end if
1266 :
1267 0 : if (qi(i,k) >= qsmall) then
1268 0 : icldm(i,k) = 1._r8
1269 : else
1270 0 : icldm(i,k) = mincld
1271 : end if
1272 :
1273 0 : cldm(i,k) = max(icldm(i,k), lcldm(i,k))
1274 0 : qsfm(i,k) = 1._r8
1275 : end do
1276 : end do
1277 : !$acc end parallel
1278 : else
1279 : ! get cloud fraction, check for minimum
1280 :
1281 : !$acc parallel vector_length(VLENS) default(present)
1282 : !$acc loop gang vector collapse(2)
1283 379739880 : do k=1,nlev
1284 6270643080 : do i=1,mgncol
1285 5890903200 : cldm(i,k) = max(cldn(i,k),mincld)
1286 5890903200 : lcldm(i,k) = max(liqcldf(i,k),mincld)
1287 5890903200 : icldm(i,k) = max(icecldf(i,k),mincld)
1288 6266175552 : qsfm(i,k) = qsatfac(i,k)
1289 : end do
1290 : end do
1291 : !$acc end parallel
1292 : end if
1293 :
1294 : ! Initialize local variables
1295 :
1296 : ! local physical properties
1297 :
1298 : !$acc parallel vector_length(VLENS) default(present)
1299 : !$acc loop gang vector collapse(2)
1300 379739880 : do k=1,nlev
1301 6270643080 : do i=1,mgncol
1302 5890903200 : rho(i,k) = p(i,k)/(r*t(i,k))
1303 5890903200 : dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k)
1304 5890903200 : mu(i,k) = 1.496E-6_r8 * t(i,k)**1.5_r8 / (t(i,k) + 120._r8)
1305 5890903200 : sc(i,k) = mu(i,k)/(rho(i,k)*dv(i,k))
1306 :
1307 : ! air density adjustment for fallspeed parameters
1308 : ! includes air density correction factor to the
1309 : ! power of 0.54 following Heymsfield and Bansemer 2007
1310 :
1311 5890903200 : rhof(i,k)=(rhosu/rho(i,k))**0.54_r8
1312 :
1313 5890903200 : arn(i,k)=ar*rhof(i,k)
1314 5890903200 : asn(i,k)=as*rhof(i,k)
1315 : ! Hail use ah*rhof graupel use ag*rhof
1316 : ! Note that do_hail and do_graupel can't both be true
1317 5890903200 : if (do_hail) then
1318 0 : agn(i,k) = ah*rhof(i,k)
1319 : end if
1320 5890903200 : if (do_graupel) then
1321 5890903200 : agn(i,k) = ag*rhof(i,k)
1322 : end if
1323 5890903200 : acn(i,k)=g*rhow/(18._r8*mu(i,k))
1324 5890903200 : ain(i,k)=ai*(rhosu/rho(i,k))**0.35_r8
1325 6266175552 : ajn(i,k)=aj*(rhosu/rho(i,k))**0.35_r8
1326 : end do
1327 : end do
1328 : !$acc end parallel
1329 :
1330 : !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
1331 : ! Get humidity and saturation vapor pressures
1332 :
1333 4467528 : call qsat_water(t, p, esl, qvl, mgncol*nlev)
1334 4467528 : call qsat_ice(t, p, esi, qvi, mgncol*nlev)
1335 :
1336 : !$acc parallel vector_length(VLENS) default(present)
1337 : !$acc loop gang vector collapse(2)
1338 379739880 : do k=1,nlev
1339 6270643080 : do i=1,mgncol
1340 : ! make sure when above freezing that esi=esl, not active yet
1341 5890903200 : if (t(i,k) >= tmelt) then
1342 1123427798 : esi(i,k)=esl(i,k)
1343 1123427798 : qvi(i,k)=qvl(i,k)
1344 : else
1345 : ! Scale the water saturation values to reflect subgrid scale
1346 : ! ice cloud fraction, where ice clouds begin forming at a
1347 : ! gridbox average relative humidity of rhmini (not 1).
1348 : !
1349 : ! NOTE: For subcolumns and other non-subgrid clouds, qsfm willi
1350 : ! be 1.
1351 4767475402 : qvi(i,k) = qsfm(i,k) * qvi(i,k)
1352 4767475402 : esi(i,k) = qsfm(i,k) * esi(i,k)
1353 4767475402 : qvl(i,k) = qsfm(i,k) * qvl(i,k)
1354 4767475402 : esl(i,k) = qsfm(i,k) * esl(i,k)
1355 : end if
1356 :
1357 6266175552 : relhum(i,k) = q(i,k) / max(qvl(i,k), qsmall)
1358 :
1359 : end do
1360 : end do
1361 : !$acc end parallel
1362 :
1363 : ! initialize microphysics output
1364 :
1365 : !$acc parallel vector_length(VLENS) default(present)
1366 : !$acc loop gang vector collapse(2)
1367 379739880 : do k=1,nlev
1368 6270643080 : do i=1,mgncol
1369 5890903200 : proc_rates%qcsevap(i,k) = 0._r8
1370 5890903200 : proc_rates%qisevap(i,k) = 0._r8
1371 5890903200 : proc_rates%qvres(i,k) = 0._r8
1372 5890903200 : proc_rates%cmeitot(i,k) = 0._r8
1373 5890903200 : proc_rates%vtrmc(i,k) = 0._r8
1374 5890903200 : proc_rates%vtrmi(i,k) = 0._r8
1375 5890903200 : proc_rates%qcsedten(i,k) = 0._r8
1376 5890903200 : proc_rates%qisedten(i,k) = 0._r8
1377 5890903200 : proc_rates%qrsedten(i,k) = 0._r8
1378 5890903200 : proc_rates%qssedten(i,k) = 0._r8
1379 5890903200 : proc_rates%qgsedten(i,k) = 0._r8
1380 :
1381 5890903200 : proc_rates%pratot(i,k) = 0._r8
1382 5890903200 : proc_rates%prctot(i,k) = 0._r8
1383 5890903200 : proc_rates%mnuccctot(i,k) = 0._r8
1384 5890903200 : proc_rates%mnuccttot(i,k) = 0._r8
1385 5890903200 : proc_rates%msacwitot(i,k) = 0._r8
1386 5890903200 : proc_rates%psacwstot(i,k) = 0._r8
1387 5890903200 : proc_rates%bergstot(i,k) = 0._r8
1388 5890903200 : proc_rates%vapdepstot(i,k) = 0._r8
1389 5890903200 : proc_rates%bergtot(i,k) = 0._r8
1390 5890903200 : proc_rates%melttot(i,k) = 0._r8
1391 :
1392 5890903200 : proc_rates%mnudeptot(i,k) = 0._r8
1393 5890903200 : proc_rates%meltstot(i,k) = 0._r8
1394 5890903200 : proc_rates%meltgtot(i,k) = 0._r8
1395 5890903200 : proc_rates%homotot(i,k) = 0._r8
1396 5890903200 : proc_rates%qcrestot(i,k) = 0._r8
1397 5890903200 : proc_rates%prcitot(i,k) = 0._r8
1398 5890903200 : proc_rates%praitot(i,k) = 0._r8
1399 5890903200 : proc_rates%qirestot(i,k) = 0._r8
1400 5890903200 : proc_rates%mnuccrtot(i,k) = 0._r8
1401 5890903200 : proc_rates%mnuccritot(i,k) = 0._r8
1402 5890903200 : proc_rates%pracstot(i,k) = 0._r8
1403 5890903200 : proc_rates%meltsdttot(i,k) = 0._r8
1404 5890903200 : proc_rates%frzrdttot(i,k) = 0._r8
1405 5890903200 : proc_rates%mnuccdtot(i,k) = 0._r8
1406 5890903200 : proc_rates%psacrtot(i,k) = 0._r8
1407 5890903200 : proc_rates%pracgtot(i,k) = 0._r8
1408 5890903200 : proc_rates%psacwgtot(i,k) = 0._r8
1409 5890903200 : proc_rates%pgsacwtot(i,k) = 0._r8
1410 5890903200 : proc_rates%pgracstot(i,k) = 0._r8
1411 5890903200 : proc_rates%prdgtot(i,k) = 0._r8
1412 5890903200 : proc_rates%qmultgtot(i,k) = 0._r8
1413 5890903200 : proc_rates%qmultrgtot(i,k) = 0._r8
1414 5890903200 : proc_rates%npracgtot(i,k) = 0._r8
1415 5890903200 : proc_rates%nscngtot(i,k) = 0._r8
1416 5890903200 : proc_rates%ngracstot(i,k) = 0._r8
1417 5890903200 : proc_rates%nmultgtot(i,k) = 0._r8
1418 5890903200 : proc_rates%nmultrgtot(i,k) = 0._r8
1419 5890903200 : proc_rates%npsacwgtot(i,k) = 0._r8
1420 :
1421 5890903200 : proc_rates%nnuccctot(i,k) = 0._r8
1422 5890903200 : proc_rates%nnuccttot(i,k) = 0._r8
1423 5890903200 : proc_rates%nnuccdtot(i,k) = 0._r8
1424 5890903200 : proc_rates%nnudeptot(i,k) = 0._r8
1425 5890903200 : proc_rates%nhomotot(i,k) = 0._r8
1426 5890903200 : proc_rates%nnuccrtot(i,k) = 0._r8
1427 5890903200 : proc_rates%nnuccritot(i,k) = 0._r8
1428 5890903200 : proc_rates%nsacwitot(i,k) = 0._r8
1429 5890903200 : proc_rates%npratot(i,k) = 0._r8
1430 5890903200 : proc_rates%npsacwstot(i,k) = 0._r8
1431 5890903200 : proc_rates%npraitot(i,k) = 0._r8
1432 5890903200 : proc_rates%npracstot(i,k) = 0._r8
1433 5890903200 : proc_rates%nprctot(i,k) = 0._r8
1434 5890903200 : proc_rates%nraggtot(i,k) = 0._r8
1435 5890903200 : proc_rates%nprcitot(i,k) = 0._r8
1436 5890903200 : proc_rates%ncsedten(i,k) = 0._r8
1437 5890903200 : proc_rates%nisedten(i,k) = 0._r8
1438 5890903200 : proc_rates%nrsedten(i,k) = 0._r8
1439 5890903200 : proc_rates%nssedten(i,k) = 0._r8
1440 5890903200 : proc_rates%ngsedten(i,k) = 0._r8
1441 5890903200 : proc_rates%nmelttot(i,k) = 0._r8
1442 5890903200 : proc_rates%nmeltstot(i,k) = 0._r8
1443 5890903200 : proc_rates%nmeltgtot(i,k) = 0._r8
1444 :
1445 : !need to zero these out to be totally switchable (for conservation)
1446 5890903200 : psacr(i,k) = 0._r8
1447 5890903200 : pracg(i,k) = 0._r8
1448 5890903200 : psacwg(i,k) = 0._r8
1449 5890903200 : pgsacw(i,k) = 0._r8
1450 5890903200 : pgracs(i,k) = 0._r8
1451 5890903200 : prdg(i,k) = 0._r8
1452 5890903200 : qmultg(i,k) = 0._r8
1453 5890903200 : qmultrg(i,k) = 0._r8
1454 5890903200 : npracg(i,k) = 0._r8
1455 5890903200 : nscng(i,k) = 0._r8
1456 5890903200 : ngracs(i,k) = 0._r8
1457 5890903200 : nmultg(i,k) = 0._r8
1458 5890903200 : nmultrg(i,k) = 0._r8
1459 5890903200 : npsacwg(i,k) = 0._r8
1460 5890903200 : prc(i,k) = 0._r8
1461 5890903200 : nprc(i,k) = 0._r8
1462 5890903200 : nprc1(i,k) = 0._r8
1463 5890903200 : pra(i,k) = 0._r8
1464 6266175552 : npra(i,k) = 0._r8
1465 : end do
1466 : end do
1467 : !$acc end parallel
1468 :
1469 : !$acc parallel vector_length(VLENS) default(present)
1470 : !$acc loop gang vector collapse(2)
1471 384207408 : do k=1,nlev+1
1472 6345240408 : do i=1,mgncol
1473 5961033000 : rflx(i,k) = 0._r8
1474 5961033000 : sflx(i,k) = 0._r8
1475 5961033000 : lflx(i,k) = 0._r8
1476 5961033000 : iflx(i,k) = 0._r8
1477 5961033000 : gflx(i,k) = 0._r8
1478 6340772880 : zint(i,k) = 0._r8
1479 : end do
1480 : end do
1481 : !$acc end parallel
1482 :
1483 : ! initialize precip at surface
1484 :
1485 : !$acc parallel vector_length(VLENS) default(present)
1486 : !$acc loop gang vector
1487 74597328 : do i=1,mgncol
1488 70129800 : prect(i) = 0._r8
1489 70129800 : preci(i) = 0._r8
1490 70129800 : prect_i(i) = 0._r8
1491 70129800 : preci_i(i) = 0._r8
1492 70129800 : prect_l(i) = 0._r8
1493 70129800 : prect_r(i) = 0._r8
1494 70129800 : prect_s(i) = 0._r8
1495 70129800 : preci_s(i) = 0._r8
1496 70129800 : prect_g(i) = 0._r8
1497 74597328 : preci_g(i) = 0._r8
1498 : end do
1499 : !$acc end parallel
1500 :
1501 : !$acc parallel vector_length(VLENS) default(present)
1502 : !$acc loop gang vector collapse(2)
1503 379739880 : do k=1,nlev
1504 6270643080 : do i=1,mgncol
1505 : ! initialize precip output
1506 5890903200 : qrout(i,k) = 0._r8
1507 5890903200 : qsout(i,k) = 0._r8
1508 5890903200 : nrout(i,k) = 0._r8
1509 5890903200 : nsout(i,k) = 0._r8
1510 5890903200 : qgout(i,k) = 0._r8
1511 5890903200 : ngout(i,k) = 0._r8
1512 :
1513 : ! initialize rain size
1514 5890903200 : rercld(i,k) = 0._r8
1515 :
1516 5890903200 : qcsinksum_rate1ord(i,k) = 0._r8
1517 :
1518 : ! initialize variables for trop_mozart
1519 5890903200 : nevapr(i,k) = 0._r8
1520 5890903200 : prer_evap(i,k) = 0._r8
1521 5890903200 : proc_rates%evapsnow(i,k) = 0._r8
1522 5890903200 : am_evp_st(i,k) = 0._r8
1523 5890903200 : prain(i,k) = 0._r8
1524 5890903200 : proc_rates%prodsnow(i,k) = 0._r8
1525 5890903200 : cmeout(i,k) = 0._r8
1526 :
1527 5890903200 : precip_frac(i,k) = mincld
1528 5890903200 : lamc(i,k) = 0._r8
1529 5890903200 : lamg(i,k) = 0._r8
1530 :
1531 : ! Interim variables for accretion
1532 5890903200 : rtmp(i,k) = 0._r8
1533 5890903200 : ctmp(i,k) = 0._r8
1534 5890903200 : ntmp(i,k) = 0._r8
1535 :
1536 : ! initialize microphysical tendencies
1537 5890903200 : tlat(i,k) = 0._r8
1538 5890903200 : qvlat(i,k) = 0._r8
1539 5890903200 : qctend(i,k) = 0._r8
1540 5890903200 : qitend(i,k) = 0._r8
1541 5890903200 : qstend(i,k) = 0._r8
1542 5890903200 : qrtend(i,k) = 0._r8
1543 5890903200 : nctend(i,k) = 0._r8
1544 5890903200 : nitend(i,k) = 0._r8
1545 5890903200 : nrtend(i,k) = 0._r8
1546 5890903200 : nstend(i,k) = 0._r8
1547 5890903200 : qgtend(i,k) = 0._r8
1548 5890903200 : ngtend(i,k) = 0._r8
1549 :
1550 : ! initialize in-cloud and in-precip quantities to zero
1551 5890903200 : qcic(i,k) = 0._r8
1552 5890903200 : qiic(i,k) = 0._r8
1553 5890903200 : qsic(i,k) = 0._r8
1554 5890903200 : qric(i,k) = 0._r8
1555 5890903200 : qgic(i,k) = 0._r8
1556 :
1557 5890903200 : ncic(i,k) = 0._r8
1558 5890903200 : niic(i,k) = 0._r8
1559 5890903200 : nsic(i,k) = 0._r8
1560 5890903200 : nric(i,k) = 0._r8
1561 6266175552 : ngic(i,k) = 0._r8
1562 : end do
1563 : end do
1564 : !$acc end parallel
1565 :
1566 : !$acc parallel vector_length(VLENS) default(present)
1567 : !$acc loop gang vector collapse(2)
1568 379739880 : do k=1,nlev
1569 6270643080 : do i=1,mgncol
1570 : ! initialize vapor_deposition
1571 5890903200 : vap_dep(i,k) = 0._r8
1572 5890903200 : vap_deps(i,k) = 0._r8
1573 :
1574 : ! initialize precip fallspeeds to zero
1575 5890903200 : proc_rates%ums(i,k) = 0._r8
1576 5890903200 : uns(i,k) = 0._r8
1577 5890903200 : proc_rates%umr(i,k) = 0._r8
1578 5890903200 : unr(i,k) = 0._r8
1579 5890903200 : proc_rates%umg(i,k) = 0._r8
1580 5890903200 : ung(i,k) = 0._r8
1581 :
1582 : ! initialize limiter for output
1583 5890903200 : qcrat(i,k) = 1._r8
1584 :
1585 : ! Many outputs have to be initialized here at the top to work around
1586 : ! ifort problems, even if they are always overwritten later.
1587 5890903200 : effc(i,k) = 10._r8
1588 5890903200 : lamcrad(i,k) = 0._r8
1589 5890903200 : pgamrad(i,k) = 0._r8
1590 5890903200 : effc_fn(i,k) = 10._r8
1591 5890903200 : effi(i,k) = 25._r8
1592 5890903200 : effi(i,k) = effi(i,k)*micro_mg_effi_factor
1593 5890903200 : sadice(i,k) = 0._r8
1594 5890903200 : sadsnow(i,k) = 0._r8
1595 5890903200 : deffi(i,k) = 50._r8
1596 :
1597 5890903200 : qrout2(i,k) = 0._r8
1598 5890903200 : nrout2(i,k) = 0._r8
1599 5890903200 : drout2(i,k) = 0._r8
1600 5890903200 : qsout2(i,k) = 0._r8
1601 5890903200 : nsout2(i,k) = 0._r8
1602 5890903200 : dsout(i,k) = 0._r8
1603 5890903200 : dsout2(i,k) = 0._r8
1604 5890903200 : qgout2(i,k) = 0._r8
1605 5890903200 : ngout2(i,k) = 0._r8
1606 5890903200 : freqg(i,k) = 0._r8
1607 5890903200 : freqr(i,k) = 0._r8
1608 5890903200 : freqs(i,k) = 0._r8
1609 :
1610 5890903200 : reff_rain(i,k) = 0._r8
1611 5890903200 : reff_snow(i,k) = 0._r8
1612 5890903200 : reff_grau(i,k) = 0._r8
1613 :
1614 5890903200 : refl(i,k) = -9999._r8
1615 5890903200 : arefl(i,k) = 0._r8
1616 5890903200 : areflz(i,k) = 0._r8
1617 5890903200 : frefl(i,k) = 0._r8
1618 5890903200 : csrfl(i,k) = 0._r8
1619 5890903200 : acsrfl(i,k) = 0._r8
1620 5890903200 : fcsrfl(i,k) = 0._r8
1621 :
1622 5890903200 : refl10cm(i,k) = -9999._r8
1623 5890903200 : reflz10cm(i,k) = 0._r8
1624 :
1625 5890903200 : ncal(i,k) = 0._r8
1626 5890903200 : ncai(i,k) = 0._r8
1627 5890903200 : nfice(i,k) = 0._r8
1628 :
1629 5890903200 : pdel_inv(i,k) = 1._r8/pdel(i,k)
1630 5890903200 : tlat_i(i,k) = 0._r8
1631 5890903200 : qvlat_i(i,k) = 0._r8
1632 5890903200 : tlat_l(i,k) = 0._r8
1633 5890903200 : qvlat_l(i,k) = 0._r8
1634 :
1635 5890903200 : nnudep(i,k) = 0._r8
1636 5890903200 : mnudep(i,k) = 0._r8
1637 5890903200 : nragg(i,k) = 0._r8
1638 :
1639 5890903200 : proc_rates%qctend_KK2000(i,k) = 0._r8
1640 5890903200 : proc_rates%nctend_KK2000(i,k) = 0._r8
1641 5890903200 : proc_rates%qrtend_KK2000(i,k) = 0._r8
1642 5890903200 : proc_rates%nrtend_KK2000(i,k) = 0._r8
1643 5890903200 : proc_rates%lamc_out(i,k) = 0._r8
1644 5890903200 : proc_rates%lamr_out(i,k) = 0._r8
1645 5890903200 : proc_rates%pgam_out(i,k) = 0._r8
1646 6266175552 : proc_rates%n0r_out(i,k) = 0._r8
1647 : end do
1648 : end do
1649 : !$acc end parallel
1650 :
1651 4467528 : if (trim(warm_rain) == 'sb2001') then
1652 : !$acc parallel vector_length(VLENS) default(present)
1653 : !$acc loop gang vector collapse(2)
1654 0 : do k=1,nlev
1655 0 : do i=1,mgncol
1656 0 : proc_rates%qctend_SB2001(i,k) = 0._r8
1657 0 : proc_rates%nctend_SB2001(i,k) = 0._r8
1658 0 : proc_rates%qrtend_SB2001(i,k) = 0._r8
1659 0 : proc_rates%nrtend_SB2001(i,k) = 0._r8
1660 : end do
1661 : end do
1662 : !$acc end parallel
1663 : end if
1664 :
1665 4467528 : if (trim(warm_rain) == 'tau' .or. trim(warm_rain) == 'emulated') then
1666 : !$acc parallel vector_length(VLENS) default(present)
1667 : !$acc loop gang vector collapse(2)
1668 0 : do k=1,nlev
1669 0 : do i=1,mgncol
1670 0 : proc_rates%qctend_TAU(i,k) = 0._r8
1671 0 : proc_rates%nctend_TAU(i,k) = 0._r8
1672 0 : proc_rates%qrtend_TAU(i,k) = 0._r8
1673 0 : proc_rates%nrtend_TAU(i,k) = 0._r8
1674 0 : proc_rates%qc_out_TAU(i,k) = 0._r8
1675 0 : proc_rates%nc_out_TAU(i,k) = 0._r8
1676 0 : proc_rates%qr_out_TAU(i,k) = 0._r8
1677 0 : proc_rates%nr_out_TAU(i,k) = 0._r8
1678 0 : proc_rates%qc_in_TAU(i,k) = 0._r8
1679 0 : proc_rates%nc_in_TAU(i,k) = 0._r8
1680 0 : proc_rates%qr_in_TAU(i,k) = 0._r8
1681 0 : proc_rates%nr_in_TAU(i,k) = 0._r8
1682 0 : proc_rates%gmnnn_lmnnn_TAU(i,k) = 0._r8
1683 : end do
1684 : end do
1685 : !$acc end parallel
1686 : end if
1687 :
1688 : !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
1689 : ! droplet activation
1690 : ! get provisional droplet number after activation. This is used for
1691 : ! all microphysical process calculations, for consistency with update of
1692 : ! droplet mass before microphysics
1693 :
1694 : ! calculate potential for droplet activation if cloud water is present
1695 : ! tendency from activation (npccn) is read in from companion routine
1696 :
1697 : ! output activated liquid and ice (convert from #/kg -> #/m3)
1698 : !--------------------------------------------------
1699 :
1700 : !$acc parallel vector_length(VLENS) default(present)
1701 : !$acc loop gang vector collapse(2)
1702 379739880 : do k=1,nlev
1703 6270643080 : do i=1,mgncol
1704 5890903200 : if (qc(i,k) >= qsmall) then
1705 512413729 : nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, 0._r8)
1706 512413729 : ncal(i,k) = npccn(i,k)
1707 : else
1708 5378489471 : ncal(i,k) = 0._r8
1709 : end if
1710 :
1711 5890903200 : if (t(i,k) < icenuct) then
1712 4574163907 : ncai(i,k) = naai(i,k)*deltat*rho(i,k)
1713 : else
1714 1316739293 : ncai(i,k) = 0._r8
1715 : end if
1716 :
1717 : !===============================================
1718 :
1719 : ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5%
1720 : !
1721 : ! NOTE: If using gridbox average values, condensation will not occur until rh=1,
1722 : ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid
1723 : ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus
1724 : ! the nucleation threshold should also be 1.05 and not rhmini + 0.05.
1725 : !-------------------------------------------------------
1726 :
1727 6266175552 : if (do_cldice) then
1728 5890903200 : if (icenuc_rh_off) then
1729 0 : if (naai(i,k) > 0._r8 .and. t(i,k) < icenuct) then
1730 : !if NAAI > 0. then set numice = naai (as before)
1731 : !note: this is gridbox averaged
1732 0 : nnuccd(i,k) = naai(i,k)*icldm(i,k)
1733 0 : nnuccd(i,k) = max(nnuccd(i,k),0._r8)
1734 :
1735 : !Calc mass of new particles using new crystal mass...
1736 : !also this will be multiplied by mtime as nnuccd is...
1737 0 : mnuccd(i,k) = nnuccd(i,k) * mi0
1738 : else
1739 0 : nnuccd(i,k) = 0._r8
1740 0 : mnuccd(i,k) = 0._r8
1741 : end if
1742 : else
1743 5890903200 : if (naai(i,k) > 0._r8 .and. t(i,k) < icenuct .and. &
1744 : relhum(i,k)*esl(i,k)/esi(i,k) > 1.05_r8) then
1745 : !if NAAI > 0. then set numice = naai (as before)
1746 : !note: this is gridbox averaged
1747 136479667 : nnuccd(i,k) = naai(i,k)*icldm(i,k)
1748 136479667 : nnuccd(i,k) = max(nnuccd(i,k),0._r8)
1749 :
1750 : !Calc mass of new particles using new crystal mass...
1751 : !also this will be multiplied by mtime as nnuccd is...
1752 136479667 : mnuccd(i,k) = nnuccd(i,k) * mi0
1753 : else
1754 5754423533 : nnuccd(i,k) = 0._r8
1755 5754423533 : mnuccd(i,k) = 0._r8
1756 : end if
1757 : end if
1758 : end if
1759 : end do
1760 : end do
1761 : !$acc end parallel
1762 :
1763 : !=============================================================================
1764 :
1765 : !$acc parallel vector_length(VLENS) default(present)
1766 : !$acc loop gang vector collapse(2)
1767 379739880 : do k=1,nlev
1768 6270643080 : do i=1,mgncol
1769 : ! calculate instantaneous precip processes (melting and homogeneous freezing)
1770 : ! melting of snow at +2 C
1771 5890903200 : if (t(i,k) > snowmelt) then
1772 1042844582 : if (qs(i,k) > 0._r8) then
1773 : ! make sure melting snow doesn't reduce temperature below threshold
1774 1042844450 : dum = -xlf/cpp*qs(i,k)
1775 1042844450 : if (t(i,k)+dum < snowmelt) then
1776 417972 : dum = (t(i,k)-snowmelt)*cpp/xlf
1777 417972 : dum = dum/qs(i,k)
1778 417972 : dum = max(0._r8,dum)
1779 417972 : dum = min(1._r8,dum)
1780 : else
1781 : dum = 1._r8
1782 : end if
1783 :
1784 1042844450 : minstsm(i,k) = dum*qs(i,k)
1785 1042844450 : ninstsm(i,k) = dum*ns(i,k)
1786 :
1787 1042844450 : dum1=-xlf*minstsm(i,k)*rdeltat
1788 1042844450 : tlat(i,k)=tlat(i,k)+dum1
1789 1042844450 : proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
1790 1042844450 : proc_rates%meltstot(i,k)=minstsm(i,k)*rdeltat
1791 :
1792 1042844450 : qs(i,k) = max(qs(i,k) - minstsm(i,k), 0._r8)
1793 1042844450 : ns(i,k) = max(ns(i,k) - ninstsm(i,k), 0._r8)
1794 1042844450 : qr(i,k) = max(qr(i,k) + minstsm(i,k), 0._r8)
1795 1042844450 : nr(i,k) = max(nr(i,k) + ninstsm(i,k), 0._r8)
1796 : end if
1797 : end if
1798 :
1799 : ! melting of graupel at +2 C
1800 :
1801 5890903200 : if (t(i,k) > snowmelt) then
1802 1042844582 : if (qg(i,k) > 0._r8) then
1803 :
1804 : ! make sure melting graupel doesn't reduce temperature below threshold
1805 1042844453 : dum = -xlf/cpp*qg(i,k)
1806 1042844453 : if (t(i,k)+dum < snowmelt) then
1807 176077 : dum = (t(i,k)-snowmelt)*cpp/xlf
1808 176077 : dum = dum/qg(i,k)
1809 176077 : dum = max(0._r8,dum)
1810 176077 : dum = min(1._r8,dum)
1811 : else
1812 : dum = 1._r8
1813 : end if
1814 :
1815 1042844453 : minstgm(i,k) = dum*qg(i,k)
1816 1042844453 : ninstgm(i,k) = dum*ng(i,k)
1817 :
1818 1042844453 : dum1=-xlf*minstgm(i,k)*rdeltat
1819 1042844453 : tlat(i,k)=tlat(i,k)+dum1
1820 1042844453 : proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
1821 1042844453 : proc_rates%meltgtot(i,k)=minstgm(i,k)*rdeltat
1822 :
1823 1042844453 : qg(i,k) = max(qg(i,k) - minstgm(i,k), 0._r8)
1824 1042844453 : ng(i,k) = max(ng(i,k) - ninstgm(i,k), 0._r8)
1825 1042844453 : qr(i,k) = max(qr(i,k) + minstgm(i,k), 0._r8)
1826 1042844453 : nr(i,k) = max(nr(i,k) + ninstgm(i,k), 0._r8)
1827 : end if
1828 : end if
1829 :
1830 : ! freezing of rain at -5 C
1831 :
1832 6266175552 : if (t(i,k) < rainfrze) then
1833 :
1834 3233807170 : if (qr(i,k) > 0._r8) then
1835 :
1836 : ! make sure freezing rain doesn't increase temperature above threshold
1837 3233228109 : dum = xlf/cpp*qr(i,k)
1838 3233228109 : if (t(i,k)+dum > rainfrze) then
1839 7 : dum = -(t(i,k)-rainfrze)*cpp/xlf
1840 7 : dum = dum/qr(i,k)
1841 7 : dum = max(0._r8,dum)
1842 7 : dum = min(1._r8,dum)
1843 : else
1844 : dum = 1._r8
1845 : end if
1846 :
1847 3233228109 : minstrf(i,k) = dum*qr(i,k)
1848 3233228109 : ninstrf(i,k) = dum*nr(i,k)
1849 :
1850 : ! heating tendency
1851 3233228109 : dum1 = xlf*minstrf(i,k)*rdeltat
1852 3233228109 : tlat(i,k)=tlat(i,k)+dum1
1853 3233228109 : proc_rates%frzrdttot(i,k)=proc_rates%frzrdttot(i,k) + dum1
1854 :
1855 3233228109 : qr(i,k) = max(qr(i,k) - minstrf(i,k), 0._r8)
1856 3233228109 : nr(i,k) = max(nr(i,k) - ninstrf(i,k), 0._r8)
1857 :
1858 : ! freeze rain to graupel not snow.
1859 3233228109 : if(do_hail.or.do_graupel) then
1860 3233228109 : qg(i,k) = max(qg(i,k) + minstrf(i,k), 0._r8)
1861 3233228109 : ng(i,k) = max(ng(i,k) + ninstrf(i,k), 0._r8)
1862 : else
1863 0 : qs(i,k) = max(qs(i,k) + minstrf(i,k), 0._r8)
1864 0 : ns(i,k) = max(ns(i,k) + ninstrf(i,k), 0._r8)
1865 : end if
1866 : end if
1867 : end if
1868 : end do
1869 : end do
1870 : !$acc end parallel
1871 :
1872 : !$acc parallel vector_length(VLENS) default(present)
1873 : !$acc loop gang vector collapse(2)
1874 379739880 : do k=1,nlev
1875 6270643080 : do i=1,mgncol
1876 : ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations
1877 : !-------------------------------------------------------
1878 : ! for microphysical process calculations
1879 : ! units are kg/kg for mixing ratio, 1/kg for number conc
1880 :
1881 5890903200 : if (qc(i,k).ge.qsmall) then
1882 : ! limit in-cloud values to 0.005 kg/kg
1883 512413729 : qcic(i,k)=min(qc(i,k)/lcldm(i,k),5.e-3_r8)
1884 512413729 : ncic(i,k)=max(nc(i,k)/lcldm(i,k),0._r8)
1885 :
1886 : ! specify droplet concentration
1887 512413729 : if (nccons) then
1888 0 : ncic(i,k)=ncnst/rho(i,k)
1889 : end if
1890 : else
1891 5378489471 : qcic(i,k)=0._r8
1892 5378489471 : ncic(i,k)=0._r8
1893 : end if
1894 :
1895 5890903200 : if (qi(i,k).ge.qsmall) then
1896 : ! limit in-cloud values to 0.005 kg/kg
1897 1341873208 : qiic(i,k)=min(qi(i,k)/icldm(i,k),5.e-3_r8)
1898 1341873208 : niic(i,k)=max(ni(i,k)/icldm(i,k),0._r8)
1899 :
1900 : ! switch for specification of cloud ice number
1901 1341873208 : if (nicons) then
1902 0 : niic(i,k)=ninst/rho(i,k)
1903 : end if
1904 : else
1905 4549029992 : qiic(i,k)=0._r8
1906 4549029992 : niic(i,k)=0._r8
1907 : end if
1908 :
1909 : !========================================================================
1910 :
1911 : ! for sub-columns cldm has already been set to 1 if cloud
1912 : ! water or ice is present, so precip_frac will be correctly set below
1913 : ! and nothing extra needs to be done here
1914 :
1915 6266175552 : precip_frac(i,k) = cldm(i,k)
1916 : end do
1917 : end do
1918 : !$acc end parallel
1919 :
1920 4467528 : if (precip_frac_method == MG_PRECIP_FRAC_INCLOUD) then
1921 : !$acc parallel vector_length(VLENS) default(present)
1922 : !$acc loop gang vector
1923 74597328 : do i=1,mgncol
1924 : !$acc loop seq
1925 5895370728 : do k=2,nlev
1926 5890903200 : if (qc(i,k) < qsmall .and. qi(i,k) < qsmall) then
1927 4161758578 : precip_frac(i,k) = precip_frac(i,k-1)
1928 : end if
1929 : end do
1930 : end do
1931 : !$acc end parallel
1932 0 : else if (precip_frac_method == MG_PRECIP_FRAC_OVERLAP) then
1933 : ! calculate precip fraction based on maximum overlap assumption
1934 :
1935 : ! if rain or snow mix ratios are smaller than threshold,
1936 : ! then leave precip_frac as cloud fraction at current level
1937 :
1938 : !$acc parallel vector_length(VLENS) default(present)
1939 : !$acc loop gang vector
1940 0 : do i=1,mgncol
1941 : !$acc loop seq
1942 0 : do k=2,nlev
1943 0 : if (qr(i,k-1) >= qsmall .or. qs(i,k-1) >= qsmall .or. qg(i,k-1) >= qsmall) then
1944 0 : precip_frac(i,k)=max(precip_frac(i,k-1),precip_frac(i,k))
1945 : end if
1946 : end do
1947 : end do
1948 : !$acc end parallel
1949 : end if
1950 :
1951 : !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
1952 : ! get size distribution parameters based on in-cloud cloud water
1953 : ! these calculations also ensure consistency between number and mixing ratio
1954 : !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
1955 :
1956 : ! cloud liquid
1957 : !-------------------------------------------
1958 4467528 : call size_dist_param_liq(mg_liq_props, qcic, ncic, rho, pgam, lamc, mgncol, nlev)
1959 :
1960 :
1961 : !$acc parallel vector_length(VLENS) default(present)
1962 : !$acc loop gang vector collapse(2)
1963 379739880 : do k=1,nlev
1964 6270643080 : do i=1,mgncol
1965 : ! assign qric based on prognostic qr, using assumed precip fraction
1966 : ! note: this could be moved above for consistency with qcic and qiic calculations
1967 5890903200 : qric(i,k) = qr(i,k)/precip_frac(i,k)
1968 5890903200 : nric(i,k) = nr(i,k)/precip_frac(i,k)
1969 :
1970 : ! limit in-precip mixing ratios to 10 g/kg
1971 5890903200 : qric(i,k)=min(qric(i,k),0.01_r8)
1972 :
1973 : ! add autoconversion to precip from above to get provisional rain mixing ratio
1974 : ! and number concentration (qric and nric)
1975 :
1976 5890903200 : if (qric(i,k).lt.qsmall) then
1977 4455952799 : qric(i,k)=0._r8
1978 4455952799 : nric(i,k)=0._r8
1979 : end if
1980 :
1981 : ! make sure number concentration is a positive number to avoid
1982 : ! taking root of negative later
1983 :
1984 6266175552 : nric(i,k)=max(nric(i,k),0._r8)
1985 : end do
1986 : end do
1987 : !$acc end parallel
1988 :
1989 : ! get size distribution parameters for rain
1990 : !......................................................................
1991 :
1992 4467528 : call size_dist_param_basic(mg_rain_props, qric, nric, lamr, mgncol, nlev, n0=n0r)
1993 :
1994 : ! Save off size distribution parameters for output
1995 : !$acc parallel vector_length(VLENS) default(present)
1996 : !$acc loop gang vector collapse(2)
1997 379739880 : do k=1,nlev
1998 6270643080 : do i=1,mgncol
1999 5890903200 : proc_rates%pgam_out(i,k)=pgam(i,k)
2000 5890903200 : proc_rates%n0r_out(i,k)=n0r(i,k)
2001 5890903200 : proc_rates%lamc_out(i,k)=lamc(i,k)
2002 6266175552 : proc_rates%lamr_out(i,k)=lamr(i,k)
2003 : end do
2004 : end do
2005 : !$acc end parallel
2006 :
2007 : !========================================================================
2008 : ! autoconversion of cloud liquid water to rain
2009 : ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc
2010 : ! minimum qc of 1 x 10^-8 prevents floating point error
2011 :
2012 : call kk2000_liq_autoconversion(microp_uniform, qcic, ncic, rho, relvar, &
2013 : proc_rates%qctend_KK2000, proc_rates%nrtend_KK2000, &
2014 : proc_rates%nctend_KK2000, micro_mg_autocon_fact, &
2015 : micro_mg_autocon_nd_exp, micro_mg_autocon_lwp_exp, &
2016 4467528 : mgncol*nlev)
2017 :
2018 : ! Write to pumas tendency arrays if kk2000 is active, otherwise just record diagnostics
2019 :
2020 4467528 : if ( trim(warm_rain) == 'kk2000' ) then
2021 : !$acc parallel vector_length(VLENS) default(present)
2022 : !$acc loop gang vector collapse(2)
2023 379739880 : do k=1,nlev
2024 6270643080 : do i=1,mgncol
2025 5890903200 : prc(i,k)=proc_rates%qctend_KK2000(i,k)
2026 5890903200 : nprc1(i,k)=proc_rates%nctend_KK2000(i,k)
2027 5890903200 : nprc(i,k)=proc_rates%nrtend_KK2000(i,k)
2028 6266175552 : proc_rates%qrtend_KK2000(i,k)=-proc_rates%qctend_KK2000(i,k)
2029 : end do
2030 : end do
2031 : !$acc end parallel
2032 : end if
2033 :
2034 4467528 : if ( trim(warm_rain) == 'tau' ) then
2035 : call pumas_stochastic_collect_tau_tend(deltatin,t,rho,qcn,qrn,qcic,ncic,qric, &
2036 : nric,lcldm,precip_frac,pgam,lamc,n0r,lamr, &
2037 : proc_rates%qc_out_TAU,proc_rates%nc_out_TAU, &
2038 : proc_rates%qr_out_TAU,proc_rates%nr_out_TAU, &
2039 : qctend,nctend,qrtend,nrtend, &
2040 : proc_rates%qctend_TAU,proc_rates%nctend_TAU, &
2041 : proc_rates%qrtend_TAU,proc_rates%nrtend_TAU, &
2042 : proc_rates%scale_qc,proc_rates%scale_nc, &
2043 : proc_rates%scale_qr,proc_rates%scale_nr, &
2044 : proc_rates%amk_c,proc_rates%ank_c, &
2045 : proc_rates%amk_r,proc_rates%ank_r, &
2046 : proc_rates%amk, proc_rates%ank, &
2047 : proc_rates%amk_out, proc_rates%ank_out, &
2048 0 : proc_rates%gmnnn_lmnnn_TAU,mgncol,nlev)
2049 :
2050 : !$acc parallel vector_length(VLENS) default(present)
2051 : !$acc loop gang vector collapse(2)
2052 0 : do k=1,nlev
2053 0 : do i=1,mgncol
2054 0 : proc_rates%qc_in_TAU(i,k)=qcic(i,k)
2055 0 : proc_rates%nc_in_TAU(i,k)=ncic(i,k)
2056 0 : proc_rates%qr_in_TAU(i,k)=qric(i,k)
2057 0 : proc_rates%nr_in_TAU(i,k)=nric(i,k)
2058 : ! PUMAS expects prc and nprc1 (cloud rates) are positive
2059 0 : prc(i,k)= -proc_rates%qctend_TAU(i,k)
2060 0 : nprc1(i,k)= -proc_rates%nctend_TAU(i,k)
2061 :
2062 : ! PUMAS expects nprc to be positive. Negative nrtend_TAU is from self collection, so put it into nragg
2063 0 : if ( proc_rates%nrtend_TAU(i,k) > 0._r8 ) then
2064 0 : nprc(i,k)= proc_rates%nrtend_TAU(i,k)
2065 : else
2066 0 : nragg(i,k) = proc_rates%nrtend_TAU(i,k)
2067 : end if
2068 : end do
2069 : end do
2070 : !$acc end parallel
2071 :
2072 4467528 : else if (trim(warm_rain) == 'emulated') then
2073 : ! JS - 08/22/2023: this code block only works on CPU
2074 :
2075 : !$acc update self(qcic,ncic,qric,nric,rho,lcldm,precip_frac, &
2076 : !$acc proc_rates%qctend_TAU,proc_rates%qrtend_TAU, &
2077 : !$acc proc_rates%nctend_TAU,proc_rates%nrtend_TAU, &
2078 : !$acc qc,nc,qr,nr,prc,nprc1,nprc,nragg)
2079 :
2080 0 : do k=1,nlev
2081 : call tau_emulated_cloud_rain_interactions(qcic(1:mgncol,k), ncic(1:mgncol,k), &
2082 : qric(1:mgncol,k), nric(1:mgncol,k), &
2083 : rho(1:mgncol,k), lcldm(1:mgncol,k), &
2084 : precip_frac(1:mgncol,k), mgncol, qsmall, &
2085 0 : proc_rates%qctend_TAU(1:mgncol,k), &
2086 0 : proc_rates%qrtend_TAU(1:mgncol,k), &
2087 0 : proc_rates%nctend_TAU(1:mgncol,k), &
2088 0 : proc_rates%nrtend_TAU(1:mgncol,k))
2089 :
2090 : call ML_fixer_calc(mgncol, deltatin, qc(1:mgncol,k), nc(1:mgncol,k), &
2091 0 : qr(1:mgncol,k), nr(1:mgncol,k), &
2092 0 : proc_rates%qctend_TAU(1:mgncol,k),&
2093 0 : proc_rates%nctend_TAU(1:mgncol,k), &
2094 0 : proc_rates%qrtend_TAU(1:mgncol,k), &
2095 0 : proc_rates%nrtend_TAU(1:mgncol,k), &
2096 0 : proc_rates%ML_fixer(1:mgncol,k), &
2097 0 : proc_rates%QC_fixer(1:mgncol,k), &
2098 0 : proc_rates%NC_fixer(1:mgncol,k), &
2099 0 : proc_rates%QR_fixer(1:mgncol,k), &
2100 0 : proc_rates%NR_fixer(1:mgncol,k))
2101 :
2102 : ! PUMAS expects prc and nprc1 (cloud rates) are positive
2103 0 : prc(1:mgncol,k)= -proc_rates%qctend_TAU(1:mgncol,k)
2104 0 : nprc1(1:mgncol,k)= -proc_rates%nctend_TAU(1:mgncol,k)
2105 :
2106 : ! PUMAS expects nprc to be positive. Negative nrtend_TAU is from self
2107 : ! collection, so put it into nragg
2108 0 : do i=1,mgncol
2109 0 : if (proc_rates%nrtend_TAU(i,k).gt.0._r8) then
2110 0 : nprc(i,k)= proc_rates%nrtend_TAU(i,k)
2111 : else
2112 0 : nragg(i,k)= proc_rates%nrtend_TAU(i,k)
2113 : end if
2114 : end do
2115 :
2116 : end do
2117 :
2118 : !$acc update device(proc_rates%qctend_TAU,proc_rates%qrtend_TAU, &
2119 : !$acc proc_rates%nctend_TAU,proc_rates%nrtend_TAU, &
2120 : !$acc prc,nprc1,nprc,nragg)
2121 :
2122 : end if
2123 :
2124 : ! Alternative autoconversion
2125 4467528 : if (trim(warm_rain) == 'sb2001') then
2126 : call sb2001v2_liq_autoconversion(pgam,qcic,ncic,qric,rho,relvar, &
2127 : proc_rates%qctend_SB2001, &
2128 : proc_rates%nrtend_SB2001, &
2129 : proc_rates%nctend_SB2001, &
2130 0 : mgncol*nlev)
2131 :
2132 : !$acc parallel vector_length(VLENS) default(present)
2133 : !$acc loop gang vector collapse(2)
2134 0 : do k=1,nlev
2135 0 : do i=1,mgncol
2136 0 : prc(i,k)=proc_rates%qctend_SB2001(i,k)
2137 0 : nprc(i,k)=proc_rates%nrtend_SB2001(i,k)
2138 0 : nprc1(i,k)=proc_rates%nctend_SB2001(i,k)
2139 0 : proc_rates%qrtend_SB2001(i,k)= -proc_rates%qctend_SB2001(i,k)
2140 : end do
2141 : end do
2142 : !$acc end parallel
2143 : end if
2144 :
2145 : ! Get size distribution parameters for cloud ice
2146 4467528 : call size_dist_param_basic(mg_ice_props, qiic, niic, lami, mgncol, nlev, n0=n0i)
2147 :
2148 : !.......................................................................
2149 : ! Autoconversion of cloud ice to snow
2150 : ! similar to Ferrier (1994)
2151 4467528 : if (do_cldice) then
2152 4467528 : call ice_autoconversion(t, qiic, lami, n0i, dcs, prci, nprci, mgncol*nlev)
2153 : else
2154 : ! Add in the particles that we have already converted to snow, and
2155 : ! don't do any further autoconversion of ice.
2156 :
2157 : !$acc parallel vector_length(VLENS) default(present)
2158 : !$acc loop gang vector collapse(2)
2159 0 : do k=1,nlev
2160 0 : do i=1,mgncol
2161 0 : prci(i,k) = tnd_qsnow(i,k) / cldm(i,k)
2162 0 : nprci(i,k) = tnd_nsnow(i,k) / cldm(i,k)
2163 : end do
2164 : end do
2165 : !$acc end parallel
2166 : end if
2167 :
2168 : ! note, currently we don't have this
2169 : ! inside the do_cldice block, should be changed later
2170 : ! assign qsic based on prognostic qs, using assumed precip fraction
2171 :
2172 : !$acc parallel vector_length(VLENS) default(present)
2173 : !$acc loop gang vector collapse(2)
2174 379739880 : do k=1,nlev
2175 6270643080 : do i=1,mgncol
2176 5890903200 : qsic(i,k) = qs(i,k)/precip_frac(i,k)
2177 5890903200 : nsic(i,k) = ns(i,k)/precip_frac(i,k)
2178 :
2179 : ! limit in-precip mixing ratios to 10 g/kg
2180 5890903200 : qsic(i,k)=min(qsic(i,k),0.01_r8)
2181 :
2182 : ! if precip mix ratio is zero so should number concentration
2183 5890903200 : if (qsic(i,k) < qsmall) then
2184 4300794524 : qsic(i,k)=0._r8
2185 4300794524 : nsic(i,k)=0._r8
2186 : end if
2187 :
2188 : ! make sure number concentration is a positive number to avoid
2189 : ! taking root of negative later
2190 5890903200 : nsic(i,k)=max(nsic(i,k),0._r8)
2191 :
2192 : ! also do this for graupel, which is assumed to be 'precip_frac'
2193 5890903200 : qgic(i,k) = qg(i,k)/precip_frac(i,k)
2194 5890903200 : ngic(i,k) = ng(i,k)/precip_frac(i,k)
2195 :
2196 : ! limit in-precip mixing ratios to 10 g/kg
2197 5890903200 : qgic(i,k)=min(qgic(i,k),0.01_r8)
2198 :
2199 : ! if precip mix ratio is zero so should number concentration
2200 5890903200 : if (qgic(i,k) < qsmall) then
2201 5130310782 : qgic(i,k)=0._r8
2202 5130310782 : ngic(i,k)=0._r8
2203 : end if
2204 :
2205 : ! make sure number concentration is a positive number to avoid
2206 : ! taking root of negative later
2207 6266175552 : ngic(i,k)=max(ngic(i,k),0._r8)
2208 : end do
2209 : end do
2210 : !$acc end parallel
2211 :
2212 : !$acc parallel vector_length(VLENS) default(present)
2213 : !$acc loop gang vector collapse(2)
2214 379739880 : do k=1,nlev
2215 6270643080 : do i=1,mgncol
2216 6266175552 : if (lamr(i,k) >= qsmall) then
2217 1434950401 : dum_2D(i,k)= lamr(i,k)**br
2218 : ! provisional rain number and mass weighted mean fallspeed (m/s)
2219 1434950401 : unr(i,k) = min(arn(i,k)*gamma_br_plus1/dum_2D(i,k),9.1_r8*rhof(i,k))
2220 1434950401 : proc_rates%umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*dum_2D(i,k)),9.1_r8*rhof(i,k))
2221 : else
2222 4455952799 : proc_rates%umr(i,k) = 0._r8
2223 4455952799 : unr(i,k) = 0._r8
2224 : end if
2225 : end do
2226 : end do
2227 : !$acc end parallel
2228 :
2229 : !......................................................................
2230 : ! snow
2231 4467528 : call size_dist_param_basic(mg_snow_props, qsic, nsic, lams, mgncol, nlev, n0=n0s)
2232 :
2233 : !$acc parallel vector_length(VLENS) default(present)
2234 : !$acc loop gang vector collapse(2)
2235 379739880 : do k=1,nlev
2236 6270643080 : do i=1,mgncol
2237 6266175552 : if (ifs_sed) then
2238 0 : if (lams(i,k) > 0._r8) then
2239 0 : proc_rates%ums(i,k) = 1._r8
2240 0 : uns(i,k) = 1._r8
2241 : else
2242 0 : proc_rates%ums(i,k) = 0._r8
2243 0 : uns(i,k) = 0._r8
2244 : end if
2245 : else
2246 5890903200 : if (lams(i,k) > 0._r8) then
2247 1590108676 : dum_2D(i,k) = lams(i,k)**bs
2248 : ! provisional snow number and mass weighted mean fallspeed (m/s)
2249 1590108676 : proc_rates%ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*dum_2D(i,k)),1.2_r8*rhof(i,k))
2250 1590108676 : proc_rates%ums(i,k) = proc_rates%ums(i,k)*micro_mg_vtrms_factor
2251 1590108676 : uns(i,k) = min(asn(i,k)*gamma_bs_plus1/dum_2D(i,k),1.2_r8*rhof(i,k))
2252 : else
2253 4300794524 : proc_rates%ums(i,k) = 0._r8
2254 4300794524 : uns(i,k) = 0._r8
2255 : end if
2256 : end if
2257 : end do
2258 : end do
2259 : !$acc end parallel
2260 :
2261 : ! graupel/hail size distributions and properties
2262 :
2263 4467528 : if (do_hail) then
2264 0 : call size_dist_param_basic(mg_hail_props, qgic, ngic, lamg, mgncol, nlev, n0=n0g)
2265 : end if
2266 4467528 : if (do_graupel) then
2267 4467528 : call size_dist_param_basic(mg_graupel_props, qgic, ngic, lamg, mgncol, nlev, n0=n0g)
2268 : end if
2269 :
2270 : !$acc parallel vector_length(VLENS) default(present)
2271 : !$acc loop gang vector collapse(2)
2272 379739880 : do k=1,nlev
2273 6270643080 : do i=1,mgncol
2274 6266175552 : if (lamg(i,k) > 0._r8) then
2275 760592418 : dum_2D(i,k) = lamg(i,k)**bgtmp
2276 : ! provisional graupel/hail number and mass weighted mean fallspeed (m/s)
2277 760592418 : proc_rates%umg(i,k) = min(agn(i,k)*gamma_bg_plus4/(6._r8*dum_2D(i,k)),20._r8*rhof(i,k))
2278 760592418 : ung(i,k) = min(agn(i,k)*gamma_bg_plus1/dum_2D(i,k),20._r8*rhof(i,k))
2279 : else
2280 5130310782 : proc_rates%umg(i,k) = 0._r8
2281 5130310782 : ung(i,k) = 0._r8
2282 : end if
2283 : end do
2284 : end do
2285 : !$acc end parallel
2286 :
2287 4467528 : if (do_cldice) then
2288 4467528 : if (.not. use_hetfrz_classnuc) then
2289 : ! heterogeneous freezing of cloud water via Bigg, 1953
2290 : !----------------------------------------------
2291 4467528 : call immersion_freezing(microp_uniform, t, pgam, lamc, qcic, ncic, relvar, mnuccc, nnuccc, mgncol*nlev)
2292 :
2293 : ! make sure number of droplets frozen does not exceed available ice nuclei concentration
2294 : ! this prevents 'runaway' droplet freezing
2295 :
2296 : !$acc parallel vector_length(VLENS) default(present)
2297 : !$acc loop gang vector collapse(2)
2298 379739880 : do k=1,nlev
2299 6270643080 : do i=1,mgncol
2300 5890903200 : if (qcic(i,k).ge.qsmall .and. t(i,k).lt.269.15_r8 .and. &
2301 375272352 : nnuccc(i,k)*lcldm(i,k).gt.nnuccd(i,k)) then
2302 : ! scale mixing ratio of droplet freezing with limit
2303 74690812 : mnuccc(i,k)=mnuccc(i,k)*(nnuccd(i,k)/(nnuccc(i,k)*lcldm(i,k)))
2304 74690812 : nnuccc(i,k)=nnuccd(i,k)/lcldm(i,k)
2305 : end if
2306 : end do
2307 : end do
2308 : !$acc end parallel
2309 :
2310 : call contact_freezing(microp_uniform, t, p, rndst, nacon, pgam, lamc, qcic, ncic, &
2311 50169612168 : relvar, mnucct, nnucct, mgncol*nlev, mdust)
2312 : else
2313 : ! Mass of droplets frozen is the average droplet mass, except
2314 : ! with two limiters: concentration must be at least 1/cm^3, and
2315 : ! mass must be at least the minimum defined above.
2316 :
2317 : !$acc parallel vector_length(VLENS) default(present)
2318 : !$acc loop gang vector collapse(2)
2319 0 : do k=1,nlev
2320 0 : do i=1,mgncol
2321 0 : mi0l(i,k) = qcic(i,k)/max(ncic(i,k), 1.0e6_r8/rho(i,k))
2322 0 : mi0l(i,k) = max(mi0l_min, mi0l(i,k))
2323 0 : if (qcic(i,k) >= qsmall) then
2324 0 : nnuccc(i,k) = frzimm(i,k)*1.0e6_r8/rho(i,k)
2325 0 : mnuccc(i,k) = nnuccc(i,k)*mi0l(i,k)
2326 0 : nnucct(i,k) = frzcnt(i,k)*1.0e6_r8/rho(i,k)
2327 0 : mnucct(i,k) = nnucct(i,k)*mi0l(i,k)
2328 0 : nnudep(i,k) = frzdep(i,k)*1.0e6_r8/rho(i,k)
2329 0 : mnudep(i,k) = nnudep(i,k)*mi0
2330 : else
2331 0 : nnuccc(i,k) = 0._r8
2332 0 : mnuccc(i,k) = 0._r8
2333 0 : nnucct(i,k) = 0._r8
2334 0 : mnucct(i,k) = 0._r8
2335 0 : nnudep(i,k) = 0._r8
2336 0 : mnudep(i,k) = 0._r8
2337 : end if
2338 : end do
2339 : end do
2340 : !$acc end parallel
2341 : end if
2342 : else
2343 : !$acc parallel vector_length(VLENS) default(present)
2344 : !$acc loop gang vector collapse(2)
2345 0 : do k=1,nlev
2346 0 : do i=1,mgncol
2347 0 : mnuccc(i,k)=0._r8
2348 0 : nnuccc(i,k)=0._r8
2349 0 : mnucct(i,k)=0._r8
2350 0 : nnucct(i,k)=0._r8
2351 0 : mnudep(i,k)=0._r8
2352 0 : nnudep(i,k)=0._r8
2353 : end do
2354 : end do
2355 : !$acc end parallel
2356 : end if
2357 :
2358 :
2359 4467528 : call snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol*nlev)
2360 :
2361 : call accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, pgam, &
2362 4467528 : lamc, lams, n0s, psacws, npsacws, mgncol*nlev)
2363 :
2364 : !$acc parallel vector_length(VLENS) default(present)
2365 : !$acc loop gang vector collapse(2)
2366 379739880 : do k=1,nlev
2367 6270643080 : do i=1,mgncol
2368 5890903200 : psacws(i,k) = psacws(i,k)*micro_mg_iaccr_factor
2369 6266175552 : npsacws(i,k) = npsacws(i,k)*micro_mg_iaccr_factor
2370 : end do
2371 : end do
2372 : !$acc end parallel
2373 :
2374 4467528 : if (do_cldice) then
2375 4467528 : call secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol*nlev)
2376 : else
2377 : !$acc parallel vector_length(VLENS) default(present)
2378 : !$acc loop gang vector collapse(2)
2379 0 : do k=1,nlev
2380 0 : do i=1,mgncol
2381 0 : nsacwi(i,k) = 0.0_r8
2382 0 : msacwi(i,k) = 0.0_r8
2383 : end do
2384 : end do
2385 : !$acc end parallel
2386 : end if
2387 :
2388 : call accrete_rain_snow(t, rho, proc_rates%umr, proc_rates%ums, unr, uns, qric, qsic, lamr, &
2389 4467528 : n0r, lams, n0s, pracs, npracs, mgncol*nlev)
2390 :
2391 4467528 : call heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol*nlev)
2392 :
2393 4467528 : if (trim(warm_rain) == 'sb2001') then
2394 0 : call sb2001v2_accre_cld_water_rain(qcic, ncic, qric, rho, relvar, pra, npra, mgncol*nlev)
2395 : !$acc parallel vector_length(VLENS) default(present)
2396 : !$acc loop gang vector collapse(2)
2397 0 : do k=1,nlev
2398 0 : do i=1,mgncol
2399 0 : proc_rates%nctend_SB2001(i,k)=proc_rates%nctend_SB2001(i,k)+npra(i,k)
2400 0 : proc_rates%qctend_SB2001(i,k)=proc_rates%qctend_SB2001(i,k)+pra(i,k)
2401 0 : proc_rates%nrtend_SB2001(i,k)=proc_rates%nrtend_SB2001(i,k)+npra(i,k) !Sign should be same as prc?
2402 0 : proc_rates%qrtend_SB2001(i,k)=proc_rates%qrtend_SB2001(i,k)-pra(i,k)
2403 : end do
2404 : end do
2405 : !$acc end parallel
2406 : end if
2407 :
2408 4467528 : if (trim(warm_rain) == 'kk2000') then
2409 : !$acc parallel vector_length(VLENS) default(present)
2410 : !$acc loop gang vector collapse(2)
2411 379739880 : do k = 1,nlev
2412 6270643080 : do i = 1,mgncol
2413 5890903200 : rtmp(i,k) = qric(i,k)
2414 5890903200 : ctmp(i,k) = qcic(i,k)
2415 5890903200 : ntmp(i,k) = ncic(i,k)
2416 :
2417 : !Option: include recently autoconverted rain (prc, nprc) in accretion
2418 6266175552 : if (accre_sees_auto) then
2419 5890903200 : rtmp(i,k) = rtmp(i,k) + prc(i,k)*deltat
2420 5890903200 : ctmp(i,k) = ctmp(i,k) - prc(i,k)*deltat
2421 5890903200 : ntmp(i,k) = ntmp(i,k) - nprc(i,k)*deltat
2422 : endif
2423 : end do
2424 : end do
2425 : !$acc end parallel
2426 :
2427 : call accrete_cloud_water_rain(microp_uniform,rtmp,ctmp,ntmp,relvar, &
2428 4467528 : accre_enhan,pra,npra,mgncol*nlev)
2429 :
2430 : !$acc parallel vector_length(VLENS) default(present)
2431 : !$acc loop gang vector collapse(2)
2432 379739880 : do k = 1,nlev
2433 6270643080 : do i = 1,mgncol
2434 5890903200 : proc_rates%nctend_KK2000(i,k)=proc_rates%nctend_KK2000(i,k)+npra(i,k)
2435 5890903200 : proc_rates%qctend_KK2000(i,k)=proc_rates%qctend_KK2000(i,k)+pra(i,k)
2436 5890903200 : proc_rates%nrtend_KK2000(i,k)=proc_rates%nrtend_KK2000(i,k)+npra(i,k) !Sign consistent with prc,nprc
2437 6266175552 : proc_rates%qrtend_KK2000(i,k)=proc_rates%qrtend_KK2000(i,k)-pra(i,k)
2438 : end do
2439 : end do
2440 : !$acc end parallel
2441 : endif
2442 :
2443 : !$acc parallel vector_length(VLENS) default(present)
2444 : !$acc loop gang vector collapse(2)
2445 379739880 : do k=1,nlev
2446 6270643080 : do i=1,mgncol
2447 5890903200 : pra(i,k) = pra(i,k)*micro_mg_accre_enhan_fact
2448 6266175552 : npra(i,k) = npra(i,k)*micro_mg_accre_enhan_fact
2449 : end do
2450 : end do
2451 : !$acc end parallel
2452 :
2453 4467528 : if (trim(warm_rain) == 'kk2000' .or. trim(warm_rain) == 'sb2001') then
2454 4467528 : call self_collection_rain(rho, qric, nric, nragg, mgncol*nlev)
2455 : end if
2456 :
2457 4467528 : if (do_cldice) then
2458 4467528 : call accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, lams, n0s, prai, nprai, mgncol*nlev)
2459 : else
2460 : !$acc parallel vector_length(VLENS) default(present)
2461 : !$acc loop gang vector collapse(2)
2462 0 : do k=1,nlev
2463 0 : do i=1,mgncol
2464 0 : prai(i,k) = 0._r8
2465 0 : nprai(i,k) = 0._r8
2466 : end do
2467 : end do
2468 : !$acc end parallel
2469 : end if
2470 :
2471 4467528 : call bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, qcic, qsic, lams, n0s, bergs, mgncol*nlev)
2472 : !$acc parallel vector_length(VLENS) default(present)
2473 : !$acc loop gang vector collapse(2)
2474 379739880 : do k=1,nlev
2475 6270643080 : do i=1,mgncol
2476 6266175552 : bergs(i,k)=bergs(i,k)*micro_mg_berg_eff_factor
2477 : end do
2478 : end do
2479 : !$acc end parallel
2480 :
2481 :
2482 : call vapor_deposition_onto_snow(t, q, qs, ns, precip_frac, rho, dv, qvl, &
2483 4467528 : qvi, asn, mu, sc, vap_deps, mgncol*nlev)
2484 :
2485 :
2486 4467528 : if (do_cldice) then
2487 : call ice_deposition_sublimation(t, q, qi, ni, icldm, rho, dv, qvl, qvi, &
2488 4467528 : berg, vap_dep, ice_sublim, mgncol*nlev)
2489 : !$acc parallel vector_length(VLENS) default(present)
2490 : !$acc loop gang vector collapse(2)
2491 379739880 : do k=1,nlev
2492 6270643080 : do i=1,mgncol
2493 5890903200 : berg(i,k)=berg(i,k)*micro_mg_berg_eff_factor
2494 5890903200 : if (ice_sublim(i,k) < 0._r8 .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then
2495 148195522 : nsubi(i,k) = sublim_factor*ice_sublim(i,k) / qi(i,k) * ni(i,k) / icldm(i,k)
2496 : else
2497 5742707678 : nsubi(i,k) = 0._r8
2498 : end if
2499 :
2500 : ! bergeron process should not reduce nc unless
2501 : ! all ql is removed (which is handled elsewhere)
2502 : !in fact, nothing in this entire file makes nsubc nonzero.
2503 6266175552 : nsubc(i,k) = 0._r8
2504 :
2505 : end do
2506 : end do
2507 : !$acc end parallel
2508 : end if !do_cldice
2509 :
2510 : ! Process rate calls for graupel
2511 : !===================================================================
2512 :
2513 4467528 : if (do_hail.or.do_graupel) then
2514 : call graupel_collecting_snow(qsic, qric, proc_rates%umr, proc_rates%ums, rho, &
2515 4467528 : lamr, n0r, lams, n0s, psacr, mgncol*nlev)
2516 :
2517 4467528 : call graupel_collecting_cld_water(qgic, qcic, ncic, rho, n0g, lamg, bgtmp, agn, psacwg, npsacwg, mgncol*nlev)
2518 :
2519 : !$acc parallel vector_length(VLENS) default(present)
2520 : !$acc loop gang vector collapse(2)
2521 379739880 : do k=1,nlev
2522 6270643080 : do i=1,mgncol
2523 5890903200 : psacwg(i,k) = psacwg(i,k)*micro_mg_iaccr_factor
2524 6266175552 : npsacwg(i,k) = npsacwg(i,k)*micro_mg_iaccr_factor
2525 : end do
2526 : end do
2527 : !$acc end parallel
2528 :
2529 : call graupel_riming_liquid_snow(psacws, qsic, qcic, nsic, rho, rhosn, rhogtmp, asn, &
2530 4467528 : lams, n0s, deltat, pgsacw, nscng, mgncol*nlev)
2531 :
2532 : call graupel_collecting_rain(qric, qgic, proc_rates%umg, proc_rates%umr, ung, unr, rho, n0r, &
2533 4467528 : lamr, n0g, lamg, pracg, npracg, mgncol*nlev)
2534 :
2535 : !$acc parallel vector_length(VLENS) default(present)
2536 : !$acc loop gang vector collapse(2)
2537 379739880 : do k=1,nlev
2538 6270643080 : do i=1,mgncol
2539 5890903200 : pracg(i,k) = pracg(i,k)*micro_mg_iaccr_factor
2540 6266175552 : npracg(i,k) = npracg(i,k)*micro_mg_iaccr_factor
2541 : end do
2542 : end do
2543 : !$acc end parallel
2544 :
2545 : !AG note: Graupel rain riming snow changes
2546 : ! pracs, npracs, (accretion of rain by snow) psacr (collection of snow by rain)
2547 :
2548 : call graupel_rain_riming_snow(pracs, npracs, psacr, qsic, qric, nric, nsic, &
2549 4467528 : n0s, lams, n0r, lamr, deltat, pgracs, ngracs, mgncol*nlev)
2550 :
2551 4467528 : call graupel_rime_splintering(t, qcic, qric, qgic, psacwg, pracg, qmultg, nmultg, qmultrg, nmultrg,mgncol*nlev)
2552 :
2553 :
2554 : call evaporate_sublimate_precip_graupel(t, rho, dv, mu, sc, q, qvl, qvi, lcldm, precip_frac, arn, asn, agn, &
2555 : bgtmp, qcic, qiic, qric, qsic, qgic, lamr, n0r, lams, n0s, lamg, n0g, &
2556 4467528 : pre, prds, prdg, am_evp_st, mgncol*nlev, evap_rhthrsh_ifs)
2557 : else
2558 : ! Routine without Graupel (original)
2559 : call evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, lcldm, precip_frac, arn, asn, qcic, qiic, &
2560 0 : qric, qsic, lamr, n0r, lams, n0s, pre, prds, am_evp_st, mgncol*nlev, evap_rhthrsh_ifs)
2561 : end if ! end do_graupel/hail loop
2562 :
2563 : ! scale precip evaporation to match IFS 'new' version (option 2)
2564 4467528 : if (evap_scl_ifs) then
2565 : !$acc parallel vector_length(VLENS) default(present)
2566 : !$acc loop gang vector collapse(2)
2567 0 : do k=1,nlev
2568 0 : do i=1,mgncol
2569 0 : pre(i,k)= 0.15_r8 * pre(i,k)
2570 : end do
2571 : end do
2572 : !$acc end parallel
2573 : end if
2574 :
2575 : !$acc parallel vector_length(VLENS) default(present)
2576 : !$acc loop gang vector collapse(2)
2577 379739880 : do k=1,nlev
2578 6270643080 : do i=1,mgncol
2579 : ! conservation to ensure no negative values of cloud water/precipitation
2580 : ! in case microphysical process rates are large
2581 : !===================================================================
2582 :
2583 : ! note: for check on conservation, processes are multiplied by omsm
2584 : ! to prevent problems due to round off error
2585 :
2586 : ! conservation of qc
2587 : !-------------------------------------------------------------------
2588 11781806400 : dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ &
2589 : psacws(i,k)+bergs(i,k)+qmultg(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)+ &
2590 11781806400 : berg(i,k))*deltat
2591 5890903200 : if (dum.gt.qc(i,k)) then
2592 : ratio = qc(i,k)*rdeltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ &
2593 : msacwi(i,k)+psacws(i,k)+bergs(i,k)+qmultg(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)+&
2594 1342331399 : berg(i,k))*omsm
2595 1342331399 : qmultg(i,k)=qmultg(i,k)*ratio
2596 1342331399 : psacwg(i,k)=psacwg(i,k)*ratio
2597 1342331399 : pgsacw(i,k)=pgsacw(i,k)*ratio
2598 1342331399 : prc(i,k) = prc(i,k)*ratio
2599 1342331399 : pra(i,k) = pra(i,k)*ratio
2600 1342331399 : mnuccc(i,k) = mnuccc(i,k)*ratio
2601 1342331399 : mnucct(i,k) = mnucct(i,k)*ratio
2602 1342331399 : msacwi(i,k) = msacwi(i,k)*ratio
2603 1342331399 : psacws(i,k) = psacws(i,k)*ratio
2604 1342331399 : bergs(i,k) = bergs(i,k)*ratio
2605 1342331399 : berg(i,k) = berg(i,k)*ratio
2606 1342331399 : qcrat(i,k) = ratio
2607 : else
2608 4548571801 : qcrat(i,k) = 1._r8
2609 : end if
2610 : !PMC 12/3/12: ratio is also frac of step w/ liquid.
2611 : !thus we apply berg for "ratio" of timestep and vapor
2612 : !deposition for the remaining frac of the timestep.
2613 5890903200 : if (qc(i,k) >= qsmall) then
2614 512413729 : vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k))
2615 512413729 : vap_deps(i,k) = vap_deps(i,k)*(1._r8-qcrat(i,k))
2616 : end if
2617 :
2618 : !=================================================================
2619 : ! apply limiter to ensure that ice/snow sublimation and rain evap
2620 : ! don't push conditions into supersaturation, and ice deposition/nucleation don't
2621 : ! push conditions into sub-saturation
2622 : ! note this is done after qc conservation since we don't know how large
2623 : ! vap_dep is before then
2624 : ! estimates are only approximate since other process terms haven't been limited
2625 : ! for conservation yet
2626 :
2627 : ! first limit ice deposition/nucleation vap_dep + mnuccd + vap_deps
2628 5890903200 : mnuccd(i,k) = max(0._r8,mnuccd(i,k))
2629 5890903200 : vap_dep(i,k) = max(0._r8,vap_dep(i,k))
2630 5890903200 : vap_deps(i,k) = max(0._r8,vap_deps(i,k))
2631 :
2632 5890903200 : dum1 = vap_dep(i,k) + mnuccd(i,k) + vap_deps(i,k)
2633 6266175552 : if (dum1 > 1.e-20_r8) then
2634 471953685 : dum = (q(i,k)-qvi(i,k))/(1._r8 + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)**2))*rdeltat
2635 471953685 : dum = max(dum,0._r8)
2636 471953685 : if (dum1 > dum) then
2637 : ! Allocate the limited "dum" tendency to mnuccd and vap_dep
2638 : ! processes. Don't divide by cloud fraction; these are grid-
2639 : ! mean rates.
2640 11391544 : mnuccd(i,k) = dum*mnuccd(i,k)/dum1
2641 11391544 : vap_dep(i,k) = dum*vap_dep(i,k)/dum1
2642 11391544 : vap_deps(i,k) = dum*vap_deps(i,k)/dum1
2643 :
2644 : end if
2645 : end if
2646 : end do
2647 : end do
2648 : !$acc end parallel
2649 :
2650 : !$acc parallel vector_length(VLENS) default(present)
2651 : !$acc loop gang vector collapse(2)
2652 379739880 : do k=1,nlev
2653 6270643080 : do i=1,mgncol
2654 : !===================================================================
2655 : ! conservation of nc
2656 : !-------------------------------------------------------------------
2657 11781806400 : dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ &
2658 11781806400 : npsacws(i,k)-nsubc(i,k)+npsacwg(i,k))*lcldm(i,k)*deltat
2659 :
2660 5890903200 : if (dum.gt.nc(i,k)) then
2661 : ratio = nc(i,k)*rdeltat/((nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+&
2662 194991117 : npsacws(i,k)-nsubc(i,k)+npsacwg(i,k))*lcldm(i,k))*omsm
2663 194991117 : npsacwg(i,k) = npsacwg(i,k)*ratio
2664 194991117 : nprc1(i,k) = nprc1(i,k)*ratio
2665 194991117 : npra(i,k) = npra(i,k)*ratio
2666 194991117 : nnuccc(i,k) = nnuccc(i,k)*ratio
2667 194991117 : nnucct(i,k) = nnucct(i,k)*ratio
2668 194991117 : npsacws(i,k) = npsacws(i,k)*ratio
2669 194991117 : nsubc(i,k) = nsubc(i,k)*ratio
2670 : end if
2671 5890903200 : mnuccri(i,k)=0._r8
2672 5890903200 : nnuccri(i,k)=0._r8
2673 :
2674 6266175552 : if (do_cldice) then
2675 : ! freezing of rain to produce ice if mean rain size is smaller than Dcs
2676 5890903200 : if (lamr(i,k) > qsmall) then
2677 1434950401 : if (1._r8/lamr(i,k) < Dcs) then
2678 1391415819 : mnuccri(i,k)=mnuccr(i,k)
2679 1391415819 : nnuccri(i,k)=nnuccr(i,k)
2680 1391415819 : mnuccr(i,k)=0._r8
2681 1391415819 : nnuccr(i,k)=0._r8
2682 : end if
2683 : end if
2684 : end if
2685 : end do
2686 : end do
2687 : !$acc end parallel
2688 :
2689 : !$acc parallel vector_length(VLENS) default(present)
2690 : !$acc loop gang vector collapse(2)
2691 379739880 : do k=1,nlev
2692 6270643080 : do i=1,mgncol
2693 : ! conservation of rain mixing ratio
2694 : !-------------------------------------------------------------------
2695 11781806400 : dum = ((-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k) &
2696 : +qmultrg(i,k)+pracg(i,k)+pgracs(i,k))*precip_frac(i,k)- &
2697 11781806400 : (pra(i,k)+prc(i,k))*lcldm(i,k))*deltat
2698 : ! note that qrtend is included below because of instantaneous freezing/melt
2699 5890903200 : if (dum.gt.qr(i,k).and. &
2700 : (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)+qmultrg(i,k)+pracg(i,k)+pgracs(i,k)).ge.qsmall) then
2701 : ratio = (qr(i,k)*rdeltat+(pra(i,k)+prc(i,k))*lcldm(i,k))/ &
2702 : precip_frac(i,k)/(-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k) &
2703 613226772 : +qmultrg(i,k)+pracg(i,k)+pgracs(i,k))*omsm
2704 613226772 : qmultrg(i,k)= qmultrg(i,k)*ratio
2705 613226772 : pracg(i,k)=pracg(i,k)*ratio
2706 613226772 : pgracs(i,k)=pgracs(i,k)*ratio
2707 613226772 : pre(i,k)=pre(i,k)*ratio
2708 613226772 : pracs(i,k)=pracs(i,k)*ratio
2709 613226772 : mnuccr(i,k)=mnuccr(i,k)*ratio
2710 613226772 : mnuccri(i,k)=mnuccri(i,k)*ratio
2711 : end if
2712 :
2713 : ! conservation of rain number
2714 : !-------------------------------------------------------------------
2715 : ! Add evaporation of rain number.
2716 5890903200 : if (pre(i,k) < 0._r8) then
2717 721992020 : nsubr(i,k) = pre(i,k)*nr(i,k)/qr(i,k)
2718 : else
2719 5168911180 : nsubr(i,k) = 0._r8
2720 : end if
2721 :
2722 : dum = ((-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k)) &
2723 5890903200 : *precip_frac(i,k)- nprc(i,k)*lcldm(i,k))*deltat
2724 :
2725 : ! Added a check to trap for division by zero errors
2726 :
2727 5890903200 : tmpnr = -nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k)
2728 5890903200 : tmpp = nr(i,k)*rdeltat + nprc(i,k)*lcldm(i,k)
2729 :
2730 6266175552 : if (dum.gt.nr(i,k) .and. tmpnr.gt.0._r8 .and. tmpp.gt.0._r8 .and. precip_frac(i,k).gt.0._r8) then
2731 : ratio = (nr(i,k)*rdeltat+nprc(i,k)*lcldm(i,k))/precip_frac(i,k)/ &
2732 710146797 : (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k)+npracg(i,k)+ngracs(i,k))*omsm
2733 :
2734 710146797 : npracg(i,k)=npracg(i,k)*ratio
2735 710146797 : ngracs(i,k)=ngracs(i,k)*ratio
2736 710146797 : nragg(i,k)=nragg(i,k)*ratio
2737 710146797 : npracs(i,k)=npracs(i,k)*ratio
2738 710146797 : nnuccr(i,k)=nnuccr(i,k)*ratio
2739 710146797 : nsubr(i,k)=nsubr(i,k)*ratio
2740 710146797 : nnuccri(i,k)=nnuccri(i,k)*ratio
2741 : end if
2742 : end do
2743 : end do
2744 : !$acc end parallel
2745 :
2746 4467528 : if (do_cldice) then
2747 : !$acc parallel vector_length(VLENS) default(present)
2748 : !$acc loop gang vector collapse(2)
2749 379739880 : do k=1,nlev
2750 6270643080 : do i=1,mgncol
2751 : ! conservation of qi
2752 : !-------------------------------------------------------------------
2753 11781806400 : dum = ((-mnuccc(i,k)-mnucct(i,k)-mnudep(i,k)-msacwi(i,k)-qmultg(i,k))*lcldm(i,k)+(prci(i,k)+ &
2754 : prai(i,k))*icldm(i,k)+(-qmultrg(i,k)-mnuccri(i,k))*precip_frac(i,k) &
2755 11781806400 : -ice_sublim(i,k)-vap_dep(i,k)-berg(i,k)-mnuccd(i,k))*deltat
2756 5890903200 : if (dum.gt.qi(i,k)) then
2757 : ratio = (qi(i,k)*rdeltat+vap_dep(i,k)+berg(i,k)+mnuccd(i,k)+ &
2758 : (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k)+ &
2759 : (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k))/ &
2760 656096697 : ((prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k))*omsm
2761 656096697 : prci(i,k) = prci(i,k)*ratio
2762 656096697 : prai(i,k) = prai(i,k)*ratio
2763 656096697 : ice_sublim(i,k) = ice_sublim(i,k)*ratio
2764 : end if
2765 :
2766 : ! conservation of ni
2767 : !-------------------------------------------------------------------
2768 5890903200 : if (use_hetfrz_classnuc) then
2769 0 : tmpfrz = nnuccc(i,k)
2770 : else
2771 : tmpfrz = 0._r8
2772 : end if
2773 : dum = ((-nnucct(i,k)-tmpfrz-nnudep(i,k)-nsacwi(i,k)-nmultg(i,k))*lcldm(i,k)+(nprci(i,k)+ &
2774 : nprai(i,k)-nsubi(i,k))*icldm(i,k)+(-nmultrg(i,k)-nnuccri(i,k))*precip_frac(i,k)- &
2775 5890903200 : nnuccd(i,k))*deltat
2776 6266175552 : if (dum.gt.ni(i,k)) then
2777 : ratio = (ni(i,k)*rdeltat+nnuccd(i,k)+ &
2778 : (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k)+ &
2779 : (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k))/ &
2780 229069389 : ((nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k))*omsm
2781 229069389 : nprci(i,k) = nprci(i,k)*ratio
2782 229069389 : nprai(i,k) = nprai(i,k)*ratio
2783 229069389 : nsubi(i,k) = nsubi(i,k)*ratio
2784 : end if
2785 : end do
2786 : end do
2787 : !$acc end parallel
2788 : end if
2789 :
2790 : !$acc parallel vector_length(VLENS) default(present)
2791 : !$acc loop gang vector collapse(2)
2792 379739880 : do k=1,nlev
2793 6270643080 : do i=1,mgncol
2794 : ! conservation of snow mixing ratio
2795 : !-------------------------------------------------------------------
2796 5890903200 : if (do_hail .or. do_graupel) then
2797 : ! NOTE: mnuccr is moved to graupel when active
2798 : ! psacr is a positive value, but a loss for snow
2799 : !HM: psacr is positive in dum (two negatives)
2800 11781806400 : dum = (-(prds(i,k)+pracs(i,k)-psacr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) &
2801 17672709600 : -(bergs(i,k)+psacws(i,k))*lcldm(i,k) - vap_deps(i,k))*deltat
2802 : else
2803 0 : dum = (-(prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)-(prai(i,k)+prci(i,k))*icldm(i,k) &
2804 0 : -(bergs(i,k)+psacws(i,k))*lcldm(i,k) - vap_deps(i,k))*deltat
2805 : end if
2806 5890903200 : if (dum.gt.qs(i,k).and.(psacr(i,k)-prds(i,k)).ge.qsmall) then
2807 270432578 : if (do_hail .or. do_graupel) then
2808 : ratio = (qs(i,k)*rdeltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ &
2809 : (bergs(i,k)+psacws(i,k))*lcldm(i,k)+vap_deps(i,k)+pracs(i,k)*precip_frac(i,k))/ &
2810 270432578 : precip_frac(i,k)/(psacr(i,k)-prds(i,k))*omsm
2811 270432578 : psacr(i,k)=psacr(i,k)*ratio
2812 : else
2813 : ratio = (qs(i,k)*rdeltat+(prai(i,k)+prci(i,k))*icldm(i,k)+ &
2814 : (bergs(i,k)+psacws(i,k))*lcldm(i,k)+vap_deps(i,k)+(pracs(i,k)+mnuccr(i,k))*precip_frac(i,k))/ &
2815 0 : precip_frac(i,k)/(-prds(i,k))*omsm
2816 : end if
2817 270432578 : prds(i,k)=prds(i,k)*ratio
2818 : end if
2819 :
2820 : ! conservation of snow number
2821 : !-------------------------------------------------------------------
2822 : ! calculate loss of number due to sublimation
2823 : ! for now neglect sublimation of ns
2824 5890903200 : nsubs(i,k)=0._r8
2825 5890903200 : if (do_hail .or. do_graupel) then
2826 5890903200 : dum = ((-nsagg(i,k)-nsubs(i,k)+ngracs(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k)+nscng(i,k)*lcldm(i,k))*deltat
2827 : else
2828 0 : dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat
2829 : end if
2830 6266175552 : if (dum.gt.ns(i,k)) then
2831 161385097 : if (do_hail .or. do_graupel) then
2832 : ratio = (ns(i,k)*rdeltat+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ &
2833 161385097 : (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)+lcldm(i,k)/precip_frac(i,k)*nscng(i,k))*omsm
2834 161385097 : nscng(i,k)=nscng(i,k)*ratio
2835 161385097 : ngracs(i,k)=ngracs(i,k)*ratio
2836 : else
2837 : ratio = (ns(i,k)*rdeltat+nnuccr(i,k)* &
2838 : precip_frac(i,k)+nprci(i,k)*icldm(i,k))/precip_frac(i,k)/ &
2839 0 : (-nsubs(i,k)-nsagg(i,k))*omsm
2840 : endif
2841 161385097 : nsubs(i,k)=nsubs(i,k)*ratio
2842 161385097 : nsagg(i,k)=nsagg(i,k)*ratio
2843 : end if
2844 : end do
2845 : end do
2846 : !$acc end parallel
2847 :
2848 : ! Graupel Conservation Checks
2849 : !-------------------------------------------------------------------
2850 :
2851 4467528 : if (do_hail.or.do_graupel) then
2852 : ! conservation of graupel mass
2853 : !-------------------------------------------------------------------
2854 : !$acc parallel vector_length(VLENS) default(present)
2855 : !$acc loop gang vector collapse(2)
2856 379739880 : do k=1,nlev
2857 6270643080 : do i=1,mgncol
2858 11781806400 : dum= ((-pracg(i,k)-pgracs(i,k)-prdg(i,k)-psacr(i,k)-mnuccr(i,k))*precip_frac(i,k) &
2859 11781806400 : + (-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k))*deltat
2860 6266175552 : if (dum.gt.qg(i,k)) then
2861 : ! note: prdg is always negative (like prds), so it needs to be subtracted in ratio
2862 : ratio = (qg(i,k)*rdeltat + (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) &
2863 61338013 : + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)) / ((-prdg(i,k))*precip_frac(i,k)) * omsm
2864 61338013 : prdg(i,k)= prdg(i,k)*ratio
2865 : end if
2866 : end do
2867 : end do
2868 : !$acc end parallel
2869 : ! conservation of graupel number: not needed, no sinks
2870 : !-------------------------------------------------------------------
2871 : end if
2872 :
2873 : !$acc parallel vector_length(VLENS) default(present)
2874 : !$acc loop gang vector collapse(2)
2875 379739880 : do k=1,nlev
2876 6270643080 : do i=1,mgncol
2877 : ! next limit ice and snow sublimation and rain evaporation
2878 : ! get estimate of q and t at end of time step
2879 : ! don't include other microphysical processes since they haven't
2880 : ! been limited via conservation checks yet
2881 11781806400 : qtmpAI(i,k)=q(i,k)-(ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+vap_deps(i,k)+ &
2882 11781806400 : (pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k))*deltat
2883 : ttmpA(i,k)=t(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ &
2884 6266175552 : ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+vap_deps(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls)*deltat/cpp
2885 : end do
2886 : end do
2887 : !$acc end parallel
2888 :
2889 : ! use rhw to allow ice supersaturation
2890 4467528 : call qsat_water(ttmpA, p, esnA, qvnAI, mgncol*nlev)
2891 :
2892 : !$acc parallel vector_length(VLENS) default(present)
2893 : !$acc loop gang vector collapse(2)
2894 379739880 : do k=1,nlev
2895 6270643080 : do i=1,mgncol
2896 6266175552 : if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
2897 : ! modify ice/precip evaporation rate if q > qsat
2898 1584660241 : if (qtmpAI(i,k) > qvnAI(i,k)) then
2899 14711 : dum1A(i,k)=pre(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
2900 14711 : dum2A(i,k)=prds(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
2901 14711 : dum3A(i,k)=prdg(i,k)*precip_frac(i,k)/((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k))
2902 : ! recalculate q and t after vap_dep and mnuccd but without evap or sublim
2903 14711 : ttmpA(i,k)=t(i,k)+((vap_dep(i,k)+vap_deps(i,k)+mnuccd(i,k))*xxls)*deltat/cpp
2904 14711 : dum_2D(i,k)=q(i,k)-(vap_dep(i,k)+vap_deps(i,k)+mnuccd(i,k))*deltat
2905 : end if
2906 : end if
2907 : end do
2908 : end do
2909 : !$acc end parallel
2910 :
2911 : ! use rhw to allow ice supersaturation
2912 4467528 : call qsat_water(ttmpA, p, esnA, qvnA, mgncol*nlev)
2913 :
2914 : !$acc parallel vector_length(VLENS) default(present)
2915 : !$acc loop gang vector collapse(2)
2916 379739880 : do k=1,nlev
2917 6270643080 : do i=1,mgncol
2918 6266175552 : if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
2919 : ! modify ice/precip evaporation rate if q > qsat
2920 1584660241 : if (qtmpAI(i,k) > qvnAI(i,k)) then
2921 14711 : dum=(dum_2D(i,k)-qvnA(i,k))/(1._r8 + xxlv_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))
2922 14711 : dum=min(dum,0._r8)
2923 : ! modify rates if needed, divide by precip_frac to get local (in-precip) value
2924 14711 : pre(i,k)=dum*dum1A(i,k)*rdeltat/precip_frac(i,k)
2925 : end if
2926 : end if
2927 : end do
2928 : end do
2929 : !$acc end parallel
2930 :
2931 : ! do separately using RHI for prds and ice_sublim
2932 4467528 : call qsat_ice(ttmpA, p, esnA, qvnA, mgncol*nlev)
2933 :
2934 : !$acc parallel vector_length(VLENS) default(present)
2935 : !$acc loop gang vector collapse(2)
2936 379739880 : do k=1,nlev
2937 6270643080 : do i=1,mgncol
2938 5890903200 : if ((pre(i,k)+prds(i,k)+prdg(i,k))*precip_frac(i,k)+ice_sublim(i,k) < -1.e-20_r8) then
2939 : ! modify ice/precip evaporation rate if q > qsat
2940 1584660241 : if (qtmpAI(i,k) > qvnAI(i,k)) then
2941 14711 : dum=(dum_2D(i,k)-qvnA(i,k))/(1._r8 + xxls_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))
2942 14711 : dum=min(dum,0._r8)
2943 : ! modify rates if needed, divide by precip_frac to get local (in-precip) value
2944 14711 : prds(i,k) = dum*dum2A(i,k)*rdeltat/precip_frac(i,k)
2945 14711 : prdg(i,k) = dum*dum3A(i,k)*rdeltat/precip_frac(i,k)
2946 : ! don't divide ice_sublim by cloud fraction since it is grid-averaged
2947 14711 : dum1A(i,k) = (1._r8-dum1A(i,k)-dum2A(i,k)-dum3A(i,k))
2948 14711 : ice_sublim(i,k) = dum*dum1A(i,k)*rdeltat
2949 : end if
2950 : end if
2951 :
2952 : ! get tendencies due to microphysical conversion processes
2953 : !==========================================================
2954 : ! note: tendencies are multiplied by appropriate cloud/precip
2955 : ! fraction to get grid-scale values
2956 : ! note: vap_dep is already grid-average values
2957 :
2958 : ! The net tendencies need to be added to rather than overwritten,
2959 : ! because they may have a value already set for instantaneous
2960 : ! melting/freezing.
2961 : qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k)-&
2962 : vap_dep(i,k)-vap_deps(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) &
2963 5890903200 : -prdg(i,k)*precip_frac(i,k)
2964 : tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ &
2965 : ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+vap_deps(i,k)+ice_sublim(i,k)+ &
2966 : mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ &
2967 : ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacwg(i,k)+ &
2968 : qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ &
2969 : (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ &
2970 5890903200 : berg(i,k))*xlf)
2971 : qctend(i,k) = qctend(i,k)+ &
2972 : (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- &
2973 5890903200 : psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k)
2974 :
2975 5890903200 : if (do_cldice) then
2976 : qitend(i,k) = qitend(i,k)+ &
2977 : (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k)+(-prci(i,k)- &
2978 : prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ &
2979 5890903200 : mnuccd(i,k)+(mnuccri(i,k)+qmultrg(i,k))*precip_frac(i,k)
2980 : end if
2981 :
2982 : qrtend(i,k) = qrtend(i,k)+ &
2983 : (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- &
2984 5890903200 : mnuccr(i,k)-mnuccri(i,k)-qmultrg(i,k)-pracg(i,k)-pgracs(i,k))*precip_frac(i,k)
2985 :
2986 6266175552 : if (do_hail.or.do_graupel) then
2987 : qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) &
2988 5890903200 : + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)
2989 : qstend(i,k) = qstend(i,k)+ &
2990 : (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ &
2991 5890903200 : pracs(i,k)-psacr(i,k))*precip_frac(i,k)+vap_deps(i,k)
2992 : else
2993 : !necessary since mnuccr moved to graupel
2994 : qstend(i,k) = qstend(i,k)+ &
2995 : (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(prds(i,k)+ &
2996 0 : pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)+vap_deps(i,k)
2997 : end if
2998 : end do
2999 : end do
3000 : !$acc end parallel
3001 :
3002 : !$acc parallel vector_length(VLENS) default(present)
3003 : !$acc loop gang vector collapse(2)
3004 379739880 : do k=1,nlev
3005 6270643080 : do i=1,mgncol
3006 5890903200 : cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + vap_deps(i,k)
3007 : ! add output for cmei (accumulate)
3008 5890903200 : proc_rates%cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + vap_deps(i,k)
3009 : !-------------------------------------------------------------------
3010 : ! evaporation/sublimation is stored here as positive term
3011 : ! Add to evapsnow via prdg
3012 5890903200 : proc_rates%evapsnow(i,k) = (-prds(i,k)-prdg(i,k))*precip_frac(i,k)
3013 5890903200 : nevapr(i,k) = -pre(i,k)*precip_frac(i,k)
3014 5890903200 : prer_evap(i,k) = -pre(i,k)*precip_frac(i,k)
3015 : ! change to make sure prain is positive: do not remove snow from
3016 : ! prain used for wet deposition
3017 : prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- &
3018 5890903200 : mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k)
3019 5890903200 : if (do_hail .or. do_graupel) then
3020 0 : proc_rates%prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(&
3021 5890903200 : pracs(i,k))*precip_frac(i,k)+vap_deps(i,k)
3022 : else
3023 0 : proc_rates%prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(&
3024 0 : pracs(i,k)+mnuccr(i,k))*precip_frac(i,k)+vap_deps(i,k)
3025 : end if
3026 : ! following are used to calculate 1st order conversion rate of cloud water
3027 : ! to rain and snow (1/s), for later use in aerosol wet removal routine
3028 : ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc
3029 : ! used to calculate pra, prc, ... in this routine
3030 : ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow }
3031 : ! (no cloud ice or bergeron terms)
3032 5890903200 : qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k)
3033 : ! Avoid zero/near-zero division.
3034 : qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / &
3035 6266175552 : max(qc(i,k),1.0e-30_r8)
3036 : end do
3037 : end do
3038 : !$acc end parallel
3039 :
3040 : !$acc parallel vector_length(VLENS) default(present)
3041 : !$acc loop gang vector collapse(2)
3042 379739880 : do k=1,nlev
3043 6270643080 : do i=1,mgncol
3044 : ! microphysics output, note this is grid-averaged
3045 5890903200 : proc_rates%pratot(i,k) = pra(i,k)*lcldm(i,k)
3046 5890903200 : proc_rates%prctot(i,k) = prc(i,k)*lcldm(i,k)
3047 5890903200 : proc_rates%mnuccctot(i,k) = mnuccc(i,k)*lcldm(i,k)
3048 5890903200 : proc_rates%mnudeptot(i,k) = mnudep(i,k)*lcldm(i,k)
3049 5890903200 : proc_rates%mnuccttot(i,k) = mnucct(i,k)*lcldm(i,k)
3050 5890903200 : proc_rates%msacwitot(i,k) = msacwi(i,k)*lcldm(i,k)
3051 5890903200 : proc_rates%psacwstot(i,k) = psacws(i,k)*lcldm(i,k)
3052 5890903200 : proc_rates%bergstot(i,k) = bergs(i,k)*lcldm(i,k)
3053 5890903200 : proc_rates%vapdepstot(i,k) = vap_deps(i,k)
3054 5890903200 : proc_rates%bergtot(i,k) = berg(i,k)
3055 5890903200 : proc_rates%prcitot(i,k) = prci(i,k)*icldm(i,k)
3056 5890903200 : proc_rates%praitot(i,k) = prai(i,k)*icldm(i,k)
3057 5890903200 : proc_rates%mnuccdtot(i,k) = mnuccd(i,k)*icldm(i,k)
3058 5890903200 : proc_rates%pracstot(i,k) = pracs(i,k)*precip_frac(i,k)
3059 5890903200 : proc_rates%mnuccrtot(i,k) = mnuccr(i,k)*precip_frac(i,k)
3060 5890903200 : proc_rates%mnuccritot(i,k) = mnuccri(i,k)*precip_frac(i,k)
3061 5890903200 : proc_rates%psacrtot(i,k) = psacr(i,k)*precip_frac(i,k)
3062 5890903200 : proc_rates%pracgtot(i,k) = pracg(i,k)*precip_frac(i,k)
3063 5890903200 : proc_rates%psacwgtot(i,k) = psacwg(i,k)*lcldm(i,k)
3064 5890903200 : proc_rates%pgsacwtot(i,k) = pgsacw(i,k)*lcldm(i,k)
3065 5890903200 : proc_rates%pgracstot(i,k) = pgracs(i,k)*precip_frac(i,k)
3066 5890903200 : proc_rates%prdgtot(i,k) = prdg(i,k)*precip_frac(i,k)
3067 5890903200 : proc_rates%qmultgtot(i,k) = qmultg(i,k)*lcldm(i,k)
3068 5890903200 : proc_rates%qmultrgtot(i,k) = qmultrg(i,k)*precip_frac(i,k)
3069 5890903200 : proc_rates%npracgtot(i,k) = npracg(i,k)*precip_frac(i,k)
3070 5890903200 : proc_rates%nscngtot(i,k) = nscng(i,k)*lcldm(i,k)
3071 5890903200 : proc_rates%ngracstot(i,k) = ngracs(i,k)*precip_frac(i,k)
3072 5890903200 : proc_rates%nmultgtot(i,k) = nmultg(i,k)*lcldm(i,k)
3073 5890903200 : proc_rates%nmultrgtot(i,k) = nmultrg(i,k)*precip_frac(i,k)
3074 5890903200 : proc_rates%npsacwgtot(i,k) = npsacwg(i,k)*lcldm(i,k)
3075 :
3076 5890903200 : proc_rates%nnuccctot(i,k) = nnuccc(i,k)*lcldm(i,k)
3077 5890903200 : proc_rates%nnuccttot(i,k) = nnucct(i,k)*lcldm(i,k)
3078 5890903200 : proc_rates%nnuccdtot(i,k) = nnuccd(i,k)*icldm(i,k)
3079 5890903200 : proc_rates%nnudeptot(i,k) = nnudep(i,k)*lcldm(i,k)
3080 5890903200 : proc_rates%nnuccrtot(i,k) = nnuccr(i,k)*precip_frac(i,k)
3081 5890903200 : proc_rates%nnuccritot(i,k) = nnuccri(i,k)*precip_frac(i,k)
3082 5890903200 : proc_rates%nsacwitot(i,k) = nsacwi(i,k)*lcldm(i,k)
3083 5890903200 : proc_rates%npratot(i,k) = npra(i,k)*lcldm(i,k)
3084 5890903200 : proc_rates%npsacwstot(i,k) = npsacws(i,k)*lcldm(i,k)
3085 5890903200 : proc_rates%npraitot(i,k) = nprai(i,k)*icldm(i,k)
3086 5890903200 : proc_rates%npracstot(i,k) = npracs(i,k)*precip_frac(i,k)
3087 5890903200 : proc_rates%nprctot(i,k) = nprc(i,k)*lcldm(i,k)
3088 5890903200 : proc_rates%nraggtot(i,k) = nragg(i,k)*precip_frac(i,k)
3089 5890903200 : proc_rates%nprcitot(i,k) = nprci(i,k)*icldm(i,k)
3090 5890903200 : proc_rates%nmeltstot(i,k) = ninstsm(i,k)/deltat
3091 6266175552 : proc_rates%nmeltgtot(i,k) = ninstgm(i,k)/deltat
3092 : end do
3093 : end do
3094 : !$acc end parallel
3095 :
3096 : !$acc parallel vector_length(VLENS) default(present)
3097 : !$acc loop gang vector collapse(2)
3098 379739880 : do k=1,nlev
3099 6270643080 : do i=1,mgncol
3100 11781806400 : nctend(i,k) = nctend(i,k)+&
3101 : (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) &
3102 11781806400 : -npra(i,k)-nprc1(i,k)-npsacwg(i,k))*lcldm(i,k)
3103 :
3104 5890903200 : if (do_cldice) then
3105 5890903200 : if (use_hetfrz_classnuc) then
3106 0 : tmpfrz = nnuccc(i,k)
3107 : else
3108 : tmpfrz = 0._r8
3109 : end if
3110 : nitend(i,k) = nitend(i,k)+ nnuccd(i,k)+ &
3111 : (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- &
3112 5890903200 : nprai(i,k))*icldm(i,k)+(nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k)
3113 : end if
3114 :
3115 5890903200 : if(do_graupel.or.do_hail) then
3116 : nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ &
3117 5890903200 : nsagg(i,k)-ngracs(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k)
3118 5890903200 : ngtend(i,k) = ngtend(i,k)+nscng(i,k)*lcldm(i,k)+(ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k)
3119 : else
3120 : !necessary since mnuccr moved to graupel
3121 : nstend(i,k) = nstend(i,k)+(nsubs(i,k)+ &
3122 0 : nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k)+nprci(i,k)*icldm(i,k)
3123 : end if
3124 :
3125 : nrtend(i,k) = nrtend(i,k)+ &
3126 : nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) &
3127 5890903200 : -nnuccri(i,k)+nragg(i,k)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k)
3128 :
3129 : !-----------------------------------------------------
3130 : ! convert rain/snow q and N for output to history, note,
3131 : ! output is for gridbox average
3132 :
3133 5890903200 : qrout(i,k) = qr(i,k)
3134 5890903200 : nrout(i,k) = nr(i,k) * rho(i,k)
3135 5890903200 : qsout(i,k) = qs(i,k)
3136 5890903200 : nsout(i,k) = ns(i,k) * rho(i,k)
3137 5890903200 : qgout(i,k) = qg(i,k)
3138 6266175552 : ngout(i,k) = ng(i,k) * rho(i,k)
3139 : end do
3140 : end do
3141 : !$acc end parallel
3142 :
3143 : ! calculate n0r and lamr from rain mass and number
3144 : ! divide by precip fraction to get in-precip (local) values of
3145 : ! rain mass and number, divide by rhow to get rain number in kg^-1
3146 4467528 : call size_dist_param_basic(mg_rain_props, qric, nric, lamr, mgncol, nlev, n0=n0r)
3147 :
3148 : ! Calculate rercld
3149 : ! calculate mean size of combined rain and cloud water
3150 4467528 : call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol*nlev)
3151 :
3152 : ! Assign variables back to start-of-timestep values
3153 : ! Some state variables are changed before the main microphysics loop
3154 : ! to make "instantaneous" adjustments. Afterward, we must move those changes
3155 : ! back into the tendencies.
3156 : ! These processes:
3157 : ! - Droplet activation (npccn, impacts nc)
3158 : ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns)
3159 : ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns)
3160 : !================================================================================
3161 : ! Re-apply droplet activation tendency
3162 :
3163 : !$acc parallel vector_length(VLENS) default(present)
3164 : !$acc loop gang vector collapse(2)
3165 379739880 : do k=1,nlev
3166 6270643080 : do i=1,mgncol
3167 5890903200 : nc(i,k) = ncn(i,k)
3168 5890903200 : nctend(i,k) = nctend(i,k) + npccn(i,k)
3169 : ! Re-apply rain freezing and snow melting.
3170 5890903200 : dum_2D(i,k) = qs(i,k)
3171 5890903200 : qs(i,k) = qsn(i,k)
3172 5890903200 : qstend(i,k) = qstend(i,k) + (dum_2D(i,k)-qs(i,k))*rdeltat
3173 :
3174 5890903200 : dum_2D(i,k) = ns(i,k)
3175 5890903200 : ns(i,k) = nsn(i,k)
3176 5890903200 : nstend(i,k) = nstend(i,k) + (dum_2D(i,k)-ns(i,k))*rdeltat
3177 :
3178 5890903200 : dum_2D(i,k) = qr(i,k)
3179 5890903200 : qr(i,k) = qrn(i,k)
3180 5890903200 : qrtend(i,k) = qrtend(i,k) + (dum_2D(i,k)-qr(i,k))*rdeltat
3181 :
3182 5890903200 : dum_2D(i,k) = nr(i,k)
3183 5890903200 : nr(i,k) = nrn(i,k)
3184 5890903200 : nrtend(i,k) = nrtend(i,k) + (dum_2D(i,k)-nr(i,k))*rdeltat
3185 :
3186 : ! Re-apply graupel freezing/melting
3187 5890903200 : dum_2D(i,k) = qg(i,k)
3188 5890903200 : qg(i,k) = qgr(i,k)
3189 5890903200 : qgtend(i,k) = qgtend(i,k) + (dum_2D(i,k)-qg(i,k))*rdeltat
3190 :
3191 5890903200 : dum_2D(i,k) = ng(i,k)
3192 5890903200 : ng(i,k) = ngr(i,k)
3193 5890903200 : ngtend(i,k) = ngtend(i,k) + (dum_2D(i,k)-ng(i,k))*rdeltat
3194 : !.............................................................................
3195 : !================================================================================
3196 : ! modify to include snow. in prain & evap (diagnostic here: for wet dep)
3197 5890903200 : nevapr(i,k) = nevapr(i,k) + proc_rates%evapsnow(i,k)
3198 6266175552 : prain(i,k) = prain(i,k) + proc_rates%prodsnow(i,k)
3199 : end do
3200 : end do
3201 : !$acc end parallel
3202 :
3203 : !$acc parallel vector_length(VLENS) default(present)
3204 : !$acc loop gang vector collapse(2)
3205 379739880 : do k=1,nlev
3206 6270643080 : do i=1,mgncol
3207 : ! calculate sedimentation for cloud water and ice
3208 : ! and Graupel (mg3)
3209 : !================================================================================
3210 : ! update in-cloud cloud mixing ratio and number concentration
3211 : ! with microphysical tendencies to calculate sedimentation, assign to dummy vars
3212 : ! note: these are in-cloud values***, hence we divide by cloud fraction
3213 5890903200 : dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)/lcldm(i,k)
3214 5890903200 : dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)/icldm(i,k)
3215 5890903200 : dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k),0._r8)
3216 5890903200 : dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)/icldm(i,k),0._r8)
3217 :
3218 5890903200 : dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)/precip_frac(i,k)
3219 5890903200 : dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)/precip_frac(i,k),0._r8)
3220 5890903200 : dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)/precip_frac(i,k)
3221 5890903200 : dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)/precip_frac(i,k),0._r8)
3222 :
3223 5890903200 : dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat)/precip_frac(i,k)
3224 5890903200 : dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)/precip_frac(i,k),0._r8)
3225 :
3226 : ! switch for specification of droplet and crystal number
3227 5890903200 : if (ngcons) then
3228 0 : dumng(i,k)=ngnst/rho(i,k)
3229 : end if
3230 :
3231 : ! switch for specification of droplet and crystal number
3232 5890903200 : if (nccons) then
3233 0 : dumnc(i,k)=ncnst/rho(i,k)
3234 : end if
3235 :
3236 : ! switch for specification of cloud ice number
3237 5890903200 : if (nicons) then
3238 0 : dumni(i,k)=ninst/rho(i,k)
3239 : end if
3240 :
3241 : ! switch for specification of constant number
3242 5890903200 : if (nscons) then
3243 0 : dumns(i,k)=nsnst/rho(i,k)
3244 : end if
3245 :
3246 : ! switch for specification of constant number
3247 6266175552 : if (nrcons) then
3248 0 : dumnr(i,k)=nrnst/rho(i,k)
3249 : end if
3250 : end do
3251 : end do
3252 : !$acc end parallel
3253 :
3254 : ! obtain new slope parameter to avoid possible singularity
3255 4467528 : call size_dist_param_basic(mg_ice_props, dumi, dumni, lami, mgncol, nlev)
3256 4467528 : call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
3257 :
3258 : ! fallspeed for rain
3259 4467528 : call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev)
3260 : ! fallspeed for snow
3261 4467528 : call size_dist_param_basic(mg_snow_props, dums, dumns, lams, mgncol, nlev)
3262 : ! fallspeed for graupel
3263 4467528 : if (do_hail) then
3264 0 : call size_dist_param_basic(mg_hail_props, dumg, dumng, lamg, mgncol, nlev)
3265 : end if
3266 4467528 : if (do_graupel) then
3267 4467528 : call size_dist_param_basic(mg_graupel_props, dumg, dumng, lamg, mgncol, nlev)
3268 : end if
3269 :
3270 4467528 : if ( do_implicit_fall ) then
3271 : ! calculate interface height for implicit sedimentation
3272 : ! uses Hypsometric equation
3273 :
3274 : !$acc parallel vector_length(VLENS) default(present)
3275 : !$acc loop gang vector
3276 74597328 : do i=1,mgncol
3277 70129800 : zint(i,nlev+1)=0._r8
3278 : !$acc loop seq
3279 5965500528 : do k = nlev,1,-1
3280 5890903200 : H = r*t(i,k)/g*log(pint(i,k+1)/pint(i,k))
3281 5961033000 : zint(i,k)=zint(i,k+1)+H
3282 : enddo
3283 : enddo
3284 : !$acc end parallel
3285 : end if
3286 :
3287 : !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
3288 : !$acc loop gang vector collapse(2)
3289 379739880 : do k=1,nlev
3290 6270643080 : do i=1,mgncol
3291 : ! calculate number and mass weighted fall velocity for droplets and cloud ice
3292 : !-------------------------------------------------------------------
3293 5890903200 : if (dumc(i,k).ge.qsmall) then
3294 515312722 : dum1 = 4._r8+bc+pgam(i,k)
3295 515312722 : dum2 = pgam(i,k)+4._r8
3296 515312722 : proc_rates%vtrmc(i,k)=acn(i,k)*gamma(dum1)/(lamc(i,k)**bc*gamma(dum2))
3297 : ! Following ifs, no condensate sedimentation
3298 515312722 : if (ifs_sed) then
3299 0 : fc(i,k) = 0._r8
3300 0 : fnc(i,k) = 0._r8
3301 : else
3302 515312722 : dum3 = 1._r8+bc+pgam(i,k)
3303 515312722 : dum4 = pgam(i,k)+1._r8
3304 515312722 : fc(i,k) = g*rho(i,k)*proc_rates%vtrmc(i,k)
3305 : fnc(i,k) = g*rho(i,k)* &
3306 : acn(i,k)*gamma(dum3)/ &
3307 515312722 : (lamc(i,k)**bc*gamma(dum4))
3308 : end if
3309 : else
3310 5375590478 : fc(i,k) = 0._r8
3311 5375590478 : fnc(i,k)= 0._r8
3312 : end if
3313 :
3314 : ! redefine dummy variables - sedimentation is calculated over grid-scale
3315 : ! quantities to ensure conservation
3316 5890903200 : dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat)
3317 5890903200 : dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat),0._r8)
3318 6266175552 : if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8
3319 : end do
3320 : end do
3321 : !$acc end parallel
3322 :
3323 : !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
3324 : !$acc loop gang vector collapse(2)
3325 379739880 : do k=1,nlev
3326 6270643080 : do i=1,mgncol
3327 : ! calculate number and mass weighted fall velocity for cloud ice
3328 5890903200 : if (dumi(i,k).ge.qsmall) then
3329 0 : proc_rates%vtrmi(i,k)=min(ain(i,k)*gamma_bi_plus4/(6._r8*lami(i,k)**bi), &
3330 1933577142 : 1.2_r8*rhof(i,k))
3331 1933577142 : proc_rates%vtrmi(i,k)=proc_rates%vtrmi(i,k)*micro_mg_vtrmi_factor
3332 :
3333 1933577142 : fi(i,k) = g*rho(i,k)*proc_rates%vtrmi(i,k)
3334 : fni(i,k) = g*rho(i,k)* &
3335 1933577142 : min(ain(i,k)*gamma_bi_plus1/lami(i,k)**bi,1.2_r8*rhof(i,k))
3336 :
3337 : ! adjust the ice fall velocity for smaller (r < 20 um) ice
3338 : ! particles (blend over 8-20 um)
3339 1933577142 : irad = 1.5_r8 / lami(i,k) * 1e6_r8
3340 1933577142 : ifrac = min(1._r8, max(0._r8, (irad - 18._r8) / 2._r8))
3341 :
3342 1933577142 : if (ifrac .lt. 1._r8) then
3343 0 : proc_rates%vtrmi(i,k) = ifrac * proc_rates%vtrmi(i,k) + &
3344 : (1._r8 - ifrac) * &
3345 : min(ajn(i,k)*gamma_bj_plus4/(6._r8*lami(i,k)**bj), &
3346 509061122 : 1.2_r8*rhof(i,k))
3347 509061122 : proc_rates%vtrmi(i,k)=proc_rates%vtrmi(i,k)*micro_mg_vtrmi_factor
3348 :
3349 509061122 : fi(i,k) = g*rho(i,k)*proc_rates%vtrmi(i,k)
3350 : fni(i,k) = ifrac * fni(i,k) + &
3351 : (1._r8 - ifrac) * &
3352 : g*rho(i,k)* &
3353 509061122 : min(ajn(i,k)*gamma_bj_plus1/lami(i,k)**bj,1.2_r8*rhof(i,k))
3354 : end if
3355 :
3356 : ! Fix ice fall speed following IFS microphysics
3357 1933577142 : if (ifs_sed) then
3358 0 : fi(i,k)=g*rho(i,k)*0.1_r8
3359 0 : fni(i,k)=g*rho(i,k)*0.1_r8
3360 : end if
3361 : else
3362 3957326058 : fi(i,k) = 0._r8
3363 3957326058 : fni(i,k)= 0._r8
3364 : end if
3365 :
3366 : ! redefine dummy variables - sedimentation is calculated over grid-scale
3367 : ! quantities to ensure conservation
3368 5890903200 : dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat)
3369 5890903200 : dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat),0._r8)
3370 6266175552 : if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8
3371 : end do
3372 : end do
3373 : !$acc end parallel
3374 :
3375 : !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
3376 : !$acc loop gang vector
3377 74597328 : do i=1,mgncol
3378 : !$acc loop seq
3379 5965500528 : do k=1,nlev
3380 5890903200 : if (lamr(i,k).ge.qsmall) then
3381 1328674440 : qtmp = lamr(i,k)**br
3382 : ! 'final' values of number and mass weighted mean fallspeed for rain (m/s)
3383 1328674440 : unr(i,k) = min(arn(i,k)*gamma_br_plus1/qtmp,9.1_r8*rhof(i,k))
3384 1328674440 : fnr(i,k) = g*rho(i,k)*unr(i,k)
3385 1328674440 : proc_rates%umr(i,k) = min(arn(i,k)*gamma_br_plus4/(6._r8*qtmp),9.1_r8*rhof(i,k))
3386 1328674440 : fr(i,k) = g*rho(i,k)*proc_rates%umr(i,k)
3387 : else
3388 4562228760 : fr(i,k)=0._r8
3389 4562228760 : fnr(i,k)=0._r8
3390 : end if
3391 :
3392 : ! Fallspeed correction to ensure non-zero if rain in the column
3393 : ! from updated Morrison (WRFv3.3) and P3 schemes
3394 : ! If fallspeed exists at a higher level, apply it below to eliminate
3395 5890903200 : if (precip_fall_corr) then
3396 0 : if (k.gt.2) then
3397 0 : if (fr(i,k).lt.1.e-10_r8) then
3398 0 : fr(i,k)=fr(i,k-1)
3399 0 : fnr(i,k)=fnr(i,k-1)
3400 : end if
3401 : end if
3402 : end if
3403 :
3404 : ! redefine dummy variables - sedimentation is calculated over grid-scale
3405 : ! quantities to ensure conservation
3406 5890903200 : dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat)
3407 5890903200 : dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat),0._r8)
3408 5961033000 : if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8
3409 : end do
3410 : end do
3411 : !$acc end parallel
3412 :
3413 : !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
3414 : !$acc loop gang vector
3415 74597328 : do i=1,mgncol
3416 : !$acc loop seq
3417 5965500528 : do k=1,nlev
3418 5890903200 : if (lams(i,k).ge.qsmall) then
3419 1524747491 : qtmp = lams(i,k)**bs
3420 : ! 'final' values of number and mass weighted mean fallspeed for snow (m/s)
3421 1524747491 : proc_rates%ums(i,k) = min(asn(i,k)*gamma_bs_plus4/(6._r8*qtmp),1.2_r8*rhof(i,k))
3422 1524747491 : proc_rates%ums(i,k) = proc_rates%ums(i,k)*micro_mg_vtrms_factor
3423 :
3424 1524747491 : fs(i,k) = g*rho(i,k)*proc_rates%ums(i,k)
3425 1524747491 : uns(i,k) = min(asn(i,k)*gamma_bs_plus1/qtmp,1.2_r8*rhof(i,k))
3426 1524747491 : fns(i,k) = g*rho(i,k)*uns(i,k)
3427 : ! Fix fallspeed for snow
3428 1524747491 : if (ifs_sed) then
3429 0 : proc_rates%ums(i,k) = 1._r8
3430 0 : uns(i,k) = 1._r8
3431 : end if
3432 : else
3433 4366155709 : fs(i,k)=0._r8
3434 4366155709 : fns(i,k)=0._r8
3435 : end if
3436 :
3437 5890903200 : if (precip_fall_corr) then
3438 0 : if (k.gt.2) then
3439 0 : if (fs(i,k).lt.1.e-10_r8) then
3440 0 : fs(i,k)=fs(i,k-1)
3441 0 : fns(i,k)=fns(i,k-1)
3442 : end if
3443 : end if
3444 : end if
3445 :
3446 : ! redefine dummy variables - sedimentation is calculated over grid-scale
3447 : ! quantities to ensure conservation
3448 5890903200 : dums(i,k) = (qs(i,k)+qstend(i,k)*deltat)
3449 5890903200 : dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat),0._r8)
3450 5961033000 : if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8
3451 : end do
3452 : end do
3453 : !$acc end parallel
3454 :
3455 : !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
3456 : !$acc loop gang vector
3457 74597328 : do i=1,mgncol
3458 : !$acc loop seq
3459 5965500528 : do k=1,nlev
3460 5890903200 : if (lamg(i,k).ge.qsmall) then
3461 729470418 : qtmp = lamg(i,k)**bgtmp
3462 : ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s)
3463 729470418 : proc_rates%umg(i,k) = min(agn(i,k)*gamma_bg_plus4/(6._r8*qtmp),20._r8*rhof(i,k))
3464 729470418 : fg(i,k) = g*rho(i,k)*proc_rates%umg(i,k)
3465 729470418 : ung(i,k) = min(agn(i,k)*gamma_bg_plus1/qtmp,20._r8*rhof(i,k))
3466 729470418 : fng(i,k) = g*rho(i,k)*ung(i,k)
3467 : else
3468 5161432782 : fg(i,k)=0._r8
3469 5161432782 : fng(i,k)=0._r8
3470 : end if
3471 :
3472 5890903200 : if (precip_fall_corr) then
3473 0 : if (k.gt.2) then
3474 0 : if (fg(i,k).lt.1.e-10_r8) then
3475 0 : fg(i,k)=fg(i,k-1)
3476 0 : fng(i,k)=fng(i,k-1)
3477 : end if
3478 : end if
3479 : end if
3480 :
3481 : ! redefine dummy variables - sedimentation is calculated over grid-scale
3482 : ! quantities to ensure conservation
3483 5890903200 : dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat)
3484 5890903200 : dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat),0._r8)
3485 5961033000 : if (dumg(i,k).lt.qsmall) dumng(i,k)=0._r8
3486 : end do
3487 : end do
3488 : !$acc end parallel
3489 :
3490 : ! ----------------------------------------------
3491 : ! Sedimentation
3492 : ! ----------------------------------------------
3493 :
3494 4467528 : if ( do_implicit_fall ) then
3495 :
3496 : ! Implicit Sedimentation calculation: from Guo et al, 2021, GFDL version.
3497 :
3498 : !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
3499 : !$acc loop gang vector collapse(2)
3500 379739880 : do k=1,nlev
3501 6270643080 : do i=1,mgncol
3502 5890903200 : fc(i,k) = vfac_drop * fc(i,k)/g/rho(i,k)
3503 6266175552 : fnc(i,k) = vfac_drop * fnc(i,k)/g/rho(i,k)
3504 : end do
3505 : end do
3506 : !$acc end parallel
3507 :
3508 : !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
3509 : !$acc loop gang vector collapse(2)
3510 379739880 : do k=1,nlev
3511 6270643080 : do i=1,mgncol
3512 5890903200 : fi(i,k) = vfac_ice * fi(i,k)/g/rho(i,k)
3513 6266175552 : fni(i,k) = vfac_ice * fni(i,k)/g/rho(i,k)
3514 : end do
3515 : end do
3516 : !$acc end parallel
3517 :
3518 : !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
3519 : !$acc loop gang vector collapse(2)
3520 379739880 : do k=1,nlev
3521 6270643080 : do i=1,mgncol
3522 5890903200 : fr(i,k) = vfactor * fr(i,k)/g/rho(i,k)
3523 6266175552 : fnr(i,k) = vfactor * fnr(i,k)/g/rho(i,k)
3524 : end do
3525 : end do
3526 : !$acc end parallel
3527 :
3528 : !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
3529 : !$acc loop gang vector collapse(2)
3530 379739880 : do k=1,nlev
3531 6270643080 : do i=1,mgncol
3532 5890903200 : fs(i,k) = vfactor * fs(i,k)/g/rho(i,k)
3533 6266175552 : fns(i,k) = vfactor * fns(i,k)/g/rho(i,k)
3534 : end do
3535 : end do
3536 : !$acc end parallel
3537 :
3538 : !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
3539 : !$acc loop gang vector collapse(2)
3540 379739880 : do k=1,nlev
3541 6270643080 : do i=1,mgncol
3542 5890903200 : fg(i,k) = vfactor * fg(i,k)/g/rho(i,k)
3543 6266175552 : fng(i,k) = vfactor * fng(i,k)/g/rho(i,k)
3544 : end do
3545 : end do
3546 : !$acc end parallel
3547 :
3548 : ! cloud water mass sedimentation
3549 :
3550 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumc,fc,.FALSE.,qctend, &
3551 4467528 : LQUEUE,xflx=lflx,qxsedten=proc_rates%qcsedten,prect=prect_l)
3552 :
3553 : ! cloud water number sedimentation
3554 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumnc,fnc,.FALSE.,nctend, &
3555 4467528 : LQUEUE,qxsedten=proc_rates%ncsedten)
3556 :
3557 : ! cloud ice mass sedimentation
3558 :
3559 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumi,fi,.FALSE.,qitend, &
3560 4467528 : IQUEUE,xflx=iflx,qxsedten=proc_rates%qisedten,prect=prect_i,preci=preci_i)
3561 :
3562 : ! cloud ice number sedimentation
3563 :
3564 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumni,fni,.FALSE.,nitend, &
3565 4467528 : IQUEUE,qxsedten=proc_rates%nisedten)
3566 :
3567 : ! rain water mass sedimentation
3568 :
3569 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumr,fr,.TRUE.,qrtend, &
3570 4467528 : RQUEUE,xflx=rflx,qxsedten=proc_rates%qrsedten,prect=prect_r)
3571 :
3572 : ! rain water number sedimentation
3573 :
3574 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumnr,fnr,.TRUE.,nrtend, &
3575 4467528 : RQUEUE,qxsedten=proc_rates%nrsedten)
3576 :
3577 : ! snow water mass sedimentation
3578 :
3579 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dums,fs,.TRUE.,qstend, &
3580 4467528 : SQUEUE,xflx=sflx,qxsedten=proc_rates%qssedten,prect=prect_s,preci=preci_s)
3581 :
3582 : ! snow water number sedimentation
3583 :
3584 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumns,fns,.TRUE.,nstend, &
3585 4467528 : SQUEUE,qxsedten=proc_rates%nssedten)
3586 :
3587 : ! graupel mass sedimentation
3588 :
3589 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumg,fg,.TRUE.,qgtend, &
3590 4467528 : GQUEUE,xflx=gflx,qxsedten=proc_rates%qgsedten,prect=prect_g,preci=preci_g)
3591 :
3592 : ! graupel number sedimentation
3593 :
3594 : call Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumng,fng,.TRUE.,ngtend, &
3595 4467528 : GQUEUE,qxsedten=proc_rates%ngsedten)
3596 :
3597 : else
3598 :
3599 : ! Explicit Sedimentation calculation
3600 :
3601 : !$acc parallel vector_length(VLENS) default(present) async(IQUEUE)
3602 : !$acc loop gang vector
3603 0 : do i = 1, mgncol
3604 0 : nstep_i(i) = 1 + int( max( maxval( fi(i,:)*pdel_inv(i,:) ), maxval( fni(i,:)*pdel_inv(i,:) ) ) * deltat )
3605 0 : rnstep_i(i) = 1._r8/real(nstep_i(i))
3606 : end do
3607 : !$acc end parallel
3608 :
3609 : ! ice mass sediment
3610 : call Sedimentation(mgncol,nlev,do_cldice,deltat,nstep_i,rnstep_i,fi,dumi,pdel_inv, &
3611 : qitend,IQUEUE,qxsedten=proc_rates%qisedten,prect=prect_i,xflx=iflx,xxlx=xxls, &
3612 0 : qxsevap=proc_rates%qisevap,tlat=tlat_i,qvlat=qvlat_i,xcldm=icldm,preci=preci_i)
3613 :
3614 : ! ice number sediment
3615 : call Sedimentation(mgncol,nlev,do_cldice,deltat,nstep_i,rnstep_i,fni,dumni,pdel_inv, &
3616 0 : nitend,IQUEUE,xcldm=icldm,qxsedten=proc_rates%nisedten)
3617 :
3618 : !$acc parallel vector_length(VLENS) default(present) async(LQUEUE)
3619 : !$acc loop gang vector
3620 0 : do i = 1, mgncol
3621 0 : nstep_l(i) = 1 + int( max( maxval( fc(i,:)*pdel_inv(i,:) ), maxval( fnc(i,:)*pdel_inv(i,:) ) ) * deltat )
3622 0 : rnstep_l(i) = 1._r8/real(nstep_l(i))
3623 : end do
3624 : !$acc end parallel
3625 :
3626 : ! liq mass sediment
3627 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_l,rnstep_l,fc,dumc,pdel_inv, &
3628 : qctend,LQUEUE,qxsedten=proc_rates%qcsedten,prect=prect_l,xflx=lflx,xxlx=xxlv, &
3629 0 : qxsevap=proc_rates%qcsevap,tlat=tlat_l,qvlat=qvlat_l,xcldm=lcldm)
3630 :
3631 : ! liq number sediment
3632 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_l,rnstep_l,fnc,dumnc,pdel_inv, &
3633 0 : nctend,LQUEUE,xcldm=lcldm,qxsedten=proc_rates%ncsedten)
3634 :
3635 : !$acc parallel vector_length(VLENS) default(present) async(RQUEUE)
3636 : !$acc loop gang vector
3637 0 : do i = 1, mgncol
3638 0 : nstep_r(i) = 1 + int( max( maxval( fr(i,:)*pdel_inv(i,:) ), maxval( fnr(i,:)*pdel_inv(i,:) ) ) * deltat )
3639 0 : rnstep_r(i) = 1._r8/real(nstep_r(i))
3640 : end do
3641 : !$acc end parallel
3642 :
3643 : ! rain mass sediment
3644 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_r,rnstep_r,fr,dumr,pdel_inv, &
3645 0 : qrtend,RQUEUE,qxsedten=proc_rates%qrsedten,prect=prect_r,xflx=rflx)
3646 :
3647 : ! rain number sediment
3648 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_r,rnstep_r,fnr,dumnr,pdel_inv, &
3649 0 : nrtend,RQUEUE,qxsedten=proc_rates%nrsedten)
3650 :
3651 : !$acc parallel vector_length(VLENS) default(present) async(SQUEUE)
3652 : !$acc loop gang vector
3653 0 : do i = 1, mgncol
3654 0 : nstep_s(i) = 1 + int( max( maxval( fs(i,:)*pdel_inv(i,:) ), maxval( fns(i,:)*pdel_inv(i,:) ) ) * deltat )
3655 0 : rnstep_s(i) = 1._r8/real(nstep_s(i))
3656 : end do
3657 : !$acc end parallel
3658 :
3659 : ! snow mass sediment
3660 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_s,rnstep_s,fs,dums,pdel_inv, &
3661 0 : qstend,SQUEUE,qxsedten=proc_rates%qssedten,prect=prect_s,xflx=sflx,preci=preci_s)
3662 :
3663 : ! snow number sediment
3664 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_s,rnstep_s,fns,dumns,pdel_inv, &
3665 0 : nstend,SQUEUE,qxsedten=proc_rates%nssedten)
3666 :
3667 : !$acc parallel vector_length(VLENS) default(present) async(GQUEUE)
3668 : !$acc loop gang vector
3669 0 : do i = 1, mgncol
3670 0 : nstep_g(i) = 1 + int( max( maxval( fg(i,:)*pdel_inv(i,:) ), maxval( fng(i,:)*pdel_inv(i,:) ) ) * deltat )
3671 0 : rnstep_g(i) = 1._r8/real(nstep_g(i))
3672 : end do
3673 : !$acc end parallel
3674 :
3675 : ! graupel mass sediment
3676 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_g,rnstep_g,fg,dumg,pdel_inv, &
3677 0 : qgtend,GQUEUE,qxsedten=proc_rates%qgsedten,prect=prect_g,xflx=gflx,preci=preci_g)
3678 :
3679 : ! graupel number sediment
3680 : call Sedimentation(mgncol,nlev,.TRUE.,deltat,nstep_g,rnstep_g,fng,dumng,pdel_inv, &
3681 0 : ngtend,GQUEUE,qxsedten=proc_rates%ngsedten)
3682 :
3683 : end if
3684 : ! ----------------------------------------------
3685 : ! End Sedimentation
3686 : ! ----------------------------------------------
3687 :
3688 : ! sum up the changes due to sedimentation process for different hydrometeors
3689 :
3690 : !$acc parallel vector_length(VLENS) default(present) wait(IQUEUE,LQUEUE)
3691 : !$acc loop gang vector collapse(2)
3692 379739880 : do k=1,nlev
3693 6270643080 : do i=1,mgncol
3694 5890903200 : tlat(i,k) = tlat(i,k) + tlat_i(i,k) + tlat_l(i,k)
3695 6266175552 : qvlat(i,k) = qvlat(i,k) + qvlat_i(i,k) + qvlat_l(i,k)
3696 : end do
3697 : end do
3698 : !$acc end parallel
3699 :
3700 : !$acc parallel vector_length(VLENS) wait(RQUEUE,SQUEUE,GQUEUE)
3701 : !$acc loop gang vector
3702 74597328 : do i=1,mgncol
3703 70129800 : prect(i) = prect(i) + prect_i(i) + prect_l(i) + prect_r(i) + prect_s(i) + prect_g(i)
3704 74597328 : preci(i) = preci(i) + preci_i(i) + preci_s(i) + preci_g(i)
3705 : end do
3706 : !$acc end parallel
3707 :
3708 : !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
3709 :
3710 : ! get new update for variables that includes sedimentation tendency
3711 : ! note : here dum variables are grid-average, NOT in-cloud
3712 :
3713 : !$acc parallel vector_length(VLENS) default(present)
3714 : !$acc loop gang vector collapse(2)
3715 379739880 : do k=1,nlev
3716 6270643080 : do i=1,mgncol
3717 5890903200 : dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)
3718 5890903200 : dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)
3719 5890903200 : dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)
3720 5890903200 : dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)
3721 :
3722 5890903200 : dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)
3723 5890903200 : dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)
3724 5890903200 : dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)
3725 5890903200 : dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)
3726 5890903200 : dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat,0._r8)
3727 5890903200 : dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat,0._r8)
3728 :
3729 : ! switch for specification of droplet and crystal number
3730 5890903200 : if (nccons) then
3731 0 : dumnc(i,k)=ncnst/rho(i,k)*lcldm(i,k)
3732 : end if
3733 :
3734 : ! switch for specification of cloud ice number
3735 5890903200 : if (nicons) then
3736 0 : dumni(i,k)=ninst/rho(i,k)*icldm(i,k)
3737 : end if
3738 :
3739 : ! switch for specification of graupel number
3740 5890903200 : if (ngcons) then
3741 0 : dumng(i,k)=ngnst/rho(i,k)*precip_frac(i,k)
3742 : end if
3743 :
3744 : ! switch for specification of constant snow number
3745 5890903200 : if (nscons) then
3746 0 : dumns(i,k)=nsnst/rho(i,k)
3747 : end if
3748 :
3749 : ! switch for specification of constant rain number
3750 5890903200 : if (nrcons) then
3751 0 : dumnr(i,k)=nrnst/rho(i,k)
3752 : end if
3753 :
3754 5890903200 : if (dumc(i,k).lt.qsmall) dumnc(i,k)=0._r8
3755 5890903200 : if (dumi(i,k).lt.qsmall) dumni(i,k)=0._r8
3756 5890903200 : if (dumr(i,k).lt.qsmall) dumnr(i,k)=0._r8
3757 5890903200 : if (dums(i,k).lt.qsmall) dumns(i,k)=0._r8
3758 5890903200 : if (dumg(i,k).lt.qsmall) dumng(i,k)=0._r8
3759 :
3760 : ! calculate instantaneous processes (melting, homogeneous freezing)
3761 : !====================================================================
3762 : ! melting of snow at +2 C
3763 :
3764 5890903200 : if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then
3765 1042349170 : if (dums(i,k) > 0._r8) then
3766 : ! make sure melting snow doesn't reduce temperature below threshold
3767 40917756 : dum = -xlf/cpp*dums(i,k)
3768 40917756 : if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt. snowmelt) then
3769 675149 : dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf
3770 675149 : dum = dum/dums(i,k)
3771 675149 : dum = max(0._r8,dum)
3772 675149 : dum = min(1._r8,dum)
3773 : else
3774 : dum = 1._r8
3775 : end if
3776 :
3777 40917756 : qstend(i,k)=qstend(i,k)-dum*dums(i,k)*rdeltat
3778 40917756 : nstend(i,k)=nstend(i,k)-dum*dumns(i,k)*rdeltat
3779 40917756 : qrtend(i,k)=qrtend(i,k)+dum*dums(i,k)*rdeltat
3780 40917756 : nrtend(i,k)=nrtend(i,k)+dum*dumns(i,k)*rdeltat
3781 :
3782 40917756 : dum1=-xlf*dum*dums(i,k)*rdeltat
3783 40917756 : tlat(i,k)=tlat(i,k)+dum1
3784 40917756 : proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
3785 :
3786 : !STOPPED FIX FOR SNOW NUMBER
3787 : !ensure that snow... number does not go negative with constant number set
3788 : !necessary because dumng is updated above.
3789 40917756 : if (nscons .and. ((ns(i,k)+nstend(i,k)*deltat) .lt. 0._r8)) then
3790 0 : nstend(i,k)=-ns(i,k)*rdeltat
3791 : end if
3792 : end if
3793 : end if
3794 :
3795 : ! melting of graupel at +2 C
3796 :
3797 6266175552 : if (t(i,k)+tlat(i,k)/cpp*deltat > snowmelt) then
3798 1041674032 : if (dumg(i,k) > 0._r8) then
3799 : ! make sure melting graupel doesn't reduce temperature below threshold
3800 36841612 : dum = -xlf/cpp*dumg(i,k)
3801 36841612 : if (t(i,k)+tlat(i,k)/cpp*deltat+dum .lt. snowmelt) then
3802 323198 : dum = (t(i,k)+tlat(i,k)/cpp*deltat-snowmelt)*cpp/xlf
3803 323198 : dum = dum/dumg(i,k)
3804 323198 : dum = max(0._r8,dum)
3805 323198 : dum = min(1._r8,dum)
3806 : else
3807 : dum = 1._r8
3808 : end if
3809 :
3810 36841612 : qgtend(i,k)=qgtend(i,k)-dum*dumg(i,k)*rdeltat
3811 36841612 : ngtend(i,k)=ngtend(i,k)-dum*dumng(i,k)*rdeltat
3812 36841612 : qrtend(i,k)=qrtend(i,k)+dum*dumg(i,k)*rdeltat
3813 36841612 : nrtend(i,k)=nrtend(i,k)+dum*dumng(i,k)*rdeltat
3814 :
3815 36841612 : dum1=-xlf*dum*dumg(i,k)*rdeltat
3816 36841612 : tlat(i,k)=tlat(i,k)+dum1
3817 36841612 : proc_rates%meltsdttot(i,k)=proc_rates%meltsdttot(i,k) + dum1
3818 :
3819 : !ensure that graupel number does not go negative with constant number set
3820 : !necessary because dumng is updated above.
3821 36841612 : if (ngcons .and. ((ng(i,k)+ngtend(i,k)*deltat) .lt. 0._r8)) then
3822 0 : ngtend(i,k)=-ng(i,k)*rdeltat
3823 : end if
3824 : end if
3825 : end if
3826 : end do
3827 : end do
3828 : !$acc end parallel
3829 :
3830 : ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice
3831 : ! depending on mean rain size
3832 : ! add to graupel if using that option....
3833 4467528 : call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev)
3834 :
3835 : !$acc parallel vector_length(VLENS) default(present)
3836 : !$acc loop gang vector collapse(2)
3837 379739880 : do k=1,nlev
3838 6270643080 : do i=1,mgncol
3839 : ! freezing of rain at -5 C
3840 6266175552 : if (t(i,k)+tlat(i,k)/cpp*deltat < rainfrze) then
3841 3233767098 : if (dumr(i,k) > 0._r8) then
3842 : ! make sure freezing rain doesn't increase temperature above threshold
3843 8484716 : dum = xlf/cpp*dumr(i,k)
3844 8484716 : if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.rainfrze) then
3845 5 : dum = -(t(i,k)+tlat(i,k)/cpp*deltat-rainfrze)*cpp/xlf
3846 5 : dum = dum/dumr(i,k)
3847 5 : dum = max(0._r8,dum)
3848 5 : dum = min(1._r8,dum)
3849 : else
3850 : dum = 1._r8
3851 : end if
3852 :
3853 8484716 : qrtend(i,k)=qrtend(i,k)-dum*dumr(i,k)*rdeltat
3854 8484716 : nrtend(i,k)=nrtend(i,k)-dum*dumnr(i,k)*rdeltat
3855 :
3856 8484716 : if (lamr(i,k) < 1._r8/Dcs) then
3857 284368 : if (do_hail.or.do_graupel) then
3858 284368 : qgtend(i,k)=qgtend(i,k)+dum*dumr(i,k)*rdeltat
3859 284368 : ngtend(i,k)=ngtend(i,k)+dum*dumnr(i,k)*rdeltat
3860 : else
3861 0 : qstend(i,k)=qstend(i,k)+dum*dumr(i,k)*rdeltat
3862 0 : nstend(i,k)=nstend(i,k)+dum*dumnr(i,k)*rdeltat
3863 : end if
3864 : else
3865 8200348 : qitend(i,k)=qitend(i,k)+dum*dumr(i,k)*rdeltat
3866 8200348 : nitend(i,k)=nitend(i,k)+dum*dumnr(i,k)*rdeltat
3867 : end if
3868 :
3869 : ! heating tendency
3870 8484716 : dum1 = xlf*dum*dumr(i,k)*rdeltat
3871 8484716 : proc_rates%frzrdttot(i,k)=proc_rates%frzrdttot(i,k) + dum1
3872 8484716 : tlat(i,k)=tlat(i,k)+dum1
3873 : end if
3874 : end if
3875 : end do
3876 : end do
3877 : !$acc end parallel
3878 :
3879 4467528 : if (do_cldice) then
3880 : !$acc parallel vector_length(VLENS) default(present)
3881 : !$acc loop gang vector collapse(2)
3882 379739880 : do k=1,nlev
3883 6270643080 : do i=1,mgncol
3884 5890903200 : if (t(i,k)+tlat(i,k)/cpp*deltat > tmelt) then
3885 1123406578 : if (dumi(i,k) > 0._r8) then
3886 : ! limit so that melting does not push temperature below freezing
3887 : !-----------------------------------------------------------------
3888 1123406503 : dum = -dumi(i,k)*xlf/cpp
3889 1123406503 : if (t(i,k)+tlat(i,k)/cpp*deltat+dum.lt.tmelt) then
3890 10954 : dum = (t(i,k)+tlat(i,k)/cpp*deltat-tmelt)*cpp/xlf
3891 10954 : dum = dum/dumi(i,k)
3892 10954 : dum = max(0._r8,dum)
3893 10954 : dum = min(1._r8,dum)
3894 : else
3895 : dum = 1._r8
3896 : end if
3897 :
3898 1123406503 : qctend(i,k)=qctend(i,k)+dum*dumi(i,k)*rdeltat
3899 :
3900 : ! for output
3901 1123406503 : proc_rates%melttot(i,k)=dum*dumi(i,k)*rdeltat
3902 :
3903 : ! assume melting ice produces droplet
3904 : ! mean volume radius of 8 micron
3905 :
3906 0 : proc_rates%nmelttot(i,k)=3._r8*dum*dumi(i,k)*rdeltat/ &
3907 1123406503 : (4._r8*pi*5.12e-16_r8*rhow)
3908 1123406503 : nctend(i,k)=nctend(i,k)+proc_rates%nmelttot(i,k)
3909 :
3910 1123406503 : qitend(i,k)=((1._r8-dum)*dumi(i,k)-qi(i,k))*rdeltat
3911 1123406503 : nitend(i,k)=((1._r8-dum)*dumni(i,k)-ni(i,k))*rdeltat
3912 1123406503 : tlat(i,k)=tlat(i,k)-xlf*dum*dumi(i,k)*rdeltat
3913 : end if
3914 : end if
3915 :
3916 : ! homogeneously freeze droplets at -40 C
3917 : !-----------------------------------------------------------------
3918 :
3919 5890903200 : if (t(i,k)+tlat(i,k)/cpp*deltat < 233.15_r8) then
3920 3233767098 : if (dumc(i,k) > 0._r8) then
3921 : ! limit so that freezing does not push temperature above threshold
3922 15671477 : dum = dumc(i,k)*xlf/cpp
3923 15671477 : if (t(i,k)+tlat(i,k)/cpp*deltat+dum.gt.233.15_r8) then
3924 6 : dum = -(t(i,k)+tlat(i,k)/cpp*deltat-233.15_r8)*cpp/xlf
3925 6 : dum = dum/dumc(i,k)
3926 6 : dum = max(0._r8,dum)
3927 6 : dum = min(1._r8,dum)
3928 : else
3929 : dum = 1._r8
3930 : end if
3931 :
3932 15671477 : qitend(i,k)=qitend(i,k)+dum*dumc(i,k)*rdeltat
3933 : ! for output
3934 15671477 : proc_rates%homotot(i,k)=dum*dumc(i,k)*rdeltat
3935 :
3936 : ! assume 25 micron mean volume radius of homogeneously frozen droplets
3937 : ! consistent with size of detrained ice in stratiform.F90
3938 15671477 : proc_rates%nhomotot(i,k)=dum*3._r8*dumc(i,k)/(4._r8*3.14_r8*micro_mg_homog_size**3._r8*500._r8)*rdeltat
3939 15671477 : nitend(i,k)=nitend(i,k)+proc_rates%nhomotot(i,k)
3940 :
3941 15671477 : qctend(i,k)=((1._r8-dum)*dumc(i,k)-qc(i,k))*rdeltat
3942 15671477 : nctend(i,k)=((1._r8-dum)*dumnc(i,k)-nc(i,k))*rdeltat
3943 15671477 : tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)*rdeltat
3944 : end if
3945 : end if
3946 :
3947 : ! ice number limiter
3948 5890903200 : if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.micro_mg_max_nicons*icldm(i,k)/rho(i,k)) then
3949 7687780 : nitend(i,k)=max(0._r8,(micro_mg_max_nicons*icldm(i,k)/rho(i,k)-ni(i,k))/deltat)
3950 : end if
3951 :
3952 : ! remove any excess over-saturation, which is possible due to non-linearity when adding
3953 : ! together all microphysical processes
3954 : !-----------------------------------------------------------------
3955 : ! follow code similar to old CAM scheme
3956 :
3957 5890903200 : dum_2D(i,k)=q(i,k)+qvlat(i,k)*deltat
3958 6266175552 : ttmpA(i,k)=t(i,k)+tlat(i,k)/cpp*deltat
3959 : end do
3960 : end do
3961 : !$acc end parallel
3962 :
3963 : ! use rhw to allow ice supersaturation
3964 4467528 : call qsat_water(ttmpA, p, esnA, qvnA, mgncol*nlev)
3965 :
3966 : !$acc parallel vector_length(VLENS) default(present)
3967 : !$acc loop gang vector collapse(2)
3968 379739880 : do k=1,nlev
3969 6270643080 : do i=1,mgncol
3970 6266175552 : if (dum_2D(i,k) > qvnA(i,k) .and. qvnA(i,k) > 0 .and. remove_supersat) then
3971 : ! expression below is approximate since there may be ice deposition
3972 0 : dum = (dum_2D(i,k)-qvnA(i,k))/(1._r8+xxlv_squared*qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))*rdeltat
3973 : ! add to output cme
3974 0 : cmeout(i,k) = cmeout(i,k)+dum
3975 : ! now add to tendencies, partition between liquid and ice based on temperature
3976 0 : if (ttmpA(i,k) > 268.15_r8) then
3977 0 : dum1=0.0_r8
3978 : ! now add to tendencies, partition between liquid and ice based on te
3979 : !-------------------------------------------------------
3980 0 : else if (ttmpA(i,k) < 238.15_r8) then
3981 0 : dum1=1.0_r8
3982 : else
3983 0 : dum1=(268.15_r8-ttmpA(i,k))/30._r8
3984 : end if
3985 : dum = (dum_2D(i,k)-qvnA(i,k))/(1._r8+(xxls*dum1+xxlv*(1._r8-dum1))**2 &
3986 0 : *qvnA(i,k)/(cpp*rv*ttmpA(i,k)**2))*rdeltat
3987 0 : qctend(i,k)=qctend(i,k)+dum*(1._r8-dum1)
3988 : ! for output
3989 0 : proc_rates%qcrestot(i,k)=dum*(1._r8-dum1)
3990 0 : qitend(i,k)=qitend(i,k)+dum*dum1
3991 0 : proc_rates%qirestot(i,k)=dum*dum1
3992 0 : qvlat(i,k)=qvlat(i,k)-dum
3993 : ! for output
3994 0 : proc_rates%qvres(i,k)=-dum
3995 0 : tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls
3996 : end if
3997 : end do
3998 : end do
3999 : !$acc end parallel
4000 : end if
4001 :
4002 : ! calculate effective radius for pass to radiation code
4003 : !=========================================================
4004 : ! if no cloud water, default value is 10 micron for droplets,
4005 : ! 25 micron for cloud ice
4006 :
4007 : ! update cloud variables after instantaneous processes to get effective radius
4008 : ! variables are in-cloud to calculate size dist parameters
4009 :
4010 : !$acc parallel vector_length(VLENS) default(present)
4011 : !$acc loop gang vector collapse(2)
4012 379739880 : do k=1,nlev
4013 6270643080 : do i=1,mgncol
4014 5890903200 : dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat,0._r8)/lcldm(i,k)
4015 5890903200 : dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat,0._r8)/icldm(i,k)
4016 5890903200 : dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat,0._r8)/lcldm(i,k)
4017 5890903200 : dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat,0._r8)/icldm(i,k)
4018 :
4019 5890903200 : dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat,0._r8)/precip_frac(i,k)
4020 5890903200 : dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat,0._r8)/precip_frac(i,k)
4021 5890903200 : dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat,0._r8)/precip_frac(i,k)
4022 5890903200 : dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat,0._r8)/precip_frac(i,k)
4023 5890903200 : dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat,0._r8)
4024 5890903200 : dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat,0._r8)
4025 :
4026 : ! switch for specification of droplet and crystal number
4027 5890903200 : if (nccons) then
4028 0 : dumnc(i,k)=ncnst/rho(i,k)
4029 : end if
4030 :
4031 : ! switch for specification of cloud ice number
4032 5890903200 : if (nicons) then
4033 0 : dumni(i,k)=ninst/rho(i,k)
4034 : end if
4035 :
4036 : ! switch for specification of graupel number
4037 5890903200 : if (ngcons) then
4038 0 : dumng(i,k)=ngnst/rho(i,k)*precip_frac(i,k)
4039 : end if
4040 :
4041 : ! switch for specification of constant snow number
4042 5890903200 : if (nscons) then
4043 0 : dumns(i,k)=nsnst/rho(i,k)
4044 : end if
4045 :
4046 : ! switch for specification of constant rain number
4047 5890903200 : if (nrcons) then
4048 0 : dumnr(i,k)=nrnst/rho(i,k)
4049 : end if
4050 :
4051 : ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1
4052 5890903200 : dumc(i,k)=min(dumc(i,k),5.e-3_r8)
4053 5890903200 : dumi(i,k)=min(dumi(i,k),5.e-3_r8)
4054 : ! limit in-precip mixing ratios
4055 5890903200 : dumr(i,k)=min(dumr(i,k),10.e-3_r8)
4056 5890903200 : dums(i,k)=min(dums(i,k),10.e-3_r8)
4057 6266175552 : dumg(i,k)=min(dumg(i,k),10.e-3_r8)
4058 : end do
4059 : end do
4060 : !$acc end parallel
4061 :
4062 : ! cloud ice effective radius
4063 : !-----------------------------------------------------------------
4064 4467528 : if (do_cldice) then
4065 : !$acc parallel vector_length(VLENS) default(present)
4066 : !$acc loop gang vector collapse(2)
4067 379739880 : do k=1,nlev
4068 6270643080 : do i=1,mgncol
4069 6266175552 : dum_2D(i,k) = dumni(i,k)
4070 : end do
4071 : end do
4072 : !$acc end parallel
4073 :
4074 4467528 : call size_dist_param_basic(mg_ice_props, dumi, dumni, lami, mgncol, nlev, n0=dumni0A2D)
4075 :
4076 : !$acc parallel vector_length(VLENS) default(present)
4077 : !$acc loop gang vector collapse(2)
4078 379739880 : do k=1,nlev
4079 6270643080 : do i=1,mgncol
4080 5890903200 : if (dumi(i,k).ge.qsmall) then
4081 1789185940 : if (dumni(i,k) /=dum_2D(i,k)) then
4082 : ! adjust number conc if needed to keep mean size in reasonable range
4083 191633618 : nitend(i,k)=(dumni(i,k)*icldm(i,k)-ni(i,k))*rdeltat
4084 : end if
4085 1789185940 : effi(i,k) = 1.5_r8/lami(i,k)*1.e6_r8
4086 1789185940 : effi(i,k) = effi(i,k)*micro_mg_effi_factor
4087 :
4088 1789185940 : sadice(i,k) = 2._r8*pi*(lami(i,k)**(-3))*dumni0A2D(i,k)*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3
4089 : else
4090 4101717260 : effi(i,k) = 25._r8
4091 4101717260 : effi(i,k) = effi(i,k)*micro_mg_effi_factor
4092 :
4093 4101717260 : sadice(i,k) = 0._r8
4094 : end if
4095 : ! ice effective diameter for david mitchell's optics
4096 6266175552 : deffi(i,k)=effi(i,k)*rhoi/rhows*2._r8
4097 : end do
4098 : end do
4099 : !$acc end parallel
4100 : else
4101 : !$acc parallel vector_length(VLENS) default(present)
4102 : !acc loop gang vector collapse(2)
4103 0 : do k=1,nlev
4104 0 : do i=1,mgncol
4105 : ! NOTE: If CARMA is doing the ice microphysics, then the ice effective
4106 : ! radius has already been determined from the size distribution.
4107 0 : effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um
4108 0 : effi(i,k) = effi(i,k)*micro_mg_effi_factor
4109 :
4110 0 : deffi(i,k) = effi(i,k) * 2._r8
4111 0 : sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8
4112 : end do
4113 : end do
4114 : !$acc end parallel
4115 : end if
4116 :
4117 : ! cloud droplet effective radius
4118 : !-----------------------------------------------------------------
4119 :
4120 : !$acc parallel vector_length(VLENS) default(present)
4121 : !$acc loop gang vector collapse(2)
4122 379739880 : do k=1,nlev
4123 6270643080 : do i=1,mgncol
4124 6266175552 : dum_2D(i,k) = dumnc(i,k)
4125 : end do
4126 : end do
4127 : !$acc end parallel
4128 :
4129 4467528 : call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
4130 :
4131 : !$acc parallel vector_length(VLENS) default(present)
4132 : !$acc loop gang vector collapse(2)
4133 379739880 : do k=1,nlev
4134 6270643080 : do i=1,mgncol
4135 6266175552 : if (dumc(i,k).ge.qsmall) then
4136 : ! switch for specification of droplet and crystal number
4137 699718963 : if (nccons) then
4138 : ! make sure nc is consistence with the constant N by adjusting tendency, need
4139 : ! to multiply by cloud fraction
4140 : ! note that nctend may be further adjusted below if mean droplet size is
4141 : ! out of bounds
4142 0 : nctend(i,k)=(ncnst/rho(i,k)*lcldm(i,k)-nc(i,k))*rdeltat
4143 : end if
4144 699718963 : if (dum_2D(i,k) /= dumnc(i,k)) then
4145 : ! adjust number conc if needed to keep mean size in reasonable range
4146 104796758 : nctend(i,k)=(dumnc(i,k)*lcldm(i,k)-nc(i,k))*rdeltat
4147 : end if
4148 :
4149 699718963 : effc(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8
4150 : !assign output fields for shape here
4151 699718963 : lamcrad(i,k)=lamc(i,k)
4152 699718963 : pgamrad(i,k)=pgam(i,k)
4153 :
4154 : ! recalculate effective radius for constant number, in order to separate
4155 : ! first and second indirect effects
4156 : !======================================
4157 : ! assume constant number of 10^8 kg-1
4158 699718963 : dumnc(i,k)=1.e8_r8
4159 : end if
4160 : end do
4161 : end do
4162 : !$acc end parallel
4163 :
4164 : ! Pass in "false" adjust flag to prevent number from being changed within
4165 : ! size distribution subroutine.
4166 4467528 : call size_dist_param_liq(mg_liq_props, dumc, dumnc, rho, pgam, lamc, mgncol, nlev)
4167 :
4168 : !$acc parallel vector_length(VLENS) default(present)
4169 : !$acc loop gang vector collapse(2)
4170 379739880 : do k =1,nlev
4171 6270643080 : do i=1,mgncol
4172 5890903200 : if (dumc(i,k).ge.qsmall) then
4173 699718963 : effc_fn(i,k) = (pgam(i,k)+3._r8)/lamc(i,k)/2._r8*1.e6_r8
4174 : else
4175 5191184237 : effc(i,k) = 10._r8
4176 5191184237 : lamcrad(i,k)=0._r8
4177 5191184237 : pgamrad(i,k)=0._r8
4178 5191184237 : effc_fn(i,k) = 10._r8
4179 : end if
4180 :
4181 : ! recalculate 'final' rain size distribution parameters
4182 : ! to ensure that rain size is in bounds, adjust rain number if needed
4183 6266175552 : dum_2D(i,k) = dumnr(i,k)
4184 : end do
4185 : end do
4186 : !$acc end parallel
4187 :
4188 4467528 : call size_dist_param_basic(mg_rain_props, dumr, dumnr, lamr, mgncol, nlev, n0=n0r)
4189 :
4190 : !$acc parallel vector_length(VLENS) default(present)
4191 : !$acc loop gang vector collapse(2)
4192 379739880 : do k=1,nlev
4193 6270643080 : do i=1,mgncol
4194 5890903200 : if (dumr(i,k).ge.qsmall) then
4195 1323665688 : if (dum_2D(i,k) /= dumnr(i,k)) then
4196 : ! adjust number conc if needed to keep mean size in reasonable range
4197 428653196 : nrtend(i,k)=(dumnr(i,k)*precip_frac(i,k)-nr(i,k))*rdeltat
4198 : end if
4199 :
4200 : end if
4201 :
4202 : ! recalculate 'final' snow size distribution parameters
4203 : ! to ensure that snow size is in bounds, adjust snow number if needed
4204 6266175552 : dum_2D(i,k) = dumns(i,k)
4205 : end do
4206 : end do
4207 : !$acc end parallel
4208 :
4209 4467528 : call size_dist_param_basic(mg_snow_props, dums, dumns, lams, mgncol, nlev, n0=dumns0A2D)
4210 :
4211 : !$acc parallel vector_length(VLENS) default(present)
4212 : !$acc loop gang vector collapse(2)
4213 379739880 : do k=1,nlev
4214 6270643080 : do i=1,mgncol
4215 5890903200 : if (dums(i,k).ge.qsmall) then
4216 :
4217 1536610668 : if (dum_2D(i,k) /= dumns(i,k)) then
4218 : ! adjust number conc if needed to keep mean size in reasonable range
4219 108590278 : nstend(i,k)=(dumns(i,k)*precip_frac(i,k)-ns(i,k))*rdeltat
4220 : end if
4221 :
4222 1536610668 : sadsnow(i,k) = 2._r8*pi*(lams(i,k)**(-3))*dumns0A2D(i,k)*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3
4223 :
4224 : end if
4225 :
4226 : ! recalculate 'final' graupel size distribution parameters
4227 : ! to ensure that size is in bounds, addjust number if needed
4228 6266175552 : dum_2D(i,k) = dumng(i,k)
4229 : end do
4230 : end do
4231 : !$acc end parallel
4232 :
4233 4467528 : if (do_hail) then
4234 0 : call size_dist_param_basic(mg_hail_props, dumg, dumng, lamg, mgncol, nlev)
4235 : end if
4236 4467528 : if (do_graupel) then
4237 4467528 : call size_dist_param_basic(mg_graupel_props, dumg, dumng, lamg, mgncol, nlev)
4238 : end if
4239 :
4240 : !$acc parallel vector_length(VLENS) default(present)
4241 : !$acc loop gang vector collapse(2)
4242 379739880 : do k=1,nlev
4243 6270643080 : do i=1,mgncol
4244 5890903200 : if (dumg(i,k).ge.qsmall) then
4245 429982127 : if (dum_2D(i,k) /= dumng(i,k)) then
4246 : ! adjust number conc if needed to keep mean size in reasonable range
4247 92301145 : ngtend(i,k)=(dumng(i,k)*precip_frac(i,k)-ng(i,k))*rdeltat
4248 : end if
4249 : end if
4250 :
4251 : ! if updated q (after microphysics) is zero, then ensure updated n is also zero
4252 : !=================================================================================
4253 5890903200 : if (qc(i,k)+qctend(i,k)*deltat.lt.qsmall) nctend(i,k)=-nc(i,k)*rdeltat
4254 5890903200 : if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat.lt.qsmall) nitend(i,k)=-ni(i,k)*rdeltat
4255 5890903200 : if (qr(i,k)+qrtend(i,k)*deltat.lt.qsmall) nrtend(i,k)=-nr(i,k)*rdeltat
4256 5890903200 : if (qs(i,k)+qstend(i,k)*deltat.lt.qsmall) nstend(i,k)=-ns(i,k)*rdeltat
4257 5890903200 : if (qg(i,k)+qgtend(i,k)*deltat.lt.qsmall) ngtend(i,k)=-ng(i,k)*rdeltat
4258 :
4259 : ! DO STUFF FOR OUTPUT:
4260 : !==================================================
4261 : ! qc and qi are only used for output calculations past here,
4262 : ! so add qctend and qitend back in one more time
4263 :
4264 5890903200 : qc(i,k) = qc(i,k) + qctend(i,k)*deltat
4265 5890903200 : qi(i,k) = qi(i,k) + qitend(i,k)*deltat
4266 :
4267 : ! averaging for snow and rain number and diameter
4268 : !--------------------------------------------------
4269 : ! drout2/dsout2:
4270 : ! diameter of rain and snow
4271 : ! dsout:
4272 : ! scaled diameter of snow (passed to radiation in CAM)
4273 : ! reff_rain/reff_snow:
4274 : ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual
4275 :
4276 : ! avoid divide by zero in avg_diameter_vec
4277 6266175552 : if (nrout(i,k) .eq. 0._r8) nrout(i,k)=1.e-34_r8
4278 : end do
4279 : end do
4280 : !$acc end parallel
4281 :
4282 : ! The avg_diameter_vec call does the actual calculation; other diameter
4283 : ! outputs are just drout2 times constants.
4284 4467528 : call avg_diameter_vec(qrout,nrout,rho,rhow,drout2,mgncol*nlev)
4285 :
4286 : !$acc parallel vector_length(VLENS) default(present)
4287 : !$acc loop gang vector collapse(2)
4288 379739880 : do k=1,nlev
4289 6270643080 : do i=1,mgncol
4290 5890903200 : if (qrout(i,k) .gt. 1.e-7_r8 .and. nrout(i,k) .gt. 0._r8) then
4291 675875180 : qrout2(i,k) = qrout(i,k) * precip_frac(i,k)
4292 675875180 : nrout2(i,k) = nrout(i,k) * precip_frac(i,k)
4293 675875180 : freqr(i,k) = precip_frac(i,k)
4294 675875180 : reff_rain(i,k)=1.5_r8*drout2(i,k)*1.e6_r8
4295 : else
4296 5215028020 : qrout2(i,k) = 0._r8
4297 5215028020 : nrout2(i,k) = 0._r8
4298 5215028020 : drout2(i,k) = 0._r8
4299 5215028020 : freqr(i,k) = 0._r8
4300 5215028020 : reff_rain(i,k) = 0._r8
4301 : end if
4302 :
4303 : ! avoid divide by zero in avg_diameter_vec
4304 6266175552 : if (nsout(i,k) .eq. 0._r8) nsout(i,k) = 1.e-34_r8
4305 : end do
4306 : end do
4307 : !$acc end parallel
4308 :
4309 : ! The avg_diameter_vec call does the actual calculation; other diameter
4310 : ! outputs are just dsout2 times constants.
4311 4467528 : call avg_diameter_vec(qsout, nsout, rho, rhosn,dsout2,mgncol*nlev)
4312 :
4313 : !$acc parallel vector_length(VLENS) default(present)
4314 : !$acc loop gang vector collapse(2)
4315 379739880 : do k=1,nlev
4316 6270643080 : do i=1,mgncol
4317 5890903200 : if (qsout(i,k) .gt. 1.e-7_r8 .and. nsout(i,k) .gt. 0._r8) then
4318 609250130 : qsout2(i,k) = qsout(i,k) * precip_frac(i,k)
4319 609250130 : nsout2(i,k) = nsout(i,k) * precip_frac(i,k)
4320 609250130 : freqs(i,k) = precip_frac(i,k)
4321 609250130 : dsout(i,k)=3._r8*rhosn/rhows*dsout2(i,k)
4322 609250130 : reff_snow(i,k)=1.5_r8*dsout2(i,k)*1.e6_r8
4323 : else
4324 5281653070 : dsout(i,k) = 0._r8
4325 5281653070 : qsout2(i,k) = 0._r8
4326 5281653070 : nsout2(i,k) = 0._r8
4327 5281653070 : dsout2(i,k) = 0._r8
4328 5281653070 : freqs(i,k) = 0._r8
4329 5281653070 : reff_snow(i,k)=0._r8
4330 : end if
4331 :
4332 : ! avoid divide by zero in avg_diameter_vec
4333 6266175552 : if (ngout(i,k) .eq. 0._r8) ngout(i,k) = 1.e-34_r8
4334 : end do
4335 : end do
4336 : !$acc end parallel
4337 :
4338 : ! The avg_diameter_vec call does the actual calculation; other diameter
4339 : ! outputs are just dgout2 times constants.
4340 4467528 : if (do_hail .or. do_graupel) then
4341 4467528 : call avg_diameter_vec(qgout, ngout, rho, rhogtmp, dgout2, mgncol*nlev)
4342 : else
4343 : ! need this if statement for MG2, where rhogtmp = 0
4344 :
4345 : !$acc parallel vector_length(VLENS) default(present)
4346 : !$acc loop gang vector collapse(2)
4347 0 : do k=1,nlev
4348 0 : do i=1,mgncol
4349 0 : dgout2(i,k) = 0._r8
4350 : end do
4351 : end do
4352 : !$acc end parallel
4353 : end if
4354 :
4355 : !$acc parallel vector_length(VLENS) default(present)
4356 : !$acc loop gang vector collapse(2)
4357 379739880 : do k=1,nlev
4358 6270643080 : do i=1,mgncol
4359 6266175552 : if (qgout(i,k) .gt. 1.e-7_r8 .and. ngout(i,k) .gt. 0._r8) then
4360 42838400 : qgout2(i,k) = qgout(i,k) * precip_frac(i,k)
4361 42838400 : ngout2(i,k) = ngout(i,k) * precip_frac(i,k)
4362 42838400 : freqg(i,k) = precip_frac(i,k)
4363 42838400 : dgout(i,k)=3._r8*rhogtmp/rhows*dgout2(i,k)
4364 42838400 : reff_grau(i,k)=1.5_r8*dgout2(i,k)*1.e6_r8
4365 : else
4366 5848064800 : dgout(i,k) = 0._r8
4367 5848064800 : qgout2(i,k) = 0._r8
4368 5848064800 : ngout2(i,k) = 0._r8
4369 5848064800 : dgout2(i,k) = 0._r8
4370 5848064800 : freqg(i,k) = 0._r8
4371 5848064800 : reff_grau(i,k)=0._r8
4372 : end if
4373 : end do
4374 : end do
4375 : !$acc end parallel
4376 :
4377 : ! analytic radar reflectivity
4378 : !--------------------------------------------------
4379 : ! formulas from Matthew Shupe, NOAA/CERES
4380 : ! *****note: radar reflectivity is local (in-precip average)
4381 : ! units of mm^6/m^3
4382 :
4383 : ! Min rain rate of 0.1 mm/hr
4384 : rthrsh=0.0001_r8/3600._r8
4385 :
4386 : !$acc parallel vector_length(VLENS) default(present)
4387 : !$acc loop gang vector collapse(2)
4388 379739880 : do k=1,nlev
4389 6270643080 : do i=1,mgncol
4390 5890903200 : if (qc(i,k).ge.qsmall .and. (nc(i,k)+nctend(i,k)*deltat).gt.10._r8) then
4391 : dum=(qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 &
4392 436572438 : /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k)
4393 : else
4394 : dum=0._r8
4395 : end if
4396 5890903200 : if (qi(i,k).ge.qsmall) then
4397 1075293880 : dum1=(qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)*icldm(i,k)/precip_frac(i,k)
4398 : else
4399 4815609320 : dum1=0._r8
4400 : end if
4401 5890903200 : if (qsout(i,k).ge.qsmall) then
4402 1416430442 : dum1=dum1+(qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(1._r8/0.63_r8)
4403 : end if
4404 5890903200 : refl(i,k)=dum+dum1
4405 :
4406 : ! add rain to reflectivity (rain rate in mm/hr)
4407 : ! reflectivity (dum) is in DBz
4408 : ! New version Aircraft cloud values
4409 : !Z=a*R^b (R in mm/hr) from Comstock et al 2004
4410 :
4411 5890903200 : if (rflx(i,k+1).ge.rthrsh) then
4412 737808468 : dum=32._r8*(rflx(i,k+1)*3600._r8)**1.4_r8
4413 : else
4414 : ! don't include rain rate in R calculation for values less than 0.001 mm/hr
4415 : dum=0._r8
4416 : end if
4417 :
4418 : ! add to refl
4419 5890903200 : refl(i,k)=refl(i,k)+dum
4420 :
4421 : !output reflectivity in Z.
4422 5890903200 : areflz(i,k)=refl(i,k) * precip_frac(i,k)
4423 :
4424 : ! convert back to DBz
4425 5890903200 : if (refl(i,k).gt.minrefl) then
4426 1802126771 : refl(i,k)=10._r8*dlog10(refl(i,k))
4427 : else
4428 4088776429 : refl(i,k)=-9999._r8
4429 : end if
4430 :
4431 : !set averaging flag
4432 5890903200 : if (refl(i,k).gt.mindbz) then
4433 1802126771 : arefl(i,k)=refl(i,k) * precip_frac(i,k)
4434 1802126771 : frefl(i,k)=precip_frac(i,k)
4435 : else
4436 4088776429 : arefl(i,k)=0._r8
4437 4088776429 : areflz(i,k)=0._r8
4438 4088776429 : frefl(i,k)=0._r8
4439 : end if
4440 :
4441 : ! bound cloudsat reflectivity
4442 5890903200 : csrfl(i,k)=min(csmax,refl(i,k))
4443 :
4444 : !set averaging flag
4445 6266175552 : if (csrfl(i,k).gt.csmin) then
4446 1297813884 : acsrfl(i,k)=refl(i,k) * precip_frac(i,k)
4447 1297813884 : fcsrfl(i,k)=precip_frac(i,k)
4448 : else
4449 4593089316 : acsrfl(i,k)=0._r8
4450 4593089316 : fcsrfl(i,k)=0._r8
4451 : end if
4452 : end do
4453 : end do
4454 : !$acc end parallel
4455 :
4456 : ! 10cm analytic radar reflectivity (rain radar)
4457 : !--------------------------------------------------
4458 : ! Formula from Hugh Morrison
4459 : ! Ice dielectric correction from Smith 1984, Equation 10 and Snow correction from Smith 1984 Equation 14
4460 : ! Smith, Paul L. “Equivalent Radar Reflectivity Factors for Snow and Ice Particles.
4461 : ! ” Journal of Climate and Applied Meteorology 23, no. 8 (1984): 1258–60.
4462 : ! DOI: 10.1175/1520-0450(1984)023<1258:ERRFFS>2.0.CO;2
4463 :
4464 : ! *****note: radar reflectivity is local (in-precip average)
4465 : ! units of mm^6/m^3
4466 :
4467 : !$acc parallel vector_length(VLENS) default(present)
4468 : !$acc loop gang vector collapse(2)
4469 379739880 : do k=1,nlev
4470 6270643080 : do i=1,mgncol
4471 :
4472 5890903200 : dum1 = minrefl10
4473 5890903200 : dum2 = minrefl10
4474 5890903200 : dum3 = minrefl10
4475 5890903200 : dum4 = minrefl10
4476 5890903200 : dum = minrefl10
4477 :
4478 : ! Rain
4479 5890903200 : if (lamr(i,k) > 0._r8) then
4480 1323665688 : dum1 = rho(i,k)*n0r(i,k)*720._r8/lamr(i,k)**3/lamr(i,k)**3/lamr(i,k)
4481 1323665688 : dum1 = max(dum1,minrefl10)
4482 : end if
4483 :
4484 : ! Ice
4485 : ! Add diaelectric factor from Smith 1984 equation 10
4486 5890903200 : if (lami(i,k) > 0._r8) then
4487 1789185940 : dum2= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*dumni0A2D(i,k)*(rhoi/900._r8)**2/lami(i,k)**7
4488 1789185940 : dum2 = max(dum2,minrefl10)
4489 : endif
4490 :
4491 : ! Snow
4492 5890903200 : if (lams(i,k) > 0._r8) then
4493 1536610668 : dum3= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*dumns0A2D(i,k)*(rhosn/900._r8)**2/lams(i,k)**7._r8
4494 1536610668 : dum3 = max(dum3,minrefl10)
4495 : endif
4496 :
4497 : ! Graupel
4498 5890903200 : if (do_hail .or. do_graupel .and. lamg(i,k) > 0._r8) then
4499 429982127 : dum4= rho(i,k)*(0.176_r8/0.93_r8) * 720._r8*n0g(i,k)*(rhogtmp/900._r8)**2/lamg(i,k)**7._r8
4500 429982127 : dum4 =max(dum4,minrefl10)
4501 : end if
4502 :
4503 5890903200 : reflz10cm(i,k) = (dum1+dum2+dum3+dum4) * precip_frac(i,k)
4504 :
4505 : ! Convert to dBz....
4506 :
4507 5890903200 : dum = reflz10cm(i,k)*1.e18_r8
4508 5890903200 : refl10cm(i,k) = 10._r8*dlog10(dum)
4509 :
4510 : !redefine fice here....
4511 :
4512 5890903200 : dum_2D(i,k) = qsout(i,k) + qrout(i,k) + qc(i,k) + qi(i,k)
4513 5890903200 : dumi(i,k) = qsout(i,k) + qi(i,k)
4514 6266175552 : if (dumi(i,k) .gt. qsmall .and. dum_2D(i,k) .gt. qsmall) then
4515 1498924183 : nfice(i,k) = min(dumi(i,k)/dum_2D(i,k),1._r8)
4516 : else
4517 4391979017 : nfice(i,k) = 0._r8
4518 : end if
4519 :
4520 : end do
4521 : end do
4522 : !$acc end parallel
4523 :
4524 : !$acc end data
4525 :
4526 4467528 : end subroutine micro_pumas_tend
4527 :
4528 : !========================================================================
4529 : !OUTPUT CALCULATIONS
4530 : !========================================================================
4531 :
4532 4467528 : subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, vlen)
4533 : integer, intent(in) :: vlen
4534 : real(r8), dimension(vlen), intent(in) :: lamr ! rain size parameter (slope)
4535 : real(r8), dimension(vlen), intent(in) :: n0r ! rain size parameter (intercept)
4536 : real(r8), dimension(vlen), intent(in) :: lamc ! size distribution parameter (slope)
4537 : real(r8), dimension(vlen), intent(in) :: pgam ! droplet size parameter
4538 : real(r8), dimension(vlen), intent(in) :: qric ! in-cloud rain mass mixing ratio
4539 : real(r8), dimension(vlen), intent(in) :: qcic ! in-cloud cloud liquid
4540 : real(r8), dimension(vlen), intent(in) :: ncic ! in-cloud droplet number concentration
4541 :
4542 : real(r8), dimension(vlen), intent(inout) :: rercld ! effective radius calculation for rain + cloud
4543 :
4544 : ! combined size of precip & cloud drops
4545 8935056 : real(r8) :: Atmp,tmp(vlen), pgamp1(vlen)
4546 :
4547 : integer :: i
4548 :
4549 : !$acc data create (tmp,pgamp1)
4550 :
4551 : !$acc parallel vector_length(VLENS) default(present)
4552 : !$acc loop gang vector
4553 5895370728 : do i=1,vlen
4554 5895370728 : pgamp1(i) = pgam(i)+1._r8
4555 : end do
4556 : !$acc end parallel
4557 :
4558 4467528 : call rising_factorial(pgamp1, 2, tmp, vlen)
4559 :
4560 : !$acc parallel vector_length(VLENS) default(present)
4561 : !$acc loop gang vector
4562 5895370728 : do i=1,vlen
4563 : ! Rain drops
4564 5890903200 : if (lamr(i) > 0._r8) then
4565 1434950401 : Atmp = n0r(i) * pi / (2._r8 * lamr(i)**3._r8)
4566 : else
4567 : Atmp = 0._r8
4568 : end if
4569 : ! Add cloud drops
4570 5890903200 : if (lamc(i) > 0._r8) then
4571 : Atmp = Atmp + &
4572 512413729 : ncic(i) * pi * tmp(i) / (4._r8 * lamc(i)**2._r8)
4573 : end if
4574 5895370728 : if (Atmp > 0._r8) then
4575 1447332558 : rercld(i) = rercld(i) + 3._r8 *(qric(i) + qcic(i)) / (4._r8 * rhow * Atmp)
4576 : end if
4577 : end do
4578 : !$acc end parallel
4579 :
4580 : !$acc end data
4581 4467528 : end subroutine calc_rercld
4582 :
4583 : !========================================================================
4584 : !2020-09-15: Follow John Dennis's version to generate a new interface
4585 : ! to update tendency in the sedimentation loop;
4586 : !2021-10-19: Separate the mass and ice sediment for each class;
4587 : !========================================================================
4588 0 : subroutine Sedimentation(mgncol,nlev,do_cldice,deltat,nstep,rnstep,fx,dumx,pdel_inv, &
4589 0 : xxtend,queue,qxsedten,prect,xflx,xxlx,qxsevap,tlat,qvlat,xcldm,preci)
4590 :
4591 : integer, intent(in) :: mgncol,nlev
4592 : logical, intent(in) :: do_cldice
4593 : real(r8),intent(in) :: deltat
4594 : integer, intent(in) :: nstep(mgncol)
4595 : real(r8), intent(in) :: rnstep(mgncol)
4596 : real(r8), intent(in) :: fx(mgncol,nlev)
4597 : real(r8), intent(inout) :: dumx(mgncol,nlev)
4598 : real(r8), intent(in) :: pdel_inv(mgncol,nlev)
4599 : real(r8), intent(inout) :: xxtend(mgncol,nlev)
4600 : integer, intent(in) :: queue
4601 : real(r8), intent(inout), optional :: qxsedten(mgncol,nlev)
4602 : real(r8), intent(inout), optional :: prect(mgncol)
4603 : real(r8), intent(inout), optional :: xflx(mgncol,nlev+1)
4604 : real(r8), intent(in) , optional :: xxlx
4605 : real(r8), intent(inout), optional :: qxsevap(mgncol,nlev)
4606 : real(r8), intent(in) , optional :: xcldm(mgncol,nlev)
4607 : real(r8), intent(inout), optional :: tlat(mgncol,nlev)
4608 : real(r8), intent(inout), optional :: qvlat(mgncol,nlev)
4609 : real(r8), intent(inout), optional :: preci(mgncol)
4610 :
4611 : ! local variables
4612 : integer :: i,k,n,nstepmax
4613 : real(r8) :: faltndx,rnstepmax,faltndqxe
4614 0 : real(r8) :: dum1(mgncol,nlev),faloutx(mgncol,0:nlev)
4615 : logical :: present_tlat, present_qvlat, present_xcldm, present_qxsevap, &
4616 : present_prect, present_preci, present_qxsedten, present_xflx
4617 :
4618 0 : present_tlat = present(tlat)
4619 0 : present_qvlat = present(qvlat)
4620 0 : present_xcldm = present(xcldm)
4621 0 : present_qxsevap = present(qxsevap)
4622 0 : present_preci = present(preci)
4623 0 : present_prect = present(prect)
4624 0 : present_qxsedten = present(qxsedten)
4625 0 : present_xflx = present(xflx)
4626 :
4627 : ! loop over sedimentation sub-time step to ensure stability
4628 : !==============================================================
4629 :
4630 : !$acc enter data create (faloutx,dum1) async(queue)
4631 :
4632 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4633 : !$acc loop gang vector
4634 0 : do i = 1,mgncol
4635 0 : nstepmax = nstep(i)
4636 0 : rnstepmax = rnstep(i)
4637 :
4638 0 : dum1(i,1) = 0._r8
4639 0 : if (present_xcldm) then
4640 0 : do k = 2,nlev
4641 0 : dum1(i,k) = xcldm(i,k)/xcldm(i,k-1)
4642 0 : dum1(i,k) = min(dum1(i,k),1._r8)
4643 : end do
4644 : else
4645 0 : do k=2,nlev
4646 0 : dum1(i,k) = 1._r8
4647 : end do
4648 : end if
4649 :
4650 : !$acc loop seq
4651 0 : do n = 1,nstepmax
4652 0 : faloutx(i,0) = 0._r8
4653 0 : if (do_cldice) then
4654 0 : do k=1,nlev
4655 0 : faloutx(i,k) = fx(i,k) * dumx(i,k)
4656 : end do
4657 : else
4658 0 : do k=1,nlev
4659 0 : faloutx(i,k) = 0._r8
4660 : end do
4661 : end if
4662 :
4663 0 : do k = 1,nlev
4664 : ! for cloud liquid and ice, if cloud fraction increases with height
4665 : ! then add flux from above to both vapor and cloud water of current level
4666 : ! this means that flux entering clear portion of cell from above evaporates
4667 : ! instantly
4668 : ! note: this is not an issue with precip, since we assume max overlap
4669 0 : faltndx = (faloutx(i,k) - dum1(i,k) * faloutx(i,k-1)) * pdel_inv(i,k)
4670 : ! add fallout terms to eulerian tendencies
4671 0 : xxtend(i,k) = xxtend(i,k) - faltndx * rnstepmax
4672 : ! sedimentation tendency for output
4673 0 : if (present_qxsedten) qxsedten(i,k) = qxsedten(i,k)-faltndx*rnstepmax
4674 : ! add terms to to evap/sub of cloud water
4675 0 : dumx(i,k) = dumx(i,k) - faltndx*deltat*rnstepmax
4676 :
4677 0 : if (k>1) then
4678 0 : if (present_qxsevap .or. present_qvlat .or. present_tlat) then
4679 0 : faltndqxe = (faloutx(i,k)-faloutx(i,k-1))*pdel_inv(i,k)
4680 : ! for output
4681 0 : if (present_qxsevap) qxsevap(i,k) = qxsevap(i,k) - (faltndqxe-faltndx)*rnstepmax
4682 0 : if (present_qvlat) qvlat(i,k) = qvlat(i,k) - (faltndqxe-faltndx)*rnstepmax
4683 0 : if (present_tlat) tlat(i,k) = tlat(i,k) + (faltndqxe-faltndx)*xxlx*rnstepmax
4684 : end if
4685 : end if
4686 :
4687 0 : if (present_xflx) xflx(i,k+1) = xflx(i,k+1) + faloutx(i,k) / g * rnstepmax
4688 : end do
4689 :
4690 : ! units below are m/s
4691 : ! sedimentation flux at surface is added to precip flux at surface
4692 : ! to get total precip (cloud + precip water) rate
4693 0 : if (present_prect) prect(i) = prect(i) + faloutx(i,nlev) / g * rnstepmax / 1000._r8
4694 0 : if (present_preci) preci(i) = preci(i) + faloutx(i,nlev) / g * rnstepmax / 1000._r8
4695 : end do ! n loop of 1, nstep
4696 : end do ! i loop of 1, mgncol
4697 : !$acc end parallel
4698 :
4699 : !$acc exit data delete(faloutx,dum1) async(queue)
4700 0 : end subroutine Sedimentation
4701 :
4702 : !========================================================================
4703 : !2021-10-19: Add a new interface for the implicit sedimentation calculation;
4704 : ! Separate number/mass sediment for each class;
4705 : !========================================================================
4706 89350560 : subroutine Sedimentation_implicit(mgncol,nlev,deltat,zint,pdel,dumx,fx,check_qsmall, &
4707 102753144 : xxtend,queue,xflx,qxsedten,prect,preci)
4708 :
4709 : integer, intent(in) :: mgncol,nlev
4710 : real(r8), intent(in) :: deltat
4711 : real(r8), intent(in) :: zint(mgncol,nlev+1)
4712 : real(r8), intent(in) :: pdel(mgncol,nlev)
4713 : real(r8), intent(in) :: dumx(mgncol,nlev)
4714 : real(r8), intent(in) :: fx(mgncol,nlev)
4715 : logical, intent(in) :: check_qsmall
4716 : real(r8), intent(inout) :: xxtend(mgncol,nlev)
4717 : integer, intent(in) :: queue
4718 : real(r8), intent(inout), optional :: xflx(mgncol,nlev+1)
4719 : real(r8), intent(inout), optional :: qxsedten(mgncol,nlev)
4720 : real(r8), intent(inout), optional :: prect(mgncol)
4721 : real(r8), intent(inout), optional :: preci(mgncol)
4722 :
4723 : ! Local variables
4724 : integer :: i,k
4725 89350560 : real(r8) :: dum_2D(mgncol,nlev),flx(mgncol,nlev),precip(mgncol)
4726 : logical :: present_preci, present_xflx, present_qxsedten, present_prect
4727 :
4728 44675280 : present_preci = present(preci)
4729 44675280 : present_xflx = present(xflx)
4730 44675280 : present_qxsedten = present(qxsedten)
4731 44675280 : present_prect = present(prect)
4732 :
4733 : !$acc enter data create (flx,dum_2D,precip) async(queue)
4734 :
4735 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4736 : !$acc loop gang vector collapse(2)
4737 3797398800 : do k=1,nlev
4738 62706430800 : do i=1,mgncol
4739 62661755520 : dum_2D(i,k) = dumx(i,k)
4740 : enddo
4741 : enddo
4742 : !$acc end parallel
4743 :
4744 44675280 : call implicit_fall ( deltat, mgncol, 1, nlev, zint, fx, pdel, dum_2D, precip, flx, queue)
4745 :
4746 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4747 : !$acc loop gang vector collapse(2)
4748 3797398800 : do k=1,nlev
4749 62706430800 : do i=1,mgncol
4750 58909032000 : if ( check_qsmall ) then
4751 : !h1g, 2019-11-26, ensure numerical stability
4752 35345419200 : if ( flx(i,k) .ge. qsmall .and. present_xflx ) xflx(i,k+1) = xflx(i,k+1) + flx(i,k) / g / deltat
4753 : else
4754 23563612800 : if ( present_xflx ) xflx(i,k+1) = xflx(i,k+1) + flx(i,k) / g / deltat
4755 : end if
4756 58909032000 : if ( present_qxsedten) qxsedten(i,k) = qxsedten(i,k) + (dum_2D(i,k) - dumx(i,k)) / deltat
4757 62661755520 : xxtend(i,k) = xxtend(i,k) + (dum_2D(i,k) - dumx(i,k)) / deltat
4758 : enddo
4759 : enddo
4760 : !$acc end parallel
4761 :
4762 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4763 : !$acc loop gang vector
4764 745973280 : do i=1,mgncol
4765 745973280 : if ( precip(i) .ge. 0.0 ) then !h1g, 2019-11-26, ensure numerical stability
4766 516998999 : if ( present_prect ) prect(i) = prect(i) + precip(i) / g / deltat / 1000._r8
4767 516998999 : if ( present_preci ) preci(i) = preci(i) + precip(i) / g / deltat / 1000._r8
4768 : endif
4769 : enddo
4770 : !$acc end parallel
4771 :
4772 : !$acc exit data delete(flx,dum_2D,precip) async(queue)
4773 :
4774 125090784 : end subroutine Sedimentation_implicit
4775 :
4776 : !========================================================================
4777 : !UTILITIES
4778 : !========================================================================
4779 :
4780 :
4781 0 : pure subroutine micro_pumas_get_cols(ncol, nlev, top_lev, mgncol, mgcols, &
4782 0 : qcn, qin, qrn, qsn, qgr)
4783 :
4784 : ! Determines which columns microphysics should operate over by
4785 : ! checking for non-zero cloud water/ice.
4786 :
4787 : integer, intent(in) :: ncol ! Number of columns with meaningful data
4788 : integer, intent(in) :: nlev ! Number of levels to use
4789 : integer, intent(in) :: top_lev ! Top level for microphysics
4790 : integer, intent(out) :: mgncol ! Number of columns MG will use
4791 : integer, allocatable, intent(out) :: mgcols(:) ! column indices
4792 :
4793 : real(r8), intent(in) :: qcn(:,:) ! cloud water mixing ratio (kg/kg)
4794 : real(r8), intent(in) :: qin(:,:) ! cloud ice mixing ratio (kg/kg)
4795 : real(r8), intent(in) :: qrn(:,:) ! rain mixing ratio (kg/kg)
4796 : real(r8), intent(in) :: qsn(:,:) ! snow mixing ratio (kg/kg)
4797 : real(r8), optional, intent(in) :: qgr(:,:) ! graupel mixing ratio (kg/kg)
4798 :
4799 : integer :: lev_offset ! top_lev - 1 (defined here for consistency)
4800 0 : logical :: ltrue(ncol) ! store tests for each column
4801 :
4802 : integer :: i, ii ! column indices
4803 :
4804 0 : if (allocated(mgcols)) deallocate(mgcols)
4805 :
4806 0 : lev_offset = top_lev - 1
4807 :
4808 : ! Using "any" along dimension 2 collapses across levels, but
4809 : ! not columns, so we know if water is present at any level
4810 : ! in each column.
4811 :
4812 0 : ltrue = any(qcn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
4813 0 : ltrue = ltrue .or. any(qin(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
4814 0 : ltrue = ltrue .or. any(qrn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
4815 0 : ltrue = ltrue .or. any(qsn(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
4816 :
4817 0 : if(present(qgr)) ltrue = ltrue .or. any(qgr(:ncol,top_lev:(nlev+lev_offset)) >= qsmall, 2)
4818 :
4819 : ! Scan for true values to get a usable list of indices.
4820 :
4821 0 : mgncol = count(ltrue)
4822 0 : allocate(mgcols(mgncol))
4823 0 : i = 0
4824 0 : do ii = 1,ncol
4825 0 : if (ltrue(ii)) then
4826 0 : i = i + 1
4827 0 : mgcols(i) = ii
4828 : end if
4829 : end do
4830 :
4831 0 : end subroutine micro_pumas_get_cols
4832 :
4833 : ! =======================================================================
4834 : ! time - implicit monotonic scheme
4835 : ! developed by sj lin, 2016
4836 : ! =======================================================================
4837 :
4838 44675280 : subroutine implicit_fall (dt, mgncol, ktop, kbot, ze, vt, dp, q, precip, m1, queue)
4839 :
4840 : implicit none
4841 :
4842 : integer, intent (in) :: mgncol ! Number of columns in MG
4843 : integer, intent (in) :: ktop,kbot ! Level range (top to bottom)
4844 : real(r8), intent (in) :: dt ! Time step
4845 : real(r8), intent (in), dimension (mgncol,ktop:kbot+1) :: ze ! Interface height (m)
4846 : real(r8), intent (in), dimension (mgncol,ktop:kbot) :: vt, dp ! fall speed and pressure difference across level
4847 : real(r8), intent (inout), dimension (mgncol,ktop:kbot) :: q ! mass
4848 : real(r8), intent (out), dimension (mgncol,ktop:kbot) :: m1 ! Surface Flux
4849 : real(r8), intent (out), dimension (mgncol) :: precip ! Surface Precipitation
4850 : integer, intent (in) :: queue ! Stream ID for GPU asynchronous run
4851 :
4852 : ! Local variables
4853 89350560 : real(r8), dimension (mgncol,ktop:kbot) :: dz, qm, dd
4854 : integer :: i,k
4855 :
4856 : !$acc enter data create (dz,qm,dd) async(queue)
4857 :
4858 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4859 : !$acc loop gang vector collapse(2)
4860 745973280 : do i = 1, mgncol
4861 59655005280 : do k = ktop, kbot
4862 58909032000 : dz (i,k) = ze (i,k) - ze (i,k + 1)
4863 58909032000 : dd (i,k) = dt * vt (i,k)
4864 59610330000 : q (i,k) = q (i,k) * dp (i,k)
4865 : end do
4866 : end do
4867 : !$acc end parallel
4868 :
4869 : ! -----------------------------------------------------------------------
4870 : ! sedimentation: non - vectorizable loop
4871 : ! -----------------------------------------------------------------------
4872 :
4873 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4874 : !$acc loop gang vector
4875 745973280 : do i = 1, mgncol
4876 701298000 : qm (i,ktop) = q (i,ktop) / (dz (i,ktop) + dd (i,ktop))
4877 :
4878 : !$acc loop seq
4879 58953707280 : do k = ktop + 1, kbot
4880 58909032000 : qm (i,k) = (q (i,k) + dd (i,k - 1) * qm (i,k - 1)) / (dz (i,k) + dd (i,k))
4881 : end do
4882 : end do
4883 : !$acc end parallel
4884 :
4885 : ! -----------------------------------------------------------------------
4886 : ! qm is density at this stage
4887 : ! -----------------------------------------------------------------------
4888 :
4889 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4890 : !$acc loop gang vector collapse(2)
4891 745973280 : do i = 1, mgncol
4892 59655005280 : do k = ktop, kbot
4893 59610330000 : qm (i,k) = qm (i,k) * dz (i,k)
4894 : end do
4895 : end do
4896 : !$acc end parallel
4897 :
4898 : ! -----------------------------------------------------------------------
4899 : ! output mass fluxes: non - vectorizable loop
4900 : ! -----------------------------------------------------------------------
4901 :
4902 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4903 : !$acc loop gang vector
4904 745973280 : do i = 1, mgncol
4905 701298000 : m1 (i,ktop) = q (i,ktop) - qm (i,ktop)
4906 :
4907 : !$acc loop seq
4908 58953707280 : do k = ktop + 1, kbot
4909 58909032000 : m1 (i,k) = m1 (i,k - 1) + q (i,k) - qm (i,k)
4910 : end do
4911 : end do
4912 : !$acc end parallel
4913 :
4914 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4915 : !$acc loop gang vector
4916 745973280 : do i = 1, mgncol
4917 745973280 : precip(i) = m1 (i,kbot)
4918 : end do
4919 : !$acc end parallel
4920 :
4921 : ! -----------------------------------------------------------------------
4922 : ! update:
4923 : ! -----------------------------------------------------------------------
4924 :
4925 : !$acc parallel vector_length(VLENS) default(present) async(queue)
4926 : !$acc loop gang vector collapse(2)
4927 745973280 : do i = 1, mgncol
4928 59655005280 : do k = ktop, kbot
4929 59610330000 : q (i,k) = qm (i,k) / dp (i,k)
4930 : end do
4931 : end do
4932 : !$acc end parallel
4933 :
4934 : !$acc exit data delete (dz,qm,dd) async(queue)
4935 :
4936 44675280 : end subroutine implicit_fall
4937 :
4938 :
4939 : end module micro_pumas_v1
|
