| bl_mynn_cloudpdf | mynnedmf_wrapper | flag to determine which cloud PDF to use \n
- 0: use Sommeria-Deardorff subgrid cloud PDF
@@ -384,6 +387,9 @@ show some variables in the namelist that must match the SDF.
| t_sub | gfdl_cloud_microphys | temperature threshold for sublimation. Cloud ice, snow or graupel stops(starts) sublimation when temperature is lower(higher) then \p t_sub | 184.
| | mp_print | gfdl_cloud_microphys | \a .true. to turn on GFDL cloud microphysics debugging print out. (not supported in GFS physics) | .false.
| | ltaerosol | mp_thompson | flag for using aerosol climotology in Thompson MP scheme | .false.
+ | | mraerosol | | flag for merra2 aerosol aware | .false.
+ | | lradar | | flag for radar reflectivity | .false.
+ | | nsfullradar_diag | | seconds between resetting radar reflectivity calculation | .-999.0
| | ttendlim | mp_thompson | temperature tendency limiter per time step in K/s, set to < 0 to deactivate | -999.0
| | ext_diag_thompson | mp_thompson | flag for extended diagnostic output from Thompson MP | .false.
| | thompson_ext_ndiag3d | mp_thompson | number of 3d arrays for extended diagnostic output from Thompson MP | 37
@@ -394,10 +400,13 @@ show some variables in the namelist that must match the SDF.
| | cnvcld | see \a GFS_typedefs.F90 | flag for convective cloud | .false.
| | lgfdlmprad | gfs_rrtmg_pre | flag for GFDL mp scheme and radiation consistency | .false.
| | nssl_cccn | mp_nssl | CCN concentration (m^-3) | 0.6e9
- | | nssl_alphar | mp_nssl | rain PSD shape parameter | 0.0
- | | nssl_alphah | mp_nssl | graupel PSD shape parameter | 0.0
- | | nssl_alphahl | mp_nssl | hail PSD shape parameter | 1.0
+ | | nssl_alphah | mp_nssl | graupel shape parameter | 0.0
+ | | nssl_alphahl | mp_nssl | hail shape parameter | 1.0
+ | | nssl_alphar | mp_nssl | shape paramter for rain (imurain=1 only) | 0.0
+ | | nssl_ehw0_in | mp_nssl | constant or max assumed graupel-droplet collection efficiency | 0.9
+ | | nssl_ehlw0_in | mp_nssl | constant or max assumed hail-droplet collection efficiency | 0.9
| | nssl_hail_on | mp_nssl | NSSL flag to activate the hail category | .false.
+ | | nssl_3moment | mp_nssl | NSSL flag to activate 3-moment for rain/graupel (and hail if activated) | .false.
| | nssl_ccn_on | mp_nssl | NSSL flag to activate the CCN category | .true.
| | nssl_invertccn | mp_nssl | NSSL flag to treat CCN as activated or unactivated | .true.
| | nssl_ehw0 | mp_nssl | NSSL graupel-droplet collection efficiency | 0.9
@@ -508,15 +517,19 @@ show some variables in the namelist that must match the SDF.
- 0: USGS
- 1: IGBP(20 category): IGBP must be selected if NoahMP is used
- 2: UMD (13 category)
+
- 3: NLCD40 (40 category, NOAH WRFv4 only)
+
- 4: USGS-RUC (28 category, NOAH WRFv4 only)
+
- 5: MODIS-RUC (21 category, NOAH WRFv4 only)
| 2
| | isot | lsm_noah, lsm_ruc, \ref noahmpdrv | flag for soil type dataset choice:\n
- 0: Zobler soil type (9 category)
- 1: STATSGO soil type (19 category): STATSGO must be selected if NoahMP is used
+
- 2: STAS-RUC soil type (19 category, NOAH WRFv4 only
| 0
-
+ | | exticeden | lsm_noah,lsm_ruc | flag for calculating frozen precip ice density outside of the LSM | .false.
| | iopt_dveg | \ref noahmpdrv | options for dynamic vegetation \n
- 1: off (use table LAI; use FVEG = SHDFAC from input)
@@ -606,14 +619,42 @@ show some variables in the namelist that must match the SDF.
| 1
| | iopt_trs | \ref noahmpdrv | options for thermal roughness scheme:\n
-
- - 1: z0h=z0m
-
- 2: canopy based czil
-
- 3: ec
-
- 4: kb inversed
-
- | 2
+
+ - 1: z0h=z0m
+
- 2: canopy based czil
+
- 3: ec
+
- 4: kb inversed
+
+ | 2
+ | | mosaic_lu | \ref lsm_ruc | control for use of fractional landuse in RUC land surface model
+
+ - 1: use of fractional landuse in RUC LSM
+
+ | 0
+ | | mosaic_soil | \ref lsm_ruc | control for use of fractional soil in RUC land surface model
+
+ - 1: use of fractional soil in RUC LSM
+
+ | 0
+ | | isncond_opt | \ref lsm_ruc | control for soil thermal conductivity option in RUC land surface model
+
+ - 1: constant
+
- 2: Sturm et al.(1997) \cite sturm_1997
+
+ | 1
+ | | isncovr_opt | \ref lsm_ruc | control for snow cover fraction option in RUC land surface model
+
+ - 1: original formulation using threshold snow depth to compute snow fraction
+
- 2: Niu-Yang(2007) \cite Niu_2007
+
- 3: updated Niu-Yang similar to Noah MP
+
+ | 1
| | \b Parameters \b related \b to \b other \b surface \b scheme \b options
+ | | lkm | \ref clm_lake | 0: no lake; 1: lake; 2: lake&nsst | 0
+ | | iopt_lake | \ref clm_lake | 1: flake; 2: CLM lake | 2
+ | | lakedepth_threshold | \ref clm_lake | lakedepth must be greater than this value to enable a lake model | 1.0
+ | | lakefrac_threshold | \ref clm_lake | lakefrac must be greater than this value to enable a lake model | 0.0
+ | | use_lake2m | \ref clm_lake | use 2m T&Q from CLM lake model | .false.
| | nstf_name(5) | sfc_nst | NSST related paramters:\n
- nstf_name(1): 0=NSST off, 1= NSST on but uncoupled, 2= NSST on and coupled
diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90
index 22f122e71..ff68f4216 100644
--- a/physics/drag_suite.F90
+++ b/physics/drag_suite.F90
@@ -460,6 +460,8 @@ subroutine drag_suite_run( &
real(kind=kind_phys), parameter :: ce = 0.8
real(kind=kind_phys), parameter :: cg = 0.5
real(kind=kind_phys), parameter :: sgmalolev = 0.5 ! max sigma lvl for dtfac
+ real(kind=kind_phys), parameter :: plolevmeso = 70.0 ! pres lvl for mesosphere OGWD reduction (Pa)
+ real(kind=kind_phys), parameter :: facmeso = 0.5 ! fractional velocity reduction for OGWD
integer,parameter :: kpblmin = 2
!
@@ -472,7 +474,7 @@ subroutine drag_suite_run( &
rcsks,wdir,ti,rdz,tem2,dw2,shr2, &
bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, &
rim,temc,tem1,efact,temv,dtaux,dtauy, &
- dtauxb,dtauyb,eng0,eng1
+ dtauxb,dtauyb,eng0,eng1,ksmax,dtfac_meso
!
logical :: ldrag(im),icrilv(im), &
flag(im),kloop1(im)
@@ -887,6 +889,14 @@ subroutine drag_suite_run( &
ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0
ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0
ldrag(i) = ldrag(i) .or. var_stoch(i) .le. 0.0
+! Check if mesoscale gravity waves will propagate vertically or be evanescent
+! and not impart a drag force -- consider the maximum sub-grid horizontal
+! topographic wavelength to be one-half the horizontal grid spacing -- calculate
+! ksmax accordingly
+ ksmax = 4.0*pi/dx(i) ! based on wavelength = 0.5*dx(i)
+ if ( bnv2(i,1).gt.0.0 ) then
+ ldrag(i) = ldrag(i) .or. sqrt(bnv2(i,1))*rulow(i).lt.ksmax
+ endif
!
! set all ri low level values to the low level value
!
@@ -1106,7 +1116,19 @@ subroutine drag_suite_run( &
enddo
!
do k = kts,km
- taud_ms(i,k) = taud_ms(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i))
+
+ ! Check if well into mesosphere -- if so, perform similar reduction of
+ ! velocity tendency due to mesoscale GWD to prevent sudden reversal of
+ ! wind direction (similar to above)
+ dtfac_meso = 1.0
+ if (prsl(i,k).le.plolevmeso) then
+ if (taud_ms(i,k).ne.0.) &
+ dtfac_meso = min(dtfac_meso,facmeso*abs(velco(i,k) &
+ /(deltim*rcs*taud_ms(i,k))))
+ end if
+
+ taud_ms(i,k) = taud_ms(i,k)*dtfac(i)*dtfac_meso* &
+ ls_taper(i) *(1.-rstoch(i))
taud_bl(i,k) = taud_bl(i,k)*dtfac(i)* ls_taper(i) *(1.-rstoch(i))
dtaux = taud_ms(i,k) * xn(i)
diff --git a/physics/module_mp_nssl_2mom.F90 b/physics/module_mp_nssl_2mom.F90
index 409bf4019..ad90ec81f 100644
--- a/physics/module_mp_nssl_2mom.F90
+++ b/physics/module_mp_nssl_2mom.F90
@@ -1,7 +1,14 @@
!> \file module_mp_nssl_2mom.F90
+
+
+
+
+
+
+
!---------------------------------------------------------------------
-! code snapshot: "Feb 24 2022" at "14:27:57"
+! code snapshot: "Sep 22 2023" at "22:01:53"
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! IMPORTANT: Best results are attained using the 5th-order WENO (Weighted Essentially Non-Oscillatory) advection option (4) for scalars:
@@ -19,37 +26,32 @@
! WENO references: Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
!
!>\ingroup mod_mp_nssl2m
-!! This module provides a 2-moment bulk microphysics scheme described by
-!! Mansell, Zeigler, and Bruning (2010, JAS)
-!!
-!! This module provides a 2-moment bulk microphysics scheme based on a combination of
-!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in
-!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation
+!! This module provides a 1/2/3-moment bulk microphysics scheme based on a combination of
+!! Straka and Mansell (2005, JAM) and Zeigler (1985, JAS) and modified/upgraded in
+!! in Mansell, Zeigler, and Bruning (2010, JAS). Two-moment adaptive sedimentation
!! follows Mansell (2010, JAS), using parameter infall = 4.
!!
!! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS)
!!
-!! Average graupel particle density is predicted, which affects fall speed as well.
-!! Hail density prediction is by default disabled in this version, but may be enabled
-!! at some point if there is interest.
+!! Average graupel and hail particle densities are predicted, which affects fall speed as well.
!!
!! Maintainer: Ted Mansell, National Severe Storms Laboratory
!!
!! Microphysics References:
!!
-!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small
+!! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small
!! thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1.
!!
-!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and
-!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050,
+!! Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and
+!! precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050,
!! doi:10.1175/JAS-D-12-0264.1.
!!
-!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms.
+!! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms.
!! Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509.
!!
!! Sedimentation reference:
!!
-!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics.
+!! Mansell, E. R., 2010: On sedimentation and advection in multimoment bulk microphysics.
!! J. Atmos. Sci., 67, 3084-3094, doi:10.1175/2010JAS3341.1.
!
! Possible parameters to adjust:
@@ -63,18 +65,25 @@
! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The
! implementation of an explicit charging and discharge lightning scheme
! within the WRF-ARW model: Benchmark simulations of a continental squall line, a
-! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415
+! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415
!
-! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated
+! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated
! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287
!
! Note: Some parameters below apply to unreleased features.
!
!
!---------------------------------------------------------------------
+! Apr. 2023
+! - Update to 3-moment for rain, graupel, and hail
+! - Change default graupel/hail fall speeds to icdx/icdxhl=6 (Milbrandt & Morrison 2013)
+! and also set default ehw0=0.9 and ehlw0=0.9 to compensate for lower fall speeds.
+! - Change default hail conversion to ihlcnh=-1, and then =1 for 2-mom or =3 for 3-mom,
+! using wet growth diameter to convert large graupel
+!---------------------------------------------------------------------
! Sept. 2021:
! Fixes:
-! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
+! Restored previous formulation of snow reflectivity, as it was realized that the last change incorrectly assumed a fixed
! density independent of size. Generally lower snow reflectivity values as a result (no effect on microphysics)
! Other:
! Generic fall speed coeffecients (axx,bxx) to accomodate future frozen drops category (no effect)
@@ -221,7 +230,7 @@ MODULE module_mp_nssl_2mom
real, private :: rho_qr = 1000., cnor = 8.0e5 ! cnor is set in namelist!! rain params
real, private :: rho_qs = 100., cnos = 3.0e6 ! set in namelist!! snow params
real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params
- real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params
+ real, private :: rho_qhl= 800., cnohl = 4.0e4 ! set in namelist!! hail params
real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel)
real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail)
@@ -234,8 +243,9 @@ MODULE module_mp_nssl_2mom
real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5)
real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion)
real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime)
- real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
- real , public :: qccn ! ccn "mixing ratio"
+ real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value
+ real , private :: ccnuf = 0 ! set in namelist!! Central plains CCN value
+ real , public :: qccn, qccnuf ! ccn "mixing ratio"
real , private :: old_qccn = -1.0
integer, private :: iauttim = 1 ! 10-ice rain delay flag
real , private :: auttim = 300. ! 10-ice rain delay time
@@ -245,12 +255,17 @@ MODULE module_mp_nssl_2mom
! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#else
- logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
+ logical, private :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
#endif
logical :: switchccn = .false.
real :: old_cccn = -1.0
logical :: restoreccn = .true. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted)
real :: ccntimeconst = 3600. ! time constant for CCN restore (either for CCNA or when restoreccn = true)
+ real, private :: restoreccnfrac = 1.0 ! fraction of evaporated droplets that restore CCN
+ real :: ufccntimeconst = 6.*3600. ! time constant for UFCCN decay (Blossey et al. 2018)
+ real :: ufbackground = 0.1e9 ! background ccnuf value (Blossey et al.)
+ logical :: decayufccn = .false.
+ integer :: i_uf_or_ccn = 0 ! 0 = ship adds UF; 1 = treat UF as regular ccn (add to qccn)
! sedimentation flags
! itfall -> 0 = 1st order fallout (other options removed)
@@ -259,6 +274,7 @@ MODULE module_mp_nssl_2mom
integer, private :: itfall = 0
integer, private :: iscfall = 1
integer, private :: irfall = -1
+ integer, private :: isfall = 2 ! default limit with method II (more restrictive)
logical, private :: do_accurate_sedimentation = .true. ! if true, recalculate fall speeds on sub time steps; (more expensive)
! if false, reuse fall speeds on multiple steps (can have a noticeable speedup)
! Mainly is an issue for small dz near the surface.
@@ -269,14 +285,20 @@ MODULE module_mp_nssl_2mom
! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS)
! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS)
! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max.
+ integer :: imydiagalpha = 0 ! apply MY diagnostic shape parameter for fall speeds (1=for fall speed only; 2=also for microphysics rates)
real, private :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
real, private :: icefallfac = 1.5 ! factor to adjust ice fall speed
real, private :: snowfallfac = 1.25 ! factor to adjust snow fall speed
real, private :: graupelfallfac = 1.0 ! factor to adjust graupel fall speed
real, private :: hailfallfac = 1.0 ! factor to adjust hail fall speed
integer, private :: icefallopt = 3 ! 1= default, 2 = Ferrier ice fall speed; 3 = adjusted Ferrier (slightly high Vt)
- integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
- integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ integer, private :: icdx = 6 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ integer, private :: icdxhl = 6 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
+ ! 6= Milbrandt and Morrison (2013) density-based fall speed
+ real :: axh = 75.7149, bxh = 0.5
+ real :: axf = 75.7149, bxf = 0.5
+ real :: axhl = 206.984, bxhl = 0.6384
real , private :: cdhmin = 0.45, cdhmax = 0.8 ! defaults for graupel (icdx=4)
real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4)
real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4)
@@ -310,7 +332,7 @@ MODULE module_mp_nssl_2mom
integer, private :: irimtim = 0 ! future use
! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds
- integer, private :: irimdenopt = 1 ! = 1 for default Macklin; = 2 for experimental Cober and List (1993)
+ integer, private :: irimdenopt = 1 ! = 1 for default Heymsfield and Pflaum (1985); = 2 for experimental Cober and List (1993); = 3 Macklin
real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985)
real , private :: rimc3 = 170.0 ! minimum rime density
real :: rimc4 = 900.0 ! maximum rime density
@@ -325,7 +347,7 @@ MODULE module_mp_nssl_2mom
! (first nucleation is done with a KW sat. adj. step)
integer, private :: issfilt = 0 ! flag to turn on filtering of supersaturation field
integer, private :: icnuclimit = 0 ! limit droplet nucleation based on Konwar et al. (2012) and Chandrakar et al. (2016)
- integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud
+ integer, private :: irenuc = 2 ! =1 to always allow renucleation of droplets within the cloud (do no use, obsolete)
! =2 renucleation following Twomey/Cohard&Pinty
! =7 New renucleation that requires prediction of the number of activated nuclei
! i.e., not only at cloud base
@@ -347,6 +369,7 @@ MODULE module_mp_nssl_2mom
! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr
integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process
+ integer, private :: in_freeze_rain_first = 0 ! =1 use IN to freezed rain drops (if none, then freeze droplets)
integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott), =4 DeMott (2010)
real, private :: naer = 1.0e6 ! background large aerosol conc. for DeMott
integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
@@ -357,7 +380,9 @@ MODULE module_mp_nssl_2mom
integer, private :: iremoveqwfrz = 1 ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation
integer, private :: iacr = 2 ! Flag for drop contact freezing with crytals
! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
+ integer, private :: icrcev = 1 ! 1 = old crcev; 2 = crcev scaled by vtrain ratio (num/mass); 3 = set to zero
integer, private :: icracr = 1 ! Flag to turn rain self-collection on/off (=0 to turn off)
+ integer, private :: icracrthresh = 1 ! For rain self-coll. thresh. use: 1 = mean diam of 2mm; 2 = rain median volume diam of 1.9mm
integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel
! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
@@ -413,11 +438,15 @@ MODULE module_mp_nssl_2mom
! set eii1 = 0 to get a constant value of eii0
real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
! set eii1hl = 0 to get a constant value of eii0hl
+ real, private :: ewi_dcmin = 15.0e-06 ! minimum droplet diameter for nonzero ewi
+ real, private :: ewi_dimin = 30.0e-06 ! minimum ice crystal diameter for nonzero ewi
real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals
real , private :: eri_cimin = 10.e-6 ! minimum ice crystal diameter for collection by rain
real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency
real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0))
! set ehs1 = 0 to get a constant value of ehs0
+ integer :: iessopt = 1 ! 1 = Original (no factor); 2 = factor based on wvel; 3 = factor based on SSI
+ ! 4 = as 3 but sets min factor of 0.1 and goes to full value at 0.5% SSI
real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0))
! set ess1 = 0 to get a constant value of ess0
real , private :: esstem1 = -15. ! lower temperature where snow aggregation turns on
@@ -452,11 +481,13 @@ MODULE module_mp_nssl_2mom
! 0 = no condensation on rain; 1 = bulk condensation on rain
integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation
! icond = 2 does not work (intended to calc. dep in loop with droplet cond.)
+ integer, private :: iqis0 = 2 ! = 1 for normal qis; = 2 to set qis to use T = 0C when T > 0C
real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1
! and for ciacrf for iacr=4
real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail
real , private :: dshd = 1.0e-3 ! nominal diameter for rain drops shed from graupel/hail
+ integer, private :: ivshdgs = 1 ! 0 = use 1mm for all shedding (non-mixedphase); 1 = use vshdgs with sheddiam
integer, private :: ished2cld = 0 ! 1: Send shed liquid (from wet growth) to cloud droplets
integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail
@@ -480,6 +511,7 @@ MODULE module_mp_nssl_2mom
real, private :: qhdpvdn = -1.
real, private :: qhacidn = -1.
+ integer, private :: iraintypes = 0
logical, private :: mixedphase = .false. ! .false.=off, true=on to include mixed phase graupel
integer, private :: imixedphase = 0
logical, private :: qsdenmod = .false. ! true = modify snow density by linear interpolation of snow and rain density
@@ -511,17 +543,23 @@ MODULE module_mp_nssl_2mom
real, parameter :: alpharmax = 8. ! limited for rwvent calculation
- integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use
+ integer, private :: ihlcnh = -1 ! which graupel -> hail conversion to use
! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter
! 2 = Straka and Mansell (2005) conversion using size threshold
+ ! 3 = Conversion using wet growth diameter
real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
- real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
+ real , private :: hldia1 = 10.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option.
+ integer, private :: incwet = 0 ! flag to do wet growth only on D > D_wet
integer, private :: iusedw = 0 ! flag to use experimental wet growth ice diameter for gr -> hl conversion (=1 turns on)
- real , private :: dwmin = 0.0 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwetmin = 5.0e-3 ! Minimum diameter with iusedw (can stay at 0 or be set to something larger)
+ real , private :: dwmax = 15.e-3 ! for ihlcnh, always convert this size and larger whether or not there is wet growth
real , private :: dwtempmin = 242. ! lowest temperature to allow wet growth conversion to hail
real , private :: dwehwmin = 0. ! Minimum ehw to use to find wet growth diameter (if > ehw0, then wet growth diam becomes smaller)
real , private :: dg0thresh = 0.15 ! graupel wet growth diameter above which we say do not bother
+ integer :: ifddenfac = 0 ! = 1 to use density threshold to count FD as GR when converting to HL
+ real :: fddenthresh = 500. ! if ifddenfac > 0, then hail from FD with lower density are considered to come from graupel
integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed
integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
@@ -538,6 +576,8 @@ MODULE module_mp_nssl_2mom
! = 1 use mean diameter for breakup
! = 2 use maximum mass diameter for breakup
! = 3 use mass-weighted diameter for breakup
+ integer :: iraintailbreak = 0 ! 1 = on
+ real :: draintail = 8.e-3 ! starting size for rain breakup
integer, private :: dmrauto = 0
! = -1 no limiter on crcnw
! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
@@ -545,7 +585,7 @@ MODULE module_mp_nssl_2mom
! = 2 DTD mass-weighted version based on MY code
! = 3 Milbrandt version (from Cohard and Pinty code
integer :: dmropt = 0 ! extra option for crcnw
- integer :: dmhlopt = 1 ! options for graupel -> conversion
+ integer :: dmhlopt = 0 ! options for graupel -> hail conversion
integer :: irescalerainopt = 3 ! 0 = default option
! 1 = qx(mgs,lc) > qxmin(lc)
! 2 = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < 3.0
@@ -562,7 +602,7 @@ MODULE module_mp_nssl_2mom
integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting
! when liquid fraction is not predicted
- logical :: iwetsoak = .true. ! soak and freeze during wet growth or not
+ logical, private :: iwetsoak = .true. ! soak and freeze during wet growth or not
integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters
! 1 = original Zrnic et al. (Mansell et al. 2010)
@@ -595,9 +635,12 @@ MODULE module_mp_nssl_2mom
integer, private :: ibinnum = 2 ! number of bins for melting of smaller ice (for ibinhmlr = 1)
integer, private :: iqhacrmlr = 1 ! turn on/off qhacrmlr
integer, private :: iqhlacrmlr = 1 ! turn on/off qhlacrmlr
+ integer, private :: iqhacwshr = 1 ! turn on/off qhacw for T > 0
+ integer, private :: iqhlacwshr = 1 ! turn on/off qhlacw for T > 0
real, private :: binmlrmxdia = 40.e-3 ! threshold diameter (graupel/hail) to switch bin-bulk melting to use standard chmlr
real, private :: binmlrzrrfac = 1.0 ! factor for reflectivity change ice that sheds while melting
real, private :: snowmeltdia = 0 ! If nonzero, sets the size of rain drops from melting snow.
+ real, private :: alphasmlr0 = 14.0 ! shape parameter for drops formed from melting/shedding snow
real, private :: delta_alphamlr = 0.5 ! offset from alphamax at which melting does not further collapse the shape parameter
integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau)
@@ -739,6 +782,7 @@ MODULE module_mp_nssl_2mom
real da1 (lc:lqmx) ! collection coefficients from Seifert 2005
real bb (lc:lqmx)
+
! put ipelec here for now....
integer :: ipelec = 0
integer :: isaund = 0
@@ -764,8 +808,8 @@ MODULE module_mp_nssl_2mom
double precision, parameter :: dgam = 0.01, dgami = 100.
double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)
- integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15
- integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25
+ integer, parameter :: nqiacralpha = 300 !480 ! 240 ! 120 ! 15
+ integer, parameter :: nqiacrratio = 400 ! 500 !50 ! 25
! real, parameter :: maxratiolu = 25.
real, parameter :: maxratiolu = 100. ! 25.
real, parameter :: maxalphalu = 15.
@@ -782,6 +826,10 @@ MODULE module_mp_nssl_2mom
! real :: ziacrratio(0:nqiacrratio,0:nqiacralpha)
! double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,12,2) ! last index for graupel (1) or hail (2)
+! for 3-moment collection coefficients
+ real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+ real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005
+
integer, parameter :: ngdnmm = 9
real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail
@@ -860,7 +908,7 @@ MODULE module_mp_nssl_2mom
! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius
real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius
- real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius
+ real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks max volume = 60 micron radius
real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6
real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6
real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13
@@ -903,18 +951,20 @@ MODULE module_mp_nssl_2mom
real, parameter :: cawbolton = 17.67
real, parameter :: tfrh = 233.15
+! --------------------------
+ ! For CCPP, the following variables should be set by the host model, but initial values are set just in case
real :: tfr = 273.15
-
real :: cp = 1004.0, rd = 287.04
real :: rw = 461.5 ! gas const. for water vapor
- REAL, PRIVATE :: cpl = 4190.0
- REAL, PRIVATE :: cpigb = 2106.0
- real :: cpi
- real :: cap
- real :: tfrcbw
- real :: tfrcbi
- real :: rovcp
-
+ real :: cpl = 4190.0
+ real :: cpigb = 2106.0
+ real :: cpi = 1.0/1004.0
+ real :: cap = 287.04/1004.0
+ real :: tfrcbw = 273.15 - cbw
+ real :: tfrcbi = 273.15 - cbi
+ real :: rovcp = 287.04/1004.0
+ real :: rdorv = 0.622
+! --------------------------
real, parameter :: poo = 1.0e+05
real, parameter :: advisc0 = 1.832e-05 ! reference dynamic viscosity (SMT; see Beard & Pruppacher 71)
real, parameter :: advisc1 = 1.718e-05 ! dynamic viscosity constant used in thermal conductivity calc
@@ -922,8 +972,8 @@ MODULE module_mp_nssl_2mom
! GHB: Needed for eqtset=2 in cm1
! REAL, PRIVATE :: cv = cp - rd
- real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air
- REAL, PRIVATE, parameter :: cvv = 1408.5
+ real, private, parameter :: cv = 717.0 ! specific heat at constant volume - air
+ REAL, PRIVATE, parameter :: cvv = 1408.5
! GHB
real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0)
@@ -952,10 +1002,12 @@ MODULE module_mp_nssl_2mom
logical, parameter :: do_satadj_for_wrfchem = .true.
+ integer, parameter :: ac_opt = 0 ! option flag for alternate aerosol (for NUWRF only)
+ logical, private :: nuaccoinp = .false.
! Note to users: Many of these options are for development and not guaranteed to perform well.
! Some may not be functional depending on the version of the code.
-! Some may be useful for ensemble physics diversity. Feel free to contact me if you have questions
+! Some may be useful for ensemble physics diversity. Feel free to contact Ted Mansell if you have questions
! in that regard.
NAMELIST /nssl_mp_params/ &
ndebug, ncdebug,&
@@ -965,7 +1017,7 @@ MODULE module_mp_nssl_2mom
idbzci, &
vtmaxsed, &
itfall,iscfall, &
- infall, &
+ infall,irfall,isfall, &
rssflg, &
sssflg, &
hssflg, &
@@ -976,13 +1028,15 @@ MODULE module_mp_nssl_2mom
icnuclimit, &
irenuc, &
restoreccn, ccntimeconst, cck, &
+ decayufccn, ufccntimeconst, &
switchccn, old_cccn, &
ciintmx, &
itype1, itype2, &
- icenucopt, &
+ icenucopt, in_freeze_rain_first, &
naer, &
icfn, &
ibfc, iacr, icracr, &
+ icracrthresh, &
cwfrz2snowfrac, cwfrz2snowratio, &
ibfr, &
ibiggopt, &
@@ -998,7 +1052,7 @@ MODULE module_mp_nssl_2mom
eri_cimin, &
eii0hl, eii1hl, &
ehs0, ehs1, &
- ess0, ess1, &
+ ess0, ess1, iessopt, &
esstem1,esstem2, &
ircnw, qminrncw,& ! single-moment only
iglcnvi, &
@@ -1024,6 +1078,7 @@ MODULE module_mp_nssl_2mom
hailfallfac, &
icefallopt, &
icdx,icdxhl, &
+ axh,bxh,axf,bxf,axhl,bxhl, &
cdhmin, cdhmax, &
cdhdnmin, cdhdnmax, &
cdhlmin, cdhlmax, &
@@ -1058,7 +1113,7 @@ MODULE module_mp_nssl_2mom
rescale_low_alphah, &
rescale_low_alphahl, &
rescale_high_alpha, &
- ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwtempmin, &
+ ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, &
icvhl2h, hldnmn,hdnmn, &
hlcnhdia, hlcnhqmin, &
isedonly, &
@@ -1133,12 +1188,12 @@ SUBROUTINE nssl_2mom_init_const( &
real, intent(in) :: con_g, con_rd, con_cp, con_rv, &
con_t0c, con_cliq, con_csol, con_eps
- cp608 = con_eps ! 0.608 ! constant used in conversion of T to Tv
gr = con_g
tfr = con_t0c
cp = con_cp
rd = con_rd
rw = con_rv
+ rdorv = con_eps
cpl = con_cliq ! 4190.0
cpigb = con_csol ! 2106.0
cpi = 1./cp
@@ -1151,6 +1206,8 @@ SUBROUTINE nssl_2mom_init_const( &
RETURN
END SUBROUTINE nssl_2mom_init_const
+
+
! #####################################################################
! #####################################################################
!>\ingroup mod_nsslmp
@@ -1165,7 +1222,14 @@ SUBROUTINE nssl_2mom_init( &
& nssl_icdxhl, &
& nssl_icefallfac, &
& nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_ufccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar, &
+ & nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on, ccn_is_ccna, &
& errmsg, errflg, &
+ & infileunit, &
& myrank, mpiroot &
)
@@ -1177,24 +1241,38 @@ SUBROUTINE nssl_2mom_init( &
& nssl_ehw0, &
& nssl_ehlw0, &
& nssl_icefallfac, &
- & nssl_snowfallfac
+ & nssl_snowfallfac, &
+ & nssl_cccn, &
+ & nssl_alphah, &
+ & nssl_alphahl, &
+ & nssl_alphar
integer, intent(in), optional :: &
& nssl_icdx, &
- & nssl_icdxhl, myrank, mpiroot
+ & nssl_icdxhl, myrank, mpiroot, &
+ & nssl_ufccn
+ logical, intent(in), optional :: nssl_density_on, nssl_hail_on, nssl_ccn_on, nssl_icecrystals_on
+ integer, intent(inout), optional :: ccn_is_ccna
+
+ integer, intent(in),optional :: infileunit
! CCPP error handling
character(len=*), intent( out) :: errmsg
integer, intent( out) :: errflg
- integer, intent(in) :: ims,ime, jms,jme, kms,kme
- real, intent(in), dimension(20) :: nssl_params
+ integer, intent(in), optional :: ims,ime, jms,jme, kms,kme
+
+ real, intent(in), dimension(20), optional :: nssl_params
- integer, intent(in) :: ipctmp,mixphase,ihvol
+ integer, intent(in) :: ipctmp,mixphase
+ integer, optional, intent(in) :: ihvol
logical, optional, intent(in) :: idoniconlytmp
+ integer :: igvol_local = 1
logical :: wrote_namelist = .false.
logical :: wrf_dm_on_monitor
+ integer :: hail_on = -1, density_on = -1, icecrystals_on = 1
+ integer :: ccn_on = -1
double precision :: arg
real :: temq
@@ -1202,22 +1280,59 @@ SUBROUTINE nssl_2mom_init( &
integer :: i,il,j,l
integer :: ltmp
integer :: isub
- real :: bxh,bxhl
+ real :: bxh1,bxhl1
real :: alp,ratio
double precision :: x,y,y2,y7
logical :: turn_on_ccna, turn_on_cina
+ integer :: iufccn = 0
integer :: istat
+
+ real :: alpjj, alpii, xnuii, xnujj
+ integer :: ii, jj
errmsg = ''
errflg = 0
turn_on_ccna = .false.
turn_on_cina = .false.
+
+! IF ( present( igvol ) ) THEN
+! igvol_local = igvol
+! ENDIF
+
+ IF ( present( nssl_hail_on ) ) THEN
+ IF ( nssl_hail_on ) THEN
+ hail_on = 1
+ ELSE
+ hail_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_density_on ) ) THEN
+ IF ( nssl_density_on ) THEN
+ density_on = 1
+ ELSE
+ density_on = 0
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_icecrystals_on ) ) THEN
+ IF ( nssl_icecrystals_on ) THEN
+ icecrystals_on = 1
+ ELSE
+ icecrystals_on = 0
+ ! renucfrac = 1.0 ! why was this set to 1?
+ ffrzs = 1.0
+ ENDIF
+ ENDIF
+
+
!
! set some global values from namelist input
!
+ IF ( present( nssl_params ) ) THEN
ccn = Abs( nssl_params(1) )
alphah = nssl_params(2)
alphahl = nssl_params(3)
@@ -1228,26 +1343,60 @@ SUBROUTINE nssl_2mom_init( &
rho_qh = nssl_params(8)
rho_qhl = nssl_params(9)
rho_qs = nssl_params(10)
- alphar = nssl_params(15)
-
+ IF ( Nint(nssl_params(13)) == 1 ) THEN
+ ! hack to switch CCN field to CCNA (activated ccn)
+! invertccn = .true.
+ turn_on_ccna = .true.
+ irenuc = 7
+ ENDIF
+ ccnuf = Abs( nssl_params(14) )
+ IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn
+
+ ENDIF
+ alphar = nssl_params(15)
! ipelec = Nint(nssl_params(11))
! isaund = Nint(nssl_params(12))
+
+
IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac
IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac
- IF ( present(nssl_ehw0) ) ehw0 = nssl_ehw0
- IF ( present(nssl_ehlw0) ) ehlw0 = nssl_ehlw0
+ IF ( present(nssl_ehw0) ) THEN
+ IF ( nssl_ehw0 > 0.0 ) ehw0 = nssl_ehw0
+ ENDIF
+ IF ( present(nssl_ehlw0) ) THEN
+ IF ( nssl_ehlw0 > 0.0 ) ehlw0 = nssl_ehlw0
+ ENDIF
IF ( present(nssl_icdx) ) icdx = nssl_icdx
IF ( present(nssl_icdxhl) ) icdxhl = nssl_icdxhl
IF ( present(nssl_icefallfac) ) icefallfac = nssl_icefallfac
IF ( present(nssl_snowfallfac) ) snowfallfac = nssl_snowfallfac
+ IF ( present(nssl_cccn) ) THEN
+ IF (nssl_cccn > 1 ) ccn = nssl_cccn
+ ENDIF
+ IF ( present(nssl_alphah) ) THEN
+ IF ( nssl_alphah > -1. ) alphah = nssl_alphah
+ ENDIF
+ IF ( present(nssl_alphahl) ) THEN
+ IF ( nssl_alphahl > -1. ) alphahl = nssl_alphahl
+ ENDIF
+ IF ( present(nssl_alphar) ) THEN
+ IF ( nssl_alphar > -1.0 ) alphar = nssl_alphar
+ ENDIF
- IF ( Nint(nssl_params(13)) == 1 ) THEN
- ! hack to switch CCN field to CCNA (activated ccn)
-! invertccn = .true.
- turn_on_ccna = .true.
- irenuc = 7
+ ipconc = ipctmp
+
+ IF ( ipconc < 5 ) THEN
+ ihlcnh = 0
+ ENDIF
+
+ IF ( ihlcnh <= 0 ) THEN
+ IF ( ipconc == 5 ) THEN
+ ihlcnh = 3
+ ELSEIF ( ipconc >= 6 ) THEN
+ ihlcnh = 3
ENDIF
+ ENDIF
@@ -1275,8 +1424,43 @@ SUBROUTINE nssl_2mom_init( &
+ IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn
+ irenuc = 7
+ IF ( ccnuf <= 0.0 ) decayufccn = .true. ! assume surface emission and need decay
+ IF ( i_uf_or_ccn > 0 ) THEN
+ ufbackground = 0.0
+ ccntimeconst = ufccntimeconst
+ ENDIF
+ ENDIF
+
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( nssl_ccn_on ) THEN
+ ccn_on = 1
+ ELSE
+ ccn_on = 0
+ irenuc = 2
+ ENDIF
+ ENDIF
+
IF ( irenuc >= 5 ) THEN
turn_on_ccna = .true.
+ IF ( present( nssl_ccn_on ) ) THEN
+ IF ( .not. nssl_ccn_on ) THEN
+ errmsg = 'NSSL_MP Error: Must have nssl_ccn_on=1 for irenuc >= 5!'
+ errflg = 1
+ return
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( present( ccn_is_ccna ) .and. ccn_on == 1 ) THEN
+ IF ( ccn_is_ccna > 0 ) THEN
+ turn_on_ccna = .true.
+ ELSE
+ IF ( irenuc >= 5 ) THEN
+ ccn_is_ccna = 1
+ ENDIF
+ ENDIF
ENDIF
cwccn = ccn
@@ -1290,25 +1474,42 @@ SUBROUTINE nssl_2mom_init( &
lh = lh + 1
lhl = lhl + 1
ENDIF
- IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
- IF ( ihvol == -1 .or. ihvol == -2 ) THEN
- lhab = lhab - 1 ! turns off hail
- lhl = 0
- ! past me thought it would be a good idea to change graupel factors when hail is off....
- ! ehw0 = 0.75
- ! iehw = 2
- ! dfrz = Max( dfrz, 0.5e-3 )
- ENDIF
- IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off
- ! a value of -3 means to turn off ice crystals but turn on hail
- renucfrac = 1.0
- ffrzs = 1.0
- ! idoci = 0 ! try this later
+ IF ( hail_on == -1 ) THEN ! hail_on is not set
+ hail_on = 1
+ IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
+ IF ( ihvol == -1 .or. ihvol == -2 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ hail_on = 0
+ ! past me thought it would be a good idea to change graupel factors when hail is off....
+ ! ehw0 = 0.75
+ ! iehw = 2
+ ! dfrz = Max( dfrz, 0.5e-3 )
+ ENDIF
+ IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ! ice crystals are turned off
+ ! a value of 2? means to turn off ice crystals but turn on hail
+ ! renucfrac = 1.0 ! why?
+ ffrzs = 1.0
+ ! idoci = 0 ! try this later
+ ENDIF
+ ENDIF
+
+ ELSE ! hail_on is set
+ IF ( hail_on == 0 ) THEN
+ lhab = lhab - 1 ! turns off hail
+ lhl = 0
+ ELSE
+ ! assume default that hail is on
ENDIF
ENDIF
+
+ IF ( density_on == -1 ) THEN ! density flag not set, so default is to predict it
+ density_on = 1
+ ENDIF
+
IF ( iresetmoments == 0 ) iresetmoments = 1 ! lhl
-! write(0,*) 'wrf_init: lhab,lhl = ',lhab,lhl
+! write(0,*) 'wrf_init: lhab,lhl,hail_on,density_on = ',lhab,lhl,hail_on,density_on
! IF ( ipelec > 0 ) idonic = .true.
@@ -1335,29 +1536,42 @@ SUBROUTINE nssl_2mom_init( &
bx(lr) = 0.85
ax(lr) = 1647.81
fx(lr) = 135.477
+
IF ( icdx == 6 ) THEN
bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550.
ax(lh) = 157.71
- ELSEIF ( icdx > 0 ) THEN
+! ELSEIF ( icdx == 1 ) THEN
+! bx(lh) = bxh
+! ax(lh) = axh
+ ELSEIF ( icdx > 1 ) THEN
bx(lh) = 0.5
ax(lh) = 75.7149
- ELSE
- bx(lh) = 0.37 ! 0.6 ! Ferrier 1994
+ ELSEIF ( icdx == 0 ) THEN
+ bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 graupel
ax(lh) = 19.3
+ ELSE ! icdx < 0
+! ax(lh) = 206.984 ! Ferrier 1994 hail/frozen drops
+! bx(lh) = 0.6384
+ bx(lh) = bxh
+ ax(lh) = axh
ENDIF
+
! bx(lh) = 0.6
IF ( lhl .gt. 1 ) THEN
IF ( icdxhl == 6 ) THEN
bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750.
ax(lhl) = 179.36
+ ELSEIF (icdxhl == 0 ) THEN
+ ax(lhl) = 206.984 ! Ferrier 1994
+ bx(lhl) = 0.6384
ELSEIF (icdxhl > 0 ) THEN
- bx(lhl) = 0.5
- ax(lhl) = 75.7149
+ bx(lhl) = 0.5
+ ax(lhl) = 75.7149
ELSE
- ax(lhl) = 206.984 ! Ferrier 1994
- bx(lhl) = 0.6384
+ bx(lhl) = bxhl
+ ax(lhl) = axhl
ENDIF
ENDIF
@@ -1373,8 +1587,8 @@ SUBROUTINE nssl_2mom_init( &
! Uses incomplete gamma functions
! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option)
- bxh = bx(lh)
- bxhl = bx(Max(lh,lhl))
+ bxh1 = bx(lh)
+ bxhl1 = bx(Max(lh,lhl))
! DO j = 0,nqiacralpha
DO j = ialpstart,nqiacralpha
@@ -1390,9 +1604,9 @@ SUBROUTINE nssl_2mom_init( &
! graupel (.,.,.,1)
gamxinflu(i,j,1,1) = x/y
gamxinflu(i,j,2,1) = gamxinfdp( 2.0+alp, ratio )/y
- gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh, ratio )/y
+ gamxinflu(i,j,3,1) = gamxinfdp( 2.5+alp+0.5*bxh1, ratio )/y
gamxinflu(i,j,5,1) = (gamma_dpr(5.0+alp) - gamxinfdp( 5.0+alp, ratio ))/y
- gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh) - gamxinfdp( 5.5+alp+0.5*bxh, ratio ))/y
+ gamxinflu(i,j,6,1) = (gamma_dpr(5.5+alp+0.5*bxh1) - gamxinfdp( 5.5+alp+0.5*bxh1, ratio ))/y
gamxinflu(i,j,9,1) = gamxinfdp( 1.0+alp, ratio )/y
gamxinflu(i,j,10,1)= gamxinfdp( 4.0+alp, ratio )/y
@@ -1401,9 +1615,9 @@ SUBROUTINE nssl_2mom_init( &
! hail (.,.,.,2)
gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1)
gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1)
- gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl, ratio )/y
+ gamxinflu(i,j,3,2) = gamxinfdp( 2.5+alp+0.5*bxhl1, ratio )/y
gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1)
- gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl) - gamxinfdp( 5.5+alp+0.5*bxhl, ratio ))/y
+ gamxinflu(i,j,6,2) = (gamma_dpr(5.5+alp+0.5*bxhl1) - gamxinfdp( 5.5+alp+0.5*bxhl1, ratio ))/y
gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)
@@ -1411,16 +1625,16 @@ SUBROUTINE nssl_2mom_init( &
! gamxinflu(i,j,7,1) = gamxinfdp( alp - 1., ratio )/y
gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., ratio ))/y
! gamxinflu(i,j,8,1) = gamxinfdp( alp - 0.5 + 0.5*bxh, ratio )/y
- gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh) - gamxinfdp( alp - 0.5 + 0.5*bxh, ratio ))/y
-! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio )/y
- gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl) - gamxinfdp( alp - 0.5 + 0.5*bxhl, ratio ))/y
+ gamxinflu(i,j,8,1) = (gamma_dpr(alp - 0.5 + 0.5*bxh1) - gamxinfdp( alp - 0.5 + 0.5*bxh1, ratio ))/y
+! gamxinflu(i,j,8,2) = gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y
ELSE
! gamxinflu(i,j,7,1) = gamxinfdp( .1, ratio )/y
gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, ratio ) )/y
-! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio )/y
-! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio )/y
- gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y
- gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y
+! gamxinflu(i,j,8,1) = gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio )/y
+! gamxinflu(i,j,8,2) = gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio )/y
+ gamxinflu(i,j,8,1) = (gamma_dpr(1.1 - 0.5 + 0.5*bxh1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxh1, ratio ) )/y
+ gamxinflu(i,j,8,2) = (gamma_dpr(1.1 - 0.5 + 0.5*bxhl1) - gamxinfdp( 1.1 - 0.5 + 0.5*bxhl1, ratio ) )/y
ENDIF
gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)
@@ -1454,9 +1668,8 @@ SUBROUTINE nssl_2mom_init( &
qiacrratio(0,:) = 1.0
- isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0
-
lccn = 0
+ lccnuf = 0
lccna = 0
lnc = 0
lnr = 0
@@ -1478,34 +1691,41 @@ SUBROUTINE nssl_2mom_init( &
! lccn = 9
- ipconc = ipctmp
IF ( ipconc == 0 ) THEN
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN ! turn on graupel density for 1-moment scheme
lvh = 9
ltmp = 9
denscale(lvh) = 1
- ELSE ! no hail
+ ELSE ! no hail, 'LFO' scheme
ltmp = lhab
lhl = 0
ENDIF
ELSEIF ( ipconc == 5 ) THEN
- lccn = lhab+1 ! 9
- lnc = lhab+2 ! 10
- lnr = lhab+3 ! 11
- lni = lhab+4 !12
- lns = lhab+5 !13
- lnh = lhab+6 !14
+ ltmp = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
- IF ( ihvol >= 0 ) THEN
+ IF ( hail_on == 1 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on >= 1 ) THEN
ltmp = ltmp + 1
lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
! ltmp = lvh
- denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
+ ENDIF
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1523,25 +1743,31 @@ SUBROUTINE nssl_2mom_init( &
! ltmp = lhlw
ENDIF
ELSEIF ( ipconc >= 6 ) THEN
- errmsg = 'NSSL microphysics has not been compiled for 3-moment. Sorry.'
- errflg = 1
- return
- lccn = lhab+1 ! 9
- lnc = lhab+2 ! 10
- lnr = lhab+3 ! 11
- lni = lhab+4 !12
- lns = lhab+5 !13
- lnh = lhab+6 !14
+ ltmp = lhab
+ IF ( iufccn > 0 ) THEN
+ ltmp = ltmp+1
+ lccnuf = ltmp
+ denscale(lccnuf) = 1
+ ENDIF
+
+ lccn= ltmp+1 ! 9
+ lnc = ltmp+2 ! 10
+ lnr = ltmp+3 ! 11
+ lni = ltmp+4 !12
+ lns = ltmp+5 !13
+ lnh = ltmp+6 !14
ltmp = lnh
IF ( lhl > 0 ) THEN
ltmp = ltmp + 1
lnhl = ltmp ! lhab+7 ! 15
ENDIF
+ IF ( density_on == 1 ) THEN
ltmp = ltmp + 1
lvh = ltmp ! lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
+ ENDIF
! ltmp = lvh
- denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
+ denscale(lccn:ltmp) = 1
+ IF ( density_on == 1 .and. hail_on == 1 ) THEN
ltmp = ltmp + 1
lvhl = ltmp
! ltmp = lvhl
@@ -1561,19 +1787,14 @@ SUBROUTINE nssl_2mom_init( &
lzh = ltmp
ltmp = ltmp + 1
lzr = ltmp
- ltmp = ltmp + 1
IF ( lhl > 1 ) THEN
ltmp = ltmp + 1
lzhl = ltmp
ENDIF
+ ! write(0,*) 'ipcon,lzr = ',ipconc,lzr,lzh,lzhl
ENDIF
! ltmp = lvh
! denscale(lccn:lvh) = 1
- IF ( ihvol >= 1 ) THEN
- lvhl = ltmp+1
- ltmp = lvhl
- denscale(lvhl) = 1
- ENDIF
IF ( mixedphase ) THEN
ltmp = ltmp + 1
lsw = ltmp
@@ -1593,7 +1814,8 @@ SUBROUTINE nssl_2mom_init( &
-
+ ! write(0,*) 'wrf_init: lh,lhl,lzh,lzhl = ',lh,lhl,lzh,lzhl
+ ! write(0,*) 'wrf_init: ipconc = ',ipconc
! write(0,*) 'wrf_init: irenuc, turn_on_ccna = ',irenuc, turn_on_ccna
IF ( turn_on_ccna ) THEN
ltmp = ltmp + 1
@@ -1825,9 +2047,11 @@ SUBROUTINE nssl_2mom_init( &
IF ( lhl .gt. 1 ) ido(lhl) = idohl
IF ( irfall .lt. 0 ) irfall = infall
+ IF ( isfall .lt. 0 ) isfall = infall
IF ( lzr > 0 ) irfall = 0
qccn = ccn/rho00
+ qccnuf = ccnuf/rho00
IF ( old_cccn > 0.0 ) THEN
old_qccn = old_cccn/rho00
ELSE
@@ -1981,6 +2205,33 @@ SUBROUTINE nssl_2mom_init( &
ENDDO
ENDDO
+ dab0lu(:,:,:,:) = 0.0
+ dab1lu(:,:,:,:) = 0.0
+
+ IF ( ipconc >= 6 ) THEN
+ DO il = lc,lhab ! collector
+ DO j = lc,lhab ! collected
+ IF ( il .ne. j ) THEN
+
+ DO jj = ialpstart,nqiacralpha
+ alpjj = float(jj)*dqiacralpha
+ xnujj = (alpjj - 2.)/3.
+ DO ii = ialpstart,nqiacralpha
+ alpii = float(ii)*dqiacralpha
+ xnuii = (alpii - 2.)/3.
+
+ dab0lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 0)
+ dab1lu(ii,jj,il,j) = delabk(bb(il), bb(j), xnuii, xnujj, xmu(il), xmu(j), 1)
+
+ ENDDO
+ ENDDO
+! write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
gf4br = gamma_sp(4.0+br)
gf4ds = gamma_sp(4.0+ds)
gf4p5 = gamma_sp(4.0+0.5)
@@ -2029,18 +2280,25 @@ END SUBROUTINE nssl_2mom_init
!>\ingroup mod_nsslmp
!! Driver subroutine that copies state data to local 2D arrays for microphysics calls
SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl, &
- cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
- zrw, zhw, zhl, &
+ cn, vhw, vhl, cna, cni, f_cn, f_cna, f_cina, &
+ f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, &
+ cnuf, f_cnuf, &
+ zrw, zhw, zhl, f_zrw, f_zhw, f_zhl, f_vhw, f_vhl, &
qsw, qhw, qhlw, &
tt, th, pii, p, w, dn, dz, dtp, itimestep, &
+ is_theta_or_temp, &
+ ntmul, ntcnt, lastloop, &
RAINNC,RAINNCV, &
dx, dy, &
axtra, &
SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, &
SR,HAILNC, HAILNCV, &
+ hail_maxk1, hail_max2d, nwp_diagnostics, &
tkediss, &
re_cloud, re_ice, re_snow, re_rain, &
+ re_graup, re_hail, &
has_reqc, has_reqi, has_reqs, has_reqr, &
+ has_reqg, has_reqh, &
rainncw2, rainnci2, &
dbz, vzf,compdbz, &
rscghis_2d,rscghis_2dp,rscghis_2dn, &
@@ -2074,6 +2332,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
+
+
implicit none
@@ -2091,7 +2351,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
zrw, zhw, zhl, &
qsw, qhw, qhlw, &
qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni
+ integer, optional, intent(in) :: is_theta_or_temp
+ logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl ! not used yet
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf
real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & ! 2D accumulation arrays for vertically-integrated charging rate
rscghis_2dp, & ! 2D accumulation arrays for vertically-integrated charging rate (positive only)
@@ -2102,8 +2364,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
scr,scw,sci,scs,sch,schl,sciona,sctot ! space charge
real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: &
induc,noninduc,noninducp,noninducn ! charging rates: inductive, noninductive (all, positive, negative to graupel)
- real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez
- real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
+ real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz ! elecsave = Ez
+ real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion
real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn
real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii
@@ -2124,22 +2386,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra
! WRF variables
- real, dimension(ims:ime, jms:jme), intent(inout):: &
+ real, dimension(ims:ime, jms:jme) :: &
RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV)
real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV)
real, dimension(ims:ime, jms:jme), optional, intent(inout):: &
HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV)
+ real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d
+ integer, optional, intent(in) :: nwp_diagnostics
+! for cm1, set nproctot=44 (or as needed) to get domain total rates
integer, parameter :: nproc = 1
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, re_rain
+ double precision :: proctot(nproc),proctotmpi(nproc)
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: re_cloud, re_ice, re_snow, &
+ re_rain, re_graup, re_hail
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss
- INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr
+ INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs, has_reqr, has_reqg, has_reqh
real, dimension(ims:ime, jms:jme), intent(out), optional :: &
rainncw2, rainnci2 ! liquid rain, ice, accumulation rates
real, optional, intent(in) :: dx,dy
real, intent(in):: dtp
integer, intent(in):: itimestep !, ccntype
- logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina
+ integer, intent(in), optional :: ntmul, ntcnt
+ logical, optional, intent(in) :: lastloop
+ logical, optional, intent(in) :: diagflag, f_cna, f_cn, f_cina, f_cnuf
+ logical, optional, intent(in) :: f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl
integer, optional, intent(in) :: ipelectmp, ke_diag
! CCPP error handling
@@ -2151,7 +2421,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
LOGICAL :: flag_qndrop ! wrf-chem
LOGICAL :: flag_qnifa , flag_qnwfa
+ logical :: flag_cnuf = .false.
+ logical :: flag_ccn = .false.
+ logical :: flag_qi = .true.
+ logical :: has_reqg_local = .false., has_reqh_local = .false.
logical :: flag
+ logical :: nwp_diagflag = .false.
real :: cinchange, t7max,testmax,wmax
! 20130903 acd_ck_washout start
@@ -2176,12 +2451,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d
real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten
real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra2d
+ real, dimension(its:ite, 1, kts:kte, 3) :: alpha2d
real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
real, dimension(its:ite, 1, na) :: xfall
+ real, dimension(its:ite, 1) :: hailmax1d,hailmaxk1
real, dimension(kts:kte, nproc) :: thproclocal
integer, parameter :: nor = 0, ng = 0
- integer :: nx,ny,nz
+ integer :: nx,ny,nz,ngs
integer ix,jy,kz,i,j,k,il,n
integer :: infdo
real :: ssival, ssifac, t8s, t9s, qvapor
@@ -2223,15 +2500,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
real :: fach(kts:kte)
logical, parameter :: debugdriver = .false.
-
-#ifdef MPI
-
-#if defined(MPI)
- integer, parameter :: ntot = 50
- double precision mpitotindp(ntot), mpitotoutdp(ntot)
- INTEGER :: mpi_error_code = 1
-#endif
-#endif
+
+ integer :: loopcnt, loopmax, outerloopcnt
+ logical :: lastlooptmp
! -------------------------------------------------------------------
@@ -2246,13 +2517,52 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
flag_qndrop = .false.
flag_qnifa = .false.
flag_qnwfa = .false.
+ flag_cnuf = .false.
+ flag_ccn = .false.
+ nwp_diagflag = .false.
IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn
+ IF ( present ( f_cnuf ) ) flag_cnuf = f_cnuf
+ IF ( present ( nwp_diagnostics ) ) nwp_diagflag = ( nwp_diagnostics > 0 )
+ IF ( present ( f_cn ) .and. present( cn ) ) THEN
+ flag_ccn = f_cn
+ ELSEIF ( present( cn ) ) THEN
+ flag_ccn = .true.
+ ENDIF
+
+ IF ( present( f_qi ) ) THEN
+ flag_qi = f_qi
+ ELSE
+ IF ( ffrzs < 1.0 ) THEN
+ flag_qi = .true.
+ ELSE
+ flag_qi = .false.
+ ENDIF
+ ENDIF
+ IF ( .not. flag_qi .and. ffrzs < 1.0 ) ffrzs = 1.0
+
+ IF ( PRESENT ( has_reqg ) ) has_reqg_local = has_reqg > 0
+ IF ( PRESENT ( has_reqh ) ) has_reqh_local = has_reqh > 0
- ! ---
+ loopmax = 1
+ outerloopcnt = 1
+ lastlooptmp = .true.
+ IF ( present( ntmul ) .and. present( ntcnt ) .and. present( lastloop ) ) THEN
+ loopmax = ntmul
+ outerloopcnt = ntcnt
+ lastlooptmp = lastloop
+ ENDIF
+
+
+ has_wetscav = .false.
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( PRESENT( wetscav_on ) ) THEN
+ has_wetscav = wetscav_on
+ ENDIF
+ ENDIF
IF ( present( f_cna ) ) THEN
f_cnatmp = f_cna
@@ -2303,8 +2613,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
nx = ite-its+1
ny = 1 ! set up as 2D slabs
nz = kte-kts+1
+ ngs = 64
- IF ( .not. present( cn ) ) THEN
+ IF ( .not. flag_ccn ) THEN
renucfrac = 1.0
ENDIF
@@ -2365,32 +2676,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ancuten(its:ite,1,kts:kte,:) = 0.0
thproclocal(:,:) = 0.0
+
DO jy = jts,jye
- xfall(:,:,:) = 0.0
-
! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn
IF ( present( pcc2 ) .and. makediag ) THEN
axtra2d(its:ite,1,kts:kte,:) = 0.0
ENDIF
+ IF ( nwp_diagflag ) THEN
+ alpha2d(its:ite,1,kts:kte,1) = alphar
+ alpha2d(its:ite,1,kts:kte,2) = alphah
+ alpha2d(its:ite,1,kts:kte,3) = alphahl
+ ENDIF
+
+
! copy from 3D array to 2D slab
DO kz = kts,kte
DO ix = its,ite
-
IF ( present( tt ) ) THEN
an(ix,1,kz,lt) = tt(ix,kz,jy)/pii(ix,kz,jy)
ELSE
an(ix,1,kz,lt) = th(ix,kz,jy)
ENDIF
-
-
an(ix,1,kz,lv) = qv(ix,kz,jy)
an(ix,1,kz,lc) = qc(ix,kz,jy)
an(ix,1,kz,lr) = qr(ix,kz,jy)
- IF ( present( qi ) ) THEN
+ IF ( flag_qi ) THEN
an(ix,1,kz,li) = qi(ix,kz,jy)
ELSE
an(ix,1,kz,li) = 0.0
@@ -2401,13 +2715,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lccn > 1 ) THEN
IF ( is_aerosol_aware .and. flag_qnwfa ) THEN
!
- ELSEIF ( present( cn ) ) THEN
+ ELSEIF ( flag_ccn ) THEN
IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
an(ix,1,kz,lccna) = cn(ix,kz,jy)
an(ix,1,kz,lccn) = qccn ! cn(ix,kz,jy)
ELSE
an(ix,1,kz,lccn) = cn(ix,kz,jy)
ENDIF
+ IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN ! UF ccn are extra regular ccn
+ an(ix,1,kz,lccn) = an(ix,1,kz,lccn) + cnuf(ix,kz,jy)
+ ENDIF
ELSE
IF ( lccna == 0 .and. ( .not. f_cnatmp ) ) THEN
an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy)
@@ -2418,6 +2735,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn == 0 ) THEN ! UF are UF
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ELSE ! UF were added to lccn
+ an(ix,1,kz,lccnuf) = 0.0
+ ENDIF
+ ENDIF
+
IF ( lccna > 1 ) THEN
IF ( present( cna ) .and. f_cnatmp ) THEN
an(ix,1,kz,lccna) = cna(ix,kz,jy)
@@ -2448,9 +2773,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lvh > 0 ) an(ix,1,kz,lvh) = vhw(ix,kz,jy)
IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl) = vhl(ix,kz,jy)
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) an(ix,1,kz,lzr) = zrw(ix,kz,jy)*zscale
+ IF ( lzh > 0 ) an(ix,1,kz,lzh) = zhw(ix,kz,jy)*zscale
+ IF ( lzhl > 0 ) an(ix,1,kz,lzhl) = zhl(ix,kz,jy)*zscale
+ ENDIF
+ ENDDO
+ ENDDO
+
+ DO kz = kts,kte
+ DO ix = its,ite
IF ( present( tt ) ) THEN
@@ -2458,6 +2793,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ELSE
t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
ENDIF
+ t00(ix,1,kz) = 380.0/p(ix,kz,jy)
+ t77(ix,1,kz) = pii(ix,kz,jy)
+ dbz2d(ix,1,kz) = 0.0
+ vzf2d(ix,1,kz) = 0.0
+ ENDDO
+ ENDDO
+
+ DO ix = its,ite
+ RAINNCV(ix,jy) = 0.0
+ IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = 0.0
+ IF ( present( HAILNCV ) ) HAILNCV(ix,jy) = 0.0
+ IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = 0.0
+ ENDDO
+
+ DO loopcnt = 1,loopmax
+
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
t1(ix,1,kz) = 0.0
t2(ix,1,kz) = 0.0
t3(ix,1,kz) = 0.0
@@ -2467,14 +2822,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
t7(ix,1,kz) = 0.0
t8(ix,1,kz) = 0.0
t9(ix,1,kz) = 0.0
- t00(ix,1,kz) = 380.0/p(ix,kz,jy)
- t77(ix,1,kz) = pii(ix,kz,jy)
- dbz2d(ix,1,kz) = 0.0
- vzf2d(ix,1,kz) = 0.0
- dn1(ix,1,kz) = dn(ix,kz,jy)
pn(ix,1,kz) = p(ix,kz,jy)
wn(ix,1,kz) = w(ix,kz,jy)
+! calculate dn1 in case we are substepping: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
! wmax = Max(wmax,wn(ix,1,kz))
dz2d(ix,1,kz) = dz(ix,kz,jy)
dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy)
@@ -2492,6 +2844,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
!
ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s ! qv/qvi
+
if ( ssival .gt. 1.0 ) then
!
IF ( icenucopt == 1 ) THEN
@@ -2544,19 +2897,20 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ELSEIF ( icenucopt == 4 ) THEN ! DeMott 2010
- IF ( t0(ix,jy,kz) < 268.16 .and. t0(ix,jy,kz) > 223.15 .and. ssival > 1.001 ) THEN !
+ IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN !
! a = 0.0000594, b = 3.33, c = 0.0264, d = 0.0033,
! nint = a*(-Tc)**b * naer**(c*(-Tc) + d)
! nint has units of per (standard) liter, so mult by 1.e3 and scale by dn/rho00
! naer needs units of cm**-3, so mult by 1.e-6
- ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*cin*dn(ix,jy,kz))**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
- dp1 = 1.e3*dn(ix,jy,kz)/rho00*0.0000594*(273.16 - t0(ix,jy,kz))**3.33 * (1.e-6*naer)**(0.0264*(273.16 - t0(ix,jy,kz)) + 0.0033)
- t7(ix,jy,kz) = Min(dp1, 1.0d30)
+ ! dp1 = 1.e3*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * (1.e-6*cin*dn(ix,1,kz))**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ tmp = 1.e-6*naer
+ dp1 = 1.e3*dn1(ix,1,kz)/rho00*0.0000594*(273.16 - t0(ix,1,kz))**3.33 * tmp**(0.0264*(273.16 - t0(ix,1,kz)) + 0.0033)
+ t7(ix,1,kz) = Min(dp1, 1.0d30)
ELSE
- t7(ix,jy,kz) = 0.0
+ ! t7(ix,1,kz) = 0.0
ENDIF
ENDIF ! icenucopt
@@ -2569,39 +2923,39 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO ! ix
ENDDO ! kz
- has_wetscav = .false.
- IF ( wrfchem_flag > 0 ) THEN
- IF ( PRESENT( wetscav_on ) ) THEN
- has_wetscav = wetscav_on
- IF ( has_wetscav ) THEN
- IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
- IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
- ENDIF
- ENDIF
- ENDIF
+ IF ( wrfchem_flag > 0 ) THEN
+ IF ( has_wetscav ) THEN
+ IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0
+ IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0
+ ENDIF
+ ENDIF
! transform from number mixing ratios to number conc.
+ IF ( loopcnt == 1 ) THEN
DO il = lnb,na
IF ( denscale(il) == 1 ) THEN
DO kz = kts,kte
DO ix = its,ite
- an(ix,1,kz,il) = an(ix,1,kz,il)*dn(ix,kz,jy)
+ an(ix,1,kz,il) = an(ix,1,kz,il)*dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
ENDDO ! il
+ ENDIF
+
! sedimentation
xfall(:,:,:) = 0.0
- IF ( .true. ) THEN
+
+! IF ( .true. ) THEN
! #ifndef CM1
! for real cases when hydrometeor mixing ratios have been initialized without concentrations
- IF ( itimestep == 1 .and. ipconc > 0 ) THEN
+ IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN
call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
ENDIF
! IF ( itimestep == 3 .and. ipconc > 0 ) THEN
@@ -2611,9 +2965,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( present(cu_used) .and. &
( present( qrcuten ) .or. present( qscuten ) .or. &
- present( qicuten ) .or. present( qccuten ) ) ) THEN
+ present( qicuten ) .or. present( qccuten ) ) ) THEN !{
- IF ( cu_used == 1 ) THEN
+ IF ( cu_used == 1 ) THEN !{
DO kz = kts,kte
DO ix = its,ite
@@ -2627,10 +2981,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)
+ DO kz = kts,kte
+ DO ix = its,ite
+
+
+ IF ( ipconc >= 6 ) THEN
+! IF ( lzr > 0 ) an(ix,1,kz,lzr) = an(ix,1,kz,lzr) + ancuten(ix,1,kz,lzr)
+ ENDIF
+
+ ENDDO
+ ENDDO
- ENDIF
+ ENDIF !}
- ENDIF
+ ENDIF !}
+
+
call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
@@ -2644,10 +3010,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
DO ix = its,ite
IF ( lhl > 1 ) THEN
- RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
+ RAINNCV(ix,jy) = RAINNCV(ix,jy) + &
+ dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
& xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) )
ELSE
- RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
+ RAINNCV(ix,jy) = RAINNCV(ix,jy) + &
+ dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
& xfall(ix,1,lh)*1000./xdn0(lr) )
ENDIF
IF ( present ( rainncw2 ) ) THEN ! rain only
@@ -2662,17 +3030,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& xfall(ix,1,lh)*1000./xdn0(lr) )
ENDIF
ENDIF
- IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
+ IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = SNOWNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
IF ( present( GRPLNCV ) ) THEN
IF ( lhl > 1 .and. .not. present( HAILNC) ) THEN ! if no separate hail accum, then add to graupel
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,lh) + xfall(ix,1,lhl)) *1000./xdn0(lr)
ELSE
- GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
+ GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
ENDIF
ENDIF
- RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy)
+ IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy)
- IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
+ IF ( present (SNOWNC) .and. present (SNOWNCV) .and. loopcnt == loopmax ) THEN
+ SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
+ ENDIF
IF ( lhl > 1 ) THEN
!#ifdef CM1
! IF ( .true. ) THEN
@@ -2680,13 +3050,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( present( HAILNC ) ) THEN
!#endif
HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
- HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy)
+ IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy)
! ELSEIF ( present( GRPLNCV ) ) THEN ! if no separate hail accum, then add to graupel
! GRPLNCV(ix,jy) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr)
ENDIF
ENDIF
- IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
- IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN
+ IF ( present( GRPLNCV ) .and. loopcnt == loopmax ) THEN
+ GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy)
+ ENDIF
+ IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) .and. loopcnt == loopmax ) THEN
IF ( present( HAILNC ) ) THEN
SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
ELSE
@@ -2695,7 +3067,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDDO
- ENDIF ! .false.
+! ENDIF ! .false.
IF ( isedonly /= 1 ) THEN
! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics
@@ -2717,15 +3089,22 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,dbz2d,tke2d, &
- & thproclocal,nproc,dx1,dy1, &
+ & thproclocal,nproc,dx1,dy1,ngs, &
& timevtcalc,axtra2d, makediag &
- & ,has_wetscav, rainprod2d, evapprod2d &
+ & ,has_wetscav, rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec2,its,ids,ide,jds,jde &
& )
+! recalculate dn1 after temperature changes: rho = con_eps*prsl/(con_rd*tgrs*(qv_mp+con_eps))
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF ! isedonly /= 1
@@ -2737,29 +3116,38 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
& ,dz2d &
& ,t0,t9 &
& ,an,dn1,t77 &
- & ,pn,wn &
+ & ,pn,wn &
+ & ,ngs &
& ,axtra2d, makediag &
& ,ssat,t00,t77,flag_qndrop)
+! recalculate dn1 after temperature changes
+ DO kz = kts,kte
+ DO ix = its,ite
+ dn1(ix,1,kz) = rdorv*pn(ix,1,kz)/(rd*t0(ix,1,kz)*(an(ix,1,kz,lv) + rdorv))
+ ENDDO
+ ENDDO
+
ENDIF
+
+ ENDDO ! loopcnt=1,loopmax
IF ( present( pcc2 ) .and. makediag ) THEN
DO kz = kts,kte
DO ix = its,ite
! example of using the 'axtra2d' array to get rates out of the microphysics routine for output.
! Search for 'axtra' to find example code below
! pcc2(ix,kz,jy) = axtra2d(ix,1,kz,1)
-
ENDDO
ENDDO
ENDIF
! compute diagnostic S-band reflectivity if needed
- IF ( present( dbz ) .and. makediag ) THEN
+ IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN
! calc dbz
IF ( .true. ) THEN
@@ -2797,7 +3185,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F
IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. &
- present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN
+ present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) .and. &
+ lastlooptmp) THEN
IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN
DO kz = kts,kte
DO ix = its,ite
@@ -2815,16 +3204,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
call calc_eff_radius &
& (nx,ny,nz,na,jy &
& ,nor,nor &
- & ,t1=t1,t2=t2,t3=t3,t4=t4 &
+ & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,f_t5=has_reqg_local, f_t6=has_reqh_local &
& ,an=an,dn=dn1 )
DO kz = kts,kte
DO ix = its,ite
re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6))
- re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 200.E-6))
+ re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6))
re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6))
! check for case where snow needs to be treated as cloud ice (for rrtmg radiation)
- IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 200.E-6))
+ IF ( .not. present(qi) ) re_ice(ix,kz,jy) = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6))
ENDDO
ENDDO
@@ -2837,19 +3226,53 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDIF
ENDIF
+
+ IF ( present(has_reqg) .and. present( re_graup ) ) THEN
+ IF ( has_reqg /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_graup(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 10.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF ( present(has_reqh) .and. present( re_hail ) ) THEN
+ IF ( has_reqh /= 0 ) THEN
+ DO kz = kts,kte
+ DO ix = its,ite
+ re_hail(ix,kz,jy) = MAX(50.E-6, MIN(t5(ix,1,kz), 40.E-3))
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
ENDIF
ENDIF
+ IF ( present( hail_maxk1 ) .and. present( hail_max2d ) .and. nwp_diagflag ) THEN
+ DO ix = its,ite
+ hailmax1d(ix,1) = hail_max2d(ix,jy)
+ hailmaxk1(ix,1) = hail_maxk1(ix,jy)
+ ENDDO
+
+ call hailmaxd(dtp,nx,ny,nz,an,na,nor,nor,alpha2d,dn1, &
+ hailmax1d,hailmaxk1,1 )
+ DO ix = its,ite
+ hail_max2d(ix,jy) = hailmax1d(ix,1)
+ hail_maxk1(ix,jy) = hailmaxk1(ix,1)
+ ENDDO
+! ENDIF
+ ENDIF
! transform concentrations back to mixing ratios
DO il = lnb,na
IF ( denscale(il) == 1 ) THEN
DO kz = kts,kte
DO ix = its,ite
- an(ix,1,kz,il) = an(ix,1,kz,il)/dn(ix,kz,jy)
+ an(ix,1,kz,il) = an(ix,1,kz,il)/dn1(ix,1,kz) ! dn(ix,kz,jy)
ENDDO
ENDDO
ENDIF
@@ -2870,14 +3293,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
qv(ix,kz,jy) = an(ix,1,kz,lv)
qc(ix,kz,jy) = an(ix,1,kz,lc)
qr(ix,kz,jy) = an(ix,1,kz,lr)
- IF ( present(qi) ) qi(ix,kz,jy) = an(ix,1,kz,li)
+ IF ( flag_qi ) qi(ix,kz,jy) = an(ix,1,kz,li)
qs(ix,kz,jy) = an(ix,1,kz,ls)
qh(ix,kz,jy) = an(ix,1,kz,lh)
IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl)
IF ( lccn > 1 .and. is_aerosol_aware .and. flag_qnwfa ) THEN
! not used here
- ELSEIF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN
+ ELSEIF ( flag_ccn .and. lccn > 1 .and. .not. flag_qndrop) THEN
IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN
cn(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) )
ELSE
@@ -2896,6 +3319,21 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDIF
ENDIF
+ IF ( lccnuf > 0 .and. flag_cnuf ) THEN
+ IF ( i_uf_or_ccn > 0 ) THEN ! UF are ccn and lccnuf is zero, so put cnuf into lccnuf to do decay
+ an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) )
+ ENDIF
+ IF ( decayufccn ) THEN
+ IF ( an(ix,1,kz,lccnuf) > ufbackground ) THEN
+ an(ix,1,kz,lccnuf) = an(ix,1,kz,lccnuf) - (an(ix,1,kz,lccnuf) - &
+ ufbackground)*(1.0 - exp(-dtp/ufccntimeconst))
+ ENDIF
+ ENDIF
+ cnuf(ix,kz,jy) = an(ix,1,kz,lccnuf)
+ ENDIF
+
+
+
IF ( ipconc >= 5 ) THEN
ccw(ix,kz,jy) = an(ix,1,kz,lnc)
@@ -2906,6 +3344,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
ENDIF
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 0 ) zrw(ix,kz,jy) = an(ix,1,kz,lzr) *zscaleinv
+ IF ( lzh > 0 ) zhw(ix,kz,jy) = an(ix,1,kz,lzh) *zscaleinv
+ IF ( lzhl > 0 ) zhl(ix,kz,jy) = an(ix,1,kz,lzhl)*zscaleinv
+ ENDIF
@@ -2914,6 +3357,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
#if ( WRF_CHEM == 1 )
IF ( has_wetscav ) THEN
+ IF ( loopmax > 1 ) THEN
+ ! wrferror not supported
+ ENDIF
IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz)
IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz)
ENDIF
@@ -2921,8 +3367,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
ENDDO
ENDDO
-
+
+
ENDDO ! jy
+
+
@@ -3217,7 +3666,7 @@ END FUNCTION GAML02
! **********************************************************
!>\ingroup mod_nsslmp
!! Function calculates fraction of drops larger than 300 microns ( imurain == 3 )
- real FUNCTION GAML02d300(x)
+ real FUNCTION GAML02d300(x)
implicit none
integer ig, i, ii, n, np
real x
@@ -3558,11 +4007,245 @@ Function delabk(ba,bb,nua,nub,mua,mub,k)
RETURN
END Function delabk
-
+
+
+! #######################################################################
+! HAILMAXD - calculated maximum expected hail size
+! #######################################################################
!>\ingroup mod_nsslmp
-!! Sedimentation driver subroutine. Calls fallout column by column
- subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
+!! Hail max size subroutine.
+ subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, &
+ & hailmax1d,hailmaxk1,jslab )
+!
+! Calculate maximum hail size from the tail of of the distribution. The value
+! of thresh_conc sets the minimum concentration in the integral over (Dmax, Inf).
+! This uses the lookup tables for incomplete gamma functions and simply search for
+! the expected value (and linearly interpolate) on D.
+!
+! Written by ERM 7/2023
+!
+!
+!
+ implicit none
+
+ integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
+ integer id ! =1 use density, =0 no density
+! integer :: its,ite ! x-range to calculate
+
+ integer ng1
+ parameter(ng1 = 1)
+
+ real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
+ real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+
+! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
+ real dtp
+ real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) ! array for PSD shape parameters
+ real :: hailmax1d(nx,ny),hailmaxk1(nx,ny)
+ integer infdo
+ integer jslab ! which line of xfall to use
+
+ integer ix,jy,kz,ndfall,n,k,il,in
+ double precision :: tmp, ratio, del, g1palp
+ real, parameter :: dz = 200.
+
+ real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+
+ real :: rhovtzx(nz,nx)
+
+ real :: alp, diam, diam1, hwdn
+
+! real, parameter :: cmin = 0.001 ! threshold number per m^3 for maximum diamter (threshold from diag_nwp)
+ DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 ! number conc. of graupel/hail per cubic meter
+ real :: cwchtmp,cwchltmp, maxdia
+
+!-----------------------------------------------------------------------------
+
+ integer :: ixb, jyb, kzb
+ integer :: ixe, jye, kze
+ integer :: plo, phi
+ integer :: ialp, i, j
+
+ logical :: debug_mpi = .TRUE.
+
+! ###################################################################
+
+
+ IF ( lh > 1 ) THEN
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+ ENDIF
+ IF ( lhl > 1 ) THEN
+ cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
+ ENDIF
+
+
+ kzb = 1
+ kze = nz
+
+ ixb = 1 ! aliased its
+ ixe = nx ! aliased ite
+
+
+ jy = jslab
+ jgs = jy
+
+
+! hailmax1d(:,jy) = 0.0
+! hailmaxk1(:,jy) = 0.0
+
+ if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
+
+
+! first graupel, even if hail is also predicted, since graupel can sometime be large on its own
+ IF ( lh > 1 .and. lnh > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lh) .gt. qxmin(lh) .and. an(ix,jy,kz,lnh) .gt. thresh_conc ) THEN
+ IF ( lvh .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
+ ELSE
+ hwdn = rho_qh
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,2)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzh > 1 ) THEN ! 3moment
+ cwchtmp = ((3. + alpha2d(ix,1,kz,2))*(2. + alpha2d(ix,1,kz,2))*(1.0 + alpha2d(ix,1,kz,2)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchtmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh)
+ alp = alpha2d(ix,1,kz,2)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lh) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF ! lh
+
+! And diam for hail if present
+ IF ( lhl > 1 .and. lnhl > 1 ) THEN
+ DO kz = kzb,kze
+ DO ix = ixb,ixe
+ IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. an(ix,jy,kz,lnhl) .gt. thresh_conc ) THEN
+ IF ( lvhl .gt. 1 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = rho_qhl
+ ENDIF
+
+ tmp = 1. + alpha2d(ix,1,kz,3)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl))
+ diam = (6.0*tmp/pi)**(1./3.)
+ IF ( lzhl > 1 ) THEN ! 3moment
+ cwchltmp = ((3. + alpha2d(ix,1,kz,3))*(2. + alpha2d(ix,1,kz,3))*(1.0 + alpha2d(ix,1,kz,3)))**(-1./3.)
+ ENDIF
+ diam1 = diam*cwchltmp ! characteristic diameter, i.e., 1/lambda
+ ! want cxd1 = thresh_conc
+ ! tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ ! cxd1 = cx(mgs,lh)*(tmp)/g1palp
+ ! tmp = thresh_conc*g1palp/cx
+ !
+ tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl)
+ alp = alpha2d(ix,1,kz,3)
+ ! gamxinflu(i,j,luindex,ilh)
+ j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv)
+ ratio = 0.0
+ maxdia = 0.0
+ ! eventually could replace with bisection search, but final value of i is usually small
+ ! compared to nqiacrratio
+ DO i = 0,nqiacrratio-1
+ IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN
+ ! interpolate here for FWIW
+ ratio = i*dqiacrratio
+ del = tmp - gamxinflu(i,j,1,1)
+ ratio = (float(i) + del/(gamxinflu(i+1,j,1,1) - gamxinflu(i,j,1,1)))*dqiacrratio
+ exit
+ ENDIF
+ ENDDO
+
+ IF ( ratio > 0.0 ) THEN
+ maxdia = ratio*diam1 ! units of m
+ ENDIF
+
+ IF ( kz == kzb ) THEN
+ hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) )
+! IF ( maxdia > 0.1 ) THEN
+! IF ( an(ix,jy,kz,lhl) > 1.e-4 ) THEN
+! write(0,*) 'maxdia,tmp,alp,ratio,diam,diam1= ',maxdia,tmp,alp,ratio,diam*100.,diam1*100.
+! write(0,*) 'hwdn, cxhl, qx, g1palp = ',hwdn, an(ix,jy,kz,lnhl), an(ix,jy,kz,lhl), g1palp
+! write(0,*) 'j,gamxinflu(0,2,4) = ',j,gamxinflu(0,j,1,1),gamxinflu(2,j,1,1), &
+! gamxinflu(4,j,1,1)
+! ENDIF
+ ENDIF
+
+ hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) )
+
+ !
+
+ ENDIF
+
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+
+ END SUBROUTINE HAILMAXD
+! #######################################################################
+! #######################################################################
+!>\ingroup mod_nsslmp
+!! Sedimentation driver subroutine. Calls fallout column by column
+ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
& t0,t7,infdo,jslab,its,jts, &
& timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing
!
@@ -3591,7 +4274,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! real gz(-nor+ng1:nz+nor),z1d(-nor+ng1:nz+nor,4)
real dtp
real xfall(nx,ny,na) ! array for stuff landing on the ground
- real xfall0(nx,ny) ! dummy array
+! real xfall0(nx,ny) ! dummy array
integer infdo
integer jslab ! which line of xfall to use
@@ -3599,47 +4282,81 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
real tmp, vtmax, dtptmp, dtfrac
real, parameter :: dz = 200.
- real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
- real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
- real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
- real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
- real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+! real :: xvt(nz+1,nx,3,lc:lhab) ! (nx,nz,2,lc:lhab) ! 1=mass-weighted, 2=number-weighted
+! real :: tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
+! real :: tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
+! real :: z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab)
+! real :: db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
- real :: rhovtzx(nz,nx)
+! real :: rhovtzx(nz,nx)
+
+ real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) ! db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1)
+ real, allocatable :: rhovtzx(:,:)
+ real, allocatable :: xfall0(:,:), xvt(:,:,:,:),tmpn(:,:,:),tmpn2(:,:,:),z(:,:,:)
double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
double precision :: dt1,dt2,dt3,dt4
- integer,parameter :: ngs = 128
+ integer :: ngs ! = 512
integer :: ngscnt,mgs,ipconc0
- real :: qx(ngs,lv:lhab)
- real :: qxw(ngs,ls:lhab)
- real :: cx(ngs,lc:lhab)
- real :: xv(ngs,lc:lhab)
- real :: vtxbar(ngs,lc:lhab,3)
- real :: xmas(ngs,lc:lhab)
- real :: xdn(ngs,lc:lhab)
- real :: xdia(ngs,lc:lhab,3)
- real :: vx(ngs,li:lhab)
- real :: alpha(ngs,lc:lhab)
- real :: zx(ngs,lr:lhab)
- logical :: hasmass(nx,lc+1:lhab)
-
- integer igs(ngs),kgs(ngs)
-
- real rho0(ngs),temcg(ngs)
-
- real temg(ngs)
-
- real rhovt(ngs)
-
- real cwnc(ngs),cinc(ngs)
- real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
-
- real cimasn,cimasx,cnina(ngs),cimas(ngs)
-
- real cnostmp(ngs)
+! real :: qx(ngs,lv:lhab)
+! real :: qxw(ngs,ls:lhab)
+! real :: cx(ngs,lc:lhab)
+! real :: xv(ngs,lc:lhab)
+! real :: vtxbar(ngs,lc:lhab,3)
+! real :: xmas(ngs,lc:lhab)
+! real :: xdn(ngs,lc:lhab)
+! real :: xdia(ngs,lc:lhab,3)
+! real :: vx(ngs,li:lhab)
+! real :: alpha(ngs,lc:lhab)
+! real :: zx(ngs,lr:lhab)
+! logical :: hasmass(nx,lc+1:lhab)
+!
+! integer igs(ngs),kgs(ngs)
+!
+! real rho0(ngs),temcg(ngs)
+!
+! real temg(ngs)
+!
+! real rhovt(ngs)
+!
+! real cwnc(ngs),cinc(ngs)
+! real fadvisc(ngs),cwdia(ngs),cipmas(ngs)
+!
+! real cimasn,cimasx,cnina(ngs),cimas(ngs)
+!
+! real cnostmp(ngs)
+
+ real, allocatable :: qx(:,:)
+ real, allocatable :: qxw(:,:)
+ real, allocatable :: cx(:,:)
+ real, allocatable :: xv(:,:)
+ real, allocatable :: vtxbar(:,:,:)
+ real, allocatable :: xmas(:,:)
+ real, allocatable :: xdn(:,:)
+ real, allocatable :: xdia(:,:,:)
+ real, allocatable :: vx(:,:)
+ real, allocatable :: alpha(:,:)
+ real, allocatable :: zx(:,:)
+ logical, allocatable :: hasmass(:,:)
+
+ integer, allocatable :: igs(:),kgs(:)
+
+ real, allocatable :: rho0(:),temcg(:)
+
+ real, allocatable :: temg(:)
+
+ real, allocatable :: rhovt(:)
+
+ real, allocatable :: cwnc(:),cinc(:)
+ real, allocatable :: fadvisc(:),cwdia(:),cipmas(:)
+
+ real, allocatable :: cnina(:),cimas(:)
+
+ real, allocatable :: cnostmp(:)
+
+ real :: cimasn,cimasx
!-----------------------------------------------------------------------------
@@ -3653,7 +4370,30 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ###################################################################
-
+ allocate( db1(nx,nz+1),dtz1(nz+1,nx,0:1),dz2dinv(nz+1,nx),db1inv(nx,nz+1),rhovtzx(nz,nx) )
+ allocate( xfall0(nx,ny), xvt(nz+1,nx,3,lc:lhab), tmpn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) )
+ allocate( tmpn2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz), z(-nor+ng1:nx+nor,-norz+ng1:nz+norz,lr:lhab))
+
+ ngs = nz+3
+
+ allocate( qx(ngs,lv:lhab), &
+ qxw(ngs,ls:lhab), &
+ cx(ngs,lc:lhab), &
+ xv(ngs,lc:lhab), &
+ vtxbar(ngs,lc:lhab,3), &
+ xmas(ngs,lc:lhab), &
+ xdn(ngs,lc:lhab), &
+ xdia(ngs,lc:lhab,3), &
+ vx(ngs,li:lhab), &
+ alpha(ngs,lc:lhab), &
+ zx(ngs,lr:lhab), &
+ hasmass(nx,lc+1:lhab), &
+ igs(ngs),kgs(ngs), &
+ rho0(ngs),temcg(ngs),temg(ngs), rhovt(ngs), &
+ cwnc(ngs),cinc(ngs), &
+ fadvisc(ngs),cwdia(ngs),cipmas(ngs), &
+ cnina(ngs),cimas(ngs), &
+ cnostmp(ngs) )
kzb = 1
kze = nz
@@ -3825,7 +4565,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN
- IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN
+ IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. &
+ (il .ge. lh .and. lz(il) .lt. 1 ) .or. (il == ls .and. isfall == infall ) ) THEN
call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, &
& z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il), lvol(il), xdn0(il), ix )
ENDIF
@@ -3850,6 +4591,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
ENDIF
+! reflectivity
+
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lz(il) .gt. 1 ) THEN
+ call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
+ & an,db1,lz(il),0,xfall,dtz1,ix)
+ ENDIF
+ ENDIF
if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'
@@ -3863,9 +4612,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! to put a lower bound on number conc.
!
- IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( il .eq. lh .or. il .eq. lhl .or. &
+ IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il == ls .and. isfall .eq. infall ) &
+ & .or. il .eq. lh .or. il .eq. lhl .or. il == lf .or. &
& ( il .eq. lr .and. irfall .eq. infall) ) ) THEN
+ ! set up for method I+II
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn2(ix,jy,kz) = z(ix,kz,il)
@@ -3878,7 +4629,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO
ELSE
-
+ ! set up for method II only
DO kz = kzb,kze
! DO ix = ixb,ixe
tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il))
@@ -3907,7 +4658,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
xfall0(:,jgs) = 0.0
IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. &
- & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) ) ) THEN
+ & ( il .ge. lh .or. (il .eq. lr .and. irfall .eq. infall) &
+ .or. (il .eq. ls .and. isfall .eq. infall) ) ) THEN
call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,3,il), &
& tmpn2,db1,1,0,xfall0,dtz1,ix)
call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), &
@@ -3918,12 +4670,12 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDIF
IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. ( (il .eq. lr .and. irfall .eq. infall) &
- & .or. il .ge. lh ) ) THEN
+ & .or. il .ge. lh .or. (il == ls .and. isfall .eq. infall ) ) ) THEN
! "Method I" - dbz correction
call calcnfromz1d(nx,ny,nz,nor,na,an,tmpn2,ixe,kze, &
& z,db1,jgs,ipconc, dnu(il), il, ln(il), qxmin(il), xvmn(il), xvmx(il),tmpn, &
- & lvol(il), rho_qh, infall, ix)
+ & lvol(il), xdn0(il), infall, ix)
ELSEIF ( infall .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN
@@ -3934,7 +4686,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
! ENDDO
ENDDO
- ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) ) THEN
+ ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN
! "Method II" M-wgt N-fallout correction
DO kz = kzb,kze
@@ -3961,8 +4713,29 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
ENDDO ! ix
+ deallocate( db1,dtz1,dz2dinv,db1inv,rhovtzx )
+ deallocate( xfall0, xvt, tmpn )
+ deallocate( tmpn2, z)
+
+ deallocate( qx, &
+ qxw, &
+ cx, &
+ xv, &
+ vtxbar, &
+ xmas, &
+ xdn, &
+ xdia, &
+ vx, &
+ alpha, &
+ zx, &
+ hasmass, &
+ igs,kgs, &
+ rho0,temcg,temg, rhovt, &
+ cwnc,cinc, &
+ fadvisc,cwdia,cipmas, &
+ cnina,cimas, &
+ cnostmp )
-
RETURN
END SUBROUTINE SEDIMENT1D
@@ -4120,13 +4893,14 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
integer ix,jy,kz
- real vr,qr,nrx,rd,xv,g1,zx,chw,xdn
+ real vr,qr,nrx,rd,xv,g1,zx,chw,xdn,ynu
jy = jgs
ix = ixcol
- IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) ) THEN
+ IF ( l .eq. lh .or. l .eq. lhl .or. ( l .eq. lr .and. imurain == 1 ) &
+ .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN
DO kz = 1,kze
@@ -4176,16 +4950,19 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, &
ENDDO
- ELSEIF ( l .eq. lr .and. imurain == 3) THEN
+ ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN
- xdn = 1000.
+ xdn = rho_qx ! 1000.
+ IF ( l == ls ) ynu = snu
+ IF ( l == lr ) ynu = rnu
DO kz = 1,kze
+
IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN
vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln))
-! z(ix,kz,l) = 3.6e18*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
- z(ix,kz,l) = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0)
+! z(ix,kz,l) = 3.6e18*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
+ z(ix,kz,l) = 3.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0)
! qr = a(ix,jy,kz,lr)
! nrx = a(ix,jy,kz,lnr)
@@ -4598,6 +5375,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lr) > qxmin_init(lr) .and. an(ix,jy,kz,lzr) < zxmin .and. &
+ an(ix,jy,kz,lnr) > cxmin ) THEN
+ q = an(ix,jy,kz,lr)
+ nrx = an(ix,jy,kz,lnr)
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
+
! snow
IF ( lns > 1 ) THEN
IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN
@@ -4660,6 +5446,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+ IF ( lzh > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lh) > qxmin_init(lh) .and. an(ix,jy,kz,lzh) < zxmin .and. &
+ an(ix,jy,kz,lnh) > cxmin ) THEN
+ q = an(ix,jy,kz,lh)
+ nrx = an(ix,jy,kz,lnh)
+ an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
+
! hail
IF ( lnhl > 1 .and. lhl > 1 ) THEN
@@ -4680,7 +5475,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
-
ELSEIF ( an(ix,jy,kz,lhl) <= qxmin(lhl) .or. &
( an(ix,jy,kz,lnhl) <= cxmin .and. an(ix,jy,kz,lhl) <= qxmin_init(lhl)) ) THEN
@@ -4689,6 +5483,15 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, &
ENDIF
ENDIF
+
+ IF ( lzhl > 1 ) THEN ! set reflectivity moment
+ IF ( an(ix,jy,kz,lhl) > qxmin_init(lhl) .and. an(ix,jy,kz,lzhl) < zxmin .and. &
+ an(ix,jy,kz,lnhl) > cxmin ) THEN
+ q = an(ix,jy,kz,lhl)
+ nrx = an(ix,jy,kz,lnhl)
+ an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+ ENDIF
+ ENDIF
! ENDIF
@@ -4859,6 +5662,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
ENDIF
+ IF ( lzr > 1 ) THEN ! set reflectivity moment
+ an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ! *dninv
+ ENDIF
ENDIF
ENDIF
@@ -4909,6 +5715,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzh > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzh) = 36.*g1h*dn(ix,kz)**2*q**2/(pi**2*xdnh**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
!
@@ -4932,6 +5741,9 @@ subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
!
! an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
!
+! IF ( lzhl > 1 ) THEN ! set reflectivity moment
+! an(ix,jy,kz,lzhl) = 36.*g1hl*dn(ix,kz)**2*q**2/(pi**2*xdnhl**2*nrx) ! *dninv
+! ENDIF
! ENDIF
! ENDIF
@@ -4950,7 +5762,7 @@ END subroutine calcnfromcuten
SUBROUTINE calc_eff_radius &
& (nx,ny,nz,na,jyslab &
& ,nor,norz &
- & ,t1,t2,t3,t4 &
+ & ,t1,t2,t3,t4,t5,t6, f_t5,f_t6 &
& ,qcw,qci,qsw,qrw &
& ,ccw,cci,csw,crw &
& ,an,dn )
@@ -4972,6 +5784,9 @@ SUBROUTINE calc_eff_radius &
real,optional :: t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
real,optional :: t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ real,optional :: t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+ logical, optional :: f_t5, f_t6 ! flags to fill t5/t6 for graupel/hail
real, optional :: an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)
real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
@@ -6490,6 +7305,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
aax = axx(mgs,lhl)
bbx = bxx(mgs,lhl)
+ ELSEIF ( icdxhl <= 0 ) THEN !
+ aax = ax(lhl)
+ bbx = bx(lhl)
ENDIF
ENDIF ! }
@@ -6798,7 +7616,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
real vtmax
real xvbarmax
-
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+
integer l1, l2
double precision :: dpt1, dpt2
@@ -7074,68 +7896,549 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
ELSEIF ( imurain == 3 ) THEN
alpha(:,lr) = xnu(lr)
ENDIF
-
-
-
+ IF ( ipconc == 5 .and. imydiagalpha > 0 ) THEN
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+ alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
!
-! Set density
-!
- if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
+! Set 6th moments
!
+ IF ( ipconc .ge. 6 .or. lzr > 1) THEN
- call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
- & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
- & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
- & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
- & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
-! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
+ zx(:,:) = 0.0
+
+! DO il = lr,lhab
+ DO il = l1,l2
+
+ IF ( lz(il) .ge. 1 ) THEN
+
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0)
+ ENDDO
+
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
-!
-! put fall speeds into the x-z arrays
-!
- DO il = l1,l2
- do mgs = 1,ngscnt
- vtmax = 150.0
+! Find shape parameter rain
-
- IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. &
- & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
-
-
-
- vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
- vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
+
+ IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+! IF ( .false. .and. zx(mgs,lr) <= zxmin ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+! ELSEIF ( zx(mgs,lr) <= 0.0 .and. cx(mgs,lr) > 0.0 .and. qx(mgs,il) .gt. qxmin(il)) THEN
+! write(91,*) 'ZF: overdepletion of Zr: z,c,q = ',zx(mgs,il),cx(mgs,il),qx(mgs,il)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
- ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
-
- IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
- & vtxbar(mgs,il,3) .gt. vtmax ) THEN
-
- vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) )
- vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) )
- vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) )
-
-! call commasmpi_abort()
- ENDIF
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! tmp = cx(mgs,lr)
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+!! zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(1000.))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+!! an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+! ENDIF
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+
+! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+! vr = xv(mgs,lr)
+
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! write(91,*) 'alpha = ',alpha(mgs,il)
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*Max(1.0e-9,cx(mgs,lr)))
+ vr = xv(mgs,lr)
+! z = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+! IF ( 100.*Abs(alp - alpha(mgs,lr))/Abs(alpha(mgs,lr)) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(mgs,lr),qr*1000,z*1.e18,vr,nrx
+
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
- xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
- xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
- IF ( infdo .ge. 2 ) THEN
- xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
- ELSE
- xvt(kgs(mgs),igs(mgs),3,il) = 0.0
- ENDIF
+
+ ENDIF
+ ENDIF
-! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+! IF ( alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ zx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ENDIF
+
+ ENDDO
+ ENDIF ! }
+
+
+ IF ( ipconc .ge. 6 ) THEN
+
+! Find shape parameters for graupel,hail
+
+ DO il = lr,lhab
+
+ IF ( lz(il) .gt. 1 .and. (ildo == 0 .or. ildo == il ) .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'cx=0; qx,zx = ',1000.*qx(mgs,il),1.e18*zx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+! tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+! IF ( tmp < cx(mgs,il) ) THEN ! breakup
+! g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+! zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+! an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+!
+! ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+! write(91,*) 'ziegfall: something screwy with moments: il = ',il
+! write(91,*) 'q,n,z = ', 1.e3*qx(mgs,il),cx(mgs,il),zx(mgs,il)
+! write(91,*) 'alpha = ',alpha(mgs,il)
+
+ IF ( qx(mgs,il) < 1.e-8 ) THEN
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ ELSE
+! write(0,*) 'alpha = ',alpha(mgs,il)
+ ! set values according to dBZ of -10
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) .and. cx(mgs,il) .gt. cxmin ) THEN
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rd = z*(pi/6.*1000.)**2*chw/(0.224*(dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((dn(igs(mgs),jy,kgs(mgs))*qr)**2)
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+
+ IF ( imaxdiaopt == 1 ) THEN
+ xvbarmax = xvmx(il)
+ ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
+ xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
+ xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ENDIF
+
+ IF ( xv(mgs,il) .gt. xvbarmax ) THEN
+ tmp = cx(mgs,il)
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rd = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) ) THEN
+
+!! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*( 0.224*qr)*qr/chw
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ELSE
+ ENDIF
+ ENDIF
+ ENDDO ! mgs
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+! CALL cld_cpu('Z-MOMENT-ZFAll')
+
+ ENDIF
+
+ IF ( lzhl > 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ ENDIF
+ ENDIF
+
+
+
+!
+! Set density
+!
+ if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz'
+!
+
+ call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
+ & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, &
+ & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
+ & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, &
+ & itype1,itype2,temcg,infdo,alpha,ildo,axx,bxx)
+! & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl)
+
+
+
+!
+! put fall speeds into the x-z arrays
+!
+ DO il = l1,l2
+ do mgs = 1,ngscnt
+
+ vtmax = 150.0
+
+
+ IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. &
+ & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN
+
+
+! IF ( qx(mgs,il) > 1.e-4 .and. &
+! & .not. ( il == lr .and. 1.e3*xdia(mgs,il,3) > 5.0 ) ) THEN
+! write(0,*) 'infdo,mgs = ',infdo,lzr,mgs
+! write(0,*) 'Moment problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg .or. il == lr ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+
+ vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) )
+ vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) )
+
+ ENDIF
+
+
+ IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. &
+ & vtxbar(mgs,il,3) .gt. vtmax ) THEN
+
+! IF ( ndebugzf >= 0 .and. 1.e3*qx(mgs,il) > 0.1 ) THEN
+! write(0,*) 'infdo = ',infdo
+! write(0,*) 'Problem with vtxbar for il at i,j,k = ',il,igs(mgs),jy,kgs(mgs)
+! write(0,*) 'nx,ny,nz,ng = ',nx,ny,nz,nor
+! write(0,*) 'cwmasn,cwmasx = ',cwmasn,cwmasx
+! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,il,1),vtxbar(mgs,il,2),vtxbar(mgs,il,3)
+! write(0,*) 'q,n,d = ', 1.e3*qx(mgs,il),cx(mgs,il),1.e3*xdia(mgs,il,3)
+! IF ( il .ge. lr .and. lz(il) > 1 ) write(0,*) 'z = ', zx(mgs,il)
+! IF ( il .ge. lg ) THEN
+! write(0,*) 'alpha = ',alpha(mgs,il)
+! ENDIF
+! ENDIF
+ vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) )
+ vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) )
+ vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) )
+
+! call commasmpi_abort()
+ ENDIF
+
+
+ xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1)
+ xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2)
+ IF ( infdo .ge. 2 ) THEN
+ xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3)
+ ELSE
+ xvt(kgs(mgs),igs(mgs),3,il) = 0.0
+ ENDIF
+
+! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il)
enddo
ENDDO
@@ -7630,6 +8933,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( ipconc .le. 2 ) THEN
gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25)
dtmp(ix,kz) = zrc*gtmp(ix,kz)**7
+ ELSEIF ( lzr .gt. 1 ) THEN
+ dtmp(ix,kz) = 1e18*an(ix,jy,kz,lzr)
ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN
IF ( imurain == 3 ) THEN
vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
@@ -7822,7 +9127,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size
! p = 0.106214 for m = p v^(2/3)
- dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
+ dnsnow = 0.0346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
IF ( .true. .or. dnsnow < 900. ) THEN
gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + &
& (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ &
@@ -7898,6 +9203,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzh > 1 ) THEN
+ IF ( an(ix,jy,kz,lzh) > 0.0 .and. an(ix,jy,kz,lh) > qhmin .and. &
+ an(ix,jy,kz,lnh) >= cxmin ) ltest = .true.
+ ENDIF
IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .ge. cxmin )) THEN
@@ -7943,6 +9252,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzh .gt. 1 ) THEN
+ x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) ! weighted average of dielectric const
+ dtmph = 1.e18*x*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmph
ELSE
g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw
@@ -8015,6 +9327,10 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
IF ( ipconc .ge. 5 ) THEN
ltest = .false.
+ IF ( lzhl > 1 ) THEN
+ IF ( an(ix,jy,kz,lzhl) > 0.0 .and. an(ix,jy,kz,lhl) > qhlmin .and. &
+ an(ix,jy,kz,lnhl) > 0.0 ) ltest = .true.
+ ENDIF
IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{
chl = an(ix,jy,kz,lnhl)
@@ -8038,6 +9354,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
ENDIF
IF ( lzhl .gt. 1 ) THEN !{
+ x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) ! weighted average of dielectric const
+ dtmphl = 1.e18*x*an(ix,jy,kz,lzhl)*(hldn/rwdn)**2
+ dtmp(ix,kz) = dtmp(ix,kz) + dtmphl
ELSE !}
g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
@@ -8118,8 +9437,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, &
! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
! ENDIF
-
- IF ( ndebug>1 .and. .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
+ IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN
! write(0,*) 'my_rank = ',my_rank
write(0,*) 'ix,jy,kz = ',ix,jy,kz
@@ -8190,6 +9508,8 @@ END subroutine radardd02
! #####################################################################
!
! Subroutine for explicit cloud condensation and droplet nucleation
+!
+! 11/30/2022: Fixed droplet evaporation heating term for CM1 eqtset=2 (was only doing eqtset=1)
!
SUBROUTINE NUCOND &
& (nx,ny,nz,na,jyslab &
@@ -8198,6 +9518,7 @@ SUBROUTINE NUCOND &
& ,t0,t9 &
& ,an,dn,p2 &
& ,pn,w &
+ & ,ngs &
& ,axtra,io_flag &
& ,ssfilt,t00,t77,flag_qndrop &
& )
@@ -8256,6 +9577,7 @@ SUBROUTINE NUCOND &
logical :: io_flag
real :: dv
+ real :: ccnefactwo, sstmp, cn1, cnuctmp
!
! declarations microphysics and for gather/scatter
@@ -8264,7 +9586,6 @@ SUBROUTINE NUCOND &
real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 ! mass of 20-micron radius droplet, for sat. adj.
integer nxmpb,nzmpb,nxz
integer mgs,ngs,numgs,inumgs
- parameter (ngs=500)
integer ngscnt,igs(ngs),kgs(ngs)
integer kgsp(ngs),kgsm(ngs)
integer nsvcnt
@@ -8283,6 +9604,7 @@ SUBROUTINE NUCOND &
real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
+ real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs)
real ccncuf(ngs)
real sscb ! 'cloud base' SS threshold
parameter ( sscb = 2.0 )
@@ -8295,7 +9617,7 @@ SUBROUTINE NUCOND &
integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat
parameter ( ifilt = 0 )
real temp1,temp2 ! ,ssold
- real :: ssmax(ngs) = 0.0 ! maximum SS experienced by a parcel
+ real :: ssmax(ngs) ! maximum SS experienced by a parcel
real ssmx
real dnnet,dqnet
! real cnu,rnu,snu,cinu
@@ -8419,7 +9741,6 @@ SUBROUTINE NUCOND &
integer :: count
-
! -------------------------------------------------------------------------------
itile = nxi
jtile = ny
@@ -8433,6 +9754,7 @@ SUBROUTINE NUCOND &
kzbeg = 1
nzbeg = 1
+ IF ( ac_opt > 0 ) ccnefactwo = (1.63e-3/(cck * beta(3./2., cck/2.)))**(1.0/(cck + 2.0))
f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73)
jy = 1
@@ -8543,6 +9865,7 @@ SUBROUTINE NUCOND &
qx(:,:) = 0.0
cx(:,:) = 0.0
+ zx(:,:) = 0.0
xv(:,:) = 0.0
xmas(:,:) = 0.0
@@ -8602,6 +9925,7 @@ SUBROUTINE NUCOND &
ELSE ! equation set 2 in cm1
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
+cpigb*(tmp)
cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
@@ -8656,12 +9980,16 @@ SUBROUTINE NUCOND &
ELSE
ssmax(mgs) = 0.0
ENDIF
- IF ( lccn .gt. 1 ) THEN
- ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ IF ( lccn .gt. 1 .and. ac_opt == 0 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn > 0 ) THEN
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + an(igs(mgs),jy,kgs(mgs),lccnuf)
+ ELSE
+ ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+ ENDIF
ELSE
ccnc(mgs) = cwnccn(mgs)
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. i_uf_or_ccn == 0 ) THEN
ccncuf(mgs) = an(igs(mgs),jy,kgs(mgs),lccnuf)
ELSE
ccncuf(mgs) = 0.0
@@ -8716,6 +10044,237 @@ SUBROUTINE NUCOND &
ventrxn(:) = ventrn
+! Find shape parameter rain
+
+ IF ( lzr > 1 .and. rcond == 2 ) THEN ! { RAIN SHAPE PARAM
+ DO mgs = 1,ngscnt
+ zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0)
+ ENDDO
+
+! CALL cld_cpu('Z-MOMENT-1r2')
+ il = lr
+ DO mgs = 1,ngscnt
+
+ IF ( zx(mgs,il) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( cx(mgs,il) <= 0.0 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+ xv(mgs,lr) = xvmx(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+
+ ENDIF
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(chw*1000.*1000)
+
+ ENDIF
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z1*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( imurain == 1 ) THEN
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z1 = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(z1*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+! z1 = 36.*(alpha(kz)+2.0)*a(ix,jy,kz,lnr)*vr**2/((alpha(kz)+1.0)*pi**2)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z1 = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z1*(pi/6.*1000.)**2/xv
+
+
+! determine shape parameter alpha by iteration
+ IF ( z1 .gt. 0.0 ) THEN
+
+ IF ( imurain == 3 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'kz, alp, alpha(kz) = ',kz,alp,alpha(kz),rd,z1,xv
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*pi**2) - 1.
+! write(0,*) 'i,alp = ',i,alp
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+ ELSE ! imurain == 1
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ rd1 = z1*(pi/6.*xdn(mgs,il))**2*nrx/(rho0(mgs)*qr)**2
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rd1) - 1.0
+
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+! ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ IF ( imurain == 3 ) THEN
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+
+ z1 = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z1
+ ENDIF
+ ENDIF
+
+ ELSEIF ( imurain == 1 ) THEN
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( (rescale_low_alpha .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*rho0(mgs)**2*(qr)*qr/zx(mgs,lr)*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alpha .and. alp <= alphamin ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ z1 = g1*rho0(mgs)**2*(qr)*qr/nrx
+ z2 = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z2
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z2
+ ENDIF
+ ENDIF ! imurain
+
+ ENDIF ! z > 0
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+ ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma(alpha(mgs,lr) + 1.5 + br/6.)/Gamma(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r2')
+ ENDIF ! }
+
! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit
ssmx = 0.0
@@ -8735,6 +10294,8 @@ SUBROUTINE NUCOND &
ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1))
ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1))
+! IF ( wvel(mgs) /= 0.0 ) write(0,*) 'mgs,wvel1,ssf = ',mgs,wvel(mgs),ssf(mgs)
+
ENDDO
@@ -8744,7 +10305,7 @@ SUBROUTINE NUCOND &
! cloud water variables
!
- if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables'
+ if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables'
do mgs = 1,ngscnt
xv(mgs,lc) = 0.0
@@ -8868,23 +10429,22 @@ SUBROUTINE NUCOND &
QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) )
- IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63
+ IF ( qx(mgs,lc) <= QEVAP ) THEN ! GO TO 63
qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
- thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*qx(mgs,lc)/(pi0(mgs))
IF ( io_flag .and. nxtra > 1 ) THEN
axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp
ENDIF
qx(mgs,lc) = 0.
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
- IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
- ELSE
- ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
- ENDIF
- ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - cx(mgs,lc)
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( irenuc <= 2 ) THEN
+ IF ( .not. invertccn ) THEN
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
+ ELSE
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
+ ENDIF
ENDIF
ENDIF
cx(mgs,lc) = 0.
@@ -8894,39 +10454,37 @@ SUBROUTINE NUCOND &
qx(mgs,lc) = qx(mgs,lc) - QEVAP
IF ( qx(mgs,lc) .le. 0. ) THEN
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*cx(mgs,lc)
+ ELSEIF ( irenuc <= 2 ) THEN
! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
! ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + cx(mgs,lc) ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*cx(mgs,lc) ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + cx(mgs,lc)
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*cx(mgs,lc)
ENDIF
ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - cx(mgs,lc)
- ENDIF
ENDIF
cx(mgs,lc) = 0.
ELSE
tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp ! let droplets get smaller but also remove some. A factor of 1.0 would maintain same size
IF ( restoreccn ) THEN
- IF ( irenuc <= 2 ) THEN
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) - restoreccnfrac*tmp
+ ELSEIF ( irenuc <= 2 ) THEN
! ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
! ccnc(mgs) = ccnc(mgs) + tmp
IF ( .not. invertccn ) THEN
- ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + tmp ) )
+ ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) )
ELSE
- ccnc(mgs) = ccnc(mgs) + tmp
+ ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp
ENDIF
ENDIF
- IF ( lccna > 1 ) THEN
- ccna(mgs) = ccna(mgs) - tmp
- ENDIF
ENDIF
cx(mgs,lc) = cx(mgs,lc) - tmp
ENDIF
- thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs))
+ thetap(mgs) = thetap(mgs) - felvcp(mgs)*QEVAP/(pi0(mgs))
IF ( io_flag .and. nxtra > 1 ) THEN
axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp
ENDIF
@@ -9208,11 +10766,24 @@ SUBROUTINE NUCOND &
!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs))
- theta(mgs) = thetap(mgs) + theta0(mgs)
- temg(mgs) = theta(mgs)*f1
- ltemq = (temg(mgs)-163.15)/fqsat+1.5
- ltemq = Min( nqsat, Max(1,ltemq) )
- qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
+ IF ( lzr > 1 .and. rcond == 2 .and. qx(mgs,lr) .gt. qxmin(lr) &
+ & .and. cx(mgs,lr) .gt. 1.e-9 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ IF ( imurain == 3 ) THEN
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ ELSE
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+
+ ENDIF
+ zx(mgs,lr) = zx(mgs,lr) + g1*(rho0(mgs)/(xdn(mgs,lr)))**2*( 2.*( tmp ) * dqr )
+ ENDIF
+
+ theta(mgs) = thetap(mgs) + theta0(mgs)
+ temg(mgs) = theta(mgs)*f1
+ ltemq = (temg(mgs)-163.15)/fqsat+1.5
+ ltemq = Min( nqsat, Max(1,ltemq) )
+ qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
! es(mgs) = 6.1078e2*tabqvs(ltemq)
!
@@ -9249,7 +10820,8 @@ SUBROUTINE NUCOND &
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 5.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs) ) THEN ! this one works
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 ) THEN ! test -- fails
! IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.1*cwnccn(mgs)) THEN ! test -- is OK
- IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. ccnc(mgs) > 0.05*cwnccn(mgs)) THEN ! test
+ IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. &
+ ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc_ac(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN ! test
! IF ( ssf(mgs) > ssmx ) THEN ! original condition
CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, &
& pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
@@ -9260,7 +10832,7 @@ SUBROUTINE NUCOND &
ELSE
dcloud = 0.0
ENDIF
-
+
thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
qwvp(mgs) = qwvp(mgs) - DCLOUD
qx(mgs,lc) = qx(mgs,lc) + DCLOUD
@@ -9285,11 +10857,16 @@ SUBROUTINE NUCOND &
IF ( .not. flag_qndrop ) THEN ! { do not calculate number of droplets if using wrf-chem
+ IF ( ac_opt == 0 ) THEN
+ cnuctmp = cnuc(mgs)
+ ELSE
+ cnuctmp = ccnc_ac(mgs)
+ ENDIF
! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN
! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
- CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
+ CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 &
& .and. ncdebug .ge. 1 ) THEN
write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, &
@@ -9311,12 +10888,16 @@ SUBROUTINE NUCOND &
ENDIF
IF ( cn(mgs) .gt. 0.0 ) THEN
- IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
- cn(mgs) = ccnc(mgs)
-! ccnc(mgs) = 0.0
+ IF ( ac_opt == 0 ) THEN
+ IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
+ cn(mgs) = ccnc(mgs)
+! ccnc(mgs) = 0.0
+ ENDIF
+ ELSE
+ cn(mgs) = Min( cn(mgs), ccnc_ac(mgs) )
ENDIF
! cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
ccna(mgs) = ccna(mgs) + cn(mgs)
ENDIF
@@ -9362,7 +10943,8 @@ SUBROUTINE NUCOND &
DSSDZ=0.
r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
- IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
+
+ IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
IF ( irenuc < 2 ) THEN !{
@@ -9439,6 +11021,7 @@ SUBROUTINE NUCOND &
! nucleation
CN(mgs) = Min(cn(mgs), ccnc(mgs))
cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+ CN(mgs) = Min( CN(mgs), Max(0.0, (cnuc(mgs) - ccna(mgs) )) )
IF ( .false. .and. ny <= 2 ) THEN
write(0,*) 'i,k, cwmasn = ',igs(mgs),kgs(mgs),cwmasn
@@ -9466,8 +11049,136 @@ SUBROUTINE NUCOND &
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ ELSEIF ( irenuc == 3 ) THEN !} {
+ ! Phillips Donner Garner 2007
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+! CN(mgs) = cwccn*Min(ssf(mgs),ssfcut)**cck
+
+! Need to calculate new ssf since condensation has happened:
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+ c1= pqs(mgs)*tabqvs(ltemq)
+
+ ssf(mgs) = 0.0
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ! from "new" values
+ ENDIF
+ CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) !
+
+ CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+ CN(mgs) = Min(cn(mgs), ccnc(mgs))
+ cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+
+ ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
+ ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
+ ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ ELSEIF ( irenuc == 4 ) THEN !} {
+ ! modification of Phillips Donner Garner 2007
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+! CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp
+! cn(mgs) = Min( cn(mgs), cnuc(mgs) )
+! Need to calculate new ssf since condensation has happened:
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+ c1= pqs(mgs)*tabqvs(ltemq)
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
+ ELSE
+ ssf(mgs) = 0.0
+ ENDIF
+ CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ! this allows cn(mgs) > cnuc(mgs)
+
+ CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+! CN(mgs) = Min(cn(mgs), ccnc(mgs))
+ cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ IF ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+ dcrit = 2.0*2.5e-7
+
+ dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+ qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+ thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+ qwvp(mgs) = qwvp(mgs) - DCLOUD
+ ENDIF
+ ! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
+ ! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
+! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+
+
+ ELSEIF ( irenuc == 6 ) THEN !} {
+
+ ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
+! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
+ cn(mgs) = 0.0
+! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
+ IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN ! here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
+! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
+ ! prevent this branch from activating more than 70% of CCN
+ CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) )
+! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
+
+ ELSE
+ ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.
+
+ temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+! t0(ix,jy,kz) = temp1
+ ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+ ltemq = Min( nqsat, Max(1,ltemq) )
+
+! c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
+ c1= pqs(mgs)*tabqvs(ltemq)
+ IF ( c1 > 0. ) THEN
+ ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ! from "new" values
+ ELSE
+ ssf(mgs) = 0.0
+ ENDIF
+! CN(mgs) = cnuc(mgs)*Min(0.99, Min(ssf(mgs),ssfcut)**cck ) !
+ CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) !
+! CN(mgs) = cnuc(mgs)*Min(ssf(mgs),ssfcut)**cck !
+
+
+ CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+! cn(mgs) = 0.0
+ ENDIF
+! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
+!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+ ! Philips, Donner et al. 2007, but results in too much limitation of
+ ! nucleation
+! CN(mgs) = Min(cn(mgs), ccnc(mgs))
+! cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+
+ IF ( cn(mgs) > 0.0 ) THEN
+ cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+
+ ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
+
+ dcrit = 2.0*2.5e-7
+
+ dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+ qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+ thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+ qwvp(mgs) = qwvp(mgs) - DCLOUD
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ ENDIF
ELSEIF ( irenuc == 5 ) THEN !} {
! modification of Phillips Donner Garner 2007
@@ -9525,17 +11236,22 @@ SUBROUTINE NUCOND &
! 6/13/2016: Phillips et al. appears not to decrement CCN, but only increments CCNa.
! This would allow an initially non-homogeneous (vertically, e.g.) initial value of CCN/rho_air
! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
- ELSEIF ( irenuc == 7 ) THEN !} {
+ ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN !} {
! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs)
cn(mgs) = 0.0
+ IF ( irenuc == 7 ) THEN
+ frac = 0.9
+ ELSE
+ frac = 0.98
+ ENDIF
! IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
- IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
- CN(mgs) = Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
+ IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
+ CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
! IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
! prevent this branch from activating more than 70% of CCN
- CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) )
+ CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) )
! CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
! write(0,*) '1: k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
!! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
@@ -9573,7 +11289,7 @@ SUBROUTINE NUCOND &
! write(0,*) 'k,cn = ',kgs(mgs),cn(mgs),ssf(mgs)
! write(0,*) 'ccn-ccna = ',cnuc(mgs) - ccna(mgs),ccnc(mgs) - ccna(mgs)
! IF ( ccncuf(mgs) > 0.0 .and. cn(mgs) < 1.e-3 .and. ssmax(mgs) > 1.0 ) THEN
- IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ssmax(mgs) > ssmxuf ) THEN
+ IF ( ccncuf(mgs) > 0.0 .and. ssf(mgs) > ssmxuf .and. ( ssmax(mgs) > ssmxuf .or. lss < 1 ) ) THEN
CNuf(mgs) = Min( ccncuf(mgs), CCNE0*ccncuf(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
! IF ( cnuf(mgs) >= 0.0 ) write(0,*) 'cnuf, k = ',cnuf(mgs),ccncuf(mgs),kgs(mgs)
ENDIF
@@ -9675,7 +11391,7 @@ SUBROUTINE NUCOND &
IF ( cn(mgs) > 0.0 ) THEN
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
- ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+ ! ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
! create some small droplets at minimum size (CP 2000), although it adds very little liquid
@@ -9694,8 +11410,6 @@ SUBROUTINE NUCOND &
ccna(mgs) = ccna(mgs) + cn(mgs)
-
-
ENDIF ! irenuc >= 0 .and. .not. flag_qndrop
IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
@@ -9748,7 +11462,11 @@ SUBROUTINE NUCOND &
ELSEIF ( imaxsupopt == 4 ) THEN
cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) )
ENDIF
- ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
+ IF ( lccna > 1 ) THEN
+ ccna(mgs) = ccna(mgs) + cn(mgs)
+ ELSE
+ ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) )
+ ENDIF
cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
ENDIF
@@ -9853,15 +11571,21 @@ SUBROUTINE NUCOND &
! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
end if
+ IF ( lzr > 1 .and. rcond == 2 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lzr) = zx(mgs,lr) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lzr), 0.0 )
+ ENDIF
IF ( ipconc .ge. 2 ) THEN
an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0)
IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) )
- IF ( lccn .gt. 1 ) THEN
- an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
+ IF ( ac_opt == 0 ) THEN
+ IF ( lccn .gt. 1 .and. lccna .lt. 1 ) THEN
+ an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) )
+ ENDIF
ENDIF
- IF ( lccnuf .gt. 1 ) THEN
+ IF ( lccnuf .gt. 1 .and. .not. ( lccna .gt. 1 .and. i_uf_or_ccn > 0 ) ) THEN
an(igs(mgs),jy,kgs(mgs),lccnuf) = Max(0.0, ccncuf(mgs) )
ENDIF
IF ( lccna .gt. 1 ) THEN
@@ -9938,6 +11662,42 @@ SUBROUTINE NUCOND &
IF ( lhl .gt. 1 ) THEN
+ IF ( lzhl .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzhl) = Max(0.0, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lhl) .ge. frac*qxmin(lhl) .and. rescale_low_alpha ) THEN ! check 6th moment
+
+ IF ( an(ix,jy,kz,lnhl) .gt. 0.0 ) THEN
+
+ IF ( lvhl .gt. 1 ) THEN
+ IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl)
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+ hwdn = Max( xdnmn(lhl), hwdn )
+ ELSE
+ hwdn = xdn0(lhl)
+ ENDIF
+
+ chw = an(ix,jy,kz,lnhl)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lhl) )*an(ix,jy,kz,lhl)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzhl) = Min( z1, an(ix,jy,kz,lzhl) )
+
+ IF ( an(ix,jy,kz,lnhl) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzhl) = 0.9*an(ix,jy,kz,lzhl)
+ ENDIF
+ ENDIF
+
+ ENDIF !lzhl
if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then
@@ -10038,6 +11798,42 @@ SUBROUTINE NUCOND &
+ IF ( lzh .gt. 1 ) THEN
+
+ an(ix,jy,kz,lzh) = Max(0.0, an(ix,jy,kz,lzh) )
+
+ IF ( .false. .and. an(ix,jy,kz,lh) .ge. frac*qxmin(lh) .and. rescale_low_alpha ) THEN
+
+ IF ( an(ix,jy,kz,lnh) .gt. 0.0 ) THEN
+
+ IF ( lvh .gt. 1 ) THEN
+ IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
+ hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
+ ELSE
+ hwdn = xdn0(lh)
+ ENDIF
+ hwdn = Max( xdnmn(lh), hwdn )
+ ELSE
+ hwdn = xdn0(lh)
+ ENDIF
+
+ chw = an(ix,jy,kz,lnh)
+ g1 = (6.0+alphamin)*(5.0+alphamin)*(4.0+alphamin)/ &
+ & ((3.0+alphamin)*(2.0+alphamin)*(1.0+alphamin))
+ z1 = g1*dn(ix,jy,kz)**2*( an(ix,jy,kz,lh) )*an(ix,jy,kz,lh)/chw
+ z1 = z1*(6./(pi*hwdn))**2
+ ELSE
+ z1 = 0.0
+ ENDIF
+
+ an(ix,jy,kz,lzh) = Min( z1, an(ix,jy,kz,lzh) )
+
+ IF ( an(ix,jy,kz,lnh) .lt. 1.e-5 ) THEN
+! an(ix,jy,kz,lzh) = 0.9*an(ix,jy,kz,lzh)
+ ENDIF
+ ENDIF
+
+ ENDIF
if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then
@@ -10198,6 +11994,9 @@ SUBROUTINE NUCOND &
end if
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = Max(0.0, an(ix,jy,kz,lzr) )
+ ENDIF
if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) &
& ) then
@@ -10208,6 +12007,10 @@ SUBROUTINE NUCOND &
an(ix,jy,kz,lnr) = 0.0
ENDIF
+ IF ( lzr > 1 ) THEN
+ an(ix,jy,kz,lzr) = 0.0
+ ENDIF
+
end if
!
@@ -10260,18 +12063,25 @@ SUBROUTINE NUCOND &
an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
an(ix,jy,kz,lc)= 0.0
IF ( ipconc .ge. 2 ) THEN
- IF ( lccn .gt. 1 ) THEN
- an(ix,jy,kz,lccn) = &
- & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
+ IF ( lccn .gt. 1 .or. ac_opt == 1 ) THEN
+ IF ( irenuc < 5 .and. lccna <= 1 ) THEN
+ IF ( ac_opt == 0 ) THEN
+ an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
+ ENDIF
+ ELSEIF ( lccna > 1 ) THEN
+ an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - Max(0.0,an(ix,jy,kz,lnc)) )
+ ENDIF
ENDIF
an(ix,jy,kz,lnc) = 0.0
+ IF ( lccn > 1 ) an(ix,jy,kz,lccn) = Max( 0.0, an(ix,jy,kz,lccn) )
- IF ( lccna > 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( lccna > 0 .and. ac_opt == 0 ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+ IF ( restoreccn ) THEN
tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst)
-
- ELSEIF ( lccn > 1 .and. restoreccn ) THEN
+ ENDIF
+ ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN
! in this case, we are treating the ccn field as ccna
tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)
! IF ( ny == 2 .and. ix == nx/2 ) THEN
@@ -10335,9 +12145,9 @@ subroutine nssl_2mom_gs &
! & ln,ipc,lvol,lz,lliq, &
& cdx, &
& xdn0,tmp3d,tkediss &
- & ,thproc,numproc,dx1,dy1 &
+ & ,thproc,numproc,dx1,dy1,ngs &
& ,timevtcalc,axtra,io_flag &
- & , has_wetscav,rainprod2d, evapprod2d &
+ & , has_wetscav,rainprod2d, evapprod2d, alpha2d &
& ,errmsg,errflg &
& ,elec,its,ids,ide,jds,jde &
& )
@@ -10425,6 +12235,12 @@ subroutine nssl_2mom_gs &
real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz)
+
+ real :: alpha2d(-nor+1:nx+nor,-norz+ng1:nz+norz,3)
+
+ real, parameter :: tfrdry = 243.15
+
+ logical lrescalelow(lc:lhab)
real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz)
real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra)
@@ -10570,7 +12386,6 @@ subroutine nssl_2mom_gs &
!
integer nxmpb,nzmpb,nxz
integer jgs,mgs,ngs,numgs
- parameter (ngs=500) !500)
integer, parameter :: ngsz = 500
integer ntt
parameter (ntt=300)
@@ -10633,7 +12448,8 @@ subroutine nssl_2mom_gs &
real ex1, ft, rhoinv(ngs)
double precision ec0(ngs)
- real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,temp3 ! , sstdy, super
+ real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 ! , sstdy, super
+ real :: flim
real dw,dwr
double precision :: tmpz, tmpzmlt
real ratio, delx, dely
@@ -10714,7 +12530,7 @@ subroutine nssl_2mom_gs &
real temgx(ngs),temcgx(ngs)
real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
real elv(ngs),elf(ngs),els(ngs)
- real tsqr(ngs),ssi(ngs),ssw(ngs)
+ real tsqr(ngs),ssi(ngs),ssw(ngs),ssi0(ngs)
real qcwtmp(ngs),qtmp,qtot(ngs)
real qcond(ngs)
real ctmp, sctmp
@@ -10729,6 +12545,7 @@ subroutine nssl_2mom_gs &
parameter ( rwradmn = 50.e-6 )
real dh0
real dg0(ngs),df0(ngs)
+ real dhwet(ngs),dhlwet(ngs),dfwet(ngs)
real clionpmx,clionnmx
parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
@@ -10736,7 +12553,7 @@ subroutine nssl_2mom_gs &
! other arrays
real fwet1(ngs),fwet2(ngs)
- real fmlt1(ngs),fmlt2(ngs)
+ real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs)
real fvds(ngs),fvce(ngs),fiinit(ngs)
real fvent(ngs),fraci(ngs),fracl(ngs)
!
@@ -10760,6 +12577,7 @@ subroutine nssl_2mom_gs &
!
real :: sfm1(ngs),sfm2(ngs)
real :: gfm1(ngs),gfm2(ngs)
+ real :: ffm1(ngs),ffm2(ngs)
real :: hfm1(ngs),hfm2(ngs)
logical :: wetsfc(ngs),wetsfchl(ngs),wetsfcf(ngs)
@@ -10800,6 +12618,10 @@ subroutine nssl_2mom_gs &
real :: alpha(ngs,lc:lhab)
real :: dab0lh(ngs,lc:lhab,lc:lhab)
real :: dab1lh(ngs,lc:lhab,lc:lhab)
+ real :: zx(ngs,lr:lhab)
+ real :: zxmxd(ngs,lr:lhab)
+ real :: g1x(ngs,lr:lhab)
+
real :: qsimxdep(ngs) ! max sublimation of qi+qs+qis
real :: qsimxsub(ngs) ! max depositionof qi+qs+qis
@@ -10815,6 +12637,7 @@ subroutine nssl_2mom_gs &
real ventrxn(ngs)
real g1shr, alphashr
real g1mlr, alphamlr
+ real g1smlr, alphasmlr
real massfacshr, massfacmlr
real :: qhgt8mm ! ice mass greater than 8mm
@@ -10827,6 +12650,8 @@ subroutine nssl_2mom_gs &
real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield
!
real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs)
+ real hxventtmp
+ real hlventinc(ngs),hwventinc(ngs)
integer, parameter :: ndiam = 10
integer :: numdiam
real hwvent0(ndiam+4),hlvent0 ! 0 to d1
@@ -10940,15 +12765,15 @@ subroutine nssl_2mom_gs &
real qrcnw(ngs), qwcnr(ngs)
real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs)
-
real qracw(ngs) ! qwacr(ngs),
real qiacw(ngs) !, qwaci(ngs)
real qsacw(ngs) ! ,qwacs(ngs),
real qhacw(ngs) ! qwach(ngs),
- real :: qhlacw(ngs) !
+ real :: qhlacw(ngs), qxacwtmp, qxacrtmp, qxacitmp, qxacstmp !
real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs)
+ real qfcev(ngs)
real qfmul1(ngs),cfmul1(ngs)
!
real qsacws(ngs)
@@ -10957,7 +12782,7 @@ subroutine nssl_2mom_gs &
! arrays for x-ac-r and r-ac-x;
!
real qsacr(ngs),qracs(ngs)
- real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs)
+ real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) ! ,qrach(ngs)
real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
real qiacr(ngs),qraci(ngs)
@@ -10965,7 +12790,7 @@ subroutine nssl_2mom_gs &
real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs)
- real :: qhlacr(ngs),qhlacrmlr(ngs)
+ real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs)
real qsacrs(ngs) !,qracss(ngs)
!
! ice - ice interactions
@@ -11011,7 +12836,8 @@ subroutine nssl_2mom_gs &
real zfmlr(ngs), zfdsv(ngs), zfsbv(ngs), zhlcnf(ngs), zfshr(ngs), zfshrr(ngs)
real zhmlrtmp,zhmlr0inf,zhlmlr0inf
real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs),zfmlrr(ngs)
- real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs)
+! real zsmlr(ngs)
+ real zsmlrr(ngs), zsshr(ngs), zsshrr(ngs)
real zhcns(ngs), zhcni(ngs)
real zhwdn(ngs), zfwdn(ngs) ! change in Z due to density changes
real zhldn(ngs) ! change in Z due to density changes
@@ -11052,9 +12878,10 @@ subroutine nssl_2mom_gs &
!
real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(ngs)
- real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs)
+ real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs), qxwettmp
!
real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
+ real :: qffz(ngs)
!
real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs),
real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs)
@@ -11064,6 +12891,7 @@ subroutine nssl_2mom_gs &
real qhshh(ngs) !accreted water that remains on graupel
real qhmlh(ngs) !melt water that remains on graupel
real qhfzh(ngs) !water that freezes on mixed-phase graupel
+ real qffzf(ngs) !water that freezes on mixed-phase FD
real qhlfzhl(ngs) !water that freezes on mixed-phase hail
real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters
@@ -11115,6 +12943,7 @@ subroutine nssl_2mom_gs &
real qrshr(ngs)
real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) !liquid water fractions
real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) !liquid water fractions
+ real ffwmax(ngs)
real qhcnf(ngs)
real :: qhlcnh(ngs)
real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
@@ -11128,7 +12957,7 @@ subroutine nssl_2mom_gs &
real ehxr(ngs),ehlr(ngs),egmr(ngs)
real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs),efis(ngs)
real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs)
- real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs)
+ real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs),ehsfac(ngs)
real ehscnv(ngs)
real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs)
@@ -11187,12 +13016,13 @@ subroutine nssl_2mom_gs &
real pqgli(ngs),pqghi(ngs),pqfwi(ngs)
real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs)
real pqiri(ngs),pqipi(ngs) ! pqwai(ngs),
- real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs)
+ real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs),pqlwfi(ngs)
real pqlwlghi(ngs),pqlwlghli(ngs)
real pqlwlghd(ngs),pqlwlghld(ngs)
+
real pvhwi(ngs), pvhwd(ngs)
real pvfwi(ngs), pvfwd(ngs)
@@ -11204,7 +13034,7 @@ subroutine nssl_2mom_gs &
real pqgld(ngs),pqghd(ngs),pqfwd(ngs)
real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs)
real pqird(ngs),pqipd(ngs) ! pqwad(ngs),
- real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs)
+ real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs)
!
! real pqxii(ngs,nhab),pqxid(ngs,nhab)
!
@@ -11352,7 +13182,7 @@ subroutine nssl_2mom_gs &
real frcrglgm, frcrglgh, frcrglfw, frcrglgl1
real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1
real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1
- real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt
+ real total, qweps, gf2a, gf4a, dqldt, dqidt, dqdt
real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl
real frcrghgm, frcrghgh, frcrghfw, frcrghgh1
real a1,a2,a3,a4,a5,a6
@@ -11384,9 +13214,22 @@ subroutine nssl_2mom_gs &
real :: term1,term2,term3,term4
real :: qaacw ! combined qsacw-qhacw for WSM6 variation
+ real :: cwchtmp
+
+ real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 ! rain
+ real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 ! Graupel
+ real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 ! Hail
+! inline functions for Newton method
+ real :: galpha, dgalpha
+ real :: a_in
+ logical, parameter :: newton = .false.
+
+ galpha(a_in) = ((4. + a_in)*(5. + a_in)*(6. + a_in))/((1. + a_in)*(2. + a_in)*(3. + a_in))
+ dgalpha(a_in) = (876. + 1260.*a_in + 621.*a_in**2 + 126.*a_in**3 + 9.*a_in**4)/ &
+ & (36. + 132.*a_in + 193.*a_in**2 + 144.*a_in**3 + 58.*a_in**4 + 12.*a_in**5 + a_in**6)
!
! ####################################################################
!
@@ -11416,6 +13259,11 @@ subroutine nssl_2mom_gs &
jstag = 0
kstag = 1
+ lrescalelow(:) = rescale_low_alpha
+ lrescalelow(lr) = rescale_low_alphar .and. rescale_low_alpha
+ lrescalelow(lh) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lf > 1 ) lrescalelow(lf) = rescale_low_alphah .and. rescale_low_alpha
+ IF ( lhl > 1 ) lrescalelow(lhl) = rescale_low_alphahl .and. rescale_low_alpha
!
@@ -11533,11 +13381,18 @@ subroutine nssl_2mom_gs &
vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 )
vshd = Min(xvmx(lr), 0.523599*(dshd)**3 )
- snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
+ IF ( snowmeltdia > 0.0 ) THEN
+ snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ! maximum rain particle mass from melting snow (if snowmeltdia > 0)
+ ENDIF
tdtol = 1.0e-05
tfrcbw = tfr - cbw
tfrcbi = tfr - cbi
+
+ IF ( mixedphase ) THEN
+ ibinhmlr = 0
+ ibinhlmlr = 0
+ ENDIF
!
!
! #ifdef COMMAS
@@ -11689,35 +13544,25 @@ subroutine nssl_2mom_gs &
do ix = nxmpb,itile
pqs(1) = t00(ix,jy,kz)
-! pqs(kz) = t00(ix,jy,kz)
theta(1) = an(ix,jy,kz,lt)
temg(1) = t0(ix,jy,kz)
temcg(1) = temg(1) - tfr
tqvcon = temg(1)-cbw
- ltemq = (temg(1)-163.15)/fqsat+1.5
+ ltemq = (temg(1)-163.15)/fqsat + 1.5
ltemq = Min( nqsat, Max(1,ltemq) )
qvs(1) = pqs(1)*tabqvs(ltemq)
- qis(1) = pqs(1)*tabqis(ltemq)
+ IF ( iqis0 == 1 .or. temg(1) <= tfr+0.5 ) THEN
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(1) = pqs(1)*tabqis(ltemq)
+ ENDIF
qss(1) = qvs(1)
-! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN
-! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz)
-! ENDIF
-
if ( temg(1) .lt. tfr ) then
-! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = qis(kz)
-! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
-! > (qcw(kz) + qci(kz))
- qss(1) = qis(1)
- else
-! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN
-! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz)
-! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz))
-! ENDIF
+ qss(1) = qis(1)
end if
!
ishail = .false.
@@ -11793,7 +13638,12 @@ subroutine nssl_2mom_gs &
ltemq = (temg(mgs)-163.15)/fqsat+1.5
ltemq = Min( nqsat, Max(1,ltemq) )
qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
- qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ IF ( iqis0 == 1 .or. temg(mgs) <= tfr+0.5 ) THEN
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ELSE
+ ltemq = (tfr - 163.15)/fqsat + 1.5
+ qis(mgs) = pqs(mgs)*tabqis(ltemq)
+ ENDIF
qss(mgs) = qvs(mgs)
! es(mgs) = 6.1078e2*tabqvs(ltemq)
! eis(mgs) = 6.1078e2*tabqis(ltemq)
@@ -11834,93 +13684,21 @@ subroutine nssl_2mom_gs &
- scx(:,:) = 0.0
+
!
-! set shape parameters
+! set concentrations
!
- IF ( imurain == 1 ) THEN
- alpha(:,lr) = alphar
- ELSEIF ( imurain == 3 ) THEN
- alpha(:,lr) = xnu(lr)
- ENDIF
-
- alpha(:,li) = xnu(li)
- alpha(:,lc) = xnu(lc)
-
- IF ( imusnow == 1 ) THEN
- alpha(:,ls) = alphas
- ELSEIF ( imusnow == 3 ) THEN
- alpha(:,ls) = xnu(ls)
- ENDIF
+! ssmax = 0.0
- DO il = lr,lhab
- do mgs = 1,ngscnt
- IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
-
-
- DO ic = lc,lhab
- dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il)
- dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il)
- ENDDO
- ENDDO
- end do
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
-! DO mgs = 1,ngscnt
- DO il = lr,lhab
- da0lx(:,il) = da0(il)
- ENDDO
- da0lh(:) = da0(lh)
- da0lr(:) = da0(lr)
- da1lr(:) = da1(lr)
- da0lc(:) = da0(lc)
- da1lc(:) = da1(lc)
-
-
- IF ( lzh < 1 .or. lzhl < 1 ) THEN
- rzxhlh(:) = rzhl/rz
- ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
- rzxhlh(:) = 1.
- ENDIF
- IF ( lzr > 1 ) THEN
- rzxh(:) = 1.
- rzxhl(:) = 1.
- ELSE
- rzxh(:) = rz
- rzxhl(:) = rzhl
- ENDIF
-
- IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
- rzxs(:) = rzs
- ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
- rzxs(:) = 1.
- ENDIF
- ! ENDDO
-
- IF ( lhl .gt. 1 ) THEN
- DO mgs = 1,ngscnt
- da0lhl(mgs) = da0(lhl)
- ENDDO
- ENDIF
-
- ventrx(:) = ventr
- ventrxn(:) = ventrn
- gf1palp(:) = gamma_sp(1.0 + alphar)
-
-!
-! set concentrations
-!
-! ssmax = 0.0
-
-
- if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) 'ICEZVD_GS: dbg = 5b'
-
- if ( ipconc .ge. 1 ) then
- do mgs = 1,ngscnt
- cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
- IF ( qx(mgs,li) .le. qxmin(li) ) THEN
- cx(mgs,li) = 0.0
- ENDIF
+ if ( ipconc .ge. 1 ) then
+ do mgs = 1,ngscnt
+ cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
+ IF ( qx(mgs,li) .le. qxmin(li) ) THEN
+ cx(mgs,li) = 0.0
+ ENDIF
IF ( lcina .gt. 1 ) THEN
cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina)
@@ -12074,6 +13852,124 @@ subroutine nssl_2mom_gs &
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ zx(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ DO mgs = 1,ngscnt
+ zx(mgs,il) = Max( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ ENDDO
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF ( ipconc .ge. 6 ) THEN
+
+ IF ( lz(lr) .lt. 1 ) THEN
+ g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ &
+ & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+
+
+ DO mgs = 1,ngscnt
+ IF ( cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ vr = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ IF ( lzr < 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ zx(mgs,lr) = 3.6476*(rnu+2.0)*cx(mgs,lr)*vr**2/(rnu+1.0)
+ ELSE ! imurain == 1
+ zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ENDIF
+
+
+ scx(:,:) = 0.0
+!
+! set shape parameters
+!
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set alpha'
+ IF ( imurain == 1 ) THEN
+ alpha(:,lr) = alphar
+ ELSEIF ( imurain == 3 ) THEN
+ alpha(:,lr) = xnu(lr)
+ ENDIF
+
+ alpha(:,li) = xnu(li)
+ alpha(:,lc) = xnu(lc)
+
+ IF ( imusnow == 1 ) THEN
+ alpha(:,ls) = alphas
+ ELSEIF ( imusnow == 3 ) THEN
+ alpha(:,ls) = xnu(ls)
+ ENDIF
+
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set dab'
+
+ DO il = lr,lhab
+ do mgs = 1,ngscnt
+ IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
+
+
+ DO ic = lc,lhab
+ dab0lh(mgs,il,ic) = dab0(il,ic) ! dab0(ic,il)
+ dab1lh(mgs,il,ic) = dab1(il,ic) ! dab1(ic,il)
+ ENDDO
+ end do
+ ENDDO
+
+
+! DO mgs = 1,ngscnt
+ DO il = lr,lhab
+ da0lx(:,il) = da0(il)
+ ENDDO
+ da0lh(:) = da0(lh)
+ da0lr(:) = da0(lr)
+ da1lr(:) = da1(lr)
+ da0lc(:) = da0(lc)
+ da1lc(:) = da1(lc)
+
+ if ( ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'ICEZVD_GS: dbg = set rz'
+
+ IF ( lzh < 1 .or. lzhl < 1 ) THEN
+ rzxhlh(:) = rzhl/rz
+ ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
+ rzxhlh(:) = 1.
+ ENDIF
+ IF ( lzr > 1 ) THEN
+ rzxh(:) = 1.
+ rzxhl(:) = 1.
+ ELSE
+ rzxh(:) = rz
+ rzxhl(:) = rzhl
+ ENDIF
+
+ IF ( imurain == 1 .and. imusnow == 3 .and. lzr < 1 ) THEN
+ rzxs(:) = rzs
+ ELSEIF ( imurain == imusnow .or. lzr > 1 ) THEN
+ rzxs(:) = 1.
+ ENDIF
+ ! ENDDO
+
+ IF ( lhl .gt. 1 ) THEN
+ DO mgs = 1,ngscnt
+ da0lhl(mgs) = da0(lhl)
+ ENDDO
+ ENDIF
+
+ ventrx(:) = ventr
+ ventrxn(:) = ventrn
+ gf1palp(:) = gamma_sp(1.0 + alphar)
!
! set factors
@@ -12112,6 +14008,7 @@ subroutine nssl_2mom_gs &
tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+ IF ( lf > 1 ) tmp = tmp + qx(mgs,lf)
cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) &
+cpigb*(tmp)
@@ -12231,62 +14128,880 @@ subroutine nssl_2mom_gs &
ENDIF
- IF ( lhl .gt. 1 ) THEN
+ IF ( lhl .gt. 1 ) THEN
+
+ xdn(mgs,lhl) = xdn0(lhl)
+ xdntmp(mgs,lhl) = xdn0(lhl)
+
+ IF ( lvol(lhl) .gt. 1 ) THEN
+ IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
+
+ IF ( mixedphase .and. lhlw > 1 ) THEN
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+
+ xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
+ vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+ xdntmp(mgs,lhl) = xdn(mgs,lhl)
+
+ ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
+
+ vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+
+ end do
+
+ IF ( ipconc == 5 .and. imydiagalpha == 2 ) THEN
+
+ cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
+
+ DO mgs = 1,ngscnt
+ !IF ( igs(mgs) == 19 ) write(0,*) 'k,qr,qh,cr,ch = ',kgs(mgs),qx(mgs,lr),cx(mgs,lr),qx(mgs,lh),cx(mgs,lh)
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > cxmin ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) !
+ xdia(mgs,lr,3) = (xv(mgs,lr)*6.0*cwc1)**(1./3.)
+ ! alpha(mgs,lr) = Min(alphamax, c1r*tanh(c2r*(xdia(mgs,lr,3)*1000. - c3r)) + c4r)
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alpr,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lr),xdia(mgs,lr,3)*1000.
+
+ ! M&M-C 2010:
+ tmp = 4. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + alphar
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lr,3)*cwchtmp
+
+ alpha(mgs,lr) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ENDIF
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) > cxmin ) THEN
+! MY 2005:
+ xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) !
+ xdia(mgs,lh,3) = (xv(mgs,lh)*6.*piinv)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.)
+! alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h)
+
+ ! M&M-C 2010:
+ tmp = 4. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 1. + dnu(lh)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = (x/y)**(1./3.)*xdia(mgs,lh,3)*cwchtmp
+
+ alpha(mgs,lh) = Min(15., 11.8*(1000.*tmp - 0.7)**2 + 2.)
+ ! alphan(mgs,lh) = alpha(mgs,lh)
+
+ ! IF ( igs(mgs) == 19 ) write(0,*) 'imy: i,k,alph,xdia = ',igs(mgs),kgs(mgs),alpha(mgs,lh),xdia(mgs,lh,3)*1000.
+ il = lh
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+ ENDIF
+! alpha(:,lr) = 0. ! 10.
+! alpha(:,lh) = 0. ! 10.
+ IF ( lhl > 0 ) THEN
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) > cxmin ) THEN
+ xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) !
+ xdia(mgs,lhl,3) = (xv(mgs,lhl)*6.*piinv)**(1./3.)
+ IF ( xdia(mgs,lhl,3) < 0.008 ) THEN
+ alpha(mgs,lhl) = Min(alphamax, c1hl*tanh(c2hl*(xdia(mgs,lhl,3)*1000. - c3hl)) + c4hl)
+ ELSE
+ alpha(mgs,lhl) = Min(alphamax, c5hl*xdia(mgs,lhl,3)*1000. + c6hl)
+ ENDIF
+
+ il = lhl
+ DO ic = lc,lh-1 ! lhab
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+ ENDDO
+
+ ENDIF
+ ENDIF
+
+
+
+ ENDDO
+ ENDIF
+
+
+ IF ( imurain == 3 ) THEN
+ IF ( lzr > 1 ) THEN
+ alphashr = 0.0
+ alphamlr = -2.0/3.0
+ alphasmlr = -2.0/3.0
+ ELSE
+ alphashr = xnu(lr)
+ alphamlr = xnu(lr)
+ alphasmlr = xnu(lr)
+ ENDIF
+! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
+! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
+ massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor
+ massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
+ ELSEIF ( imurain == 1 ) THEN
+ IF ( lzr > 1 ) THEN
+ alphashr = 4.0
+ alphamlr = 4.0
+ alphasmlr = alphasmlr0
+ ELSE
+ alphashr = alphar
+ alphamlr = alphar
+ alphasmlr = alphar
+ ENDIF
+! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
+! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
+ massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
+ massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
+ ENDIF
+
+! Find shape parameter rain
+
+ g1shr = 1.0
+ g1mlr = 1.0
+ g1smlr = 1.0
+
+! CALL cld_cpu('Z-MOMENT-1')
+
+ IF ( ipconc >= 6 ) THEN
+
+ ! set base g1x in case rain is not 3-moment
+ IF ( ipconc >= 6 .and. imurain == 3 ) THEN
+ il = lr
+ DO mgs = 1,ngscnt
+! g1x(mgs,il) = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ g1x(mgs,il) = (alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0))
+ ENDDO
+ ENDIF
+
+ IF (lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ g1shr = (alphashr+2.0)/((alphashr+1.0))
+ g1mlr = (alphamlr+2.0)/((alphamlr+1.0))
+ g1smlr = (alphasmlr+2.0)/((alphasmlr+1.0))
+ ELSEIF ( imurain == 1 ) THEN
+! g1shr = 36.*(6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+! & (pi**2*(3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+ g1shr = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ &
+ & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr))
+! g1mlr = 36.*(6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+! & (pi**2*(3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1mlr = (6.0 + alphamlr)*(5.0 + alphamlr)*(4.0 + alphamlr)/ &
+ & ((3.0 + alphamlr)*(2.0 + alphamlr)*(1.0 + alphamlr))
+ g1smlr = (6.0 + alphasmlr)*(5.0 + alphasmlr)*(4.0 + alphasmlr)/ &
+ & ((3.0 + alphasmlr)*(2.0 + alphasmlr)*(1.0 + alphasmlr))
+ ENDIF
+ ENDIF
+
+ IF ( lzr > 1 .and. imurain == 3 ) THEN ! { RAIN SHAPE PARAM
+
+
+! CALL cld_cpu('Z-MOMENT-1r')
+ il = lr
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 THEN
+
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( .false. .and. zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+! alpha(mgs,lr) = 3.
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( (xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) )) THEN
+ tmp = cx(mgs,il)
+ IF ( ioldlimiter >= 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+ IF ( alp >= rnumax - 0.01 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = xdn(mgs,il)*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,lr))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ tmp = alpha(mgs,lr) + 4./3.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ gf1palp(mgs) = y
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
+ IF ( imurain == 3 .and. izwisventr == 2 ) THEN
+
+ tmp = alpha(mgs,lr) + 1.5 + br/6.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+ ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.))
+
+! This whole section is imurain == 3, so this branch never runs
+! ELSEIF ( imurain == 1 .and. iferwisventr == 2 ) THEN
+!
+! tmp = alpha(mgs,lr) + 2.5 + br/2.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrxn(mgs) = x/y
+
+
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+ ENDIF ! }
+
+ ENDIF ! ipconc >= 6
+
+! Find shape parameters for graupel and hail
+ IF ( ipconc .ge. 6 ) THEN
+
+ DO il = lr,lhab
+
+ ! set base values of g1x
+ IF ( (.not. ( il == lr .and. imurain == 3 )) .and. ( il == lr .or. il == lh .or. il == lhl .or. il == lf ) ) THEN
+ DO mgs = 1,ngscnt
+ g1x(mgs,il) = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ ENDDO
+ ENDIF
+
+ IF ( lz(il) .gt. 1 .and. ( .not. ( il == lr .and. imurain == 3 )) ) THEN
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! .or. qx(mgs,il) <= qxmin(il) ) THEN
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ zx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3 ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+ ENDIF
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSE
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ alp = Max( alphamin, Min( alphamax, alp ) )
+
+ IF ( newton ) THEN
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = alp + ( galpha(alp) - rdi )/dgalpha(alp)
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+ ELSE
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+ ENDIF
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( imaxdiaopt == 1 ) THEN
+ xvbarmax = xvmx(il)
+ ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
+ xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
+ xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il))))
+ ELSE
+ xvbarmax = xvmx(il)
+ ENDIF
+
+ IF ( xv(mgs,il) .gt. xvbarmax .or. (il == lr .and. ioldlimiter >= 2 .and. xv(mgs,il) .gt. xvmx(il)/8.)) THEN
+ tmp = cx(mgs,il)
+ IF( ioldlimiter >= 2 .and. il == lr) THEN ! MY-style drop limiter for rain
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE
+ xv(mgs,il) = Min( xvbarmax, Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ IF ( tmp < cx(mgs,il) ) THEN ! artificial breakup has happened, so need to adjust reflectivity and find new shape parameter
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN
+
+
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest ) ) THEN
+! IF ( temcg(mgs) > 0.0 .and. il == lr .and. qx(mgs,lc) > qxmin(lc) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+ ENDIF
+ ENDIF
+
+
+ ! set g1x to use as G factor later. If alpha is in the range ( rnumin < alpha < rnumax ), then
+ ! this will be the same as computing G from alpha. If alpha = rnumax, however, it probably means that
+ ! the moments are not matched correctly, so we compute G from the moments instead so that the dZ/dt rates
+ ! stay consistent with dN/dt and dq/dt.
+! g1x(mgs,il) = zx(mgs,il)*chw*(pi*xdn(mgs,il))**2/(6.*qr*dn(igs(mgs),jy,kgs(mgs)))**2
+! g1x(mgs,il) = g1 ! zx(mgs,il)*cx(mgs,il)/(qr)**2
+ IF ( alp >= alphamax - 0.5 ) THEN
+! g1x(mgs,il) = 6**2*zx(mgs,il)/(cx(mgs,il)*(pi*xv(mgs,lr))**2)
+! g1x(mgs,il) = (xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((rho0(mgs)*qx(mgs,il))**2)
+ g1x(mgs,il) = (pi*xdn(mgs,il))**2*zx(mgs,il)*cx(mgs,il)/((6.*rho0(mgs)*qx(mgs,il))**2)
+ ELSE
+ g1x(mgs,il) = g1
+ ENDIF
+
+ ENDIF
+
+! IF ( ny .eq. 2 ) THEN
+! IF ( qr .gt. 1.e-3 ) THEN
+! write(0,*) 'alphah at nstep,i,k = ',dtp*(nstep-1),igs(mgs),kgs(mgs),alpha(mgs,il),qr*1000.
+! ENDIF
+! ENDIF
+
+
+ ENDIF ! .true.
+
+ IF ( il == lr ) THEN
+
+! tmp = alpha(mgs,lr) + 4./3.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+! tmp = alpha(mgs,lr) + 1.
+! i = Int(dgami*(tmp))
+! del = tmp - dgam*i
+! y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!
+!! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 4./3.)/(alpha(mgs,lr) + 1.)**(1./3.)/Gamma_sp(alpha(mgs,lr) + 1.)
+! ventrx(mgs) = x/(y*(alpha(mgs,lr) + 1.)**(1./3.))
+
- xdn(mgs,lhl) = xdn0(lhl)
- xdntmp(mgs,lhl) = xdn0(lhl)
+ tmp = alpha(mgs,lr) + 1.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- IF ( lvol(lhl) .gt. 1 ) THEN
- IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
+ gf1palp(mgs) = y
- IF ( mixedphase .and. lhlw > 1 ) THEN
- ELSE
- dnmx = xdnmx(lhl)
- ENDIF
+ IF ( iferwisventr == 2 ) THEN
+ tmp = alpha(mgs,lr) + 2.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
- xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
- vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
- xdntmp(mgs,lhl) = xdn(mgs,lhl)
-
- ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
+! ventrx(mgs) = Gamma_sp(alpha(mgs,lr) + 1.5 + br/6.)/Gamma_sp(alpha(mgs,lr) + 1.)
- vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
-
+ ventrxn(mgs) = x/y
+
ENDIF
- ENDIF
-
- ENDIF
+
+ ENDIF ! il==lr
+
+
+ ELSE ! below mass threshold
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+! z1 = g1*rho0(mgs)**2*(qr)*qr/chw
+! z = 1.e18*z1*(6./(pi*1000.))**2
+! z = z1*(6./(pi*1000.))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF ! ( qx(mgs,il) .gt. qxmin(il) )
+
+
+
+! ENDIF
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+
+! IF ( il == lr ) THEN
+! xnutmp = (alpha(mgs,il) - 2.)/3.
+! da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+! ENDIF
+
+ IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN
+! CALL cld_cpu('Z-DELABK')
+ DO mgs = 1,ngscnt
+ IF ( qx(mgs,il) > qxmin(il) ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+
+! IF ( .true. ) THEN
+ DO ic = lc,lh-1 ! lhab
+ IF ( il .ne. ic .and. qx(mgs,ic) .gt. qxmin(ic)) THEN
+ xnuc = xnu(ic)
+ IF ( ic == lc .and. idiagnosecnu > 0 ) xnuc = alpha(mgs,lc) ! alpha for droplets is actually nu
+ IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN
+ IF ( imurain == 3 ) THEN
+ xnuc = alpha(mgs,lr) ! alpha is nu already
+ ELSE
+ xnuc = ( alpha(mgs,lr) - 2. )/3. ! convert alpha to nu
+ ENDIF
+ ENDIF
+ ! delabk(ba,bb,nua,nub,mua,mub,k), where a (il) is collector and b (ic) is collected
+ IF ( .false. ) THEN
+ dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) !dab0(il,ic)
+ dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) !dab1(il,ic)
+ dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+ dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+ ELSE ! use lookup table -- not interpolating yet because table resolution of 0.05 is good enough
+ i = Nint( alpha(mgs,il)*dqiacralphainv )
+ IF ( ic == lc .or. ic == li .or. ic == ls .or. (ic == lr .and. imurain == 3) ) THEN
+ alp = (3.*alpha(mgs,ic) + 2.)
+ j = Nint( (3.*alpha(mgs,ic) + 2.)*dqiacralphainv )
+ ELSE ! IF ( ic == lr .and. imurain == 1 ) ! rain
+ alp = alpha(mgs,ic)
+ j = Nint( alpha(mgs,ic)*dqiacralphainv )
+ ENDIF
+
+ dab0lh(mgs,ic,il) = dab0lu(j,i,ic,il)
+ dab1lh(mgs,ic,il) = dab1lu(j,i,ic,il)
+ dab0lh(mgs,il,ic) = dab0lu(i,j,il,ic)
+ dab1lh(mgs,il,ic) = dab1lu(i,j,il,ic)
+
+! tmp1 = dab0lu(j,i,ic,il)
+! tmp2 = dab1lu(j,i,ic,il)
+! tmp3 = dab0lu(i,j,il,ic)
+! tmp4 = dab1lu(i,j,il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(ic), xmu(il), 1) !dab1(il,ic)
+! tmp5 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) !dab0(il,ic)
+! tmp6 = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) !dab1(il,ic)
+
+ IF ( .false. .and. ny <= 2 ) THEN
+ write(0,*)
+ write(0,*) 'bb: ', bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic)
+ write(0,*) 'il,ic = ',il,ic,alpha(mgs,il),i,xnuc,alp,j
+ write(0,*) 'dab0lh,tmp1 = ',dab0lh(mgs,ic,il),tmp1
+ write(0,*) 'dab1lh,tmp2 = ',dab1lh(mgs,ic,il),tmp2
+ write(0,*) 'dab0lh,tmp3 = ',dab0lh(mgs,il,ic),tmp3,tmp5
+ write(0,*) 'dab1lh,tmp4 = ',dab1lh(mgs,il,ic),tmp4,tmp6
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+ ENDDO
- end do
+! ENDIF
+
+ da0lx(mgs,il) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( il .eq. lh ) THEN
+ da0lh(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxh(mgs) = 1.
+ ELSE
+ rzxh(mgs) = ((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+
+ IF ( lzhl < 1 ) THEN
+ rzxhlh(mgs) = rzxhl(mgs)/(((4. + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr))))
+ ENDIF
+ ELSEIF ( il .eq. lhl ) THEN
+ da0lhl(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ IF ( lzr > 1 ) THEN
+ rzxhl(mgs) = 1.
+ ELSE
+ rzxhl(mgs) = ((4.0 + alpha(mgs,il))*(5. + alpha(mgs,il))*(6. + alpha(mgs,il))*(1. + xnu(lr)))/ &
+ & ((1. + alpha(mgs,il))*(2. + alpha(mgs,il))*(3. + alpha(mgs,il))*(2. + xnu(lr)))
+ ENDIF
+ ELSEIF ( il == lr ) THEN
+ xnutmp = (alpha(mgs,il) - 2.)/3.
+ da0lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 0)
+ da1lr(mgs) = delbk(bb(il), xnutmp, xmu(il), 1)
+ ENDIF
+
+ ENDIF ! ( qx(mgs,il) > qxmin(il) )
+ ENDDO ! mgs
+! CALL cld_cpu('Z-DELABK')
+ ENDIF ! il /= lr
+! CALL cld_cpu('Z-DELABK')
+
+ ENDIF ! lz(il) .gt. 1
+
+ ENDDO ! il
+
+ ENDIF ! ipconc .ge. 6
- IF ( imurain == 3 ) THEN
- IF ( lzr > 1 ) THEN
- alphashr = 0.0
- alphamlr = -2.0/3.0
- ELSE
- alphashr = xnu(lr)
- alphamlr = xnu(lr)
- ENDIF
-! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor
-! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.)
- massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor
- massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) )
- ELSEIF ( imurain == 1 ) THEN
- IF ( lzr > 1 ) THEN
- alphashr = 4.0
- alphamlr = 4.0
- ELSE
- alphashr = alphar
- alphamlr = alphar
- ENDIF
-! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor
-! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.)
- massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor
- massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )
- ENDIF
-
+! CALL cld_cpu('Z-MOMENT-1')
!
! set some values for ice nucleation
@@ -12318,7 +15033,7 @@ subroutine nssl_2mom_gs &
! & itype1a,itype2a,temcg,infdo,alpha)
- infdo = 0
+ infdo = 1
IF ( rimdenvwgt > 0 ) infdo = 1
call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
@@ -12332,9 +15047,9 @@ subroutine nssl_2mom_gs &
IF ( lwsm6 .and. ipconc == 0 ) THEN
tmp = Max(qxmin(lh), qxmin(ls))
DO mgs = 1,ngscnt
- sum = qx(mgs,lh) + qx(mgs,ls)
- IF ( sum > tmp ) THEN
- vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum
+ total = qx(mgs,lh) + qx(mgs,ls)
+ IF ( total > tmp ) THEN
+ vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/total
ELSE
vt2ave(mgs) = 0.0
ENDIF
@@ -12480,6 +15195,17 @@ subroutine nssl_2mom_gs &
+ IF ( ipconc >= 6 ) THEN
+ frac = 0.4d0
+ zxmxd(:,:) = 0.0
+ DO il = lr,lhab
+ IF ( lz(il) > 0 .or. ( il == lr ) ) THEN
+ DO mgs = 1,ngscnt
+ zxmxd(mgs,il) = frac*zx(mgs,il)*dtpinv
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDIF
@@ -12517,10 +15243,10 @@ subroutine nssl_2mom_gs &
vshdgs(mgs,il) = vshd ! base value
- IF ( qx(mgs,il) > qxmin(il) ) THEN
+ IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN
! tmpdiam is weighted diameter of d^(shedalp-1), so for shedalp=3, this is the area-weighted diameter or maximum mass diameter.
- tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015
+ tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1) ! *( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015
IF ( tmpdiam > sheddiam0 ) THEN
vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice
@@ -12577,13 +15303,13 @@ subroutine nssl_2mom_gs &
ers(mgs) = 0.0
ess(mgs) = 0.0
ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn
+ ehsfac(mgs) = 1.0 ! factor based on ice saturation
ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn
ehscnv(mgs) = 0.0
! ehxs(mgs) = 0.0
!
eiw(mgs) = 0.0
eii(mgs) = 0.0
-
ehsclsn(mgs) = 0.0
ehiclsn(mgs) = 0.0
ehlsclsn(mgs) = 0.0
@@ -12678,7 +15404,7 @@ subroutine nssl_2mom_gs &
if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then
- if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then
+ if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then
! erm 5/10/2007 test following change:
! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then
eiw(mgs) = 0.5
@@ -12802,7 +15528,7 @@ subroutine nssl_2mom_gs &
ELSE
fac = Abs(ess0)
- IF ( .true. .and. ess0 < 0.0 ) THEN
+ IF ( iessopt == 2 ) THEN ! experimental code
! IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN
IF ( wvel(mgs) > 2.0 ) THEN
! assume convective cell or downdraft
@@ -12810,9 +15536,25 @@ subroutine nssl_2mom_gs &
ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
fac = Max(0.0, 2.0 - wvel(mgs))*fac
ENDIF
+ ELSEIF ( iessopt == 3 ) THEN ! factor based on ice supersat
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.0
+ ehsfac(mgs) = 0.0
+ ELSEIF ( ssi(mgs) <= 1.02 ) THEN
+ fac = fac*(ssi(mgs) - 1.0)/0.02
+ ehsfac(mgs) = (ssi(mgs) - 1.0)/0.02
+ ENDIF
+ ELSEIF ( iessopt == 4 ) THEN ! factor based on ice supersat; very roughly based on Hosler et al. 1957 (J. Met.)
+ IF ( ssi(mgs) <= 1.0 ) THEN
+ fac = 0.1
+ ehsfac(mgs) = 0.1
+ ELSEIF ( ssi(mgs) <= 1.005 ) THEN
+ fac = Max(0.1, fac*(ssi(mgs) - 1.0)/0.005)
+ ehsfac(mgs) = Max(0.1, (ssi(mgs) - 1.0)/0.005)
+ ENDIF
ENDIF
- IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25
+ IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > esstem1
ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2
ELSEIF ( temcg(mgs) >= esstem2 ) THEN
ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) )
@@ -12923,7 +15665,11 @@ subroutine nssl_2mom_gs &
ELSE
ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0))
ENDIF
- if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then
+
+ IF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) THEN
+! ehsclsn(mgs) = ehs_collsn
+! ehs(mgs) = ehscnv(mgs)*ehsfac(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. )
+! ELSEIF ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) >= qxmin(lc) ) then
ehsclsn(mgs) = ehs_collsn
IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN
ehsclsn(mgs) = 0.0
@@ -12933,10 +15679,9 @@ subroutine nssl_2mom_gs &
ehsclsn(mgs) = ehs_collsn
ENDIF
! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density
- ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density
+ ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density; limits scavenging of snow in bright band
! ehs(mgs) = ehscnv(mgs) ! *Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density
ehs(mgs) = Min(ehs(mgs),ehsmax)
- IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0
end if
ENDIF
!
@@ -12944,7 +15689,7 @@ subroutine nssl_2mom_gs &
ehiclsn(mgs) = ehi_collsn
ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) )
- if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
end if
IF ( lis > 1 ) THEN
@@ -12952,7 +15697,7 @@ subroutine nssl_2mom_gs &
ehisclsn(mgs) = ehi_collsn
ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) )
- if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
+! if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
end if
ENDIF
@@ -13089,6 +15834,7 @@ subroutine nssl_2mom_gs &
end do
+
!
!
!
@@ -13162,6 +15908,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qraci(mgs) = 0.0
craci(mgs) = 0.0
+ qracs(mgs) = 0.0
IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN
IF ( ipconc .ge. 3 ) THEN
@@ -13207,8 +15954,9 @@ subroutine nssl_2mom_gs &
ENDIF
end do
!
+ IF ( ipconc < 3 ) THEN
do mgs = 1,ngscnt
- qracs(mgs) = 0.0
+ qracs(mgs) = 0.0
IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
IF ( lwsm6 .and. ipconc == 0 ) THEN
vt = vt2ave(mgs)
@@ -13225,6 +15973,7 @@ subroutine nssl_2mom_gs &
& , qsmxd(mgs))
ENDIF
end do
+ ENDIF
!
!
@@ -13371,6 +16120,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
qhacw(mgs) = 0.0
+ qhacwmlr(mgs) = 0.0
rarx(mgs,lh) = 0.0
vhacw(mgs) = 0.0
vhsoak(mgs) = 0.0
@@ -13437,6 +16187,11 @@ subroutine nssl_2mom_gs &
ENDIF
+ qhacwmlr(mgs) = qhacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhacwshr == 0 ) THEN
+ qhacw(mgs) = 0.0
+ ENDIF
+
IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
IF ( temg(mgs) .lt. 273.15) THEN
@@ -13466,14 +16221,18 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lh) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
tmp = (-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
& *( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) &
& /(temg(mgs)-273.15))
! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
- rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -13687,6 +16446,7 @@ subroutine nssl_2mom_gs &
do mgs = 1,ngscnt
qhlacw(mgs) = 0.0
+ qhlacwmlr(mgs) = 0.0
vhlacw(mgs) = 0.0
vhlsoak(mgs) = 0.0
IF ( lhl > 1 .and. .true.) THEN
@@ -13715,10 +16475,15 @@ subroutine nssl_2mom_gs &
qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)*dtpinv )
+ qhlacwmlr(mgs) = qhlacw(mgs)
+ IF ( temg(mgs) > tfr .and. iqhlacwshr == 0 ) THEN
+ qhlacw(mgs) = 0.0
+ ENDIF
+
IF ( lvol(lhl) .gt. 1 ) THEN
IF ( temg(mgs) .lt. 273.15) THEN
- IF ( irimdenopt == 1 ) THEN ! Rasmussen and Heymsfeld (1985)
+ IF ( irimdenopt == 1 ) THEN ! Heymsfeld and Pflaum (1985)
rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) &
& *((0.60)*( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) )) &
& /(temg(mgs)-273.15))**(rimc2)
@@ -13732,13 +16497,17 @@ subroutine nssl_2mom_gs &
rimdn(mgs,lhl) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2)
- ELSEIF ( irimdenopt == 3 ) THEN ! Macklin
+ ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN ! Macklin (3) or Saunders and Hosseini 2001
tmp = -0.5*(1.e+06)*xdia(mgs,lc,1) &
& *( (1.0-rimdenvwgt)*vtxbar(mgs,lhl,1) + rimdenvwgt*vtxbar(mgs,lhl,2) ) &
& /(temg(mgs)-273.15)
! tmp = Min( 5.5/0.6, Max( 0.3/0.6, tmp ) )
- rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ IF ( irimdenopt == 3 ) THEN
+ rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) )
+ ELSEIF ( irimdenopt == 4 ) THEN ! Saunders and Hosseini
+ rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) )
+ ENDIF
ENDIF
ELSE
@@ -14053,7 +16822,7 @@ subroutine nssl_2mom_gs &
frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow)))
qiacrs(mgs) = (1.-frach)*qiacr(mgs)
- ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs)
+ ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ! *rzxh(mgs)
ENDIF
ENDIF
@@ -14083,7 +16852,7 @@ subroutine nssl_2mom_gs &
tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) ! fraction of max snow mass
IF ( tmp .lt. essfrac1 ) THEN
ec0(mgs) = 1.0
- ELSEIF ( tmp .gt. essfrac2 ) THEN
+ ELSEIF ( tmp .ge. essfrac2 ) THEN
ec0(mgs) = 0.0
ELSE
ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1)
@@ -14160,7 +16929,21 @@ subroutine nssl_2mom_gs &
ec0(mgs) = 2.e9
IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
rwrad = 0.5*xdia(mgs,lr,3)
- IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
+
+
+ ! check median volume diameter
+ IF ( icracrthresh > 1 ) THEN
+ IF ( imurain == 1 ) THEN
+ tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ! median volume diameter; units of mm (Ulbrich 1983, JCAM)
+ ELSE ! imurain == 3,
+ tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ! units of mm (using method of Ulbrich 1983. See ventillation_stuff.nb)
+ ENDIF
+ ELSE
+ tmp = xdia(mgs,lr,3) - 0.1e-3
+ ENDIF
+
+! IF ( xdia(mgs,lr,3) .gt. 2.0e-3 .or. icracr <= 0 ) THEN
+ IF ( tmp .gt. 1.9e-3 .or. icracr <= 0 ) THEN
ec0(mgs) = 0.0
cracr(mgs) = 0.0
ELSE
@@ -14242,6 +17025,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
chaci(:) = 0.0
+ chaci0(:) = 0.0
if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
do mgs = 1,ngscnt
IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
@@ -14292,6 +17076,7 @@ subroutine nssl_2mom_gs &
!
if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
chacs(:) = 0.0
+ chacs0(:) = 0.0
if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
do mgs = 1,ngscnt
IF ( ehs(mgs) .gt. 0 ) THEN
@@ -14451,7 +17236,7 @@ subroutine nssl_2mom_gs &
! Ziegler (1985) autoconversion
!
!
- IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion
+ IF ( ipconc .ge. 2 ) THEN
if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
DO mgs = 1,ngscnt
@@ -14534,6 +17319,47 @@ subroutine nssl_2mom_gs &
IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0
+ IF ( ipconc >= 6 ) THEN
+ IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs))
+! zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2)
+ ! DTD: If rain exists at a grid point already either use the alpha-preserving Z-rate eqn. (dmrauto == 1)
+ ! or a mass-weighted average of the alpha-preserving Z-rate eqn. and the init. rate eqn. (dmrauto == 2)
+ ! or the original initiation rate equation (dmrauto == 0). Not sure if this is the correct way to go but seems to work ok.
+ IF (qx(mgs,lr) .gt. qxmin(lr) .and. ( dmrauto == 1 .or. dmrauto ==2 ) ) THEN
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ tmp4 = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ if (imurain == 3) then
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.)
+ tmp3 = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ else
+ tmp3 = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ endif
+ IF ( dmrauto == 1 ) THEN ! Preserve alpha
+ zrcnw(mgs) = tmp4
+ ELSEIF ( dmrauto == 2 ) THEN ! Mass-weighted average
+ zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
+ ENDIF
+ else ! original formulation
+ IF ( imurain == 3 ) THEN
+ vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+ zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ELSE ! rain in gamma of diameter
+ IF ( dmropt <= 1 .or. dmropt >= 4 .or. ( qx(mgs,lr) < qxmin(lr) .and. cx(mgs,lr) < cxmin ) ) THEN
+ zrcnw(mgs) = galpharaut*(6.*rho0(mgs)*qrcnw(mgs)/(pi*xdn0(lr)))**2/crcnw(mgs)
+ ELSE
+ tmp3 = qx(mgs,lr)/cx(mgs,lr)
+ zrcnw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*tmp3 * qrcnw(mgs) - tmp3**2 * crcnw(mgs) )
+ ENDIF
+! vr = rho0(mgs)*qrcnw(mgs)/(1000.) ! crcnw(mgs) not divided here but is in next line, cancels one factor in the numerator
+! zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
+ ENDIF
+ endif
+! z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ ENDIF
+ ENDIF ! ipconc >= 6
! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
! : THEN
! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
@@ -14744,6 +17570,15 @@ subroutine nssl_2mom_gs &
ELSE !{
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ ENDIF
IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
! IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < xvbiggsnow .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
@@ -14753,6 +17588,10 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrz(mgs)
qrfrzs(mgs) = qrfrz(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
ELSEIF ( dbigg < Max( biggsnowdiam, Max(dfrz,dhmn)) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone!
@@ -14764,6 +17603,10 @@ subroutine nssl_2mom_gs &
crfrzf(mgs) = 0.0
qrfrzf(mgs) = 0.0
+ IF (ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ zrfrzf(mgs) = 0.
+ ENDIF
ELSE !{
! recalculate using dhmn for ratio
@@ -14803,10 +17646,23 @@ subroutine nssl_2mom_gs &
crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrzs(mgs) = zrfrz(mgs)
+ ! interpolate along x, i.e., ratio;
+ tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j))
+ tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1))
+
+ ! interpolate along alpha;
+
+ zrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr)*dtpinv
+ zrfrzs(mgs) = zrfrzs(mgs) - zrfrzf(mgs)
+ zrfrzf(mgs) = (1000./900.)**2*zrfrzf(mgs)
+ ENDIF
ENDIF ! }
ELSE
crfrzs(mgs) = 0.0
qrfrzs(mgs) = 0.0
+ zrfrzs(mgs) = 0.0
ENDIF ! }
ENDIF !}
@@ -14819,6 +17675,10 @@ subroutine nssl_2mom_gs &
crfrz(mgs) = fac*crfrz(mgs)
crfrzs(mgs) = fac*crfrzs(mgs)
crfrzf(mgs) = fac*crfrzf(mgs)
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN
+ zrfrz(mgs) = fac*zrfrz(mgs)
+ zrfrzf(mgs) = fac*zrfrzf(mgs)
+ ENDIF
ENDIF
ENDIF !}
@@ -15363,8 +18223,16 @@ subroutine nssl_2mom_gs &
x = 1. + alpha(mgs,lr)
- IF ( lzr > 1 ) THEN ! 3 moment
-!
+ IF ( ipconc >= 6 .and. lzr > 1 ) THEN ! 3 moment
+ tmp = 1. + alpr ! alpha(mgs,lr)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+ tmp = 2.5 + alpha(mgs,lr) + 0.5*bx(lr)
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
ELSE
y = ventrxn(mgs)
ENDIF
@@ -15380,6 +18248,13 @@ subroutine nssl_2mom_gs &
& 0.308*fvent(mgs)*y* &
& Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+ rwventz(mgs) = 0.0
+
+! rwventz(mgs) = &
+! & 0.78*x + &
+! & 0.308*fvent(mgs)*y* &
+! & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+
ELSEIF ( iferwisventr == 2 ) THEN
@@ -15392,6 +18267,23 @@ subroutine nssl_2mom_gs &
& *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+ IF ( ipconc >= 7 ) THEN
+ alpr = Min(alpharmax,alpha(mgs,lr) )
+
+ tmp = alpr + 5.5 + br/2.
+ i = Int(dgami*(tmp))
+ del = tmp - dgam*i
+ y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+! rwventz(mgs) = &
+! & 0.78*(4. + alpha(mgs,lr))*(3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)) + &
+ rwventz(mgs) = &
+ & 0.78*(4. + alpr)*(3. + alpr)*(2. + alpr)*(1. + alpr) + &
+ & 0.308*fvent(mgs)* &
+ & Sqrt(ax(lr)*rhovt(mgs))*(y/gf1palp(mgs))*(xdia(mgs,lr,1)**((1.0+br)/2.0))
+
+ ENDIF
+
ENDIF ! iferwisventr
@@ -15434,6 +18326,9 @@ subroutine nssl_2mom_gs &
hwventa = (0.78)*gmoi(igmhwa)
hwventb = (0.308)*gmoi(igmhwb)
! hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25)
+ hwvent(:) = 0.0
+ hwventy(:) = 0.0
+
do mgs = 1,ngscnt
IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN
hwventc = (4.0*gr/(3.0*cdxgs(mgs,lh)))**(0.25)
@@ -15554,6 +18449,8 @@ subroutine nssl_2mom_gs &
& -ftka(mgs)*temcg(mgs)/rho0(mgs) ) &
& / (felf(mgs))
fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
+ fmlt1e(mgs) = (2.0*pi)* &
+ & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) ) / (felf(mgs))
end do
!
! Vapor Deposition constants
@@ -15581,6 +18478,7 @@ subroutine nssl_2mom_gs &
qhlmlrlg(:) = 0.0
ENDIF
qhfzh(:) = 0.0
+ qffzf(:) = 0.0
qhlfzhl(:) = 0.0
qhfzhlg(:) = 0.0
qhlfzhllg(:) = 0.0
@@ -15588,9 +18486,10 @@ subroutine nssl_2mom_gs &
vffzf(:) = 0.0
vhlfzhl(:) = 0.0
qsfzs(:) = 0.0
- zsmlr(:) = 0.0
+! zsmlr(:) = 0.0
zhmlr(:) = 0.0
zhmlrr(:) = 0.0
+ zsmlrr(:) = 0.0
zhshr(:) = 0.0
zhlmlr(:) = 0.0
zhlshr(:) = 0.0
@@ -15642,7 +18541,7 @@ subroutine nssl_2mom_gs &
qhmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) &
- & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) &
+ & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) &
& , 0.0 )
ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
@@ -15674,13 +18573,13 @@ subroutine nssl_2mom_gs &
qhlmlr(mgs) = &
& meltfac*min( &
& fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) &
- & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) &
+ & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) &
& , 0.0 )
ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results
-! #ifdef Z3MOM
-! #if (defined Z3MOM) && defined( COMMAS ) || defined( COMMASTMP )
+! #ifdef 1
+! #if (defined 1) && defined( COMMAS ) || defined( COMMASTMP )
ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results
@@ -15711,7 +18610,7 @@ subroutine nssl_2mom_gs &
chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) )
ENDIF
! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)*dtpinv ) !limits to 1/2 qh or max depletion
- qhmlh(mgs) = 0.
+ qhmlh(mgs) = 0. ! not used
! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding
@@ -15788,8 +18687,15 @@ subroutine nssl_2mom_gs &
! ENDIF
-
IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN ! { already done if ibinhmlr > 0
+ IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN ! Only compute if rain is 3-moment but graupel is not, otherwise is computed later
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = alpha(mgs,lh)
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+
+ ENDIF
IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN
IF ( ihmlt .eq. 1 ) THEN
@@ -15895,6 +18801,17 @@ subroutine nssl_2mom_gs &
ENDIF !}
+ IF ( ipconc >= 8 .and. lzhl .gt. 1 .and. ibinhlmlr <= 0 ) THEN
+ IF ( cx(mgs,lhl) > 0.0 ) THEN
+
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = alpha(mgs,lhl)
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) )
+ ENDIF
+ ENDIF
ENDIF ! }
ENDIF ! }.not. mixedphase
@@ -15932,6 +18849,7 @@ subroutine nssl_2mom_gs &
ENDDO
!
!
+ qhdsv(:) = 0.0
qhldsv(:) = 0.0
do mgs = 1,ngscnt
@@ -15941,6 +18859,7 @@ subroutine nssl_2mom_gs &
& fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac
qsdsv(mgs) = &
& fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac
+
! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN
! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
@@ -16177,20 +19096,41 @@ subroutine nssl_2mom_gs &
! end of qlimit
+ qhcev(:) = 0.0
+ chcev(:) = 0.0
+ qhlcev(:) = 0.0
+ chlcev(:) = 0.0
+ qfcev(:) = 0.0
+
do mgs = 1,ngscnt
qisbv(mgs) = 0.0
qssbv(mgs) = 0.0
qidpv(mgs) = 0.0
qsdpv(mgs) = 0.0
+ qhsbv(mgs) = 0.0
+ qscev(mgs) = 0.0
+ cscev(mgs) = 0.0
IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh &
- & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
+ & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! last condition (qr qxmin(lh) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN
+ ! no liquid from melting, so evaporation is greater. Thus can calculate sublimation rate
qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) )
-
qhdpv(mgs) = Max(qhdsv(mgs), 0.0)
+ ENDIF
+
+ IF ( .true. .and. qhmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+! qhcev(mgs) = &
+! & evapfac*min( &
+! & fmlt1e(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1), 0.0 )
+
+ qhcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lh)*xdia(mgs,lh,1)*hwvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhcev(mgs) = max(qhcev(mgs), -qhmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhcev(mgs) = Min(0.0, qhcev(mgs) )
+
+ ENDIF
+ ENDIF
qhlsbv(mgs) = 0.0
qhldpv(mgs) = 0.0
IF ( lhl .gt. 1 ) THEN
+ IF ( qx(mgs,lhl) > qxmin(lhl) ) THEN
+ IF ( temg(mgs) < tfr .or. .not. qhlmlr(mgs) < 0.0 ) THEN
qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
qhldpv(mgs) = Max(qhldsv(mgs), 0.0)
+ ENDIF
+ IF ( qhlmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN
+ ! Liquid is forming, so find the evaporation that was subtracted from melting (if it is not condensing)
+ qhlcev(mgs) = evapfac*2.0*pi*(qx(mgs,lv)-qss0(mgs))* &
+ & cx(mgs,lhl)*xdia(mgs,lhl,1)*hlvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs)))
+
+ qhlcev(mgs) = max(qhlcev(mgs), -qhlmxd(mgs))
+ IF ( temg(mgs) > tfr ) qhlcev(mgs) = Min(0.0, qhlcev(mgs) )
+
+ ENDIF
+ ENDIF
ENDIF
temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)
@@ -16345,6 +19318,10 @@ subroutine nssl_2mom_gs &
end if
end do
+
+
+
+
!
!
! compute dry growth rate of snow, graupel, and hail
@@ -16371,7 +19348,7 @@ subroutine nssl_2mom_gs &
!
do mgs = 1,ngscnt
- IF ( temg(mgs) < tfr ) THEN
+ IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) THEN
!
! qswet(mgs) =
! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs)
@@ -16382,31 +19359,39 @@ subroutine nssl_2mom_gs &
! IF ( dnu(lh) .ne. 0. ) THEN
! qhwet(mgs) = qhdry(mgs)
! ELSE
+ IF ( incwet == 0 ) THEN
qhwet(mgs) = &
& ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) &
& + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) )
qhwet(mgs) = max( 0.0, qhwet(mgs))
+ ELSE
+ ENDIF
+
! ENDIF
qhlwet(mgs) = 0.0
IF ( lhl .gt. 1 ) THEN
- qhlwet(mgs) = &
- & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) &
- & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
- qhlwet(mgs) = max( 0.0, qhlwet(mgs))
+ IF ( incwet == 0 ) THEN
+ qhlwet(mgs) = &
+ & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) &
+ & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) )
+ qhlwet(mgs) = max( 0.0, qhlwet(mgs))
+
+ ELSE
+ ENDIF ! incwet
ENDIF
ELSE
qhwet(mgs) = qhdry(mgs)
qhlwet(mgs) = qhldry(mgs)
-
ENDIF
!
! qhlwet(mgs) = qhldry(mgs)
end do
+
!
! shedding rate
!
@@ -16466,7 +19451,7 @@ subroutine nssl_2mom_gs &
qhshr(mgs) = -qhdry(mgs)
qhlshr(mgs) = -qhldry(mgs)
ELSE ! new and correct
-
+ ! note that the qxacr terms should be zero here, so shedding at T > 0 is all from the droplets
qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) ! -qsdry(mgs)
qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) ! -qhldry(mgs)
qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ! -qhdry(mgs)
@@ -16802,7 +19787,93 @@ subroutine nssl_2mom_gs &
ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ! test on mass-weighted diameter
ENDIF
- dg0(mgs) = -1.
+ IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN
+ dg0(mgs) = -1.
+ ELSE
+ IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 &
+ .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+! dw = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*ehw(mgs)*qx(mgs,lc) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+! dwr = 0.01*( Exp( -temcg(mgs)/( 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+! 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0 ) ) - 1.0 )
+ x = 1.1e4 * rho0(mgs)*(ehw(mgs)*qx(mgs,lc)+ehr(mgs)*qx(mgs,lr)) - &
+ 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0
+ IF ( x > 1.e-20 ) THEN
+ arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit
+ dwr = 0.01*(exp(arg) - 1.0)
+ ELSE
+ dwr = 1.e30
+ ENDIF
+ d = dwr
+ IF ( dwr < 0.2 .and. dwr > 0.0 .and. rho0(mgs)*(qx(mgs,lc)+qx(mgs,lr)) > 1.e-4 ) THEN
+ sqrtrhovt = Sqrt( rhovt(mgs) )
+ fventh = sqrtrhovt*(fpndl(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ fventm = sqrtrhovt*(fschm(mgs)**(1./3.)) * (fakvisc(mgs))**(-0.5)
+ ltemq = (tfr-163.15)/fqsat+1.5
+ qvs0 = pqs(mgs)*tabqvs(ltemq)
+ denomdp = felf(mgs) + fcw(mgs)*temcg(mgs)
+ denominvdp = 1.d0/(felf(mgs) + fcw(mgs)*temcg(mgs))
+
+! write(91,*) 'dw,dwr,temcg = ',100.*dw,100.*dwr,temcg(mgs)
+ h1 = ( -ftka(mgs)*temcg(mgs) - felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qx(mgs,lv) - qvs0) )
+ h2 = ehi(mgs)*qx(mgs,li)*rho0(mgs)*fci(mgs)*temcg(mgs)
+ h3 = Max(dwehwmin, ehw(mgs))*qx(mgs,lc)
+ h4 = ehr(mgs)* qx(mgs,lr)
+ ! iterate to find minimum diameter for wet growth. Start with value of dwr
+ DO n = 1,10
+ d = Max(d, 1.e-4)
+ dold = d
+ vth = axx(mgs,lh)*d**bxx(mgs,lh)
+ x2 = fventh*sqrtrhovt*Sqrt(d*vth)
+ IF ( x2 > 1.4 ) THEN
+ ah = 0.78 + 0.308*x2 ! heat ventillation
+ ELSE
+ ah = 1.0 + 0.108*x2**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ IF ( .false. ) THEN ! this option includes 'am' separate from ah, which makes only small differences. Otherwise equivalent to second option
+ x1 = fventm*sqrtrhovt*Sqrt(d*vth)
+ IF ( x1 > 1.4 ) THEN
+ am = 0.78 + 0.308*x1 ! mass ventillation (Beard and Pruppacher 1971, eq. 8)
+ ELSE
+ am = 1.0 + 0.108*x1**2 ! mass ventillation (Beard and Pruppacher 1971, eq. 9)
+ ENDIF
+
+ d = 8.*denominvdp*( am*felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qvs0 - qx(mgs,lv)) - ah*ftka(mgs)*temcg(mgs) )/ &
+ (dtp* ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs) + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2*denominvdp))
+
+ ELSE
+
+ ! Based on Farley and Orville (1986), eq. 5-9 but neglecting the Ci*(T0-Ts) term in (8) since we want Ts=T0
+ ! Simplified mass rates as dm_w/dt = pi/4*d**2*(Vh - Vc)*rhoair*qc*ehw, etc.
+ d = 8.*ah*h1/ &
+ ( ( Max(0.001,vth - vtxbar(mgs,lc,1))*h3 + &
+ Max(0.001,vth - vtxbar(mgs,lr,1))*h4) *rho0(mgs)*denomdp + &
+ Max(0.001,vth - vtxbar(mgs,li,1))*h2)
+
+ ENDIF
+ IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT
+
+ ENDDO
+ ENDIF
+
+ dg0(mgs) = Min( dwmax, Max( d, dwmin ) )
+ ELSE
+ IF ( qx(mgs,lh) > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. temg(mgs) .le. tfr-2.0 ) THEN
+ dg0(mgs) = dwmax
+ ELSE
+ dg0(mgs) = dg0thresh + 0.0001
+ ENDIF
+ ENDIF
+
+ IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin &
+ .and. temg(mgs) .le. tfr-2.0 ) THEN
+ ! set a secondary condition on to capture large graupel that is riming but not in wet growth
+ dg0(mgs) = Min( dg0(mgs), dg0thresh - 0.0001 )
+ ENDIF
+
+ ENDIF
wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh )
@@ -16837,18 +19908,6 @@ subroutine nssl_2mom_gs &
tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs)
! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp)
-! IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN
-! hdia1 = Max(dh0, xdia(mgs,lh,3) )
-! qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, &
-! & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) &
-! & *exp(-hdia1/xdia(mgs,lh,1)) &
-! & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) &
-! & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) )
-
-! ENDIF
-
-! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
-! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) )
qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp )
IF ( ipconc .ge. 5 ) THEN !{
@@ -16858,8 +19917,6 @@ subroutine nssl_2mom_gs &
chlcnhhl(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) )
r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter
-! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r )
-! chlcnh(mgs) = Min( chlcnh(mgs), r )
chlcnh(mgs) = Max( chlcnhhl(mgs), r )
ENDIF !}
@@ -16874,12 +19931,119 @@ subroutine nssl_2mom_gs &
ELSEIF ( ihlcnh == 3 ) THEN !{
+ IF ( wtest .and. &
+ ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > hlcnhqmin ) ) THEN
+ ! convert number, mass, and reflectivity for d > dw
+ IF ( ipconc == 5 ) THEN
+ ! dg0(mgs) = Min( dg0(mgs), hldia1 )
+ !dg0(mgs) = hldia1
+ ENDIF
+
+ ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) )
+
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp2 = Min( 0.25, tmp2 )
+ ENDIF
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+ flim = 1.0
+ tmp3 = qxmxd(mgs,lh)
+ IF (qxd1 > tmp3 ) THEN
+! flim = tmp3/(qxd1)
+! qhlcnh(mgs) = flim*qhlcnh(mgs)
+ ENDIF
+
+
+
+ IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ IF ( ipconc == 5 ) THEN
+ ! tmp = Min( 0.2, tmp )
+ ENDIF
+ cxd1 = flim*cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ IF ( qx(mgs,lhl) > qxmin(lhl) .and. dmhlopt > 0 ) THEN
+ tmp = rho0(mgs)*qhlcnh(mgs)/chlcnhhl(mgs)
+ IF ( tmp < xmas(mgs,lhl) ) THEN
+ ! dh0 = ( qxd1*dh0 + qx(mgs,lhl)*xmas(mgs,lhl))/( qxd1 + qx(mgs,lhl)) ! weighted average
+ dh0 = (( qxd1*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 ! weighted average
+ chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 )
+ ELSE
+! dh0 = Max( dh0, xmas(mgs,lhl) ) ! when enough hail is established, do not dilute the size
+ ENDIF
+ ENDIF
+
+
+ ! reflectivity
+ IF ( ipconc >= 6 .and. lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = flim*zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+
+ ELSE
+ qhlcnh(mgs) = 0.0
+ ENDIF
+
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+
ENDIF !}
ENDDO
ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion
+!
+! Staka and Mansell (2005) type conversion
+!
+! hldia1 is set in micro_module and namelist
+! IF ( .true. ) THEN
+
+ ! convert number, mass, and reflectivity for d > hldia1,
+ ! regardless of wet growth status, but as long as riming > 0
+ DO mgs = 1,ngscnt
+ IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr-2. .and. qx(mgs,lh) > qxmin(lh) ) THEN
+ ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) )
+
+ ! number
+ tmp = gaminterp(ratio,alpha(mgs,lh),1,1)
+ cxd1 = cx(mgs,lh)*( tmp)
+ chlcnh(mgs) = dtpinv*cxd1
+ chlcnhhl(mgs) = chlcnh(mgs)
+
+ ! mass
+ tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1)
+ qxd1 = qx(mgs,lh)*(tmp2)
+ qhlcnh(mgs) = dtpinv*qxd1
+
+ ! reflectivity
+ IF ( lzh > 1 .and. lzhl > 1 ) THEN
+ tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1)
+ zxd1 = zx(mgs,lh)*(tmp3)
+ zhlcnh(mgs) = dtpinv*zxd1
+ ELSE
+ zxd1 = 0
+ ENDIF
+ vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh)
+ vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh))
+
+ ENDIF
+
+ ENDDO
+! ENDIF
ELSEIF ( ihlcnh == 0 ) THEN
do mgs = 1,ngscnt
@@ -17115,6 +20279,10 @@ subroutine nssl_2mom_gs &
ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs)
ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs)
+! IF ( lzh .gt. 1 ) THEN
+! zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+! ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+! ENDIF
vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs)
viacrf(mgs) = qrzfac(mgs)*viacrf(mgs)
@@ -17154,7 +20322,13 @@ subroutine nssl_2mom_gs &
IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN
! qrcev(mgs) = -qrmxd(mgs)
! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs)
- crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
+ IF ( icrcev == 1 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
+ ELSEIF ( icrcev == 2 ) THEN
+ crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)*vtxbar(mgs,lr,2)/vtxbar(mgs,lr,1)
+ ELSE
+ crcev(mgs) = 0.0
+ ENDIF
ELSE
crcev(mgs) = 0.0
ENDIF
@@ -17166,12 +20340,6 @@ subroutine nssl_2mom_gs &
!
! evaporation/condensation of wet graupel and snow
!
- qscev(:) = 0.0
- cscev(:) = 0.0
- qhcev(:) = 0.0
- chcev(:) = 0.0
- qhlcev(:) = 0.0
- chlcev(:) = 0.0
IF ( lhwlg > 1 ) THEN
qhcevlg(:) = 0.0
chcevlg(:) = 0.0
@@ -17181,6 +20349,7 @@ subroutine nssl_2mom_gs &
chlcevlg(:) = 0.0
ENDIF
+
!
!
!
@@ -18128,6 +21297,14 @@ subroutine nssl_2mom_gs &
pqlwlghld(:) = 0.0
pqlwhli(:) = 0.0
pqlwhld(:) = 0.0
+ IF ( ipconc > 5 ) THEN
+ pzhwi(:) = 0.0
+ pzhwd(:) = 0.0
+ pzrwi(:) = 0.0
+ pzrwd(:) = 0.0
+ pzhli(:) = 0.0
+ pzhld(:) = 0.0
+ ENDIF
!
@@ -18366,7 +21543,8 @@ subroutine nssl_2mom_gs &
qrcev(mgs) = frac*qrcev(mgs)
qhlacr(mgs) = frac*qhlacr(mgs)
vhlacr(mgs) = frac*vhlacr(mgs)
-! qhcev(mgs) = frac*qhcev(mgs)
+ qhcev(mgs) = frac*qhcev(mgs)
+ qhlcev(mgs) = frac*qhlcev(mgs)
IF ( warmonly < 0.5 ) THEN
@@ -18412,6 +21590,8 @@ subroutine nssl_2mom_gs &
! STOP
ENDIF
+
+
end do
IF ( warmonly < 0.5 ) THEN
@@ -18440,7 +21620,7 @@ subroutine nssl_2mom_gs &
& -qhcns(mgs) &
& +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included
! > +il5(mgs)*(qssbv(mgs)) &
- & + (qssbv(mgs)) &
+ & + qssbv(mgs) &
& + Min(0.0, qscev(mgs)) &
& -qsmul(mgs)
@@ -18555,53 +21735,634 @@ subroutine nssl_2mom_gs &
& +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included
end do
-!
-! Hail
-!
- IF ( lhl .gt. 1 ) THEN
+!
+! Hail
+!
+ IF ( lhl .gt. 1 ) THEN
+
+ do mgs = 1,ngscnt
+ pqhli(mgs) = &
+ & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) &
+ & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) &
+ & +qhlacr(mgs)+qhlacw(mgs) &
+! & +qhlacs(mgs)+qhlaci(mgs) &
+ & + qhlcnh(mgs)
+ pqhld(mgs) = &
+ & qhlshr(mgs) &
+ & +(1-il5(mgs))*qhlmlr(mgs) &
+! > +il5(mgs)*qhlsbv(mgs) &
+ & + qhlsbv(mgs) &
+ & -qhlmul1(mgs) - qhcnhl(mgs)
+
+ end do
+
+ ENDIF ! lhl
+
+ ENDIF ! warmonly
+
+!
+! Liquid water on snow and graupel
+!
+
+ vhmlr(:) = 0.0
+ vhlmlr(:) = 0.0
+ vhfzh(:) = 0.0
+ vhlfzhl(:) = 0.0
+
+ IF ( mixedphase ) THEN
+ ELSE ! set arrays for non-mixedphase graupel
+
+! vhshdr(:) = 0.0
+ vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
+! vhsoak(:) = 0.0
+
+! vhlshdr(:) = 0.0
+ vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
+! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl)
+! vhlsoak(:) = 0.0
+
+ ENDIF ! mixedphase
+
+
+
+!
+! Graupel reflectivity
+!
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity'
+
+ do mgs = 1,ngscnt
+
+! zhmlr(mgs) = 0.0
+! zhshr(mgs) = 0.0
+! zhmlrr(mgs) = 0.0
+! zhshrr(mgs) = 0.0
+ zhdsv(mgs) = 0.0
+! IF ( lf < 1 ) THEN
+ IF ( ffrzh > 0.0 ) THEN
+ ziacr(mgs) = 0.0
+ ziacrf(mgs) = 0.0
+ ENDIF
+! ENDIF
+ zhcns(mgs) = 0.0
+ zhcni(mgs) = 0.0
+ zhacs(mgs) = 0.0
+ zhaci(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzh .gt. 1 ) THEN !
+ do mgs = 1,ngscnt
+
+
+ IF ( qx(mgs,lh) .gt. qxmin(lh) .and. cx(mgs,lh) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+ alp = Max( alphamin, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+ zhaci(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhaci(mgs) )
+ zhacs(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacs(mgs) )
+
+ IF ( .not. mixedphase .and. ibinhmlr < 1 ) THEN
+ zhmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlr(mgs) )
+ ENDIF
+
+ zhshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+
+! IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 .and. ibinhmlr < 1 ) THEN
+ IF ( lzr > 0 .and. qhshr(mgs) /= 0.0 .and. chshrr(mgs) /= 0.0 ) THEN
+! IF ( temg(mgs) > tfr + 2.0 ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+! IF ( zhshrr(mgs) > 0. ) THEN
+! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+! ENDIF
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+! ELSE
+! zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+
+
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshrr(mgs) )
+ ! IF ( zhshrr(mgs) > 0.0 ) THEN
+ ! zhshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) ) ! should this be g1shr?
+! zhshrr(mgs) = Max( z1, zhshrr(mgs))
+ ELSE
+ zhshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhshr(mgs)**2/ chshrr(mgs) )
+ ENDIF
+
+ zhshrr(mgs) = Min( 0.0, zhshrr(mgs) )
+ ENDIF
+
+ IF ( zhshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhshr! zhshr,qhshr,chshr = ',zhshr(mgs),qhshr(mgs),chshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lh),cx(mgs,lh),zx(mgs,lh)
+ write(0,*) ( 2.*tmp * qhshr(mgs) - tmp**2 * chshr(mgs) ), 2.*tmp * qhshr(mgs), - tmp**2 * chshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chshr recalc = ',(cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs)
+
+ STOP
+ ENDIF
+
+
+! zhshr(mgs) = (xdn0(lr)/(xdn(mgs,lh)))**2*( zx(mgs,lh) * qhshr(mgs) )
+
+ qtmp = qhdpv(mgs) + qhcev(mgs) + qhsbv(mgs)
+ ctmp = chdpv(mgs) + chcev(mgs) + chsbv(mgs)
+
+ zhdsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lh) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lh) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhacr(mgs) .gt. 0.0 ) THEN
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+
+! g1r = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+ zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) )
+! zhacrf(mgs) = g1*zhacr
+
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*qhacr(mgs))**2)/(cx(mgs,lh))
+
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacr(mgs) = (z - zx(mgs,lh))*dtpinv
+ ELSE
+! zhacr(mgs) = 0.0
+ ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+! alp = Max( 1.0, alpha(mgs,lh)+1. )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/
+! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( qhacw(mgs) .gt. 0.0 ) THEN
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+ IF ( z > zx(mgs,lh) ) THEN
+! zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ELSE ! } { ! this is not used because of the 'true' above
+
+ IF ( qhacw(mgs) .gt. 0.0 .or. qhacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lh)+dtp*(qhacr(mgs) + qhacw(mgs)-qhmul1(mgs)))**2)/(cx(mgs,lh))
+! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) )
+ IF ( z > zx(mgs,lh) ) THEN
+ zhacw(mgs) = (z - zx(mgs,lh))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qhlcnh(mgs) .gt. 0.0 .and. ihlcnh < 2 ) THEN
+ zhlcnh(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhlcnh(mgs) - tmp**2 * chlcnh(mgs) )
+ ENDIF
+ ENDIF
+! qsplinter(mgs)
+ IF ( ffrzh*qiacrf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ ! note that 3.6476 = (6/pi)**2
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.))* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ELSE ! imurain == 1
+ ziacr(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2)* &
+ & ( 2.*tmp * qiacrf(mgs) - tmp**2 * ciacrf(mgs) )
+ ENDIF
+ ziacr(mgs) = Min( ziacr(mgs), zxmxd(mgs,lr) )
+! ziacrf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * ziacr(mgs)
+ ziacrf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * ziacr(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qiacrf(mgs) - qsplinter(mgs)) - tmp**2 * ciacrf(mgs) )
+! ziacrf(mgs) = Min( ziacrf(mgs), z )
+ ENDIF
+
+
+
+ IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+! alp = 3.0
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ IF ( imurain == 3 ) THEN
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+ ELSEIF ( imurain == 1 .and. ibiggopt /= 2 ) THEN
+! zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+! & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrz(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(xdn0(lr)**2) * &
+ & ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs) )
+ zrfrzf(mgs) = 3.6476*rho0(mgs)**2*g1x(mgs,lr)/(rhofrz**2) * &
+ & ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs) )
+ ENDIF
+ zrfrz(mgs) = Min( zrfrz(mgs), Max(0.4,qrfrz(mgs)/qx(mgs,lr))*zx(mgs,lr)*dtpinv )
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdn(mgs,lh))**2 * zrfrz(mgs)
+! zrfrzf(mgs) = (xdn(mgs,lr)/xdnmx(lh))**2 * zrfrz(mgs)
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * (qrfrzf(mgs)-qsplinter2(mgs)) - tmp**2 * crfrzf(mgs) )
+! zrfrzf(mgs) = Min( zrfrzf(mgs), z )
+ ! change this to be alpha=0?
+ ENDIF
+
+ IF ( lhl > 1 .and. qhcnhl(mgs) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ zhcnhl(mgs) = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+
+ ENDIF
+
+ IF ( qhcns(mgs) > 0.0 .and. chcns(mgs) > 0.0 .and. cx(mgs,ls) > cxmin .and. vhcns(mgs) > 0 ) THEN
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ r = rho0(mgs)*qhcns(mgs)/vhcns(mgs) ! density of new graupel particles
+ IF ( imusnow == 3 ) THEN
+ zhcns(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,ls)+2.)/(r**2*(alpha(mgs,ls)+1.)) * &
+ & ( 2.*tmp * qhcns(mgs) - tmp**2 * chcns(mgs) )
+ ELSE
+ write(0,*) 'Value of imusnow not valid. Must be 3 (fix me for =1). imusnow = ',imusnow
+ STOP
+ ENDIF
+ ENDIF
+
+ IF ( qhcni(mgs) > 0.0 .and. chcni(mgs) > 0.0 .and. cx(mgs,li) > cxmin .and. vhcni(mgs) > 0 ) THEN
+ tmp = qx(mgs,li)/cx(mgs,li)
+ r = rho0(mgs)*qhcni(mgs)/vhcni(mgs) ! density of new graupel particles
+ zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * &
+ & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcni(mgs) )
+ ENDIF
+
+
+ pzhwi(mgs) = &
+ & +ifrzg*ffrzh*(zrfrzf(mgs) &
+ & +il5(mgs)*ifiacrg*(ziacrf(mgs) ) ) &
+! : + zhcnsh(mgs) + zhcnih(mgs) &
+ & + zhacw(mgs) &
+ & + zhacr(mgs) &
+ & + zhcnhl(mgs) &
+ & + zhacs(mgs) &
+ & + zhaci(mgs) &
+ & + f2h*zhcni(mgs) + f2h*zhcns(mgs) &
+ & + Max( 0.0, zhdsv(mgs) )
+
+ pzhwd(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhmlr(mgs) &
+ & + zhshr(mgs) &
+ & + Min( 0.0, zhdsv(mgs) ) &
+ & - il5(mgs)*zhlcnh(mgs)
+
+
+ IF ( igs(mgs) == 44 .and. kgs(mgs) == 23 .or. dtp*( pqhwi(mgs) + pqhwd(mgs) ) > qxmin(lh) ) THEN
+! write(0,*) 'i,k,time = ',igs(mgs),kgs(mgs),time_real
+! write(0,*) 'pzhwi,d = ',pzhwi(mgs),pzhwd(mgs),dtp*( pzhwi(mgs) + pzhwd(mgs) ),zx(mgs,lh)
+! write(0,*) 'pqhwi,d = ',pqhwi(mgs),pqhwd(mgs),dtp*( pqhwi(mgs) + pqhwd(mgs) ),qx(mgs,lh)
+! write(0,*) 'pchwi,d = ',pchwi(mgs),pchwd(mgs),dtp*( pchwi(mgs) + pchwd(mgs) ),cx(mgs,lh)
+ ENDIF
+
+
+! IF ( zhcnhl(mgs) < 0.0 ) THEN
+! write(0,*) 'Problem with zhcnhl! zhcnhl,qhcnhl,chcnhl = ',zhcnhl(mgs),qhcnhl(mgs),chcnhl(mgs)
+! write(0,*) 'g1,tmp = ',g1x(mgs,lhl),tmp
+! write(0,*) ( 2.*( tmp ) * qhcnhl(mgs) - tmp**2 * chcnhl(mgs) )
+!
+!! STOP
+! ENDIF
+ end do
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity'
+
+ ENDIF
+
+!
+! Hail reflectivity
+!
+
+ do mgs = 1,ngscnt
+
+ zhldsv(mgs) = 0.0
+ zhlacr(mgs) = 0.0
+ zhlacw(mgs) = 0.0
+
+ ENDDO
+
+ IF ( lzhl .gt. 1 .or. ( lzr > 1 .and. lnhl > 1 ) ) THEN ! also run for 2-moment hail for 3-moment rain sources
+
+ if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'hail reflectivity'
+
+ do mgs = 1,ngscnt
+
+ IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. cx(mgs,lhl) .gt. 0.0 ) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+ alp = Max( alphamin, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .not. mixedphase .and. qhlmlr(mgs) /= 0.0 .and. chlmlr(mgs) /= 0.0 .and. ibinhlmlr < 1 ) THEN
+ zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlr(mgs) )
+ ENDIF
+
+ zhlshr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ IF ( lzr > 1 .and. qhlshr(mgs) /= 0.0 .and. chlshrr(mgs) /= 0.0 ) THEN
+ IF ( temg(mgs) >= tfr ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshrr(mgs) )
+ ! IF ( zhlshrr(mgs) > 0.0 ) THEN
+ ! zhlshrr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn0(lr)))**2*( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) )
+ ! ENDIF
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ELSE
+ z1 = g1shr*(6.0*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+ ENDIF
+ zhlshrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) ) ! should this be g1shr?
+! zhlshrr(mgs) = Max( z1, zhlshrr(mgs))
+ ELSE
+ zhlshrr(mgs) = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlshr(mgs)**2/ chlshrr(mgs) )
+ ENDIF
+
+ zhlshrr(mgs) = Min( 0.0, zhlshrr(mgs) )
+ ENDIF
+
+ IF ( zhlshr(mgs) > 0.0 ) THEN
+ write(0,*) 'Problem with zhlshr! zhlshr,qhlshr,chlshr = ',zhlshr(mgs),qhlshr(mgs),chlshr(mgs)
+ write(0,*) 'g1,tmp, qx,cx,zx = ',g1,tmp,qx(mgs,lhl),cx(mgs,lhl),zx(mgs,lhl)
+ write(0,*) ( 2.*tmp * qhlshr(mgs) - tmp**2 * chlshr(mgs) ), 2.*tmp * qhlshr(mgs), - tmp**2 * chlshr(mgs)
+ write(0,*) 'temcg = ',temcg(mgs),'chlshr recalc = ',(cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
+
+ STOP
+ ENDIF
+! zhlshr(mgs) = Min( 0.0, zhlshr(mgs) )
+
+! zhlshr(mgs) = (xdn0(lr)/(xdn(mgs,lhl)))**2*( zx(mgs,lhl) * qhlshr(mgs) )
+
+ qtmp = qhldpv(mgs) + qhlcev(mgs)
+ ctmp = chldpv(mgs) + chlcev(mgs)
+
+ zhldsv(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+ alp = Max( alphahacx, alpha(mgs,lhl) )
+! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+ IF ( .true. ) THEN ! {
+ IF ( qhlacr(mgs) .gt. 0.0 ) THEN
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*qhlacr(mgs))**2)/(cx(mgs,lhl))
+ zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) )
+! zhlacr(mgs) = Min( zxmxd(mgs,lr), zhlacr(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacr(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ELSE
+! zhlacr(mgs) = 0.0
+! ENDIF
+ ENDIF
+
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) )
+! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+
+ IF ( qhlacw(mgs) .gt. 0.0 ) THEN
+ alp = Max( 3.0, alpha(mgs,lhl)+1. )
+ g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+
+! z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) )
+
+! IF ( z > zx(mgs,lhl) ) THEN
+! zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+! ENDIF
+ g1 = g1x(mgs,lhl) ! (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/((3.0 + alp)*(2.0 + alp)*(1.0 + alp))
+ ENDIF
+
+ ELSE ! } .false. {
+
+ IF ( qhlacw(mgs) .gt. 0.0 .or. qhlacr(mgs) .gt. 0.0 ) THEN
+ z = g1*(6.*rho0(mgs)/(pi*1000.))**2*( (qx(mgs,lhl)+dtp*(qhlacr(mgs) + qhlacw(mgs)-qhlmul1(mgs)))**2)/(cx(mgs,lhl))
+! zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lhl)/cx(mgs,lhl)) * qhlacw(mgs) )
+ IF ( z > zx(mgs,lhl) ) THEN
+ zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv
+ ENDIF
+ ENDIF
+
+ ENDIF ! }
+
+ ENDIF
+! qsplinter(mgs)
+
+ IF ( lzhl > 1 ) THEN
+ pzhli(mgs) = ffrzh*(((1.0-ifrzg)*zrfrzf(mgs) &
+ & +il5(mgs)*(1.0-ifiacrg)*ziacrf(mgs) )) &
+ & + il5(mgs)*zhlcnh(mgs) &
+ & + zhlacw(mgs) &
+ & + zhlacr(mgs) &
+! : + zhlacs(mgs) &
+ & + Max( 0.0, zhldsv(mgs) )
+
+ pzhld(mgs) = 0.0 &
+ & + (1-il5(mgs))*zhlmlr(mgs) &
+ & + zhlshr(mgs) &
+ & - zhcnhl(mgs) &
+ & + Min( 0.0, zhldsv(mgs) )
+
+
+ IF ( .not. ( -1.0 < pzhli(mgs) .and. pzhli(mgs) < 1.e20 ) ) THEN
+ write(iunit,*) 'Problem with pzhli!'
+ write(iunit,*) 'zhlcnh,zhlacw,zhlacr,zhldsv = ',zhlcnh(mgs),zhlacw(mgs),zhlacr(mgs),zhldsv(mgs)
+ ENDIF
+
+ IF ( .not. ( -1.0e20 < pzhld(mgs) .and. pzhld(mgs) < 1. ) ) THEN
+ write(iunit,*) 'Problem with pzhld!'
+ write(iunit,*) 'zhlmlr,zhlshr,zhldsv = ',zhlmlr(mgs),zhlshr(mgs),zhldsv(mgs)
+ ENDIF
+
+ ENDIF ! lzhl > 1
+
+ end do
+
+ ENDIF
+
+!
+! rain reflectivity
+!
+ if (ndebug .gt. 0 ) write(0,*) 'WARMZIEG: dbg = 11'
+
+ IF ( lzr .gt. 1 ) THEN !
+
+ DO mgs = 1,ngscnt
+
+ zracw(mgs) = 0.0
+ zracr(mgs) = 0.0
+ zrcev(mgs) = 0.0
+ zrach(mgs) = 0.0
+ zrachl(mgs) = 0.0
+ zsshr(mgs) = 0.0
+ zsshrr(mgs) = 0.0
+! zsmlr(mgs) = 0.0
+ zsmlrr(mgs) = 0.0
+
+ IF ( qx(mgs,ls) .gt. qxmin(ls) .and. ( csmlr(mgs) /= 0.0 .or. csshr(mgs) /= 0.0 .or. &
+ csmlrr(mgs) /= 0.0 .or. csshrr(mgs) /= 0.0) ) THEN !{
+ tmp = qx(mgs,ls)/cx(mgs,ls)
+ g1 = 36.*(xnu(ls)+2.0)/((xnu(ls)+1.0)*pi**2)
+ IF ( .not. mixedphase ) THEN
+! zsmlr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsmlr(mgs) - tmp**2 * csmlr(mgs) )
+
+ IF ( csmlrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsmlr(mgs)**2/ csmlrr(mgs) )
+ zsmlrr(mgs) = z1
+ ENDIF
+ ENDIF
+
+! zsshr(mgs) = (xdn(mgs,ls)/xdn(mgs,lr))**2*g1*(rho0(mgs)/(xdn(mgs,ls)))**2* &
+! & ( 2.*tmp * qsshr(mgs) - tmp**2 * csshr(mgs) )
+
+ IF ( csshrr(mgs) /= 0.0 ) THEN
+ z1 = g1smlr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qsshr(mgs)**2/ csshrr(mgs) )
+ zsshrr(mgs) = z1
+ ENDIF
+
+ ENDIF !}
+
+ IF ( .not. mixedphase ) THEN !{
+ IF ( zhmlr(mgs) < 0.0 .and. chmlrr(mgs) /= 0.0 .and. ibinhmlr == 0 ) THEN !{
+ tmp = qx(mgs,lh)/cx(mgs,lh)
+! zhmlrr(mgs) = Min(0.0, (xdn(mgs,lh)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*tmp * qhmlr(mgs) - tmp**2 * chmlrr(mgs) ) )
+
+! IF ( zhmlrr(mgs) >= 0. ) THEN
+! zhmlrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhmlr(mgs)
+! ENDIF
+ IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of graupel
+ z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+ ENDIF
+ zhmlrr(mgs) = z1
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) )
+! zhmlrr(mgs) = Max( z1, zhmlrr(mgs))
+ ENDIF !}
+
+
+! zhshrr(mgs) = (xdn(mgs,lh)/xdn(mgs,lr))**2 * zhshr(mgs)
+
+ IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN
+ tmp = qx(mgs,lhl)/cx(mgs,lhl)
+! zhlmlrr(mgs) = Min(0.0, (xdn(mgs,lhl)/xdn(mgs,lr))**2 * &
+! & g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlmlr(mgs) - tmp**2 * chlmlrr(mgs) ) )
+
+! IF ( zhlmlrr(mgs) >= 0. ) THEN ! should be negative, if not, then use alternate calculation
+! zhlmlrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlmlr(mgs)
+! ENDIF
+
+ IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN ! if not shedding small drops, then use alpha of hail
+ z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ELSE ! assume drops are shed off, so use either alpha for shedding or graupel alpha, whichever gives the lower g-factor (i.e., larger alpha)
+ z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! z1 = g1shr*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+ ENDIF
+ zhlmlrr(mgs) = z1
+
+! z1 = g1mlr*(rho0(mgs)/(xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) )
+! zhlmlrr(mgs) = Max( z1, zhlmlrr(mgs))
+! zhlmlr(mgs) =
+! zhlshrr(mgs) = (xdn(mgs,lhl)/xdn(mgs,lr))**2 * zhlshr(mgs)
+ ENDIF
+
+ ENDIF ! }
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) .gt. 0.0 ) THEN
+
+ tmp = qx(mgs,lr)/cx(mgs,lr)
+ g1 = g1x(mgs,lr) ! 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+
+
+ IF ( qracw(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracw(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*tmp * qracw(mgs) )
+ ENDIF
+
+ IF ( cracr(mgs) > 0.0 .and. cx(mgs,lr) > 0.0 ) THEN
+ zracr(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*1000.))**2*( tmp**2 * cracr(mgs) )
+ ENDIF
+
+ qtmp = qrcev(mgs)
+ ctmp = crcev(mgs)
+
+! IF ( .false. .or. iferwisventr == 2 ) THEN
+! zrcev(mgs) = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs) )
+! ELSE
+ zrcev(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( 2.*( tmp ) * qtmp - tmp**2 * ctmp )
+
+
+ IF ( iferwisventr == 2 ) THEN
+ vent1 = Min(0.0, (12./(pii*xdn(mgs,lr)))*xdia(mgs,lr,1)**3*fvce(mgs)*rwcap(mgs)*rwventz(mgs))
+ zrcev(mgs) = Max( zrcev(mgs), vent1 )
+ ENDIF
+! IF ( ny == 2 .and. igs(mgs) == 20 ) THEN
+! write(0,*) 'k,zrcevold,new,maxdep : ',kgs(mgs),zrcev(mgs),vent1,-zxmxd(mgs,lr),alpha(mgs,lr),cx(mgs,lr)
+! ENDIF
+
- do mgs = 1,ngscnt
- pqhli(mgs) = &
- & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) &
- & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) &
- & +qhlacr(mgs)+qhlacw(mgs) &
-! & +qhlacs(mgs)+qhlaci(mgs) &
- & + qhlcnh(mgs)
- pqhld(mgs) = &
- & qhlshr(mgs) &
- & +(1-il5(mgs))*qhlmlr(mgs) &
-! > +il5(mgs)*qhlsbv(mgs) &
- & + qhlsbv(mgs) &
- & -qhlmul1(mgs) - qhcnhl(mgs)
+! ENDIF
+ zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) )
- end do
+ IF ( qhacr(mgs) > 0.0 ) THEN
+ zrach(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhacr(mgs) - tmp**2 * chacr(mgs) )
+ zrach(mgs) = Min( zrach(mgs), zxmxd(mgs,lr) )
+
+ ENDIF
- ENDIF ! lhl
+ IF ( lhl > 1 .and. qhlacr(mgs) > 0.0 ) THEN
+ zrachl(mgs) = g1x(mgs,lr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2* &
+ & ( 2.*( qx(mgs,lr)/cx(mgs,lr)) * qhlacr(mgs) - tmp**2 * chlacr(mgs) )
+ zrachl(mgs) = Min( zrachl(mgs), zxmxd(mgs,lr) )
+ ENDIF
- ENDIF ! warmonly
-!
-! Liquid water on snow and graupel
-!
+
+ ENDIF
- vhmlr(:) = 0.0
- vhlmlr(:) = 0.0
- vhfzh(:) = 0.0
- vhlfzhl(:) = 0.0
+ pzrwi(mgs) = zrcnw(mgs) + zracw(mgs) + zracr(mgs) &
+ & + Max( 0.,zrcev(mgs) ) &
+ & - (1-il5(mgs))*zsmlrr(mgs) &
+ & - zsshrr(mgs) &
+ & - (1-il5(mgs))*zhmlrr(mgs) &
+ & - zhshrr(mgs) &
+ & - (1-il5(mgs))*zhlmlrr(mgs) &
+ & - zhlshrr(mgs)
- IF ( mixedphase ) THEN
- ELSE ! set arrays for non-mixedphase graupel
-
-! vhshdr(:) = 0.0
- vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation
-! vhsoak(:) = 0.0
-! vhlshdr(:) = 0.0
- vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation
-! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl)
-! vhlsoak(:) = 0.0
+ pzrwd(mgs) = 0.0 &
+ & + Min(0.,zrcev(mgs) ) &
+ & - zrach(mgs) &
+ & - zrachl(mgs) &
+ & - zrfrz(mgs) &
+ & - il5(mgs)*(ziacr(mgs) )
- ENDIF ! mixedphase
+
+ IF ( zx(mgs,lr) + dtp*(pzrwi(mgs)+pzrwd(mgs)) <= 0.0 &
+ .and. qx(mgs,lr) > qxmin(lr) ) THEN
+ pzrwd(mgs) = -zx(mgs,lr)*dtpinv - pzrwi(mgs)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
@@ -18678,6 +22439,33 @@ subroutine nssl_2mom_gs &
! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr)
! ENDIF
+ IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lh) + dtp*(pqhwi(mgs) + pqhwd(mgs) ))/ &
+ & (vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lh) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lh)
+ ENDIF
+
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lh) )
+
+ drhodt = (xdn_new - xdn(mgs,lh))*dtpinv
+
+ zhwdn(mgs) = -2.*g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh)*6.*pii )**2/(cx(mgs,lh)*xdn(mgs,lh)**3)*drhodt
+
+ pzhwi(mgs) = pzhwi(mgs) + Max(0.0, zhwdn(mgs))
+ pzhwd(mgs) = pzhwd(mgs) + Min(0.0, zhwdn(mgs))
+
+
+ ENDIF
IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN
write(iunit,*)
@@ -18760,6 +22548,32 @@ subroutine nssl_2mom_gs &
& + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) &
& + vhlshdr(mgs) - vhlsoak(mgs)
+ IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) ) THEN
+! Calculate change in reflectivity due to density changes
+
+ xdn_new = rho0(mgs)*(qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs) ))/ &
+ & (vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) )
+
+ IF ( mixedphase ) THEN
+ IF ( qxw(mgs,lhl) .gt. 0.0 ) THEN
+ dnmx = xdnmx(lr)
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ ELSE
+ dnmx = xdnmx(lhl)
+ ENDIF
+ xdn_new = Max( Min( xdn_new, dnmx ), xdnmn(lhl) )
+
+ drhodt = (xdn_new - xdn(mgs,lhl))*dtpinv
+
+ zhldn(mgs) = -2.*g1x(mgs,lhl)*(rho0(mgs)*qx(mgs,lhl)*6.*pii )**2/(cx(mgs,lhl)*xdn(mgs,lhl)**3)*drhodt
+
+ pzhli(mgs) = pzhli(mgs) + Max(0.0, zhldn(mgs))
+ pzhld(mgs) = pzhld(mgs) + Min(0.0, zhldn(mgs))
+
+
+ ENDIF
ENDDO
@@ -18989,7 +22803,7 @@ subroutine nssl_2mom_gs &
write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs)
write(iunit,*) -qhcns(mgs)
write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)
- write(iunit,*) (qssbv(mgs))
+ write(iunit,*) qssbv(mgs)
write(iunit,*) Min(0.0, qscev(mgs))
write(iunit,*) -qsmul(mgs)
!
@@ -19061,33 +22875,37 @@ subroutine nssl_2mom_gs &
IF ( warmonly < 0.5 ) THEN
pfrz(mgs) = &
& (1-il5(mgs))* &
- & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
- & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) &
+ & (qhmlr(mgs)+ &
+ & qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) &
& +il5(mgs)*(1-imixedphase)*( &
& qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) &
& +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) &
& +qsshr(mgs) &
& +qhshr(mgs) &
- & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) &
+ & +qhlshr(mgs) &
+ & +qrfrz(mgs)+qiacr(mgs) &
& ) &
& +il5(mgs)*(qwfrz(mgs) &
& +qwctfz(mgs)+qiihr(mgs) &
& +qiacw(mgs))
pmlt(mgs) = &
& (1-il5(mgs))* &
- & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs))
+ & (qhmlr(mgs)+qsmlr(mgs)+ &
+ & qhlmlr(mgs)) !+qhmlh(mgs))
! NOTE: psub is sum of sublimation and deposition
psub(mgs) = &
& il5(mgs)*( &
& + qsdpv(mgs) + qhdpv(mgs) &
& + qhldpv(mgs) &
& + qidpv(mgs) + qisbv(mgs) ) &
- & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) &
+ & + qssbv(mgs) + qhsbv(mgs) &
+ & + qhlsbv(mgs) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + qfcev(mgs)
pevap(mgs) = &
- & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs))
+ & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) &
+ + Min(0.0,qfcev(mgs))
! NOTE: pdep is the deposition part only
pdep(mgs) = &
& il5(mgs)*( &
@@ -19115,7 +22933,7 @@ subroutine nssl_2mom_gs &
& + qidpv(mgs) + qisbv(mgs) ) &
& +il5(mgs)*(qiint(mgs))
pvap(mgs) = &
- & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs)
+ & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs)
ELSE
pfrz(mgs) = 0.0
psub(mgs) = 0.0
@@ -19143,6 +22961,8 @@ subroutine nssl_2mom_gs &
!
!
do mgs = 1,ngscnt
+
+
qwvp(mgs) = qwvp(mgs) + &
& dtp*(pqwvi(mgs)+pqwvd(mgs))
qx(mgs,lc) = qx(mgs,lc) + &
@@ -19155,6 +22975,7 @@ subroutine nssl_2mom_gs &
& dtp*(pqswi(mgs)+pqswd(mgs))
qx(mgs,lh) = qx(mgs,lh) + &
& dtp*(pqhwi(mgs)+pqhwd(mgs))
+
IF ( lhl .gt. 1 ) THEN
qx(mgs,lhl) = qx(mgs,lhl) + &
& dtp*(pqhli(mgs)+pqhld(mgs))
@@ -19224,12 +23045,32 @@ subroutine nssl_2mom_gs &
+ ENDIF
+ ENDIF
+ IF ( ipconc .ge. 6 ) THEN
+ IF ( lzr .gt. 1 ) THEN
+ zx(mgs,lr) = zx(mgs,lr) + &
+ & dtp*(pzrwi(mgs)+pzrwd(mgs))
+ ENDIF
+ IF ( lzs .gt. 1 ) THEN
+ zx(mgs,ls) = zx(mgs,ls) + &
+ & dtp*(pzswi(mgs)+pzswd(mgs))
+ ENDIF
+ IF ( lzh .gt. 1 ) THEN
+ zx(mgs,lh) = zx(mgs,lh) + &
+ & dtp*(pzhwi(mgs)+pzhwd(mgs))
+ ENDIF
+ IF ( lzhl .gt. 1 ) THEN
+ zx(mgs,lhl) = zx(mgs,lhl) + &
+ & dtp*(pzhli(mgs)+pzhld(mgs))
+! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
+! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
+! ENDIF
ENDIF
ENDIF
end do
end if
-
IF ( has_wetscav ) THEN
DO mgs = 1,ngscnt
evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs))
@@ -19471,41 +23312,9 @@ subroutine nssl_2mom_gs &
tqvcon = temg(mgs)-cbw
ltemq = (temg(mgs)-163.15)/fqsat+1.5
ltemq = Min( nqsat, Max(1,ltemq) )
-! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN
-! C$PAR CRITICAL SECTION
-! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs),
-! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs),
-! : ltemq,igs(mgs),jy,kgs(mgs)
-! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt),
-! : ab(igs(mgs),jy,kgs(mgs),lt),
-! : t0(igs(mgs),jy,kgs(mgs))
-! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs)
-! STOP
-! C$PAR END CRITICAL SECTION
-! END IF
+
qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
qis(mgs) = pqs(mgs)*tabqis(ltemq)
-! qss(kz) = qvs(kz)
-! if ( temg(kz) .lt. tfr ) then
-! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = qis(kz)
-! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
-! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
-! > (qcw(kz) + qci(kz))
-! qss(kz) = qis(kz)
-! end if
-! dont get enough condensation with qcw .le./.gt. qxmin(lc)
-! if ( temg(mgs) .lt. tfr ) then
-! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) )
-! > qss(mgs) = qvs(mgs)
-! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
-! > qss(mgs) = qis(mgs)
-! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li))
-! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) /
-! > (qx(mgs,lc) + qitmp(mgs))
-! else
-! qss(mgs) = qvs(mgs)
-! end if
qss(mgs) = qvs(mgs)
if ( temg(mgs) .lt. tfr ) then
if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) &
@@ -19744,7 +23553,6 @@ subroutine nssl_2mom_gs &
-
if (ndebug .gt. 0 ) write(0,*) 'gs 11'
do mgs = 1,ngscnt
@@ -19775,6 +23583,29 @@ subroutine nssl_2mom_gs &
ENDIF
+
+
+
+!
+! 6th moments
+!
+
+ IF ( ipconc .ge. 6 ) THEN
+ DO il = lr,lhab
+ IF ( lz(il) .gt. 1 ) THEN
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,3) = an(igs(mgs),jy,kgs(mgs),lz(il))
+ lfsave(mgs,4) = zx(mgs,il)
+ ENDIF
+
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il) + &
+ & min( an(igs(mgs),jy,kgs(mgs),lz(il)), 0.0 )
+ zx(mgs,il) = an(igs(mgs),jy,kgs(mgs),lz(il))
+
+ ENDIF
+ ENDDO
+
+ ENDIF
!
end do
!
@@ -19839,7 +23670,455 @@ subroutine nssl_2mom_gs &
ENDIF !}
ENDDO ! mgs
+ ELSE ! } { is three-moment, so have to adjust Z if size is too large
+ IF ( il == lr .and. imurain == 3 ) THEN ! { { RAIN
+
+! rdmx =
+! rdmn =
+
+ DO mgs = 1,ngscnt
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
+ IF ( zx(mgs,lr) <= zxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ qx(mgs,lr) = 0.0
+ cx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),ln(lr)) = cx(mgs,lr)
+ ELSEIF ( cx(mgs,lr) <= cxmin ) THEN
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,lr) = 0.0
+ qx(mgs,lr) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),lr)
+ an(igs(mgs),jgs,kgs(mgs),lr) = qx(mgs,lr)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+ ENDIF
+ ENDIF
+
+ IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
+
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
+ IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
+! xv(mgs,lr) = xvmx(lr)
+! cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+ ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
+ xv(mgs,lr) = xvmn(lr)
+ cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*xdn(mgs,lr)**2)
+! an(igs(mgs),jgs,kgs(mgs),ln(il)) = zx(mgs,il)
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(xdn(mgs,lr)**2*chw)
+ an(igs(mgs),jgs,kgs(mgs),lz(lr)) = zx(mgs,lr)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/(z*1000.*1000)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ENDIF
+
+ IF ( zx(mgs,lr) > 0.0 ) THEN
+ xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(1000.*cx(mgs,lr))
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+! xv = (db(1,kz)*a(1,1,kz,lr))**2/(a(1,1,kz,lnr))
+! rd = z*(pi/6.*1000.)**2/xv
+
+! determine shape parameter alpha by iteration
+ IF ( z .gt. 0.0 ) THEN
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+! check for artificial breakup (rain larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) .or. (ioldlimiter == 2 .and. xv(mgs,il) .gt. xvmx(il)/8.) ) THEN
+ tmp = cx(mgs,il)
+! write(0,*) 'MY limiter: xv: ',xv(mgs,il), xv(mgs,il)/(xvmx(il)/8.)
+! STOP
+ IF ( ioldlimiter == 2 ) THEN ! MY-style active breakup
+ x = (6.*rho0(mgs)*qx(mgs,il)/(pi*xdn(mgs,il)*cx(mgs,il)))**(1./3.)
+ x1 = Max(0.0e-3, x - 3.0e-3)
+ x2 = Max(0.5, x/6.0e-3)
+ x3 = x2**3
+ cx(mgs,il) = cx(mgs,il)*Max((1.+2.222e3*x1**2), x3)
+ xv(mgs,il) = xv(mgs,il)/Max((1.+2.222e3*x1**2), x3)
+ ELSE ! simple cutoff
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+ !xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ !cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+
+
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ vr = xv(mgs,lr)
+ qr = qx(mgs,lr)
+ nrx = cx(mgs,lr)
+ z = zx(mgs,lr)
+
+
+! determine shape parameter alpha by iteration
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ DO i = 1,20
+ IF ( Abs(alp - alpha(mgs,lr)) .lt. 0.01 ) EXIT
+ alpha(mgs,lr) = Max( rnumin, Min( rnumax, alp ) )
+ alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z*pi**2) - 1.
+ alp = Max( rnumin, Min( rnumax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = 36.*(alpha(mgs,lr)+2.0)/((alpha(mgs,lr)+1.0)*pi**2)
+ IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN
+
+ IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(1./(xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( rescale_low_alphar .and. alp <= rnumin ) THEN
+ z = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/((alpha(mgs,lr)+1.0)*pi**2)
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ENDIF
+
+
+
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+! CALL cld_cpu('Z-MOMENT-1r')
+
+
+ ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN ! } { Rain, GRAUPEL OR HAIL
+
+
+
+ DO mgs = 1,ngscnt
+
+ IF ( lf > 1 .and. il == lf ) THEN
+ lfsave(mgs,5) = an(igs(mgs),jy,kgs(mgs),ln(il))
+ lfsave(mgs,6) = cx(mgs,il)
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ IF ( cx(mgs,lhl) > cxmin ) THEN
+ frac = chxf(mgs,lhl)/cx(mgs,lhl)
+ ELSE
+ frac = 0.0
+ ENDIF
+ ENDIF
+
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ IF ( cx(mgs,lh) > cxmin ) THEN
+ frach = chxf(mgs,lh)/cx(mgs,lh)
+ ELSE
+ frach = 0.0
+ ENDIF
+ ENDIF
+
+
+
+ IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN ! { .or. qx(mgs,il) <= qxmin(il)
+ IF ( zx(mgs,il) <= zxmin ) THEN ! .and. qx(mgs,il) > 0.05e-3
+!! write(91,*) 'zx=0; qx,cx = ',1000.*qx(mgs,il),cx(mgs,il)
+ qx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ ELSEIF ( iresetmoments == -1 .and. qx(mgs,il) < qxmin(il) ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( cx(mgs,il) <= cxmin .and. iresetmoments /= -1 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ qx(mgs,lv) = qx(mgs,lv) + qx(mgs,il)
+ zx(mgs,il) = 0.0
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+ ELSE
+ IF ( zx(mgs,il) < 0.0 ) THEN ! .and. qx(mgs,il) > 0.05e-3
+ zx(mgs,il) = 0.0
+ ENDIF
+ ENDIF !}
+
+
+ IF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= cxmin ) THEN
+ zx(mgs,il) = 0.0
+ cx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),lv) = an(igs(mgs),jgs,kgs(mgs),lv) + an(igs(mgs),jgs,kgs(mgs),il)
+ qx(mgs,il) = 0.0
+ an(igs(mgs),jgs,kgs(mgs),il) = qx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+ ENDIF
+
+ IF ( qx(mgs,il) .gt. qxmin(il) ) THEN !{
+
+ xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il)))
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+
+ IF ( xv(mgs,il) .lt. xvmn(il) ) THEN
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ ENDIF
+
+ IF ( zx(mgs,il) > 0.0 .and. cx(mgs,il) <= 0.0 ) THEN !{
+! have mass and reflectivity but no concentration, so set concentration, using default alpha
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN
+! have mass and concentration but no reflectivity, so set reflectivity, using default alpha
+! g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+! & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+! zx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! zx(mgs,il) = Min(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ g1 = (6.0 + alphamax)*(5.0 + alphamax)*(4.0 + alphamax)/ &
+ & ((3.0 + alphamax)*(2.0 + alphamax)*(1.0 + alphamax))
+ zx(mgs,il) = Max(zxmin*1.1, g1*dn(igs(mgs),jy,kgs(mgs))**2*(6*qr)**2/(chw*(pi*xdn(mgs,il))**2) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN
+! How did this happen?
+ ! set values according to dBZ of -10, or Z = 0.1
+! 0.1 = 1.e18*0.224*an(ix,jy,kz,lzh)*(hwdn/rwdn)**2
+
+! write(0,*) 'GS: moment problem! il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ zx(mgs,il) = 1.e-19/0.224*(xdn0(lr)/xdn0(il))**2
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+ z = zx(mgs,il)
+ qr = qx(mgs,il)
+! cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(6.*qr)**2/(z*(pi*xdn(mgs,il))**2)
+ an(igs(mgs),jgs,kgs(mgs),ln(il)) = cx(mgs,il)
+
+! write(0,*) 'GS: moment problem! reset il,c,z,q = ',il,cx(mgs,il),zx(mgs,il),qx(mgs,il)
+
+ ELSE
+ ! have all valid moments, so find shape parameter
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ IF ( zx(mgs,il) .gt. 0. ) THEN !{
+
+! rdi = z*(pi/6.*1000.)**2*chw/((rho0(mgs)*qr)**2)
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'kz, alp, alpha(mgs,il) = ',kz,alp,alpha(mgs,il),rdi,z,xv
+ DO i = 1,10
+! IF ( 100.*Abs(alp - alpha(mgs,il))/(Abs(alpha(mgs,il))+1.e-5) .lt. 1. ) EXIT
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+! alp = 1.e18*(6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/
+! : ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+! print*,'i,alp = ',i,alp
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+! check for artificial breakup (graupel/hail larger than allowed max size)
+ IF ( xv(mgs,il) .gt. xvmx(il) ) THEN !{
+ tmp = cx(mgs,il)
+
+
+ xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) )
+ xmas(mgs,il) = xv(mgs,il)*xdn(mgs,il)
+ cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xmas(mgs,il))
+ IF ( tmp < cx(mgs,il) ) THEN ! breakup
+ g1 = 36.*(6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il))*pi**2)
+ zx(mgs,il) = zx(mgs,il) + g1*(rho0(mgs)/xdn(mgs,il))**2*( (qx(mgs,il)/tmp)**2 * (tmp-cx(mgs,il)) )
+ an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il)
+
+ chw = cx(mgs,il)
+ qr = qx(mgs,il)
+ z = zx(mgs,il)
+
+ rdi = z*(pi/6.*xdn(mgs,il))**2*chw/((rho0(mgs)*qr)**2)
+ alp = (6.0+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ DO i = 1,10
+ IF ( Abs(alp - alpha(mgs,il)) .lt. 0.01 ) EXIT
+ alpha(mgs,il) = Max( alphamin, Min( alphamax, alp ) )
+ alp = (6.+alpha(mgs,il))*(5.0+alpha(mgs,il))*(4.0+alpha(mgs,il))/ &
+ & ((3.0+alpha(mgs,il))*(2.0+alpha(mgs,il))*rdi) - 1.0
+ alp = Max( alphamin, Min( alphamax, alp ) )
+ ENDDO
+
+
+ ENDIF
+ ENDIF !}
+
+!
+! Check whether the shape parameter is at or less than the minimum, and if it is, reset the
+! concentration or reflectivity to match (prevents reflectivity from being out of balance with Q and N)
+!
+ g1 = (6.0 + alpha(mgs,il))*(5.0 + alpha(mgs,il))*(4.0 + alpha(mgs,il))/ &
+ & ((3.0 + alpha(mgs,il))*(2.0 + alpha(mgs,il))*(1.0 + alpha(mgs,il)))
+
+ IF ( ( lrescalelow(il) .or. rescale_high_alpha ) .and. &
+ & ( alpha(mgs,il) <= alphamin .or. alp == alphamin .or. alp == alphamax ) ) THEN !{
+
+ IF ( rescale_high_alpha .and. alp >= alphamax - 0.01 ) THEN ! reset c at high alpha to prevent growth in Z
+ cx(mgs,il) = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = cx(mgs,il)
+
+ ELSEIF ( lrescalelow(il) .and. alp <= alphamin .and. .not. (il == lh .and. icvhl2h > 0 ) .and. &
+ .not. ( il == lr .and. .not. rescale_low_alphar ) ) THEN ! alpha = alphamin, so reset Z to prevent growth in C
+
+ wtest = .false.
+ IF ( irescalerainopt == 0 ) THEN
+ wtest = .false.
+ ELSEIF ( irescalerainopt == 1 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc)
+ ELSEIF ( irescalerainopt == 2 ) THEN
+ wtest = qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ELSEIF ( irescalerainopt == 3 ) THEN
+ wtest = temcg(mgs) > rescale_tempthresh .and. qx(mgs,lc) > qxmin(lc) .and. wvel(mgs) < rescale_wthresh
+ ENDIF
+
+ IF ( il == lr .and. ( wtest .or. .not. rescale_low_alphar ) ) THEN
+ ! certain situations where rain number is adjusted instead of Z. Helps avoid rain being 'zapped' by autoconverted
+ ! drops (i.e., favor preserving Z when alpha tries to go negative)
+ chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 ! g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z1
+ cx(mgs,il) = chw
+ an(igs(mgs),jy,kgs(mgs),ln(il)) = chw
+ ELSE
+ ! Usual resetting of reflectivity moment to force consisntency between Q, N, Z, and alpha when alpha = alphamin
+ z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+ z = z1*(6./(pi*xdn(mgs,il)))**2
+ zx(mgs,il) = z
+ an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+! z1 = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/chw
+! z = z1*(6./(pi*xdn(mgs,il)))**2
+! zx(mgs,il) = z
+! an(igs(mgs),jy,kgs(mgs),lz(il)) = z
+ ENDIF
+
+ ENDIF !}
+
+
+ ENDIF !}
+
+
+ ENDIF ! !}
+
+
+ ENDIF !}
+
+ IF ( lzr > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),1) = Max(alphamin, Min(alphamax, alpha(mgs,lr) ))
+ ENDIF
+ IF ( lzh > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),2) = Max(alphamin, Min(alphamax, alpha(mgs,lh) ))
+ ENDIF
+ IF ( lzhl > 1 ) THEN
+ alpha2d(igs(mgs),kgs(mgs),3) = Max(alphamin, Min(alphamax, alpha(mgs,lhl) ))
+ ENDIF
+
+ IF ( il == lhl .and. lnhlf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lhl) = frac*cx(mgs,lhl)
+ ENDIF
+ IF ( il == lh .and. lnhf > 1 ) THEN
+ ! update chxf in case cx has changed
+ chxf(mgs,lh) = frach*cx(mgs,lh)
+ ENDIF
+
+
+! IF ( lf > 0 .and. il == lf .and. kgs(mgs) <= 20 .and. ( cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ) > 200. .or. cx(mgs,lf) > 400. )) THEN
+! write(0,*) 'ix,jy, kz, cf = ',igs(mgs)+ixbeg,jy+jybeg,kgs(mgs), an(igs(mgs),jy,kgs(mgs),ln(lf)),lfsave(mgs,5),lfsave(mgs,6)
+! write(0,*) 'qold,qxold,zold,zxold = ',lfsave(mgs,1),lfsave(mgs,2),lfsave(mgs,3),lfsave(mgs,4)
+! write(0,*) 'cf_new,pcfwi,pcfwd = ',cx(mgs,lf),cx(mgs,lf) + dtp*( pcfwi(mgs) + pcfwd(mgs) ),pcfwi(mgs) + pcfwd(mgs)
+!
+! ENDIF
+
+ ENDDO ! mgs
+
+! CALL cld_cpu('Z-DELABK')
+
+
+! CALL cld_cpu('Z-DELABK')
+
+
+
+
+ ENDIF ! } }
+
ENDIF ! }}
ENDIF ! }
diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90
index 0c708cb3d..271db11d0 100644
--- a/physics/module_mp_thompson.F90
+++ b/physics/module_mp_thompson.F90
@@ -708,9 +708,9 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, &
dtc(n) = (Dc(n) - Dc(n-1))
enddo
-!> - Create bins of cloud ice (from min diameter up to 5x min snow size)
+!> - Create bins of cloud ice (from min diameter up to 2x min snow size)
xDx(1) = D0i*1.0d0
- xDx(nbi+1) = 5.0d0*D0s
+ xDx(nbi+1) = 2.0d0*D0s
do n = 2, nbi
xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) &
*DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1)))
@@ -1046,7 +1046,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
INTEGER, INTENT(IN) :: rand_perturb_on, kme_stoch, n_var_spp
REAL, DIMENSION(:,:), INTENT(IN) :: rand_pert
REAL, DIMENSION(:), INTENT(IN) :: spp_prt_list, spp_stddev_cutoff
- CHARACTER(len=3), DIMENSION(:), INTENT(IN) :: spp_var_list
+ CHARACTER(len=10), DIMENSION(:), INTENT(IN) :: spp_var_list
INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
#if ( WRF_CHEM == 1 )
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
@@ -1509,6 +1509,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, &
enddo
endif
+ if (merra2_aerosol_aware) then
+ do k = kts, kte
+ nc(i,k,j) = nc1d(k)
+ nwfa(i,k,j) = nwfa1d(k)
+ nifa(i,k,j) = nifa1d(k)
+ enddo
+ endif
+
do k = kts, kte
qv(i,k,j) = qv1d(k)
qc(i,k,j) = qc1d(k)
@@ -2822,7 +2830,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k))
prg_rcg(k) = -prr_rcg(k)
!> - Put in explicit drop break-up due to collisions.
- pnr_rcg(k) = -5.*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M
+ pnr_rcg(k) = -1.5*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M
endif
endif
endif
@@ -3053,16 +3061,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
if (prr_sml(k) .gt. 0.) then
prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
* (prr_rcs(k)+prs_scw(k))
- endif
- prr_sml(k) = MIN(DBLE(rs(k)*odts), MAX(0.D0, prr_sml(k)))
- pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M
- pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k))
-
- if (ssati(k).lt. 0.) then
- prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- * (t1_qs_sd*smo1(k) &
- + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
- prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k))
+ prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k))
+ pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M
+ pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k))
+ elseif (ssati(k).lt. 0.) then
+ prr_sml(k) = 0.0
+ prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+ * (t1_qs_sd*smo1(k) &
+ + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
+ prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k))
endif
endif
@@ -3070,17 +3077,16 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
prr_gml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) &
* N0_g(k)*(t1_qg_me*ilamg(k)**cge(10) &
+ t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11))
-!-GT prr_gml(k) = prr_gml(k) + 4218.*olfus*tempc &
-!-GT * (prr_rcg(k)+prg_gcw(k))
- prr_gml(k) = MIN(DBLE(rg(k)*odts), MAX(0.D0, prr_gml(k)))
- pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M
- * prr_gml(k) * 10.0**(-0.5*tempc)
-
- if (ssati(k).lt. 0.) then
- prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
- + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
- prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k))
+ if (prr_gml(k) .gt. 0.) then
+ prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k))
+ pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M
+ * prr_gml(k) * 10.0**(-0.5*tempc)
+ elseif (ssati(k).lt. 0.) then
+ prr_gml(k) = 0.0
+ prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+ * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
+ + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
+ prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k))
endif
endif
diff --git a/physics/module_ozphys.F90 b/physics/module_ozphys.F90
new file mode 100644
index 000000000..f824736b1
--- /dev/null
+++ b/physics/module_ozphys.F90
@@ -0,0 +1,628 @@
+! #########################################################################################
+!> \section arg_table_module_ozphys Argument table
+!! \htmlinclude module_ozphys.html
+!!
+!
+!> The operational GFS currently parameterizes ozone production and destruction based on
+!! monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval Research Laboratory
+!! through CHEM2D chemistry model (McCormack et al. (2006) \cite mccormack_et_al_2006).
+!!
+!! There are two implementations of this parameterization within this module.
+!! run_o3prog_2006 - Relies on either two/four mean monthly coefficients. This is explained
+!! in (https://doi.org/10.5194/acp-6-4943-2006. See Eq.(4)).
+!! run_o3prog_2015 - Relies on six mean monthly coefficients, specifically for NRL
+!! parameterization and climatological T and O3 are in location 5 and 6 of
+!! the coefficient array.
+!!
+!! Both of these rely on the scheme being setup correctly by invoking the load(), setup(),
+!! and update() procedures prior to calling the run() procedure.
+!!
+!! load_o3prog() - Read in data and load into type ty_ozphys (called once from host)
+!! setup_o3prog() - Create spatial interpolation indices (called once, after model grid is known)
+!! update_o3prog() - Update ozone concentration in time (call in physics loop, before run())
+!! *CAVEAT* Since the radiation is often run at a lower temporal resolution
+!! than the rest of the physics, update_o3prog() needs to be
+!! called before the radiation, which is called before the physics.
+!! For example, within the physics loop:
+!! update_o3prog() -> radiation() -> run_o3prog() -> physics....
+!!
+!! Additionally, there is the functionality to not use interactive ozone, instead reverting
+!! to ozone climatology. In this case, analagous to when using prognostic ozone, there are
+!! update() and run() procedures that need to be called before the radiation.
+!! For example, within the physics loop:
+!! update_o3clim() -> run_o3clim() -> radiation() -> physics...
+!!
+!!\author June 2015 - Shrinivas Moorthi
+!!\modified Sep 2023 - Dustin Swales
+!!
+! #########################################################################################
+module module_ozphys
+ use machine, only : kind_phys
+ use funcphys, only : fpkapx
+ implicit none
+
+ public ty_ozphys
+
+! #########################################################################################
+!> \section arg_table_ty_ozphys Argument Table
+!! \htmlinclude ty_ozphys.html
+!!
+!> Derived type containing data and procedures needed by ozone photochemistry parameterization
+!! *Note* All data field are ordered from surface-to-toa.
+!!
+! #########################################################################################
+ type ty_ozphys
+ ! Prognostic ozone.
+ integer :: nlat !< Number of latitudes.
+ integer :: nlev !< Number of vertical layers.
+ integer :: ntime !< Number of times.
+ integer :: ncf !< Number of coefficients.
+ real(kind_phys), allocatable :: lat(:) !< Latitude.
+ real(kind_phys), allocatable :: pres(:) !< Pressure levels.
+ real(kind_phys), allocatable :: po3(:) !< Natural log pressure of levels.
+ real(kind_phys), allocatable :: time(:) !< Time.
+ real(kind_phys), allocatable :: data(:,:,:,:) !< Ozone forcing data (raw)
+ ! Climotological ozone.
+ integer :: nlatc !< Number of latitudes.
+ integer :: nlevc !< Number of vertical layers.
+ integer :: ntimec !< Number of times.
+ real(kind_phys) :: blatc !< Parameter for ozone climotology
+ real(kind_phys) :: dphiozc !< Parameter for ozone climotology
+ real(kind_phys), allocatable :: pkstr(:) !<
+ real(kind_phys), allocatable :: pstr(:) !<
+ real(kind_phys), allocatable :: datac(:,:,:) !< Ozone climotological data
+ integer :: k1oz !< Lower interpolation index in datac(dim=3), time dim
+ integer :: k2oz !< Upper interpolation index in datac(dim=3), time dim
+ real(kind_phys) :: facoz !< Parameter for ozone climotology
+ contains
+ procedure, public :: load_o3prog
+ procedure, public :: setup_o3prog
+ procedure, public :: update_o3prog
+ procedure, public :: run_o3prog_2015
+ procedure, public :: run_o3prog_2006
+ !
+ procedure, public :: load_o3clim
+ procedure, public :: update_o3clim
+ procedure, public :: run_o3clim
+ end type ty_ozphys
+
+contains
+ ! #########################################################################################
+ ! Procedure (type-bound) for loading data for prognostic ozone.
+ ! #########################################################################################
+ function load_o3prog(this, file, fileID) result (err_message)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: fileID
+ character(len=*), intent(in) :: file
+ character(len=128) :: err_message
+ integer :: i1, i2, i3
+ real(kind=4), dimension(:), allocatable :: lat4, pres4, time4, tempin
+ real(kind=4) :: blatc4
+
+ ! Get dimensions from data file
+ open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian')
+ read (fileID) this%ncf, this%nlat, this%nlev, this%ntime
+ rewind(fileID)
+
+ allocate (this%lat(this%nlat))
+ allocate (this%pres(this%nlev))
+ allocate (this%po3(this%nlev))
+ allocate (this%time(this%ntime+1))
+ allocate (this%data(this%nlat,this%nlev,this%ncf,this%ntime))
+
+ allocate(lat4(this%nlat), pres4(this%nlev), time4(this%ntime+1))
+ read (fileID) this%ncf, this%nlat, this%nlev, this%ntime, lat4, pres4, time4
+
+ ! Store
+ this%pres(:) = pres4(:)
+ this%po3(:) = log(100.0*this%pres(:)) ! from mb to ln(Pa)
+ this%lat(:) = lat4(:)
+ this%time(:) = time4(:)
+ deallocate(lat4, pres4, time4)
+
+ allocate(tempin(this%nlat))
+ do i1=1,this%ntime
+ do i2=1,this%ncf
+ do i3=1,this%nlev
+ read(fileID) tempin
+ this%data(:,i3,i2,i1) = tempin(:)
+ enddo
+ enddo
+ enddo
+ deallocate(tempin)
+ close(fileID)
+
+ end function load_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for setting up interpolation indices between data-grid and
+ ! model-grid.
+ ! Called once during initialization
+ ! #########################################################################################
+ subroutine setup_o3prog(this, lat, idx1, idx2, idxh)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: lat(:)
+ integer, intent(out) :: idx1(:), idx2(:)
+ real(kind_phys), intent(out) :: idxh(:)
+ integer :: i,j
+
+ do j=1,size(lat)
+ idx2(j) = this%nlat + 1
+ do i=1,this%nlat
+ if (lat(j) < this%lat(i)) then
+ idx2(j) = i
+ exit
+ endif
+ enddo
+ idx1(j) = max(idx2(j)-1,1)
+ idx2(j) = min(idx2(j),this%nlat)
+ if (idx2(j) .ne. idx1(j)) then
+ idxh(j) = (lat(j) - this%lat(idx1(j))) / (this%lat(idx2(j)) - this%lat(idx1(j)))
+ else
+ idxh(j) = 1.0
+ endif
+ enddo
+
+ end subroutine setup_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for updating data used in prognostic ozone scheme.
+ ! #########################################################################################
+ subroutine update_o3prog(this, idx1, idx2, idxh, rjday, idxt1, idxt2, ozpl)
+ class(ty_ozphys), intent(in) :: this
+ integer, intent(in) :: idx1(:), idx2(:)
+ real(kind_phys), intent(in) :: idxh(:)
+ real(kind_phys), intent(in) :: rjday
+ integer, intent(in) :: idxt1, idxt2
+ real(kind_phys), intent(out) :: ozpl(:,:,:)
+ integer :: nc, l, j, j1, j2
+ real(kind_phys) :: tem, tx1, tx2
+
+ tx1 = (this%time(idxt2) - rjday) / (this%time(idxt2) - this%time(idxt1))
+ tx2 = 1.0 - tx1
+
+ do nc=1,this%ncf
+ do l=1,this%nlev
+ do j=1,size(ozpl(:,1,1))
+ j1 = idx1(j)
+ j2 = idx2(j)
+ tem = 1.0 - idxh(j)
+ ozpl(j,l,nc) = tx1*(tem*this%data(j1,l,nc,idxt1)+idxh(j)*this%data(j2,l,nc,idxt1)) &
+ + tx2*(tem*this%data(j1,l,nc,idxt2)+idxh(j)*this%data(j2,l,nc,idxt2))
+ enddo
+ enddo
+ enddo
+
+ end subroutine update_o3prog
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL prognostic ozone (2015).
+ ! #########################################################################################
+ subroutine run_o3prog_2015(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2)
+ real(kind_phys), intent(in) :: &
+ dt ! Model timestep (sec)
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ p, & ! Model Pressure (Pa)
+ t, & ! Model temperature (K)
+ dp ! Model layer thickness (Pa)
+ real(kind_phys), intent(in), dimension(:,:,:) :: &
+ ozpl ! Ozone forcing data
+ real(kind_phys), intent(inout), dimension(:,:) :: &
+ oz ! Ozone concentration updated by physics
+ real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf
+ logical, dimension(size(p,1)) :: flg
+ real(kind_phys) :: pmax, pmin, tem, temp
+ real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib
+ real(kind_phys), dimension(size(p,1),this%ncf) :: prod
+ real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi
+ real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz
+
+ ! Dimensions
+ nCol = size(p,1)
+ nLev = size(p,2)
+
+ ! Temporaries
+ ozi = oz
+
+ colo3(:,nLev+1) = 0.0
+ coloz(:,nLev+1) = 0.0
+
+ do iLev=nLev,1,-1
+ pmin = 1.0e10
+ pmax = -1.0e10
+
+ do iCol=1,nCol
+ wk1(iCol) = log(p(iCol,iLev))
+ pmin = min(wk1(iCol), pmin)
+ pmax = max(wk1(iCol), pmax)
+ prod(iCol,:) = 0._kind_phys
+ enddo
+ kmax = 1
+ kmin = 1
+ do k=1,this%nlev-1
+ if (pmin < this%po3(k)) kmax = k
+ if (pmax < this%po3(k)) kmin = k
+ enddo
+ !
+ do k=kmin,kmax
+ temp = 1.0 / (this%po3(k) - this%po3(k+1))
+ do iCol=1,nCol
+ flg(iCol) = .false.
+ if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then
+ flg(iCol) = .true.
+ wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp
+ wk3(iCol) = 1.0 - wk2(iCol)
+ endif
+ enddo
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (flg(iCol)) then
+ prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf)
+ endif
+ enddo
+ enddo
+ enddo
+
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (wk1(iCol) < this%po3(this%nlev)) then
+ prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf)
+ endif
+ if (wk1(iCol) >= this%po3(1)) then
+ prod(iCol,iCf) = ozpl(iCol,1,iCf)
+ endif
+ enddo
+ enddo
+ do iCol=1,nCol
+ colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev)*con_1ovg
+ coloz(iCol,iLev) = coloz(iCol,iLev+1) + prod(iCol,6) * dp(iCol,iLev)*con_1ovg
+ prod(iCol,2) = min(prod(iCol,2), 0.0)
+ enddo
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ tem = prod(iCol,1) - prod(iCol,2) * prod(iCol,6) &
+ + prod(iCol,3) * (t(iCol,iLev) - prod(iCol,5)) &
+ + prod(iCol,4) * (colo3(iCol,iLev)-coloz(iCol,iLev))
+ oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 - prod(iCol,2)*dt)
+ enddo
+
+ ! Diagnostics (optional)
+ if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = (prod(:,1)-prod(:,2)*prod(:,6))*dt
+ if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:))
+ if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3)*(t(:,iLev)-prod(:,5))*dt
+ if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * (colo3(:,iLev)-coloz(:,iLev))*dt
+ enddo
+
+ return
+ end subroutine run_o3prog_2015
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL prognostic ozone (2006).
+ ! #########################################################################################
+ subroutine run_o3prog_2006(this, con_1ovg, dt, p, t, dp, ozpl, oz, do3_dt_prd, &
+ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_1ovg ! Physical constant: One divided by gravitational acceleration (m-1 s2)
+ real(kind_phys), intent(in) :: &
+ dt ! Model timestep (sec)
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ p, & ! Model Pressure (Pa)
+ t, & ! Model temperature (K)
+ dp ! Model layer thickness (Pa)
+ real(kind_phys), intent(in), dimension(:,:,:) :: &
+ ozpl ! Ozone forcing data
+ real(kind_phys), intent(inout), dimension(:,:) :: &
+ oz ! Ozone concentration updated by physics
+ real(kind_phys), intent(inout), dimension(:,:), pointer, optional :: &
+ do3_dt_prd, & ! Physics tendency: production and loss effect
+ do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect
+ do3_dt_temp, & ! Physics tendency: temperature effect
+ do3_dt_ohoz ! Physics tendency: overhead ozone effect
+
+ ! Locals
+ integer :: k, kmax, kmin, iLev, iCol, nCol, nLev, iCf
+ logical, dimension(size(p,1)) :: flg
+ real(kind_phys) :: pmax, pmin, tem, temp
+ real(kind_phys), dimension(size(p,1)) :: wk1, wk2, wk3, ozib
+ real(kind_phys), dimension(size(p,1),this%ncf) :: prod
+ real(kind_phys), dimension(size(p,1),size(p,2)) :: ozi
+ real(kind_phys), dimension(size(p,1),size(p,2)+1) :: colo3, coloz
+
+ ! Dimensions
+ nCol = size(p,1)
+ nLev = size(p,2)
+
+ ! Temporaries
+ ozi = oz
+
+ !> - Calculate vertical integrated column ozone values.
+ if (this%ncf > 2) then
+ colo3(:,nLev+1) = 0.0
+ do iLev=nLev,1,-1
+ do iCol=1,nCol
+ colo3(iCol,iLev) = colo3(iCol,iLev+1) + ozi(iCol,iLev) * dp(iCol,iLev) * con_1ovg
+ enddo
+ enddo
+ endif
+
+ !> - Apply vertically linear interpolation to the ozone coefficients.
+ do iLev=1,nLev
+ pmin = 1.0e10
+ pmax = -1.0e10
+
+ do iCol=1,nCol
+ wk1(iCol) = log(p(iCol,iLev))
+ pmin = min(wk1(iCol), pmin)
+ pmax = max(wk1(iCol), pmax)
+ prod(iCol,:) = 0._kind_phys
+ enddo
+ kmax = 1
+ kmin = 1
+ do k=1,this%nlev-1
+ if (pmin < this%po3(k)) kmax = k
+ if (pmax < this%po3(k)) kmin = k
+ enddo
+
+ do k=kmin,kmax
+ temp = 1.0 / (this%po3(k) - this%po3(k+1))
+ do iCol=1,nCol
+ flg(iCol) = .false.
+ if (wk1(iCol) < this%po3(k) .and. wk1(iCol) >= this%po3(k+1)) then
+ flg(iCol) = .true.
+ wk2(iCol) = (wk1(iCol) - this%po3(k+1)) * temp
+ wk3(iCol) = 1.0 - wk2(iCol)
+ endif
+ enddo
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (flg(iCol)) then
+ prod(iCol,iCf) = wk2(iCol) * ozpl(iCol,k,iCf) + wk3(iCol) * ozpl(iCol,k+1,iCf)
+ endif
+ enddo
+ enddo
+ enddo
+
+ do iCf=1,this%ncf
+ do iCol=1,nCol
+ if (wk1(iCol) < this%po3(this%nlev)) then
+ prod(iCol,iCf) = ozpl(iCol,this%nlev,iCf)
+ endif
+ if (wk1(iCol) >= this%po3(1)) then
+ prod(iCol,iCf) = ozpl(iCol,1,iCf)
+ endif
+ enddo
+ enddo
+
+ if (this%ncf == 2) then
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ oz(iCol,iLev) = (ozib(iCol) + prod(iCol,1)*dt) / (1.0 + prod(iCol,2)*dt)
+ enddo
+ endif
+
+ if (this%ncf == 4) then
+ do iCol=1,nCol
+ ozib(iCol) = ozi(iCol,iLev)
+ tem = prod(iCol,1) + prod(iCol,3)*t(iCol,iLev) + prod(iCol,4)*colo3(iCol,iLev+1)
+ oz(iCol,iLev) = (ozib(iCol) + tem*dt) / (1.0 + prod(iCol,2)*dt)
+ enddo
+ endif
+ ! Diagnostics (optional)
+ if (associated(do3_dt_prd)) do3_dt_prd(:,iLev) = prod(:,1)*dt
+ if (associated(do3_dt_ozmx)) do3_dt_ozmx(:,iLev) = (oz(:,iLev) - ozib(:))
+ if (associated(do3_dt_temp)) do3_dt_temp(:,iLev) = prod(:,3) * t(:,iLev) * dt
+ if (associated(do3_dt_ohoz)) do3_dt_ohoz(:,iLev) = prod(:,4) * colo3(:,iLev) * dt
+
+ enddo
+
+ return
+ end subroutine run_o3prog_2006
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for NRL updating climotological ozone.
+ ! #########################################################################################
+ subroutine run_o3clim(this, lat, prslk, con_pi, oz)
+ class(ty_ozphys), intent(in) :: this
+ real(kind_phys), intent(in) :: &
+ con_pi ! Physics constant: Pi
+ real(kind_phys), intent(in), dimension(:) :: &
+ lat ! Grid latitude
+ real(kind_phys), intent(in), dimension(:,:) :: &
+ prslk ! Exner function
+ real(kind_phys), intent(out), dimension(:,:) :: &
+ oz ! Ozone concentration updated by climotology
+
+ integer :: nCol, iCol, nLev, iLev, j, j1, j2, l, ll
+ real(kind_phys) :: elte, deglat, tem, tem1, tem2, tem3, tem4, temp
+ real(kind_phys), allocatable :: o3i(:,:),wk1(:)
+ logical :: top_at_1
+
+ nCol = size(prslk(:,1))
+ nLev = size(prslk(1,:))
+ allocate(o3i(nCol, this%nlevc),wk1(nCol))
+
+ ! What is vertical ordering?
+ top_at_1 = (prslk(1,1) .lt. prslk(1, nLev))
+
+ elte = this%blatc + (this%nlatc-1)*this%dphiozc
+
+ do iCol = 1, nCol
+ deglat = lat(iCol) * 180.0 / con_pi
+ if (deglat > this%blatc .and. deglat < elte) then
+ tem1 = (deglat - this%blatc) / this%dphiozc + 1
+ j1 = tem1
+ j2 = j1 + 1
+ tem1 = tem1 - j1
+ elseif (deglat <= this%blatc) then
+ j1 = 1
+ j2 = 1
+ tem1 = 1.0
+ elseif (deglat >= elte) then
+ j1 = this%nlatc
+ j2 = this%nlatc
+ tem1 = 1.0
+ endif
+
+ tem2 = 1.0 - tem1
+ do j = 1, this%nlevc
+ tem3 = tem2*this%datac(j1,j,this%k1oz) + tem1*this%datac(j2,j,this%k1oz)
+ tem4 = tem2*this%datac(j1,j,this%k2oz) + tem1*this%datac(j2,j,this%k2oz)
+ o3i(iCol,j) = tem4*this%facoz + tem3*(1.0 - this%facoz)
+ enddo
+ enddo
+
+ do iLev = 1, nLev
+ ll = iLev
+ if (.not. top_at_1) ll = nLev - iLev + 1
+
+ do iCol = 1, nCol
+ wk1(iCol) = prslk(iCol,ll)
+ enddo
+
+ do j = 1, this%nlevc-1
+ temp = 1.0 / (this%pkstr(j+1) - this%pkstr(j))
+ do iCol = 1, nCol
+ if (wk1(iCol) > this%pkstr(j) .and. wk1(iCol) <= this%pkstr(j+1)) then
+ tem = (this%pkstr(j+1) - wk1(iCol)) * temp
+ oz(iCol,ll) = tem * o3i(iCol,j) + (1.0 - tem) * o3i(iCol,j+1)
+ endif
+ enddo
+ enddo
+
+ do iCol = 1, nCol
+ if (wk1(iCol) > this%pkstr(this%nlevc)) oz(iCol,ll) = o3i(iCol,this%nlevc)
+ if (wk1(iCol) < this%pkstr(1)) oz(iCol,ll) = o3i(iCol,1)
+ enddo
+ enddo
+
+ return
+ end subroutine run_o3clim
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for loading data for climotological ozone.
+ ! #########################################################################################
+ function load_o3clim(this, file, fileID) result (err_message)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: fileID
+ character(len=*), intent(in) :: file
+ character(len=128) :: err_message
+
+ ! Locals
+ real(kind=4) :: blatc4
+ integer :: iLev, iLat, imo
+ real(kind=4), allocatable :: o3clim4(:,:,:), pstr4(:)
+ integer, allocatable :: imond(:), ilatt(:,:)
+
+ open(unit=fileID,file=trim(file), form='unformatted', convert='big_endian')
+ read (fileID,end=101) this%nlatc, this%nlevc, this%ntimec, blatc4
+101 if (this%nlevc < 10 .or. this%nlevc > 100) then
+ rewind (fileID)
+ this%nlevc = 17
+ this%nlatc = 18
+ this%blatc = -85.0
+ else
+ this%blatc = blatc4
+ endif
+ this%nlat = 2
+ this%nlev = 1
+ this%ntimec = 1
+ this%ncf = 0
+ this%dphiozc = -(this%blatc+this%blatc)/(this%nlatc-1)
+
+ allocate (o3clim4(this%nlatc,this%nlevc,12), pstr4(this%nlevc), imond(12), ilatt(this%nlatc,12) )
+
+ allocate (this%pkstr(this%nlevc), this%pstr(this%nlevc), this%datac(this%nlatc,this%nlevc,12))
+ if ( this%nlevc == 17 ) then ! For the operational ozone climatology
+ do iLev = 1, this%nlevc
+ read (fileID,15) pstr4(iLev)
+15 format(f10.3)
+ enddo
+
+ do imo = 1, 12
+ do iLat = 1, this%nlatc
+ read (fileID,16) imond(imo), ilatt(iLat,imo), (o3clim4(iLat,iLev,imo),iLev=1,10)
+16 format(i2,i4,10f6.2)
+ read (fileID,20) (o3clim4(iLat,iLev,imo),iLev=11,this%nlevc)
+20 format(6x,10f6.2)
+ enddo
+ enddo
+ else ! For newer ozone climatology
+ read (fileID)
+ do iLev = 1, this%nlevc
+ read (fileID) pstr4(iLev)
+ enddo
+
+ do imo = 1, 12
+ do iLev = 1, this%nlevc
+ read (fileID) (o3clim4(iLat,iLev,imo),iLat=1,this%nlatc)
+ enddo
+ enddo
+ endif ! end if_this%nlevc_block
+
+ do imo = 1, 12
+ do iLev = 1, this%nlevc
+ do iLat = 1, this%nlatc
+ this%datac(iLat,iLev,imo) = o3clim4(iLat,iLev,imo) * 1.655e-6
+ enddo
+ enddo
+ enddo
+
+ do iLev = 1, this%nlevc
+ this%pstr(iLev) = pstr4(iLev)
+ this%pkstr(iLev) = fpkapx(this%pstr(iLev)*100.0)
+ enddo
+
+ end function load_o3clim
+
+ ! #########################################################################################
+ ! Procedure (type-bound) for updating temporal interpolation index when using climotological
+ ! ozone
+ ! #########################################################################################
+ subroutine update_o3clim(this, imon, iday, ihour, loz1st)
+ class(ty_ozphys), intent(inout) :: this
+ integer, intent(in) :: imon, iday, ihour
+ logical, intent(in) :: loz1st
+
+ integer :: midmon=15, midm=15, midp=45, id
+ integer, parameter, dimension(13) :: mdays = (/31,28,31,30,31,30,31,31,30,31,30,31,30/)
+ logical :: change
+
+ midmon = mdays(imon)/2 + 1
+ change = loz1st .or. ( (iday==midmon) .and. (ihour==0) )
+
+ if ( change ) then
+ if ( iday < midmon ) then
+ this%k1oz = mod(imon+10, 12) + 1
+ midm = mdays(this%k1oz)/2 + 1
+ this%k2oz = imon
+ midp = mdays(this%k1oz) + midmon
+ else
+ this%k1oz = imon
+ midm = midmon
+ this%k2oz = mod(imon, 12) + 1
+ midp = mdays(this%k2oz)/2 + 1 + mdays(this%k1oz)
+ endif
+ endif
+
+ if (iday < midmon) then
+ id = iday + mdays(this%k1oz)
+ else
+ id = iday
+ endif
+
+ this%facoz = float(id - midm) / float(midp - midm)
+
+ end subroutine update_o3clim
+
+ end module module_ozphys
diff --git a/physics/module_ozphys.meta b/physics/module_ozphys.meta
new file mode 100644
index 000000000..2922d16d7
--- /dev/null
+++ b/physics/module_ozphys.meta
@@ -0,0 +1,24 @@
+[ccpp-table-properties]
+ name = ty_ozphys
+ type = ddt
+ dependencies =
+
+[ccpp-arg-table]
+ name = ty_ozphys
+ type = ddt
+
+########################################################################
+[ccpp-table-properties]
+ name = module_ozphys
+ type = module
+ dependencies = machine.F,funcphys.f90
+
+[ccpp-arg-table]
+ name = module_ozphys
+ type = module
+[ty_ozphys]
+ standard_name = ty_ozphys
+ long_name = definition of type ty_ozphys
+ units = DDT
+ dimensions = ()
+ type = ty_ozphys
\ No newline at end of file
diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90
index c60247cf6..eecc5493c 100644
--- a/physics/module_sf_mynn.F90
+++ b/physics/module_sf_mynn.F90
@@ -106,6 +106,7 @@ MODULE module_sf_mynn
REAL(kind_phys), DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab, &
psih_stab,psih_unstab
+!$acc declare create(psim_stab, psim_unstab, psih_stab, psih_unstab)
CONTAINS
@@ -371,6 +372,20 @@ SUBROUTINE SFCLAY_mynn( &
errflg = 0
errmsg = ''
+!$acc enter data copyin( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, &
+!$acc pattern_spp_sfc)
+
+!$acc enter data copyin( UST_WAT(:), UST_LND(:), UST_ICE(:), &
+!$acc MOL(:), QFLX(:), HFLX(:), &
+!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), &
+!$acc QSFC_ICE(:))
+
+!$acc enter data create( dz8w1d(:), dz2w1d(:), U1D(:), &
+!$acc V1D(:), U1D2(:), V1D2(:), &
+!$acc QV1D(:), QC1D(:), P1D(:), &
+!$acc T1D(:), rstoch1D(:), qstar(:))
+
+
IF (debug_code >= 1) THEN
write(*,*)"======= printing of constants:"
write(*,*)"cp=", cp," g=", grav
@@ -382,6 +397,10 @@ SUBROUTINE SFCLAY_mynn( &
itf=ite !MIN0(ite,ide-1)
ktf=kte !MIN0(kte,kde-1)
+!$acc parallel loop present(dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, &
+!$acc pattern_spp_sfc,dz8w1d,dz2w1d,U1D, &
+!$acc V1D,U1D2,V1D2,QV1D,QC1D,P1D,T1D, &
+!$acc rstoch1D,qstar)
DO i=its,ite
dz8w1d(I) = dz8w(i,kts)
dz2w1d(I) = dz8w(i,kts+1)
@@ -403,6 +422,9 @@ SUBROUTINE SFCLAY_mynn( &
ENDDO
IF (itimestep==1 .AND. iter==1) THEN
+!$acc parallel loop present(U1D,V1D,UST_WAT,UST_LND,UST_ICE,MOL, &
+!$acc QFLX,HFLX,QV3D,QSFC,QSFC_WAT, &
+!$acc QSFC_LND,QSFC_ICE)
DO i=its,ite
IF (.not. flag_restart) THEN
!Everything here is used before calculated
@@ -432,6 +454,9 @@ SUBROUTINE SFCLAY_mynn( &
ENDDO
ENDIF
+!$acc exit data delete( dz8w,U3D,V3D,QV3D,QC3D,P3D,T3D, &
+!$acc pattern_spp_sfc, QC1D)
+
CALL SFCLAY1D_mynn(flag_iter, &
J,U1D,V1D,T1D,QV1D,P1D,dz8w1d, &
U1D2,V1D2,dz2w1d, &
@@ -471,6 +496,16 @@ SUBROUTINE SFCLAY_mynn( &
its,ite, jts,jte, kts,kte, &
errmsg, errflg )
+!$acc exit data copyout( UST_WAT(:), UST_LND(:), UST_ICE(:), &
+!$acc MOL(:), QFLX(:), HFLX(:), &
+!$acc QSFC(:), QSFC_WAT(:), QSFC_LND(:), &
+!$acc QSFC_ICE(:))
+
+!$acc exit data delete( dz8w1d(:), dz2w1d(:), U1D(:), &
+!$acc V1D(:), U1D2(:), V1D2(:), &
+!$acc QV1D(:), T1D(:), P1D(:), &
+!$acc rstoch1D(:), qstar(:))
+
END SUBROUTINE SFCLAY_MYNN
!-------------------------------------------------------------------
@@ -629,6 +664,22 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
character(len=*), intent(inout) :: errmsg
integer, intent(inout) :: errflg
+! Local fixed-size errmsg character array for error messages on accelerator
+! devices distinct from the host (e.g. GPUs). Necessary since OpenACC does
+! not support assumed-size (len=*) arrays like errmsg. Additional
+! device_errflg integer to denote when device_errmsg needs to be synced
+! with errmsg.
+ character(len=512) :: device_errmsg
+ integer :: device_errflg
+
+! Special versions of the fixed-size errmsg character array for error messages
+! on the device and it's errflag counterpart. These are necessary to ensure
+! the return statements at lines 1417 and 2030 are executed only for this
+! special case, and not any and all error messages set on the device.
+ character(len=512) :: device_special_errmsg
+ integer :: device_special_errflg
+
+
!----------------------------------------------------------------
! LOCAL VARS
!----------------------------------------------------------------
@@ -678,7 +729,65 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
! Initialize error-handling
errflg = 0
errmsg = ''
+ device_errflg = errflg
+ device_errmsg = errmsg
+ device_special_errflg = errflg
+ device_special_errmsg = errmsg
!-------------------------------------------------------------------
+!$acc update device(psim_stab, psim_unstab, psih_stab, psih_unstab)
+
+!$acc enter data create( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, &
+!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, &
+!$acc GOVRTH, PSFC, THCON, &
+!$acc zratio_lnd, zratio_ice, zratio_wat, &
+!$acc TSK_lnd, TSK_ice, TSK_wat, &
+!$acc THSK_lnd, THSK_ice, THSK_wat, &
+!$acc THVSK_lnd, THVSK_ice, THVSK_wat, &
+!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, &
+!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, &
+!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, &
+!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, &
+!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, &
+!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, &
+!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, &
+!$acc ZT_lnd, ZT_ice, ZT_wat, &
+!$acc ZQ_lnd, ZQ_ice, ZQ_wat, &
+!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, &
+!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, &
+!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat )
+
+!$acc enter data copyin(flag_iter, dry, wet, icy, CPM, MAVAIL, &
+!$acc QFX, FLHC, FLQC, CHS, CH, CHS2, CQS2, USTM, &
+!$acc HFX, LH, wstar, qstar, PBLH, ZOL, MOL, RMOL, &
+!$acc T2, TH2, Q2, QV1D, PSFCPA, &
+!$acc WSPD, U10, V10, U1D, V1D, U1D2, V1D2, &
+!$acc T1D, P1D, rstoch1D, sigmaf, &
+!$acc shdmax, vegtype, z0pert, ztpert, dx, QGH, &
+!$acc dz2w1d, dz8w1d, &
+!$acc stress_wat, stress_lnd, stress_ice, &
+!$acc rb_wat, rb_lnd, rb_ice, &
+!$acc tskin_wat, tskin_lnd, tskin_ice, &
+!$acc tsurf_wat, tsurf_lnd, tsurf_ice, &
+!$acc psim, psih, &
+!$acc UST_wat, UST_lnd, UST_ice, &
+!$acc ZNT_wat, ZNT_lnd, ZNT_ice, &
+!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, &
+!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, &
+!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, &
+!$acc PSIX_wat, PSIX_lnd, PSIX_ice, &
+!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, &
+!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, &
+!$acc PSIT_lnd, PSIT_wat, PSIT_ice, &
+!$acc ch_lnd, ch_wat, ch_ice, &
+!$acc cm_lnd, cm_wat, cm_ice, &
+!$acc snowh_lnd, snowh_wat, snowh_ice, &
+!$acc device_errmsg, device_errflg, &
+!$acc device_special_errmsg, device_special_errflg)
+
+!$acc parallel loop present(PSFCPA, PSFC, QSFC, T1D, flag_iter, tsurf_lnd, &
+!$acc QSFC_wat, QSFCMR_wat, wet, TSK_wat, tskin_wat, &
+!$acc QSFC_lnd, QSFCMR_lnd, dry, TSK_lnd, tskin_lnd, &
+!$acc QSFC_ice, QSFCMR_ice, icy, TSK_ice, tskin_ice)
DO I=its,ite
! PSFC ( in cmb) is used later in saturation checks
@@ -791,6 +900,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
endif ! flag_iter
ENDDO
+!$acc serial present(pblh, PSFCPA, dz8w1d, qflx, hflx, &
+!$acc dry, tskin_lnd, tsurf_lnd, qsfc_lnd, znt_lnd, ust_lnd, snowh_lnd, &
+!$acc icy, tskin_ice, tsurf_ice, qsfc_ice, znt_ice, ust_ice, snowh_ice, &
+!$acc wet, tskin_wat, tsurf_wat, qsfc_wat, znt_wat, ust_wat, snowh_wat)
IF (debug_code >= 1) THEN
write(0,*)"ITIMESTEP=",ITIMESTEP," iter=",iter
DO I=its,ite
@@ -815,7 +928,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ENDIF
ENDDO
ENDIF
+!$acc end serial
+!$acc parallel loop present(PSFC, PSFCPA, QVSH, QV1D, THCON, flag_iter, &
+!$acc dry, tskin_lnd, TSK_lnd, tsurf_lnd, THSK_lnd, THVSK_lnd, qsfc_lnd, &
+!$acc icy, tskin_ice, TSK_ice, tsurf_ice, THSK_ice, THVSK_ice, qsfc_ice, &
+!$acc wet, tskin_wat, TSK_wat, tsurf_wat, THSK_wat, THVSK_wat, qsfc_wat)
DO I=its,ite
! PSFC ( in cmb) is used later in saturation checks
PSFC(I)=PSFCPA(I)/1000.
@@ -853,18 +971,21 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
endif ! flag_iter
ENDDO
+!$acc parallel loop present(TH1D, T1D, P1D, TC1D)
DO I=its,ite
! CONVERT LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE:
TH1D(I)=T1D(I)*(100000./P1D(I))**ROVCP !(Theta, K)
TC1D(I)=T1D(I)-273.15 !(T, Celsius)
ENDDO
+!$acc parallel loop present(THV1D, TH1D, QVSH, TV1D, T1D)
DO I=its,ite
! CONVERT TO VIRTUAL TEMPERATURE
THV1D(I)=TH1D(I)*(1.+EP1*QVSH(I)) !(K)
TV1D(I)=T1D(I)*(1.+EP1*QVSH(I)) !(K)
ENDDO
+!$acc parallel loop present(RHO1D, P1D, TV1D, TH1D, ZA, ZA2, dz2w1d, dz8w1d, GOVRTH)
DO I=its,ite
RHO1D(I)=P1D(I)/(Rd*TV1D(I)) !now using value calculated in sfc driver
ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level
@@ -873,11 +994,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ENDDO
!tgs - should QFX and HFX be separate for land, ice and water?
+!$acc parallel loop present(QFX, QFLX, RHO1D, HFX, HFLX)
DO I=its,ite
QFX(i)=QFLX(i)*RHO1D(I)
HFX(i)=HFLX(i)*RHO1D(I)*cp
ENDDO
+!$acc serial present(THV1D, TV1D, RHO1D, GOVRTH, &
+!$acc dry, tsk_lnd, thvsk_lnd, &
+!$acc icy, tsk_ice, thvsk_ice, &
+!$acc wet, tsk_wat, thvsk_wat)
IF (debug_code ==2) THEN
!write(*,*)"ITIMESTEP=",ITIMESTEP
DO I=its,ite
@@ -890,7 +1016,9 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
write(*,*)"RHO1D=", RHO1D(i)," GOVRTH=",GOVRTH(i)
ENDDO
ENDIF
+!$acc end serial
+!$acc parallel loop present(T1D,P1D,QGH,QV1D,CPM)
DO I=its,ite
! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP
! Q2SAT = QGH IN LSM
@@ -908,6 +1036,10 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
CPM(I)=CP*(1.+0.84*QV1D(I))
ENDDO
+!$acc serial present(QGH, &
+!$acc wet, QSFC_wat, QSFCMR_wat, &
+!$acc dry, QSFC_lnd, QSFCMR_lnd, &
+!$acc icy, QSFC_ice, QSFCMR_ice)
IF (debug_code == 2) THEN
write(*,*)"ITIMESTEP=",ITIMESTEP
DO I=its,ite
@@ -925,7 +1057,13 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
endif
ENDDO
ENDIF
+!$acc end serial
+!$acc parallel loop present(flag_iter,U1D,V1D,WSPD,wet,dry,icy, &
+!$acc THV1D,THVSK_wat,THVSK_lnd,THVSK_ice, &
+!$acc hfx,RHO1D,qfx,WSTAR,pblh,dx,GOVRTH,ZA, &
+!$acc TSK_wat,TSK_lnd,TSK_ice, &
+!$acc rb_wat,rb_lnd,rb_ice)
DO I=its,ite
if( flag_iter(i) ) then
! DH* 20200401 - note. A weird bug in Intel 18 on hera prevents using the
@@ -1067,6 +1205,35 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
!--------------------------------------------------------------------
!--------------------------------------------------------------------
+!$acc parallel loop present(flag_iter, PSFCPA, dz8w1d, pblh, &
+!$acc device_errmsg, device_errflg, &
+!$acc device_special_errmsg, device_special_errflg, &
+!$acc wet, dry, icy, &
+!$acc ZT_wat, ZT_lnd, ZT_ice, &
+!$acc ZNT_wat, ZNT_lnd, ZNT_ice, &
+!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, &
+!$acc UST_wat, UST_lnd, UST_ice, &
+!$acc ZQ_wat, ZQ_lnd, ZQ_ice, &
+!$acc snowh_wat, snowh_lnd, snowh_ice, &
+!$acc THVSK_wat, THVSK_lnd, THVSK_ice, &
+!$acc tskin_wat, tskin_lnd, tskin_ice, &
+!$acc tsurf_wat, tsurf_lnd, tsurf_ice, &
+!$acc qsfc_wat, qsfc_lnd, qsfc_ice, &
+!$acc GZ1OZ0_wat, GZ1OZt_wat, GZ2OZ0_wat, GZ2OZt_wat, GZ10OZ0_wat, GZ10OZt_wat, &
+!$acc GZ1OZ0_lnd, GZ1OZt_lnd, GZ2OZ0_lnd, GZ2OZt_lnd, GZ10OZ0_lnd, GZ10OZt_lnd, &
+!$acc GZ1OZ0_ice, GZ1OZt_ice, GZ2OZ0_ice, GZ2OZt_ice, GZ10OZ0_ice, GZ10OZt_ice, &
+!$acc zratio_wat, zratio_lnd, zratio_ice, &
+!$acc stress_wat, stress_lnd, stress_ice, &
+!$acc rb_wat, rb_lnd, rb_ice, &
+!$acc qflx, qflx_lnd, &
+!$acc hflx, hflx_lnd, &
+!$acc psim, psih, psim10, psih10, psih2, &
+!$acc psix_wat, psix10_wat, psit_wat, psit2_wat, psiq_wat, psiq2_wat, &
+!$acc psix_lnd, psix10_lnd, psit_lnd, psit2_lnd, psiq_lnd, psiq2_lnd, &
+!$acc psix_ice, psix10_ice, psit_ice, psit2_ice, psiq_ice, psiq2_ice, &
+!$acc WSPD, WSPDI, U1D, V1D, TC1D, THV1D, rstoch1D, USTM, ZA, ZOL, QVSH, &
+!$acc shdmax, vegtype, z0pert, ztpert, mol, rmol, wstar, qstar, sigmaf)
+
DO I=its,ite
if( flag_iter(i) ) then
@@ -1082,10 +1249,12 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
if (sfc_z0_type >= 0) then ! Avoid calculation is using wave model
! CALCULATE z0 (znt)
!--------------------------------------
+
IF (debug_code == 2) THEN
write(*,*)"=============Input to ZNT over water:"
write(*,*)"u*:",UST_wat(i)," wspd=",WSPD(i)," visc=",visc," za=",ZA(I)
ENDIF
+
IF ( PRESENT(ISFTCFLX) ) THEN
IF ( ISFTCFLX .EQ. 0 ) THEN
IF (COARE_OPT .EQ. 3.0) THEN
@@ -1170,7 +1339,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ENDIF
ELSEIF ( ISFTCFLX .EQ. 4 ) THEN
!GFS zt formulation
- CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,errmsg,errflg)
+ CALL GFS_zt_wat(ZT_wat(i),ZNTstoch_wat(i),restar,WSPD(i),ZA(i),sfc_z0_type,device_errmsg,device_errflg)
ZQ_wat(i)=ZT_wat(i)
ENDIF
ELSE
@@ -1183,6 +1352,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
rstoch1D(i),spp_sfc)
ENDIF
ENDIF
+
IF (debug_code > 1) THEN
write(*,*)"=============Output ZT & ZQ over water:"
write(*,*)"ZT:",ZT_wat(i)," ZQ:",ZQ_wat(i)
@@ -1230,9 +1400,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ELSEIF ( IZ0TLND .EQ. 2 ) THEN
! DH note - at this point, qstar is either not initialized
! or initialized to zero, but certainly not set correctly
- errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008'
- errflg = 1
+ device_special_errmsg = 'Logic error: qstar is not set correctly when calling Yang_2008'
+ device_special_errflg = 1
+#ifndef _OPENACC
+! Necessary since OpenACC does not support branching in parallel code
+! Must sync errmsg and errflg with device_errmsg and device_errflg, respectively
+! so that proper error message and error flag codes are returned.
+ errmsg = device_special_errmsg
+ errflg = device_special_errflg
return
+#endif
CALL Yang_2008(ZNTSTOCH_lnd(i),ZT_lnd(i),ZQ_lnd(i),UST_lnd(i),MOL(I),&
qstar(I),restar,visc)
ELSEIF ( IZ0TLND .EQ. 3 ) THEN
@@ -1249,6 +1426,7 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
UST_lnd(I),KARMAN,1.0_kind_phys,0,spp_sfc,rstoch1D(i))
ENDIF
ENDIF
+
IF (ZNTstoch_lnd(i) < 1E-8 .OR. Zt_lnd(i) < 1E-10) THEN
write(0,*)"===(land) capture bad input in mynn sfc layer, i=:",i
write(0,*)" ZNT=", ZNTstoch_lnd(i)," ZT=",Zt_lnd(i)
@@ -1258,7 +1436,6 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
" dz=",dz8w1d(i)," qflx=",qflx_lnd(i)," hflx=",hflx_lnd(i)," hpbl=",pblh(i)
ENDIF
-
GZ1OZ0_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(I))/ZNTstoch_lnd(I))
GZ1OZt_lnd(I)= LOG((ZA(I)+ZNTstoch_lnd(i))/ZT_lnd(i))
GZ2OZ0_lnd(I)= LOG((2.0+ZNTstoch_lnd(I))/ZNTstoch_lnd(I))
@@ -1821,6 +1998,26 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
endif ! flag_iter
ENDDO ! end i-loop
+#ifdef _OPENACC
+! Necessary since OpenACC does not support branching in parallel code.
+! Must sync host errflg, errmsg to determine if return must be triggered
+! and correct error message and error flag code returned.
+! This code is being executed on the HOST side only, pulling data from DEVICE.
+!$acc exit data copyout(device_special_errflg, device_special_errmsg)
+ IF (device_special_errflg /= 0) THEN
+ errflg = device_special_errflg
+ errmsg = device_special_errmsg
+ return
+ ENDIF
+#endif
+
+!$acc serial present(wet, dry, icy, &
+!$acc PSIM, PSIH, CPM, RHO1D, ZOL, wspd, MOL, &
+!$acc wstar, qstar, THV1D, HFX, MAVAIL, QVSH, &
+!$acc THVSK_wat, THVSK_lnd, THVSK_ice, &
+!$acc UST_wat, UST_lnd, UST_ice, &
+!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, &
+!$acc zt_wat, zt_lnd, zt_ice)
IF (debug_code == 2) THEN
DO I=its,ite
IF(wet(i))write(*,*)"==== AT END OF MAIN LOOP, i=",i, "(wet)"
@@ -1841,10 +2038,29 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
write(*,*)"============================================="
ENDDO ! end i-loop
ENDIF
+!$acc end serial
!----------------------------------------------------------
! COMPUTE SURFACE HEAT AND MOISTURE FLUXES
!----------------------------------------------------------
+!$acc parallel loop present(flag_iter, dry, wet, icy, &
+!$acc QFX, HFX, FLHC, FLQC, LH, CHS, CH, CHS2, CQS2, &
+!$acc RHO1D, MAVAIL, USTM, &
+!$acc UST_lnd, UST_wat, UST_ice, &
+!$acc PSIQ_lnd, PSIT_lnd, PSIX_lnd, &
+!$acc PSIQ_wat, PSIT_wat, PSIX_wat, &
+!$acc PSIQ_ice, PSIT_ice, PSIX_ice, &
+!$acc PSIQ2_lnd, PSIT2_lnd, &
+!$acc PSIQ2_wat, PSIT2_wat, &
+!$acc PSIQ2_ice, PSIT2_ice, &
+!$acc QSFC, QSFC_lnd, QSFC_wat, QSFC_ice, &
+!$acc QFLX, QFLX_lnd, QFLX_wat, QFLX_ice, &
+!$acc HFLX, HFLX_lnd, HFLX_wat, HFLX_ice, &
+!$acc QSFCMR_lnd, QSFCMR_wat, QSFCMR_ice, &
+!$acc QV1D, WSPD, WSPDI, CPM, TH1D, &
+!$acc THSK_lnd, THSK_wat, THSK_ice, &
+!$acc ch_lnd, ch_wat, ch_ice, &
+!$acc cm_lnd, cm_wat, cm_ice)
DO I=its,ite
if( flag_iter(i) ) then
@@ -2040,6 +2256,18 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ENDDO ! end i-loop
IF (compute_diag) then
+ !$acc parallel loop present(flag_iter, dry, wet, icy, &
+ !$acc ZA, ZA2, T2, TH2, TH1D, Q2, QV1D, PSFCPA, &
+ !$acc THSK_lnd, THSK_wat, THSK_ice, &
+ !$acc QSFC_lnd, QSFC_wat, QSFC_ice, &
+ !$acc U10, V10, U1D, V1D, U1D2, V1D2, &
+ !$acc ZNTstoch_lnd, ZNTstoch_lnd, ZNTstoch_ice, &
+ !$acc PSIX_lnd, PSIX_wat, PSIX_ice, &
+ !$acc PSIX10_lnd, PSIX10_wat, PSIX10_ice, &
+ !$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, &
+ !$acc PSIT_lnd, PSIT_wat, PSIT_ice, &
+ !$acc PSIQ2_lnd, PSIQ2_wat, PSIQ2_ice, &
+ !$acc PSIQ_lnd, PSIQ_wat, PSIQ_ice)
DO I=its,ite
if( flag_iter(i) ) then
!-----------------------------------------------------
@@ -2153,6 +2381,16 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
!-----------------------------------------------------
! DEBUG - SUSPICIOUS VALUES
!-----------------------------------------------------
+!$acc serial present(dry, wet, icy, CPM, MAVAIL, &
+!$acc HFX, LH, wstar, RHO1D, PBLH, ZOL, ZA, MOL, &
+!$acc PSIM, PSIH, WSTAR, T1D, TH1D, THV1D, QVSH, &
+!$acc UST_wat, UST_lnd, UST_ice, &
+!$acc THSK_wat, THSK_lnd, THSK_ice, &
+!$acc THVSK_wat, THVSK_lnd, THVSK_ice, &
+!$acc ZNTstoch_wat, ZNTstoch_lnd, ZNTstoch_ice, &
+!$acc ZT_wat, ZT_lnd, ZT_ice, &
+!$acc QSFC_wat, QSFC_lnd, QSFC_ice, &
+!$acc PSIX_wat, PSIX_lnd, PSIX_ice)
IF ( debug_code == 2) THEN
DO I=its,ite
yesno = 0
@@ -2257,6 +2495,62 @@ SUBROUTINE SFCLAY1D_mynn(flag_iter, &
ENDIF
ENDDO ! end i-loop
ENDIF ! end debug option
+!$acc end serial
+
+!$acc exit data copyout(CPM, FLHC, FLQC, CHS, CH, CHS2, CQS2,&
+!$acc USTM, wstar, qstar, ZOL, MOL, RMOL, &
+!$acc HFX, QFX, LH, QSFC, QFLX, HFLX, &
+!$acc T2, TH2, Q2, WSPD, U10, V10, &
+!$acc QGH, psim, psih, &
+!$acc stress_wat, stress_lnd, stress_ice, &
+!$acc rb_wat, rb_lnd, rb_ice, &
+!$acc UST_wat, UST_lnd, UST_ice, &
+!$acc ZNT_wat, ZNT_lnd, ZNT_ice, &
+!$acc QSFC_lnd, QSFC_wat, QSFC_ice, &
+!$acc QFLX_lnd, QFLX_wat, QFLX_ice, &
+!$acc HFLX_lnd, HFLX_wat, HFLX_ice, &
+!$acc PSIX_wat, PSIX_lnd, PSIX_ice, &
+!$acc PSIX10_wat, PSIX10_lnd, PSIX10_ice, &
+!$acc PSIT2_lnd, PSIT2_wat, PSIT2_ice, &
+!$acc PSIT_lnd, PSIT_wat, PSIT_ice, &
+!$acc ch_lnd, ch_wat, ch_ice, &
+!$acc cm_lnd, cm_wat, cm_ice, &
+!$acc device_errmsg, device_errflg)
+
+! Final sync of device and host error flags and messages
+IF (device_errflg /= 0) THEN
+ errflg = device_errflg
+ errmsg = device_errmsg
+ENDIF
+
+!$acc exit data delete( flag_iter, dry, wet, icy, dx, &
+!$acc MAVAIL, PBLH, PSFCPA, z0pert, ztpert, &
+!$acc QV1D, U1D, V1D, U1D2, V1D2, T1D, P1D, &
+!$acc rstoch1D, sigmaf, shdmax, vegtype, &
+!$acc dz2w1d, dz8w1d, &
+!$acc snowh_wat, snowh_lnd, snowh_ice, &
+!$acc tskin_wat, tskin_lnd, tskin_ice, &
+!$acc tsurf_wat, tsurf_lnd, tsurf_ice)
+
+!$acc exit data delete( ZA, ZA2, THV1D, TH1D, TC1D, TV1D, &
+!$acc RHO1D, QVSH, PSIH2, PSIM10, PSIH10, WSPDI, &
+!$acc GOVRTH, PSFC, THCON, &
+!$acc zratio_lnd, zratio_ice, zratio_wat, &
+!$acc TSK_lnd, TSK_ice, TSK_wat, &
+!$acc THSK_lnd, THSK_ice, THSK_wat, &
+!$acc THVSK_lnd, THVSK_ice, THVSK_wat, &
+!$acc GZ1OZ0_lnd, GZ1OZ0_ice, GZ1OZ0_wat, &
+!$acc GZ1OZt_lnd, GZ1OZt_ice, GZ1OZt_wat, &
+!$acc GZ2OZ0_lnd, GZ2OZ0_ice, GZ2OZ0_wat, &
+!$acc GZ2OZt_lnd, GZ2OZt_ice, GZ2OZt_wat, &
+!$acc GZ10OZ0_lnd, GZ10OZ0_ice, GZ10OZ0_wat, &
+!$acc GZ10OZt_lnd, GZ10OZt_ice, GZ10OZt_wat, &
+!$acc ZNTstoch_lnd, ZNTstoch_ice, ZNTstoch_wat, &
+!$acc ZT_lnd, ZT_ice, ZT_wat, &
+!$acc ZQ_lnd, ZQ_ice, ZQ_wat, &
+!$acc PSIQ_lnd, PSIQ_ice, PSIQ_wat, &
+!$acc PSIQ2_lnd, PSIQ2_ice, PSIQ2_wat, &
+!$acc QSFCMR_lnd, QSFCMR_ice, QSFCMR_wat )
END SUBROUTINE SFCLAY1D_mynn
!-------------------------------------------------------------------
@@ -2272,6 +2566,7 @@ END SUBROUTINE SFCLAY1D_mynn
SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
& landsea,IZ0TLND2,spp_sfc,rstoch)
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea
INTEGER, OPTIONAL, INTENT(IN) :: IZ0TLND2
@@ -2341,6 +2636,7 @@ SUBROUTINE davis_etal_2008(Z_0,ustar)
!This is an update version from Davis et al. 2008, which
!corrects a small-bias in Z_0 (AHW real-time 2012).
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: ustar
REAL(kind_phys), INTENT(OUT) :: Z_0
@@ -2368,7 +2664,7 @@ END SUBROUTINE davis_etal_2008
!>This formulation for roughness length was designed account for.
!!wave steepness.
SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: ustar,wsp10
REAL(kind_phys), INTENT(OUT) :: Z_0
@@ -2396,7 +2692,7 @@ END SUBROUTINE Taylor_Yelland_2001
!! The Charnock parameter CZC is varied from .011 to .018.
!! between 10-m wsp = 10 and 18..
SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu
REAL(kind_phys), INTENT(OUT) :: Z_0
@@ -2421,7 +2717,7 @@ END SUBROUTINE charnock_1955
!!The Charnock parameter CZC is varied from about .005 to .028
!!between 10-m wind speeds of 6 and 19 m/s.
SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: ustar, visc, wsp10, zu
REAL(kind_phys), INTENT(OUT) :: Z_0
@@ -2450,7 +2746,7 @@ END SUBROUTINE edson_etal_2013
!!data. The formula for land uses a constant ratio (Z_0/7.4) taken
!!from Garratt (1992).
SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Ren, Z_0,landsea
REAL(kind_phys), INTENT(OUT) :: Zt,Zq
@@ -2486,7 +2782,7 @@ END SUBROUTINE garratt_1992
!!
!!This is for use over water only.
SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch
INTEGER, INTENT(IN) :: spp_sfc
@@ -2530,7 +2826,7 @@ END SUBROUTINE fairall_etal_2003
!! The actual reference is unknown. This was passed along by Jim Edson (personal communication).
!! This is for use over water only, preferably open ocean.
SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_sfc)
-
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Ren,ustar,visc,rstoch
INTEGER, INTENT(IN) :: spp_sfc
@@ -2578,6 +2874,7 @@ END SUBROUTINE fairall_etal_2014
!!This should only be used over land!
SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc)
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc
REAL(kind_phys) :: ht, &! roughness height at critical Reynolds number
@@ -2613,6 +2910,7 @@ END SUBROUTINE Yang_2008
!>\ingroup mynn_sfc
SUBROUTINE GFS_z0_lnd(z0max,shdmax,z1,vegtype,ivegsrc,z0pert)
+ !$acc routine seq
REAL(kind_phys), INTENT(OUT) :: z0max
REAL(kind_phys), INTENT(IN) :: shdmax,z1,z0pert
INTEGER, INTENT(IN) :: vegtype,ivegsrc
@@ -2673,6 +2971,7 @@ END SUBROUTINE GFS_z0_lnd
!>\ingroup mynn_sfc
SUBROUTINE GFS_zt_lnd(ztmax,z0max,sigmaf,ztpert,ustar_lnd)
+ !$acc routine seq
REAL(kind_phys), INTENT(OUT) :: ztmax
REAL(kind_phys), INTENT(IN) :: z0max,sigmaf,ztpert,ustar_lnd
REAL(kind_phys) :: czilc, tem1, tem2
@@ -2701,6 +3000,7 @@ END SUBROUTINE GFS_zt_lnd
!>\ingroup mynn_sfc
SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag)
+ !$acc routine seq
REAL(kind_phys), INTENT(OUT) :: z0rl_wat
REAL(kind_phys), INTENT(INOUT):: ustar_wat
REAL(kind_phys), INTENT(IN) :: wspd,z1
@@ -2752,19 +3052,27 @@ SUBROUTINE GFS_z0_wat(z0rl_wat,ustar_wat,WSPD,z1,sfc_z0_type,redrag)
END SUBROUTINE GFS_z0_wat
!--------------------------------------------------------------------
!>\ingroup mynn_sfc
- SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg)
-
+ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,device_errmsg,device_errflg)
+ !$acc routine seq
real(kind_phys), INTENT(OUT) :: ztmax
real(kind_phys), INTENT(IN) :: wspd,z1,z0rl_wat,restar
INTEGER, INTENT(IN) :: sfc_z0_type
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
+
+! Using device_errmsg and device_errflg rather than the CCPP errmsg and errflg
+! so that this subroutine can be run on an accelerator device with OpenACC.
+! character(len=*), intent(out) :: errmsg
+! integer, intent(out) :: errflg
+ character(len=512), intent(out) :: device_errmsg
+ integer, intent(out) :: device_errflg
+
real(kind_phys) :: z0,z0max,wind10m,rat,ustar_wat
real(kind_phys), PARAMETER :: charnock = 0.014, z0s_max=.317e-2
! Initialize error-handling
- errflg = 0
- errmsg = ''
+! errflg = 0
+! errmsg = ''
+ device_errflg = 0
+ device_errmsg = ''
! z0 = 0.01 * z0rl_wat
!Already converted to meters in the wrapper
@@ -2795,9 +3103,12 @@ SUBROUTINE GFS_zt_wat(ztmax,z0rl_wat,restar,WSPD,z1,sfc_z0_type,errmsg,errflg)
call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m)
else if (sfc_z0_type > 0) then
write(0,*)'no option for sfc_z0_type=',sfc_z0_type
- errflg = 1
- errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.'
+! errflg = 1
+! errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.'
+ device_errflg = 1
+ device_errmsg = 'ERROR(GFS_zt_wat): sfc_z0_type not valid.'
return
+
endif
END SUBROUTINE GFS_zt_wat
@@ -2807,6 +3118,7 @@ END SUBROUTINE GFS_zt_wat
!! Weiguo Wang, 2019-0425
SUBROUTINE znot_m_v6(uref, znotm)
+ !$acc routine seq
use machine , only : kind_phys
IMPLICIT NONE
! Calculate areodynamical roughness over water with input 10-m wind
@@ -2856,6 +3168,7 @@ END SUBROUTINE znot_m_v6
!!
SUBROUTINE znot_t_v6(uref, znott)
+ !$acc routine seq
IMPLICIT NONE
!> Calculate scalar roughness over water with input 10-m wind
!! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
@@ -2922,6 +3235,7 @@ END SUBROUTINE znot_t_v6
!!
SUBROUTINE znot_m_v7(uref, znotm)
+ !$acc routine seq
IMPLICIT NONE
!> Calculate areodynamical roughness over water with input 10-m wind
!! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013)
@@ -2971,6 +3285,7 @@ END SUBROUTINE znot_m_v7
!!
SUBROUTINE znot_t_v7(uref, znott)
+ !$acc routine seq
IMPLICIT NONE
!> Calculate scalar roughness over water with input 10-m wind
!! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm
@@ -3040,6 +3355,7 @@ END SUBROUTINE znot_t_v7
!! This should only be used over snow/ice!
SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq)
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(IN) :: Z_0, bvisc, ustar
REAL(kind_phys), INTENT(OUT) :: Zt, Zq
@@ -3313,6 +3629,7 @@ END SUBROUTINE PSI_CB2005
!! and Holtslag (1991) for stable conditions.
SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt)
+ !$acc routine seq
IMPLICIT NONE
REAL(kind_phys), INTENT(OUT) :: zL
REAL(kind_phys), INTENT(IN) :: Rib, zaz0, z0zt
@@ -3471,6 +3788,7 @@ REAL(kind_phys) function zolri2(zol2,ri2,za,z0,zt,psi_opt)
REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
+ !$acc routine seq
! This iterative algorithm to compute z/L from bulk-Ri
IMPLICIT NONE
@@ -3480,7 +3798,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
REAL(kind_phys) :: zol20,zol3,zolt,zolold
INTEGER :: n
INTEGER, PARAMETER :: nmax = 20
- REAL(kind_phys), DIMENSION(nmax):: zLhux
+ !REAL(kind_phys), DIMENSION(nmax):: zLhux
REAL(kind_phys) :: psit2,psix2
!print*,"+++++++INCOMING: z/L=",zol1," ri=",ri
@@ -3522,7 +3840,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
endif
!print*,"n=",n," psit2=",psit2," psix2=",psix2
zolrib=ri*psix2**2/psit2
- zLhux(n)=zolrib
+ !zLhux(n)=zolrib
n=n+1
enddo
@@ -3530,7 +3848,7 @@ REAL(kind_phys) function zolrib(ri,za,z0,zt,logz0,logzt,zol1,psi_opt)
!print*,"iter FAIL, n=",n," Ri=",ri," z/L=",zolri
!if convergence fails, use approximate values:
CALL Li_etal_2010(zolrib, ri, za/z0, z0/zt)
- zLhux(n)=zolrib
+ !zLhux(n)=zolrib
!print*,"FAILED, n=",n," Ri=",ri," z0=",z0
!print*,"z/L=",zLhux(1:nmax)
else
@@ -3595,6 +3913,7 @@ END SUBROUTINE psi_init
!
!>\ingroup mynn_sfc
real(kind_phys) function psim_stable_full(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf
!psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5))
@@ -3605,6 +3924,7 @@ real(kind_phys) function psim_stable_full(zolf)
!>\ingroup mynn_sfc
real(kind_phys) function psih_stable_full(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf
!psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1))
@@ -3615,6 +3935,7 @@ real(kind_phys) function psih_stable_full(zolf)
!>\ingroup mynn_sfc
real(kind_phys) function psim_unstable_full(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf,x,ym,psimc,psimk
x=(1.-16.*zolf)**.25
@@ -3633,6 +3954,7 @@ real(kind_phys) function psim_unstable_full(zolf)
!>\ingroup mynn_sfc
real(kind_phys) function psih_unstable_full(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf,y,yh,psihc,psihk
y=(1.-16.*zolf)**.5
@@ -3654,6 +3976,7 @@ real(kind_phys) function psih_unstable_full(zolf)
!>\ingroup mynn_sfc
!!
REAL(kind_phys) function psim_stable_full_gfs(zolf)
+ !$acc routine seq
REAL(kind_phys) :: zolf
REAL(kind_phys), PARAMETER :: alpha4 = 20.
REAL(kind_phys) :: aa
@@ -3667,6 +3990,7 @@ REAL(kind_phys) function psim_stable_full_gfs(zolf)
!>\ingroup mynn_sfc
!!
real(kind_phys) function psih_stable_full_gfs(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf
real(kind_phys), PARAMETER :: alpha4 = 20.
real(kind_phys) :: bb
@@ -3680,6 +4004,7 @@ real(kind_phys) function psih_stable_full_gfs(zolf)
!>\ingroup mynn_sfc
!!
real(kind_phys) function psim_unstable_full_gfs(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf
real(kind_phys) :: hl1,tem1
real(kind_phys), PARAMETER :: a0=-3.975, a1=12.32, &
@@ -3700,6 +4025,7 @@ real(kind_phys) function psim_unstable_full_gfs(zolf)
!>\ingroup mynn_sfc
!!
real(kind_phys) function psih_unstable_full_gfs(zolf)
+ !$acc routine seq
real(kind_phys) :: zolf
real(kind_phys) :: hl1,tem1
real(kind_phys), PARAMETER :: a0p=-7.941, a1p=24.75, &
@@ -3720,6 +4046,7 @@ real(kind_phys) function psih_unstable_full_gfs(zolf)
!>\ingroup mynn_sfc
!! look-up table functions - or, if beyond -10 < z/L < 10, recalculate
real(kind_phys) function psim_stable(zolf,psi_opt)
+ !$acc routine seq
integer :: nzol,psi_opt
real(kind_phys) :: rzol,zolf
@@ -3740,6 +4067,7 @@ real(kind_phys) function psim_stable(zolf,psi_opt)
!>\ingroup mynn_sfc
real(kind_phys) function psih_stable(zolf,psi_opt)
+ !$acc routine seq
integer :: nzol,psi_opt
real(kind_phys) :: rzol,zolf
@@ -3760,6 +4088,7 @@ real(kind_phys) function psih_stable(zolf,psi_opt)
!>\ingroup mynn_sfc
real(kind_phys) function psim_unstable(zolf,psi_opt)
+ !$acc routine seq
integer :: nzol,psi_opt
real(kind_phys) :: rzol,zolf
@@ -3780,6 +4109,7 @@ real(kind_phys) function psim_unstable(zolf,psi_opt)
!>\ingroup mynn_sfc
real(kind_phys) function psih_unstable(zolf,psi_opt)
+ !$acc routine seq
integer :: nzol,psi_opt
real(kind_phys) :: rzol,zolf
diff --git a/physics/module_sf_noahmplsm.F90 b/physics/module_sf_noahmplsm.F90
index 86853dabe..6abd59f69 100644
--- a/physics/module_sf_noahmplsm.F90
+++ b/physics/module_sf_noahmplsm.F90
@@ -2116,7 +2116,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in
! thermal properties of soil, snow, lake, and frozen soil
call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
- dt ,snowh ,snice ,snliq , & !in
+ dt ,snowh ,snice ,snliq , shdfac, & !in
smc ,sh2o ,tg ,stc ,ur , & !in
lat ,z0m ,zlvl ,vegtyp , & !in
df ,hcpct ,snicev ,snliqv ,epore , & !out
@@ -2463,7 +2463,7 @@ end subroutine energy
!>\ingroup NoahMP_LSM
subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in
- dt ,snowh ,snice ,snliq , & !in
+ dt ,snowh ,snice ,snliq , shdfac, & !in
smc ,sh2o ,tg ,stc ,ur , & !in
lat ,z0m ,zlvl ,vegtyp , & !in
df ,hcpct ,snicev ,snliqv ,epore , & !out
@@ -2480,6 +2480,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso ,
real (kind=kind_phys) , intent(in) :: dt !< time step [s]
real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snice !< snow ice mass (kg/m2)
real (kind=kind_phys), dimension(-nsnow+1: 0), intent(in) :: snliq !< snow liq mass (kg/m2)
+ real (kind=kind_phys) , intent(in) :: shdfac !< green vegetation fraction [0.0-1.0]
real (kind=kind_phys), dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !< thickness of snow/soil layers [m]
real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: smc !< soil moisture (ice + liq.) [m3/m3]
real (kind=kind_phys), dimension( 1:nsoil), intent(in) :: sh2o !< liquid soil moisture [m3/m3]
@@ -2539,6 +2540,7 @@ subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso ,
! not in use because of the separation of the canopy layer from the ground.
! but this may represent the effects of leaf litter (niu comments)
! df1 = df1 * exp (sbeta * shdfac)
+ df(1) = df(1) * exp (sbeta * shdfac)
! compute lake thermal properties
! (no consideration of turbulent mixing for this version)
@@ -4888,7 +4890,7 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , &
end if
endif ! 4
-! use sfc_diag to calculate t2mv and q2v for opt_sfc=1&3
+! use sfc_diag to calculate t2mb and q2b for opt_sfc=1&3
if(opt_diag ==3) then
if(opt_sfc == 1 .or. opt_sfc == 3) then
@@ -5823,7 +5825,8 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
elseif (opt_trs == chen09) then
- z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
+! z0m_out = exp(fveg * log(z0m) + (1.0 - fveg) * log(z0mg))
+ z0m_out = fveg * z0m + (1.0 - fveg) * z0mg
czil = 10.0 ** (- 0.4 * parameters%hvt)
reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
@@ -5873,7 +5876,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
z0h_out = z0m_out
- elseif (opt_trs == tessel) then
+ elseif (opt_trs == chen09 .or. opt_trs == tessel) then
if (vegtyp <= 5) then
z0h_out = z0m_out
@@ -5881,7 +5884,7 @@ subroutine thermalz0(parameters, fveg, z0m, z0mg, zlvl,
z0h_out = z0m_out * 0.01
endif
- elseif (opt_trs == blumel99 .or. opt_trs == chen09) then
+ elseif (opt_trs == blumel99) then
reyn = ustarx*z0m_out/viscosity ! Blumel99 eqn 36c
if (reyn > 2.0) then
diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90
index 6294bc068..160127e43 100644
--- a/physics/module_sf_ruclsm.F90
+++ b/physics/module_sf_ruclsm.F90
@@ -991,10 +991,12 @@ SUBROUTINE LSMRUC(xlat,xlon, &
if(mosaic_lu == 1) then
! greenness factor: between 0 for min greenness and 1 for max greenness.
factor = max(zero,min(one,(vegfra(i,j)-shdmin(i,j))/max(one,(shdmax(i,j)-shdmin(i,j)))))
+ if (debug_print ) then
if (abs(xlat-testptlat).lt.0.1 .and. &
abs(xlon-testptlon).lt.0.1)then
print *,' lat,lon=',xlat,xlon,' factor=',factor
endif
+ endif
if((ivgtyp(i,j) == natural .or. ivgtyp(i,j) == crop) .and. factor > 0.75) then
! cropland or grassland, apply irrigation during the growing seaspon when fraction
diff --git a/physics/mp_nssl.F90 b/physics/mp_nssl.F90
index 59ca877fa..e79376709 100644
--- a/physics/mp_nssl.F90
+++ b/physics/mp_nssl.F90
@@ -26,13 +26,13 @@ module mp_nssl
!! \htmlinclude mp_nssl_init.html
!!
subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
- mpirank, mpiroot, &
- con_g, con_rd, con_cp, con_rv, &
- con_t0c, con_cliq, con_csol, con_eps, &
- imp_physics, imp_physics_nssl, &
- nssl_cccn, nssl_alphah, nssl_alphahl, &
- nssl_alphar, nssl_ehw0, nssl_ehlw0, &
- nssl_ccn_on, nssl_hail_on, nssl_invertccn )
+ mpirank, mpiroot, &
+ con_g, con_rd, con_cp, con_rv, &
+ con_t0c, con_cliq, con_csol, con_eps, &
+ imp_physics, imp_physics_nssl, &
+ nssl_cccn, nssl_alphah, nssl_alphahl, &
+ nssl_alphar, nssl_ehw0, nssl_ehlw0, &
+ nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment )
use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const
@@ -53,13 +53,13 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl
- real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
! Local variables: dimensions used in nssl_init
integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k
real :: nssl_params(20)
- integer :: ihailv
+ integer :: ihailv,ipc
! Initialize the CCPP error handling variables
@@ -104,9 +104,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(:) = 0.0
- nssl_params(1) = nssl_cccn
- nssl_params(2) = nssl_alphah
- nssl_params(3) = nssl_alphahl
+ ! nssl_params(1) = nssl_cccn ! use direct interface instead
+ ! nssl_params(2) = nssl_alphah ! use direct interface instead
+ ! nssl_params(3) = nssl_alphahl ! use direct interface instead
nssl_params(4) = 4.e5 ! nssl_cnoh -- not used for 2-moment
nssl_params(5) = 4.e4 ! nssl_cnohl-- not used for 2-moment
nssl_params(6) = 4.e5 ! nssl_cnor-- not used for 2-moment
@@ -114,10 +114,6 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
nssl_params(8) = 500. ! nssl_rho_qh
nssl_params(9) = 800. ! nssl_rho_qhl
nssl_params(10) = 100. ! nssl_rho_qs
- nssl_params(11) = 0 ! nssl_ipelec_tmp
- nssl_params(12) = 11 ! nssl_isaund
- nssl_params(13) = 0 ! 1= turn on cccna; 0 = turn off
- nssl_params(15) = nssl_alphar
nssl_qccn = nssl_cccn/1.225
! if (mpirank==mpiroot) then
@@ -129,10 +125,21 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, &
ELSE
ihailv = -1
ENDIF
+
+ IF ( nssl_3moment ) THEN
+ ipc = 8
+ ELSE
+ ipc = 5
+ ENDIF
! write(0,*) 'call nssl_2mom_init'
- CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0, &
- ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg,errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
+ CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, &
+ ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, &
+ nssl_alphar=nssl_alphar, &
+ nssl_alphah=nssl_alphah, &
+ nssl_alphahl=nssl_alphahl, &
+ nssl_cccn=nssl_cccn, &
+ errflg=errflg,myrank=mpirank,mpiroot=mpiroot)
! For restart runs, the init is done here
if (restart) then
@@ -158,17 +165,18 @@ end subroutine mp_nssl_init
!! \htmlinclude mp_nssl_run.html
!!
subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
-! spechum, cccn, qc, qr, qi, qs, qh, qhl, &
- spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
- ccw, crw, cci, csw, chw, chl, vh, vhl, &
- tgrs, prslk, prsl, phii, omega, dtp, &
- prcp, rain, graupel, ice, snow, sr, &
+ spechum, cccn, cccna, qc, qr, qi, qs, qh, qhl, &
+ ccw, crw, cci, csw, chw, chl, vh, vhl, &
+ zrw, zhw, zhl, &
+ tgrs, prslk, prsl, phii, omega, dtp, &
+ prcp, rain, graupel, ice, snow, sr, &
refl_10cm, do_radar_ref, first_time_step, restart, &
- re_cloud, re_ice, re_snow, re_rain, &
- nleffr, nieffr, nseffr, nreffr, &
- imp_physics, convert_dry_rho, &
- imp_physics_nssl, nssl_ccn_on, &
- nssl_hail_on, nssl_invertccn, ntccn, ntccna, &
+ re_cloud, re_ice, re_snow, re_rain, &
+ nleffr, nieffr, nseffr, nreffr, &
+ imp_physics, convert_dry_rho, &
+ imp_physics_nssl, nssl_ccn_on, &
+ nssl_hail_on, nssl_invertccn, nssl_3moment, &
+ ntccn, ntccna, &
errflg, errmsg)
use module_mp_nssl_2mom, only: calcnfromq, na
@@ -197,6 +205,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
real(kind_phys), intent(inout) :: chl(:,:) !(1:ncol,1:nlev) hail number
real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume
real(kind_phys), intent(inout) :: vhl(:,:) !(1:ncol,1:nlev) hail volume
+ real(kind_phys), intent(inout) :: zrw(:,:) !(1:ncol,1:nlev) rain reflectivity
+ real(kind_phys), intent(inout) :: zhw(:,:) !(1:ncol,1:nlev) graupel reflectivity
+ real(kind_phys), intent(inout) :: zhl(:,:) !(1:ncol,1:nlev) hail reflectivity
! State variables and timestep information
real(kind_phys), intent(inout) :: tgrs (:,:) !(1:ncol,1:nlev)
real(kind_phys), intent(in ) :: prsl (:,:) !(1:ncol,1:nlev)
@@ -223,7 +234,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
integer, intent(in) :: nleffr, nieffr, nseffr, nreffr
integer, intent(in) :: imp_physics
integer, intent(in) :: imp_physics_nssl
- logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn
+ logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment
integer, intent(in) :: ntccn, ntccna
integer, intent(out) :: errflg
@@ -256,6 +267,9 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
! create temporaries for hail in case it does not exist
!real(kind_phys) :: chl_mp(1:ncol,1:nlev) !< kg-1 (number mixing ratio)
real(kind_phys) :: vhl_mp(1:ncol,1:nlev) !< m3 kg-1 (volume mixing ratio)
+ real(kind_phys) :: zrw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhw_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
+ real(kind_phys) :: zhl_mp(1:ncol,1:nlev) !< m6 kg-1 (reflectivity)
! Vertical velocity and level width
real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1
real(kind_phys) :: dz(1:ncol,1:nlev) !< m
@@ -342,10 +356,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ns_mp = csw/(1.0_kind_phys-spechum)
nh_mp = chw/(1.0_kind_phys-spechum)
vh_mp = vh/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw/(1.0_kind_phys-spechum)
+ zhw_mp = zhw/(1.0_kind_phys-spechum)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl/(1.0_kind_phys-spechum)
nhl_mp = chl/(1.0_kind_phys-spechum)
vhl_mp = vhl/(1.0_kind_phys-spechum)
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl/(1.0_kind_phys-spechum)
+ ENDIF
ENDIF
ELSE
! qv_mp = spechum ! /(1.0_kind_phys-spechum)
@@ -361,10 +382,18 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ni_mp = cci
ns_mp = csw
nh_mp = chw
+ vh_mp = vh
+ IF ( nssl_3moment ) THEN
+ zrw_mp = zrw
+ zhw_mp = zhw
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl_mp = qhl ! /(1.0_kind_phys-spechum)
nhl_mp = chl
vhl_mp = vhl
+ IF ( nssl_3moment ) THEN
+ zhl_mp = zhl
+ ENDIF
ENDIF
ENDIF
@@ -572,110 +601,114 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
IF ( nssl_ccn_on ) THEN
-
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- cn=cn_mp, &
-! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
- cna=cna_mp, f_cna=.false. , &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+ cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+ cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
ELSE
- CALL nssl_2mom_driver( &
- ITIMESTEP=itimestep, &
- ! TH=th, &
- tt=tgrs, &
- QV=qv_mp, &
- QC=qc_mp, &
- QR=qr_mp, &
- QI=qi_mp, &
- QS=qs_mp, &
- QH=qh_mp, &
- QHL=qhl_mp, &
-! CCW=qnc_mp, &
- CCW=nc_mp, &
- CRW=nr_mp, &
- CCI=ni_mp, &
- CSW=ns_mp, &
- CHW=nh_mp, &
- CHL=nhl_mp, &
- VHW=vh_mp, &
- VHL=vhl_mp, &
- ! cn=cccn, &
- PII=prslk, &
- P=prsl, &
- W=w, &
- DZ=dz, &
- DTP=dtptmp, &
- DN=rho, &
- rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
- snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
-! icenc=ice_mp, icencv=delta_ice_mp, &
- GRPLNC=xgraupel_mp, GRPLNCV=xdelta_graupel_mp, sr=sr, &
- dbz = refl_10cm, &
-! nssl_progn=.false., &
- diagflag = diagflag, &
- errmsg=errmsg,errflg=errflg, &
- re_cloud=re_cloud_mp, &
- re_ice=re_ice_mp, &
- re_snow=re_snow_mp, &
- re_rain=re_rain_mp, &
- has_reqc=has_reqc, & ! ala G. Thompson
- has_reqi=has_reqi, & ! ala G. Thompson
- has_reqs=has_reqs, & ! ala G. Thompson
- has_reqr=has_reqr, &
+ CALL nssl_2mom_driver( &
+ ITIMESTEP=itimestep, &
+ ! TH=th, &
+ tt=tgrs, &
+ QV=qv_mp, &
+ QC=qc_mp, &
+ QR=qr_mp, &
+ QI=qi_mp, &
+ QS=qs_mp, &
+ QH=qh_mp, &
+ QHL=qhl_mp, &
+ CCW=nc_mp, &
+ CRW=nr_mp, &
+ CCI=ni_mp, &
+ CSW=ns_mp, &
+ CHW=nh_mp, &
+ CHL=nhl_mp, &
+ VHW=vh_mp, &
+ VHL=vhl_mp, &
+! cn=cn_mp, &
+ ZRW=zrw_mp, &
+ ZHW=zhw_mp, &
+ ZHL=zhl_mp, &
+! cna=cna_mp, f_cna=( ntccna > 0 ), & ! for future use
+! cna=cna_mp, f_cna=.false. , &
+ PII=prslk, &
+ P=prsl, &
+ W=w, &
+ DZ=dz, &
+ DTP=dtptmp, &
+ DN=rho, &
+ rainnc=xrain_mp, rainncv=xdelta_rain_mp, &
+ snownc=xsnow_mp, snowncv=xdelta_snow_mp, &
+ GRPLNC=xgraupel_mp, &
+ GRPLNCV=xdelta_graupel_mp, &
+ sr=sr, &
+ dbz = refl_10cm, &
+ diagflag = diagflag, &
+ errmsg=errmsg,errflg=errflg, &
+ re_cloud=re_cloud_mp, &
+ re_ice=re_ice_mp, &
+ re_snow=re_snow_mp, &
+ re_rain=re_rain_mp, &
+ has_reqc=has_reqc, &
+ has_reqi=has_reqi, &
+ has_reqs=has_reqs, &
+ has_reqr=has_reqr, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
)
-
+
ENDIF
-
-
+
DO i = 1,ncol
delta_rain_mp(i) = delta_rain_mp(i) + xdelta_rain_mp(i) ! this is liquid equivalent of all precip
delta_graupel_mp(i) = delta_graupel_mp(i) + xdelta_graupel_mp(i) ! this is liquid equivalent of graupel
@@ -684,7 +717,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
ENDDO
ENDDO
-
+
ENDIF
@@ -750,10 +783,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp/(1.0_kind_phys+qv_mp)
chw = nh_mp/(1.0_kind_phys+qv_mp)
vh = vh_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp/(1.0_kind_phys+qv_mp)
+ zhw = zhw_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp/(1.0_kind_phys+qv_mp)
chl = nhl_mp/(1.0_kind_phys+qv_mp)
vhl = vhl_mp/(1.0_kind_phys+qv_mp)
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp/(1.0_kind_phys+qv_mp)
+ ENDIF
ENDIF
ELSE
! spechum = qv_mp ! /(1.0_kind_phys+qv_mp)
@@ -770,10 +810,17 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, &
csw = ns_mp
chw = nh_mp
vh = vh_mp
+ IF ( nssl_3moment ) THEN
+ zrw = zrw_mp
+ zhw = zhw_mp
+ ENDIF
IF ( nssl_hail_on ) THEN
qhl = qhl_mp ! /(1.0_kind_phys+qv_mp)
chl = nhl_mp
vhl = vhl_mp
+ IF ( nssl_3moment ) THEN
+ zhl = zhl_mp
+ ENDIF
ENDIF
ENDIF
diff --git a/physics/mp_nssl.meta b/physics/mp_nssl.meta
index 6bbf92c73..337b1ab76 100644
--- a/physics/mp_nssl.meta
+++ b/physics/mp_nssl.meta
@@ -210,6 +210,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
########################################################################
[ccpp-arg-table]
name = mp_nssl_run
@@ -387,6 +394,30 @@
type = real
kind = kind_phys
intent = inout
+[zrw]
+ standard_name = reflectivity_of_rain_of_new_state
+ long_name = rain reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhw]
+ standard_name = reflectivity_of_graupel_of_new_state
+ long_name = graupel reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
+[zhl]
+ standard_name = reflectivity_of_hail_of_new_state
+ long_name = hail reflectivity
+ units = m6 kg-1
+ dimensions = (horizontal_loop_extent,vertical_layer_dimension)
+ type = real
+ kind = kind_phys
+ intent = inout
[tgrs]
standard_name = air_temperature_of_new_state
long_name = model layer mean temperature
@@ -614,6 +645,13 @@
dimensions = ()
type = logical
intent = in
+[nssl_3moment]
+ standard_name = nssl_3moment
+ long_name = 3-moment activation flag in NSSL microphysics scheme
+ units = flag
+ dimensions = ()
+ type = logical
+ intent = in
[ntccn]
standard_name = index_of_cloud_condensation_nuclei_number_concentration_in_tracer_concentration_array
long_name = tracer index for cloud condensation nuclei number concentration
diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90
index 6a95a706c..c456e87cd 100644
--- a/physics/mp_thompson.F90
+++ b/physics/mp_thompson.F90
@@ -409,7 +409,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, &
integer, intent(in) :: n_var_spp
real(kind_phys), intent(in) :: spp_wts_mp(:,:)
real(kind_phys), intent(in) :: spp_prt_list(:)
- character(len=3), intent(in) :: spp_var_list(:)
+ character(len=10), intent(in) :: spp_var_list(:)
real(kind_phys), intent(in) :: spp_stddev_cutoff(:)
logical, intent (in) :: cplchm
diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta
index 691698281..5918e4dd9 100644
--- a/physics/mp_thompson.meta
+++ b/physics/mp_thompson.meta
@@ -725,7 +725,7 @@
units = none
dimensions = (number_of_perturbed_spp_schemes)
type = character
- kind = len=3
+ kind = len=10
intent = in
[cplchm]
standard_name = flag_for_chemistry_coupling
diff --git a/physics/mynnsfc_wrapper.F90 b/physics/mynnsfc_wrapper.F90
index 1a970c9f4..3c033e65e 100644
--- a/physics/mynnsfc_wrapper.F90
+++ b/physics/mynnsfc_wrapper.F90
@@ -191,6 +191,16 @@ SUBROUTINE mynnsfc_wrapper_run( &
& IMS,IME,JMS,JME,KMS,KME, &
& ITS,ITE,JTS,JTE,KTS,KTE
+!$acc enter data create(hfx, znt, psim, psih, chs, &
+!$acc mavail, xland, GZ1OZ0, cpm, qgh, &
+!$acc qfx, snowh_wat)
+
+!$acc enter data create(dz, th, qv)
+
+!$acc enter data copyin(rmol, phii, t3d, exner, qvsh, slmsk, xland)
+
+!$acc enter data copyin(dry, wet, icy, znt_lnd, znt_wat, znt_ice, qsfc_lnd, qsfc_ice, qsfc_lnd_ruc, qsfc_ice_ruc)
+
! Initialize CCPP error handling variables
errmsg = ''
errflg = 0
@@ -203,6 +213,7 @@ SUBROUTINE mynnsfc_wrapper_run( &
! write(0,*)"iter=",iter
! endif
+!$acc kernels
! prep MYNN-only variables
dz(:,:) = 0
th(:,:) = 0
@@ -210,6 +221,9 @@ SUBROUTINE mynnsfc_wrapper_run( &
hfx(:) = 0
qfx(:) = 0
rmol(:) = 0
+!$acc end kernels
+
+!$acc parallel loop collapse(2) present(dz, phii, th, t3d, exner, qv, qvsh)
do k=1,2 !levs
do i=1,im
dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv
@@ -219,6 +233,7 @@ SUBROUTINE mynnsfc_wrapper_run( &
enddo
enddo
+!$acc parallel loop present(slmsk, xland, qgh, mavail, cpm, snowh_wat)
do i=1,im
if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3
xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn
@@ -235,6 +250,7 @@ SUBROUTINE mynnsfc_wrapper_run( &
snowh_wat(i) = 0.0
enddo
+!$acc kernels
! cm -> m
where (dry) znt_lnd=znt_lnd*0.01
where (wet) znt_wat=znt_wat*0.01
@@ -245,6 +261,7 @@ SUBROUTINE mynnsfc_wrapper_run( &
where (dry) qsfc_lnd = qsfc_lnd_ruc/(1.+qsfc_lnd_ruc) ! spec. hum
where (icy) qsfc_ice = qsfc_ice_ruc/(1.+qsfc_ice_ruc) ! spec. hum.
end if
+!$acc end kernels
! if (lprnt) then
! write(0,*)"CALLING SFCLAY_mynn; input:"
@@ -274,6 +291,8 @@ SUBROUTINE mynnsfc_wrapper_run( &
! write(0,*)"PBLH=",pblh(1)," xland=",xland(1)
! endif
+!$acc exit data delete(qsfc_lnd_ruc, qsfc_ice_ruc)
+!$acc exit data delete(phii, qvsh, slmsk)
CALL SFCLAY_mynn( &
u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, &
@@ -318,6 +337,13 @@ SUBROUTINE mynnsfc_wrapper_run( &
errmsg=errmsg, errflg=errflg )
if (errflg/=0) return
+!$acc exit data delete(hfx, znt, psim, psih, chs, &
+!$acc mavail, xland, GZ1OZ0, cpm, qgh, &
+!$acc qfx, snowh_wat, t3d, exner)
+!$acc exit data delete(dz, th, qv)
+!$acc exit data copyout(rmol)
+!$acc exit data copyout(qsfc_lnd, qsfc_ice)
+
!! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK:
!do i = 1, im
! !* Taken from sfc_nst.f
@@ -336,10 +362,15 @@ SUBROUTINE mynnsfc_wrapper_run( &
! znt_ice(i)=znt_ice(i)*100.
!enddo
+!$acc kernels
! m -> cm
where (dry) znt_lnd=znt_lnd*100.
where (wet) znt_wat=znt_wat*100.
where (icy) znt_ice=znt_ice*100.
+!$acc end kernels
+
+!$acc exit data delete(dry, wet, icy)
+!$acc exit data copyout(znt_lnd, znt_wat, znt_ice)
! if (lprnt) then
! write(0,*)
diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90
index 3b06d7f53..753c8ff24 100644
--- a/physics/noahmp_tables.f90
+++ b/physics/noahmp_tables.f90
@@ -484,6 +484,9 @@ subroutine read_mp_table_parameters(errmsg, errflg)
sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, &
sr2006_smcmax_b
+ errmsg = ''
+ errflg = 0
+
! initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything.
! vegetation parameters
isurban_table = -99999
@@ -783,7 +786,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if ( ierr /= 0 ) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -914,7 +917,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if ( ierr /= 0 ) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -957,7 +960,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if ( ierr /= 0 ) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -982,7 +985,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -1011,7 +1014,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -1069,7 +1072,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -1096,7 +1099,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -1249,7 +1252,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
@@ -1278,7 +1281,7 @@ subroutine read_mp_table_parameters(errmsg, errflg)
open(15, status='old', form='formatted', action='read', iostat=ierr)
end if
if (ierr /= 0) then
- errmsg = 'warning: cannot find file noahmptable.tb'
+ errmsg = 'warning: cannot find file noahmptable.tbl'
errflg = 1
return
! write(*,'("warning: cannot find file noahmptable.tbl")')
diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90
index 4500d51a8..c2c03d0de 100644
--- a/physics/noahmpdrv.F90
+++ b/physics/noahmpdrv.F90
@@ -450,7 +450,7 @@ subroutine noahmpdrv_run &
integer :: iopt_pedo = 1 ! option for pedotransfer function
integer :: iopt_crop = 0 ! option for crop model
integer :: iopt_gla = 2 ! option for glacier treatment
- integer :: iopt_z0m = 2 ! option for z0m treatment
+ integer :: iopt_z0m = 1 ! option for z0m treatment
!
! --- local inputs to noah-mp and glacier subroutines; listed in order in noah-mp call
diff --git a/physics/ozinterp.f90 b/physics/ozinterp.f90
deleted file mode 100644
index 5b3149d61..000000000
--- a/physics/ozinterp.f90
+++ /dev/null
@@ -1,212 +0,0 @@
-!>\file ozinterp.f90
-!! This file contains ozone climatology interpolation subroutines.
-
-!>\ingroup mod_GFS_phys_time_vary
-!! This module contains subroutines of reading and interpolating ozone coefficients.
-module ozinterp
-
- implicit none
-
- private
-
- public :: read_o3data, setindxoz, ozinterpol
-
-contains
-
- SUBROUTINE read_o3data (ntoz, me, master)
- use machine, only: kind_phys
- use ozne_def
-!--- in/out
- integer, intent(in) :: ntoz
- integer, intent(in) :: me
- integer, intent(in) :: master
-!--- locals
- integer :: i, n, k
- real(kind=4), allocatable, dimension(:) :: oz_lat4, oz_pres4
- real(kind=4), allocatable, dimension(:) :: oz_time4, tempin
- real(kind=4) :: blatc4
-
- if (ntoz <= 0) then ! Diagnostic ozone
- rewind (kozc)
- read (kozc,end=101) latsozc, levozc, timeozc, blatc4
- 101 if (levozc < 10 .or. levozc > 100) then
- rewind (kozc)
- levozc = 17
- latsozc = 18
- blatc = -85.0
- else
- blatc = blatc4
- endif
- latsozp = 2
- levozp = 1
- timeoz = 1
- oz_coeff = 0
- dphiozc = -(blatc+blatc)/(latsozc-1)
- return
- endif
-
- open(unit=kozpl,file='global_o3prdlos.f77', form='unformatted', convert='big_endian')
-
-!--- read in indices
-!---
- read (kozpl) oz_coeff, latsozp, levozp, timeoz
- if (me == master) then
- write(*,*) 'Reading in o3data from global_o3prdlos.f77 '
- write(*,*) ' oz_coeff = ', oz_coeff
- write(*,*) ' latsozp = ', latsozp
- write(*,*) ' levozp = ', levozp
- write(*,*) ' timeoz = ', timeoz
- endif
-
-!--- read in data
-!--- oz_lat - latitude of data (-90 to 90)
-!--- oz_pres - vertical pressure level (mb)
-!--- oz_time - time coordinate (days)
-!---
- allocate (oz_lat(latsozp), oz_pres(levozp),oz_time(timeoz+1))
- allocate (oz_lat4(latsozp), oz_pres4(levozp),oz_time4(timeoz+1))
- rewind (kozpl)
- read (kozpl) oz_coeff, latsozp, levozp, timeoz, oz_lat4, oz_pres4, oz_time4
- oz_pres(:) = oz_pres4(:)
-!--- convert pressure levels from mb to ln(Pa)
- oz_pres(:) = log(100.0*oz_pres(:))
- oz_lat(:) = oz_lat4(:)
- oz_time(:) = oz_time4(:)
- deallocate (oz_lat4, oz_pres4, oz_time4)
-
-!--- read in ozplin which is in order of (lattitudes, ozone levels, coeff number, time)
-!--- assume latitudes is on a uniform gaussian grid
-!---
- allocate (tempin(latsozp))
- allocate (ozplin(latsozp,levozp,oz_coeff,timeoz))
- DO i=1,timeoz
- DO n=1,oz_coeff
- DO k=1,levozp
- READ(kozpl) tempin
- ozplin(:,k,n,i) = tempin(:)
- ENDDO
- ENDDO
- ENDDO
- deallocate (tempin)
-
- close(kozpl)
-
- END SUBROUTINE read_o3data
-!
-!**********************************************************************
-!
- SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy)
-!
- USE MACHINE, ONLY: kind_phys
- USE OZNE_DEF, ONLY: jo3 => latsozp, oz_lat
-!
- implicit none
-!
- integer npts, JINDX1(npts),JINDX2(npts)
- real(kind=kind_phys) dlat(npts),DDY(npts)
-!
- integer i,j,lat
-!
- DO J=1,npts
- jindx2(j) = jo3 + 1
- do i=1,jo3
- if (dlat(j) < oz_lat(i)) then
- jindx2(j) = i
- exit
- endif
- enddo
- jindx1(j) = max(jindx2(j)-1,1)
- jindx2(j) = min(jindx2(j),jo3)
- if (jindx2(j) .ne. jindx1(j)) then
- DDY(j) = (dlat(j) - oz_lat(jindx1(j))) &
- / (oz_lat(jindx2(j)) - oz_lat(jindx1(j)))
- else
- ddy(j) = 1.0
- endif
-! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), &
-! jjindx2(j),' oz_lat=',oz_lat(jindx1(j)), &
-! oz_lat(jindx2(j)),' ddy=',ddy(j)
- ENDDO
-
- RETURN
- END SUBROUTINE setindxoz
-!
-!**********************************************************************
-!
- SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy)
-!
- USE MACHINE, ONLY : kind_phys
- USE OZNE_DEF
- implicit none
- integer iday,j,j1,j2,l,npts,nc,n1,n2
- real(kind=kind_phys) fhour,tem, tx1, tx2
-!
-
- integer JINDX1(npts), JINDX2(npts)
- integer me, idate(4), IDAT(8),JDAT(8)
-!
- real(kind=kind_phys) DDY(npts)
- real(kind=kind_phys) ozplout(npts,levozp,oz_coeff)
- real(kind=kind_phys) rjday
- integer jdow, jdoy, jday
- real(8) rinc(5)
- real(4) rinc4(5)
- integer w3kindreal,w3kindint
-!
- IDAT=0
- IDAT(1)=IDATE(4)
- IDAT(2)=IDATE(2)
- IDAT(3)=IDATE(3)
- IDAT(5)=IDATE(1)
- RINC=0.
- RINC(2)=FHOUR
- call w3kind(w3kindreal,w3kindint)
- if(w3kindreal==4) then
- rinc4=rinc
- CALL W3MOVDAT(RINC4,IDAT,JDAT)
- else
- CALL W3MOVDAT(RINC,IDAT,JDAT)
- endif
-!
- jdow = 0
- jdoy = 0
- jday = 0
- call w3doxdat(jdat,jdow,jdoy,jday)
- rjday = jdoy + jdat(5) / 24.
- IF (RJDAY < oz_time(1)) RJDAY = RJDAY + 365.
-!
- n2 = timeoz + 1
- do j=2,timeoz
- if (rjday < oz_time(j)) then
- n2 = j
- exit
- endif
- enddo
- n1 = n2 - 1
-!
-! if (me == 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday
-! &,'oz_time=',oz_time(n1),oz_time(n2)
-!
-
- tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1))
- tx2 = 1.0 - tx1
-
- if (n2 > timeoz) n2 = n2 - timeoz
-!
- do nc=1,oz_coeff
- DO L=1,levozp
- DO J=1,npts
- J1 = JINDX1(J)
- J2 = JINDX2(J)
- TEM = 1.0 - DDY(J)
- ozplout(j,L,nc) = &
- tx1*(TEM*ozplin(J1,L,nc,n1)+DDY(J)*ozplin(J2,L,nc,n1)) &
- + tx2*(TEM*ozplin(J1,L,nc,n2)+DDY(J)*ozplin(J2,L,nc,n2))
- ENDDO
- ENDDO
- enddo
-!
- RETURN
- END SUBROUTINE ozinterpol
-
-end module ozinterp
diff --git a/physics/ozne_def.f b/physics/ozne_def.f
deleted file mode 100644
index 8f3af6240..000000000
--- a/physics/ozne_def.f
+++ /dev/null
@@ -1,24 +0,0 @@
-!>\file ozne_def.f
-!! This file contains the ozone array definition used in ozone physics.
-
-!>\ingroup mod_GFS_phys_time_vary
-!! This module defines arrays in Ozone scheme.
- module ozne_def
-
-!> \section arg_table_ozne_def
-!! \htmlinclude ozne_def.html
-!!
-
- use machine , only : kind_phys
- implicit none
-
- integer, parameter :: kozpl=28, kozc=48
-
- integer latsozp, levozp, timeoz, latsozc, levozc, timeozc
- &, oz_coeff
- real (kind=kind_phys) blatc, dphiozc
- real (kind=kind_phys), allocatable :: oz_lat(:), oz_pres(:)
- &, oz_time(:)
- real (kind=kind_phys), allocatable :: ozplin(:,:,:,:)
-
- end module ozne_def
diff --git a/physics/ozne_def.meta b/physics/ozne_def.meta
deleted file mode 100644
index 3cad9c14d..000000000
--- a/physics/ozne_def.meta
+++ /dev/null
@@ -1,29 +0,0 @@
-[ccpp-table-properties]
- name = ozne_def
- type = module
- dependencies = machine.F
-
-[ccpp-arg-table]
- name = ozne_def
- type = module
-
-[levozp]
- standard_name = vertical_dimension_of_ozone_forcing_data
- long_name = number of vertical layers in ozone forcing data
- units = count
- dimensions = ()
- type = integer
-[oz_coeff]
- standard_name = number_of_coefficients_in_ozone_forcing_data
- long_name = number of coefficients in ozone forcing data
- units = index
- dimensions = ()
- type = integer
-[oz_pres]
- standard_name = natural_log_of_ozone_forcing_data_pressure_levels
- long_name = natural log of ozone forcing data pressure levels in Pa
- units = 1
- dimensions = (vertical_dimension_of_ozone_forcing_data)
- type = real
- kind = kind_phys
- active = (index_of_ozone_mixing_ratio_in_tracer_concentration_array>0)
diff --git a/physics/ozphys.f b/physics/ozphys.f
deleted file mode 100644
index 18a9ae46f..000000000
--- a/physics/ozphys.f
+++ /dev/null
@@ -1,211 +0,0 @@
-!> \file ozphys.f
-!! This file is ozone sources and sinks (previous version).
-
-
-!> This module contains the CCPP-compliant Ozone photochemistry scheme.
- module ozphys
-
- contains
-
-! \brief Brief description of the subroutine
-!
-!> \section arg_table_ozphys_init Argument Table
-!! \htmlinclude ozphys_init.html
-!!
- subroutine ozphys_init(oz_phys, errmsg, errflg)
-
- implicit none
- logical, intent(in) :: oz_phys
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if (.not.oz_phys) then
- write (errmsg,'(*(a))') 'Logic error: oz_phys == .false.'
- errflg = 1
- return
- endif
-
- end subroutine ozphys_init
-
-!>\defgroup GFS_ozphys GFS ozphys Main
-!! \brief The operational GFS currently parameterizes ozone production and
-!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval
-!! Research Laboratory through CHEM2D chemistry model
-!! (McCormack et al. (2006) \cite mccormack_et_al_2006).
-!! \section arg_table_ozphys_run Argument Table
-!! \htmlinclude ozphys_run.html
-!!
-!> \section genal_ozphys GFS ozphys_run General Algorithm
-!> @{
- subroutine ozphys_run ( &
- & im, levs, ko3, dt, oz, tin, po3, &
- & prsl, prdout, oz_coeff, delp, ldiag3d, &
- & ntoz, dtend, dtidx, index_of_process_prod_loss, &
- & index_of_process_ozmix, index_of_process_temp, &
- & index_of_process_overhead_ozone, con_g, me, errmsg, errflg)
-!
-! this code assumes that both prsl and po3 are from bottom to top
-! as are all other variables
-!
- use machine , only : kind_phys
- implicit none
-!
- ! Interface variables
- integer, intent(in) :: im, levs, ko3, oz_coeff, me
- real(kind=kind_phys), intent(inout) :: oz(:,:)
- real(kind=kind_phys), intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), ntoz, &
- & index_of_process_prod_loss, index_of_process_ozmix, &
- & index_of_process_temp, index_of_process_overhead_ozone
- real(kind=kind_phys), intent(in) :: &
- & dt, po3(:), prdout(:,:,:), &
- & prsl(:,:), tin(:,:), delp(:,:), &
- & con_g
- real :: gravi
- logical, intent(in) :: ldiag3d
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-!
- ! Local variables
- integer k,kmax,kmin,l,i,j, idtend(4)
- logical flg(im)
- real(kind=kind_phys) pmax, pmin, tem, temp
- real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff),
- & ozib(im), colo3(im,levs+1), ozi(im,levs)
-!
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-!
-! save input oz in ozi
- ozi = oz
- gravi=1.0/con_g
-
-
- if(ldiag3d) then
- idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1
- idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2
- idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3
- idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4
- else
- idtend=0
- endif
-
-!
-!> - Calculate vertical integrated column ozone values.
- if (oz_coeff > 2) then
- colo3(:,levs+1) = 0.0
- do l=levs,1,-1
- do i=1,im
- colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi
- enddo
- enddo
- endif
-!
-!> - Apply vertically linear interpolation to the ozone coefficients.
- do l=1,levs
- pmin = 1.0e10
- pmax = -1.0e10
-!
- do i=1,im
- wk1(i) = log(prsl(i,l))
- pmin = min(wk1(i), pmin)
- pmax = max(wk1(i), pmax)
- prod(i,:) = 0.0
- enddo
- kmax = 1
- kmin = 1
- do k=1,ko3-1
- if (pmin < po3(k)) kmax = k
- if (pmax < po3(k)) kmin = k
- enddo
-!
- do k=kmin,kmax
- temp = 1.0 / (po3(k) - po3(k+1))
- do i=1,im
- flg(i) = .false.
- if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then
- flg(i) = .true.
- wk2(i) = (wk1(i) - po3(k+1)) * temp
- wk3(i) = 1.0 - wk2(i)
- endif
- enddo
- do j=1,oz_coeff
- do i=1,im
- if (flg(i)) then
- prod(i,j) = wk2(i) * prdout(i,k,j)
- & + wk3(i) * prdout(i,k+1,j)
- endif
- enddo
- enddo
- enddo
-!
- do j=1,oz_coeff
- do i=1,im
- if (wk1(i) < po3(ko3)) then
- prod(i,j) = prdout(i,ko3,j)
- endif
- if (wk1(i) >= po3(1)) then
- prod(i,j) = prdout(i,1,j)
- endif
- enddo
- enddo
-
- if (oz_coeff == 2) then
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt)
- enddo
-!
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & prod(:,1)*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l) - ozib(:))
- endif
- endif
-!> - Calculate the 4 terms of prognostic ozone change during time \a dt:
-!! - ozp1(:,:) - Ozone production from production/loss ratio
-!! - ozp2(:,:) - Ozone production from ozone mixing ratio
-!! - ozp3(:,:) - Ozone production from temperature term at model layers
-!! - ozp4(:,:) - Ozone production from column ozone term at model layers
- if (oz_coeff == 4) then
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- tem = prod(i,1) + prod(i,3)*tin(i,l)
- & + prod(i,4)*colo3(i,l+1)
-! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:)
-! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1)
- oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt)
- enddo
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & prod(:,1)*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l)-ozib(:))
- endif
- if(idtend(3)>=1) then
- dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3
- & prod(:,3)*tin(:,l)*dt
- endif
- if(idtend(4)>=1) then
- dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4
- & prod(:,4)*colo3(:,l+1)*dt
- endif
- endif
- enddo ! vertical loop
-!
- return
- end subroutine ozphys_run
-!> @}
-
- end module ozphys
diff --git a/physics/ozphys.meta b/physics/ozphys.meta
deleted file mode 100644
index 485e2a491..000000000
--- a/physics/ozphys.meta
+++ /dev/null
@@ -1,208 +0,0 @@
-[ccpp-table-properties]
- name = ozphys
- type = scheme
- dependencies = machine.F
-
-########################################################################
-[ccpp-arg-table]
- name = ozphys_init
- type = scheme
-[oz_phys]
- standard_name = flag_for_nrl_2006_ozone_scheme
- long_name = flag for old (2006) ozone physics
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
-
-########################################################################
-[ccpp-arg-table]
- name = ozphys_run
- type = scheme
-[im]
- standard_name = horizontal_loop_extent
- long_name = horizontal loop extent
- units = count
- dimensions = ()
- type = integer
- intent = in
-[levs]
- standard_name = vertical_layer_dimension
- long_name = number of vertical layers
- units = count
- dimensions = ()
- type = integer
- intent = in
-[ko3]
- standard_name = vertical_dimension_of_ozone_forcing_data
- long_name = number of vertical layers in ozone forcing data
- units = count
- dimensions = ()
- type = integer
- intent = in
-[dt]
- standard_name = timestep_for_physics
- long_name = physics time step
- units = s
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[oz]
- standard_name = ozone_concentration_of_new_state
- long_name = ozone concentration updated by physics
- units = kg kg-1
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = inout
-[tin]
- standard_name = air_temperature_of_new_state
- long_name = updated air temperature
- units = K
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[po3]
- standard_name = natural_log_of_ozone_forcing_data_pressure_levels
- long_name = natural log of ozone forcing data pressure levels
- units = 1
- dimensions = (vertical_dimension_of_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[prsl]
- standard_name = air_pressure
- long_name = mid-layer pressure
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[prdout]
- standard_name = ozone_forcing
- long_name = ozone forcing coefficients
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_dimension_of_ozone_forcing_data,number_of_coefficients_in_ozone_forcing_data)
- type = real
- kind = kind_phys
- intent = in
-[oz_coeff]
- standard_name = number_of_coefficients_in_ozone_forcing_data
- long_name = number of coefficients in ozone forcing data
- units = index
- dimensions = ()
- type = integer
- intent = in
-[delp]
- standard_name = air_pressure_difference_between_midlayers
- long_name = difference between mid-layer pressures
- units = Pa
- dimensions = (horizontal_loop_extent,vertical_layer_dimension)
- type = real
- kind = kind_phys
- intent = in
-[ldiag3d]
- standard_name = flag_for_diagnostics_3D
- long_name = flag for calculating 3-D diagnostic fields
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[dtend]
- standard_name = cumulative_change_of_state_variables
- long_name = diagnostic tendencies for state variables
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max)
- type = real
- kind = kind_phys
- active = (flag_for_diagnostics_3D)
- intent = inout
-[dtidx]
- standard_name = cumulative_change_of_state_variables_outer_index
- long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index
- units = index
- dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes)
- type = integer
- intent = in
-[ntoz]
- standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array
- long_name = tracer index for ozone mixing ratio
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_prod_loss]
- standard_name = index_of_production_and_loss_process_in_cumulative_change_index
- long_name = index of production and loss effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_ozmix]
- standard_name = index_of_ozone_mixing_ratio_process_in_cumulative_change_index
- long_name = index of ozone mixing ratio effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_temp]
- standard_name = index_of_temperature_process_in_cumulative_change_index
- long_name = index of temperature effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_overhead_ozone]
- standard_name = index_of_overhead_process_in_cumulative_change_index
- long_name = index of overhead ozone effect in photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[con_g]
- standard_name = gravitational_acceleration
- long_name = gravitational acceleration
- units = m s-2
- dimensions = ()
- type = real
- kind = kind_phys
- intent = in
-[me]
- standard_name = mpi_rank
- long_name = rank of the current MPI task
- units = index
- dimensions = ()
- type = integer
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
diff --git a/physics/ozphys_2015.f b/physics/ozphys_2015.f
deleted file mode 100644
index 85c79f733..000000000
--- a/physics/ozphys_2015.f
+++ /dev/null
@@ -1,190 +0,0 @@
-!> \file ozphys_2015.f
-!! This file is ozone sources and sinks.
-
-
- module ozphys_2015
-
- contains
-
-!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Module
-!! This module contains the CCPP-compliant Ozone 2015 photochemistry scheme.
-!> @{
-!> \section arg_table_ozphys_2015_init Argument Table
-!! \htmlinclude ozphys_2015_init.html
-!!
- subroutine ozphys_2015_init(oz_phys_2015, errmsg, errflg)
-
- implicit none
- logical, intent(in) :: oz_phys_2015
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if (.not.oz_phys_2015) then
- write (errmsg,'(*(a))') 'Logic error: oz_phys_2015 == .false.'
- errflg = 1
- return
- endif
-
- end subroutine ozphys_2015_init
-
-!> The operational GFS currently parameterizes ozone production and
-!! destruction based on monthly mean coefficients (
-!! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval
-!! Research Laboratory through CHEM2D chemistry model
-!! (McCormack et al. (2006) \cite mccormack_et_al_2006).
-!! \section arg_table_ozphys_2015_run Argument Table
-!! \htmlinclude ozphys_2015_run.html
-!!
-!> \section genal_ozphys_2015 GFS ozphys_2015_run General Algorithm
-!> - This code assumes that both prsl and po3 are from bottom to top
-!! as are all other variables.
-!> - This code is specifically for NRL parameterization and
-!! climatological T and O3 are in location 5 and 6 of prdout array
-!!\author June 2015 - Shrinivas Moorthi
- subroutine ozphys_2015_run ( &
- & im, levs, ko3, dt, oz, tin, po3, prsl, prdout, pl_coeff, &
- & delp, ldiag3d, dtend, dtidx, ntoz, index_of_process_prod_loss&
- & , index_of_process_ozmix, index_of_process_temp, &
- & index_of_process_overhead_ozone, con_g, me, errmsg, errflg)
-!
-!
- use machine , only : kind_phys
- implicit none
-!
- real(kind=kind_phys),intent(in) :: con_g
- real :: gravi
- integer, intent(in) :: im, levs, ko3, pl_coeff,me
- real(kind=kind_phys), intent(in) :: po3(:), &
- & prsl(:,:), tin(:,:), &
- & delp(:,:), &
- & prdout(:,:,:), dt
- real(kind=kind_phys), intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), ntoz, &
- & index_of_process_prod_loss, index_of_process_ozmix, &
- & index_of_process_temp, index_of_process_overhead_ozone
- real(kind=kind_phys), intent(inout) :: oz(im,levs)
-
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- integer k,kmax,kmin,l,i,j, idtend(4)
- logical ldiag3d, flg(im), qdiag3d
- real(kind=kind_phys) pmax, pmin, tem, temp
- real(kind=kind_phys) wk1(im), wk2(im), wk3(im),prod(im,pl_coeff), &
- & ozib(im), colo3(im,levs+1), coloz(im,levs+1),&
- & ozi(im,levs)
-!
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if(ldiag3d) then
- idtend(1) = dtidx(100+ntoz,index_of_process_prod_loss) ! was ozp1
- idtend(2) = dtidx(100+ntoz,index_of_process_ozmix) ! was ozp2
- idtend(3) = dtidx(100+ntoz,index_of_process_temp) ! was ozp3
- idtend(4) = dtidx(100+ntoz,index_of_process_overhead_ozone) ! was ozp4
- else
- idtend=0
- endif
-
-!ccpp: save input oz in ozi
- ozi = oz
- gravi=1.0/con_g
-
- colo3(:,levs+1) = 0.0
- coloz(:,levs+1) = 0.0
-!
- do l=levs,1,-1
- pmin = 1.0e10
- pmax = -1.0e10
-!
- do i=1,im
- wk1(i) = log(prsl(i,l))
- pmin = min(wk1(i), pmin)
- pmax = max(wk1(i), pmax)
- prod(i,:) = 0.0
- enddo
- kmax = 1
- kmin = 1
- do k=1,ko3-1
- if (pmin < po3(k)) kmax = k
- if (pmax < po3(k)) kmin = k
- enddo
-!
- do k=kmin,kmax
- temp = 1.0 / (po3(k) - po3(k+1))
- do i=1,im
- flg(i) = .false.
- if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then
- flg(i) = .true.
- wk2(i) = (wk1(i) - po3(k+1)) * temp
- wk3(i) = 1.0 - wk2(i)
- endif
- enddo
- do j=1,pl_coeff
- do i=1,im
- if (flg(i)) then
- prod(i,j) = wk2(i) * prdout(i,k,j)
- & + wk3(i) * prdout(i,k+1,j)
- endif
- enddo
- enddo
- enddo
-!
- do j=1,pl_coeff
- do i=1,im
- if (wk1(i) < po3(ko3)) then
- prod(i,j) = prdout(i,ko3,j)
- endif
- if (wk1(i) >= po3(1)) then
- prod(i,j) = prdout(i,1,j)
- endif
- enddo
- enddo
- do i=1,im
- colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi
- coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi
- prod(i,2) = min(prod(i,2), 0.0)
- enddo
-! write(1000+me,*) ' colo3=',colo3(1,l),' coloz=',coloz(1,l)
-! &,' l=',l
- do i=1,im
- ozib(i) = ozi(i,l) ! no filling
- tem = prod(i,1) - prod(i,2) * prod(i,6)
- & + prod(i,3) * (tin(i,l) - prod(i,5))
- & + prod(i,4) * (colo3(i,l)-coloz(i,l))
-
-! if (me .eq. 0) print *,'ozphys_2015 tem=',tem,' prod=',prod(i,:)
-! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1)
-
-!ccpp ozo(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt)
- oz(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt)
- enddo
- if(idtend(1)>=1) then
- dtend(:,l,idtend(1)) = dtend(:,l,idtend(1)) + ! was ozp1
- & (prod(:,1)-prod(:,2)*prod(:,6))*dt
- endif
- if(idtend(2)>=1) then
- dtend(:,l,idtend(2)) = dtend(:,l,idtend(2)) + ! was ozp2
- & (oz(:,l) - ozib(:))
- endif
- if(idtend(3)>=1) then
- dtend(:,l,idtend(3)) = dtend(:,l,idtend(3)) + ! was ozp3
- & prod(:,3)*(tin(:,l)-prod(:,5))*dt
- endif
- if(idtend(4)>=1) then
- dtend(:,l,idtend(4)) = dtend(:,l,idtend(4)) + ! was ozp4
- & prod(:,4) * (colo3(:,l)-coloz(:,l))*dt
- endif
- enddo ! vertical loop
-!
- return
- end subroutine ozphys_2015_run
-
-!> @}
-
- end module ozphys_2015
diff --git a/physics/phys_tend.F90 b/physics/phys_tend.F90
deleted file mode 100644
index e63f44be5..000000000
--- a/physics/phys_tend.F90
+++ /dev/null
@@ -1,96 +0,0 @@
-!>\file phys_tend.F90
-!!
-module phys_tend
-
- use machine, only: kind_phys
-
- implicit none
-
- private
-
- public phys_tend_run
-
-contains
-
-!> \section arg_table_phys_tend_run Argument Table
-!! \htmlinclude phys_tend_run.html
-!!
- subroutine phys_tend_run(ldiag3d, dtend, dtidx, ntracp100, &
- index_of_process_physics, index_of_process_photochem, &
- nprocess, nprocess_summed, is_photochem, ntoz, errmsg, errflg)
-
- ! Interface variables
- logical, intent(in) :: ldiag3d, is_photochem(:)
- real(kind=kind_phys), optional, intent(inout) :: dtend(:,:,:)
- integer, intent(in) :: dtidx(:,:), index_of_process_physics, ntoz, &
- ntracp100, nprocess, nprocess_summed, index_of_process_photochem
- character(len=*), intent(out) :: errmsg
- integer, intent(out) :: errflg
-
- integer :: ichem, iphys, itrac
- logical :: all_true(nprocess)
-
- ! Initialize CCPP error handling variables
- errmsg = ''
- errflg = 0
-
- if(.not.ldiag3d) then
- return
- endif
-
- all_true = .true.
-
- ! Total photochemical tendencies
- itrac=ntoz+100
- ichem = dtidx(itrac,index_of_process_photochem)
- if(ichem>=1) then
- call sum_it(ichem,itrac,is_photochem)
- endif
-
-
- do itrac=2,ntracp100
- ! Total physics tendencies
- iphys = dtidx(itrac,index_of_process_physics)
- if(iphys>=1) then
- call sum_it(iphys,itrac,all_true)
- endif
- enddo
-
- contains
-
- subroutine sum_it(isum,itrac,sum_me)
- implicit none
- integer, intent(in) :: isum ! third index of dtend of summary process
- integer, intent(in) :: itrac ! tracer or state variable being summed
- logical, intent(in) :: sum_me(nprocess) ! false = skip this process
- logical :: first
- integer :: idtend, iprocess
-
- first=.true.
- do iprocess=1,nprocess
- if(iprocess>nprocess_summed) then
- exit ! Don't sum up the sums.
- else if(.not.sum_me(iprocess)) then
- cycle ! We were asked to skip this one.
- endif
- idtend = dtidx(itrac,iprocess)
- if(idtend>=1) then
- ! This tendency was calculated for this tracer, so
- ! accumulate it into the total tendency.
- if(first) then
- dtend(:,:,isum) = dtend(:,:,idtend)
- first=.false.
- else
- dtend(:,:,isum) = dtend(:,:,isum) + dtend(:,:,idtend)
- endif
- endif
- enddo
- if(first) then
- ! No tendencies were calculated, so sum is 0:
- dtend(:,:,isum) = 0
- endif
- end subroutine sum_it
-
- end subroutine phys_tend_run
-
-end module phys_tend
diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta
deleted file mode 100644
index 0f78af20b..000000000
--- a/physics/phys_tend.meta
+++ /dev/null
@@ -1,95 +0,0 @@
-[ccpp-table-properties]
- name = phys_tend
- type = scheme
- dependencies = machine.F
-
-########################################################################
-[ccpp-arg-table]
- name = phys_tend_run
- type = scheme
-[ldiag3d]
- standard_name = flag_for_diagnostics_3D
- long_name = flag for 3d diagnostic fields
- units = flag
- dimensions = ()
- type = logical
- intent = in
-[dtend]
- standard_name = cumulative_change_of_state_variables
- long_name = diagnostic tendencies for state variables
- units = mixed
- dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max)
- type = real
- kind = kind_phys
- intent = inout
-[dtidx]
- standard_name = cumulative_change_of_state_variables_outer_index
- long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index
- units = index
- dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes)
- type = integer
- intent = in
-[ntracp100]
- standard_name = number_of_tracers_plus_one_hundred
- long_name = number of tracers plus one hundred
- units = count
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_physics]
- standard_name = index_of_all_physics_process_in_cumulative_change_index
- long_name = index of all physics transport process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[index_of_process_photochem]
- standard_name = index_of_photochemistry_process_in_cumulative_change_index
- long_name = index of photochemistry process in second dimension of array cumulative change index
- units = index
- dimensions = ()
- type = integer
- intent = in
-[nprocess]
- standard_name = number_of_cumulative_change_processes
- long_name = number of processes that cause changes in state variables
- units = count
- dimensions = ()
- type = integer
- intent = in
-[nprocess_summed]
- standard_name = number_of_physics_causes_of_tracer_changes
- long_name = number of causes in dtidx per tracer summed for total physics tendency
- units = count
- dimensions = ()
- type = integer
- intent = in
-[is_photochem]
- standard_name = flags_for_photochemistry_processes_to_sum
- long_name = flags for photochemistry processes to sum as the total photochemistry process cumulative change
- units = flag
- dimensions = (number_of_cumulative_change_processes)
- type = logical
- intent = in
-[ntoz]
- standard_name = index_of_ozone_mixing_ratio_in_tracer_concentration_array
- long_name = tracer index for ozone mixing ratio
- units = index
- dimensions = ()
- type = integer
- intent = in
-[errmsg]
- standard_name = ccpp_error_message
- long_name = error message for error handling in CCPP
- units = none
- dimensions = ()
- type = character
- kind = len=*
- intent = out
-[errflg]
- standard_name = ccpp_error_code
- long_name = error code for error handling in CCPP
- units = 1
- dimensions = ()
- type = integer
- intent = out
diff --git a/physics/physcons.F90 b/physics/physcons.F90
index e7ec8fb77..19a03ef20 100644
--- a/physics/physcons.F90
+++ b/physics/physcons.F90
@@ -97,6 +97,7 @@ module physcons
real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq
real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv
real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp)
+ real(kind=kind_phys),parameter:: con_1ovg = 1._kind_phys/con_g
!> \name Other Physics/Chemistry constants (source: 2002 CODATA)
real(kind=kind_phys),parameter:: con_c =2.99792458e+8_kind_phys !< speed of light (\f$m/s\f$)
diff --git a/physics/radiation_gases.f b/physics/radiation_gases.f
index ccc3b598a..4c626b348 100644
--- a/physics/radiation_gases.f
+++ b/physics/radiation_gases.f
@@ -1,17 +1,14 @@
!> \file radiation_gases.f
-!! This file contains routines that set up ozone climatological
-!! profiles and other constant gas profiles, such as co2, ch4, n2o,
-!! o2, and those of cfc gases. All data are entered as mixing ratio
-!! by volume, except ozone which is mass mixing ratio (g/g).
+!! This file contains routines that set up gas profiles, such as co2,
+!! ch4, n2o, o2, and those of cfc gases. All data are entered as mixing
+!! ratio by volume
! ========================================================== !!!!!
! 'module_radiation_gases' description !!!!!
! ========================================================== !!!!!
! !
-! set up ozone climatological profiles and other constant gas !
-! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All !
-! data are entered as mixing ratio by volume, except ozone which is !
-! mass mixing ratio (g/g). !
+! set up constant gas profiles, such as co2, ch4, n2o, o2, and those !
+! of cfc gases. All data are entered as mixing ratio by volume !
! !
! in the module, the externally callabe subroutines are : !
! !
@@ -23,16 +20,10 @@
! !
! 'gas_update' -- read in data and update with time !
! input: !
-! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) !
+! ( iyear, imon, iday, ihour, ldoco2, me ) !
! output: !
! ( errflg, errmsg ) !
! !
-! 'getozn' -- setup climatological ozone profile !
-! input: !
-! ( prslk,xlat, !
-! IMAX, LM ) !
-! output: !
-! ( o3mmr ) !
! !
! 'getgases' -- setup constant gas profiles for LW and SW !
! input: !
@@ -47,7 +38,6 @@
! 'module module_iounitdef' in 'iounitdef.f' !
! !
! unit used for radiative active gases: !
-! ozone : mass mixing ratio (g/g) !
! co2 : volume mixing ratio (p/p) !
! n2o : volume mixing ratio (p/p) !
! ch4 : volume mixing ratio (p/p) !
@@ -81,15 +71,6 @@
! seasonal cycle calculations !
! aug 2011 - y-t hou fix a bug in subr getgases doing vertical !
! co2 mapping. (for top_at_1 case, not affact opr). !
-! aug 2012 - y-t hou modified subr getozn. moved the if-first !
-! block to subr gas_init to ensure threading safe in !
-! climatology ozone applications. (not affect gfs) !
-! also changed the initialization subr into two parts:!
-! 'gas_init' is called at the start of run to set up !
-! module parameters; and 'gas_update' is called within!
-! the time loop to check and update data sets. defined!
-! the climatology ozone parameters k1oz,k2oz,facoz as !
-! module variables and are set in subr 'gas_update' !
! nov 2012 - y-t hou modified control parameters thru module !
! 'physparam'. !
! jan 2013 - z. janjic/y. hou modified ilon (longitude index) !
@@ -105,10 +86,8 @@
!> \defgroup module_radiation_gases_mod Radiation Gases Module
!> @{
-!> This module sets up ozone climatological profiles and other constant
-!! gas profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All
-!! data are entered as mixing ratio by volume, except ozone which is
-!! mass mixing ratio (g/g).
+!> This module sets up constant gas profiles, such as co2, ch4, n2o, o2,
+!! and those of cfc gases. All data are entered as mixing ratio by volume.
!!\image html rad_gas_AGGI.png "Figure 1: Atmospheric radiative forcing, relative to 1750, by long-lived greenhouse gases and the 2016 update of the NOAA Annual Greenhouse Gas Index (AGGI)"
!! NOAA Annual Greenhouse Gas Index (AGGI) shows that from 1990 to 2016,
!! radiative forcing by long-lived greenhouse gases (LLGHGs) increased by
@@ -121,10 +100,6 @@
!!\n ICO2=1: use observed global annual mean value
!!\n ICO2=2: use observed monthly 2-d data table in \f$15^o\f$ horizontal resolution
!!
-!! O3 Distribution (namelist control parameter -\b NTOZ):
-!!\n NTOZ=0: use seasonal and zonal averaged climatological ozone
-!!\n NTOZ>0: use 3-D prognostic ozone
-!!
!! Trace Gases (currently using the global mean climatology in unit of ppmv):
!! \f$CH_4-1.50\times10^{-6}\f$;
!! \f$N_2O-0.31\times10^{-6}\f$;
@@ -137,14 +112,11 @@
!!
!!\version NCEP-Radiation_gases v5.1 Nov 2012
-!> This module sets up ozone climatological profiles and other constant gas
-!! profiles, such as co2, ch4, n2o, o2, and those of cfc gases.
+!> This module sets up constant gas rofiles, such as co2, ch4, n2o, o2, and those
+!! of cfc gases.
module module_radiation_gases
use machine, only : kind_phys, kind_io4
use funcphys, only : fpkapx
- use ozne_def, only : JMR => latsozc, LOZ => levozc, &
- & blte => blatc, dlte=> dphiozc, &
- & timeozc => timeozc
use module_iounitdef, only : NIO3CLM, NICO2CN
!
implicit none
@@ -182,22 +154,8 @@ module module_radiation_gases
! gfdl 1999 value
real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11
-! --- ozone seasonal climatology parameters defined in module ozne_def
-! - 4x5 ozone data parameter
-! integer, parameter :: JMR=45, LOZ=17
-! real (kind=kind_phys), parameter :: blte=-86.0, dlte=4.0
-! - geos ozone data
-! integer, parameter :: JMR=18, LOZ=17
-! real (kind=kind_phys), parameter :: blte=-85.0, dlte=10.0
-
! --- module variables to be set in subroutin gas_init and/or gas_update
-! variables for climatology ozone (ioznflg = 0)
-
- real (kind=kind_phys), allocatable :: pkstr(:), o3r(:,:,:)
- integer :: k1oz = 0, k2oz = 0
- real (kind=kind_phys) :: facoz = 0.0
-
! arrays for co2 2-d monthly data and global mean values from observed data
real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:)
@@ -212,33 +170,30 @@ module module_radiation_gases
! --- public interfaces
- public gas_init, gas_update, getgases, getozn
+ public gas_init, gas_update, getgases
! =================
contains
! =================
-!> This subroutine sets up ozone, co2, etc. parameters. If climatology
-!! ozone then read in monthly ozone data.
+!> This subroutine sets up co2, etc. parameters.
!!\param me print message control flag
!!\param co2usr_file co2 user defined data table
!!\param co2cyc_file co2 climotology monthly cycle data table
!!\param ictmflg data ic time/date control flag
!!\param ico2flg co2 data source control flag
-!!\param ioznflg ozone data control flag
!!\param con_pi physical constant Pi
!!\param errflg error flag
!!\param errmsg error message
!>\section gas_init_gen gas_init General Algorithm
!-----------------------------------
subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
- & ictmflg, ioznflg, con_pi, errflg, errmsg)
+ & ictmflg, con_pi, errflg, errmsg)
! =================================================================== !
! !
-! gas_init sets up ozone, co2, etc. parameters. if climatology ozone !
-! then read in monthly ozone data. !
+! gas_init sets up co2, etc. parameters. !
! !
! inputs: !
! me - print message control flag !
@@ -259,9 +214,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! further data extrapolation. !
! =yyyy1: use yyyy data for the fcst. if needed, do !
! extrapolation to match the fcst time. !
-! ioznflg - ozone data control flag !
-! =0: use climatological ozone profile !
-! >0: use interactive ozone profile !
! co2usr_file - external co2 user defined data table !
! co2cyc_file - external co2 climotology monthly cycle data table !
! con_pi - physical constant Pi !
@@ -270,9 +222,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! errflg - error flag !
! errmsg - error message !
! !
-! internal module variables: !
-! pkstr, o3r - arrays for climatology ozone data !
-! !
! usage: call gas_init !
! !
! subprograms called: none !
@@ -282,9 +231,10 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
implicit none
! --- inputs:
- integer, intent(in) :: me, ictmflg, ioznflg, ico2flg
+ integer, intent(in) :: me, ictmflg, ico2flg
character(len=26),intent(in) :: co2usr_file,co2cyc_file
real(kind=kind_phys), intent(in) :: con_pi
+
! --- output:
character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
@@ -292,10 +242,7 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
! --- locals:
real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat
real (kind=kind_phys) :: co2g1, co2g2
- real (kind=kind_phys) :: pstr(LOZ)
- real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ)
- integer :: imond(12), ilat(JMR,12)
integer :: i, j, k, iyr, imo
logical :: file_exist, lextpl
character :: cline*100, cform*8
@@ -317,78 +264,6 @@ subroutine gas_init( me, co2usr_file, co2cyc_file, ico2flg, &
kyrsav = 0
kmonsav = 1
-! --- ... climatology ozone data section
-
- if ( ioznflg > 0 ) then
- if ( me == 0 ) then
- print *,' - Using interactive ozone distribution'
- endif
- else
- if ( timeozc /= 12 ) then
- print *,' - Using climatology ozone distribution'
- print *,' timeozc=',timeozc, ' is not monthly mean', &
- & ' - job aborting in subroutin gas_init!!!'
- errflg = 1
- errmsg = 'ERROR(gas_init): Climatological o3 distribution '// &
- & 'is not monthly mean'
- return
- endif
-
- allocate (pkstr(LOZ), o3r(JMR,LOZ,12))
- rewind NIO3CLM
-
- if ( LOZ == 17 ) then ! For the operational ozone climatology
- do k = 1, LOZ
- read (NIO3CLM,15) pstr4(k)
- 15 format(f10.3)
- enddo
-
- do imo = 1, 12
- do j = 1, JMR
- read (NIO3CLM,16) imond(imo), ilat(j,imo), &
- & (o3clim4(j,k,imo),k=1,10)
- 16 format(i2,i4,10f6.2)
- read (NIO3CLM,20) (o3clim4(j,k,imo),k=11,LOZ)
- 20 format(6x,10f6.2)
- enddo
- enddo
- else ! For newer ozone climatology
- read (NIO3CLM)
- do k = 1, LOZ
- read (NIO3CLM) pstr4(k)
- enddo
-
- do imo = 1, 12
- do k = 1, LOZ
- read (NIO3CLM) (o3clim4(j,k,imo),j=1,JMR)
- enddo
- enddo
- endif ! end if_LOZ_block
-!
- do imo = 1, 12
- do k = 1, LOZ
- do j = 1, JMR
- o3r(j,k,imo) = o3clim4(j,k,imo) * 1.655e-6
- enddo
- enddo
- enddo
-
- do k = 1, LOZ
- pstr(k) = pstr4(k)
- enddo
-
- if ( me == 0 ) then
- print *,' - Using climatology ozone distribution'
- print *,' Found ozone data for levels pstr=', &
- & (pstr(k),k=1,LOZ)
-! print *,' O3=',(o3r(15,k,1),k=1,LOZ)
- endif
-
- do k = 1, LOZ
- pkstr(k) = fpkapx(pstr(k)*100.0)
- enddo
- endif ! end if_ioznflg_block
-
! --- ... co2 data section
co2_glb = co2vmr_def
@@ -542,20 +417,18 @@ end subroutine gas_init
!!\param imon month of the year
!!\param iday day of the month
!!\param ihour hour of the day
-!!\param loz1st clim ozone 1st time update control flag
!!\param ldoco2 co2 update control flag
!!\param me print message control flag
!!\param co2dat_file co2 2d monthly obsv data table
!!\param co2gbl_file co2 global annual mean data table
!!\param ictmflg data ic time/date control flag
!!\param ico2flg co2 data source control flag
-!!\param ioznflg ozone data control flag
!!\param errflg error flag
!!\param errmsg error message
!>\section gen_gas_update gas_update General Algorithm
!-----------------------------------
- subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
- & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, ioznflg, &
+ subroutine gas_update(iyear, imon, iday, ihour, ldoco2, &
+ & me, co2dat_file, co2gbl_file, ictmflg, ico2flg, &
& errflg, errmsg )
! =================================================================== !
@@ -568,7 +441,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! imon - month of the year 1 !
! iday - day of the month 1 !
! ihour - hour of the day 1 !
-! loz1st - clim ozone 1st time update control flag 1 !
! ldoco2 - co2 update control flag 1 !
! me - print message control flag 1 !
! ico2flg - co2 data source control flag !
@@ -588,9 +460,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! further data extrapolation. !
! =yyyy1: use yyyy data for the fcst. if needed, do !
! extrapolation to match the fcst time. !
-! ioznflg - ozone data control flag !
-! =0: use climatological ozone profile !
-! >0: use interactive ozone profile !
! ivflip - vertical profile indexing flag !
! co2dat_file - external co2 2d monthly obsv data table !
! co2gbl_file - external co2 global annual mean data table !
@@ -604,8 +473,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 !
! co2_glb - global annual mean co2 mixing ratio !
! gco2cyc - global monthly mean co2 variation 12 !
-! k1oz,k2oz,facoz !
-! - climatology ozone parameters 1 !
! !
! usage: call gas_update !
! !
@@ -617,9 +484,8 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
! --- inputs:
integer, intent(in) :: iyear,imon,iday,ihour,me,ictmflg,ico2flg
- integer, intent(in) :: ioznflg
character(len=26),intent(in) :: co2dat_file, co2gbl_file
- logical, intent(in) :: loz1st, ldoco2
+ logical, intent(in) :: ldoco2
! --- output:
character(len=*), intent(out) :: errmsg
@@ -644,35 +510,6 @@ subroutine gas_update(iyear, imon, iday, ihour, loz1st, ldoco2, &
errmsg = ''
errflg = 0
-!> - Ozone data section
-
- if ( ioznflg == 0 ) then
- midmon = mdays(imon)/2 + 1
- change = loz1st .or. ( (iday==midmon) .and. (ihour==0) )
-!
- if ( change ) then
- if ( iday < midmon ) then
- k1oz = mod(imon+10, 12) + 1
- midm = mdays(k1oz)/2 + 1
- k2oz = imon
- midp = mdays(k1oz) + midmon
- else
- k1oz = imon
- midm = midmon
- k2oz = mod(imon, 12) + 1
- midp = mdays(k2oz)/2 + 1 + mdays(k1oz)
- endif
- endif
-!
- if (iday < midmon) then
- id = iday + mdays(k1oz)
- else
- id = iday
- endif
-
- facoz = float(id - midm) / float(midp - midm)
- endif
-
!> - co2 data section
if ( ico2flg == 0 ) return ! use prescribed global mean co2 data
@@ -1104,119 +941,6 @@ subroutine getgases( plvl, xlon, xlat, IMAX, LMAX, ico2flg, &
end subroutine getgases
!-----------------------------------
-!> This subroutine sets up climatological ozone profile for radiation
-!! calculation. This code is originally written by Shrinivas Moorthi.
-!!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$
-!!\param xlat (IMAX), latitude in radians, default to pi/2 ->
-!! -pi/2 range, otherwise see in-line comment
-!!\param IMAX, LM (1), horizontal and vertical dimensions
-!!\param top_at_1 (1), vertical profile indexing flag
-!!\param o3mmr (IMAX,LM), output ozone profile in mass mixing
-!! ratio (g/g)
-!>\section getozn_gen getozn General Algorithm
-!-----------------------------------
- subroutine getozn( prslk,xlat, IMAX, LM, top_at_1, o3mmr)
-
-! =================================================================== !
-! !
-! getozn sets up climatological ozone profile for radiation calculation!
-! !
-! this code is originally written By Shrinivas Moorthi !
-! !
-! inputs: !
-! prslk (IMAX,LM) - exner function = (p/p0)**rocp !
-! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 !
-! range, otherwise see in-line comment !
-! IMAX, LM - horizontal and vertical dimensions !
-! top_at_1 - vertical profile indexing flag !
-! !
-! outputs: !
-! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)!
-! !
-! module variables: !
-! k1oz, k2oz - ozone data interpolation indices !
-! facoz - ozone data interpolation factor !
-! !
-! usage: call getozn !
-! !
-! =================================================================== !
-!
- implicit none
-
-! --- inputs:
- integer, intent(in) :: IMAX, LM
- logical, intent(in) :: top_at_1
- real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:)
-
-! --- outputs:
- real (kind=kind_phys), intent(out) :: o3mmr(:,:)
-
-! --- locals:
- real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, &
- & tem, tem1, tem2, tem3, tem4, temp
- integer :: i, j, k, l, j1, j2, ll
-!
-!===> ... begin here
-!
- elte = blte + (JMR-1)*dlte
-
- do i = 1, IMAX
- deglat = xlat(i) * raddeg ! if xlat in pi/2 -> -pi/2 range
-! deglat = 90.0 - xlat(i)*raddeg ! if xlat in 0 -> pi range
-
- if (deglat > blte .and. deglat < elte) then
- tem1 = (deglat - blte) / dlte + 1
- j1 = tem1
- j2 = j1 + 1
- tem1 = tem1 - j1
- elseif (deglat <= blte) then
- j1 = 1
- j2 = 1
- tem1 = 1.0
- elseif (deglat >= elte) then
- j1 = JMR
- j2 = JMR
- tem1 = 1.0
- endif
-
- tem2 = 1.0 - tem1
- do j = 1, LOZ
- tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz)
- tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz)
- o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz)
- enddo
- enddo
-
- do l = 1, LM
- ll = l
- if (.not. top_at_1) ll = LM -l + 1
-
- do i = 1, IMAX
- wk1(i) = prslk(i,ll)
- enddo
-
- do k = 1, LOZ-1
- temp = 1.0 / (pkstr(k+1) - pkstr(k))
-
- do i = 1, IMAX
- if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then
- tem = (pkstr(k+1) - wk1(i)) * temp
- o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1)
- endif
- enddo
- enddo
-
- do i = 1, IMAX
- if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ)
- if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1)
- enddo
- enddo
-!
- return
-!...................................
- end subroutine getozn
-!-----------------------------------
-
!
!........................................!
end module module_radiation_gases !
diff --git a/physics/rrtmgp_lw_main.F90 b/physics/rrtmgp_lw_main.F90
index 67f7f749a..01b25c925 100644
--- a/physics/rrtmgp_lw_main.F90
+++ b/physics/rrtmgp_lw_main.F90
@@ -19,7 +19,6 @@ module rrtmgp_lw_main
use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init
use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, &
abssnow1, absrain
- use module_radiation_gases, only: NF_VGAS, getgases, getozn
use GFS_rrtmgp_pre, only: iStr_h2o, iStr_co2, iStr_o3, iStr_n2o, iStr_ch4, &
iStr_o2, iStr_ccl4, iStr_cfc11, iStr_cfc12, iStr_cfc22, &
eps, oneminus, ftiny
diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F
index 75925a5f3..73fc4aff8 100644
--- a/physics/satmedmfvdifq.F
+++ b/physics/satmedmfvdifq.F
@@ -22,7 +22,7 @@ module satmedmfvdifq
!! and to reduce the negative wind speed bias in upper troposphere
!!
!! Incorporate the LES-based changes for TC simulation
-!! (Chen et al.,2022, https://doi.org/10.1175/WAF-D-21-0168.1)
+!! (Chen et al.,2022 \cite Chen_2022)
!! with additional improvements on MF working with Cu schemes
!! Xiaomin Chen, 5/2/2022
!!
@@ -443,7 +443,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, &
endif
enddo
!
-! compute a function for green vegetation fraction and surface roughness
+!> - Compute a function for green vegetation fraction and surface roughness.
+!! Entrainment rate in updraft is a function of vegetation fraction and surface
+!! roughness length
!
do i = 1,im
tem = (sigmaf(i) - vegflo) / (vegfup - vegflo)
@@ -745,7 +747,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, &
endif
enddo
!
-! compute mean tke within pbl
+!> - Compute mean tke within pbl
!
do i = 1, im
sumx(i) = 0.
@@ -766,8 +768,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, &
endif
enddo
!
-! compute wind shear term as a sink term for updraft and downdraft
-! velocity
+!> - Compute wind shear term as a sink term for updraft and downdraft
+!! velocity
!
kps = max(kmpbl, kmscu)
do k = 2, kps
diff --git a/physics/set_soilveg.f b/physics/set_soilveg.f
index 37f2c2a73..35f4ace37 100644
--- a/physics/set_soilveg.f
+++ b/physics/set_soilveg.f
@@ -44,6 +44,9 @@ subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg)
& DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA,
& CZIL_DATA, LAI_DATA, CSOIL_DATA
+ errmsg = ''
+ errflg = 0
+
cmy end locals
if(ivet.eq.2) then
diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90
index c1a43f170..6945e48e9 100644
--- a/physics/sfc_diag_post.F90
+++ b/physics/sfc_diag_post.F90
@@ -14,16 +14,17 @@ module sfc_diag_post
!!
#endif
subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, con_eps, con_epsm1, pgr,&
- t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, &
+ vegtype,t2mmp,q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax, &
wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg)
use machine, only: kind_phys, kind_dbl_prec
implicit none
- integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag
- logical, intent(in) :: lssav
- real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1
+ integer, intent(in) :: im, lsm, lsm_noahmp,opt_diag
+ integer, dimension(:), intent(in) :: vegtype ! vegetation type (integer index)
+ logical, intent(in) :: lssav
+ real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1
logical , dimension(:), intent(in) :: dry
real(kind=kind_phys), dimension(:), intent(in) :: pgr, u10m, v10m
real(kind=kind_phys), dimension(:), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax
@@ -41,12 +42,23 @@ subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, opt_diag, dry, lssav, dtf, co
errflg = 0
if (lsm == lsm_noahmp) then
- if (opt_diag == 2 .or. opt_diag == 3)then
+! over shrublands use opt_diag=2
+ do i=1, im
+ if(dry(i)) then
+ if (vegtype(i) == 6 .or. vegtype(i) == 7 &
+ .or. vegtype(i) == 16) then
+ t2m(i) = t2mmp(i)
+ q2m(i) = q2mp(i)
+ endif
+ endif
+ enddo
+
+ if (opt_diag == 2 .or. opt_diag == 3) then
do i=1,im
if(dry(i)) then
t2m(i) = t2mmp(i)
q2m(i) = q2mp(i)
- endif
+ endif
enddo
endif
endif
diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta
index c50d3c4dc..17648753a 100644
--- a/physics/sfc_diag_post.meta
+++ b/physics/sfc_diag_post.meta
@@ -81,6 +81,13 @@
type = real
kind = kind_phys
intent = in
+[vegtype]
+ standard_name = vegetation_type_classification
+ long_name = vegetation type at each grid cell
+ units = index
+ dimensions = (horizontal_loop_extent)
+ type = integer
+ intent= in
[t2mmp]
standard_name = temperature_at_2m_from_noahmp
long_name = 2 meter temperature from noahmp
diff --git a/physics/sfcsub.F b/physics/sfcsub.F
index 7be07b39c..494b8f7dc 100644
--- a/physics/sfcsub.F
+++ b/physics/sfcsub.F
@@ -7491,9 +7491,6 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, &
endif
call abort
endif
-!
-! soil type
- print *,'in FIXREAD fnsotc =',fnsotc
!
if(fnsotc(1:8).ne.' ') then
if ( index(fnsotc, "tileX.nc") == 0) then ! grib file
diff --git a/physics/smoke_dust/dust_data_mod.F90 b/physics/smoke_dust/dust_data_mod.F90
index a710701f1..eb809378d 100755
--- a/physics/smoke_dust/dust_data_mod.F90
+++ b/physics/smoke_dust/dust_data_mod.F90
@@ -44,24 +44,10 @@ module dust_data_mod
! Never used:
! real(kind_phys), parameter :: fengsha_alpha = 0.3
! real(kind_phys), parameter :: fengsha_gamma = 1.3
+
! -- FENGSHA threshold velocities based on Dale A. Gillette's data
integer, parameter :: fengsha_maxstypes = 13
-! real(kind_phys), dimension(fengsha_maxstypes) :: dust_uthres = &
-! (/ 0.065, & ! Sand - 1
-! 0.20, & ! Loamy Sand - 2
-! 0.52, & ! Sandy Loam - 3
-! 0.50, & ! Silt Loam - 4
-! 0.50, & ! Silt - 5
-! 0.60, & ! Loam - 6
-! 0.73, & ! Sandy Clay Loam - 7
-! 0.73, & ! Silty Clay Loam - 8
-! 0.80, & ! Clay Loam - 9
-! 0.95, & ! Sandy Clay - 10
-! 0.95, & ! Silty Clay - 11
-! 1.00, & ! Clay - 12
-! 9.999 /) ! Other - 13
-! dust_uthres = 0.065, 0.18, 0.27, 0.30, 0.35, 0.38, 0.35, 0.41, 0.41,
-! 0.45,0.50,0.45,9999.0
+
real(kind_phys), dimension(fengsha_maxstypes), parameter :: dust_uthres = &
(/ 0.065, & ! Sand - 1
0.18, & ! Loamy Sand - 2
@@ -76,12 +62,16 @@ module dust_data_mod
0.50, & ! Silty Clay - 11
0.45, & ! Clay - 12
9999.0 /) ! Other - 13
- ! -- FENGSHA uses precalculated drag partition from ASCAT. See: Prigent et al. (2012,2015)
- integer, parameter :: dust_calcdrag = 1
- real(kind_phys) :: dust_alpha = 2.2
+ ! -- FENGSHA uses precalculated drag partition
+ integer, parameter :: dust_calcdrag = 1
+ ! -- FENGSHA dust moisture parameterization 1:fecan - 2:shao
+ integer :: dust_moist_opt = 1
+
+ real(kind_phys) :: dust_alpha = 1.0
real(kind_phys) :: dust_gamma = 1.0
-
+ real(kind_phys) :: dust_moist_correction = 1.0
+ real(kind_phys) :: dust_drylimit_factor = 1.0
! -- sea salt parameters
integer, dimension(nsalt), parameter :: spoint = (/ 1, 2, 2, 2, 2, 2, 3, 3, 3 /) ! 1 Clay, 2 Silt, 3 Sand
@@ -93,7 +83,7 @@ module dust_data_mod
(/ 1., 0.2, 0.2, 0.2, 0.2, 0.2, 0.333, 0.333, 0.333 /)
- ! -- soil vagatation parameters
+ ! -- soil vegatation parameters
integer, parameter :: max_soiltyp = 30
real(kind_phys), dimension(max_soiltyp), parameter :: &
maxsmc = (/ 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, &
diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90
index 54a64239d..1e24c8947 100755
--- a/physics/smoke_dust/dust_fengsha_mod.F90
+++ b/physics/smoke_dust/dust_fengsha_mod.F90
@@ -61,6 +61,8 @@ subroutine gocart_dust_fengsha_driver(dt, &
REAL(kind_phys), INTENT(IN) :: dt ! time step
REAL(kind_phys), INTENT(IN) :: g ! gravity (m/s**2)
+
+
! Local variables
integer :: nmx,i,j,k,imx,jmx,lmx
integer :: ilwi
@@ -75,6 +77,7 @@ subroutine gocart_dust_fengsha_driver(dt, &
real(kind_phys), DIMENSION (num_emis_dust) :: distribution
real(kind_phys), dimension (3) :: massfrac
real(kind_phys) :: erodtot
+ real(kind_phys) :: moist_volumetric
! conversion values
conver=1.e-9
@@ -174,10 +177,13 @@ subroutine gocart_dust_fengsha_driver(dt, &
endif
endif
+ ! soil moisture correction factor
+ moist_volumetric = dust_moist_correction * smois(i,2,j)
+
! Call dust emission routine.
call source_dust(imx,jmx, lmx, nmx, dt, tc, ustar, massfrac, &
- erodtot, dxy, smois(i,1,j), airden, airmas, bems, g, dust_alpha, dust_gamma, &
+ erodtot, dxy, moist_volumetric, airden, airmas, bems, g, dust_alpha, dust_gamma, &
R, uthr(i,j))
! convert back to concentration
@@ -457,10 +463,16 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, &
! Now compute size-dependent total emission flux
! ----------------------------------------------
- ! Fecan moisture correction
- ! -------------------------
- h = moistureCorrectionFecan(slc, sand, clay, rhop)
-
+
+ if (dust_moist_opt .eq. 1) then
+
+ ! Fecan moisture correction
+ ! -------------------------
+ h = moistureCorrectionFecan(slc, sand, clay)
+ else
+ ! shao soil moisture correction
+ h = moistureCorrectionShao(slc)
+ end if
! Adjust threshold
! ----------------
u_thresh = uthrs * h
@@ -478,7 +490,7 @@ subroutine DustEmissionFENGSHA(slc, clay, sand, silt, &
end subroutine DustEmissionFENGSHA
!-----------------------------------------------------------------
- real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop)
+ real function soilMoistureConvertVol2Grav(vsoil, sandfrac)
! !USES:
implicit NONE
@@ -486,7 +498,6 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop)
! !INPUT PARAMETERS:
REAL(kind_phys), intent(in) :: vsoil ! volumetric soil moisture fraction [1]
REAL(kind_phys), intent(in) :: sandfrac ! fractional sand content [1]
- REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3]
! !DESCRIPTION: Convert soil moisture fraction from volumetric to gravimetric.
!
@@ -500,20 +511,21 @@ real function soilMoistureConvertVol2Grav(vsoil, sandfrac, rhop)
! !CONSTANTS:
REAL(kind_phys), parameter :: rhow = 1000. ! density of water [kg m-3]
-
+ REAL(kind_phys), parameter :: rhop = 1700. ! density of dry soil
!EOP
!-------------------------------------------------------------------------
! Begin...
! Saturated volumetric water content (sand-dependent) ! [m3 m-3]
- vsat = 0.489 - 0.00126 * ( 100. * sandfrac )
+ vsat = 0.489 - 0.126 * sandfrac
+
! Gravimetric soil content
- soilMoistureConvertVol2Grav = vsoil * rhow / (rhop * (1. - vsat))
+ soilMoistureConvertVol2Grav = 100.0 * (vsoil * rhow / rhop / ( 1. - vsat))
end function soilMoistureConvertVol2Grav
!----------------------------------------------------------------
- real function moistureCorrectionFecan(slc, sand, clay, rhop)
+ real function moistureCorrectionFecan(slc, sand, clay)
! !USES:
implicit NONE
@@ -522,7 +534,6 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop)
REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1]
REAL(kind_phys), intent(in) :: sand ! fractional sand content [1]
REAL(kind_phys), intent(in) :: clay ! fractional clay content [1]
- REAL(kind_phys), intent(in) :: rhop ! dry dust density [kg m-3]
! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture
!
@@ -540,15 +551,46 @@ real function moistureCorrectionFecan(slc, sand, clay, rhop)
! Begin...
! Convert soil moisture from volumetric to gravimetric
- grvsoilm = soilMoistureConvertVol2Grav(slc, sand, 2650.)
+ grvsoilm = soilMoistureConvertVol2Grav(slc, sand)
! Compute fecan dry limit
- drylimit = clay * (14.0 * clay + 17.0)
+ drylimit = dust_drylimit_factor * clay * (14.0 * clay + 17.0)
! Compute soil moisture correction
moistureCorrectionFecan = sqrt(1.0 + 1.21 * max(0., grvsoilm - drylimit)**0.68)
end function moistureCorrectionFecan
+!----------------------------------------------------------------
+ real function moistureCorrectionShao(slc)
+
+! !USES:
+ implicit NONE
+
+! !INPUT PARAMETERS:
+ REAL(kind_phys), intent(in) :: slc ! liquid water content of top soil layer, volumetric fraction [1]
+
+! !DESCRIPTION: Compute correction factor to account for Fecal soil moisture
+!
+! !REVISION HISTORY:
+!
+! 02Apr2020, B.Baker/NOAA - Original implementation
+! 01Apr2020, R.Montuoro/NOAA - Adapted for GOCART process library
+
+! !Local Variables
+ real :: grvsoilm
+ real :: drylimit
+
+!EOP
+!---------------------------------------------------------------
+! Begin...
+
+ if (slc < 0.03) then
+ moistureCorrectionShao = exp(22.7 * slc)
+ else
+ moistureCorrectionShao = exp(95.3 * slc - 2.029)
+ end if
+
+ end function moistureCorrectionShao
!---------------------------------------------------------------
real function DustFluxV2HRatioMB95(clay, kvhmax)
diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90
index 1f9ef6340..7b69fc9e3 100755
--- a/physics/smoke_dust/rrfs_smoke_wrapper.F90
+++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90
@@ -12,7 +12,8 @@ module rrfs_smoke_wrapper
num_moist, num_chem, num_emis_seas, num_emis_dust, &
DUST_OPT_FENGSHA, p_qv, p_atm_shum, p_atm_cldq, &
p_smoke, p_dust_1, p_coarse_pm, epsilc
- use dust_data_mod, only : dust_alpha, dust_gamma
+ use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, &
+ dust_moist_correction, dust_drylimit_factor
use plume_data_mod, only : p_frp_std, p_frp_hr, num_frp_plume
use seas_mod, only : gocart_seasalt_driver
use dust_fengsha_mod, only : gocart_dust_fengsha_driver
@@ -49,6 +50,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
ebb_smoke_hr, frp_hr, frp_std_hr, &
coef_bb, ebu_smoke,fhist, min_fplume, max_fplume, hwp, wetness, &
smoke_ext, dust_ext, ndvel, ddvel_inout,rrfs_sd, &
+ dust_moist_opt_in, dust_moist_correction_in, dust_drylimit_factor_in, &
dust_alpha_in, dust_gamma_in, fire_in, &
seas_opt_in, dust_opt_in, drydep_opt_in, coarsepm_settling_in, &
do_plumerise_in, plumerisefire_frq_in, addsmoke_flag_in, &
@@ -91,12 +93,15 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
real(kind_phys), dimension(:,:), intent(out) :: smoke_ext, dust_ext
real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa
real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout
- real (kind=kind_phys), dimension(:), intent(in) :: wetness
- integer, intent(in ) :: imp_physics, imp_physics_thompson
- real (kind=kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in
- integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, &
- coarsepm_settling_in, plumerisefire_frq_in, &
- addsmoke_flag_in, wetdep_ls_opt_in
+ real(kind_phys), dimension(:), intent(in) :: wetness
+ real(kind_phys), intent(in) :: dust_alpha_in, dust_gamma_in, wetdep_ls_alpha_in
+ real(kind_phys), intent(in) :: dust_moist_correction_in
+ real(kind_phys), intent(in) :: dust_drylimit_factor_in
+ integer, intent(in) :: dust_moist_opt_in
+ integer, intent(in) :: imp_physics, imp_physics_thompson
+ integer, intent(in) :: seas_opt_in, dust_opt_in, drydep_opt_in, &
+ coarsepm_settling_in, plumerisefire_frq_in, &
+ addsmoke_flag_in, wetdep_ls_opt_in
logical, intent(in ) :: do_plumerise_in, rrfs_sd
character(len=*), intent(out) :: errmsg
integer, intent(out) :: errflg
@@ -314,6 +319,9 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate,
! Set at compile time in dust_data_mod:
dust_alpha = dust_alpha_in
dust_gamma = dust_gamma_in
+ dust_moist_opt = dust_moist_opt_in
+ dust_moist_correction = dust_moist_correction_in
+ dust_drylimit_factor = dust_drylimit_factor_in
call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, &
isltyp,vegfrac,snowh,xland,dxy,g,emis_dust,ust,znt, &
clayf,sandf,rdrag,uthr, &
diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta
index bf2fddd60..cddc20fbc 100755
--- a/physics/smoke_dust/rrfs_smoke_wrapper.meta
+++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta
@@ -210,17 +210,17 @@
kind = kind_phys
intent = in
[nsoil]
- standard_name = vertical_dimension_of_soil
- long_name = soil vertical layer dimension
+ standard_name = vertical_dimension_of_soil_internal_to_land_surface_scheme
+ long_name = number of soil layers internal to land surface model
units = count
dimensions = ()
type = integer
intent = in
[smc]
- standard_name = volume_fraction_of_condensed_water_in_soil
- long_name = volumetric fraction of soil moisture
+ standard_name = volume_fraction_of_soil_moisture_for_land_surface_model
+ long_name = volumetric fraction of soil moisture for lsm
units = frac
- dimensions = (horizontal_loop_extent,vertical_dimension_of_soil)
+ dimensions = (horizontal_loop_extent,vertical_dimension_of_soil_internal_to_land_surface_scheme)
type = real
kind = kind_phys
intent = inout
@@ -612,6 +612,32 @@
dimensions = ()
type = logical
intent = in
+[dust_moist_opt_in]
+ standard_name = control_for_dust_soil_moisture_option
+ long_name = smoke dust moisture parameterization 1 - fecan 2 - shao
+ units = index
+ dimensions = ()
+ type = integer
+ active = (do_smoke_coupling)
+ intent = in
+[dust_moist_correction_in]
+ standard_name = dust_moist_correction_fengsha_dust_scheme
+ long_name = moisture correction term for fengsha dust emission
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ active = (do_smoke_coupling)
+ intent = in
+[dust_drylimit_factor_in]
+ standard_name = dust_drylimit_factor_fengsha_dust_scheme
+ long_name = moisture correction term for drylimit in fengsha dust emission
+ units = none
+ dimensions = ()
+ type = real
+ kind = kind_phys
+ active = (do_smoke_coupling)
+ intent = in
[dust_alpha_in]
standard_name = alpha_fengsha_dust_scheme
long_name = alpha paramter for fengsha dust scheme
| | |