!WRF:MODEL_LAYER:PHYSICS

!

MODULE module_cu_kf

USE module_wrf_error

REAL , PARAMETER :: RAD = 1500.

CONTAINS

!-------------------------------------------------------------

SUBROUTINE KFCPS( &

ids,ide, jds,jde, kds,kde &

,ims,ime, jms,jme, kms,kme &

,its,ite, jts,jte, kts,kte &

,DT,KTAU,DX,CUDT,ADAPT_STEP_FLAG &

,rho &

,RAINCV,PRATEC,NCA &

,U,V,TH,T,W,QV,dz8w,Pcps,pi &

,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 &

,EP2,SVP1,SVP2,SVP3,SVPT0 &

,STEPCU,CU_ACT_FLAG,warm_rain &

! optional arguments

,F_QV ,F_QC ,F_QR ,F_QI ,F_QS &

,RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN &

,RTHCUTEN &

!kf_edrates

,UDR_KF,DDR_KF &

,UER_KF,DER_KF &

,TIMEC_KF,KF_EDRATES &

)

!-------------------------------------------------------------

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 ) :: STEPCU

LOGICAL, INTENT(IN ) :: warm_rain

REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1

REAL, INTENT(IN ) :: CP,R,G,EP1,EP2

REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0

INTEGER, INTENT(IN ) :: KTAU

REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &

INTENT(IN ) :: &

U, &

V, &

W, &

TH, &

QV, &

T, &

dz8w, &

Pcps, &

rho, &

pi

!

REAL, INTENT(IN ) :: DT, DX

REAL, INTENT(IN ) :: CUDT

LOGICAL,OPTIONAL, INTENT(IN ) :: ADAPT_STEP_FLAG

REAL, DIMENSION( ims:ime , jms:jme ), &

INTENT(INOUT) :: &

RAINCV &

,PRATEC &

, NCA

REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &

INTENT(INOUT) :: &

W0AVG

LOGICAL, DIMENSION( ims:ime , jms:jme ), &

INTENT(INOUT) :: CU_ACT_FLAG

!

! Optional arguments

!

REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &

OPTIONAL, &

INTENT(INOUT) :: &

RTHCUTEN &

,RQVCUTEN &

,RQCCUTEN &

,RQRCUTEN &

,RQICUTEN &

,RQSCUTEN

!

! Flags relating to the optional tendency arrays declared above

! Models that carry the optional tendencies will provdide the

! optional arguments at compile time; these flags all the model

! to determine at run-time whether a particular tracer is in

! use or not.

!

LOGICAL, OPTIONAL :: &

F_QV &

,F_QC &

,F_QR &

,F_QI &

,F_QS

!kf_edrates

REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &

INTENT(INOUT) :: &

UDR_KF, &

DDR_KF, &

UER_KF, &

DER_KF

REAL, DIMENSION( ims:ime , jms:jme ) , &

INTENT(INOUT) :: &

TIMEC_KF

INTEGER, INTENT(IN) :: KF_EDRATES

! LOCAL VARS

REAL, DIMENSION( kts:kte ) :: &

U1D, &

V1D, &

T1D, &

DZ1D, &

QV1D, &

P1D, &

RHO1D, &

W0AVG1D

REAL, DIMENSION( kts:kte ):: &

DQDT, &

DQIDT, &

DQCDT, &

DQRDT, &

DQSDT, &

DTDT

REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp

INTEGER :: i,j,k,NTST,ICLDCK

LOGICAL :: qi_flag , qs_flag

! adjustable time step changes

REAL :: lastdt = -1.0

REAL :: W0AVGfctr, W0fctr, W0den

!----------------------------------------------------------------------

!--- CALL CUMULUS PARAMETERIZATION

!

!...TST IS THE NUMBER OF TIME STEPS IN 10 MINUTES...W0AVG IS CLOSE TO A

!...RUNNING MEAN VERTICAL VELOCITY...NOTE THAT IF YOU CHANGE TST, IT WIL

