MODULE module_mp_fer_hires REAL,PRIVATE,SAVE :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & & C_NR, CRAIN, & & ARAUT, BRAUT, CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, ESW0, & & RFmax, RQR_DRmin, RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, & & RR_DR3, RR_DR4, RR_DR5, RR_DRmax, BETA6, PI_E, RFmx1, ARcw, & & RH_NgC, RH_NgT, RQhail, AVhail, BVhail, QAUT0 INTEGER,PRIVATE,PARAMETER :: INDEXRstrmax=500 INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & & DelDMI=1.e-6,XMImin=1.e6*DMImin REAL, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536 INTEGER, PUBLIC,PARAMETER :: MDImin=XMImin, MDImax=XMImax REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & & ACCRI,VSNOWI,VENTI1,VENTI2 REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: SDENS REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.0e-3, & & DelDMR=1.e-6, XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax INTEGER, PUBLIC,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 INTEGER, PRIVATE,PARAMETER :: Nrime=40 REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF INTEGER,PARAMETER :: NX=7501 REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 REAL, DIMENSION(NX),PRIVATE,SAVE :: TBPVS,TBPVS0 REAL, PRIVATE,SAVE :: C1XPVS0,C2XPVS0,C1XPVS,C2XPVS REAL, PRIVATE,PARAMETER :: & & CP=1004.6, EPSQ=1.E-12, GRAV=9.806, RHOL=1000., RD=287.04 & & ,RV=461.5, T0C=273.15, XLV=2.5E6, XLF=3.3358e+5 & & ,pi=3.141592653589793 & & ,EPS=RD/RV, EPS1=RV/RD-1., EPSQ1=1.001*EPSQ & & ,RCP=1./CP, RCPRV=RCP/RV, RGRAV=1./GRAV, RRHOL=1./RHOL & & ,XLS=XLV+XLF, XLV1=XLV/CP, XLF1=XLF/CP, XLS1=XLS/CP & & ,XLV2=XLV*XLV/RV, XLS2=XLS*XLS/RV & & ,XLV3=XLV*XLV*RCPRV, XLS3=XLS*XLS*RCPRV & & ,CLIMIT=10.*EPSQ, CLIMIT1=-CLIMIT & & ,C1=1./3. & & ,DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, DMR4=0.45E-3 & & ,DMR5=0.67E-3 & & ,XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 & & ,XMR4=1.e6*DMR4, XMR5=1.e6*DMR5, RQRmix=0.05E-3, RQSmix=1.E-3 & & ,Cdry=1.634e13, Cwet=1./.224 INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3, MDR4=XMR4 & & , MDR5=XMR5 LOGICAL, SAVE :: WARN1=.TRUE.,WARN2=.TRUE.,WARN3=.TRUE.,WARN5=.TRUE. REAL, SAVE :: Pwarn=75.E2, QTwarn=1.E-3 INTEGER, PARAMETER :: MAX_ITERATIONS=10 REAL, PUBLIC,PARAMETER :: & & RHgrd_in=1. & & ,RHgrd_out=0.975 & & ,P_RHgrd_out=850.E2 & & ,T_ICE=-40. & & ,T_ICEK=T0C+T_ICE & & ,T_ICE_init=-12. & & ,NSI_max=250.E3 & & ,NLImin=1.E3 & & ,N0r0=8.E6 & & ,N0rmin=1.E4 & & ,NCW=250.E6 LOGICAL, PARAMETER :: PRINT_diag=.FALSE. REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI CONTAINS SUBROUTINE FER_HIRES (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt, & & LOWLYR,SR, & & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & & QC,QR,QI, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) IMPLICIT NONE INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & & ,ITIMESTEP,GID REAL, INTENT(IN) :: DT,DX,DY 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,qv,qt,qc,qr,qi REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & & RAINNC,RAINNCV REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & & TLATGS_PHY,TRAIN_PHY REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy INTEGER :: I,J,K,KFLIP REAL :: WC CALL MY_GROWTH_RATES (DT) CIACW=DT*0.25*PI_E*0.5*(1.E5)**C1 CIACR=PI_E*DT CRACW=DT*0.25*PI_E*1.0 BRAUT=DT*1.1E10*BETA6/NCW DO j = jts,jte DO k = kts,kte DO i = its,ite t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) ENDDO ENDDO ENDDO DO j = jts,jte DO k = kts,kte DO i = its,ite TLATGS_PHY (i,k,j)=0. TRAIN_PHY (i,k,j)=0. ENDDO ENDDO ENDDO DO j = jts,jte DO i = its,ite ACPREC(i,j)=0. APREC (i,j)=0. PREC (i,j)=0. SR (i,j)=0. ENDDO ENDDO DO j = jts,jte DO k = kts,kte DO i = its,ite QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QI(I,K,J) IF (QI(I,K,J) <= EPSQ) THEN F_ICE_PHY(I,K,J)=0. F_RIMEF_PHY(I,K,J)=1. IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1. ELSE F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QI(I,K,J)/QT(I,K,J) ) ) ENDIF IF (QR(I,K,J) <= EPSQ) THEN F_RAIN_PHY(I,K,J)=0. ELSE F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QR(I,K,J)+QC(I,K,J)) ENDIF ENDDO ENDDO ENDDO CALL EGCP01DRV(GID,DT,LOWLYR, & & APREC,PREC,ACPREC,SR, & & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) DO j = jts,jte DO k = kts,kte DO i = its,ite th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) WC=qt(I,K,J) QI(I,K,J)=0. QR(I,K,J)=0. QC(I,K,J)=0. IF(F_ICE_PHY(I,K,J)>=1.)THEN QI(I,K,J)=WC ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN QC(I,K,J)=WC ELSE QI(I,K,J)=F_ICE_PHY(I,K,J)*WC QC(I,K,J)=WC-QI(I,K,J) ENDIF IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN IF(F_RAIN_PHY(I,K,J).GE.1.)THEN QR(I,K,J)=QC(I,K,J) QC(I,K,J)=0. ELSE QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) QC(I,K,J)=QC(I,K,J)-QR(I,K,J) ENDIF endif ENDDO ENDDO ENDDO DO j=jts,jte DO i=its,ite RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) RAINNCV(i,j)=APREC(i,j)*1000. ENDDO ENDDO END SUBROUTINE FER_HIRES SUBROUTINE FER_HIRES_ADVECT (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv, & & LOWLYR,SR, & & QC,QR,QI,QRIMEF, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) IMPLICIT NONE INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE & & ,ITIMESTEP,GID REAL, INTENT(IN) :: DT,DX,DY 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,qv,qc,qr,qi,qrimef REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & & RAINNC,RAINNCV REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: & & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, QT REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & & TLATGS_PHY,TRAIN_PHY REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy INTEGER :: I,J,K,KFLIP REAL :: WC CALL MY_GROWTH_RATES (DT) CIACW=DT*0.25*PI_E*0.5*(1.E5)**C1 CIACR=PI_E*DT CRACW=DT*0.25*PI_E*1.0 BRAUT=DT*1.1E10*BETA6/NCW DO j = jts,jte DO k = kts,kte DO i = its,ite t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) ENDDO ENDDO ENDDO DO j = jts,jte DO k = kts,kte DO i = its,ite TLATGS_PHY (i,k,j)=0. TRAIN_PHY (i,k,j)=0. ENDDO ENDDO ENDDO DO j = jts,jte DO i = its,ite ACPREC(i,j)=0. APREC (i,j)=0. PREC (i,j)=0. SR (i,j)=0. ENDDO ENDDO DO j = jts,jte DO k = kts,kte DO i = its,ite QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QI(I,K,J) IF (QI(I,K,J) <= EPSQ) THEN F_ICE_PHY(I,K,J)=0. F_RIMEF_PHY(I,K,J)=1. IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1. ELSE F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QI(I,K,J)/QT(I,K,J) ) ) F_RIMEF_PHY(I,K,J)=QRIMEF(I,K,J)/QI(I,K,J) ENDIF IF (QR(I,K,J) <= EPSQ) THEN F_RAIN_PHY(I,K,J)=0. ELSE F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QR(I,K,J)+QC(I,K,J)) ENDIF ENDDO ENDDO ENDDO CALL EGCP01DRV(GID,DT,LOWLYR, & & APREC,PREC,ACPREC,SR, & & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) DO j = jts,jte DO k = kts,kte DO i = its,ite th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) WC=qt(I,K,J) QI(I,K,J)=0. QR(I,K,J)=0. QC(I,K,J)=0. IF(F_ICE_PHY(I,K,J)>=1.)THEN QI(I,K,J)=WC ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN QC(I,K,J)=WC ELSE QI(I,K,J)=F_ICE_PHY(I,K,J)*WC QC(I,K,J)=WC-QI(I,K,J) ENDIF IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN IF(F_RAIN_PHY(I,K,J).GE.1.)THEN QR(I,K,J)=QC(I,K,J) QC(I,K,J)=0. ELSE QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) QC(I,K,J)=QC(I,K,J)-QR(I,K,J) ENDIF endif QRIMEF(I,K,J)=QI(I,K,J)*F_RIMEF_PHY(I,K,J) ENDDO ENDDO ENDDO DO j=jts,jte DO i=its,ite RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) RAINNCV(i,j)=APREC(i,j)*1000. ENDDO ENDDO END SUBROUTINE FER_HIRES_ADVECT SUBROUTINE EGCP01DRV(GID, & & DTPH,LOWLYR,APREC,PREC,ACPREC,SR, & & dz8w,RHO_PHY,CWM_PHY,T_PHY,Q_PHY,F_ICE_PHY,P_PHY, & & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte) IMPLICIT NONE INTEGER,INTENT(IN ) :: ids,ide, jds,jde, kds,kde & & ,ims,ime, jms,jme, kms,kme & & ,its,ite, jts,jte, kts,kte INTEGER,INTENT(IN ) :: GID REAL,INTENT(IN) :: DTPH INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & & APREC,PREC,ACPREC,SR REAL,DIMENSION( its:ite, kts:kte, jts:jte ),INTENT(INOUT) :: t_phy REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: & & dz8w,P_PHY,RHO_PHY REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT) :: & & CWM_PHY, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY & & ,Q_PHY,TRAIN_PHY INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP REAL,DIMENSION(its:ite,jts:jte,kts:kte) :: & & CWM,T,Q,TRAIN,TLATGS,P REAL,DIMENSION(kts:kte,its:ite,jts:jte) :: F_ice,F_rain,F_RimeF INTEGER,DIMENSION(its:ite,jts:jte) :: LMH REAL :: TC,WC,QI,QR,QW,Fice,Frain,DUM,ASNOW,ARAIN REAL,DIMENSION(kts:kte) :: P_col,Q_col,T_col,QV_col,WC_col, & & RimeF_col,QI_col,QR_col,QW_col, THICK_col, RHC_col, DPCOL, & & pcond1d,pidep1d, & & piacw1d,piacwi1d,piacwr1d,piacr1d,picnd1d,pievp1d,pimlt1d, & & praut1d,pracw1d,prevp1d,pisub1d,pevap1d, DBZ_col,NR_col,NS_col, & & vsnow1d,vrain11d,vrain21d,vci1d,NSmICE1d,INDEXS1d,INDEXR1d, & & RFlag1d REAL,DIMENSION(2) :: PRECtot,PRECmax DO J=JTS,JTE DO I=ITS,ITE LMH(I,J) = KTE-LOWLYR(I,J)+1 ENDDO ENDDO DO 98 J=JTS,JTE DO 98 I=ITS,ITE DO L=KTS,KTE KFLIP=KTE+1-L CWM(I,J,L)=CWM_PHY(I,KFLIP,J) T(I,J,L)=T_PHY(I,KFLIP,J) Q(I,J,L)=Q_PHY(I,KFLIP,J) P(I,J,L)=P_PHY(I,KFLIP,J) TLATGS(I,J,L)=TLATGS_PHY(I,KFLIP,J) TRAIN(I,J,L)=TRAIN_PHY(I,KFLIP,J) F_ice(L,I,J)=F_ice_PHY(I,KFLIP,J) F_rain(L,I,J)=F_rain_PHY(I,KFLIP,J) F_RimeF(L,I,J)=F_RimeF_PHY(I,KFLIP,J) ENDDO 98 CONTINUE DO 100 J=JTS,JTE DO 100 I=ITS,ITE LSFC=LMH(I,J) DO K=KTS,KTE KFLIP=KTE+1-K DPCOL(K)=RHO_PHY(I,KFLIP,J)*GRAV*dz8w(I,KFLIP,J) ENDDO IF (CWM(I,J,1) .LE. EPSQ) CWM(I,J,1)=EPSQ F_ice(1,I,J)=1. F_rain(1,I,J)=0. F_RimeF(1,I,J)=1. DO L=1,LSFC P_col(L)=P(I,J,L) THICK_col(L)=DPCOL(L)*RGRAV T_col(L)=T(I,J,L) TC=T_col(L)-T0C QV_col(L)=max(EPSQ, Q(I,J,L)) IF (CWM(I,J,L) .LE. EPSQ1) THEN WC_col(L)=0. IF (TC .LT. T_ICE) THEN F_ice(L,I,J)=1. ELSE F_ice(L,I,J)=0. ENDIF F_rain(L,I,J)=0. F_RimeF(L,I,J)=1. ELSE WC_col(L)=CWM(I,J,L) IF (WC_col(L)>QTwarn .AND. P_col(L)1 g/kg condensate in stratosphere; I,J,L,TC,P,QT=', & I,J,L,TC,.01*P_col(L),1000.*WC_col(L) QTwarn=MAX(WC_col(L),10.*QTwarn) Pwarn=MIN(P_col(L),0.5*Pwarn) ENDIF IF (WARN5 .AND. TC/=TC) THEN WRITE(0,*) 'WARN5: NaN temperature; I,J,L,P=',I,J,L,.01*P_col(L) WARN5=.FALSE. ENDIF ENDIF IF (T_ICE<=-100.) F_ice(L,I,J)=0. WC=WC_col(L) QI=0. QR=0. QW=0. Fice=F_ice(L,I,J) Frain=F_rain(L,I,J) IF (Fice .GE. 1.) THEN QI=WC ELSE IF (Fice .LE. 0.) THEN QW=WC ELSE QI=Fice*WC QW=WC-QI ENDIF IF (QW.GT.0. .AND. Frain.GT.0.) THEN IF (Frain .GE. 1.) THEN QR=QW QW=0. ELSE QR=Frain*QW QW=QW-QR ENDIF ENDIF IF (QI .LE. 0.) F_RimeF(L,I,J)=1. RimeF_col(L)=F_RimeF(L,I,J) QI_col(L)=QI QR_col(L)=QR QW_col(L)=QW IF(GID .EQ. 1 .AND. P_col(L)EPSQ) THEN DUM=RRHO*MASSI(MDImin) NSmICE=MIN(NInuclei, QI/DUM) QSmICE=NSmICE*DUM ENDIF ENDIF init_ice: IF (QI<=EPSQ .AND. ASNOW<=CLIMIT) THEN TOT_ICE=0. PILOSS=0. RimeF1=1. VrimeF=1. VEL_INC=GAMMAS VSNOW=0. VSNOW1=0. VCI=0. EMAIRI=THICK XLIMASS=RimeF1*MASSI(INDEXS) FLIMASS=1. QLICE=0. RQLICE=0. QTICE=0. NLICE=0. ELSE init_ice TOT_ICE=THICK*QI+BLEND*ASNOW PILOSS=-TOT_ICE/THICK QLgICE=MAX(0., QI-QSmICE) VCI=GAMMAS*VSNOWI(MDImin) LBEF=MAX(1,L-1) RimeF1=(RimeF_col(L)*THICK*QLgICE & & +RimeF_col(LBEF)*BLEND*ASNOW)/TOT_ICE IF (RimeF1>2.) THEN DUM3=RH_NgC*(RHO*QLgICE)**C1 DUM2=RH_NgT*(RHO*QLgICE)**C1 IF (RimeF1>=10.) THEN DUM=DUM3 ELSE IF (RimeF1>=5.) THEN DUM=0.2*(RimeF1-5.) DUM=DUM3*DUM+DUM2*(1.-DUM) ELSE DUM1=REAL(INDEXS) DUM=0.33333*(RimeF1-2.) DUM=DUM2*DUM+DUM1*(1.-DUM) ENDIF INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) ENDIF EMAIRI=THICK+BLDTRH*VSNOW1 QLICE=(THICK*QLgICE+BLEND*ASNOW)/EMAIRI RQLICE=RHO*QLICE QTICE=QLICE+QSmICE FLIMASS=QLICE/QTICE two_pass: DO IPASS=1,2 DUM=1.E-6*REAL(INDEXS) RFmx=RFmx1*DUM*DUM*DUM/MASSI(INDEXS) RimeF1=MIN(RimeF1, RFmx) vel_rime: IF (RimeF1<=1.) THEN RimeF1=1. VrimeF=1. ELSE vel_rime RimeF1=MIN(RimeF1, RFmax) IXS=MAX(2, MIN(INDEXS/100, 9)) XRF=10.492*ALOG(RimeF1) IXRF=MAX(0, MIN(INT(XRF), Nrime)) IF (IXRF .GE. Nrime) THEN VrimeF=VEL_RF(IXS,Nrime) ELSE VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) ENDIF VrimeF=MAX(1., VrimeF) ENDIF vel_rime VEL_INC=GAMMAS*VrimeF VSNOW=VEL_INC*VSNOWI(INDEXS) IF (RimeF1>=5. .AND. INDEXS==MDImax .AND. RQLICE>RQhail) THEN DUM=GAMMAS*AVhail*RQLICE**BVhail IF (DUM>VSNOW) THEN VSNOW=DUM VEL_INC=VSNOW/VSNOWI(INDEXS) ENDIF ENDIF XLIMASS=RimeF1*MASSI(INDEXS) NLICE=RQLICE/XLIMASS IF (IPASS>=2 .OR. & (NLICE>=NLImin .AND. NLICE<=NSI_max)) EXIT two_pass NLICE=MAX(NLImin, MIN(NSI_max, NLICE) ) XLI=RQLICE/(NLICE*RimeF1) new_size: IF (XLI<=MASSI(MDImin) ) THEN INDEXS=MDImin ELSE IF (XLI<=MASSI(450) ) THEN new_size DLI=9.5885E5*XLI**.42066 INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) ELSE IF (XLIEPSQ .AND. RHOX0C<=225.) THEN STRAT=.TRUE. ELSE STRAT=.FALSE. INDEXRmin=MDRmin ENDIF IF(STRAT .AND. INDEXRmin<=MDRmin) THEN INDEXRmin=INDEXS0C*(0.001*RHOX0C)**C1 INDEXRmin=MAX(MDRmin, MIN(INDEXRmin, INDEXRstrmax) ) ENDIF ENDIF ENDIF IF(STRAT .OR. TIMLT>EPSQ) THEN DRZL=.FALSE. ELSE DRZL=.TRUE. ENDIF IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN DUM2=RHO*QW IF (DUM2>QAUT0) THEN DUM2=DUM2*DUM2 DUM=BRAUT*DUM2*QW DUM1=ARAUT*DUM2 PRAUT=MIN(QW, DUM*(1.-EXP(-DUM1*DUM1)) ) ENDIF IF (QLICE .GT. EPSQ) THEN FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS) ) PIACW=FWS*QW IF (TC<0.) THEN PIACWI=PIACW Rcw=ARcw*DUM2**C1 ENDIF ENDIF ENDIF ice_only: IF (TC.LT.T_ICE .AND. (WV.GT.QSWgrd .OR. QW.GT.EPSQ)) THEN PIACW=QW PIACWI=PIACW Rcw=0. DUM1=TK+XLF1*PIACW DUM2=WV DUM=MIN(1000.*FPVS(DUM1),0.99*PP) DUM=RHgrd*EPS*DUM/(PP-DUM) IF (WARN1 .AND. DUM1",2961,& 'module_mp_fer_hires: fer_hires_init: Can not find unused fortran unit to read in lookup table.' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN print*,'open ETAMPNEW_DATA.expanded_rain, in fer_hires' OPEN(UNIT=etampnew_unit1,FILE="ETAMPNEW_DATA.expanded_rain", & & FORM="UNFORMATTED",STATUS="OLD",ERR=9061) READ(etampnew_unit1) VENTR1 READ(etampnew_unit1) VENTR2 READ(etampnew_unit1) ACCRR READ(etampnew_unit1) MASSR READ(etampnew_unit1) VRAIN READ(etampnew_unit1) RRATE READ(etampnew_unit1) VENTI1 READ(etampnew_unit1) VENTI2 READ(etampnew_unit1) ACCRI READ(etampnew_unit1) MASSI READ(etampnew_unit1) VSNOWI READ(etampnew_unit1) VEL_RF CLOSE (etampnew_unit1) ENDIF CALL wrf_dm_bcast_bytes ( VENTR1 , size ( VENTR1 ) * 4 ) CALL wrf_dm_bcast_bytes ( VENTR2 , size ( VENTR2 ) * 4 ) CALL wrf_dm_bcast_bytes ( ACCRR , size ( ACCRR ) * 4 ) CALL wrf_dm_bcast_bytes ( MASSR , size ( MASSR ) * 4 ) CALL wrf_dm_bcast_bytes ( VRAIN , size ( VRAIN ) * 4 ) CALL wrf_dm_bcast_bytes ( RRATE , size ( RRATE ) * 4 ) CALL wrf_dm_bcast_bytes ( VENTI1 , size ( VENTI1 ) * 4 ) CALL wrf_dm_bcast_bytes ( VENTI2 , size ( VENTI2 ) * 4 ) CALL wrf_dm_bcast_bytes ( ACCRI , size ( ACCRI ) * 4 ) CALL wrf_dm_bcast_bytes ( MASSI , size ( MASSI ) * 4 ) CALL wrf_dm_bcast_bytes ( VSNOWI , size ( VSNOWI ) * 4 ) CALL wrf_dm_bcast_bytes ( VEL_RF , size ( VEL_RF ) * 4 ) CALL MY_GROWTH_RATES (DTPH) PI_E=ACOS(-1.) ABFR=-0.66 BBFR=100. CBFR=20.*PI_E*PI_E*BBFR*RHOL*1.E-21*DTPH CIACW=0.5*DTPH*0.25*PI_E CIACR=PI_E*DTPH RR_DRmin=N0r0*RRATE(MDRmin) RR_DR1=N0r0*RRATE(MDR1) RR_DR2=N0r0*RRATE(MDR2) RR_DR3=N0r0*RRATE(MDR3) RR_DR4=N0r0*RRATE(MDR4) RR_DR5=N0r0*RRATE(MDR5) RR_DRmax=N0r0*RRATE(MDRmax) RQR_DRmin=N0r0*MASSR(MDRmin) RQR_DRmax=N0r0*MASSR(MDRmax) C_NR=1./(PI*RHOL) Crain=720.E18*C_NR*C_NR C_N0r0=PI_E*RHOL*N0r0 CN0r0=1.E6/SQRT(SQRT(C_N0r0)) CN0r_DMRmin=1./(PI_E*RHOL*DMRmin*DMRmin*DMRmin*DMRmin) CN0r_DMRmax=1./(PI_E*RHOL*DMRmax*DMRmax*DMRmax*DMRmax) CRACW=DTPH*0.25*PI_E*1.0 ESW0=1000.*FPVS0(T0C) RFmax=1.1**Nrime RFmx1=PI*900. RDIS=0.5 BETA6=( (1.+3.*RDIS*RDIS)*(1.+4.*RDIS*RDIS)*(1.+5.*RDIS*RDIS)/ & & ((1.+RDIS*RDIS)*(1.+2.*RDIS*RDIS) ) ) ARAUT=1.03e19/(NCW*SQRT(NCW)) BRAUT=DTPH*1.1E10*BETA6/NCW QAUT0=PI*RHOL*NCW*(20.E-6)**3/6. ARcw=1.E6*(0.75/(PI*NCW*RHOL))**C1 RH_NgC=PI*500.*1.E3 RQhail=RH_NgC*(1.E-3)**3 Bvhail=0.82*C1 Avhail=1353.*(1./RH_NgC)**Bvhail RH_NgC=1.E6*(1./RH_NgC)**C1 RH_NgT=PI*300.*5.E3 RH_NgT=1.E6*(1./RH_NgT)**C1 DO I=MDImin,MDImax SDENS(I)=PI_E*1.5E-15*FLOAT(I*I*I)/MASSI(I) ENDDO Thour_print=-DTPH/3600. ENDIF RETURN 9061 CONTINUE WRITE( errmess , '(A,I4)' ) & 'module_mp_hwrf: error opening ETAMPNEW_DATA on unit ' & &, etampnew_unit1 CALL wrf_error_fatal3("",3148,& errmess) END SUBROUTINE fer_hires_init SUBROUTINE MY_GROWTH_RATES (DTPH) IMPLICIT NONE REAL,INTENT(IN) :: DTPH REAL DT_ICE REAL,DIMENSION(35) :: MY_600 DATA MY_600 / & & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6, & & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7, & & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5, & & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6, & & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7, 9.5E-7, & & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7, & & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 / DT_ICE=(DTPH/600.)**1.5 MY_GROWTH=DT_ICE*MY_600*1.E-3 END SUBROUTINE MY_GROWTH_RATES SUBROUTINE GPVS IMPLICIT NONE real :: X,XINC,T integer :: JX XINC=(XMAX-XMIN)/(NX-1) C1XPVS=1.-XMIN/XINC C2XPVS=1./XINC C1XPVS0=1.-XMIN/XINC C2XPVS0=1./XINC DO JX=1,NX X=XMIN+(JX-1)*XINC T=X TBPVS(JX)=FPVSX(T) TBPVS0(JX)=FPVSX0(T) ENDDO END SUBROUTINE GPVS REAL FUNCTION FPVS(T) IMPLICIT NONE real,INTENT(IN) :: T real XJ integer :: JX IF (T>=XMIN .AND. T<=XMAX) THEN XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX)) JX=MIN(XJ,NX-1.) FPVS=TBPVS(JX)+(XJ-JX)*(TBPVS(JX+1)-TBPVS(JX)) ELSE IF (T>XMAX) THEN FPVS=0.61078*exp(17.2694*(T-273.16)/(T-35.86)) ELSE FPVS=0.61078*exp(21.8746*(T-273.16)/(T-7.66)) ENDIF END FUNCTION FPVS REAL FUNCTION FPVS0(T) IMPLICIT NONE real,INTENT(IN) :: T real :: XJ1 integer :: JX1 IF (T>=XMIN .AND. T<=XMAX) THEN XJ1=MIN(MAX(C1XPVS0+C2XPVS0*T,1.),FLOAT(NX)) JX1=MIN(XJ1,NX-1.) FPVS0=TBPVS0(JX1)+(XJ1-JX1)*(TBPVS0(JX1+1)-TBPVS0(JX1)) ELSE FPVS0=0.61078*exp(17.2694*(T-273.16)/(T-35.86)) ENDIF END FUNCTION FPVS0 REAL FUNCTION FPVSX(T) IMPLICIT NONE real, parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2 & , CLIQ=4.1855E+3,CVAP= 1.8460E+3 & , CICE=2.1060E+3,HSUB=2.8340E+6 real, parameter :: PSATK=PSAT*1.E-3 real, parameter :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP) real, parameter :: DLDTI=CVAP-CICE & , XAI=-DLDTI/RV,XBI=XAI+HSUB/(RV*TTP) real T,TR TR=TTP/T IF(T.GE.TTP)THEN FPVSX=PSATK*(TR**XA)*EXP(XB*(1.-TR)) ELSE FPVSX=PSATK*(TR**XAI)*EXP(XBI*(1.-TR)) ENDIF END FUNCTION FPVSX REAL FUNCTION FPVSX0(T) IMPLICIT NONE real,parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2 & , CLIQ=4.1855E+3,CVAP=1.8460E+3 & , CICE=2.1060E+3,HSUB=2.8340E+6 real,PARAMETER :: PSATK=PSAT*1.E-3 real,PARAMETER :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP) real,PARAMETER :: DLDTI=CVAP-CICE & , XAI=-DLDT/RV,XBI=XA+HSUB/(RV*TTP) real :: T,TR TR=TTP/T FPVSX0=PSATK*(TR**XA)*EXP(XB*(1.-TR)) END FUNCTION FPVSX0 END MODULE module_mp_fer_hires