!WRF:MODEL_MP:PHYSICS
! The FULL version calculates hydrometeor distributions for qc,qr,qs,qg. and qh, and three ice types,
! and their number concentrations (and aerosol concentrations).
! To use the FULL version of SBM, please do the following.
! Set DX_BOUND to some value larger than the first inner nest, but smaller than the outer domain in meters
! Set the aerosol concentration with the variables FCCNR_MAR, and FCCNR_CON, FCCNR_MIX.
! Each of the aerosol distributions are set with ACCN (concentration of ccn particles at 1% saturation), and
! BCCN (the "k" coefficient; for example: FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN).
! Questions: contact barry.h.lynn@gmail.com (Barry Lynn)
!
MODULE module_mp_full_sbm 2
USE module_mp_radar
!
!-----------------------------------------------------------------------
! BARRY
INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
! SET ONE = TRUE
LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.FALSE.
LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.TRUE.
! LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.TRUE.
! LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.FALSE.
INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
& p_ff6i33=100,p_ff8i01=101,p_ff8i33=133,p_ff2i01=134,p_ff2i33=166,p_ff3i01=167,p_ff3i33=199,&
& p_ff4i01=200,p_ff4i33=232,p_ff7i01=233,p_ff7i33=265
!p_ff1i01 = 2
!p_ff1i33 = 34
!p_ff5i01 = 35
!p_ff5i33 = 67
!p_ff6i01 = 68
!p_ff6i33 = 100
!p_ff8i01 = 101
!p_ff8i33 = 133
!p_ff2i01 = 134
!p_ff2i33 = 166
!p_ff3i01 = 167
!p_ff3i33 = 199
!p_ff4i01 = 200
!p_ff4i33 = 232
!p_ff7i01 = 233
!p_ff7i33 = 265
! 100
! REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.1
! TEN
! REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.01
! ONE
REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
REAL, PRIVATE,PARAMETER :: R_MORR = 287.15
REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.001
REAL,PRIVATE,PARAMETER :: DX_BOUND=7500
REAL ACCN,BCCN
REAL,PRIVATE,PARAMETER :: ACCN_MAR=1.0000E02, BCCN_MAR=0.900E00,ROCCN0=0.1000E01
REAL,PRIVATE,PARAMETER :: ACCN_CON=2.00000E03, BCCN_CON=0.400E00,ROCCN03=0.1000E01
REAL,PRIVATE,PARAMETER :: I3POINT=1
INTEGER,PRIVATE,PARAMETER :: ICCN = 1
DOUBLE PRECISION, PRIVATE, PARAMETER :: SCAL=1.d0
INTEGER, PRIVATE,PARAMETER :: ICEPROCS=1,BULKNUC=0
INTEGER, PRIVATE,PARAMETER :: ICETURB=0,LIQTURB=0
! INTEGER, PRIVATE,PARAMETER :: RAIN_INIT=1,GRAUPEL_INIT=1
! INTEGER, PRIVATE,PARAMETER :: ICE_INIT=0,SNOW_INIT=1
INTEGER, PRIVATE,PARAMETER :: ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7 &
& ,ifreez_down1=0,ifreez_down2=1,ifreez_top=1 &
& ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6 &
& , IEPS_400=1,IEPS_800=0,IEPS_1600=0 &
& ,K0L_GL=16,K0G_GL=16 &
& ,KRMINL_GL=1,KRMAXL_GL=24 &
& ,KRMING_GL=1,KRMAXG_GL=33 &
& ,KRDROP=18,KRBREAK=17,KRICE=18 &
& ,NKR=33,JMAX=33,NRG=2,JBREAK = 18
REAL dt_coll
! REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0. &
REAL, PRIVATE,PARAMETER ::C1_MEY=0.00033,C2_MEY=0. &
! New CONTINENTAL
! REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0. &
& ,an0_freez=10.,COL=0.23105
REAL, PRIVATE,PARAMETER :: p1=1000000.0,p2=750000.0,p3=500000.0
! INTEGER, PRIVATE,PARAMETER :: NCOND=3
! INTEGER, PRIVATE,PARAMETER :: NCOND=6
INTEGER, PRIVATE :: NCOND
INTEGER, PRIVATE,PARAMETER :: kr_icempl=9
! REAL, PRIVATE, PARAMETER :: ALCR = 1.0
! REAL, PRIVATE, PARAMETER :: ALCR = 2.0
! REAL, PRIVATE, PARAMETER :: ALCR = 1.5
REAL, PRIVATE, PARAMETER :: ALCR = 2.25
! REAL, PRIVATE, PARAMETER :: ALCR = 3.0
REAL, PRIVATE, PARAMETER :: ALCR_G = 3.0
! REAL, PRIVATE, PARAMETER :: ALCR_G = 1.0
INTEGER,PRIVATE,PARAMETER :: icempl=1
REAL, PRIVATE, PARAMETER :: COEFREFLL=1.E6*36.E6*COL/3.1453/3.1453
REAL, PRIVATE, PARAMETER :: COEFREFLI=1.E9*36.E3*COL/3.1453/3.1453/5.
REAL, PRIVATE, PARAMETER :: COEFREF00=1.E9*36.E3*COL/3.1453/3.1453
REAL, PRIVATE,DIMENSION(NKR) ::COLREFLL,COLREFLI,COLREFLS,COLREFLG,COLREFLH
! YWLL_1000MB(nkr,nkr) - input array of kernels for pressure 1000mb
! YWLL_750MB(nkr,nkr) - input array of kernels for pressure 750mb
! YWLL_500MB(nkr,nkr) - input array of kernels for pressure 500mb
REAL, PRIVATE, SAVE :: &
! CRYSTALS
&YWLI(NKR,NKR,ICEMAX) &
! MIXTURES
&,YWIL(NKR,NKR,ICEMAX),YWII(NKR,NKR,ICEMAX,ICEMAX) &
&,YWIS(NKR,NKR,ICEMAX),YWIG(NKR,NKR,ICEMAX) &
&,YWIH(NKR,NKR,ICEMAX),YWSI(NKR,NKR,ICEMAX) &
&,YWGI(NKR,NKR,ICEMAX),YWHI(NKR,NKR,ICEMAX)
!
REAL,PRIVATE,DIMENSION(NKR,NKR),SAVE :: &
& YWLL_1000MB,YWLL_750MB,YWLL_500MB,YWLL,YWLS,YWLG,YWLH &
! SNOW :
&,YWSL,YWSS,YWSG,YWSH &
! GRAUPELS :
&,YWGL,YWGS,YWGG,YWGH &
! HAIL :
&,YWHL,YWHS,YWHG,YWHH
REAL, PRIVATE, SAVE :: &
& XI(NKR,ICEMAX) &
& ,RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
& ,RADXXO(NKR,NHYDRO),MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO) &
& ,RIEC(NKR,ICEMAX),COEFIN(NKR),SLIC(NKR,6),TLIC(NKR,2) &
& ,RO2BL(NKR,ICEMAX)
REAL, PRIVATE, SAVE :: VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR) &
& ,VR4(NKR),VR5(NKR),VRX(NKR),VRI(NKR)
REAL,PRIVATE,DIMENSION(NKR),SAVE :: &
& XL,RLEC,XX,XCCN,XS,RSEC &
& ,XG,RGEC,XH,RHEC,RO1BL,RO3BL,RO4BL,RO5BL &
& ,ROCCN,RCCN,DROPRADII
REAL, PRIVATE,SAVE :: FCCNR_MAR(NKR),FCCNR_CON(NKR)
REAL, PRIVATE,SAVE :: FCCNR_MIX(NKR)
REAL, PRIVATE,SAVE :: FCCNR(NKR)
REAL, PRIVATE :: C2,C3,C4
double precision,private,save :: cwll(nkr,nkr)
double precision,private,save:: &
& xl_mg(0:nkr),xs_mg(0:nkr),xg_mg(0:nkr),xh_mg(0:nkr) &
&,xi1_mg(0:nkr),xi2_mg(0:nkr),xi3_mg(0:nkr) &
&,chucm(nkr,nkr),ima(nkr,nkr) &
&,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr) &
&,cwli_1(nkr,nkr),cwli_2(nkr,nkr),cwli_3(nkr,nkr) &
&,cwls(nkr,nkr),cwlg(nkr,nkr),cwlh(nkr,nkr) &
&,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &
&,cwii_1_1(nkr,nkr),cwii_1_2(nkr,nkr),cwii_1_3(nkr,nkr) &
&,cwii_2_1(nkr,nkr),cwii_2_2(nkr,nkr),cwii_2_3(nkr,nkr) &
&,cwii_3_1(nkr,nkr),cwii_3_2(nkr,nkr),cwii_3_3(nkr,nkr) &
&,cwis_1(nkr,nkr),cwis_2(nkr,nkr),cwis_3(nkr,nkr) &
&,cwig_1(nkr,nkr),cwig_2(nkr,nkr),cwig_3(nkr,nkr) &
&,cwih_1(nkr,nkr),cwih_2(nkr,nkr),cwih_3(nkr,nkr) &
&,cwsl(nkr,nkr) &
&,cwsi_1(nkr,nkr),cwsi_2(nkr,nkr),cwsi_3(nkr,nkr)&
&,cwss(nkr,nkr),cwsg(nkr,nkr),cwsh(nkr,nkr) &
&,cwgl(nkr,nkr)&
&,cwgi_1(nkr,nkr),cwgi_2(nkr,nkr),cwgi_3(nkr,nkr)&
&,cwgs(nkr,nkr),cwgg(nkr,nkr),cwgh(nkr,nkr) &
&,cwhl(nkr,nkr) &
&,cwhi_1(nkr,nkr),cwhi_2(nkr,nkr),cwhi_3(nkr,nkr) &
&,cwhs(nkr,nkr),cwhg(nkr,nkr),cwhh(nkr,nkr) &
&,dlnr &
&,CTURBLL(KRMAX_LL,KRMAX_LL)&
&,CTURB_LL(K0_LL,K0_LL)&
&,CTURBGL(KRMAXG_GL,KRMAXL_GL)&
&,CTURB_GL(K0G_GL,K0L_GL)
DOUBLE PRECISION,private, save :: &
& BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
& QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)
!
!
CONTAINS
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
SUBROUTINE SBM (w,u,v,th_old, & 1,22
& chem_new,n_chem, &
& itimestep,DT,DX,DY, &
& dz8w,rho_phy,p_phy,pi_phy,th_phy, &
& xland,ivgtyp,xlat,xlong, &
& QV,QC,QR,QIP,QIC,QID,QS,QG,QH,QV_OLD, &
& QNC,QNR,QNIP,QNIC,QNID,QNS,QNG,QNH,QNA,EFFR,ICE_EFFR,TOT_EFFR, &
& QIC_EFFR,QIP_EFFR,QID_EFFR, &
& height,tempc,&
! & QRRAD,QSRAD,QGRAD,QTIRAD,QTOTRAD, &
! & QRRAD,QSRAD,QGRAD, &
& kext_ql,kext_qs,kext_qg,kext_qh,kext_qa, &
& kext_qic,kext_qip,kext_qid, &
& kext_ft_qic,kext_ft_qip,kext_ft_qid, &
& kext_ft_qs,kext_ft_qg, &
& ids,ide, jds,jde, kds,kde, &
& ims,ime, jms,jme, kms,kme, &
& its,ite, jts,jte, kts,kte, &
& refl_10cm, diagflag, do_radar_ref, & ! MO added for reflectivity calcs
& RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR )
!-----------------------------------------------------------------------
IMPLICIT NONE
!-----------------------------------------------------------------------
INTEGER, PARAMETER :: ITLO=-60, ITHI=40
INTEGER NKRO,NKRE
INTEGER KR,IKL,ICE
INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
& ,IMS,IME,JMS,JME,KMS,KME &
& ,ITS,ITE,JTS,JTE,KTS,KTE &
& ,ITIMESTEP,N_CHEM
REAL, INTENT(IN) :: DT,DX,DY
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
INTENT(IN ) :: &
U, &
V, &
W
! pi
REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT) :: chem_new
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &
INTENT(INOUT) :: &
qv, &
qv_old, &
th_old, &
qc, &
qr, &
qip, &
qic, &
qid, &
qs, &
qg, &
qh, &
qnc, &
qnr, &
qns, &
qnip, &
qnic, &
qnid, &
qng, &
qnh, &
qna, &
kext_ql, &
kext_qs, &
kext_qg, &
kext_qh, &
kext_qa, &
kext_qic, &
kext_qip, &
kext_qid, &
kext_ft_qic, &
kext_ft_qip, &
kext_ft_qid, &
kext_ft_qs, &
kext_ft_qg, &
effr, &
ice_effr,&
tot_effr,&
qic_effr,&
qip_effr,&
qid_effr,&
height, &
tempc
! effr, &
! qtirad, &
! qtotrad
REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: XLAND
LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT
refl_10cm
INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN):: IVGTYP
REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAT, XLONG
REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: &
& dz8w,p_phy,pi_phy,rho_phy
REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: &
& th_phy
REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme), OPTIONAL :: &
& RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR
! REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme), OPTIONAL :: &
! REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL :: &
! & LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
!
!-----------------------------------------------------------------------
! LOCAL VARS
!-----------------------------------------------------------------------
! NSTATS,QMAX,QTOT are diagnostic vars
INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
! REAL, DIMENSION(ITLO:ITHI,5) :: QMAX
REAL, DIMENSION(ITLO:ITHI,22):: QTOT
! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW).
! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE
! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE
! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related
! the microphysics scheme. Instead, they will be used by Eta precip
! assimilation.
REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: &
& TLATGS_PHY,TRAIN_PHY
REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC
REAL, DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: t_new,t_old, &
& zcgs, rhocgs,pcgs
INTEGER :: I,J,K,KFLIP
! BARRY
INTEGER :: KRFREEZ
! DATA
REAL Z0IN,ZMIN
DATA ZMIN/2.0E5/
DATA Z0IN/2.0E5 /
! REAL,DIMENSION(1) :: EPSF2D, &
REAL EPSF2D, &
& TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
& PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
& AFREEZMY,BFREEZMY,BFREEZMAX, &
& TCRIT,TTCOAL, &
& EPSF1,EPSF3,EPSF4, &
& SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
& AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
& DTIME,DTCOND, &
& A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
& /2.53,5.42,3.41E1,6.13/
DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
! QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
& TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
& BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
& 0.6600E00, &
& 1.0000E02,1.0000E02,0.9000E02, &
& 0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
& 0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
& 2.3315E02,0.3333E-04,0.6600E00, &
& 0.1000E-02,0.1000E-05,0.1000E-05, &
& 2.7015E02/
! JIMY: N_CHEM,variables read in as data
! SBM VARIABLES
REAL,DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
& FF1R,FF3R,FF4R,FF5R,FCCN
REAL,DIMENSION (nkr,icemax) :: FF2IN,FF2R
!!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
DOUBLE PRECISION DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
DOUBLE PRECISION DELSUP1,DELSUP2,DELDIV1,DELDIV2
DOUBLE PRECISION TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
DOUBLE PRECISION DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
REAL DEL_BB,DEL_BBN,DEL_BBR
REAL FACTZ,CONCCCN_XZ,CONCDROP
REAL SUPICE(KTE),AR1,AR2, &
& DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
& ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
& DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
INTEGER KRR,I_START,I_END,J_START,J_END
REAL DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)
REAL DXHUCM,DYHUCM
REAL FMAX1,FMAX2,FMAX3,FMAX4,FMAX5
INTEGER ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
INTEGER DIFFU
REAL DELTAW
real zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
real z_full
! SLOPE INTERCEPT FOR RAIN, SNOW, AND GRAUPEL PARAMR.32
! RON=8.E6 PARAMR.33
! RON2=1.E10 23DEC04.211
! RON2=1.E9 23DEC04.212
! SON=2.E7 PARAMR.36
! GON=5.E7 23DEC04.213
! GON=4.E6
REAL, PARAMETER :: RON=8.E6, GON=5.E7,PI=3.14159265359
REAL EFF_N,EFF_D
REAL EFF_NI(its:ite,kts:kte,jts:jte),eff_di(its:ite,kts:kte,jts:jte)
REAL EFF_NQIC,eff_DQIC
REAL EFF_NQIP,eff_DQIP
REAL EFF_NQID,eff_DQID
real lambda,chi0,xi1,xi2,xi3,xi4,xi5,r_e,chi_3,f1,f2,volume,surface_area,xi6,ft,chi_e
real ft_bin
REAL, DIMENSION(kts:kte):: &
qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
REAL, DIMENSION(kts:kte):: dBZ
real nzero,son,nzero_less
parameter (son=2.E7)
real raddumb(nkr),massdumb(nkr)
real hydrosum
integer imax,kmax,jmax
real gmax
real tmax,qmax,divmax,rainmax
real qnmax,inmax,knmax
real hydro
real difmax,tdif,tt_old,w_stag,qq_old
real teten,es
integer print_int
parameter (print_int=300)
real ft_liq(nkr)
data ft_liq/ 6.254894e-01,6.615571e-01,6.922125e-01,7.514451e-01,7.391191e-01,7.592261e-01,7.417122e-01&
& ,7.388885e-01,7.430871e-01,7.570534e-01,7.584263e-01,7.735341e-01,7.721352e-01,7.724897e-01&
& ,7.744899e-01,7.745646e-01,7.768777e-01,7.776348e-01, 7.788586e-01,7.774171e-01,7.789876e-01 &
& ,7.801301e-01,7.806936e-01,7.801274e-01,7.821974e-01,7.815210e-01,7.822269e-01,7.822353e-01 &
& ,7.808765e-01,7.824246e-01,7.814153e-01,7.818192e-01, 7.818231e-01/
!
!
! GUY'S Variables
real geo_cs
integer t_print
t_print=print_int/dt
! print*,'n_chem = ',n_chem
difmax = 0
! print*,'itimestep = ',itimestep
! if (itimestep.gt.150)return
if (itimestep.eq.1)then
if (iceprocs.eq.1) call wrf_message(" FULL SBM: ICE PROCESES ACTIVE ")
if (iceprocs.eq.0) call wrf_message(" FULL SBM: LIQUID PROCESES ONLY")
end if
tmax = 0
! COAL BOTT IS EITHER CALLED EVERY TIME STEP OR TWICE
NCOND = 0
! if (mod(dx,1000.).eq.0)then
! NCOND=dx/1000
! else if (mod(dx,2000.).eq.0)then
! NCOND=dx/500
! else if (mod(dx,3000.).eq.0)then
! NCOND=dx/1000
! else if (mod(dx,4000.).eq.0)then
! NCOND=dx/1000
! else if (mod(dx,1333.).eq.0)then
! NCOND=dx/1.3333
! end if
NCOND=nint(dx/1000)
! IF (NCOND.EQ.0)NCOND=3
NCOND=max(NCOND,1)
DTCOND=DT/REAL(NCOND)
dt_coll=dt
call kernals(dt)
! if (itimestep.eq.1.or.itimestep.eq.3)then
! do kr = 1,nkr
! print*,'xl = ',xl(kr),vr1(kr),RLEC(kr),RO1BL(kr)
! print*,'xi = ',xi(kr,1),vr2(kr,1),RIEC(KR,1),RO2BL(KR,1)
! print*,'xi = ',xi(kr,2),vr2(kr,2),RIEC(KR,2),RO2BL(KR,2)
! print*,'xi = ',xi(kr,3),vr2(kr,3),RIEC(KR,3),RO2BL(KR,3)
! print*,'xs = ',xs(kr),vr3(kr),RSEC(kr),RO3BL(kr)
! print*,'xg = ',xg(kr),vr4(kr),RGEC(kr),RO4BL(kr)
! print*,'xh = ',xh(kr),vr5(kr),RHEC(kr),RO5BL(kr)
! end do
! end if
!
DEL_BB=BB2_MY-BB1_MY
DEL_BBN=BB2_MYN-BB1_MYN
DEL_BBR=BB1_MYN/DEL_BBN
!
if (conserv)then
DO j = jts,jte
DO i = its,ite
DO k = kts,kte
rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
KRR=0
DO KR=p_ff1i01,p_ff1i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
END DO
KRR=0
DO KR=p_ff5i01,p_ff5i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
END DO
KRR=0
DO KR=p_ff6i01,p_ff6i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
END DO
! if (i.eq.100.and.j.eq.100)then
! print*,'qna 1 = ', k,FACTZ,qna(i,k,j)
! end if
KRR=0
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
! change by J. Fan
! chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000. ! chem_new (input) is #/kg
END DO
! Columns
KRR=0
DO KR=p_ff2i01,p_ff2i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,1)/XI(KRR,1)/3.0
! if (i.eq.230.and.j.eq.146.and.k.eq.13)then
END DO
! Plates
KRR=0
DO KR=p_ff3i01,p_ff3i33
KRR=KRR+1
! if (i.eq.230.and.j.eq.146.and.k.eq.13)then
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,2)/XI(KRR,2)/3.0
END DO
! Dendrites
KRR=0
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,3)/XI(KRR,3)/3.0
END DO
KRR=0
DO KR=p_ff7i01,p_ff7i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XH(KRR)/XH(KRR)/3.0
END DO
END DO
END DO
END DO
end if
call kernals(dt)
DXHUCM=100.*DX
DYHUCM=100.*DY
! print*,'dxhucm = ',dxhucm
! print*,'dyhucm = ',dyhucm
!-----------------------------------------------------------------------
!**********************************************************************
!-----------------------------------------------------------------------
!
!
! JIMY
I_START=MAX(1,ITS-1)
J_START=MAX(1,JTS-1)
I_END=MIN(IDE-1,ITE+1)
J_END=MIN(JDE-1,JTE+1)
! print*,'ide-1 = ',ide-1
! print*,'jde-1 = ',jde-1
! print*,'kte = ',kte
! print*,'i_start,i_end = ',i_start,i_end
! print*,'j_start,j_end = ',j_start,j_end
! print*,'its,ite = ',its,ite
! print*,'jts,jte = ',jts,jte
DO j = j_start,j_end
DO i = i_start,i_end
z_full=0.
DO k = kts,kte
pcgs(I,K,J)=P_PHY(I,K,J)*10.
rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
z_full=z_full+dz8w(i,k,j)*100.
ENDDO
ENDDO
ENDDO
!!!!!
if (itimestep.eq.1)then
DO j = jts,jte
DO i = its,ite
DO k = kts,kte
IF (zcgs(I,K,J).LE.ZMIN)THEN
FACTZ=1.
ELSE
FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
END IF
! FACTZ = 1
KRR=0
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
if (xland(i,j).lt.1.5)then
chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
else
chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
end if
! if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
! if (zcgs(i,k,j).le.25000)then
! chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
! else
! chem_new(I,K,J,KR)=FCCNR3(KRR)
! end if
! end if
END DO
end do
end do
end do
end if
if (itimestep.ne.1.and.dx.gt.dx_bound)then
DO j = jts,jte
DO k = kts,kte
DO i = its,ite
if (i.le.5.or.i.ge.IDE-5.OR. &
& j.le.5.or.j.ge.JDE-5)THEN
IF (zcgs(I,K,J).LE.ZMIN)THEN
FACTZ=1.
ELSE
FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
END IF
KRR=0
DO kr=p_ff8i01,p_ff8i33
KRR=KRR+1
if (xland(i,j).lt.1.5)then
chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
else
chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
end if
! if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
! if (zcgs(i,k,j).le.25000)then
! chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
! else
! chem_new(I,K,J,KR)=FCCNR3(KRR)
! end if
! end if
End do
end if
end do
end do
end do
end if
if (itimestep.eq.1)then
DO j = j_start,j_end
DO k = kts,kte
DO i = i_start,i_end
th_old(i,k,j)=th_phy(i,k,j)
qv_old(i,k,j)=qv(i,k,j)
END DO
END DO
END DO
end if
DO j = j_start,j_end
DO k = kts,kte
DO i = i_start,i_end
t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
tempc(i,k,j)=t_new(i,k,j)-273.16
t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
ENDDO
ENDDO
ENDDO
!1 172 1 1
! print*,'here at 1'
DO j = jts,jte
DO i = its,ite
DO k = kts,kte
IF(K.EQ.KTE)THEN
DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
ELSE IF(K.EQ.1)THEN
DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
ELSE
DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
END IF
ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
SUPICE(K)=EW1N/ES2N-1.
IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
END DO
DO k = kts,kte
IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
if (k.lt.kte)then
w_stag=50.*(w(i,k,j)+w(i,k+1,j))
else
w_stag=100*w(i,k,j)
end if
IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
ELSE
UX=U(I,K,J)*100.
VX=V(I,K,J)*100.
END IF
IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
& (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
IF (I.EQ.1)THEN
DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
ELSE IF (I.EQ.IDE-1)THEN
DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
ELSE
DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
END IF
IF (J.EQ.1)THEN
DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
ELSE IF (J.EQ.JDE-1)THEN
DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
ELSE
DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
END IF
DTFREEZ_XYZ(I,K,J)=DT*(VX*DERIVT_Y+ &
& UX*DERIVT_X+w_stag*DERIVT_Z)
ELSE
DTFREEZ_XYZ(I,K,J)=0.
ENDIF
IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
IF (I.LT.IDE-1)THEN
ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
& (0.622+0.378*QV_OLD(I+1,K,J))
ELSE
ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
EW1NPLSX=QV_OLD(I,K,J)*pcgs(I,K,J)/ &
& (0.622+0.378*QV_OLD(I,K,J))
END IF
IF (ES2NPLSX.EQ.0)THEN
DEL2INPLSX=0.5
ELSE
DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
END IF
IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
IF (I.GT.1)THEN
ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
ELSE
ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
END IF
DEL2IN=EW1N/ES2N-1.
IF(DEL2IN.GT.0.5) DEL2IN=.5
IF (I.GT.1.AND.I.LT.IDE-1)THEN
DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
ELSE
DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
END IF
IF (J.LT.JDE-1)THEN
ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
ELSE
ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
END IF
DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
IF (J.GT.1)THEN
ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
ELSE
ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
END IF
DEL2IN=EW1N/ES2N-1.
IF(DEL2IN.GT.0.5) DEL2IN=.5
IF (J.GT.1.AND.J.LT.JDE-1)THEN
DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
ELSE
DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
END IF
!
IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
ELSE
UX=U(I,K,J)*100.
VX=V(I,K,J)*100.
END IF
DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
& w_stag*DERIVS_Z)*DTCOND
ELSE
DSUPICE_XYZ(I,K,J)=0.0
END IF
END DO
END DO
END DO
do j = jts,jte
do k = kts,kte
do i = its,ite
! print*,'i,j,k = ',i,j,k
! LIQUID
! do kr=1,nkr
! if (ff4r(kr).lt.0)then
! print*,'i,k,j = ',i,k,j
! print*,'ff4r 0 = ',kr,ff4r(kr)
! end if
! end do
KRR=0
DO kr=p_ff1i01,p_ff1i33
KRR=KRR+1
FF1R(KRR)=chem_new(I,K,J,KR)
IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
END DO
! CCN
KRR=0
DO kr=p_ff8i01,p_ff8i33
KRR=KRR+1
FCCN(KRR)=chem_new(I,K,J,KR)
if (fccn(krr).lt.0)fccn(krr)=0.
END DO
IF (ICEPROCS.EQ.1)THEN
! COLUMNS!
KRR=0
DO kr=p_ff2i01,p_ff2i33
KRR=KRR+1
FF2R(KRR,1)=chem_new(I,K,J,KR)
if (ff2r(krr,1).lt.0)ff2r(krr,1)=0
END DO
! PLATES!
KRR=0
DO kr=p_ff3i01,p_ff3i33
KRR=KRR+1
FF2R(KRR,2)=chem_new(I,K,J,KR)
!i,j,k = 230 146 13
if (ff2r(krr,2).lt.0)ff2r(krr,2)=0
END DO
! DENDRITES!
KRR=0
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
FF2R(KRR,3)=chem_new(I,K,J,KR)
if (ff2r(krr,3).lt.0)ff2r(krr,3)=0
END DO
! SNOW
KRR=0
DO kr=p_ff5i01,p_ff5i33
KRR=KRR+1
FF3R(KRR)=chem_new(I,K,J,KR)
if (ff3r(krr).lt.0)ff3r(krr)=0.
END DO
! Graupel
KRR=0
DO kr=p_ff6i01,p_ff6i33
KRR=KRR+1
FF4R(KRR)=chem_new(I,K,J,KR)
IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
END DO
! Hail
KRR=0
DO kr=p_ff7i01,p_ff7i33
KRR=KRR+1
FF5R(KRR)=chem_new(I,K,J,KR)
if (ff5r(krr).lt.0)ff5r(krr)=0.
END DO
CALL FREEZ &
& (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
& T_NEW(I,K,J),DT,rhocgs(I,K,J), &
& COL,AFREEZMY,BFREEZMY,BFREEZMAX, &
& KRFREEZ,ICEMAX,NKR)
IF (ORIGINAL_MELT)THEN
CALL ORIG_MELT &
& (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
& T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
END IF
IF (JIWEN_FAN_MELT) THEN
CALL J_W_MELT &
& (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
& T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
END IF
ENDIF
! IF (T_OLD(I,K,J).GT.223)THEN
IF (T_OLD(I,K,J).GT.213)THEN
TT=T_OLD(I,K,J)
QQ=QV_OLD(I,K,J)
! IF (QQ.LE.0)print*,'QQ < 0'
IF (QQ.LE.0)QQ=1.D-10
PP=pcgs(I,K,J)
TTA=T_NEW(I,K,J)
QQA=QV(I,K,J)
IF (QQA.LE.0) call wrf_message("WARNING: FULL SBM, QQA < 0 ")
! IF (QQA.LE.0)print*,'QQA = ',qqa
! IF (QQA.LE.0)print*,'i,k,j = ',i,k,j
! IF (QQA.LE.0)print*,'tta = ',tta
! IF (QQA.LE.0)print*,'tt = ',tt
! IF (QQA.LE.0)print*,'qq = ',qq
IF (QQA.LE.0)QQA=1.D-10
ES1N=AA1_MY*DEXP(-BB1_MY/TT)
ES2N=AA2_MY*DEXP(-BB2_MY/TT)
EW1N=QQ*PP/(0.622+0.378*QQ)
DIV1=EW1N/ES1N
DEL1IN=EW1N/ES1N-1.
DIV2=EW1N/ES2N
DEL2IN=EW1N/ES2N-1.
ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
EW1N=QQA*PP/(0.622+0.378*QQA)
DIV3=EW1N/ES1N
DEL1AD=EW1N/ES1N-1.
DIV4=EW1N/ES2N
DEL2AD=EW1N/ES2N-1.
SUP2_OLD=DEL2IN
DELSUP1=(DEL1AD-DEL1IN)/NCOND
DELSUP2=(DEL2AD-DEL2IN)/NCOND
DELDIV1=(DIV3-DIV1)/NCOND
DELDIV2=(DIV4-DIV2)/NCOND
DELTATEMP=0
DELTAQ=0
tt_old = TT
qq_old = qq
DIFFU=1
DO IKL=1,NCOND
IF (DIFFU.NE.0)THEN
DEL1IN=DEL1IN+DELSUP1
DEL2IN=DEL2IN+DELSUP2
DIV1=DIV1+DELDIV1
DIV2=DIV2+DELDIV2
END IF
!959 format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
! IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
! Jin-Fang Yin
IF ((DIV1 - DIV2) .GE. 1.0*10e-24 .AND.TT.LE.265)THEN
! print*,'div1 > div2',div1,div2
! print*,'delsup1, delsup2 = ',delsup1,delsup2
! print*,'del1in, del2in = ',del1in,del2in
! print*,'STOP'
! print*,'RESET'
! print*,'ikl,i,j,k = ',ikl,i,j,k
! print*,'zcgs = ',zcgs(i,k,j)
! print*,'tt,qq = ',tt,qq
! DIV1=0.99999*DIV2
! DEL1IN=0.99999*DEL2IN
! STOP
DIFFU=0
END IF
IF (DIFFU.NE.0)THEN
DEL1NR=A1_MYN*(100.*DIV1)
DEL2NR=A2_MYN*(100.*DIV2)
! IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
! IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
! IF (DEL2NR.EQ.0)PRINT*,'DELDIV2 = ',DELDIV2
! IF (DEL2NR.EQ.0)PRINT*,'DIV1 = ',DIV1
! IF (DEL2NR.EQ.0)PRINT*,'DIV2 = ',DIV2
IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2NR.EQ.0) , model stop ")
DEL12R=DEL1NR/DEL2NR
DEL12RD=DEL12R**DEL_BBR
EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
TT=-DEL_BB/DLOG(DEL12R)
QQ=0.622*EW1PN/(PP-0.378*EW1PN)
DO KR=1,NKR
FF1IN(KR)=FF1R(KR)
DO ICE=1,ICEMAX
FF2IN(KR,ICE)=FF2R(KR,ICE)
ENDDO
ENDDO
IF (BULKNUC.eq.1)THEN
IF (DEL1IN.GT.0)THEN
IF (zcgs(I,K,J).LE.500.E2)THEN
FACTZ=0.
ELSE
FACTZ=1
! FACTZ=EXP(-(zcgs(I,K,J)-2.E5)/Z0IN)
END IF
CONCCCN_XZ=FACTZ*ACCN*(100.*DEL1IN)**BCCN
CONCDROP=0.D0
DO KR=1,NKR
CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
ENDDO
CONCDROP=CONCDROP*3.D0*COL
IF(CONCCCN_XZ.GT.CONCDROP) &
& FF1IN(1)=FF1IN(1)+(CONCCCN_XZ-CONCDROP)/(3.D0*COL*XL(1))
END IF
ELSE
IF(DEL1IN.GT.0.OR.DEL2IN.GT.0)THEN
CALL JERNUCL01(FF1IN,FF2IN,FCCN &
& ,XL,XI,TT,QQ &
& ,rhocgs(I,K,J),pcgs(I,K,J) &
& ,DEL1IN,DEL2IN &
& ,COL,AA1_MY, BB1_MY, AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICE_XYZ(I,K,J) &
& ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
IF (T_OLD(I,K,J).GT.220.AND.T_OLD(I,K,J).LE.233)THEN
DO KR=1,NKR
FF2IN(KR,2)=FF2IN(KR,2)+FF1IN(KR)
FF1IN(KR)=0.
END DO
END IF
END IF
END IF
!
DO KR=1,NKR
FF1R(KR)=FF1IN(KR)
DO ICE=1,ICEMAX
FF2R(KR,ICE)=FF2IN(KR,ICE)
ENDDO
ENDDO
FMAX1=0.
FMAX2=0.
FMAX3=0.
FMAX4=0.
FMAX5=0.
DO KR=1,NKR
FF1IN(KR)=FF1R(KR)
FMAX1=AMAX1(FF1R(KR),FMAX1)
FF3IN(KR)=FF3R(KR)
FMAX3=AMAX1(FF3R(KR),FMAX3)
FF4IN(KR)=FF4R(KR)
FMAX4=AMAX1(FF4R(KR),FMAX4)
FF5IN(KR)=FF5R(KR)
FMAX5=AMAX1(FF5R(KR),FMAX5)
DO ICE=1,ICEMAX
FF2IN(KR,ICE)=FF2R(KR,ICE)
FMAX2=AMAX1(FF2R(KR,ICE),FMAX2)
END DO
END DO
ISYM1=0
ISYM2=0
ISYM3=0
ISYM4=0
ISYM5=0
IF(FMAX1.GT.0)ISYM1=1
IF (ICEPROCS.EQ.1)THEN
IF(FMAX2.GT.1.E-4)ISYM2=1
IF(FMAX3.GT.1.E-4)ISYM3=1
IF(FMAX4.GT.1.E-4)ISYM4=1
IF(FMAX5.GT.1.E-4)ISYM5=1
END IF
! Avoid Diffusional Growth
! IF (T_OLD(I,K,J).GE.237)THEN
! Same temperature range as above.
IF (T_OLD(I,K,J).GT.233)THEN
IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
& (ISYM2.EQ.0.AND. &
& ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
IF (T_OLD(I,K,J).GT.233)THEN
CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
& ,VR1,pcgs(I,K,J) &
& ,DEL1IN,DEL2IN,DIV1,DIV2 &
& ,FF1R,FF1IN,XL,RLEC,RO1BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR)
END IF
ELSE IF(ISYM1.EQ.0.AND.(TT-273.15).LE.-0.187.AND. &
& (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1.OR.ISYM5.EQ.1))THEN
IF (T_OLD(I,K,J).GT.233)THEN
CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
& ,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
& ,DEL1IN,DEL2IN,DIV1,DIV2 &
& ,FF2R,FF2IN,XI,RIEC,RO2BL &
& ,FF3R,FF3IN,XS,RSEC,RO3BL &
& ,FF4R,FF4IN,XG,RGEC,RO4BL &
& ,FF5R,FF5IN,XH,RHEC,RO5BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR &
& ,ISYM2,ISYM3,ISYM4,ISYM5)
END IF
ELSE IF(ISYM1.EQ.1.AND.(TT-273.15).LE.-0.187.AND. &
& (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1 &
& .OR.ISYM5.EQ.1))THEN
CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
& ,VR1,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
& ,DEL1IN,DEL2IN,DIV1,DIV2 &
& ,FF1R,FF1IN,XL,RLEC,RO1BL &
& ,FF2R,FF2IN,XI,RIEC,RO2BL &
& ,FF3R,FF3IN,XS,RSEC,RO3BL &
& ,FF4R,FF4IN,XG,RGEC,RO4BL &
& ,FF5R,FF5IN,XH,RHEC,RO5BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR &
& ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
END IF
END IF
END IF
IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
& FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
END DO
IF (DIFFU.EQ.0)THEN
th_phy(i,k,j) = tt_old/pi_phy(i,k,j)
qv(i,k,j)=qq_old
! print*,'problem calculating diffusion in sbm'
! print*,'tt_old = ',tt_old
! print*,'qq_old = ',qq_old
ELSE
th_phy(i,k,j) = tt/pi_phy(i,k,j)
qv(i,k,j)=qq
END IF
END IF
! LIQIUD
IF (REMSAT.EQ.1)THEN
DO KR=1,NKR
FF1R(KR)=0.
FCCN(KR)=0
IF (ICEPROCS.EQ.1)THEN
FF2R(KR,1)=0.
FF2R(KR,2)=0.
FF2R(KR,3)=0.
FF3R(KR)=0.
FF4R(KR)=0.
FF5R(KR)=0.
END IF
END DO
END IF
!Liquid Water
!Alex is not responsible the "2" below.
!Alex is responsible fo rthe geo_cs formulas.
kext_ql(i,k,j)=0.
krr=0
DO kr=p_ff1i01,p_ff1i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF1R(KRR)
geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
ft=0.
kext_ql(i,k,j)=kext_ql(i,k,j)+(1.-ft_liq(krr))*2.*geo_cs*(100.*col*3.*xl(krr))*ff1r(krr)
! if (i.eq.ime/2.and.j.eq.jme/2.and.k.eq.10)then
! if (krr.eq.1)write(6,*)'ft_bin_water information'
! geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
! write(6,901)krr,xl(krr),ro1bl(krr),RADXXO(krr,1),geo_cs
! end if
END DO
! He wants per meter, so we multiply by 100 above
! CCN
KRR=0
kext_qa(i,k,j)=0.
DO kr=p_ff8i01,p_ff8i33
KRR=KRR+1
chem_new(I,K,J,KR)=FCCN(KRR)
geo_cs=3.1415*(3*XCCN(krr)/(4*3.1415*0.4))**(2./3.)
kext_qa(i,k,j)=kext_qa(i,k,j)+2.*geo_cs*fccn(krr)
END DO
IF (ICEPROCS.EQ.1)THEN
!SNOW
EFF_NI(i,k,j)=0.
eff_di(i,k,j)=0.
EFF_NQIC=0
EFF_DQIC=0
EFF_NQIP=0
EFF_DQIP=0
EFF_NQID=0
EFF_DQID=0
KRR=0
kext_qs(i,k,j)=0.
kext_ft_qs(i,k,j)=0.
lambda = 0.55
chi0 = 0.00000
xi1 = 0.12534e-2
xi2 = 0.38929e-2
xi3 = 0.36593
xi4 = 0.38827e-1
xi5 = 0.87616
DO kr=p_ff5i01,p_ff5i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF3R(KRR)
geo_cs=3.1415*(xs(krr)/(1.2*3.1415*ro3bl(krr)))**(2./3.)
volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XS(KRR)
surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XS(KRR)
if (surface_area.ne.0.and.volume.ne.0)then
r_e = 3.0/4.0*volume/surface_area
chi_e = 2.0*pi*(r_e*1.E4)/lambda
f1 = (1.0 - xi1)* &
& (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
f2 = (1.0 - xi3)* &
& (1.0 - exp(-xi4*(chi_e - chi0)))
if(chi_e.le.chi0) then
ft = 0
else
ft = (1.0 - xi5)*f1 + xi5*f2
end if
else
ft=0.
end if
ft=0.
kext_qs(i,k,j)=kext_qs(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xs(krr))*ff3r(krr)
END DO
! HERE
! Graupel
KRR=0
kext_qg(i,k,j)=0.
kext_ft_qg(i,k,j)=0.
lambda = 0.55
chi0 = 0.00000
xi1 = 0.39026e-1
xi2 = 0.94264e-5
xi3 = 0.11281e-2
xi4 = 0.35218e-1
xi5 = 0.51453
DO kr=p_ff6i01,p_ff6i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF4R(KRR)
geo_cs=3.1415*(3.*xg(krr)/(4.*3.1415*0.4))**(2./3.)
volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XG(KRR)
surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XG(KRR)
if (surface_area.ne.0.and.volume.ne.0)then
r_e = 3.0/4.0*volume/surface_area
chi_e = 2.0*pi*(r_e*1.E4)/lambda
f1 = (1.0 - xi1)* &
& (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
f2 = (1.0 - xi3)* &
& (1.0 - exp(-xi4*(chi_e - chi0)))
if(chi_e.le.chi0) then
ft = 0
else
ft = (1.0 - xi5)*f1 + xi5*f2
end if
else
ft=0.
end if
ft=0.
kext_qg(i,k,j)=kext_qg(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xg(krr))*ff4r(krr)
END DO
! Columns
KRR=0
kext_qic(i,k,j)=0.
kext_ft_qic(i,k,j)=0.
lambda = 0.55
chi0 = 0.00000
xi1 = 0.60202
xi2 = 0.85513e-3
xi3 = 0.97065e-1
xi4 = 0.21320e-1
xi5 = 0.66985
DO kr=p_ff2i01,p_ff2i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF2R(KRR,1)
geo_cs=0.26*(xi(krr,1)/(ro2bl(krr,1)*0.2))**1.28
volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)
surface_area=sqrt(geo_cs/3.1415)**2.*chem_new(i,k,j,KR)*XI(KRR,1)
if (surface_area.ne.0.and.volume.ne.0)then
r_e = 3.0/4.0*volume/surface_area
chi_e = 2.0*pi*(r_e*1.E4)/lambda
f1 = (1.0 - xi1)* &
& (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
f2 = (1.0 - xi3)* &
& (1.0 - exp(-xi4*(chi_e - chi0)))
if(chi_e.le.chi0) then
ft = 0
else
ft = (1.0 - xi5)*f1 + xi5*f2
end if
else
ft=0.
end if
ft=0.
kext_qic(i,k,j)=kext_qic(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xi(krr,1))*ff2r(krr,1)
EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NI(i,k,j)
eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_di(i,k,j)
EFF_NQIC=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NQIC
eff_dqic=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_dqic
END DO
IF (EFF_DQIC.NE.0)THEN
QIC_EFFR(I,K,J)=EFF_NQIC/EFF_DQIC
ELSE
QIC_EFFR(I,K,J)=0.
END IF
krr=0
901 format(' ',i3,1x,f12.9,1x,3(f12.9,1x),f12.6,f12.3,1x,10(f12.8,1x))
! Plates
KRR=0
kext_qip(i,k,j)=0.
lambda = 0.55
chi0 = 0.00000
xi1 = 0.23397e-2
xi2 = 0.19513e-2
xi3 = 0.51912e-4
xi4 = 0.15159e-1
xi5 = 0.81012
DO kr=p_ff3i01,p_ff3i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF2R(KRR,2)
geo_cs=(3.1415/4)*(xi(krr,2)/(ro2bl(krr,2)*0.108))**0.72
volume=sqrt(geo_cs/3.1415)**3.*chem_new(i,k,j,KR)*XI(KRR,2)
surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)
if (surface_area.ne.0.and.volume.ne.0)then
r_e = 3.0/4.0*volume/surface_area
chi_e = 2.0*pi*(r_e*1.E4)/lambda
f1 = (1.0 - xi1)* &
& (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
f2 = (1.0 - xi3)* &
& (1.0 - exp(-xi4*(chi_e - chi0)))
if(chi_e.le.chi0) then
ft = 0
else
ft = (1.0 - xi5)*f1 + xi5*f2
end if
else
ft=0.
end if
ft=0.
kext_qip(i,k,j)=kext_qip(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,2))*ff2r(krr,2)
EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NI(i,k,j)
eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_di(i,k,j)
EFF_NQIP=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NQIP
eff_dqiP=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_dqip
END DO
IF (EFF_DQIP.NE.0)THEN
QIP_EFFR(I,K,J)=EFF_NQIP/EFF_DQIP
ELSE
QIP_EFFR(I,K,J)=0.
END IF
! s=(3.1415/4)*0.097**(-0.72)*(m(nkr))**0.72^M
! Dendrites
KRR=0
kext_qid(i,k,j)=0.
lambda = 0.55
chi0 = 0.00000
xi1 = 0.14875
xi2 = 0.49514e-2
xi3 = 0.36201
xi4 = 0.36993e-1
xi5 = 0.87020
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF2R(KRR,3)
geo_cs=(3.1415/4)*(xi(krr,3)/(ro2bl(krr,3)*7.8E-3))**0.828
volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)
surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)
if (surface_area.ne.0.and.volume.ne.0)then
r_e = 3.0/4.0*volume/surface_area
chi_e = 2.0*pi*(r_e*1.E4)/lambda
f1 = (1.0 - xi1)* &
& (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
f2 = (1.0 - xi3)* &
& (1.0 - exp(-xi4*(chi_e - chi0)))
if(chi_e.le.chi0) then
ft = 0
else
ft = (1.0 - xi5)*f1 + xi5*f2
end if
else
ft=0.
end if
ft=0.
kext_qid(i,k,j)=kext_qid(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,3))*ff2r(krr,3)
EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NI(i,k,j)
eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_di(i,k,j)
EFF_NQID=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NQID
eff_dqiD=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_dqiD
END DO
IF (EFF_DQID.NE.0)THEN
QID_EFFR(I,K,J)=EFF_NQID/EFF_DQID
ELSE
QID_EFFR(I,K,J)=0.
END IF
!s=(3.1415/4)*(4.6*(10**(-3.377)))**(-0.98)*(m(nkr))**0.98
! HAIL
KRR=0
kext_qh(i,k,j)=0.
DO KR=p_ff7i01,p_ff7i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF5R(KRR)
geo_cs=3.1415*(3*xh(krr)/(4*3.1415*0.9))**(2./3.)
kext_qh(i,k,j)=kext_qh(i,k,j)+2.*geo_cs*(100.*col*3*xh(krr))*ff5r(krr)
EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XH(KRR)+EFF_NI(i,k,j)
eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XH(KRR)+eff_di(i,k,j)
END DO
END IF
END DO
END DO
END DO
NKRO=1
NKRE=NKR
DO j = jts,jte
DO i = its,ite
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff1i01,p_ff1i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
end do
end do
CALL FALFLUXHUCM(ffx_z,VR1,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff1i01,p_ff1i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
if (iceprocs.eq.1)then
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff5i01,p_ff5i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
end do
end do
CALL FALFLUXHUCM(ffx_z,VR3,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff5i01,p_ff5i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff6i01,p_ff6i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
end do
end do
CALL FALFLUXHUCM(ffx_z,VR4,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff6i01,p_ff6i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
! & ims,ime,jms,jme,kms,kme)
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff2i01,p_ff2i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
vri(krr)=vr2(krr,1)
end do
end do
CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff2i01,p_ff2i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff3i01,p_ff3i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
vri(krr)=vr2(krr,2)
end do
end do
CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff3i01,p_ff3i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff4i01,p_ff4i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
vri(krr)=vr2(krr,3)
end do
end do
CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff4i01,p_ff4i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
DO k = kts,kte
rhocgs_z(k)=rhocgs(i,k,j)
pcgs_z(k)=pcgs(i,k,j)
zcgs_z(k)=zcgs(i,k,j)
krr=0
do kr=p_ff7i01,p_ff7i33
krr=krr+1
ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
end do
end do
CALL FALFLUXHUCM(ffx_z,VR5,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
DO k = kts,kte
krr=0
do kr=p_ff7i01,p_ff7i33
krr=krr+1
chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
end do
end do
end if
end do
end do
gmax=0
qmax=0
imax=0
kmax=0
qnmax=0
inmax=0
knmax=0
DO j = jts,jte
DO k = kts,kte
DO i = its,ite
QC(I,K,J)=0
QR(I,K,J)=0
QIC(I,K,J)=0
QIP(I,K,J)=0
QID(I,K,J)=0
QS(I,K,J)=0
QG(I,K,J)=0
QH(I,K,J)=0
QNC(I,K,J)=0
QNR(I,K,J)=0
QNIP(I,K,J)=0
QNIC(I,K,J)=0
QNID(I,K,J)=0
QNS(I,K,J)=0
QNG(I,K,J)=0
QNH(I,K,J)=0
QNA(I,K,J)=0
tt= th_phy(i,k,j)*pi_phy(i,k,j)
DO KR=1,NKR
COLREFLL(KR)=COEFREFLL
COLREFLI(KR)=COEFREFLI
IF(TT.GE.271.15.AND.TT.LE.273.15) THEN
COLREFLS(KR)=COEFREF00/0.09
COLREFLG(KR)=COEFREF00/RO4BL(KR)/RO4BL(KR)
COLREFLH(KR)=COEFREF00/RO5BL(KR)/RO5BL(KR)
ELSE
COLREFLS(KR)=COEFREFLI
COLREFLG(KR)=COEFREFLI
COLREFLH(KR)=COEFREFLI
ENDIF
END DO
! END IF
EFF_N=0.
EFF_D=0.
KRR=0
DO KR = p_ff1i01,p_ff1i33
KRR=KRR+1
IF (KRR.LT.KRDROP)THEN
EFF_N=DROPRADII(KRR)**3*chem_new(i,k,j,KR)*XL(KRR)+EFF_N
EFF_D=DROPRADII(KRR)**2*chem_new(i,k,j,KR)*XL(KRR)+EFF_D
QC(I,K,J)=QC(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
! QNC(I,K,J)=QNC(I,K,J) &
! J. Fan
! & +COL*chem_new(I,K,J,KR)*XL(KR)*3
QNC(I,K,J)=QNC(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg
ELSE
QR(I,K,J)=QR(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
QNR(I,K,J)=QNR(I,K,J) &
! & +COL*chem_new(I,K,J,KR)*XL(KR)*3
& +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END IF
END DO
IF(QC(I,K,J).GT.1.E-6.and.EFF_D.GT.0)THEN
EFFR(I,K,J)=EFF_N/EFF_D
ELSE
EFFR(I,K,J)=0.
END IF
KRR=0
IF (ICEPROCS.EQ.1)THEN
KRR=0
DO KR=p_ff5i01,p_ff5i33
KRR=KRR+1
! if (KRR.LE.KRICE)THEN
! QI(I,K,J)=QI(I,K,J) &
! & +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
! ELSE
QS(I,K,J)=QS(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
! END IF
QNS(I,K,J)=QNS(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XS(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
KRR=0
DO KR=p_ff6i01,p_ff6i33
KRR=KRR+1
QG(I,K,J)=QG(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3
QNG(I,K,J)=QNG(I,K,J) &
! & +1000*COL*chem_new(I,K,J,KR)*XG(KRR)*3
& +COL*chem_new(I,K,J,KR)*XG(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
KRR=0
DO KR=p_ff2i01,p_ff2i33
KRR=KRR+1
QIC(I,K,J)=QIC(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,1)*XI(KRR,1)*3
QNIC(I,K,J)=QNIC(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XI(KRR,1)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
KRR=0
DO KR=p_ff3i01,p_ff3i33
KRR=KRR+1
QIP(I,K,J)=QIP(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,2)*XI(KRR,2)*3
QNIP(I,K,J)=QNIP(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XI(KRR,2)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
KRR=0
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
QID(I,K,J)=QID(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,3)*XI(KRR,3)*3
QNID(I,K,J)=QNID(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XI(KRR,3)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
IF((QIP(I,K,J).GT.1.E-6.OR.QIC(I,K,J).GT.1.E-6.OR.QID(I,K,J).GT.1.E-6)&
& .and.eff_di(i,k,j).GT.0)THEN
ICE_EFFR(I,K,J)=EFF_NI(i,k,j)/eff_di(i,k,j)
ELSE
ICE_EFFR(I,K,J)=0.
END IF
END IF
KRR=0
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
QNA(I,K,J)=QNA(I,K,J) &
! & +COL*chem_new(I,K,J,KR)*3
! change by J.Fan
& +COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000. ! #/kg
END DO
! if (i.eq.100.and.j.eq.100)then
! print*,'qna = ', k,qna(i,k,j)
! end if
KRR=0
DO KR=p_ff7i01,p_ff7i33
KRR=KRR+1
QH(I,K,J)=QH(I,K,J) &
& +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3
QNH(I,K,J)=QNH(I,K,J) &
& +COL*chem_new(I,K,J,KR)*XH(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
END DO
END DO
END DO
END DO
998 format(' ',10(f10.1,1x))
DO j = jts,jte
DO i = its,ite
krr=0
RAINNCV(I,J)=0.
SNOWNCV(I,J)=0.
GRAUPELNCV(I,J)=0.
HAILNCV(I,J)=0.
DO KR=p_ff1i01,p_ff1i33
krr=krr+1
DELTAW=VR1(KRR)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
RAINNCV(I,J)= RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
END DO
KRR=0
DO KR=p_ff5i01,p_ff5i33
KRR=KRR+1
DELTAW=VR3(KRR)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
SNOWNC(I,J)=SNOWNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
SNOWNCV(I,J)= SNOWNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
END DO
KRR=0
DO KR=p_ff6i01,p_ff6i33
KRR=KRR+1
DELTAW=VR4(KRR)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
GRAUPELNC(I,J)=GRAUPELNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
GRAUPELNCV(I,J)= GRAUPELNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
END DO
KRR=0
DO KR=p_ff2i01,p_ff2i33
KRR=KRR+1
DELTAW=VR2(KRR,1)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
SNOWNC(I,J)=SNOWNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
SNOWNCV(I,J)=SNOWNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
END DO
KRR=0
DO KR=p_ff3i01,p_ff3i33
KRR=KRR+1
DELTAW=VR2(KRR,2)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
SNOWNC(I,J)=SNOWNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
SNOWNCV(I,J)=SNOWNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
END DO
KRR=0
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
DELTAW=VR2(KRR,3)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
SNOWNC(I,J)=SNOWNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
SNOWNCV(I,J)=SNOWNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
END DO
KRR=0
DO KR=p_ff7i01,p_ff7i33
KRR=KRR+1
DELTAW=VR5(KRR)
RAINNC(I,J)=RAINNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
RAINNCV(I,J)=RAINNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
HAILNC(I,J)=HAILNC(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
HAILNCV(I,J)= HAILNCV(I,J) &
& +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
& chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
END DO
! print*, i,j,rainnc(i,j)
! Transfer 1D arrays back into 3D arrays
!
do k=kts,kte
qv1d(k)=qv(i,k,j)
qr1d(k)=qr(i,k,j)
nr1d(k)=qnr(i,k,j)
qs1d(k)=qs(i,k,j)
ns1d(k)=qns(i,k,j)
qg1d(k)=qg(i,k,j)+qh(i,k,j)
ng1d(k)=qng(i,k,j)+qnh(i,k,j)
t1d(k)=th_phy(i,k,j)*pi_phy(i,k,j)
p1d(k)=P_PHY(I,K,J)
end do
! wrf-chem
!+---+-----------------------------------------------------------------+
IF ( PRESENT (diagflag) ) THEN
if (diagflag .and. do_radar_ref == 1) then
call refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, &
t1d, p1d, dBZ, kts, kte, i, j)
do k = kts, kte
refl_10cm(i,k,j) = MAX(-35., dBZ(k))
enddo
endif
ENDIF
SR(I,J) = (SNOWNCV(I,J)+GRAUPELNCV(I,J)+HAILNCV(I,J))/(RAINNCV(I,J)+1.e-12)
END DO
END DO
! print*,'here 7'
do j=jts,jte
do k=kts,kte
do i=its,ite
! th_old_2(i,k,j)=th_phy(i,k,j)
! qv_old_2(i,k,j)=qv(i,k,j)
th_old(i,k,j)=th_phy(i,k,j)
qv_old(i,k,j)=qv(i,k,j)
! if(i.eq.64.and.j.eq.2.and.k.eq.16)then
! print*,'th_phy(I,K,J),tt = ',th_phy(I,K,J),tt
! print*,'qv(I,K,J) = ',qv(I,K,J)
! end if
end do
end do
end do
! stop
! print*,'here 8'
if (conserv)then
DO j = jts,jte
DO i = its,ite
DO k = kts,kte
rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
krr=0
DO KR=p_ff1i01,p_ff1i33
krr=krr+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
if (qc(i,k,j)+qr(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
DO KR=p_ff5i01,p_ff5i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
if (qs(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
DO KR=p_ff6i01,p_ff6i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
if (qg(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
! if (i.eq.100.and.j.eq.100)then
! print*,'qna 3 = ', k,qna(i,k,j)
! end if
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
! change by Fan
! chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*XCCN(KRR)
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000. ! #/kg; remember chem_new for CCN is #/cm3, not #/(gcm-3)
END DO
! if (i.eq.100.and.j.eq.100)then
! print*,'qna 4 = ', k,qna(i,k,j)
! end if
KRR=0
DO KR=p_ff2i01,p_ff2i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,1)*XI(KRR,1)*3.0
if (qic(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
DO KR=p_ff3i01,p_ff3i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,2)*XI(KRR,2)*3.0
if (qip(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
DO KR=p_ff4i01,p_ff4i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,3)*XI(KRR,3)*3.0
if (qid(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
KRR=0
DO KR=p_ff7i01,p_ff7i33
KRR=KRR+1
chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XH(KRR)*XH(KRR)*3.0
if (qh(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
END DO
END DO
END DO
END DO
END IF
! print*,'here 9'
RETURN
END SUBROUTINE SBM
SUBROUTINE FALFLUXHUCM(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, & 10,2
& kts,kte,nkr)
IMPLICIT NONE
INTEGER I,J,K,KR
INTEGER kts,kte,nkr
REAL TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
REAL DT
INTEGER IFALL,N,NSUB
REAL, DIMENSION( kts:kte,nkr ) :: chem_new
REAL, DIMENSION(kts:kte) :: rhocgs,pcgs,zcgs
REAL VR1(NKR)
! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
! ADAPTED FROM GSFC CODE FOR HUCM
! The flux at k=1 is assumed to be the ground so FLUX(1) is the
! flux into the ground. DWFLUX(1) is at the lowest half level where
! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
! is actually half a grid level above it. This is what is meant by
! an upstream method. Upstream in this case is above because the
! velocity is downwards.
! USE UPSTREAM METHOD (VFALL IS POSITIVE)
! print*,'pcgs(i,k,j) = ',pcgs(100,10,1)
! print*,'pcgs(i,k,j) = ',pcgs(100,1,1)
! read(5,*)
! print*,'pcgs(i,k,j) = ',zcgs(100,10,1)
! print*,'pcgs(i,k,j) = ',zcgs(100,1,1)
! read(5,*)
DO KR=1,NKR
IFALL=0
DO k = kts,kte
IF(chem_new(K,KR).GE.1.E-10)IFALL=1
END DO
IF (IFALL.EQ.1)THEN
TFALL=1.E10
DO K=kts,kte
VFALL(K) = VR1(KR)*SQRT(1.E6/PCGS(K))
! if (krr.eq.20.or.krr.eq.33)then
! if (k.eq.5.or.k.eq.10.or.k.eq.20)then
! print*,'vr1(krr) = ',krr,vr1(krr)
! print*, 'SQRT(1.E6/PCGS(I,K,J)) = ',i,k,SQRT(1.E6/PCGS(I,K,J))
! print*,'vfall(k) = ',i,k,vfall(k)
! print*,'zcgs(k) = ',i,k,zcgs(i,k,j)
! read(5,*)
! end if
! end if
TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))
! print*,'tfall = ',i,k,tfall
! if (krr.eq.5.or.krr.eq.10.or.krr.eq.20.or.krr.eq.33)read(5,*)
END DO
IF(TFALL.GE.1.E10) call wrf_error_fatal("fatal error in module_mp_full_sbm (TFALL.GE.1.E10), model stop")
NSUB=(INT(2.0*DT/TFALL)+1)
DTFALL=DT/NSUB
DO N=1,NSUB
DO K=KTS,KTE-1
DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
& RHOCGS(K+1)* &
& VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
& ZCGS(K)))
END DO
! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* &
& chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))
DO K=kts,kte
chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
END DO
END DO
END IF
END DO
RETURN
END SUBROUTINE FALFLUXHUCM
SUBROUTINE FULL_HUCMINIT(DT) 1,81
IMPLICIT NONE
INTEGER IKERN_0,IKERN_Z,L0_REAL,L0_INTEGER,INEWMEY,INEST
INTEGER I,J,K,KR
REAL DT
INTEGER :: hujisbm_unit1
LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
LOGICAL :: opened
LOGICAL , EXTERNAL :: wrf_dm_on_monitor
CHARACTER*80 errmess
REAL PI
double precision ax
data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! ax - coefficient used for masses calculation
! ima(i,j) - k-category number, c(i,j) - courant number
REAL C1(NKR,NKR)
! DON'T NEED ALL THESE VARIABLES: STILL NEED EDITING
INTEGER ICE,KGRAN,IPRINT01
REAL TWSIN,TWCIN,TWNUC,XF5,XF4,XF3,CONCHIN,CONCGIN,CONCSIN, &
& CONCCLIN,TWHIN,RADH,RADS,RADG,RADL,CONCLIN,A1_MY,A2,A2_MY,XLK, &
& A1N,A3_MY,A3,A1_MYN,R0CCN,X0DROP,DEG01,CONTCCNIN,CONCCCNIN, &
& A,B,X0CCN,S_KR,RCCNKR,R0,X0,TWCALLIN,A1,RCCNKR_CM,SUMIIN,TWGIN, &
& XF1N,XF1,WC1N,RF1N,WNUC,RNUC,WC5,RF5, &
& WC4,RF4,WC3,RF3,WC1,RF1,SMAX
REAL TWIIN(ICEMAX)
REAL RO_SOLUTE
REAL A_FALL,B_FALL
real graupel_fall(nkr)
data graupel_fall/0.36840E-01,0.57471E-01,0.88417E-01,0.13999E+00,&
& 0.22841E+00,0.36104E+00,0.56734E+00, 0.88417E+00, 0.13999E+01,&
& 0.22104E+01, 0.35367E+01, 0.54524E+01, 0.81049E+01,0.12526E+02,&
& 0.19157E+02, 0.27262E+02, 0.34627E+02, 0.39776E+02,0.45690E+02,&
& 0.52485E+02, 0.60289E+02, 0.69254E+02, 0.10000E+03, 0.15429E+03,&
& 0.18561E+03, 0.22329E+03, 0.26863E+03, 0.32316E+03,0.38877E+03,&
& 0.46770E+03, 0.56266E+03, 0.67690E+03, 0.81432E+03/
INTEGER KZ_MIN,KZ_MAX
PARAMETER (RO_SOLUTE=2.16)
INTEGER KR_MIN,KR_MIN1,KR_MAX
REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
REAL FR_CON,FR_MAR
REAL :: RHOSU ! STANDARD AIR DENSITY AT 850 MB
REAL :: RHOW ! DENSITY OF LIQUID WATER
REAL :: RHOI ! BULK DENSITY OF CLOUD ICE
REAL :: RHOSN ! BULK DENSITY OF SNOW
REAL :: RHOG ! BULK DENSITY OF GRAUPEL
REAL :: CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPE
FR_MAR=1.0
! FR_CON=1-FR_MAR
FR_CON=1.0
! KZ_MIN=16
! KZ_MAX=21
call wrf_message(" FULL SBM: INITIALIZING HUCM ")
call wrf_message(" FULL SBM: ****** HUCM ******* ")
! PRINT*, 'INITIALIZING HUCM'
! print *, ' ****** HUCM *******'
! INPUT :
dlnr=dlog(2.d0)/(3.d0*scal)
! print*,'here in hucmint 1'
!
!--- Read in various lookup tables
!
! print*,'wrf_dm_on_monitor() =',wrf_dm_on_monitor()
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2061
ENDIF
ENDDO
hujisbm_unit1 = -1
2061 CONTINUE
ENDIF
!
! print*,'here in hucmint 2',hujisbm_unit1
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
! print*,'here in hucmint 3',hujisbm_unit1
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
! print*,'here at 1'
! print*,'here in hucmint 4'
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="capacity.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
900 FORMAT(6E13.5)
READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
CLOSE(hujisbm_unit1)
! print*,'here in hucmint 5'
END IF
CALL wrf_dm_bcast_bytes ( RLEC , size ( RLEC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( RIEC , size ( RIEC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( RSEC , size ( RSEC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( RGEC , size ( RGEC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( RHEC , size ( RHEC ) * RWORDSIZE )
! MASSES :
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2062
ENDIF
ENDDO
hujisbm_unit1 = -1
2062 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="masses.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,900) XL,XI,XS,XG,XH
CLOSE(hujisbm_unit1)
! print *, ' ***** file2: succesfull *******'
call wrf_message(" FULL SBM: ****** file2: succesfull ******* ")
ENDIF
CALL wrf_dm_bcast_bytes ( XL , size ( XL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( XI , size ( XI ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( XS , size ( XS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( XG , size ( XG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( XH , size ( XH ) * RWORDSIZE )
! TERMINAL VELOSITY :
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2063
ENDIF
ENDDO
hujisbm_unit1 = -1
2063 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="termvels.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5
CLOSE(hujisbm_unit1)
! print *, ' ***** file3: succesfull *******'
call wrf_message(" FULL SBM: ****** file3: succesfull ******* ")
ENDIF
CALL wrf_dm_bcast_bytes ( VR1 , size ( VR1 ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( VR2 , size ( VR2 ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( VR3 , size ( VR3 ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( VR4 , size ( VR4 ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( VR5 , size ( VR5 ) * RWORDSIZE )
! CHANGE FALL VELOCITY OF GRAUPEL
DO KR=1,NKR
! A=RADXXO(KR,6)
! B=RADXXO(KR,7)
if (kr.le.17)then
A_FALL=1
B_FALL=0
else
B_FALL=1
A_FALL=0
end if
! VR4(KR)=A_FALL*VR4(KR)+B_FALL*VR5(KR)
! print*,'vr4,vr5,graupel_fall=',vr3(kr),vr5(kr),graupel_fall(kr)
! VR4(KR)=graupel_fall(kr)
END DO
! CONSTANTS :
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2065
ENDIF
ENDDO
hujisbm_unit1 = -1
2065 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="constants.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN,C2,C3,C4
CLOSE(hujisbm_unit1)
! print *, ' ***** file4: succesfull *******'
call wrf_message(" FULL SBM: ****** file4: succesfull ******* ")
END IF
CALL wrf_dm_bcast_bytes ( SLIC , size ( SLIC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( TLIC , size ( TLIC ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( COEFIN , size ( COEFIN ) * RWORDSIZE )
! CALL wrf_dm_bcast_bytes ( C2 , size ( C2 ) * RWORDSIZE )
! CALL wrf_dm_bcast_bytes ( C3 , size ( C3 ) * RWORDSIZE )
! CALL wrf_dm_bcast_bytes ( C4 , size ( C4 ) * RWORDSIZE )
! CONSTANTS :
! KERNELS DEPENDING ON PRESSURE :
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2066
ENDIF
ENDDO
hujisbm_unit1 = -1
2066 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="kernels_z.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,900) &
& YWLL_1000MB,YWLL_750MB,YWLL_500MB
CLOSE(hujisbm_unit1)
END IF
CALL wrf_dm_bcast_bytes ( YWLL_1000MB , size ( YWLL_1000MB ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLL_750MB , size ( YWLL_750MB ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLL_500MB , size ( YWLL_500MB ) * RWORDSIZE )
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2067
ENDIF
ENDDO
hujisbm_unit1 = -1
2067 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="kernels.asc_s_0_03_0_9", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
! KERNELS NOT DEPENDING ON PRESSURE :
READ(hujisbm_unit1,900) &
& YWLL,YWLI,YWLS,YWLG,YWLH, &
& YWIL,YWII,YWIS,YWIG,YWIH, &
& YWSL,YWSI,YWSS,YWSG,YWSH, &
& YWGL,YWGI,YWGS,YWGG,YWGH, &
& YWHL,YWHI,YWHS,YWHG,YWHH
close (hujisbm_unit1)
END IF
CALL wrf_dm_bcast_bytes ( YWLL , size ( YWLL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLI , size ( YWLI ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLS , size ( YWLS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLG , size ( YWLG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWLH , size ( YWLH ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWIL , size ( YWIL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWII , size ( YWII ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWIS , size ( YWIS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWIG , size ( YWIG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWIH , size ( YWIH ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWSL , size ( YWSL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWSI , size ( YWSI ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWSS , size ( YWSS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWSG , size ( YWSG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWSH , size ( YWSH ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWGL , size ( YWGL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWGI , size ( YWGI ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWGS , size ( YWGS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWGG , size ( YWGG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWGH , size ( YWGH ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWHL , size ( YWHL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWHI , size ( YWHI ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWHS , size ( YWHS ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWHG , size ( YWHG ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes ( YWHH , size ( YWHH ) * RWORDSIZE )
! BULKDENSITY :
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2068
ENDIF
ENDDO
hujisbm_unit1 = -1
2068 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="bulkdens.asc_s_0_03_0_9", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
CLOSE(hujisbm_unit1)
! print *, ' ***** file6: succesfull *******'
call wrf_message(" FULL SBM: ****** file6: succesfull ******* ")
END IF
CALL wrf_dm_bcast_bytes (RO1BL , size ( RO1BL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes (RO2BL , size ( RO2BL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes (RO3BL , size ( RO3BL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes (RO4BL , size ( RO4BL ) * RWORDSIZE )
CALL wrf_dm_bcast_bytes (RO5BL , size ( RO5BL ) * RWORDSIZE )
! BULKRADIUS
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2069
ENDIF
ENDDO
hujisbm_unit1 = -1
2069 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="bulkradii.asc_s_0_03_0_9", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
READ(hujisbm_unit1,*) RADXXO
CLOSE(hujisbm_unit1)
! print *, ' ***** file7: succesfull *******'
call wrf_message(" FULL SBM: ****** file7: succesfull ******* ")
! PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
call wrf_message(" FULL SBM: Hebrew Univ Cloud model-HUCM ")
END IF
CALL wrf_dm_bcast_bytes (RADXXO , size ( RADXXO ) * RWORDSIZE )
! calculation of the mass(in mg) for categories boundaries :
ax=2.d0**(1.0/scal)
xl_mg(1)=0.3351d-7
do i=2,nkr
xl_mg(i)=ax*xl_mg(i-1)
! if (i.eq.22)print*,'printing xl_mg = ',xl_mg(22)
enddo
do i=1,nkr
xs_mg(i)=xs(i)*1.e3
xg_mg(i)=xg(i)*1.e3
xh_mg(i)=xh(i)*1.e3
xi1_mg(i)=xi(i,1)*1.e3
xi2_mg(i)=xi(i,2)*1.e3
xi3_mg(i)=xi(i,3)*1.e3
enddo
! calculation of c(i,j) and ima(i,j) :
! ima(i,j) - k-category number, c(i,j) - courant number
! print*, 'calling courant_bott'
call courant_bott
! print*, 'called courant_bott'
DEG01=1./3.
!------------------------------------------------------------------
! print*,'XL(ICCN) = ',ICCN,XL
X0DROP=XL(ICCN)
! print*,'X0DROP = ',X0DROP
X0CCN =X0DROP/(2.**(NKR-1))
R0CCN =(3.*X0CCN/4./3.141593/ROCCN0)**DEG01
!------------------------------------------------------------------
! THIS TEXT FROM TWOINITM.F_203
!------------------------------------------------------------------
! TEMPERATURA IN SURFACE LAYER EQUAL 15 Celsius(288.15 K)
A=3.3E-05/288.15
B=2.*4.3/(22.9+35.5)
B=B*(4./3.)*3.14*RO_SOLUTE
A1=2.*(A/3.)**1.5/SQRT(B)
A2=A1*100.
!------------------------------------------------------------------
CONCCCNIN=0.
CONTCCNIN=0.
DO KR=1,NKR
DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
ENDDO
DO KR=1,NKR
! print*,'ROCCN0 = ',ROCCN0
! print*, 'X0CCN = ',X0CCN
! print*, 'DEG01 = ',DEG01
ROCCN(KR)=ROCCN0
X0=X0CCN*2.**(KR-1)
R0=(3.*X0/4./3.141593/ROCCN(KR))**DEG01
XCCN(KR)=X0
RCCN(KR)=R0
! print*,'RCCN(KR)= ', KR,RCCN(KR)
RCCNKR_CM=R0
! CCN SPECTRUM
S_KR=A2/RCCNKR_CM**1.5
ACCN=ACCN_CON
BCCN=BCCN_CON
! print*,'accn, bccn,S_KR = ',accn,bccn,S_KR
! CONTINENTAL
FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
FCCNR_CON(KR)=FCCNR(KR)
! MARITIME
ACCN=ACCN_MAR
BCCN=BCCN_MAR
FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
FCCNR_MAR(KR)=FCCNR(KR)
CONTCCNIN=CONTCCNIN+COL*FCCNR(KR)*R0*R0*R0
CONCCCNIN=CONCCCNIN+COL*FCCNR(KR)
ENDDO
! PRINT *, '********* MAR CCN CONCENTRATION & MASS *******'
! call wrf_message(" FULL SBM: MAR CCN CONCENTRATION & MASS ")
! PRINT 200, CONCCCNIN,CONTCCNIN
! CALCULATION OF FINAL MARITIME
!RCCN(KR)= 1 1.2303877E-07
!RCCN(KR)= 2 1.5501914E-07
!RCCN(KR)= 3 1.9531187E-07
!RCCN(KR)= 16 3.9372408E-06
!RCCN(KR)= 21 1.2499960E-05
!RCCN(KR)= 33 1.9999935E-04
RADCCN_MAX=RCCN(NKR)
RADCCN_MIN=0.005E-4
RADCCN_MIN1=0.02E-4
! print*,'ALOG(RADCCN_MIN) = ',ALOG(RADCCN_MIN)
! print*,'ALOG(RCCN(1) = ',ALOG(RCCN(1))
! print*,'ALOG(RADCCN_MAX) = ',ALOG(RADCCN_MAX)
! KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
! KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
! KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
KR_MIN=MAX(KR_MIN,1)
KR_MIN1=MAX(KR_MIN,KR_MIN1)
KR_MAX=MIN(NKR,KR_MAX)
! print*,'kr_min,kr_min1 = ',kr_min,kr_min1
! print*,'kr_max = ',kr_max
! Interpolation
DO KR=1,NKR
IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
FCCNR_MAR(KR)=FCCNR_MAR(KR_MIN1)* &
& (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
& (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
END IF
IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_MAR(KR)=0
! print*,'FCCNR_MAR(KR) = ',KR,FCCNR_MAR(KR)
END DO
! CALCULATION OF FINAL CONTINENTAL
RADCCN_MAX=0.6E-4
RADCCN_MIN=0.005E-4
RADCCN_MIN1=0.02E-4
! KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
! KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
! KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
KR_MIN=MAX(KR_MIN,1)
KR_MIN1=MAX(KR_MIN,KR_MIN1)
KR_MAX=MIN(NKR,KR_MAX)
! print*,'contin kr_min,kr_min1 = ',kr_min,kr_min1
! print*,'kr_max = ',kr_max
! Interpolation
DO KR=1,NKR
IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
FCCNR_CON(KR)=FCCNR_CON(KR_MIN1)* &
& (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
& (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
END IF
IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_CON(KR)=0
! print*,'FCCNR_CON(KR) = ',KR,FCCNR_CON(KR)
END DO
! CALCULATION OF MIXTURE
DO KR=1,NKR
FCCNR_MIX(KR)=FR_CON*FCCNR_CON(KR)+FR_MAR*FCCNR_MAR(KR)
! print*,'FCCNR_MIX(KR) = ',FCCNR_MIX(KR)
END DO
! STOP
CALL BREAKINIT
! CALL TWOINITMXVAR
! IN CASE : IPRINT01.NE.0
100 FORMAT(10I4)
101 FORMAT(3X,F7.5,E13.5)
102 FORMAT(4E12.4)
105 FORMAT(A48)
106 FORMAT(A80)
123 FORMAT(3E12.4,3I4)
200 FORMAT(6E13.5)
201 FORMAT(6D13.5)
300 FORMAT(8E14.6)
301 FORMAT(3X,F8.3,3X,E13.5)
302 FORMAT(5E13.5)
! if (IFREST)THEN
! dtime=dt*0.5
! else
! END IF
call kernals(dt)
!+---+-----------------------------------------------------------------+
! from morr_two_moment
!..Set these variables needed for computing radar reflectivity. These
!.. get used within radar_init to create other variables used in the
!.. radar module.
! SIZE DISTRIBUTION PARAMETERS
RHOW = 997.
RHOI = 500.
RHOSN = 100.
! IF (IHAIL.EQ.0) THEN
! RHOG = 400.
! ELSE
! RHOG = 900.
! END IF
RHOG=450
CI = RHOI*PI_MORR/6.
DI = 3.
CS = RHOSN*PI_MORR/6.
DS = 3.
CG = RHOG*PI_MORR/6.
DG = 3.
xam_r = PI_MORR*RHOW/6.
xbm_r = 3.
xmu_r = 0.
xam_s = CS
xbm_s = DS
xmu_s = 0.
xam_g = CG
xbm_g = DG
xmu_g = 0.
call radar_init
!+---+-----------------------------------------------------------------+
return
2070 continue
WRITE( errmess , '(A,I4)' ) &
'module_mp_full_sbm: error opening hujisbm_DATA on unit ' &
&, hujisbm_unit1
CALL wrf_error_fatal(errmess)
end subroutine full_hucminit
SUBROUTINE BREAKINIT 2,16
IMPLICIT NONE
INTEGER :: hujisbm_unit1
LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
LOGICAL :: opened
LOGICAL , EXTERNAL :: wrf_dm_on_monitor
CHARACTER*80 errmess
!.....INPUT VARIABLES
!
! GT : MASS DISTRIBUTION FUNCTION
! XT_MG : MASS OF BIN IN MG
! JMAX : NUMBER OF BINS
!.....LOCAL VARIABLES
INTEGER AP,IE,JE,KE
PARAMETER (AP = 1)
INTEGER I,J,K,JDIFF
REAL RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
REAL PI,D0,HLP
DOUBLE PRECISION M(0:JBREAK),ALM
REAL DBREAK(JBREAK),GAIN,LOSS
! REAL ECOALMASS
! REAL XL(JMAX)
!.....DECLARATIONS FOR INIT
INTEGER IP,KP,JP,KQ,JQ
REAL XTJ
CHARACTER*20 FILENAME_P,FILENAME_Q
FILENAME_P = 'coeff_p.asc'
FILENAME_Q = 'coeff_q.asc'
IE = JBREAK
JE = JBREAK
KE = JBREAK
PI = 3.1415927
D0 = 0.0101593
M(1) = PI/6.0 * D0**3
!.....IN CGS
!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
JDIFF = JMAX - JBREAK
!.....INITIALIZATION
! IF (FIRSTCALL.NE.1) THEN
!........CALCULATING THE BREAKUP GRID
! ALM = 2.**(1./FLOAT(AP))
ALM = 2.d0
M(0) = M(1)/ALM
DO K=1,KE-1
M(K+1) = M(K)*ALM
ENDDO
DO K=1,KE
BRKWEIGHT(K) = 2./(M(K)**2 - M(K-1)**2)
! print*,'m(k) = ',m(k)
! print*,'m(k-1) = ',m(k-1)
! print*, 'MWEIGHT = ',BRKWEIGHT(K)
ENDDO
!........OUTPUT
WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
& 'XCOAG','DCOAG', &
& 'XBREAK','DBREAK','MWEIGHT'
!........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE
! WRITE (*,*) 'COLL_BREAKUP: READ THE BREAKUP COEFFS'
! WRITE (*,*) ' FILE PKIJ: ', FILENAME_P
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2061
ENDIF
ENDDO
hujisbm_unit1 = -1
2061 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
! print*,'here at 3'
DO K=1,KE
DO I=1,IE
DO J=1,I
READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP)
! WRITE(6,*)'PKIJ(KP,IP,JP) =', &
! & KP,IP,JP,PKIJ(KP,IP,JP)
! IF(RPKIJ(KP,IP,JP).EQ.0) THEN
! * PKIJ(KP,IP,JP)=INT(RPKIJ(KP,IP,JP))
! ELSE
! PKIJ(KP,IP,JP)=RPKIJ(KP,IP,JP)
! END IF
! WRITE(6,*)'RPKIJ(KP,IP,JP) =',
! * KP,IP,JP,RPKIJ(KP,IP,JP),
! * PKIJ(KP,IP,JP)
ENDDO
ENDDO
! READ(6,*)
ENDDO
CLOSE(hujisbm_unit1)
! WRITE (*,*) ' FILE QKJ: ', FILENAME_Q
END IF
CALL wrf_dm_bcast_bytes (PKIJ , size ( PKIJ ) * DWORDSIZE )
IF ( wrf_dm_on_monitor() ) THEN
DO i = 31,99
INQUIRE ( i , OPENED = opened )
IF ( .NOT. opened ) THEN
hujisbm_unit1 = i
GOTO 2062
ENDIF
ENDDO
hujisbm_unit1 = -1
2062 CONTINUE
ENDIF
!
CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
IF ( hujisbm_unit1 < 0 ) THEN
CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
ENDIF
!
IF ( wrf_dm_on_monitor() ) THEN
OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc", &
& FORM="FORMATTED",STATUS="OLD",ERR=2070)
DO K=1,KE
DO J=1,JE
READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
! WRITE(6,*) KQ,JQ,QKJ(KQ,JQ)
! QKJ(KQ,JQ) = RQKJ(KQ,JQ)
! IF(QKJ(KQ,JQ).LE.1E-35)QKJ(KQ,JQ)=0.D0
ENDDO
ENDDO
CLOSE(hujisbm_unit1)
WRITE (*,*) 'COLL_BREAKUP READ: ... OK'
END IF
CALL wrf_dm_bcast_bytes (QKJ , size ( QKJ ) * DWORDSIZE )
! ENDIF
! DO K=1,KE
! DO J=1,JE
! WRITE(6,*) 'After Broadcast, QKJ = ',K,J,QKJ(K,J)
! ENDDO
! ENDDO
! DO K=1,KE
! DO I=1,IE
! DO J=1,I
! WRITE(6,*)'After Broadcast PKIJ(K,I,J) =', &
! & K,I,J,PKIJ(K,I,J)
! ENDDO
! ENDDO
! ENDDO
DO I=1,JMAX
DO J=1,JMAX
ECOALMASSM(I,J)=1.0D0
ENDDO
ENDDO
DO I=1,JMAX
DO J=1,JMAX
ECOALMASSM(I,J)=ECOALMASS(XL(I),XL(J))
ENDDO
ENDDO
RETURN
2070 continue
WRITE( errmess , '(A,I4)' ) &
'module_mp_full: error opening hujisbm_DATA on unit ' &
&, hujisbm_unit1
CALL wrf_error_fatal(errmess)
END SUBROUTINE BREAKINIT
REAL FUNCTION ECOALMASS(ETA,KSI) 2,2
IMPLICIT NONE
! REAL ECOALMASS
REAL PI
PARAMETER (PI = 3.1415927)
REAL ETA,KSI
REAL KPI,RHO
REAL DETA,DKSI
PARAMETER (RHO = 1.0)
! REAL ECOALDIAM
! EXTERNAL ECOALDIAM
KPI = 6./PI
DETA = (KPI*ETA/RHO)**(1./3.)
DKSI = (KPI*KSI/RHO)**(1./3.)
ECOALMASS = ECOALDIAM(DETA,DKSI)
RETURN
END FUNCTION ECOALMASS
!------------------------------------------------
! COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
!------------------------------------------------
REAL FUNCTION ECOALDIAM(DETA,DKSI) 2,2
! IMPLICIT NONE
INTEGER N
REAL DETA,DKSI
REAL DGR,DKL,RGR,RKL,P,Q,E,X,Y,QMIN,QMAX
REAL ZERO,ONE,EPS,PI
PARAMETER (ZERO = 0.0)
PARAMETER (ONE = 1.0)
PARAMETER (EPS = 1.0E-30)
PARAMETER (PI = 3.1415927)
! REAL ECOALLOWLIST,ECOALOCHS
! EXTERNAL ECOALLOWLIST,ECOALOCHS
DGR = MAX(DETA,DKSI)
DKL = MIN(DETA,DKSI)
RGR = 0.5*DGR
RKL = 0.5*DKL
P = (RKL / RGR)
Q = (RKL * RGR)**0.5
Q = 0.5 * (RKL + RGR)
qmin = 250e-4
qmax = 400e-4
if (q.lt.qmin) then
e = max(ecoalOchs(Dgr,Dkl),ecoalBeard(Dgr,Dkl))
elseif (q.ge.qmin.and.q.lt.qmax) then
x = (q - qmin) / (qmax - qmin)
e = sin(pi/2.0*x)**2 * ecoalLowList(Dgr,Dkl) &
& + sin(pi/2.0*(1 - x))**2 * ecoalOchs(Dgr,Dkl)
elseif (q.ge.qmax) then
e = ecoalLowList(Dgr,Dkl)
else
e = 1.0
endif
ECOALDIAM = MAX(MIN(ONE,E),EPS)
RETURN
END FUNCTION ECOALDIAM
!--------------------------------------------------
! COALESCENCE EFFICIENCY (LOW&LIST)
!--------------------------------------------------
REAL FUNCTION ECOALLOWLIST(DGR,DKL) 2,2
IMPLICIT NONE
! REAL ecoallowlist
REAL PI,SIGMA,KA,KB,EPSI
REAL DGR,DKL,RGR,RKL,X
REAL ST,SC,ET,DSTSC,CKE,W1,W2,DC,ECL
REAL QQ0,QQ1,QQ2
PARAMETER (EPSI=1.E-20)
PI = 3.1415927
SIGMA = 72.8
KA = 0.778
KB = 2.61E-4
RGR = 0.5*DGR
RKL = 0.5*DKL
CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
DSTSC = ST-SC
ET = CKE+DSTSC
IF (ET .LT. 50.0) THEN
QQ0=1.0+(DKL/DGR)
QQ1=KA/QQ0**2
QQ2=KB*SIGMA*(ET**2)/(SC+EPSI)
ECL=QQ1*EXP(-QQ2)
ELSE
ECL=0.0
ENDIF
ECOALLOWLIST = ECL
RETURN
END FUNCTION ECOALLOWLIST
!--------------------------------------------------
! COALESCENCE EFFICIENCY (BEARD AND OCHS)
!--------------------------------------------------
REAL FUNCTION ECOALOCHS(D_L,D_S)
IMPLICIT NONE
! real ecoalochs
REAL D_L,D_S
REAL PI,SIGMA,N_W,R_S,R_L,DV,P,G,X,E
! REAL VTBEARD,EPSF,FPMIN
REAL EPSF,FPMIN
! EXTERNAL VTBEARD
PARAMETER (EPSF = 1.E-30)
PARAMETER (FPMIN = 1.E-30)
PI = 3.1415927
SIGMA = 72.8
R_S = 0.5 * D_S
R_L = 0.5 * D_L
P = R_S / R_L
DV = ABS(VTBEARD(D_L) - VTBEARD(D_S))
IF (DV.LT.FPMIN) DV = FPMIN
N_W = R_S * DV**2 / SIGMA
G = 2**(3./2.)/(6.*PI) * P**4 * (1.+ P) / ((1.+P**2)*(1.+P**3))
X = N_W**(0.5) * G
E = 0.767 - 10.14 * X
ECOALOCHS = E
RETURN
END FUNCTION ECOALOCHS
!-----------------------------------------
! CALCULATING THE COLLISION ENERGY
!-----------------------------------------
SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC) 2,4
! IMPLICIT NONE
REAL DGR,DKL,DC
REAL K10,PI,SIGMA,RHO
REAL CKE,W1,W2,ST,SC
REAL DGKA3,DGKB3,DGKA2
REAL V1,V2,DV
! REAL VTBEARD,EPSF,FPMIN
REAL EPSF,FPMIN
! EXTERNAL VTBEARD
PARAMETER (EPSF = 1.E-30)
PARAMETER (FPMIN = 1.E-30)
PI = 3.1415927
RHO = 1.0
SIGMA = 72.8
K10=RHO*PI/12.0D0
DGR = MAX(DGR,EPSF)
DKL = MAX(DKL,EPSF)
DGKA2=(DGR**2)+(DKL**2)
DGKA3=(DGR**3)+(DKL**3)
IF (DGR.NE.DKL) THEN
V1 = VTBEARD(DGR)
V2 = VTBEARD(DKL)
DV = (V1-V2)
IF (DV.LT.FPMIN) DV = FPMIN
DV = DV**2
IF (DV.LT.FPMIN) DV = FPMIN
DGKB3=(DGR**3)*(DKL**3)
CKE = K10 * DV * DGKB3/DGKA3
ELSE
CKE = 0.0D0
ENDIF
ST = PI*SIGMA*DGKA2
SC = PI*SIGMA*DGKA3**(2./3.)
W1=CKE/(SC+EPSF)
W2=CKE/(ST+EPSF)
DC=DGKA3**(1./3.)
RETURN
END SUBROUTINE COLLENERGY
!--------------------------------------------------
! CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
!--------------------------------------------------
REAL FUNCTION VTBEARD(DIAM) 4
IMPLICIT NONE
! REAL VTBEARD
REAL DIAM,AA
REAL ROP,RU,AMT,PP,RL,TT,ETA,DENS,CD,D,A
REAL ALA,GR,SI,BOND,PART,XX,YY,RE,VT
REAL B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6
INTEGER ID
DATA B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6/-5.00015, &
&5.23778,-2.04914,.475294,-.0542819,.00238449,-3.18657,.992696, &
&-.153193E-2,-.987059E-3,-.578878E-3,.855176E-4,-.327815E-5/
AA = DIAM/2.0
ROP = 1.0
RU = 8.3144E+7
AMT = 28.9644
ID = 10000
PP = FLOAT(ID)*100.
RL = RU/AMT
TT = 283.15
ETA = (1.718+.0049*(TT-273.15))*1.E-4
DENS = PP/TT/RL
ALA = 6.6E-6*1.01325E+6/PP*TT/293.15
GR = 979.69
SI = 76.1-.155*(TT-273.15)
IF (AA.GT.500.E-4) THEN
BOND = GR*(ROP-DENS)*AA*AA/SI
PART = (SI**3*DENS*DENS/(ETA**4*GR*(ROP-DENS)))**(1./6.)
XX = LOG(16./3.*BOND*PART)
YY = B00+B11*XX+B22*XX*XX+B33*XX**3+B44*XX**4+B55*XX**5
RE = PART*EXP(YY)
VT = ETA*RE/2./DENS/AA
ELSEIF (AA.GT.1.E-3) THEN
CD = 32.*AA*AA*AA*(ROP-DENS)*DENS*GR/3./ETA/ETA
XX = LOG(CD)
RE = EXP(B0+B1*XX+B2*XX*XX+B3*XX**3+B4*XX**4+B5*XX**5+B6*XX**6)
D = CD/RE/24.-1.
VT = ETA*RE/2./DENS/AA
ELSE
A = 1.+1.26*ALA/AA
A = A*2.*AA*AA*GR*(ROP-DENS)/9./ETA
CD = 12*ETA/A/AA/DENS
VT = A
ENDIF
VTBEARD = VT
RETURN
END FUNCTION VTBEARD
!--------------------------------------------------
! Function f. Coalescence-Efficiency
! Eq. (7) of Beard and Ochs (1995)
!--------------------------------------------------
REAL FUNCTION ecoalBeard(D_l,D_s) ,2
IMPLICIT NONE
! REAL ecoalBeard
! REAL ECOALMASS
REAL D_l,D_s
REAL R_s,R_l
REAL rcoeff
REAL epsf
PARAMETER (epsf = 1.e-30)
INTEGER its
COMPLEX acoeff(4),x
R_s = 0.5 * D_s
R_l = 0.5 * D_l
rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)
acoeff(1) = CMPLX(rcoeff)
acoeff(2) = CMPLX(-5.94)
acoeff(3) = CMPLX(+7.27)
acoeff(4) = CMPLX(-5.29)
x = (0.50,0)
CALL LAGUER(acoeff,3,x,its)
EcoalBeard = REAL(x)
RETURN
END FUNCTION ecoalBeard
!--------------------------------------------------
SUBROUTINE laguer(a,m,x,its) 2
INTEGER m,its,MAXIT,MR,MT
REAL EPSS
COMPLEX a(m+1),x
PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
INTEGER iter,j
REAL abx,abp,abm,err,frac(MR)
COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
SAVE frac
DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
do 12 iter=1,MAXIT
its=iter
b=a(m+1)
err=abs(b)
d=cmplx(0.,0.)
f=cmplx(0.,0.)
abx=abs(x)
do 11 j=m,1,-1
f=x*f+d
d=x*d+b
b=x*b+a(j)
err=abs(b)+abx*err
11 continue
err=EPSS*err
if(abs(b).le.err) then
return
else
g=d/b
g2=g*g
h=g2-2.*f/b
sq=sqrt((m-1)*(m*h-g2))
gp=g+sq
gm=g-sq
abp=abs(gp)
abm=abs(gm)
if(abp.lt.abm) gp=gm
if (max(abp,abm).gt.0.) then
dx=m/gp
else
dx=exp(cmplx(log(1.+abx),float(iter)))
endif
endif
x1=x-dx
if(x.eq.x1)return
if (mod(iter,MT).ne.0) then
x=x1
else
x=x-dx*frac(iter/MT)
endif
12 continue
pause 'too many iterations in laguer'
return
END SUBROUTINE laguer
subroutine courant_bott 2
implicit none
integer k,kk,j,i
double precision x0
! ima(i,j) - k-category number,
! chucm(i,j) - courant number :
! logarithmic grid distance(dlnr) :
!================================================================
! BARRY
! print*,'dlnr in courant_bott = ',dlnr
xl_mg(0)=xl_mg(1)/2
! BARRY
do i=1,nkr
do j=i,nkr
x0=xl_mg(i)+xl_mg(j)
do k=j,nkr
kk=k
! if (k.eq.1)then
! print*,'xl_mg(k) = ',xl_mg(k)
! print*,'x0 = ',x0
! xl_mg(k) = 3.351000000000000E-008
! x0 = 6.702000000000000E-008
! read (6,*)
! end if
if(xl_mg(k).ge.x0.and.xl_mg(k-1).lt.x0) then
chucm(i,j)=dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
102 continue
if(chucm(i,j).gt.1.-1.d-08) then
chucm(i,j)=0.
kk=kk+1
endif
ima(i,j)=min(nkr-1,kk-1)
goto 2000
endif
enddo
2000 continue
! if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
chucm(j,i)=chucm(i,j)
ima(j,i)=ima(i,j)
enddo
enddo
return
end subroutine courant_bott
SUBROUTINE KERNALS(DTIME) 6,2
! KHAIN30/07/99
IMPLICIT NONE
INTEGER I,J
REAL PI
!******************************************************************
data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! dlnr - logarithmic grid distance
! ima(i,j) - k-category number, c(i,j) - courant number
! cw*(i,j) (in cm**3) - multiply help kernel with constant
! timestep(dt) and logarithmic grid distance(dlnr) :
REAL DTIME
! logarithmic grid distance(dlnr) :
! dlnr=dlog(2.d0)/(3.d0*scal)
! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
! calculation of cw*(i,j) (in cm**3) - multiply help kernel
! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
! print*,'dlnr in kernal = ',dlnr,dtime
DO I=1,NKR
DO J=1,NKR
CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
! barry
if (i.le.16.and.j.le.16)then
CWSL(I,J)=0.d0
! CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
CWLS(I,J)=0.d0
! CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
else
CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
end if
CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
IF(RADXXO(I,6).LT.2.0D-2) THEN
IF(RADXXO(J,1).LT.1.0D-3) THEN
IF(RADXXO(J,1).GE.7.0D-4) THEN
CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
ELSE
CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
ENDIF
ENDIF
ENDIF
IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
! IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
! IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
! barry
if (i.lt.12.and.j.lt.12)then
CWII_1_1(I,J)=0.D0
CWII_1_2(I,J)=0.D0
CWII_1_3(I,J)=0.D0
CWII_2_1(I,J)=0.D0
CWII_2_2(I,J)=0.D0
CWII_2_3(I,J)=0.D0
CWII_3_1(I,J)=0.D0
CWII_3_2(I,J)=0.D0
CWII_3_3(I,J)=0.D0
!barry
else
CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
end if
ENDDO
ENDDO
! GO TO 88
! NEW CHANGES 2.06.01 (BEGIN)
CALL TURBCOEF
DO J=1,7
DO I=15,24-J
CWGL(I,J)=0.0D0
ENDDO
ENDDO
! NEW CHANGES 2.06.01 (END)
! NEW CHANGES 3.02.01 (BEGIN)
DO I=1,NKR
DO J=1,NKR
CWLG(J,I)=CWGL(I,J)
ENDDO
ENDDO
! print*, 'ICETURB = ',ICETURB
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
IF (ICETURB.EQ.1)THEN
CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
ELSE
CWGL(I,J)=CWGL(I,J)
END IF
ENDDO
ENDDO
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
CWLG(J,I)=CWGL(I,J)
ENDDO
ENDDO
88 CONTINUE
RETURN
END SUBROUTINE KERNALS
SUBROUTINE KERNALS_IN(DTIME),2
! KHAIN30/07/99
IMPLICIT NONE
INTEGER I,J
REAL PI
!******************************************************************
data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! dlnr - logarithmic grid distance
! ima(i,j) - k-category number, c(i,j) - courant number
! cw*(i,j) (in cm**3) - multiply help kernel with constant
! timestep(dt) and logarithmic grid distance(dlnr) :
REAL DTIME
! logarithmic grid distance(dlnr) :
! dlnr=dlog(2.d0)/(3.d0*scal)
! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
! calculation of cw*(i,j) (in cm**3) - multiply help kernel
! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
! print*,'dlnr in kernal = ',dlnr,dtime
DO I=1,NKR
DO J=1,NKR
CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
! CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
! barry
if (i.le.16.and.j.le.16)then
CWSL(I,J)=0.d0
! CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
CWLS(I,J)=0.d0
! CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
else
CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
end if
CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
! CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
IF(RADXXO(I,6).LT.2.0D-2) THEN
IF(RADXXO(J,1).LT.1.0D-3) THEN
IF(RADXXO(J,1).GE.7.0D-4) THEN
CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
ELSE
CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
ENDIF
ENDIF
ENDIF
IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
! IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
! IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
! CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
! CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
! CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
! CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
! CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
! CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
! CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
! CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
! CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
! CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
! CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
! CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
! CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
! CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
! CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
! CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
! CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
! CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
! CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
! CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
! CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
! CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
! CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
! CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
! CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
! CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
! CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
! CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
! CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
! barry
if (i.lt.12.and.j.lt.12)then
! CWII_1_1(I,J)=0.D0
! CWII_1_2(I,J)=0.D0
! CWII_1_3(I,J)=0.D0
! CWII_2_1(I,J)=0.D0
! CWII_2_2(I,J)=0.D0
! CWII_2_3(I,J)=0.D0
! CWII_3_1(I,J)=0.D0
! CWII_3_2(I,J)=0.D0
! CWII_3_3(I,J)=0.D0
!barry
else
! CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
! CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
! CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
! CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
! CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
! CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
! CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
! CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
! CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
end if
ENDDO
ENDDO
! GO TO 88
! NEW CHANGES 2.06.01 (BEGIN)
CALL TURBCOEF
DO J=1,7
DO I=15,24-J
CWGL(I,J)=0.0D0
ENDDO
ENDDO
! NEW CHANGES 2.06.01 (END)
! NEW CHANGES 3.02.01 (BEGIN)
DO I=1,NKR
DO J=1,NKR
CWLG(J,I)=CWGL(I,J)
ENDDO
ENDDO
! print*, 'ICETURB = ',ICETURB
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
IF (ICETURB.EQ.1)THEN
CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
ELSE
CWGL(I,J)=CWGL(I,J)
END IF
ENDDO
ENDDO
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
CWLG(J,I)=CWGL(I,J)
ENDDO
ENDDO
88 CONTINUE
RETURN
END SUBROUTINE KERNALS_IN
SUBROUTINE TURBCOEF 4,4
IMPLICIT NONE
INTEGER I,J
! DOUBLE PRECISION X_KERN,Y_KERN,F
DOUBLE PRECISION X_KERN,Y_KERN
DOUBLE PRECISION RL_LL(K0_LL),RL_GL(K0L_GL),RG_GL(K0G_GL)
RL_LL(1)=RADXXO(KRMIN_LL,1)*1.E4
RL_LL(2)=10.0D0
RL_LL(3)=20.0D0
RL_LL(4)=30.0D0
RL_LL(5)=40.0D0
RL_LL(6)=50.0D0
RL_LL(7)=60.0D0
RL_LL(8)=RADXXO(KRMAX_LL,1)*1.E4
DO J=1,K0_LL
DO I=1,K0_LL
CTURB_LL(I,J)=1.0D0
ENDDO
ENDDO
CTURB_LL(1,1)=4.50D0
CTURB_LL(1,2)=4.50D0
CTURB_LL(1,3)=3.00D0
CTURB_LL(1,4)=2.25D0
CTURB_LL(1,5)=1.95D0
CTURB_LL(1,6)=1.40D0
CTURB_LL(1,7)=1.40D0
CTURB_LL(1,8)=1.40D0
CTURB_LL(2,1)=4.50D0
CTURB_LL(2,2)=4.50D0
CTURB_LL(2,3)=3.00D0
CTURB_LL(2,4)=2.25D0
CTURB_LL(2,5)=1.95D0
CTURB_LL(2,6)=1.40D0
CTURB_LL(2,7)=1.40D0
CTURB_LL(2,8)=1.40D0
CTURB_LL(3,1)=3.00D0
CTURB_LL(3,2)=3.00D0
CTURB_LL(3,3)=2.70D0
CTURB_LL(3,4)=2.25D0
CTURB_LL(3,5)=1.65D0
CTURB_LL(3,6)=1.40D0
CTURB_LL(3,7)=1.40D0
CTURB_LL(3,8)=1.40D0
CTURB_LL(4,1)=2.25D0
CTURB_LL(4,2)=2.25D0
CTURB_LL(4,3)=2.25D0
CTURB_LL(4,4)=1.95D0
CTURB_LL(4,5)=1.65D0
CTURB_LL(4,6)=1.40D0
CTURB_LL(4,7)=1.40D0
CTURB_LL(4,8)=1.40D0
CTURB_LL(5,1)=1.95D0
CTURB_LL(5,2)=1.95D0
CTURB_LL(5,3)=1.65D0
CTURB_LL(5,4)=1.65D0
CTURB_LL(5,5)=1.65D0
CTURB_LL(5,6)=1.40D0
CTURB_LL(5,7)=1.40D0
CTURB_LL(5,8)=1.40D0
CTURB_LL(6,1)=1.40D0
CTURB_LL(6,2)=1.40D0
CTURB_LL(6,3)=1.40D0
CTURB_LL(6,4)=1.40D0
CTURB_LL(6,5)=1.40D0
CTURB_LL(6,6)=1.40D0
CTURB_LL(6,7)=1.40D0
CTURB_LL(6,8)=1.40D0
CTURB_LL(7,1)=1.40D0
CTURB_LL(7,2)=1.40D0
CTURB_LL(7,3)=1.40D0
CTURB_LL(7,4)=1.40D0
CTURB_LL(7,5)=1.40D0
CTURB_LL(7,6)=1.40D0
CTURB_LL(7,7)=1.40D0
CTURB_LL(7,8)=1.40D0
CTURB_LL(8,1)=1.40D0
CTURB_LL(8,2)=1.40D0
CTURB_LL(8,3)=1.40D0
CTURB_LL(8,4)=1.40D0
CTURB_LL(8,5)=1.40D0
CTURB_LL(8,6)=1.40D0
CTURB_LL(8,7)=1.40D0
CTURB_LL(8,8)=1.40D0
DO J=1,K0_LL
DO I=1,K0_LL
CTURB_LL(I,J)=(CTURB_LL(I,J)-1.0D0)/1.5D0+1.0D0
ENDDO
ENDDO
DO I=KRMIN_LL,KRMAX_LL
DO J=KRMIN_LL,KRMAX_LL
CTURBLL(I,J)=1.0D0
ENDDO
ENDDO
DO I=KRMIN_LL,KRMAX_LL
X_KERN=RADXXO(I,1)*1.0D4
IF(X_KERN.LT.RL_LL(1)) X_KERN=RL_LL(1)
IF(X_KERN.GT.RL_LL(K0_LL)) X_KERN=RL_LL(K0_LL)
DO J=KRMIN_LL,KRMAX_LL
Y_KERN=RADXXO(J,1)*1.0D4
IF(Y_KERN.LT.RL_LL(1)) Y_KERN=RL_LL(1)
IF(Y_KERN.GT.RL_LL(K0_LL)) Y_KERN=RL_LL(K0_LL)
CTURBLL(I,J)=F(X_KERN,Y_KERN,RL_LL,RL_LL,CTURB_LL &
& ,K0_LL,K0_LL)
ENDDO
ENDDO
RL_GL(1) = RADXXO(1,1)*1.E4
RL_GL(2) = 8.0D0
RL_GL(3) = 10.0D0
RL_GL(4) = 16.0D0
RL_GL(5) = 20.0D0
RL_GL(6) = 30.0D0
RL_GL(7) = 40.0D0
RL_GL(8) = 50.0D0
RL_GL(9) = 60.0D0
RL_GL(10)= 70.0D0
RL_GL(11)= 80.0D0
RL_GL(12)= 90.0D0
RL_GL(13)=100.0D0
RL_GL(14)=200.0D0
RL_GL(15)=300.0D0
RL_GL(16)=RADXXO(24,1)*1.0D4
! TURBULENCE GRAUPEL BULK RADII IN MKM
RG_GL(1) = RADXXO(1,6)*1.0D4
RG_GL(2) = 30.0D0
RG_GL(3) = 60.0D0
RG_GL(4) = 100.0D0
RG_GL(5) = 200.0D0
RG_GL(6) = 300.0D0
RG_GL(7) = 400.0D0
RG_GL(8) = 500.0D0
RG_GL(9) = 600.0D0
RG_GL(10)= 700.0D0
RG_GL(11)= 800.0D0
RG_GL(12)= 900.0D0
RG_GL(13)=1000.0D0
RG_GL(14)=2000.0D0
RG_GL(15)=3000.0D0
RG_GL(16)=RADXXO(33,6)*1.0D4
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
CTURBGL(I,J)=1.0D0
ENDDO
ENDDO
DO I=1,K0G_GL
DO J=1,K0L_GL
CTURB_GL(I,J)=1.0D0
ENDDO
ENDDO
IF(IEPS_400.EQ.1) THEN
CTURB_GL(1,1)=0.0D0
CTURB_GL(1,2)=0.0D0
CTURB_GL(1,3)=1.2D0
CTURB_GL(1,4)=1.3D0
CTURB_GL(1,5)=1.4D0
CTURB_GL(1,6)=1.5D0
CTURB_GL(1,7)=1.5D0
CTURB_GL(1,8)=1.5D0
CTURB_GL(1,9)=1.5D0
CTURB_GL(1,10)=1.5D0
CTURB_GL(1,11)=1.5D0
CTURB_GL(1,12)=1.0D0
CTURB_GL(1,13)=1.0D0
CTURB_GL(1,14)=1.0D0
CTURB_GL(1,15)=1.0D0
CTURB_GL(2,1)=1.0D0
CTURB_GL(2,2)=1.4D0
CTURB_GL(2,3)=1.8D0
CTURB_GL(2,4)=2.2D0
CTURB_GL(2,5)=2.6D0
CTURB_GL(2,6)=3.0D0
CTURB_GL(2,7)=2.85D0
CTURB_GL(2,8)=2.7D0
CTURB_GL(2,9)=2.55D0
CTURB_GL(2,10)=2.4D0
CTURB_GL(2,11)=2.25D0
CTURB_GL(2,12)=1.0D0
CTURB_GL(2,13)=1.0D0
CTURB_GL(2,14)=1.0D0
CTURB_GL(3,1)=7.5D0
CTURB_GL(3,2)=7.5D0
CTURB_GL(3,3)=4.5D0
CTURB_GL(3,4)=4.5D0
CTURB_GL(3,5)=4.65D0
CTURB_GL(3,6)=4.65D0
CTURB_GL(3,7)=4.5D0
CTURB_GL(3,8)=4.5D0
CTURB_GL(3,9)=4.0D0
CTURB_GL(3,10)=3.0D0
CTURB_GL(3,11)=2.0D0
CTURB_GL(3,12)=1.5D0
CTURB_GL(3,13)=1.3D0
CTURB_GL(3,14)=1.0D0
CTURB_GL(4,1)=5.5D0
CTURB_GL(4,2)=5.5D0
CTURB_GL(4,3)=4.5D0
CTURB_GL(4,4)=4.5D0
CTURB_GL(4,5)=4.65D0
CTURB_GL(4,6)=4.65D0
CTURB_GL(4,7)=4.5D0
CTURB_GL(4,8)=4.5D0
CTURB_GL(4,9)=4.0D0
CTURB_GL(4,10)=3.0D0
CTURB_GL(4,11)=2.0D0
CTURB_GL(4,12)=1.5D0
CTURB_GL(4,13)=1.35D0
CTURB_GL(4,14)=1.0D0
CTURB_GL(5,1)=4.5D0
CTURB_GL(5,2)=4.5D0
CTURB_GL(5,3)=3.3D0
CTURB_GL(5,4)=3.3D0
CTURB_GL(5,5)=3.3D0
CTURB_GL(5,6)=3.4D0
CTURB_GL(5,7)=3.8D0
CTURB_GL(5,8)=3.8D0
CTURB_GL(5,9)=3.8D0
CTURB_GL(5,10)=3.6D0
CTURB_GL(5,11)=2.5D0
CTURB_GL(5,12)=2.0D0
CTURB_GL(5,13)=1.4D0
CTURB_GL(5,14)=1.0D0
CTURB_GL(6,1)=4.0D0
CTURB_GL(6,2)=4.0D0
CTURB_GL(6,3)=2.8D0
CTURB_GL(6,4)=2.8D0
CTURB_GL(6,5)=2.85D0
CTURB_GL(6,6)=2.9D0
CTURB_GL(6,7)=3.0D0
CTURB_GL(6,8)=3.1D0
CTURB_GL(6,9)=2.9D0
CTURB_GL(6,10)=2.6D0
CTURB_GL(6,11)=2.5D0
CTURB_GL(6,12)=2.0D0
CTURB_GL(6,13)=1.3D0
CTURB_GL(6,14)=1.1D0
CTURB_GL(7,1)=3.5D0
CTURB_GL(7,2)=3.5D0
CTURB_GL(7,3)=2.5D0
CTURB_GL(7,4)=2.5D0
CTURB_GL(7,5)=2.6D0
CTURB_GL(7,6)=2.7D0
CTURB_GL(7,7)=2.8D0
CTURB_GL(7,8)=2.8D0
CTURB_GL(7,9)=2.8D0
CTURB_GL(7,10)=2.6D0
CTURB_GL(7,11)=2.3D0
CTURB_GL(7,12)=2.0D0
CTURB_GL(7,13)=1.3D0
CTURB_GL(7,14)=1.1D0
CTURB_GL(8,1)=3.25D0
CTURB_GL(8,2)=3.25D0
CTURB_GL(8,3)=2.3D0
CTURB_GL(8,4)=2.3D0
CTURB_GL(8,5)=2.35D0
CTURB_GL(8,6)=2.37D0
CTURB_GL(8,7)=2.55D0
CTURB_GL(8,8)=2.55D0
CTURB_GL(8,9)=2.55D0
CTURB_GL(8,10)=2.3D0
CTURB_GL(8,11)=2.1D0
CTURB_GL(8,12)=1.9D0
CTURB_GL(8,13)=1.3D0
CTURB_GL(8,14)=1.1D0
CTURB_GL(9,1)=3.0D0
CTURB_GL(9,2)=3.0D0
CTURB_GL(9,3)=3.1D0
CTURB_GL(9,4)=2.2D0
CTURB_GL(9,5)=2.2D0
CTURB_GL(9,6)=2.2D0
CTURB_GL(9,7)=2.3D0
CTURB_GL(9,8)=2.3D0
CTURB_GL(9,9)=2.5D0
CTURB_GL(9,10)=2.5D0
CTURB_GL(9,11)=2.2D0
CTURB_GL(9,12)=1.8D0
CTURB_GL(9,13)=1.25D0
CTURB_GL(9,14)=1.1D0
CTURB_GL(10,1)=2.75D0
CTURB_GL(10,2)=2.75D0
CTURB_GL(10,3)=2.0D0
CTURB_GL(10,4)=2.0D0
CTURB_GL(10,5)=2.0D0
CTURB_GL(10,6)=2.1D0
CTURB_GL(10,7)=2.2D0
CTURB_GL(10,8)=2.2D0
CTURB_GL(10,9)=2.3D0
CTURB_GL(10,10)=2.3D0
CTURB_GL(10,11)=2.3D0
CTURB_GL(10,12)=1.8D0
CTURB_GL(10,13)=1.2D0
CTURB_GL(10,14)=1.1D0
CTURB_GL(11,1)=2.6D0
CTURB_GL(11,2)=2.6D0
CTURB_GL(11,3)=1.95D0
CTURB_GL(11,4)=1.95D0
CTURB_GL(11,5)=1.95D0
CTURB_GL(11,6)=2.05D0
CTURB_GL(11,7)=2.15D0
CTURB_GL(11,8)=2.15D0
CTURB_GL(11,9)=2.25D0
CTURB_GL(11,10)=2.25D0
CTURB_GL(11,11)=1.9D0
CTURB_GL(11,12)=1.8D0
CTURB_GL(11,13)=1.2D0
CTURB_GL(11,14)=1.1D0
CTURB_GL(12,1)=2.4D0
CTURB_GL(12,2)=2.4D0
CTURB_GL(12,3)=1.85D0
CTURB_GL(12,4)=1.85D0
CTURB_GL(12,5)=1.85D0
CTURB_GL(12,6)=1.75D0
CTURB_GL(12,7)=1.85D0
CTURB_GL(12,8)=1.85D0
CTURB_GL(12,9)=2.1D0
CTURB_GL(12,10)=2.1D0
CTURB_GL(12,11)=1.9D0
CTURB_GL(12,12)=1.8D0
CTURB_GL(12,13)=1.3D0
CTURB_GL(12,14)=1.1D0
CTURB_GL(13,1)=1.67D0
CTURB_GL(13,2)=1.67D0
CTURB_GL(13,3)=1.75D0
CTURB_GL(13,4)=1.83D0
CTURB_GL(13,5)=1.87D0
CTURB_GL(13,6)=2.0D0
CTURB_GL(13,7)=2.1D0
CTURB_GL(13,8)=2.12D0
CTURB_GL(13,9)=2.15D0
CTURB_GL(13,10)=2.18D0
CTURB_GL(13,11)=2.19D0
CTURB_GL(13,12)=1.67D0
CTURB_GL(13,13)=1.28D0
CTURB_GL(13,14)=1.0D0
CTURB_GL(14,1)=1.3D0
CTURB_GL(14,2)=1.3D0
CTURB_GL(14,3)=1.35D0
CTURB_GL(14,4)=1.4D0
CTURB_GL(14,5)=1.6D0
CTURB_GL(14,6)=1.7D0
CTURB_GL(14,7)=1.7D0
CTURB_GL(14,8)=1.7D0
CTURB_GL(14,9)=1.7D0
CTURB_GL(14,10)=1.7D0
CTURB_GL(14,11)=1.7D0
CTURB_GL(14,12)=1.4D0
CTURB_GL(14,13)=1.25D0
CTURB_GL(14,14)=1.0D0
CTURB_GL(15,1)=1.17D0
CTURB_GL(15,2)=1.17D0
CTURB_GL(15,3)=1.17D0
CTURB_GL(15,4)=1.25D0
CTURB_GL(15,5)=1.3D0
CTURB_GL(15,6)=1.35D0
CTURB_GL(15,7)=1.4D0
CTURB_GL(15,8)=1.4D0
CTURB_GL(15,9)=1.45D0
CTURB_GL(15,10)=1.47D0
CTURB_GL(15,11)=1.44D0
CTURB_GL(15,12)=1.3D0
CTURB_GL(15,13)=1.12D0
CTURB_GL(15,14)=1.0D0
CTURB_GL(16,1)=1.17D0
CTURB_GL(16,2)=1.17D0
CTURB_GL(16,3)=1.17D0
CTURB_GL(16,4)=1.25D0
CTURB_GL(16,5)=1.3D0
CTURB_GL(16,6)=1.35D0
CTURB_GL(16,7)=1.4D0
CTURB_GL(16,8)=1.45D0
CTURB_GL(16,9)=1.45D0
CTURB_GL(16,10)=1.47D0
CTURB_GL(16,11)=1.44D0
CTURB_GL(16,12)=1.3D0
CTURB_GL(16,13)=1.12D0
CTURB_GL(16,14)=1.0D0
ENDIF
IF(IEPS_800.EQ.1) THEN
CTURB_GL(1,1) =0.00D0
CTURB_GL(1,2) =0.00D0
CTURB_GL(1,3) =1.00D0
CTURB_GL(1,4) =1.50D0
CTURB_GL(1,5) =1.40D0
CTURB_GL(1,6) =1.30D0
CTURB_GL(1,7) =1.20D0
CTURB_GL(1,8) =1.10D0
CTURB_GL(1,9) =1.00D0
CTURB_GL(1,10)=1.00D0
CTURB_GL(1,11)=1.00D0
CTURB_GL(1,12)=1.00D0
CTURB_GL(1,13)=1.00D0
CTURB_GL(1,14)=1.00D0
CTURB_GL(1,15)=1.00D0
CTURB_GL(1,16)=1.00D0
CTURB_GL(2,1) =0.00D0
CTURB_GL(2,2) =0.00D0
CTURB_GL(2,3) =1.00D0
CTURB_GL(2,4) =2.00D0
CTURB_GL(2,5) =1.80D0
CTURB_GL(2,6) =1.70D0
CTURB_GL(2,7) =1.60D0
CTURB_GL(2,8) =1.50D0
CTURB_GL(2,9) =1.50D0
CTURB_GL(2,10)=1.50D0
CTURB_GL(2,11)=1.50D0
CTURB_GL(2,12)=1.50D0
CTURB_GL(2,13)=1.50D0
CTURB_GL(2,14)=1.00D0
CTURB_GL(2,15)=1.00D0
CTURB_GL(2,16)=1.00D0
CTURB_GL(3,1) =0.00D0
CTURB_GL(3,2) =0.00D0
CTURB_GL(3,3) =4.00D0
CTURB_GL(3,4) =7.65D0
CTURB_GL(3,5) =7.65D0
CTURB_GL(3,6) =8.00D0
CTURB_GL(3,7) =8.00D0
CTURB_GL(3,8) =7.50D0
CTURB_GL(3,9) =6.50D0
CTURB_GL(3,10)=6.00D0
CTURB_GL(3,11)=5.00D0
CTURB_GL(3,12)=4.50D0
CTURB_GL(3,13)=4.00D0
CTURB_GL(3,14)=2.00D0
CTURB_GL(3,15)=1.30D0
CTURB_GL(3,16)=1.00D0
CTURB_GL(4,1) =7.50D0
CTURB_GL(4,2) =7.50D0
CTURB_GL(4,3) =7.50D0
CTURB_GL(4,4) =7.65D0
CTURB_GL(4,5) =7.65D0
CTURB_GL(4,6) =8.00D0
CTURB_GL(4,7) =8.00D0
CTURB_GL(4,8) =7.50D0
CTURB_GL(4,9) =6.50D0
CTURB_GL(4,10)=6.00D0
CTURB_GL(4,11)=5.00D0
CTURB_GL(4,12)=4.50D0
CTURB_GL(4,13)=4.00D0
CTURB_GL(4,14)=2.00D0
CTURB_GL(4,15)=1.30D0
CTURB_GL(4,16)=1.00D0
CTURB_GL(5,1) =5.50D0
CTURB_GL(5,2) =5.50D0
CTURB_GL(5,3) =5.50D0
CTURB_GL(5,4) =5.75D0
CTURB_GL(5,5) =5.75D0
CTURB_GL(5,6) =6.00D0
CTURB_GL(5,7) =6.25D0
CTURB_GL(5,8) =6.17D0
CTURB_GL(5,9) =5.75D0
CTURB_GL(5,10)=5.25D0
CTURB_GL(5,11)=4.75D0
CTURB_GL(5,12)=4.25D0
CTURB_GL(5,13)=4.00D0
CTURB_GL(5,14)=2.00D0
CTURB_GL(5,15)=1.35D0
CTURB_GL(5,16)=1.00D0
CTURB_GL(6,1) =4.50D0
CTURB_GL(6,2) =4.50D0
CTURB_GL(6,3) =4.50D0
CTURB_GL(6,4) =4.75D0
CTURB_GL(6,5) =4.75D0
CTURB_GL(6,6) =5.00D0
CTURB_GL(6,7) =5.25D0
CTURB_GL(6,8) =5.25D0
CTURB_GL(6,9) =5.00D0
CTURB_GL(6,10)=4.75D0
CTURB_GL(6,11)=4.50D0
CTURB_GL(6,12)=4.00D0
CTURB_GL(6,13)=3.75D0
CTURB_GL(6,14)=2.00D0
CTURB_GL(6,15)=1.40D0
CTURB_GL(6,16)=1.00D0
CTURB_GL(7,1) =4.00D0
CTURB_GL(7,2) =4.00D0
CTURB_GL(7,3) =4.00D0
CTURB_GL(7,4) =4.00D0
CTURB_GL(7,5) =4.00D0
CTURB_GL(7,6) =4.25D0
CTURB_GL(7,7) =4.50D0
CTURB_GL(7,8) =4.67D0
CTURB_GL(7,9) =4.50D0
CTURB_GL(7,10)=4.30D0
CTURB_GL(7,11)=4.10D0
CTURB_GL(7,12)=3.80D0
CTURB_GL(7,13)=3.50D0
CTURB_GL(7,14)=2.00D0
CTURB_GL(7,15)=1.30D0
CTURB_GL(7,16)=1.10D0
CTURB_GL(8,1) =3.50D0
CTURB_GL(8,2) =3.50D0
CTURB_GL(8,3) =3.50D0
CTURB_GL(8,4) =3.65D0
CTURB_GL(8,5) =3.65D0
CTURB_GL(8,6) =3.80D0
CTURB_GL(8,7) =4.1D02
CTURB_GL(8,8) =4.17D0
CTURB_GL(8,9) =4.17D0
CTURB_GL(8,10)=4.00D0
CTURB_GL(8,11)=3.80D0
CTURB_GL(8,12)=3.67D0
CTURB_GL(8,13)=3.40D0
CTURB_GL(8,14)=2.00D0
CTURB_GL(8,15)=1.30D0
CTURB_GL(8,16)=1.10D0
CTURB_GL(9,1) =3.25D0
CTURB_GL(9,2) =3.25D0
CTURB_GL(9,3) =3.25D0
CTURB_GL(9,4) =3.25D0
CTURB_GL(9,5) =3.25D0
CTURB_GL(9,6) =3.50D0
CTURB_GL(9,7) =3.75D0
CTURB_GL(9,8) =3.75D0
CTURB_GL(9,9) =3.75D0
CTURB_GL(9,10)=3.75D0
CTURB_GL(9,11)=3.60D0
CTURB_GL(9,12)=3.40D0
CTURB_GL(9,13)=3.25D0
CTURB_GL(9,14)=2.00D0
CTURB_GL(9,15)=1.30D0
CTURB_GL(9,16)=1.10D0
CTURB_GL(10,1) =3.00D0
CTURB_GL(10,2) =3.00D0
CTURB_GL(10,3) =3.00D0
CTURB_GL(10,4) =3.10D0
CTURB_GL(10,5) =3.10D0
CTURB_GL(10,6) =3.25D0
CTURB_GL(10,7) =3.40D0
CTURB_GL(10,8) =3.50D0
CTURB_GL(10,9) =3.50D0
CTURB_GL(10,10)=3.50D0
CTURB_GL(10,11)=3.40D0
CTURB_GL(10,12)=3.25D0
CTURB_GL(10,13)=3.15D0
CTURB_GL(10,14)=1.90D0
CTURB_GL(10,15)=1.30D0
CTURB_GL(10,16)=1.10D0
CTURB_GL(11,1) =2.75D0
CTURB_GL(11,2) =2.75D0
CTURB_GL(11,3) =2.75D0
CTURB_GL(11,4) =2.75D0
CTURB_GL(11,5) =2.75D0
CTURB_GL(11,6) =3.00D0
CTURB_GL(11,7) =3.25D0
CTURB_GL(11,8) =3.25D0
CTURB_GL(11,9) =3.25D0
CTURB_GL(11,10)=3.25D0
CTURB_GL(11,11)=3.25D0
CTURB_GL(11,12)=3.15D0
CTURB_GL(11,13)=3.00D0
CTURB_GL(11,14)=1.80D0
CTURB_GL(11,15)=1.30D0
CTURB_GL(11,16)=1.10D0
CTURB_GL(12,1) =2.60D0
CTURB_GL(12,2) =2.60D0
CTURB_GL(12,3) =2.60D0
CTURB_GL(12,4) =2.67D0
CTURB_GL(12,5) =2.67D0
CTURB_GL(12,6) =2.75D0
CTURB_GL(12,7) =3.00D0
CTURB_GL(12,8) =3.17D0
CTURB_GL(12,9) =3.17D0
CTURB_GL(12,10)=3.17D0
CTURB_GL(12,11)=3.10D0
CTURB_GL(12,12)=2.90D0
CTURB_GL(12,13)=2.80D0
CTURB_GL(12,14)=1.87D0
CTURB_GL(12,15)=1.37D0
CTURB_GL(12,16)=1.10D0
CTURB_GL(13,1) =2.40D0
CTURB_GL(13,2) =2.40D0
CTURB_GL(13,3) =2.40D0
CTURB_GL(13,4) =2.50D0
CTURB_GL(13,5) =2.50D0
CTURB_GL(13,6) =2.67D0
CTURB_GL(13,7) =2.83D0
CTURB_GL(13,8) =2.90D0
CTURB_GL(13,9) =3.00D0
CTURB_GL(13,10)=2.90D0
CTURB_GL(13,11)=2.85D0
CTURB_GL(13,12)=2.80D0
CTURB_GL(13,13)=2.75D0
CTURB_GL(13,14)=1.83D0
CTURB_GL(13,15)=1.30D0
CTURB_GL(13,16)=1.10D0
CTURB_GL(14,1) =1.67D0
CTURB_GL(14,2) =1.67D0
CTURB_GL(14,3) =1.67D0
CTURB_GL(14,4) =1.75D0
CTURB_GL(14,5) =1.75D0
CTURB_GL(14,6) =1.83D0
CTURB_GL(14,7) =1.87D0
CTURB_GL(14,8) =2.00D0
CTURB_GL(14,9) =2.10D0
CTURB_GL(14,10)=2.12D0
CTURB_GL(14,11)=2.15D0
CTURB_GL(14,12)=2.18D0
CTURB_GL(14,13)=2.19D0
CTURB_GL(14,14)=1.67D0
CTURB_GL(14,15)=1.28D0
CTURB_GL(14,16)=1.00D0
CTURB_GL(15,1) =1.30D0
CTURB_GL(15,2) =1.30D0
CTURB_GL(15,3) =1.30D0
CTURB_GL(15,4) =1.35D0
CTURB_GL(15,5) =1.35D0
CTURB_GL(15,6) =1.40D0
CTURB_GL(15,7) =1.60D0
CTURB_GL(15,8) =1.70D0
CTURB_GL(15,9) =1.70D0
CTURB_GL(15,10)=1.70D0
CTURB_GL(15,11)=1.70D0
CTURB_GL(15,12)=1.70D0
CTURB_GL(15,13)=1.70D0
CTURB_GL(15,14)=1.40D0
CTURB_GL(15,15)=1.25D0
CTURB_GL(15,16)=1.00D0
CTURB_GL(16,1) =1.17D0
CTURB_GL(16,2) =1.17D0
CTURB_GL(16,3) =1.17D0
CTURB_GL(16,4) =1.17D0
CTURB_GL(16,5) =1.17D0
CTURB_GL(16,6) =1.25D0
CTURB_GL(16,7) =1.30D0
CTURB_GL(16,8) =1.35D0
CTURB_GL(16,9) =1.40D0
CTURB_GL(16,10)=1.45D0
CTURB_GL(16,11)=1.45D0
CTURB_GL(16,12)=1.47D0
CTURB_GL(16,13)=1.44D0
CTURB_GL(16,14)=1.30D0
CTURB_GL(16,15)=1.12D0
CTURB_GL(16,16)=1.00D0
ENDIF
IF(IEPS_800.EQ.1.AND.IEPS_1600.EQ.1) THEN
DO I=1,K0G_GL
DO J=1,K0L_GL
CTURB_GL(I,J)=CTURB_GL(I,J)*1.7D0
ENDDO
ENDDO
ENDIF
DO J=1,K0L_GL
DO I=1,K0G_GL
CTURB_GL(I,J)=(CTURB_GL(I,J)-1.0D0)/1.5D0+1.0D0
ENDDO
ENDDO
DO I=KRMING_GL,KRMAXG_GL
DO J=KRMINL_GL,KRMAXL_GL
CTURBGL(I,J)=1.
ENDDO
ENDDO
DO I=KRMING_GL,KRMAXG_GL
X_KERN=RADXXO(I,6)*1.0D4
IF(X_KERN.LT.RG_GL(1)) X_KERN=RG_GL(1)
IF(X_KERN.GT.RG_GL(K0G_GL)) X_KERN=RG_GL(K0G_GL)
DO J=KRMINL_GL,KRMAXL_GL
Y_KERN=RADXXO(J,1)*1.0D4
IF(Y_KERN.LT.RL_GL(1)) Y_KERN=RL_GL(1)
IF(Y_KERN.GT.RL_GL(K0L_GL)) Y_KERN=RL_GL(K0L_GL)
CTURBGL(I,J)=F(X_KERN,Y_KERN,RG_GL,RL_GL,CTURB_GL &
& ,K0G_GL,K0L_GL)
ENDDO
ENDDO
IF(IEPS_800.EQ.1) THEN
DO I=KRMING_GL,15
DO J=KRMINL_GL,13
IF(CTURBGL(I,J).LT.3.0D0) CTURBGL(I,J)=3.0D0
ENDDO
ENDDO
ENDIF
IF(IEPS_1600.EQ.1) THEN
DO I=KRMING_GL,15
DO J=KRMINL_GL,13
IF(CTURBGL(I,J).LT.5.1D0) CTURBGL(I,J)=5.1D0
ENDDO
ENDDO
ENDIF
DO I=1,33
DO J=1,24
IF(I.LE.14.AND.J.EQ.8) CTURBGL(I,J)=1.0D0
IF(I.GT.14.AND.J.LE.8) CTURBGL(I,J)=1.2D0
ENDDO
ENDDO
RETURN
END SUBROUTINE TURBCOEF
!===================================================================
! QUESTION
real * 8 function f(x,y,x0,y0,table,k0,kk0) 33
! two-dimensional linear interpolation of the collision efficiency
! with help table(k0,kk0)
implicit none
integer k0,kk0,k,ir,kk,iq
double precision x,y,p,q,ec,ek
! double precision x,y,p,q,ec,ek,f
double precision x0(k0),y0(kk0),table(k0,kk0)
do k=2,k0
if(x.le.x0(k).and.x.ge.x0(k-1)) then
ir=k
elseif(x.gt.x0(k0)) then
ir=k0+1
elseif(x.lt.x0(1)) then
ir=1
endif
enddo
do kk=2,kk0
if(y.le.y0(kk).and.y.ge.y0(kk-1)) iq=kk
enddo
if(ir.lt.k0+1) then
if(ir.ge.2) then
p =(x-x0(ir-1))/(x0(ir)-x0(ir-1))
q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
ec=(1.d0-p)*(1.d0-q)*table(ir-1,iq-1)+ &
& p*(1.d0-q)*table(ir,iq-1)+ &
& q*(1.d0-p)*table(ir-1,iq)+ &
& p*q*table(ir,iq)
else
q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
ec=(1.d0-q)*table(1,iq-1)+q*table(1,iq)
endif
else
q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
ek=(1.d0-q)*table(k0,iq-1)+q*table(k0,iq)
ec=min(ek,1.d0)
endif
f=ec
return
end function f
! function f
!======================================================================
SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & 2
&,TIN,DT,RO,COL,AFREEZMY,BFREEZMY,BFREEZMAX,KRFREEZ,ICEMAX,NKR)
IMPLICIT NONE
INTEGER KR,ICE,ICE_TYPE
REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
INTEGER KRFREEZ,ICEMAX,NKR
REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, &
& TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
& F2_MAX,F3_MAX,F4_MAX,F5_MAX
REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
& ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
& ,XG(NKR),FF5(NKR),XH(NKR)
TTIN=TIN
DEL_T =TTIN-273.15
ICE_TYPE=2
F1_MAX=0.
F2_MAX=0.
F3_MAX=0.
F4_MAX=0.
F5_MAX=0.
DO 1 KR=1,NKR
F1_MAX=AMAX1(F1_MAX,FF1(KR))
F3_MAX=AMAX1(F3_MAX,FF3(KR))
F4_MAX=AMAX1(F4_MAX,FF4(KR))
F5_MAX=AMAX1(F5_MAX,FF5(KR))
DO 1 ICE=1,ICEMAX
F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
1 CONTINUE
FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
!
!******************************* FREEZING ****************************
!
IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
SUM_ICE=0.
AF =AFREEZMY
CFREEZ =(BFREEZMAX-BFREEZMY)/XL(NKR)
!
!***************************** MASS LOOP **************************
!
DO KR =1,NKR
ARG_M =XL(KR)
BF =BFREEZMY+CFREEZ*ARG_M
PF_1 =AF*EXP(-BF*DEL_T)
PF =ARG_M*PF_1
YKK =EXP(-PF*DT)
DF1 =FF1(KR)*(1.-YKK)
YK2 =DF1
FF1(KR)=FF1(KR)*YKK
IF(KR.LE.KRFREEZ) THEN
FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
ELSE
FF5(KR) =FF5(KR)+YK2
ENDIF
SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
!
!************************ END OF "MASS LOOP" **************************
!
ENDDO
!
!************************** NEW TEMPERATURE *************************
!
ARG_1 =333.*SUM_ICE/RO
TT_DROP_AFTER_FREEZ=TTIN+ARG_1
TIN =TT_DROP_AFTER_FREEZ
!
!************************** END OF "FREEZING" ****************************
!
ENDIF
!
RETURN
END SUBROUTINE FREEZ
SUBROUTINE ORIG_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & 2
& ,TIN,DT,RO,COL,ICEMAX,NKR)
IMPLICIT NONE
INTEGER KR,ICE,ICE_TYPE
INTEGER ICEMAX,NKR
REAL COL
REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
& RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
& DEL_T,TIN
REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
& ,FF3(NKR),XS(NKR),FF4(NKR) &
& ,XG(NKR),FF5(NKR),XH(NKR)
! gamma=4.4
DEL_T =TIN-273.15
ICE_TYPE=2
F1_MAX=0.
F2_MAX=0.
F3_MAX=0.
F4_MAX=0.
F5_MAX=0.
DO 1 KR=1,NKR
F1_MAX=AMAX1(F1_MAX,FF1(KR))
F3_MAX=AMAX1(F3_MAX,FF3(KR))
F4_MAX=AMAX1(F4_MAX,FF4(KR))
F5_MAX=AMAX1(F5_MAX,FF5(KR))
DO 1 ICE=1,ICEMAX
F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
1 CONTINUE
FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
! MELTING :
IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
SUM_ICE=0.
! MASS LOOP :
DO KR=1,NKR
ARG_M=FF3(KR)+FF4(KR)+FF5(KR)
DO ICE=1,ICEMAX
ARG_M=ARG_M+FF2(KR,ICE)
FF2(KR,ICE)=0.
ENDDO
FF1(KR)=FF1(KR)+ARG_M
FF3(KR)=0.
FF4(KR)=0.
FF5(KR)=0.
SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
! END OF "MASS LOOP"
ENDDO
! CYCLE BY KR
! NEW TEMPERATURE :
ARG_1=333.*SUM_ICE/RO
TIN=TIN-ARG_1
! END OF MELTING
! IN CASE DEL_T.GE.0.AND.FF_MAX.NE.0
ENDIF
RETURN
END SUBROUTINE ORIG_MELT
!===========================
SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH & 2
& ,TIN,DT,RO,COL,ICEMAX,NKR)
IMPLICIT NONE
INTEGER KR,ICE,ICE_TYPE
INTEGER ICEMAX,NKR
REAL COL
REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
& RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
& DEL_T,TIN,meltrate
REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
& ,FF3(NKR),XS(NKR),FF4(NKR) &
& ,XG(NKR),FF5(NKR),XH(NKR)
! gamma=4.4
DEL_T =TIN-273.15
F1_MAX=0.
F2_MAX=0.
F3_MAX=0.
F4_MAX=0.
F5_MAX=0.
DO 1 KR=1,NKR
F1_MAX=AMAX1(F1_MAX,FF1(KR))
F3_MAX=AMAX1(F3_MAX,FF3(KR))
F4_MAX=AMAX1(F4_MAX,FF4(KR))
F5_MAX=AMAX1(F5_MAX,FF5(KR))
DO 1 ICE=1,ICEMAX
F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
1 CONTINUE
FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
! MELTING :
SUM_ICE=0.
IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
! Fan's "MASS LOOP"
DO KR = 1,NKR
ARG_M = 0.
DO ICE = 1,ICEMAX
IF (ICE ==1) THEN
IF (KR .le. 10) THEN
ARG_M = ARG_M+FF2(KR,ICE)
FF2(KR,ICE)=0.
ELSEIF (KR .gt. 10 .and. KR .lt. 18) THEN
meltrate = 0.5/50.
ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
ELSE
meltrate = 0.683/120.
ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
ENDIF
ENDIF
IF (ICE ==2 .or. ICE ==3) THEN
IF (kr .le. 12) THEN
ARG_M = ARG_M+FF2(KR,ICE)
FF2(KR,ICE)=0.
ELSEIF (kr .gt. 12 .and. kr .lt. 20) THEN
meltrate = 0.5/50.
ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
ELSE
meltrate = 0.683/120.
ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
ENDIF
ENDIF
ENDDO ! Do ice
! snow
IF (kr .le. 14) THEN
ARG_M = ARG_M+FF3(KR)
FF3(KR)=0.
ELSEIF (kr .gt. 14 .and. kr .lt. 22) THEN
meltrate = 0.5/50.
ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
ELSE
meltrate = 0.683/120.
ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
ENDIF
! graupel/hail
IF (kr .le. 13) then
ARG_M = ARG_M+FF4(KR)+FF5(KR)
FF4(KR)=0.
FF5(KR)=0.
ELSEIF (kr .gt. 13 .and. kr .lt. 23) THEN
meltrate = 0.5/50.
ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
ELSE
meltrate = 0.683/120.
ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
ENDIF
FF1(KR)=FF1(KR)+ARG_M
SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
! END OF Fan'a "MASS LOOP"
ENDDO
! CYCLE BY KR
! NEW TEMPERATURE :
ARG_1=333.*SUM_ICE/RO
TIN=TIN-ARG_1
! END OF MELTING
ENDIF
RETURN
END SUBROUTINE J_W_MELT
!===================================================================
SUBROUTINE JERNUCL01(PSI1,PSI2,FCCNR & 2,4
& ,X1,X2,DTT,DQQ,ROR,PP,DSUP1,DSUP2 &
& ,COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY &
& ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ &
& ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
IMPLICIT NONE
!
INTEGER ICEMAX,NKR
INTEGER ICEPROCS
REAL COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY, &
& C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ, &
& RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
!
INTEGER KR,ICE,ITYPE,NRGI,ICORR,II,JJ,KK,NKRDROP,NCRITI
DOUBLE PRECISION DTT,DQQ,DSUP1,DSUP2
REAL TT,QQ, &
& DX,BMASS,CONCD,C2,CONCDF,DELTACD,CONCDIN,ROR, &
& DELTAF,DELMASSL,FMASS,HELEK1,DEL2NN,FF1BN, &
& HELEK2,TPCC,PP,ADDF,DSUP2N,FACT,EW1N,ES2N,ES1N,FNEW, &
& C1,SUP1N,SUP2N,QPN,TPN,TPC,SUP1,SUP2,DEL1N,DEL2N,AL1,AL2, &
& TEMP1,TEMP2,TEMP3,A1,B1,A2,B2
!
!********************************************************************
! NEW MEYERS IN JERNUCL01 SUBROUTINE
!********************************************************************
REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
& ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
DATA AL1/2500./,AL2/2834./
SUP1=DSUP1
SUP2=DSUP2
TT=DTT
QQ=DQQ
! DROPLETS NUCLEATION (BEGIN)
TPN=TT
QPN=QQ
DEL1N=100.*SUP1
TPC=TT-273.15
IF(DEL1N.GT.0.AND.TPC.GT.-73.16) THEN
CALL WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 &
& ,COL,RCCN,DROPRADII,NKR,ICEMAX)
ENDIF
! DROPLETS NUCLEATION (END)
! drop nucleation (end)
! nucleation of crystals (begin)
IF (ICEPROCS.EQ.1)THEN
DEL2N=100.*SUP2
IF(TPC.LT.0..AND.TPC.GE.-73.16.AND.DEL2N.GT.0.) THEN
CALL ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
& ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
& ,NKR,ICEMAX)
ENDIF
ENDIF
! nucleation of crystals (end)
! new change in drop nucleation (begin)
! no sink of water vapour by nucleation
RETURN
END SUBROUTINE JERNUCL01
! SUBROUTINE JERNUCL01
!======================================================================
SUBROUTINE WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 & 2,2
&,COL,RCCN,DROPRADII,NKR,ICEMAX)
IMPLICIT NONE
INTEGER NDROPMAX,KR,ICEMAX,NKR
REAL PSI1(NKR),FCCNR(NKR),X1(NKR)
REAL DROPCONCN(NKR)
REAL RCCN(NKR),DROPRADII(NKR)
REAL TT,SUP1,DX,COL
CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN &
&,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
! NEW WATER SIZE DISTRIBUTION FUNCTION (BEGIN)
DO KR=1,NDROPMAX
DX=3.*COL*X1(KR)
! new changes 25.06.01 (begin)
PSI1(KR)=PSI1(KR)+DROPCONCN(KR)/DX
! new changes 25.06.01 (end)
ENDDO
RETURN
END SUBROUTINE WATER_NUCL
SUBROUTINE ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD & 2
& ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
& ,NKR,ICEMAX)
IMPLICIT NONE
INTEGER ITYPE,KR,ICE,NRGI,ICEMAX,NKR
REAL DEL2N,SUP2,C1,C2,C1_MEY,C2_MEY,TPC,TT,ROR
REAL DX,COL,BMASS,BFMASS,FMASS
REAL HELEK1,HELEK2,TPCC,DEL2NN,FF1BN,DSUPICEXZ
REAL FACT,DSUP2N,SUP2_OLD,DELTACD,DELTAF,ADDF,FNEW
REAL X2(NKR,ICEMAX),PSI2(NKR,ICEMAX)
REAL A1,B1,A2,B2
DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
! DATA A1,B1,A2,B2/-0.639,0.15,-2.8,0.262/
REAL TEMP1,TEMP2,TEMP3
DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
REAL ICE_CON
C1=C1_MEY
C2=C2_MEY
! TYPE OF ICE WITH NUCLEATION (BEGIN)
TPC=TT-273.15
ITYPE=0
IF((TPC.GT.-4.0).OR.(TPC.LE.-8.1.AND.TPC.GT.-12.7).OR.&
& (TPC.LE.-17.8.AND.TPC.GT.-22.4)) THEN
ITYPE=2
ELSE
IF((TPC.LE.-4.0.AND.TPC.GT.-8.1).OR.(TPC.LE.-22.4)) THEN
ITYPE=1
ELSE
ITYPE=3
ENDIF
ENDIF
! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION (BEGIN)
ICE=ITYPE
NRGI=2
IF(TPC.LT.TEMP1) THEN
DEL2N=100.*SUP2
DEL2NN=DEL2N
IF(DEL2N.GT.50.0) DEL2NN=50.
HELEK1=C1*EXP(A1+B1*DEL2NN)
ELSE
HELEK1=0.
ENDIF
IF(TPC.LT.TEMP2) THEN
TPCC=TPC
IF(TPCC.LT.TEMP3) TPCC=TEMP3
HELEK2=C2*EXP(A2-B2*TPCC)
ELSE
HELEK2=0.
ENDIF
FF1BN=HELEK1+HELEK2
FACT=1.
DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.
SUP2_OLD=SUP2
IF(DSUP2N.GT.50.) DSUP2N=50.
DELTACD=FF1BN*B1*DSUP2N
IF(DELTACD.GE.FF1BN) DELTACD=FF1BN
IF(DELTACD.GT.0.) THEN
ICE_CON=0.
DO KR=1,NRGI-1
DX=3.*X2(KR,ICE)*COL
ICE_CON=ICE_CON+DX*PSI2(KR,ICE)
ENDDO
IF(ICE_CON.GT.HELEK1)THEN
! CONTINUE
ELSE
DELTAF=DELTACD*FACT
DO KR=1,NRGI-1
DX=3.*X2(KR,ICE)*COL
ADDF=DELTAF/DX
PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
ENDDO
END IF
ENDIF
! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION (END)
RETURN
END SUBROUTINE ICE_NUCL
SUBROUTINE NUCLEATION (SUP1,TT,FCCNR,DROPCONCN & 2,14
&,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
! DROPCONCN(KR), 1/cm^3 - drop bin concentrations, KR=1,...,NKR
! determination of new size spectra due to drop nucleation
IMPLICIT NONE
INTEGER NDROPMAX,IDROP,ICCN,INEXT,ISMALL,KR,NCRITI
INTEGER ICEMAX,IMIN,IMAX,NKR,I,II,I0,I1
REAL &
& SUP1,TT,RACTMAX,XKOE,R03,SUPCRITI,AKOE23,RCRITI,BKOE, &
& AKOE,CONCCCNIN,DEG01,ALN_IP
REAL CCNCONC(NKR)
REAL CCNCONC_BFNUCL
REAL COL
REAL RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
REAL RACT(NKR),DROPCONC(NKR),DROPCONCN(NKR)
REAL DLN1,DLN2,FOLD_IP
DEG01=1./3.
! calculation initial value of NDROPMAX - maximal number of drop bin
! which is activated
! initial value of NDROPMAX
NDROPMAX=0
DO KR=1,NKR
! initialization of bin radii of activated drops
RACT(KR)=0.
! initialization of aerosol(CCN) bin concentrations
CCNCONC(KR)=0.
! initialization of drop bin concentrations
DROPCONCN(KR)=0.
ENDDO
! CCNCONC_BFNUCL - concentration of aerosol particles before
! nucleation
CCNCONC_BFNUCL=0.
DO I=1,NKR
CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
ENDDO
CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL
IF(CCNCONC_BFNUCL.EQ.0.) THEN
RETURN
ELSE
CALL BOUNDARY(IMIN,IMAX,FCCNR,NKR)
CALL CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
IF(RCRITI.GE.RCCN(IMAX)) RETURN
END IF
! calculation of CCNCONC(I) - aerosol(CCN) bin concentrations;
! I=IMIN,...,IMAX
! determination of NCRITI - number bin in which is located RCRITI
IF (IMIN.EQ.1)THEN
CALL CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
& FCCNR,NKR)
CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
& FCCNR,NKR)
ELSE
CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
& FCCNR,NKR)
END IF
! calculation CCNCONC_AFNUCL - ccn concentration after nucleation
! CCNCONC_AFNUCL=0.
! DO I=IMIN,IMAX
! CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
! ENDDO
! CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL
! calculation DEL_CCNCONC
! DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
CALL DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
! put nucleated droplets into the drop bin according to radius
! change in drop concentration due to activation DROPCONCN(IDROP)
ISMALL=NCRITI
INEXT=ISMALL
! ISMALL=1
! INEXT=ISMALL
DO IDROP=1,NDROPMAX
DROPCONCN(IDROP)=0.
DO I=ISMALL,IMAX
IF(RACT(I).LE.DROPRADII(IDROP)) THEN
DROPCONCN(IDROP)=DROPCONCN(IDROP)+CCNCONC(I)
INEXT=I+1
ENDIF
ENDDO
ISMALL=INEXT
ENDDO
!999 CONTINUE
RETURN
END SUBROUTINE NUCLEATION
SUBROUTINE BOUNDARY(IMIN,IMAX,FCCNR,NKR) 2
! IMIN - left CCN spectrum boundary
IMPLICIT NONE
INTEGER I,IMIN,IMAX,NKR
REAL FCCNR(NKR)
IMIN=0
DO I=1,NKR
IF(FCCNR(I).NE.0.) THEN
IMIN=I
GOTO 40
ENDIF
ENDDO
40 CONTINUE
! IMAX - right CCN spectrum boundary
IMAX=0
DO I=NKR,1,-1
IF(FCCNR(I).NE.0.) THEN
IMAX=I
GOTO 41
ENDIF
ENDDO
41 CONTINUE
RETURN
END SUBROUTINE BOUNDARY
SUBROUTINE CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01) 2
! AKOE & BKOE - constants in Koehler equation
IMPLICIT NONE
REAL AKOE,BKOE,TT,RCRITI,SUP1,DEG01
REAL RO_SOLUTE
PARAMETER (RO_SOLUTE=2.16)
AKOE=3.3E-05/TT
BKOE=2.*4.3/(22.9+35.5)
! new change 21.07.02 (begin)
BKOE=BKOE*(4./3.)*3.141593*RO_SOLUTE
! new change 21.07.02 (end)
! table of critical aerosol radii
! GOTO 992
! SUP1_TEST(I), %
! SUP1_TEST(1)=0.01
! DO I=1,99
! SUP1_TEST(I+1)=SUP1_TEST(I)+0.01
! SUP1_I=SUP1_TEST(I)*0.01
! RCRITI_TEST(I)=(AKOE/3.)*(4./BKOE/SUP1_I/SUP1_I)**DEG01
! ENDDO
! RCRITI, cm - critical radius of "dry" aerosol
RCRITI=(AKOE/3.)*(4./BKOE/SUP1/SUP1)**DEG01
RETURN
END SUBROUTINE CRITICAL
SUBROUTINE CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, & 2
& FCCNR,NKR)
! FOR IMIN=1
IMPLICIT NONE
INTEGER IMIN,II,IMAX,NCRITI,NKR
REAL RCRITI,COL
REAL RCCN(NKR),FCCNR(NKR),CCNCONC(NKR)
REAL RCCN_MIN
REAL DLN1,DLN2,FOLD_IP
! rccn_min - minimum aerosol(ccn) radius
RCCN_MIN=RCCN(1)/10000.
! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
! concentrations,
! ii=imin,...,imax
! determination of ncriti - number bin in which is located rcriti
! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
! where,
! dln1=Ln(rcriti)-Ln(rccn_min)
! dln2=Ln(rccn(1)-Ln(rcriti)
! calculation of new value of fccnr(ncriti)
! IF(IMIN.EQ.1) THEN
IF(RCRITI.LE.RCCN_MIN) THEN
NCRITI=1
DO II=NCRITI+1,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
GOTO 42
ENDIF
IF(RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)) THEN
NCRITI=1
DO II=NCRITI+1,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
DLN1=ALOG(RCRITI)-ALOG(RCCN_MIN)
DLN2=ALOG(RCCN(1))-ALOG(RCRITI)
CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/(DLN1+DLN2)
GOTO 42
! in case RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)
ENDIF
! in case IMIN.EQ.1
42 CONTINUE
RETURN
END SUBROUTINE CCNIMIN
SUBROUTINE CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, & 4
& FCCNR,NKR)
IMPLICIT NONE
INTEGER I,IMIN,IMAX,NKR,II,NCRITI
REAL COL
REAL RCRITI,RCCN(NKR),CCNCONC(NKR),FCCNR(NKR)
REAL DLN1,DLN2,FOLD_IP
IF(IMIN.GT.1) THEN
IF(RCRITI.LE.RCCN(IMIN-1)) THEN
NCRITI=IMIN
DO II=NCRITI,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
GOTO 42
ENDIF
IF(RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)) &
& THEN
! this line eliminates bug you found (when IMIN=IMAX)
NCRITI=IMIN
DO II=NCRITI+1,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
DLN1=ALOG(RCRITI)-ALOG(RCCN(IMIN-1))
DLN2=COL-DLN1
CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
GOTO 42
! in case RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
ENDIF
! in case IMIN.GT.1
ENDIF
! END of part of interest. so in case
!RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
!we go to 42 and avoid the next loop
DO I=IMIN,IMAX-1
IF(RCRITI.EQ.RCCN(I)) THEN
NCRITI=I+1
DO II=I+1,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
GOTO 42
ENDIF
IF(RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)) THEN
NCRITI=I+1
IF(I.NE.IMAX-1) THEN
DO II=NCRITI+1,IMAX
CCNCONC(II)=COL*FCCNR(II)
FCCNR(II)=0.
ENDDO
ENDIF
DLN1=ALOG(RCRITI)-ALOG(RCCN(I))
DLN2=COL-DLN1
CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
GOTO 42
! in case RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)
END IF
ENDDO
! cycle by I, I=IMIN,...,IMAX-1
42 CONTINUE
RETURN
END SUBROUTINE CCNLOOP
SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR) 6,14
IMPLICIT NONE
INTEGER IMIN,IMAX,NKR
INTEGER I,I0,I1
REAL RCCN(NKR)
REAL R03,SUPCRITI,RACT(NKR),XKOE
REAL AKOE,BKOE,AKOE23,RACTMAX
! Spectrum of activated drops (begin)
DO I=IMIN,IMAX
! critical water supersaturations appropriating CCN radii
XKOE=(4./27.)*(AKOE**3/BKOE)
AKOE23=AKOE*2./3.
R03=RCCN(I)**3
SUPCRITI=SQRT(XKOE/R03)
! RACT(I) - radii of activated drops, I=IMIN,...,IMAX
IF(RCCN(I).LE.(0.3E-5)) &
& RACT(I)=AKOE23/SUPCRITI
IF(RCCN(I).GT.(0.3E-5))&
& RACT(I)=5.*RCCN(I)
ENDDO
! cycle by I
! calculation of I0
I0=IMIN
DO I=IMIN,IMAX-1
IF(RACT(I+1).LT.RACT(I)) THEN
I0=I+1
GOTO 45
ENDIF
ENDDO
45 CONTINUE
! new changes 9.04.02 (begin)
I1=I0-1
! new changes 9.04.02 (end)
IF(I0.EQ.IMIN) GOTO 47
! new changes 9.04.02 (begin)
IF(I0.EQ.IMAX) THEN
RACT(IMAX)=RACT(IMAX-1)
GOTO 47
ENDIF
IF(RACT(IMAX).LE.RACT(I0-1)) THEN
DO I=I0,IMAX
RACT(I)=RACT(I0-1)
ENDDO
GOTO 47
ENDIF
! new changes 9.04.02 (end)
! calculation of I1
DO I=I0+1,IMAX
IF(RACT(I).GE.RACT(I0-1)) THEN
I1=I
GOTO 46
ENDIF
ENDDO
46 CONTINUE
! spectrum of activated drops (end)
! line interpolation RACT(I) for I=I0,...,I1
DO I=I0,I1
RACT(I)=RACT(I0-1)+(I-I0+1)*(RACT(I1)-RACT(I0-1)) &
& /(I1-I0+1)
ENDDO
47 CONTINUE
RACTMAX=0.
DO I=IMIN,IMAX
RACTMAX=AMAX1(RACTMAX,RACT(I))
ENDDO
RETURN
END SUBROUTINE ACTIVATE
SUBROUTINE DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR) 2
IMPLICIT NONE
INTEGER IDROP,NKR,NDROPMAX
REAL RACTMAX,DROPRADII(NKR)
! calculation of NDROPMAX - maximal number of drop bin which
! is activated
NDROPMAX=1
DO IDROP=1,NKR
IF(RACTMAX.LE.DROPRADII(IDROP)) THEN
NDROPMAX=IDROP
GOTO 44
ENDIF
ENDDO
44 CONTINUE
RETURN
END SUBROUTINE DROPMAX
SUBROUTINE ONECOND1 & 2,26
& (TT,QQ,PP,ROR &
& ,VR1,PSINGLE &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,FF1,PSI1,R1,RLEC,RO1BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR)
IMPLICIT NONE
INTEGER NKR,ICEMAX
REAL COL,VR1(NKR),PSINGLE &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,DTCOND
REAL C1_MEY,C2_MEY
INTEGER I_ABERGERON,I_BERGERON, &
& KR,ICE,ITIME,KCOND,NR,NRM, &
& KLIMIT, &
& KM,KLIMITL
REAL AL1,AL2,D,GAM,POD, &
& RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
& A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
& TPC1, TPC2, TPC3, TPC4, TPC5, &
& EPSDEL, EPSDEL2,DT0L, DT0I,&
& ROR, &
& CWHUCM,B6,B8L,B8I, &
& DEL1,DEL2,DEL1S,DEL2S, &
& TIMENEW,TIMEREV,SFN11,SFN12, &
& SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
& PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
& DEL_R1,DT0L0,DT0I0, &
& DTNEWL0, &
& DTNEWL2
REAL DT_WATER_COND,DT_WATER_EVAP
INTEGER K
! NEW ALGORITHM OF CONDENSATION (12.01.00)
REAL FF1_OLD(NKR),SUPINTW(NKR)
DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
& ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
& ,R1_K,R2_K,R3_K,R4_K,R5_K &
& ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
& ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
& ,ES1N,ES2N,EW1N,ARGEXP &
& ,TT,QQ,PP &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,OPER2,OPER3,AR1,AR2
DOUBLE PRECISION DELMASSL1
! DROPLETS
REAL R1(NKR) &
& ,RLEC(NKR),RO1BL(NKR) &
& ,FI1(NKR),FF1(NKR),PSI1(NKR) &
& ,B11_MY(NKR),B12_MY(NKR)
! WORK ARRAYS
! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
REAL DTIMEO(NKR),DTIMEL(NKR) &
& ,TIMESTEPD(NKR)
! NEW ALGORITHM (NO TYPE OF ICE)
OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
& ,GAM /1.E-4/, POD /10./
DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
& /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
& /2.53,5.42,3.41E1,6.13/
DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
& /-4.0,-8.1,-12.7,-17.8,-22.4/
DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
DATA DT0L, DT0I /1.E20,1.E20/
! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
I_ABERGERON=0
I_BERGERON=0
COL3=3.0*COL
ITIME=0
KCOND=0
DT_WATER_COND=0.4
DT_WATER_EVAP=0.4
ITIME=0
KCOND=0
DT0LREF=0.2
DTLREF=0.4
NR=NKR
NRM=NKR-1
DT=DTCOND
DTT=DTCOND
XRAD=0.
! BARRY
CWHUCM=0.
XRAD=0.
B6=CWHUCM*GAM-XRAD
B8L=1./ROR
B8I=1./ROR
RORI=1./ROR
! INITIALIZATION OF SOME ARRAYS
! print*, 'got to here 0'
! BARRY: REMOVE RS2 LOOP
DO KR=1,NKR
FF1_OLD(KR)=FF1(KR)
SUPINTW(KR)=0.
DSUPINTW(KR)=0.
ENDDO
! OLD TREATMENT OF "T" & "Q"
!DEL12RD=DEL12R**DEL_BBR
! BARRY
! EW1PN=AA1_MY*(100.+DEL1IN*100.)*DEL12RD/100.
! QQIN=OPER4(EW1PN,PP)
TPN=TT
QPN=QQ
DO 19 KR=1,NKR
FI1(KR)=FF1(KR)
19 CONTINUE
! WARM OR NO ICE (BEGIN)
! ONLY WATER (CONDENSATION OR EVAPORATION) (BEGIN)
TIMENEW=0.
ITIME=0
! NEW CHANGES 10.01.01 (BEGIN)
TOLD=TPN
QOLD=QPN
! NEW CHANGES 10.01.01 (END)
56 ITIME=ITIME+1
TIMEREV=DT-TIMENEW
TIMEREV=DT-TIMENEW
DEL1=DEL1N
DEL2=DEL2N
DEL1S=DEL1N
DEL2S=DEL2N
TPS=TPN
QPS=QPN
! NO QPS IN JERRATE
CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
& ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
! INTEGRALS IN DELTA EQUATION (ONLY WATER)
! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND
! CALL JERTIMESC WATER - 1 (ONLY WATER)
CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
& ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
SFNL=SFN11+SFN12
SFNI=0.
! SOME CONSTANTS
B5L=BB1_MY/TPS/TPS
B5I=BB2_MY/TPS/TPS
B7L=B5L*B6
B7I=B5I*B6
DOPL=1.+DEL1S
DOPI=1.+DEL2S
RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
QW=B7L*DOPL
PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
QI=B7I*DOPI
! SOLVING FOR TIMEZERO
KCOND=10
IF(DEL1.GT.0) KCOND=11
! PROCESS'S TYPE
IF(KCOND.EQ.11) THEN
! NEW TIME STEP IN CONDENSATION (ONLY WATER) (BEGIN)
IF (DEL1N.EQ.0)THEN
DTNEWL=DT
ELSE
DTNEWL=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N &
& -B12_MY(ITIME)))
IF(DTNEWL.GT.DT) DTNEWL=DT
END IF
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (ONLY WATER: CONDENSATION)
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMESTEPD(ITIME)=DTNEWL
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
! SOLVING FOR SUPERSATURATION
! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)
CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N,D2N,DT0L,DT0I)
! END OF "NEW SUPERSATURATION"
! DROPLETS
! DROPLET DISTRIBUTION FUNCTION
! CALL JERDFUN WATER - 1 (ONLY WATER: CONDENSATION)
CALL JERDFUN(R1,B11_MY,B12_MY &
& ,FI1,PSI1,D1N &
& ,1,1,COL,NKR,TPN)
IF((DEL1.GT.0.AND.DEL1N.LT.0) &
& .AND.ABS(DEL1N).GT.EPSDEL) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
ENDIF
! IN CASE : KCOND.EQ.11
ELSE
! EVAPORATION - ONLY WATER
! IN CASE : KCOND.NE.11
IF (DEL1N.EQ.0)THEN
DTIMEO(1)=DT
DO KR=2,NKR
DTIMEO(KR)=DT
ENDDO
ELSE
DTIMEO(1)=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
DO KR=2,NKR
KM=KR-1
DTIMEO(KR)=(R1(KM)-R1(KR))/(B11_MY(KR)*DEL1N &
& -B12_MY(KR))
ENDDO
END IF
KLIMIT=1
DO KR=1,NKR
IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
KLIMIT=KR
ENDDO
55 KLIMIT=KLIMIT-1
IF(KLIMIT.LT.1) KLIMIT=1
! BARRY THIS LINE CAUSED A PROBLEM BECAUSE DTNEWL GOES FROM
! LARGE TO SMALL
DTNEWL1=AMIN1(DTIMEO(3),TIMEREV)
IF(DTNEWL1.LT.DTLREF) DTNEWL1=AMIN1(DTLREF,TIMEREV)
DTNEWL=DTNEWL1
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (ONLY_WATER: EVAPORATION)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMESTEPD(ITIME)=DTNEWL
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
! SOLVING FOR SUPERSATURATION
! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)
CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N,D2N,DT0L0,DT0I0)
! END OF "NEW SUPERSATURATION"
! DROPLETS
! DROPLET DISTRIBUTION FUNCTION (ONLY_WATER: EVAPORATION)
! CALL JERDFUN WATER - 2 (ONLY_WATER: EVAPORATION)
CALL JERDFUN(R1,B11_MY,B12_MY &
& ,FI1,PSI1,D1N &
& ,1,1,COL,NKR,TPN)
! IN CASE : ISYML.NE.0 (ENDING OF
! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)
! ENDIF
IF((DEL1.LT.0.AND.DEL1N.GT.0) &
& .AND.ABS(DEL1N).GT.EPSDEL) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
ENDIF
! END OF "PROCESS'S TYPE"
! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)
ENDIF
! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
! EVAPORATION : ONLY WATER)
! CONCENTRATION & MASS (ONLY WATER)
RMASSLBB=0.
RMASSLAA=0.
! BEFORE JERNEWF (ONLY WATER)
DO K=1,NKR
FI1_K=FI1(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLBB=RMASSLBB+FI1R1
ENDDO
RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
IF(RMASSLBB.LE.0.) RMASSLBB=0.
DO K=1,NKR
FI1_K=PSI1(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLAA=RMASSLAA+FI1R1
ENDDO
RMASSLAA=RMASSLAA*COL3*RORI
IF(RMASSLAA.LE.0.) RMASSLAA=0.
! NEW TREATMENT OF "T" & "Q" (ONLY WATER)
DELMASSL1=RMASSLAA-RMASSLBB
QPN=QPS-DELMASSL1
DAL1=AL1
TPN=TPS+DAL1*DELMASSL1
! SUPERSATURATION (ONLY WATER)
ARGEXP=-BB1_MY/TPN
ES1N=AA1_MY*DEXP(ARGEXP)
ARGEXP=-BB2_MY/TPN
ES2N=AA2_MY*DEXP(ARGEXP)
EW1N=OPER3(QPN,PP)
IF(ES1N.EQ.0)THEN
DEL1N=0.5
DIV1=1.5
ELSE
DIV1=EW1N/ES1N
DEL1N=EW1N/ES1N-1.
END IF
IF(ES2N.EQ.0)THEN
DEL2N=0.5
DIV2=1.5
ELSE
DEL2N=EW1N/ES2N-1.
DIV2=EW1N/ES2N
END IF
DO KR=1,NKR
SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
DD1N=D1N
DB11_MY=B11_MY(KR)
DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
ENDDO
! REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION)
IF(TIMENEW.LT.DT) GOTO 56
57 CONTINUE
CALL JERDFUN_NEW(R1,DSUPINTW &
& ,FF1_OLD,PSI1,D1N &
& ,1,1,COL,NKR,TPN)
RMASSLAA=0.0
RMASSLBB=0.0
! BEFORE JERNEWF
DO K=1,NKR
FI1_K=FF1_OLD(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLBB=RMASSLBB+FI1R1
ENDDO
RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
! AFTER JERNEWF
DO K=1,NKR
FI1_K=PSI1(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLAA=RMASSLAA+FI1R1
ENDDO
RMASSLAA=RMASSLAA*COL3*RORI
! NEW CHANGE RMASSLAA
IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
! NEW TREATMENT OF "T" & "Q"
DELMASSL1=RMASSLAA-RMASSLBB
! NEW CHANGES 10.01.01 (BEGIN)
QPN=QOLD-DELMASSL1
DAL1 = AL1
TPN=TOLD+DAL1*DELMASSL1
! NEW CHANGES 10.01.01 (END)
! SUPERSATURATION
ARGEXP=-BB1_MY/TPN
ES1N=AA1_MY*DEXP(ARGEXP)
ARGEXP=-BB2_MY/TPN
ES2N=AA2_MY*DEXP(ARGEXP)
EW1N=OPER3(QPN,PP)
IF(ES1N.EQ.0)THEN
DEL1N=0.5
DIV1=1.5
call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
ELSE
DIV1=EW1N/ES1N
DEL1N=EW1N/ES1N-1.
END IF
IF(ES2N.EQ.0)THEN
DEL2N=0.5
DIV2=1.5
call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
ELSE
DEL2N=EW1N/ES2N-1.
DIV2=EW1N/ES2N
END IF
TT=TPN
QQ=QPN
DO KR=1,NKR
FF1(KR)=PSI1(KR)
ENDDO
RETURN
! END
END SUBROUTINE ONECOND1
!==================================================================
!BARRY
SUBROUTINE JERDFUN(R2,B21_MY,B22_MY & 42,4
& ,FI2,PSI2,DEL2N &
& ,IND,ITYPE,COL,NKR,TPN)
IMPLICIT NONE
! CRYSTALS
REAL COL,DEL2N
INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,NKR,IDROP
REAL &
& R2(NKR,IND),R2N(NKR,IND) &
& ,FI2(NKR,IND),PSI2(NKR,IND) &
& ,B21_MY(NKR,IND),B22_MY(NKR,IND) &
& ,DEL_R2M(NKR,IND)
DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
& DB21_MY(NKR,IND)
DOUBLE PRECISION CHECK,TPN
CHECK=0.D0
DO KR=1,NKR
CHECK=B21_MY(1,1)*B21_MY(KR,1)
IF (CHECK.LT.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (CHECK.LT.0), model stop")
END DO
IF(IND.NE.1) THEN
ITYP=ITYPE
ELSE
ITYP=1
ENDIF
DDEL2N=DEL2N
DO KR=1,NKR
PSI2R(KR)=FI2(KR,ITYP)
FI2R(KR)=FI2(KR,ITYP)
DR2(KR,ITYP)=R2(KR,ITYP)
DB21_MY(KR,ITYP)=B21_MY(KR,ITYP)
ENDDO
!
!Q2=0.
NR=NKR
NRM=NKR-1
! NEW DISTRIBUTION FUNCTION
DO 8 ICE=1,IND
IF(ITYP.EQ.ICE) THEN
DO KR=1,NKR
DR2N(KR,ICE)=DR2(KR,ICE)+DDEL2N*DB21_MY(KR,ICE)
R2N(KR,ICE)=DR2N(KR,ICE)
! IF (D1N.LT.0)THEN
! if (DR2N(KR,ICE).EQ.DR2(KR,ICE))THEN
! KK=NKR-KR+1
! DR2N(KR,ICE)=R2N(KR,ICE)-2.E-15/2**KK
! end if
! END IF
ENDDO
ENDIF
8 CONTINUE
! CRYSTAL DISTRIBUTION FUNCTION
DO ICE=1,IND
! ICE_TYPE
IF(ITYP.EQ.ICE) THEN
! Q2=20.*ITYPE+ICE
DO 5 KR=1,NKR
R2R(KR)=DR2(KR,ICE)
R2NR(KR)=DR2N(KR,ICE)
5 continue
! Andrei's new change 1.12.09 (start)
! IDROP=1
! IDROP=0
IF(IND.EQ.1.AND.ITYPE.EQ.1) IDROP=1
! Andrei's new change 1.12.09 (end)
CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
! Andrei's new change 1.12.09 (start)
& ,IDROP,TPN)
! Andrei's new change 1.12.09 (end)
! CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
DO KR=1,NKR
PSI2(KR,ICE)=PSI2R(KR)
ENDDO
! END OF "ICE_TYPE"
ENDIF
! END OF "CRYSTAL DISTRIBUTION FUNCTION"
ENDDO
! END OF "NEW DISTRIBUTION FUNCTION"
RETURN
END SUBROUTINE JERDFUN
!===================================================================
SUBROUTINE JERDFUN_NEW(R2,B21_MY & 2,2
& ,FI2,PSI2,DEL2N &
& ,IND,ITYPE,COL,NKR,TPN)
IMPLICIT NONE
! CRYSTALS
REAL COL,DEL2N
INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,KK,NKR,IDROP
REAL &
& R2(NKR,IND),R2N(NKR,IND) &
& ,FI2(NKR,IND),PSI2(NKR,IND)
DOUBLE PRECISION TPN
DOUBLE PRECISION B21_MY(NKR,IND)
DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
& DB21_MY(NKR,IND)
IF(IND.NE.1) THEN
ITYP=ITYPE
ELSE
ITYP=1
ENDIF
DDEL2N=DEL2N
DO KR=1,NKR
PSI2R(KR)=FI2(KR,ITYP)
FI2R(KR)=FI2(KR,ITYP)
DR2(KR,ITYP)=R2(KR,ITYP)
ENDDO
!
!Q2=0.
NR=NKR
NRM=NKR-1
! NEW DISTRIBUTION FUNCTION
! CRYSTAL DISTRIBUTION FUNCTION
DO ICE=1,IND
! ICE_TYPE
IF(ITYP.EQ.ICE) THEN
DO 5 KR=1,NKR
R2R(KR)=DR2(KR,ICE)
R2NR(KR)=DR2(KR,ICE)+B21_MY(KR,ICE)
R2N(KR,ICE)=R2NR(KR)
! IF (D1N.LT.0)THEN
! if (R2NR(KR).EQ.R2R(KR))THEN
! KK=NKR-KR+1
! R2NR(KR)=R2R(KR)-2.E-15/2**KK
! end if
! END IF
5 continue
! Andrei's new change 1.12.09 (start)
IDROP=1
! IDROP=0
CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
& ,IDROP,TPN)
! Andrei's new change 1.12.09 (end)
! CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
DO KR=1,NKR
PSI2(KR,ICE)=PSI2R(KR)
ENDDO
! END OF "ICE_TYPE"
ENDIF
! END OF "CRYSTAL DISTRIBUTION FUNCTION"
ENDDO
! END OF "NEW DISTRIBUTION FUNCTION"
RETURN
END SUBROUTINE JERDFUN_NEW
! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)
! new change 30.01.06 (start)
! SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)
SUBROUTINE JERNEWF & 4,12
(NRX,NRM,RR,FI_OLD,PSI,RN,COL,NKR, &
! Andrei's new change 1.12.09 (start)
IDROP,TPN)
! Andrei's new change 1.12.09 (end)
IMPLICIT NONE
! Andrei's new change 1.12.09 (start)
INTEGER &
KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
INTEGER NRX
DOUBLE PRECISION &
COEFF_REMAP,TPN
DOUBLE PRECISION &
CDROP(NRX),DELTA_CDROP(NRX)
! Andrei's new change 1.12.09 (end)
INTEGER &
I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
REAL &
COL
DOUBLE PRECISION &
AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
DOUBLE PRECISION &
RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
GN1,GN1P,GN2,GN3,GMAT2
DOUBLE PRECISION &
DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK
INTEGER NRM
DOUBLE PRECISION &
RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
,RRS(NKR+1),RNS(NKR+1),PSIN(NKR+1),FIN(NKR+1)
DOUBLE PRECISION &
FI_OLD(NRX)
! ANDREI (start)
! new change 7.02.06 (start)
DOUBLE PRECISION &
PSI_IM,PSI_I,PSI_IP
! ANDREI (end)
! new change 7.02.06 (end)
! Andrei's new change 1.12.09 (start)
IF(TPN.LT.273.15-7.0D0) IDROP=0
! LEAVE REMAPPING ON
! IDROP=0
! VALUES FOR SOME REMAPING VARIABLES
KRDROP_REMAP_MIN=8
KRDROP_REMAP_MAX=13
COEFF_REMAP=1.0D0/150.0D0
! Andrei's new change 1.12.09 (end)
! INITIAL VALUES FOR SOME VARIABLES
NRXP=NRX+1
DO K=1,NRX
FI(K)=FI_OLD(K)
ENDDO
DO K=1,NRX
PSI(K)=0.0D0
ENDDO
! ANDREI (start)
! new change 7.02.06 (start)
IF(RN(NRX).NE.RR(NRX)) THEN
! Kovetz-Olund method (start)
! ANDREI (end)
! new change 7.02.06 (end)
ISYM=1
IF(RN(1).LT.RR(1)) ISYM=-1
! CALCULATION OF DISTRIBUTION FUNCTION
IF(ISYM.GT.0) THEN
! CONDENSATION
RNS(NRXP)=1024.0D0*RR(NRX)
RRS(NRXP)=1024.0D0*RR(NRX)
PSIN(NRXP)=0.0D0
FIN(NRXP)=0.0D0
DO K=1,NRX
RNS(K)=RN(K)
RRS(K)=RR(K)
PSIN(K)=0.0D0
! FIN(K) - initial(before condensation) concentration of hydrometeors
FIN(K)=3.0D0*FI(K)*RR(K)*COL
ENDDO
! NUMBER OF NEW RADII POSITION IN REGULAR GRID
! RNK - new first bin mass(after condensation)
RNK=RNS(1)
DO I=1,NRX
RRI=RRS(I)
IF(RRI.GT.RNK) GOTO 3
ENDDO
3 IIN=I-1
IFIN=NRX
CONCL=0.0D0
DMASS=0.0D0
DO 6 I=IIN,IFIN
IP=I+1
IM=MAX(1,I-1)
R1=RRS(IM)
R2=RRS(I)
R3=RRS(IP)
DRM=R2-R1
DRP=R3-R2
FNEW=0.0D0
DO 7 K=1,I
FIK=FIN(K)
IF(FIK.NE.0.0D0) THEN
KM=K-1
! RNK - new bin mass(after condensation)
RNK=RNS(K)
IF(RNK.NE.R2) THEN
GMAT=0.0D0
IF(RNK.GT.R1.AND.RNK.LT.R3) THEN
IF(RNK.LT.R2) THEN
GMAT=(RNK-R1)/DRM
ELSE
GMAT=(R3-RNK)/DRP
ENDIF
ENDIF
ELSE
GMAT=1.0D0
ENDIF
FNEW=FNEW+FIK*GMAT
! in case FIK.NE.0.0D0
ENDIF
7 CONTINUE
CONCL=CONCL+FNEW
DMASS=DMASS+FNEW*R2
! PSIN(I)) - new concentration of hydrometeors after condensation
PSIN(I)=FNEW
6 CONTINUE
! NEW VALUES OF DISTRIBUTION FUNCTION
! PSI(K) - new size distribution function of hydrometeors after
! condensation, K=1,...,NRX=NKR
DO K=1,NRX
PSI(K)=PSIN(K)/3./RR(K)/COL
ENDDO
! IN CASE: ISYM.GT.0 (CONDENSATION)
ELSE
! IN CASE: ISYM.LE.0 (EVAPORATION)
RNS(1)=0.0D0
RRS(1)=0.0D0
FIN(1)=0.0D0
PSIN(1)=0.0D0
! FIN(K) - initial(before evaporation) concentration of hydrometeors
DO K=2,NRXP
KM=K-1
RNS(K)=RN(KM)
RRS(K)=RR(KM)
PSIN(K)=0.0D0
FIN(K)=3.0D0*FI(KM)*RR(KM)*COL
ENDDO
DO I=1,NRXP
IM=MAX(I-1,1)
IP=MIN(I+1,NRXP)
R1=RRS(IP)
R2=RRS(I)
R3=RRS(IM)
DRM=R1-R2
DRP=R2-R3
FNEW=0.0D0
DO K=I,NRXP
RNK=RNS(K)
IF(RNK.GE.R1) GOTO 4321
IF(RNK.GT.R3)THEN
IF(RNK.GT.R2) THEN
FNEW=FNEW+FIN(K)*(R1-RNK)/DRM
ELSE
FNEW=FNEW+FIN(K)*(RNK-R3)/DRP
ENDIF
ENDIF
ENDDO
4321 CONTINUE
! PSIN(I) - new concentration of hydrometeors after evaporation
PSIN(I)=FNEW
ENDDO
! cycle by I
! NEW VALUES OF DISTRIBUTION FUNCTION (start)
! PSI(K), 1/g/cm^3 - new size distribution function of hydrometeors
! after evaporation, K=1,...,NRX
DO K=2,NRXP
KM=K-1
R1=PSIN(K)*RR(KM)
PSINEW=PSIN(K)/3.0D0/RR(KM)/COL
IF(R1.LT.1.0D-20) PSINEW=0.0D0
PSI(KM)=PSINEW
ENDDO
! NEW VALUES OF DISTRIBUTION FUNCTION (end)
! IN CASE: ISYM.LE.0 (EVAPORATION)
ENDIF
! Andrei's new change 1.12.09 (start)
IF(I3POINT.NE.0.AND.ISYM.GT.0) THEN
! DIFFERENCE
! IF(I3POINT.NE.0) THEN
! Andrei's new change 1.12.09 (end)
DO K=1,NKR
RRS(K)=RR(K)
ENDDO
RRS(NKR+1)=RRS(NKR)*1024.0D0
DO I=1,NKR
PSI(I)=PSI(I)*RR(I)
! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
! RN(I), g - new masses after condensation or evaporation
IF(RN(I).LT.0.0D0) THEN
RN(I)=1.0D-50
FI(I)=0.0D0
ENDIF
ENDDO
DO K=1,NKR
IF(FI(K).NE.0.0D0) THEN
IF(RRS(2).LT.RN(K)) THEN
I=2
DO WHILE &
(.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
.AND.I.LT.NKR)
I=I+1
ENDDO
! ANDREI (start)
! new change 7.02.06 (start)
IF(I.LT.NKR-2) THEN
! new change 7.02.06 (end)
! ANDREI (end)
RNTMP=RN(K)
RRTMP=RRS(I)
RRP=RRS(I+1)
RRM=RRS(I-1)
RNTMP2=RN(K+1)
RRTMP2=RRS(I+1)
RRP2=RRS(I+2)
RRM2=RRS(I)
GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
(RRTMP-RRM)
GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
(RRP2-RRM2)/(RRTMP2-RRM2)
GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
(RRTMP-RRM)
GMAT=(RRP-RNTMP)/(RRP-RRTMP)
! ANDREI (start)
! new change 7.02.06 (start)
GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
(RRP-RRTMP)
GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
! Andrei's new change 1.12.09 (start)
! PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
PSI_I=PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
(GN2-GMAT)*FI(K)*RR(K)
! Andrei's new change 1.12.09 (end)
PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
IF(PSI_IM.GT.0.0D0) THEN
IF(PSI_IP.GT.0.0D0) THEN
IF(I.GT.2) THEN
! smoothing criteria
IF(PSI_IM.GT.PSI(I-2).AND.PSI_IM.LT.PSI_I &
.AND.PSI(I-2).LT.PSI(I).OR.PSI(I-2) &
.GE.PSI(I)) THEN
PSI(I-1)=PSI_IM
PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
PSI(I+1)=PSI_IP
! in case smoothing criteria
ENDIF
! in case I.GT.2
ENDIF
! in case PSI_IP.GT.0.0D0
ENDIF
! in case PSI_IM.GT.0.0D0
ENDIF
! in case I.LT.NKR-2
ENDIF
! new change 7.02.06 (end)
! ANDREI (end)
! in case RRS(2).LT.RN(K)
ENDIF
! in case FI(K).NE.0.0D0
ENDIF
1000 CONTINUE
ENDDO
! cycle by K
AOLDCON=0.0D0
ANEWCON=0.0D0
AOLDMASS=0.0D0
ANEWMASS=0.0D0
DO K=1,NKR
AOLDCON=AOLDCON+FI(K)*RR(K)
ANEWCON=ANEWCON+PSI(K)
AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
ANEWMASS=ANEWMASS+PSI(K)*RR(K)
ENDDO
! new change 8.02.06 (start)
! ANDREI (start)
! PSI(K) - new hydrometeor size distribution function(sdf)
DO K=1,NKR
PSI(K)=PSI(K)/RR(K)
ENDDO
! new change 8.02.06 (end)
! ANDREI (end)
! 3 point method (end)
! in case I3POINT.NE.0.AND.ISYM.GT.0
ENDIF
! Andrei's new change 1.12.09 (start)
IF(IDROP.NE.0.AND.ISYM.GT.0) THEN
DO K=KRDROP_REMAP_MIN,KRDROP_REMAP_MAX
CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
ENDDO
! KMAX - right boundary of drop sdf spectrum
!(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)
DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
KMAX=K
IF(PSI(K).GT.0.0D0) GOTO 2011
ENDDO
2011 CONTINUE
! Andrei start
! DO K=KMAX-1,1,-1
! Andre end
!Alex, Andrei, Barry
DO K=KMAX-1,KRDROP_REMAP_MIN,-1
!Alex, Andrei, Barry
IF(CDROP(K).GT.1.d-20) THEN
DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
IF(DELTA_CDROP(K).LT.COEFF_REMAP) THEN
CDROP(K)=CDROP(K)+CDROP(K+1)
CDROP(K+1)=0.0D0
ENDIF
ENDIF
ENDDO
DO K=KRDROP_REMAP_MIN,KMAX
PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
ENDDO
! in case IDROP.NE.0.AND.ISYM.GT.0
ENDIF
! Andrei's new change 1.12.09 (end)
! ANDREI (start)
! new change 8.02.06 (start)
! in case RN(NRX).NE.RR(NRX)
ELSE
! in case RN(NRX).EQ.RR(NRX)
DO K=1,NKR
PSI(K)=FI(K)
ENDDO
ENDIF
! new change 8.02.06 (end)
! ANDREI
RETURN
! SUBROUTINE JERNEWF
END SUBROUTINE JERNEWF
! BARRY REMOVED QP,ROR
SUBROUTINE JERRATEOLD(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
& ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
IMPLICIT NONE
INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
DOUBLE PRECISION TP,PP
REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
& CONST
REAL VR1(NKR,ID),PSINGLE,ROR
REAL &
& R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
&,RO1BL(NKR,ID),RIEC(NKR,ID) &
&,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
&,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
&,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
&,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
&,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
DOUBLE PRECISION TZERO
REAL PZERO,CF_MY,D_MYIN,RV_MY
PARAMETER (TZERO=273.150,PZERO=1.013E6)
DATA AL1/2500.,2833./
CONST=12.566372
AL1_MY(1)=2.5E10
AL1_MY(2)=2.834E10
A1_MY(1)=2.53E12
A1_MY(2)=3.41E13
BB1_MY(1)=5.42E3
BB1_MY(2)=6.13E3
CF_MY=2.4E3
D_MYIN=0.221
RV_MY=461.5E4
NRM=NKR-1
! RHS FOR "MAXWELL" EQUATION
D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
RVT=RV_MY*TP
ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
DO 1 ICE=1,ID
DO 1 KR=1,NKR
RO1=RO1BL(KR,ICE)
CONSTL=CONST*RIEC(KR,ICE)
CONSTLI(ICE)=CONSTL
VR1K=0.
VR1KL(KR,ICE)=VR1K
VENTPL=1.
VENTRL(KR,ICE)=VENTPL
FACTPL=1.
FACTRL(KR,ICE)=FACTPL
FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
R1_MY1(KR,ICE)=VENTPL*CONSTL
R11_MY(KR,ICE)=R1_MY1(KR,ICE)
!BARRY
! R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
! R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
! R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
!BARRY
! GROWTH RATE
DETL=FK1(KR,ICE)+FD1(KR,ICE)
B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
!BARRY B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
B12_MY(KR,ICE)=0
1 CONTINUE
RETURN
END SUBROUTINE JERRATEOLD
! SUBROUTINE JERRATE
!========================================================================
!BARRY CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
! * ,RW,PW,RI,PI,QW,QI
! SUBROUTINE JERNEWF
!=========================================================================
! BARRY REMOVED QP
SUBROUTINE JERRATE(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL & 20
& ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
IMPLICIT NONE
INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
DOUBLE PRECISION TP,PP
REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
& CONST
REAL VR1(NKR,ID),PSINGLE &
&,R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
&,RO1BL(NKR,ID),RIEC(NKR,ID) &
&,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
&,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
&,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
&,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
&,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
DOUBLE PRECISION TZERO
REAL PZERO,CF_MY,D_MYIN,RV_MY,DEG01,DEG03
REAL COEFF_VISCOUS,SHMIDT_NUMBER,A,B
REAL REINOLDS_NUMBER,RESHM,ROR
PARAMETER (TZERO=273.150,PZERO=1.013E6)
DATA AL1/2500.,2833./
DEG01=1./3.
DEG03=1./3.
CONST=12.566372
AL1_MY(1)=2.5E10
AL1_MY(2)=2.834E10
A1_MY(1)=2.53E12
A1_MY(2)=3.41E13
BB1_MY(1)=5.42E3
BB1_MY(2)=6.13E3
CF_MY=2.4E3
D_MYIN=0.221
RV_MY=461.5E4
NRM=NKR-1
! rhs for "maxwell" equation
! coefficient of diffusion
D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
! new change 20.04.02
! coefficient of viscousity
COEFF_VISCOUS=1.72E-2*SQRT(TP/273.)*393./(TP-120.)/ROR
! Shmidt number
SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
! Constants used for calculation of Reinolds number
A=2.*(3./4./3.141593)**DEG01
B=A/COEFF_VISCOUS
RVT=RV_MY*TP
ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
DO ICE=1,ID
DO KR=1,NKR
! Reinolds numbers
REINOLDS_NUMBER= &
& B*VR1(KR,ICE)*SQRT(1.E6/PSINGLE)* &
& (R1S(KR,ICE)/RO1BL(KR,ICE))**DEG03
RESHM=SQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER**DEG03
IF(REINOLDS_NUMBER.LT.2.5) THEN
VENTPL=1.+0.108*RESHM*RESHM
ELSE
VENTPL=0.78+0.308*RESHM
ENDIF
! new change 20.04.02 (end)
CONSTL=CONST*RIEC(KR,ICE)
CONSTLI(ICE)=CONSTL
! VR1K=0.
! VR1KL(KR,ICE)=VR1K
! new change 20.04.02 (begin)
! VENTPL=1.
! VENTRL(KR,ICE)=VENTPL
! new change 20.04.02 (end)
FACTPL=1.
FACTRL(KR,ICE)=FACTPL
FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
R1_MY1(KR,ICE)=VENTPL*CONSTL
! R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
! R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
R11_MY(KR,ICE)=R1_MY1(KR,ICE)
!BARRY R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
! growth rate
DETL=FK1(KR,ICE)+FD1(KR,ICE)
B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
!BARRY B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
B12_MY(KR,ICE)=0.
ENDDO
ENDDO
RETURN
END SUBROUTINE JERRATE
! SUBROUTINE JERRATE
!========================================================================
!BARRY CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
! * ,RW,PW,RI,PI,QW,QI
! * ,DTT,D1N,D2N,DT0L,DT0I)
SUBROUTINE JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N & 12,10
& ,RW,PW,RI,PI,QW,QI &
& ,DT,DEL1INT,DEL2INT,DT0L,DT0I)
IMPLICIT NONE
INTEGER ITYPE
REAL DEL1,DEL2,RW,PW,RI,PI,QW,QI, &
& DT,DEL1INT,DEL2INT,DT0L,DT0I,DTLIN,DTIIN
REAL DETER,DBLRW,DBLPW,DBLPI,DBLRI, &
& DBLDEL1,DBLDEL2,DBLDEL1INT,DBLDTLIN,DBLDTIIN, &
& EXPM,EXPP,ALFAMX,ALFAPX,X,ALFA,DELX,DBLDEL2INT, &
& R1RES,R2RES,R1,R2,R3,R4,R21,R11,R10,R41,R31,R30,DBLDT, &
& DBLDEL1N,DBLDEL2N
DOUBLE PRECISION DEL1N,DEL2N
DOUBLE PRECISION DEL1N_2P,DEL1INT_2P,DEL2N_2P,DEL2INT_2P
DOUBLE PRECISION EXPP_2P,EXPM_2P,ARGEXP
! BARRY
DOUBLE PRECISION RW_DP,PW_DP,PI_DP,RI_DP,X_DP,ALFA_DP
! * ,ALFAPX_DP
! Andrei's new change 9.03.10 (start)
DOUBLE PRECISION EXPM1
EXPM1(x_dp)= &
&x_dp+x_dp*x_dp/2.0D0+x_dp*x_dp*x_dp/6.0D0+x_dp*x_dp*x_dp*x_dp/24.0D0+x_dp*x_dp*x_dp*x_dp*x_dp/120.0D0
DOUBLE PRECISION DETER_MIN
! Andrei's new change 9.03.10 (start)
DOUBLE PRECISION EXP1, EXP2
! Andrei's new change 9.03.10 (end)
DTLIN=1000.E17
DTIIN=1000.E17
! Andrei's new change 9.03.10 (start)
DETER=RW*PI-PW*RI
! DETER_MIN=1.0D-20
! Andrei's new change 9.03.10 (end)
! SOLUTION
!IF(DETER.EQ.0) THEN
IF(RW.EQ.0.AND.RI.EQ.0) THEN
! NO CLOUD: WITHOUT WATER & ICE
DEL1N_2P=DEL1
DEL2N_2P=DEL2
DEL1INT_2P=DEL1*DT
DEL2INT_2P=DEL2*DT
! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
ELSE IF(RW.NE.0.AND.RI*1.E5.LT.RW) THEN
! ONLY WATER
ARGEXP=-RW*DT
DEL1N_2P=DEL1*DEXP(ARGEXP)+QW*(1.-DEXP(ARGEXP))
DEL1INT_2P=(DEL1-DEL1N_2P)/RW
DEL2N_2P=DEL2-PW*DEL1INT_2P
DEL2INT_2P= &
& (DEL2N_2P-PW*DEL1N_2P/RW)*DT+PW*DEL1INT_2P/RW
ELSE IF(RI.NE.0.AND.RW*1.E5.LT.RI) THEN
! IN CASE: RW.EQ.0
! ONLY ICE
ARGEXP=-PI*DT
DEL2N_2P=DEL2*DEXP(ARGEXP)+QI*(1.-DEXP(ARGEXP))
DEL2INT_2P=(DEL2-DEL2N_2P)/PI
DEL1N_2P=DEL1-RI*DEL2INT_2P
DEL1INT_2P= &
& (DEL1N_2P-RI*DEL2N_2P/PI)*DT+RI*DEL2INT_2P/PI
! GOTO 100
! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
! IN CASE: DETER.EQ.0
ELSE
! IN CASE: DETER.NE.0
! COMPLETE SOLUTION
! ALFA=SQRT((RW-PI)*(RW-PI)+4.*PW*RI)
! X=RW+PI
! ALFAPX=.5*(ALFA+X)
! BARRY
RW_DP=RW
RI_DP=RI
PI_DP=PI
PW_DP=PW
IF (RW.LE.0)PRINT*,'RW = ',RW
IF (PW.LE.0)PRINT*,'PW = ',PW
IF (RI.LE.0)PRINT*,'RI = ',RI
IF (PI.LE.0)PRINT*,'PI = ',PI
IF (RW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RW.LE.0), model stop")
IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PW.LE.0), model stop")
IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RI.LE.0), model stop")
IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PI.LE.0), model stop")
ALFA_DP=SQRT((RW_DP-PI_DP)*(RW_DP-PI_DP)+4.*PW_DP*RI_DP)
X_DP=RW_DP+PI_DP
ALFAPX=.5*(ALFA_DP+X_DP)
IF (ALFAPX.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (ALFAPX.LE.0), model stop")
ALFAMX=.5*(ALFA_DP-X_DP)
!
!
ARGEXP=-ALFAPX*DT
! Andrei 11/04/10
EXPP_2P=DEXP(ARGEXP)
IF(DABS(ARGEXP).LE.1.0E-6) THEN
EXP1=EXPM1(ARGEXP)
ELSE
EXP1=EXPP_2P-1.0D0
ENDIF
!
ARGEXP=ALFAMX*DT
!Andre 11/04/10
EXPM_2P=DEXP(ARGEXP)
IF(DABS(ARGEXP).LE.1.0E-6) THEN
EXP2=EXPM1(ARGEXP)
ELSE
EXP2=EXPM_2P-1.0D0
ENDIF
!
! DROPLETS
R10=RW*DEL1+RI*DEL2
R11=R10-ALFAPX*DEL1
R21=R10+ALFAMX*DEL1
DEL1N_2P=(R21*EXPP_2P-R11*EXPM_2P)/ALFA_DP
! BARRY
IF(ALFAMX.NE.0) THEN
R1=-R11/ALFAMX
R2=R21/ALFAPX
! DEL1INT_2P=(R1*(EXPM_2P-1.)-R2*(EXPP_2P-1.))/ALFA_DP
DEL1INT_2P=(R1*EXP2-R2*EXP1)/ALFA_DP
ELSE
DEL1INT_2P = 0.
ENDIF
! BARRY
R1RES=0.
IF(R11.NE.0) R1RES=R21/R11
IF(R1RES.GT.0) DTLIN=ALOG(R1RES)/ALFA_DP
! ICE
R30=PW*DEL1+PI*DEL2
R31=R30-ALFAPX*DEL2
R41=R30+ALFAMX*DEL2
! BARRY
DEL2N_2P=(R41*EXPP_2P-R31*EXPM_2P)/ALFA_DP
IF(ALFAMX.NE.0.AND.ALFAPX.NE.0) THEN
R3=-R31/ALFAMX
R4=R41/ALFAPX
! DEL2INT_2P=(R3*(EXPM_2P-1.)-R4*(EXPP_2P-1.))/ALFA_DP
DEL2INT_2P=(R3*EXP2-R4*EXP1)/ALFA_DP
ELSE
DEL2INT_2P=0.
ENDIF
R2RES=0.
IF(R31.NE.0) R2RES=R41/R31
IF(R2RES.GT.0) DTIIN=ALOG(R2RES)/ALFA_DP
! IN CASE: DETER.NE.0
! END OF COMPLETE SOLUTION
ENDIF
! IN CASES: DETER.EQ.0 OR DETER.NE.0
100 CONTINUE
DEL1N=DEL1N_2P
DEL2N=DEL2N_2P
! BARRY
DEL1INT=DEL1INT_2P
DEL2INT=DEL2INT_2P
DT0L=DTLIN
IF(DT0L.LT.0) DT0L=1.E20
DT0I=DTIIN
IF(DT0I.LT.0) DT0I=1.E20
RETURN
END SUBROUTINE JERSUPSAT
!==========================================================================
SUBROUTINE JERTIMESC(FI1,X1,SFN11,SFN12 & 16
& ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)
IMPLICIT NONE
INTEGER NRM,KR,ICE,ID,NKR
REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
REAL COL, &
& X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
&,RIEC(NKR,ID),SFN11,SFN12
NRM=NKR-1
DO 1 ICE=1,ID
SFN11S=0.
SFN12S=0.
SFN11=CF*SFN11S
SFN12=CF*SFN12S
DO KR=1,NRM
! VALUE OF DISTRIBUTION FUNCTION
FK=FI1(KR,ICE)
! DELTA-M
DELM=X1(KR,ICE)*3.*COL
! INTEGRAL'S EXPRESSION
FUN=FK*DELM
! VALUES OF INTEGRALS
B11=B11_MY(KR,ICE)
B12=B12_MY(KR,ICE)
SFN11S=SFN11S+FUN*B11
SFN12S=SFN12S+FUN*B12
ENDDO
! CORRECTION
SFN11=CF*SFN11S
SFN12=CF*SFN12S
1 CONTINUE
! END
RETURN
END SUBROUTINE JERTIMESC
!
SUBROUTINE JERTIMESC_ICE(FI1,X1,SFN11,SFN12 & 4
& ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)
IMPLICIT NONE
INTEGER NRM,KR,ICE,ID,NKR
REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
REAL COL, &
& X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
&,RIEC(NKR,ID),SFN11(ID),SFN12(ID)
NRM=NKR-1
DO 1 ICE=1,ID
SFN11S=0.
SFN12S=0.
SFN11(ICE)=CF*SFN11S
SFN12(ICE)=CF*SFN12S
DO KR=1,NRM
! VALUE OF DISTRIBUTION FUNCTION
FK=FI1(KR,ICE)
! DELTA-M
DELM=X1(KR,ICE)*3.*COL
! INTEGRAL'S EXPRESSION
FUN=FK*DELM
! VALUES OF INTEGRALS
B11=B11_MY(KR,ICE)
B12=B12_MY(KR,ICE)
SFN11S=SFN11S+FUN*B11
SFN12S=SFN12S+FUN*B12
ENDDO
! CORRECTION
SFN11(ICE)=CF*SFN11S
SFN12(ICE)=CF*SFN12S
1 CONTINUE
! END
RETURN
END SUBROUTINE JERTIMESC_ICE
SUBROUTINE ONECOND2 & 2,56
& (TT,QQ,PP,ROR &
& ,VR2,VR3,VR4,VR5,PSINGLE &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,FF2,PSI2,R2,RIEC,RO2BL &
& ,FF3,PSI3,R3,RSEC,RO3BL &
& ,FF4,PSI4,R4,RGEC,RO4BL &
& ,FF5,PSI5,R5,RHEC,RO5BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR &
& ,ISYM2,ISYM3,ISYM4,ISYM5)
IMPLICIT NONE
INTEGER NKR,ICEMAX
REAL COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
& ,VR5(NKR),PSINGLE &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,DTCOND
REAL C1_MEY,C2_MEY
INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
& KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
& ISYM2,ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
& KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
& NCRITI
REAL AL1,AL2,D,GAM,POD, &
& RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
& A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
& TPC1, TPC2, TPC3, TPC4, TPC5, &
& EPSDEL, DT0L, DT0I, &
& ROR, &
& DEL1NUC,DEL2NUC, &
& CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
& DEL1,DEL2,DEL1S,DEL2S, &
& TIMENEW,TIMEREV,SFN11,SFN12, &
& SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
& PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
& DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
& SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
& DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
& SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
& DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
& DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI
REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
& DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
INTEGER K
! NEW ALGORITHM OF CONDENSATION (12.01.00)
DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
& ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
& ,R1_K,R2_K,R3_K,R4_K,R5_K &
& ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
& ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
& ,ES1N,ES2N,EW1N,ARGEXP &
& ,TT,QQ,PP &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,OPER2,OPER3,AR1,AR2
DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
CHARACTER*70 CPRINT
! CRYSTALS
REAL R2(NKR,ICEMAX) &
& ,RIEC(NKR,ICEMAX) &
& ,RO2BL(NKR,ICEMAX) &
& ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
& ,FF2(NKR,ICEMAX) &
& ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)
! SNOW
REAL R3(NKR) &
& ,RSEC(NKR),RO3BL(NKR) &
& ,FI3(NKR),FF3(NKR),PSI3(NKR) &
& ,B31_MY(NKR),B32_MY(NKR)
! GRAUPELS
REAL R4(NKR) &
& ,RGEC(NKR),RO4BL(NKR) &
& ,FI4(NKR),FF4(NKR),PSI4(NKR) &
& ,B41_MY(NKR),B42_MY(NKR)
! HAIL
REAL R5(NKR) &
& ,RHEC(NKR),RO5BL(NKR) &
& ,FI5(NKR),FF5(NKR),PSI5(NKR) &
& ,B51_MY(NKR),B52_MY(NKR)
! CCN
! WORK ARRAYS
! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
REAL DTIMEG(NKR),DTIMEH(NKR)
REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
! NEW ALGORITHM (NO TYPE OF ICE)
& ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
& ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
& ,TIMESTEPD(NKR) &
& ,FI1REF(NKR),PSI1REF(NKR) &
& ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
& ,FCCNRREF(NKR)
OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
& ,GAM /1.E-4/, POD /10./
DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
& /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
& /2.53,5.42,3.41E1,6.13/
DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
& /-4.0,-8.1,-12.7,-17.8,-22.4/
DATA EPSDEL/0.1E-03/
DATA DT0L, DT0I /1.E20,1.E20/
! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
I_MIXCOND=0
I_MIXEVAP=0
I_ABERGERON=0
I_BERGERON=0
! SOME CONSTANTS
COL3=3.0*COL
ICM=ICEMAX
ITIME=0
KCOND=0
DT_WATER_COND=0.4
DT_WATER_EVAP=0.4
DT_ICE_COND=0.4
DT_ICE_EVAP=0.4
DT_MIX_COND=0.4
DT_MIX_EVAP=0.4
DT_MIX_BERGERON=0.4
DT_MIX_ANTIBERGERON=0.4
ICM=ICEMAX
ITIME=0
KCOND=0
DT0LREF=0.2
DTLREF=0.4
NR=NKR
NRM=NKR-1
DT=DTCOND
DTT=DTCOND
XRAD=0.
! BARRY
CWHUCM=0.
XRAD=0.
B6=CWHUCM*GAM-XRAD
B8L=1./ROR
B8I=1./ROR
RORI=1./ROR
! INITIALIZATION OF SOME ARRAYS
! BARRY
TPN=TT
QPN=QQ
! TYPE OF ICE IN DIFFUSIONAL GROWTH
DO ICE=1,ICEMAX
SFNI1(ICE)=0.
SFNI2(ICE)=0.
DEL2D(ICE)=0.
ENDDO
! TIME SPLITTING
TIMENEW=0.
ITIME=0
! ONLY ICE (CONDENSATION OR EVAPORATION) :
46 ITIME=ITIME+1
TIMEREV=DT-TIMENEW
DEL1=DEL1N
DEL2=DEL2N
DEL1S=DEL1N
DEL2S=DEL2N
DEL2D(1)=DEL2N
DEL2D(2)=DEL2N
DEL2D(3)=DEL2N
TPS=TPN
QPS=QPN
DO KR=1,NKR
FI3(KR)=PSI3(KR)
FI4(KR)=PSI4(KR)
FI5(KR)=PSI5(KR)
DO ICE=1,ICEMAX
FI2(KR,ICE)=PSI2(KR,ICE)
ENDDO
ENDDO
! TIME-STEP GROWTH RATE:
! ONLY ICE (CONDENSATION OR EVAPORATION)
CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
& ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
& ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
& ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
& ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
! INTEGRALS IN DELTA EQUATION
! CALL JERTIMESC CRYSTAL - 1 (ONLY ICE)
CALL JERTIMESC_ICE &
& (FI2,R2,SFNI1,SFNI2,B21_MY,B22_MY,RIEC,B8I,ICM,COL,NKR)
CALL JERTIMESC &
& (FI3,R3,SFN31,SFN32,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
CALL JERTIMESC &
& (FI4,R4,SFN41,SFN42,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
CALL JERTIMESC &
& (FI5,R5,SFN51,SFN52,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
SFN21=SFNII1+SFN31+SFN41+SFN51
SFN22=SFNII2+SFN32+SFN42+SFN52
SFNL=0.
SFNI=SFN21+SFN22
! SOME CONSTANTS
B5L=BB1_MY/TPS/TPS
B5I=BB2_MY/TPS/TPS
B7L=B5L*B6
B7I=B5I*B6
DOPL=1.+DEL1S
DOPI=1.+DEL2S
OPERQ=OPER2(QPS)
RW=(OPERQ+B5L*AL1)*DOPL*SFNL
QW=B7L*DOPL
PW=(OPERQ+B5I*AL1)*DOPI*SFNL
RI=(OPERQ+B5L*AL2)*DOPL*SFNI
PI=(OPERQ+B5I*AL2)*DOPI*SFNI
QI=B7I*DOPI
KCOND=20
IF(DEL2.GT.0) KCOND=21
! PROCESS'S TYPE (ONLY ICE)
IF(KCOND.EQ.21) THEN
! ONLY_ICE: CONDENSATION
DT0I=1.E20
DTNEWI1=DTCOND
DTNEWL=DTNEWI1
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (ONLY_ICE: CONDENSATION)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMESTEPD(ITIME)=DTNEWL
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
! SOLVING FOR SUPERSATURATION (ONLY ICE: CONDENSATION)
! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)
CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N,D2N,DT0L0,DT0I0)
! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)
! CRYSTALS (ONLY ICE: CONDENSATION)
IF(ISYM2.NE.0) THEN
! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION)
! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)
! NEW ALGORITHM (NO TYPE ICE)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,1,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,2,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,3,COL,NKR,TPN)
! IN CASE : ISYM2.NE.0
ENDIF
! SNOW
IF(ISYM3.NE.0) THEN
! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION)
! CALL JERDFUN SNOW - 1 (ONLY ICE: CONDENSATION)
CALL JERDFUN(R3,B31_MY,B32_MY &
& ,FI3,PSI3,D2N &
& ,1,3,COL,NKR,TPN)
ENDIF
! IN CASE : ISYM4.NE.0
! GRAUPELS (ONLY_ICE: EVAPORATION)
IF(ISYM4.NE.0) THEN
! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
CALL JERDFUN(R4,B41_MY,B42_MY &
& ,FI4,PSI4,D2N &
& ,1,4,COL,NKR,TPN)
! IN CASE : ISYM4.NE.0
ENDIF
! HAIL (ONLY ICE: CONDENSATION)
IF(ISYM5.NE.0) THEN
! HAIL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION)
! CALL JERDFUN HAIL - 1 (ONLY ICE: CONDENSATION)
CALL JERDFUN(R5,B51_MY,B52_MY &
& ,FI5,PSI5,D2N &
& ,1,5,COL,NKR,TPN)
! IN CASE : ISYM5.NE.0
ENDIF
IF((DEL2.GT.0.AND.DEL2N.LT.0) &
& .AND.ABS(DEL2N).GT.EPSDEL) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
ENDIF
ELSE
! IN CASE KCOND.NE.21
! ONLY ICE: EVAPORATION
! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION)
DT0I=1.E20
IF (DEL2N.EQ.0)THEN
DTNEWL=DT
ELSE
DTNEWI3=-R3(3)/(B31_MY(3)*DEL2N-B32_MY(3))
DTNEWI4=-R4(3)/(B41_MY(3)*DEL2N-B42_MY(3))
DTNEWI5=-R5(3)/(B51_MY(3)*DEL2N-B52_MY(3))
! NEW ALGORITHM (NO TYPE OF ICE)
DTNEWI2_1=-R2(3,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
DTNEWI2_2=-R2(3,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
DTNEWI2_3=-R2(3,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
& ,DTNEWI5,DT0I,TIMEREV)
DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
DTNEWL=DTNEWI1
IF(DTNEWL.LT.DTLREF) DTNEWL=AMIN1(DTLREF,TIMEREV)
END IF
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (ONLY_ICE: EVAPORATION)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMENEW=TIMENEW+DTNEWL
TIMESTEPD(ITIME)=DTNEWL
DTT=DTNEWL
! SOLVING FOR SUPERSATURATION (ONLY_ICE: EVAPORATION)
CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N,D2N,DT0L0,DT0I0)
! END OF "NEW SUPERSATURATION" (ONLY_ICE: EVAPORATION)
! CRYSTALS
IF(ISYM2.NE.0) THEN
! CRYSTAL DISTRIBUTION FUNCTION
! NEW ALGORITHM (NO TYPE ICE)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,1,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,2,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICM,3,COL,NKR,TPN)
ENDIF
! SNOW
IF(ISYM3.NE.0) THEN
! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)
CALL JERDFUN(R3,B31_MY,B32_MY &
& ,FI3,PSI3,D2N &
& ,1,3,COL,NKR,TPN)
! IN CASE : ISYM3.NE.0
ENDIF
! GRAUPELS (ONLY_ICE: EVAPORATION)
IF(ISYM4.NE.0) THEN
! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
CALL JERDFUN(R4,B41_MY,B42_MY &
& ,FI4,PSI4,D2N &
& ,1,4,COL,NKR,TPN)
! IN CASE : ISYM4.NE.0
ENDIF
! HAIL (ONLY_ICE: EVAPORATION)
IF(ISYM5.NE.0) THEN
! HAIL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
CALL JERDFUN(R5,B51_MY,B52_MY &
& ,FI5,PSI5,D2N &
& ,1,5,COL,NKR,TPN)
! IN CASE : ISYM5.NE.0
ENDIF
IF((DEL2.LT.0.AND.DEL2N.GT.0) &
& .AND.ABS(DEL2N).GT.EPSDEL) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.LT.0.AND.DEL2N.GT.0), model stop")
ENDIF
! IN CASE : KCOND.NE.21
ENDIF
! IN CASES : KCOND = 21 OR KCOND.NE.21
! END OF "PROCESS'S TYPE"
!
! MASSES
RMASSIBB=0.0
RMASSIAA=0.0
! BEFORE JERNEWF
DO K=1,NKR
DO ICE =1,ICEMAX
FI2_K=FI2(K,ICE)
R2_K=R2(K,ICE)
FI2R2=FI2_K*R2_K*R2_K
RMASSIBB=RMASSIBB+FI2R2
ENDDO
FI3_K=FI3(K)
FI4_K=FI4(K)
FI5_K=FI5(K)
R3_K=R3(K)
R4_K=R4(K)
R5_K=R5(K)
FI3R3=FI3_K*R3_K*R3_K
FI4R4=FI4_K*R4_K*R4_K
FI5R5=FI5_K*R5_K*R5_K
RMASSIBB=RMASSIBB+FI3R3
RMASSIBB=RMASSIBB+FI4R4
RMASSIBB=RMASSIBB+FI5R5
ENDDO
RMASSIBB=RMASSIBB*COL3*RORI
! NEW CHANGE RMASSIBB
IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
! AFTER JERNEWF
DO K=1,NKR
DO ICE =1,ICEMAX
FI2_K=PSI2(K,ICE)
R2_K=R2(K,ICE)
FI2R2=FI2_K*R2_K*R2_K
RMASSIAA=RMASSIAA+FI2R2
ENDDO
FI3_K=PSI3(K)
FI4_K=PSI4(K)
FI5_K=PSI5(K)
R3_K=R3(K)
R4_K=R4(K)
R5_K=R5(K)
FI3R3=FI3_K*R3_K*R3_K
FI4R4=FI4_K*R4_K*R4_K
FI5R5=FI5_K*R5_K*R5_K
RMASSIAA=RMASSIAA+FI3R3
RMASSIAA=RMASSIAA+FI4R4
RMASSIAA=RMASSIAA+FI5R5
ENDDO
RMASSIAA=RMASSIAA*COL3*RORI
! NEW CHANGE RMASSIAA
IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
! NEW TREATMENT OF "T" & "Q"
DELMASSI1=RMASSIAA-RMASSIBB
QPN=QPS-DELMASSI1
DAL2=AL2
TPN=TPS+DAL2*DELMASSI1
! SUPERSATURATION
ARGEXP=-BB1_MY/TPN
ES1N=AA1_MY*DEXP(ARGEXP)
ARGEXP=-BB2_MY/TPN
ES2N=AA2_MY*DEXP(ARGEXP)
EW1N=OPER3(QPN,PP)
IF(ES1N.EQ.0)THEN
DEL1N=0.5
DIV1=1.5
call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
ELSE
DIV1=EW1N/ES1N
DEL1N=EW1N/ES1N-1.
END IF
IF(ES2N.EQ.0)THEN
DEL2N=0.5
DIV2=1.5
call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
ELSE
DEL2N=EW1N/ES2N-1.
DIV2=EW1N/ES2N
END IF
! END OF TIME SPLITTING
! (ONLY ICE: CONDENSATION OR EVAPORATION)
IF(TIMENEW.LT.DT) GOTO 46
TT=TPN
QQ=QPN
DO KR=1,NKR
DO ICE=1,ICEMAX
FF2(KR,ICE)=PSI2(KR,ICE)
ENDDO
FF3(KR)=PSI3(KR)
FF4(KR)=PSI4(KR)
FF5(KR)=PSI5(KR)
ENDDO
! GO TO "CONDENSATION AND VAPORATION"
RETURN
END SUBROUTINE ONECOND2
!==================================================================
SUBROUTINE ONECOND3 & 2,44
& (TT,QQ,PP,ROR &
& ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,FF1,PSI1,R1,RLEC,RO1BL &
& ,FF2,PSI2,R2,RIEC,RO2BL &
& ,FF3,PSI3,R3,RSEC,RO3BL &
& ,FF4,PSI4,R4,RGEC,RO4BL &
& ,FF5,PSI5,R5,RHEC,RO5BL &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND,ICEMAX,NKR &
& ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
IMPLICIT NONE
INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
& ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
& KLIMITI_2,KLIMITI_3
INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON
REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
& ,VR5(NKR),PSINGLE &
& ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
& ,C1_MEY,C2_MEY &
& ,COL,DTCOND
! DROPLETS
REAL R1(NKR)&
& ,RLEC(NKR),RO1BL(NKR) &
& ,FI1(NKR),FF1(NKR),PSI1(NKR) &
& ,B11_MY(NKR),B12_MY(NKR)
! CRYSTALS
REAL R2(NKR,ICEMAX) &
& ,RIEC(NKR,ICEMAX) &
& ,RO2BL(NKR,ICEMAX) &
& ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
& ,FF2(NKR,ICEMAX) &
& ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
& ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)
! SNOW
REAL R3(NKR) &
& ,RSEC(NKR),RO3BL(NKR) &
& ,FI3(NKR),FF3(NKR),PSI3(NKR) &
& ,B31_MY(NKR),B32_MY(NKR) &
& ,DEL_R3M(NKR)
! GRAUPELS
REAL R4(NKR),R4N(NKR) &
& ,RGEC(NKR),RO4BL(NKR) &
& ,FI4(NKR),FF4(NKR),PSI4(NKR) &
& ,B41_MY(NKR),B42_MY(NKR) &
& ,DEL_R4M(NKR)
! HAIL
REAL R5(NKR),R5N(NKR) &
& ,RHEC(NKR),RO5BL(NKR) &
& ,FI5(NKR),FF5(NKR),PSI5(NKR) &
& ,B51_MY(NKR),B52_MY(NKR) &
& ,DEL_R5M(NKR)
DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
& ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
& ,R1_K,R2_K,R3_K,R4_K,R5_K &
& ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
& ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
& ,ES1N,ES2N,EW1N,ARGEXP &
& ,TT,QQ,PP,DEL1N0,DEL2N0 &
& ,DEL1N,DEL2N,DIV1,DIV2 &
& ,OPER2,OPER3,AR1,AR2
DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
& /2.53,5.42,3.41E1,6.13/
REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
& RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
& SFN52
REAL DEL1,DEL2
REAL TIMEREV,DT,DTT,TIMENEW
REAL DTIMEG(NKR),DTIMEH(NKR)
REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
& ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
& DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
& DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
& DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
REAL TIMESTEPD(NKR)
DATA AL1 /2500./, AL2 /2834./
REAL EPSDEL,EPSDEL2
DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
! BELOW
!
DT_WATER_COND=0.4
DT_WATER_EVAP=0.4
DT_ICE_COND=0.4
DT_ICE_EVAP=0.4
DT_MIX_COND=0.4
DT_MIX_EVAP=0.4
DT_MIX_BERGERON=0.4
DT_MIX_ANTIBERGERON=0.4
I_MIXCOND=0
I_MIXEVAP=0
I_ABERGERON=0
I_BERGERON=0
ITIME = 0
TIMENEW=0.
DT=DTCOND
DTT=DTCOND
B6=0.
B8L=1./ROR
B8I=1./ROR
! NEW CHANGES 19.04.01 (BEGIN)
RORI=1.D0/ROR
! NEW CHANGES 19.04.01 (END)
! NEW CHANGES 19.04.01 (BEGIN)
COL3=3.D0*COL
! NEW CHANGES 19.04.01 (END)
! BARRY:DIV
TPN=TT
QPN=QQ
! HERE
16 ITIME=ITIME+1
! BARRY
! TPC_NEW=TPN-273.15
IF((TPN-273.15).GE.-0.187) GO TO 17
TIMEREV=DT-TIMENEW
DEL1=DEL1N
DEL2=DEL2N
DEL1S=DEL1N
DEL2S=DEL2N
! NEW ALGORITHM (NO TYPE ICE)
DEL2D(1)=DEL2N
DEL2D(2)=DEL2N
DEL2D(3)=DEL2N
TPS=TPN
QPS=QPN
DO KR=1,NKR
FI1(KR)=PSI1(KR)
FI3(KR)=PSI3(KR)
FI4(KR)=PSI4(KR)
FI5(KR)=PSI5(KR)
DO ICE=1,ICEMAX
FI2(KR,ICE)=PSI2(KR,ICE)
ENDDO
ENDDO
! TIME-STEP GROWTH RATE
! HERE
CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
& ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
& ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
& ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
& ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
& ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
& ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
CALL JERTIMESC_ICE(FI2,R2,SFNI1,SFNI2 &
& ,B21_MY,B22_MY,RIEC,B8I,ICEMAX,COL,NKR)
CALL JERTIMESC(FI3,R3,SFN31,SFN32 &
& ,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
CALL JERTIMESC(FI4,R4,SFN41,SFN42 &
& ,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
CALL JERTIMESC(FI5,R5,SFN51,SFN52 &
& ,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
! NEW ALGORITHM (NO TYPE ICE)
SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
SFN21=SFNII1+SFN31+SFN41+SFN51
SFN22=SFNII2+SFN32+SFN42+SFN52
SFNL=SFN11+SFN12
SFNI=SFN21+SFN22
! SOME CONSTANTS (QW,QI=0,since B6=0.)
B5L=BB1_MY/TPS/TPS
B5I=BB2_MY/TPS/TPS
B7L=B5L*B6
B7I=B5I*B6
DOPL=1.+DEL1S
DOPI=1.+DEL2S
RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
QW=B7L*DOPL
PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
QI=B7I*DOPI
! SOLVING FOR TIMEZERO
CALL JERSUPSAT(DEL1,DEL2,DEL1N0,DEL2N0 &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N0,D2N0,DT0L,DT0I)
! DEL1 > 0, DEL2 < 0 (ANTIBERGERON MIXED PHASE - KCOND=50)
! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
! DEL1 < 0, DEL2 > 0 (BERGERON MIXED PHASE - KCOND=32)
KCOND=50
IF(DEL1.LT.0.AND.DEL2.LT.0) KCOND=30
IF(DEL1.GT.0.AND.DEL2.GT.0) KCOND=31
IF(DEL1.LT.0.AND.DEL2.GT.0) KCOND=32
IF(KCOND.EQ.50) THEN
I_ABERGERON=I_ABERGERON+1
IF(DT0L.EQ.0) THEN
DTNEWL=DT
ELSE
DTNEWL=AMIN1(DT,DT0L)
ENDIF
! NEW TIME STEP (ANTIBERGERON MIXED PHASE)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! ANTIBERGERON MIXED PHASE (BEGIN)
! IN CASE : KCOND = 50
ENDIF
IF(KCOND.EQ.31) THEN
! CONDENSATION MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
I_MIXCOND=I_MIXCOND+1
IF (DEL1N.EQ.0)THEN
DTNEWL0=DT
ELSE
DTNEWL0=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N- &
& B12_MY(ITIME)))
END IF
! NEW ALGORITHM (NO TYPE OF ICE)
IF (DEL2N.EQ.0)THEN
DTNEWI2_1=DT
DTNEWI2_2=DT
DTNEWI2_3=DT
DTNEWI3=DT
DTNEWI4=DT
DTNEWI5=DT
ELSE
DTNEWI2_1=ABS(R2(ITIME,1)/ &
& (B21_MY(ITIME,1)*DEL2N-B22_MY(ITIME,1)))
DTNEWI2_2=ABS(R2(ITIME,2)/ &
& (B21_MY(ITIME,2)*DEL2N-B22_MY(ITIME,2)))
DTNEWI2_3=ABS(R2(ITIME,3)/ &
& (B21_MY(ITIME,3)*DEL2N-B22_MY(ITIME,3)))
DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
DTNEWI3=ABS(R3(ITIME)/(B31_MY(ITIME)*DEL2N- &
& B32_MY(ITIME)))
DTNEWI4=ABS(R4(ITIME)/(B41_MY(ITIME)*DEL2N- &
& B42_MY(ITIME)))
DTNEWI5=ABS(R5(ITIME)/(B51_MY(ITIME)*DEL2N- &
& B52_MY(ITIME)))
END IF
DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I)
IF(DT0L.NE.0) THEN
IF(ABS(DT0L).LT.DT_MIX_COND) THEN
DTNEWL1=AMIN1(DT_MIX_COND,DTNEWL0)
ELSE
DTNEWL1=AMIN1(DT0L,DTNEWL0)
ENDIF
ELSE
DTNEWL1=DTNEWL0
ENDIF
DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (CONDENSATION MIXED PHASE)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMENEW=TIMENEW+DTNEWL
TIMESTEPD(ITIME)=DTNEWL
DTT=DTNEWL
! CONDENSATION MIXED PHASE (END)
! IN CASE : KCOND = 31
ENDIF
IF(KCOND.EQ.30) THEN
! EVAPORATION MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
I_MIXEVAP=I_MIXEVAP+1
DO KR=1,NKR
DTIMEL(KR)=0.
DTIMEG(KR)=0.
DTIMEH(KR)=0.
! NEW ALGORITHM (NO TYPE ICE)
DTIMEI_1(KR)=0.
DTIMEI_2(KR)=0.
DTIMEI_3(KR)=0.
ENDDO
DO KR=1,NKR
IF (DEL1N.EQ.0) THEN
DTIMEL(KR)=DT
DTIMEG(KR)=DT
DTIMEH(KR)=DT
ELSE
DTIMEL(KR)=-R1(KR)/(B11_MY(KR)*DEL1N- &
& B12_MY(KR))
DTIMEG(KR)=-R4(KR)/(B41_MY(KR)*DEL1N- &
& B42_MY(KR))
DTIMEH(KR)=-R5(KR)/(B51_MY(KR)*DEL1N- &
& B52_MY(KR))
! NEW ALGORITHM (NO TYPE OF ICE)
END IF
IF (DEL2N.EQ.0) THEN
DTIMEI_1(KR)=DT
DTIMEI_2(KR)=DT
DTIMEI_3(KR)=DT
ELSE
DTIMEI_1(KR)=-R2(KR,1)/ &
& (B21_MY(KR,1)*DEL2N-B22_MY(KR,1))
DTIMEI_2(KR)=-R2(KR,2)/ &
& (B21_MY(KR,2)*DEL2N-B22_MY(KR,2))
DTIMEI_3(KR)=-R2(KR,3)/ &
& (B21_MY(KR,3)*DEL2N-B22_MY(KR,3))
END IF
ENDDO
! WATER
KLIMITL=1
DO KR=1,NKR
IF(DTIMEL(KR).GT.TIMEREV) GOTO 355
KLIMITL=KR
ENDDO
355 KLIMITL=KLIMITL-1
IF(KLIMITL.LT.1) KLIMITL=1
DTNEWL1=AMIN1(DTIMEL(KLIMITL),DT0L,TIMEREV)
! GRAUPELS
KLIMITG=1
DO KR=1,NKR
IF(DTIMEG(KR).GT.TIMEREV) GOTO 455
KLIMITG=KR
ENDDO
455 KLIMITG=KLIMITG-1
IF(KLIMITG.LT.1) KLIMITG=1
DTNEWG1=AMIN1(DTIMEG(KLIMITG),TIMEREV)
! HAIL
KLIMITH=1
DO KR=1,NKR
IF(DTIMEH(KR).GT.TIMEREV) GOTO 555
KLIMITH=KR
ENDDO
555 KLIMITH=KLIMITH-1
IF(KLIMITH.LT.1) KLIMITH=1
DTNEWH1=AMIN1(DTIMEH(KLIMITH),TIMEREV)
! ICE CRYSTALS
! NEW ALGORITHM (NO TYPE OF ICE) (BEGIN)
KLIMITI_1=1
KLIMITI_2=1
KLIMITI_3=1
DO KR=1,NKR
IF(DTIMEI_1(KR).GT.TIMEREV) GOTO 655
KLIMITI_1=KR
ENDDO
655 CONTINUE
DO KR=1,NKR
IF(DTIMEI_2(KR).GT.TIMEREV) GOTO 656
KLIMITI_2=KR
ENDDO
656 CONTINUE
DO KR=1,NKR
IF(DTIMEI_3(KR).GT.TIMEREV) GOTO 657
KLIMITI_3=KR
ENDDO
657 CONTINUE
KLIMITI_1=KLIMITI_1-1
IF(KLIMITI_1.LT.1) KLIMITI_1=1
DTNEWI2_1=AMIN1(DTIMEI_1(KLIMITI_1),TIMEREV)
KLIMITI_2=KLIMITI_2-1
IF(KLIMITI_2.LT.1) KLIMITI_2=1
DTNEWI2_2=AMIN1(DTIMEI_2(KLIMITI_2),TIMEREV)
KLIMITI_3=KLIMITI_3-1
IF(KLIMITI_3.LT.1) KLIMITI_3=1
DTNEWI2_3=AMIN1(DTIMEI_3(KLIMITI_3),TIMEREV)
DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
! NEW ALGORITHM (NO TYPE OF ICE) (END)
DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1,DT0I)
IF(ABS(DEL2N).LT.EPSDEL2) &
& DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1)
DTNEWL2=AMIN1(DTNEWL1,DTNEWI1)
DTNEWL=DTNEWL2
IF(DTNEWL.LT.DT_MIX_EVAP) &
& DTNEWL=AMIN1(DT_MIX_EVAP,TIMEREV)
IF(ITIME.GE.NKR) THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
ENDIF
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (EVAPORATION MIXED PHASE)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT &
& .AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMESTEPD(ITIME)=DTNEWL
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
! EVAPORATION MIXED PHASE (END)
! IN CASE : KCOND = 30
ENDIF
IF(KCOND.EQ.32) THEN
! BERGERON MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
I_BERGERON=I_BERGERON+1
! NEW TREATMENT OF TIME STEP (BERGERON MIXED PHASE)
IF (DEL1N.EQ.0)THEN
DTNEWL0=DT
ELSE
DTNEWL0=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
END IF
! NEW ALGORITHM (NO TYPE ICE)
IF (DEL2N.EQ.0)THEN
DTNEWI2_1=DT
DTNEWI2_2=DT
DTNEWI2_3=DT
ELSE
DTNEWI2_1=R2(1,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
DTNEWI2_2=R2(1,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
DTNEWI2_3=R2(1,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
END IF
DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
IF (DEL2N.EQ.0)THEN
DTNEWI3=DT
DTNEWI4=DT
DTNEWI5=DT
ELSE
DTNEWI3=R3(1)/(B31_MY(1)*DEL2N-B32_MY(1))
DTNEWI4=R4(1)/(B41_MY(1)*DEL2N-B42_MY(1))
DTNEWI5=R5(1)/(B51_MY(1)*DEL2N-B52_MY(1))
END IF
DTNEWL1=AMIN1(DTNEWL0,DT0L,TIMEREV)
DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
& ,DTNEWI5,DT0I,TIMEREV)
DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
! NEW CHANGES 23.04.01 (BEGIN)
IF(DTNEWL.LT.DT_MIX_BERGERON) &
& DTNEWL=AMIN1(DT_MIX_BERGERON,TIMEREV)
TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (BERGERON MIXED PHASE)
IF(DTNEWL.GT.DT) DTNEWL=DT
IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
& DTNEWL=DT-TIMENEW
IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
TIMESTEPD(ITIME)=DTNEWL
TIMENEW=TIMENEW+DTNEWL
DTT=DTNEWL
! BERGERON MIXED PHASE (END)
! IN CASE : KCOND = 32
ENDIF
! SOLVING FOR SUPERSATURATION
! CALL JERSUPSAT - 7 (MIXED_PHASE)
CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
& ,RW,PW,RI,PI,QW,QI &
& ,DTT,D1N,D2N,DT0L,DT0I)
! END OF "NEW SUPERSATURATION"
! DROPLETS
IF(ISYM1.NE.0) THEN
! DROPLET DISTRIBUTION FUNCTION
! CALL JERDFUN - 3
CALL JERDFUN(R1,B11_MY,B12_MY &
& ,FI1,PSI1,D1N &
& ,1,1,COL,NKR,TPN)
! END OF "DROPLET DISTRIBUTION FUNCTION"
! IN CASE ISYM1.NE.0
ENDIF
! CRYSTALS
IF(ISYM2.NE.0) THEN
! CRYSTAL DISTRIBUTION FUNCTION
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICEMAX,1,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICEMAX,2,COL,NKR,TPN)
CALL JERDFUN(R2,B21_MY,B22_MY &
& ,FI2,PSI2,D2N &
& ,ICEMAX,3,COL,NKR,TPN)
! IN CASE ISYM2.NE.0
ENDIF
! SNOW
IF(ISYM3.NE.0) THEN
! SNOW DISTRIBUTION FUNCTION
! CALL JERDFUN - SNOW - 3
CALL JERDFUN(R3,B31_MY,B32_MY &
& ,FI3,PSI3,D2N &
& ,1,3,COL,NKR,TPN)
! IN CASE ISYM3.NE.0
ENDIF
! GRAUPELS
IF(ISYM4.NE.0) THEN
! GRAUPEL DISTRIBUTION FUNCTION
CALL JERDFUN(R4,B41_MY,B42_MY &
& ,FI4,PSI4,D2N &
& ,1,4,COL,NKR,TPN)
! IN CASE ISYM4.NE.0
ENDIF
! HAIL
IF(ISYM5.NE.0) THEN
! HAIL DISTRIBUTION FUNCTION
CALL JERDFUN(R5,B51_MY,B52_MY &
& ,FI5,PSI5,D2N &
& ,1,5,COL,NKR,TPN)
! IN CASE ISYM5.NE.0
ENDIF
! MASSES
RMASSLBB=0.D0
RMASSIBB=0.D0
RMASSLAA=0.D0
RMASSIAA=0.D0
! BEFORE JERNEWF
DO K=1,NKR
FI1_K=FI1(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLBB=RMASSLBB+FI1R1
DO ICE =1,ICEMAX
FI2_K=FI2(K,ICE)
R2_K=R2(K,ICE)
FI2R2=FI2_K*R2_K*R2_K
RMASSIBB=RMASSIBB+FI2R2
ENDDO
FI3_K=FI3(K)
FI4_K=FI4(K)
FI5_K=FI5(K)
R3_K=R3(K)
R4_K=R4(K)
R5_K=R5(K)
FI3R3=FI3_K*R3_K*R3_K
FI4R4=FI4_K*R4_K*R4_K
FI5R5=FI5_K*R5_K*R5_K
RMASSIBB=RMASSIBB+FI3R3
RMASSIBB=RMASSIBB+FI4R4
RMASSIBB=RMASSIBB+FI5R5
ENDDO
RMASSIBB=RMASSIBB*COL3*RORI
! NEW CHANGE RMASSIBB
IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
! AFTER JERNEWF
DO K=1,NKR
FI1_K=PSI1(K)
R1_K=R1(K)
FI1R1=FI1_K*R1_K*R1_K
RMASSLAA=RMASSLAA+FI1R1
DO ICE =1,ICEMAX
FI2(K,ICE)=PSI2(K,ICE)
FI2_K=FI2(K,ICE)
R2_K=R2(K,ICE)
FI2R2=FI2_K*R2_K*R2_K
RMASSIAA=RMASSIAA+FI2R2
ENDDO
FI3_K=PSI3(K)
FI4_K=PSI4(K)
FI5_K=PSI5(K)
R3_K=R3(K)
R4_K=R4(K)
R5_K=R5(K)
FI3R3=FI3_K*R3_K*R3_K
FI4R4=FI4_K*R4_K*R4_K
FI5R5=FI5_K*R5_K*R5_K
RMASSIAA=RMASSIAA+FI3R3
RMASSIAA=RMASSIAA+FI4R4
RMASSIAA=RMASSIAA+FI5R5
ENDDO
RMASSIAA=RMASSIAA*COL3*RORI
! NEW CHANGE RMASSIAA
IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
RMASSLAA=RMASSLAA*COL3*RORI
! NEW CHANGE RMASSLAA
IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
! NEW TREATMENT OF "T" & "Q"
DELMASSL1=RMASSLAA-RMASSLBB
DELMASSI1=RMASSIAA-RMASSIBB
DELTAQ1=DELMASSL1+DELMASSI1
! QPN=QPS-DELTAQ1-CWQ*DTT
QPN=QPS-DELTAQ1
DAL1=AL1
DAL2=AL2
! TPN=TPS+DAL1*DELMASSL1+AL2*DELMASSI1-CWQ*DTT
TPN=TPS+DAL1*DELMASSL1+DAL2*DELMASSI1
! SUPERSATURATION
ARGEXP=-BB1_MY/TPN
ES1N=AA1_MY*DEXP(ARGEXP)
ARGEXP=-BB2_MY/TPN
ES2N=AA2_MY*DEXP(ARGEXP)
EW1N=OPER3(QPN,PP)
IF(ES1N.EQ.0)THEN
DEL1N=0.5
DIV1=1.5
print*,'es1n onecond3 = 0'
! stop
ELSE
DIV1=EW1N/ES1N
DEL1N=EW1N/ES1N-1.
END IF
IF(ES2N.EQ.0)THEN
DEL2N=0.5
DIV2=1.5
print*,'es2n onecond3 = 0'
! stop
ELSE
DEL2N=EW1N/ES2N-1.
DIV2=EW1N/ES2N
END IF
! END OF TIME SPLITTING
! HERE
IF(TIMENEW.LT.DT) GOTO 16
17 CONTINUE
TT=TPN
QQ=QPN
DO KR=1,NKR
FF1(KR)=PSI1(KR)
DO ICE=1,ICEMAX
FF2(KR,ICE)=PSI2(KR,ICE)
ENDDO
FF3(KR)=PSI3(KR)
FF4(KR)=PSI4(KR)
FF5(KR)=PSI5(KR)
ENDDO
RETURN
END SUBROUTINE ONECOND3
SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, & 2,56
& FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL)
implicit none
INTEGER KR,ICE
INTEGER icol_drop,icol_snow,icol_graupel,icol_hail, &
& icol_column,icol_plate,icol_dendrite,icol_drop_brk
double precision g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr)
double precision gdumb(JMAX),xl_dumb(0:nkr),g_orig(nkr)
double precision g2_1(nkr),g2_2(nkr),g2_3(nkr)
real cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
& delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
& cont_init_drop,ALWC
REAL FF1R(NKR),FF2R(NKR,ICEMAX),FF3R(NKR),FF4R(NKR),FF5R(NKR)
REAL dt_coll
REAL TCRIT,TTCOAL
real tt_no_coll
parameter (tt_no_coll=273.16)
! SHARED
INTEGER I,J,IT,NDIV
REAL RHO
DOUBLE PRECISION break_drop_bef,break_drop_aft,dtbreakup
DOUBLE PRECISION break_drop_per
DOUBLE PRECISION TT,QQ,PP,prdkrn,prdkrn1
parameter (prdkrn1=1.d0)
! print*,'tcrit = ',tcrit
! print*,'ttcoal = ',ttcoal
! print*,'col = ',col
! print*,'p1,p2,p3 = ',p1,p2,p3
! print*,'icempl,kr_icempl = ',icempl,kr_icempl
! print*,'dt_coll = ',dt_coll
icol_drop_brk=0
icol_drop=0
icol_snow=0
icol_graupel=0
icol_hail=0
icol_column=0
icol_plate=0
icol_dendrite=0
t_new=tt
CALL MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
& cwll,nkr)
! THIS IS FOR BREAKUP
DO I=1,NKR
DO J=1,NKR
CWLL(I,J)=ECOALMASSM(I,J)*CWLL(I,J)
ENDDO
ENDDO
!
! THIS IS FOR TURBULENCE
IF (LIQTURB.EQ.1)THEN
DO I=1,KRMAX_LL
DO J=1,KRMAX_LL
CWLL(I,J)=CTURBLL(I,J)*CWLL(I,J)
END DO
END DO
END IF
CALL MODKRN(TT,QQ,PP,PRDKRN,TTCOAL)
DO 13 KR=1,NKR
G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
g2_1(kr)=g2(KR,1)
g2_2(KR)=g2(KR,2)
g2_3(KR)=g2(KR,3)
if(kr.gt.(nkr-jbreak).and.g1(kr).gt.1.e-17)icol_drop_brk=1
! icol_drop_brk=0
IF (IBREAKUP.NE.1)icol_drop_brk=0
if(g1(kr).gt.1.e-10)icol_drop=1
if (tt.le.tt_no_coll)then
if(g2_1(kr).gt.1.e-10)icol_column=1
if(g2_2(kr).gt.1.e-10)icol_plate=1
if(g2_3(kr).gt.1.e-10)icol_dendrite=1
if(g3(kr).gt.1.e-10)icol_snow=1
if(g4(kr).gt.1.e-10)icol_graupel=1
if(g5(kr).gt.1.e-10)icol_hail=1
end if
13 CONTINUE
! calculation of initial hydromteors content in g/cm**3 :
cont_init_drop=0.
cont_init_ice=0.
do kr=1,nkr
cont_init_drop=cont_init_drop+g1(kr)
cont_init_ice=cont_init_ice+g3(kr)+g4(kr)+g5(kr)
do ice=1,icemax
cont_init_ice=cont_init_ice+g2(kr,ice)
enddo
enddo
cont_init_drop=col*cont_init_drop*1.e-3
cont_init_ice=col*cont_init_ice*1.e-3
! calculation of alwc in g/m**3
alwc=cont_init_drop*1.e6
! calculation interactions :
! droplets - droplets and droplets - ice :
! water-water = water
if (icol_drop.eq.1)then
! break-up
call coll_xxx (G1,CWLL,XL_MG,CHUCM,IMA,NKR)
! breakup!
if(icol_drop_brk.eq.1)then
ndiv=1
10 continue
do it = 1,ndiv
if (ndiv.gt.1024)print*,'ndiv in coal_bott_new = ',ndiv
if (ndiv.gt.10000) call wrf_error_fatal("fatal error in module_mp_full_sbm (ndiv.gt.10000), model stop")
dtbreakup = dt_coll/ndiv
if (it.eq.1)then
! do kr=1,nkr
do kr=1,JMAX
gdumb(kr)= g1(kr)*1.D-3
xl_dumb(kr)=xl_mg(KR)*1.D-3
end do
break_drop_bef=0.d0
! do kr=1,nkr
do kr=1,JMAX
break_drop_bef=break_drop_bef+g1(kr)*1.D-3
enddo
end if
call breakup(gdumb,xl_dumb,dtbreakup,brkweight, &
& pkij,qkj,JMAX,jbreak)
end do
break_drop_aft=0.0d0
do kr=1,JMAX
break_drop_aft=break_drop_aft+gdumb(kr)
enddo
break_drop_per=break_drop_aft/break_drop_bef
if (break_drop_per.gt.1.001)then
ndiv=ndiv*2
GO TO 10
else
do kr=1,JMAX
g1(kr)=gdumb(kr)*1.D3
end do
end if
end if
end if
if (icol_snow.eq.1)then
call coll_xyz (g1,g3,g4,cwls,xl_mg,xs_mg, &
& chucm,ima,prdkrn1,nkr,0)
if(alwc.lt.alcr) then
call coll_xyx (g3,g1,cwsl,xs_mg,xl_mg, &
& chucm,ima,prdkrn1,nkr,1)
endif
if(alwc.ge.alcr) then
! call coll_xyz (g3,g1,g4,cwsl,xs_mg,xl_mg, &
! & chucm,ima,prdkrn1,nkr,1)
call coll_xyxz_h (g3,g1,g4,cwsl,xs_mg,xl_mg, &
& chucm,ima,prdkrn1,nkr,1)
endif
! in case : icolxz_snow.ne.0
end if
! interactions between water and graupel (begin)
! water - graupel = graupel (t < tcrit ; xl_mg ge xg_mg)
! graupel - water = graupel (t < tcrit ; xg_mg > xl_mg)
! water - graupel = hail (t ge tcrit ; xl_mg ge xg_mg)
! graupel - water = hail (t ge tcrit ; xg_mg > xl_mg)
if (icol_graupel.eq.1)then
! water-graupel
! included kp_bound = 25
call coll_xyyz_h (g1,g4,g5,cwlg,xl_mg,xg_mg, &
& chucm,ima,prdkrn1,nkr,1)
! for ice multiplication
conc_old=0.
conc_new=0.
do kr=kr_icempl,nkr
conc_old=conc_old+col*g1(kr)/xl_mg(kr)
enddo
! graupel-water
if(alwc.lt.alcr_g) then
! water-graupel
! TEST
call coll_xyy (g1,g4,cwlg,xl_mg,xg_mg, &
& chucm,ima,prdkrn1,nkr,0)
call coll_xyx (g4,g1,cwgl,xg_mg,xl_mg, &
& chucm,ima,prdkrn1,nkr,1)
! TEST
else
call coll_xyxz_h (g4,g1,g5,cwgl,xg_mg,xl_mg, &
& chucm,ima,prdkrn1,nkr,1)
end if
! interactions between water and graupels (end)
if(icempl.eq.1) then
if(tt.ge.265.15.and.tt.le.tcrit) then
! ice-multiplication :
do kr=kr_icempl,nkr
conc_new=conc_new+col*g1(kr)/xl_mg(kr)
enddo
dconc=conc_old-conc_new
if(tt.le.268.15) then
conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
endif
if(tt.gt.268.15) then
conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
endif
!CHANGE FOR FOUR BIN SCHEME g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
! g3(1)=g3(1)+conc_icempl*xs_mg(1)/col
! in case t.ge.265.15 :
endif
! in case icempl=1
endif
! interactions between water and graupels (end)
! in case icolxz_graup.ne.0
endif
! water - hail = hail (xl_mg ge xh_mg) (kxyy=2)
! hail - water = hail (xh_mg > xl_mg) (kxyx=3)
if(icol_hail.eq.1) then
call coll_xyy (g1,g5,cwlh,xl_mg,xh_mg, &
& chucm,ima,prdkrn1,nkr,0)
call coll_xyx (g5,g1,cwhl,xh_mg,xl_mg, &
& chucm,ima,prdkrn1,nkr,1)
! in case icolxz_hail.ne.0
endif
! interactions between water and hail (end)
! interactions between water and crystals :
! interactions between water and columns :
! water - columns = graupel (t < tcrit ; xl_mg ge xi_mg) (kxyz=6)
! water - columns = hail (t ge tcrit ; xl_mg ge xi_mg) (kxyz=7)
! columns - water = columns/graupel (xi_mg > xl_mg) (kxyx=4); kxyxz=2)
! now: columns - water = columns (xi_mg > xl_mg) (kxyx=4); kxyxz=2)
if(icol_column.eq.1) then
if(tt.lt.tcrit) then
call coll_xyz (g1,g2_1,g4,cwli_1,xl_mg,xi1_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
if(tt.ge.tcrit) then
call coll_xyz (g1,g2_1,g5,cwli_1,xl_mg,xi1_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
call coll_xyxz (g2_1,g1,g4,cwil_1,xi1_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
call coll_xyx (g2_1,g1,cwil_1,xi1_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
! in case icolxz_column.ne.0
endif
! if(icolxz_plate.ne.0) then
! interactions between water and plates :
! water - plates = graupel (t < tcrit ; xl_mg ge xi2_mg) (kxyz=8)
! water - plates = hail (t ge tcrit ; xl_mg ge xi2_mg) (kxyz=9)
! plates - water = plates/graupel (xi2_mg > xl_mg) (kxyx=5; kxyxz=3)
!now: plates - water = plates (xi2_mg > xl_mg) (kxyx=5; kxyxz=3)
if(icol_plate.eq.1) then
if(tt.lt.tcrit) then
call coll_xyz (g1,g2_2,g4,cwli_2,xl_mg,xi2_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
if(tt.ge.tcrit) then
call coll_xyz (g1,g2_2,g5,cwli_2,xl_mg,xi2_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
call coll_xyxz (g2_2,g1,g4,cwil_2,xi2_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
call coll_xyx (g2_2,g1,cwil_2,xi2_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
! in case icolxz_plate.ne.0
endif
! interactions between water and dendrites :
! water - dendrites = graupel (t < tcrit ; xl_mg ge xi3_mg) (kxyz=10)
! water - dendrites = hail (t ge tcrit ; xl_mg ge xi3_mg) (kxyz=11)
! dendrites - water = dendrites/graupel (xi3_mg > xl_mg) (kxyx=6; kxyxz=4)
!now dendrites - water = dendrites (xi3_mg > xl_mg) (kxyx=6; kxyxz=4)
if(icol_dendrite.eq.1) then
if(tt.lt.tcrit) then
call coll_xyz (g1,g2_3,g4,cwli_3,xl_mg,xi3_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
if(tt.ge.tcrit) then
call coll_xyz (g1,g2_3,g5,cwli_3,xl_mg,xi3_mg, &
& chucm,ima,prdkrn,nkr,0)
endif
call coll_xyxz (g2_3,g1,g4,cwil_3,xi3_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
call coll_xyx (g2_3,g1,cwil_3,xi3_mg,xl_mg, &
& chucm,ima,prdkrn,nkr,1)
! in case icolxz_dendr.ne.0
endif
! interactions between water and dendrites (end)
! in case icolxz_drop.ne.0
! endif
! interactions between water and crystals (end)
! interactions between crystals :
! if(t.le.TTCOAL) - no interactions between crystals
if(tt.gt.TTCOAL) then
! interactions between columns and other particles (begin)
if(icol_column.eq.1) then
! columns - columns = snow
call coll_xxy (g2_1,g3,cwii_1_1,xi1_mg, &
& chucm,ima,prdkrn,nkr)
! interactions between columns and plates :
! columns - plates = snow (xi1_mg ge xi2_mg) (kxyz=12)
! plates - columns = snow (xi2_mg > xi1_mg) (kxyz=13)
if(icol_plate.eq.1) then
call coll_xyz (g2_1,g2_2,g3,cwii_1_2,xi1_mg,xi2_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyz (g2_2,g2_1,g3,cwii_2_1,xi2_mg,xi1_mg, &
& chucm,ima,prdkrn,nkr,1)
end if
! interactions between columns and dendrites :
! columns - dendrites = snow (xi1_mg ge xi3_mg) (kxyz=14)
! dendrites - columns = snow (xi3_mg > xi1_mg) (kxyz=15)
if(icol_dendrite.eq.1) then
call coll_xyz (g2_1,g2_3,g3,cwii_1_3,xi1_mg,xi3_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyz (g2_3,g2_1,g3,cwii_3_1,xi3_mg,xi1_mg, &
& chucm,ima,prdkrn,nkr,1)
end if
! interactions between columns and snow :
! columns - snow = snow (xi1_mg ge xs_mg) (kxyy=3)
! snow - columns = snow (xs_mg > xi1_mg) (kxyx=7)
! ALEX?
if(icol_snow.eq.1) then
call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyx (g3,g2_1,cwsi_1,xs_mg,xi1_mg, &
& chucm,ima,prdkrn,nkr,1)
endif
! in case icolxz_column.ne.0
endif
! interactions between columns and other particles (end)
! interactions between plates and other particles (begin)
! plates - plates = snow
if(icol_plate.eq.1) then
call coll_xxy (g2_2,g3,cwii_2_2,xi2_mg, &
& chucm,ima,prdkrn,nkr)
! interactions between plates and dendrites :
! plates - dendrites = snow (xi2_mg ge xi3_mg) (kxyz=17)
! dendrites - plates = snow (xi3_mg > xi2_mg) (kxyz=18)
if(icol_dendrite.eq.1) then
call coll_xyz (g2_2,g2_3,g3,cwii_2_3,xi2_mg,xi3_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyz (g2_3,g2_2,g3,cwii_3_2,xi3_mg,xi2_mg, &
& chucm,ima,prdkrn,nkr,1)
end if
! interactions between plates and snow :
! plates - snow = snow (xi2_mg ge xs_mg) (kxyy=4)
! snow - plates = snow (xs_mg > xi2_mg) (kxyx=12)
if(icol_snow.eq.1) then
! ALEX
call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyx (g3,g2_2,cwsi_2,xs_mg,xi2_mg, &
& chucm,ima,prdkrn,nkr,1)
end if
! in case icolxz_plate.ne.0
endif
! interactions between plates and others particles (end)
! interactions between dendrites and other hydrometeors (begin)
! dendrites - dendrites = snow
if(icol_dendrite.eq.1) then
call coll_xxy (g2_3,g3,cwii_3_3,xi3_mg, &
& chucm,ima,prdkrn,nkr)
! interactions between dendrites and snow :
! dendrites - snow = snow (xi3_mg ge xs_mg) (kxyy=5)
! snow - dendrites = snow (xs_mg > xi3_mg) (kxyx=17)
if(icol_snow.eq.1) then
! ALEX
call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg, &
& chucm,ima,prdkrn,nkr,0)
call coll_xyx (g3,g2_3,cwsi_3,xs_mg,xi3_mg, &
& chucm,ima,prdkrn,nkr,1)
end if
! in case icolxz_dendr.ne.0
endif
! interactions between dendrites and other hydrometeors (end)
! interactions between snowflakes and other hydromteors (begin)
if(icol_snow.ne.0) then
! interactions between snowflakes
! snow - snow = snow
call coll_xxx_prd (g3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
! interactions between snowflakes and graupels :
! snow - graupel = snow (xs_mg > xg_mg) (kxyx=22)
! graupel - snow = graupel (xg_mg ge xs_mg) (kxyx=23)
if(icol_graupel.eq.1) then
call coll_xyx (g3,g4,cwsg,xs_mg,xg_mg, &
& chucm,ima,prdkrn,nkr,1)
! in case icolxz_graup.ne.0
endif
! in case icolxz_snow.ne.0
endif
! interactions between snowflakes and other hydromteors (end)
! in case : t > TTCOAL
endif
! in case : t > TTCOAL or t.le.TTCOAL
! calculation of finish hydrometeors contents in g/cm**3 :
cont_fin_drop=0.
cont_fin_ice=0.
do kr=1,nkr
g2(kr,1)=g2_1(kr)
g2(kr,2)=g2_2(kr)
g2(kr,3)=g2_3(kr)
cont_fin_drop=cont_fin_drop+g1(kr)
cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
! cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)
do ice=1,icemax
cont_fin_ice=cont_fin_ice+g2(kr,ice)
enddo
enddo
cont_fin_drop=col*cont_fin_drop*1.e-3
cont_fin_ice=col*cont_fin_ice*1.e-3
deldrop=cont_init_drop-cont_fin_drop
! deldrop in g/cm**3
! resulted value of temperature (rob in g/cm**3) :
if(t_new.le.273.15) then
if(deldrop.ge.0.) then
t_new=t_new+320.*deldrop/rho
else
! if deldrop < 0
if(abs(deldrop).gt.cont_init_drop*0.05) then
call wrf_error_fatal("fatal error in module_mp_full_sbm (abs(deldrop).gt.cont_init_drop), model stop")
endif
endif
endif
61 continue
! recalculation of density function f1,f2,f3,f4,f5 in 1/(g*cm**3) :
DO 15 KR=1,NKR
FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
FF2R(KR,1)=G2(KR,1)/(3*xi(KR,1)*XI(KR,1)*1.e3)
FF2R(KR,2)=G2(KR,2)/(3.*xi(KR,2)*XI(KR,2)*1.e3)
FF2R(KR,3)=G2(KR,3)/(3.*xi(KR,3)*XI(KR,3)*1.e3)
FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
15 CONTINUE
tt=t_new
RETURN
END SUBROUTINE COAL_BOTT_NEW
SUBROUTINE MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, & 2
& cwll,nkr)
IMPLICIT NONE
INTEGER kr1,kr2,NKR
DOUBLE PRECISION PP
REAL P_Z
double precision cwll(nkr,nkr),cwll_1,cwll_2,cwll_3 &
&,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr)
P_Z=PP
do 12 kr1=1,nkr
do 12 kr2=1,nkr
cwll_1=cwll_1000mb(kr1,kr2)
cwll_2=cwll_750mb(kr1,kr2)
cwll_3=cwll_500mb(kr1,kr2)
if(p_z.ge.p1) cwll(kr1,kr2)=cwll_1
if(p_z.eq.p2) cwll(kr1,kr2)=cwll_2
if(p_z.eq.p3) cwll(kr1,kr2)=cwll_3
if(p_z.lt.p1.and.p_z.gt.p2) &
& cwll(kr1,kr2)=cwll_2+ &
& (cwll_1-cwll_2)*(p_z-p2)/(p1-p2)
if(p_z.lt.p2.and.p_z.gt.p3) &
& cwll(kr1,kr2)=cwll_3+ &
& (cwll_2-cwll_3)*(p_z-p3)/(p2-p3)
if(p_z.lt.p3) cwll(kr1,kr2)=cwll_3
12 CONTINUE
RETURN
END SUBROUTINE MISC1
subroutine coll_xxx (g,ckxx,x,chucm,ima,nkr) 2
implicit double precision (a-h,o-z)
dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! gmin=1.d-15
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(g(i).gt.gmin) goto 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(g(i).gt.gmin) goto 2010
enddo
2010 continue
! J. Dudhia gave reasons why this can't be looped with a
! multiprocessor.
! BARRY
! do i=ix0,ix1
! do j=i,ix1
do i=ix0,ix1-1
do j=i+1,ix1
k=ima(i,j)
kp=k+1
x0=ckxx(i,j)*g(i)*g(j)
x0=min(x0,g(i)*x(j))
if(j.ne.k) then
x0=min(x0,g(j)*x(i))
endif
gsi=x0/x(j)
gsj=x0/x(i)
gsk=gsi+gsj
g(i)=g(i)-gsi
if(g(i).lt.0.d0) g(i)=0.d0
g(j)=g(j)-gsj
gk=g(k)+gsk
if(g(j).lt.0.d0.and.gk.lt.gmin) then
g(j)=0.d0
g(k)=g(k)+gsi
endif
flux=0.d0
!
! BARRY
if(gk.gt.gmin) then
x1=dlog(g(kp)/gk+1.d-15)
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
g(k)=gk-flux
if(g(k).lt.0.d0) g(k)=0.d0
g(kp)=g(kp)+flux
! in case gk > gmin :
endif
end do
end do
2020 continue
return
end subroutine coll_xxx
subroutine coll_xxx_prd (g,ckxx,x,chucm,ima,prdkrn,nkr) 2
implicit double precision (a-h,o-z)
dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
! this is character values containes adresses of temporary files
gmin=1.d-60
! gmin=1.d-15
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(g(i).gt.gmin) goto 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(g(i).gt.gmin) goto 2010
enddo
2010 continue
! J. Dudhia gave reasons why this can't be looped with a
! multiprocessor.
! BARRY
! do i=ix0,ix1
! do j=i,ix1
do i=ix0,ix1-1
do j=i+1,ix1
k=ima(i,j)
kp=k+1
x0=ckxx(i,j)*g(i)*g(j)*prdkrn
x0=min(x0,g(i)*x(j))
if(j.ne.k) then
x0=min(x0,g(j)*x(i))
endif
gsi=x0/x(j)
gsj=x0/x(i)
gsk=gsi+gsj
g(i)=g(i)-gsi
if(g(i).lt.0.d0) g(i)=0.d0
g(j)=g(j)-gsj
gk=g(k)+gsk
if(g(j).lt.0.d0.and.gk.lt.gmin) then
g(j)=0.d0
g(k)=g(k)+gsi
endif
flux=0.d0
!
! BARRY
if(gk.gt.gmin) then
x1=dlog(g(kp)/gk+1.d-15)
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
g(k)=gk-flux
if(g(k).lt.0.d0) g(k)=0.d0
g(kp)=g(kp)+flux
! in case gk > gmin :
endif
end do
end do
2020 continue
return
end subroutine coll_xxx_prd
subroutine modkrn(TT,QQ,PP,PRDKRN,TTCOAL) 2
implicit none
real epsf,tc,ttt1,ttt,factor,qs2,qq1,dele,f,factor_t
double precision TT,QQ,PP,satq2,t,p
double precision prdkrn
REAL at,bt,ct,dt,temp,a,b,c,d,tc_min,tc_max
real factor_max,factor_min
REAL TTCOAL
data at,bt,ct,dt/0.88333,0.0931878,0.0034793,4.5185186e-05/
satq2(t,p)=3.80e3*(10**(9.76421-2667.1/t))/p
temp(a,b,c,d,tc)=d*tc*tc*tc+c*tc*tc+b*tc+a
IF (QQ.LE.0)QQ=1.E-12
epsf =.5
tc =tt-273.15
factor=1 !mchen add
if(tc.le.0) then
! in case tc.le.0
ttt1 =temp(at,bt,ct,dt,tc)
ttt =ttt1
qs2 =satq2(tt,pp)
qq1 =qq*(0.622+0.378*qs2)/(0.622+0.378*qq)/qs2
dele =ttt*qq1
! new change 27.06.00
if(tc.ge.-6.) then
factor = dele
if(factor.lt.epsf) factor=epsf
if(factor.gt.1.) factor=1.
! in case : tc.ge.-6.
endif
factor_t=factor
if(tc.ge.-12.5.and.tc.lt.-6.) factor_t=0.5
if(tc.ge.-17.0.and.tc.lt.-12.5) factor_t=1.
if(tc.ge.-20.0.and.tc.lt.-17.) factor_t=0.4
if(tc.lt.-20.) then
tc_min=ttcoal-273.15
tc_max=-20.
factor_max=0.25
factor_min=0.
f=factor_min+(tc-tc_min)*(factor_max-factor_min)/ &
& (tc_max-tc_min)
factor_t=f
endif
! BARRY
if (factor_t.lt.0)factor_t=0.01
prdkrn=factor_t
else
prdkrn=1.d0
end if
RETURN
END SUBROUTINE modkrn
subroutine coll_xxy(gx,gy,ckxx,x,chucm,ima,prdkrn,nkr) 3
implicit double precision (a-h,o-z)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
dimension &
& gx(nkr),gy(nkr),ckxx(nkr,nkr),x(0:nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) goto 2000
enddo
if(ix0.eq.nkr-1) goto 2020
2000 continue
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) goto 2010
enddo
2010 continue
! collisions
do i=ix0,ix1
do j=i,ix1
k=ima(i,j)
kp=k+1
x0=ckxx(i,j)*gx(i)*gx(j)*prdkrn
x0=min(x0,gx(i)*x(j))
x0=min(x0,gx(j)*x(i))
gsi=x0/x(j)
gsj=x0/x(i)
gsk=gsi+gsj
gx(i)=gx(i)-gsi
if(gx(i).lt.0.d0) gx(i)=0.d0
gx(j)=gx(j)-gsj
if(gx(j).lt.0.d0) gx(j)=0.d0
gk=gy(k)+gsk
flux=0.d0
! BARRY
if(gk.gt.gmin) then
! new changes 13.01.01 (begin)
x1=dlog(gy(kp)/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! new changes 23.01.01 (end)
! new changes 13.01.01 (end)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
gy(k)=gk-flux
if(gy(k).lt.0.d0) gy(k)=0.d0
gy(kp)=gy(kp)+flux
! in case gk > gmin :
endif
enddo
enddo
2020 continue
return
end subroutine coll_xxy
!====================================================================
subroutine coll_xyy(gx,gy,ckxy,x,y,chucm,ima, & 6
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension &
& gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
x0=min(x0,gx(j)*y(i))
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
if(gx(j).lt.0.d0) gx(j)=0.d0
gk=gy(k)+gsk
flux=0.d0
! BARRY
if(gk.gt.gmin) then
x1=dlog(gy(kp)/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gy(k)=gk-flux
if(gy(k).lt.0.d0) gy(k)=0.d0
gy(kp)=gy(kp)+flux
! in case gk > gmin :
endif
! in case gk > gmin or gk.le.gmin
enddo
enddo
2020 continue
return
end subroutine coll_xyy
!=================================================================
subroutine coll_xyx(gx,gy,ckxy,x,y,chucm,ima, & 12
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
if(j.ne.k) then
x0=min(x0,gx(j)*y(i))
endif
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
gk=gx(k)+gsk
! BARRY
! if(gx(j).lt.0.d0)then
! gy(i)=gy(i)+gsi
! gx(j)=gx(j)+gsj
! go to 10
! end if
if(gx(j).lt.0.d0.and.gk.lt.gmin) then
gx(j)=0.d0
gx(k)=gx(k)+gsi
endif
flux=0.d0
! BARRY
if(gk.gt.gmin) then
x1=dlog(gx(kp)/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gx(k)=gk-flux
if(gx(k).lt.0.d0) gx(k)=0.d0
gx(kp)=gx(kp)+flux
! in case gk > gmin :
endif
! in case gk > gmin or gk.le.gmin
! BARRY
10 continue
enddo
enddo
2020 continue
return
end subroutine coll_xyx
!=====================================================================
subroutine coll_xyxz(gx,gy,gz,ckxy,x,y,chucm,ima, & 3
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
if(j.ne.k) then
x0=min(x0,gx(j)*y(i))
endif
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
gk=gx(k)+gsk
if(gx(j).lt.0.d0.and.gk.lt.gmin) then
gx(j)=0.d0
gx(k)=gx(k)+gsi
endif
flux=0.d0
! BARRY
if(kp.lt.17) gkp=gx(kp)
if(kp.ge.17) gkp=gz(kp)
if(gk.gt.gmin) then
x1=dlog(gkp/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gx(k)=gk-flux
if(gx(k).lt.0.d0) gx(k)=0.d0
if(kp.lt.17) gx(kp)=gkp+flux
if(kp.ge.17) gz(kp)=gkp+flux
! ALEX 15 11 2005
! if(kp.ge.17) gx(kp)=gkp+flux
! in case gk > gmin :
endif
! in case gk > gmin or gk.le.gmin
enddo
enddo
2020 continue
return
end subroutine coll_xyxz
!=====================================================================
subroutine coll_xyxz_h(gx,gy,gz,ckxy,x,y,chucm,ima, & 3
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
if(j.ne.k) then
x0=min(x0,gx(j)*y(i))
endif
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
gk=gx(k)+gsk
if(gx(j).lt.0.d0.and.gk.lt.gmin) then
gx(j)=0.d0
gx(k)=gx(k)+gsi
endif
flux=0.d0
! BARRY
if(kp.lt.22) gkp=gx(kp)
if(kp.ge.22) gkp=gz(kp)
if(gk.gt.gmin) then
x1=dlog(gkp/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gx(k)=gk-flux
if(gx(k).lt.0.d0) gx(k)=0.d0
if(kp.lt.22) gx(kp)=gkp+flux
if(kp.ge.22) gz(kp)=gkp+flux
! ALEX 15 11 2005
! if(kp.ge.25) gx(kp)=gkp+flux
! in case gk > gmin :
endif
! in case gk > gmin or gk.le.gmin
enddo
enddo
2020 continue
return
end subroutine coll_xyxz_h
!=====================================================================
subroutine coll_xyz(gx,gy,gz,ckxy,x,y,chucm,ima, & 14
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension gx(nkr),gy(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
x0=min(x0,gx(j)*y(i))
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
if(gx(j).lt.0.d0) gx(j)=0.d0
gk=gz(k)+gsk
flux=0.d0
! BARRY
if(gk.gt.gmin) then
x1=dlog(gz(kp)/gk+1.d-15)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gz(k)=gk-flux
if(gz(k).lt.0.d0) gz(k)=0.d0
gz(kp)=gz(kp)+flux
! in case gk > gmin :
endif
enddo
enddo
2020 continue
return
end subroutine coll_xyz
subroutine coll_xyyz_h(gx,gy,gz,ckxy,x,y,chucm,ima, & 1
& prdkrn,nkr,indc)
implicit double precision (a-h,o-z)
dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
dimension chucm(nkr,nkr)
double precision ima(nkr,nkr)
gmin=1.d-60
! lower and upper integration limit ix0,ix1
do i=1,nkr-1
ix0=i
if(gx(i).gt.gmin) go to 2000
enddo
2000 continue
if(ix0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
ix1=i
if(gx(i).gt.gmin) go to 2010
enddo
2010 continue
! lower and upper integration limit iy0,iy1
do i=1,nkr-1
iy0=i
if(gy(i).gt.gmin) go to 2001
enddo
2001 continue
if(iy0.eq.nkr-1) goto 2020
do i=nkr-1,1,-1
iy1=i
if(gy(i).gt.gmin) go to 2011
enddo
2011 continue
! collisions :
do i=iy0,iy1
jmin=i
if(jmin.eq.(nkr-1)) goto 2020
if(i.lt.ix0) jmin=ix0-indc
do j=jmin+indc,ix1
k=ima(i,j)
kp=k+1
x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
x0=min(x0,gy(i)*x(j))
if(j.ne.k) then
x0=min(x0,gx(j)*y(i))
endif
gsi=x0/x(j)
gsj=x0/y(i)
gsk=gsi+gsj
gy(i)=gy(i)-gsi
if(gy(i).lt.0.d0) gy(i)=0.d0
gx(j)=gx(j)-gsj
gk=gx(k)+gsk
if(gx(j).lt.0.d0.and.gk.lt.gmin) then
gx(j)=0.d0
gx(k)=gx(k)+gsi
endif
flux=0.d0
! BARRY
if(kp.lt.25) gkp=gy(kp)
if(kp.ge.25) gkp=gz(kp)
if(gk.gt.gmin) then
x1=dlog(gkp/gk+1.d-15)
! BARRY
! flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
! flux=min(flux,gk)
! flux=min(flux,gsk)
! BARRY
if (x1.eq.0)then
flux=0
else
flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
flux=min(flux,gsk)
end if
! new changes 23.01.01 (end)
gx(k)=gk-flux
if(gx(k).lt.0.d0) gx(k)=0.d0
if(kp.lt.25) gy(kp)=gkp+flux
if(kp.ge.25) gz(kp)=gkp+flux
! ALEX 15 11 2005
! if(kp.ge.25) gx(kp)=gkp+flux
! in case gk > gmin :
endif
! in case gk > gmin or gk.le.gmin
enddo
enddo
2020 continue
return
end subroutine coll_xyyz_h
!===============================================================
!****************************************************************
! SEE /include/microhucm.incl for setting of krdrop and krbreak
!****************************************************************
SUBROUTINE BREAKUP(GT_MG,XT_MG,DT,BRKWEIGHT, & 3
& PKIJ,QKJ,JMAX,JBREAK)
! SUBROUTINE BREAKUP(GT_MG,DT,JMAX,JBREAK)
! implicit double precision (a-h,o-z)
!.....INPUT VARIABLES
!
! GT : MASS DISTRIBUTION FUNCTION
! XT_MG : MASS OF BIN IN MG
! JMAX : NUMBER OF BINS
! DT : TIMESTEP IN S
INTEGER JMAX
!.....LOCAL VARIABLES
LOGICAL LTHAN
INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
DOUBLE PRECISION EPS,NEGSUM
PARAMETER (AP = 1)
PARAMETER (IA = 1)
PARAMETER (JA = 1)
PARAMETER (KA = 1)
PARAMETER (EPS = 1.D-20)
INTEGER I,J,K,JJ,JDIFF
DOUBLE PRECISION GT_MG(JMAX),XT_MG(0:JMAX),DT
! xl_mg(0:nkr)
DOUBLE PRECISION BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
& QKJ(JBREAK,JBREAK)
DOUBLE PRECISION D0,ALM,HLP(JMAX)
DOUBLE PRECISION FT(JMAX),FA(JMAX)
DOUBLE PRECISION DG(JMAX),DF(JMAX),DBREAK(JBREAK),GAIN,LOSS
REAL PI
PARAMETER (PI = 3.1415927)
INTEGER IP,KP,JP,KQ,JQ
IE = JBREAK
JE = JBREAK
KE = JBREAK
!.....IN CGS
! DO J=1,JMAX
! XT(J) = XT_MG(J) * 1E-3
! GT_MG(J) = GT_MG(J)* 1E-3
! ENDDO
!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
JDIFF = JMAX - JBREAK
! 14 = 33 - 19
!.....INITIALIZATION
!.....TRANSFORMATION FROM G(LN X) = X**2 F(X) TO F(X)
DO J=1,JMAX
FT(J) = GT_MG(J) / XT_MG(J)**2
ENDDO
!.....SHIFT TO BREAKUP GRID
DO K=1,KE
FA(K) = FT(K+JDIFF)
ENDDO
!.....BREAKUP: BLECK'S FIRST ORDER METHOD
!
! PKIJ: GAIN COEFFICIENTS
! QKJ : LOSS COEFFICIENTS
!
DO K=1,KE
GAIN = 0.0
DO I=1,IE
DO J=1,I
GAIN = GAIN + FA(I)*FA(J)*PKIJ(K,I,J)
ENDDO
ENDDO
LOSS = 0.0
DO J=1,JE
LOSS = LOSS + FA(J)*QKJ(K,J)
ENDDO
DBREAK(K) = BRKWEIGHT(K) * (GAIN - FA(K)*LOSS)
ENDDO
!.....SHIFT RATE TO COAGULATION GRID
DO J=1,JDIFF
DF(J) = 0.0
ENDDO
DO J=1,KE
DF(J+JDIFF) = DBREAK(J)
ENDDO
!.....TRANSFORMATION TO MASS DISTRIBUTION FUNCTION G(LN X)
DO J=1,JMAX
DG(J) = DF(J) * XT_MG(J)**2
ENDDO
!.....TIME INTEGRATION
DO J=1,JMAX
HLP(J) = 0.0
NEGSUM = 0.0
GT_MG(J) = GT_MG(J) + DG(J) * DT
IF (GT_MG(J).LT.0) THEN
HLP(J) = MIN(GT_MG(J),HLP(J))
GT_MG(J) = EPS
! NEGSUM = NEGSUM+GT_MG(J)
! GT_MG(J) = 0.D0
ENDIF
ENDDO
! DO J=1,JMAX
! IF (HLP(J).LT.0.) THEN
! GT_MG(J-1)=GT_MG(J-1)-NEGSUM -EPS
! END IF
! GO TO 10
! END DO
!10 CONTINUE
! IF (HLP.LT.-1E-7) THEN
! BARRY
! LTHAN=.FALSE.
! DO J=1,JMAX
! IF (HLP(J).LT.0.OR.LTHAN) THEN
! WRITE (*,'(1X,A,E10.4)')
! F 'COLL_BREAKUP: WARNING! G(J) < 0, MIN = '
! IF(HLP(J).LT.0.OR.LTHAN)WRITE(6,*)
! F 'J,G(J) = ',J,HLP(J),GT_MG(J)
! LTHAN=.TRUE. C ENDIF
! END DO
! DO J=1,JMAX
! GT_MG(J) = GT_MG(J) * 1E3
! ENDDO
!.....THAT'S IT
RETURN
END SUBROUTINE BREAKUP
SUBROUTINE BOUNDNUM(MASSMM5,FCONC,RHOX,COL,NZERO, &,2
& RADXX,MASSXX,HYDROSUM, &
& NKR)
IMPLICIT NONE
INTEGER NKR,NKRI,KRBEG,KREND,IP,IPCNT
REAL NZERO,LAMBDAHYD,MASSMM5,RHOX,HYDROMASS,COL
REAL RADXX(NKR),MASSXX(NKR)
REAL TERM1,TERM2A,TERM2B,TERM2C
REAL FCONC(NKR),HYDROSUM
DOUBLE PRECISION D1,D2,D3,D4,D5,D6,D7A,D7B
DOUBLE PRECISION VAR1,VAR2,VAR3,VAR4,VAR5,VAR6
! HYDROMASS IN kg/kg
! VAR1=NZERO
! VAR2=RHOX
! VAR3=MASSXX(1,IHYDR)
! VAR4=RADXX(1,IHYDR)
! VAR5=MASSMM5
! VAR6=(6.*VAR1/VAR2)*VAR3/(8.*VAR4**3)*(1./VAR5)
! var6 =sqrt(sqrt(var6))
! print*,'radxx(1) = ',RADXX(1)
! print*,'rhox = ',rhox
! print*,'massmm5 = ',massmm5
! print*,'nzero = ',nzerO
! print*,'massxx = ',MASSXX(1)
LAMBDAHYD=(6.*NZERO/RHOX)*MASSXX(1)/(8.*RADXX(1)**3) &
& *(1./MASSMM5)
LAMBDAHYD=SQRT(SQRT(LAMBDAHYD))
HYDROSUM =0
TERM1=(NZERO/RHOX)*(MASSXX(1)/(8.*RADXX(1)**3))
DO NKRI=1,NKR
IF(NKRI.EQ.1)THEN
D1=LAMBDAHYD*2.*RADXX(NKRI)
D2=0
ELSE
D1=LAMBDAHYD*2.*RADXX(NKRI)
D2=LAMBDAHYD*2.*RADXX(NKRI-1)
END IF
D3=DEXP(-D1)
D4=DEXP(-D2)
D5 = (1./LAMBDAHYD**4)
D6=TERM1
IF (NKRI.EQ.1)THEN
D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
D7B=-6.*D5
ELSE
D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
END IF
HYDROMASS= D6*(D7A-D7B)
HYDROSUM=HYDROSUM+HYDROMASS
FCONC(NKRI)=HYDROMASS*RHOX/(COL &
& *MASSXX(NKRI)*MASSXX(NKRI)*3)
IF (HYDROMASS .LT.0)THEN
call wrf_error_fatal("fatal error in module_mp_full_sbm (HYDROMASS.LT.0), model stop")
END IF
END DO
! print*, 'massmm5,hydrosum =',massmm5,hydrosum
IF (HYDROSUM.LT.MASSMM5)THEN
D1=LAMBDAHYD*2.*RADXX(NKR)
D2=LAMBDAHYD*2.*RADXX(NKR-1)
D3=DEXP(-D1)
D4=DEXP(-D2)
D5 = (1./LAMBDAHYD**4)
D6=TERM1
D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
HYDROMASS= D6*(D7A-D7B)+(MASSMM5-HYDROSUM)
FCONC(NKR)=HYDROMASS*RHOX/(COL &
& *MASSXX(NKR)*MASSXX(NKR)*3)
HYDROSUM=HYDROSUM+(MASSMM5-HYDROSUM)
END IF
! print*, 'massmm5,hydrosum adj =',massmm5,hydrosum
RETURN
END SUBROUTINE BOUNDNUM
! NEW (OLD) MELTING CODE
!====================================================================
! Version of 23.08.04
SUBROUTINE MELTING &,71
(ihucm_flag &
,FF1,XL,VTL &
,FF2,XI,V2,VTC,FLIQFR_I,RHO_I &
,FF3,XS,V3,VTS,FLIQFR_S,RHO_S &
,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
,XI_MELT,XS_MELT,XG_MELT,XH_MELT &
,TIN,rhoa,pres,DT,QQV)
!===============================================!
! EXPLICIT MELTING SCHEME !
! Author: Vaughan T.J. PHILLIPS, August 2004 !
! at Princeton University (AOS program) !
! and GFDL, NOAA/OAR, USA !
!===============================================!
implicit double precision (a-h,o-z)
! new change 27.03.07 (start)
!PARAMETER(NKR=33, NK=129, ICEMAX=3)
! new change 27.03.07 (end)
! new change 12.02.07 (start)
PARAMETER(CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
PETIT_PARAMETRE=1.D-10)
PARAMETER (ivt_G_H_interpol=0)
! new change 12.02.07 (end)
! new change 12.02.07 (start)
PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
! new change 12.02.07 (end)
! control in main program & others subroutines
! new change 29.10.08 (start)
! new change 29.10.08 (end)
DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
DIMENSION FF2(NKR,ICEMAX),XI(NKR,ICEMAX),V2(NKR,ICEMAX), &
VTC(NKR,ICEMAX),FLIQFR_I(NKR,ICEMAX),RHO_I(NKR,ICEMAX)
DIMENSION FF3(NKR),XS(NKR),V3(NKR), &
VTS(NKR),FLIQFR_S(NKR),RHO_S(NKR)
DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
DIMENSION FF1_SI(NKR), XL_SI(NKR), VTL_SI(NKR)
DIMENSION FF2_SI(NKR,ICEMAX),XI_SI(NKR,ICEMAX),V2_SI(NKR,ICEMAX), &
VTC_SI(NKR,ICEMAX),RHO_I_SI(NKR,ICEMAX)
DIMENSION FF3_SI(NKR),XS_SI(NKR),V3_SI(NKR), &
VTS_SI(NKR), RHO_S_SI(NKR)
DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
VTG_SI(NKR), RHO_G_SI(NKR)
DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
VTH_SI(NKR), RHO_H_SI(NKR)
DIMENSION &
XI_MELT(NKR,ICEMAX),XS_MELT(NKR),XG_MELT(NKR),XH_MELT(NKR)
DIMENSION &
XI_MELT_SI(NKR,ICEMAX),XS_MELT_SI(NKR),XG_MELT_SI(NKR),XH_MELT_SI(NKR)
INTRINSIC SUM
If(TIN <= 273.15D0) then
RETURN
ENDIF
if(SUM(FF2) <= 0.D0.and.SUM(FF3) <= 0.D0.and.SUM(FF4) <= 0.D0.and. &
SUM(FF5) <= 0.D0) then
return
endif
!=============================================================
! UNIT CONVERSION OF ALL INPUTS to SI
!=============================================================
if(ihucm_flag == 1) then
RHO_I_SI = RHO_I*1000.D0
RHO_S_SI = RHO_S*1000.D0
RHO_G_SI = RHO_G*1000.D0
RHO_H_SI = RHO_H*1000.D0
XL_SI = XL/1000.D0
XI_SI = XI/1000.D0
XS_SI = XS/1000.D0
XG_SI = XG/1000.D0
XH_SI = XH/1000.D0
XI_MELT_SI = XI_SI
XS_MELT_SI = XS_SI
XG_MELT_SI = XG_SI
XH_MELT_SI = XH_SI
VTL_SI = VTL/100.D0
VTC_SI = VTC/100.D0
VTS_SI = VTS/100.D0
!do kr=1,nkr
! print*,'vts within = ',vts(kr)
!end do
VTG_SI = VTG/100.D0
VTH_SI = VTH/100.D0
V2_SI = V2/100.D0
V3_SI = V3/100.D0
V4_SI = V4/100.D0
V5_SI = V5/100.D0
FF1_SI = 1.E9*FF1
FF2_SI = 1.E9*FF2
FF3_SI = 1.E9*FF3
FF4_SI = 1.E9*FF4
FF5_SI = 1.E9*FF5
pres_SI = pres/10.D0
rhoa_SI = rhoa*1000.D0
! in case ihucm_flag == 1
else
! in case ihucm_flag.NE.1
RHO_I_SI = RHO_I
RHO_S_SI = RHO_S
RHO_G_SI = RHO_G
RHO_H_SI = RHO_H
XL_SI = XL
XI_SI = XI
XS_SI = XS
XG_SI = XG
XH_SI = XH
XI_MELT_SI = XI_SI
XS_MELT_SI = XS_SI
XG_MELT_SI = XG_SI
XH_MELT_SI = XH_SI
VTL_SI = VTL
VTC_SI = VTC
VTS_SI = VTS
VTG_SI = VTG
VTH_SI = VTH
V2_SI = V2
V3_SI = V3
V4_SI = V4
V5_SI = V5
FF1_SI = FF1
FF2_SI = FF2
FF3_SI = FF3
FF4_SI = FF4
FF5_SI = FF5
pres_SI = pres
rhoa_SI = rhoa
! in case ihucm_flag.NE.1
endif
!=============================================================
! INITIALISATION
!=============================================================
!
V2_SI(:,:) = VTC_SI(:,:)
V3_SI(:) = VTS_SI(:)
V4_SI(:) = VTG_SI(:)
V5_SI(:) = VTH_SI(:)
ee = QQV*pres_SI/(EPS + QQV)
es_zero = 611.21D0
if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PSI is wrong), model stop")
D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
! D_V = 2.21D-5
! FK_a = 2.40D-2
FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
! XLV = 2.50D6
! XLF = 2.83D6 - XLV
! The expressions for latent heats used by R&H, 1987,
! seem more applicable to
! T > 0degC than
! those by P & K 1997, and more modern
! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
XLV = 597.3D0
XLV = XLV*FJOULES_IN_A_CAL*1000.D0
XLS = 2.83D6
!XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
XLF = 79.7D0
XLF = XLF*FJOULES_IN_A_CAL*1000.D0
! FNSC=0.632D0
etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
! etaa/rhoa_SI = kinematic viscosity
FNSC = etaa/(rhoa_SI*D_V)
! FNPR=0.71D0
ALPHA_H = FK_a/(CP*rhoa_SI)
FNPR = etaa/(rhoa_SI*ALPHA_H)
RHO_CRIT = 910.D0
!if(IPRINTING==1) print *, &
! 'FNSC,FNPR,XLF,XLV = ', FNSC, FNPR, XLF, XLV
if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI>2), model stop 111")
if(rhoa_SI < 0.1D0) then
call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI<0.1), model stop 112")
endif
if(RHO_H_SI(1) < 1.D0) then
call wrf_error_fatal("fatal error in module_mp_full_sbm (RHO_H_SI(1) < 1.D0kg/m3), model stop 113")
endif
! new changes 23.08.04 (start)
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
if(TS > 273.15D0) TS = 273.15D0
! new changes 23.08.04 (end)
!=============================================================
! CRYSTALS
!=============================================================
DO I = 1, ICEMAX
I_MELT=I
DO IK = 1, NKR
IK_MELT=IK
if(TIN > 273.15D0) then
IF(FLIQFR_I(IK,I).GE.1.D0.OR.FF2_SI(IK,I).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_I(IK,I) > 1.D0) FLIQFR_I(IK,I) = 1.D0
CYCLE
ENDIF
rho_p=RHO_I_SI(IK,I)+FLIQFR_I(IK,I)*(RHO_WATER-RHO_I_SI(IK,I))
fm_i = XI_SI(IK,I)*(1.D0 - FLIQFR_I(IK,I))
fm_w = XI_SI(IK,I)*FLIQFR_I(IK,I)
V_p = (fm_i+fm_w)/rho_p
V_i = V_p
rhoi = fm_i/V_i
! COLUMN (Heymsfield 1972) AR = 2 to 5
IF(I.eq.1) then
AR_izero = column_AR(XI_SI(IK,I), RHO_I_SI(IK,I))
AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
if(AR_i < AR_LIM) AR_i = AR_LIM
CAP_izero = COLUMN_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
vt_R = VTL_SI(IK)
vt_start = VTC_SI(IK,I)
vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
fnre = vt *FL_star*rhoa_SI/etaa
fv = COLUMN_VENTILATION_COEF(fnre, FNSC)
! in case I.eq.1
endif
! PLATE C1g type (see P1a in p52 in P&K)
IF(I.eq.2) then
AR_izero = PLATE_AR(XI_SI(IK,I))
AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
if(AR_i > 1.D0/AR_LIM) AR_i = 1.D0/AR_LIM
CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
vt_R = VTL_SI(IK)
vt_start = VTC_SI(IK,I)
vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
fnre = vt * FL_star*rhoa_SI/etaa
fv = PLATE_VENTILATION_COEF(fnre, FNSC)
! in case I.eq.2
endif
! DENDRITES P1c type (see P1c in p52 in P&K)
IF(I.eq.3) then
AR_izero = DENDRITE_AR(XI_SI(IK,I))
AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
if(AR_i > 1./AR_LIM) AR_i = 1.D0/AR_LIM
CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
vt_R = VTL_SI(IK)
vt_start = VTC_SI(IK,I)
vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
fnre = vt * FL_star*rhoa_SI/etaa
fv = DENDRITE_VENTILATION_COEF(fnre, FNSC)
! in case I.eq.3
endif
! CAP = V**(1./3.)
V2_SI(IK,I) = vt
CAP = CAP_izero*(0.8D0 + FLIQFR_I(IK,I)*0.2D0)
FICEMASS = XI_SI(IK,I) * (1.D0 - FLIQFR_I(IK,I))
DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
(FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
(ee/TIN - es_zero/273.15D0))
! new changes 23.08.04 (start)
if(TS < 273.15D0 .and. FLIQFR_I(IK,I) <= 0.D0) DMELT = 0.D0
! new changes 23.08.04 (end)
call fmass_limits(DMELT, FICEMASS, fm_w, XI_SI(IK,I))
if(ITEMP_ADJUST == 1) then
call thermodynamical_limits &
(FF2_SI(IK,I), XI_SI(IK,I), rhoa_SI, XLF/CP, TIN, DMELT)
! in case ITEMP_ADJUST == 1
endif
FICEMASS = FICEMASS - DMELT
! DMELT > 0 for melting
FLIQFR_I(IK,I) = (XI_SI(IK,I) - FICEMASS)/XI_SI(IK,I)
if(FLIQFR_I(IK,I) < 0.D0) FLIQFR_I(IK,I) = 0.D0
if(FLIQFR_I(IK,I) > 0.D0) then
if(IEVAP_ADJUST == 1 ) then
if(FLIQFR_I(IK,I) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (FLIQFR_I > 1), model stop 114")
! HEAT_EVAP = Joules of latent heat absorbed (released)
! by FMASS_EVAP, kg
! of water evaporating (condensation)
! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
! new changes 24.08.04 (start)
IF(HEAT_EVAP.LT.0.D0) THEN
! PRINT*, 'HEAT_EVAP < 0'
! PRINT*, 'CRYSTAL'
! PRINT*, 'I_MELT'
! PRINT*, I_MELT
! PRINT*, 'IJK,KX,KZ,IK'
! PRINT*, IJK,KX,KZ,IK_MELT
! HEAT_EVAP=0.D0
! in case HEAT_EVAP.LT.0.D0
ENDIF
! new changes 24.08.04 (end)
FMASS_EVAP = HEAT_EVAP/XLV
if(FMASS_EVAP > FLIQFR_I(IK,I) * XI_SI(IK,I)) then
FMASS_EVAP = FLIQFR_I(IK,I) * XI_SI(IK,I)
endif
Q_EVAP=FMASS_EVAP*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
CALL EVAP_MELTWATER &
(XI_SI(IK,I),rhoa_SI,Q_EVAP,FLIQFR_I(IK,I),FF2_SI(IK,I))
XI_MELT_SI(IK,I)=XX_MELT
! I assume that, during the period before the RH-dependent onset
! of melting is reached, the loss of mass of water
! by evaporation is as negligible as the source of mass
! of meltwater from melting itself
!(see Rasmussen and Pruppacher 1982; P & K 1997)
TIN=TIN-XLV/CP*Q_EVAP
QQV=QQV+Q_EVAP
! new changes 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new changes 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
! in case IEVAP_ADJUST == 1
endif
! in case FLIQFR_I(IK,I) > 0.D0
else
! in case FLIQFR_I(IK,I).LE.0.D0
if(ISUBLIME_ADJUST == 1 ) then
! new changes 24.08.04 (start)
if(TS > 273.16) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 13655")
sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
sub_fac = sub_fac + RV*TIN/((100.D0*GGESI(TS))*D_V)
DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
! new changes 24.08.04 (end)
if(DSUB > XI_SI(IK,I)) then
DSUB = XI_SI(IK,I)
endif
Q_SUBL = DSUB*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
CALL SUBLIME_ICE &
(XI_SI(IK,I),rhoa_SI,Q_SUBL,FF2_SI(IK,I))
XI_MELT_SI(IK,I)=XX_MELT
TIN=TIN-XLS/CP*Q_SUBL
QQV=QQV+Q_SUBL
! new changes 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new changes 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop ")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm ( TIN < 150) , model stop ")
! in case ISUBLIME_ADJUST == 1
endif
! in case FLIQFR_I(IK,I).LE.0.D0
endif
if(FLIQFR_I(IK,I) < 0.D0) then
FLIQFR_I(IK,I) = 0.D0
endif
IF(FLIQFR_I(IK,I) > FLIQFRAC_LIM) then
if(XL_SI(IK).NE.XI_SI(IK,I)) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop 7011")
if(ITEMP_ADJUST == 1) then
Q_ICE_MELTED= &
FICEMASS*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
TIN=TIN-XLF/CP*Q_ICE_MELTED
! in case ITEMP_ADJUST == 1
endif
FF1_SI(IK) = FF1_SI(IK) + FF2_SI(IK,I)
! FLIQFR_I(IK,I) = 0.
FLIQFR_I(IK,I) = 1.D0
FF2_SI(IK,I) = 0.D0
! in case FLIQFR_I(IK,I) > FLIQFRAC_LIM
ENDIF
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
ENDDO
! cycle by I
!=============================================================
! SNOW
!=============================================================
DO IK = 1, NKR
IK_MELT=IK
I_MELT=0
if(TIN > 273.15D0) then
IF(FLIQFR_S(IK).GE.1.D0.OR.FF3_SI(IK).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_S(IK) > 1.D0) FLIQFR_S(IK) = 1.D0
CYCLE
ENDIF
rho_p = RHO_S_SI(IK) + FLIQFR_S(IK)* &
(RHO_WATER - RHO_S_SI(IK))
fm_i = XS_SI(IK)*(1.D0 - FLIQFR_S(IK))
fm_w = XS_SI(IK)*FLIQFR_S(IK)
V_p = (fm_i + fm_w)/rho_p
V_i = V_p
rhoi = fm_i/V_i
!
! Based on Mitra et al. (1990)/Matsuo and Sasyo (1981)
! V_p = (4/3) PI AR a_i**3
!
! ASSUME:- (1) snowflakes have an ice skeleton structure that
! is incollapsable,
! but of varing AR, until completion of melting;
! (2) melting occurs only at snowflake exterior surface and water
! then penetrates inside
!
! fm_i in the text of Mitra et al is the mass of the ice component
! a_i (b_i) are the major (minor) axes of the ice skeleton
! AR = b_i/a_i
AR_p = 0.3D0 + 0.7D0 * FLIQFR_S(IK)
! new change 26.07.04 (start)
! the rest of the HUCM seems to assume that snow is spherical
!(see JERRATE)
! AR_p = 1.
! new change 26.07.04 (end)
AR_i = AR_p
CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
CAP = CAP_izero*(0.8D0 + FLIQFR_S(IK)*0.2D0)
vt_R = VTL_SI(IK)
vt_start = VTS_SI(IK)
vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
fnre = FL_star * vt*rhoa_SI/etaa
! new change 24.08.04 (start)
fv = SNOW_VENTILATION_COEF(fnre, FNSC, AR_i)
! new change 24.08.04 (end)
V3_SI(IK) = vt
FICEMASS = XS_SI(IK) * (1.D0 - FLIQFR_S(IK))
DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
(FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
(ee/TIN - es_zero/273.15D0))
! new change 24.08.04 (start)
if(TS < 273.15D0 .and. FLIQFR_S(IK) <= 0.D0) DMELT = 0.D0
! new change 24.08.04 (end)
call fmass_limits(DMELT, FICEMASS, fm_w, XS_SI(IK))
if(ITEMP_ADJUST == 1) then
call thermodynamical_limits &
(FF3_SI(IK), XS_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
! in case ITEMP_ADJUST == 1
endif
FICEMASS = FICEMASS - DMELT
FLIQFR_S(IK) = (XS_SI(IK) - FICEMASS)/XS_SI(IK)
if(FLIQFR_S(IK) < 0.D0) then
FLIQFR_S(IK) = 0.D0
endif
if(FLIQFR_S(IK) > 0.D0) then
if(IEVAP_ADJUST == 1) then
if(FLIQFR_S(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 905")
! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
! of water evaporating
! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
! new change 24.08.04 (start)
IF(HEAT_EVAP.LT.0.D0) THEN
! PRINT*, 'HEAT_EVAP < 0'
! PRINT*, 'SNOW'
! PRINT*, 'IJK,KX,KZ,IK'
! PRINT*, IJK,KX,KZ,IK_MELT
! HEAT_EVAP=0.D0
ENDIF
! new change 24.08.04 (end)
FMASS_EVAP = HEAT_EVAP/XLV
if(FMASS_EVAP > FLIQFR_S(IK) * XS_SI(IK)) then
FMASS_EVAP = FLIQFR_S(IK) * XS_SI(IK)
endif
Q_EVAP= FMASS_EVAP*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
CALL EVAP_MELTWATER &
(XS_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_S(IK),FF3_SI(IK))
XS_MELT_SI(IK)=XX_MELT
TIN=TIN-XLV/CP*Q_EVAP
QQV=QQV+Q_EVAP
! new change 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new change 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 915")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 916")
! in case IEVAP_ADJUST == 1
endif
! in case FLIQFR_S(IK) > 0.D0
else
! in case FLIQFR_S(IK).LE.0.D0
if(ISUBLIME_ADJUST == 1) then
sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
! new change 24.08.04 (start)
sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
! new change 24.08.04 (end)
if(DSUB > XS_SI(IK)) then
DSUB = XS_SI(IK)
endif
Q_SUBL = DSUB*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
CALL SUBLIME_ICE(XS_SI(IK),rhoa_SI,Q_SUBL,FF3_SI(IK))
XS_MELT_SI(IK)=XX_MELT
TIN=TIN-XLS/CP*Q_SUBL
QQV=QQV+Q_SUBL
! new change 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new change 24.08.04 (end)
if(QQV < 0.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
if(TIN < 150.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
! in case ISUBLIME_ADJUST == 1
endif
! in case FLIQFR_S(IK).LE.0.D0
endif
if(FLIQFR_S(IK) < 0.D0) then
FLIQFR_S(IK) = 0.D0
endif
IF(FLIQFR_S(IK) > FLIQFRAC_LIM) then
if(XL_SI(IK).NE.XS_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7012")
if(ITEMP_ADJUST == 1) then
Q_ICE_MELTED=FICEMASS*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
TIN=TIN-XLF/CP*Q_ICE_MELTED
! in case ITEMP_ADJUST == 1
endif
FF1_SI(IK) = FF1_SI(IK) + FF3_SI(IK)
! FLIQFR_S(IK) = 0.D0
FLIQFR_S(IK) = 1.D0
FF3_SI(IK) = 0.D0
! in case FLIQFR_S(IK) > FLIQFRAC_LIM
ENDIF
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
!
!=============================================================
! GRAUPEL (assumed to be spheres)
!=============================================================
DO IK = 1, NKR
IK_MELT=IK
I_MELT=0
if(TIN > 273.15D0) then
IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
CYCLE
ENDIF
!
vt_start = 0.D0
vt_end = 0.D0
!
rhoi = RHO_G_SI(IK)
fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
V_i = fm_i/rhoi
fm_w = XG_SI(IK)*FLIQFR_G(IK)
V_w = fm_w/RHO_WATER
if(rhoi < RHO_CRIT) then
V_soakable = V_i - fm_i/RHO_ICE
else
V_soakable = 0.D0
endif
a_i = rad_sphere(V_i)
a_izero = rad_sphere(XG_SI(IK)/rhoi)
fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
!(fnre_smooth is invariant during melting)
X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
fnre_smooth = fnre_sphere(X_Best)
if(V_w < V_soakable) then
a_d = a_i
vt=VT_LOW_DENSITY_SOAKING &
(fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
! in case V_w < V_soakable
else
! in case V_w >= V_soakable
a_d = rad_sphere(V_i + (V_w - V_soakable))
fm_w_soaked = RHO_WATER* V_soakable
fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
fm_w_crit = fm_w_crit* 1.D-3
a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
if(rhoi < RHO_CRIT) then
vt_start = VT_LOW_DENSITY_TRANS &
(fnre_dry, fnre_smooth, &
VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
else
vt_start=VT_HIGH_DENSITY_TRANS &
(fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
endif
vt_end=equilibrium_fallspeed &
(fm_i+fm_w_soaked,fm_w_crit, &
XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
if(frac_eqm < 0.D0) frac_eqm = 0.D0
if(frac_eqm > 1.D0) frac_eqm = 1.D0
vt = vt_start + (vt_end - vt_start) * frac_eqm
if(vt < 0.D0) vt = 0.D0
! in case V_w >= V_soakable
endif
! new changes 23.01.08 (start)
! new changes 3.02.08 (start)
if(ivt_G_H_interpol.ne.0) then
vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
endif
! new changes 3.02.08 (end)
! new changes 23.01.08 (end)
V4_SI(IK) = vt
fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
! new change 5.02.07 (start)
fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
! new change 5.02.07 (end)
! new change 24.08.04 (start)
if(FLIQFR_G(IK) <= 0.D0) then
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
else
TS = 273.15D0
endif
if(TS > 273.15D0) TS = 273.15D0
! new change 24.08.04 (end)
if(fnre < 6000.D0) then
CAP = a_d
else
CAP = a_i
endif
FICEMASS = XG_SI(IK) * (1.D0 - FLIQFR_G(IK))
DMELT = DT*(4.D0*PI*CAP/XLF) * &
(FK_a*(TIN-273.15D0)*fh+(D_V*XLV/RV)*fv*(ee/TIN - es_zero/273.15D0))
! new change 24.08.04 (start)
if(TS < 273.15D0 .and. FLIQFR_G(IK) <= 0.) DMELT = 0.D0
! new change 24.08.04 (end)
call fmass_limits(DMELT, FICEMASS, fm_w, XG_SI(IK))
if(ITEMP_ADJUST == 1) then
call thermodynamical_limits &
(FF4_SI(IK), XG_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
! in case ITEMP_ADJUST == 1
endif
FICEMASS = FICEMASS - DMELT
FLIQFR_G(IK) = (XG_SI(IK) - FICEMASS)/XG_SI(IK)
if(FLIQFR_G(IK) < 0.D0) then
FLIQFR_G(IK) = 0.D0
endif
if(FLIQFR_G(IK) > 0.D0) then
if(IEVAP_ADJUST == 1) then
if(FLIQFR_G(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 901")
! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
! of water evaporating
! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
! new changes 24.08.04 (start)
IF(HEAT_EVAP.LT.0.D0) THEN
! PRINT*, 'HEAT_EVAP < 0'
! PRINT*, 'GRAUPEL'
! PRINT*, 'IJK,KX,KZ,IK'
! PRINT*, IJK,KX,KZ,IK_MELT
! HEAT_EVAP=0.D0
ENDIF
! new change 24.08.04 (end)
FMASS_EVAP=HEAT_EVAP/XLV
if(FMASS_EVAP > FLIQFR_G(IK)*XG_SI(IK)) then
FMASS_EVAP = FLIQFR_G(IK)*XG_SI(IK)
endif
Q_EVAP = FMASS_EVAP * FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
! in case IEVAP_ADJUST == 1
endif
! in case FLIQFR_G(IK) > 0.D0
else
! in case FLIQFR_G(IK) <= 0.D0
if(ISUBLIME_ADJUST == 1)then
sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
! new change 24.08.04 (start)
sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
! new change 24.08.04 (end)
if(DSUB > XG_SI(IK)) then
DSUB = XG_SI(IK)
endif
Q_SUBL = DSUB*FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
CALL SUBLIME_ICE( XG_SI(IK), rhoa_SI, Q_SUBL, FF4_SI(IK))
XG_MELT_SI(IK)=XX_MELT
!
TIN = TIN - XLS/CP*Q_SUBL
QQV = QQV + Q_SUBL
! new change 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new change 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
! in case ISUBLIME_ADJUST == 1
endif
! in case FLIQFR_G(IK) <= 0.D0
endif
IF(FLIQFR_G(IK) > FLIQFRAC_LIM) then
if(XL_SI(IK).NE.XG_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7013")
if(ITEMP_ADJUST == 1) then
Q_ICE_MELTED = FICEMASS *FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
TIN = TIN - XLF/CP*Q_ICE_MELTED
! in case ITEMP_ADJUST == 1
endif
FF1_SI(IK) = FF1_SI(IK) + FF4_SI(IK)
! FLIQFR_G(IK) = 0.D0
FLIQFR_G(IK) = 1.D0
FF4_SI(IK) = 0.D0
! in case FLIQFR_G(IK) > FLIQFRAC_LIM
ENDIF
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
!
!=============================================================
! HAIL (assumed to be spheres)
!=============================================================
DO IK = 1, NKR
IK_MELT=IK
I_MELT=0
if(TIN > 273.15D0) then
IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
CYCLE
ENDIF
vt_start = 0.D0
vt_end = 0.D0
rhoi = RHO_H_SI(IK)
fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
V_i = fm_i/rhoi
fm_w = XH_SI(IK)*FLIQFR_H(IK)
V_w = fm_w/RHO_WATER
if(rhoi < RHO_CRIT) then
V_soakable = V_i - fm_i/RHO_ICE
else
V_soakable = 0.D0
endif
a_i = rad_sphere(V_i)
a_izero = rad_sphere(XH_SI(IK)/rhoi)
! FIND RE OF SMOOTH SPHERE OF SAME MASS
! (fnre_smooth is invariant during melting)
if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
fnre_smooth=fnre_sphere(X_Best)
vt_justwet = 0.D0
vt_justsoaked = 0.D0
if(V_w < V_soakable) then
! SOAKING OF WATER
a_d = a_i
vt=VT_LOW_DENSITY_SOAKING &
(fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
! in case V_w < V_soakable
else
! in case V_w >= V_soakable
a_d = rad_sphere(V_i + (V_w - V_soakable))
fm_w_soaked = RHO_WATER* V_soakable
fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
fm_w_crit = fm_w_crit* 1.D-3
a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
!RH87: Just-wet terminal velocity - look at history
!of same particle passing 0oC
!(ie. 'just-wet' means when 0degC is just reached
!by surface and melting commences):
if(rhoi < RHO_CRIT) then
vt_start = VT_LOW_DENSITY_TRANS &
(fnre_dry,fnre_smooth, &
VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
else
vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
VTH_SI(IK), a_izero, etaa, rhoa_SI)
endif
vt_end=equilibrium_fallspeed &
(fm_i + fm_w_soaked, fm_w_crit, XH(:), &
VTL_SI(:), rhoa_SI, etaa, a_crit)
! RH87: Interpolation based on fraction of equilibrium water
! on surface
frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
if(frac_eqm < 0.D0) frac_eqm = 0.D0
if(frac_eqm > 1.D0) frac_eqm = 1.D0
vt = vt_start + (vt_end - vt_start) * frac_eqm
if(vt < 0.D0) then
if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
vt = 0.D0
endif
if(IPRINTING == 1) print *, &
'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
vt_start,vt_end,a_izero/a_i
if(IPRINTING == 1) print *, &
'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
! in case V_w >= V_soakable
endif
! new changes 23.01.08 (start)
! new changes 3.02.08 (start)
if(ivt_G_H_interpol.ne.0) then
vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
endif
! new changes 3.02.08 (end)
! new changes 23.01.08 (end)
V5_SI(IK) = vt
if(IPRINTING == 1) print *, 'HERE 2: VT,LIQUID FRACTION,IK', &
V5_SI(IK),FLIQFR_H(IK),IK
fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
! new change 5.02.07 (start)
fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
! new change 5.02.07 (end)
! new change 24.08.04 (start)
if(FLIQFR_H(IK) <= 0.D0) then
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
else
TS = 273.15D0
endif
if(TS > 273.15D0) TS = 273.15D0
! new change 24.08.04 (end)
if(fnre < 6000.D0) then
CAP = a_d
else
CAP = a_i
endif
FICEMASS = XH_SI(IK) * (1.D0 - FLIQFR_H(IK))
DMELT = DT*4.D0*PI*CAP/XLF* &
(FK_a*(TIN-273.15D0)*fh+D_V*XLV/RV*fv*(ee/TIN-es_zero/273.15D0))
! new change 24.08.04 (start)
if(TS < 273.15D0 .and. FLIQFR_H(IK) <= 0.) DMELT = 0.D0
! new change 24.08.04 (end)
!
call fmass_limits (DMELT,FICEMASS,fm_w,XH_SI(IK))
!
if(ITEMP_ADJUST == 1) then
call thermodynamical_limits &
(FF5_SI(IK),XH_SI(IK),rhoa_SI,XLF/CP,TIN,DMELT)
! in case ITEMP_ADJUST == 1
endif
FICEMASS = FICEMASS - DMELT
FLIQFR_H(IK) = (XH_SI(IK) - FICEMASS)/XH_SI(IK)
if(FLIQFR_H(IK) < 0.D0) then
FLIQFR_H(IK) = 0.D0
endif
if(FLIQFR_H(IK) > 0.D0) then
if(IEVAP_ADJUST == 1) then
if( FLIQFR_H(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 906")
! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
! of water evaporating
! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
! new changes 24.08.04 (start)
IF(HEAT_EVAP.LT.0.D0) THEN
! PRINT*, 'HEAT_EVAP < 0'
! PRINT*, 'GRAUPEL'
! PRINT*, 'IJK,KX,KZ,IK'
! PRINT*, IJK,KX,KZ,IK_MELT
! HEAT_EVAP=0.D0
ENDIF
! new change 24.08.04 (end)
FMASS_EVAP = HEAT_EVAP/XLV
if(FMASS_EVAP > FLIQFR_H(IK) * XH_SI(IK)) then
FMASS_EVAP = FLIQFR_H(IK) * XH_SI(IK)
endif
Q_EVAP=FMASS_EVAP*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
CALL EVAP_MELTWATER &
(XH_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_H(IK),FF5_SI(IK))
XH_MELT_SI(IK)=XX_MELT
TIN = TIN - XLV/CP*Q_EVAP
QQV = QQV + Q_EVAP
! new change 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new change 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
! in case IEVAP_ADJUST == 1
endif
! in case FLIQFR_H(IK) > 0.D0
else
! in case FLIQFR_H(IK) <= 0.D0
if(ISUBLIME_ADJUST == 1) then
sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
! new change 24.08.04 (start)
sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
! new change 24.08.04 (end)
if(DSUB > XH_SI(IK)) then
DSUB = XH_SI(IK)
endif
Q_SUBL = DSUB*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
CALL SUBLIME_ICE(XH_SI(IK),rhoa_SI,Q_SUBL,FF5_SI(IK))
XH_MELT_SI(IK)=XX_MELT
TIN = TIN - XLS/CP*Q_SUBL
QQV = QQV + Q_SUBL
! new change 24.08.04 (start)
ee = QQV*pres_SI/(EPS + QQV)
! new change 24.08.04 (end)
if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
! in case ISUBLIME_ADJUST == 1
endif
! in case FLIQFR_H(IK) <= 0.D0
endif
if(FLIQFR_H(IK) < 0.D0) then
FLIQFR_H(IK) = 0.D0
endif
IF(FLIQFR_H(IK) > FLIQFRAC_LIM) then
if(XL_SI(IK).NE.XH_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7014")
if(ITEMP_ADJUST == 1) then
Q_ICE_MELTED = FICEMASS *FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
TIN = TIN - XLF/CP*Q_ICE_MELTED
! in case ITEMP_ADJUST == 1
endif
FF1_SI(IK) = FF1_SI(IK) + FF5_SI(IK)
! FLIQFR_H(IK) = 0.D0
FLIQFR_H(IK) = 1.D0
FF5_SI(IK) = 0.D0
! in case FLIQFR_H(IK) > FLIQFRAC_LIM
ENDIF
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
!=============================================================
! UNIT CONVERSION OF ALL OUTPUTS from SI
!=============================================================
!
if(ihucm_flag == 1) then
if(IVT_ADJUST == 1) then
V2 = 100.D0 * V2_SI
V3 = 100.D0 * V3_SI
V4 = 100.D0 * V4_SI
V5 = 100.D0 * V5_SI
endif
FF1 = 1.D-9*FF1_SI
FF2 = 1.D-9*FF2_SI
FF3 = 1.D-9*FF3_SI
FF4 = 1.D-9*FF4_SI
FF5 = 1.D-9*FF5_SI
XI_MELT = XI_MELT_SI*1000.D0
XS_MELT = XS_MELT_SI*1000.D0
XG_MELT = XG_MELT_SI*1000.D0
XH_MELT = XH_MELT_SI*1000.D0
! in case ihucm_flag == 1
else
! in case ihucm_flag.NE.1
if(IVT_ADJUST == 1) then
V2 = V2_SI
V3 = V3_SI
V4 = V4_SI
V5 = V5_SI
endif
FF1 = FF1_SI
FF2 = FF2_SI
FF3 = FF3_SI
FF4 = FF4_SI
FF5 = FF5_SI
XI_MELT = XI_MELT_SI
XS_MELT = XS_MELT_SI
XG_MELT = XG_MELT_SI
XH_MELT = XH_MELT_SI
! in case ihucm_flag.NE.1
endif
101 FORMAT(1X,D13.5)
102 FORMAT(1X,2D13.5)
103 FORMAT(1X,3D13.5)
104 FORMAT(1X,4D13.5)
105 FORMAT(1X,5D13.5)
106 FORMAT(1X,6D13.5)
107 FORMAT(1X,7D13.5)
201 FORMAT(1X,I2,D13.5)
202 FORMAT(1X,I2,2D13.5)
203 FORMAT(1X,I2,3D13.5)
204 FORMAT(1X,I2,4D13.5)
END SUBROUTINE MELTING
! end of melting subroutine
SUBROUTINE EVAP_MELTWATER(XX,rhoax,Q_EVAPX,FLIQFRX,FFX) 3,4
implicit double precision (a-h,o-z)
PARAMETER(COL=0.23105D0)
! control in main program & others subroutines
! new change 29.10.08 (start)
! new change 29.10.08 (end)
total_mass= XX*FFX*XX*3.D0*COL/rhoax
total_mass_ice=(1.D0-FLIQFRX)*total_mass
total_mass_liq=FLIQFRX*total_mass
if(Q_EVAPX > total_mass_liq) Q_EVAPX = total_mass_liq
if(Q_EVAPX > total_mass) Q_EVAPX = total_mass
total_mass_liq = total_mass_liq - Q_EVAPX
total_mass = total_mass - Q_EVAPX
XX_MELT=total_mass*rhoax/(3.D0*XX*FFX*COL)
FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 136")
if(total_mass_liq < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 137")
if(total_mass_ice < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
IF(total_mass.EQ.0.D0) THEN
FLIQFRX =1.D0
ELSE
FLIQFRX = (total_mass - total_mass_ice)/total_mass
ENDIF
if(FLIQFRX < 0.D0) FLIQFRX = 0.D0
if(FLIQFRX > 1.D0) FLIQFRX = 1.D0
101 FORMAT(1X,D13.5)
102 FORMAT(1X,2D13.5)
103 FORMAT(1X,3D13.5)
104 FORMAT(1X,4D13.5)
105 FORMAT(1X,5D13.5)
106 FORMAT(1X,6D13.5)
END SUBROUTINE evap_meltwater
! end of evap_meltwater subroutine
!====================================================================
SUBROUTINE SUBLIME_ICE (XX,rhoax,Q_SUBLX,FFX) 4,2
implicit double precision (a-h,o-z)
PARAMETER(COL = 0.23105D0)
! new change 24.08.04 (start)
! new change 24.08.04 (end)
total_mass = XX*FFX*XX*3.D0*COL/rhoax
if(Q_SUBLX > total_mass) Q_SUBLX = total_mass
total_mass = total_mass - Q_SUBLX
! new change 20.06.04 (start)
XX_MELT=total_mass*rhoax/(3.D0*FFX*XX*COL)
! new change 20.06.04 (end)
FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
END SUBROUTINE sublime_ice
! end of sublime_ice subroutine
!====================================================================
FUNCTION VT_LOW_DENSITY_SOAKING &
(fnre_dryx,fnre_smoothx,vt_dryx,a_ix,a_izerox,etaax,rhoax)
implicit double precision (a-h,o-z)
! During melting, Re is constant (see RH87, Appendix B)
! but size changes
! Same as for just-wet case, except we use the current ice size
if(fnre_dryx > 4000.D0) then
vtx = vt_dryx * a_izerox/a_ix
! in case fnre_dryx > 4000.D0
else
! in case fnre_dryx <= 4000.D0
vtx = fnre_smoothx * etaax/(2.D0 * a_ix * rhoax)
! in case fnre_dryx <= 4000.D0
endif
VT_LOW_DENSITY_SOAKING = vtx
RETURN
END FUNCTION VT_LOW_DENSITY_SOAKING
! end of vt_low_density_soaking function
!====================================================================
FUNCTION VT_LOW_DENSITY_TRANS &,1
(fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax,rhoix,fm_tot)
implicit double precision (a-h,o-z)
PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
fm_ijustsoaked=fm_tot/(1.D0+RHO_WATER/rhoix-RHO_WATER/RHO_ICE)
a_ijustsoaked=rad_sphere(fm_ijustsoaked/rhoix)
if(fnre_dryx <= 4000.D0.or.rhoix < 800.D0) then
vt_justsoaked=fnre_smoothx*etaax/(2.D0*a_ijustsoaked*rhoax)
else
vt_justsoaked=vt_dryx*a_izerox/a_ijustsoaked
endif
vtx = vt_justsoaked
VT_LOW_DENSITY_TRANS = vtx
RETURN
END FUNCTION VT_LOW_DENSITY_TRANS
! end of function vt_low_density_trans
!====================================================================
FUNCTION VT_HIGH_DENSITY_TRANS & 2
(fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax)
implicit double precision (a-h,o-z)
PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
! Just-wet size = a_izero
if(fnre_dryx > 4000.D0) then
vt_justwet=vt_dryx
else
vt_justwet=fnre_smoothx*etaax/(2.D0*a_izerox*rhoax)
endif
vtx = vt_justwet
VT_HIGH_DENSITY_TRANS = vtx
RETURN
END FUNCTION VT_HIGH_DENSITY_TRANS
! end of function vt_high_density_trans
!====================================================================
! new change 5.02.07 (start)
FUNCTION HAIL_VENTILATION_COEF (fnrex, fnumber, KR) 8
! new change 5.02.07 (end)
implicit double precision (a-h,o-z)
! new change 29.10.08 (start)
! new change 29.10.08 (end)
if(fnrex < 6000.D0) then
X_F = (fnrex**0.5D0)*(fnumber**(1.D0/3.D0))
IF(X_F < 1.4D0) then
fx = 1.D0 + 0.108D0*X_F*X_F
ELSE
fx = 0.78D0 + 0.308D0*X_F
ENDIF
if(fnrex < 250.D0) then
fx = fx*2.D0
endif
! in case fnrex < 6000.D0
else
! in case fnrex >= 6000.D0
if(fnrex < 20000.D0) then
chi_fr = 0.76D0
else
chi_fr = 0.57 + fnrex*9.D-6
endif
fx = chi_fr*(fnrex**0.5D0)*(fnumber**(1.D0/3.D0))/2.D0
! in case fnrex >= 6000.D0
endif
if(fx < 1.D0) then
fx = 1.D0
endif
! new change 5.02.07 (start)
!if(fx > 100.D0) stop 99991
if(fx > 100.D0) then
! print*, 'IJK,KX,KZ,KR'
! print*, IJK,KX,KZ,KR
! print*, 'chi_fr,fnrex,fnumber,fx'
! print 204, chi_fr,fnrex,fnumber,fx
! print*, 'stop 99991 : fx > 100.D0'
! stop 99991
fx=100.D0
endif
! new change 5.02.07 (end)
HAIL_VENTILATION_COEF = fx
201 FORMAT(E13.5)
202 FORMAT(2E13.5)
203 FORMAT(3E13.5)
204 FORMAT(4E13.5)
205 FORMAT(5E13.5)
206 FORMAT(6E13.5)
207 FORMAT(7E13.5)
return
end function HAIL_VENTILATION_COEF
! end of hail_ventilation_coef function
!====================================================================
! new change 24.08.04 (start)
FUNCTION GGESI(T)
implicit double precision (a-h,o-z)
intrinsic DLOG10
!
! SATURATION VAPOR PRESSURE OVER ICE
! (GOFF AND GRATCH)
!
! ESI SATURATION VAPOR PRESSURE (MB)
! T TEMP (KELVIN)
!
DATA C1_MELT/-9.09718D0/C2_MELT/-3.56654D0/C3_MELT/0.876793D0/C4_MELT/0.78583503D0/
!
A = 273.16D0/T
B = C1_MELT*(A-1.0D0)+C2_MELT*DLOG10(A)+C3_MELT*(1.0D0-1.0D0/A)+C4_MELT
GGESI = 10.0D0**B
RETURN
END FUNCTION GGESI
! ending of GGESI function
! new change 24.08.04 (end)
!====================================================================
! new change 24.08.04 (start)
FUNCTION SNOW_VENTILATION_COEF(fnrex,fnumber, ARx) 1
! new change 24.08.04 (end)
implicit double precision (a-h,o-z)
X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
! new change 24.08.04 (start)
if(ARx == 1.D0) then
! real snow is not spherical, so this should not be used
IF(X_F < 1.4D0) then
fx = 1.D0 + 0.108D0*X_F*X_F
ELSE
fx = 0.78D0 + 0.308D0*X_F
ENDIF
else
! this is the correct formula for real snow
! new change 24.08.04 (end)
if(X_F.le.1.D0) then
fx=1.D0 + 0.14D0*X_F*X_F
else
fx = 0.86D0 + 0.28D0*X_F
endif
endif
if(fx < 1.D0) then
fx = 1.D0
endif
if(fx > 100.D0) then
print *,'99992 stop:',fx,X_F,fnrex,fnumber, ARx
fx = 100.D0
!stop 99992
endif
SNOW_VENTILATION_COEF = fx
return
end function SNOW_VENTILATION_COEF
! ending of SNOW_VENTILATION_COEF function
!====================================================================
! new change 24.08.04 (start)
!REAL FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV) 6
! new change 24.08.04 (end)
implicit double precision (a-h,o-z)
intrinsic DEXP, DABS
tsxold = 269.D0
tsx = 270.D0
tdiff = 1.D0
ilj = 0
alpha_ts = factor_vap*fvofh
beta_ts = alpha_ts*eex/tempK
do while(tdiff > 1.D-6)
! esix_check=611.21D0*(DEXP((tsx-273.15)*XLS /(RV * tsx * 273.15)))
esix = 100.D0*GGESI(tsx)
! print *, 'E_si = ', esix, ' Pa', ilj, esix_check
f_tsx = tempK - tsx - alpha_ts*esix/tsx + beta_ts
f_tsxold= &
tempK-tsxold-alpha_ts*100.D0*GGESI(tsxold)/tsxold+beta_ts
tsxnew = tsx - f_tsx*(tsx - tsxold)/(f_tsx - f_tsxold)
tsxold = tsx
tsx = tsxnew
tdiff = DABS(tsx - tsxold)
ilj = ilj + 1
if(ilj > 1e6) then
print *, &
'SURFACE_TEMP not converging', tsx,tempK,tdiff,fvofh,eex,esix
tsx = tempK
exit
endif
enddo
SURFACE_TEMP = tsx
return
END FUNCTION SURFACE_TEMP
! ending of SURFACE_TEMP function
! new change 24.08.04 (end)
!====================================================================
FUNCTION COLUMN_VENTILATION_COEF(fnrex, fnumber) 1,1
implicit double precision (a-h,o-z)
if(fnrex < 50.D0) then
X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
else
X_F = (50.D0**0.5D0) * (fnumber**(1.D0/3.D0))
endif
fx=1.D0-0.00668D0*X_F/4.D0+2.39402D0*((X_F/4.D0)**2.D0)+ &
0.73409D0*((X_F/4.D0)**3.D0)-0.73911D0*((X_F/4.D0)**4.D0)
if(fx < 1.D0) then
fx = 1.D0
endif
if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99993")
COLUMN_VENTILATION_COEF = fx
return
end function COLUMN_VENTILATION_COEF
! end of column_ventilation_coef function
!====================================================================
FUNCTION PLATE_VENTILATION_COEF(fnrex, fnumber) 1,1
implicit double precision (a-h,o-z)
if(fnrex < 150.D0) then
X_F = fnrex**0.5D0 * fnumber**(1.D0/3.D0)
else
X_F = 150.D0**0.5D0 * fnumber**(1.D0/3.D0)
endif
fx=1.D0-0.06042D0*X_F/10.D0+2.79820D0*((X_F/10.D0)**2.D0) - &
0.31933D0*((X_F/10.D0)**3.D0)-0.06247D0*((X_F/10.D0)**4.D0)
if(fx < 1.D0) then
fx = 1.D0
endif
if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99994")
PLATE_VENTILATION_COEF = fx
return
end function PLATE_VENTILATION_COEF
! end of plate_ventilation_coef function
!====================================================================
FUNCTION DENDRITE_VENTILATION_COEF(fnrex, fnumber) 1,1
implicit double precision (a-h,o-z)
if(fnrex < 150.D0) then
X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
else
X_F = (150.D0**0.5D0) * (fnumber**(1.D0/3.D0))
endif
fx=1.D0+0.35463D0*X_F/10.D0+3.55338D0*((X_F/10.D0)**2.D0)
if(fx < 1.D0) then
fx = 1.D0
endif
if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99995")
DENDRITE_VENTILATION_COEF = fx
return
end function DENDRITE_VENTILATION_COEF
! end of dendrite_ventilation_coef function
!====================================================================
FUNCTION chi_fra(fra),4
implicit double precision (a-h,o-z)
DIMENSION xxa(14), yya(14)
pc = 100.D0 * fra
if(pc.le.0.D0) then
chi_fra = 0.D0
return
endif
if(pc.ge.100.D0) then
chi_fra = 1.D0
return
endif
xxa(1) = 0.D0
yya(1) = 0.D0
xxa(2) = 10.D0
yya(2) = 1.25D0
xxa(3) = 20.D0
yya(3) = 3.12D0
xxa(4) = 30.D0
yya(4) = 5.D0
xxa(5) = 40.D0
yya(5) = 8.12D0
xxa(6) = 50.D0
yya(6) = 11.87D0
xxa(7) = 60.D0
yya(7) = 17.49D0
xxa(8) = 70.D0
yya(8) = 24.36D0
xxa(9) = 75.D0
yya(9) = 28.73D0
xxa(10) = 80.D0
yya(10) = 34.98D0
xxa(11) = 85.D0
yya(11) = 43.72D0
xxa(12) = 90.D0
yya(12) = 56.84D0
xxa(13) = 95.D0
yya(13) = 73.08D0
xxa(14) = 100.D0
yya(14) = 100.D0
ix_max = 14
ix = 0
pc_hi = 0.D0
DO WHILE(pc_hi < pc)
ix = ix + 1
if(ix > ix_max) then
ix = ix - 1
exit
endif
pc_hi = xxa(ix)
ENDDO
! new change 24.08.04 (start)
if(ix -1 < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42567")
if(ix > ix_max) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42568")
! new change 24.08.04 (end)
chi_fra=yya(ix-1)+ &
(pc-xxa(ix-1))*(yya(ix)-yya(ix-1))/(xxa(ix)-xxa(ix-1))
chi_fra = chi_fra/100.D0
if(chi_fra < 0.D0) chi_fra = 0.D0
if(chi_fra > 1.D0) chi_fra = 1.D0
! new change 24.08.04 (start)
if(chi_fra > 0.3D0 .and. pc < 75.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1478")
if(chi_fra > 0.6D0 .and. pc < 90.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1477")
! new change 24.08.04 (end)
RETURN
END FUNCTION chi_fra
! end of chi_fra function
!====================================================================
function fnre_sphere(xd) 4
implicit double precision (a-h,o-z)
INTRINSIC DLOG10
ww1 = dlog10(xd)
ww2 = ww1 * ww1
ww3 = ww1 * ww1* ww1
fnre_sphere = 0.d0
if(xd < 73.D0) then
fnre_sphere = xd/24.D0
endif
if(xd < 562.D0.and.xd >= 73.D0) then
fnre_sphere = - 1.7095D0 + 1.33438D0*ww1 - 0.11591D0*ww2
fnre_sphere = 10.D0**fnre_sphere
endif
if(xd < 1.83D3.and.xd >= 562.D0) then
fnre_sphere= &
-1.81391D0 + 1.34671D0*ww1 - 0.12427D0*ww2 + 0.0063D0*ww3
fnre_sphere = 10.D0**fnre_sphere
endif
if(xd < 5.4D10.and.xd >= 1.83D3) then
fnre_sphere= &
0.003567D0*ww3 - 0.089620D0*ww2 + 1.225713D0*ww1 - 1.706026D0
fnre_sphere = 10.D0**fnre_sphere
endif
if(xd >= 5.4D10) then
fnre_sphere = (xd/0.1D0)**0.5D0
endif
end function fnre_sphere
! end of fnre_sphere function
!====================================================================
function equilibrium_fallspeed (fm_s, fm_w_critx, XXL, vt_rain, &,1
rhoax, etaax, a_eqm)
implicit double precision (a-h,o-z)
!PARAMETER(PI = 3.141592654D0, NKR = 43, GRAV = 9.8D0)
PARAMETER(PI = 3.141592654D0, GRAV = 9.8D0)
DIMENSION XXL(NKR), vt_rain(NKR)
fnre_shed = 4800.D0 + 4831.5D0*1000.D0*fm_s
if(fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4) then
! a_d or a_eqm here?
! new change 21.06.04 (start)
vt_eqm = 1.5D-5* fnre_shed/(2.D0*a_eqm)
! new change 21.06.04 (end)
vt_eqm = vt_eqm* ((1.20D0/rhoax)**0.5D0)
if(vt_eqm > 100.D0) then
! print *, 'WARNING: vt_eqm exceeding 100 m/s', vt_eqm
! print *, 'fnre_shed, etaax, rhoax, a_eqm ::', &
! fnre_shed, etaax, rhoax, a_eqm
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
endif
! in case fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4
else
! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
if(fnre_shed > 2.5D4) then
X_Best_crit=8.D0*(fm_s+fm_w_critx)*rhoax*GRAV/(PI*etaax*etaax)
fnre_fast=(X_Best_crit/0.6D0)**0.5D0
vt_eqm=fnre_fast*etaax/(2.D0*a_eqm*rhoax)
! in case fnre_shed > 2.5D4
else
! in case fnre_shed < 5000.D0
ILIQ = IFIND_IK (fm_s + fm_w_critx, XXL, finter_frac)
if(ILIQ < NKR ) then
vt_eqm = &
vt_rain(ILIQ)+finter_frac*(vt_rain(ILIQ+1)-vt_rain(ILIQ))
else
vt_eqm = vt_rain(NKR)
endif
! in case fnre_shed < 5000.D0
endif
! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
endif
equilibrium_fallspeed = vt_eqm
end function equilibrium_fallspeed
! end of equilibrium_fallspeed function
!====================================================================
FUNCTION IFIND_IK (fmass_target, fmass_array, fraction) 2,1
implicit double precision (a-h,o-z)
!PARAMETER(NKR = 43)
DIMENSION fmass_array(NKR)
IKX = 2
DO WHILE(fmass_array(IKX) < fmass_target)
if(IKX > NKR - 1) exit
IKX = IKX + 1
ENDDO
IKX = IKX - 1
fraction= &
(fmass_target-fmass_array(IKX))/(fmass_array(IKX+1)-fmass_array(IKX))
if(fraction < 0.D0) fraction = 0.D0
if(fraction > 1.D0) fraction = 1.D0
if(IKX > NKR.or.IKX < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99999")
IFIND_IK = IKX
END FUNCTION IFIND_IK
! end of ifind_ik function
!====================================================================
FUNCTION COLUMN_AR (fmassx, rhoix) 1
implicit double precision (a-h,o-z)
parameter (PI = 3.141592654D0)
! estimate equivalent diameter (mm)
d_equiv = (fmassx/rhoix)/(4.D0*PI/3.D0)
d_equiv = d_equiv**(1.D0/3.D0)
d_equiv = 2.D0*d_equiv*1000.D0
! apply Table 1 from Heymsfield (1972)
if(d_equiv < 0.3D0) then
shape = 2.D0
else
shape = d_equiv/(0.1973D0*(d_equiv**0.414D0))
endif
! Now improve the estimate of AR
FL_i = 4.D0*shape*shape*(fmassx/rhoix)/PI
FL_i = FL_i**(1.D0/3.D0)
FL_i = FL_i* 1000.D0
if(FL_i < 0.3D0) then
COLUMN_AR = 2.D0
else
COLUMN_AR = FL_i/(0.1973D0*(FL_i**0.414D0))
endif
if(COLUMN_AR > 5.D0) COLUMN_AR = 5.D0
return
end function COLUMN_AR
! end of COLUMN_AR function
!====================================================================
FUNCTION PLATE_AR (fmassx) 1
implicit double precision (a-h,o-z)
d_i = (fmassx/1.d-3)/0.03760d0
d_i = d_i**(1.d0/3.31d0)
d_i = d_i/100.d0
h_i = 0.0141d0*( (d_i*100.d0)**0.474d0)
h_i = h_i/100.d0
PLATE_AR = h_i/d_i
return
end function PLATE_AR
! end of plate_ar function
!====================================================================
FUNCTION DENDRITE_AR(fmassx) 1
implicit double precision (a-h,o-z)
d_i = (fmassx/1.d-3)/0.00376D0
d_i = d_i**(1.D0/2.79D0)
d_i = d_i/100.D0
h_i = 0.00996D0*((d_i*100.D0)** 0.415D0)
h_i = h_i/100.D0
DENDRITE_AR = h_i/d_i
return
end function DENDRITE_AR
! end of dendrite_ar function
!====================================================================
FUNCTION COLUMN_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar) 1,2
implicit double precision (a-h,o-z)
PARAMETER(PI = 3.141592654D0)
INTRINSIC DLOG
a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
a_ix = a_ix**(1.D0/3.D0)
b_i = AR_ice*a_ix
if(AR_ice < 0.D0.or.AR_ice < 1.D0) then
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9011")
endif
epsil_i = b_i*b_i - a_ix*a_ix
if(epsil_i.le.0.D0) then
! print*, a_ix, b_i , fm_ice, AR_ice
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9044")
endif
epsil_i = epsil_i**0.5D0
COLUMN_CAP_ZERO= (b_i+epsil_i)/a_ix
COLUMN_CAP_ZERO = epsil_i /(DLOG(COLUMN_CAP_ZERO))
omega_i = 2.D0*(PI*a_ix*a_ix) + 4.D0*b_i*a_ix
P_i = 2.D0*PI*a_ix
FLstar = omega_i/P_i
return
end function COLUMN_CAP_ZERO
! end of column_cap_zero function
!====================================================================
FUNCTION PLANAR_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar) 3,3
implicit double precision (a-h,o-z)
PARAMETER(PI = 3.141592654D0)
! new change 29.06.04 (start)
!INTRINSIC DLOG, DSIN
INTRINSIC DLOG, DASIN
! new change 29.06.04 (end)
a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
a_ix = a_ix**(1.D0/3.D0)
if(AR_ice < 0.D0.or.AR_ice > 1.D0) then
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9022")
endif
epsil_i = 1.D0 - AR_ice*AR_ice
if( epsil_i < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9086")
epsil_i = epsil_i**0.5D0
if(epsil_i > 0.D0) then
! new change 29.06.04 (start)
! PLANAR_CAP_ZERO = a_ix*epsil_i/DSIN(epsil_i)
PLANAR_CAP_ZERO = a_ix*epsil_i/DASIN(epsil_i)
! new change 29.06.04 (end)
if((1.D0+epsil_i)/(1.D0-epsil_i).le.0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9054")
omega_i = DLOG((1.D0+ epsil_i)/( 1.D0- epsil_i))
omega_i = 2.D0 + PI*AR_ice*(1.D0/epsil_i)*omega_i
omega_i = PI*a_ix*a_ix*omega_i
P_i = 2.D0*PI*a_ix
FLstar = omega_i/P_i
else
PLANAR_CAP_ZERO = a_ix
FLstar = 2.D0*a_ix
endif
return
end function PLANAR_CAP_ZERO
! end of planar_cap_zero function
!====================================================================
FUNCTION rad_sphere (volume) 17
implicit double precision (a-h,o-z)
PARAMETER(PI = 3.141592654D0)
rad_sphere = volume/(4.D0*PI/3.D0)
rad_sphere = rad_sphere**(1.D0/3.D0)
return
end FUNCTION rad_sphere
! end of rad_sphere function
!====================================================================
SUBROUTINE thermodynamical_limits & 4
(FFX, fm_tot, rhoax, XLFOCP, tempx, dmeltx)
implicit double precision (a-h,o-z)
PARAMETER (COL=0.23105D0)
! control in main program & others subroutines
! new change 29.10.08 (start)
! new change 29.10.08 (end)
! PROBLEMS HERE: is "fnumber_MR" correct
! for the particle number mixing ratio ( /m3) ?
fnumber_MR = 3.D0*FFX*fm_tot*COL/rhoax
Q_ICE_MELTED = dmeltx*fnumber_MR
temp_star = tempx - XLFOCP*Q_ICE_MELTED
if(temp_star < 273.15D0) then
Q_ICE_MELTED = (tempx - 273.15D0)/XLFOCP
dmeltx = Q_ICE_MELTED / fnumber_MR
tempx = 273.15D0
! in case temp_star < 273.15D0
else
! in case temp_star >= 273.15D0
tempx = temp_star
endif
101 FORMAT(1X,D13.5)
102 FORMAT(1X,2D13.5)
103 FORMAT(1X,3D13.5)
104 FORMAT(1X,4D13.5)
105 FORMAT(1X,5D13.5)
106 FORMAT(1X,6D13.5)
END SUBROUTINE thermodynamical_limits
! end of thermodynamical_limits subroutine
!====================================================================
SUBROUTINE fmass_limits (dmeltx, ficemassx, fm_water, fm_tot) 4
implicit double precision (a-h,o-z)
INTRINSIC DABS
! new change 29.10.08 (start)
! new change 29.10.08 (end)
if(dmeltx > ficemassx) then
dmeltx = ficemassx
endif
if(dmeltx < 0.D0.and.DABS(dmeltx) > fm_water) then
dmeltx = - fm_water
endif
if(ficemassx - dmeltx > fm_tot) then
dmeltx = ficemassx - fm_tot
endif
101 FORMAT(1X,D13.5)
102 FORMAT(1X,2D13.5)
103 FORMAT(1X,3D13.5)
104 FORMAT(1X,4D13.5)
105 FORMAT(1X,5D13.5)
106 FORMAT(1X,6D13.5)
end subroutine fmass_limits
! end of fmass_limits subroutine
! Version of 3.06.04
! new size distribution functions after evaporation
SUBROUTINE JERDFUN_MELT &,1
& (R2,R2N&
& ,FI2,PSI2&
& ,FL2_OLD,FL2_NEW&
& ,IND,ITYPE)
! new change 29.09.10 (end)
implicit none
! implicit double precision (a-h,o-z)
REAL DEL2N
INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,IDROP
INTEGER NRX,I_3POINT,ICE_TYPE
! include file
!INCLUDE 'MICRO.PRM'
REAL &
& R2(NKR,IND),R2N(NKR,IND) &
& ,FI2(NKR,IND),PSI2(NKR,IND) &
& ,FL2_OLD(NKR,IND),FL2_NEW(NKR,IND)
! work arrays
! DOUBLE PRECISION TPN
! DOUBLE PRECISION B21_MY(NKR,IND)
DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND)
DOUBLE PRECISION FL2R_OLD(NKR),FL2R_NEW(NKR)
NRX=NKR
IF(IND.NE.1) THEN
ITYP=ITYPE
ELSE
ITYP=1
ENDIF
! recalculation of size distribution functions (start)
DO ICE_TYPE=1,IND
IF(ITYP.EQ.ICE_TYPE) THEN
DO KR=1,NKR
R2R(KR)=R2(KR,ICE_TYPE)
R2NR(KR)=R2N(KR,ICE_TYPE)
FI2R(KR)=FI2(KR,ICE_TYPE)
PSI2R(KR)=FI2R(KR)
FL2R_OLD(KR)=FL2_OLD(KR,ICE_TYPE)
FL2R_NEW(KR)=FL2R_OLD(KR)
ENDDO
! new size distribution functions after evaporatiion (start)
! new change 12.06.06 (start)
I_3POINT=0
! new change 12.06.06 (end)
CALL JERNEWF_MELT(NRX,R2R,R2NR,FI2R,PSI2R,FL2R_OLD,FL2R_NEW,I_3POINT)
DO KR=1,NKR
PSI2(KR,ICE_TYPE)=PSI2R(KR)
FL2_NEW(KR,ICE_TYPE)=FL2R_NEW(KR)
ENDDO
! in case ITYP.EQ.ICE_TYPE
ENDIF
ENDDO
! cycle by ICE_TYPE
! recalculation of size distribution functions (end)
! new size distribution functions (end)
128 FORMAT(1X,I2,2D13.5)
RETURN
END SUBROUTINE JERDFUN_MELT
! end of SUBROUTINE JERDFUN_MELT
SUBROUTINE JERNEWF_MELT & 1,5
! new change 27.10.08 (start)
(NRX,RR,RN,FI,PSI,FL_OLD,FL_NEW,I3POINT)
IMPLICIT NONE
INTEGER &
KR
INTEGER &
I,K,NRXP,I3POINT
! new change 10.06.06 (start)
INTEGER &
ISIGN_DIFFUSIONAL_GROWTH
! new change 10.06.06 (end)
DOUBLE PRECISION &
AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
DOUBLE PRECISION &
RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
GN1,GN2,GN3,GN1P,GMAT,GMAT2
INTEGER &
NRX
DOUBLE PRECISION &
RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
! new change 12.06.06 (start)
,RRS(NRX+1),PSINEW(NRX+1)
! new change 12.06.06 (end)
DOUBLE PRECISION &
FL_OLD(NRX),FL_NEW(NRX)
DOUBLE PRECISION &
! new change 12.06.06 (start)
DROPMASS(NRX+1)
! new change 12.06.06 (end)
DOUBLE PRECISION &
PSI_IM,PSI_I,PSI_IP
! INITIAL VALUES FOR SOME VARIABLES
NRXP=NRX+1
DO I=1,NRX
! RN(I), g - new masses after condensation or evaporation
IF(RN(I).LT.0.0D0) THEN
RN(I)=1.0D-50
FI(I)=0.0D0
ENDIF
ENDDO
DO K=1,NRX
PSI(K)=0.0D0
! new change 12.06.06 (start)
PSINEW(K)=0.0D0
! new change 12.06.06 (end)
RRS(K)=RR(K)
DROPMASS(K)=0.0D0
ENDDO
RRS(NRXP)=RRS(NRX)*1024.0D0
! new change 12.06.06 (start)
PSINEW(NRXP)=0.0D0
! new change 12.06.06 (end)
! new change 7.05.07 (start)
DROPMASS(NRXP)=0.0D0
! new change 7.05.07 (end)
! new change 10.06.06 (start)
ISIGN_DIFFUSIONAL_GROWTH=0
DO K=1,NRX
IF(RN(K).NE.RR(K)) THEN
ISIGN_DIFFUSIONAL_GROWTH=1
GOTO 2000
ENDIF
ENDDO
2000 CONTINUE
IF(ISIGN_DIFFUSIONAL_GROWTH.NE.0) THEN
! new change 10.06.06 (end)
! Kovetz-Olund method (start)
DO K=1,NRX
IF(FI(K).NE.0.0D0) THEN
I=1
DO WHILE &
! new change 12.06.06 (start)
(.NOT.(RRS(I).LE.RN(K).AND.RRS(I+1).GT.RN(K)) &
! new change 12.06.06 (end)
.AND.I.LT.NRX)
I=I+1
ENDDO
IF(RN(K).LT.RRS(1)) THEN
RNTMP=RN(K)
RRTMP=0.0D0
RRP=RRS(1)
GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
! new change 13.06.06 (start)
PSINEW(1)=PSINEW(1)+FI(K)*RR(K)*GMAT2
DROPMASS(1)= &
DROPMASS(1)+FL_OLD(K)*RR(1)*FI(K)*RR(K)*GMAT2
! new change 13.06.06 (end)
ELSE
RNTMP=RN(K)
RRTMP=RRS(I)
RRP=RRS(I+1)
GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
GMAT=(RRP-RNTMP)/(RRP-RRTMP)
! new change 13.06.06 (start)
PSINEW(I)=PSINEW(I)+FI(K)*RR(K)*GMAT
PSINEW(I+1)=PSINEW(I+1)+FI(K)*RR(K)*GMAT2
DROPMASS(I)= &
DROPMASS(I)+FL_OLD(K)*RR(I)*FI(K)*RR(K)*GMAT
! new change 7.05.07 (start)
! DROPMASS(I+1)= &
! DROPMASS(I+1)+FL_OLD(K)*RR(I+1)*FI(K)*RR(K)*GMAT2
DROPMASS(I+1)= &
DROPMASS(I+1)+FL_OLD(K)*RRS(I+1)*FI(K)*RR(K)*GMAT2
! new change 7.05.07 (start)
! new change 13.06.06 (end)
ENDIF
! in case FI(K).NE.0.0D0
ENDIF
ENDDO
! cycle by K
DO I=1,NRX
! new change 12.06.06 (start)
PSI(I)=PSINEW(I)
! new change 12.06.06 (end)
IF(PSI(I).NE.0.D0) THEN
FL_NEW(I)=DROPMASS(I)/RR(I)/PSI(I)
ELSE
! new change 19.03.08 (start)
! FL_NEW(I)=1.0D0
FL_NEW(I)=0.0D0
! new change 19.03.08 (end)
ENDIF
ENDDO
! Kovetz-Olund method (end)
! calculation both new total drop concentrations(after KO) and new
! total drop masses (after KO)
AOLDCON=0.0D0
ANEWCON=0.0D0
AOLDMASS=0.0D0
ANEWMASS=0.0D0
DO K=1,NRX
AOLDCON=AOLDCON+FI(K)*RR(K)
ANEWCON=ANEWCON+PSI(K)
AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
ANEWMASS=ANEWMASS+PSI(K)*RR(K)
ENDDO
! new change 29.04.08 (start)
! IF(I3POINT.NE.0) THEN
IF(I3POINT.NE.0) GOTO 2001
! new change 29.04.08 (end)
DO K=1,NRX
IF(FI(K).NE.0.0D0) THEN
IF(RRS(2).LT.RN(K)) THEN
I=2
DO WHILE &
(.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
.AND.I.LT.NRX)
I=I+1
ENDDO
IF(I.LT.NRX-2) THEN
RNTMP=RN(K)
RRTMP=RRS(I)
RRP=RRS(I+1)
RRM=RRS(I-1)
RNTMP2=RN(K+1)
RRTMP2=RRS(I+1)
RRP2=RRS(I+2)
RRM2=RRS(I)
GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
(RRTMP-RRM)
GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
(RRP2-RRM2)/(RRTMP2-RRM2)
GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
(RRTMP-RRM)
GMAT=(RRP-RNTMP)/(RRP-RRTMP)
GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
(RRP-RRTMP)
GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
IF(PSI_IM.GT.0.0D0) THEN
IF(PSI_IP.GT.0.0D0) THEN
IF(I.GT.2) THEN
! smoothing criteria
IF(PSI_IM.GT.PSI(I-2) &
.AND.PSI_IM.LT.PSI_I &
.AND.PSI(I-2).LT.PSI(I) &
.OR.PSI(I-2).GE.PSI(I)) THEN
PSI(I-1)=PSI_IM
PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
PSI(I+1)=PSI_IP
! in case smoothing criteria
ENDIF
! in case I.GT.2
ENDIF
! in case PSI_IP.GT.0.0D0
ENDIF
! in case PSI_IM.GT.0.0D0
ENDIF
! in case I.LT.NRX-2
ENDIF
! in case RRS(2).LT.RN(K)
ENDIF
! in case FI(K).NE.0.0D0
ENDIF
1000 CONTINUE
ENDDO
! cycle by K
AOLDCON=0.0D0
ANEWCON=0.0D0
AOLDMASS=0.0D0
ANEWMASS=0.0D0
DO K=1,NRX
AOLDCON=AOLDCON+FI(K)*RR(K)
ANEWCON=ANEWCON+PSI(K)
AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
ANEWMASS=ANEWMASS+PSI(K)*RR(K)
ENDDO
! 3 point method (end)
! new change 29.04.08 (start)
! in case I3POINT.NE.0
! ENDIF
2001 CONTINUE
! new change 29.04.08 (end)
! PSI(K) - new hydrometeor size distribution function
DO K=1,NRX
PSI(K)=PSI(K)/RR(K)
ENDDO
! new change 10.06.06 (start)
! in case ISIGN_DIFFUSIONAL_GROWTH.NE.0
ELSE
! in case ISIGN_DIFFUSIONAL_GROWTH.EQ.0
! new change 10.06.06 (end)
DO K=1,NRX
PSI(K)=FI(K)
ENDDO
ENDIF
201 FORMAT(1X,D13.5)
202 FORMAT(1X,2D13.5)
203 FORMAT(1X,3D13.5)
204 FORMAT(1X,4D13.5)
205 FORMAT(1X,5D13.5)
206 FORMAT(1X,6D13.5)
301 FORMAT(1X,I2,2X,D13.5)
302 FORMAT(1X,I2,2X,2D13.5)
303 FORMAT(1X,I2,2X,3D13.5)
304 FORMAT(1X,I2,2X,4D13.5)
305 FORMAT(1X,I2,2X,5D13.5)
306 FORMAT(1X,I2,2X,6D13.5)
RETURN
END SUBROUTINE JERNEWF_MELT
! SUBROUTINE JERNEWF_MELT
! Version of 10.02.08
! new changes 10.02.08 (start)
SUBROUTINE SHEDDING &,24
(ihucm_flag&
,FF1,XL,VTL &
,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
,TIN,rhoa,pres,DT,QQV)
! new changes 25.01.08 (end)
! new changes 10.02.08 (end)
!===============================================!
! EXPLICIT MELTING SCHEME !
! Author: Vaughan T.J. PHILLIPS, August 2004 !
! at Princeton University (AOS program) !
! and GFDL, NOAA/OAR, USA !
!===============================================!
implicit double precision (a-h,o-z)
!PARAMETER(NKR=33, NK=129, ICEMAX=3)
! new changes 25.01.08 (start)
PARAMETER(COL=0.23105D0, CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
PETIT_PARAMETRE=1.D-10)
! new changes 12.02.08 (start)
PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
! new changes 12.02.08 (end)
! new changes 25.01.08 (end)
! control in main program & others subroutines
! new changes 12.02.08 (start)
DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
! new changes 10.02.08 (end)
DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
DIMENSION FF1_SI(NKR), XL_SI(NKR), &
VTL_SI(NKR)
DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
VTG_SI(NKR), RHO_G_SI(NKR)
DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
VTH_SI(NKR), RHO_H_SI(NKR)
INTRINSIC SUM
If(TIN <= 273.15D0) then
RETURN
ENDIF
if(SUM(FF4) <= 0.D0.and.SUM(FF5) <= 0.D0) then
return
endif
!=============================================================
! UNIT CONVERSION OF ALL INPUTS to SI
!=============================================================
if(ihucm_flag == 1) then
RHO_G_SI = RHO_G*1000.D0
RHO_H_SI = RHO_H*1000.D0
XL_SI = XL/1000.D0
XG_SI = XG/1000.D0
XH_SI = XH/1000.D0
VTL_SI = VTL/100.D0
VTG_SI = VTG/100.D0
VTH_SI = VTH/100.D0
V4_SI = V4/100.D0
V5_SI = V5/100.D0
FF1_SI = 1.E9*FF1
FF4_SI = 1.E9*FF4
FF5_SI = 1.E9*FF5
pres_SI = pres/10.D0
rhoa_SI = rhoa*1000.D0
! in case ihucm_flag == 1
else
! in case ihucm_flag.NE.1
RHO_G_SI = RHO_G
RHO_H_SI = RHO_H
XL_SI = XL
XG_SI = XG
XH_SI = XH
VTL_SI = VTL
VTG_SI = VTG
VTH_SI = VTH
V4_SI = V4
V5_SI = V5
FF1_SI = FF1
FF4_SI = FF4
FF5_SI = FF5
pres_SI = pres
rhoa_SI = rhoa
! in case ihucm_flag.NE.1
endif
!=============================================================
! INITIALISATION
!=============================================================
!
V4_SI(:) = VTG_SI(:)
V5_SI(:) = VTH_SI(:)
ee = QQV*pres_SI/(EPS + QQV)
es_zero = 611.21D0
if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9071")
D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
! D_V = 2.21D-5
! FK_a = 2.40D-2
FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
! XLV = 2.50D6
! XLF = 2.83D6 - XLV
! The expressions for latent heats used by R&H, 1987,
! seem more applicable to
! T > 0degC than
! those by P & K 1997, and more modern
! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
XLV = 597.3D0
XLV = XLV*FJOULES_IN_A_CAL*1000.D0
XLS = 2.83D6
!XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
XLF = 79.7D0
XLF = XLF*FJOULES_IN_A_CAL*1000.D0
! FNSC=0.632D0
etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
! etaa/rhoa_SI = kinematic viscosity
FNSC = etaa/(rhoa_SI*D_V)
! FNPR=0.71D0
ALPHA_H = FK_a/(CP*rhoa_SI)
FNPR = etaa/(rhoa_SI*ALPHA_H)
RHO_CRIT = 910.D0
if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 111")
if(rhoa_SI < 0.1D0) then
! print*, &
! 'rhoa_SI < 0.1D0 kg/m3::TIN,rhoa_SI,PRES,DT,QQV = ', &
! TIN,rhoa_SI,pres_SI,DT,QQV
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 112")
endif
if(RHO_H_SI(1) < 1.D0) then
! print *, 'RHO_H_SI(1) < 1.D0kg/m3'
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 113")
endif
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
if(TS > 273.15D0) TS = 273.15D0
!=============================================================
! GRAUPEL (assumed to be spheres)
!=============================================================
ISIGN_GRAUPEL=1
ISIGN_HAIL=0
DO IK = 1, NKR
IK_MELT=IK
I_MELT=0
if(TIN > 273.15D0) then
IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
CYCLE
ENDIF
!
vt_start = 0.D0
vt_end = 0.D0
!
rhoi = RHO_G_SI(IK)
fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
V_i = fm_i/rhoi
fm_w = XG_SI(IK)*FLIQFR_G(IK)
V_w = fm_w/RHO_WATER
if(rhoi < RHO_CRIT) then
V_soakable = V_i - fm_i/RHO_ICE
else
V_soakable = 0.D0
endif
a_i = rad_sphere(V_i)
a_izero = rad_sphere(XG_SI(IK)/rhoi)
fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
!(fnre_smooth is invariant during melting)
X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
fnre_smooth = fnre_sphere(X_Best)
if(V_w < V_soakable) then
a_d = a_i
vt=VT_LOW_DENSITY_SOAKING &
(fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
! in case V_w < V_soakable
else
! in case V_w >= V_soakable
a_d = rad_sphere(V_i + (V_w - V_soakable))
fm_w_soaked = RHO_WATER* V_soakable
fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
fm_w_crit = fm_w_crit* 1.D-3
a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
if(rhoi < RHO_CRIT) then
vt_start = VT_LOW_DENSITY_TRANS &
(fnre_dry, fnre_smooth, &
VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
else
vt_start=VT_HIGH_DENSITY_TRANS &
(fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
endif
vt_end=equilibrium_fallspeed &
(fm_i+fm_w_soaked,fm_w_crit, &
XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
if(frac_eqm < 0.D0) frac_eqm = 0.D0
if(frac_eqm > 1.D0) frac_eqm = 1.D0
vt = vt_start + (vt_end - vt_start) * frac_eqm
if(vt < 0.D0) vt = 0.D0
! in case V_w >= V_soakable
endif
! new changes 3.02.08 (start)
if(ivt_G_H_interpol.ne.0) then
vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
endif
! new changes 3.02.08 (end)
V4_SI(IK) = vt
fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
! new change 10.02.08 (start)
if(FLIQFR_G(IK) <= 0.D0) then
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
else
TS = 273.15D0
endif
! new change 10.02.08 (end)
if(TS > 273.15D0) TS = 273.15D0
if(fnre < 6000.D0) then
CAP = a_d
else
CAP = a_i
endif
if(FLIQFR_G(IK) <= FLIQFRAC_LIM) then
if(ISHEDDING_ON.eq.1) then
if(IPRINTING == 1) print *,' SHEDDING CODE(GRAUPEL) '
CALL SHED_MELTWATER &
(fnre,rhoi,RHO_CRIT,XG_SI,FF4_SI,FLIQFR_G,XL_SI,FF1_SI,IK)
endif
! in case FLIQFR_G(IK) <= FLIQFRAC_LIM
endif
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
!
!=============================================================
! HAIL (assumed to be spheres)
!=============================================================
ISIGN_GRAUPEL=0
ISIGN_HAIL=1
DO IK = 1, NKR
IK_MELT=IK
I_MELT=0
if(TIN > 273.15D0) then
IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
TIN <= 273.15D0) THEN
IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
CYCLE
ENDIF
vt_start = 0.D0
vt_end = 0.D0
rhoi = RHO_H_SI(IK)
fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
V_i = fm_i/rhoi
fm_w = XH_SI(IK)*FLIQFR_H(IK)
V_w = fm_w/RHO_WATER
if(rhoi < RHO_CRIT) then
V_soakable = V_i - fm_i/RHO_ICE
else
V_soakable = 0.D0
endif
a_i = rad_sphere(V_i)
a_izero = rad_sphere(XH_SI(IK)/rhoi)
! FIND RE OF SMOOTH SPHERE OF SAME MASS
! (fnre_smooth is invariant during melting)
if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
fnre_smooth=fnre_sphere(X_Best)
vt_justwet = 0.D0
vt_justsoaked = 0.D0
if(V_w < V_soakable) then
! SOAKING OF WATER
a_d = a_i
vt=VT_LOW_DENSITY_SOAKING &
(fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
! in case V_w < V_soakable
else
! in case V_w >= V_soakable
a_d = rad_sphere(V_i + (V_w - V_soakable))
fm_w_soaked = RHO_WATER* V_soakable
fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
fm_w_crit = fm_w_crit* 1.D-3
a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
!RH87: Just-wet terminal velocity - look at history
!of same particle passing 0oC
!(ie. 'just-wet' means when 0degC is just reached
!by surface and melting commences):
if(rhoi < RHO_CRIT) then
vt_start = VT_LOW_DENSITY_TRANS &
(fnre_dry,fnre_smooth, &
VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
else
vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
VTH_SI(IK), a_izero, etaa, rhoa_SI)
endif
vt_end=equilibrium_fallspeed &
(fm_i + fm_w_soaked, fm_w_crit, XH(:), &
VTL_SI(:), rhoa_SI, etaa, a_crit)
! RH87: Interpolation based on fraction of equilibrium water
! on surface
frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
if(frac_eqm < 0.D0) frac_eqm = 0.D0
if(frac_eqm > 1.D0) frac_eqm = 1.D0
vt = vt_start + (vt_end - vt_start) * frac_eqm
if(vt < 0.D0) then
if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
vt = 0.D0
endif
if(IPRINTING == 1) print *, &
'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
vt_start,vt_end,a_izero/a_i
if(IPRINTING == 1) print *, &
'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
! in case V_w >= V_soakable
endif
! new changes 3.02.08 (start)
if(ivt_G_H_interpol.ne.0) then
vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
endif
! new changes 3.02.08 (end)
V5_SI(IK) = vt
fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
! new change 5.02.07 (start)
fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
! new change 10.02.08 (start)
if(FLIQFR_H(IK) <= 0.D0) then
TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
else
TS = 273.15D0
endif
! new change 10.02.08 (end)
if(TS > 273.15D0) TS = 273.15D0
if(fnre < 6000.D0) then
CAP = a_d
else
CAP = a_i
endif
if(FLIQFR_H(IK) <= FLIQFRAC_LIM) then
if(ISHEDDING_ON.eq.1) then
CALL SHED_MELTWATER &
(fnre,rhoi,RHO_CRIT,XH_SI,FF5_SI,FLIQFR_H,XL_SI,FF1_SI,IK)
! in case ISHEDDING_ON.eq.1
endif
! in case FLIQFR_H(IK) <= FLIQFRAC_LIM
endif
! in case TIN > 273.15D0
endif
ENDDO
! cycle by IK
!=============================================================
! UNIT CONVERSION OF ALL OUTPUTS from SI
!=============================================================
!
if(ihucm_flag == 1) then
if(IVT_ADJUST == 1) then
V4 = 100.D0 * V4_SI
V5 = 100.D0 * V5_SI
endif
FF1 = 1.D-9*FF1_SI
FF4 = 1.D-9*FF4_SI
FF5 = 1.D-9*FF5_SI
! in case ihucm_flag == 1
else
! in case ihucm_flag.NE.1
if(IVT_ADJUST == 1) then
V4 = V4_SI
V5 = V5_SI
endif
FF1 = FF1_SI
FF4 = FF4_SI
FF5 = FF5_SI
! in case ihucm_flag.NE.1
endif
101 FORMAT(1X,D13.5)
102 FORMAT(1X,2D13.5)
103 FORMAT(1X,3D13.5)
104 FORMAT(1X,4D13.5)
105 FORMAT(1X,5D13.5)
106 FORMAT(1X,6D13.5)
107 FORMAT(1X,7D13.5)
201 FORMAT(1X,I2,D13.5)
202 FORMAT(1X,I2,2D13.5)
203 FORMAT(1X,I2,3D13.5)
204 FORMAT(1X,I2,4D13.5)
END SUBROUTINE
! end of shedding subroutine
!====================================================================
SUBROUTINE SHED_MELTWATER & 2,10
(fnrex,rhoix,RHO_CRITX,XX,FFX,FLIQFR_X,XL_SI,FF1_SI,INK)
implicit double precision (a-h,o-z)
! new change 27.03.07 (start)
!PARAMETER(NKR=33, &
PARAMETER(PI=3.141592654D0, RHO_ICE=920D0, RHO_WATER=1000.D0, &
! new change 27.03.07 (end)
! new change 27.08.04 (start)
IPRINTING=0, &
!IPRINTING=1, &
COL=0.23105D0, FMAX_DROP_MASS_FRACTION=0.5D0)
! new change 27.08.04 (end)
! new change 21.06.04 (start)
! new change 30.10.04 (start)
DIMENSION XX(NKR), XL_SI(NKR)
DIMENSION FFX(NKR), FF1_SI(NKR), FLIQFR_X(NKR)
DIMENSION fmass_ice(NKR), fmass_X(NKR)
INTRINSIC DABS, SUM
fm_i = XX(INK)*(1.D0 - FLIQFR_X(INK))
V_i = fm_i/rhoix
fm_w = XX(INK)*FLIQFR_X(INK)
V_w = fm_w/RHO_WATER
if(rhoix < RHO_CRITX) then
V_soakable = V_i - fm_i/RHO_ICE
else
V_soakable = 0.D0
endif
if(V_w > V_soakable) then
! new change 21.06.04 (start)
! new change 21.06.04 (end)
fm_w_soaked = RHO_WATER*V_soakable
fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
fm_w_crit = fm_w_crit*1.D-3
! new change 22.06.04 (start)
! new change 22.06.04 (end)
if(fm_w - fm_w_soaked > fm_w_crit) then
! new change 21.06.04 (start)
! new change 21.06.04 (end)
if(fnrex > 1.5D4) then
melting_mode = 2
else
if(fnrex > 1.D4 ) then
melting_mode = 3
else
melting_mode = 4
endif
endif
select case (melting_mode)
case(2)
d_w_shed = 1.5D-3
case(3)
d_w_shed = 3.D-3
case(4)
d_w_shed = 4.5E-3
case default
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
end select
drop_mass = RHO_WATER*(PI/6.D0)*(d_w_shed**3.D0)
if(drop_mass > fm_w_crit*FMAX_DROP_MASS_FRACTION) &
drop_mass = fm_w_crit*FMAX_DROP_MASS_FRACTION
fm_w_save=fm_w
if(melting_mode == 2) then
if(fnrex > 2.5D4) then
! all melt-water on sfc is shed
fm_w = fm_w_soaked
else
! small drops shed continuously
fm_w = fm_w_crit + fm_w_soaked
endif
! in case melting_mode == 2
else
! in case melting_mode.ne.2
! intermittent shedding of up to FMAX_DROP_MASS_FRACTION
! of exterior meltwater
fm_w = fm_w - drop_mass
! in case melting_mode.ne.2
endif
if(fm_w - fm_w_soaked > fm_w_crit) fm_w = fm_w_crit + fm_w_soaked
if(fm_w < fm_w_soaked) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9065")
fm_w_shed = fm_w_save - fm_w
ILIQ = IFIND_IK(drop_mass, XL_SI, frac_liq)
INEW = IFIND_IK(fm_w + fm_i, XX, frac)
if(INEW < INK) then
! new change 21.06.04 (start)
! new change 21.06.04 (end)
fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
fm_X_before = SUM(fmass_X)
fm_ice_before = SUM(fmass_ice)
! take mass of water shed out of mass_X(IK) and place
! in temporary reservoir 1
res_mass_shed = FFX(INK) * fm_w_shed * XX(INK)*3.D0*COL
fmass_X(INK) = fmass_X(INK) - res_mass_shed
if(fmass_X(INK) < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8020")
if(res_mass_shed < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8021")
! take all remaining water out of mass_X/mass_ice and place
! in temporary reservoirs 2 and 3
res_mass_X = fmass_X(INK)
fmass_X(INK) = 0.D0
res_mass_ice = fmass_ice(INK)
fmass_ice(INK) = 0.D0
! transfer water of reservoir 2 into the two size-bins adjacent
! to fm_w+m_i
fmass_X(INEW)=fmass_X(INEW )+(1.D0-frac)*res_mass_X
fmass_X(INEW+1)=fmass_X(INEW+1)+frac*res_mass_X
res_mass_X = 0.D0
! transfer ice of reservoir 3 into the two size-bins adjacent
! to fm_w+m_i
fmass_ice(INEW)=fmass_ice(INEW)+(1.D0-frac)*res_mass_ice
fmass_ice(INEW+1)=fmass_ice(INEW+1)+frac*res_mass_ice
res_mass_ice=0.D0
! transfer shed water of reservoir 1 into liquid bins
FF1_SI(ILIQ)=FF1_SI(ILIQ)+ &
res_mass_shed/(XL_SI(ILIQ)*XL_SI(ILIQ)*3.D0*COL)
FFX(INEW)=fmass_X (INEW)/(XX(INEW)*XX(INEW)*3.D0*COL)
FFX(INEW+1)=fmass_X (INEW+1)/(XX(INEW+1)*XX(INEW+1)*3.D0*COL)
FFX(INK)=fmass_X (INK)/(XX(INK)*XX(INK)*3.D0*COL)
if(FFX(INEW) > 0.D0) then
FLIQFR_X(INEW)= &
1.D0-fmass_ice (INEW)/(XX(INEW)*FFX(INEW)*XX(INEW)*3.D0*COL)
! new change 9.12.07 (start)
if(DABS(FLIQFR_X(INEW)) < 1.0D-3) FLIQFR_X(INEW)= 0.0D0
! new change 9.12.07 (end)
else
FLIQFR_X(INEW) = 1.D0
endif
if(FFX(INEW+1) > 0.D0) then
FLIQFR_X(INEW+1)=1.D0 - &
fmass_ice(INEW+1)/ &
(XX(INEW+1)*FFX(INEW+1)*XX(INEW+1)*3.D0*COL)
! new change 9.12.07 (start)
if(DABS(FLIQFR_X(INEW+1)) < 1.0D-3) FLIQFR_X(INEW+1)= 0.0D0
! new change 9.12.07 (end)
else
FLIQFR_X(INEW+1) = 1.D0
endif
if(FFX(INK) > 0.D0) then
FLIQFR_X(INK)=1.D0 - fmass_ice(INK)/ &
(XX(INK)*FFX(INK)*XX(INK)*3.D0*COL)
! new change 9.12.07 (start)
if(DABS(FLIQFR_X(INK)) < 1.0D-3) FLIQFR_X(INK)= 0.0D0
! new change 9.12.07 (end)
else
FLIQFR_X(INK) = 1.D0
endif
! new change 21.06.04 (start)
! new change 21.06.04 (end)
! new change 9.12.07 (start)
! if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) stop 8003
if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) THEN
! PRINT*, 'IJK,KX,KZ,INK,INEW'
! PRINT*, IJK,KX,KZ,INK,INEW
!
! PRINT*, 'FLIQFR_X(INEW)'
! PRINT 106, FLIQFR_X(INEW)
!
! PRINT*, 'XX(INEW),FFX(INEW),fmass_ice(INEW)'
! PRINT 106, XX(INEW),FFX(INEW),fmass_ice(INEW)
!
! PRINT*, &
! 'STOP 8003: FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0'
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8003")
endif
! new change 9.12.07 (end)
if(FLIQFR_X(INEW+1) < 0.D0.or.FLIQFR_X(INEW+1) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8004")
if(FLIQFR_X(INK) < 0.D0.or.FLIQFR_X(INK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8005")
fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
fm_X_after = SUM(fmass_X)
fm_ice_after = SUM(fmass_ice)
if(fm_ice_before > 0.D0) then
fjunk = (fm_ice_after/fm_ice_before-1.D0)*100.D0
! new change 9.12.07 (start)
! new change 21.06.04 (end)
! if(DABS(fjunk) > 1.D0) stop 8011
! in case fm_ice_before > 0.D0
endif
if(fm_X_before > 0.D0) then
fjunk=((fm_X_after+res_mass_shed)/fm_X_before-1.D0)*100.D0
! new change 21.06.04 (start)
! new change 21.06.04 (end)
! if(DABS(fjunk) > 1.D0) stop 8012
! in case fm_X_before > 0.D0
endif
! new change 21.06.04 (start)
! new change 21.06.04 (end)
! in case INEW < INK
else
! in case INEW >= INK
! new change 21.06.04 (start)
! print*, &
!'STOP: drop_mass is too large compared to total mass of particle'
! print*, 'INEW >= INK'
! print*, 'INEW,INK'
! print*, INEW,INK
! print*, 'drop_mass,fm_i+fm_w'
! print 106, drop_mass,fm_i+fm_w
call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9089")
! new change 21.06.04 (end)
! in case INEW >= INK
endif
! in case fm_w - fm_w_soaked > fm_w_crit
endif
! in case V_w > V_soakable
endif
! new change 21.06.04 (start)
106 FORMAT(1X,6D13.5)
! new change 21.06.04 (end)
END SUBROUTINE
! end of shed_meltwater subroutine
!====================================================================
! from module_mp_morr_two_moment.F
subroutine refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, & 3,6
t1d, p1d, dBZ, kts, kte, ii, jj)
IMPLICIT NONE
!..Sub arguments
INTEGER, INTENT(IN):: kts, kte, ii, jj
REAL, DIMENSION(kts:kte), INTENT(IN):: &
qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
!..Local variables
REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng
DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, ilams
DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_g, N0_s
DOUBLE PRECISION:: lamr, lamg, lams
LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
DOUBLE PRECISION:: fmelt_s, fmelt_g
DOUBLE PRECISION:: cback, x, eta, f_d
INTEGER:: i, k, k_0, kbot, n
LOGICAL:: melti
!+---+
do k = kts, kte
dBZ(k) = -35.0
enddo
!+---+-----------------------------------------------------------------+
!..Put column of data into local arrays.
!+---+-----------------------------------------------------------------+
do k = kts, kte
temp(k) = t1d(k)
qv(k) = MAX(1.E-10, qv1d(k))
pres(k) = p1d(k)
rho(k) = 0.622*pres(k)/(R_MORR*temp(k)*(qv(k)+0.622))
if (qr1d(k) .gt. 1.E-9) then
rr(k) = qr1d(k)*rho(k)
nr(k) = nr1d(k)*rho(k)
lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr
ilamr(k) = 1./lamr
N0_r(k) = nr(k)*xorg2*lamr**xcre(2)
L_qr(k) = .true.
else
rr(k) = 1.E-12
nr(k) = 1.E-12
L_qr(k) = .false.
endif
if (qs1d(k) .gt. 1.E-9) then
rs(k) = qs1d(k)*rho(k)
ns(k) = ns1d(k)*rho(k)
lams = (xam_s*xcsg(3)*xosg2*ns(k)/rs(k))**xobms
ilams(k) = 1./lams
N0_s(k) = ns(k)*xosg2*lams**xcse(2)
L_qs(k) = .true.
else
rs(k) = 1.E-12
ns(k) = 1.E-12
L_qs(k) = .false.
endif
if (qg1d(k) .gt. 1.E-9) then
rg(k) = qg1d(k)*rho(k)
ng(k) = ng1d(k)*rho(k)
lamg = (xam_g*xcgg(3)*xogg2*ng(k)/rg(k))**xobmg
ilamg(k) = 1./lamg
N0_g(k) = ng(k)*xogg2*lamg**xcge(2)
L_qg(k) = .true.
else
rg(k) = 1.E-12
ng(k) = 1.E-12
L_qg(k) = .false.
endif
enddo
!+---+-----------------------------------------------------------------+
!..Locate K-level of start of melting (k_0 is level above).
!+---+-----------------------------------------------------------------+
melti = .false.
k_0 = kts
do k = kte-1, kts, -1
if ( (temp(k).gt.273.15) .and. L_qr(k) &
.and. (L_qs(k+1).or.L_qg(k+1)) ) then
k_0 = MAX(k+1, k_0)
melti=.true.
goto 195
endif
enddo
195 continue
!+---+-----------------------------------------------------------------+
!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
!.. and non-water-coated snow and graupel when below freezing are
!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
!+---+-----------------------------------------------------------------+
do k = kts, kte
ze_rain(k) = 1.e-22
ze_snow(k) = 1.e-22
ze_graupel(k) = 1.e-22
if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR) &
* (xam_s/900.0)*(xam_s/900.0) &
* N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR) &
* (xam_g/900.0)*(xam_g/900.0) &
* N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
enddo
!+---+-----------------------------------------------------------------+
!..Special case of melting ice (snow/graupel) particles. Assume the
!.. ice is surrounded by the liquid water. Fraction of meltwater is
!.. extremely simple based on amount found above the melting level.
!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
!.. routines).
!+---+-----------------------------------------------------------------+
if (melti .and. k_0.ge.kts+1) then
do k = k_0-1, kts, -1
!..Reflectivity contributed by melting snow
if (L_qs(k) .and. L_qs(k_0) ) then
fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
eta = 0.d0
lams = 1./ilams(k)
do n = 1, nrbins
x = xam_s * xxDs(n)**xbm_s
call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
CBACK, mixingrulestring_s, matrixstring_s, &
inclusionstring_s, hoststring_s, &
hostmatrixstring_s, hostinclusionstring_s)
f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
eta = eta + f_d * CBACK * simpson(n) * xdts(n)
enddo
ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
endif
!..Reflectivity contributed by melting graupel
if (L_qg(k) .and. L_qg(k_0) ) then
fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
eta = 0.d0
lamg = 1./ilamg(k)
do n = 1, nrbins
x = xam_g * xxDg(n)**xbm_g
call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
CBACK, mixingrulestring_g, matrixstring_g, &
inclusionstring_g, hoststring_g, &
hostmatrixstring_g, hostinclusionstring_g)
f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
enddo
ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
endif
enddo
endif
do k = kte, kts, -1
dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
enddo
end subroutine refl10cm_hm
END MODULE module_mp_full_sbm