!...CHANGE THE FREQUENCY OF THE CONVECTIVE INTITIATION CHECK (SEE BELOW)

!...NOTE THAT THE ORDERING OF VERTICAL LAYERS MUST BE REVERSED FOR W0AVG

!...BECAUSE THE ORDERING IS REVERSED IN KFPARA...

!

DXSQ=DX*DX

qi_flag = .FALSE.

qs_flag = .FALSE.

IF ( PRESENT( F_QI ) ) qi_flag = f_qi

IF ( PRESENT( F_QS ) ) qs_flag = f_qs

!----------------------

NTST=STEPCU

TST=float(NTST*2)

!----------------------

! NTST=NINT(1200./(DT*2.))

! TST=float(NTST)

! NTST=NINT(0.5*TST)

! NTST=MAX0(NTST,1)

!----------------------

! ICLDCK=MOD(KTAU,NTST)

!----------------------

! write(0,*) 'DT = ',DT,' KTAU = ',KTAU,' DX = ',DX

! write(0,*) 'CUDT = ',CUDT

! write(0,*) 'ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG,' IDS = ',IDS

! write(0,*) 'STEPCU = ',STEPCU,' warm_rain = ',warm_rain

! write(0,*) 'F_QV = ',F_QV,' F_QC = ',F_QV

! write(0,*) 'F_QI = ',F_QI,' F_QS = ',F_QS

! write(0,*) 'F_QR = ',F_QR

! stop

if (lastdt < 0) then

lastdt = dt

endif

if (ADAPT_STEP_FLAG) then

W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt

W0fctr = dt

W0den = 2 * MAX(CUDT*60,dt)

else

W0AVGfctr = (TST-1.)

W0fctr = 1.

W0den = TST

endif

DO J = jts,jte

DO K=kts,kte

DO I= its,ite

! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J))

! TV=T(I,K,J)*(1.+EP1*QV(I,K,J))

! RHOE=Pcps(I,K,J)/(R*TV)

! W0=-101.9368*SCR1/RHOE

W0=0.5*(w(I,K,J)+w(I,K+1,J))

! Old:

!

! W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST

! New, to support adaptive time step:

!

W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den

ENDDO

ENDDO

ENDDO

lastdt = dt

DO J = jts,jte

DO I= its,ite

CU_ACT_FLAG(i,j) = .true.

ENDDO

ENDDO

DO J = jts,jte

DO I=its,ite

! if (i.eq. 110 .and. j .eq. 59 ) then

! write(0,*) 'nca = ',nca(i,j),' CU_ACT_FLAG = ',CU_ACT_FLAG(i,j)

! write(0,*) 'dt = ',dt,' ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG

! endif

! IF ( NINT(NCA(I,J)) .gt. 0 ) then

IF ( NCA(I,J) .gt. 0.5*DT ) then

CU_ACT_FLAG(i,j) = .false.

ELSE

DO k=kts,kte

DQDT(k)=0.

DQIDT(k)=0.

DQCDT(k)=0.

DQRDT(k)=0.

DQSDT(k)=0.

DTDT(k)=0.

ENDDO

!kf_edrates

IF (KF_EDRATES == 1) THEN

DO k=kts,kte

UDR_KF(I,k,J)=0.

DDR_KF(I,k,J)=0.

UER_KF(I,k,J)=0.

DER_KF(I,k,J)=0.

ENDDO

TIMEC_KF(I,J)=0.

ENDIF

RAINCV(I,J)=0.

PRATEC(I,J)=0.

!

! assign vars from 3D to 1D

DO K=kts,kte

U1D(K) =U(I,K,J)

V1D(K) =V(I,K,J)

T1D(K) =T(I,K,J)

RHO1D(K) =rho(I,K,J)

QV1D(K)=QV(I,K,J)

P1D(K) =Pcps(I,K,J)

W0AVG1D(K) =W0AVG(I,K,J)

DZ1D(k)=dz8w(I,K,J)

ENDDO

!

