!WRF:MODEL_MP:PHYSICS
! The fast version calculates hydrometeor distributions for qc,qr,qs,qg, and their number concentrations
! (including aerosol concentrations).
! To use the FAST 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_fast_sbm 2
USE module_mp_radar
! USE module_state_description
!
!-----------------------------------------------------------------------
! BARRY
INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
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
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.
REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
REAL, PRIVATE,PARAMETER :: R_MORR = 287.15
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=4.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.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)
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 FAST_SBM (w,u,v,th_old, & 1,21
& chem_new,n_chem, &
& itimestep,DT,DX,DY, &
& dz8w,rho_phy,p_phy,pi_phy,th_phy, &
& xland,ivgtyp,xlat,xlong, &
& QV,QC,QR,QI,QS,QG,QV_OLD, &
& QNC,QNR,QNS,QNG,QNA, &
& ids,ide, jds,jde, kds,kde, &
& ims,ime, jms,jme, kms,kme, &
& its,ite, jts,jte, kts,kte, &
& refl_10cm, diagflag, do_radar_ref, & ! GT added for reflectivity calcs
& RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,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, &
qi, &
qs, &
qg, &
qnc, &
qnr, &
qns, &
qng, &
qna
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):: &
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,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
REAL EFF_N,EFF_D
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
REAL, DIMENSION(kts:kte):: &
qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
REAL, DIMENSION(kts:kte):: dBZ
integer print_int
parameter (print_int=300)
integer t_print,xlong10
t_print=print_int/dt
difmax = 0
! print*,'itimestep = ',itimestep
! if (itimestep.gt.150)return
if (itimestep.eq.1)then
if (iceprocs.eq.1) call wrf_message("SBM FAST: ICE PROCESES ACTIVE")
if (iceprocs.eq.0) call wrf_message("SBM FAST: LIQUID PROCESES ONLY")
print*,'num_chem = ',n_chem
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/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
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
END DO
END DO
END DO
end if
call kernals(dt)
DXHUCM=100.*DX
DYHUCM=100.*DY
! 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
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)
t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
ENDDO
ENDDO
ENDDO
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 = j_start,j_end
! DO i = i_start,i_end
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 (dx.ge.4500)then
! if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
! chem_new(I,K,J,KR)=FCCNR_MIX(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
End do
end if
end do
end do
end do
end if
! print*,'dxhucm = ',dxhucm
! print*,'dyhucm = ',dyhucm
!
!-----------------------------------------------------------------------
!**********************************************************************
!-----------------------------------------------------------------------
!
!
! 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 i = its,ite
do k = kts,kte
! if (i.eq.214.and.j.eq.60.and.k.eq.14)then
! if (i.eq.214.and.j.eq.60)then
! print*,'i,j = ',i,j,k
! end if
! print*,'i,j = ',i,j,k
! 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(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
FF1R(KRR)=chem_new(I,K,J,KR)
IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
END DO
! DO KR=1,NKR
! FF1R(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
! IF (FF1R(KR).LT.0)FF1R(KR)=0.
! END DO
! CCN
KRR=0
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
! FCCN(KRR)=chem_new(I,K,J,KR)
! FCCN(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
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=NKR+1,NKR*2
KRR=KRR+1
FF2R(KRR,1)=0.
END DO
! PLATES!
KRR=0
DO KR=NKR*2+1,NKR*3
KRR=KRR+1
FF2R(KRR,2)=0.
END DO
! DENDRITES!
KRR=0
DO KR=NKR*3+1,NKR*4
KRR=KRR+1
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)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
FF3R(KRR)=chem_new(I,K,J,KR)
if (ff3r(krr).lt.0)ff3r(krr)=0.
END DO
! KRR=0
! DO KR=NKR*1+1,NKR*2
! KRR=KRR+1
! FF3R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
! 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)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
FF4R(KRR)=chem_new(I,K,J,KR)
IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
END DO
! KRR=0
! DO KR=NKR*2+1,NKR*3
! KRR=KRR+1
! FF4R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
! IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
! END DO
! Hail
KRR=0
DO KR=NKR*6+1,NKR*7
KRR=KRR+1
FF5R(KRR)=0.
if (ff5r(krr).lt.0)ff5r(krr)=0.
END DO
!
! if (i.eq.43.and.k.eq.6.and.j.eq.41)then
! print*,'here 2'
! end if
! do kr=1,nkr
! if (ff4r(kr).lt.0)then
! print*,'i,k,j = ',i,k,j
! print*,'ff4r 1 = ',kr,ff4r(kr)
! end if
! 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)
DO KR=1,NKR
DO ICE=1,ICEMAX
FF3R(KR)=FF2IN(KR,ICE)+FF3R(KR)
FF2IN(KR,ICE)=0
FF2R(KR,ICE)=0
FF4R(KR)=FF5R(KR)+FF4R(KR)
FF5R(KR)=0
ENDDO
END DO
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
! do kr=1,nkr
! if (ff4r(kr).lt.0)then
! print*,'i,k,j = ',i,k,j
! print*,'ff4r 2 = ',ff4r(kr)
! end if
! end do
! if(i.eq.64.and.j.eq.2.and.k.eq.16)then
! print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
! print*,'T_OLD(I,K,J) = ',T_OLD(I,K,J)
! end if
DO KR=1,NKR
DO ICE=1,ICEMAX
FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
FF2R(KR,ICE)=0.
ENDDO
FF4R(KR)=FF4R(KR)+FF5R(KR)
FF5R(KR)=0.
END DO
! do kr=1,nkr
! if (ff4r(kr).lt.0)then
! print*,'i,k,j = ',i,k,j
! print*,'ff4r 3 = ',ff4r(kr)
! end if
! end do
IF (T_OLD(I,K,J).GT.233)THEN
TT=T_OLD(I,K,J)
QQ=QV_OLD(I,K,J)
IF (QQ.LE.0) call wrf_message("WARNING : SBM FAST: 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 : SBM FAST: 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
! if(i.eq.64.and.j.eq.2.and.k.eq.16)then
! print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
! print*,'tt = ',tt
! print*,'qq = ',qq
! print*,'tta = ',tta
! print*,'qqa = ',qqa
! print*,'ES1N = ',ES1N
! print*,'ES2N = ',ES2N
! print*,'EW1N = ',EW1N
! print*,'DIV1 = ',DIV1
! print*,'pp = ',pp
! print*,'zcgs = ',zcgs(i,k,j)
! end if
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
! if (i.eq.43.and.k.eq.6.and.j.eq.41)then
! print*,'here 4'
! end if
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
call wrf_error_fatal("fatal error in module_mp_fast_sbm (DIV1>DIV2), model 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)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2NR.EQ.0), model stop")
DEL12R=DEL1NR/DEL2NR
DEL12RD=DEL12R**DEL_BBR
EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
! IF (DEL12R.EQ.0)PRINT*,'DEL12R = 0'
IF (DEL12R.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL12R.EQ.0), model stop")
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)
END IF
END IF
DO KR=1,NKR
DO ICE=1,ICEMAX
FF3R(KR)=FF3R(KR)+FF2IN(KR,ICE)
FF2IN(KR,ICE)=0.
FF2R(KR,ICE)=0.
END DO
END DO
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
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)
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
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)
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
DO KR=1,NKR
DO ICE=1,ICEMAX
FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
FF2R(KR,ICE)=0
END DO
FF4R(KR)=FF4R(KR)+FF5R(KR)
FF5R(KR)=0
END DO
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*,'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
KRR=0
DO KR=p_ff1i01,p_ff1i33
KRR=KRR+1
chem_new(I,K,J,KR)=FF1R(KRR)
END DO
! CCN
KRR=0
DO KR=p_ff8i01,p_ff8i33
KRR=KRR+1
! chem_new(I,K,J,KR)=FCCN(KRR)
! chem_new(I,K,J,KR)=FCCN(KRR)/RHOCGS(I,K,J)*XCCN(KRR)
chem_new(I,K,J,KR)=FCCN(KRR)
END DO
IF (ICEPROCS.EQ.1)THEN
KRR=0
DO KR=p_ff5i01,p_ff5i33
KRR=KRR+1
! chem_new(I,K,J,KR)=FF3R(KRR)
! chem_new(I,K,J,KR)=FF3R(KRR)*(1./RHOCGS(I,K,J))*COL*XS(KRR)*XS(KRR)*3
chem_new(I,K,J,KR)=FF3R(KRR)
END DO
! Graupel
KRR=0
DO KR=p_ff6i01,p_ff6i33
KRR=KRR+1
! chem_new(I,K,J,KR)=FF4R(KRR)
! chem_new(I,K,J,KR)=FF4R(KRR)*(1./RHOCGS(I,K,J))*COL*XG(KRR)*XG(KRR)*3
chem_new(I,K,J,KR)=FF4R(KRR)
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)
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 i = its,ite
DO k = kts,kte
QC(I,K,J)=0
QR(I,K,J)=0
! QI(I,K,J)=0
! QIC(I,K,J)=0
! QIP(I,K,J)=0
! QID(I,K,J)=0
QI(I,K,J)=0
QS(I,K,J)=0
QG(I,K,J)=0
QNC(I,K,J)=0
QNR(I,K,J)=0
QNS(I,K,J)=0
QNG(I,K,J)=0
QNA(I,K,J)=0
! EFFR(I,K,J)=0
! if (mod(itimestep,t_print).eq.0)then
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(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
! 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) &
! & +1000*COL*chem_new(I,K,J,KR)*XS(KRR)*3
& +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
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
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.
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
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)
ng1d(k)=qng(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))/(RAINNCV(I,J)+1.e-12)
! print*, i,j,rainnc(i,j)
END DO
END DO
do j=jts,jte
do k=kts,kte
do i=its,ite
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
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
KRR=0
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
END DO
END DO
END DO
END IF
RETURN
END SUBROUTINE FAST_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_fast_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 FAST_HUCMINIT(DT) 1,80
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/
PARAMETER (RO_SOLUTE=2.16)
INTEGER KR_MIN,KR_MIN1,KR_MAX
REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
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
REAL FR_CON,FR_MAR
FR_MAR=1.0
! FR_CON=1-FR_MAR
FR_CON=1.0
! PRINT*, 'INITIALIZING HUCM'
! print *, ' ****** HUCM *******'
call wrf_message("SBM FAST: INITIALIZING 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_fast: 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_fast: 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("SBM FAST: 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_fast: 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("SBM FAST: 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_fast: 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("SBM FAST: 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_fast: 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_fast: 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_fast: 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("SBM FAST: 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_fast: 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("SBM FAST: file7: succesfull")
! PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
call wrf_message("SBM FAST: 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 *******'
! 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
CALL BREAKINIT
! CALL TWOINITMXVAR
! PRINT *, '**** MIN CCN RADIUS,MASS & DENSITY ***'
! PRINT 200, R0CCN,X0CCN,ROCCN0
! PRINT *, '********* CONT CCN CONCENTRATION & MASS *******'
! PRINT 200, CONCCCNIN,CONTCCNIN
! PRINT *, '********* DROP RADII *******'
! PRINT 200, DROPRADII
! PRINT *, '********* CCN RADII *******'
! PRINT 200, RCCN
! PRINT *, '********* CCN MASSES *******'
! PRINT 200, XCCN
! PRINT *, '********* INITIAL CCN DISTRIBUTION *******'
! IF(IPRINT01.NE.0) THEN
! PRINT *, '******** INITIAL: TWC,TWI(ICEMAX),TWS ********'
! PRINT 300, TWCIN,TWIIN,TWSIN
! PRINT *, '******** INITIAL: CONCLIN ********'
! PRINT 300, CONCLIN
! IN CASE : IPRINT01.NE.0
! ENDIF
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_fast_sbm: error opening hujisbm_DATA on unit ' &
&, hujisbm_unit1
CALL wrf_error_fatal(errmess)
end subroutine fast_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_fast: 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_fast: 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_fast: 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,gamma,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.-30.) 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.-35..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/
REAL TEMP1,TEMP2,TEMP3
DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
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
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
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_fast_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_fast_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_fast_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_fast_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_fast_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_fast_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_fast_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
INTEGER &
I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
! Andrei's new change 1.12.09 (start)
INTEGER &
KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
DOUBLE PRECISION &
COEFF_REMAP,TPN
DOUBLE PRECISION &
CDROP(NRX),DELTA_CDROP(NRX)
! Andrei's new change 1.12.09 (end)
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 NRX,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) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RW.LE.0), model stop")
IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (PW.LE.0), model stop")
IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RI.LE.0), model stop")
IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_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_fast_sbm (CHECK.LT.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_fast_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_fast_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_fast_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_fast_sbm (ABS(DEL2N).GT.EPSDEL), 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_fast_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_fast_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_fast_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_fast_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_fast_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.10000) call wrf_error_fatal("fatal error in module_mp_fast_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,cwlh,xl_mg,xg_mg, &
& chucm,ima,prdkrn1,nkr,0)
call coll_xyx (g4,g1,cwhl,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
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
!B call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg,
!B 1 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
!B call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg,
!B 1 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
!B call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg,
!B 1 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_fast_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=0 ! mchen add temporarily
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
!===============================================================
!****************************************************************
! 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_fast_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
! 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_fast_sbm