MODULE module_mp_nssl_2mom IMPLICIT NONE public nssl_2mom_driver public nssl_2mom_init private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis private gamma_dp, gamxinfdp, gamma_dpr private delbk, delabk private gammadp logical, private :: cleardiag = .false. PRIVATE integer, parameter :: wrfchem_flag = 0 LOGICAL, PRIVATE:: is_aerosol_aware = .false. logical, private :: turn_on_cin = .false. integer, private :: eqtset = 1 double precision, parameter, public :: zscale = 1.0d0 double precision, parameter, public :: zscaleinv = 1.0d0/zscale real, parameter :: warmonly = 0.0 logical, parameter :: lwsm6 = .false. real, parameter :: dimax = 500.e-6 real, parameter :: roqimax = 2.08e22*dimax**8 integer :: iuseferrier = 1 integer :: idbzci = 1 integer :: iusewetgraupel = 1 integer :: iusewethail = 0 integer :: iusewetsnow = 0 real, private :: rho_qr = 1000., cnor = 8.0e5 real, private :: rho_qs = 100., cnos = 3.0e6 real, private :: rho_qh = 500., cnoh = 4.0e5 real, private :: rho_qhl= 800., cnohl = 4.0e4 real, private :: hdnmn = 170.0 real, private :: hldnmn = 500.0 real :: cnohmn = 1.e-2 real :: cnohlmn = 1.e-2 real , private :: qcmincwrn = 2.0e-3 real , private :: cwdiap = 20.0e-6 real , private :: cwdisp = 0.15 real , private :: ccn = 0.6e+09 real , private :: ccnuf = 0 real , public :: qccn, qccnuf real , private :: old_qccn = -1.0 integer, private :: iauttim = 1 real , private :: auttim = 300. real , private :: qcwmntim = 1.0e-5 logical, private :: invertccn = .false. logical :: switchccn = .false. real :: old_cccn = -1.0 logical :: restoreccn = .true. real :: ccntimeconst = 3600. real, private :: restoreccnfrac = 1.0 real :: ufccntimeconst = 6.*3600. real :: ufbackground = 0.1e9 logical :: decayufccn = .false. integer :: i_uf_or_ccn = 0 integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 integer, private :: iifall = 0 integer, private :: isfall = 2 logical, private :: do_accurate_sedimentation = .false. integer, private :: interval_sedi_vt = 1 integer, private :: infall = 4 integer :: imydiagalpha = 0 real, private :: rainfallfac = 1.0 real, private :: icefallfac = 1.0 real, private :: snowfallfac = 1.0 real, private :: graupelfallfac = 1.0 real, private :: hailfallfac = 1.0 integer, private :: icefallopt = 3 integer, private :: icdx = 6 integer, private :: icdxhl = 6 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 real , private :: cdhdnmin = 500., cdhdnmax = 800.0 real , private :: cdhlmin = 0.45, cdhlmax = 0.6 real , private :: cdhldnmin = 500., cdhldnmax = 800.0 real , private :: vtmaxsed = 70. integer :: rssflg = 1 integer :: sssflg = 1 integer :: hssflg = 1 integer :: hlssflg = 1 integer, private :: ndebug = -1, ncdebug = 0 integer, private :: ipconc = 5 integer, private :: inucopt = 0 integer, private :: ichaff = 0 integer, parameter :: ilimit = 0 real, private :: constccw = -1. real, private :: cimn = 1.0e3, cimx = 1.0e6 real , private :: rhofrz = 900 real , private :: ifrzg = 1.0 real , private :: ifiacrg = 1.0 real , private :: ifrzs = 1.0 real , private :: ffrzs = 0.0 real , private :: f2h = 1.0 integer, private :: irwfrz = 1 integer, private :: irimtim = 0 integer, private :: irimdenopt = 1 real , private :: rimc1 = 300.0, rimc2 = 0.44 real , private :: rimc3 = 170.0 real :: rimc4 = 900.0 real , private :: rimtim = 120.0 real , private :: eqtot = 1.0e-9 real, private :: rimdenvwgt = 0.0 integer, private :: ireadmic = 0 integer, private :: idiagnosecnu = 0 integer, private :: iccwflg = 1 integer, private :: issfilt = 0 integer, private :: icnuclimit = 0 integer, private :: irenuc = 5 integer, private :: irenuc3d = 0 real :: renucfrac = 0.0 real :: ssf2kmax = 10. real , private :: cck = 0.6 real , private :: ciintmx = 1.0e6 real , private :: cwccn real , private :: ccwmx integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1 integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1 integer, private :: itype1 = 0, itype2 = 2 integer, private :: in_freeze_rain_first = 0 integer, private :: icenucopt = 1 real, private :: naer = 1.0e6 integer, private :: icfn = 2 integer, private :: ihrn = 0 integer, private :: ibfc = 1 real, private :: cwfrz2snowfrac = 0.0 real, private :: cwfrz2snowratio = 5. integer, private :: iremoveqwfrz = 1 integer, private :: iacr = 2 integer, private :: icrcev = 1 integer, private :: icracr = 1 integer, private :: icracrthresh = 1 integer, private :: ibfr = 2 integer, private :: ibiggopt = 2 integer :: ibiggsmallrain = 0 integer, private :: iacrsize = 5 real , private :: cimas0 = 6.62e-11 real , private :: cimas1 = 6.88e-13 real , private :: splintermass = 6.88e-13 real , private :: cfnfac = 0.1 integer, private :: iscni = 4 real , private :: fscni = 1.0 logical, private :: imeyers5 = .false. real , private :: dmincw = 15.0e-6 integer, private :: iehw = 1 integer, private :: iefw = 1 integer, private :: iehlw = 1 integer, private :: ierw = 1 integer, private :: iehr0c = 0 integer, private :: iehlr0c = 0 real , private :: eiw0 = 0.5 real , private :: esw0 = 0.5 real , private :: ehw0 = 0.9 real , private :: erw0 = 1.0 real , private :: ehlw0 = 0.9 real , private :: efw0 = 0.5 real :: ehr0 = 1.0 real :: efr0 = 1.0 real :: ehlr0 = 1.0 real , private :: exwmindiam = 0.0 real , private :: esilfo0 = 1.0 real , private :: ehslfo0 = 1.0 integer, private :: ircnw = 5 real , private :: qminrncw = 2.0e-3 integer, private :: iqcinit = 2 real , private :: ssmxinit = 0.4 real , private :: ewfac = 1.0 real , private :: eii0 = 0.1 ,eii1 = 0.1 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 real, private :: ewi_dcmin = 15.0e-06 real, private :: ewi_dimin = 30.0e-06 real , private :: eri0 = 0.1 real , private :: eri_cimin = 10.e-6 real , private :: esi0 = 0.1 real , private :: ehs0 = 0.1, ehs1 = 0.1 integer :: iessopt = 1 real , private :: ess0 = 0.5, ess1 = 0.05 real , private :: esstem1 = -15. real , private :: esstem2 = -10. real , private :: essrmax = 0.02 real , private :: essfrac1 = 0.5 real , private :: essfrac2 = 0.75 integer, private :: iessec0flag = 0 real , private :: ehsfrac = 1.0 real , private :: ehimin = 0.0 real , private :: ehimax = 1.0 real , private :: ehsmax = 0.5 real , private :: ecollmx = 0.5 integer, private :: iglcnvi = 1 integer, private :: iglcnvs = 2 real , private :: rz real , private :: rzhl real , private :: rzs real , private :: alphahacx = 0.0 real , private :: fconv = 1.0 real , private :: rg0 = 400.0 integer, private :: rcond = 2 integer, parameter, private :: icond = 1 integer, private :: iqis0 = 2 real , private :: dfrz = 0.15e-3 real , private :: dmlt = 3.0e-3 real , private :: dshd = 1.0e-3 integer, private :: ivshdgs = 1 integer, private :: ished2cld = 0 integer, private :: ihmlt = 2 integer, private :: imltshddmr = 2 real :: mltdiam1 = 9.0e-3, mltdiam2 = 16.0e-3, mltdiam3 = 19.0e-3, mltdiam4 = 200.0e-3, mltdiam05 = 4.5e-3 integer, private :: nsplinter = 0 real, private :: lawson_splinter_fac = 2.5e-11 integer, private :: isnwfrac = 0 real, private :: qhdpvdn = -1. real, private :: qhacidn = -1. integer, private :: iraintypes = 0 logical, private :: mixedphase = .false. integer, private :: imixedphase = 0 logical, private :: qsdenmod = .false. logical, private :: qhdenmod = .false. logical, private :: qsvtmod = .false. real , private :: sheddiam = 8.0e-03 real :: sheddiamlg = 10.0e-03 real :: sheddiam0 = 20.0e-03 real :: fwmhtmptem = -15. integer :: ifwmhtmptemopt = 1 integer :: ifwmhopt = 2 integer :: ihxw2rain = 0 real , private :: fwms = 0.5 real , private :: fwmh = 0.5 real , private :: fwmhl = 0.5 real :: fwmlarge = 0.2 integer :: ifwmfall = 0 logical :: rescale_high_alpha = .false. logical :: rescale_low_alpha = .true. logical :: rescale_low_alphar = .true. logical :: rescale_low_alphah = .true. logical :: rescale_low_alphahl = .true. real, parameter :: alpharmax = 8. integer, private :: ihlcnh = -1 real, private :: hlcnhdia = 1.e-3 real, private :: hlcnhqmin = 0.1e-3 real , private :: hldia1 = 10.0e-3 integer, private :: incwet = 0 integer, private :: iusedw = 0 real , private :: dwmin = 5.0e-3 real , private :: dwetmin = 5.0e-3 real , private :: dwmax = 15.e-3 real , private :: dwtempmin = 242. real , private :: dwehwmin = 0. real , private :: dg0thresh = 0.15 real , private :: wetgrthtoffset = -1. real , private :: hailcnvtoffset = -2. integer :: ifddenfac = 0 real :: fddenthresh = 500. integer :: icvhl2h = 0 integer, private :: imurain = 1 integer, private :: imusnow = 3 integer, private :: iturbenhance = 0 integer, private :: isedonly = 0 integer, private :: iferwisventr = 2 integer, private :: izwisventr = 2 integer :: iresetmoments = 0 integer, private :: imaxdiaopt = 3 integer :: irainbreak = -1 integer :: ibincracr = 0 real :: rainbreakfac = 1.0e6 real :: draintail = 10.e-3 real :: drsmall = 1.e-3 real :: qrbrthresh1 = 0.1e-3 real :: qrbrthresh2 = 1.0e-3 integer, private :: dmrauto = 0 integer :: dmropt = 0 integer :: dmhlopt = 0 integer :: irescalerainopt = 3 real :: rescale_wthresh = 3.0 real :: rescale_tempthresh = 0.0 real, parameter :: alpharaut = 0.0 real :: cxmin = 1.e-8 real :: zxmin = 1.e-28 integer :: ithompsoncnoh = 0 integer :: ivhmltsoak = 1 logical, private :: iwetsoak = .true. integer, private :: ioldlimiter = 0 integer, private :: isnowfall = 2 integer, private :: isnowdens = 1 integer, private :: ibiggsnow = 3 real :: biggsnowdiam = -1.0 integer, private :: ixtaltype = 1 real, private :: takshedsize1 = 0.15 real, private :: takshedsize2 = 0.3 real, private :: takshedsize3 = 0.45 integer, private :: numshedregimes = 3 real, private :: evapfac = 1.0 real, private :: depfac = 1.0 real,private,parameter :: meltfac = 1.0 integer, private :: ibinhmlr = 0 integer, private :: ibinhlmlr = 0 integer, private :: ibinnum = 2 integer, private :: iqhacrmlr = 1 integer, private :: iqhlacrmlr = 1 integer, private :: iqhacwshr = 1 integer, private :: iqhlacwshr = 1 real, private :: binmlrmxdia = 40.e-3 real, private :: binmlrzrrfac = 1.0 real, private :: snowmeltdia = 0 real, private :: alphasmlr0 = 14.0 real, private :: delta_alphamlr = 0.5 integer, private :: iqvsopt = 1 integer :: imaxsupopt = 4 real :: maxsupersat = 1.9 real :: maxlowtempss = 1.08 real :: ssmxuf = 4.0 integer, parameter :: icespheres = 0 integer, parameter :: lqmx = 30 integer, parameter :: lt = 1 integer, parameter :: lv = 2 integer, parameter :: lc = 3 integer, parameter :: lr = 4 integer, parameter :: li = 5 integer, private :: lis = 0 integer, private :: ls = 6 integer, private :: lh = 7 integer, private :: lf = 0 integer, private :: lhl = 0 integer, private :: lccn = 9 integer, private :: lccnuf = 0 integer, private :: lccna = 0 integer, private :: lccnaco = 0 integer, private :: lccnanu = 0 integer, private :: lcina = 0 integer, private :: lcin = 0 integer, private :: lnc = 9 integer, private :: lnr = 10 integer, private :: lni = 11 integer, private :: lnis = 0 integer, private :: lns = 12 integer, private :: lnh = 13 integer, private :: lnf = 0 integer, private :: lnhl = 0 integer, private :: lnhf = 0 integer, private :: lnhlf = 0 integer, private :: lss = 0 integer :: lvh = 15 integer, private :: lhab = 8 integer, private :: lg = 7 integer :: lvi = 0 integer :: lvs = 0 integer :: lvgl = 0 integer :: lvgm = 0 integer :: lvgh = 0 integer :: lvf = 0 integer :: lvhl = 0 integer :: lhw = 0 integer :: lfw = 0 integer :: lsw = 0 integer :: lhlw = 0 integer :: lhwlg = 0 integer :: lhlwlg = 0 integer :: lzr = 0 integer :: lzi = 0 integer :: lzs = 0 integer :: lzgl = 0 integer :: lzgm = 0 integer :: lzgh = 0 integer :: lzf = 0 integer :: lzh = 0 integer :: lzhl = 0 integer :: lscw = 0 integer :: lscr = 0 integer :: lsci = 0 integer :: lscis = 0 integer :: lscs = 0 integer :: lsch = 0 integer :: lscf = 0 integer :: lschl = 0 integer :: lscwi = 0 integer :: lscpi = 0 integer :: lscni = 0 integer :: lscpli = 0 integer :: lscnli = 0 integer :: lschab = 0 integer :: lscb = 0 integer :: lsce = 0 integer :: lsceq = 0 integer :: lne = 0 real :: cnoh0 = 4.0e+5 real :: hwdn1 = 700.0 real :: alphai = 0.0 real :: alphas = 0.0 real :: alphar = 0.0 real, private :: alphah = 0.0 real, private :: alphahl = 1.0 real :: dmuh = 1.0 real :: dmuhl = 1.0 real, private :: alphamax = 15. real, private :: alphamin = 0. real, parameter :: rnumin = -0.8 real, parameter :: rnumax = 15.0 real :: cnu = 0.0 real, parameter :: rnu = -0.8, snu = -0.8, cinu = 0.0 real xnu(lc:lqmx) real xmu(lc:lqmx) real dnu(lc:lqmx) real dmu(lc:lqmx) real ax(lc:lqmx) real bx(lc:lqmx) real fx(lc:lqmx) real da0 (lc:lqmx) real dab0(lc:lqmx,lc:lqmx) real dab1(lc:lqmx,lc:lqmx) real da1 (lc:lqmx) real bb (lc:lqmx) integer :: ipelec = 0 integer :: isaund = 0 logical :: idoniconly = .false. integer, private :: elec_on_time = -1 integer, private :: elec_ramp_time = 0 integer :: jchgs = 3 integer :: jchgn = 2 integer :: ichge = 3 integer :: ichgw = 2 real :: charging_border = 4000. real, private :: delqnw = -1.0e-10 real, private :: delqxw = 1.0e-10 real :: tindmn = 233, tindmx = 298.0 integer, private :: imorrgdnglimit = 0 real, private :: morrdnglimit = 2000.E-6 integer ngm0,ngm1,ngm2 parameter (ngm0=3001,ngm1=500,ngm2=500) double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) integer, parameter :: nqiacralpha = 300 integer, parameter :: nqiacrratio = 400 real, parameter :: maxratiolu = 100. real, parameter :: maxalphalu = 15. real, parameter :: minalphalu = -0.95 real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha integer, parameter :: ialpstart = minalphalu*dqiacralphainv real :: ciacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: qiacrratio(0:nqiacrratio,ialpstart:nqiacralpha) real :: ziacrratio(0:nqiacrratio,ialpstart:nqiacralpha) double precision :: gamxinflu(0:nqiacrratio,ialpstart:nqiacralpha,12,2) real, save :: dab0lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) real, save :: dab1lu(ialpstart:nqiacralpha,ialpstart:nqiacralpha,lc:lqmx,lc:lqmx) integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./ DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 / DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 / integer lsc(lc:lqmx) integer ln(lc:lqmx) integer ipc(lc:lqmx) integer lvol(lc:lqmx) integer lz(lc:lqmx) integer lliq(li:lqmx) integer linfall(lc:lqmx) integer denscale(lc:lqmx) integer ido(lc:lqmx) logical ldovol real xdn0(lc:lqmx) real xdnmx(lc:lqmx), xdnmn(lc:lqmx) real cdx(lc:lqmx) real cno(lc:lqmx) real xvmn(lc:lqmx), xvmx(lc:lqmx) real qxmin(lc:lqmx) real qxmin_init(lc:lqmx) integer nqsat parameter (nqsat=1000001) real fqsat,fqsati parameter (fqsat=0.002,fqsati=1./fqsat) real tabqvs(nqsat),tabqis(nqsat),dtabqvs(nqsat),dtabqis(nqsat) real, parameter :: ar = 841.99666 real, parameter :: br = 0.8 real, parameter :: aradcw = -0.27544 real, parameter :: bradcw = 0.26249e+06 real, parameter :: cradcw = -1.8896e+10 real, parameter :: dradcw = 4.4626e+14 real, parameter :: bta1 = 0.6 real, parameter :: cnit = 1.0e-02 real, parameter :: dragh = 0.60 real, parameter :: dnz00 = 1.225 real, parameter :: rho00 = 1.225 real, parameter :: cs = 12.42 real, parameter :: ds = 0.42 real, parameter :: cp608 = 0.608 real, parameter :: gr = 9.8 real, parameter :: pi = 3.141592653589793 real, parameter :: piinv = 1./pi real, parameter :: pid4 = pi/4.0 real xvrmn, xvrmx0 real xvsmn, xvsmx real xvfmn, xvfmx real xvgmn, xvgmx real xvhmn, xvhmn0, xvhmx, xvhmx0 real xvhlmn, xvhlmx, xvhlmx0 real, parameter :: dhlmn = 0.3e-3 real, parameter :: dhmn0 = 0.3e-3 real, private :: dhmn = dhmn0, dhmx = -1., dhlmx = -1. real, parameter :: cwradn = 2.0e-6, xcradmn = cwradn real, parameter :: cwradx = 60.e-6, xcradmx = cwradx real, parameter :: cwc1 = 6.0/(pi*1000.) real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 real, parameter :: cwmasn = 1000.*xvcmn real, parameter :: cwmasx = 1000.*xvcmx real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 real, private :: xvdmx = -1.0 real :: xvrmx parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx0=0.523599*(40.e-3)**3 ) real eperao parameter (eperao = 8.8592e-12 ) real ec,eci parameter (ec = 1.602e-19) parameter (eci = 1.0/ec) real :: scwppmx = 20.0e-12 real :: scippmx = 20.0e-12 real, parameter :: c1f3 = 1.0/3.0 real, parameter :: cai = 21.87455 real, parameter :: caw = 17.2693882 real, parameter :: cbi = 7.66 real, parameter :: cbw = 35.86 real, parameter :: cbwbolton = 29.65 real, parameter :: cawbolton = 17.67 real, parameter :: esbolton = 6.112e2 real, parameter :: tfrh = 233.15 real, parameter :: tfr = 273.15 real, parameter :: cp = 1004.0, rd = 287.04 real, parameter :: rw = 461.5 real, parameter :: cpl = 4190.0 real, parameter :: cpigb = 2106.0 real, parameter :: cpi = 1./cp real, parameter :: cap = rd/cp real, parameter :: tfrcbw = tfr - cbw real, parameter :: tfrcbi = tfr - cbi real, parameter :: rovcp = rd/cp real :: rdorv = 0.622 real, parameter :: poo = 1.0e+05 real, parameter :: advisc0 = 1.832e-05 real, parameter :: advisc1 = 1.718e-05 real, parameter :: tka0 = 2.43e-02 real, private, parameter :: cv = 717.0 REAL, PRIVATE, parameter :: cvv = 1408.5 real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) real :: ventr, ventrn, ventc, c1sw real :: cckm,ccne,ccnefac,cnexp,CCNE0 integer :: na = 9 integer :: nxtra = 1 real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 real gfcinu1, gfcinu1p47, gfcinu2p47 real gfcinu1p22,gfcinu2p22 real gfcinu1p18,gfcinu2p18 real :: cwchtmp0 = 1.0 real :: cwchltmp0 = 1.0 real :: esctot = 1.0e-13 integer iexy(lc:lqmx,lc:lqmx) integer :: ieswi = 1, ieswc = 1, ieswr = 0 integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 logical, parameter :: do_satadj_for_wrfchem = .true. integer, private :: lcn_nu = 0 integer, private :: lcn_ac = 0 integer, private :: lcn_co = 0 integer, private :: lcinp = 0 integer, private :: ac_opt = 0 real, private :: ac_wthresh = 10.0 logical, private :: nuaccoinp = .false. logical, private :: arg_para = .true. real, private :: nu_pmr = 7.5 * 1.e-3 * 1.e-6 real, private :: nu_pgw = 0.53 real, private :: nu_kappa = 0.07 real, private :: ac_pmr = 3.8 * 1.e-2 * 1.e-6 real, private :: ac_pgw = 0.69 real, private :: ac_kappa = 0.61 real, private :: co_pmr = 0.51 * 1.e-6 real, private :: co_pgw = 0.77 real, private :: co_kappa = 0.61 real, parameter :: cn_minlimit = 1.e3 logical :: dm15_para = .false. NAMELIST /nssl_mp_params/ & ac_opt,arg_para, & ac_kappa, ac_pmr, ac_pgw, & nu_kappa, nu_pmr, nu_pgw, & co_kappa, co_pmr, co_pgw, & ndebug, ncdebug,& iusewetgraupel, & iusewethail, & iusewetsnow, & idbzci, & vtmaxsed, & itfall,iscfall, & infall,irfall,isfall,iifall, & rssflg, & sssflg, & hssflg, & hlssflg, & irainbreak, rainbreakfac, & irimdenopt,rimdenvwgt, & rimc1, rimc2, rimc3, rimc4, & idiagnosecnu, & icnuclimit, & irenuc, ccn, & restoreccn, ccntimeconst, cck, & decayufccn, ufccntimeconst, & switchccn, old_cccn, & ciintmx, & itype1, itype2, & icenucopt, in_freeze_rain_first, & naer, & icfn, & ibfc, iacr, icracr, & icracrthresh, & cwfrz2snowfrac, cwfrz2snowratio, & ibfr, & ibiggopt, & ibiggsmallrain, & ifrzg,ifiacrg, & ifrzs,ffrzs, & iacrsize, & cimas0, cimas1, cfnfac, & splintermass, & ewfac, & eii0, eii1, & eri0, esi0, & eri_cimin, & eii0hl, eii1hl, & ehs0, ehs1, & ess0, ess1, iessopt, & esstem1,esstem2, & ircnw, qminrncw,& iglcnvi, & iglcnvs, & alphahacx, & fconv, & eqtot, & imeyers5, & iehw, & ierw, & iehr0c,iehlr0c, & alphai, & alphar, & alphas, & cnu, & iscni,fscni, & dfrz, & dmlt, & rainfallfac, & icefallfac, & snowfallfac, & graupelfallfac, & hailfallfac, & icefallopt, & icdx,icdxhl, & axh,bxh,axf,bxf,axhl,bxhl, & cdhmin, cdhmax, & cdhdnmin, cdhdnmax, & cdhlmin, cdhlmax, & cdhldnmin, cdhldnmax, & ihmlt, & ehimin, & ehimax, & ehsmax, & ecollmx, & eiw0, esw0, & ehw0, ehlw0, & ehr0, ehlr0, & erw0, & exwmindiam, & nsplinter, & lawson_splinter_fac, & iqcinit, & ssmxinit, & xvdmx, & dhmn, dhmx, dhlmx, & fwms,fwmh,fwmhl, & ifwmhopt, & ihxw2rain, & fwmlarge, & ifwmfall, & iturbenhance, & qsdenmod,qhdenmod, & qsvtmod, & alphamin,alphamax, & isnwfrac, & rescale_low_alpha, & rescale_low_alphar, & rescale_low_alphah, & rescale_low_alphahl, & rescale_high_alpha, & ihlcnh, hldia1,iusedw, dwehwmin, dwmin, dwmax, dwtempmin, dg0thresh, incwet, & wetgrthtoffset, hailcnvtoffset, & icvhl2h, hldnmn,hdnmn, & hlcnhdia, hlcnhqmin, & isedonly, & iresetmoments, & cxmin, zxmin, & imurain, & iferwisventr, & izwisventr, & qhdpvdn, & qhacidn, & sheddiam,sheddiamlg, & sheddiam0, & mltdiam1,mltdiam2,mltdiam3,mltdiam4,mltdiam05, & imaxdiaopt, & ithompsoncnoh, & cnohmn, & ivhmltsoak, & ioldlimiter, & isnowfall, & isnowdens, & ibiggsnow, & ixtaltype, & evapfac, & depfac, & dmrauto,irescalerainopt, dmropt,dmhlopt, & rescale_tempthresh, rescale_wthresh, & ibinhmlr,ibinhlmlr,imltshddmr, binmlrmxdia, binmlrzrrfac,ibinnum, & iqhacrmlr, iqhlacrmlr, & snowmeltdia, & delta_alphamlr, & iqvsopt, & maxsupersat, & do_accurate_sedimentation, interval_sedi_vt CONTAINS REAL FUNCTION fqvs(t) implicit none real :: t fqvs = exp(caw*(t-273.15)/(t-cbw)) END FUNCTION fqvs REAL FUNCTION fqis(t) implicit none real :: t fqis = exp(cai*(t-273.15)/(t-cbi)) END FUNCTION fqis SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & & namelist_filename, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icdx, & & 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, & & nssl_ccn_opt, & & infileunit, & & myrank, mpiroot & ) implicit none real, intent(in), optional :: & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & & nssl_ehlw0, & & nssl_icefallfac, & & nssl_snowfallfac, & & nssl_cccn, & & nssl_alphah, & & nssl_alphahl, & & nssl_alphar integer, intent(in), optional :: & & nssl_icdx, & & nssl_icdxhl, myrank, mpiroot, & & nssl_ufccn, & & nssl_ccn_opt logical, intent(in), optional :: nssl_density_on, nssl_ccn_on, nssl_hail_on, nssl_icecrystals_on integer, intent(inout), optional :: ccn_is_ccna integer, intent(in),optional :: infileunit integer,parameter::strsize=512 character(len=strsize), intent(in), optional :: namelist_filename character(len=strsize) :: namelist_inputfile integer, intent(in), optional :: ims,ime, jms,jme, kms,kme real, intent(in), dimension(20), optional :: nssl_params 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,cwch real :: temq integer :: igam integer :: i,il,j,l integer :: ltmp integer :: isub 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 turn_on_ccna = .false. turn_on_cina = .false. 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 ffrzs = 1.0 ENDIF ENDIF IF ( present( nssl_params ) ) THEN ccn = Abs( nssl_params(1) ) alphah = nssl_params(2) alphahl = nssl_params(3) cnoh = nssl_params(4) cnohl = nssl_params(5) cnor = nssl_params(6) cnos = nssl_params(7) rho_qh = nssl_params(8) rho_qhl = nssl_params(9) rho_qs = nssl_params(10) IF ( Nint(nssl_params(13)) == 1 ) THEN turn_on_ccna = .true. irenuc = 5 ENDIF ccnuf = Abs( nssl_params(14) ) IF ( present(nssl_ufccn) ) iufccn = nssl_ufccn ENDIF IF ( present(nssl_graupelfallfac) ) graupelfallfac = nssl_graupelfallfac IF ( present(nssl_hailfallfac) ) hailfallfac = nssl_hailfallfac 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 ipconc = ipctmp IF ( ihlcnh <= 0 ) THEN IF ( ipconc < 5 ) THEN ihlcnh = 0 ELSEIF ( ipconc == 5 ) THEN ihlcnh = 3 ELSEIF ( ipconc >= 6 ) THEN ihlcnh = 3 ENDIF ENDIF IF ( irainbreak == -1 ) THEN IF ( ipconc >= 6 ) THEN irainbreak = 2 ELSE irainbreak = 0 ENDIF ENDIF namelist_inputfile = 'namelist.input' IF ( present( namelist_filename ) ) THEN namelist_inputfile = namelist_filename ELSE ENDIF IF ( .true. ) THEN open(15,file=namelist_inputfile,status='old',form='formatted',action='read') rewind(15) read(15,NML=nssl_mp_params,iostat=istat) close(15) IF ( istat /= 0 ) THEN ENDIF IF ( wrf_dm_on_monitor() .and. .not. wrote_namelist ) THEN open(15,file='namelist.output',status='old',action='readwrite', position='append',form='formatted') write(15,NML=nssl_mp_params) close(15) wrote_namelist = .true. ENDIF ENDIF IF ( iufccn > 0 ) THEN irenuc = 7 IF ( ccnuf <= 0.0 ) decayufccn = .true. 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 IF ( present( nssl_ccn_opt ) ) THEN IF ( nssl_ccn_opt > 10 ) ac_opt = 22 ENDIF 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 write(0,*) 'NSSL_MP Error: Must have nssl_ccn_on=1/true for irenuc >= 5!' STOP 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 lhab = 8 lhl = 8 IF ( icespheres >= 1 ) THEN lhab = lhab + 1 lis = li + 1 ls = ls + 1 lh = lh + 1 lhl = lhl + 1 ENDIF IF ( hail_on == -1 ) THEN hail_on = 1 IF ( ihvol <= -1 .or. ihvol == 2 ) THEN IF ( ihvol == -1 .or. ihvol == -2 ) THEN lhab = lhab - 1 lhl = 0 hail_on = 0 ENDIF IF ( ihvol == -2 .or. ihvol == 2 .or. icecrystals_on == 0 ) THEN ffrzs = 1.0 ENDIF ENDIF ELSE IF ( hail_on == 0 ) THEN lhab = lhab - 1 lhl = 0 ELSE ENDIF ENDIF IF ( density_on == -1 ) THEN density_on = 1 ENDIF do l = 1,nqsat temq = 163.15 + (l-1)*fqsat IF ( iqvsopt == 0 ) THEN tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & & caw/(temq - cbw))*tabqvs(l) ELSE tabqvs(l) = exp(cawbolton*(temq-273.15)/(temq-cbwbolton)) dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + & & cawbolton/(temq - cbwbolton))*tabqvs(l) ENDIF tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & & cai/(temq - cbi))*tabqis(l) end do bx(lr) = 0.85 ax(lr) = 1647.81 fx(lr) = 135.477 IF ( icdx == 6 ) THEN bx(lh) = 0.6 ax(lh) = 157.71 ELSEIF ( icdx > 1 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 ELSEIF ( icdx == 0 ) THEN bx(lh) = 0.37 ax(lh) = 19.3 ELSE bx(lh) = bxh ax(lh) = axh ENDIF IF ( lhl .gt. 1 ) THEN IF ( icdxhl == 6 ) THEN bx(lhl) = 0.593 ax(lhl) = 179.36 ELSEIF (icdxhl == 0 ) THEN ax(lhl) = 206.984 bx(lhl) = 0.6384 ELSEIF (icdxhl > 0 ) THEN bx(lhl) = 0.5 ax(lhl) = 75.7149 ELSE bx(lhl) = bxhl ax(lhl) = axhl ENDIF ENDIF gmoi(0) = 1.d32 do igam = 1,ngm0 arg = dgam*igam gmoi(igam) = gamma_dp(arg) end do bxh1 = bx(lh) bxhl1 = bx(Max(lh,lhl)) DO j = ialpstart,nqiacralpha alp = float(j)*dqiacralpha y = gamma_dpr(1.+alp) y2 = gamma_dpr(2.+alp) DO i = 0,nqiacrratio ratio = float(i)*dqiacrratio x = gamxinfdp( 1.+alp, ratio ) ciacrratio(i,j) = x/y 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*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*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 gamxinflu(i,j,12,1) = gamxinfdp( 2.0+alp, ratio )/y2 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*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*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) IF ( alp > 1.1 ) THEN gamxinflu(i,j,7,1) = (gamma_dpr(alp - 1.) - gamxinfdp( alp - 1., 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) = (gamma_dpr(alp - 0.5 + 0.5*bxhl1) - gamxinfdp( alp - 0.5 + 0.5*bxhl1, ratio ))/y ELSE gamxinflu(i,j,7,1) = (gamma_dpr(0.1) - gamxinfdp( 0.1, 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) ENDDO ENDDO ciacrratio(0,:) = 1.0 DO j = ialpstart,nqiacralpha alp = float(j)*dqiacralpha y = gamma_sp(4.+alp) y7 = gamma_sp(7.+alp) DO i = 0,nqiacrratio ratio = float(i)*dqiacrratio x = gamxinfdp( 4.+alp, ratio ) qiacrratio(i,j) = x/y gamxinflu(i,j,4,1) = x/y gamxinflu(i,j,4,2) = x/y x = gamxinfdp( 7.+alp, ratio ) ziacrratio(i,j) = x/y7 gamxinflu(i,j,11,1) = x/y7 gamxinflu(i,j,11,2) = x/y7 ENDDO ENDDO qiacrratio(0,:) = 1.0 lccn = 0 lccnuf = 0 lccna = 0 lccnaco = 0 lccnanu = 0 lnc = 0 lnr = 0 lni = 0 lnis = 0 lns = 0 lnh = 0 lnhl = 0 lvh = 0 lvhl = 0 lzr = 0 lzh = 0 lzhl = 0 lsw = 0 lhw = 0 lhlw = 0 denscale(:) = 0 IF ( ipconc == 0 ) THEN IF ( hail_on == 1 ) THEN IF ( density_on >= 1 ) THEN lvh = 9 ltmp = 9 denscale(lvh) = 1 ELSE ltmp = lhab lvh = 0 lvhl = 0 ENDIF ELSE ltmp = lhab lhl = 0 ENDIF ELSEIF ( ipconc == 5 ) THEN ltmp = lhab IF ( iufccn > 0 ) THEN ltmp = ltmp+1 lccnuf = ltmp denscale(lccnuf) = 1 ENDIF lccn= ltmp+1 lnc = ltmp+2 lnr = ltmp+3 lni = ltmp+4 lns = ltmp+5 lnh = ltmp+6 ltmp = lnh IF ( hail_on == 1 ) THEN ltmp = ltmp + 1 lnhl = ltmp ENDIF IF ( density_on >= 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ENDIF denscale(lccn:ltmp) = 1 IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp denscale(lvhl) = 1 ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp ltmp = ltmp + 1 lhw = ltmp IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lhlw = ltmp ENDIF ENDIF ELSEIF ( ipconc >= 6 ) THEN ltmp = lhab IF ( iufccn > 0 ) THEN ltmp = ltmp+1 lccnuf = ltmp denscale(lccnuf) = 1 ENDIF lccn= ltmp+1 lnc = ltmp+2 lnr = ltmp+3 lni = ltmp+4 lns = ltmp+5 lnh = ltmp+6 ltmp = lnh IF ( lhl > 0 ) THEN ltmp = ltmp + 1 lnhl = ltmp ENDIF IF ( density_on == 1 ) THEN ltmp = ltmp + 1 lvh = ltmp ENDIF denscale(lccn:ltmp) = 1 IF ( density_on == 1 .and. hail_on == 1 ) THEN ltmp = ltmp + 1 lvhl = ltmp denscale(lvhl) = 1 ENDIF IF ( ipconc == 6 ) THEN ltmp = ltmp + 1 lzh = ltmp ELSEIF ( ipconc == 7 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp ELSEIF ( ipconc == 8 ) THEN ltmp = ltmp + 1 lzh = ltmp ltmp = ltmp + 1 lzr = ltmp IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lzhl = ltmp ENDIF ENDIF IF ( mixedphase ) THEN ltmp = ltmp + 1 lsw = ltmp ltmp = ltmp + 1 lhw = ltmp IF ( lhl > 1 ) THEN ltmp = ltmp + 1 lhlw = ltmp ENDIF ENDIF ELSE CALL wrf_error_fatal3("",1853,& 'nssl_2mom_init: Invalid value of ipctmp' ) ENDIF IF ( turn_on_ccna ) THEN ltmp = ltmp + 1 lccna = ltmp denscale(ltmp) = 1 ENDIF IF ( turn_on_cina ) THEN ltmp = ltmp + 1 lcina = ltmp denscale(ltmp) = 1 ENDIF IF ( turn_on_cin .or. is_aerosol_aware ) THEN ltmp = ltmp + 1 lcin = ltmp denscale(ltmp) = 1 ENDIF na = ltmp ln(:) = 0 ln(lc) = lnc ln(lr) = lnr ln(li) = lni ln(ls) = lns ln(lh) = lnh IF ( lhl .gt. 1 ) ln(lhl) = lnhl ipc(:) = 0 ipc(lc) = 2 ipc(lr) = 3 ipc(li) = 1 ipc(ls) = 4 ipc(lh) = 5 IF ( lhl .gt. 1 ) ipc(lhl) = 5 ldovol = .false. lvol(:) = 0 lvol(li) = lvi lvol(ls) = lvs lvol(lh) = lvh IF ( lhl .gt. 1 .and. lvhl .gt. 1 ) lvol(lhl) = lvhl lne = Max(lnh,lnhl) lne = Max(lne,lvh) lne = Max(lne,lvhl) lne = Max(lne,na) lsc(:) = 0 lsc(lc) = lscw lsc(lr) = lscr lsc(li) = lsci lsc(ls) = lscs lsc(lh) = lsch IF ( lhl .gt. 1 ) lsc(lhl) = lschl DO il = lc,lhab ldovol = ldovol .or. ( lvol(il) .gt. 1 ) ENDDO lz(:) = 0 lz(lr) = lzr lz(li) = lzi lz(ls) = lzs lz(lh) = lzh IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl lliq(:) = 0 lliq(ls) = lsw lliq(lh) = lhw IF ( lhl .gt. 1 ) lliq(lhl) = lhlw IF ( mixedphase ) THEN ENDIF xnu(lc) = cnu xmu(lc) = 1. IF ( imurain == 3 ) THEN xnu(lr) = rnu xmu(lr) = 1. ELSEIF ( imurain == 1 ) THEN xnu(lr) = (alphar - 2.0)/3.0 xmu(lr) = 1./3. ENDIF xnu(li) = cinu xmu(li) = 1. IF ( lis >= 1 ) THEN xnu(lis) = 0.0 xmu(lis) = 1. ENDIF dnu(lc) = 3.*xnu(lc) + 2. dmu(lc) = 3.*xmu(lc) dnu(lr) = 3.*xnu(lr) + 2. dmu(lr) = 3.*xmu(lr) xnu(ls) = snu xmu(ls) = 1. dnu(ls) = 3.*xnu(ls) + 2. dmu(ls) = 3.*xmu(ls) dnu(lh) = alphah dmu(lh) = dmuh xnu(lh) = (dnu(lh) - 2.)/3. xmu(lh) = dmuh/3. IF ( imurain == 3 ) THEN rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) rzs = 1. ELSE rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) rzs = & & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) ENDIF IF ( ipconc <= 5 ) THEN imltshddmr = Min(1, imltshddmr) ibinhmlr = 0 ibinhlmlr = 0 ENDIF IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN imltshddmr = Min(1, imltshddmr) ENDIF IF ( ipconc .lt. 4 ) THEN dnu(ls) = alphas dmu(ls) = 1. xnu(ls) = (dnu(ls) - 2.)/3. xmu(ls) = 1./3. ENDIF IF ( lhl .gt. 1 ) THEN dnu(lhl) = alphahl dmu(lhl) = dmuhl xnu(lhl) = (dnu(lhl) - 2.)/3. xmu(lhl) = dmuhl/3. ENDIF cno(lc) = 1.0e+08 IF ( li .gt. 1 ) cno(li) = 1.0e+08 cno(lr) = cnor IF ( ls .gt. 1 ) cno(ls) = cnos IF ( lh .gt. 1 ) cno(lh) = cnoh IF ( lhl .gt. 1 ) cno(lhl) = cnohl xdnmx(:) = 900.0 xdnmx(lr) = 1000.0 xdnmx(lc) = 1000.0 xdnmx(li) = 917.0 xdnmx(ls) = 300.0 xdnmx(lh) = 900.0 IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 xdnmn(:) = 900.0 xdnmn(lr) = 1000.0 xdnmn(lc) = 1000.0 xdnmn(li) = 100.0 xdnmn(ls) = 100.0 xdnmn(lh) = hdnmn IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn xdn0(:) = 900.0 xdn0(lc) = 1000.0 xdn0(li) = 900.0 xdn0(lr) = 1000.0 xdn0(ls) = rho_qs xdn0(lh) = rho_qh IF ( lhl .gt. 1 ) xdn0(lhl) = rho_qhl cdx(lr) = 0.60 cdx(lh) = 0.8 cdx(ls) = 2.00 IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 ido(lc) = idocw ido(lr) = idorw ido(li) = idoci ido(ls) = idosw ido(lh) = idohw IF ( lhl .gt. 1 ) ido(lhl) = idohl linfall(:) = infall linfall(lc) = 0 IF ( irfall .lt. 0 ) irfall = infall IF ( isfall .lt. 0 ) isfall = infall IF ( iifall .lt. 0 ) iifall = infall IF ( lzr > 0 ) irfall = 0 IF ( lzs > 0 ) isfall = 0 IF ( lzh > 0 ) linfall(lh) = 0 IF ( lzhl > 0 .and. lhl > 0 ) linfall(lhl) = 0 IF ( lzr > 0 .and. lf > 0 ) linfall(lf) = 0 linfall(lr) = irfall linfall(ls) = isfall linfall(li) = iifall qccn = ccn/rho00 qccnuf = ccnuf/rho00 IF ( old_cccn > 0.0 ) THEN old_qccn = old_cccn/rho00 ELSE old_qccn = qccn ENDIF IF ( xvdmx .gt. 0.0 ) THEN xvrmx = 0.523599*(xvdmx)**3 ELSE xvrmx = xvrmx0 ENDIF IF ( dhmn <= 0.0 ) THEN xvhmn = xvhmn0 ELSE xvhmn = 0.523599*(dhmn)**3 ENDIF IF ( dhmx <= 0.0 ) THEN xvhmx = xvhmx0 ELSE xvhmx = 0.523599*(dhmx)**3 ENDIF IF ( dhlmx <= 0.0 ) THEN xvhlmx = xvhlmx0 ELSE xvhlmx = 0.523599*(dhlmx)**3 ENDIF IF ( ipconc == 5 .and. imorrgdnglimit >= 1 ) THEN cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) xvhmx = pi/6.0*(morrdnglimit/cwch)**3 dhmx = morrdnglimit/cwch ENDIF IF ( qhdpvdn < 0. ) qhdpvdn = xdnmn(lh) IF ( qhacidn < 0. ) qhacidn = xdnmn(lh) xvmn(lc) = xvcmn xvmn(li) = xvimn xvmn(lr) = xvrmn xvmn(ls) = xvsmn xvmn(lh) = xvhmn xvmx(lc) = xvcmx xvmx(li) = xvimx xvmx(lr) = xvrmx xvmx(ls) = xvsmx xvmx(lh) = xvhmx IF ( lhl .gt. 1 ) THEN xvmn(lhl) = xvhlmn xvmx(lhl) = xvhlmx ENDIF IF ( ipconc .ge. 2 ) THEN ENDIF IF ( lhl < 1 ) ifrzg = 1 ventr = 1. IF ( imurain == 3 ) THEN ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ventrn = Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ELSE ventr = Gamma_sp(2. + alphar) ventrn = Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ENDIF ventc = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.) c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0) qxmin(:) = 1.0e-12 qxmin(lc) = 1.e-9 qxmin(lr) = 1.e-7 IF ( li > 1 ) qxmin(li) = 1.e-12 IF ( ls > 1 ) qxmin(ls) = 1.e-7 IF ( lh > 1 ) qxmin(lh) = 1.e-7 IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7 IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13 IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12 IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 qxmin_init(:) = 1.0e-8 cckm = cck-1. ccnefac = (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0)) cnexp = (3./2.)*cck/(cck+2.0) ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) IF ( cwccn .lt. 0.0 ) THEN cwccn = Abs(cwccn) ccwmx = 50.e9 ELSE ccwmx = 50.e9 ENDIF bb(:) = 1.0/3.0 bb(li) = 0.3429 DO il = lc,lhab da0(il) = delbk(bb(il), xnu(il), xmu(il), 0) da1(il) = delbk(bb(il), xnu(il), xmu(il), 1) ENDDO dab0(:,:) = 0.0 dab1(:,:) = 0.0 DO il = lc,lhab DO j = lc,lhab IF ( il .ne. j ) THEN dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0) dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1) ENDIF ENDDO ENDDO dab0lu(:,:,:,:) = 0.0 dab1lu(:,:,:,:) = 0.0 IF ( ipconc >= 6 ) THEN DO il = lc,lhab DO j = lc,lhab 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 ENDIF ENDDO ENDDO ENDIF gf4br = gamma_sp(4.0+br) gf4ds = gamma_sp(4.0+ds) gf4p5 = gamma_sp(4.0+0.5) gfcinu1 = gamma_sp(cinu + 1.0) gfcinu1p47 = gamma_sp(cinu + 1.47167) gfcinu2p47 = gamma_sp(cinu + 2.47167) gfcinu1p22 = gamma_sp(cinu + 1.22117) gfcinu2p22 = gamma_sp(cinu + 2.22117) gfcinu1p18 = gamma_sp(cinu + 1.18333) gfcinu2p18 = gamma_sp(cinu + 2.18333) gsnow1 = gamma_sp(snu + 1.0) gsnow53 = gamma_sp(snu + 5./3.) gsnow73 = gamma_sp(snu + 7./3.) IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) iexy(:,:)=0; iexy(ls,li) = ieswi iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; IF (lhl .gt. 1 ) THEN iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; ENDIF RETURN END SUBROUTINE nssl_2mom_init 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, & f_qc, f_qr, f_qi, f_qs, f_qh, f_qhl, & cn_nu, cn_co, cinp, f_cnnu, f_cnco, f_cinp, & cna_co, cna_nu, f_cnaco, f_cnanu, & cnuf, f_cnuf, cn_ac, f_cnac, & 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, & scr,scw,sci,scs,sch,schl,sctot, & elec_physics, & induc,elecz,scion,sciona,f_scion,f_sciona, & noninduc,noninducp,noninducn, & ssat3d,ssati,nssl_ssat_output, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & nctr2, nnuccd2, nnucf2, & effc2,effr2,effi2, & effs2, effg2, & fc2, fr2,fi2,fs2,fg2, & fnc2, fnr2,fni2,fns2,fng2, & ipelectmp, & isedonly_in, & diagflag,ke_diag, & nssl_progn, & wetscav_on, rainprod, evapprod, & cu_used, qrcuten, qscuten, qicuten, qccuten, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) implicit none integer, intent(in):: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & qv,qc,qr,qs,qh real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & th, tt, & zrw, zhw, zhl, & qsw, qhw, qhlw, & qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl integer, optional, intent(in) :: is_theta_or_temp logical, optional, intent(in) :: f_zrw, f_zhw, f_zhl, f_vhw, f_vhl integer, optional, intent(in) :: nssl_ssat_output real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn, cna, cni, cnuf real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: cn_nu, cn_ac, cn_co, cinp, cna_co, cna_nu logical, optional, intent(in) :: f_cnnu, f_cnac, f_cnco, f_cinp, f_cnaco, f_cnanu real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d, & rscghis_2dp, & rscghis_2dn integer, optional, intent(in) :: elec_physics real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & scr,scw,sci,scs,sch,schl,sciona,sctot real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & induc,noninduc,noninducp,noninducn real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elecz 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 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & ssat3d, ssati, & pcc2, pre2, depsubr, & mnucf2, melr2, ctr2, & rim1_2, rim2_2,rim3_2, & nctr2, nnuccd2, nnucf2, & effc2,effr2,effi2, & effs2, effg2, & fc2, fr2,fi2,fs2,fg2, & fnc2, fnr2,fni2,fns2,fng2 real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout) :: axtra real, dimension(ims:ime, jms:jme) :: & RAINNC,RAINNCV real, dimension(ims:ime, jms:jme), optional, intent(inout):: & SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV real, dimension(ims:ime, jms:jme), optional, intent(inout) :: hail_maxk1, hail_max2d integer, optional, intent(in) :: nwp_diagnostics integer, parameter :: nproc = 1 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, has_reqg, has_reqh real, dimension(ims:ime, jms:jme), intent(out), optional :: & rainncw2, rainnci2 real, optional, intent(in) :: dx,dy real, intent(in) :: dtp integer, intent(in) :: itimestep 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 logical, optional, intent(in) :: f_scion,f_sciona integer, optional, intent(in) :: ipelectmp, ke_diag, isedonly_in LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn LOGICAL :: flag_qndrop LOGICAL :: flag_qnifa , flag_qnwfa logical :: flag_cnuf = .false. logical :: flag_ccn = .false. logical :: flag_qi = .true. logical :: has_reqr_local = .false., has_reqg_local = .false., has_reqh_local = .false. logical :: flag logical :: nwp_diagflag = .false. real :: cinchange, t7max,testmax,wmax REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten INTEGER, optional, intent(in) :: cu_used LOGICAL, optional, intent(in) :: wetscav_on real, dimension(its:ite, 1, kts:kte) :: elec2 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,ngs integer ix,jy,kz,i,j,k,il,n integer :: infdo real :: ssival, ssifac, t8s, t9s, qvapor integer :: ltemq double precision :: dp1 integer :: jye, lnb integer :: imx,kmx real :: dbzmx,refl integer :: vzflag0 = 0 logical :: makediag real :: dx1,dy1 real, parameter :: cnin20 = 1.0e3 real, parameter :: cnin10 = 5.0e1 real, parameter :: cnin1a = 4.5 real, parameter :: cnin2a = 12.96 real, parameter :: cnin2b = 0.639 double precision :: cwmass1,cwmass2 double precision :: rwmass1,rwmass2 double precision :: icemass1,icemass2 double precision :: swmass1,swmass2 double precision :: grmass1,grmass2 double precision :: hlmass1,hlmass2 double precision :: wvol5,wvol10 real :: tmp,dv,dv1,tmpchg real :: rdt real :: temp1, c1 double precision :: dt1,dt2 double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt logical :: f_cnatmp, f_cinatmp, f_cnacotmp, f_cnanutmp logical :: has_wetscav integer :: kediagloc integer :: iunit integer :: isedonly_local real :: ycent, y, emissrate, emissrate0, emissrate1, z, fac, factot real :: fach(kts:kte) logical, parameter :: debugdriver = .false. integer :: loopcnt, loopmax, outerloopcnt logical :: lastlooptmp rdt = 1.0/dtp IF ( debugdriver ) write(0,*) 'N2M: entering routine' 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_reqr ) ) has_reqr_local = has_reqr > 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 ELSE f_cnatmp = .false. ENDIF IF ( present( f_cina ) ) THEN f_cinatmp = f_cina ELSE f_cinatmp = .false. ENDIF IF ( present( vzf ) ) vzflag0 = 1 IF ( present( ipelectmp ) ) THEN ipelec = ipelectmp ELSE ipelec = 0 ENDIF IF ( present( isedonly_in ) ) THEN isedonly_local = isedonly_in ELSE isedonly_local = 0 ENDIF IF ( present( dx ) .and. present( dy ) ) THEN dx1 = dx dy1 = dy ELSE dx1 = 1.0 dy1 = 1.0 ENDIF makediag = .true. IF ( present( diagflag ) ) THEN makediag = diagflag .or. itimestep == 1 ENDIF IF ( debugdriver ) write(0,*) 'N2M: makediag = ',makediag nx = ite-its+1 ny = 1 nz = kte-kts+1 ngs = 64 IF ( .not. flag_ccn ) THEN renucfrac = 1.0 ENDIF IF ( itimestep == 1 .and. .not. invertccn .and. flag_ccn ) THEN IF ( lccna > 1 .and. .not. ( present( cna ) .and. f_cnatmp ) ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cn(ix,kz,jy) = 0.0 ENDDO ENDDO ENDDO ELSEIF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cn(ix,kz,jy) = qccn ENDDO ENDDO ENDDO ENDIF IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cnuf(ix,kz,jy) = qccnuf ENDDO ENDDO ENDDO ENDIF ENDIF IF ( itimestep == 1 .and. invertccn .and. flag_ccn ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cn(ix,kz,jy) = 0.0 ENDDO ENDDO ENDDO ENDIF IF ( invertccn .and. flag_ccn ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) ENDDO ENDDO ENDDO IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) ENDDO ENDDO ENDDO ENDIF ENDIF infdo = 2 IF ( infall .ne. 1 .or. iscfall .ge. 2 ) THEN infdo = 1 ELSE infdo = 0 ENDIF IF ( Any(linfall(:) .ge. 3 ) .or. ipconc .ge. 6 ) THEN infdo = 2 ENDIF IF ( present( HAILNCV ) .and. lhl < 1 ) THEN HAILNCV(its:ite,jts:jte) = 0. ENDIF tke2d(:,:) = 0.0 lnb = Max(lh,lhl)+1 jye = jte IF ( present( compdbz ) .and. makediag ) THEN DO jy = jts,jye DO ix = its,ite compdbz(ix,jy) = -3.0 ENDDO ENDDO ENDIF zmaxsed = 0.0d0 timevtcalc = 0.0d0 timesetvt = 0.0d0 timesed = 0.0d0 timesed1 = 0.0d0 timesed2 = 0.0d0 timesed3 = 0.0d0 timegs = 0.0d0 timenucond = 0.0d0 IF ( debugdriver ) write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl) ancuten(its:ite,1,kts:kte,:) = 0.0 thproclocal(:,:) = 0.0 DO jy = jts,jye IF ( ( present( pcc2 ) .or. present( axtra ) ) .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 DO kz = kts,kte DO ix = its,ite an(ix,1,kz,lt) = th(ix,kz,jy) 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 ( flag_qi ) THEN an(ix,1,kz,li) = qi(ix,kz,jy) ELSE an(ix,1,kz,li) = 0.0 ENDIF an(ix,1,kz,ls) = qs(ix,kz,jy) an(ix,1,kz,lh) = qh(ix,kz,jy) IF ( lhl > 1 ) an(ix,1,kz,lhl) = qhl(ix,kz,jy) IF ( lccn > 1 ) THEN IF ( is_aerosol_aware .and. flag_qnwfa ) 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 ELSE an(ix,1,kz,lccn) = cn(ix,kz,jy) ENDIF IF ( i_uf_or_ccn > 0 .and. lccnuf > 1 ) THEN 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) ELSE an(ix,1,kz,lccn) = qccn ENDIF ENDIF ENDIF IF ( lccnuf > 0 .and. flag_cnuf ) THEN IF ( i_uf_or_ccn == 0 ) THEN an(ix,1,kz,lccnuf) = Max(0.0, cnuf(ix,kz,jy) ) ELSE 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) = Max(0.0, cna(ix,kz,jy) ) ENDIF ENDIF IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN an(ix,1,kz,lcina) = cni(ix,kz,jy) ENDIF ENDIF IF ( ipconc >= 5 ) THEN an(ix,1,kz,lnc) = ccw(ix,kz,jy) IF ( constccw > 0.0 ) THEN an(ix,1,kz,lnc) = constccw ENDIF an(ix,1,kz,lnr) = crw(ix,kz,jy) IF ( present( cci ) ) THEN an(ix,1,kz,lni) = cci(ix,kz,jy) ELSE an(ix,1,kz,lni) = 0.0 ENDIF an(ix,1,kz,lns) = csw(ix,kz,jy) an(ix,1,kz,lnh) = chw(ix,kz,jy) IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy) ENDIF IF ( lvh > 0 .and. present( vhw ) ) 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 t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) 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 t4(ix,1,kz) = 0.0 t5(ix,1,kz) = 0.0 t6(ix,1,kz) = 0.0 t7(ix,1,kz) = 0.0 t8(ix,1,kz) = 0.0 t9(ix,1,kz) = 0.0 pn(ix,1,kz) = p(ix,kz,jy) wn(ix,1,kz) = w(ix,kz,jy) dn1(ix,1,kz) = dn(ix,kz,jy) dz2d(ix,1,kz) = dz(ix,kz,jy) dz2dinv(ix,1,kz) = 1./dz(ix,kz,jy) ltemq = Int( (t0(ix,1,kz)-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN t8s = t00(ix,1,kz)*tabqvs(ltemq) ELSE t8s = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) ENDIF t9s = t00(ix,1,kz)*tabqis(ltemq) ssival = Min(t8s,max(an(ix,1,kz,lv),0.0))/t9s if ( ssival .gt. 1.0 ) then IF ( icenucopt == 1 ) THEN if ( t0(ix,1,kz).le.268.15 ) then dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) t7(ix,1,kz) = Min(dp1, 1.0d30) end if IF ( imeyers5 ) THEN if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then qvapor = max(an(ix,1,kz,lv),0.0) ssifac = 0.0 if ( (qvapor-t9s) .gt. 1.0e-5 ) then if ( (t8s-t9s) .gt. 1.0e-5 ) then ssifac = (qvapor-t9s) /(t8s-t9s) ssifac = ssifac**cnin1a end if end if t7(ix,1,kz) = dn1(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1) end if ENDIF ELSEIF ( icenucopt == 2 ) THEN t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ELSEIF ( icenucopt == 3 ) THEN if ( t0(ix,1,kz).le.268.15 .and. t0(ix,1,kz) > 243.15 ) then dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) ) t7(ix,1,kz) = Min(dp1, 1.0d30) elseif ( t0(ix,1,kz) <= 243.15 ) then dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3 t7(ix,1,kz) = Min(dp1, 1.0d30) end if ELSEIF ( icenucopt == 4 ) THEN IF ( t0(ix,1,kz) < 268.16 .and. t0(ix,1,kz) > 223.15 .and. ssival > 1.001 ) THEN 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 ENDIF ENDIF end if ENDDO ENDDO 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 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)*dn1(ix,1,kz) ENDDO ENDDO ENDIF ENDDO ENDIF xfall(:,:,:) = 0.0 IF ( itimestep == 1 .and. ipconc > 0 .and. loopcnt == 1 ) THEN call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1) ENDIF IF ( present(cu_used) .and. & ( present( qrcuten ) .or. present( qscuten ) .or. & present( qicuten ) .or. present( qccuten ) ) ) THEN IF ( cu_used == 1 ) THEN DO kz = kts,kte DO ix = its,ite IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy) IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy) IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy) IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy) ENDDO ENDDO call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1) ENDIF ENDIF IF ( isedonly_local == 0 ) THEN call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, & & t0,t7,infdo,jy,its,jts & & ,timesed1,timesed2,timesed3,zmaxsed,timesetvt) IF ( debugdriver ) write(0,*) 'N2M: end sediment, jy = ',jy DO ix = its,ite IF ( lhl > 1 ) THEN 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) = 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 rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) ENDIF IF ( present ( rainnci2 ) ) THEN IF ( lhl > 1 ) THEN rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) ELSE rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF ENDIF 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 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) = GRPLNCV(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) ENDIF ENDIF IF ( loopcnt == loopmax ) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(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 IF ( present( HAILNC ) ) THEN HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) IF ( loopcnt == loopmax ) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) ENDIF ENDIF 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 SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ENDIF ENDIF ENDDO ENDIF IF ( isedonly /= 1 ) THEN IF ( debugdriver ) write(0,*) 'N2M: gs, jy = ',jy call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & & ,dtp,dz2d & & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & & ,an,dn1,t77 & & ,pn,wn,0 & & ,t00,t77, & & ventr,ventc,c1sw,1,ido, & & xdnmx,xdnmn, & & cdx, & & xdn0,dbz2d,tke2d, & & thproclocal,nproc,dx1,dy1,ngs, & & timevtcalc,axtra2d, makediag & & ,has_wetscav, rainprod2d, evapprod2d, alpha2d & & ,elec2,its,ids,ide,jds,jde & & ) ENDIF IF ( .true. ) THEN CALL NUCOND & & (nx,ny,nz,na,jy & & ,nor,nor,dtp,nx & & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & & ,ngs & & ,axtra2d, makediag & & ,ssat,t00,t77,flag_qndrop) CALL smallvalues & & (nx,ny,nz,na,jy & & ,nor,nor,dtp,nx & & ,t0 & & ,an,dn1,wn & & ,t77,flag_qndrop) ENDIF ENDDO IF ( present( pcc2 ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite ENDDO ENDDO ENDIF IF ( ( present( ssat3d ) .and. present( nssl_ssat_output ) ) .and. makediag ) THEN DO kz = kts,kte DO ix = its,ite temp1 = t0(ix,1,kz) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( present( ssat3d ) .and. nssl_ssat_output >= 1 ) THEN IF ( iqvsopt == 0 ) THEN c1 = (380.0/pn(ix,1,kz))*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,1,kz) - esbolton*tabqvs(ltemq)) ENDIF IF ( c1 > 0. ) THEN ssat3d(ix,kz,jy) = 100.*(an(ix,1,kz,lv)/c1 - 1.0) ENDIF ENDIF IF ( present( ssati ) .and. nssl_ssat_output >= 2 ) THEN t9s = (380.0/pn(ix,1,kz))*tabqis(ltemq) ssati(ix,kz,jy) = 100.*(an(ix,1,kz,lv)/t9s - 1.0) ENDIF ENDDO ENDDO ENDIF IF ( present( dbz ) .and. makediag .and. lastlooptmp ) THEN IF ( .true. ) THEN IF ( present(ke_diag) ) THEN kediagloc = ke_diag ELSE kediagloc = nz ENDIF call radardd02(nx,ny,nz,nor,na,an,t0, & & dbz2d,dn1,nz,cnoh,rho_qh,ipconc,kediagloc, 0) ENDIF DO kz = kts,kediagloc DO ix = its,ite dbz(ix,kz,jy) = dbz2d(ix,1,kz) IF ( present( vzf ) ) THEN vzf(ix,kz,jy) = vzf2d(ix,1,kz) IF ( dbz2d(ix,1,kz) <= 0.0 ) THEN vzf(ix,kz,jy) = 0.0 ELSEIF ( dbz2d(ix,1,kz) <= 15.0 ) THEN refl = 10**(0.1*dbz2d(ix,1,kz)) vzf(ix,kz,jy) = Min( vzf2d(ix,1,kz), 2.6 * Max(0.0,refl)**0.107 * (1.2/dn1(ix,1,kz))**0.4 ) ENDIF ENDIF IF ( present( compdbz ) ) THEN compdbz(ix,jy) = Max( compdbz(ix,jy), dbz2d(ix,1,kz) ) ENDIF ENDDO ENDDO ENDIF IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & 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 re_cloud(ix,kz,jy) = 2.51E-6 re_ice(ix,kz,jy) = 10.01E-6 re_snow(ix,kz,jy) = 25.E-6 t1(ix,1,kz) = 2.51E-6 t2(ix,1,kz) = 10.01E-6 t3(ix,1,kz) = 25.E-6 t4(ix,1,kz) = 50.e-6 ENDDO ENDDO call calc_eff_radius & & (nx,ny,nz,na,jy & & ,nor,nor & & ,t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 & & ,f_t4=has_reqr_local,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), 125.E-6)) re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.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 IF ( present(has_reqr) .and. present( re_rain ) ) THEN IF ( has_reqr /= 0 ) THEN DO kz = kts,kte DO ix = its,ite re_rain(ix,kz,jy) = MAX(50.E-6, MIN(t4(ix,1,kz), 2999.E-6)) ENDDO 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 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)/dn1(ix,1,kz) ENDDO ENDDO ENDIF ENDDO DO kz = kts,kte DO ix = its,ite th(ix,kz,jy) = an(ix,1,kz,lt) 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 ( 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 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 cn(ix,kz,jy) = an(ix,1,kz,lccn) ENDIF ENDIF IF ( lccna > 1 ) THEN IF ( present( cna ) .and. f_cnatmp ) THEN cna(ix,kz,jy) = Max(0.0, an(ix,1,kz,lccna) ) ENDIF ENDIF IF ( lcina > 1 ) THEN IF ( present( cni ) .and. f_cinatmp ) THEN cni(ix,kz,jy) = Max(0.0, an(ix,1,kz,lcina) ) ENDIF ENDIF IF ( lccnuf > 0 .and. flag_cnuf ) THEN IF ( i_uf_or_ccn > 0 ) THEN 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) crw(ix,kz,jy) = an(ix,1,kz,lnr) IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni) csw(ix,kz,jy) = an(ix,1,kz,lns) chw(ix,kz,jy) = an(ix,1,kz,lnh) 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 IF ( lvh > 0 .and. present( vhw ) ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) ENDDO ENDDO ENDDO IF ( invertccn .and. flag_ccn ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) ENDDO ENDDO ENDDO ENDIF IF ( lccnuf > 1 .and. flag_cnuf .and. ccnuf > 1.0 ) THEN DO jy = jts,jte DO kz = kts,kte DO ix = its,ite cnuf(ix,kz,jy) = qccnuf - cnuf(ix,kz,jy) ENDDO ENDDO ENDDO ENDIF RETURN END SUBROUTINE nssl_2mom_driver REAL FUNCTION GAMMA_SP(xx) implicit none real xx integer j double precision :: ser,stp,tmp,x,y,cof(6) SAVE cof,stp DATA cof /76.18009172947146d+0, & & -86.50532032941677d0, & & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& & -0.5395239384953d-5/ DATA stp/2.5066282746310005d0/ IF ( xx <= 0.0 ) THEN write(0,*) 'Argument to gamma must be > 0!! xx = ',xx STOP ENDIF x = xx y = x tmp = x + 5.5d0 tmp = (x + 0.5d0)*Log(tmp) - tmp ser = 1.000000000190015d0 DO j=1,6 y = y + 1.0d0 ser = ser + cof(j)/y END DO gamma_sp = Exp(tmp + log(stp*ser/x)) RETURN END FUNCTION GAMMA_SP DOUBLE PRECISION FUNCTION GAMMA_DPR(x) implicit none real :: x double precision :: xx xx = x gamma_dpr = gamma_dp(xx) return end FUNCTION GAMMA_DPR real function GAMXINF(A1,X1) implicit none real :: a1,x1 double precision :: xam,dlog,s,r,ga,t0,a,x integer :: k double precision :: gin, gim a = a1 x = x1 IF ( x1 <= 0.0 ) THEN gamxinf = GAMMA_SP(A1) return ENDIF XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 GIM = GAMMA_SP(A1) ELSE IF (X.LE.1.0+A) THEN S=1.0D0/A R=S DO 10 K=1,60 R=R*X/(A+K) S=S+R IF (DABS(R/S).LT.1.0D-15) GO TO 15 10 CONTINUE 15 GIN=DEXP(XAM)*S ga = GAMMA_SP(A1) GIM=GA-GIN ELSE IF (X.GT.1.0+A) THEN T0=0.0D0 DO 20 K=60,1,-1 T0=(K-A)/(1.0D0+K/(X+T0)) 20 CONTINUE GIM=DEXP(XAM)/(X+T0) ENDIF gamxinf = GIM return END function GAMXINF double precision function GAMXINFDP(A1,X1) implicit none real :: a1,x1 double precision :: xam,dlog,s,r,ga,t0,a,x integer :: k double precision :: gin, gim a = a1 x = x1 IF ( x1 <= 0.0 ) THEN gamxinfdp = GAMMA_DP(A) return ENDIF XAM=-X+A*DLOG(X) IF (XAM.GT.700.0.OR.A.GT.170.0) THEN WRITE(*,*)'a and/or x too large' STOP ENDIF IF (X.EQ.0.0) THEN GIN=0.0 GIM = GAMMA_dp(A) ELSE IF (X.LE.1.0+A) THEN S=1.0D0/A R=S DO 10 K=1,60 R=R*X/(A+K) S=S+R IF (DABS(R/S).LT.1.0D-15) GO TO 15 10 CONTINUE 15 GIN=DEXP(XAM)*S ga = GAMMA_DP(A) GIM=GA-GIN ELSE IF (X.GT.1.0+A) THEN T0=0.0D0 DO 20 K=60,1,-1 T0=(K-A)/(1.0D0+K/(X+T0)) 20 CONTINUE GIM=DEXP(XAM)/(X+T0) ENDIF gamxinfdp = GIM return END function GAMXINFDP real function gaminterp(ratio, alp, luindex, ilh) implicit none real, intent(in) :: ratio, alp integer, intent(in) :: ilh integer, intent(in) :: luindex real :: delx, dely, tmp1, tmp2, temp3 integer :: i,j,ip1,jp1 i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) delx = Min(maxratiolu,ratio) - float(i)*dqiacrratio dely = alp - float(j)*dqiacralpha ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) tmp1 = gamxinflu(i,j,luindex,ilh) + delx*dqiacrratioinv* & & (gamxinflu(ip1,j,luindex,ilh) - gamxinflu(i,j,luindex,ilh)) tmp2 = gamxinflu(i,jp1,luindex,ilh) + delx*dqiacrratioinv* & & (gamxinflu(ip1,jp1,luindex,ilh) - gamxinflu(i,jp1,luindex,ilh)) gaminterp = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1)) END FUNCTION gaminterp real FUNCTION GAML02(x) implicit none integer ig, i, ii, n, np real x integer ng parameter(ng=12) real gamxg(ng), xg(ng) DATA xg/0.01,0.02,0.025,0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 7.391019203578037e-8,0.02212726874591478,0.06959352407989682, & & 0.2355654024970809,0.46135930387500346,0.545435791452399, & & 0.7371571313308203, & & 0.8265676632204345,0.8640182781845841,0.8855756211304151, & & 0.9245079225301251, & & 0.9712578342732681/ IF ( x .ge. xg(ng) ) THEN gaml02 = xg(ng) RETURN ENDIF IF ( x .lt. xg(1) ) THEN gaml02 = 0.0 RETURN ENDIF DO ii = 1,ng-1 i = ng - ii n = i np = n + 1 IF ( x .ge. xg(i) ) THEN gaml02 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO RETURN END FUNCTION GAML02 real FUNCTION GAML02d300(x) implicit none integer ig, i, ii, n, np real x integer ng parameter(ng=9) real gamxg(ng), xg(ng) DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 0.0, & & 7.391019203578011e-8,0.0002260640810600053, & & 0.16567071824457152, & & 0.4231369044918005,0.5454357914523988, & & 0.6170290936864555, & & 0.7471346054110058,0.9037156157718299 / IF ( x .ge. xg(ng) ) THEN GAML02d300 = xg(ng) RETURN ENDIF IF ( x .lt. xg(1) ) THEN GAML02d300 = 0.0 RETURN ENDIF DO ii = 1,ng-1 i = ng - ii n = i np = n + 1 IF ( x .ge. xg(i) ) THEN GAML02d300 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO RETURN END FUNCTION GAML02d300 real FUNCTION GAML02d500(x) implicit none integer ig, i, ii, n, np real x integer ng parameter(ng=9) real gamxg(ng), xg(ng) DATA xg/0.04,0.075,0.1,0.25,0.5,0.75,1.,2.,10./ DATA gamxg/ & & 0.0,0.0, & & 2.2346039e-13, 0.0221272687459, & & 0.23556540, 0.38710348, & & 0.48136183,0.6565833, & & 0.86918315 / IF ( x .ge. xg(ng) ) THEN GAML02d500 = xg(ng) RETURN ENDIF IF ( x .lt. xg(1) ) THEN GAML02d500 = 0.0 RETURN ENDIF DO ii = 1,ng-1 i = ng - ii n = i np = n + 1 IF ( x .ge. xg(i) ) THEN GAML02d500 = gamxg(N)+((X-XG(N))/(XG(NP)-XG(N)))* & & ( gamxg(NP) - gamxg(N) ) RETURN ENDIF ENDDO RETURN END FUNCTION GAML02d500 real function BETA(P,Q) implicit none double precision p1,gp,q1,gq, ppq,gpq real p,q p1 = p q1 = q CALL GAMMADP(P1,GP) CALL GAMMADP(Q1,GQ) PPQ=P1+Q1 CALL GAMMADP(PPQ,GPQ) beta=GP*GQ/GPQ RETURN END function BETA DOUBLE PRECISION FUNCTION GAMMA_DP(xx) implicit none double precision :: xx integer j double precision ser,stp,tmp,x,y,cof(6) SAVE cof,stp DATA cof /76.18009172947146d+0, & & -86.50532032941677d0, & & 24.01409824083091d0, & & -1.231739572450155d0, & & 0.1208650973866179d-2,& & -0.5395239384953d-5/ DATA stp/2.5066282746310005d0/ x = xx y = x tmp = x + 5.5d0 tmp = (x + 0.5d0)*Log(tmp) - tmp ser = 1.000000000190015d0 DO j=1,6 y = y + 1.0d0 ser = ser + cof(j)/y END DO gamma_dp = Exp(tmp + log(stp*ser/x)) RETURN END function gamma_dp SUBROUTINE GAMMADP(X,GA) implicit none double precision, parameter :: PI=3.141592653589793D0 double precision :: x,ga,z,r,gr integer :: k,m1,m double precision :: G(26) DATA G/1.0D0,0.5772156649015329D0, & & -0.6558780715202538D0, -0.420026350340952D-1, & & 0.1665386113822915D0,-.421977345555443D-1, & & -.96219715278770D-2, .72189432466630D-2, & & -.11651675918591D-2, -.2152416741149D-3, & & .1280502823882D-3, -.201348547807D-4, & & -.12504934821D-5, .11330272320D-5, & & -.2056338417D-6, .61160950D-8, & & .50020075D-8, -.11812746D-8, & & .1043427D-9, .77823D-11, & & -.36968D-11, .51D-12, & & -.206D-13, -.54D-14, .14D-14, .1D-15/ IF (X.EQ.INT(X)) THEN IF (X.GT.0.0D0) THEN GA=1.0D0 M1=X-1 DO K=2,M1 GA=GA*K ENDDO ELSE GA=1.0D+300 ENDIF ELSE IF (DABS(X).GT.1.0D0) THEN Z=DABS(X) M=INT(Z) R=1.0D0 DO K=1,M R=R*(Z-K) ENDDO Z=Z-M ELSE Z=X ENDIF GR=G(26) DO K=25,1,-1 GR=GR*Z+G(K) ENDDO GA=1.0D0/(GR*Z) IF (DABS(X).GT.1.0D0) THEN GA=GA*R IF (X.LT.0.0D0) GA=-PI/(X*GA*DSIN(PI*X)) ENDIF ENDIF RETURN END SUBROUTINE GAMMADP Function delbk(bb,nu,mu,k) implicit none real delbk real nu, mu, bb integer k real tmp, del real x1, x2, x3, x4 integer i tmp = ((1.0 + nu)/mu) i = Int(dgami*(tmp)) del = tmp - dgam*i x1 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((2.0 + nu)/mu) i = Int(dgami*(tmp)) del = tmp - dgam*i x2 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((1.0 + 2.0*bb + k + nu)/mu) i = Int(dgami*(tmp)) del = tmp - dgam*i x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami delbk = & & ((x1/x2)**(2.0*bb + k)* & & x3)/x1 RETURN END Function delbk Function delabk(ba,bb,nua,nub,mua,mub,k) implicit none real delabk real nua, mua, ba integer k real nub, mub, bb integer i real tmp,del real g1pnua, g2pnua, g1pbapnua, g1pbbpk, g1pnub, g2pnub tmp = (1. + nua)/mua i = Int(dgami*(tmp)) del = tmp - dgam*i IF ( i+1 > ngm0 ) THEN write(0,*) 'delabk: i+1 > ngm0!!!!',i,ngm0,nua,mua,tmp STOP ENDIF g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((2. + nua)/mua) i = Int(dgami*(tmp)) del = tmp - dgam*i g2pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((1. + ba + nua)/mua) i = Int(dgami*(tmp)) del = tmp - dgam*i g1pbapnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((1. + nub)/mub) i = Int(dgami*(tmp)) del = tmp - dgam*i g1pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((2 + nub)/mub) i = Int(dgami*(tmp)) del = tmp - dgam*i g2pnub = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = ((1. + bb + k + nub)/mub) i = Int(dgami*(tmp)) del = tmp - dgam*i g1pbbpk = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami delabk = & & (2.*(g1pnua/g2pnua)**ba* & & g1pbapnua* & & (g1pnub/g2pnub)**(bb + k)* & & g1pbbpk)/ & & (g1pnua*g1pnub) RETURN END Function delabk subroutine cld_cpu(string) implicit none character( LEN = * ) string return end subroutine cld_cpu subroutine hailmaxd(dtp,nx,ny,nz,an,na,nor,norz,alpha2d,dn, & & hailmax1d,hailmaxk1,jslab ) implicit none integer nx,ny,nz,nor,norz,ngt,jgs,na,ia integer id 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 dtp real alpha2d(-nor+1:nx+nor,1,-norz+1:nz+norz,3) real :: hailmax1d(nx,ny),hailmaxk1(nx,ny) integer infdo integer jslab 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 DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.0005d0 real :: cwchtmp,cwchltmp, maxdia integer :: ixb, jyb, kzb integer :: ixe, jye, kze integer :: plo, phi integer :: ialp, i, j logical :: debug_mpi = .false. 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 ixe = nx jy = jslab jgs = jy if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' 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 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 tmp = thresh_conc*g1palp/an(ix,jy,kz,lnh) alp = alpha2d(ix,1,kz,2) j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) ratio = 0.0 maxdia = 0.0 DO i = 0,nqiacrratio-1 IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN 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 ENDIF IF ( kz == kzb ) THEN hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) ENDIF hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) ENDIF ENDDO ENDDO ENDIF 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 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 tmp = thresh_conc*g1palp/an(ix,jy,kz,lnhl) alp = alpha2d(ix,1,kz,3) j = Int(Max(0.0,Min(maxalphalu,alp))*dqiacralphainv) ratio = 0.0 maxdia = 0.0 DO i = 0,nqiacrratio-1 IF ( gamxinflu(i,j,1,1) >= tmp .and. tmp >= gamxinflu(i+1,j,1,1) ) THEN 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 ENDIF IF ( kz == kzb ) THEN hailmaxk1(ix,jy) = Max( maxdia, hailmaxk1(ix,jy) ) ENDIF hailmax1d(ix,jy) = Max(maxdia, hailmax1d(ix,jy) ) ENDIF ENDDO ENDDO ENDIF END SUBROUTINE HAILMAXD 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) implicit none integer nx,ny,nz,nor,norz,ngt,jgs,na,ia integer id integer :: its,jts 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 dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real dz3dinv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real dtp real xfall(nx,ny,na) integer infdo integer jslab integer ix,jy,kz,ndfall,n,k,il,in real tmp, vtmax, dtptmp, dtfrac real, parameter :: dz = 200. real, allocatable :: db1(:,:), dtz1(:,:,:),dz2dinv(:,:),db1inv(:,:) 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 :: ngs integer :: ngscnt,mgs,ipconc0 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 integer :: ixb, jyb, kzb integer :: ixe, jye, kze integer :: plo, phi 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 ixb = 1 ixe = nx jy = 1 jgs = jy xvt(:,:,:,:) = 0.0 if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a' DO kz = kzb,kze DO ix = ixb,ixe db1(ix,kz) = dn(ix,jy,kz) db1inv(ix,kz) = 1./dn(ix,jy,kz) rhovtzx(kz,ix) = Sqrt(rho00*Min(1.0/0.05, db1inv(ix,kz))) ENDDO ENDDO DO kz = kzb,kze DO ix = ixb,ixe dtz1(kz,ix,0) = dz3dinv(ix,jy,kz) dtz1(kz,ix,1) = dz3dinv(ix,jy,kz)*db1inv(ix,kz) dz2dinv(kz,ix) = dz3dinv(ix,jy,kz) ENDDO ENDDO IF ( lzh .gt. 1 ) THEN DO kz = kzb,kze DO ix = ixb,ixe an(ix,jy,kz,lzh) = Max( 0., an(ix,jy,kz,lzh) ) ENDDO ENDDO ENDIF DO il = lc+1,lhab DO ix = ixb,ixe ENDDO ENDDO if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2' DO ix = ixb,ixe dummy = 0.d0 call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & & cwradn, & & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & & infdo,0 & & ) DO il = lc,lhab IF ( ido(il) == 0 ) CYCLE vtmax = 0.0 do kz = kzb,kze xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix)) ENDDO IF ( vtmax == 0.0 ) CYCLE IF ( dtp*vtmax .lt. 0.7 ) THEN ndfall = 1 ELSE IF ( dtp > 20.0 ) THEN ndfall = Max(2, Int(dtp*vtmax/0.7) + 1) ELSE ndfall = 1+Int(dtp*vtmax + 0.301) ENDIF ENDIF IF ( ndfall .gt. 1 ) THEN dtptmp = dtp/Real(ndfall) ELSE dtptmp = dtp ENDIF dtfrac = dtptmp/dtp DO n = 1,ndfall IF ( do_accurate_sedimentation .and. n .ge. 2 .and. ( n == interval_sedi_vt*(n/interval_sedi_vt) ) ) THEN dummy = 0.d0 xvt(kzb:kze,ix,1:3,il) = 0.0 call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & & xvt, rhovtzx, & & an,dn,ipconc,t0,t7,cwmasn,cwmasx, & & cwradn, & & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & & infdo,il) DO kz = kzb,kze xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) ENDDO ENDIF IF ( il >= lr .and. ( linfall(il) .eq. 3 .or. linfall(il) .eq. 4 ) .and. ln(il) > 0 ) 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 if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b' call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & an,db1,il,1,xfall,dtz1,ix) if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c' IF ( ldovol .and. il >= li ) THEN IF ( lvol(il) .gt. 1 ) THEN call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & an,db1,lvol(il),0,xfall,dtz1,ix) ENDIF ENDIF 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' IF ( ipconc .gt. 0 ) THEN IF ( ipconc .ge. ipc(il) ) THEN IF ( ( linfall(il) .ge. 2 ) .and. lz(il) .lt. 1) THEN IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN DO kz = kzb,kze tmpn2(ix,jy,kz) = z(ix,kz,il) ENDDO DO kz = kzb,kze tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) ENDDO ELSE DO kz = kzb,kze tmpn(ix,jy,kz) = an(ix,jy,kz,ln(il)) ENDDO ENDIF ENDIF if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f' in = 2 IF ( linfall(il) .eq. 1 ) in = 1 call fallout1d(nx,ny,nz,nor,na,dtptmp,dtfrac,jgs,xvt(1,1,in,il), & & an,db1,ln(il),0,xfall,dtz1,ix) IF ( lz(il) .lt. 1 ) THEN IF ( linfall(il) >= 2 ) THEN xfall0(:,jgs) = 0.0 IF ( ( infall .eq. 3 .or. infall .eq. 4 ) .and. & & ( 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), & & tmpn,db1,1,0,xfall0,dtz1,ix) ELSE call fallout1d(nx,ny,nz,nor,1,dtptmp,dtfrac,jgs,xvt(1,1,1,il), & & tmpn,db1,1,0,xfall0,dtz1,ix) ENDIF IF ( linfall(il) == 3 .or. linfall(il) == 4 ) THEN 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), xdn0(il), infall, ix) ELSEIF ( linfall(il) .eq. 5 .and. il .ge. lh .or. ( il == lr .and. irfall == 5 ) ) THEN DO kz = kzb,kze an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), 0.5* ( an(ix,jgs,kz,ln(il)) + tmpn(ix,jy,kz) )) ENDDO ELSEIF ( .not. (il .eq. lr .and. irfall .eq. 0) .and. .not. (il .eq. ls .and. isfall .eq. 0) ) THEN DO kz = kzb,kze an(ix,jgs,kz,ln(il)) = Max( an(ix,jgs,kz,ln(il)), tmpn(ix,jy,kz) ) ENDDO ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO 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 subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt, & & a,db1,ia,id,xfall,dtz1,ixcol) implicit none integer nx,ny,nz,nor,ngt,jgs,na,ia integer id integer ng1 parameter(ng1 = 1) integer :: ixcol real a(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real vt(nz+1,nx) real dtp,dtfrac real cmax real xfall(nx,ny,na) real db1(nx,nz+1),dtz1(nz+1,nx,0:1) integer ix,jy,kz,n,k integer iv1,iv2 real tmp integer imn,imx,kmn,kmx real qtmp1(nz+1) integer :: ixb, jyb, kzb integer :: ixe, jye, kze jy = 1 iv1 = 0 iv2 = 0 imn = nx imx = 1 kmn = nz kmx = 1 cmax = 0.0 kzb = 1 kze = nz ixb = ixcol ixe = ixcol ix = ixcol qtmp1(nz+1) = 0.0 DO kz = kzb,kze IF ( id == 1 ) THEN qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix)*db1(ix,kz) ELSE qtmp1(kz) = a(ix,jgs,kz,ia)*vt(kz,ix) ENDIF IF ( a(ix,jgs,kz,ia) .ne. 0.0 ) THEN kmn = Min(kz,kmn) kmx = Max(kz,kmx) ENDIF ENDDO kmn = Max(1,kmn-1) IF ( kmn == 1 ) THEN kz = 1 xfall(ix,jy,ia) = xfall(ix,jy,ia) + a(ix,jgs,kz,ia)*vt(kz,ix)*dtfrac ENDIF do kz = 1,nz a(ix,jgs,kz,ia) = a(ix,jgs,kz,ia) + dtp*dtz1(kz,ix,id)*(qtmp1(kz+1) - qtmp1(kz) ) enddo RETURN END SUBROUTINE FALLOUT1D subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) implicit none integer nx,ny,nz,nor,na,ngt,jgs integer :: ixcol integer, parameter :: norz = 3 real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) real db(nx,nz+1) integer ixe,kze real alpha real qmin real xvmn,xvmx integer ipconc integer l integer ln integer lvol real rho_qx integer ix,jy,kz 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 ) & .or. ( l .eq. ls .and. imusnow == 1 ) ) THEN DO kz = 1,kze IF ( a(ix,jy,kz,l) .gt. qmin .and. a(ix,jy,kz,ln) .gt. 1.e-15 ) THEN IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) xdn = Min( 900., Max( hdnmn, xdn ) ) ELSE xdn = rho_qx ENDIF ELSE xdn = rho_qx ENDIF IF ( l == lr ) xdn = 1000. qr = a(ix,jy,kz,l) xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) chw = a(ix,jy,kz,ln) IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN xv = Min( xvmx, Max( xvmn,xv ) ) chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) ENDIF g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw z(ix,kz,l) = zx*(6./(pi*1000.))**2 ELSE z(ix,kz,l) = 0.0 ENDIF ENDDO ELSEIF ( (l == ls .and. imusnow == 3) .or. ( l .eq. lr .and. imurain == 3 ) ) THEN xdn = rho_qx 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.6*(ynu+2.0)*a(ix,jy,kz,ln)*vr**2/(ynu+1.0) ELSE z(ix,kz,l) = 0.0 ENDIF ENDDO ENDIF RETURN END subroutine calczgr1d subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & & lvol, rho_qx, infall, ixcol) implicit none integer nx,ny,nz,nor,na,ngt,jgs,ixcol real a(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,na) real t0(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) real t1(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor) real z0(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab) real db(nx,nz+1) integer ixe,kze real alpha real qmin real xvmn,xvmx integer ipconc integer l integer ln integer lvol real rho_qx integer infall integer ix,jy,kz double precision vr,qr,nrx,rd,g1,zx,chw,z,znew,zt,zxt real xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz ndbz = 0 nmwgt = 0 nnwgt = 0 nwlessthanz = 0 jy = jgs ix = ixcol IF ( l .eq. lh .or. l .eq. lhl .or. ( l == lr .and. imurain == 1 ) ) THEN g1 = (6.0 + alpha)*(5.0 + alpha)*(4.0 + alpha)/ & & ((3.0 + alpha)*(2.0 + alpha)*(1.0 + alpha)) DO kz = 1,kze IF ( t0(ix,jy,kz) .gt. 0. ) THEN IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) xdn = Min( 900., Max( hdnmn, xdn ) ) ELSE xdn = rho_qx ENDIF ELSE xdn = rho_qx ENDIF IF ( l == lr ) xdn = 1000. qr = a(ix,jy,kz,l) xv = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) chw = a(ix,jy,kz,ln) IF ( xv .lt. xvmn .or. xv .gt. xvmx ) THEN xv = Min( xvmx, Max( xvmn,xv ) ) chw = db(ix,kz)*a(ix,jy,kz,l)/(xv*xdn) ENDIF zx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw z = zx*(6./(pi*1000.))**2 IF ( (z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & & t0(ix,jy,kz) .gt. z0(ix,kz,l) )) THEN zx = t0(ix,jy,kz)/((6./(pi*1000.))**2) nrx = g1*db(ix,kz)**2*( a(ix,jy,kz,l))*a(ix,jy,kz,l)/zx IF ( infall .eq. 3 ) THEN IF ( nrx .gt. a(ix,jy,kz,ln) ) THEN ndbz = ndbz + 1 IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 ELSE nnwgt = nnwgt + 1 ENDIF a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) ELSE IF ( nrx .gt. a(ix,jy,kz,ln) .and. t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN IF ( nrx .lt. t1(ix,jy,kz) ) THEN ndbz = ndbz + 1 ELSE nmwgt = nmwgt + 1 IF ( t1(ix,jy,kz) .lt. ndbz ) nwlessthanz = nwlessthanz + 1 ENDIF ELSE nnwgt = nnwgt + 1 ENDIF a(ix,jy,kz,ln) = Max(Min( real(nrx), t1(ix,jy,kz) ), a(ix,jy,kz,ln) ) ENDIF ELSE IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN nmwgt = nmwgt + 1 ELSE nnwgt = nnwgt + 1 ENDIF ENDIF a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) nrx = a(ix,jy,kz,ln) ENDIF ELSE IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN nmwgt = nmwgt + 1 ELSE nnwgt = nnwgt + 1 ENDIF ENDIF ENDIF ENDDO ELSEIF ( l .eq. lr .and. imurain == 3) THEN xdn = 1000. DO kz = 1,kze IF ( t0(ix,jy,kz) .gt. 0. ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn*a(ix,jy,kz,ln)) z = 3.6*(rnu+2.0)*a(ix,jy,kz,ln)*vr**2/(rnu+1.0) IF ( z .gt. t0(ix,jy,kz) .and. z .gt. 0.0 .and. & & t0(ix,jy,kz) .gt. 0.0 & & .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn) chw = a(ix,jy,kz,ln) nrx = 3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz)) IF ( infall .eq. 3 ) THEN a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) ) ELSEIF ( infall .eq. 4 ) THEN a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) ) ENDIF ELSE a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) ENDIF ELSE a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) ) ENDIF ENDDO ENDIF RETURN END subroutine calcnfromz1d subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn, & & qcw,qci,qsw,qrw,qhw,qhl, & & ccw,cci,csw,crw,chw,chl, & & cccn,cccna, vhw,vhl,qv,spechum, invertccn_flag, cwmasin ) implicit none integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(nx,nz+1) real, optional, dimension(nx,nz), intent(inout) :: qcw,qci,qsw,qrw,qhw,qhl, & ccw,cci,csw,crw,chw,chl, & cccn,cccna,vhw,vhl,qv, spechum logical, optional, intent(in) :: invertccn_flag real, optional :: cwmasin integer ixe,kze real alpha real qmin real xvmn,xvmx integer ipconc integer lvol integer infall integer ix,jy,kz double precision vr,q,nrx,nrx2,rd,g1h,g1hl,g1r,g1s,zx,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e8, xn0r = 8.0e6, xn0h = 2.0e5, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) real, parameter :: zrfac = 1./(pi*xdnr*xn0r) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 real, parameter :: xgms=xdnh*0.523599*(300.e-6)**3 real, parameter :: cwmas09 = 1000.*0.523599*(2.*9.e-6)**3 real xv,xdn,cwmasinv integer :: ndbz, nmwgt, nnwgt, nwlessthanz double precision :: mixconv, mixconvqv, qsmax,qsmax2,qsmax3,qsmax4 logical :: invertccn_local IF ( present( invertccn_flag ) ) THEN invertccn_local = invertccn_flag ELSE invertccn_local = .false. ENDIF IF ( present( cwmasin ) ) THEN cwmasinv = 1.0/cwmasin ELSE cwmasinv = 1.0/cwmas09 ENDIF jy = 1 g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) IF ( imurain == 3 ) THEN g1r = (rnu+2.0)/(rnu+1.0) ELSE g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) ENDIF g1s = (snu+2.0)/(snu+1.0) qsmax = 0 qsmax2 = 0 qsmax3 = 0 qsmax4 = 0 DO kz = 1,nz DO ix = 1,nx mixconv = 1 IF ( present( spechum ) ) THEN an(ix,jy,kz,lv) = spechum(ix,kz)/(1.0d0 - spechum(ix,kz)) mixconv = 1.0d0/(1.0d0 - spechum(ix,kz)) ELSE mixconv = 1.0d0 ENDIF IF ( present( qv ) ) an(ix,jy,kz,lv) = qv(ix,kz) IF ( present( qcw ) ) an(ix,jy,kz,lc) = qcw(ix,kz)*mixconv IF ( present( qrw ) ) an(ix,jy,kz,lr) = qrw(ix,kz)*mixconv IF ( present( qci ) ) an(ix,jy,kz,li) = qci(ix,kz)*mixconv IF ( present( qsw ) ) THEN an(ix,jy,kz,ls) = qsw(ix,kz)*mixconv ENDIF IF ( present( qhw ) ) an(ix,jy,kz,lh) = qhw(ix,kz)*mixconv IF ( lhl > 1 .and. present( qhl ) ) an(ix,jy,kz,lhl) = qhl(ix,kz)*mixconv IF ( present( ccw ) ) an(ix,jy,kz,lnc) = ccw(ix,kz)*mixconv*dn(ix,kz) IF ( present( crw ) ) an(ix,jy,kz,lnr) = crw(ix,kz)*mixconv*dn(ix,kz) IF ( present( cci ) ) an(ix,jy,kz,lni) = cci(ix,kz)*mixconv*dn(ix,kz) IF ( present( csw ) ) an(ix,jy,kz,lns) = csw(ix,kz)*mixconv*dn(ix,kz) IF ( present( chw ) ) an(ix,jy,kz,lnh) = chw(ix,kz)*mixconv*dn(ix,kz) IF ( lhl > 1 .and. present( chl ) ) an(ix,jy,kz,lnhl) = chl(ix,kz)*mixconv*dn(ix,kz) IF ( lvh > 1 .and. present( vhw ) ) an(ix,jy,kz,lvh) = vhw(ix,kz)*mixconv IF ( lvhl > 1 .and. present( vhl ) ) an(ix,jy,kz,lvhl) = vhl(ix,kz)*mixconv IF ( lccn > 1 .and. present( cccn ) ) an(ix,jy,kz,lccn) = cccn(ix,kz)*mixconv*dn(ix,kz) IF ( lccna > 1 .and. present( cccna ) ) an(ix,jy,kz,lccna) = cccna(ix,kz)*mixconv dninv = 1./dn(ix,kz) IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) > qxmin_init(lc) ) THEN an(ix,jy,kz,lnc) = Min(qccn, an(ix,jy,kz,lc)*cwmasinv )*dn(ix,kz) IF ( invertccn_local ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + an(ix,jy,kz,lnc) ELSE IF ( lccn > 1 .and. lccna < 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) - an(ix,jy,kz,lnc) ENDIF IF ( lccna > 1 ) THEN an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna) + an(ix,jy,kz,lnc) ENDIF ENDIF ELSEIF ( an(ix,jy,kz,lc) <= qxmin(lc) .or. & ( an(ix,jy,kz,lnc) <= cxmin .and. an(ix,jy,kz,lc) <= qxmin_init(lc)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) an(ix,jy,kz,lnc) = 0.0 an(ix,jy,kz,lc) = 0.0 ENDIF ENDIF IF ( lni > 1 ) THEN IF ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) > qxmin_init(li) ) THEN an(ix,jy,kz,lni) = dn(ix,kz)*an(ix,jy,kz,li)/xims ELSEIF ( an(ix,jy,kz,li) <= qxmin(li) .or. & ( an(ix,jy,kz,lni) <= cxmin .and. an(ix,jy,kz,li) <= qxmin_init(li)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) an(ix,jy,kz,lni) = 0.0 an(ix,jy,kz,li) = 0.0 ENDIF ENDIF IF ( lnr > 1 ) THEN IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin_init(lr) ) THEN q = an(ix,jy,kz,lr) laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) n1 = laminv1*xn0r nrx = n1*g1r/g0 an(ix,jy,kz,lnr) = nrx ELSEIF ( an(ix,jy,kz,lr) <= qxmin(lr) .or. & ( an(ix,jy,kz,lnr) <= cxmin .and. an(ix,jy,kz,lr) <= qxmin_init(lr)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lnr) = 0.0 an(ix,jy,kz,lr) = 0.0 ENDIF ENDIF IF ( lzr > 1 ) THEN 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) ENDIF ENDIF IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin_init(ls) ) THEN q = an(ix,jy,kz,ls) laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) n1 = laminv1*xn0s nrx = n1*g1s/g0 an(ix,jy,kz,lns) = nrx ELSEIF ( an(ix,jy,kz,ls) <= qxmin(ls) .or. & ( an(ix,jy,kz,lns) <= cxmin .and. an(ix,jy,kz,ls) <= qxmin_init(ls)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,lns) = 0.0 an(ix,jy,kz,ls) = 0.0 ENDIF ENDIF IF ( lnh > 1 ) THEN IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin_init(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh ENDIF ENDIF q = an(ix,jy,kz,lh) laminv1 = (dn(ix,kz) * q * zhfac)**(0.25) n1 = laminv1*xn0h nrx = n1*g1h/g0 nrx2 = dn(ix,kz) * q / xgms nrx = Min( nrx, nrx2 ) IF ( nrx > cxmin ) THEN an(ix,jy,kz,lnh) = nrx ELSE an(ix,jy,kz,lh) = 0.0 an(ix,jy,kz,lnh) = 0.0 an(ix,jy,kz,lvh) = 0.0 ENDIF ELSEIF ( an(ix,jy,kz,lh) <= qxmin(lh) .or. & ( an(ix,jy,kz,lnh) <= cxmin .and. an(ix,jy,kz,lh) <= qxmin_init(lh)) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 ENDIF ENDIF IF ( lzh > 1 ) THEN 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) ENDIF ENDIF IF ( lnhl > 1 .and. lhl > 1 ) THEN IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin_init(lhl) ) THEN IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl ENDIF ENDIF q = an(ix,jy,kz,lhl) laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) n1 = laminv1*xn0hl nrx = n1*g1hl/g0 an(ix,jy,kz,lnhl) = nrx 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 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 ENDIF ENDIF IF ( lzhl > 1 ) THEN 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) ENDIF ENDIF mixconvqv = 1 IF ( present( spechum ) ) THEN mixconvqv = 1.0d0/(1.0d0 + an(ix,jy,kz,lv)) spechum(ix,kz) = an(ix,jy,kz,lv)*mixconvqv ELSE mixconvqv = 1.0d0 ENDIF IF ( present( qv ) ) qv(ix,kz) = an(ix,jy,kz,lv) IF ( present( qcw ) ) qcw(ix,kz) = an(ix,jy,kz,lc)*mixconvqv IF ( present( qrw ) ) qrw(ix,kz) = an(ix,jy,kz,lr)*mixconvqv IF ( present( qci ) ) qci(ix,kz) = an(ix,jy,kz,li)*mixconvqv IF ( present( qsw ) ) THEN qsw(ix,kz) = an(ix,jy,kz,ls)*mixconvqv ENDIF IF ( present( qhw ) ) qhw(ix,kz) = an(ix,jy,kz,lh)*mixconvqv IF ( lhl > 1 .and. present( qhl ) ) qhl(ix,kz) = an(ix,jy,kz,lhl)*mixconvqv IF ( present( ccw ) ) ccw(ix,kz) = an(ix,jy,kz,lnc)*mixconvqv*dninv IF ( present( crw ) ) crw(ix,kz) = an(ix,jy,kz,lnr)*mixconvqv*dninv IF ( present( cci ) ) cci(ix,kz) = an(ix,jy,kz,lni)*mixconvqv*dninv IF ( present( csw ) ) csw(ix,kz) = an(ix,jy,kz,lns)*mixconvqv*dninv IF ( present( chw ) ) chw(ix,kz) = an(ix,jy,kz,lnh)*mixconvqv*dninv IF ( lhl > 1 .and. present( chl ) ) chl(ix,kz) = an(ix,jy,kz,lnhl)*mixconvqv*dninv IF ( lvh > 1 .and. present( vhw ) ) vhw(ix,kz) = an(ix,jy,kz,lvh)*mixconvqv IF ( lvhl > 1 .and. present( vhl ) ) vhl(ix,kz) = an(ix,jy,kz,lvhl)*mixconvqv IF ( lccn > 1 .and. present( cccn ) ) cccn(ix,kz) = an(ix,jy,kz,lccn)*mixconvqv*dninv IF ( lccna > 1 .and. present( cccna ) ) cccna(ix,kz) = an(ix,jy,kz,lccna)*mixconvqv ENDDO ENDDO RETURN END subroutine calcnfromq subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn) implicit none integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(nx,nz+1) integer ixe,kze real alpha real qmin real xvmn,xvmx integer ipconc integer lvol integer infall integer ix,jy,kz double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) real, parameter :: zrfac = 1./(pi*xdnr*xn0r) real, parameter :: zsfac = 1./(pi*xdns*xn0s) real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0)) real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3 real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3 real :: xmass,xv,xdn integer :: ndbz, nmwgt, nnwgt, nwlessthanz jy = 1 g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) IF ( imurain == 3 ) THEN g1r = (rnu+2.0)/(rnu+1.0) ELSE g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) ENDIF g1s = (snu+2.0)/(snu+1.0) DO kz = 1,nz DO ix = 1,nx dninv = 1./dn(ix,kz) IF ( lnc > 1 ) THEN IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms ENDIF ENDIF IF ( lni > 1 ) THEN IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims ENDIF ENDIF IF ( lnr > 1 ) THEN IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN q = an(ix,jy,kz,lr) laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) n1 = laminv1*xn0r nrx = n1*g1r/g0 anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ELSE xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr) anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass ENDIF IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = 36.*g1r*dn(ix,kz)**2*q**2/(pi**2*xdnr**2*nrx) ENDIF ENDIF ENDIF IF ( lns > 1 ) THEN IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN q = an(ix,jy,kz,ls) laminv1 = (dn(ix,kz) * q * zsfac)**(0.25) n1 = laminv1*xn0s nrx = n1*g1s/g0 anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ELSE xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns) anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass ENDIF ENDIF ENDIF ENDDO ENDDO RETURN END subroutine calcnfromcuten SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & & ,t1,t2,t3,t4,t5,t6, f_t4, f_t5,f_t6 & & ,qcw,qci,qsw,qrw & & ,ccw,cci,csw,crw & & ,an,dn ) implicit none integer, parameter :: ng1 = 1 integer :: nx,ny,nz,na integer :: ng integer :: nor,norz, jyslab real :: dtp real,optional :: t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) 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_t4, f_t5, f_t6 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) real, optional, dimension(nx,nz) :: qcw,qci,qsw,qrw,ccw,cci,csw,crw real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs parameter (ngs=1) integer ngscnt,igs(ngs),kgs(ngs) real rho0(ngs) integer ix,kz,i,n, kp1 integer :: jy, jgs integer ixb,ixe,jyb,jye,kzb,kze integer itile,jtile,ktile integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg real :: qx(ngs,lv:lhab) real :: cx(ngs,lc:lhab) real :: xv(ngs,lc:lhab) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: alpha(ngs,lc:lhab) real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s real :: lam_c, lam_i, lam_s, lam_r, lam_h, lam_hl real :: gamr1,gamr2,gamh1,gamh2,factor_r,factor_h,factor_hl integer :: il real :: hwdn,hldn double precision :: numh, numhl,denomh,denomhl logical :: flag_t4, flag_t5, flag_t6 real, parameter :: qmin = 1.e-8 real, parameter :: volmin = 1.e-30 itile = nx jtile = ny ktile = nz ixend = nx jyend = ny kzend = nz nxend = nx + 1 nyend = ny + 1 nzend = nz kzbeg = 1 nzbeg = 1 flag_t4 = .false. flag_t5 = .false. flag_t6 = .false. IF ( present(f_t4) ) THEN IF ( present(f_t4) ) THEN flag_t4 = f_t4 ENDIF ENDIF IF ( present(f_t5) ) THEN IF ( present(f_t5) ) THEN flag_t5 = f_t5 ENDIF ENDIF IF ( present(f_t6) ) THEN IF ( present(f_t6) ) THEN flag_t6 = f_t6 ENDIF ENDIF jy = 1 pb(:) = 0.0 pinit(:) = 0.0 gamc1 = Gamma_sp(2. + cnu) gamc2 = 1. gami1 = Gamma_sp(2. + cinu) gami2 = 1. gams1 = Gamma_sp(2. + snu) gams2 = Gamma_sp(1. + snu) gamr1 = Gamma_sp(2. + rnu) gamr2 = Gamma_sp(1. + rnu) factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu) factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu) factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu) IF ( present(t4) ) THEN IF ( imurain == 3 ) THEN factor_r = (1. + rnu)*Gamma_sp(1. + rnu)/Gamma_sp(5./3. + rnu) ELSE factor_r = ((Pi*(alphar+3.)*(alphar+1.)*(alphar+1.))/6.)**(1./3.) ENDIF ENDIF factor_h = ((Pi*(alphah+3.)*(alphah+1.)*(alphah+1.))/6.)**(1./3.) factor_hl = ((Pi*(alphahl+3.)*(alphahl+1.)*(alphahl+1.))/6.)**(1./3.) jgs = jy mgs = 1 DO kz = 1,nz DO ix = 1,nx rho0(mgs) = dn(ix,jy,kz) IF ( present( an ) ) THEN DO il = lc,lhab qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) ENDDO ELSE qx(mgs,:) = 0.0 cx(mgs,:) = 0.0 IF ( present(qcw) ) qx(mgs,lc) = qcw(ix,kz) IF ( present(qci) ) qx(mgs,li) = qci(ix,kz) IF ( present(qsw) ) qx(mgs,ls) = qsw(ix,kz) IF ( present(qrw) ) qx(mgs,lr) = qrw(ix,kz) IF ( present(ccw) ) cx(mgs,lc) = ccw(ix,kz)*rho0(mgs) IF ( present(cci) ) cx(mgs,li) = cci(ix,kz)*rho0(mgs) IF ( present(csw) ) cx(mgs,ls) = csw(ix,kz)*rho0(mgs) IF ( present(crw) ) cx(mgs,lr) = crw(ix,kz)*rho0(mgs) ENDIF IF ( present( t1 ) .and. qx(mgs,lc) > qxmin(lc) .and. cx(mgs,lc) > cxmin ) THEN lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) t1(ix,jy,kz) = 0.5*factor_c/lam_c ENDIF IF ( present( t2 ) .and. qx(mgs,li) > qxmin(li) .and. cx(mgs,li) > cxmin ) THEN lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) t2(ix,jy,kz) = 0.5*factor_i/lam_i ENDIF IF ( present( t3 ) .and. qx(mgs,ls) > qxmin(ls) .and. cx(mgs,ls) > cxmin ) THEN lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) t3(ix,jy,kz) = 0.5*factor_s/lam_s ENDIF IF ( present( t4 ) .and.( ( present(qrw) .and. present(crw) ) .or. flag_t4 ) ) THEN IF ( qx(mgs,lr) > Max(qmin,qxmin(lr)) .and. cx(mgs,lr) > cxmin ) THEN IF ( imurain == 1 ) THEN lam_r = factor_r *((xdn0(lr)*cx(mgs,lr))/(qx(mgs,lr)*rho0(mgs)))**(1./3.) t4(ix,jy,kz) = 0.5*(alphar+3.)/lam_r ELSE lam_r = ((cx(mgs,lr)*(Pi/6.)*xdn0(lr)*Gamr1)/(qx(mgs,lr)*rho0(mgs)*Gamr2))**(1./3.) t4(ix,jy,kz) = 0.5*factor_r/lam_r ENDIF ENDIF ENDIF IF ( present(t5) .and. flag_t5 ) THEN IF ( lhl < 1 .or. flag_t6 ) THEN IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) ) THEN hwdn = xdn0(lh) IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h ENDIF ELSE IF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) < Max(qmin,qxmin(lhl)) ) THEN hwdn = xdn0(lh) IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphah+3.)/lam_h ELSEIF ( qx(mgs,lh) < Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t5(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl ELSEIF ( qx(mgs,lh) > Max(qmin,qxmin(lh)) .and. qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF hwdn = xdn0(lh) IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) > volmin ) THEN hwdn = rho0(mgs)*qx(mgs,lh)/an(ix,jy,kz,lvh) ENDIF ENDIF lam_h = factor_h *((hwdn*cx(mgs,lh))/(qx(mgs,lh)*rho0(mgs)))**(1./3.) lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) numh = cx(mgs,lh)*(alphah+3.)*(alphah+2.)*(alphah+1.)/lam_h**3 numhl = cx(mgs,lhl)*(alphahl+3.)*(alphahl+2.)*(alphahl+1.)/lam_hl**3 denomh = cx(mgs,lh)*(alphah+2.)*(alphah+1.)/lam_h**2 denomhl = cx(mgs,lhl)*(alphahl+2.)*(alphahl+1.)/lam_hl**2 t5(ix,jy,kz) = 0.5*(numh + numhl)/(denomh + denomhl) ENDIF ENDIF ENDIF IF ( present(t6) .and. flag_t6 .and. lhl > 1 ) THEN IF ( qx(mgs,lhl) > Max(qmin,qxmin(lhl)) ) THEN hldn = xdn0(lhl) IF ( lvhl > 1 ) THEN IF ( an(ix,jy,kz,lvhl) > volmin ) THEN hldn = rho0(mgs)*qx(mgs,lhl)/an(ix,jy,kz,lvhl) ENDIF ENDIF lam_hl = factor_hl *((hldn*cx(mgs,lhl))/(qx(mgs,lhl)*rho0(mgs)))**(1./3.) t6(ix,jy,kz) = 0.5*(alphahl+3.)/lam_hl ENDIF ENDIF ENDDO ENDDO RETURN END SUBROUTINE calc_eff_radius SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) implicit none integer ngs,mgs,ngscnt real theta2temp real qvex integer nqsat real fqsat, cbw real ss1 real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) real thetap0(ngs), theta0(ngs) real fcqv1(ngs), felvcp(ngs), pi0(ngs) real pk(ngs) real tabqvs(nqsat) integer itertd integer ltemq real gamss, tmp real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) real temg(ngs), temcg(ngs), thetap(ngs) real tfr parameter ( tfr = 273.15 ) pqs(mgs) = (380.0)/(pres(mgs)) thetap(mgs) = thetap0(mgs) theta(mgs) = thetap(mgs) + theta0(mgs) qwvp(mgs) = qwvp0(mgs) qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) temg(mgs) = theta(mgs)*pk(mgs) qwv(mgs) = max( 0.0, qvap(mgs) ) qcw(mgs) = max( 0.0, qcw1(mgs) ) qcwtmp(mgs) = qcw(mgs) temcg(mgs) = temg(mgs) - tfr ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN pqs(mgs) = (380.0)/(pres(mgs)) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) do itertd = 1,2 dqcw(mgs) = 0.0 dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) if( dqwv(mgs) .lt. 0. ) then if( qcw(mgs) .gt. -dqwv(mgs) ) then dqcw(mgs) = dqwv(mgs) dqwv(mgs) = 0. else dqcw(mgs) = -qcw(mgs) dqwv(mgs) = dqwv(mgs) + qcw(mgs) end if qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) qcw(mgs) = qcw(mgs) + dqcw(mgs) thetap(mgs) = thetap(mgs) + & & 1./pi0(mgs)* & & (felvcp(mgs)*dqcw(mgs) ) end if IF ( dqwv(mgs) .ge. 0. ) THEN dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & & ((temg(mgs)-cbw)**2)) dqcw(mgs) = dqvcnd(mgs) thetap(mgs) = thetap(mgs) + & & (felvcp(mgs)*dqcw(mgs) ) & & / (pi0(mgs)) qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) qcw(mgs) = qcw(mgs) + dqcw(mgs) END IF theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) temcg(mgs) = temg(mgs) - tfr ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qcw(mgs) = max( 0.0, qcw(mgs) ) qwv(mgs) = max( 0.0, qvap(mgs)) qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) end do qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) RETURN END SUBROUTINE QVEXCESS SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx,cdxgs, & & ipconc1,ndebug1,ngs,nz,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & & itype1a,itype2a,temcg,infdo,alpha,axx,bxx,ildo) implicit none integer ngscnt,ngs0,ngs,nz real xv(ngs,lc:lhab) real qx(ngs,lv:lhab) real qxw(ngs,ls:lhab) real cx(ngs,lc:lhab) real vtxbar(ngs,lc:lhab,3) real xmas(ngs,lc:lhab) real xdn(ngs,lc:lhab) real cdxgs(ngs,lc:lhab) real xdia(ngs,lc:lhab,3) real xvmn0(lc:lhab), xvmx0(lc:lhab) real qxmin(lc:lhab) real cdx(lc:lhab) real alpha(ngs,lc:lhab) real rho0(ngs),rhovt(ngs),temcg(ngs) real cno(lc:lhab) real cnostmp(ngs) real cwc1, cimna, cimxa real cnina(ngs) integer igs(ngs),kgs(ngs) real fadvisc(ngs) real fsw integer ipconc1 integer ndebug1 integer, intent (in) :: itype1a,itype2a,infdo integer, intent (in) :: ildo real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) real swmasmx, dtmp real cd real cwc0 real :: cwch(ngscnt), cwchl(ngscnt) real :: cwchtmp,cwchltmp,xnutmp real pii real cimasx,cimasn real cwmasn,cwmasx,cwradn real cwrad real vr,rnux real alp real ccimx integer mgs real arx,frx,vtrain,fw real fwlo,fwhi,rfwdiff real ar,br,cs,ds real gr real rwrad,rwdia real mwfac integer il real bta1,cnit parameter ( bta1 = 0.6, cnit = 1.0e-02 ) real x,y,tmp,del real aax,bbx,delrho integer :: indxr real mwt, nwt, zwt real, parameter :: rho00 = 1.225 integer i real xvbarmax integer l1, l2 fwlo = 0.2 fwhi = 0.4 rfwdiff = 1./(fwhi - fwlo) pii = piinv arx = 10. frx = 516.575 ar = 841.99666 br = 0.8 gr = 9.8 cs = 12.42 ds = 0.42 IF ( ildo == 0 ) THEN l1 = lc l2 = lhab ELSE l1 = ildo l2 = ildo ENDIF IF ( lh .gt. 1 ) THEN IF ( dmuh == 1.0 ) THEN cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) ELSE cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) ) ENDIF ENDIF IF ( lhl .gt. 1 ) THEN IF ( dmuhl == 1.0 ) THEN cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) ELSE cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) ) ENDIF ENDIF IF ( ipconc .le. 5 ) THEN IF ( lh .gt. 1 ) cwch(:) = cwchtmp IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp ELSE DO mgs = 1,ngscnt IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( dmuh == 1.0 ) THEN cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) ELSE xnutmp = (alpha(mgs,lh) - 2.0)/3.0 cwch(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) ) ENDIF ELSE cwch(mgs) = cwchtmp ENDIF ENDIF IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN IF ( dmuhl == 1.0 ) THEN cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) ELSE xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) ) ENDIF ELSE cwchl(mgs) = cwchltmp ENDIF ENDIF ENDDO ENDIF cimasn = Min( cimas0, 6.88e-13) cimasx = 1.0e-8 ccimx = 5000.0e3 cwc1 = 6.0/(pi*1000.) cwc0 = pii mwfac = 6.0**(1./3.) if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' IF ( ildo == 0 .or. ildo == lc ) THEN do mgs = 1,ngscnt xv(mgs,lc) = 0.0 IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN IF ( ipconc .ge. 2 ) THEN IF ( cx(mgs,lc) .gt. cxmin) THEN xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSE cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) xmas(mgs,lc) = Min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ENDIF ELSE IF ( ipconc .lt. 2 ) THEN cx(mgs,lc) = rho0(mgs)*ccn/rho00 ENDIF IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & & xdn(mgs,lc)*xvmx(lc) ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 1.0e-9 ) THEN cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSE xmas(mgs,lc) = cwmasn xv(mgs,lc) = xmas(mgs,lc)/1000. ENDIF ENDIF xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 xdia(mgs,lc,3) = xdia(mgs,lc,1) cwrad = 0.5*xdia(mgs,lc,1) IF ( fadvisc(mgs) > 0.0 ) THEN vtxbar(mgs,lc,1) = & & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & & /(9.0*fadvisc(mgs)) ELSE vtxbar(mgs,lc,1) = 0.0 ENDIF ELSE xmas(mgs,lc) = cwmasn xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) IF ( qx(mgs,lc) <= 0.0 ) cx(mgs,lc) = 0.0 IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 xdia(mgs,lc,1) = 2.*cwradn xdia(mgs,lc,2) = 4.*cwradn**2 xdia(mgs,lc,3) = xdia(mgs,lc,1) vtxbar(mgs,lc,1) = 0.0 ENDIF end do ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN do mgs = 1,ngscnt xdn(mgs,li) = 900.0 IF ( ipconc .eq. 0 ) THEN cx(mgs,li) = cnina(mgs) IF ( cimna .gt. 1.0 ) THEN cx(mgs,li) = Max(cimna,cx(mgs,li)) ENDIF IF ( cimxa .gt. 1.0 ) THEN cx(mgs,li) = Min(cimxa,cx(mgs,li)) ENDIF IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) ENDIF cx(mgs,li) = max(1.0e-20,cx(mgs,li)) ELSEIF ( ipconc .ge. 1 ) THEN IF ( qx(mgs,li) .gt. qxmin(li) ) THEN cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) ENDIF ENDIF IF ( qx(mgs,li) .gt. qxmin(li) ) THEN xmas(mgs,li) = & & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) if ( xmas(mgs,li) .gt. 0.0 ) THEN IF ( ixtaltype == 1 ) THEN xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) ELSEIF ( ixtaltype == 2 ) THEN xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 ENDIF end if IF ( ipconc .ge. 0 ) THEN xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) IF ( icefallopt == 1 ) THEN IF ( ixtaltype == 1 ) THEN tmp = (67056.6300748612*rhovt(mgs))/ & & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p47 vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ELSEIF ( ixtaltype == 2 ) THEN vtxbar(mgs,li,1) = 11.9495*rhovt(mgs)*(xv(mgs,li))**(0.14) vtxbar(mgs,li,2) = 7.02909*rhovt(mgs)*(xv(mgs,li))**(0.14) vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ENDIF ELSEIF ( icefallopt == 2 ) THEN tmp = (82.3166*rhovt(mgs))/ & & (((1.0 + cinu)/xv(mgs,li))**0.22117*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p22 vtxbar(mgs,li,1) = tmp*gfcinu2p22/(1. + cinu) vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ELSEIF ( icefallopt == 3 ) THEN tmp = (47.6273*rhovt(mgs))/ & & (((1.0 + cinu)/xv(mgs,li))**0.18333*gfcinu1) vtxbar(mgs,li,2) = tmp*gfcinu1p18 vtxbar(mgs,li,1) = tmp*gfcinu2p18/(1. + cinu) vtxbar(mgs,li,3) = vtxbar(mgs,li,1) ENDIF xdia(mgs,li,2) = xdia(mgs,li,1)**2 ELSE xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) xdn(mgs,li) = 900.0 xdia(mgs,li,2) = xdia(mgs,li,1)**2 vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) ENDIF ELSE xmas(mgs,li) = 1.e-13 IF ( qx(mgs,li) <= 0.0 ) cx(mgs,li) = 0.0 xdn(mgs,li) = 900.0 xdia(mgs,li,1) = 1.e-7 xdia(mgs,li,2) = (1.e-14) xdia(mgs,li,3) = 1.e-7 vtxbar(mgs,li,1) = 0.0 ENDIF IF ( icefallfac /= 1.0 ) THEN vtxbar(mgs,li,1) = icefallfac*vtxbar(mgs,li,1) vtxbar(mgs,li,2) = icefallfac*vtxbar(mgs,li,2) vtxbar(mgs,li,3) = icefallfac*vtxbar(mgs,li,3) ENDIF end do ENDIF IF ( ildo == 0 .or. ildo == lr ) THEN do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) ) then if ( ipconc .ge. 3 ) then xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) xvbarmax = xvmx(lr) IF ( imaxdiaopt == 1 ) THEN xvbarmax = xvmx(lr) ELSEIF ( imaxdiaopt == 2 ) THEN IF ( imurain == 1 ) THEN xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) ELSEIF ( imurain == 3 ) THEN ENDIF ELSEIF ( imaxdiaopt == 3 ) THEN IF ( imurain == 1 ) THEN xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) ELSEIF ( imurain == 3 ) THEN ENDIF ENDIF IF ( xv(mgs,lr) .gt. xvbarmax ) THEN xv(mgs,lr) = xvbarmax cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*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 xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) IF ( imurain == 3 ) THEN xdia(mgs,lr,1) = xdia(mgs,lr,3) ELSE xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) ENDIF ELSE xdia(mgs,lr,1) = & & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) end if else xdia(mgs,lr,1) = 1.e-9 xdia(mgs,lr,3) = 1.e-9 xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 end if xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 end do ENDIF IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN do mgs = 1,ngscnt if ( qx(mgs,ls) .gt. qxmin(ls) ) then if ( ipconc .ge. 4 ) then xmas(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls))) swmasmx = 13.7e-6 IF ( isnowdens == 2 ) THEN xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) ) IF ( xdn(mgs,ls) <= 900. ) THEN dtmp = Sqrt( xmas(mgs,ls)/0.069 ) xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.) ELSE xdn(mgs,ls) = 900. xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) ENDIF ELSE xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.) ENDIF xdia(mgs,ls,1) = dtmp IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) ) xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) ENDIF IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.) cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) ) xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) ENDIF xdia(mgs,ls,3) = xdia(mgs,ls,1) ELSE xdia(mgs,ls,1) = & & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) end if else xdia(mgs,ls,1) = 1.e-9 xdia(mgs,ls,3) = 1.e-9 cx(mgs,ls) = 0.0 IF ( isnowdens == 2 ) THEN xdn(mgs,ls) = 90. ENDIF end if xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 end do ENDIF IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN do mgs = 1,ngscnt if ( qx(mgs,lh) .gt. qxmin(lh) ) then if ( ipconc .ge. 5 ) then xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) ENDIF xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) IF ( dmuh == 1.0 ) THEN xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) ELSE xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) ENDIF ELSE xdia(mgs,lh,1) = & & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) end if else xdia(mgs,lh,1) = 1.e-9 xdia(mgs,lh,3) = 1.e-9 end if xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 end do ENDIF IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN do mgs = 1,ngscnt if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then if ( ipconc .ge. 5 ) then xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) ENDIF xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) IF ( dmuhl == 1.0 ) THEN xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) ELSE xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) ENDIF ELSE xdia(mgs,lhl,1) = & & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) end if else xdia(mgs,lhl,1) = 1.e-9 xdia(mgs,lhl,3) = 1.e-9 end if xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 end do ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' IF ( ildo == 0 .or. ildo == lr ) THEN do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) ) then IF ( ipconc .lt. 3 ) THEN vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) ELSE IF ( imurain == 1 ) THEN alp = alpha(mgs,lr) vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ELSE vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) ENDIF IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ELSE vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) ENDIF ELSEIF ( imurain == 3 ) THEN IF ( lzr < 1 ) THEN rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) IF ( infdo .ge. 1 ) THEN IF ( rssflg >= 1 ) THEN vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) ELSE vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) ENDIF ENDIF IF ( infdo .ge. 2 ) THEN vtxbar(mgs,lr,3) = rhovt(mgs)*( & & 0.0911229 + & & 9246.494*(rwdia) - & & 3.2839926e6*(rwdia**2) + & & 4.944093e8*(rwdia**3) - & & 2.631718e10*(rwdia**4) ) ENDIF ELSE vr = xv(mgs,lr) rnux = alpha(mgs,lr) IF ( infdo .ge. 1 .and. rssflg == 1) THEN vtxbar(mgs,lr,2) = rhovt(mgs)* & & (((1. + rnux)/vr)**(-1.333333)* & & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + & & (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/ & & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & & Gamma_sp(1.666667 + rnux) + & & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & & Gamma_sp(2. + rnux) - & & 2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/ & & Gamma_sp(1. + rnux) ENDIF vtxbar(mgs,lr,1) = rhovt(mgs)* & & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) + & & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & & Gamma_sp(2.333333333333333 + rnux) - & & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & & Gamma_sp(2.6666666666666667 + rnux) + & & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) - & & 2.3303765697228556e9*vr**1.3333333333333333* & & Gamma_sp(3.333333333333333 + rnux))/ & & ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) IF(infdo .ge. 1 .and. rssflg == 0) THEN vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) ENDIF IF ( infdo .ge. 2 .and. rssflg == 1) THEN vtxbar(mgs,lr,3) = rhovt(mgs)* & & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) + & & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & & Gamma_sp(3.3333333333333335 + rnux) - & & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & & vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) + & & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - & & 2.3303765697228556e9*vr**1.3333333333333333* & & Gamma_sp(4.333333333333333 + rnux)))/ & & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux)) ELSEIF (infdo .ge. 2) THEN vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) ENDIF ENDIF ENDIF ENDIF else vtxbar(mgs,lr,1) = 0.0 vtxbar(mgs,lr,2) = 0.0 end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' ENDIF IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN do mgs = 1,ngscnt if ( qx(mgs,ls) .gt. qxmin(ls) ) then IF ( ipconc .ge. 4 ) THEN if ( mixedphase .and. qsvtmod ) then else IF ( isnowfall == 1 ) THEN vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ELSEIF ( isnowfall == 2 ) THEN IF ( isnowdens == 1 ) THEN vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) ELSE vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ENDIF ELSEIF ( isnowfall == 3 ) THEN vtxbar(mgs,ls,1) = 50.092*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) ENDIF IF(Abs(sssflg) >= 1) THEN IF ( isnowfall == 1 ) THEN vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ELSEIF ( isnowfall == 2 ) THEN IF ( isnowdens == 1 ) THEN vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ELSE vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) ENDIF ELSEIF ( isnowfall == 3 ) THEN vtxbar(mgs,ls,2) = 21.6147*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) ENDIF ELSE vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) ENDIF IF ( infdo >= 2 ) THEN IF ( isnowfall == 1 ) THEN vtxbar(mgs,ls,3) = 6.12217*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ELSEIF ( isnowfall == 2 ) THEN vtxbar(mgs,ls,3) = 13.3436*rhovt(mgs)*(xv(mgs,ls))**(0.14) ELSEIF ( isnowfall == 3 ) THEN vtxbar(mgs,ls,3) = 61.0914*rhovt(mgs)*(xmas(mgs,ls))**(0.2635) ENDIF ENDIF IF ( sssflg < 0 .and. temcg(mgs) > Abs(sssflg) ) THEN vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) ENDIF endif ELSE vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) ENDIF else vtxbar(mgs,ls,1) = 0.0 end if IF ( snowfallfac /= 1.0 ) THEN vtxbar(mgs,ls,1) = snowfallfac*vtxbar(mgs,ls,1) vtxbar(mgs,ls,2) = snowfallfac*vtxbar(mgs,ls,2) vtxbar(mgs,ls,3) = snowfallfac*vtxbar(mgs,ls,3) ENDIF end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' ENDIF IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN do mgs = 1,ngscnt vtxbar(mgs,lh,1) = 0.0 if ( qx(mgs,lh) .gt. qxmin(lh) ) then cd = cdx(lh) IF ( icdx .eq. 1 ) THEN cd = cdx(lh) ELSEIF ( icdx .eq. 2 ) THEN cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) ELSEIF ( icdx .eq. 3 ) THEN cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ELSEIF ( icdx .eq. 4 ) THEN cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) ELSEIF ( icdx .eq. 5 ) THEN cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) ELSEIF ( icdx .eq. 6 ) THEN indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 indxr = Min( ngdnmm, Max(1,indxr) ) delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN axx(mgs,lh) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) bxx(mgs,lh) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE axx(mgs,lh) = mmgraupvt(indxr,2) bxx(mgs,lh) = mmgraupvt(indxr,3) ENDIF aax = axx(mgs,lh) bbx = bxx(mgs,lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ELSEIF ( icdx <= 0 ) THEN aax = ax(lh) bbx = bx(lh) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ELSE cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ENDIF cdxgs(mgs,lh) = cd IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN axx(mgs,lh) = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) bxx(mgs,lh) = 0.5 vtxbar(mgs,lh,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lh) * Sqrt(xdia(mgs,lh,1)) ELSE IF ( icdx /= 6 ) bbx = bx(lh) tmp = 4. + alpha(mgs,lh) + bbx i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 4. + alpha(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami IF ( icdx > 0 .and. icdx /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y axx(mgs,lh) = aax bxx(mgs,lh) = bbx ELSEIF (icdx == 6 ) THEN vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y ELSE axx(mgs,lh) = ax(lh) bxx(mgs,lh) = bx(lh) vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y ENDIF ENDIF IF ( lwsm6 .and. ipconc == 0 ) THEN vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) ENDIF end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' ENDIF IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN do mgs = 1,ngscnt vtxbar(mgs,lhl,1) = 0.0 if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then IF ( icdxhl .eq. 1 ) THEN cd = cdx(lhl) ELSEIF ( icdxhl .eq. 3 ) THEN cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) ELSEIF ( icdxhl .eq. 4 ) THEN cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) ELSEIF ( icdxhl .eq. 5 ) THEN cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) ELSEIF ( icdxhl .eq. 6 ) THEN indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 indxr = Min( ngdnmm, Max(1,indxr) ) delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) IF ( indxr < ngdnmm ) THEN axx(mgs,lhl) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) bxx(mgs,lhl) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) ELSE axx(mgs,lhl) = mmgraupvt(indxr,2) bxx(mgs,lhl) = mmgraupvt(indxr,3) ENDIF aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) ELSE cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) ENDIF cdxgs(mgs,lhl) = cd IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN axx(mgs,lhl) = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) bxx(mgs,lhl) = 0.5 vtxbar(mgs,lhl,1) = (gf4p5/6.0)* rhovt(mgs)*axx(mgs,lhl) * Sqrt(xdia(mgs,lhl,1)) ELSE IF ( icdxhl /= 6 ) bbx = bx(lhl) tmp = 4. + alpha(mgs,lhl) + bbx i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 4. + alpha(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami IF ( icdxhl > 0 .and. icdxhl /= 6) THEN aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y axx(mgs,lhl) = aax bxx(mgs,lhl) = bbx ELSEIF ( icdxhl == 6 ) THEN vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y ELSE axx(mgs,lhl) = ax(lhl) bxx(mgs,lhl) = bx(lhl) vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y ENDIF ENDIF end if end do if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' ENDIF IF ( infdo .ge. 1 ) THEN DO mgs = 1,ngscnt IF ( ildo == 0 .or. ildo == lc ) THEN vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) ENDIF IF ( li .gt. 1 ) THEN ENDIF ENDDO IF ( lg .gt. lr ) THEN DO il = lg,lhab IF ( ildo == 0 .or. ildo == il ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,il) .gt. qxmin(il) ) THEN IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN IF ( il .eq. lh ) THEN IF ( icdx .eq. 1 ) THEN cd = cdx(lh) ELSEIF ( icdx .eq. 2 ) THEN cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) ELSEIF ( icdx .eq. 3 ) THEN cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) ELSEIF ( icdx .eq. 4 ) THEN cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) ELSEIF ( icdx .eq. 5 ) THEN cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) ELSEIF ( icdx .eq. 6 ) THEN aax = axx(mgs,lh) bbx = bxx(mgs,lh) ELSEIF ( icdx <= 0 ) THEN aax = ax(lh) bbx = bx(lh) ENDIF ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN IF ( icdxhl .eq. 1 ) THEN cd = cdx(lhl) ELSEIF ( icdxhl .eq. 3 ) THEN cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) ELSEIF ( icdxhl .eq. 4 ) THEN cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) ELSEIF ( icdxhl == 5 ) THEN cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) ELSEIF ( icdxhl .eq. 6 ) THEN aax = axx(mgs,lhl) bbx = bxx(mgs,lhl) ELSEIF ( icdxhl <= 0 ) THEN aax = ax(lhl) bbx = bx(lhl) ENDIF ENDIF IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & & (3.0*cd*Max(0.05,rho0(mgs))) ) ELSE IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) tmp = 1. + alpha(mgs,il) + bbx i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 1. + alpha(mgs,il) i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami IF ( il .eq. lh .or. il .eq. lhl) THEN IF ( ( il==lh .and. icdx > 0 ) ) THEN IF ( icdx /= 6 ) THEN aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y ELSE vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y ENDIF ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN IF ( icdxhl /= 6 ) THEN aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bx(il) * x/y ELSE vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y ENDIF ELSE aax = ax(il) vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y ENDIF IF ( infdo .ge. 2 ) THEN tmp = 7. + alpha(mgs,il) + bbx i = Int(dgami*(tmp)) del = tmp - dgam*i x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 7. + alpha(mgs,il) i = Int(dgami*(tmp)) del = tmp - dgam*i y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami vtxbar(mgs,il,3) = rhovt(mgs)* & & (aax*(xdia(mgs,il,1) )**bbx * & & x)/y IF ( .not. (vtxbar(mgs,il,1) > -1. .and. vtxbar(mgs,il,1) < 250. ) .or. & .not. (vtxbar(mgs,il,3) > -1. .and. vtxbar(mgs,il,3) < 250. ) ) THEN write(0,*) 'Setvtz: problem with vtxbar1/3: ',il,vtxbar(mgs,il,1),vtxbar(mgs,il,3),aax,bbx,x,y write(0,*) 'q, number, diam1,3(mm) = ', qx(mgs,il),cx(mgs,il),1000.*xdia(mgs,il,1),1000.*xdia(mgs,il,3) ENDIF ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' ELSE vtxbar(mgs,il,2) = & & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & & x)/y IF ( infdo .ge. 2 ) THEN vtxbar(mgs,il,3) = rhovt(mgs)* & & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & & Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il)) ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' ENDIF ENDIF ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN vtxbar(mgs,il,2) = vtxbar(mgs,il,1) vtxbar(mgs,il,3) = vtxbar(mgs,il,1) ELSE vtxbar(mgs,il,2) = & & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & & (3.0*cdx(il)*Max(0.05,rho0(mgs))) ) vtxbar(mgs,il,3) = vtxbar(mgs,il,1) if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' ENDIF ELSE vtxbar(mgs,il,2) = 0.0 if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' ENDIF ENDDO if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' ENDIF ENDDO if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' ENDIF IF ( lh > 0 .and. graupelfallfac /= 1.0 ) THEN DO mgs = 1,ngscnt vtxbar(mgs,lh,1) = graupelfallfac*vtxbar(mgs,lh,1) vtxbar(mgs,lh,2) = graupelfallfac*vtxbar(mgs,lh,2) vtxbar(mgs,lh,3) = graupelfallfac*vtxbar(mgs,lh,3) axx(mgs,lh) = graupelfallfac*axx(mgs,lh) ENDDO ENDIF IF ( lhl > 0 .and. hailfallfac /= 1.0 ) THEN DO mgs = 1,ngscnt vtxbar(mgs,lhl,1) = hailfallfac*vtxbar(mgs,lhl,1) vtxbar(mgs,lhl,2) = hailfallfac*vtxbar(mgs,lhl,2) vtxbar(mgs,lhl,3) = hailfallfac*vtxbar(mgs,lhl,3) axx(mgs,lhl) = hailfallfac*axx(mgs,lhl) ENDDO ENDIF if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' RETURN END SUBROUTINE setvtz subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & & xvt, rhovtzx, & & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & & cwradn, & & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & & cnostmp, & & infdo,ildo,timesetvt) implicit none integer ng1 parameter(ng1 = 1) integer, intent(in) :: ixcol integer, intent(in) :: ildo integer nx,ny,nz,nor,norz,ngt,jgs,na real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real dtp,dtz1 real :: rhovtzx(nz,nx) integer ndebugzf parameter (ndebugzf = 0) integer ix,jy,kz,i,j,k,il integer infdo real xvt(nz+1,nx,3,lc:lhab) real qxmin(lc:lhab) real xdn0(lc:lhab) real xvmn(lc:lhab), xvmx(lc:lhab) double precision,optional :: timesetvt integer :: ngs 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 :: cdxgs(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vx(ngs,li:lhab) real :: alpha(ngs,lc:lhab) real :: zx(ngs,lr:lhab) real xdnmx(lc:lhab), xdnmn(lc:lhab) real :: axx(ngs,lh:lhab), bxx(ngs,lh:lhab) real cdx(lc:lhab) real cno(lc:lhab) real cwccn0,cwmasn,cwmasx,cwradn integer nxmpb,nzmpb,nxz,numgs,inumgs integer kstag parameter (kstag=1) 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 :: cnina(ngs),cimas(ngs) real :: cnostmp(ngs) logical flag logical ldoliq real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp, tmpc, tmpz real vtmax real xvbarmax real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 integer l1, l2 double precision :: dpt1, dpt2 integer :: ixb, jyb, kzb integer :: ixe, jye, kze logical :: debug_mpi = .false. if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL1D: ENTERED SUBROUTINE" ldoliq = .false. IF ( ls .gt. 1 ) THEN DO il = ls,lhab ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) ENDDO ENDIF jy = jgs nxmpb = ixcol nzmpb = 1 nxz = 1*nz numgs = 1 IF ( ildo == 0 ) THEN l1 = lc l2 = lhab ELSE l1 = ildo l2 = ildo ENDIF do inumgs = 1,numgs ngscnt = 0 do kz = 1,nz do ix = ixcol,ixcol flag = .false. DO il = l1,l2 flag = flag .or. ( an(ix,jy,kz,il) > 0.0 ) ENDDO if ( flag ) then ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz if ( ngscnt .eq. nz ) goto 1100 end if end do nxmpb = 1 end do 1100 continue if ( ngscnt .eq. 0 ) go to 9998 do mgs = 1,ngscnt rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temcg(mgs) = temg(mgs) - tfr end do IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & & (temg(mgs)/296.0)**(1.5) end do ENDIF IF ( ipconc .eq. 0 ) THEN do mgs = 1,ngscnt cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) end do ENDIF IF ( ildo > 0 ) THEN vtxbar(:,ildo,:) = 0.0 ELSE vtxbar(:,:,:) = 0.0 ENDIF DO il = l1,l2 do mgs = 1,ngscnt qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) ENDDO end do cnostmp(:) = cno(ls) IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN DO mgs = 1,ngscnt tmp = Min( 0.0, temcg(mgs) ) cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) ENDDO ENDIF cx(:,:) = 0.0 if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then do mgs = 1,ngscnt cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) end do end if if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) end do end if if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) end do end if if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then do mgs = 1,ngscnt cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) end do end if if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then do mgs = 1,ngscnt cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) end do ENDIF if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then do mgs = 1,ngscnt cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) end do end if DO il = l1,l2 IF ( lz(il) < 1 .and. ln(il) > 1 ) THEN do mgs = 1,ngscnt IF ( cx(mgs,il) <= cxmin .or. qx(mgs,il) < qxmin(il) ) THEN 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) ENDIF end do ENDIF ENDDO do mgs = 1,ngscnt xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) end do IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN vx(:,:) = 0.0 DO il = l1,l2 IF ( lvol(il) .ge. 1 ) THEN DO mgs = 1,ngscnt vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) ENDIF ENDDO ENDIF ENDDO ENDIF DO il = lg,lhab DO mgs = 1,ngscnt alpha(mgs,il) = dnu(il) ENDDO ENDDO IF ( imurain == 1 ) THEN alpha(:,lr) = alphar 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.) alpha(mgs,lh) = Min(alphamax, c1h*tanh(c2h*(xdia(mgs,lh,3)*1000. - c3h)) + c4h) ENDIF 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 IF ( ipconc .ge. 6 .or. lzr > 1) THEN zx(:,:) = 0.0 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 IF ( lz(lr) > 1 .and. (ildo == 0 .or. ildo == lr ) .and. imurain == 3 ) THEN il = lr DO mgs = 1,ngscnt IF ( iresetmoments == 1 .or. iresetmoments == il ) 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 ( 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 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 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 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 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(il)) = zx(mgs,il) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) <= 0.0 ) THEN 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 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) qr = qx(mgs,lr) nrx = cx(mgs,lr) z = zx(mgs,lr) 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 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 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) 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 IF ( .true. .and. (alpha(mgs,il) <= rnumin .or. alp == rnumin .or. alp == rnumax) ) THEN IF ( rescale_high_alpha .and. alp >= rnumax - 0.01 ) THEN 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 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 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 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 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 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 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) = 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 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 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.*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 alp = Max( alphamin, Min( alphamax, alp ) ) ENDDO IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSEIF ( imaxdiaopt == 3 ) THEN 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 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) tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp IF ( tmpz > zx(mgs,il) ) THEN tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) cx(mgs,il) = Max(cx(mgs,il), tmpc) ENDIF zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/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 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 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*(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 ENDIF ENDDO ENDIF IF ( lzhl > 1 ) THEN IF ( lhl .gt. 1 ) THEN ENDIF ENDIF 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,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & & itype1,itype2,temcg,infdo,alpha,axx,bxx,ildo) 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 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 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) ) 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 enddo ENDDO if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' 9998 continue if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' if ( kz .gt. nz-1 ) then go to 1200 else nzmpb = kz end if if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' end do if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' 1200 continue if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" RETURN END subroutine ziegfall1d subroutine radardd02(nx,ny,nz,nor,na,an,temk, & & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc,ke_diag, iunit) implicit none character(LEN=15), parameter :: microp = 'ZVD' integer nx,ny,nz,nor,na,ngt integer nzdbz integer ng1,n10 integer iunit integer, parameter :: printyn = 0 parameter( ng1 = 1 ) real cnoh0t,hwdn1t integer ke_diag integer ipconc real vr integer imapz,mzdist integer vzflag integer, parameter :: norz = 3 real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) real gz(-nor+1:nz+nor) real cr1, cr2 , hwdnsq,swdnsq real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc real reflectmin, kw_sq real const_ki_sn, const_ki_h, ki_sq_sn real ki_sq_h, dielf_sn, dielf_h real pi logical ltest real gtmp (nx,nz) real dtmp (nx,nz) real tmp double precision :: dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x integer i,j,k,ix,jy,kz,ihcnt double precision :: xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc double precision :: dadr real dbzmax,dbzmin parameter ( dbzmin = 0 ) real cnow,cnoi,cnoip,cnoir,cnor,cnos real cnogl,cnogm,cnogh,cnof,cnoh,cnohl real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn real swdn0 real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx real ghdnmx,fwdnmx,hwdnmx,hldnmx real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn real ghdnmn,fwdnmn,hwdnmn,hldnmn real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq real dadgl,dadgm,dadgh,dadhl,dadf real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc real zhldryc,zhlwetc,zfdryc,zfwetc real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw integer imx,jmx,kmx real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia real csw,cgl,cgm,cgh,cfw,chw,chl real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl real cwc0 integer izieg integer ice10 real rhos parameter ( rhos = 0.1 ) real qxw,qxw1 real :: dnsnow real qh real, parameter :: cwmasn = 5.23e-13 real, parameter :: cwmasx = 5.25e-10 real, parameter :: cwradn = 5.0e-6 real cwnccn(nz) real :: vzsnow, vzrain, vzgraupel, vzhail real :: ksq real :: dtp vzflag = 0 izieg = 0 ice10 = 0 pi = 4.0*ATan(1.) cwc0 = piinv cnoh = cnoh0t hwdn = hwdn1t rwdn = 1000.0 swdn = 100.0 qrmin = 1.0e-05 qsmin = 1.0e-06 qhmin = 1.0e-05 cnow = 1.0e+08 cnoi = 1.0e+08 cnoip = 1.0e+08 cnoir = 1.0e+08 cnor = 8.0e+06 cnos = 8.0e+06 cnogl = 4.0e+05 cnogm = 4.0e+05 cnogh = 4.0e+05 cnof = 4.0e+05 cnohl = 1.0e+03 imx = 1 jmx = 1 kmx = 1 i = 1 IF ( microp(1:4) .eq. 'ZIEG' ) THEN izieg = 1 hwdn = hwdn1t cnor = cno(lr) cnos = cno(ls) cnoh = cno(lh) qrmin = qxmin(lr) qsmin = qxmin(ls) qhmin = qxmin(lh) IF ( lhl .gt. 1 ) THEN cnohl = cno(lhl) qhlmin = qxmin(lhl) ENDIF ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN izieg = 1 swdn0 = swdn cnor = cno(lr) cnos = cno(ls) cnoh = cno(lh) qrmin = qxmin(lr) qsmin = qxmin(ls) qhmin = qxmin(lh) IF ( lhl .gt. 1 ) THEN cnohl = cno(lhl) qhlmin = qxmin(lhl) ENDIF ENDIF rwdnmx = 1000.0 cwdnmx = 1000.0 cidnmx = 917.0 xidnmx = 917.0 swdnmx = 200.0 gldnmx = 400.0 gmdnmx = 600.0 ghdnmx = 800.0 fwdnmx = 900.0 hwdnmx = 900.0 hldnmx = 900.0 rwdnmn = 1000.0 cwdnmn = 1000.0 xidnmn = 001.0 cidnmn = 001.0 swdnmn = 001.0 gldnmn = 200.0 gmdnmn = 400.0 ghdnmn = 600.0 fwdnmn = 700.0 hwdnmn = 700.0 hldnmn = 900.0 gldn = (0.5)*(gldnmn+gldnmx) gmdn = (0.5)*(gmdnmn+gmdnmx) ghdn = (0.5)*(ghdnmn+ghdnmx) fwdn = (0.5)*(fwdnmn+fwdnmx) hldn = (0.5)*(hldnmn+hldnmx) cr1 = 7.2e+20 cr2 = 7.295e+19 hwdnsq = hwdn**2 swdnsq = swdn**2 rwdnsq = rwdn**2 gldnsq = gldn**2 gmdnsq = gmdn**2 ghdnsq = ghdn**2 fwdnsq = fwdn**2 hldnsq = hldn**2 dhmin = 0.005 tfr = 273.16 tfrh = tfr - 8.0 zrc = cr1*cnor reflectmin = 0.0 kw_sq = 0.93 dbzmax = dbzmin ihcnt=0 const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 dielf_sn = ki_sq_sn / kw_sq dielf_h = ki_sq_h / kw_sq dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq DO jy=1,1 DO kz = 1,ke_diag DO ix=1,nx dbz(ix,jy,kz) = 0.0 vzsnow = 0.0 vzrain = 0.0 vzgraupel = 0.0 vzhail = 0.0 dtmph = 0.0 dtmps = 0.0 dtmphl = 0.0 dtmpr = 0.0 dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) dtmp(ix,kz) = 0.0 gtmp(ix,kz) = 0.0 IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN 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)) dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) ELSE g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) ze =1.e18*zx*(6./(pi*1000.))**2 dtmp(ix,kz) = ze ENDIF ENDIF dtmpr = dtmp(ix,kz) ENDIF IF( lhab .gt. lr ) THEN xcnoh = cnoh xcnos = cnos IF ( ls .gt. 1 ) THEN IF ( lvs .gt. 1 ) THEN IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) swdn = Min( 300., Max( 100., swdn ) ) ELSE swdn = swdn0 ENDIF ENDIF IF ( ipconc .ge. 5 ) THEN xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN xvs = Min( xvsmx, Max( xvsmn,xvs ) ) csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) ENDIF swdia = (xvs*cwc0)**(1./3.) xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) ENDIF ENDIF IF ( lh .gt. 1 ) THEN IF ( lvh .gt. 1 ) THEN IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) hwdn = Min( 900., Max( hdnmn, hwdn ) ) ELSE hwdn = 500. ENDIF ELSE hwdn = hwdn1t ENDIF IF ( ipconc .ge. 5 ) THEN xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN xvh = Min( xvhmx, Max( xvhmn,xvh ) ) chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) ENDIF hwdia = (xvh*cwc0)**(1./3.) xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) ENDIF ENDIF dadh = 0.0 dadhl = 0.0 dads = 0.0 IF ( xcnoh .gt. 0.0 ) THEN dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ELSE dadh = 0.0 zhdryc = 0.0 ENDIF IF ( xcnos .gt. 0.0 ) THEN dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ELSE dads = 0.0 zsdryc = 0.0 ENDIF zhwetc = zhdryc zswetc = zsdryc IF ( ls .gt. 1 ) THEN gtmp(ix,kz) = 0.0 qxw = 0.0 qxw1 = 0.0 dtmps = 0.0 IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN IF ( ipconc .ge. 4 ) THEN if (lsw .gt. 1) THEN qxw = an(ix,jy,kz,lsw) qxw1 = 0.0 ELSEIF ( ( iusewetsnow == 1 .or. iusewetsnow == 3) .and. temk(ix,jy,kz) .gt. tfr+1. & & .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) .and. an(ix,jy,kz,lr) > qsmin) THEN qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) qxw1 = qxw ENDIF vr = xvs ksq = 0.189 IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN IF ( qxw > qsmin .or. iusewetsnow >= 2 ) THEN gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 ELSE 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/ & & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) ELSE gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 ENDIF ENDIF ENDIF dtmps = gtmp(ix,kz) dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) ELSE gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) IF ( gtmp(ix,kz) .gt. 0.0 ) THEN dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) IF ( temk(ix,jy,kz) .lt. tfr ) THEN dtmp(ix,kz) = dtmp(ix,kz) + & & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) ELSE dtmp(ix,kz) = dtmp(ix,kz) + & & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) ENDIF ENDIF ENDIF ENDIF ENDIF IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN IF ( idbzci == 1 .and. lni > 0 ) THEN IF ( an(ix,jy,kz,li) > qxmin(li) .and. an(ix,jy,kz,lni) > 1.0 ) THEN vr = db(ix,jy,kz)*an(ix,jy,kz,li)/(900.*an(ix,jy,kz,lni)) dtmp(ix,kz) = dtmp(ix,kz) + & & 0.224*3.6e18*(cinu+2.)*an(ix,jy,kz,lni)*vr**2/(cinu+1.)*(900./1000.)**2 ENDIF ELSEIF ( idbzci == 2 ) THEN gtmp(ix,kz) = 0.0 IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 ENDIF ENDIF ENDIF IF ( lh .gt. 1 ) THEN gtmp(ix,kz) = 0.0 dtmph = 0.0 qxw = 0.0 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 IF ( lvh .gt. 1 ) THEN IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) hwdn = Min( 900., Max( 100., hwdn ) ) ELSE hwdn = 500. ENDIF ENDIF chw = an(ix,jy,kz,lnh) IF ( chw .gt. 0.0 ) THEN xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN xvh = Min( xvhmx, Max( xvhmn,xvh ) ) chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) ENDIF qh = an(ix,jy,kz,lh) IF ( lhw .gt. 1 ) THEN IF ( iusewetgraupel .eq. 1 ) THEN qxw = an(ix,jy,kz,lhw) ELSEIF ( iusewetgraupel .eq. 2 ) THEN IF ( hwdn .lt. 300. ) THEN qxw = an(ix,jy,kz,lhw) ENDIF ENDIF ELSEIF ( iusewetgraupel .eq. 3 ) THEN IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) qh = qh + qxw ENDIF ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & & .and. an(ix,jy,kz,lr) > qhmin) THEN qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) qh = qh + qxw ENDIF IF ( lzh .gt. 1 ) THEN x = (0.224*qh + 0.776*qxw)/an(ix,jy,kz,lh) 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)**2*( 0.224*qh + 0.776*qxw)*qh/chw ze =1.e18*zx*(6./(pi*1000.))**2 dtmp(ix,kz) = dtmp(ix,kz) + ze dtmph = ze ENDIF ENDIF ENDIF ELSE dtmph = 0.0 IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) IF ( gtmp(ix,kz) .gt. 0.0 ) THEN dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) IF ( temk(ix,jy,kz) .lt. tfr ) THEN dtmp(ix,kz) = dtmp(ix,kz) + & & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) ELSE dtmp(ix,kz) = dtmp(ix,kz) + & & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN hldn = 900.0 gtmp(ix,kz) = 0.0 dtmphl = 0.0 qxw = 0.0 IF ( lvhl .gt. 1 ) THEN IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) hldn = Min( 900., Max( 300., hldn ) ) ELSE hldn = 900. ENDIF ELSE hldn = rho_qhl ENDIF 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) IF ( chl .gt. 0.0 ) THEN xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) ENDIF IF ( lhlw .gt. 1 ) THEN IF ( iusewethail .eq. 1 ) THEN qxw = an(ix,jy,kz,lhlw) ELSEIF ( iusewethail .eq. 2 ) THEN IF ( hldn .lt. 300. ) THEN qxw = an(ix,jy,kz,lhlw) ENDIF ENDIF ENDIF IF ( lzhl .gt. 1 ) THEN x = (0.224*an(ix,jy,kz,lhl) + 0.776*qxw)/an(ix,jy,kz,lhl) 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)) zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl ze = 1.e18*zx*(6./(pi*1000.))**2 dtmp(ix,kz) = dtmp(ix,kz) + ze dtmphl = ze ENDIF ENDIF ENDIF ELSE IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) IF ( gtmp(ix,kz) .gt. 0.0 ) THEN zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) IF ( temk(ix,jy,kz) .lt. tfr ) THEN dtmp(ix,kz) = dtmp(ix,kz) + & & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) ELSE dtmp(ix,kz) = dtmp(ix,kz) + & & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) ENDIF ENDIF ENDIF ENDIF ENDIF IF ( dtmp(ix,kz) .gt. 0.0 ) THEN dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN dbzmax = Max(dbzmax,dbz(ix,jy,kz)) imx = ix jmx = jy kmx = kz ENDIF ELSE dbz(ix,jy,kz) = dbzmin IF ( lh > 1 .and. lhl > 1) THEN IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) ENDIF ENDIF ENDIF IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN write(0,*) 'ix,jy,kz = ',ix,jy,kz write(0,*) 'dbz = ',dbz(ix,jy,kz) write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc write(0,*) 'Hail intercept: ',xcnoh,ix,kz write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) write(0,*) 'graupel density hwdn = ',hwdn write(0,*) 'rain q: ',an(ix,jy,kz,lr) write(0,*) 'ice q: ',an(ix,jy,kz,li) IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) IF ( ipconc .ge. 5 ) THEN write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) IF ( lzhl .gt. 1 ) THEN write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx ENDIF ENDIF write(0,*) 'chw,xvh = ', chw,xvh write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl write(0,*) 'dtmpr = ',dtmpr write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN write(0,*) 'dbz out of bounds!' ENDIF ENDIF ENDDO ENDDO ENDDO IF ( printyn .eq. 1 ) THEN write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) IF ( lh .gt. 1 ) THEN write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) ENDIF ENDIF RETURN END subroutine radardd02 SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & & ,nor,norz,dtp,nxi & & ,dz3d & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & & ,ngs & & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) implicit none integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab real :: dtp logical :: flag_qndrop integer, parameter :: ng1 = 1 real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) 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 w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) logical :: io_flag real :: dv real :: ccnefactwo, sstmp, cn1, cnuctmp real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs) integer nsvcnt integer ix,kz,i,n, kp1, km1 integer :: jy, jgs integer ixb,ixe,jyb,jye,kzb,kze integer itile,jtile,ktile integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs), ccnaco(ngs), ccnanu(ngs) real :: ccnc_nu(ngs), ccnc_ac(ngs), ccnc_co(ngs) real ccncuf(ngs) real sscb parameter ( sscb = 2.0 ) integer idecss parameter ( idecss = 1 ) integer iba parameter (iba = 1) integer ifilt parameter ( ifilt = 0 ) real temp1,temp2 real :: ssmax(ngs) real ssmx real dnnet,dqnet real ventrx(ngs) real ventrxn(ngs) real volb, t2s real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 real rhoinv(ngs) real chw, g1, rd1 real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 real tmpmx, fw, qctmp real x,y,del,r,alpr double precision :: vent1,vent2 real g1palp real bs real v1, v2 real d1r, d1i, d1s, e1i integer nc real dtcon,dtcon1,dtcon2 real delta integer ltemq1,ltemq1m real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 real dqvr, dqc, dqr, dqi, dqs real qv1m,qvs1m,ss1m,ssi1m,qis1m real cwmastmp real dcloud,dcloud2 real dcrit real cn(ngs), cnuf(ngs) real :: ccwmax integer ltemq integer il real es(ngs) real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) real, parameter :: ssfcut = 4.0 real ssfjp1(ngs),ssfjm1(ngs) real ssfip1(ngs),ssfim1(ngs) real supcb, supmx parameter (supcb=0.5,supmx=238.0) real r2dxm, r2dym, r2dzm real dssdz, dssdy, dssdx real epsi,d parameter (epsi = 0.622, d = 0.266) real r1,qevap real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc real ctmp, ccwtmp real f5, qvs0 real :: t0p1, t0p3 real qvex real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) real temp(ngs),tempc(ngs) real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real felv(ngs),felf(ngs),fels(ngs) real felvcp(ngs),felvpi(ngs) real gamw(ngs),gams(ngs) real tsqr(ngs),ssi(ngs),ssw(ngs) real cc3(ngs),cqv1(ngs),cqv2(ngs) real qcwtmp(ngs),qtmp real fvent(ngs) real fwvdf(ngs),ftka(ngs),fthdf(ngs) real fadvisc(ngs),fakvisc(ngs) real fci(ngs),fcw(ngs) real fschm(ngs),fpndl(ngs) real pres(ngs),pipert(ngs) real pk(ngs) real rho0(ngs),pi0(ngs) real rhovt(ngs) real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) real thsave(ngs) real qss0(ngs) real fcqv1(ngs) real wvel(ngs),wvelkm1(ngs) real wvdf(ngs),tka(ngs) real advisc(ngs) real rwvent(ngs) real :: qx(ngs,lv:lhab) real :: cx(ngs,lc:lhab) real :: xv(ngs,lc:lhab) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: alpha(ngs,lc:lhab) real :: zx(ngs,lr:lhab) logical zerocx(lc:lqmx) logical :: lprint integer, parameter :: iunit = 0 real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol real :: cvm,cpm,rmm real, parameter :: cpv = 1885.0 real, parameter :: Mair = 0.0284 integer :: kstag integer :: count real, parameter :: mwwater = 0.01801528 real, parameter :: rhowater = 997.0 real, parameter :: gasconst = 8.3144598 real :: sswater real :: sigvl, aact real :: alpha_ar, gamma_ar, G_ar, evs, zeta, smax real :: f_ac, g_ac, eta_ac real :: f_nu, g_nu, eta_nu real :: f_co, g_co, eta_co real :: sm_nu, sm_ac, sm_co, ss_ac, ss_nu, ss_co real :: uu_nu, uu_ac, uu_co real :: cn_ac, cn_co, cn_nu itile = nxi jtile = ny ktile = nz ixend = nxi jyend = ny kzend = nz nxend = nxi + 1 nyend = ny + 1 nzend = nz 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 jy = 1 kstag = 0 pb(:) = 0.0 pinit(:) = 0.0 IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 ssmx = 0 count = 0 do kz = 1,nz-kstag do ix = 1,nxi temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) t0(ix,jy,kz) = temp1 ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN c1 = t00(ix,jy,kz)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pn(ix,jy,kz) + pb(kz) - esbolton*tabqvs(ltemq)) ENDIF IF ( c1 > 0. ) THEN ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ENDIF ENDDO ENDDO jgs = jy if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' nxmpb = 1 nzmpb = 1 nxz = nxi*nz numgs = nxz/ngs + 1 do 2000 inumgs = 1,numgs ngscnt = 0 kzb = nzmpb kze = nz-kstag ixb = nxmpb ixe = itile do kz = kzb,kze do ix = nxmpb,nxi pres(1) = pn(ix,jy,kz) + pb(kz) pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) theta(1) = an(ix,jy,kz,lt) temg(1) = t0(ix,jy,kz) temcg(1) = temg(1) - tfr ltemq = (temg(1)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) ENDIF qis(1) = pqs(1)*tabqis(ltemq) qss(1) = qvs(1) if ( temg(1) .lt. tfr ) then end if if ( (temg(1) .gt. tfrh .or. an(ix,jy,kz,lv)/qvs(1) > maxlowtempss ) .and. & & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & & )) then ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz if ( ngscnt .eq. ngs ) goto 2100 end if end do nxmpb = 1 end do 2100 continue if ( ngscnt .eq. 0 ) go to 29998 if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' qx(:,:) = 0.0 cx(:,:) = 0.0 zx(:,:) = 0.0 xv(:,:) = 0.0 xmas(:,:) = 0.0 IF ( imurain == 1 ) THEN alpha(:,lr) = alphar ELSEIF ( imurain == 3 ) THEN alpha(:,lr) = xnu(lr) ENDIF DO mgs = 1,ngscnt qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) DO il = lc,lhab qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) ENDDO qcwtmp(mgs) = qx(mgs,lc) theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) thetap(mgs) = 0.0 theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) qv0(mgs) = qx(mgs,lv) qwvp(mgs) = qx(mgs,lv) - qv0(mgs) pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) rhovt(mgs) = Sqrt(rho00/rho0(mgs)) pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temcg(mgs) = temg(mgs) - tfr qss0(mgs) = (380.0)/(pres(mgs)) pqs(mgs) = (380.0)/(pres(mgs)) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) IF ( iqvsopt == 0 ) THEN es(mgs) = 6.1078e2*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN es(mgs) = esbolton*tabqvs(ltemq) ENDIF qss(mgs) = qvs(mgs) temgx(mgs) = min(temg(mgs),313.15) temgx(mgs) = max(temgx(mgs),233.15) felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) IF ( eqtset <= 1 ) THEN felvcp(mgs) = felv(mgs)*cpi ELSE 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)) & +cpigb*(tmp) rmm=rd+rw*qx(mgs,lv) IF ( eqtset == 2 ) THEN felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm ELSE felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm ENDIF ENDIF temcgx(mgs) = min(temg(mgs),273.15) temcgx(mgs) = max(temcgx(mgs),223.15) temcgx(mgs) = temcgx(mgs)-273.15 felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 fels(mgs) = felv(mgs) + felf(mgs) fcqv1(mgs) = 4098.0258*felv(mgs)*cpi wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & & (temg(mgs)/296.0)**(1.5) tka(mgs) = tka0*advisc(mgs)/advisc1 ENDDO if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) end do end if if ( ipconc .ge. 2 ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) cwnccn(mgs) = cwccn*rho0(mgs)/rho00 cn(mgs) = 0.0 IF ( lss > 1 ) THEN ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) ELSE ssmax(mgs) = 0.0 ENDIF 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) IF ( lccna > 1 ) THEN cnuc(mgs) = ccnc(mgs) ENDIF ENDIF IF ( lcn_nu > 1 ) THEN ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) ENDIF IF ( lcn_co > 1 ) THEN ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ENDIF IF ( lccnaco > 1 ) THEN ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) ELSE ccnaco(mgs) = 0.0 ENDIF IF ( lccnanu > 1 ) THEN ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) ELSE ccnanu(mgs) = 0.0 ENDIF ELSEIF ( lccn > 1 .and. ( ac_opt == 1 .or. ac_opt == 11 ) ) THEN ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) cnuc(mgs) = ccnc(mgs) cwnccn(mgs) = cnuc(mgs) ELSEIF ( lccn > 1 .and. ( ac_opt == 2 .or. ac_opt == 22 ) ) THEN ccnc_nu(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_nu) ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) ccnc_co(mgs) = an(igs(mgs),jy,kgs(mgs),lcn_co) ELSE ccnc(mgs) = cwnccn(mgs) ENDIF 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 ENDIF cnuf(mgs) = 0.0 IF ( lccna > 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) IF ( ac_opt == 22 ) THEN IF ( lccnaco > 1 ) THEN ccnaco(mgs) = an(igs(mgs),jy,kgs(mgs),lccnaco) ELSE ccnaco(mgs) = 0.0 ENDIF IF ( lccnanu > 1 ) THEN ccnanu(mgs) = an(igs(mgs),jy,kgs(mgs),lccnanu) ELSE ccnanu(mgs) = 0.0 ENDIF ENDIF ELSE IF ( lccn > 1 ) THEN ccna(mgs) = 0.0 ELSE ccna(mgs) = cx(mgs,lc) ENDIF ENDIF end do end if if ( ipconc .ge. 3 ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) end do end if DO mgs = 1,ngscnt IF ( irenuc /= 6 ) THEN IF ( irenuc == 2 ) THEN cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac ELSE cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + ccnc(mgs)*renucfrac ENDIF ELSE cnuc(mgs) = ccnc(mgs)*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac ENDIF IF ( renucfrac >= 0.999 ) THEN IF ( temg(mgs) < 265. ) THEN IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN cnuc(mgs) = 0.0 ELSE cnuc(mgs) = 0.1*cnuc(mgs) ENDIF ENDIF ENDIF ENDDO if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' do mgs = 1,ngscnt xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) end do ventrx(:) = ventr ventrxn(:) = ventrn IF ( lzr > 1 .and. rcond == 2 ) THEN DO mgs = 1,ngscnt zx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lzr), 0.0) ENDDO 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 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 ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN 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 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)) qr = qx(mgs,lr) nrx = cx(mgs,lr) z1 = zx(mgs,lr) IF ( z1 .gt. 0.0 ) THEN IF ( imurain == 3 ) THEN alp = 36.*(alpha(mgs,lr)+2.0)*nrx*vr**2/(z1*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/(z1*pi**2) - 1. alp = Max( rnumin, Min( rnumax, alp ) ) ENDDO 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) 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 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 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 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 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 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 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 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 ventrxn(mgs) = x/y ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ssmx = 0.0 DO mgs = 1,ngscnt kp1 = Min(nz, kgs(mgs)+1 ) wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & & +w(igs(mgs),jgs,kgs(mgs))) wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) ENDDO if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set cloud water variables' do mgs = 1,ngscnt xv(mgs,lc) = 0.0 IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSE IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & & xdn(mgs,lc)*xvmx(lc) ) cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. cxmin ) THEN cx(mgs,lc) = Max( cxmin, rho0(mgs)*qx(mgs,lc)/cwmasx ) xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSE xmas(mgs,lc) = cwmasn ENDIF ENDIF xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 end do do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) ) then if ( ipconc .ge. 3 ) then xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,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 xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) IF ( imurain == 3 ) THEN xdia(mgs,lr,1) = xdia(mgs,lr,3) ELSE xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) ENDIF ELSE xdia(mgs,lr,1) = & & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) end if else xdia(mgs,lr,1) = 1.e-9 end if end do do mgs = 1,ngscnt fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & & (temg(mgs)/296.0)**(1.5) fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & & (101325.0/(pres(mgs))) fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) end do DO mgs=1,ngscnt dcloud = 0.0 IF ( temg(mgs) .le. tfrh .and. qx(mgs,lv)/qvs(mgs) < maxlowtempss ) THEN CYCLE ENDIF IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & & (cp*(temg(mgs) - cbw)**2)) QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) IF ( qx(mgs,lc) <= QEVAP ) THEN qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) 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 ( lccna > 1 ) THEN tmp = restoreccnfrac*cx(mgs,lc) IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) IF ( tmp2 > 0.0 ) THEN ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 ENDIF ELSE ccna(mgs) = ccna(mgs) - tmp ENDIF 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. ELSE qctmp = qx(mgs,lc) qwvp(mgs) = qwvp(mgs) + QEVAP qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) THEN IF ( restoreccn ) THEN IF ( lccna > 1 ) THEN tmp = restoreccnfrac*cx(mgs,lc) IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) IF ( tmp2 > 0.0 ) THEN ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 ENDIF ELSE ccna(mgs) = ccna(mgs) - tmp ENDIF 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. ELSE tmp = 0.9*QEVAP*cx(mgs,lc)/qctmp IF ( restoreccn ) THEN IF ( lccna > 1 ) THEN tmp = restoreccnfrac*tmp IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN tmp2 = ccna(mgs) + ccnaco(mgs) + ccnanu(mgs) IF ( tmp2 > 0.0 ) THEN ccna(mgs) = ccna(mgs) - tmp*ccna(mgs)/tmp2 ccnaco(mgs) = ccnaco(mgs) - tmp*ccnaco(mgs)/tmp2 ccnanu(mgs) = ccnanu(mgs) - tmp*ccnanu(mgs)/tmp2 ENDIF ELSE ccna(mgs) = ccna(mgs) - tmp ENDIF ELSEIF ( irenuc <= 2 ) THEN IF ( .not. invertccn ) THEN ccnc(mgs) = Max( ccnc(mgs), Min( qccn*rho0(mgs), ccnc(mgs) + restoreccnfrac*tmp ) ) ELSE ccnc(mgs) = ccnc(mgs) + restoreccnfrac*tmp ENDIF ENDIF ENDIF cx(mgs,lc) = cx(mgs,lc) - tmp ENDIF 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 ENDIF GO TO 631 620 CONTINUE IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN IF ( ny .le. 2 ) THEN ENDIF IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN xmas(mgs,lc) = cwmasn xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 ENDIF d1 = (1./(ac1 + bc))*4.0*pi*ventc & & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) ELSE d1 = 0.0 ENDIF IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN IF ( imurain == 3 ) THEN IF ( izwisventr == 1 ) THEN rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) ELSE rwvent(mgs) = & & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & & *Sqrt((ar*rhovt(mgs))) & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) ENDIF ELSE IF ( iferwisventr == 1 ) THEN alpr = Min(alpharmax,alpha(mgs,lr) ) x = 1. + alpr tmp = 1 + alpr i = Int(dgami*(tmp)) del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 2.5 + alpr + 0.5*bx(lr) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) rwvent(mgs) = & & 0.78*x + & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) ELSEIF ( iferwisventr == 2 ) THEN x = 1. + alpha(mgs,lr) rwvent(mgs) = & & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & & *Sqrt((ar*rhovt(mgs))) & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) ENDIF ENDIF d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) ELSE d1r = 0.0 ENDIF e1 = felvcp(mgs)/(pi0(mgs)) f1 = pk(mgs) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) ltemq1 = ltemq temp1 = temg(mgs) IF ( iqvsopt == 0 ) THEN p380 = 380.0/pres(mgs) ELSE p380 = esbolton*rdorv/(pres(mgs) - es(mgs)) ENDIF ss1 = qx(mgs,lv)/qvs(mgs) ss2 = ss1 temp2 = temp1 qv1 = qx(mgs,lv) qvs1 = qvs(mgs) qis1 = qis(mgs) dt1 = 0.0 ltemq1 = ltemq IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) ELSE delta = 0.1*dtp ENDIF dtcon1 = Min(0.05,0.2*delta) nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) dtcon2 = (dtp-4.0*dtcon1)/nc n = 1 dt1 = 0.0 nc = 0 dqc = 0.0 dqr = 0.0 dqi = 0.0 dqs = 0.0 dqvii = 0.0 dqvis = 0.0 RK2c: DO WHILE ( dt1 .lt. dtp ) nc = 0 IF ( n .le. 4 ) THEN dtcon = dtcon1 ELSE dtcon = dtcon2 ENDIF 609 dqv = -(ss1 - 1.)*d1*dtcon dqvr = -(ss1 - 1.)*d1r*dtcon dtemp = -0.5*e1*f1*(dqv + dqvr) ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5 ltemq1m = Min( nqsat, Max(1,ltemq1m) ) IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN write(0,*) 'STOP in nucond line 1192 ' write(0,*) ' ltemq1m,icond = ',ltemq1m,icond write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 write(0,*) ' dqc, dqr = ',dqc,dqr write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta write(0,*) ' nc,dtp = ',nc,dtp write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 ENDIF dqvs = dtemp*p380*dtabqvs(ltemq1m) qv1m = qv1 + dqv + dqvr qvs1m = qvs1 + dqvs ss1m = qv1m/qvs1m IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN dtcon = (0.5*dtcon) IF ( dtcon .ge. dtcon1 ) THEN GOTO 609 ELSE EXIT ENDIF ENDIF dqv = -(ss1m - 1.)*d1*dtcon dqvr = -(ss1m - 1.)*d1r*dtcon dtemp = -e1*f1*(dqv + dqvr) ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5 ltemq1 = Min( nqsat, Max(1,ltemq1) ) IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN write(0,*) 'STOP in nucond line 1230 ' write(0,*) ' ltemq1m,icond = ',ltemq1m,icond write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr ENDIF dqvs = dtemp*p380*dtabqvs(ltemq1) qv1 = qv1 + dqv + dqvr dqc = dqc - dqv dqr = dqr - dqvr qvs1 = qvs1 + dqvs ss1 = qv1/qvs1 temp1 = temp1 + dtemp IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & & ss1 .eq. 1.00 .or. & & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN EXIT ELSE ss2 = ss1 temp2 = temp1 dt1 = dt1 + dtcon n = n + 1 ENDIF ENDDO RK2c dcloud = dqc thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) ENDIF IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp ENDIF qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) qx(mgs,lc) = qx(mgs,lc) + DCLOUD qx(mgs,lr) = qx(mgs,lr) + dqr 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) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF ENDIF ELSE IF ( ssf(mgs) .gt. 0.0 ) THEN IF ( iqcinit == 1 ) THEN qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) ELSEIF ( iqcinit == 3 ) THEN R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & & ((temg(mgs) - cbw)**2)) DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ELSEIF ( iqcinit == 2 ) THEN ssmx = ssmxinit IF ( ssf(mgs) > ssmx .and. ssf(mgs) < 20.0 .and. & ( ccnc(mgs) > 0.05*cwnccn(mgs) .or. ( ac_opt > 0 .and. ccnc(mgs) - cx(mgs,lc) > 0.0 ) ) ) THEN CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) ELSE dcloud = 0.0 ENDIF ENDIF 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 IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp ENDIF theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF cn(mgs) = 0.0 IF ( ncdebug .ge. 1 ) THEN write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) ENDIF IF ( .not. flag_qndrop ) THEN cnuctmp = cnuc(mgs) IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN CN(mgs) = CCNE0*cnuctmp**(2./(2.+cck))*wvel(mgs)**cnexp 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, & & wvel(mgs), dcloud*1.e3 IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & & igs(mgs),kgs(mgs),temcg(mgs), & & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) ENDIF IF ( iccwflg .eq. 1 ) THEN cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) ENDIF ELSE cn(mgs) = 0.0 dcloud = 0.0 ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN IF ( ac_opt == 0 ) THEN IF ( cn(mgs) .gt. ccnc(mgs) ) THEN cn(mgs) = ccnc(mgs) ENDIF ELSE cn(mgs) = Min( cn(mgs), ccnc(mgs) ) ENDIF IF ( irenuc <= 2 .and. lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN cx(mgs,lc) = 0. ELSE cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) ENDIF ENDIF GOTO 613 END IF IF ( wvel(mgs) .le. 0. ) GO TO 616 IF ( cx(mgs,lc) .le. 0. ) GO TO 613 IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & & (ssfkp1(mgs) .GE. SUPMX .OR. & & ssf(mgs) .GE. SUPMX .OR. & & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" DSSDZ=0. r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) IF ( irenuc >= 0 .and. ac_opt == 0 .and. .not. flag_qndrop ) THEN IF ( irenuc < 2 ) THEN IF ( kzend == nzend ) THEN t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) ELSE t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) ENDIF IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & & .and. ( ( lccn .lt. 1 .and. & & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & & ) THEN IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & & .and. ssf(mgs) .gt. 0.0 & & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & & .and. t0p3 .gt. 233.2) THEN DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & & .and. ssfkp1(mgs) .gt. 0.0 & & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & & .AND. ssf(mgs) .gt. ssfkm1(mgs) & & .and. t0p1 .gt. 233.2) THEN DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ENDIF ENDIF c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) IF ( lccn .lt. 1 ) THEN CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & & Max(0.0, & & (wvel(mgs)*DSSDZ) ) ELSE CN(mgs) = & & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & & Max(0.0, & & ( wvel(mgs)*DSSDZ) ) ) ENDIF IF ( cn(mgs) .gt. 0.0 ) THEN IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN cn(mgs) = 5.e7 ccnc(mgs) = 0.0 ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN cn(mgs) = ccnc(mgs) ccnc(mgs) = 0.0 ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF ELSEIF ( irenuc == 2 ) THEN CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) 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 write(0,*) 'wvel, cnuc, cn = ',wvel(mgs),cnuc(mgs),cn(mgs) write(0,*) 'ccne0,cnexp,cck = ',ccne0,cnexp,cck write(0,*) 'part1, part2 = ',CCNE0*cnuc(mgs)**(2./(2.+cck)), Max(0.0,wvel(mgs))**cnexp write(0,*) 'ccnc, dqc, dqc/cwmasn = ',ccnc(mgs), dqc, 0.5*dqc/cwmasn ENDIF IF ( icnuclimit > 0 ) THEN tmp = ccnc(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 ELSE ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 ENDIF cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) ENDIF cx(mgs,lc) = cx(mgs,lc) + cn(mgs) IF ( lccna < 1 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ELSEIF ( irenuc == 3 ) THEN temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) 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) ENDIF CN(mgs) = cnuc(mgs)*Min(1.0, (ssf(mgs))**cck ) CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) CN(mgs) = Min(cn(mgs), ccnc(mgs)) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ELSEIF ( irenuc == 4 ) THEN temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) 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) ) ELSE ssf(mgs) = 0.0 ENDIF CN(mgs) = cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + 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 ELSEIF ( irenuc == 6 ) THEN cn(mgs) = 0.0 IF ( ccna(mgs) < 0.7*cnuc(mgs) ) THEN CN(mgs) = Min( 0.9*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) CN(mgs) = Min( CN(mgs), Max(0.0, (0.7*cnuc(mgs) - ccna(mgs) )) ) ELSE temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) 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) ) ELSE ssf(mgs) = 0.0 ENDIF CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,ssf(mgs))**cck ) CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ENDIF IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + 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 ELSEIF ( irenuc == 5 ) THEN CN(mgs) = Min( cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) IF ( ccna(mgs) >= cnuc(mgs) ) THEN temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF IF ( c1 > 0. ) THEN ssf(mgs) = Max(0.0, 100.*((qv0(mgs) + qwvp(mgs))/c1 - 1.0) ) ELSE ssf(mgs) = 0.0 ENDIF CN(mgs) = Max( cn(mgs), cnuc(mgs)*Min(ssf2kmax, ssf(mgs)**cck) ) CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ELSE CN(mgs) = Min( cn(mgs), cnuc(mgs) - ccna(mgs) ) ENDIF dcrit = 2.0*2.0e-6 dcloud = 1000.*dcrit**3*Pi/6. tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) cn(mgs) = Min(tmp, cn(mgs) ) IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + cn(mgs) dcrit = 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 ELSEIF ( irenuc == 7 .or. irenuc == 17 ) THEN cn(mgs) = 0.0 IF ( irenuc == 7 ) THEN frac = 0.9 ELSE frac = 0.98 ENDIF IF ( ccna(mgs) < frac*cnuc(mgs) ) THEN CN(mgs) = Min( (frac+0.01)*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ) CN(mgs) = Min( CN(mgs), Max(0.0, (frac*cnuc(mgs) - ccna(mgs) )) ) ELSE temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF ssf(mgs) = 0.0 IF ( c1 > 0. ) THEN ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ENDIF IF ( ssf(mgs) <= 1.0 ) THEN CN(mgs) = cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ELSE CN(mgs) = cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) ENDIF 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 ) ENDIF CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ENDIF IF ( icnuclimit > 0 ) THEN tmp = ccnc(mgs) - ccna(mgs) + cx(mgs,lc) IF ( tmp < 330.34e6 ) THEN ccwmax = 1.1173e6 * (1.e-6*tmp)**0.9504 ELSE ccwmax = 21.57e6 * (1.e-6*tmp)**0.44 ENDIF cn(mgs) = Max( 0.0, Min( cn(mgs), ccwmax - cx(mgs,lc) ) ) ENDIF IF ( cn(mgs) + cnuf(mgs) > 0.0 ) THEN dcrit = 2.0*2.0e-6 dcloud = 1000.*dcrit**3*Pi/6. tmp = Max(0.0, rho0(mgs)*qx(mgs,lc)/dcloud - cx(mgs,lc)) cn(mgs) = Min(tmp, cn(mgs) ) cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + cnuf(mgs) dcrit = 2.0*2.5e-7 dcloud = 1000.*dcrit**3*Pi/6.*(cn(mgs) + cnuf(mgs) ) qx(mgs,lc) = qx(mgs,lc) + DCLOUD thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD ccncuf(mgs) = Max(0.0, ccncuf(mgs) - cnuf(mgs)) ENDIF ELSEIF ( irenuc == 8 ) THEN cn(mgs) = 0.0 IF ( ccnc(mgs) > 0. ) THEN CN(mgs) = CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp CN(mgs) = Min(cn(mgs), ccnc(mgs)) ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ltemq = Int( (temp1-163.15)/fqsat+1.5 ) ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN c1 = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN c1 = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF ssf(mgs) = 0.0 IF ( c1 > 0. ) THEN ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0) ENDIF IF ( ssf(mgs) <= 1.0 ) THEN CN(mgs) = 0.0 ELSE CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc) ENDIF ENDIF IF ( cn(mgs) > 0.0 ) THEN cx(mgs,lc) = cx(mgs,lc) + 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 ELSEIF ( irenuc == 9 .or. irenuc == 10 ) THEN write(0,*) 'irenuc=9 requires nuwrfmods=1' ELSEIF ( irenuc == 11 ) THEN write(0,*) 'irenuc=11 requires nuwrfmods=1' ENDIF ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF GO TO 631 613 CONTINUE 631 CONTINUE ssmx = maxsupersat qv1 = qv0(mgs) + qwvp(mgs) qvs1 = qvs(mgs) IF ( qv1 .gt. (ssmx*qvs1) ) THEN ss1 = qv1/qvs1 ssmx = 100.*(ssmx - 1.0) qvex = 0.0 CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) IF ( io_flag .and. nxtra > 1 ) THEN axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp ENDIF qwvp(mgs) = qwvp(mgs) - qvex qx(mgs,lc) = qx(mgs,lc) + qvex IF ( .not. flag_qndrop) THEN IF ( imaxsupopt == 1 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) ELSEIF ( imaxsupopt == 2 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas30,xmas(mgs,lc)) ) ) ELSEIF ( imaxsupopt == 3 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmasx,xmas(mgs,lc)) ) ) ELSEIF ( imaxsupopt == 4 ) THEN cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, Max(cwmas20,xmas(mgs,lc)) ) ) ENDIF 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 ENDIF ENDIF IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN tmp = cx(mgs,lc) xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) ENDIF ENDIF IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) ENDIF ENDDO DO mgs=1,ngscnt IF ( lss > 1 .and. ssf(mgs) .gt. ssmax(mgs) & & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN ssmax(mgs) = ssf(mgs) ENDIF ENDDO do mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) IF ( eqtset > 2 ) THEN p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) ENDIF if ( ido(lc) .eq. 1 ) then an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) end if if ( ido(lr) .eq. 1 .and. rcond == 2 ) then an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) 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 ( 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 ELSEIF ( ac_opt == 1 .and. lccn > 1) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) ELSEIF ( ac_opt == 11 .and. lccna > 1) THEN ELSEIF ( ac_opt == 2 .and. lccn > 1) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max( 0.0, ccnc(mgs) ) an(igs(mgs),jy,kgs(mgs),lcn_nu) = Max( 0.0, ccnc_nu(mgs) ) an(igs(mgs),jy,kgs(mgs),lcn_co) = Max( 0.0, ccnc_co(mgs) ) ELSEIF ( ac_opt == 22 .and. lccna > 1) THEN an(igs(mgs),jy,kgs(mgs),lccnanu) = Max( 0.0, ccnanu(mgs) ) an(igs(mgs),jy,kgs(mgs),lccnaco) = Max( 0.0, ccnaco(mgs) ) ENDIF 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 an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) ) ENDIF ENDIF IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) ENDIF end do 29998 continue if ( kz .gt. nz-1 .and. ix .ge. nxi) then if ( ix .ge. nxi ) then go to 2200 else nzmpb = kz endif else nzmpb = kz end if if ( ix .ge. nxi ) then nxmpb = 1 nzmpb = kz+1 else nxmpb = ix+1 end if 2000 continue 2200 continue 9999 RETURN END SUBROUTINE NUCOND subroutine smallvalues & & (nx,ny,nz,na,jyslab & & ,nor,norz,dtp,nxi & & ,t0 & & ,an,dn, w & & ,t77,flag_qndrop & & ) implicit none integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab real :: dtp logical,intent(in) :: flag_qndrop real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) 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 w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) logical zerocx(lc:lqmx) real :: frac, hwdn, tmpg, xdia1, xdia3, cwch,xvol integer ix,kz,i,n, km1 integer :: il integer :: jy, jgs real :: chw, g1, z1, tmp, tmp2, fw, tmpmx, qr jy = 1 frac = 1.0 cwch = ((3. + alphah)*(2. + alphah)*(1.0 + alphah))**(-1./3.) do kz = 1,nz do ix = 1,nxi t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz) zerocx(:) = .false. DO il = lc,lhab IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. (an(ix,jy,kz,lz(il)) < zxmin) ) ELSE IF ( il == lc ) THEN IF ( ln(il) > 1 ) THEN zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) .and. .not. flag_qndrop ENDIF ELSE IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0.0 ) ENDIF ENDIF ENDDO 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 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 ENDIF ENDIF ENDIF if ( (an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl)) .or. zerocx(lhl) ) then an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) an(ix,jy,kz,lhl) = 0.0 IF ( ipconc .ge. 5 ) THEN an(ix,jy,kz,lnhl) = 0.0 ENDIF IF ( lvhl .gt. 1 ) THEN an(ix,jy,kz,lvhl) = 0.0 ENDIF IF ( lhlw .gt. 1 ) THEN an(ix,jy,kz,lhlw) = 0.0 ENDIF IF ( lnhlf .gt. 1 ) THEN an(ix,jy,kz,lnhlf) = 0.0 ENDIF IF ( lzhl .gt. 1 ) THEN an(ix,jy,kz,lzhl) = 0.0 ENDIF ELSE IF ( lvol(lhl) .gt. 1 ) THEN IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) ELSE tmp = rho_qhl an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF IF ( tmp .lt. xdnmn(lhl) ) THEN tmp = Max( xdnmn(lhl), tmp ) an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN tmp = Min( xdnmx(lhl), tmp ) an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) IF ( tmp .gt. tmpmx ) THEN an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx ENDIF ENDIF IF ( lhlw .gt. 1 ) THEN IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN tmp = xdnmx(lr) an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF ENDIF ENDIF 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 IF ( ipconc >= 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) THEN qr = an(ix,jy,kz,lhl) xvol = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(hwdn*an(ix,jy,kz,lnhl)) chw = an(ix,jy,kz,lnhl) IF ( xvol .lt. xvmn(lhl) .or. xvol .gt. xvmx(lhl) ) THEN xvol = Min( xvmx(lhl), Max( xvmn(lhl),xvol ) ) chw = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvol*hwdn) an(ix,jy,kz,lnhl) = chw ENDIF ENDIF IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN IF ( lvhl .gt. 1 ) THEN hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) ELSE hwdn = xdn0(lhl) ENDIF tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) tmpg = an(ix,jy,kz,lnhl)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohlmn ) THEN tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*pi)**(1./3.) an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) ENDIF ENDIF end if ENDIF 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 ENDIF ENDIF ENDIF if ( (an(ix,jy,kz,lh) .lt. frac*qxmin(lh)) .or. zerocx(lh) ) then an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) an(ix,jy,kz,lh) = 0.0 IF ( ipconc .ge. 5 ) THEN an(ix,jy,kz,lnh) = 0.0 ENDIF IF ( lvh .gt. 1 ) THEN an(ix,jy,kz,lvh) = 0.0 ENDIF IF ( lhw .gt. 1 ) THEN an(ix,jy,kz,lhw) = 0.0 ENDIF IF ( lnhf .gt. 1 ) THEN an(ix,jy,kz,lnhf) = 0.0 ENDIF IF ( lzh .gt. 1 ) THEN an(ix,jy,kz,lzh) = 0.0 ENDIF ELSE IF ( lvol(lh) .gt. 1 ) THEN IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) ELSE tmp = rho_qh an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ENDIF IF ( tmp .lt. xdnmn(lh) ) THEN tmp = Max( xdnmn(lh), tmp ) an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ENDIF IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN tmp = Min( xdnmx(lh), tmp ) an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) IF ( tmp .gt. tmpmx ) THEN an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx ENDIF ENDIF IF ( lhw .gt. 1 ) THEN IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN tmp = xdnmx(lr) an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ENDIF ENDIF ENDIF 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 IF ( ipconc >= 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) ) THEN qr = an(ix,jy,kz,lh) xvol = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*an(ix,jy,kz,lnh)) chw = an(ix,jy,kz,lnh) IF ( xvol .lt. xvmn(lh) .or. xvol .gt. xvmx(lh) ) THEN xvol = Min( xvmx(lh), Max( xvmn(lh),xvol ) ) chw = dn(ix,jy,kz)*an(ix,jy,kz,lh)/(xvol*hwdn) an(ix,jy,kz,lnh) = chw ENDIF ENDIF IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) tmpg = an(ix,jy,kz,lnh)*(tmp*pi)**(1./3.) IF ( tmpg .lt. cnohmn ) THEN tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*pi)**(1./3.) an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) ENDIF ENDIF IF ( ipconc == 5 .and. imorrgdnglimit == 1 ) THEN xdia3 = (xvol*6.*piinv)**(1./3.) xdia1 = cwch*xdia3 IF ( xdia1 > morrdnglimit ) THEN xdia1 = morrdnglimit xvol = pi/6.0*(xdia1/cwch)**3 chw = dn(ix,jy,kz)*qr/(xvol*hwdn) an(ix,jy,kz,lnh) = chw xdia3 = (xvol*6.*piinv)**(1./3.) ENDIF ENDIF end if if ( (an(ix,jy,kz,ls) .lt. frac*qxmin(ls)) .or. zerocx(ls) ) then IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,ls) = 0.0 IF ( ipconc .ge. 4 ) THEN an(ix,jy,kz,lns) = 0.0 ENDIF IF ( lvs .gt. 1 ) THEN an(ix,jy,kz,lvs) = 0.0 ENDIF IF ( lsw .gt. 1 ) THEN an(ix,jy,kz,lsw) = 0.0 ENDIF ELSE an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) an(ix,jy,kz,ls) = 0.0 IF ( lvs .gt. 1 ) THEN an(ix,jy,kz,lvs) = 0.0 ENDIF IF ( lsw .gt. 1 ) THEN an(ix,jy,kz,lsw) = 0.0 ENDIF IF ( ipconc .ge. 4 ) THEN an(ix,jy,kz,lns) = 0.0 ENDIF ENDIF ELSEIF ( lvol(ls) .gt. 1 ) THEN IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp ENDIF ELSE tmp = rho_qs an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp ENDIF 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 an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) an(ix,jy,kz,lr) = 0.0 IF ( ipconc .ge. 3 ) THEN an(ix,jy,kz,lnr) = 0.0 ENDIF IF ( lzr > 1 ) THEN an(ix,jy,kz,lzr) = 0.0 ENDIF end if IF ( (an(ix,jy,kz,li) .le. frac*qxmin(li)) .or. zerocx(li) ) THEN an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) an(ix,jy,kz,li)= 0.0 IF ( ipconc .ge. 1 ) THEN an(ix,jy,kz,lni) = 0.0 ENDIF ENDIF IF ( (an(ix,jy,kz,lc) .le. frac*qxmin(lc)) .or. zerocx(lc) ) THEN 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 .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)) ELSEIF ( lccn > 1 ) THEN an(ix,jy,kz,lccn) = an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) ENDIF ELSEIF ( lccna > 1 ) THEN tmp = Max(0.0,an(ix,jy,kz,lnc)) IF ( lccnaco > 1 .and. lccnanu > 1 ) THEN tmp2 = an(ix,jy,kz,lccna) + an(ix,jy,kz,lccnaco) + an(ix,jy,kz,lccnanu) IF ( tmp2 > 0.0 .and. tmp > 0.0 ) THEN an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp*an(ix,jy,kz,lccna)/tmp2 ) an(ix,jy,kz,lccnaco) = Max( 0.0, an(ix,jy,kz,lccnaco) - tmp*an(ix,jy,kz,lccnaco)/tmp2 ) an(ix,jy,kz,lccnanu) = Max( 0.0, an(ix,jy,kz,lccnanu) - tmp*an(ix,jy,kz,lccnanu)/tmp2 ) ENDIF ELSE an(ix,jy,kz,lccna) = Max( 0.0, an(ix,jy,kz,lccna) - tmp ) ENDIF 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 IF ( restoreccn ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( tmp < qxmin(li) ) THEN IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst) IF ( lccnaco > 1 ) an(ix,jy,kz,lccnaco) = an(ix,jy,kz,lccnaco)*Exp(-dtp/ccntimeconst) IF ( lccnanu > 1 ) an(ix,jy,kz,lccnanu) = an(ix,jy,kz,lccnanu)*Exp(-dtp/ccntimeconst) ENDIF ENDIF ELSEIF ( lccn > 1 .and. restoreccn .and. ac_opt == 0 ) THEN tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls) IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) .and. & ( an(ix,jy,kz,lccn) < dn(ix,jy,kz)*qccn .or. .not. invertccn ) ) THEN an(ix,jy,kz,lccn) = & dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst) ENDIF ENDIF ENDIF ENDIF end do end do end subroutine smallvalues subroutine nssl_2mom_gs & & (nx,ny,nz,na,jyslab & & ,nor,norz & & ,dtp,gz & & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & & ,an,dn,p2 & & ,pn,w,iunit & & ,t00,t77, & & ventr,ventc,c1sw,jgs,ido, & & xdnmx,xdnmn, & & cdx, & & xdn0,tmp3d,tkediss & & ,thproc,numproc,dx1,dy1,ngs & & ,timevtcalc,axtra,io_flag & & , has_wetscav,rainprod2d, evapprod2d, alpha2d & & ,elec,its,ids,ide,jds,jde & & ) implicit none integer, parameter :: ng1 = 1 integer nx,ny,nz,na,nba,nv integer nor,norz,istag,jstag,kstag integer iwrite real dtp,dx,dy,dz logical, intent(in) :: io_flag integer itile,jtile,ktile integer ixbeg,jybeg integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg integer :: my_rank = 0 integer, parameter :: myprock = 1, nprock = 1 logical, intent(in) :: has_wetscav integer, intent(in) :: numproc real, intent(inout) :: thproc(nz,numproc) real, intent(in) :: dx1,dy1 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) real :: galpharaut real :: xvbarmax integer jyslab,its,ids,ide,jds,jde integer, intent(in) :: iunit real qvex integer iraincv, icgxconv parameter ( iraincv = 1, icgxconv = 1) real ffrz real :: ffrzh = 1.0 real qcitmp,cirdiatmp real ccwtmp,ccitmp real cpqc,cpci real cpqc0,cpci0 real scfac double precision dp1 double precision frac, frach, xvfrz, xvbiggsnow double precision :: timevtcalc double precision :: dpt1,dpt2 logical, parameter :: gammacheck = .false. integer :: luindex double precision :: tmpgam logical, parameter :: usegamxinfcnu = .false. logical, parameter :: usegamxinf = .false. logical, parameter :: usegamxinf2 = .false. logical, parameter :: usegamxinf3 = .false. real vtmax integer n,ndfall double precision chgneg,chgpos,sctot real temgtmp real pb(-norz+ng1:nz+norz) real pinit(-norz+ng1:nz+norz) real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real qimax,xni0,roqi0 real dv real dtptmp integer itest,nidx,id1,jd1,kd1 parameter (itest=1) parameter (nidx=10) parameter (id1=1,jd1=1,kd1=1) integer ierr integer iend integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 integer :: jy integer i,j,k,i1 integer kzb,kze real slope1, slope2 real x1, x2, x3, y1 real eps,eps2 parameter (eps=1.e-20,eps2=1.e-5) real temele real trev logical ldovol, ishail, ltest, wtest logical , parameter :: alp0flag = .false. integer mu,mv,mw parameter (mu=1,mv=2,mw=3) integer mqcw,mqxw,mtem,mrho,mtim parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) parameter (xftem=0.5,yftem=1.) parameter (xfqcw=2000.,yfqcw=1.) parameter (xfqxw=2000.,yfqxw=1.) real dtfac parameter ( dtfac = 1.0 ) integer ido(lc:lqmx) real delqnxa(lc:lqmx) real delqxxa(lc:lqmx) real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) integer nxmpb,nzmpb,nxz integer jgs,mgs,ngs,numgs integer, parameter :: ngsz = 500 integer ntt parameter (ntt=300) real dvmgs(ngs) integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) integer ncuse parameter (ncuse=0) integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) real tdtol,temsav,tfrcbw,tfrcbi real, parameter :: thnuc = 235.15 real fimt1(ngs),fimta(ngs),fimt2(ngs) real xcwmas real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) real cwnccn(ngs) real sscb parameter ( sscb = 2.0 ) integer idecss parameter ( idecss = 1 ) integer iba parameter (iba = 1) integer ifilt parameter ( ifilt = 0 ) real temp1,temp2 real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam real, parameter :: shedalp = 3. real ssmax(ngs) real ssmx real dnnet,dqnet real bfnu, bfnu0, bfnu1 parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) real ventr, ventc real volb double precision t2s, xdp double precision xl2p(ngs),rb(ngs) real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 real, parameter :: cexs = 0.1, cecs = 0.5 real, parameter :: rvt = 0.104 real, parameter :: kfrag = 1.0e-6 real, parameter :: mfrag = 1.0e-10 double precision cautn(ngs), rh(ngs), nh(ngs) real ex1, ft, rhoinv(ngs) real :: ec0(ngs) real ac1,bc, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,temp3 real :: flim, xmass real dw,dwr double precision :: tmpz, tmpzmlt real :: tmpc real ratio, delx, dely real dbigg,volt real chgtmp,fac,mixedphasefac real x,y,y2,del,r,rtmp,alpr double precision :: vent1,vent2 double precision :: g1palp,g4palp double precision :: g1palpinf,g4palpinf real fqt real bs real v1, v2 real d1r, d1i, d1s, e1i real c1sw real, parameter :: vr1mm = 5.23599e-10 real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) real rhosm parameter ( rhosm = 500. ) integer nc real dtcon,dtcon1,dtcon2 real delta integer ltemq1,ltemq1m real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 real dqvr, dqc, dqr, dqi, dqs real qv1m,qvs1m,ss1m,ssi1m,qis1m real cwmastmp real dcloud,dcloud2 real cn(ngs) double precision xvc, xvr real mwfac real rwmasn,rwmasx real vgra,vfrz parameter ( vgra = 0.523599*(1.0e-3)**3 ) real :: d, dold, denom,denominv,vth double precision :: h1, h2, h3, h4,denomdp, denominvdp real r1,qevap real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia,rmas real :: snowmeltmass = 0 real, parameter :: rimedens = 500. real raero,kaero parameter ( raero = 3.e-7, kaero = 5.39e-3 ) real kb parameter (kb = 1.3807e-23) real knud(ngs),knuda(ngs) real gtp(ngs) real dfar(ngs) real fn1(ngs),fn2(ngs),fnft(ngs) real ccia(ngs) real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) real ni,nis,nr,d0 real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs),dqcitmp(ngs),dqwvtmp(ngs) real tempc(ngs) real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) real temgkm1(ngs), temgkm2(ngs) 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),ssi0(ngs) real qcwtmp(ngs),qtmp,qtot(ngs) real qcond(ngs) real ctmp, sctmp real cimasn,cimasx,ccimx real pid4 real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 real gcnup1,gcnup2 real gf73rds, gf83rds real gamice73fac, gamsnow73fac real gf43rds, gf53rds real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn 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) real fwet1(ngs),fwet2(ngs) real fmlt1(ngs),fmlt2(ngs),fmlt1e(ngs) real fvds(ngs),fvce(ngs),fiinit(ngs) real fvent(ngs),fraci(ngs),fracl(ngs) real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) real felv(ngs),fels(ngs),felf(ngs) real felvcp(ngs),felscp(ngs),felfcp(ngs) real felvpi(ngs),felspi(ngs),felfpi(ngs) real felvs(ngs),felss(ngs) real fwvdf(ngs),ftka(ngs),fthdf(ngs) real fadvisc(ngs),fakvisc(ngs) real fci(ngs),fcw(ngs) real fschm(ngs),fpndl(ngs) real fgamw(ngs),fgams(ngs) real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) real cvm,cpm,rmm real, parameter :: cpv = 1885.0 real fcci(ngs), fcip(ngs) 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) logical :: wetgrowth(ngs), wetgrowthhl(ngs), wetgrowthf(ngs) real qitmp(ngs),qistmp(ngs) real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs), rzxhlf(ngs) real rzxs(ngs), rzxf(ngs) real cdh(ngs),cdhl(ngs) real :: axx(ngs,lh:lhab),bxx(ngs,lh:lhab) real vt2ave(ngs) real :: qcwresv(ngs), ccwresv(ngs) real :: lfsave(ngs,6) real :: qx(ngs,lv:lhab) real :: qxw(ngs,ls:lhab) real :: qxwlg(ngs,lh:lhab) real :: chxf(ngs,lh:lhab) real :: cx(ngs,lc:lhab) real :: cxmxd(ngs,lc:lhab) real :: qxmxd(ngs,lv:lhab) real :: scx(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 :: xdntmp(ngs,lc:lhab) real :: cdxgs(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vtwtdia(ngs,lr:lhab) real :: rarx(ngs,ls:lhab) real :: vx(ngs,li:lhab) real :: rimdn(ngs,li:lhab) real :: raindn(ngs,li:lhab) 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 :: g1xmax,g1xmin real :: qsimxdep(ngs) real :: qsimxsub(ngs) logical,parameter :: DoSublimationFix = .true. real :: qrtmp(ngs),qvtmp(ngs),qctmp(ngs) real :: felvcptmp,felscptmp,qsstmp real :: thetatmp, thetaptmp, temcgtmp,qvaptmp real :: qvstmp, qisstmp, qvptmp, qitmp1, qctmp1 real :: galphrout real ventrx(ngs) real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr real g1smlr, alphasmlr real massfacshr, massfacmlr real :: qhgt8mm real :: qhwgt8mm real :: qhgt10mm real :: qhgt20mm real :: fwmhtmp real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) real, parameter :: srasheym = 0.1389 real :: dtmp 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 real hwvent1,hlvent1 real hwvent2,hlvent2 real gama0,gamb0 real gama1,gamb1 real gama2,gamb2 real :: mltdiam(ndiam+4) real mltmass0inv,mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs,mltmass3inv, mltmass3cgs real qhmlr0, qhmlr05, qhmlr1, qhmlr2,qhmlr3, qhmlr12, qhmlr23 real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2,qhlmlr3, qhlmlr12, qhlmlr23 real qxd1, cxd1, zxd1 real qxd05, cxd05 real :: qrbreak, crbreaksmall, crbreak, zrbreak, breakbin real :: qxd(ndiam+4), cxd(ndiam+4), qhml(ndiam+4), qhml0(ndiam+4) real :: dqxd(ndiam+4), dcxd(ndiam+4), dqhml(ndiam+4) real civent(ngs) real isvent(ngs) real xmascw(ngs) real xdnmx(lc:lhab), xdnmn(lc:lhab) real dnmx real :: xdiamxmas(ngs,lc:lhab) real cilen(ngs) real rwcap(ngs),swcap(ngs) real hwcap(ngs) real hlcap(ngs) real cicap(ngs) real iscap(ngs) real qvimxd(ngs) real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) real cionpmxd(ngs),cionnmxd(ngs) real clionpmxd(ngs),clionnmxd(ngs) real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) real csplinter(ngs),qsplinter(ngs) real csplinter2(ngs),qsplinter2(ngs) real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) real :: chlcnhhl(ngs) real cracif(ngs), ciacrf(ngs) real cracr(ngs) real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) real cicint(ngs) real cipint(ngs) real ciacw(ngs), cwacii(ngs) real ciacr(ngs), craci(ngs) real csacw(ngs) real csacr(ngs) real csaci(ngs), csacs(ngs) real cracw(ngs) real chacw(ngs), chacr(ngs) real :: chlacw(ngs) real chaci(ngs), chacs(ngs) real :: chlacr(ngs) real :: chlaci(ngs), chlacs(ngs) real crcnw(ngs) real cidpv(ngs),cisbv(ngs) real cisdpv(ngs),cissbv(ngs) real cimlr(ngs),cismlr(ngs) real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) real chlfmlr(ngs) real chlshr(ngs), chlshrr(ngs) real chdpv(ngs),chsbv(ngs) real chmlr(ngs),chcev(ngs) real chmlrr(ngs) real chshr(ngs), chshrr(ngs) real csdpv(ngs),cssbv(ngs) real csmlr(ngs),csmlrr(ngs),cscev(ngs) real csshr(ngs), csshrr(ngs) real crcev(ngs) real crshr(ngs) real cwshw(ngs), qwshw(ngs) real qrcnw(ngs), qwcnr(ngs) real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) real qracw(ngs) real qiacw(ngs) real qsacw(ngs) real qhacw(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) real qsacr(ngs),qracs(ngs) real qhacr(ngs),qhacrmlr(ngs),qhacwmlr(ngs) real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) real qiacr(ngs),qraci(ngs) real ziacr(ngs) real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) real :: qhlacr(ngs),qhlacrmlr(ngs), qhlacwmlr(ngs) real qsacrs(ngs) real qsaci(ngs) real qsacis(ngs) real csacis(ngs) real qhaci(ngs) real qhacs(ngs) real :: qhacis(ngs) real :: chacis(ngs) real :: chacis0(ngs) real :: csaci0(ngs) real :: csacis0(ngs) real :: chaci0(ngs) real :: chacs0(ngs) real :: chlaci0(ngs) real :: chlacis(ngs) real :: chlacis0(ngs) real :: chlacs0(ngs) real :: qsaci0(ngs) real :: qsacis0(ngs) real :: qhaci0(ngs) real :: qhacis0(ngs) real :: qhacs0(ngs) real :: qhlaci0(ngs) real :: qhlacis0(ngs) real :: qhlacs0(ngs) real :: qhlaci(ngs) real :: qhlacis(ngs) real :: qhlacs(ngs) real qrfrz(ngs) real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) real zfacw(ngs), zfacs(ngs), zfaci(ngs) 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 zsmlrr(ngs), zsshr(ngs), zsshrr(ngs) real zhcns(ngs), zhcni(ngs) real zhwdn(ngs), zfwdn(ngs) real zhldn(ngs) real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) real vrfrzf(ngs), viacrf(ngs) real qrfrzs(ngs), qrfrzf(ngs) real qwfrz(ngs), qwctfz(ngs) real cwfrz(ngs), cwctfz(ngs) real qwfrzis(ngs), qwctfzis(ngs) real cwfrzis(ngs), cwctfzis(ngs) real qwfrzc(ngs), qwctfzc(ngs) real cwfrzc(ngs), cwctfzc(ngs) real qwfrzp(ngs), qwctfzp(ngs) real cwfrzp(ngs), cwctfzp(ngs) real xcolmn(ngs), xplate(ngs) real ciihr(ngs), qiihr(ngs) real cicichr(ngs), qicichr(ngs) real cipiphr(ngs), qipiphr(ngs) real qscni(ngs), cscni(ngs), cscnis(ngs) real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) real qscnh(ngs), cscnh(ngs), vscnh(ngs) real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) real qiint(ngs),qipipnt(ngs),qicicnt(ngs) real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) real tke(ngs) real uvel(ngs),vvel(ngs) real qidpv(ngs),qisbv(ngs) real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) real qismlr(ngs) real :: qhldpv(ngs), qhlsbv(ngs) real :: qhlmlr(ngs), qhldsv(ngs), qhlmlrsave(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) real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) real qhlcev(ngs), chlcev(ngs) real qhwet(ngs),qhdry(ngs),qhshr(ngs) real qhshrp(ngs) real qhshh(ngs) real qhmlh(ngs) real qhfzh(ngs) real qffzf(ngs) real qhlfzhl(ngs) real qhmlrlg(ngs),qhlmlrlg(ngs) real qhfzhlg(ngs) real qhlfzhllg(ngs) real qhlcevlg(ngs), chlcevlg(ngs) real qhcevlg(ngs), chcevlg(ngs) real vhfzh(ngs), vffzf(ngs) real vhlfzhl(ngs) real vhshdr(ngs) real vhlshdr(ngs) real vhmlr(ngs) real vhlmlr(ngs) real vhsoak(ngs) real vhlsoak(ngs) real qsdpv(ngs),qssbv(ngs) real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) real qswet(ngs),qsdry(ngs),qsshr(ngs) real qsshrp(ngs) real qsfzs(ngs) real qipdpv(ngs),qipsbv(ngs) real qipmlr(ngs),qipdsv(ngs) real qirdpv(ngs),qirsbv(ngs) real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) real qgldpv(ngs),qglsbv(ngs) real qglmlr(ngs),qgldsv(ngs) real qglwet(ngs),qgldry(ngs),qglshr(ngs) real qglshrp(ngs) real qgmdpv(ngs),qgmsbv(ngs) real qgmmlr(ngs),qgmdsv(ngs) real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) real qgmshrp(ngs) real qghdpv(ngs),qghsbv(ngs) real qghmlr(ngs),qghdsv(ngs) real qghwet(ngs),qghdry(ngs),qghshr(ngs) real qghshrp(ngs) real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) real qrcev(ngs) real qrshr(ngs) real fsw(ngs),fhw(ngs),fhlw(ngs),ffw(ngs) real fswmax(ngs),fhwmax(ngs),fhlwmax(ngs) real ffwmax(ngs) real qhcnf(ngs) real :: qhlcnh(ngs) real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) real ehxr(ngs),ehlr(ngs),egmr(ngs) real eri(ngs),esi(ngs),esis(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),ehsfac(ngs) real ehscnv(ngs) real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs) real efsclsn(ngs),eficlsn(ngs),efisclsn(ngs) real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs) real esiclsn(ngs),esisclsn(ngs) real :: ehs_collsn = 0.5, ehi_collsn = 1.0 real :: efs_collsn = 0.5, efi_collsn = 1.0 real :: ehls_collsn = 1.0, ehli_collsn = 1.0 real :: esi_collsn = 1.0 real ew(8,6) real cwr(8,2) data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs), ifwr(ngs) real grad(6,2) data grad / 100., 200., 300., 400., 600., 1000., & & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / real da0lr(ngs),da1lr(ngs) real da0lc(ngs),da1lc(ngs) real da0lh(ngs) real da0lhl(ngs) real da0lf(ngs) real :: da0lx(ngs,lr:lhab) real va0 (lc:lqmx) real vab0(lc:lqmx,lc:lqmx) real vab1(lc:lqmx,lc:lqmx) real va1 (lc:lqmx) real ehip(ngs),ehlip(ngs),ehlir(ngs) real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) real ptotal(ngs) real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) real pqiri(ngs),pqipi(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) real pvhli(ngs), pvhld(ngs) real pvswi(ngs), pvswd(ngs) real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs), pqcwdacc(ngs) real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) real pqird(ngs),pqipd(ngs) real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs),pqlwfd(ngs) real pctot(ngs) real pcipi(ngs), pcipd(ngs) real pciri(ngs), pcird(ngs) real pccwi(ngs), pccwd(ngs), pccwdacc(ngs) real pccii(ngs), pccid(ngs) real pcisi(ngs), pcisd(ngs) real pccin(ngs) real pcrwi(ngs), pcrwd(ngs) real pcswi(ngs), pcswd(ngs) real pchwi(ngs), pchwd(ngs) real pchli(ngs), pchld(ngs) real pcfwi(ngs), pcfwd(ngs) real pcgli(ngs), pcgld(ngs) real pcgmi(ngs), pcgmd(ngs) real pcghi(ngs), pcghd(ngs) real pzrwi(ngs), pzrwd(ngs) real pzhwi(ngs), pzhwd(ngs) real pzfwi(ngs), pzfwd(ngs) real pzhli(ngs), pzhld(ngs) real pzswi(ngs), pzswd(ngs) real dqisdt(ngs) real qss0(ngs) real qsacip(ngs) real pres(ngs),pipert(ngs) real pk(ngs) real rho0(ngs),pi0(ngs) real rhovt(ngs),sqrtrhovt real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) real thsave(ngs) real ptwfzi(ngs),ptimlw(ngs) real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs),ptem2(ngs) real cnostmp(ngs) integer iholef integer iholen parameter (iholef = 1) parameter (iholen = 1) real cqtotn,cqtotn1 real cctotn real citotn real crtotn real cstotn real cvtotn real cftotn real cgltotn real cghtotn real chtotn real cqtotp,cqtotp1 real cctotp real citotp real ciptotp real crtotp real cstotp real cvtotp real cftotp real chltotp real cgltotp real cgmtotp real cghtotp real chtotp real cqfac real ccfac real cifac real cipfac real crfac real csfac real cvfac real cffac real cglfac real cghfac real chfac real ssifac, qvapor real, parameter :: cwmas30 = 1000.*0.523599*(2.*30.e-6)**3 real, parameter :: cwmas20 = 1000.*0.523599*(2.*20.e-6)**3 integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh integer lqrw real vt real arg real erbnd1, fdgt1, costhe1 real qeps real dyi2,dzi2,bta1,cnit,dragh,dnz00,pii real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds real gf1palp(ngs) real xdn0(lc:lhab) real xdn_new,drhodt integer l ,ltemq,inumgs, idelq real brz,arz,temq real ssival,tqvcon real cdx(lc:lhab) real cnox real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq,elecfac,altelecfac real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw real c4,bradp,bl2,bt2,dthr,hrifac, hdia0,hdia1,civenta,civentb real civentc,civentd,civente,civentf,civentg,cireyn,xcivent real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa real cirventb integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc real hwventa,hwventb real hwventc, hlventa, hlventb, hlventc real glventa, glventb, glventc real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc real dzfacp, dzfacm, cmassin, cwdiar real rimmas, rhobar real argtim, argqcw, argqxw, argtem real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw real frcswrsw1 real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw real frcrswsw1 real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 real frcrglgl real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 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 real gamss real cdw, cdi, denom1, denom2, delqci1, delqip1 real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp real cgmfac, chlfac, cirfac integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb integer igmgha, igmghb integer idqis, item, itim0 integer iqgl, iqgm, iqgh, iqrw, iqsw integer itertd, ia integer :: infdo real tau, ewtmp integer cntnic_noliq real q_noliqmn, q_noliqmx real scsacimn, scsacimx real :: dtpinv real :: xden,xmlt,cmlt,cmlttot,fventm,fventh,am,ah,felfinv,dmwdt real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt real :: term1,term2,term3,term4 real :: qaacw real :: cwchtmp real, parameter :: c1r=19.0, c2r=0.6, c3r=1.8, c4r=17.0 real, parameter :: c1h=5.5, c2h=0.7, c3h=4.5, c4h=8.5 real, parameter :: c1hl=3.7, c2hl=0.3, c3hl=9.0, c4hl=6.5, c5hl=1.0, c6hl=6.5 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) pb(:) = 0.0 pinit(:) = 0.0 itile = nx jtile = ny ktile = nz ixend = nx jyend = ny kzend = nz nxend = nx + 1 nyend = ny + 1 nzend = nz kzbeg = 1 nzbeg = 1 istag = 0 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 IF ( ngs .lt. nz ) THEN ENDIF cntnic_noliq = 0 q_noliqmn = 0.0 q_noliqmx = 0.0 scsacimn = 0.0 scsacimx = 0.0 ldovol = .false. DO il = lc,lhab ldovol = ldovol .or. ( lvol(il) .gt. 1 ) ENDDO ffrzh = 1 dtpinv = 1.d0/dtp qeps = 1.0e-20 aradcw = -0.27544 bradcw = 0.26249e+06 cradcw = -1.8896e+10 dradcw = 4.4626e+14 bta1 = 0.6 cnit = 1.0e-02 dragh = 0.60 dnz00 = 1.225 cs = 12.42 ds = 0.42 pii = piinv pid4 = pi/4.0 gf1 = 1.0 gf1p5 = 0.8862269255 gf2 = 1.0 gf3 = 2.0 gf3p5 = 3.32335097 gf4 = 6.00 gf5 = 24.0 gf6 = 120.0 gf7 = 720.0 gf4br = 17.837861981813607 gf4ds = 10.41688578110938 gf4p5 = 11.63172839656745 gf3ds = 3.0458730354120997 gf1ds = 0.8863557896089221 gf43rds = 0.8929795116 gf53rds = 0.9027452930 gf73rds = 1.190639349 gf83rds = 1.504575488 gamice73fac = (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4) gamsnow73fac = (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4) brz = 100.0 arz = 0.66 bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & & ((1. + alphar)*(2. + alphar)*(3. + alphar)) galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) vfrz = 0.523599*(dfrz)**3 vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) IF ( snowmeltdia > 0.0 ) THEN snowmeltmass = pi/6.0 * 1000. * snowmeltdia**3 ENDIF tdtol = 1.0e-05 tfrcbw = tfr - cbw tfrcbi = tfr - cbi IF ( mixedphase ) THEN ibinhmlr = 0 ibinhlmlr = 0 ENDIF mltmass0inv = 1.0/( 1000.0* xvmx(lr) ) mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) mltmass3inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize3)**3) ) mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) mltmass3cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize3)**3) IF ( ibinnum == 1 ) THEN numdiam = 1 mltdiam(1) = 4.5e-3 ELSEIF ( ibinnum == 2 ) THEN numdiam = 2 mltdiam(1) = mltdiam1/6. mltdiam(2) = mltdiam1/2. ELSEIF ( ibinnum > 2 ) THEN numdiam = Min(ibinnum, ndiam) DO k = 1,numdiam mltdiam(k) = (k - 0.5)*mltdiam1/float(numdiam) ENDDO ELSE numdiam = 5 mltdiam(1) = 0.5e-3 mltdiam(2) = 1.0e-3 mltdiam(3) = 2.0e-3 mltdiam(4) = 4.0e-3 mltdiam(5) = 6.0e-3 ENDIF IF ( numshedregimes == 2 ) THEN mltdiam(ndiam+1) = mltdiam1 mltdiam(ndiam+2) = mltdiam3 mltdiam(ndiam+3) = mltdiam4 ELSEIF ( numshedregimes == 3 ) THEN mltdiam(ndiam+1) = mltdiam1 mltdiam(ndiam+2) = mltdiam2 mltdiam(ndiam+3) = mltdiam3 mltdiam(ndiam+4) = mltdiam4 ENDIF kzb = 1 kze = ktile mwfac = 6.0**(1./3.) IF ( ipconc .ge. 2 ) THEN ENDIF rwmasn = xvmn(lr)*1000. rwmasx = xvmx(lr)*1000. IF ( biggsnowdiam > 0.0 ) THEN xvbiggsnow = (pi/6.0)*biggsnowdiam**3 ELSE xvbiggsnow = xvmn(lh) ENDIF cimasn = Min(cimas0, cimas1) cimasx = 1.0e-8 ccimx = 5000.0e3 iend = 0 jy = jgs IF ( ipconc < 2 ) THEN DO kz = 1,kze DO ix = 1,itile t9(ix,jy,kz) = an(ix,jy,kz,lc) ENDDO ENDDO ENDIF if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' nxmpb = 1 nzmpb = 1 nxz = itile*nz numgs = nxz/ngs + 1 do 1000 inumgs = 1,numgs ngscnt = 0 do kz = nzmpb,kze do ix = nxmpb,itile pqs(1) = t00(ix,jy,kz) pres(1) = pn(ix,jy,kz) + pb(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 = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(1) = pqs(1)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(1) = rdorv*esbolton*tabqvs(ltemq)/(pres(1) - esbolton*tabqvs(ltemq)) ENDIF 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 ( temg(1) .lt. tfr ) then qss(1) = qis(1) end if ishail = .false. IF ( lhl > 1 ) THEN IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. ENDIF if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & & an(ix,jy,kz,li) .gt. qxmin(li) .or. & & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then ngscnt = ngscnt + 1 igs(ngscnt) = ix kgs(ngscnt) = kz if ( ngscnt .eq. ngs ) goto 1100 end if enddo nxmpb = 1 enddo 1100 continue if ( ngscnt .eq. 0 ) go to 9998 if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5, ngscnt = ',ngscnt xv(:,:) = 0.0 xmas(:,:) = 0.0 vtxbar(:,:,:) = 0.0 xdia(:,:,:) = 0.0 raindn(:,:) = 900. cx(:,:) = 0.0 IF ( lnhf > 1 .or. lnhlf > 1 ) chxf(:,:) = 0.0 alpha(:,:) = 0.0 DO il = li,lhab DO mgs = 1,ngscnt rimdn(mgs,il) = rimedens ENDDO ENDDO if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = def temps' do mgs = 1,ngscnt kgsm(mgs) = max(kgs(mgs)-1,1) kgsp(mgs) = min(kgs(mgs)+1,nz-1) kgsm2(mgs) = Max(kgs(mgs)-2,1) theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) rhovt(mgs) = Sqrt(rho00/Max(0.05,rho0(mgs))) pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temcg(mgs) = temg(mgs) - tfr qss0(mgs) = (380.0)/(pres(mgs)) pqs(mgs) = (380.0)/(pres(mgs)) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF 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) cnostmp(mgs) = cno(ls) il5(mgs) = 0 if ( temg(mgs) .lt. tfr ) then il5(mgs) = 1 end if enddo IF ( ipconc < 1 .and. lwsm6 ) THEN DO mgs = 1,ngscnt tmp = Min( 0.0, temcg(mgs) ) cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) ENDDO ENDIF do mgs = 1,ngscnt qhshr(mgs) = 0.0 end do DO il = lv,lhab do mgs = 1,ngscnt qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) ENDDO end do qxw(:,:) = 0.0 qxwlg(:,:) = 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 ( lcina .gt. 1 ) THEN cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) ELSE cina(mgs) = cx(mgs,li) ENDIF IF ( lcin > 1 ) THEN ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) ENDIF end do end if if ( ipconc .ge. 2 ) then do mgs = 1,ngscnt cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) IF ( qx(mgs,lc) .le. qxmin(lc) ) THEN cx(mgs,lc) = 0.0 ENDIF IF ( lss > 1 ) THEN ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) ENDIF IF ( lccn .gt. 1 ) THEN ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) ELSE ccnc(mgs) = 0.0 ENDIF IF ( lccna .gt. 1 ) THEN ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) ELSE ccna(mgs) = cx(mgs,lc) ENDIF end do end if if ( ipconc .ge. 3 ) then do mgs = 1,ngscnt cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) qx(mgs,lr) = 0.0 ELSE cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) ENDIF end do end if if ( ipconc .ge. 4 ) then do mgs = 1,ngscnt cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) qx(mgs,ls) = 0.0 ELSE cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) IF ( ilimit .ge. ipc(ls) ) THEN tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) tmp2 = (tmp*(3.14159))**(1./3.) cnox = cx(mgs,ls)*(tmp2) IF ( cnox .gt. 3.0*cno(ls) ) THEN cx(mgs,ls) = 3.0*cno(ls)/tmp2 ENDIF ENDIF ENDIF end do end if if ( ipconc .ge. 5 ) then do mgs = 1,ngscnt cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) qx(mgs,lh) = 0.0 ELSE cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) IF ( ilimit .ge. ipc(lh) ) THEN tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) tmp2 = (tmp*(3.14159))**(1./3.) cnox = cx(mgs,lh)*(tmp2) IF ( cnox .gt. 3.0*cno(lh) ) THEN cx(mgs,lh) = 3.0*cno(lh)/tmp2 ENDIF ENDIF ENDIF end do end if if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then do mgs = 1,ngscnt cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN cx(mgs,lhl) = 0.0 ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) qx(mgs,lhl) = 0.0 ELSE cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) IF ( ilimit .ge. ipc(lhl) ) THEN tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) tmp2 = (tmp*(3.14159))**(1./3.) cnox = cx(mgs,lhl)*(tmp2) IF ( cnox .gt. 3.0*cno(lhl) ) THEN cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 ENDIF ENDIF ENDIF end do end if IF ( ldovol ) THEN vx(:,:) = 0.0 DO il = li,lhab IF ( lvol(il) .ge. 1 ) THEN DO mgs = 1,ngscnt vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) ENDDO ENDIF ENDDO ENDIF fhw(:) = 0.0 fsw(:) = 0.0 fhlw(:) = 0.0 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 tmp = alphamax - 1.0 g1xmax = (6.0 + tmp)*(5.0 + tmp)*(4.0 + tmp)/ & & ((3.0 + tmp)*(2.0 + tmp)*(1.0 + tmp)) g1xmin = (6.0 + alphamin)*(5.0 + alphamin)*(4.0 + alphamin)/ & & ((3.0 + alphamin)*(2.0 + alphamin)*(1.0 + alphamin)) 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 zx(mgs,lr) = 3.6476*g1x(mgs,lr)*cx(mgs,lr)*vr**2 ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF IF ( ipconc == 5 ) THEN g1x(:,lr) = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/ & & ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) g1x(:,lh) = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) IF ( lhl > 0 ) THEN g1x(:,lhl) = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) ENDIF ENDIF scx(:,:) = 0.0 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) dab1lh(mgs,il,ic) = dab1(il,ic) ENDDO end do ENDDO 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 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) do mgs = 1,ngscnt ssi(mgs) = qx(mgs,lv)/qis(mgs) ssw(mgs) = qx(mgs,lv)/qvs(mgs) tsqr(mgs) = temg(mgs)**2 temgx(mgs) = min(temg(mgs),313.15) temgx(mgs) = max(temgx(mgs),233.15) felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) temcgx(mgs) = min(temg(mgs),273.15) temcgx(mgs) = max(temcgx(mgs),223.15) temcgx(mgs) = temcgx(mgs)-273.15 felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 fels(mgs) = felv(mgs) + felf(mgs) felvs(mgs) = felv(mgs)*felv(mgs) felss(mgs) = fels(mgs)*fels(mgs) IF ( eqtset <= 1 ) THEN felvcp(mgs) = felv(mgs)*cpi felscp(mgs) = fels(mgs)*cpi felfcp(mgs) = felf(mgs)*cpi ELSE tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) IF ( eqtset == 2 ) THEN felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm felfcp(mgs) = felf(mgs)/cvm ELSE cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) rmm=rd+rw*qx(mgs,lv) felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm felfcp(mgs) = felf(mgs)*cv/(cp*cvm) felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) ENDIF ENDIF fgamw(mgs) = felvcp(mgs)/pi0(mgs) fgams(mgs) = felscp(mgs)/pi0(mgs) fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) fcc3(mgs) = felfcp(mgs)/pi0(mgs) fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) temcgx(mgs) = min(temg(mgs),273.15) temcgx(mgs) = max(temcgx(mgs),233.15) temcgx(mgs) = temcgx(mgs)-273.15 fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) if ( temg(mgs) .lt. 273.15 ) then temcgx(mgs) = min(temg(mgs),273.15) temcgx(mgs) = max(temcgx(mgs),233.15) temcgx(mgs) = temcgx(mgs)-273.15 fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & & + (1.60056e-5)*((temcgx(mgs)-35.)**4) end if if ( temg(mgs) .ge. 273.15 ) then temcgx(mgs) = min(temg(mgs),308.15) temcgx(mgs) = max(temcgx(mgs),273.15) temcgx(mgs) = temcgx(mgs)-273.15 fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) end if ftka(mgs) = tka0*fadvisc(mgs)/advisc1 fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) kp1 = Min(nz, kgs(mgs)+1 ) wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & & +w(igs(mgs),jgs,kgs(mgs))) end do if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' do mgs = 1,ngscnt xdn(mgs,li) = xdn0(li) xdn(mgs,lc) = xdn0(lc) xdn(mgs,lr) = xdn0(lr) xdn(mgs,ls) = xdn0(ls) xdn(mgs,lh) = xdn0(lh) IF ( lvol(ls) .gt. 1 ) THEN IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) ENDIF ENDIF IF ( lvol(lh) .gt. 1 ) THEN IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( mixedphase ) THEN ELSE dnmx = xdnmx(lh) ENDIF xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) ENDIF ENDIF 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 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 ( 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.) 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 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.) 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.) il = lh DO ic = lc,lh-1 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 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 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 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 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/( 3.*(1. + alphashr) ) ) 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/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) ENDIF g1shr = 1.0 g1mlr = 1.0 g1smlr = 1.0 IF ( ipconc >= 6 ) THEN IF ( ipconc >= 6 .and. imurain == 3 ) THEN il = lr DO mgs = 1,ngscnt 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 = (6.0 + alphashr)*(5.0 + alphashr)*(4.0 + alphashr)/ & & ((3.0 + alphashr)*(2.0 + alphashr)*(1.0 + alphashr)) 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 il = lr DO mgs = 1,ngscnt IF ( iresetmoments == 1 .or. iresetmoments == il .or. iresetmoments == -1 ) THEN IF ( zx(mgs,il) <= zxmin ) 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 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 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 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) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) 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/(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 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) 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 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 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( 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 ( tmp < cx(mgs,il) ) THEN 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) 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 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 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 IF ( alp >= rnumax - 0.01 ) THEN 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) = 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 ventrxn(mgs) = x/(y*(alpha(mgs,lr) + 1.)**((1.+br)/6. + 1./3.)) ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF IF ( ipconc .ge. 6 ) THEN DO il = lr,lhab 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 IF ( zx(mgs,il) <= zxmin ) THEN 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 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 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) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > cxmin ) THEN chw = cx(mgs,il) qr = qx(mgs,il) 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 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) ELSE chw = cx(mgs,il) qr = qx(mgs,il) z = zx(mgs,il) IF ( zx(mgs,il) .gt. 0. ) THEN 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 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 ( 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 IF ( imaxdiaopt == 1 .or. il /= lr ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSEIF ( imaxdiaopt == 3 ) THEN 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 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 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) tmpz = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/tmp IF ( tmpz > zx(mgs,il) ) THEN tmpc = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/zx(mgs,il) cx(mgs,il) = Max(cx(mgs,il), tmpc) ENDIF zx(mgs,il) = g1/(pi/6.*xdn(mgs,il))**2 * ((rho0(mgs)*qx(mgs,il))**2)/cx(mgs,il) an(igs(mgs),jgs,kgs(mgs),lz(il)) = zx(mgs,il) qr = qx(mgs,il) chw = cx(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 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 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 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 chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 cx(mgs,il) = chw an(igs(mgs),jy,kgs(mgs),ln(il)) = chw ELSE 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 IF ( alp >= alphamax - 0.5 ) THEN 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 ENDIF IF ( il == lr ) THEN 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 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 ventrxn(mgs) = x/y ENDIF ENDIF ELSE ENDIF ENDDO IF ( .not. ( il == lr .and. imurain == 3 ) ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,il) > qxmin(il) ) THEN xnutmp = (alpha(mgs,il) - 2.)/3. DO ic = lc,lh-1 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) IF ( il /= lr .and. ic == lr .and. lzr > 1 ) THEN IF ( imurain == 3 ) THEN xnuc = alpha(mgs,lr) ELSE xnuc = ( alpha(mgs,lr) - 2. )/3. ENDIF ENDIF IF ( .false. ) THEN dab0lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 0) dab1lh(mgs,ic,il) = delabk(bb(ic), bb(il), xnuc, xnutmp, xmu(ic), xmu(il), 1) dab0lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 0) dab1lh(mgs,il,ic) = delabk(bb(il), bb(ic), xnutmp, xnuc, xmu(il), xmu(ic), 1) ELSE 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 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) 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 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 ENDDO ENDIF ENDIF ENDDO ENDIF do mgs = 1,ngscnt kp1 = Min(nz, kgs(mgs)+1 ) wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & & +w(igs(mgs),jgs,kgsm(mgs))) cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) end do infdo = 1 IF ( rimdenvwgt > 0 ) infdo = 1 call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,cdxgs, & & ipconc,ndebug,ngs,nz,igs,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & & itype1,itype2,temcg,infdo,alpha,axx,bxx,0) IF ( lwsm6 .and. ipconc == 0 ) THEN tmp = Max(qxmin(lh), qxmin(ls)) DO mgs = 1,ngscnt 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 ENDDO ENDIF if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' IF ( ipconc .lt. 1 ) THEN cina(1:ngscnt) = cx(1:ngscnt,li) ENDIF if ( ipconc .lt. 5 ) then do mgs = 1,ngscnt IF ( ipconc .lt. 3 ) THEN if ( qx(mgs,lr) .gt. qxmin(lh) ) then end if ENDIF IF ( ipconc .lt. 4 ) THEN if ( qx(mgs,ls) .gt. qxmin(ls) ) then end if ENDIF IF ( ipconc .lt. 5 ) THEN if ( qx(mgs,lh) .gt. qxmin(lh) ) then end if ENDIF end do end if IF ( ipconc .ge. 2 ) THEN DO mgs = 1,ngscnt rb(mgs) = 0.5*xdia(mgs,lc,1)*(1./(1.+alpha(mgs,lc)))**(1./6.) xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) IF ( rb(mgs) .gt. 3.51e-6 ) THEN rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) ELSE rh(mgs) = 41.d-6 ENDIF IF ( xl2p(mgs) .gt. 0.0 ) THEN nh(mgs) = 4.2d9*xl2p(mgs) ELSE nh(mgs) = 1.e30 ENDIF ENDDO ENDIF if( ndebug .ge. 0 ) THEN endif do mgs = 1,ngscnt qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))*dtpinv IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))*dtpinv qvimxd(mgs) = max(qvimxd(mgs), 0.0) frac = 0.1d0 qimxd(mgs) = frac*qx(mgs,li)*dtpinv qcmxd(mgs) = frac*qx(mgs,lc)*dtpinv qrmxd(mgs) = frac*qx(mgs,lr)*dtpinv qsmxd(mgs) = frac*qx(mgs,ls)*dtpinv qhmxd(mgs) = frac*qx(mgs,lh)*dtpinv IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)*dtpinv end do if( ndebug .ge. 0 ) THEN endif do mgs = 1,ngscnt if ( qx(mgs,lc) .le. qxmin(lc) ) then ccmxd(mgs) = 0.20*cx(mgs,lc)*dtpinv else IF ( ipconc .ge. 2 ) THEN ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv ELSE ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) ENDIF end if if ( qx(mgs,li) .le. qxmin(li) ) then cimxd(mgs) = frac*cx(mgs,li)*dtpinv else IF ( ipconc .ge. 1 ) THEN cimxd(mgs) = frac*cx(mgs,li)*dtpinv ELSE cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) ENDIF end if crmxd(mgs) = 0.10*cx(mgs,lr)*dtpinv csmxd(mgs) = frac*cx(mgs,ls)*dtpinv chmxd(mgs) = frac*cx(mgs,lh)*dtpinv ccmxd(mgs) = frac*cx(mgs,lc)*dtpinv cimxd(mgs) = frac*cx(mgs,li)*dtpinv crmxd(mgs) = frac*cx(mgs,lr)*dtpinv csmxd(mgs) = frac*cx(mgs,ls)*dtpinv chmxd(mgs) = frac*cx(mgs,lh)*dtpinv qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))*dtpinv) DO il = lc,lhab qxmxd(mgs,il) = frac*qx(mgs,il)*dtpinv cxmxd(mgs,il) = frac*cx(mgs,il)*dtpinv ENDDO end do 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 maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) IF ( imurain == 3 ) THEN maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) ELSE maxmassfac(lr) = (3.0 + alphar)**3/ & & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) ENDIF IF ( imusnow == 3 ) THEN maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) ELSE maxmassfac(ls) = (3.0 + alphas)**3/ & & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) ENDIF maxmassfac(lh) = (3.0 + alphah)**3/ & & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) IF ( lhl > 1 ) THEN maxmassfac(lhl) = (3.0 + alphahl)**3/ & & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) ENDIF DO mgs = 1,ngscnt DO il = lh,lhab vshdgs(mgs,il) = vshd IF ( qx(mgs,il) > qxmin(il) .and. ivshdgs > 0 ) THEN tmpdiam = (shedalp+0.0)*xdia(mgs,il,1) IF ( tmpdiam > sheddiam0 ) THEN vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ELSEIF ( tmpdiam > sheddiam ) THEN vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ELSE vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ENDIF ENDIF ENDDO ENDDO if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' do mgs = 1,ngscnt qcwresv(mgs) = 0.0 ccwresv(mgs) = 0.0 erw(mgs) = 0.0 esw(mgs) = 0.0 ehw(mgs) = 0.0 efw(mgs) = 0.0 ehlw(mgs) = 0.0 err(mgs) = 0.0 esr(mgs) = 0.0 il2(mgs) = 0 il3(mgs) = 0 ehr(mgs) = 0.0 ehlr(mgs) = 0.0 eri(mgs) = 0.0 esi(mgs) = 0.0 ehi(mgs) = 0.0 ehis(mgs) = 0.0 ehli(mgs) = 0.0 ehlis(mgs) = 0.0 ers(mgs) = 0.0 ess(mgs) = 0.0 ehs(mgs) = 0.0 ehsfac(mgs) = 1.0 ehls(mgs) = 0.0 ehscnv(mgs) = 0.0 eiw(mgs) = 0.0 eii(mgs) = 0.0 ehsclsn(mgs) = 0.0 ehiclsn(mgs) = 0.0 ehlsclsn(mgs) = 0.0 ehliclsn(mgs) = 0.0 esiclsn(mgs) = 0.0 IF ( exwmindiam > 0 .and. qx(mgs,lc) > qxmin(lc) ) THEN tmp = cx(mgs,lc)*Exp(- (exwmindiam/xdia(mgs,lc,1))**3 ) ccwresv(mgs) = Min( cx(mgs,lc), Max( 2.e6, cx(mgs,lc) - tmp ) ) tmp = cx(mgs,lc) - ccwresv(mgs) volt = pi/6.*(exwmindiam)**3 qcwresv(mgs) = qx(mgs,lc) - tmp*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) IF ( .false. .and. qx(mgs,lc) > 0.1e-3 ) THEN write(0,*) 'cx,qx,crsv,qrsv = ',cx(mgs,lc),qx(mgs,lc),ccwresv(mgs),qcwresv(mgs) ENDIF ENDIF icwr(mgs) = 1 IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN cwrad = 0.5*xdia(mgs,lc,1) DO il = 1,8 IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il ENDDO ENDIF irwr(mgs) = 1 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) DO il = 1,6 IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il ENDDO ENDIF igwr(mgs) = 1 IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN rwrad = 0.5*xdia(mgs,lh,3) DO il = 1,6 IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il ENDDO ENDIF IF ( lhl .gt. 1 ) THEN ihlr(mgs) = 1 IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN rwrad = 0.5*xdia(mgs,lhl,3) DO il = 1,6 IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il ENDDO ENDIF ENDIF if ( qx(mgs,li) .gt. qxmin(li) ) then eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 end if eiw(mgs) = 0.0 if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then if (xdia(mgs,lc,1).gt.ewi_dcmin .and. xdia(mgs,li,1).gt.ewi_dimin) then eiw(mgs) = eiw0 end if if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 end if if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then IF ( lnr .gt. 1 ) THEN erw(mgs) = 1.0 ELSE ic = icwr(mgs) icp1 = Min( 8, ic+1 ) ir = irwr(mgs) irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,3) rwrad = 0.5*xdia(mgs,lr,3) slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) slope1 = (x2 - x1)*grad(ir,2) erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) erw(mgs) = Max(0.0, erw(mgs) ) IF ( rwrad .lt. 50.e-6 ) THEN erw(mgs) = 0.0 ELSEIF ( rwrad .lt. 100.e-6 ) THEN erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 ENDIF ENDIF end if IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then err(mgs)=1.0 end if if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then ers(mgs)=1.0 end if if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then eri(mgs) = eri0 if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0 end if esw(mgs) = 0.0 if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then esw(mgs) = 0.5 if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then esw(mgs) = 0.5 ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) ENDIF end if if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & & .and. temg(mgs) .lt. tfr - 1. & & ) then esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 end if IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN il3(mgs) = 1 ENDIF if ( temcg(mgs) < 0.0 ) then IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN ess(mgs) = 0.0 ELSE fac = Abs(ess0) IF ( iessopt == 2 ) THEN IF ( wvel(mgs) > 2.0 ) THEN fac = 0.0 ELSEIF ( wvel(mgs) > 1.0 ) THEN fac = Max(0.0, 2.0 - wvel(mgs))*fac ENDIF ELSEIF ( iessopt == 3 ) THEN 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 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 ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) ) ENDIF ENDIF end if if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then esiclsn(mgs) = esi_collsn IF ( ipconc < 1 .and. lwsm6 ) THEN esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) ELSE esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) esi(mgs) = Min(0.1,esi(mgs)) ENDIF IF ( ipconc .le. 3 ) THEN esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ENDIF if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 end if xmascw(mgs) = xmas(mgs,lc) if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then ehw(mgs) = 1.0 IF ( iehw .eq. 0 ) THEN ehw(mgs) = ehw0 ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN cwrad = 0.5*xdia(mgs,lc,1) ehw(mgs) = Min( ehw0, & & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & & (cradcw + cwrad*(dradcw)))), 1.0) ) ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN ic = icwr(mgs) icp1 = Min( 8, ic+1 ) ir = igwr(mgs) irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,1) rwrad = 0.5*xdia(mgs,lh,3) slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) slope1 = (x2 - x1)*grad(ir,2) tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) ehw(mgs) = Min( ehw(mgs), tmp ) ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ehw(mgs) = Min( ehw(mgs), tmp ) ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN tmp = & & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) tmp = Max( 1.5, Min(10.0, tmp) ) ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) ENDIF if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 ehw(mgs) = Min( ehw0, ehw(mgs) ) IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN ehw(mgs) = 0.0 ENDIF end if if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & & ) then ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3)) ehr(mgs) = Min( ehr0, ehr(mgs) ) end if IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN IF ( ipconc .ge. 4 ) THEN ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) 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 ehsclsn(mgs) = ehs_collsn IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN ehsclsn(mgs) = 0.0 ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) ELSE ehsclsn(mgs) = ehs_collsn ENDIF ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ehs(mgs) = Min(ehs(mgs),ehsmax) end if ENDIF if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) end if IF ( lis > 1 ) THEN if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then ehisclsn(mgs) = ehi_collsn ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) ) end if ENDIF IF ( lhl .gt. 1 ) THEN if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then IF ( iehw == 3 ) iehlw = 3 IF ( iehw == 4 ) iehlw = 4 ehlw(mgs) = ehlw0 IF ( iehlw .eq. 0 ) THEN ehlw(mgs) = ehlw0 ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN cwrad = 0.5*xdia(mgs,lc,1) ehlw(mgs) = Min( ehlw0, & & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & & (cradcw + cwrad*(dradcw)))), 1.0) ) ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN ic = icwr(mgs) icp1 = Min( 8, ic+1 ) ir = ihlr(mgs) irp1 = Min( 6, ir+1 ) cwrad = 0.5*xdia(mgs,lc,1) rwrad = 0.5*xdia(mgs,lhl,3) slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) slope1 = (x2 - x1)*grad(ir,2) tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) ehlw(mgs) = Min( ehlw(mgs), tmp ) ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) ehlw(mgs) = Min( ehlw(mgs), tmp ) ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN tmp = & & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) tmp = Max( 1.5, Min(10.0, tmp) ) ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) ENDIF if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN ehlw(mgs) = 0.0 ENDIF end if if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & & ) then ehlr(mgs) = 1.0 ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) end if IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN if ( qx(mgs,lhl).gt.qxmin(lhl) ) then ehlsclsn(mgs) = ehls_collsn ehls(mgs) = ehscnv(mgs) ehls(mgs) = Min(ehls(mgs),ehsmax) end if ENDIF if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then ehliclsn(mgs) = ehli_collsn ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 end if IF ( lis > 1 ) THEN if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then ehlisclsn(mgs) = ehli_collsn ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) ) if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0 end if ENDIF ENDIF ENDDO do mgs = 1,ngscnt xplate(mgs) = 0.0 xcolmn(mgs) = 1.0 end do if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' do mgs = 1,ngscnt qracw(mgs) = 0.0 IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN IF ( ipconc .lt. 3 ) THEN IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) qracw(mgs) = & & (0.25)*pi*erw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lr) & & *Max(0.0, vtxbar(mgs,lr,1)-vt) & & *( gf3*xdia(mgs,lr,2) & & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & & + gf1*xdia(mgs,lc,2) ) ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN rwrad = 0.5*xdia(mgs,lr,3) IF ( rwrad .gt. rh(mgs) ) THEN IF ( rwrad .gt. rwradmn ) THEN qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,lr))/rho0(mgs) ELSE IF ( imurain == 3 ) THEN qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) ELSE qracw(mgs) = aa1*cx(mgs,lr)*(qx(mgs,lc)-qcwresv(mgs))* & & ((alpha(mgs,lc) + 3.)*(alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.)**2 + & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) ENDIF ENDIF ENDIF ENDIF ENDIF qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) ENDIF end do 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 tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) craci(mgs) = Min( cxmxd(mgs,li), tmp ) ELSE qraci(mgs) = & & min( & & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & & *( gf3*xdia(mgs,lr,2) & & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & & + gf1*xdia(mgs,li,2) ) & & , qimxd(mgs)) ENDIF if ( temg(mgs) .gt. 268.15 ) then qraci(mgs) = 0.0 end if ENDIF end do IF ( ipconc < 3 ) THEN do mgs = 1,ngscnt qracs(mgs) = 0.0 IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) ELSE vt = vtxbar(mgs,ls,1) ENDIF qracs(mgs) = & & min( & & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & & *abs(vtxbar(mgs,lr,1)-vt) & & *( gf6*gf1*xdia(mgs,ls,2) & & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & & + gf4*gf3*xdia(mgs,lr,2) ) & & , qsmxd(mgs)) ENDIF end do ENDIF if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' do mgs = 1,ngscnt qsacw(mgs) = 0.0 csacw(mgs) = 0.0 vsacw(mgs) = 0.0 IF ( esw(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 4 ) THEN tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)/(alpha(mgs,lc) + 1.) + xv(mgs,ls)) qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) IF ( lvol(ls) .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,ls,1)) & & /(temg(mgs)-273.15))**(rimc2) rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) ELSE rimdn(mgs,ls) = 1000. ENDIF vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) ENDIF ELSE vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & & ( da0(ls)*xdia(mgs,ls,3)**2 + & & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) ENDIF ENDIF end do do mgs = 1,ngscnt qsaci(mgs) = 0.0 csaci(mgs) = 0.0 csaci0(mgs) = 0.0 IF ( ipconc .ge. 4 ) THEN IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) csaci0(mgs) = tmp csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) ENDIF ELSE IF ( esi(mgs) .gt. 0.0 ) THEN qsaci(mgs) = & & min( & & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & & *( gf3*xdia(mgs,ls,2) & & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & & + gf1*xdia(mgs,li,2) ) & & , qimxd(mgs)) ENDIF ENDIF end do do mgs = 1,ngscnt qsacr(mgs) = 0.0 qsacrs(mgs) = 0.0 csacr(mgs) = 0.0 IF ( esr(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 3 ) THEN ELSE IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) ELSE vt = vtxbar(mgs,ls,1) ENDIF qsacr(mgs) = & & min( & & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & & *abs(vtxbar(mgs,lr,1)-vt) & & *( gf6*gf1*xdia(mgs,lr,2) & & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & & + gf4*gf3*xdia(mgs,ls,2) ) & & , qrmxd(mgs)) ENDIF ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' 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 zhacw(mgs) = 0.0 IF ( .false. ) THEN vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) ENDIF IF ( ehw(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 2 ) THEN IF ( .false. ) THEN qhacw(mgs) = (ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh)*pi* & & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & & xdia(mgs,lc,1)*gf73rds) + & & xdia(mgs,lc,2)*gf83rds))/4. ELSE vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & & da1lc(mgs)*xdia(mgs,lc,3)**2 ) ENDIF qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)*dtpinv ) IF ( lzh .gt. 1 ) THEN tmp = qx(mgs,lh)/cx(mgs,lh) ENDIF ELSE qhacw(mgs) = & & min( & & ((0.25)*pi)*ehw(mgs)*(qx(mgs,lc)-qcwresv(mgs))*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & & *( gf3*xdia(mgs,lh,2) & & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & & + gf1*xdia(mgs,lc,2) ) & & , 0.5*(qx(mgs,lc)-qcwresv(mgs))*dtpinv) IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) qsacw(mgs) = qaacw qhacw(mgs) = qaacw ENDIF 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 IF ( temg(mgs) .lt. 273.15) THEN IF ( irimdenopt == 1 ) THEN vt = ( (1.0-rimdenvwgt)*vtxbar(mgs,lh,1) + rimdenvwgt*vtxbar(mgs,lh,2) ) rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vt ) & & /(temg(mgs)-273.15))**(rimc2) rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) ELSEIF ( irimdenopt == 2 ) THEN 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) = 1000.*(0.051 + 0.114*tmp - 0.0055*tmp**2) ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN 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)) IF ( irimdenopt == 3 ) THEN rimdn(mgs,lh) = Min(900., Max( 170., 110.*tmp**0.76 ) ) ELSEIF ( irimdenopt == 4 ) THEN rimdn(mgs,lh) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) ENDIF ENDIF ELSE rimdn(mgs,lh) = 1000. ENDIF IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) ENDIF IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN rarx(mgs,lh) = & & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) ENDIF ENDIF end do do mgs = 1,ngscnt qhaci(mgs) = 0.0 qhaci0(mgs) = 0.0 IF ( ehi(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) ELSE qhaci(mgs) = & & min( & & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & & *( gf3*xdia(mgs,lh,2) & & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & & + gf1*xdia(mgs,li,2) ) & & , qimxd(mgs)) ENDIF ENDIF end do do mgs = 1,ngscnt qhacs(mgs) = 0.0 qhacs0(mgs) = 0.0 IF ( ehs(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) ELSE qhacs(mgs) = & & min( & & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & & *( gf6*gf1*xdia(mgs,ls,2) & & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & & + gf4*gf3*xdia(mgs,lh,2) ) & & , qsmxd(mgs)) ENDIF ENDIF end do do mgs = 1,ngscnt qhacr(mgs) = 0.0 qhacrmlr(mgs) = 0.0 vhacr(mgs) = 0.0 chacr(mgs) = 0.0 zhacr(mgs) = 0.0 IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 IF ( ehr(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 3 ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & & da1lr(mgs)*xdia(mgs,lr,3)**2 ) qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) qhacrmlr(mgs) = qhacr(mgs) IF ( temg(mgs) > tfr .and. iehr0c == 0 ) THEN qhacr(mgs) = 0.0 IF ( iqhacrmlr == 0 ) THEN qhacrmlr(mgs) = -qhacw(mgs) ENDIF ELSE chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab0lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & & da0lr(mgs)*xdia(mgs,lr,3)**2 ) chacr(mgs) = min(chacr(mgs),crmxd(mgs)) IF ( lzh .gt. 1 ) THEN tmp = qx(mgs,lh)/cx(mgs,lh) ENDIF ENDIF ELSE IF ( lwsm6 .and. ipconc == 0 ) THEN vt = vt2ave(mgs) ELSE vt = vtxbar(mgs,lh,1) ENDIF qhacr(mgs) = & & min( & & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & & *abs(vt-vtxbar(mgs,lr,1)) & & *( gf6*gf1*xdia(mgs,lr,2) & & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & & + gf4*gf3*xdia(mgs,lh,2) ) & & , qrmxd(mgs)) IF ( temg(mgs) > tfr ) THEN IF ( iqhacrmlr >= 1 ) qhacrmlr(mgs) = qhacr(mgs) qhacr(mgs) = 0.0 ENDIF ENDIF IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN IF ( temg(mgs) .lt. 273.15) THEN raindn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lr,3)) & & *((0.60)*vt) & & /(temg(mgs)-273.15))**(rimc2) raindn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) ELSE raindn(mgs,lh) = 1000. ENDIF IF ( lvol(lh) > 1 ) vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) ENDIF ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' 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 vtmax = (gz(igs(mgs),jgs,kgs(mgs))*dtpinv) vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) ENDIF IF ( lhl > 0 ) THEN rarx(mgs,lhl) = 0.0 ENDIF IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & & da1lc(mgs)*xdia(mgs,lc,3)**2 ) 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 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) rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) ELSEIF ( irimdenopt == 2 ) THEN 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) = 1000.*(0.051 + 0.114*tmp - 0.005*tmp**2) ELSEIF ( irimdenopt == 3 .or. irimdenopt == 4) THEN 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) IF ( irimdenopt == 3 ) THEN rimdn(mgs,lhl) = Min(900., Max( 170., 110.*tmp**0.76 ) ) ELSEIF ( irimdenopt == 4 ) THEN rimdn(mgs,lhl) = Min(917., Max( 10., 900.0*(1.0 - 0.905**tmp ) ) ) ENDIF ENDIF ELSE rimdn(mgs,lhl) = 1000. ENDIF vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) ENDIF IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN rarx(mgs,lhl) = & & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) ENDIF ENDIF end do qhlaci(:) = 0.0 qhlaci0(:) = 0.0 IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt IF ( ehli(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) ENDIF ENDIF end do ENDIF qhlacis(:) = 0.0 qhlacis0(:) = 0.0 qhlacs(:) = 0.0 qhlacs0(:) = 0.0 IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt IF ( ehls(mgs) .gt. 0.0) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) ENDIF ENDIF end do ENDIF do mgs = 1,ngscnt qhlacr(mgs) = 0.0 qhlacrmlr(mgs) = 0.0 chlacr(mgs) = 0.0 vhlacr(mgs) = 0.0 IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN IF ( ipconc .ge. 3 ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & & da1lr(mgs)*xdia(mgs,lr,3)**2 ) qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) IF ( iqhlacrmlr >= 1 ) qhlacrmlr(mgs) = qhlacr(mgs) IF ( temg(mgs) > tfr .and. iehlr0c == 0) THEN qhlacr(mgs) = 0.0 IF ( iqhlacrmlr == 0 ) THEN qhlacrmlr(mgs) = -qhlacw(mgs) ENDIF ELSE chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab0lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & & da0lr(mgs)*xdia(mgs,lr,3)**2 ) chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) IF ( lvol(lhl) .gt. 1 ) THEN vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) ENDIF ENDIF ENDIF ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' do mgs = 1,ngscnt qiacw(mgs) = 0.0 IF ( eiw(mgs) .gt. 0.0 ) THEN vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & & da1lc(mgs)*xdia(mgs,lc,3)**2 ) qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' do mgs = 1,ngscnt qiacr(mgs) = 0.0 qiacrf(mgs) = 0.0 qiacrs(mgs) = 0.0 ciacrs(mgs) = 0.0 ciacr(mgs) = 0.0 ciacrf(mgs) = 0.0 viacrf(mgs) = 0.0 csplinter(mgs) = 0.0 qsplinter(mgs) = 0.0 csplinter2(mgs) = 0.0 qsplinter2(mgs) = 0.0 IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & & .and. temg(mgs) .le. 270.15 ) THEN IF ( ipconc .ge. 3 ) THEN ni = 0.0 IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) ENDIF IF ( imurain == 1 ) THEN IF ( iacrsize /= 4 ) THEN IF ( iacrsize .eq. 1 ) THEN ratio = 500.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 2 ) THEN ratio = 300.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 3 ) THEN ratio = 40.e-6/xdia(mgs,lr,1) ELSEIF ( iacrsize .eq. 5 ) THEN ratio = 150.e-6/xdia(mgs,lr,1) ENDIF i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) delx = ratio - float(i)*dqiacrratio dely = alpha(mgs,lr) - float(j)*dqiacralpha ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) ELSE nr = cx(mgs,lr) qr = qx(mgs,lr) ENDIF vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab1lh(mgs,li,lr)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da1(lr)*xdia(mgs,lr,3)**2 ) qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & & ( da0(li)*xdia(mgs,li,3)**2 + & & dab0lh(mgs,li,lr)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & & da0(lr)*xdia(mgs,lr,3)**2 ) ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) ELSEIF ( imurain == 3 ) THEN arg = 1000.*xdia(mgs,lr,3) IF ( ipconc .ge. 3 ) THEN IF ( iacrsize .eq. 1 ) THEN nr = cx(mgs,lr)*gaml02d500( arg ) ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN nr = cx(mgs,lr)*gaml02d300( arg ) ELSEIF ( iacrsize .eq. 3 ) THEN nr = cx(mgs,lr)*gaml02( arg ) ELSEIF ( iacrsize .eq. 4 ) THEN nr = cx(mgs,lr) ENDIF ELSE nr = cx(mgs,lr)*gaml02( arg ) ENDIF IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN d0 = xdia(mgs,lr,3) qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & & (0.217239*(0.522295*(d0**5) + & & 49711.81*(d0**6) - & & 1.673016e7*(d0**7)+ & & 2.404471e9*(d0**8) - & & 1.22872e11*(d0**9))*ni*nr) qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) ciacr(mgs) = & & (0.217239*(0.2301947*(d0**2) + & & 15823.76*(d0**3) - & & 4.167685e6*(d0**4) + & & 4.920215e8*(d0**5) - & & 2.133344e10*(d0**6))*ni*nr) ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) ENDIF ENDIF IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ELSEIF ( iacr .eq. 2 ) THEN ciacrf(mgs) = ciacr(mgs) ELSEIF ( iacr .eq. 4 ) THEN ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ELSEIF ( iacr .eq. 5 ) THEN ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) ENDIF ENDIF ELSE qiacr(mgs) = & & min( & & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & & *( gf6*gf1*xdia(mgs,lr,2) & & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & & + gf4*gf3*xdia(mgs,li,2) ) & & , qrmxd(mgs)) ENDIF IF ( ipconc .ge. 1 ) THEN IF ( nsplinter .ge. 1000 ) THEN IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) fac = 1.0 IF ( nsplinter .eq. 1001 ) THEN fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ENDIF csplinter(mgs) = fac*lawson_splinter_fac*tmpdiam**4*ciacr(mgs) ENDIF ELSEIF ( nsplinter .ge. 0 ) THEN csplinter(mgs) = nsplinter*ciacr(mgs) ELSE csplinter(mgs) = -nsplinter*ciacrf(mgs) ENDIF qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ENDIF frach = 1.0 IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN IF ( ciacr(mgs) > qxmin(lh) ) THEN xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvbiggsnow))) qiacrs(mgs) = (1.-frach)*qiacr(mgs) ciacrs(mgs) = (1.-frach)*ciacrf(mgs) ENDIF ENDIF qiacrf(mgs) = frach*qiacr(mgs) ciacrf(mgs) = frach*ciacrf(mgs) IF ( lvol(lh) > 1 ) THEN viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz ENDIF end do if ( ipconc .ge. 4 ) then do mgs = 1,ngscnt csacs(mgs) = 0.0 IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 ) THEN IF ( iessec0flag == 0 ) THEN ec0(mgs) = 1.0 ELSE tmp = xv(mgs,ls)/(xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls)))) IF ( tmp .lt. essfrac1 ) THEN ec0(mgs) = 1.0 ELSEIF ( tmp .ge. essfrac2 ) THEN ec0(mgs) = 0.0 ELSE ec0(mgs) = (essfrac2 - tmp)/(essfrac2 - essfrac1) ENDIF ENDIF csacs(mgs) = ec0(mgs)*rvt*aa2*ess(mgs)*cx(mgs,ls)**2*Min( xv(mgs,ls), 4.*pii/3.*essrmax**3 ) csacs(mgs) = Min(csacs(mgs),csmxd(mgs)) ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then do mgs = 1,ngscnt ciacw(mgs) = 0.0 IF ( eiw(mgs) .gt. 0.0 .and. xmas(mgs,lc) > 0.0 ) THEN ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt tmp1 = 0.0 cracw(mgs) = 0.0 cracr(mgs) = 0.0 ec0(mgs) = 1.e9 IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & & .and. qracw(mgs) .gt. 0.0 ) THEN IF ( ipconc .lt. 3 ) THEN IF ( erw(mgs) .gt. 0.0 ) THEN cracw(mgs) = & & ((0.25)*pi)*erw(mgs)*(cx(mgs,lc) - ccwresv(mgs))*cx(mgs,lr) & & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & & *( gf1*xdia(mgs,lc,2) & & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & & + gf3*xdia(mgs,lr,2) ) ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN cracw(mgs) = aa2*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))*(xv(mgs,lc) + xv(mgs,lr)) ELSE IF ( imurain == 3 ) THEN cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) ELSE cracw(mgs) = aa1*cx(mgs,lr)*(cx(mgs,lc) - ccwresv(mgs))* & & ((alpha(mgs,lc) + 2.)*xv(mgs,lc)**2/(alpha(mgs,lc) + 1.) + & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ec0(mgs) = 1.0 IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN rwrad = 0.5*xdia(mgs,lr,3) IF ( icracrthresh > 1 ) THEN IF ( imurain == 1 ) THEN tmp = (3.67+alpha(mgs,lr))*xdia(mgs,lr,1) ELSE tmp = (1.678+alpha(mgs,lr))**(1./3.)*xdia(mgs,lr,1) ENDIF ELSE tmp = xdia(mgs,lr,3) - 0.1e-3 ENDIF IF ( ( tmp .gt. 1.9e-3 .and. irainbreak /= 10 .and. irainbreak /= 20 ) .or. icracr <= 0 ) THEN ec0(mgs) = 0.0 cracr(mgs) = 0.0 IF ( ibincracr == 3 ) THEN tmp1 = aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ENDIF ELSE IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN IF ( xdia(mgs,lr,3) .lt. 6.1e-4 .or. irainbreak == 10 ) THEN ec0(mgs) = 1.0 ELSE ec0(mgs) = Exp( -2500.0*(xdia(mgs,lr,3) - 6.0e-4) ) ENDIF IF ( rwrad .ge. 50.e-6 ) THEN tmp1 = aa2*cx(mgs,lr)**2*xv(mgs,lr) cracr(mgs) = ec0(mgs)*tmp1 IF ( irainbreak == 20 ) THEN cracr(mgs) = tmp1 ENDIF ELSE IF ( imurain == 3 ) THEN cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) ELSE tmp1 = aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) cracr(mgs) = ec0(mgs)*tmp1 IF ( irainbreak == 20 ) THEN cracr(mgs) = tmp1 ENDIF ENDIF ENDIF ENDIF ENDIF IF ( irainbreak == 100 ) THEN ec0(mgs) = 1.0 IF ( xdia(mgs,lr,1) > 300.e-6 ) THEN ec0(mgs) = 2. - Exp(2300.*(xdia(mgs,lr,1)-300.e-6)) ENDIF cracr(mgs) = 5.78*ec0(mgs)*cx(mgs,lr)*qx(mgs,lr) ENDIF ENDIF crbreak = 0.0 IF ( irainbreak == 1 .or. irainbreak == 10 ) THEN crbreak = Max( 0.0, rainbreakfac* (rho0(mgs)*qx(mgs,lr))**2 ) cracr(mgs) = cracr(mgs) - crbreak ELSEIF ( irainbreak == 2 .or. irainbreak == 20 ) THEN crbreak = Max( 0.0, rainbreakfac*(1. - ec0(mgs))*(rho0(mgs)*qx(mgs,lr))**2 ) cracr(mgs) = cracr(mgs) - crbreak ELSEIF ( irainbreak == 11 .and. rho0(mgs)*qx(mgs,lr) > qrbrthresh1 .and. ipconc >= 5 ) THEN ratio = Min( maxratiolu, draintail/xdia(mgs,lr,1) ) tmp2 = gaminterp(ratio,alpha(mgs,lr),4,1) qxd1 = qx(mgs,lr)*(tmp2) qrbreak = dtpinv*qxd1 crbreaksmall = rho0(mgs)*qrbreak/(xdn(mgs,lr)*pi/6.*drsmall**3) IF ( ( qxd1 > qxmin(lr)) ) THEN tmp = gaminterp(ratio,alpha(mgs,lr),1,1) IF ( ipconc == 5 ) THEN ENDIF cxd1 = cx(mgs,lr)*( tmp) IF ( rho0(mgs)*qx(mgs,lr) > qrbrthresh2 ) THEN flim = 1.0 ELSE flim = (rho0(mgs)*qx(mgs,lr) - qrbrthresh1)/(qrbrthresh2 - qrbrthresh1) ENDIF crbreak = flim*(crbreaksmall - dtpinv*cxd1) cracr(mgs) = cracr(mgs) - crbreak ELSEIF ( irainbreak == 12 ) THEN crbreak = Max( 0.0, 3.8098 * (rho0(mgs)*qx(mgs,lr))**1.9416 ) cracr(mgs) = cracr(mgs) - crbreak ENDIF ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' chacw(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( ipconc .ge. 5 ) THEN IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) chacw(mgs) = Min( chacw(mgs), 0.5*(cx(mgs,lc) - ccwresv(mgs))*dtpinv ) ELSE qhacw(mgs) = 0.0 ENDIF ELSE chacw(mgs) = & & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & & *( gf1*xdia(mgs,lc,2) & & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & & + gf3*xdia(mgs,lh,2) ) chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)*dtpinv) ENDIF end do end if 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 IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab0lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & da0(li)*xdia(mgs,li,3)**2 ) ELSE chaci0(mgs) = & & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & & *( gf1*xdia(mgs,li,2) & & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & & + gf3*xdia(mgs,lh,2) ) ENDIF chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) ENDIF end do end if 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 IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab0lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da0(ls)*xdia(mgs,ls,3)**2 ) ELSE chacs0(mgs) = & & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & & *( gf3*gf1*xdia(mgs,ls,2) & & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & & + gf1*gf3*xdia(mgs,lh,2) ) ENDIF chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' chlacw(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)*dtpinv ) ELSE qhlacw(mgs) = 0.0 ENDIF ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' chlaci(:) = 0.0 chlaci0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & da0(li)*xdia(mgs,li,3)**2 ) ENDIF chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) ENDIF end do end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' chlacs(:) = 0.0 chlacs0(:) = 0.0 if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN IF ( ipconc .ge. 5 ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da0(ls)*xdia(mgs,ls,3)**2 ) ENDIF chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) ENDIF end do end if IF ( ipconc .ge. 2 ) THEN if (ndebug .gt. 0 ) write(0,*) 'conc 26a' DO mgs = 1,ngscnt zrcnw(mgs) = 0.0 qrcnw(mgs) = 0.0 crcnw(mgs) = 0.0 cautn(mgs) = 0.0 ENDDO IF ( dmrauto >= -1 ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN volb = xv(mgs,lc)*(1./(1.+alpha(mgs,lc)))**(1./2.) cautn(mgs) = Min(ccmxd(mgs), & & ((alpha(mgs,lc)+2.)/(alpha(mgs,lc)+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) cautn(mgs) = Max( 0.0d0, cautn(mgs) ) IF ( rb(mgs) .le. 7.51d-6 .or. dmrauto == -1) THEN t2s = 1.d30 ELSE t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) IF ( dmrauto == 0 ) THEN IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) ELSEIF ( ( dmropt == 1 .or. dmropt == 3 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = Min(tmp,crcnw(mgs) ) ELSEIF ( ( dmropt == 4 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) ELSEIF ( ( dmropt == 5 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*qx(mgs,lc)+tmp2*qx(mgs,lr))/(qx(mgs,lc)+qx(mgs,lr)) ELSEIF ( ( dmropt == 6 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*xdia(mgs,lc,3)*qx(mgs,lc)+tmp2*xdia(mgs,lr,3)*qx(mgs,lr))/ & (xdia(mgs,lc,3)*qx(mgs,lc)+xdia(mgs,lr,3)*qx(mgs,lr)) ELSEIF ( ( dmropt == 7 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*xdia(mgs,lc,3)+tmp2*xdia(mgs,lr,3))/(xdia(mgs,lc,3)+xdia(mgs,lr,3)) ELSEIF ( ( dmropt == 8 ) .and. qx(mgs,lr) > qxmin(lr) ) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*sqrt(xdia(mgs,lc,3))+tmp2*sqrt(xdia(mgs,lr,3)))/ & (sqrt(xdia(mgs,lc,3))+sqrt(xdia(mgs,lr,3))) ENDIF ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN IF ( qx(mgs,lr) > qxmin(lr) ) THEN tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = Min(tmp,crcnw(mgs) ) ENDIF ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN tmp = crcnw(mgs) tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) ENDIF IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 IF ( ipconc >= 6 ) THEN IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN 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 zrcnw(mgs) = tmp4 ELSEIF ( dmrauto == 2 ) THEN zrcnw(mgs) = (tmp3*qrcnw(mgs)+tmp4*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) ENDIF else IF ( imurain == 3 ) THEN vr = rho0(mgs)*qrcnw(mgs)/(1000.) zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2) ELSE 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 ENDIF endif ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ELSE if ( ircnw .eq. 4 ) then do mgs = 1,ngscnt qrcnw(mgs) = 0.0 qdiff = max((qx(mgs,lc)-qminrncw),0.0) if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then argrcnw = & & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw qrcnw(mgs) = (max(qrcnw(mgs),0.0)) end if end do ENDIF if ( ircnw .eq. 5 ) then do mgs = 1,ngscnt qrcnw(mgs) = 0.0 qrcnw(mgs) = 0.0 qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) qdiff = max((qx(mgs,lc)-qccrit),0.) if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then argrcnw = & & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) qrcnw(mgs) = & & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) end if end do end if if ( ircnw .eq. 2 ) then do mgs = 1,ngscnt qrcnw(mgs) = 0.0 qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) end do end if if ( ircnw .eq. 1 ) then do mgs = 1,ngscnt qrcnw(mgs) = 0.0 c1 = 0.2 c4 = pi/(6.0) bradp = & & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) bl2 = & & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) bt2 = (bradp -7.5) / (3.72) qrcnw(mgs) = 0.0 if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & & * qx(mgs,lc) * qx(mgs,lc) end if end do end if ENDIF if (ndebug .gt. 0 ) write(0,*) 'conc 27a' qrfrz(:) = 0.0 qrfrzs(:) = 0.0 qrfrzf(:) = 0.0 vrfrzf(:) = 0.0 crfrz(:) = 0.0 crfrzs(:) = 0.0 crfrzf(:) = 0.0 zrfrz(:) = 0.0 zrfrzs(:) = 0.0 zrfrzf(:) = 0.0 qwcnr(:) = 0.0 IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN do mgs = 1,ngscnt if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then IF ( ipconc .lt. 3 ) THEN qrfrz(mgs) = & & min( & & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & & , qrmxd(mgs)) qrfrzf(mgs) = qrfrz(mgs) ELSEIF ( ipconc .ge. 3 ) THEN frach = 1.0d0 IF ( ibiggopt == 2 .and. imurain == 1 ) THEN volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 dbigg = (6./pi* volt )**(1./3.) IF ( dbigg < 8.e-3 ) THEN ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) IF ( alp0flag ) THEN j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) ELSE j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) ENDIF delx = ratio - float(i)*dqiacrratio dely = alpha(mgs,lr) - float(j)*dqiacralpha ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv crfrzf(mgs) = crfrz(mgs) tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv qrfrzf(mgs) = qrfrz(mgs) IF ( qrfrz(mgs)*dtp < qxmin(lh) .or. crfrz(mgs)*dtp < cxmin ) THEN crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 qrfrzf(mgs) = 0.0 ELSE IF ( ipconc >= 5 .or. lzr > 1 ) THEN cxd1 = crfrz(mgs)*dtp qxd1 = qrfrz(mgs)*dtp tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) IF ( ipconc >= 6 .and. lzr > 1 ) THEN zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*zx(mgs,lr) zrfrz(mgs) = zxd1*dtpinv tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) tmp4 = tmp3/cxd1 IF ( tmp4 > zxd1 ) THEN cxd1 = tmp3/zxd1 crfrzf(mgs) = dtpinv*cxd1 ENDIF ELSE tmp5 = g1x(mgs,lr)*(rho0(mgs)*qx(mgs,lr))**2/((pi*xdn(mgs,lr)/6.)**2*cx(mgs,lr)) zxd1 = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*tmp5 tmp3 = g1x(mgs,lr)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lr)/6.0)**2) tmp4 = tmp3/cxd1 IF ( tmp4 > zxd1 ) THEN crfrzf(mgs) = tmp3/zxd1*dtpinv ENDIF ENDIF ENDIF IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 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 crfrzs(mgs) = crfrz(mgs) qrfrzs(mgs) = qrfrz(mgs) IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN crfrzf(mgs) = 0.0 qrfrzf(mgs) = 0.0 IF (ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) zrfrzf(mgs) = 0. ENDIF ELSE ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) IF ( alp0flag ) THEN j = Int(Max(0.0,Min(alphamax,alpha(mgs,lr)))*dqiacralphainv) ELSE j = Int(Max(minalphalu,Min(maxalphalu,alpha(mgs,lr)))*dqiacralphainv) ENDIF delx = ratio - float(i)*dqiacrratio dely = alpha(mgs,lr) - float(j)*dqiacralpha ip1 = Min( i+1, nqiacrratio ) jp1 = Min( j+1, nqiacralpha ) tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)*dtpinv tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)*dtpinv crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) IF ( ipconc >= 6 .and. lzr > 1 ) THEN zrfrzs(mgs) = zrfrz(mgs) tmp1 = ziacrratio(i,j) + delx*dqiacrratioinv*(ziacrratio(ip1,j) - ziacrratio(i,j)) tmp2 = ziacrratio(i,jp1) + delx*dqiacrratioinv*(ziacrratio(ip1,jp1) - ziacrratio(i,jp1)) 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 IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) qrfrz(mgs) = fac*qrfrz(mgs) qrfrzs(mgs) = fac*qrfrzs(mgs) qrfrzf(mgs) = fac*qrfrzf(mgs) 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 ELSEIF ( ibiggopt == 1 ) THEN tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN crfrz(mgs) = cxmxd(mgs,lr) qrfrz(mgs) = qxmxd(mgs,lr) ELSE crfrz(mgs) = tmp IF ( lzr < 1 ) THEN IF ( imurain == 3 ) THEN bfnu = bfnu0 ELSE bfnu = bfnu1 ENDIF ELSE IF ( imurain == 3 ) THEN bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) ELSE bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) ENDIF ENDIF qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)*dtpinv ) crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)*dtpinv ) qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) qrfrzf(mgs) = qrfrz(mgs) ENDIF IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) crfrzs(mgs) = (1.-frach)*crfrz(mgs) ENDIF IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN qrfrzs(mgs) = qrfrz(mgs) crfrzs(mgs) = crfrz(mgs) ELSE qrfrzf(mgs) = frach*qrfrz(mgs) IF ( ibfr .le. 1 ) THEN crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ELSEIF ( ibfr .eq. 5 ) THEN crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) ELSEIF ( ibfr .eq. 2 ) THEN crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ELSEIF ( ibfr .eq. 6 ) THEN crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ELSE crfrzf(mgs) = frach*crfrz(mgs) ENDIF ENDIF ELSE crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 ENDIF ENDIF IF ( lvol(lh) .gt. 1 ) THEN vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz ENDIF IF ( nsplinter .ne. 0 ) THEN IF ( nsplinter .ge. 1000 ) THEN tmp = 0 IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.) fac = 1.0 IF ( nsplinter .eq. 1001 ) THEN fac = 0.2*Exp(-0.5*((258.-temg(mgs))/10.)**2 ) ENDIF tmp = fac*lawson_splinter_fac*tmpdiam**4*crfrz(mgs) ENDIF ELSEIF ( nsplinter .gt. 0 ) THEN tmp = nsplinter*crfrz(mgs) ELSE tmp = -nsplinter*crfrzf(mgs) ENDIF csplinter2(mgs) = tmp qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ENDIF ENDIF else end if end do ENDIF if (ndebug .gt. 0 ) write(0,*) 'conc 25b' do mgs = 1,ngscnt qwfrz(mgs) = 0.0 cwfrz(mgs) = 0.0 qwfrzc(mgs) = 0.0 cwfrzc(mgs) = 0.0 qwfrzp(mgs) = 0.0 cwfrzp(mgs) = 0.0 IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN IF ( ipconc < 2 ) THEN qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & & *rho0(mgs)*(qx(mgs,lc)**2) qwfrz(mgs) = max(qwfrz(mgs), 0.0) qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) ELSEIF ( ipconc .ge. 2 ) THEN IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 IF ( alpha(mgs,lc) == 0.0 ) THEN cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))*dtpinv qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) ELSE ratio = (1. + alpha(mgs,lc))*volt/xv(mgs,lc) IF ( .false. .and. usegamxinfcnu ) THEN i = Nint(dgami*(1. + alpha(mgs,lc))) gcnup1 = gmoi(i) i = Nint(dgami*(2. + alpha(mgs,lc))) gcnup2 = gmoi(i) cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+alpha(mgs,lc), ratio)/(dtp*gcnup1) qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*Gamxinf(2.+alpha(mgs,lc), ratio)/(dtp*gcnup2) ELSE ratio = Min( maxratiolu, ratio ) tmp = gaminterp(ratio,alpha(mgs,lc),1,1) cwfrz(mgs) = cx(mgs,lc)*tmp*dtpinv tmp = gaminterp(ratio,alpha(mgs,lc),12,1) qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*xv(mgs,lc)*rhoinv(mgs)*dtpinv*tmp ENDIF ENDIF ENDIF ENDIF if ( temg(mgs) .gt. 268.15 ) then qwfrz(mgs) = 0.0 cwfrz(mgs) = 0.0 end if end if ENDIF if ( xplate(mgs) .eq. 1 ) then qwfrzp(mgs) = qwfrz(mgs) cwfrzp(mgs) = cwfrz(mgs) end if if ( xcolmn(mgs) .eq. 1 ) then qwfrzc(mgs) = qwfrz(mgs) cwfrzc(mgs) = cwfrz(mgs) end if end do if (ndebug .gt. 0 ) write(0,*) 'conc 25a' do mgs = 1,ngscnt ccia(mgs) = 0.0 cwctfz(mgs) = 0.0 qwctfz(mgs) = 0.0 ctfzbd(mgs) = 0.0 ctfzth(mgs) = 0.0 ctfzdi(mgs) = 0.0 cwctfzc(mgs) = 0.0 qwctfzc(mgs) = 0.0 cwctfzp(mgs) = 0.0 qwctfzp(mgs) = 0.0 IF ( icfn .ge. 1 ) THEN IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN IF ( icfn .ge. 2 ) THEN ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) ctfzbd(mgs) = fn1(mgs)*dfar(mgs) ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) ELSEIF ( icfn .eq. 1 ) THEN IF ( wvel(mgs) .lt. -0.05 ) THEN cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) ENDIF ENDIF IF ( ipconc .ge. 2 ) THEN cwctfz(mgs) = Min( cwctfz(mgs)*dtpinv, ccmxd(mgs) ) qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) ELSE qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) qwctfz(mgs) = max(qwctfz(mgs), 0.0) qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) ENDIF if ( xplate(mgs) .eq. 1 ) then qwctfzp(mgs) = qwctfz(mgs) cwctfzp(mgs) = cwctfz(mgs) end if if ( xcolmn(mgs) .eq. 1 ) then qwctfzc(mgs) = qwctfz(mgs) cwctfzc(mgs) = cwctfz(mgs) end if end if ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'conc 23a' dthr = 300.0 hrifac = (1.e-3)*((0.044)*(0.01**3)) do mgs = 1,ngscnt ciihr(mgs) = 0.0 qiihr(mgs) = 0.0 cicichr(mgs) = 0.0 qicichr(mgs) = 0.0 cipiphr(mgs) = 0.0 qipiphr(mgs) = 0.0 IF ( ihrn .ge. 1 ) THEN if ( qx(mgs,lc) .gt. qxmin(lc) ) then if ( temg(mgs) .lt. 273.15 ) then IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN ciihr(mgs) = ((1.69e17)/dthr) & & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) ciihr(mgs) = ciihr(mgs)*(1.0e6) qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) qiihr(mgs) = max(qiihr(mgs), 0.0) qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) ENDIF if ( xplate(mgs) .eq. 1 ) then qipiphr(mgs) = qiihr(mgs) cipiphr(mgs) = ciihr(mgs) end if if ( xcolmn(mgs) .eq. 1 ) then qicichr(mgs) = qiihr(mgs) cicichr(mgs) = ciihr(mgs) end if end if end if ENDIF end do hdia0 = 300.0e-6 do mgs = 1,ngscnt qscnvi(mgs) = 0.0 cscnvi(mgs) = 0.0 cscnvis(mgs) = 0.0 IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN IF ( ipconc .ge. 4 .and. .false. ) THEN if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then cirdiatmp = & & (qx(mgs,li)*rho0(mgs) & & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) IF ( cirdiatmp .gt. 100.e-6 ) THEN qscnvi(mgs) = & & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & & *exp(-hdia0/cirdiatmp) & & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) qscnvi(mgs) = & & min(qscnvi(mgs),qimxd(mgs)) IF ( ipconc .ge. 4 ) THEN cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) ENDIF ENDIF end if ELSEIF ( ipconc .lt. 4 ) THEN qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) cscnvis(mgs) = 0.5*cscnvi(mgs) ENDIF ENDIF end do do mgs = 1,ngscnt fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) end do if ( ndebug .gt. 0 ) write(0,*) 'civent' civenta = 1.258e4 civentb = 2.331 civentc = 5.662e4 civentd = 2.373 civente = 0.8241 civentf = -0.042 civentg = 1.70 do mgs = 1,ngscnt IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN IF ( qx(mgs,li) .gt. qxmin(li) ) THEN cireyn = & & (civenta*xdia(mgs,li,1)**civentb & & +civentc*xdia(mgs,li,1)**civentd) & & / & & (civente*xdia(mgs,li,1)**civentf+civentg) xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) if ( xcivent .lt. 1.0 ) then civent(mgs) = 1.0 + 0.14*xcivent**2 end if if ( xcivent .ge. 1.0 ) then civent(mgs) = 0.86 + 0.28*xcivent end if ELSE civent(mgs) = 0.0 ENDIF ENDIF end do igmrwa = 100.0*2.0 igmrwb = 100.*((5.0+br)/2.0) rwventa = (0.78)*gmoi(igmrwa) rwventb = (0.308)*gmoi(igmrwb) do mgs = 1,ngscnt IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN IF ( ipconc .ge. 3 ) THEN IF ( imurain == 3 ) THEN IF ( izwisventr == 1 ) THEN rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) ELSE rwvent(mgs) = & & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & & *Sqrt((ar*rhovt(mgs))) & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) ENDIF ELSE IF ( iferwisventr == 1 ) THEN alpr = Min(alpharmax,alpha(mgs,lr) ) x = 1. + alpha(mgs,lr) IF ( ipconc >= 6 .and. lzr > 1 ) THEN tmp = 1. + alpr 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 ELSE y = ventrxn(mgs) ENDIF vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr)) rwvent(mgs) = & & 0.78*x + & & 0.308*fvent(mgs)*y* & & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) rwventz(mgs) = 0.0 ELSEIF ( iferwisventr == 2 ) THEN x = 1. + alpha(mgs,lr) rwvent(mgs) = & & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & & *Sqrt((ar*rhovt(mgs))) & & *(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. + 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 ENDIF ELSE rwvent(mgs) = & & (rwventa + rwventb*fvent(mgs) & & *Sqrt((ar*rhovt(mgs))) & & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) ENDIF ELSE rwvent(mgs) = 0.0 ENDIF end do igmswa = 100.0*2.0 igmswb = 100.*((5.0+ds)/2.0) swventa = (0.78)*gmoi(igmswa) swventb = (0.308)*gmoi(igmswb) do mgs = 1,ngscnt IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN IF ( ipconc .ge. 4 ) THEN swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) ELSE swvent(mgs) = & & (swventa + swventb*fvent(mgs) & & *Sqrt((cs*rhovt(mgs))) & & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) ENDIF ELSE swvent(mgs) = 0.0 ENDIF end do igmhwa = 100.0*2.0 igmhwb = 100.0*2.75 hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) 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) IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN hwvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & & *(xdia(mgs,lh,1)**(0.75))) ELSE x = 1. + alpha(mgs,lh) tmp = 1 + alpha(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxx(mgs,lh)))*Sqrt(axx(mgs,lh)*rhovt(mgs)) hwvent(mgs) = & & ( 0.78*x + y*hwventy(mgs) ) ENDIF ELSE hwvent(mgs) = 0.0 hwventy(mgs) = 0.0 ENDIF end do hlvent(:) = 0.0 hlventy(:) = 0.0 IF ( lhl .gt. 1 ) THEN igmhwa = 100.0*2.0 igmhwb = 100.0*2.75 hwventa = (0.78)*gmoi(igmhwa) hwventb = (0.308)*gmoi(igmhwb) do mgs = 1,ngscnt IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN hwventc = (4.0*gr/(3.0*cdxgs(mgs,lhl)))**(0.25) IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN hlvent(mgs) = & & ( hwventa + hwventb*hwventc*fvent(mgs) & & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & & *(xdia(mgs,lhl,1)**(0.75))) ELSE x = 1. + alpha(mgs,lhl) tmp = 1 + alpha(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxx(mgs,lhl)))*Sqrt(axx(mgs,lhl)*rhovt(mgs)) hlvent(mgs) = 0.78*x + y*hlventy(mgs) ENDIF ENDIF end do ENDIF do mgs = 1,ngscnt fwet1(mgs) = & & (2.0*pi)* & & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & & -ftka(mgs)*temcg(mgs) ) & & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) fwet2(mgs) = & & (1.0)-fci(mgs)*temcg(mgs) & & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) end do do mgs = 1,ngscnt fmlt1(mgs) = (2.0*pi)* & & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & & -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 do mgs = 1,ngscnt fvds(mgs) = & & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & & (1.0/(fai(mgs)+fbi(mgs))) end do do mgs = 1,ngscnt fvce(mgs) = & & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & & (1.0/(fav(mgs)+fbv(mgs))) end do qsmlr(:) = 0.0 qimlr(:) = 0.0 qhmlr(:) = 0.0 qhlmlr(:) = 0.0 IF ( lhwlg > 1 ) THEN qhmlrlg(:) = 0.0 qhlmlrlg(:) = 0.0 ENDIF qhfzh(:) = 0.0 qffzf(:) = 0.0 qhlfzhl(:) = 0.0 qhfzhlg(:) = 0.0 qhlfzhllg(:) = 0.0 vhfzh(:) = 0.0 vffzf(:) = 0.0 vhlfzhl(:) = 0.0 qsfzs(:) = 0.0 zhmlr(:) = 0.0 zhmlrr(:) = 0.0 zsmlrr(:) = 0.0 zhshr(:) = 0.0 zhlmlr(:) = 0.0 zhlshr(:) = 0.0 zhshrr(:) = 0.0 zhlmlrr(:) = 0.0 zhlshrr(:) = 0.0 csmlr(:) = 0.0 csmlrr(:) = 0.0 chmlr(:) = 0.0 chmlrr(:) = 0.0 chlmlr(:) = 0.0 chlfmlr(:) = 0.0 chlmlrr(:) = 0.0 if ( .not. mixedphase ) then do mgs = 1,ngscnt IF ( temg(mgs) .gt. tfr ) THEN IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN qsmlr(mgs) = & & min( & & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & & , 0.0 ) ENDIF IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN qhmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN write(0,*) 'ibinhmlr = 1 not available for 2-moment' STOP ELSEIF ( ibinhmlr == 2 .or. ibinhmlr == 3 ) THEN ENDIF IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) vhsoak(mgs) = Min(v1,v2) ENDIF ENDIF IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN qhlmlr(mgs) = & & meltfac*min( & & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacwmlr(mgs)) & & , 0.0 ) ELSEIF ( ibinhlmlr == 1 ) THEN ELSEIF ( ibinhlmlr == -1 ) THEN ENDIF IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) vhlsoak(mgs) = Min(v1,v2) ENDIF ENDIF ENDIF ENDIF if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) IF ( .not. mixedphase ) THEN qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.95*qx(mgs,lh)*dtpinv ) ) chmlr(mgs) = max( chmlr(mgs), Min( -chmxd(mgs), -0.95*cx(mgs,lh)*dtpinv ) ) ENDIF qhmlh(mgs) = 0. IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.95*qx(mgs,lhl)*dtpinv ) ) chlmlr(mgs) = max( chlmlr(mgs), Min( -cxmxd(mgs,lhl), -0.95*cx(mgs,lhl)*dtpinv ) ) ENDIF end do endif if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) IF ( .not. mixedphase ) THEN IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) ENDIF csmlrr(mgs) = csmlr(mgs)/rzxs(mgs) IF ( -csmlrr(mgs)*dtp > cxmin .and. -qsmlr(mgs)*dtp > qxmin(lr) .and. snowmeltdia > 0.0 ) THEN rmas = rho0(mgs)*qsmlr(mgs)/csmlrr(mgs) IF ( rmas > snowmeltmass ) THEN csmlrr(mgs) = rho0(mgs)*qsmlr(mgs)/snowmeltmass ENDIF ENDIF IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN tmp = 1. + alpha(mgs,lh) i = Int(dgami*(tmp)) del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxx(mgs,lh), ratio)/g1palp hwvent1 = 0.78*x + y*hwventy(mgs) qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) ENDIF ENDIF IF ( chmlr(mgs) < 0.0 .and. (ibinhmlr < 1 .or. lzh < 1) ) THEN IF ( ipconc >= 6 .and. lzr .gt. 1 .and. lzh < 1 .and. qx(mgs,lh) > qxmin(lh) ) THEN tmp = qx(mgs,lh)/cx(mgs,lh) alp = alpha(mgs,lh) g1 = g1x(mgs,lh) 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 chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN IF(imltshddmr == 1) THEN tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ELSE chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ENDIF ELSE chmlrr(mgs) = chmlr(mgs) ENDIF ELSEIF ( ihmlt .eq. 0 ) THEN chmlrr(mgs) = chmlr(mgs) ENDIF ELSE chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ENDIF ENDIF IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN tmp = 1. + alpha(mgs,lhl) i = Int(dgami*(tmp)) del = tmp - dgam*i g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxx(mgs,lhl), ratio)/g1palp hwvent1 = 0.78*x + y*hlventy(mgs) qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) ENDIF ENDIF IF ( ibinhlmlr == 0 .or. lzhl < 1 ) THEN IF ( ihmlt .eq. 1 ) THEN chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN IF(imltshddmr == 1 ) THEN tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ELSE chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ENDIF ELSE chlmlrr(mgs) = chlmlr(mgs) ENDIF ELSEIF ( ihmlt .eq. 0 ) THEN chlmlrr(mgs) = chlmlr(mgs) ENDIF ELSE chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) 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 = g1x(mgs,lhl) zhlmlr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( tmp * qhlmlr(mgs) ) ENDIF ENDIF ENDIF ENDIF end do end if DO mgs = 1,ngscnt rwcap(mgs) = (0.5)*xdia(mgs,lr,1) swcap(mgs) = (0.5)*xdia(mgs,ls,1) hwcap(mgs) = (0.5)*xdia(mgs,lh,1) IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) cval = xdia(mgs,li,1) aval = cilen(mgs) eval = Sqrt(1.0-(aval**2)/(cval**2)) fval = min(0.99,eval) gval = alog( abs( (1.+fval)/(1.-fval) ) ) cicap(mgs) = cval*fval / gval ELSE cicap(mgs) = 0.0 end if ENDDO qhdsv(:) = 0.0 qhldsv(:) = 0.0 do mgs = 1,ngscnt IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN qidsv(mgs) = & & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs)*depfac qsdsv(mgs) = & & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)*depfac ELSE qidsv(mgs) = 0.0 qsdsv(mgs) = 0.0 ENDIF qhdsv(mgs) = & & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac end do IF ( DoSublimationFix ) THEN do mgs = 1,ngscnt qitmp(mgs) = qx(mgs,li) + qx(mgs,ls) + qx(mgs,lh) IF ( lis > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lis) IF ( lhl > 1 ) qitmp(mgs) = qitmp(mgs) + qx(mgs,lhl) qrtmp(mgs) = qx(mgs,lr) qctmp(mgs) = qx(mgs,lc) qsimxdep(mgs) = 0.0 qsimxsub(mgs) = 0.0 dqcitmp(mgs) = 0.0 IF ( qitmp(mgs) > qxmin(li) ) THEN qitmp1 = qitmp(mgs) qctmp1 = qctmp(mgs) felvcptmp = felvcp(mgs) felscptmp = felscp(mgs) qvtmp(mgs) = qx(mgs,lv) qss(mgs) = qvs(mgs) qsstmp = qvs(mgs) qvstmp = qvs(mgs) qisstmp = qis(mgs) thetatmp = theta(mgs) thetaptmp = thetap(mgs) temgtmp = temg(mgs) temcgtmp = temcg(mgs) qvaptmp = qx(mgs,lv) qvptmp = 0.0 qsstmp = qisstmp dqwvtmp(mgs) = ( qvtmp(mgs) - qsstmp ) do itertd = 1,2 IF ( itertd == 1 ) THEN ELSE dqcitmp(mgs) = dqci(mgs) ENDIF dqcw(mgs) = 0.0 dqci(mgs) = 0.0 dqwv(mgs) = ( qvtmp(mgs) - qsstmp ) if( dqwv(mgs) .lt. 0. ) then if( qitmp(mgs) .gt. -dqwv(mgs) ) then dqci(mgs) = dqwv(mgs) dqwv(mgs) = 0. else dqci(mgs) = -qitmp(mgs) dqwv(mgs) = dqwv(mgs) + qitmp(mgs) end if qvptmp = qvptmp - ( dqcw(mgs) + dqci(mgs) ) IF ( itertd == 2 .and. eqtset > 1 ) THEN tmp = qitmp(mgs) cvm = cv+cvv*qvtmp(mgs)+cpl*(qx(mgs,lc)+qrtmp(mgs)) & +cpigb*(tmp) felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm felscptmp = (fels(mgs)-rw*temg(mgs))/cvm ENDIF qctmp(mgs) = qctmp(mgs) + dqcw(mgs) qitmp(mgs) = qitmp(mgs) + dqci(mgs) thetaptmp = thetaptmp + & & 1./pi0(mgs)* & & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) end if IF ( dqwv(mgs) .ge. 0. ) THEN fracl(mgs) = 0.0 fraci(mgs) = 1.0 if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then end if if ( temg(mgs) .le. thnuc ) then fraci(mgs) = 1.0 fracl(mgs) = 0.0 end if gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & & / (pi0(mgs)) dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qsstmp/ & & ((temg(mgs)-cbi)**2)) if ( temg(mgs) .ge. tfr ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qsstmp/ & & ((temg(mgs)-cbw)**2)) end if delqci1=qx(mgs,li) dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) dqci(mgs) = dqvcnd(mgs)*fraci(mgs) thetaptmp = thetaptmp + & & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & & / (pi0(mgs)) qvptmp = qvptmp - ( dqvcnd(mgs) ) qctmp(mgs) = qctmp(mgs) + dqcw(mgs) qitmp(mgs) = qitmp(mgs) + dqci(mgs) IF ( itertd == 2 .and. eqtset > 1 ) THEN tmp = qitmp(mgs) cvm = cv+cvv*qvtmp(mgs)+cpl*(qctmp(mgs) +qrtmp(mgs)) & +cpigb*(tmp) felvcptmp = (felv(mgs)-rw*temg(mgs))/cvm felscptmp = (fels(mgs)-rw*temg(mgs))/cvm ENDIF END IF IF ( itertd == 1 ) THEN thetatmp = thetaptmp + theta0(mgs) temgtmp = thetatmp*pk(mgs) qvaptmp = Max((qvptmp + qv0(mgs)), 0.0) temcgtmp = temgtmp - tfr tqvcon = temgtmp-cbw ltemq = (temgtmp-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvstmp = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvstmp = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qisstmp = pqs(mgs)*tabqis(ltemq) qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) qvtmp(mgs) = max( 0.0, qvaptmp ) qsstmp = qisstmp ELSE qctmp(mgs) = max( 0.0, qctmp(mgs) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) IF ( qitmp(mgs) < qitmp1 ) THEN qsimxsub(mgs) = (qitmp1 - qitmp(mgs))*dtpinv ELSEIF ( qitmp(mgs) > qitmp1 ) THEN qsimxdep(mgs) = (qitmp(mgs) - qitmp1)*dtpinv ENDIF ENDIF end do ENDIF end do ELSE DO mgs = 1,ngscnt qsimxdep(mgs) = qvimxd(mgs) qsimxsub(mgs) = 1.e20 ENDDO ENDIF 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 qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.5*qx(mgs,li)*dtpinv ) ) IF ( temg(mgs) < tfr .or. .not. qsmlr(mgs) < 0.0 ) THEN qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) ENDIF qidpv(mgs) = Max(qidsv(mgs), 0.0) qsdpv(mgs) = Max(qsdsv(mgs), 0.0) IF ( qsmlr(mgs) < 0.0 .and. .not. mixedphase ) THEN qscev(mgs) = evapfac* & & 4.0*pi*(qx(mgs,lv)-qss0(mgs))*cx(mgs,ls)*swcap(mgs)*swvent(mgs)/(qss0(mgs)*(fav(mgs)+fbv(mgs))) qscev(mgs) = Max( Min(0.0,qscev(mgs)), Min( -qsmxd(mgs), -0.5*qx(mgs,ls)*dtpinv ) ) ELSE ENDIF ELSE qisbv(mgs) = 0.0 qssbv(mgs) = 0.0 qidpv(mgs) = 0.0 qsdpv(mgs) = 0.0 ENDIF qhsbv(mgs) = 0.0 qhdpv(mgs) = 0.0 IF ( qx(mgs,lh) > qxmin(lh) ) THEN IF ( temg(mgs) < tfr .or. .not. qhmlr(mgs) < 0.0 ) THEN 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 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 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) IF ( temp1 .gt. qsimxdep(mgs) ) THEN frac = qsimxdep(mgs)/temp1 qidpv(mgs) = frac*qidpv(mgs) qsdpv(mgs) = frac*qsdpv(mgs) qhdpv(mgs) = frac*qhdpv(mgs) qhldpv(mgs) = frac*qhldpv(mgs) ENDIF temp1 = qisbv(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) IF ( temp1 < -qsimxsub(mgs) ) THEN frac = -qsimxsub(mgs)/temp1 qisbv(mgs) = frac*qisbv(mgs) qssbv(mgs) = frac*qssbv(mgs) qhsbv(mgs) = frac*qhsbv(mgs) qhlsbv(mgs) = frac*qhlsbv(mgs) ENDIF end do if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) csdpv(mgs) = 0.0 cidpv(mgs) = 0.0 cisdpv(mgs) = 0.0 chdpv(mgs) = 0.0 chldpv(mgs) = 0.0 end do end if if (ndebug .gt. 0 ) write(0,*) 'conc 29a' do mgs = 1,ngscnt qscni(mgs) = 0.0 cscni(mgs) = 0.0 cscnis(mgs) = 0.0 if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then IF ( iscni .eq. 1 ) THEN qscni(mgs) = & & pi*rho0(mgs)*((0.25)/(6.0)) & & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & & *vtxbar(mgs,li,1)/xmas(mgs,li) cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) cscnis(mgs) = 0.5*cscni(mgs) ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(rho_qs*xvmn(ls),xmas(mgs,li)) cscnis(mgs) = cscni(mgs) ENDIF IF ( iscni .ne. 4 ) THEN tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) ENDIF ELSEIF ( iscni .eq. 3 ) THEN qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) cscnis(mgs) = 0.5*cscni(mgs) ENDIF ELSEIF ( ipconc < 4 ) THEN IF ( lwsm6 ) THEN qimax = rhoinv(mgs)*roqimax qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) ) ELSE qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) ENDIF else if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then qscni(mgs) = & & pi*rho0(mgs)*((0.25)/(6.0)) & & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & & *vtxbar(mgs,li,1)/xmas(mgs,li) cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) end if end if end do IF ( incwet < 1 ) THEN dhwet(:) = d1t dhlwet(:) = d1t dfwet(:) = d1t ENDIF IF ( incwet >= 1 ) THEN dhwet(:) = dg0thresh + 0.0001 dhlwet(:) = dg0thresh + 0.0001 dfwet(:) = dg0thresh + 0.0001 DO mgs = 1,ngscnt 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)) IF (((qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin .and. & temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN 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 )) 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 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) 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 ELSE ah = 1.0 + 0.108*x2**2 ENDIF 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) IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT ENDDO ENDIF dhwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin )) ELSE dhwet(mgs) = dg0thresh + 0.0001 ENDIF IF (((qhlacw(mgs) + qhlacr(mgs))*dtp > qxmin(lhl) .and. qx(mgs,lhl) > 0.01e-3 & .and. temg(mgs) .le. tfr + wetgrthtoffset .and. temg(mgs) .ge. 243.15 ) ) THEN x = 1.1e4 * rho0(mgs)*(ehlw(mgs)*qx(mgs,lc)+ehlr(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 )) 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 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, ehlw(mgs))*qx(mgs,lc) h4 = ehlr(mgs)* qx(mgs,lr) DO n = 1,10 d = Max(d, 1.e-4) dold = d vth = axx(mgs,lhl)*d**bxx(mgs,lhl) x2 = fventh*sqrtrhovt*Sqrt(d*vth) IF ( x2 > 1.4 ) THEN ah = 0.78 + 0.308*x2 ELSE ah = 1.0 + 0.108*x2**2 ENDIF 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) IF ( Abs(dold - d)/dold < 0.05 .or. ( n > 3 .and. d > dg0thresh ) ) EXIT ENDDO ENDIF dhlwet(mgs) = Min(dg0thresh + 0.0001, Max( d, dwetmin ) ) ELSE dhlwet(mgs) = dg0thresh + 0.0001 ENDIF ENDDO ENDIF do mgs = 1,ngscnt qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & & + qsaci(mgs) qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & & + qhacr(mgs) & & + qhacw(mgs) qhldry(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & & + qhlacr(mgs) & & + qhlacw(mgs) ENDIF end do do mgs = 1,ngscnt IF ( tfrdry < temg(mgs) .and. temg(mgs) < tfr ) 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)) IF ( incwet == 1 .and. qhwet(mgs) < qhdry(mgs) .and. dhwet(mgs) < dg0thresh ) THEN ratio = Min( maxratiolu, dhwet(mgs)/xdia(mgs,lh,1) ) tmp1 = gaminterp(ratio,alpha(mgs,lh),13,1) tmp2 = gaminterp(ratio,alpha(mgs,lh),12,1) tmp3 = gaminterp(ratio,alpha(mgs,lh), 9,1) IF ( qhacw(mgs)*dtp > qxmin(lh) ) THEN vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) qxacwtmp = 0.25*pi*ehw(mgs)*cx(mgs,lh)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & & tmp2*dab1lh(mgs,lh,lc)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) ELSE qxacwtmp = 0.0 ENDIF IF ( qhacr(mgs)*dtp > qxmin(lh) ) THEN vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) qxacrtmp = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & & tmp2*dab1lh(mgs,lh,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) ELSE qxacrtmp = 0.0 ENDIF x = gaminterp(ratio,alpha(mgs,lh),9,1) y = gaminterp(ratio,alpha(mgs,lh),3,1) hxventtmp = 0.78*x + y*hwventy(mgs) qxacitmp = 0.0 IF ( qhaci(mgs)*dtp > qxmin(lh) ) THEN vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) qxacitmp = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & & ( tmp1*da0lh(mgs)*xdia(mgs,lh,3)**2 + & & tmp2*dab1lh(mgs,lh,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & & tmp3*da1(li)*xdia(mgs,li,3)**2 ) ENDIF qxacstmp = 0.0 IF ( qhacs(mgs)*dtp > qxmin(lh) ) THEN vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) qxacstmp = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & & dab1lh(mgs,lh,ls)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) ENDIF qxwettmp = & & xdia(mgs,lh,1)*hxventtmp*cx(mgs,lh)*fwet1(mgs) & & + fwet2(mgs)*(qxacitmp + qxacstmp) qhwet(mgs) = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) & - ehi(mgs)*qxacitmp - ehs(mgs)*qxacstmp & - qxacwtmp - qxacrtmp + qxwettmp 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 == 1 .and. qhlwet(mgs) < qhldry(mgs) .and. dhlwet(mgs) < dg0thresh ) THEN ratio = Min( maxratiolu, dhlwet(mgs)/xdia(mgs,lhl,1) ) tmp1 = gaminterp(ratio,alpha(mgs,lhl),13,2) tmp2 = gaminterp(ratio,alpha(mgs,lhl),12,2) tmp3 = gaminterp(ratio,alpha(mgs,lhl), 9,2) IF ( qhlacw(mgs)*dtp > qxmin(lhl) ) THEN vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) qxacwtmp = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*(qx(mgs,lc)-qcwresv(mgs))*vt* & & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & tmp2*dab1lh(mgs,lhl,lc)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & & tmp3*da1lc(mgs)*xdia(mgs,lc,3)**2 ) ELSE qxacwtmp = 0.0 ENDIF IF ( qhlacr(mgs)*dtp > qxmin(lhl) ) THEN vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) qxacrtmp = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & tmp2*dab1lh(mgs,lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & & tmp3*da1lr(mgs)*xdia(mgs,lr,3)**2 ) ELSE qxacrtmp = 0.0 ENDIF x = gaminterp(ratio,alpha(mgs,lhl),9,2) y = gaminterp(ratio,alpha(mgs,lhl),3,2) hxventtmp = 0.78*x + y*hlventy(mgs) qxacitmp = 0.0 IF ( qhlaci(mgs)*dtp > qxmin(lhl) ) THEN vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) qxacitmp = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & & ( tmp1*da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & tmp2*dab1lh(mgs,lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & tmp3*da1(li)*xdia(mgs,li,3)**2 ) ENDIF qxacstmp = 0.0 IF ( qhlacs(mgs)*dtp > qxmin(lhl) ) THEN vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) qxacstmp = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) ENDIF qxwettmp = & & xdia(mgs,lhl,1)*hxventtmp*cx(mgs,lhl)*fwet1(mgs) & & + fwet2(mgs)*(qxacitmp + qxacstmp) qhlwet(mgs) = qhlacw(mgs) + qhlacr(mgs) + qhlaci(mgs) + qhlacs(mgs) & - ehli(mgs)*qxacitmp - ehls(mgs)*qxacstmp & - qxacwtmp - qxacrtmp + qxwettmp ENDIF ENDIF ELSE qhwet(mgs) = qhdry(mgs) qhlwet(mgs) = qhldry(mgs) ENDIF end do qsshr(:) = 0.0 qhshr(:) = 0.0 qhlshr(:) = 0.0 qhshh(:) = 0.0 csshr(:) = 0.0 csshrr(:) = 0.0 chshr(:) = 0.0 chlshr(:) = 0.0 chshrr(:) = 0.0 chlshrr(:) = 0.0 vhshdr(:) = 0.0 vhlshdr(:) = 0.0 wetsfc(:) = .false. wetgrowth(:) = .false. wetsfchl(:) = .false. wetgrowthhl(:) = .false. do mgs = 1,ngscnt qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) qsshr(mgs) = 0.0 if ( temg(mgs) .lt. 243.15 ) then qsshr(mgs) = 0.0 qhshr(mgs) = 0.0 qhlshr(mgs) = 0.0 vhshdr(mgs) = 0.0 vhlshdr(mgs) = 0.0 wetsfc(mgs) = .false. wetgrowth(mgs) = .false. wetsfchl(mgs) = .false. wetgrowthhl(mgs) = .false. end if if ( temg(mgs) .gt. tfr ) then IF ( .false. ) THEN qsshr(mgs) = -qsdry(mgs) qhshr(mgs) = -qhdry(mgs) qhlshr(mgs) = -qhldry(mgs) ELSE qsshr(mgs) = - qsacr(mgs) - qsacw(mgs) qhlshr(mgs) = - qhlacw(mgs) - qhlacr(mgs) qhshr(mgs) = - qhacw(mgs) - qhacr(mgs) ENDIF vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) vhlshdr(mgs) = -vhlacw(mgs) - vhlacr(mgs) qhwet(mgs) = 0.0 qhlwet(mgs) = 0.0 end if wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) ENDIF end do if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 chshr(mgs) = 0.0 chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) chlshr(mgs) = 0.0 chlshrr(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN chlshr(mgs) = 0.0 chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ENDIF end do end if do mgs = 1,ngscnt if ( qsshr(mgs) .lt. 0.0 ) then qsdpv(mgs) = 0.0 qssbv(mgs) = 0.0 else qsshr(mgs) = 0.0 end if if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN IF ( iwetsoak ) THEN rimdn(mgs,lh) = xdnmx(lh) raindn(mgs,lh) = xdnmx(lh) vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) vhsoak(mgs) = Min(v1,v2) ENDIF ENDIF vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN ENDIF qhdpv(mgs) = 0.0 chdpv(mgs) = 0.0 IF ( ehi(mgs) .gt. 0.0 ) THEN qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ENDIF IF ( ehs(mgs) .gt. 0.0 ) THEN qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) ehs(mgs) = ehsmax qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ENDIF wetsfc(mgs) = .true. else end if if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then qhldpv(mgs) = 0.0 chldpv(mgs) = 0.0 IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN IF ( iwetsoak ) THEN rimdn(mgs,lhl) = xdnmx(lhl) raindn(mgs,lhl) = xdnmx(lhl) vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) IF ( v1 > v2 ) THEN vhlsoak(mgs) = v2 ELSE vhlsoak(mgs) = v1 ENDIF ELSE vhlsoak(mgs) = 0.0 ENDIF ENDIF vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN ENDIF IF ( ehli(mgs) .gt. 0.0 ) THEN qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ENDIF IF ( ehls(mgs) .gt. 0.0 ) THEN qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) ehls(mgs) = ehsmax ENDIF wetsfchl(mgs) = .true. else end if end do DO mgs = 1,ngscnt qhcni(mgs) = 0.0 chcni(mgs) = 0.0 chcnih(mgs) = 0.0 vhcni(mgs) = 0.0 IF ( iglcnvi .ge. 1 ) THEN IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,li,1)) & & /(temg(mgs)-273.15))**(rimc2) tmp = Min( Max( rimc3, tmp ), 900.0 ) IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r ENDIF ELSEIF ( iglcnvi == 3 ) THEN IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,li,1)) & & /(temg(mgs)-273.15))**(rimc2) tmp = Min( Max( rimc3, tmp ), 900.0 ) IF ( tmp .ge. xdnmn(lh) ) THEN r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) qhcni(mgs) = 0.5*qiacw(mgs) chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r ENDIF ENDIF ENDIF ENDIF ENDDO qhlcnh(:) = 0.0 chlcnh(:) = 0.0 chlcnhhl(:) = 0.0 vhlcnh(:) = 0.0 vhlcnhl(:) = 0.0 zhlcnh(:) = 0.0 qhcnhl(:) = 0.0 chcnhl(:) = 0.0 vhcnhl(:) = 0.0 zhcnhl(:) = 0.0 IF ( lhl .gt. 1 ) THEN IF ( ihlcnh == 1 .or. ihlcnh == 3 ) THEN DO mgs = 1,ngscnt IF ( hlcnhdia > 0 ) THEN ltest = xdia(mgs,lh,3) .gt. hlcnhdia ELSE ltest = xdia(mgs,lh,1)*(4. + alpha(mgs,lh)) > Abs( hlcnhdia ) ENDIF IF ( iusedw == 0 .and. ihlcnh == 1 ) THEN dg0(mgs) = -1. ELSE IF ( temg(mgs) .le. tfr+hailcnvtoffset .and. & (( (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & .and. temg(mgs) .gt. dwtempmin ) .or. ( wetgrowth(mgs) .and. qx(mgs,lh) > hlcnhqmin )) ) THEN IF ( incwet > 0 ) THEN d = dhwet(mgs) ELSE 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 )) dwr = 0.01*(exp(arg) - 1.0) ELSE dwr = 1.e30 ENDIF d = Min(dwr, dg0thresh + 0.0001) 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)) 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) 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 ELSE ah = 1.0 + 0.108*x2**2 ENDIF IF ( .false. ) THEN x1 = fventm*sqrtrhovt*Sqrt(d*vth) IF ( x1 > 1.4 ) THEN am = 0.78 + 0.308*x1 ELSE am = 1.0 + 0.108*x1**2 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 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 d = Min( d, dg0thresh + 0.0001 ) ENDIF ENDIF dg0(mgs) = Max( d, dwmin ) ELSE dg0(mgs) = dg0thresh + 0.0001 ENDIF IF ( ihlcnh == 3 .and. (qhacw(mgs) + qhacr(mgs))*dtp > qxmin(lh) .and. qx(mgs,lh) > hlcnhqmin & .and. temg(mgs) .le. tfr+hailcnvtoffset .and. temg(mgs) > 238.0 ) THEN dg0(mgs) = Min( dg0(mgs), dwmax ) ENDIF ENDIF wtest = (dg0(mgs) > 0.0 .and. dg0(mgs) < dg0thresh ) IF ( ihlcnh == 1 ) THEN IF ( ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & & rimdn(mgs,lh) .gt. 800. .and. & & ltest .and. qx(mgs,lh) .gt. hlcnhqmin ) .or. wtest ) THEN IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr+hailcnvtoffset ) THEN IF ( wtest ) THEN dh0 = dg0(mgs) ELSE x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) IF ( x > 1.e-20 ) THEN arg = Min(70.0, (-temcg(mgs)/x )) dh0 = 0.01*(exp(arg) - 1.0) ELSE dh0 = 1.e30 ENDIF dg0(mgs) = Min(dh0, dg0thresh + 0.0001) ENDIF IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) IF ( ipconc .ge. 5 ) THEN IF ( .not. wtest ) dh0 = Min( dh0, 10.e-3 ) IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = Max( dh0, xdia(mgs,lhl,3) ) 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)) chlcnh(mgs) = Max( chlcnhhl(mgs), r ) ENDIF vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) ENDIF ENDIF ENDIF ELSEIF ( ihlcnh == 3 ) THEN IF ( wtest .and. & ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > hlcnhqmin ) ) THEN IF ( ipconc == 5 ) THEN ENDIF ratio = Min( maxratiolu, dg0(mgs)/xdia(mgs,lh,1) ) tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) IF ( ipconc == 5 ) THEN ENDIF qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 flim = 1.0 tmp3 = qxmxd(mgs,lh) IF (qxd1 > tmp3 ) THEN ENDIF IF ( ( qxd1 > qxmin(lhl) .and. ipconc > 5 ) .or. ( qxd1 > 10.*qxmin(lhl) .and. ipconc == 5) ) THEN tmp = gaminterp(ratio,alpha(mgs,lh),1,1) IF ( ipconc == 5 ) THEN 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*tmp**(1./3.) + qx(mgs,lhl)*xmas(mgs,lhl)**(1./3.))/( qxd1 + qx(mgs,lhl)))**3 chlcnhhl(mgs) = Min( chlcnhhl(mgs), rho0(mgs)*qhlcnh(mgs)/dh0 ) ELSE ENDIF ENDIF 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 tmp3 = g1xmax*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) tmp4 = tmp3/cxd1 IF ( tmp4 > zxd1 ) THEN cxd1 = tmp3/zxd1 chlcnhhl(mgs) = dtpinv*cxd1 ENDIF ELSE zxd1 = 0 ENDIF IF ( ipconc == 5 ) THEN tmp3 = gaminterp(ratio,alpha(mgs,lh),11,1) tmp5 = g1x(mgs,lh)*(rho0(mgs)*qx(mgs,lh))**2/((pi*xdn(mgs,lh)/6.)**2*cx(mgs,lh)) zxd1 = flim*(tmp3)*tmp5 tmp3 = g1x(mgs,lh)*(rho0(mgs)*qxd1)**2/((pi*xdn(mgs,lh)/6.0)**2) tmp4 = tmp3/cxd1 IF ( tmp4 > zxd1 ) THEN cxd1 = tmp3/zxd1 chlcnhhl(mgs) = dtpinv*cxd1 ENDIF 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 DO mgs = 1,ngscnt IF ( qhacw(mgs)*dtp > qxmin(lh) .and. temg(mgs) .lt. tfr+hailcnvtoffset .and. qx(mgs,lh) > qxmin(lh) ) THEN ratio = Min( maxratiolu, hldia1/xdia(mgs,lh,1) ) tmp = gaminterp(ratio,alpha(mgs,lh),1,1) cxd1 = cx(mgs,lh)*( tmp) chlcnh(mgs) = dtpinv*cxd1 chlcnhhl(mgs) = chlcnh(mgs) tmp2 = gaminterp(ratio,alpha(mgs,lh),4,1) qxd1 = qx(mgs,lh)*(tmp2) qhlcnh(mgs) = dtpinv*qxd1 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 ELSEIF ( ihlcnh == 0 ) THEN do mgs = 1,ngscnt if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then if ( qhacw(mgs).gt.1.e-6 .and. ( xdn(mgs,lh) > 700. .or. lvh == 0 ) ) then qhlcnh(mgs) = & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & *exp(-hldia1/xdia(mgs,lh,1)) & *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) IF ( ipconc .ge. 5 ) THEN chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) chlcnhhl(mgs) = chlcnh(mgs) ENDIF vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) end if end if end do ENDIF IF ( icvhl2h >= 1 ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) qhcnhl(mgs) = tmp*qx(mgs,lhl)*dtpinv chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) ENDIF ENDDO ENDIF ENDIF DO mgs = 1,ngscnt qhcns(mgs) = 0.0 chcns(mgs) = 0.0 chcnsh(mgs) = 0.0 vhcns(mgs) = 0.0 qscnh(mgs) = 0.0 cscnh(mgs) = 0.0 vscnh(mgs) = 0.0 IF ( ipconc .ge. 5 ) THEN IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN IF ( xdn(mgs,lh) < 290. ) THEN ENDIF ENDIF IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN IF ( iglcnvs .eq. 1 ) THEN dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) a3 = 1./(rho0(mgs)*qx(mgs,ls)) a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) chcnsh(mgs) = chcns(mgs) qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) ELSEIF ( iglcnvs .ge. 2 ) THEN IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & ( iglcnvs >= 3 .and. qsacw(mgs)*dtp > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,ls,1)) & & /(temg(mgs)-273.15))**(rimc2) tmp = Min( tmp , 900.0 ) IF ( iglcnvs == 2 ) THEN IF ( tmp .ge. 200.0 ) THEN r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r ENDIF ELSEIF ( iglcnvs == 3 ) THEN IF ( tmp > xdnmn(lh) ) THEN r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) qhcns(mgs) = 0.5*qsacw(mgs) chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls)) chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r ENDIF ENDIF ENDIF ENDIF ENDIF ELSE qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) ENDIF ENDDO if ( irwfrz .gt. 0 .and. .not. mixedphase) then do mgs = 1,ngscnt qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) qrzmax(mgs) = & & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) qrzmax(mgs) = max(qrzmax(mgs), 0.0) qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) qrzmax(mgs) = min(qx(mgs,lr)*dtpinv, qrzmax(mgs)) IF ( temcg(mgs) < -30. ) THEN qrzmax(mgs) = qx(mgs,lr)*dtpinv ENDIF IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) ELSE qrzfac(mgs) = 1.0 ENDIF qrzfac(mgs) = min(1.0, qrzfac(mgs)) end do do mgs = 1,ngscnt if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) end if end do end if qrcev(:) = 0.0 crcev(:) = 0.0 do mgs = 1,ngscnt IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN qrcev(mgs) = & & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac IF ( rcond .eq. 1 ) THEN qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) ELSE qrcev(mgs) = min(qrcev(mgs), 0.0) ENDIF qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN 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 ENDIF end do IF ( lhwlg > 1 ) THEN qhcevlg(:) = 0.0 chcevlg(:) = 0.0 ENDIF IF ( lhlwlg > 1 ) THEN qhlcevlg(:) = 0.0 chlcevlg(:) = 0.0 ENDIF chmul1(:) = 0.0 chlmul1(:) = 0.0 csmul1(:) = 0.0 qhmul1(:) = 0.0 qhlmul1(:) = 0.0 qsmul1(:) = 0.0 do mgs = 1,ngscnt ltest = qx(mgs,lh) .gt. qxmin(lh) IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then IF ( ipconc .ge. 2 ) THEN IF ( xv(mgs,lc) .gt. 0.0 & & .and. ltest & & ) THEN IF ( alpha(mgs,lc) == 0.0 ) THEN ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) ELSE ratio = (1. + alpha(mgs,lc))*(7.23e-15)/xv(mgs,lc) IF ( usegamxinfcnu ) THEN i = Nint(dgami*(1. + alpha(mgs,lc))) gcnup1 = gmoi(i) ex1 = (1./250.)*Gamxinf(1.+alpha(mgs,lc), ratio)/(gcnup1) ELSE ratio = Min( maxratiolu, ratio ) tmp = gaminterp(ratio,alpha(mgs,lc),1,1) ex1 = (1./250.)*tmp ENDIF ENDIF IF ( itype2 .le. 2 ) THEN ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) ELSE IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN ft = 0.5 ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN ft = 1.0 ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN ft = 0.5 ELSE ft = 0.0 ENDIF ENDIF IF ( ft > 0.0 ) THEN IF ( itype2 > 0 ) THEN IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN chmul1(mgs) = ft*ex1*chacw(mgs) qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) ENDIF IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN chlmul1(mgs) = (ft*ex1*chlacw(mgs)) qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) ENDIF ENDIF ENDIF IF ( itype1 > 0 ) THEN IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) chmul1(mgs) = chmul1(mgs) + tmp qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) ENDIF IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) chlmul1(mgs) = chlmul1(mgs) + tmp qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) ENDIF ENDIF ENDIF ENDIF ENDIF ELSE fimt1(mgs) = 0.0 if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 ELSE fimt1(mgs) = 0.0 end if if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then fimt1(mgs) = 0.5 elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then fimt1(mgs) = 1.0 elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then fimt1(mgs) = 0.5 ELSE fimt1(mgs) = 0.0 end if IF ( itype1 .ge. 1 ) THEN fimta(mgs) = (3.5e+08)*rho0(mgs) ELSE fimta(mgs) = 0.0 ENDIF fimt2(mgs) = 0.0 xcwmas = xmas(mgs,lc) * 1000. IF ( itype2 .ge. 1 ) THEN if ( xcwmas.lt.1.26e-9 ) then fimt2(mgs) = 0.0 end if if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 end if if ( xcwmas .gt. 3.55e-9 ) then fimt2(mgs) = 1.0 end if fimt2(mgs) = min(fimt2(mgs),1.0) fimt2(mgs) = max(fimt2(mgs),0.0) ENDIF IF ( .not. wetsfc(mgs) ) THEN chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & & (4.0e-03)*fimt2(mgs))*qhacw(mgs) ENDIF qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) IF ( lhl .gt. 1 ) THEN IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN tmp = fimt1(mgs)*(fimta(mgs) + & & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) chlmul1(mgs) = tmp qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) ENDIF ENDIF ENDIF end if ENDIF end do csmul(:) = 0.0 qsmul(:) = 0.0 IF ( isnwfrac /= 0 ) THEN do mgs = 1,ngscnt IF (temg(mgs) .gt. 265.0) THEN if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) endif ENDIF enddo ENDIF do mgs = 1,ngscnt qracif(mgs) = qraci(mgs) cracif(mgs) = craci(mgs) end do cmassin = cimasn do mgs = 1,ngscnt qiint(mgs) = 0.0 ciint(mgs) = 0.0 qicicnt(mgs) = 0.0 cicint(mgs) = 0.0 qipipnt(mgs) = 0.0 cipint(mgs) = 0.0 ccitmp = 0.0 IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN if ( ( temg(mgs) .lt. 268.15 .or. & & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & & ciintmx .gt. (cx(mgs,li)+ccitmp) & & ) then fiinit(mgs) = (felv(mgs)**2)/(cp*rw) dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) idqis = 0 if ( ssi(mgs) .gt. 1.0 ) THEN idqis = 1 dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) qiint(mgs) = & & idqis*il5(mgs) & & *(cmassin/rho0(mgs)) & & *max(0.0,wvel(mgs)) & & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & & /((dzfacp+dzfacm)) qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin IF ( icenucopt /= -10 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(ciint(mgs), ccin(mgs)*dtpinv) ccin(mgs) = ccin(mgs) - ciint(mgs)*dtp qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ELSEIF ( lcina > 1 ) THEN ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ENDIF ENDIF end if endif ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ccin(mgs) = ccin(mgs) - ciint(mgs) ciint(mgs) = ciint(mgs)*dtpinv ELSE ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv ENDIF qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) fiinit(mgs) = (felv(mgs)**2)/(cp*rw) dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin ENDIF ELSEIF ( icenucopt == 3 .or. icenucopt == 4 .or. icenucopt == 10 ) THEN IF ( temg(mgs) .lt. 268.15 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ccin(mgs) = ccin(mgs) - ciint(mgs) ciint(mgs) = ciint(mgs)*dtpinv ELSE ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv ENDIF qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ENDIF ENDIF if ( xplate(mgs) .eq. 1 ) then qipipnt(mgs) = qiint(mgs) cipint(mgs) = ciint(mgs) end if if ( xcolmn(mgs) .eq. 1 ) then qicicnt(mgs) = qiint(mgs) cicint(mgs) = ciint(mgs) end if end do if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' do mgs = 1,ngscnt qrshr(mgs) = 0.0 qwshw(mgs) = 0.0 cwshw(mgs) = 0.0 qsshrp(mgs) = 0.0 qhshrp(mgs) = 0.0 end do do mgs = 1,ngscnt qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) IF ( ipconc .ge. 3 ) THEN ENDIF end do if (ndebug .gt. 0 ) write(0,*) 'dbg = 8a' IF ( ipconc .ge. 1 ) THEN pccwi(:) = 0.0 pccwd(:) = 0.0 pccwdacc(:) = 0.0 pccii(:) = 0.0 pccin(:) = 0.0 pccid(:) = 0.0 pcisi(:) = 0.0 pcisd(:) = 0.0 pcrwi(:) = 0.0 pcrwd(:) = 0.0 pcswi(:) = 0.0 pcswd(:) = 0.0 pchwi(:) = 0.0 pchwd(:) = 0.0 pchli(:) = 0.0 pchld(:) = 0.0 if (ndebug .gt. 0 ) write(0,*) 'cloud ice sum' IF ( warmonly < 0.5 ) THEN IF ( ffrzs < 1.0 ) THEN do mgs = 1,ngscnt pccii(mgs) = & & il5(mgs)*cicint(mgs) & & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) pccii(mgs) = pccii(mgs)*(1.0 - ffrzs) pccid(mgs) = & & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & & -craci(mgs) & & -csaci(mgs) & & -chaci(mgs) - chlaci(mgs) & & -chcni(mgs)) & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) pccin(mgs) = ciint(mgs) end do ENDIF ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt pccii(mgs) = & & il5(mgs)*cicint(mgs) & & +il5(mgs)*((1.0-cwfrz2snowfrac)*cwfrzc(mgs)+cwctfzc(mgs) & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) pccii(mgs) = pccii(mgs)*(1. - ffrzs) pccid(mgs) = & & +il5(mgs)*cisbv(mgs) & & -(1.-il5(mgs))*cimlr(mgs) pccin(mgs) = ciint(mgs) end do ENDIF IF ( ipconc .ge. 2 ) THEN do mgs = 1,ngscnt pccwi(mgs) = (0.0) - cwshw(mgs) IF ( warmonly < 0.5 ) THEN pccwd(mgs) = & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & & -cwctfzc(mgs) & & ) & & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) ELSEIF ( warmonly < 0.8 ) THEN pccwd(mgs) = & & - cautn(mgs) + & & il5(mgs)*( & & -ciacw(mgs)-cwfrz(mgs)-cwctfzp(mgs) & & -cwctfzc(mgs) & & ) & & -cracw(mgs) -chacw(mgs) -chlacw(mgs) ELSE pccwd(mgs) = & & - cautn(mgs) -cracw(mgs) ENDIF IF ( .false. .and. exwmindiam > 0.0 .and. ccwresv(mgs) > 0.0 ) THEN pccwdacc(mgs) = & & il5(mgs)*(-ciacw(mgs) & & ) & & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) IF ( -pccwdacc(mgs)*dtp .gt. cx(mgs,lc) - ccwresv(mgs) ) THEN frac = -(cx(mgs,lc) - ccwresv(mgs) )/(pccwdacc(mgs)*dtp) pccwdacc(mgs) = -(cx(mgs,lc) - ccwresv(mgs) )*dtpinv ciacw(mgs) = frac*ciacw(mgs) cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) pccwd(mgs) = & & - cautn(mgs) + & & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & & -cwfrzc(mgs)-cwctfzc(mgs) & & -il5(mgs)*(ciihr(mgs)) & & ) & & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) ENDIF ENDIF IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) pccwd(mgs) = -cx(mgs,lc)*dtpinv ciacw(mgs) = frac*ciacw(mgs) cwfrz(mgs) = frac*cwfrz(mgs) cwfrzp(mgs) = frac*cwfrzp(mgs) cwctfzp(mgs) = frac*cwctfzp(mgs) cwfrzc(mgs) = frac*cwfrzc(mgs) cwctfzc(mgs) = frac*cwctfzc(mgs) cwctfz(mgs) = frac*cwctfz(mgs) cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) cautn(mgs) = frac*cautn(mgs) pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs) IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) ENDIF end do ENDIF IF ( ipconc .ge. 3 ) THEN do mgs = 1,ngscnt IF ( warmonly < 0.5 ) THEN pcrwi(mgs) = & & crcnw(mgs) & & +(1-il5(mgs))*( & & -chmlrr(mgs)/rzxh(mgs) & & -chlmlrr(mgs)/rzxhl(mgs) & & -csmlrr(mgs) & & - cimlr(mgs) ) & & - Min(0.0,cracr(mgs)) & & -crshr(mgs) pcrwd(mgs) = & & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & & - chacr(mgs) - chlacr(mgs) & & +crcev(mgs) & & - Max(0.0,cracr(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pcrwi(mgs) = & & crcnw(mgs) & & +(1-il5(mgs))*( & & -chmlrr(mgs)/rzxh(mgs) & & -chlmlrr(mgs)/rzxhl(mgs) & & -csmlrr(mgs) & & - cimlr(mgs) ) & & -crshr(mgs) pcrwd(mgs) = & & il5(mgs)*( - crfrz(mgs) ) & & - chacr(mgs) & & - chlacr(mgs) & & +crcev(mgs) & & - cracr(mgs) ELSE pcrwi(mgs) = & & crcnw(mgs) pcrwd(mgs) = & & +crcev(mgs) & & - cracr(mgs) ENDIF frac = 0.0 IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) pcrwd(mgs) = -cx(mgs,lr)*dtpinv ciacr(mgs) = frac*ciacr(mgs) ciacrf(mgs) = frac*ciacrf(mgs) ciacrs(mgs) = frac*ciacrs(mgs) crfrz(mgs) = frac*crfrz(mgs) crfrzf(mgs) = frac*crfrzf(mgs) crfrzs(mgs) = frac*crfrzs(mgs) chacr(mgs) = frac*chacr(mgs) chlacr(mgs) = frac*chlacr(mgs) crcev(mgs) = frac*crcev(mgs) cracr(mgs) = frac*cracr(mgs) ENDIF end do ENDIF IF ( warmonly < 0.5 ) THEN IF ( ipconc .ge. 4 ) THEN do mgs = 1,ngscnt pcswi(mgs) = & & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & & + cwfrz2snowfrac*cwfrz(mgs)/cwfrz2snowratio & & + cscnh(mgs) IF ( ffrzs > 0.0 ) THEN pcswi(mgs) = pcswi(mgs) + ffrzs* ( & & il5(mgs)*cicint(mgs) & & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & & +cicichr(mgs)) & & +chmul1(mgs) & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & & +csmul(mgs) ) ENDIF IF ( ess0 < 0.0 ) THEN csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs))) ENDIF pcswd(mgs) = & & -chacs(mgs) - chlacs(mgs) & & -chcns(mgs) & & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & & + cssbv(mgs) & & - csacs(mgs) frac = 0.0 IF ( imixedphase == 0 ) THEN IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) pcswd(mgs) = frac*pcswd(mgs) chacs(mgs) = frac*chacs(mgs) chlacs(mgs) = frac*chlacs(mgs) chcns(mgs) = frac*chcns(mgs) csmlr(mgs) = frac*csmlr(mgs) csshr(mgs) = frac*csshr(mgs) cssbv(mgs) = frac*cssbv(mgs) csacs(mgs) = frac*csacs(mgs) ENDIF ENDIF pccii(mgs) = pccii(mgs) & & + (1. - ifrzs)*crfrzs(mgs) & & + (1. - ifrzs)*ciacrs(mgs) pcswi(mgs) = pcswi(mgs) & & + (ifrzs)*crfrzs(mgs) & & + (ifrzs)*ciacrs(mgs) end do ENDIF IF ( ipconc .ge. 5 ) THEN do mgs = 1,ngscnt pchwi(mgs) = & & +(ffrzh*ifrzg*crfrzf(mgs) & & +il5(mgs)*ffrzh*ifiacrg*(ciacrf(mgs) )) & & + f2h*chcnsh(mgs) + f2h*chcnih(mgs) + chcnhl(mgs) pchwd(mgs) = & & (1-il5(mgs))*chmlr(mgs) & & + chsbv(mgs) & & - il5(mgs)*chlcnh(mgs) & & - cscnh(mgs) end do IF ( lhl .gt. 1 .and. lnhl > 1 ) THEN do mgs = 1,ngscnt pchli(mgs) = (ffrzh*(1.0-ifrzg)*crfrzf(mgs) +il5(mgs)*ffrzh*(1.0-ifiacrg)*(ciacrf(mgs) )) & & + chlcnhhl(mgs) *rzxhlh(mgs) pchld(mgs) = & & (1-il5(mgs))*chlmlr(mgs) & & + chlsbv(mgs) - chcnhl(mgs) IF ( imixedphase == 0 ) THEN frac = 0.0 IF ( cx(mgs,lhl) + dtp*(pchli(mgs) + pchld(mgs)) < 0.0 ) THEN frac = (-cx(mgs,lhl) + pchli(mgs)*dtp)/(pchld(mgs)*dtp) chlmlr(mgs) = frac*chlmlr(mgs) chlsbv(mgs) = frac*chlsbv(mgs) chcnhl(mgs) = frac*chcnhl(mgs) pchld(mgs) = frac*pchld(mgs) ENDIF ENDIF end do ENDIF ENDIF ELSEIF ( warmonly < 0.8 ) THEN IF ( ipconc .ge. 5 ) THEN do mgs = 1,ngscnt pchwi(mgs) = & & +ifrzg*(crfrzf(mgs) ) pchwd(mgs) = & & (1-il5(mgs))*chmlr(mgs) & & - il5(mgs)*chlcnh(mgs) end do IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs)) & & + chlcnhhl(mgs) *rzxhl(mgs)/rzxh(mgs) pchld(mgs) = & & (1-il5(mgs))*chlmlr(mgs) end do ENDIF ENDIF ENDIF do mgs = 1,ngscnt pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & & pccii(mgs) +pccid(mgs) + & & pcrwi(mgs) +pcrwd(mgs) + & & pcswi(mgs) +pcswd(mgs) + & & pchwi(mgs) +pchwd(mgs) + & & pchli(mgs) +pchld(mgs) end do ENDIF pqwvi(:) = 0.0 pqwvd(:) = 0.0 pqcwi(:) = 0.0 pqcwd(:) = 0.0 pqcwdacc(:) = 0.0 pqcii(:) = 0.0 pqcid(:) = 0.0 pqrwi(:) = 0.0 pqrwd(:) = 0.0 pqswi(:) = 0.0 pqswd(:) = 0.0 pqhwi(:) = 0.0 pqhwd(:) = 0.0 pqhli(:) = 0.0 pqhld(:) = 0.0 pqlwsi(:) = 0.0 pqlwsd(:) = 0.0 pqlwhi(:) = 0.0 pqlwhd(:) = 0.0 pqlwlghi(:) = 0.0 pqlwlghd(:) = 0.0 pqlwlghli(:) = 0.0 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 IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -il5(mgs)*qidpv(mgs) end do ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) - qhldpv(mgs)) & & -Max(0.0, qrcev(mgs)) & & -il5(mgs)*qidpv(mgs) end do ELSE do mgs = 1,ngscnt pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) end do ENDIF do mgs = 1,ngscnt pqcwi(mgs) = (0.0) + qwcnr(mgs) - qwshw(mgs) IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & & -il5(mgs)*(qiihr(mgs)) & & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) ELSEIF ( warmonly < 0.8 ) THEN pqcwd(mgs) = & & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & & -il5(mgs)*(qiihr(mgs)) & & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) ELSE pqcwd(mgs) = & & -qracw(mgs) - qrcnw(mgs) ENDIF IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) pqcwd(mgs) = -qx(mgs,lc)*dtpinv qiacw(mgs) = frac*qiacw(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) qhacw(mgs) = frac*qhacw(mgs) vhacw(mgs) = frac*vhacw(mgs) qrcnw(mgs) = frac*qrcnw(mgs) qwfrzp(mgs) = frac*qwfrzp(mgs) IF ( lhl .gt. 1 ) THEN qhlacw(mgs) = frac*qhlacw(mgs) vhlacw(mgs) = frac*vhlacw(mgs) ENDIF ENDIF end do IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt IF ( ffrzs < 1.0 ) THEN pqcii(mgs) = & & il5(mgs)*qicicnt(mgs) & & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs)) & & +il5(mgs)*(qicichr(mgs)) & & +qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & & + qsplinter(mgs) + qsplinter2(mgs) ENDIF pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) & & +il5(mgs)*qidpv(mgs) & & +il5(mgs)*qiacw(mgs) pqcid(mgs) = & & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & & -qraci(mgs) & & -qsaci(mgs) ) & & -qhaci(mgs) & & -qhlaci(mgs) & & +il5(mgs)*qisbv(mgs) & & +(1.-il5(mgs))*qimlr(mgs) & & - qhcni(mgs) end do ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt pqcii(mgs) = & & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & & +il5(mgs)*((1.0-cwfrz2snowfrac)*qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & & +qhmul1(mgs) + qhlmul1(mgs) & & + qsplinter(mgs) + qsplinter2(mgs) & & +il5(mgs)*qidpv(mgs) & & +il5(mgs)*qiacw(mgs) pqcid(mgs) = & & +il5(mgs)*qisbv(mgs) & & +(1.-il5(mgs))*qimlr(mgs) end do ENDIF do mgs = 1,ngscnt IF ( warmonly < 0.5 ) THEN pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & & -qhmlr(mgs) & & -qsmlr(mgs) - qhlmlr(mgs) & & -qimlr(mgs)) & & - qrshr(mgs) pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & & +(1-il5(mgs))*( & & -qhlmlr(mgs) & & -qhmlr(mgs) ) & & -qhshr(mgs) & & -qhlshr(mgs) pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & & - qhacr(mgs) & & - qhlacr(mgs) & & + Min(0.0,qrcev(mgs)) ELSE pqrwi(mgs) = & & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) pqrwd(mgs) = Min(0.0,qrcev(mgs)) ENDIF IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) pqwvi(mgs) = pqwvi(mgs) & & + Min(0.0, qrcev(mgs)) & & - frac*Min(0.0, qrcev(mgs)) pqwvd(mgs) = pqwvd(mgs) & & + Max(0.0, qrcev(mgs)) & & - frac*Max(0.0, qrcev(mgs)) qiacr(mgs) = frac*qiacr(mgs) qiacrf(mgs) = frac*qiacrf(mgs) qiacrs(mgs) = frac*qiacrs(mgs) viacrf(mgs) = frac*viacrf(mgs) qrfrz(mgs) = frac*qrfrz(mgs) qrfrzs(mgs) = frac*qrfrzs(mgs) qrfrzf(mgs) = frac*qrfrzf(mgs) vrfrzf(mgs) = frac*vrfrzf(mgs) qsacr(mgs) = frac*qsacr(mgs) qhacr(mgs) = frac*qhacr(mgs) vhacr(mgs) = frac*vhacr(mgs) qrcev(mgs) = frac*qrcev(mgs) qhlacr(mgs) = frac*qhlacr(mgs) vhlacr(mgs) = frac*vhlacr(mgs) qhcev(mgs) = frac*qhcev(mgs) qhlcev(mgs) = frac*qhlcev(mgs) IF ( warmonly < 0.5 ) THEN pqrwd(mgs) = & & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & & + Min(0.0,qrcev(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqrwd(mgs) = & & il5(mgs)*(-qrfrz(mgs)) & & - qhacr(mgs) & & - qhlacr(mgs) & & + Min(0.0,qrcev(mgs)) ELSE pqrwd(mgs) = Min(0.0,qrcev(mgs)) ENDIF IF ( qrcev(mgs) .ne. 0.0 ) THEN pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & & -Min(0.0, qhlcev(mgs)) & & -Min(0.0, qscev(mgs)) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & & -il5(mgs)*qisbv(mgs) pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & & -Max(0.0, qhlcev(mgs)) & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -il5(mgs)*qidpv(mgs) ENDIF ENDIF end do IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt pqswi(mgs) = & & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & & + qscnvi(mgs) & & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & & + il5(mgs)*(( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & & + (1.0 - ffrzs)*cwfrz2snowfrac*qwfrz(mgs) ) & & + il2(mgs)*qsacr(mgs)) & & + il5(mgs)*qicicnt(mgs)*ffrzs & & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & & + Max(0.0, qscev(mgs)) & & + qsacw(mgs) + qscnh(mgs) & & + ffrzs*(qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & & + qsplinter(mgs) + qsplinter2(mgs)) pqswd(mgs) = & & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & & -qhcns(mgs) & & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & & + qssbv(mgs) & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) pqswd(mgs) = frac*pqswd(mgs) qracs(mgs) = frac*qracs(mgs) qhacs(mgs) = frac*qhacs(mgs) qhlacs(mgs) = frac*qhlacs(mgs) qhcns(mgs) = frac*qhcns(mgs) qsmlr(mgs) = frac*qsmlr(mgs) qsshr(mgs) = frac*qsshr(mgs) qssbv(mgs) = frac*qssbv(mgs) qsmul(mgs) = frac*qsmul(mgs) IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) ENDIF ENDIF pqcii(mgs) = pqcii(mgs) & & + (1. - ifrzs)*qrfrzs(mgs) & & + (1. - ifrzs)*qiacrs(mgs) end do do mgs = 1,ngscnt pqhwi(mgs) = & & +il5(mgs)*(ffrzh*ifrzg*qrfrzf(mgs) + (1-il3(mgs))*ffrzh*ifiacrg*(qiacrf(mgs)+qracif(mgs))) & & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & & +il5(mgs)*(qhdpv(mgs)) & & +Max(0.0, qhcev(mgs)) & & +qhacr(mgs)+qhacw(mgs) & & +qhacs(mgs)+qhaci(mgs) & & + f2h*qhcns(mgs) + f2h*qhcni(mgs) + qhcnhl(mgs) pqhwd(mgs) = & & qhshr(mgs) & & +(1-il5(mgs))*qhmlr(mgs) & & + qhsbv(mgs) & & + Min(0.0, qhcev(mgs)) & & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & & - ffrzh*(qsplinter(mgs) + qsplinter2(mgs)) end do IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt pqhli(mgs) = & & +il5(mgs)*(qhldpv(mgs) + ((1.0-ifrzg)*qrfrzf(mgs) + (1.0-ifiacrg)*(qiacrf(mgs)+ qracif(mgs)))) & & +Max(0.0, qhlcev(mgs)) & & +qhlacr(mgs)+qhlacw(mgs) & & +qhlacs(mgs)+qhlaci(mgs) & & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & & +(1-il5(mgs))*qhlmlr(mgs) & & + qhlsbv(mgs) & & + Min(0.0, qhlcev(mgs)) & & -qhlmul1(mgs) - qhcnhl(mgs) IF ( imixedphase == 0 ) THEN frac = 0.0 IF ( qx(mgs,lhl) + dtp*(pqhli(mgs) + pqhld(mgs)) < 0.0 ) THEN frac = (-qx(mgs,lhl) + pqhli(mgs)*dtp)/(pqhld(mgs)*dtp) qhlmlr(mgs) = frac*qhlmlr(mgs) qhlsbv(mgs) = frac*qhlsbv(mgs) qhcnhl(mgs) = frac*qhcnhl(mgs) qhlmul1(mgs) = frac*qhlmul1(mgs) IF ( qhlcev(mgs) < 0.0 ) qhlcev(mgs) = frac*qhlcev(mgs) pqhld(mgs) = frac*pqhld(mgs) ENDIF ENDIF end do ENDIF ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt pqhwi(mgs) = & & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & & +il5(mgs)*(qhdpv(mgs)) & & +qhacr(mgs)+qhacw(mgs) pqhwd(mgs) = & & qhshr(mgs) & & - qhlcnh(mgs) & & - qhmul1(mgs) & & - qsplinter(mgs) - qsplinter2(mgs) & & +(1-il5(mgs))*qhmlr(mgs) end do IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt pqhli(mgs) = & & +il5(mgs)*(qhldpv(mgs) ) & & +il5(mgs)*(1.0-ifrzg)*(qrfrzf(mgs) ) & & +qhlacr(mgs)+qhlacw(mgs) & & + qhlcnh(mgs) pqhld(mgs) = & & qhlshr(mgs) & & +(1-il5(mgs))*qhlmlr(mgs) & & + qhlsbv(mgs) & & -qhlmul1(mgs) - qhcnhl(mgs) end do ENDIF ENDIF vhmlr(:) = 0.0 vhlmlr(:) = 0.0 vhfzh(:) = 0.0 vhlfzhl(:) = 0.0 IF ( mixedphase ) THEN ELSE vhmlr(:) = qhmlr(:) vhlmlr(:) = qhlmlr(:) ENDIF if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'graupel reflectivity' do mgs = 1,ngscnt zhdsv(mgs) = 0.0 IF ( ffrzh > 0.0 ) THEN ziacr(mgs) = 0.0 ziacrf(mgs) = 0.0 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 = g1x(mgs,lh) 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 ) THEN IF ( temg(mgs) >= tfr ) THEN IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN 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) ) ENDIF zhshrr(mgs) = z1 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 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 = g1x(mgs,lh) IF ( .true. ) THEN IF ( qhacr(mgs) .gt. 0.0 ) THEN zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacr(mgs) ) ENDIF IF ( qhacw(mgs) .gt. 0.0 ) THEN zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) ENDIF ELSE 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)) 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 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) IF ( imurain == 3 ) THEN 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 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)/xdnmx(lh))**2 * ziacr(mgs) ENDIF IF ( ffrzh*qrfrzf(mgs) .gt. 0.0 .and. cx(mgs,lr) .gt. 0.0 ) THEN tmp = qx(mgs,lr)/cx(mgs,lr) 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 * 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 ) 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) 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 * chcnsh(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. chcnih(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) zhcni(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,li)+2.)/(r**2*(alpha(mgs,li)+1.)) * & & ( 2.*tmp * qhcni(mgs) - tmp**2 * chcnih(mgs) ) ENDIF pzhwi(mgs) = & & +ifrzg*ffrzh*(zrfrzf(mgs) & & +il5(mgs)*ifiacrg*(ziacrf(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) end do if (ndebug .gt. 0 .and. my_rank>=0 ) write(0,*) my_rank, 'end graupel reflectivity' ENDIF 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 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 = g1x(mgs,lhl) 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 IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN 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) ) ENDIF zhlshrr(mgs) = z1 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 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 = g1x(mgs,lhl) IF ( .true. ) THEN IF ( qhlacr(mgs) .gt. 0.0 ) THEN zhlacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*( tmp ) * qhlacr(mgs) ) ENDIF 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)) zhlacw(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lhl)))**2*( 2.*tmp * qhlacw(mgs) ) g1 = g1x(mgs,lhl) ENDIF ELSE 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)) IF ( z > zx(mgs,lhl) ) THEN zhlacw(mgs) = (z - zx(mgs,lhl))*dtpinv ENDIF ENDIF ENDIF ENDIF 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) & & + 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 end do ENDIF 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 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 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 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) IF ( (shedalp + alpha(mgs,lh))*xdia(mgs,lh,1) < sheddiam ) THEN z1 = g1x(mgs,lh)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) ELSE z1 = Min(g1x(mgs,lh),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhmlr(mgs)**2/ chmlrr(mgs) ) ENDIF zhmlrr(mgs) = z1 ENDIF IF ( lhl > 1 .and. qhlmlr(mgs) /= 0 .and. ibinhlmlr == 0) THEN tmp = qx(mgs,lhl)/cx(mgs,lhl) IF ( (shedalp + alpha(mgs,lhl))*xdia(mgs,lhl,1) < sheddiam ) THEN z1 = g1x(mgs,lhl)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) ELSE z1 = Min(g1x(mgs,lhl),g1shr)*(6.*rho0(mgs)/(pi*xdn(mgs,lr)))**2*( qhlmlr(mgs)**2/ chlmlrr(mgs) ) ENDIF zhlmlrr(mgs) = z1 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) 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) 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( dble(zrcev(mgs)), vent1 ) ENDIF zrcev(mgs) = Max( zrcev(mgs), -zxmxd(mgs,lr) ) 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 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 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) pzrwd(mgs) = 0.0 & & + Min(0.,zrcev(mgs) ) & & - zrach(mgs) & & - zrachl(mgs) & & - zrfrz(mgs) & & - il5(mgs)*(ziacr(mgs) ) 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 IF ( lvol(ls) .gt. 1 ) THEN do mgs = 1,ngscnt pvswi(mgs) = rho0(mgs)*( & & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & & + (1. - ifrzs)*qrfrzs(mgs) & & )/xdn0(ls) & & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & & -rho0(mgs)*qsmul(mgs)/xdn0(ls) end do ENDIF IF ( lvol(lh) .gt. 1 ) THEN DO mgs = 1,ngscnt pvhwi(mgs) = rho0(mgs)*( & & +il5(mgs)*( ifiacrg*ffrzh*qracif(mgs))/rhofrz & & + ( il5(mgs)*qhdpv(mgs)/qhdpvdn & & + (qhacs(mgs) + qhaci(mgs))/qhacidn ) ) & & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & & + f2h*vhcns(mgs) & & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & & + f2h*vhcni(mgs) + (ifiacrg*viacrf(mgs) + ifrzg*vrfrzf(mgs))*ffrzh pvhwd(mgs) = rho0(mgs)*( & & +( (1-il5(mgs))*vhmlr(mgs) & & + qhsbv(mgs) & & + Min(0.0, qhcev(mgs)) & & -qhmul1(mgs) )/xdn(mgs,lh) ) & & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) IF ( lzh > 1 .and. qx(mgs,lh) > qxmin(lh) .and. & vx(mgs,lh) + dtp*(pvhwi(mgs) + pvhwd(mgs)) > rho0(mgs)*qxmin(lh)/900. ) THEN 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,*) write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) write(iunit,*) il5(mgs)*qiacrf(mgs) write(iunit,*) il5(mgs)*qracif(mgs) write(iunit,*) 'qhcns',qhcns(mgs) write(iunit,*) 'qhcni',qhcni(mgs) write(iunit,*) il5(mgs)*(qhdpv(mgs)) write(iunit,*) 'qhacr ',qhacr(mgs) write(iunit,*) 'qhacw', qhacw(mgs) write(iunit,*) 'qhacs', qhacs(mgs) write(iunit,*) 'qhaci', qhaci(mgs) write(iunit,*) 'pqhwi = ',pqhwi(mgs) write(iunit,*) write(iunit,*) 'qhcev',qhcev(mgs) write(iunit,*) write(iunit,*) 'qhshr',qhshr(mgs) write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) write(iunit,*) 'qhsbv', qhsbv(mgs) write(iunit,*) 'qhlcnh',-qhlcnh(mgs) write(iunit,*) 'qhmul1',-qhmul1(mgs) write(iunit,*) 'pqhwd = ', pqhwd(mgs) write(iunit,*) write(iunit,*) 'Volume' write(iunit,*) write(iunit,*) 'pvhwi',pvhwi(mgs) write(iunit,*) 'vhcns', vhcns(mgs) write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) write(iunit,*) 'vhcni',vhcni(mgs) write(iunit,*) write(iunit,*) 'pvhwd',pvhwd(mgs) write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) write(iunit,*) 'vhmlr', vhmlr(mgs) write(iunit,*) write(iunit,*) 'Concentration' write(iunit,*) pchwi(mgs),pchwd(mgs) write(iunit,*) crfrzf(mgs) write(iunit,*) chcns(mgs) write(iunit,*) ciacrf(mgs) ENDIF ENDDO ENDIF IF ( lhl .gt. 1 ) THEN IF ( lvol(lhl) .gt. 1 ) THEN DO mgs = 1,ngscnt pvhli(mgs) = rho0(mgs)*( & & + ( il5(mgs)*(((1.0-ifiacrg)*ffrzh*qracif(mgs))/rhofrz + qhldpv(mgs) ) & & + qhlacs(mgs) + qhlaci(mgs) )/500. ) & & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & & + vhlcnhl(mgs) + ((1.0-ifiacrg)*ffrzh*viacrf(mgs) + (1.0-ifrzg)*ffrzh*vrfrzf(mgs)) & & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) pvhld(mgs) = rho0(mgs)*( & & +( qhlsbv(mgs) & & + Min(0.0, qhlcev(mgs)) & & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & & + vhlshdr(mgs) - vhlsoak(mgs) IF ( lzhl > 1 .and. qx(mgs,lhl) > qxmin(lhl) .and. & vx(mgs,lhl) + dtp*(pvhli(mgs) + pvhld(mgs)) > rho0(mgs)*qxmin(lhl)/900. ) THEN 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 ENDIF ENDIF if ( ndebug .ge. 1 ) then do mgs = 1,ngscnt ptotal(mgs) = 0. ptotal(mgs) = ptotal(mgs) & & + pqwvi(mgs) + pqwvd(mgs) & & + pqcwi(mgs) + pqcwd(mgs) & & + pqcii(mgs) + pqcid(mgs) & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & & + pqhli(mgs) + pqhld(mgs) ENDDO do mgs = 1,ngscnt if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & & ) then write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & & kgs(mgs),ptotal(mgs) write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & & vtxbar(mgs,li,1) write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) write(iunit,*) 'temcg = ', temcg(mgs) write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) tmp = pqwvi(mgs) + pqwvd(mgs) & & + pqcwi(mgs) + pqcwd(mgs) & & + pqcii(mgs) + pqcid(mgs) & & + pqrwi(mgs) + pqrwd(mgs) & & + pqswi(mgs) + pqswd(mgs) & & + pqhwi(mgs) + pqhwd(mgs) & & + pqhli(mgs) + pqhld(mgs) write(iunit,*) 'total = ',tmp write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' write(iunit,*) write(iunit,*) 'Vapor' write(iunit,*) -Min(0.0,qrcev(mgs)) write(iunit,*) -il5(mgs)*qhsbv(mgs) write(iunit,*) -il5(mgs)*qhlsbv(mgs) write(iunit,*) -il5(mgs)*qssbv(mgs) write(iunit,*) -il5(mgs)*qisbv(mgs) write(iunit,*) 'pqwvi= ', pqwvi(mgs) write(iunit,*) -Max(0.0,qrcev(mgs)) write(iunit,*) -Max(0.0,qhcev(mgs)) write(iunit,*) -Max(0.0,qhlcev(mgs)) write(iunit,*) -Max(0.0,qscev(mgs)) write(iunit,*) -il5(mgs)*qiint(mgs) write(iunit,*) -il5(mgs)*qhdpv(mgs) write(iunit,*) -il5(mgs)*qhldpv(mgs) write(iunit,*) -il5(mgs)*qsdpv(mgs) write(iunit,*) -il5(mgs)*qidpv(mgs) write(iunit,*) 'pqwvd = ', pqwvd(mgs) write(iunit,*) write(iunit,*) 'Cloud ice' write(iunit,*) il5(mgs)*qicicnt(mgs) write(iunit,*) il5(mgs)*qidpv(mgs) write(iunit,*) il5(mgs)*qiacw(mgs) write(iunit,*) il5(mgs)*qwfrzc(mgs) write(iunit,*) il5(mgs)*qwctfzc(mgs) write(iunit,*) il5(mgs)*qicichr(mgs) write(iunit,*) qhmul1(mgs) write(iunit,*) qhlmul1(mgs) write(iunit,*) 'pqcii = ', pqcii(mgs) write(iunit,*) -il5(mgs)*qscni(mgs) write(iunit,*) -il5(mgs)*qscnvi(mgs) write(iunit,*) -il5(mgs)*qraci(mgs) write(iunit,*) -il5(mgs)*qsaci(mgs) write(iunit,*) -il5(mgs)*qhaci(mgs) write(iunit,*) -il5(mgs)*qhlaci(mgs) write(iunit,*) il5(mgs)*qisbv(mgs) write(iunit,*) (1.-il5(mgs))*qimlr(mgs) write(iunit,*) -il5(mgs)*qhcni(mgs) write(iunit,*) 'pqcid = ', pqcid(mgs) write(iunit,*) ' Conc:' write(iunit,*) pccii(mgs),pccid(mgs) write(iunit,*) il5(mgs),cicint(mgs) write(iunit,*) cwfrzc(mgs),cwctfzc(mgs) write(iunit,*) cicichr(mgs) write(iunit,*) chmul1(mgs) write(iunit,*) chlmul1(mgs) write(iunit,*) csmul(mgs) write(iunit,*) write(iunit,*) 'Cloud water' write(iunit,*) 'pqcwi =', pqcwi(mgs) write(iunit,*) -il5(mgs)*qiacw(mgs) write(iunit,*) -il5(mgs)*qwfrzc(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) write(iunit,*) -il5(mgs)*qicichr(mgs) write(iunit,*) -il5(mgs)*qipiphr(mgs) write(iunit,*) -qracw(mgs) write(iunit,*) -qsacw(mgs) write(iunit,*) -qrcnw(mgs) write(iunit,*) -qhacw(mgs) write(iunit,*) -qhlacw(mgs) write(iunit,*) 'pqcwd = ', pqcwd(mgs) write(iunit,*) write(iunit,*) 'Concentration:' write(iunit,*) -cautn(mgs) write(iunit,*) -cracw(mgs) write(iunit,*) -csacw(mgs) write(iunit,*) -chacw(mgs) write(iunit,*) -ciacw(mgs) write(iunit,*) -cwfrzp(mgs) write(iunit,*) -cwctfzp(mgs) write(iunit,*) -cwfrzc(mgs) write(iunit,*) -cwctfzc(mgs) write(iunit,*) pccwd(mgs) write(iunit,*) write(iunit,*) 'Rain ' write(iunit,*) qracw(mgs) write(iunit,*) qrcnw(mgs) write(iunit,*) Max(0.0, qrcev(mgs)) write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) write(iunit,*) -(1-il5(mgs))*qimlr(mgs) write(iunit,*) -qrshr(mgs) write(iunit,*) 'pqrwi = ', pqrwi(mgs) write(iunit,*) -qsshr(mgs) write(iunit,*) -qhshr(mgs) write(iunit,*) -qhlshr(mgs) write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) write(iunit,*) -il5(mgs)*qrfrz(mgs) write(iunit,*) -qsacr(mgs) write(iunit,*) -qhacr(mgs) write(iunit,*) -qhlacr(mgs) write(iunit,*) qrcev(mgs) write(iunit,*) 'pqrwd = ', pqrwd(mgs) write(iunit,*) 'qrzfac = ', qrzfac(mgs) write(iunit,*) write(iunit,*) 'Rain concentration' write(iunit,*) pcrwi(mgs) write(iunit,*) crcnw(mgs) write(iunit,*) 1-il5(mgs) write(iunit,*) -chmlr(mgs),-csmlr(mgs) write(iunit,*) -crshr(mgs) write(iunit,*) pcrwd(mgs) write(iunit,*) il5(mgs) write(iunit,*) -ciacr(mgs),-crfrz(mgs) write(iunit,*) -csacr(mgs),-chacr(mgs) write(iunit,*) +crcev(mgs) write(iunit,*) cracr(mgs) write(iunit,*) write(iunit,*) 'Snow' write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) write(iunit,*) il5(mgs)*qsaci(mgs) write(iunit,*) il5(mgs)*qrfrzs(mgs), qiacrs(mgs) write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) write(iunit,*) qsacw(mgs),qwfrzc(mgs), qwctfzc(mgs), qicichr(mgs) write(iunit,*) qsacr(mgs), qscnh(mgs) write(iunit,*) il2(mgs)*qsacr(mgs) write(iunit,*) il5(mgs)*qicicnt(mgs)*ffrzs write(iunit,*) il3(mgs)*(qiacrf(mgs)+qracif(mgs)) write(iunit,*) Max(0.0, qscev(mgs)) write(iunit,*) qsacw(mgs) + qscnh(mgs) write(iunit,*) 'pqswi = ',pqswi(mgs) write(iunit,*) -qhcns(mgs) write(iunit,*) -qracs(mgs) write(iunit,*) -qhacs(mgs) write(iunit,*) -qhlacs(mgs) write(iunit,*) (1-il5(mgs))*qsmlr(mgs) write(iunit,*) qsshr(mgs) write(iunit,*) il5(mgs)*(qssbv(mgs)) write(iunit,*) 'pqswd = ', pqswd(mgs) 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,*) Min(0.0, qscev(mgs)) write(iunit,*) -qsmul(mgs) write(iunit,*) write(iunit,*) 'Graupel' write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) write(iunit,*) il5(mgs)*qiacrf(mgs) write(iunit,*) il5(mgs)*qracif(mgs) write(iunit,*) qhcns(mgs) write(iunit,*) qhcni(mgs) write(iunit,*) il5(mgs)*(qhdpv(mgs)) write(iunit,*) qhacr(mgs) write(iunit,*) qhacw(mgs) write(iunit,*) qhacs(mgs) write(iunit,*) qhaci(mgs) write(iunit,*) 'pqhwi = ',pqhwi(mgs) write(iunit,*) write(iunit,*) qhshr(mgs) write(iunit,*) (1-il5(mgs))*qhmlr(mgs) write(iunit,*) il5(mgs),qhsbv(mgs) write(iunit,*) -qhlcnh(mgs) write(iunit,*) -qhmul1(mgs) write(iunit,*) 'pqhwd = ', pqhwd(mgs) write(iunit,*) 'Concentration' write(iunit,*) pchwi(mgs),pchwd(mgs) write(iunit,*) crfrzf(mgs) write(iunit,*) chcns(mgs) write(iunit,*) ciacrf(mgs) write(iunit,*) write(iunit,*) 'Hail' write(iunit,*) qhlcnh(mgs) write(iunit,*) il5(mgs)*(qhldpv(mgs)) write(iunit,*) qhlacr(mgs) write(iunit,*) qhlacw(mgs) write(iunit,*) qhlacs(mgs) write(iunit,*) qhlaci(mgs) write(iunit,*) pqhli(mgs) write(iunit,*) write(iunit,*) qhlshr(mgs) write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) write(iunit,*) il5(mgs)*qhlsbv(mgs) write(iunit,*) pqhld(mgs) write(iunit,*) 'Concentration' write(iunit,*) pchli(mgs),pchld(mgs) write(iunit,*) chlcnh(mgs) write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' write(iunit,*) 'PTOTAL',ptotal(mgs) end if end do end if do mgs = 1,ngscnt IF ( warmonly < 0.5 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+ & & qsmlr(mgs)+qhlmlr(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) & & ) & & +il5(mgs)*(qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs)) pmlt(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+qsmlr(mgs)+ & & qhlmlr(mgs)) psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & & + qssbv(mgs) + qhsbv(mgs) & & + qhlsbv(mgs) & & +il5(mgs)*(qiint(mgs)) pvap(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,qfcev(mgs)) pdep(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) ) & & +il5(mgs)*(qiint(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pfrz(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+qhlmlr(mgs)) & & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & & +il5(mgs)*( & & +qhshr(mgs) & & +qhlshr(mgs) & & +qrfrz(mgs)+qwfrz(mgs) & & +qwctfz(mgs)+qiihr(mgs) & & +qiacw(mgs) & & +qhacw(mgs) + qhlacw(mgs) & & +qhacr(mgs) + qhlacr(mgs) ) psub(mgs) = 0.0 + & & il5(mgs)*( & & + qhdpv(mgs) & & + qhldpv(mgs) & & + qidpv(mgs) + qisbv(mgs) ) & & +il5(mgs)*(qiint(mgs)) pvap(mgs) = & & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) + qfcev(mgs) ELSE pfrz(mgs) = 0.0 psub(mgs) = 0.0 pvap(mgs) = qrcev(mgs) ENDIF ptem(mgs) = & & (1./pi0(mgs))* & & (felfcp(mgs)*pfrz(mgs) & & +felscp(mgs)*psub(mgs) & & +felvcp(mgs)*pvap(mgs)) thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) ptem2(mgs) = ptem(mgs) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & & +felspi(mgs)*psub(mgs) & & +felvpi(mgs)*pvap(mgs))*dtp ENDIF end do do mgs = 1,ngscnt qwvp(mgs) = qwvp(mgs) + & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & & dtp*(pqcwi(mgs)+pqcwd(mgs)) qx(mgs,lr) = qx(mgs,lr) + & & dtp*(pqrwi(mgs)+pqrwd(mgs)) qx(mgs,li) = qx(mgs,li) + & & dtp*(pqcii(mgs)+pqcid(mgs)) qx(mgs,ls) = qx(mgs,ls) + & & 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)) ENDIF end do IF ( ldovol ) THEN do mgs = 1,ngscnt IF ( lvol(ls) .gt. 1 ) THEN vx(mgs,ls) = vx(mgs,ls) + & & dtp*(pvswi(mgs)+pvswd(mgs)) ENDIF IF ( lvol(lh) .gt. 1 ) THEN vx(mgs,lh) = vx(mgs,lh) + & & dtp*(pvhwi(mgs)+pvhwd(mgs)) ENDIF IF ( lhl .gt. 1 ) THEN IF ( lvol(lhl) .gt. 1 ) THEN vx(mgs,lhl) = vx(mgs,lhl) + & & dtp*(pvhli(mgs)+pvhld(mgs)) ENDIF ENDIF ENDDO ENDIF if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = cx(mgs,li) + & & dtp*(pccii(mgs)+pccid(mgs)) cina(mgs) = cina(mgs) + pccin(mgs)*dtp IF ( ipconc .ge. 2 ) THEN cx(mgs,lc) = cx(mgs,lc) + & & dtp*(pccwi(mgs)+pccwd(mgs)) ENDIF IF ( ipconc .ge. 3 ) THEN cx(mgs,lr) = cx(mgs,lr) + & & dtp*(pcrwi(mgs)+pcrwd(mgs)) ENDIF IF ( ipconc .ge. 4 ) THEN cx(mgs,ls) = cx(mgs,ls) + & & dtp*(pcswi(mgs)+pcswd(mgs)) ENDIF IF ( ipconc .ge. 5 ) THEN cx(mgs,lh) = cx(mgs,lh) + & & dtp*(pchwi(mgs)+pchwd(mgs)) IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) 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)) 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)) rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) ENDDO ENDIF if (ndebug .gt. 0 ) write(0,*) 'conc 30a' do mgs = 1,ngscnt pqs(mgs) = (380.0)/(pres(mgs)) theta(mgs) = thetap(mgs) + theta0(mgs) qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) temg(mgs) = theta(mgs)*pk(mgs) end do do mgs = 1,ngscnt qcwtmp(mgs) = qx(mgs,lc) ptimlw(mgs) = 0.0 end do do mgs = 1,ngscnt qitmp(mgs) = qx(mgs,li) if( temg(mgs) .gt. tfr .and. & & qitmp(mgs) .gt. 0.0 ) then qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & & felfcp(mgs)*(- qitmp(mgs)*dtpinv) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) ENDIF pmlt(mgs) = pmlt(mgs) - qitmp(mgs)*dtpinv scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) thetap(mgs) = thetap(mgs) - & & fcc3(mgs)*qitmp(mgs) ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)*dtpinv cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) qx(mgs,li) = 0.0 cx(mgs,li) = 0.0 scx(mgs,li) = 0.0 vx(mgs,li) = 0.0 qitmp(mgs) = 0.0 end if end do IF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt qcwtmp(mgs) = qx(mgs,lc) ptwfzi(mgs) = 0.0 end do do mgs = 1,ngscnt ctmp = 0.0 frac = 0.0 qtmp = 0.0 if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and. & & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then IF ( ibfc >= 3 ) THEN frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) ELSE volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) frac = qtmp/qx(mgs,lc) ENDIF qtmp = frac*qx(mgs,lc) IF ( ibfc == 4 .and. lis >= 1 ) THEN qx(mgs,lis) = qx(mgs,lis) + qtmp ELSE qx(mgs,li) = qx(mgs,li) + qtmp ENDIF pfrz(mgs) = pfrz(mgs) + qtmp*dtpinv ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & & felfcp(mgs)*(qtmp*dtpinv) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp ENDIF IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) IF ( ipconc .ge. 2 ) THEN ctmp = frac*cx(mgs,lc) IF ( ibfc == 4 .and. lis >= 1 ) THEN cx(mgs,lis) = cx(mgs,lis) + ctmp ELSE cx(mgs,li) = cx(mgs,li) + ctmp ENDIF ELSE ctmp = 0.0 IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp ELSE cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & & /gz(igs(mgs),jgs,kgs(mgs)) cx(mgs,lc) = cwccn ENDIF IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) ENDIF sctmp = frac*scx(mgs,lc) scx(mgs,li) = scx(mgs,li) + sctmp thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp ptwfzi(mgs) = fcc3(mgs)*qtmp*dtpinv qx(mgs,lc) = qx(mgs,lc) - qtmp cx(mgs,lc) = cx(mgs,lc) - ctmp scx(mgs,lc) = scx(mgs,lc) - sctmp end if end do ENDIF qcond(:) = 0.0 IF ( ipconc .le. 1 .and. lwsm6 ) THEN DO mgs = 1,ngscnt qcwtmp(mgs) = qx(mgs,lc) theta(mgs) = thetap(mgs) + theta0(mgs) temgtmp = temg(mgs) temg(mgs) = theta(mgs)*pk(mgs) temcg(mgs) = temg(mgs) - tfr ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN qcond(mgs) = Max( tmp, -qx(mgs,lc) ) ENDIF qwvp(mgs) = qwvp(mgs) - qcond(mgs) qvap(mgs) = qvap(mgs) - qcond(mgs) qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) ENDIF ENDDO ENDIF IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN do mgs = 1,ngscnt qx(mgs,lv) = max( 0.0, qvap(mgs) ) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) qx(mgs,li) = max( 0.0, qx(mgs,li) ) qitmp(mgs) = qx(mgs,li) end do do mgs = 1,ngscnt qcwtmp(mgs) = qx(mgs,lc) qitmp(mgs) = qx(mgs,li) theta(mgs) = thetap(mgs) + theta0(mgs) temgtmp = temg(mgs) temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) temsav = temg(mgs) thsave(mgs) = thetap(mgs) temcg(mgs) = temg(mgs) - tfr tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qss(mgs) = qvs(mgs) 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) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & & qss(mgs) = qis(mgs) if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & & (qx(mgs,lc) + qitmp(mgs)) end if end do do itertd = 1,2 do mgs = 1,ngscnt qitmp(mgs) = qx(mgs,li) fcci(mgs) = 0.0 fcip(mgs) = 0.0 dqcw(mgs) = 0.0 dqci(mgs) = 0.0 dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) if( dqwv(mgs) .lt. 0. ) then if( qx(mgs,lc) .gt. -dqwv(mgs) ) then dqcw(mgs) = dqwv(mgs) dqwv(mgs) = 0. else dqcw(mgs) = -qx(mgs,lc) dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) end if if( qitmp(mgs) .gt. -dqwv(mgs) ) then dqci(mgs) = dqwv(mgs) dqwv(mgs) = 0. else dqci(mgs) = -qitmp(mgs) dqwv(mgs) = dqwv(mgs) + qitmp(mgs) end if qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) qitmp(mgs) = qx(mgs,li) IF ( qitmp(mgs) .ge. qxmin(li) ) THEN fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) ELSE fcci(mgs) = 1.0 ENDIF qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) thetap(mgs) = thetap(mgs) + & & 1./pi0(mgs)* & & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) & & +(felspi(mgs)*dqci(mgs) & & +felvpi(mgs)*dqcw(mgs)) ENDIF end if IF ( dqwv(mgs) .ge. 0. ) THEN qitmp(mgs) = qx(mgs,li) fracl(mgs) = 1.0 fraci(mgs) = 0.0 if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) fraci(mgs) = 1.0-fracl(mgs) end if if ( temg(mgs) .le. thnuc ) then fraci(mgs) = 1.0 fracl(mgs) = 0.0 end if fraci(mgs) = 1.0-fracl(mgs) gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & & / (pi0(mgs)) IF ( temg(mgs) .lt. tfr ) then IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & & ((temg(mgs)-cbw)**2)) END IF IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & & ((temg(mgs)-cbi)**2)) END IF IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) denom1 = qx(mgs,lc) + qitmp(mgs) denom2 = 1.0 + gamss* & & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 dqvcnd(mgs) = dqwv(mgs) / denom2 END IF ENDIF if ( temg(mgs) .ge. tfr ) then dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & & ((temg(mgs)-cbw)**2)) end if delqci1=qx(mgs,li) IF ( qitmp(mgs) .gt. qxmin(li) ) THEN fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) ELSE fcci(mgs) = 1.0 ENDIF dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) dqci(mgs) = dqvcnd(mgs)*fraci(mgs) thetap(mgs) = thetap(mgs) + & & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & & / (pi0(mgs)) IF ( eqtset > 2 ) THEN pipert(mgs) = pipert(mgs) + (0 & & +felspi(mgs)*dqci(mgs) & & +felvpi(mgs)*dqcw(mgs)) ENDIF qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) qitmp(mgs) = qx(mgs,li) END IF end do do mgs = 1,ngscnt qitmp(mgs) = qx(mgs,li) theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) temcg(mgs) = temg(mgs) - tfr tqvcon = temg(mgs)-cbw ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) IF ( iqvsopt == 0 ) THEN qvs(mgs) = pqs(mgs)*tabqvs(ltemq) ELSEIF ( iqvsopt == 1 ) THEN qvs(mgs) = rdorv*esbolton*tabqvs(ltemq)/(pres(mgs) - esbolton*tabqvs(ltemq)) ENDIF qis(mgs) = pqs(mgs)*tabqis(ltemq) qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) qitmp(mgs) = max( 0.0, qitmp(mgs) ) qx(mgs,lv) = max( 0.0, qvap(mgs)) qss(mgs) = qvs(mgs) 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) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & & qss(mgs) = qis(mgs) if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & & (qx(mgs,lc) + qitmp(mgs)) end if end do end do ENDIF if (ndebug .gt. 0 ) write(0,*) 'conc 30b' ! !DIR$ IVDEP do mgs = 1,ngscnt t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) end do if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lt) = & & theta0(mgs) + thetap(mgs) an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) IF ( eqtset > 2 ) THEN p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) ENDIF DO il = lc,lhab IF ( ido(il) .eq. 1 ) THEN IF ( lf > 1 .and. il == lf ) THEN lfsave(mgs,1) = an(igs(mgs),jy,kgs(mgs),il) lfsave(mgs,2) = qx(mgs,il) ENDIF an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) ENDIF ENDDO IF ( lcina > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) ENDIF 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 if ( ipconc .ge. 1 ) then DO il = lc,lhab IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN DO mgs = 1,ngscnt IF ( qx(mgs,il) .le. 0.0 ) THEN cx(mgs,il) = 0.0 ELSE IF ( cx(mgs,il) .gt. cxmin .and. qx(mgs,il) > qxmin(il) ) THEN xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. & & (il == ls .and. imusnow == 3 ) .or. ( il >= lh .and. lh > 0 ) ) THEN xvbarmax = xvmx(il) ELSEIF ( imaxdiaopt == 2 ) THEN xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) ELSEIF ( imaxdiaopt == 3 ) THEN 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 tmp = 1.0 IF ( il == ls ) THEN xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) ENDIF IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) ENDIF ENDIF ENDIF ENDDO ELSE IF ( il == lr .and. imurain == 3 ) THEN 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 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 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) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) 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/(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 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) 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 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 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( 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 ( tmp < cx(mgs,il) ) THEN 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) 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 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 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 ELSEIF ( il == lh .or. il == lhl .or. il == lf .or. (il == lr .and. imurain == 1 )) THEN 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 IF ( zx(mgs,il) <= zxmin ) 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 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 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 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) ELSEIF ( zx(mgs,il) <= zxmin .and. cx(mgs,il) > 0.0 ) THEN chw = cx(mgs,il) qr = qx(mgs,il) 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 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) ELSE chw = cx(mgs,il) qr = qx(mgs,il) z = zx(mgs,il) IF ( zx(mgs,il) .gt. zxmin .and. qr > qxmin(il) .and. chw > cxmin ) THEN 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 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 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 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 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 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 chw = g1*dn(igs(mgs),jy,kgs(mgs))**2*(qr)*qr/z*(6./(pi*xdn(mgs,il)))**2 cx(mgs,il) = chw an(igs(mgs),jy,kgs(mgs),ln(il)) = chw ELSE 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 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 chxf(mgs,lhl) = frac*cx(mgs,lhl) ENDIF IF ( il == lh .and. lnhf > 1 ) THEN chxf(mgs,lh) = frach*cx(mgs,lh) ENDIF ENDDO ENDIF ENDIF ENDIF DO mgs = 1,ngscnt IF ( il == lh ) THEN IF ( lnhf > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lnhf) = Max( chxf(mgs,lh), 0.0) ENDIF ENDIF IF ( il == lhl ) THEN IF ( lnhlf > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lnhlf) = Max( chxf(mgs,lhl), 0.0) ENDIF ENDIF an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) ENDDO ENDIF ENDDO IF ( lcin > 1 ) THEN do mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) end do ENDIF IF ( ipconc .ge. 2 ) THEN do mgs = 1,ngscnt IF ( lss > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) ENDIF IF ( lccn > 1 ) THEN an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF end do ENDIF ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN DO mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) ENDDO end if IF ( ldovol ) THEN DO il = li,lhab IF ( lvol(il) .ge. 1 ) THEN DO mgs = 1,ngscnt an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) ENDDO ENDIF ENDDO ENDIF if (ndebug .gt. 0 ) write(0,*) 'gs 12' if (ndebug .gt. 0 ) write(0,*) 'gs 13' 9998 continue if ( kz .gt. nz-1 .and. ix .ge. itile) then if ( ix .ge. itile ) then go to 1200 else nzmpb = kz endif else nzmpb = kz end if if ( ix .ge. itile ) then nxmpb = 1 nzmpb = kz+1 else nxmpb = ix+1 end if 1000 continue 1200 continue return end subroutine nssl_2mom_gs END MODULE module_mp_nssl_2mom