CALL KFPARA(I, J, &

U1D,V1D,T1D,QV1D,P1D,DZ1D, &

W0AVG1D,DT,DX,DXSQ,RHO1D, &

XLV0,XLV1,XLS0,XLS1,CP,R,G, &

EP2,SVP1,SVP2,SVP3,SVPT0, &

DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &

RAINCV,PRATEC,NCA, &

warm_rain,qi_flag,qs_flag, &

ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte, &

!kf_edrates

UDR_KF,DDR_KF, &

UER_KF,DER_KF, &

TIMEC_KF,KF_EDRATES )

IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN ) ) THEN

DO K=kts,kte

RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J)

RQVCUTEN(I,K,J)=DQDT(K)

ENDDO

ENDIF

IF( PRESENT(RQRCUTEN) .AND. PRESENT(RQCCUTEN) .AND. &

PRESENT(F_QR) ) THEN

IF ( F_QR ) THEN

DO K=kts,kte

RQRCUTEN(I,K,J)=DQRDT(K)

RQCCUTEN(I,K,J)=DQCDT(K)

ENDDO

ELSE

! This is the case for Eta microphysics without 3d rain field

DO K=kts,kte

RQRCUTEN(I,K,J)=0.

RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K)

ENDDO

ENDIF

ENDIF

!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)

IF( PRESENT( RQICUTEN ) .AND. qi_flag )THEN

DO K=kts,kte

RQICUTEN(I,K,J)=DQIDT(K)

ENDDO

ENDIF

IF( PRESENT ( RQSCUTEN ) .AND. qs_flag )THEN

DO K=kts,kte

RQSCUTEN(I,K,J)=DQSDT(K)

ENDDO

ENDIF

!

ENDIF

ENDDO

ENDDO

END SUBROUTINE KFCPS

!-----------------------------------------------------------

SUBROUTINE KFPARA (I, J, &

U0,V0,T0,QV0,P0,DZQ,W0AVG1D, &

DT,DX,DXSQ,rho, &

XLV0,XLV1,XLS0,XLS1,CP,R,G, &

EP2,SVP1,SVP2,SVP3,SVPT0, &

DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &

RAINCV,PRATEC,NCA, &

warm_rain,qi_flag,qs_flag, &

ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte, &

!kf_edrates

UDR_KF,DDR_KF, &

UER_KF,DER_KF, &

TIMEC_KF,KF_EDRATES )

!-----------------------------------------------------------

IMPLICIT NONE

!-----------------------------------------------------------

INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &

ims,ime, jms,jme, kms,kme, &

its,ite, jts,jte, kts,kte, &

I,J

LOGICAL, INTENT(IN ) :: warm_rain

LOGICAL :: qi_flag, qs_flag

!

REAL, DIMENSION( kts:kte ), &

INTENT(IN ) :: U0, &

V0, &

T0, &

QV0, &

P0, &

rho, &

DZQ, &

W0AVG1D

!

REAL, INTENT(IN ) :: DT,DX,DXSQ

!

REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G

REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0

!

REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: &

DQDT, &

DQIDT, &

DQCDT, &

DQRDT, &

DQSDT, &

DTDT

REAL, DIMENSION( ims:ime , jms:jme ), &

INTENT(INOUT) :: RAINCV, &

PRATEC, &

NCA

!kf_edrates

REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), &

INTENT(INOUT) :: UDR_KF, &

DDR_KF, &

UER_KF, &

DER_KF

REAL, DIMENSION( ims:ime , jms:jme ), &

INTENT(INOUT) :: TIMEC_KF

INTEGER, INTENT(IN) :: KF_EDRATES

!

!...DEFINE LOCAL VARIABLES...

!

REAL, DIMENSION( kts:kte ) :: &

Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, &

QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, &

UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, &

UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, &

THTAU,THETEU,THTAD,THETED,QLIQ,QICE, &

QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, &

DETLQ2,DETIC2,RATIO,RATIO2

REAL, DIMENSION( kts:kte ) :: &

DOMGDP,EXN,RHOE,TVQU,DP,RH,EQFRC,WSPD, &

QDT,FXM,THTAG,THTESG,THPA,THFXTOP, &

THFXBOT,QPA,QFXTOP,QFXBOT,QLPA,QLFXIN, &

QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, &

QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, &

QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG

REAL, DIMENSION( kts:kte+1 ) :: OMG

REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB

! LOCAL VARS

REAL :: P00,T00,CV,B61,RLF,RHIC,RHBC,PIE, &

TTFRZ,TBFRZ,C5,RATE

REAL :: GDRY,ROCP,ALIQ,BLIQ, &

CLIQ,DLIQ,AICE,BICE,CICE,DICE

REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, &

ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, &

CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, &

ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,&

TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, &

UPNEW,ABE,WKLCL,THTUDL,TUDL,TTEMP,FRC1, &

QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,&

DZZ,WSQ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, &

THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, &

UD1,CLDHGT,DPTT,QNEWLQ,DUMFDP,EE,TSAT, &

THTA,P150,USR,VCONV,TIMEC,SHSIGN,VWS,PEF, &

CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, &

DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, &

DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, &

UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, &

DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, &

AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, &

DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, &

TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, &

UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, &

RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, &

DDFRC,TDC,DEFRC

INTEGER :: KX,K,KL

!

INTEGER :: ISTOP,ML,L5,L4,KMIX,LOW, &

LC,MXLAYR,LLFC,NLAYRS,NK, &

KPBL,KLCL,LCL,LET,IFLAG, &

KFRZ,NK1,LTOP,NJ,LTOP1, &

LTOPM1,LVF,KSTART,KMIN,LFS, &

ND,NIC,LDB,LDT,ND1,NDK, &

NM,LMAX,NCOUNT,NOITR, &

NSTEP,NTC

!

DATA P00,T00/1.E5,273.16/

DATA CV,B61,RLF/717.,0.608,3.339E5/

DATA RHIC,RHBC/1.,0.90/

DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/

DATA RATE/0.01/

!-----------------------------------------------------------

GDRY=-G/CP

ROCP=R/CP

KL=kte

KX=kte

!

! ALIQ = 613.3

! BLIQ = 17.502

! CLIQ = 4780.8

! DLIQ = 32.19

ALIQ = SVP1*1000.

BLIQ = SVP2

CLIQ = SVP2*SVPT0

DLIQ = SVP3

AICE = 613.2

BICE = 22.452

CICE = 6133.0

DICE = 0.61

!

!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER

!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL)

!...FIELD. 'FBFRC' IS THE FRACTION OF AVAILABLE

!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)...

!

FBFRC=0.0

!

!...SCHEME IS CALLED ONCE ON EACH NORTH-SOUTH SLICE, THE LOOP BELOW

!...CHECKS FOR THE POSSIBILITY OF INITIATING PARAMETERIZED

!...CONVECTION AT EACH POINT WITHIN THE SLICE

!

!...SEE IF IT IS NECESSARY TO CHECK FOR CONVECTIVE TRIGGERING AT THIS

!...GRID POINT. IF NCA>0, CONVECTION IS ALREADY ACTIVE AT THIS POINT,

!...JUST FEED BACK THE TENDENCIES SAVED FROM THE TIME WHEN CONVECTION

!...WAS INITIATED. IF NCA<0, CONVECTION IS NOT ACTIVE

!...AND YOU MAY WANT TO CHECK TO SEE IF IT CAN BE ACTIVATED FOR THE

!...CURRENT CONDITIONS. IN PREVIOUS APLICATIONS OF THIS SCHEME,

!...THE VARIABLE ICLDCK WAS USED BELOW TO SAVE TIME BY ONLY CHECKING

!...FOR THE POSSIBILITY OF CONVECTIVE INITIATION EVERY 5 OR 10

!...MINUTES...

!

! 10 CONTINUE

!SUE P300=1000.*(PSB(I,J)*A(KL)+PTOP-30.)+PP3D(I,J,KL)

P300=P0(1)-30000.

!

!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF

!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND

!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION...

!

!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED

!...FROM BOTTOM-UP IN THE KF SCHEME...

!

ML=0

!SUE tmprpsb=1./PSB(I,J)

!SUE CELL=PTOP*tmprpsb

DO 15 K=1,KX

!SUE P0(K)=1.E3*(A(NK)*PSB(I,J)+PTOP)+PP3D(I,J,NK)

!

!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL...

!

ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ))

QES(K)=EP2*ES/(P0(K)-ES)

Q0(K)=AMIN1(QES(K),QV0(K))

Q0(K)=AMAX1(0.000001,Q0(K))

QL0(K)=0.

QI0(K)=0.

QR0(K)=0.

QS0(K)=0.

TV0(K)=T0(K)*(1.+B61*Q0(K))

RHOE(K)=P0(K)/(R*TV0(K))

DP(K)=rho(k)*g*DZQ(k)

!

!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL

! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS...

!

IF(P0(K).GE.500E2)L5=K

IF(P0(K).GE.400E2)L4=K

IF(P0(K).GE.P300)LLFC=K

IF(T0(K).GT.T00)ML=K

15 CONTINUE

Z0(1)=.5*DZQ(1)

DO 20 K=2,KL

Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1))

DZA(K-1)=Z0(K)-Z0(K-1)

20 CONTINUE

DZA(KL)=0.

KMIX=1

25 LOW=KMIX

IF(LOW.GT.LLFC)GOTO 325

LC=LOW

MXLAYR=0

!

!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF

!...UNSTABLE AIR 50 TO 100 mb DEEP...TO APPROXIMATE THIS, ISOLATE A

!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL

!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 60 mb..

!

NLAYRS=0

DPTHMX=0.

DO 63 NK=LC,KX

DPTHMX=DPTHMX+DP(NK)

NLAYRS=NLAYRS+1

63 IF(DPTHMX.GT.6.E3)GOTO 64

GOTO 325

64 KPBL=LC+NLAYRS-1

KMIX=LC+1

18 THMIX=0.

QMIX=0.

ZMIX=0.

PMIX=0.

DPTHMX=0.

!

!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY

!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL

!...LAYERS...

!

DO 17 NK=LC,KPBL

DPTHMX=DPTHMX+DP(NK)

ROCPQ=0.2854*(1.-0.28*Q0(NK))

THMIX=THMIX+DP(NK)*T0(NK)*(P00/P0(NK))**ROCPQ

QMIX=QMIX+DP(NK)*Q0(NK)

ZMIX=ZMIX+DP(NK)*Z0(NK)

17 PMIX=PMIX+DP(NK)*P0(NK)

THMIX=THMIX/DPTHMX

QMIX=QMIX/DPTHMX

ZMIX=ZMIX/DPTHMX

PMIX=PMIX/DPTHMX

ROCPQ=0.2854*(1.-0.28*QMIX)

TMIX=THMIX*(PMIX/P00)**ROCPQ

EMIX=QMIX*PMIX/(EP2+QMIX)

!

!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL, PRESSURE

!...LEVEL OF LCL...

!

TLOG=ALOG(EMIX/ALIQ)

TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)

TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX- &

TDPT)

TLCL=AMIN1(TLCL,TMIX)

TVLCL=TLCL*(1.+0.608*QMIX)

CPORQ=1./ROCPQ

PLCL=P00*(TLCL/THMIX)**CPORQ

DO 29 NK=LC,KL

KLCL=NK

IF(PLCL.GE.P0(NK))GOTO 35

29 CONTINUE

GOTO 325

35 K=KLCL-1

DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K))

!

!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL...

!

TENV=T0(K)+(T0(KLCL)-T0(K))*DLP

QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP

TVEN=TENV*(1.+0.608*QENV)

TVBAR=0.5*(TV0(K)+TVEN)

! ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G

ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP

!

!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER

!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0AVG IS AN

!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL

!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION

!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE

!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST

!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS,

!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID

!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH...

!

WKLCL=0.02*ZLCL/2.5E3

WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3- &

WKLCL

WABS=ABS(WKL)+1.E-10

WSIGNE=WKL/WABS

DTLCL=4.64*WSIGNE*WABS**0.33

GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN)

WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10)

IF(TLCL+DTLCL.GT.TENV)GOTO 45

IF(KPBL.GE.LLFC)GOTO 325

GOTO 25

!

!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE

!...EQUIVALENT POTENTIAL TEMPERATURE

!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL...

!

45 THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* &

EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX))

ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ))

TVAVG=0.5*(TV0(KLCL)+TENV*(1.+0.608*QENV))

PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL))

QESE=EP2*ES/(PLCL-ES)

GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN)

WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10)

THTES(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* &

EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE))

WTW=WLCL*WLCL

IF(WLCL.LT.0.)GOTO 25

TVLCL=TLCL*(1.+0.608*QMIX)

RHOLCL=PLCL/(R*TVLCL)

!

LCL=KLCL

LET=LCL

!

!*******************************************************************

! *

! COMPUTE UPDRAFT PROPERTIES *

! *

!*******************************************************************

!

!

!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))...

!

WU(K)=WLCL

AU0=PIE*RAD*RAD

UMF(K)=RHOLCL*AU0

VMFLCL=UMF(K)

UPOLD=VMFLCL

UPNEW=UPOLD

!

!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1),

!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE BUOYANT ENERGY,

! TRPPT IS THE TOTAL RATE OF PRECIPITATION PRODUCTION...

!

RATIO2(K)=0.

UER(K)=0.

ABE=0.

TRPPT=0.

TU(K)=TLCL

TVU(K)=TVLCL

QU(K)=QMIX

EQFRC(K)=1.

QLIQ(K)=0.

QICE(K)=0.

QLQOUT(K)=0.

QICOUT(K)=0.

DETLQ(K)=0.

DETIC(K)=0.

PPTLIQ(K)=0.

PPTICE(K)=0.

IFLAG=0

KFRZ=LC

!

!...THE AMOUNT OF CONV AVAIL POT ENERGY (CAPE) IS CALCULATED WITH

! RESPECT TO UNDILUTE PARCEL ASCENT; EQ POT TEMP OF UNDILUTE

! PARCEL IS THTUDL, UNDILUTE TEMPERATURE IS GIVEN BY TUDL...

!

THTUDL=THETEU(K)

TUDL=TLCL

!

!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION

! PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH

! FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION

! INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE

! PREVIOUS MODEL LEVEL...

!

TTEMP=TTFRZ

!

!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP,

! MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND

! MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL...

!

DO 60 NK=K,KL-1

NK1=NK+1

RATIO2(NK1)=RATIO2(NK)

!

!...UPDATE UPDRAFT PROPERTIES AT THE NEXT MODEL LVL TO REFLECT

! ENTRAINMENT OF ENVIRONMENTAL AIR...

!

FRC1=0.

TU(NK1)=T0(NK1)

THETEU(NK1)=THETEU(NK)

QU(NK1)=QU(NK)

QLIQ(NK1)=QLIQ(NK)

QICE(NK1)=QICE(NK)

CALL TPMIX(P0(NK1),THETEU(NK1),TU(NK1),QU(NK1),QLIQ(NK1), &

QICE(NK1),QNEWLQ,QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0, &

XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE)

TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1))

!

!...CHECK TO SEE IF UPDRAFT TEMP IS WITHIN THE FREEZING INTERVAL,

! IF IT IS, CALCULATE THE FRACTIONAL CONVERSION TO GLACIATION

! AND ADJUST QNEWLQ TO REFLECT THE GRADUAL CHANGE IN THETAU

! SINCE THE LAST MODEL LEVEL...THE GLACIATION EFFECTS WILL BE

! DETERMINED AFTER THE AMOUNT OF CONDENSATE AVAILABLE AFTER

! PRECIP FALLOUT IS DETERMINED...TTFRZ IS THE TEMP AT WHICH

! GLACIATION BEGINS, TBFRZ THE TEMP AT WHICH IT ENDS...

!

IF(TU(NK1).LE.TTFRZ.AND.IFLAG.LT.1)THEN

IF(TU(NK1).GT.TBFRZ)THEN

IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ

FRC1=(TTEMP-TU(NK1))/(TTFRZ-TBFRZ)

R1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ)

ELSE

FRC1=(TTEMP-TBFRZ)/(TTFRZ-TBFRZ)

R1=1.

IFLAG=1

ENDIF

QNWFRZ=QNEWLQ

QNEWIC=QNEWIC+QNEWLQ*R1*0.5

QNEWLQ=QNEWLQ-QNEWLQ*R1*0.5

EFFQ=(TTFRZ-TBFRZ)/(TTEMP-TBFRZ)

TTEMP=TU(NK1)

ENDIF

!

! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT...

!

IF(NK.EQ.K)THEN

BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1.

BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5

ENTERM=0.

DZZ=Z0(NK1)-ZLCL

ELSE

BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1.

BOTERM=2.*DZA(NK)*G*BE/1.5

ENTERM=2.*UER(NK)*WTW/UPOLD

DZZ=DZA(NK)

ENDIF

WSQ=WTW

CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM,RATE, &

QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1), G)

!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND,

! IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS...

!

IF(WTW.LE.0.)GOTO 65

WABS=SQRT(ABS(WTW))

WU(NK1)=WTW/WABS

!

! UPDATE THE ABE FOR UNDILUTE ASCENT...

!

THTES(NK1)=T0(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QES(NK1))) &

* &

EXP((3374.6525/T0(NK1)-2.5403)*QES(NK1)*(1.+0.81* &

QES(NK1)))

UDLBE=((2.*THTUDL)/(THTES(NK)+THTES(NK1))-1.)*DZZ

IF(UDLBE.GT.0.)ABE=ABE+UDLBE*G

!

! DETERMINE THE EFFECTS OF CLOUD GLACIATION IF WITHIN THE SPECIFIED

! TEMP INTERVAL...

!

IF(FRC1.GT.1.E-6)THEN

CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QLIQ(NK1), &

QICE(NK1),RATIO2(NK1),TTFRZ,TBFRZ,QNWFRZ,RL,FRC1,EFFQ, &

IFLAG,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE &

,CICE,DICE)

ENDIF

!

! CALL SUBROUTINE TO CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMP.

! WITHIN GLACIATION INTERVAL, THETAE MUST BE CALCULATED WITH RESPECT TO

! SAME DEGREE OF GLACIATION FOR ALL ENTRAINING AIR...

!

CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),RATIO2(NK1), &

RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE)

!...REI IS THE RATE OF ENVIRONMENTAL INFLOW...

!

REI=VMFLCL*DP(NK1)*0.03/RAD

TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1))

!

!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, NO

! ENTRAINMENT IS ALLOWED AT THIS LEVEL...

!

IF(TVQU(NK1).LE.TV0(NK1))THEN

UER(NK1)=0.0

UDR(NK1)=REI

EE2=0.

UD2=1.

EQFRC(NK1)=0.

GOTO 55

ENDIF

LET=NK1

TTMP=TVQU(NK1)

!

!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL

! AIR FOR ESTIMATION OF ENTRAINMENT AND DETRAINMENT RATES...

!

F1=0.95

F2=1.-F1

THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)

QTMP=F1*Q0(NK1)+F2*QU(NK1)

TMPLIQ=F2*QLIQ(NK1)

TMPICE=F2*QICE(NK1)

CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, &

QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, &

DLIQ,AICE,BICE,CICE,DICE)

TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)

IF(TU95.GT.TV0(NK1))THEN

EE2=1.

UD2=0.

EQFRC(NK1)=1.0

GOTO 50

ENDIF

F1=0.10

F2=1.-F1

THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)

QTMP=F1*Q0(NK1)+F2*QU(NK1)

TMPLIQ=F2*QLIQ(NK1)

TMPICE=F2*QICE(NK1)

CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ, &

QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, &

DLIQ,AICE,BICE,CICE,DICE)

TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)

IF(TU10.EQ.TVQU(NK1))THEN

EE2=1.

UD2=0.

EQFRC(NK1)=1.0

GOTO 50

ENDIF

EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1))

EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1))

EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1))

IF(EQFRC(NK1).EQ.1)THEN

EE2=1.

UD2=0.

GOTO 50

ELSEIF(EQFRC(NK1).EQ.0.)THEN

EE2=0.

UD2=1.

GOTO 50

ELSE

!

!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE

! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES...

!

CALL PROF5(EQFRC(NK1),EE2,UD2)

ENDIF

!

50 IF(NK.EQ.K)THEN

EE1=1.

UD1=0.

ENDIF

!

!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE

! FRACTIONAL VALUES IN THE LAYER...

!

UER(NK1)=0.5*REI*(EE1+EE2)

UDR(NK1)=0.5*REI*(UD1+UD2)

!

!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL

! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATION

!

55 IF(UMF(NK)-UDR(NK1).LT.10.)THEN

!

!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL

! UPDRAFT FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE

! PREVIOUS MODEL

!

IF(UDLBE.GT.0.)ABE=ABE-UDLBE*G

LET=NK

! WRITE(98,1015)P0(NK1)/100.

GOTO 65

ENDIF

EE1=EE2

UD1=UD2

UPOLD=UMF(NK)-UDR(NK1)

UPNEW=UPOLD+UER(NK1)

UMF(NK1)=UPNEW

!

!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND ICE IN

! THE DETRAINING UPDRAFT MASS...

!

DETLQ(NK1)=QLIQ(NK1)*UDR(NK1)

DETIC(NK1)=QICE(NK1)*UDR(NK1)

QDT(NK1)=QU(NK1)

QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW

THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW

QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW

QICE(NK1)=QICE(NK1)*UPOLD/UPNEW

!

!...KFRZ IS THE HIGHEST MODEL LEVEL AT WHICH LIQUID CONDENSATE IS

! GENERATING PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF LIQUID

! PRECIP AT A GIVING MODEL LVL, PPTICE THE SAME FOR ICE, TRPPT IS

! THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE CURRENT MODEL LEVEL

!

IF(ABS(RATIO2(NK1)-1.).GT.1.E-6)KFRZ=NK1

PPTLIQ(NK1)=QLQOUT(NK1)*(UMF(NK)-UDR(NK1))

PPTICE(NK1)=QICOUT(NK1)*(UMF(NK)-UDR(NK1))

TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1)

IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX

60 CONTINUE

!

!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU

! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO

! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE

! BETWEEN THE LET AND CLOUD TOP...

!

!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL

! VELOCITY FIRST BECOMES NEGATIVE...

!

65 LTOP=NK

CLDHGT=Z0(LTOP)-ZLCL

!

!...IF CLOUD TOP HGT IS LESS THAN SPECIFIED MINIMUM HEIGHT, GO BACK AND

! THE NEXT HIGHEST 60MB LAYER TO SEE IF A BIGGER CLOUD CAN BE OBTAINED

! THAT SOURCE AIR...

!

! IF(CLDHGT.LT.4.E3.OR.ABE.LT.1.)THEN

IF(CLDHGT.LT.3.E3.OR.ABE.LT.1.)THEN

DO 70 NK=K,LTOP

UMF(NK)=0.

UDR(NK)=0.

UER(NK)=0.

DETLQ(NK)=0.

DETIC(NK)=0.

PPTLIQ(NK)=0.

70 PPTICE(NK)=0.

GOTO 25

ENDIF

!

!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS

! FLUX THIS LEVEL...

!

IF(LET.EQ.LTOP)THEN

UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP)

DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD

DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD

TRPPT=TRPPT-(PPTLIQ(LTOP)+PPTICE(LTOP))

UER(LTOP)=0.

UMF(LTOP)=0.

GOTO 85

ENDIF

!

! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET...