<p><b>laura@ucar.edu</b> 2010-12-21 16:01:03 -0700 (Tue, 21 Dec 2010)</p><p>deleted initial physics<br>
</p><hr noshade><pre><font color="gray">Deleted: branches/atmos_physics/src/core_hyd_phys/Makefile
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/Makefile 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/Makefile 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,50 +0,0 @@
-.SUFFIXES: .F .o
-
-OBJS = \
- module_cu_kfeta.o \
- module_microphysics_driver.o \
- module_mp_thompson.o \
- module_physics_constants.o \
- module_physics_driver.o \
- module_physics_init.o \
- module_physics_manager.o \
- module_physics_todynamics.o \
- module_physics_vars.o
-
-all: core_hyd_phys
-
-core_hyd_phys: $(OBJS)
- ar -ru libphys.a $(OBJS)
-
-# DEPENDENCIES:
-module_microphysics_driver.o: \
- module_mp_thompson.o \
- module_physics_vars.o
-
-module_physics_driver.o: \
- module_cu_kfeta.o \
- module_mp_thompson.o \
- module_physics_constants.o \
- module_physics_manager.o \
- module_physics_vars.o
-
-module_physics_init.o: \
- module_cu_kfeta.o \
- module_mp_thompson.o \
- module_physics_constants.o \
- module_physics_vars.o
-
-module_physics_manager.o: \
- module_physics_vars.o
-
-module_physics_todynamics.o: \
- module_physics_vars.o
-
-clean:
- $(RM) *.o *.mod libphys.a
-
-.F.o:
- $(RM) $@ $*.mod
- $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
- $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
-# $(RM) $*.f90
Deleted: branches/atmos_physics/src/core_hyd_phys/module_cu_kfeta.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_cu_kfeta.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_cu_kfeta.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,2944 +0,0 @@
-MODULE module_cu_kfeta
-
-! USE module_wrf_error
-
-!--------------------------------------------------------------------
-! Lookup table variables:
- INTEGER, PARAMETER :: KFNT=250,KFNP=220
- REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB
- REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K
- REAL, DIMENSION(200),PRIVATE, SAVE :: ALU
- REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP
-! Note: KF Lookup table is used by subroutines KF_eta_PARA, TPMIX2,
-! TPMIX2DD, ENVIRTHT
-! End of Lookup table variables:
-
-CONTAINS
-
- SUBROUTINE KF_eta_CPS( &
- ids,ide, jds,jde, kds,kde &
- ,ims,ime, jms,jme, kms,kme &
- ,its,ite, jts,jte, kts,kte &
- ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG &
- ,rho,RAINCV,PRATEC,NCA &
- ,U,V,TH,T,W,dz8w,Pcps,pi &
- ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 &
- ,EP2,SVP1,SVP2,SVP3,SVPT0 &
- ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT &
- ,QV &
- ! optionals
- ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS &
- ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN &
- ,RQICUTEN,RQSCUTEN &
- )
-!
-!-------------------------------------------------------------
- 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, &
- T, &
- QV, &
- dz8w, &
- Pcps, &
- rho, &
- pi
-!
- REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
- INTENT(INOUT) :: &
- W0AVG
-
- REAL, INTENT(IN ) :: DT, DX
- REAL, INTENT(IN ) :: CUDT
- REAL, INTENT(IN ) :: CURR_SECS
- LOGICAL,INTENT(IN ) :: ADAPT_STEP_FLAG
-!
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(INOUT) :: RAINCV
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(INOUT) :: PRATEC
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(INOUT) :: NCA
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(OUT) :: CUBOT, &
- CUTOP
-
- 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
-
-
-! LOCAL VARS
-
- LOGICAL :: flag_qr, flag_qi, flag_qs
-
- 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
- REAL :: lastdt = -1.0
- REAL :: W0AVGfctr, W0fctr, W0den
- LOGICAL :: run_param
-
-!
- DXSQ=DX*DX
-
-!----------------------
- NTST=STEPCU
- TST=float(NTST*2)
- flag_qr = .FALSE.
- flag_qi = .FALSE.
- flag_qs = .FALSE.
- IF ( PRESENT(F_QR) ) flag_qr = F_QR
- IF ( PRESENT(F_QI) ) flag_qi = F_QI
- IF ( PRESENT(F_QS) ) flag_qs = F_QS
-!
- 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
-
-
-!
-!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)...
-!
-!----------------------
-
-!
-! Modified for adaptive time step
-!
- if (ADAPT_STEP_FLAG) then
- if ( (KTAU .eq. 1) .or. (cudt .eq. 0) .or. &
- ( CURR_SECS + dt >= &
- ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
- run_param = .TRUE.
- else
- run_param = .FALSE.
- endif
-
- else
- if (MOD(KTAU,NTST) .EQ. 0 .or. KTAU .eq. 1) then
- run_param = .TRUE.
- else
- run_param = .FALSE.
- endif
- endif
-
- if (run_param) then
-!
- 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 ( NCA(I,J) .ge. 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
- RAINCV(I,J)=0.
- CUTOP(I,J)=KTS
- CUBOT(I,J)=KTE+1
- 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 KF_eta_PARA(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, &
- flag_QI,flag_QS,warm_rain, &
- CUTOP,CUBOT,CUDT, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte)
- 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)) 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 )) THEN
- IF ( F_QI ) THEN
- DO K=kts,kte
- RQICUTEN(I,K,J)=DQIDT(K)
- ENDDO
- ENDIF
- ENDIF
-
- IF(PRESENT( rqscuten )) THEN
- IF ( F_QS ) THEN
- DO K=kts,kte
- RQSCUTEN(I,K,J)=DQSDT(K)
- ENDDO
- ENDIF
- ENDIF
-!
- ENDIF
- ENDDO ! i-loop
- ENDDO ! j-loop
- ENDIF ! run_param
-!
- END SUBROUTINE KF_eta_CPS
-! ****************************************************************************
-!-----------------------------------------------------------
- SUBROUTINE KF_eta_PARA (I, J, &
- U0,V0,T0,QV0,P0,DZQ,W0AVG1D, &
- DT,DX,DXSQ,rhoe, &
- XLV0,XLV1,XLS0,XLS1,CP,R,G, &
- EP2,SVP1,SVP2,SVP3,SVPT0, &
- DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &
- RAINCV,PRATEC,NCA, &
- F_QI,F_QS,warm_rain, &
- CUTOP,CUBOT,CUDT, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte)
-!-----------------------------------------------------------
-!***** The KF scheme that is currently used in experimental runs of EMCs
-!***** Eta model....jsk 8/00
-!
- 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
- ! ,P_QI,P_QS,P_FIRST_SCALAR
-
- LOGICAL, INTENT(IN ) :: F_QI, F_QS
-
- LOGICAL, INTENT(IN ) :: warm_rain
-!
- REAL, DIMENSION( kts:kte ), &
- INTENT(IN ) :: U0, &
- V0, &
- T0, &
- QV0, &
- P0, &
- rhoe, &
- 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) :: NCA
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(INOUT) :: RAINCV
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(INOUT) :: PRATEC
-
- REAL, DIMENSION( ims:ime , jms:jme ), &
- INTENT(OUT) :: CUBOT, &
- CUTOP
- REAL, INTENT(IN ) :: CUDT
-!
-!...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,TVQU,DP,RH,EQFRC,WSPD, &
- QDT,FXM,THTAG,THPA,THFXOUT, &
- THFXIN,QPA,QFXOUT,QFXIN,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
- REAL, DIMENSION( kts:kte ) :: &
- CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG
-
-! LOCAL VARS
-
- REAL :: P00,T00,RLF,RHIC,RHBC,PIE, &
- TTFRZ,TBFRZ,C5,RATE
- REAL :: GDRY,ROCP,ALIQ,BLIQ, &
- CLIQ,DLIQ
- 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,TTEMP,FRC1, &
- QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,&
- DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, &
- THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, &
- UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, &
- THTA,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,RHBAR,DMFFRC,DPMIN,DILBE
- REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,&
- QSS,PPTMLT,DTMELT,RHH,EVAC,BINC
-!
- INTEGER :: INDLU,NU,NUCHM,NNN,KLFS
- REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP
- REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP
-
- INTEGER :: KX,K,KL
-!
- INTEGER :: NCHECK
- INTEGER, DIMENSION (kts:kte) :: KCHECK
-
- INTEGER :: ISTOP,ML,L5,KMIX,LOW, &
- LC,MXLAYR,LLFC,NLAYRS,NK, &
- KPBL,KLCL,LCL,LET,IFLAG, &
- NK1,LTOP,NJ,LTOP1, &
- LTOPM1,LVF,KSTART,KMIN,LFS, &
- ND,NIC,LDB,LDT,ND1,NDK, &
- NM,LMAX,NCOUNT,NOITR, &
- NSTEP,NTC,NCHM,ISHALL,NSHALL
- LOGICAL :: IPRNT
- CHARACTER*1024 message
-!
- DATA P00,T00/1.E5,273.16/
- DATA RLF/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.03/
-! DATA RATE/0.01/ ! value used in NRCM
-!-----------------------------------------------------------
- IPRNT=.FALSE.
- GDRY=-G/CP
- ROCP=R/CP
- NSHALL = 0
- 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
-!
-!
-!****************************************************************************
-! ! PPT FB MODS
-!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS
-!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS
-!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS
-!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS
- FBFRC=0.0 ! PPT FB MODS
-!...mods to allow shallow convection...
- NCHM = 0
- ISHALL = 0
- DPMIN = 5.E3
-!...
- 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 K=1,KX
-!
-!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL...
-!
- ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ))
- QES(K)=0.622*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.
- RH(K) = Q0(K)/QES(K)
- DILFRC(K) = 1.
- TV0(K)=T0(K)*(1.+0.608*Q0(K))
-! RHOE(K)=P0(K)/(R*TV0(K))
-! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS...
- DP(K)=rhoe(k)*g*DZQ(k)
-! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme
-! use it for shallow convection...For now, assume it is not available....
-! TKE(K) = Q2(I,J,NK)
- TKE(K) = 0.
- CLDHGT(K) = 0.
-! IF(P0(K).GE.500E2)L5=K
- IF(P0(K).GE.0.5*P0(1))L5=K
- IF(P0(K).GE.P300)LLFC=K
- ENDDO
-!
-!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL
- Z0(1)=.5*DZQ(1)
-!cdir novector
- DO K=2,KL
- Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1))
- DZA(K-1)=Z0(K)-Z0(K-1)
- ENDDO
- DZA(KL)=0.
-!
-!
-! To save time, specify a pressure interval to move up in sequential
-! check of different ~50 mb deep groups of adjacent model layers in
-! the process of identifying updraft source layer (USL). Note that
-! this search is terminated as soon as a buoyant parcel is found and
-! this parcel can produce a cloud greater than specifed minimum depth
-! (CHMIN)...For now, set interval at 15 mb...
-!
- NCHECK = 1
- KCHECK(NCHECK)=1
- PM15 = P0(1)-15.E2
- DO K=2,LLFC
- IF(P0(K).LT.PM15)THEN
- NCHECK = NCHECK+1
- KCHECK(NCHECK) = K
- PM15 = PM15-15.E2
- ENDIF
- ENDDO
-!
- NU=0
- NUCHM=0
-usl: DO
- NU = NU+1
- IF(NU.GT.NCHECK)THEN
- IF(ISHALL.EQ.1)THEN
- CHMAX = 0.
- NCHM = 0
- DO NK = 1,NCHECK
- NNN=KCHECK(NK)
- IF(CLDHGT(NNN).GT.CHMAX)THEN
- NCHM = NNN
- NUCHM = NK
- CHMAX = CLDHGT(NNN)
- ENDIF
- ENDDO
- NU = NUCHM-1
- FBFRC=1.
- CYCLE usl
- ELSE
- RETURN
- ENDIF
- ENDIF
- KMIX = KCHECK(NU)
- LOW=KMIX
-!...
- LC = LOW
-!
-!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF
-!...UNSTABLE AIR AT LEAST 50 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 50 mb..
-!
- NLAYRS=0
- DPTHMX=0.
- NK=LC-1
- IF ( NK+1 .LT. KTS ) THEN
- WRITE(message,*)'WOULD GO OFF BOTTOM: KF_ETA_PARA I,J,NK',I,J,NK
-! CALL wrf_message (TRIM(message))
- ELSE
- DO
- NK=NK+1
- IF ( NK .GT. KTE ) THEN
- WRITE(message,*)'WOULD GO OFF TOP: KF_ETA_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN
-! CALL wrf_message (TRIM(message))
- EXIT
- ENDIF
- DPTHMX=DPTHMX+DP(NK)
- NLAYRS=NLAYRS+1
- IF(DPTHMX.GT.DPMIN)THEN
- EXIT
- ENDIF
- END DO
- ENDIF
- IF(DPTHMX.LT.DPMIN)THEN
- RETURN
- ENDIF
- KPBL=LC+NLAYRS-1
-!
-!...********************************************************
-!...for computational simplicity without much loss in accuracy,
-!...mix temperature instead of theta for evaluating convective
-!...initiation (triggering) potential...
-! THMIX=0.
- TMIX=0.
- QMIX=0.
- ZMIX=0.
- PMIX=0.
-!
-!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY
-!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL
-!...LAYERS...
-!
-!cdir novector
- DO NK=LC,KPBL
- TMIX=TMIX+DP(NK)*T0(NK)
- QMIX=QMIX+DP(NK)*Q0(NK)
- ZMIX=ZMIX+DP(NK)*Z0(NK)
- PMIX=PMIX+DP(NK)*P0(NK)
- ENDDO
-! THMIX=THMIX/DPTHMX
- TMIX=TMIX/DPTHMX
- QMIX=QMIX/DPTHMX
- ZMIX=ZMIX/DPTHMX
- PMIX=PMIX/DPTHMX
- EMIX=QMIX*PMIX/(0.622+QMIX)
-!
-!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL...
-!
-! TLOG=ALOG(EMIX/ALIQ)
-! ...calculate dewpoint using lookup table...
-!
- astrt=1.e-3
- ainc=0.075
- a1=emix/aliq
- tp=(a1-astrt)/ainc
- indlu=int(tp)+1
- value=(indlu-1)*ainc+astrt
- aintrp=(a1-value)/ainc
- tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
- 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)
- ZLCL = ZMIX+(TLCL-TMIX)/GDRY
- NK = LC-1
- DO
- NK = NK+1
- KLCL=NK
- IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN
- EXIT
- ENDIF
- ENDDO
- IF(NK.GT.KL)THEN
- RETURN
- ENDIF
- K=KLCL-1
- DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(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)
-!
-!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER
-!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0 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...
-!
- IF(ZLCL.LT.2.E3)THEN
- WKLCL=0.02*ZLCL/2.E3
- ELSE
- WKLCL=0.02
- ENDIF
- WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL
- IF(WKL.LT.0.0001)THEN
- DTLCL=0.
- ELSE
- DTLCL=4.64*WKL**0.33
- ENDIF
-!
-!...for ETA model, give parcel an extra temperature perturbation based
-!...the threshold RH for condensation (U00)...
-!
-!...for now, just assume U00=0.75...
-!...!!!!!! for MM5, SET DTRH = 0. !!!!!!!!
-! U00 = 0.75
-! IF(U00.lt.1.)THEN
-! QSLCL=QES(K)+(QES(KLCL)-QES(K))*DLP
-! RHLCL = QENV/QSLCL
-! DQSSDT = QMIX*(CLIQ-BLIQ*DLIQ)/((TLCL-DLIQ)*(TLCL-DLIQ))
-! IF(RHLCL.ge.0.75 .and. RHLCL.le.0.95)then
-! DTRH = 0.25*(RHLCL-0.75)*QMIX/DQSSDT
-! ELSEIF(RHLCL.GT.0.95)THEN
-! DTRH = (1./RHLCL-1.)*QMIX/DQSSDT
-! ELSE
- DTRH = 0.
-! ENDIF
-! ENDIF
-! IF(ISHALL.EQ.1)IPRNT=.TRUE.
-! IPRNT=.TRUE.
-! IF(TLCL+DTLCL.GT.TENV)GOTO 45
-!
-trigger: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN
-!
-! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL...
-!
- CYCLE usl
-!
- ELSE ! Parcel is buoyant, determine updraft
-!
-!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE
-!...EQUIVALENT POTENTIAL TEMPERATURE
-!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL...
-!
- CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ)
-!
-!...modify calculation of initial parcel vertical velocity...jsk 11/26/97
-!
- DTTOT = DTLCL+DTRH
- IF(DTTOT.GT.1.E-4)THEN
- GDT=2.*G*DTTOT*500./TVEN
- WLCL=1.+0.5*SQRT(GDT)
- WLCL = AMIN1(WLCL,3.)
- ELSE
- WLCL=1.
- ENDIF
- PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP
- WTW=WLCL*WLCL
-!
- TVLCL=TLCL*(1.+0.608*QMIX)
- RHOLCL=PLCL/(R*TVLCL)
-!
- LCL=KLCL
- LET=LCL
-! make RAD a function of background vertical velocity...
- IF(WKL.LT.0.)THEN
- RAD = 1000.
- ELSEIF(WKL.GT.0.1)THEN
- RAD = 2000.
- ELSE
- RAD = 1000.+1000*WKL/0.1
- ENDIF
-!
-!*******************************************************************
-! *
-! COMPUTE UPDRAFT PROPERTIES *
-! *
-!*******************************************************************
-!
-!
-!...
-!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))...
-!
- WU(K)=WLCL
- AU0=0.01*DXSQ
- 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
-!
-!...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...
-!
-!
- EE1=1.
- UD1=0.
- REI = 0.
- DILBE = 0.
-updraft: DO NK=K,KL-1
- NK1=NK+1
- RATIO2(NK1)=RATIO2(NK)
- FRC1=0.
- TU(NK1)=T0(NK1)
- THETEU(NK1)=THETEU(NK)
- QU(NK1)=QU(NK)
- QLIQ(NK1)=QLIQ(NK)
- QICE(NK1)=QICE(NK)
- call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), &
- qice(nk1),qnewlq,qnewic,XLV1,XLV0)
-!
-!
-!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH
-!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE
-!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE
-!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL
-!...LIQUID WATER IS FROZEN AT EACH LEVEL...
-!
- IF(TU(NK1).LE.TTFRZ)THEN
- IF(TU(NK1).GT.TBFRZ)THEN
- IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ
- FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ)
- ELSE
- FRC1=1.
- IFLAG=1
- ENDIF
- TTEMP=TU(NK1)
-!
-! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE
-!...IS BELOW TTFRZ...
-!
- QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1
- QNEWIC=QNEWIC+QNEWLQ*FRC1
- QNEWLQ=QNEWLQ-QNEWLQ*FRC1
- QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1
- QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1
- CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, &
- QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
- ENDIF
- TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1))
-!
-! 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
- DZZ=Z0(NK1)-ZLCL
- ELSE
- BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1.
- BOTERM=2.*DZA(NK)*G*BE/1.5
- DZZ=DZA(NK)
- ENDIF
- ENTERM=2.*REI*WTW/UPOLD
-
- 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.LT.1.E-3)THEN
- EXIT
- ELSE
- WU(NK1)=SQRT(WTW)
- ENDIF
-!...Calculate value of THETA-E in environment to entrain into updraft...
-!
- CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
-!
-!...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(NK.EQ.K)THEN
- DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ
- ELSE
- DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ
- ENDIF
- IF(DILBE.GT.0.)ABE=ABE+DILBE*G
-!
-!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL
-!...ENTRAINMENT (0.5*REI) IS IMPOSED...
-!
- IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK
- EE2=0.5
- UD2=1.
- EQFRC(NK1)=0.
- ELSE
- LET=NK1
- TTMP=TVQU(NK1)
-!
-!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR...
-!
- 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 tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, &
- qnewlq,qnewic,XLV1,XLV0)
- TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)
- IF(TU95.GT.TV0(NK1))THEN
- EE2=1.
- UD2=0.
- EQFRC(NK1)=1.0
- ELSE
- 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 tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, &
- qnewlq,qnewic,XLV1,XLV0)
- TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)
- TVDIFF = ABS(TU10-TVQU(NK1))
- IF(TVDIFF.LT.1.e-3)THEN
- EE2=1.
- UD2=0.
- EQFRC(NK1)=1.0
- ELSE
- 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.
- ELSEIF(EQFRC(NK1).EQ.0.)THEN
- EE2=0.
- UD2=1.
- ELSE
-!
-!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE
-! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES...
-!
- CALL PROF5(EQFRC(NK1),EE2,UD2)
- ENDIF
- ENDIF
- ENDIF
- ENDIF ! End of Entrain/Detrain IF BLOCK
-!
-!
-!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL
-! VALUES IN THE LAYER...
-!
- EE2 = AMAX1(EE2,0.5)
- UD2 = 1.5*UD2
- 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 CALCULATIONS...
-!
- IF(UMF(NK)-UDR(NK1).LT.10.)THEN
-!
-!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS
-! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL..
-! First, correct ABE calculation if needed...
-!
- IF(DILBE.GT.0.)THEN
- ABE=ABE-DILBE*G
- ENDIF
- LET=NK
-! WRITE(98,1015)P0(NK1)/100.
- EXIT
- ELSE
- EE1=EE2
- UD1=UD2
- UPOLD=UMF(NK)-UDR(NK1)
- UPNEW=UPOLD+UER(NK1)
- UMF(NK1)=UPNEW
- DILFRC(NK1) = UPNEW/UPOLD
-!
-!...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
-!
-!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF
-!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE,
-!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE
-!...CURRENT MODEL LEVEL...
-!
- PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK)
- PPTICE(NK1)=QICOUT(NK1)*UMF(NK)
-!
- TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1)
- IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX
- ENDIF
-!
- END DO updraft
-!
-!...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 BE
-! THE LET AND CLOUD TOP...
-!
-!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOC
-! FIRST BECOMES NEGATIVE...
-!
- LTOP=NK
- CLDHGT(LC)=Z0(LTOP)-ZLCL
-!
-!...Instead of using the same minimum cloud height (for deep convection)
-!...everywhere, try specifying minimum cloud depth as a function of TLCL...
-!
-!
-!
- IF(TLCL.GT.293.)THEN
- CHMIN = 4.E3
- ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN
- CHMIN = 2.E3 + 100.*(TLCL-273.)
- ELSEIF(TLCL.LT.273.)THEN
- CHMIN = 2.E3
- ENDIF
-
-!
-!...If cloud top height is less than the specified minimum for deep
-!...convection, save value to consider this level as source for
-!...shallow convection, go back up to check next level...
-!
-!...Try specifying minimum cloud depth as a function of TLCL...
-!
-!
-!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF:
-!
-!... 1.) if there is no CAPE, or
-!... 2.) cloud top is at model level just above LCL, or
-!... 3.) cloud top is within updraft source layer, or
-!... 4.) cloud-top detrainment layer begins within
-!... updraft source layer.
-!
- IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL)THEN ! No Convection Allowed
- CLDHGT(LC)=0.
- DO NK=K,LTOP
- UMF(NK)=0.
- UDR(NK)=0.
- UER(NK)=0.
- DETLQ(NK)=0.
- DETIC(NK)=0.
- PPTLIQ(NK)=0.
- PPTICE(NK)=0.
- ENDDO
-!
- ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed
- ISHALL=0
- EXIT usl
- ELSE
-!
-!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!!
- ISHALL = 1
- IF(NU.EQ.NUCHM)THEN
- EXIT usl ! Shallow Convection from this layer
- ELSE
-! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer
- DO NK=K,LTOP
- UMF(NK)=0.
- UDR(NK)=0.
- UER(NK)=0.
- DETLQ(NK)=0.
- DETIC(NK)=0.
- PPTLIQ(NK)=0.
- PPTICE(NK)=0.
- ENDDO
- ENDIF
- ENDIF
- ENDIF trigger
- END DO usl
- IF(ISHALL.EQ.1)THEN
- KSTART=MAX0(KPBL,KLCL)
- LET=KSTART
- endif
-!
-!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL
-! 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
- UER(LTOP)=0.
- UMF(LTOP)=0.
- ELSE
-!
-! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET...
-!
- DPTT=0.
- DO NJ=LET+1,LTOP
- DPTT=DPTT+DP(NJ)
- ENDDO
- DUMFDP=UMF(LET)/DPTT
-!
-!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL
-! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND
-!
- DO NK=LET+1,LTOP
-!
-!...entrainment is allowed at every level except for LTOP, so disallow
-!...entrainment at LTOP and adjust entrainment rates between LET and LTOP
-!...so the the dilution factor due to entyrianment is not changed but
-!...the actual entrainment rate will change due due forced total
-!...detrainment in this layer...
-!
- IF(NK.EQ.LTOP)THEN
- UDR(NK) = UMF(NK-1)
- UER(NK) = 0.
- DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK)
- DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK)
- ELSE
- UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP
- UER(NK)=UMF(NK)*(1.-1./DILFRC(NK))
- UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK)
- DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK)
- DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK)
- ENDIF
- IF(NK.GE.LET+2)THEN
- TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK)
- PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK)
- PPTICE(NK)=UMF(NK-1)*QICOUT(NK)
- TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK)
- ENDIF
- ENDDO
- ENDIF
-!
-! Initialize some arrays below cloud base and above cloud top...
-!
- DO NK=1,LTOP
- IF(T0(NK).GT.T00)ML=NK
- ENDDO
- DO NK=1,K
- IF(NK.GE.LC)THEN
- IF(NK.EQ.LC)THEN
- UMF(NK)=VMFLCL*DP(NK)/DPTHMX
- UER(NK)=VMFLCL*DP(NK)/DPTHMX
- ELSEIF(NK.LE.KPBL)THEN
- UER(NK)=VMFLCL*DP(NK)/DPTHMX
- UMF(NK)=UMF(NK-1)+UER(NK)
- ELSE
- UMF(NK)=VMFLCL
- UER(NK)=0.
- ENDIF
- TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY
- QU(NK)=QMIX
- WU(NK)=WLCL
- ELSE
- TU(NK)=0.
- QU(NK)=0.
- UMF(NK)=0.
- WU(NK)=0.
- UER(NK)=0.
- ENDIF
- UDR(NK)=0.
- QDT(NK)=0.
- QLIQ(NK)=0.
- QICE(NK)=0.
- QLQOUT(NK)=0.
- QICOUT(NK)=0.
- PPTLIQ(NK)=0.
- PPTICE(NK)=0.
- DETLQ(NK)=0.
- DETIC(NK)=0.
- RATIO2(NK)=0.
- CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ)
- EQFRC(NK)=1.0
- ENDDO
-!
- LTOP1=LTOP+1
- LTOPM1=LTOP-1
-!
-!...DEFINE VARIABLES ABOVE CLOUD TOP...
-!
- DO NK=LTOP1,KX
- UMF(NK)=0.
- UDR(NK)=0.
- UER(NK)=0.
- QDT(NK)=0.
- QLIQ(NK)=0.
- QICE(NK)=0.
- QLQOUT(NK)=0.
- QICOUT(NK)=0.
- DETLQ(NK)=0.
- DETIC(NK)=0.
- PPTLIQ(NK)=0.
- PPTICE(NK)=0.
- IF(NK.GT.LTOP1)THEN
- TU(NK)=0.
- QU(NK)=0.
- WU(NK)=0.
- ENDIF
- THTA0(NK)=0.
- THTAU(NK)=0.
- EMS(NK)=0.
- EMSD(NK)=0.
- TG(NK)=T0(NK)
- QG(NK)=Q0(NK)
- QLG(NK)=0.
- QIG(NK)=0.
- QRG(NK)=0.
- QSG(NK)=0.
- OMG(NK)=0.
- ENDDO
- OMG(KX+1)=0.
- DO NK=1,LTOP
- EMS(NK)=DP(NK)*DXSQ/G
- EMSD(NK)=1./EMS(NK)
-!
-!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCH
-!
- EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK)))
- THTAU(NK)=TU(NK)*EXN(NK)
- EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK)))
- THTA0(NK)=T0(NK)*EXN(NK)
- DDILFRC(NK) = 1./DILFRC(NK)
- OMG(NK)=0.
- ENDDO
-! IF (XTIME.LT.10.)THEN
-! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG,
-! * TMIX-T00,PMIX,QMIX,ABE
-! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100.,
-! * WLCL,CLDHGT
-! ENDIF
-!
-!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL
-!...AND MIDTROPOSPHERE IS USED.
-!
- WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL))
- WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5))
- WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP))
- VCONV=.5*(WSPD(KLCL)+WSPD(L5))
-!...for ETA model, DX is a function of location...
-! TIMEC=DX(I,J)/VCONV
- TIMEC=DX/VCONV
- TADVEC=TIMEC
- TIMEC=AMAX1(1800.,TIMEC)
- TIMEC=AMIN1(3600.,TIMEC)
- IF(ISHALL.EQ.1)TIMEC=2400.
- NIC=NINT(TIMEC/DT)
- TIMEC=FLOAT(NIC)*DT
-!
-!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY.
-!
- IF(WSPD(LTOP).GT.WSPD(KLCL))THEN
- SHSIGN=1.
- ELSE
- SHSIGN=-1.
- ENDIF
- VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* &
- (V0(LTOP)-V0(KLCL))
- VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL))
- PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3))
- PEF=AMAX1(PEF,.2)
- PEF=AMIN1(PEF,.9)
-!
-!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE.
-!
- CBH=(ZLCL-Z0(1))*3.281E-3
- IF(CBH.LT.3.)THEN
- RCBH=.02
- ELSE
- RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- &
- 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6))))
- ENDIF
- IF(CBH.GT.25)RCBH=2.4
- PEFCBH=1./(1.+RCBH)
- PEFCBH=AMIN1(PEFCBH,.9)
-!
-!... MEAN PEF. IS USED TO COMPUTE RAINFALL.
-!
- PEFF=.5*(PEF+PEFCBH)
- PEFF2 = PEFF ! JSK MODS
- IF(IPRNT)THEN
-! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS
- WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS
-! CALL wrf_message( message )
-! call flush(98)
- endif
-! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS
-!*****************************************************************
-! *
-! COMPUTE DOWNDRAFT PROPERTIES *
-! *
-!*****************************************************************
-!
-!
- TDER=0.
- devap:IF(ISHALL.EQ.1)THEN
- LFS = 1
- ELSE
-!
-!...start downdraft about 150 mb above cloud base...
-!
-! KSTART=MAX0(KPBL,KLCL)
-! KSTART=KPBL ! Changed 7/23/99
- KSTART=KPBL+1 ! Changed 7/23/99
- KLFS = LET-1
- DO NK = KSTART+1,KL
- DPPP = P0(KSTART)-P0(NK)
-! IF(DPPP.GT.200.E2)THEN
- IF(DPPP.GT.150.E2)THEN
- KLFS = NK
- EXIT
- ENDIF
- ENDDO
- KLFS = MIN0(KLFS,LET-1)
- LFS = KLFS
-!
-!...if LFS is not at least 50 mb above cloud base (implying that the
-!...level of equil temp, LET, is just above cloud base) do not allow a
-!...downdraft...
-!
- IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN
- THETED(LFS) = THETEE(LFS)
- QD(LFS) = Q0(LFS)
-!
-!...call tpmix2dd to find wet-bulb temp, qv...
-!
- call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j)
- THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS))
-!
-!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX...
-!
- TVD(LFS)=TZ(LFS)*(1.+0.608*QSS)
- RDD=P0(LFS)/(R*TVD(LFS))
- A1=(1.-PEFF)*AU0
- DMF(LFS)=-A1*RDD
- DER(LFS)=DMF(LFS)
- DDR(LFS)=0.
- RHBAR = RH(LFS)*DP(LFS)
- DPTT = DP(LFS)
- DO ND = LFS-1,KSTART,-1
- ND1 = ND+1
- DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS)
- DDR(ND)=0.
- DMF(ND)=DMF(ND1)+DER(ND)
- THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND)
- QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND)
- DPTT = DPTT+DP(ND)
- RHBAR = RHBAR+RH(ND)*DP(ND)
- ENDDO
- RHBAR = RHBAR/DPTT
- DMFFRC = 2.*(1.-RHBAR)
- DPDD = 0.
-!...Calculate melting effect
-!... first, compute total frozen precipitation generated...
-!
- pptmlt = 0.
- DO NK = KLCL,LTOP
- PPTMLT = PPTMLT+PPTICE(NK)
- ENDDO
- if(lc.lt.ml)then
-!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as
-!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large!
-!...12/14/98 jsk...
- DTMELT = RLF*PPTMLT/(CP*UMF(KLCL))
- else
- DTMELT = 0.
- endif
- LDT = MIN0(LFS-1,KSTART-1)
-!
- call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j)
-!
- tz(kstart) = tz(kstart)-dtmelt
- ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ))
- QSS=0.622*ES/(P0(KSTART)-ES)
- THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* &
- EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS))
-!....
- LDT = MIN0(LFS-1,KSTART-1)
- DO ND = LDT,1,-1
- DPDD = DPDD+DP(ND)
- THETED(ND) = THETED(KSTART)
- QD(ND) = QD(KSTART)
-!
-!...call tpmix2dd to find wet bulb temp, saturation mixing ratio...
-!
- call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j)
- qsd(nd) = qss
-!
-!...specify RH decrease of 20%/km in downdraft...
-!
- RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND))
-!
-!...adjust downdraft TEMP, Q to specified RH:
-!
- IF(RHH.LT.1.)THEN
- DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ))
- RL=XLV0-XLV1*TZ(ND)
- DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT)
- T1RH=TZ(ND)+DTMP
- ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ))
- QSRH=0.622*ES/(P0(ND)-ES)
-!
-!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL
-!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION...
-!
- IF(QSRH.LT.QD(ND))THEN
- QSRH=QD(ND)
- T1RH=TZ(ND)+(QSS-QSRH)*RL/CP
- ENDIF
- TZ(ND)=T1RH
- QSS=QSRH
- QSD(ND) = QSS
- ENDIF
- TVD(nd) = tz(nd)*(1.+0.608*qsd(nd))
- IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN
- LDB=ND
- EXIT
- ENDIF
- ENDDO
- IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth!
- DO ND=LDT,LDB,-1
- ND1 = ND+1
- DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD
- DER(ND) = 0.
- DMF(ND) = DMF(ND1)+DDR(ND)
- TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND)
- QD(ND)=QSD(nd)
- THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND)))
- ENDDO
- ENDIF
- ENDIF
- ENDIF devap
-!
-!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE
-!...HUMIDITY, NO DOWNDRAFT IS ALLOWED...
-!
-d_mf: IF(TDER.LT.1.)THEN
-! WRITE(98,3004)I,J
-!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2)
- PPTFLX=TRPPT
- CPR=TRPPT
- TDER=0.
- CNDTNF=0.
- UPDINC=1.
- LDB=LFS
- DO NDK=1,LTOP
- DMF(NDK)=0.
- DER(NDK)=0.
- DDR(NDK)=0.
- THTAD(NDK)=0.
- WD(NDK)=0.
- TZ(NDK)=0.
- QD(NDK)=0.
- ENDDO
- AINCM2=100.
- ELSE
- DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART)
- UPDINC=1.
- IF(TDER*DDINC.GT.TRPPT)THEN
- DDINC = TRPPT/TDER
- ENDIF
- TDER = TDER*DDINC
- DO NK=LDB,LFS
- DMF(NK)=DMF(NK)*DDINC
- DER(NK)=DER(NK)*DDINC
- DDR(NK)=DDR(NK)*DDINC
- ENDDO
- CPR=TRPPT
- PPTFLX = TRPPT-TDER
- PEFF=PPTFLX/TRPPT
- IF(IPRNT)THEN
-! write(98,*)'PRECIP EFFICIENCY =',PEFF
- write(message,*)'PRECIP EFFICIENCY =',PEFF
-! CALL wrf_message(message)
-! call flush(98)
- ENDIF
-!
-!
-!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN
-! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE
-! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS...
-!
-! DO NK=LC,LFS
-! UMF(NK)=UMF(NK)*UPDINC
-! UDR(NK)=UDR(NK)*UPDINC
-! UER(NK)=UER(NK)*UPDINC
-! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC
-! PPTICE(NK)=PPTICE(NK)*UPDINC
-! DETLQ(NK)=DETLQ(NK)*UPDINC
-! DETIC(NK)=DETIC(NK)*UPDINC
-! ENDDO
-!
-!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE
-!...DOWNDRAFT...
-!
- IF(LDB.GT.1)THEN
- DO NK=1,LDB-1
- DMF(NK)=0.
- DER(NK)=0.
- DDR(NK)=0.
- WD(NK)=0.
- TZ(NK)=0.
- QD(NK)=0.
- THTAD(NK)=0.
- ENDDO
- ENDIF
- DO NK=LFS+1,KX
- DMF(NK)=0.
- DER(NK)=0.
- DDR(NK)=0.
- WD(NK)=0.
- TZ(NK)=0.
- QD(NK)=0.
- THTAD(NK)=0.
- ENDDO
- DO NK=LDT+1,LFS-1
- TZ(NK)=0.
- QD(NK)=0.
- THTAD(NK)=0.
- ENDDO
- ENDIF d_mf
-!
-!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFL
-! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILAB
-! IN THAT LAYER INITIALLY...
-!
- AINCMX=1000.
- LMAX=MAX0(KLCL,LFS)
- DO NK=LC,LMAX
- IF((UER(NK)-DER(NK)).GT.1.e-3)THEN
- AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC)
- AINCMX=AMIN1(AINCMX,AINCM1)
- ENDIF
- ENDDO
- AINC=1.
- IF(AINCMX.LT.AINC)AINC=AINCMX
-!
-!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL
-!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION
-!...CLOSURE...
-!
- TDER2=TDER
- PPTFL2=PPTFLX
- DO NK=1,LTOP
- DETLQ2(NK)=DETLQ(NK)
- DETIC2(NK)=DETIC(NK)
- UDR2(NK)=UDR(NK)
- UER2(NK)=UER(NK)
- DDR2(NK)=DDR(NK)
- DER2(NK)=DER(NK)
- UMF2(NK)=UMF(NK)
- DMF2(NK)=DMF(NK)
- ENDDO
- FABE=1.
- STAB=0.95
- NOITR=0
- ISTOP=0
-!
- IF(ISHALL.EQ.1)THEN ! First for shallow convection
-!
-! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available
-! from a turbulence parameterization, scale cloud-base updraft mass flux as a function
-! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5...
-!
-!...find the maximum TKE value between LC and KLCL...
-! TKEMAX = 0.
- TKEMAX = 5.
-! DO 173 K = LC,KLCL
-! NK = KX-K+1
-! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK))
-! 173 CONTINUE
-! TKEMAX = AMIN1(TKEMAX,10.)
-! TKEMAX = AMAX1(TKEMAX,5.)
-!c TKEMAX = 10.
-!c...3_24_99...DPMIN was changed for shallow convection so that it is the
-!c... the same as for deep convection (5.E3). Since this doubles
-!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu-
-!c... lation of EVAC...
-!c EVAC = TKEMAX*0.1
- EVAC = 0.5*TKEMAX*0.1
-! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC)
-! AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC)
- AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC)
- TDER=TDER2*AINC
- PPTFLX=PPTFL2*AINC
- DO NK=1,LTOP
- UMF(NK)=UMF2(NK)*AINC
- DMF(NK)=DMF2(NK)*AINC
- DETLQ(NK)=DETLQ2(NK)*AINC
- DETIC(NK)=DETIC2(NK)*AINC
- UDR(NK)=UDR2(NK)*AINC
- UER(NK)=UER2(NK)*AINC
- DER(NK)=DER2(NK)*AINC
- DDR(NK)=DDR2(NK)*AINC
- ENDDO
- ENDIF ! Otherwise for deep convection
-! use iterative procedure to find mass fluxes...
-iter: DO NCOUNT=1,10
-!
-!*****************************************************************
-! *
-! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE *
-! *
-!*****************************************************************
-!
-!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO
-!...SATISFY MASS CONTINUITY...
-!
- DTT=TIMEC
- DO NK=1,LTOP
- DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK)
- IF(NK.GT.1)THEN
- OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1)
- ABSOMG = ABS(OMG(NK))
- ABSOMGTC = ABSOMG*TIMEC
- FRDP = 0.75*DP(NK-1)
- IF(ABSOMGTC.GT.FRDP)THEN
- DTT1 = FRDP/ABSOMG
- DTT=AMIN1(DTT,DTT1)
- ENDIF
- ENDIF
- ENDDO
- DO NK=1,LTOP
- THPA(NK)=THTA0(NK)
- QPA(NK)=Q0(NK)
- NSTEP=NINT(TIMEC/DTT+1)
- DTIME=TIMEC/FLOAT(NSTEP)
- FXM(NK)=OMG(NK)*DXSQ/G
- ENDDO
-!
-!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV...
-!
- DO NTC=1,NSTEP
-!
-!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED
-!...SIGN OF OMEGA...
-!
- DO NK=1,LTOP
- THFXIN(NK)=0.
- THFXOUT(NK)=0.
- QFXIN(NK)=0.
- QFXOUT(NK)=0.
- ENDDO
- DO NK=2,LTOP
- IF(OMG(NK).LE.0.)THEN
- THFXIN(NK)=-FXM(NK)*THPA(NK-1)
- QFXIN(NK)=-FXM(NK)*QPA(NK-1)
- THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK)
- QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK)
- ELSE
- THFXOUT(NK)=FXM(NK)*THPA(NK)
- QFXOUT(NK)=FXM(NK)*QPA(NK)
- THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK)
- QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK)
- ENDIF
- ENDDO
-!
-!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL...
-!
- DO NK=1,LTOP
- THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* &
- THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* &
- DTIME*EMSD(NK)
- QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- &
- QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK)
- ENDDO
- ENDDO
- DO NK=1,LTOP
- THTAG(NK)=THPA(NK)
- QG(NK)=QPA(NK)
- ENDDO
-!
-!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORRO
-!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO...
-!
- DO NK=1,LTOP
- IF(QG(NK).LT.0.)THEN
- IF(NK.EQ.1)THEN ! JSK MODS
-! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS
-! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS
-! CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS
- ENDIF ! JSK MODS
- NK1=NK+1
- IF(NK.EQ.LTOP)THEN
- NK1=KLCL
- ENDIF
- TMA=QG(NK1)*EMS(NK1)
- TMB=QG(NK-1)*EMS(NK-1)
- TMM=(QG(NK)-1.E-9)*EMS(NK )
- BCOEFF=-TMM/((TMA*TMA)/TMB+TMB)
- ACOEFF=BCOEFF*TMA/TMB
- TMB=TMB*(1.-BCOEFF)
- TMA=TMA*(1.-ACOEFF)
- IF(NK.EQ.LTOP)THEN
- QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1)
-! IF(ABS(QVDIFF).GT.1.)THEN
-! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', &
-! QVDIFF, &
-! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', &
-! 'VALUES IN KAIN-FRITSCH'
-! ENDIF
- ENDIF
- QG(NK)=1.E-9
- QG(NK1)=TMA*EMSD(NK1)
- QG(NK-1)=TMB*EMSD(NK-1)
- ENDIF
- ENDDO
- TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP)
- IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN
-! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; &
-! TOPOMG, OMG =',TOPOMG,OMG(LTOP)
-! TOPOMG, OMG =',TOPOMG,OMG(LTOP)
- ISTOP=1
- IPRNT=.TRUE.
- EXIT iter
- ENDIF
-!
-!...CONVERT THETA TO T...
-!
- DO NK=1,LTOP
- EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK)))
- TG(NK)=THTAG(NK)/EXN(NK)
- TVG(NK)=TG(NK)*(1.+0.608*QG(NK))
- ENDDO
- IF(ISHALL.EQ.1)THEN
- EXIT iter
- ENDIF
-!
-!*******************************************************************
-! *
-! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. *
-! *
-!*******************************************************************
-!
-!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT
-!
-! THMIX=0.
- TMIX=0.
- QMIX=0.
-!
-!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY
-!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL
-!...LAYERS...
-!
- DO NK=LC,KPBL
- TMIX=TMIX+DP(NK)*TG(NK)
- QMIX=QMIX+DP(NK)*QG(NK)
- ENDDO
- TMIX=TMIX/DPTHMX
- QMIX=QMIX/DPTHMX
- ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ))
- QSS=0.622*ES/(PMIX-ES)
-!
-!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY...
-!
- IF(QMIX.GT.QSS)THEN
- RL=XLV0-XLV1*TMIX
- CPM=CP*(1.+0.887*QMIX)
- DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ))
- DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM)
- TMIX=TMIX+RL/CP*DQ
- QMIX=QMIX-DQ
- TLCL=TMIX
- ELSE
- QMIX=AMAX1(QMIX,0.)
- EMIX=QMIX*PMIX/(0.622+QMIX)
- astrt=1.e-3
- binc=0.075
- a1=emix/aliq
- tp=(a1-astrt)/binc
- indlu=int(tp)+1
- value=(indlu-1)*binc+astrt
- aintrp=(a1-value)/binc
- tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
- 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)
- ENDIF
- TVLCL=TLCL*(1.+0.608*QMIX)
- ZLCL = ZMIX+(TLCL-TMIX)/GDRY
- DO NK = LC,KL
- KLCL=NK
- IF(ZLCL.LE.Z0(NK))THEN
- EXIT
- ENDIF
- ENDDO
- K=KLCL-1
- DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K))
-!
-!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL...
-!
- TENV=TG(K)+(TG(KLCL)-TG(K))*DLP
- QENV=QG(K)+(QG(KLCL)-QG(K))*DLP
- TVEN=TENV*(1.+0.608*QENV)
- PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP
- THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* &
- EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX))
-!
-!...COMPUTE ADJUSTED ABE(ABEG).
-!
- ABEG=0.
- DO NK=K,LTOPM1
- NK1=NK+1
- THETEU(NK1) = THETEU(NK)
-!
- call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j)
-!
- TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1))
- IF(NK.EQ.K)THEN
- DZZ=Z0(KLCL)-ZLCL
- DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ
- ELSE
- DZZ=DZA(NK)
- DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ
- ENDIF
- IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G
-!
-!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT...
-!
- CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ)
- THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1))
- ENDDO
-!
-!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING
-!...THE PERIOD TIMEC...
-!
- IF(NOITR.EQ.1)THEN
-! write(98,*)' '
-! write(98,*)'TAU, I, J, =',NTSD,I,J
-! WRITE(98,1060)FABE
-! GOTO 265
- EXIT iter
- ENDIF
- DABE=AMAX1(ABE-ABEG,0.1*ABE)
- FABE=ABEG/ABE
- IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN
-! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS
-! *GRID POINT; NO CONVECTION ALLOWED!'
- RETURN
- ENDIF
- IF(NCOUNT.NE.1)THEN
- IF(ABS(AINC-AINCOLD).LT.0.0001)THEN
- NOITR=1
- AINC=AINCOLD
- CYCLE iter
- ENDIF
- DFDA=(FABE-FABEOLD)/(AINC-AINCOLD)
- IF(DFDA.GT.0.)THEN
- NOITR=1
- AINC=AINCOLD
- CYCLE iter
- ENDIF
- ENDIF
- AINCOLD=AINC
- FABEOLD=FABE
- IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN
-! write(98,*)' '
-! write(98,*)'TAU, I, J, =',NTSD,I,J
-! WRITE(98,1055)FABE
-! GOTO 265
- EXIT
- ENDIF
- IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN
- EXIT iter
- ELSE
- IF(NCOUNT.GT.10)THEN
-! write(98,*)' '
-! write(98,*)'TAU, I, J, =',NTSD,I,J
-! WRITE(98,1060)FABE
-! GOTO 265
- EXIT
- ENDIF
-!
-!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTI
-!...MASS FLUX BY THE FACTOR AINC:
-!
- IF(FABE.EQ.0.)THEN
- AINC=AINC*0.5
- ELSE
- IF(DABE.LT.1.e-4)THEN
- NOITR=1
- AINC=AINCOLD
- CYCLE iter
- ELSE
- AINC=AINC*STAB*ABE/DABE
- ENDIF
- ENDIF
-! AINC=AMIN1(AINCMX,AINC)
- AINC=AMIN1(AINCMX,AINC)
-!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS
-!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS
- IF(AINC.LT.0.05)then
- RETURN ! JSK MODS
- ENDIF
-! AINC=AMAX1(AINC,0.05) ! JSK MODS
- TDER=TDER2*AINC
- PPTFLX=PPTFL2*AINC
-! IF (XTIME.LT.10.)THEN
-! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,
-! * FABEOLD,AINCOLD
-! ENDIF
- DO NK=1,LTOP
- UMF(NK)=UMF2(NK)*AINC
- DMF(NK)=DMF2(NK)*AINC
- DETLQ(NK)=DETLQ2(NK)*AINC
- DETIC(NK)=DETIC2(NK)*AINC
- UDR(NK)=UDR2(NK)*AINC
- UER(NK)=UER2(NK)*AINC
- DER(NK)=DER2(NK)*AINC
- DDR(NK)=DDR2(NK)*AINC
- ENDDO
-!
-!...GO BACK UP FOR ANOTHER ITERATION...
-!
- ENDIF
- ENDDO iter
-!
-!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV...
-!
-!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS
-!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS
-!
-! Redistribute hydormeteors according to the final mass-flux values:
-!
- IF(CPR.GT.0.)THEN
- FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS
- ELSE
- FRC2=0.
- ENDIF
- DO NK=1,LTOP
- QLPA(NK)=QL0(NK)
- QIPA(NK)=QI0(NK)
- QRPA(NK)=QR0(NK)
- QSPA(NK)=QS0(NK)
- RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS
- SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS
- ENDDO
- DO NTC=1,NSTEP
-!
-!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAY
-!...BASED ON THE SIGN OF OMEGA...
-!
- DO NK=1,LTOP
- QLFXIN(NK)=0.
- QLFXOUT(NK)=0.
- QIFXIN(NK)=0.
- QIFXOUT(NK)=0.
- QRFXIN(NK)=0.
- QRFXOUT(NK)=0.
- QSFXIN(NK)=0.
- QSFXOUT(NK)=0.
- ENDDO
- DO NK=2,LTOP
- IF(OMG(NK).LE.0.)THEN
- QLFXIN(NK)=-FXM(NK)*QLPA(NK-1)
- QIFXIN(NK)=-FXM(NK)*QIPA(NK-1)
- QRFXIN(NK)=-FXM(NK)*QRPA(NK-1)
- QSFXIN(NK)=-FXM(NK)*QSPA(NK-1)
- QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK)
- QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK)
- QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK)
- QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK)
- ELSE
- QLFXOUT(NK)=FXM(NK)*QLPA(NK)
- QIFXOUT(NK)=FXM(NK)*QIPA(NK)
- QRFXOUT(NK)=FXM(NK)*QRPA(NK)
- QSFXOUT(NK)=FXM(NK)*QSPA(NK)
- QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK)
- QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK)
- QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK)
- QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK)
- ENDIF
- ENDDO
-!
-!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL...
-!
- DO NK=1,LTOP
- QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK)
- QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK)
- QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS
- QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS
- ENDDO
- ENDDO
- DO NK=1,LTOP
- QLG(NK)=QLPA(NK)
- QIG(NK)=QIPA(NK)
- QRG(NK)=QRPA(NK)
- QSG(NK)=QSPA(NK)
- ENDDO
-!
-!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS
-!...GRID POINT...
-!
-! IF (XTIME.LT.10.)THEN
-! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
-! ENDIF
- IF(IPRNT)THEN
-! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
- WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
-! CALL wrf_message(message)
-! call flush(98)
- endif
-!
-!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES...
-!
-!297 IF(IPRNT)then
- IF(IPRNT)then
-! if(I.eq.16 .and. J.eq.41)then
-! IF(ISTOP.EQ.1)THEN
- write(98,*)
-! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J
- write(message,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., &
- TLCL+DTLCL+dtrh-TENV,WKL,WKLCL
-! call wrf_message(message)
- write(message,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, &
- DTRH,TENV
-! call wrf_message(message)
- WRITE(message,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, &
- TMIX-T00,PMIX,QMIX,ABE
-! call wrf_message(message)
- WRITE(message,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., &
- WLCL,CLDHGT(LC)
-! call wrf_message(message)
- WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS
-! call wrf_message(message)
- write(message,*)'PRECIP EFFICIENCY =',PEFF
-! call wrf_message(message)
- WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
-! call wrf_message(message)
-! ENDIF
-!!!!! HERE !!!!!!!
- WRITE(message,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', &
- ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' &
- ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC '
-! call wrf_message(message)
- write(message,*)'just before DO 300...'
-! call wrf_message(message)
-! call flush(98)
- DO NK=1,LTOP
- K=LTOP-NK+1
- DTT=(TG(K)-T0(K))*86400./TIMEC
- RL=XLV0-XLV1*TG(K)
- DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP)
- UDFRC=UDR(K)*TIMEC*EMSD(K)
- UEFRC=UER(K)*TIMEC*EMSD(K)
- DDFRC=DDR(K)*TIMEC*EMSD(K)
- DEFRC=-DER(K)*TIMEC*EMSD(K)
- WRITE(message,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, &
- UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, &
- W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* &
- TIMEC*EMSD(K)*1.E3
-! call wrf_message(message)
- ENDDO
- WRITE(message,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', &
- 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG'
-! call wrf_message(message)
- DO NK=1,KL
- K=KX-NK+1
- DTT=TG(K)-T0(K)
- TUC=TU(K)-T00
- IF(K.LT.LC.OR.K.GT.LTOP)TUC=0.
- TDC=TZ(K)-T00
- IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0.
- IF(T0(K).LT.T00)THEN
- ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ))
- ELSE
- ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ))
- ENDIF
- QGS=ES*0.622/(P0(K)-ES)
- RH0=Q0(K)/QES(K)
- RHG=QG(K)/QGS
- WRITE(message,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, &
- TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* &
- 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., &
- QSG(K)*1000.,RH0,RHG
-! call wrf_message(message)
- ENDDO
-!
-!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A
-!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN...
-!
-! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN
-
-! IF(ISHALL.NE.1)THEN
-! write(98,4421)i,j,iyr,imo,idy,ihr,imn
-! write(98)i,j,iyr,imo,idy,ihr,imn,kl
-! 4421 format(7i4)
-! write(98,4422)kl
-! 4422 format(i6)
- DO 310 NK = 1,KL
- k = kl - nk + 1
- write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., &
- u0(k),v0(k),W0AVG1D(K),dp(k),tke(k)
-! write(98) p0,t0,q0,u0,v0,w0,dp,tke
-! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000.,
-! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K)
- 310 CONTINUE
- IF(ISTOP.EQ.1)THEN
-! CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' )
- ENDIF
-! ENDIF
- 4455 format(8f11.3)
- ENDIF
- CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS)
- PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
- RAINCV(I,J)=DT*PRATEC(I,J) ! PPT FB MODS
-! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS
-! RNC=0.1*TIMEC*PPTFLX/DXSQ
- RNC=RAINCV(I,J)*NIC
- IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC
-
-! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF
-!
-! EVALUATE MOISTURE BUDGET...
-!
-
- QINIT=0.
- QFNL=0.
- DPT=0.
- DO 315 NK=1,LTOP
- DPT=DPT+DP(NK)
- QINIT=QINIT+Q0(NK)*EMS(NK)
- QFNL=QFNL+QG(NK)*EMS(NK)
- QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK)
- 315 CONTINUE
- QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS
-! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS
- ERR2=(QFNL-QINIT)*100./QINIT
- IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2
- IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN
-! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!'
-! WRITE(99,1110)QINIT,QFNL,ERR2
- IPRNT=.TRUE.
- ISTOP=1
- write(98,4422)kl
- 4422 format(i6)
- DO 311 NK = 1,KL
- k = kl - nk + 1
-! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., &
-! u0(k),v0(k),W0AVG1D(K),dp(k)
-! write(98) p0,t0,q0,u0,v0,w0,dp,tke
-! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., &
-! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k)
- WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., &
- U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k)
- 311 CONTINUE
-! call flush(98)
-
-! GOTO 297
-! STOP 'QVERR'
- ENDIF
- 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4)
- 4456 format(8f12.3)
- IF(PPTFLX.GT.0.)THEN
- RELERR=ERR2*QINIT/(PPTFLX*TIMEC)
- ELSE
- RELERR=0.
- ENDIF
- IF(IPRNT)THEN
- WRITE(98,1120)RELERR
- WRITE(98,*)'TDER, CPR, TRPPT =', &
- TDER,CPR*AINC,TRPPT*AINC
- ENDIF
-!
-!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES.
-!
-!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM
-!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC...
-!
- IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT)
- NCA(I,J) = REAL(NIC)*DT
- IF(ISHALL.EQ.1)THEN
- TIMEC = 2400.
- NCA(I,J) = CUDT*60.
- NSHALL = NSHALL+1
- ENDIF
-
- DO K=1,KX
-! IF(IMOIST(INEST).NE.2)THEN
-!
-!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT
-!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE.
-!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND
-!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE
-!...OF QG...
-!
-! RLC=XLV0-XLV1*TG(K)
-! RLS=XLS0-XLS1*TG(K)
-! CPM=CP*(1.+0.887*QG(K))
-! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM
-! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K))
-! DQLDT(I,J,NK)=0.
-! DQIDT(I,J,NK)=0.
-! DQRDT(I,J,NK)=0.
-! DQSDT(I,J,NK)=0.
-! ELSE
-!
-!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS...
-!
- IF(.NOT. F_QI .and. warm_rain)THEN
-
- CPM=CP*(1.+0.887*QG(K))
- TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM
- DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC
- DQIDT(K)=0.
- DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC
- DQSDT(K)=0.
- ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN
-!
-!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME
-!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL
-!
- CPM=CP*(1.+0.887*QG(K))
- IF(K.LE.ML)THEN
- TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM
- ELSEIF(K.GT.ML)THEN
- TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM
- ENDIF
- DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC
- DQIDT(K)=0.
- DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC
- DQSDT(K)=0.
- ELSEIF(F_QI) THEN
-!
-!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN
-!...OF HYDROMETEORS DIRECTLY...
-!
- DQCDT(K)=(QLG(K)-QL0(K))/TIMEC
- DQIDT(K)=(QIG(K)-QI0(K))/TIMEC
- DQRDT(K)=(QRG(K)-QR0(K))/TIMEC
- IF (F_QS) THEN
- DQSDT(K)=(QSG(K)-QS0(K))/TIMEC
- ELSE
- DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC
- ENDIF
- ELSE
-! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!'
-! CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' )
- ENDIF
- DTDT(K)=(TG(K)-T0(K))/TIMEC
- DQDT(K)=(QG(K)-Q0(K))/TIMEC
- ENDDO
- PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
- RAINCV(I,J)=DT*PRATEC(I,J)
-! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS
-! RNC=0.1*TIMEC*PPTFLX/DXSQ
- RNC=RAINCV(I,J)*NIC
- 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm')
-! write (98,909)I,J,RNC
-! write (6,909)I,J,RNC
-! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =',
-! * NCCNT
-! call flush(98)
-1000 FORMAT(' ',10A8)
-1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X))
-1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB')
-1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB')
-1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', &
- ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', &
- I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, &
- ' CAPE=',0PF7.1)
-1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', &
- E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', &
- F8.1)
-1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' &
- ,F6.3,'VWS=',F5.2)
-!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, &
-! ', NO MORE MASS FLUX IS ALLOWED!')
-!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED &
-! &DEGREE OF STABILIZATION! FABE= ',F6.4)
- 1070 FORMAT (16A8)
- 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3)
- 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', &
- 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2)
- 1085 FORMAT (A3,16A7,2A8)
- 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3)
- 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0)
-1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',&
- E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%')
-1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, &
- ' TOTAL WATER CHANGE =',F8.2,'%')
-! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4)
-1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%')
-!
-!-----------------------------------------------------------------------
-!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------
-!-----------------------------------------------------------------------
-!
- CUTOP(I,J)=REAL(LTOP)
- CUBOT(I,J)=REAL(LCL)
-!
-!-----------------------------------------------------------------------
- END SUBROUTINE KF_eta_PARA
-!********************************************************************
-! ***********************************************************************
- SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0)
-!
-! Lookup table variables:
-! INTEGER, PARAMETER :: (KFNT=250,KFNP=220)
-! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
-! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
-! REAL, SAVE, DIMENSION(1:200) :: ALU
-! REAL, SAVE :: RDPR,RDTHK,PLUTOP
-! End of Lookup table variables:
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
- REAL, INTENT(IN ) :: P,THES,XLV1,XLV0
- REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC
- REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE
- REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, &
- TEMP,QS,QNEW,DQ,QTOT,RLL,CPP
- INTEGER :: IPTB,ITHTB
-!-----------------------------------------------------------------------
-
-!c******** LOOKUP TABLE VARIABLES... ****************************
-! parameter(kfnt=250,kfnp=220)
-!c
-! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp),
-! * alu(200),rdpr,rdthk,plutop
-!C***************************************************************
-!c
-!c***********************************************************************
-!c scaling pressure and tt table index
-!c***********************************************************************
-!c
- tp=(p-plutop)*rdpr
- qq=tp-aint(tp)
- iptb=int(tp)+1
-
-!
-!***********************************************************************
-! base and scaling factor for the
-!***********************************************************************
-!
-! scaling the and tt table index
- bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb)
- tth=(thes-bth)*rdthk
- pp =tth-aint(tth)
- ithtb=int(tth)+1
- IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN
- write(98,*)'**** OUT OF BOUNDS *********'
-! call flush(98)
- ENDIF
-!
- t00=ttab(ithtb ,iptb )
- t10=ttab(ithtb+1,iptb )
- t01=ttab(ithtb ,iptb+1)
- t11=ttab(ithtb+1,iptb+1)
-!
- q00=qstab(ithtb ,iptb )
- q10=qstab(ithtb+1,iptb )
- q01=qstab(ithtb ,iptb+1)
- q11=qstab(ithtb+1,iptb+1)
-!
-!***********************************************************************
-! parcel temperature
-!***********************************************************************
-!
- temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq)
-!
- qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq)
-!
- DQ=QS-QU
- IF(DQ.LE.0.)THEN
- QNEW=QU-QS
- QU=QS
- ELSE
-!
-! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE
-! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE
-!
- QNEW=0.
- QTOT=QLIQ+QICE
-!
-! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS
-! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING
-! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION
-! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE
-! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE.
-!
-!...subsaturated values only occur in calculations involving various mixtures of
-!...updraft and environmental air for estimation of entrainment and detrainment.
-!...For these purposes, assume that reasonable estimates can be given using
-!...liquid water saturation calculations only - i.e., ignore the effect of the
-!...ice phase in this process only...will not affect conservative properties...
-!
- IF(QTOT.GE.DQ)THEN
- qliq=qliq-dq*qliq/(qtot+1.e-10)
- qice=qice-dq*qice/(qtot+1.e-10)
- QU=QS
- ELSE
- RLL=XLV0-XLV1*TEMP
- CPP=1004.5*(1.+0.89*QU)
- IF(QTOT.LT.1.E-10)THEN
-!
-!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY:
- TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP
- ELSE
-!
-!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION,
-! THE TEMPERATURE IS GIVEN BY:
-!
- TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP
- QU=QU+QTOT
- QTOT=0.
- QLIQ=0.
- QICE=0.
- ENDIF
- ENDIF
- ENDIF
- TU=TEMP
- qnewlq=qnew
- qnewic=0.
-!
- END SUBROUTINE TPMIX2
-!******************************************************************************
- SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ)
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
- REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ
- REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE
- REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII
-!-----------------------------------------------------------------------
-!
-!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN
-!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE
-!...TTFRZ TO TBFRZ...
-!...FOR COLDER TERMPERATURES, FREEZE ALL LIQUID WATER...
-!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER
-!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE...
-!
- RLC=2.5E6-2369.276*(TU-273.16)
- RLS=2833922.-259.532*(TU-273.16)
- RLF=RLS-RLC
- CPP=1004.5*(1.+0.89*QU)
-!
-! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS
-! FOR SATURATION VAPOR PRESSURE...
-!
- A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ))
- DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A)
- TU = TU+DTFRZ
-
- ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ))
- QS = ES*0.622/(P-ES)
-!
-!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE
-!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA-
-!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY,
-!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW
-!...TEMPERATURE TO THE SATURATION VALUE...
-!
- DQEVAP = QS-QU
- QICE = QICE-DQEVAP
- QU = QU+DQEVAP
- PII=(1.E5/P)**(0.2854*(1.-0.28*QU))
- THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU))
-!
- END SUBROUTINE DTFRZNEW
-! --------------------------------------------------------------------------------
-
- SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, &
- QNEWIC,QLQOUT,QICOUT,G)
-
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
-! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US
-! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL-
-! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI-
-! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL
-! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ).
-
- REAL, INTENT(IN ) :: G
- REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE
- REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC
- REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG
-
-!
-! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US
-! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL-
-! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI-
-! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL
-! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ).
- QTOT=QLIQ+QICE
- QNEW=QNEWLQ+QNEWIC
-!
-! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY
-! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL
-! LEVELS...
-!
- QEST=0.5*(QTOT+QNEW)
- G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5
- IF(G1.LT.0.0)G1=0.
- WAVG=0.5*(SQRT(WTW)+SQRT(G1))
- CONV=RATE*DZ/WAVG
-!
-! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS
-! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV
-! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN
-! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS...
-!
- RATIO3=QNEWLQ/(QNEW+1.E-8)
-! OLDQ=QTOT
- QTOT=QTOT+0.6*QNEW
- OLDQ=QTOT
- RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8)
- QTOT=QTOT*EXP(-CONV)
-!
-! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT
-! PARCEL AT THIS LEVEL...
-!
- DQ=OLDQ-QTOT
- QLQOUT=RATIO4*DQ
- QICOUT=(1.-RATIO4)*DQ
-!
-! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL
-! LATE VERTICAL VELOCITY
-!
- PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW)
- WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5
- IF(ABS(WTW).LT.1.E-4)WTW=1.E-4
-!
-! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE
-! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION...
-!
- QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW
- QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW
- QNEWLQ=0.
- QNEWIC=0.
-
- END SUBROUTINE CONDLOAD
-
-! ----------------------------------------------------------------------
- SUBROUTINE PROF5(EQ,EE,UD)
-!
-!***********************************************************************
-!***** GAUSSIAN TYPE MIXING PROFILE....******************************
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN
-! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM
-! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES"
-! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED
-! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968.
-! JACK KAIN
-! 7/6/89
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
- REAL, INTENT(IN ) :: EQ
- REAL, INTENT(INOUT) :: EE,UD
- REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2
-
- DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, &
- 0.9372980,0.33267,0.166666667,0.202765151/
- X=(EQ-0.5)/SIGMA
- Y=6.*EQ-3.
- EY=EXP(Y*Y/(-2))
- E45=EXP(-4.5)
- T2=1./(1.+P*ABS(Y))
- T1=0.500498
- C1=A1*T1+A2*T1*T1+A3*T1*T1*T1
- C2=A1*T2+A2*T2*T2+A3*T2*T2*T2
- IF(Y.GE.0.)THEN
- EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2.
- UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- &
- EQ)
- ELSE
- EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2.
- UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* &
- EQ/2.-EQ)
- ENDIF
- EE=EE/FE
- UD=UD/FE
-
- END SUBROUTINE PROF5
-
-! ------------------------------------------------------------------------
- SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j)
-!
-! Lookup table variables:
-! INTEGER, PARAMETER :: (KFNT=250,KFNP=220)
-! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
-! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
-! REAL, SAVE, DIMENSION(1:200) :: ALU
-! REAL, SAVE :: RDPR,RDTHK,PLUTOP
-! End of Lookup table variables:
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
- REAL, INTENT(IN ) :: P,THES
- REAL, INTENT(INOUT) :: TS,QS
- INTEGER, INTENT(IN ) :: i,j ! avail for debugging
- REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11
- INTEGER :: IPTB,ITHTB
- CHARACTER*256 :: MESS
-!-----------------------------------------------------------------------
-
-!
-!******** LOOKUP TABLE VARIABLES (F77 format)... ****************************
-! parameter(kfnt=250,kfnp=220)
-!
-! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), &
-! alu(200),rdpr,rdthk,plutop
-!***************************************************************
-!
-!***********************************************************************
-! scaling pressure and tt table index
-!***********************************************************************
-!
- tp=(p-plutop)*rdpr
- qq=tp-aint(tp)
- iptb=int(tp)+1
-!
-!***********************************************************************
-! base and scaling factor for the
-!***********************************************************************
-!
-! scaling the and tt table index
- bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb)
- tth=(thes-bth)*rdthk
- pp =tth-aint(tth)
- ithtb=int(tth)+1
-!
- t00=ttab(ithtb ,iptb )
- t10=ttab(ithtb+1,iptb )
- t01=ttab(ithtb ,iptb+1)
- t11=ttab(ithtb+1,iptb+1)
-!
- q00=qstab(ithtb ,iptb )
- q10=qstab(ithtb+1,iptb )
- q01=qstab(ithtb ,iptb+1)
- q11=qstab(ithtb+1,iptb+1)
-!
-!***********************************************************************
-! parcel temperature and saturation mixing ratio
-!***********************************************************************
-!
- ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq)
-!
- qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq)
-!
- END SUBROUTINE TPMIX2DD
-
-! -----------------------------------------------------------------------
- SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ)
-!
-!-----------------------------------------------------------------------
- IMPLICIT NONE
-!-----------------------------------------------------------------------
- REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ
- REAL, INTENT(INOUT) :: THT1
- REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, &
- T00,P00,C1,C2,C3,C4,C5
- INTEGER :: INDLU
-!-----------------------------------------------------------------------
- DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, &
- 0.278296,1.0723E-3/
-!
-! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE...
-!
-! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00
-!
- EE=Q1*P1/(0.622+Q1)
-! TLOG=ALOG(EE/ALIQ)
-! ...calculate LOG term using lookup table...
-!
- astrt=1.e-3
- ainc=0.075
- a1=ee/aliq
- tp=(a1-astrt)/ainc
- indlu=int(tp)+1
- value=(indlu-1)*ainc+astrt
- aintrp=(a1-value)/ainc
- tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu)
-!
- TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)
- TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT)
- THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1))
- THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1))
-!
- END SUBROUTINE ENVIRTHT
-! ***********************************************************************
-!====================================================================
- SUBROUTINE kf_eta_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, &
- RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, &
- SVP1,SVP2,SVP3,SVPT0, &
- P_FIRST_SCALAR,restart,allowed_to_read, &
- ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte )
-!--------------------------------------------------------------------
- IMPLICIT NONE
-!--------------------------------------------------------------------
- LOGICAL , INTENT(IN) :: restart,allowed_to_read
- INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
- ims, ime, jms, jme, kms, kme, &
- its, ite, jts, jte, kts, kte
- INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR
-
- REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
- RTHCUTEN, &
- RQVCUTEN, &
- RQCCUTEN, &
- RQRCUTEN, &
- RQICUTEN, &
- RQSCUTEN
-
- REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG
-
- REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA
-
- INTEGER :: i, j, k, itf, jtf, ktf
- REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0
-
- jtf=min0(jte,jde-1)
- ktf=min0(kte,kde-1)
- itf=min0(ite,ide-1)
-
- IF(.not.restart)THEN
-
- DO j=jts,jtf
- DO k=kts,ktf
- DO i=its,itf
- RTHCUTEN(i,k,j)=0.
- RQVCUTEN(i,k,j)=0.
- RQCCUTEN(i,k,j)=0.
- RQRCUTEN(i,k,j)=0.
- ENDDO
- ENDDO
- ENDDO
-
- IF (P_QI .ge. P_FIRST_SCALAR) THEN
- DO j=jts,jtf
- DO k=kts,ktf
- DO i=its,itf
- RQICUTEN(i,k,j)=0.
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- IF (P_QS .ge. P_FIRST_SCALAR) THEN
- DO j=jts,jtf
- DO k=kts,ktf
- DO i=its,itf
- RQSCUTEN(i,k,j)=0.
- ENDDO
- ENDDO
- ENDDO
- ENDIF
-
- DO j=jts,jtf
- DO i=its,itf
- NCA(i,j)=-100.
- ENDDO
- ENDDO
-
- DO j=jts,jtf
- DO k=kts,ktf
- DO i=its,itf
- W0AVG(i,k,j)=0.
- ENDDO
- ENDDO
- ENDDO
-
- endif
-
- CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0)
-
- END SUBROUTINE kf_eta_init
-
-!-------------------------------------------------------
-
- subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0)
-!
-! This subroutine is a lookup table.
-! Given a series of series of saturation equivalent potential
-! temperatures, the temperature is calculated.
-!
-!--------------------------------------------------------------------
- IMPLICIT NONE
-!--------------------------------------------------------------------
-! Lookup table variables
-! INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220
-! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB
-! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K
-! REAL, SAVE, DIMENSION(1:200) :: ALU
-! REAL, SAVE :: RDPR,RDTHK,PLUTOP
-! End of Lookup table variables
-
- INTEGER :: KP,IT,ITCNT,I
- REAL :: DTH,TMIN,TOLER,PBOT,DPR, &
- TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, &
- ASTRT,AINC,A1,THTGS
-! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0
- REAL :: ALIQ,BLIQ,CLIQ,DLIQ
- REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0
-!
-! equivalent potential temperature increment
- data dth/1./
-! minimum starting temp
- data tmin/150./
-! tolerance for accuracy of temperature
- data toler/0.001/
-! top pressure (pascals)
- plutop=5000.0
-! bottom pressure (pascals)
- pbot=110000.0
-
- ALIQ = SVP1*1000.
- BLIQ = SVP2
- CLIQ = SVP2*SVPT0
- DLIQ = SVP3
-
-!
-! compute parameters
-!
-! 1._over_(sat. equiv. theta increment)
- rdthk=1./dth
-! pressure increment
-!
- DPR=(PBOT-PLUTOP)/REAL(KFNP-1)
-! dpr=(pbot-plutop)/REAL(kfnp-1)
-! 1._over_(pressure increment)
- rdpr=1./dpr
-! compute the spread of thes
-! thespd=dth*(kfnt-1)
-!
-! calculate the starting sat. equiv. theta
-!
- temp=tmin
- p=plutop-dpr
- do kp=1,kfnp
- p=p+dpr
- es=aliq*exp((bliq*temp-cliq)/(temp-dliq))
- qs=0.622*es/(p-es)
- pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
- the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* &
- (1.+0.81*qs))
- enddo
-!
-! compute temperatures for each sat. equiv. potential temp.
-!
- p=plutop-dpr
- do kp=1,kfnp
- thes=the0k(kp)-dth
- p=p+dpr
- do it=1,kfnt
-! define sat. equiv. pot. temp.
- thes=thes+dth
-! iterate to find temperature
-! find initial guess
- if(it.eq.1) then
- tgues=tmin
- else
- tgues=ttab(it-1,kp)
- endif
- es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq))
- qs=0.622*es/(p-es)
- pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
- thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* &
- (1.+0.81*qs))
- f0=thgues-thes
- t1=tgues-0.5*f0
- t0=tgues
- itcnt=0
-! iteration loop
- do itcnt=1,11
- es=aliq*exp((bliq*t1-cliq)/(t1-dliq))
- qs=0.622*es/(p-es)
- pi=(1.e5/p)**(0.2854*(1.-0.28*qs))
- thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs))
- f1=thtgs-thes
- if(abs(f1).lt.toler)then
- exit
- endif
-! itcnt=itcnt+1
- dt=f1*(t1-t0)/(f1-f0)
- t0=t1
- f0=f1
- t1=t1-dt
- enddo
- ttab(it,kp)=t1
- qstab(it,kp)=qs
- enddo
- enddo
-!
-! lookup table for tlog(emix/aliq)
-!
-! set up intial values for lookup tables
-!
- astrt=1.e-3
- ainc=0.075
-!
- a1=astrt-ainc
- do i=1,200
- a1=a1+ainc
- alu(i)=alog(a1)
- enddo
-!
- END SUBROUTINE KF_LUTAB
-
-END MODULE module_cu_kfeta
Deleted: branches/atmos_physics/src/core_hyd_phys/module_microphysics_driver.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_microphysics_driver.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_microphysics_driver.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,236 +0,0 @@
-!==============================================================================
- MODULE module_microphysics_driver
- USE grid_types
- USE constants, g => gravity
-
- USE module_mp_thompson
- USE module_physics_vars
-
- IMPLICIT NONE
- PRIVATE
- PUBLIC:: microphysics_driver
-
- REAL(KIND=RKIND),PARAMETER,PRIVATE:: p0 = 100000.
-
- CONTAINS
-
-!==============================================================================
- SUBROUTINE microphysics_driver(tend,vars,grid,itimestep,config_ntimesteps)
-!==============================================================================
-
-!INPUT ARGUMENTS:
-!----------------
- TYPE(grid_meta),INTENT(in) :: grid
- INTEGER,INTENT(in):: itimestep,config_ntimesteps
-
-!INOUT ARGUMENTS:
-!----------------
- TYPE(grid_state),INTENT(inout):: tend,vars
-
-!LOCAL VARIABLES AND ARRAYS:
-!---------------------------
- LOGICAL:: log_microphysics
- INTEGER:: nCells,nCellsSolve,nLevels
- INTEGER:: itf,jtf,ktf
- INTEGER:: i,iCell,icount,istep,j,k,kk
-
-!==============================================================================
- write(6,*)
- write(6,*) '--- enter subroutine MICROPHYSICS_DRIVER: itimestep=', itimestep
- write(6,*) ' dt_microp=',dt_microp
-
- nCells = grid%nCells
- nCellsSolve = grid%nCellsSolve
- nLevels = grid%nVertLevels
-
-!write(6,*) '--- nCells =', nCells
-!write(6,*) '--- nCellsSolve =', nCellsSolve
-!write(6,*) '--- nLevels =', nLevels
-
-!write(6,*) '--- num_scalars =', num_scalars
-!write(6,*) '--- moist_start =', moist_start
-!write(6,*) '--- moist_end =', moist_end
-!write(6,*) '--- number_start =', number_start
-!write(6,*) '--- number_end =', number_end
-!write(6,*)
-
-!INITIALIZATION:
- itf = ite
- jtf = jte
- ktf = kte-1
-
- write(6,*) ' IMS= ',ims,' IME=',ime
- write(6,*) ' JMS= ',jms,' JME=',jme
- write(6,*) ' KMS= ',kms,' KME=',kme
- write(6,*)
- write(6,*) ' IDS= ',ids,' IDE=',ide
- write(6,*) ' JDS= ',jds,' JDE=',jde
- write(6,*) ' KDS= ',kds,' KDE=',kde
- write(6,*)
- write(6,*) ' ITS= ',its,' ITE=',ite
- write(6,*) ' JTS= ',jts,' JTE=',jte
- write(6,*) ' KTS= ',kts,' KTE=',kte
- write(6,*)
-
-!SAVES THE INITIAL POTENTIAL TEMPERATURE FOR CALCULATION OF THE POTENTIAL
-!TEMPERATURE TENDENCY NEEDED IN THE DYNMICAL CORE:
- DO k = 1, nLevels
- DO iCell = 1, nCellsSolve
- vars%h_diabatic%array(k,i) = vars%theta%array(k,i)
- ENDDO
- ENDDO
-
-!INITIALIZATION OF TIME-STEP PRECIPITATION VARIABLES ON THE GEODESIC GRID:
- DO iCell = 1, nCellsSolve
- vars%rainncv%array(iCell) = 0.
- vars%snowncv%array(iCell) = 0.
- vars%graupelncv%array(iCell) = 0.
- vars%sr%array(iCell) = 0.
- ENDDO
-
-!COPY PHYSICS VARIABLES FROM THE GEODESIC GRID TO THE "WRF" GRID:
- DO j = jts, jtf
- DO i = its, itf
- rainnc_phy(i,j) = vars%rainnc%array(i)
- snownc_phy(i,j) = vars%snownc%array(i)
- graupelnc_phy(i,j) = vars%graupelnc%array(i)
- IF(vars%rainnc%array(i) .GT. 0.) &
- write(6,204) itimestep,j,i,vars%rainncv%array(i),vars%rainnc%array(i)
- ENDDO
- ENDDO
-
- DO j = jts, jtf
- DO k = kts, ktf
- DO i = its, itf
- dz_phy(i,k,j) = (vars%geopotential%array(k+1,i) &
- - vars%geopotential%array(k,i)) / g
- p_phy(i,k,j) = (vars%pressure%array(k+1,i) &
- + vars%pressure%array(k,i)) / 2
- th_phy(i,k,j) = vars%theta%array(k,i)
-
- pi_phy(i,k,j) = (p_phy(i,k,j)/p0)**(rgas/cp)
-
- qv_phy(i,k,j) = vars%scalars%array(index_qv,k,i)
- qc_phy(i,k,j) = vars%scalars%array(index_qc,k,i)
- qr_phy(i,k,j) = vars%scalars%array(index_qr,k,i)
- qi_phy(i,k,j) = vars%scalars%array(index_qi,k,i)
- qs_phy(i,k,j) = vars%scalars%array(index_qs,k,i)
- qg_phy(i,k,j) = vars%scalars%array(index_qr,k,i)
-
- qnr_phy(i,k,j) = vars%scalars%array(index_qnr,k,i)
- qni_phy(i,k,j) = vars%scalars%array(index_qni,k,i)
- ENDDO
- ENDDO
- ENDDO
-
-!CALL TO THOMPSON CLOUD MICROPHYSICS:
- istep = 1
- DO WHILE (istep .LE. n_microp)
- write(6,*) '--- istep=',istep
- CALL mp_gt_driver(qv_phy ,qc_phy,qr_phy,qi_phy,qs_phy,qg_phy,qni_phy, &
- qnr_phy,th_phy,pi_phy,p_phy ,dz_phy,dt_microp,itimestep,&
- rainnc_phy,rainncv_phy,snownc_phy,snowncv_phy, &
- graupelnc_phy,graupelncv_phy,sr_phy, &
-! refl_10cm,grid_clock,grid_alarms, &
- ids,ide,jds,jde,kds,kde, & ! domain dimensions
- ims,ime,jms,jme,kms,kme, & ! memory dimensions
- its,itf,jts,jtf,kts,ktf) ! tile dimensions
- istep = istep + 1
- ENDDO
-
- write(6,*) '--- end subroutine MP_GT_DRIVER:'
-!DO j = jts, jtf
-!DO i = its, itf
-! log_microphysics = .false.
-! IF(rainncv_phy(i,j) .GT. 0.) THEN
-! write(6,203) itimestep,j,i,rainnc_phy(i,j),rainncv_phy(i,j)
-! log_microphysics = .true.
-! IF(log_microphysics) THEN
-! DO k = kts,ktf
-! write(6,201) j,i,k,qv_phy(i,k,j),qc_phy(i,k,j),qr_phy(i,k,j), &
-! qi_phy(i,k,j),qs_phy(i,k,j),qg_phy(i,k,j)
-! ENDDO
-! ENDIF
-! ENDIF
-!ENDDO
-!ENDDO
-
-!BACK TO DYNAMICAL CORE:
- DO j = jts, jtf
- DO k = kts, ktf
- DO i = its, itf
- vars%theta%array(k,i) = th_phy(i,k,j)
- vars%scalars%array(index_qv,k,i) = qv_phy(i,k,j)
- vars%scalars%array(index_qc,k,i) = qc_phy(i,k,j)
- vars%scalars%array(index_qr,k,i) = qr_phy(i,k,j)
- vars%scalars%array(index_qi,k,i) = qi_phy(i,k,j)
- vars%scalars%array(index_qs,k,i) = qs_phy(i,k,j)
- vars%scalars%array(index_qr,k,i) = qg_phy(i,k,j)
- vars%scalars%array(index_qnr,k,i) = qnr_phy(i,k,j)
- vars%scalars%array(index_qni,k,i) = qni_phy(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-
-!CALCULATES THE POTENTIAL TEMPERATURE TENDENCY:
- DO k = 1, nLevels
- DO iCell = 1, nCellsSolve
- vars%h_diabatic%array(k,i) = &
- (vars%theta%array(k,i) - vars%h_diabatic%array(k,i)) / dt_dyn
- ENDDO
- ENDDO
-
-!DIAGNOSTICS FOR PRECIPITATION:
- DO j = jts,jtf
- DO i = its,itf
-
- !Time-step precipitation:
- vars%rainncv%array(i) = rainncv_phy(i,j)
- vars%snowncv%array(i) = snowncv_phy(i,j)
- vars%graupelncv%array(i) = graupelncv_phy(i,j)
- vars%sr%array(i) = sr_phy(i,j)
-
- !Accumulated precipitation:
- vars%rainnc%array(i) = rainnc_phy(i,j)
- vars%snownc%array(i) = snownc_phy(i,j)
- vars%graupelnc%array(i) = graupelnc_phy(i,j)
-
-! IF(vars%rainncv%array(i) .GT. 0.) &
-! write(6,204) itimestep,j,i,vars%rainncv%array(i),rainncv_phy(i,j)
- ENDDO
- ENDDO
-
- IF(itimestep == config_ntimesteps) THEN
- write(6,*) 'itimestep=', itimestep
- write(6,*) 'config_ntimesteps=', config_ntimesteps
- DO iCell = 1, nCellsSolve
- IF(vars%rainncv%array(iCell) .GT. 0.) THEN
- write(6,204) config_ntimesteps,itimestep,iCell, &
- vars%rainncv%array(iCell) ,vars%rainnc%array(iCell), &
- vars%snowncv%array(iCell) ,vars%snownc%array(iCell), &
- vars%graupelncv%array(iCell),vars%graupelnc%array(iCell)
- DO k = 1, nLevels
- write(6,201) itimestep,iCell,k,vars%theta%array(k,iCell), &
- vars%scalars%array(index_qv,k,iCell), &
- vars%scalars%array(index_qc,k,iCell), &
- vars%scalars%array(index_qr,k,iCell), &
- vars%scalars%array(index_qi,k,iCell), &
- vars%scalars%array(index_qs,k,iCell), &
- vars%scalars%array(index_qg,k,iCell)
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-
- write(6,*) '--- end SUBROUTINE MICROPHYSICS_DRIVER:'
-
-!FORMATS:
- 201 FORMAT(i3,1x,i6,1x,i3,10(1x,e15.8))
- 203 FORMAT('MICROPHYSICS BEGINS:',3i6,2(1x,f6.1))
- 204 FORMAT('MICROPHYSICS PRECIP:',3i6,8(1x,e15.8))
-
- END SUBROUTINE microphysics_driver
-
-!==============================================================================
- END MODULE module_microphysics_driver
-!==============================================================================
Deleted: branches/atmos_physics/src/core_hyd_phys/module_mp_thompson.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_mp_thompson.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_mp_thompson.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,3653 +0,0 @@
-!+---+-----------------------------------------------------------------+
-!.. This subroutine computes the moisture tendencies of water vapor,
-!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel.
-!.. Prior to WRFv2.2 this code was based on Reisner et al (1998), but
-!.. few of those pieces remain. A complete description is now found in
-!.. Thompson, G., P. R. Field, R. M. Rasmussen, and W. D. Hall, 2008:
-!.. Explicit Forecasts of winter precipitation using an improved bulk
-!.. microphysics scheme. Part II: Implementation of a new snow
-!.. parameterization. Mon. Wea. Rev., 136, 5095-5115.
-!.. Prior to WRFv3.1, this code was single-moment rain prediction as
-!.. described in the reference above, but in v3.1 and higher, the
-!.. scheme is two-moment rain (predicted rain number concentration).
-!..
-!.. Most importantly, users may wish to modify the prescribed number of
-!.. cloud droplets (Nt_c; see guidelines mentioned below). Otherwise,
-!.. users may alter the rain and graupel size distribution parameters
-!.. to use exponential (Marshal-Palmer) or generalized gamma shape.
-!.. The snow field assumes a combination of two gamma functions (from
-!.. Field et al. 2005) and would require significant modifications
-!.. throughout the entire code to alter its shape as well as accretion
-!.. rates. Users may also alter the constants used for density of rain,
-!.. graupel, ice, and snow, but the latter is not constant when using
-!.. Paul Field's snow distribution and moments methods. Other values
-!.. users can modify include the constants for mass and/or velocity
-!.. power law relations and assumed capacitances used in deposition/
-!.. sublimation/evaporation/melting.
-!.. Remaining values should probably be left alone.
-!..
-!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
-!..Last modified: 09 Nov 2009
-!+---+-----------------------------------------------------------------+
-!wrft:model_layer:physics
-!+---+-----------------------------------------------------------------+
-!
- MODULE module_mp_thompson
-! USE module_wrf_error
-! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm
-! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep
-
- IMPLICIT NONE
-
-!LDF begin (05-13-2010): Added the capabilities to read pre-calculated
-!look-up tables to speed up initialization.
- LOGICAL, PRIVATE:: iiwarm
- LOGICAL, PRIVATE:: l_qr_acr_qg
- LOGICAL, PRIVATE:: l_qr_acr_qs
- LOGICAL, PRIVATE:: l_qi_aut_qs
- LOGICAL, PRIVATE:: l_freezeH2O
-!LDF end.
-! LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false.
- INTEGER, PARAMETER, PRIVATE:: IFDRY = 0
- REAL, PARAMETER, PRIVATE:: T_0 = 273.15
- REAL, PARAMETER, PRIVATE:: PI = 3.1415926536
-
-!..Densities of rain, snow, graupel, and cloud ice.
- REAL, PARAMETER, PRIVATE:: rho_w = 1000.0
- REAL, PARAMETER, PRIVATE:: rho_s = 100.0
- REAL, PARAMETER, PRIVATE:: rho_g = 400.0
- REAL, PARAMETER, PRIVATE:: rho_i = 890.0
-
-!..Prescribed number of cloud droplets. Set according to known data or
-!.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and
-!.. 300 per cc (300.E6 m^-3) for Continental. Gamma shape parameter,
-!.. mu_c, calculated based on Nt_c is important in autoconversion
-!.. scheme.
- REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6
-
-!..Generalized gamma distributions for rain, graupel and cloud ice.
-!.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential.
- REAL, PARAMETER, PRIVATE:: mu_r = 0.0
- REAL, PARAMETER, PRIVATE:: mu_g = 0.0
- REAL, PARAMETER, PRIVATE:: mu_i = 0.0
- REAL, PRIVATE:: mu_c
-
-!..Sum of two gamma distrib for snow (Field et al. 2005).
-!.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3)
-!.. + Kap1*(M2/M3)**mu_s * D**mu_s * exp(-M2*Lam1*D/M3)]
-!.. M2 and M3 are the (bm_s)th and (bm_s+1)th moments respectively
-!.. calculated as function of ice water content and temperature.
- REAL, PARAMETER, PRIVATE:: mu_s = 0.6357
- REAL, PARAMETER, PRIVATE:: Kap0 = 490.6
- REAL, PARAMETER, PRIVATE:: Kap1 = 17.46
- REAL, PARAMETER, PRIVATE:: Lam0 = 20.78
- REAL, PARAMETER, PRIVATE:: Lam1 = 3.29
-
-!..Y-intercept parameter for graupel is not constant and depends on
-!.. mixing ratio. Also, when mu_g is non-zero, these become equiv
-!.. y-intercept for an exponential distrib and proper values are
-!.. computed based on same mixing ratio and total number concentration.
- REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4
- REAL, PARAMETER, PRIVATE:: gonv_max = 3.E6
-
-!..Mass power law relations: mass = am*D**bm
-!.. Snow from Field et al. (2005), others assume spherical form.
- REAL, PARAMETER, PRIVATE:: am_r = PI*rho_w/6.0
- REAL, PARAMETER, PRIVATE:: bm_r = 3.0
- REAL, PARAMETER, PRIVATE:: am_s = 0.069
- REAL, PARAMETER, PRIVATE:: bm_s = 2.0
- REAL, PARAMETER, PRIVATE:: am_g = PI*rho_g/6.0
- REAL, PARAMETER, PRIVATE:: bm_g = 3.0
- REAL, PARAMETER, PRIVATE:: am_i = PI*rho_i/6.0
- REAL, PARAMETER, PRIVATE:: bm_i = 3.0
-
-!..Fallspeed power laws relations: v = (av*D**bv)*exp(-fv*D)
-!.. Rain from Ferrier (1994), ice, snow, and graupel from
-!.. Thompson et al (2008). Coefficient fv is zero for graupel/ice.
- REAL, PARAMETER, PRIVATE:: av_r = 4854.0
- REAL, PARAMETER, PRIVATE:: bv_r = 1.0
- REAL, PARAMETER, PRIVATE:: fv_r = 195.0
- REAL, PARAMETER, PRIVATE:: av_s = 40.0
- REAL, PARAMETER, PRIVATE:: bv_s = 0.55
- REAL, PARAMETER, PRIVATE:: fv_s = 125.0
- REAL, PARAMETER, PRIVATE:: av_g = 442.0
- REAL, PARAMETER, PRIVATE:: bv_g = 0.89
- REAL, PARAMETER, PRIVATE:: av_i = 1847.5
- REAL, PARAMETER, PRIVATE:: bv_i = 1.0
-
-!..Capacitance of sphere and plates/aggregates: D**3, D**2
- REAL, PARAMETER, PRIVATE:: C_cube = 0.5
- REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3
-
-!..Collection efficiencies. Rain/snow/graupel collection of cloud
-!.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and
-!.. get computed elsewhere because they are dependent on stokes
-!.. number.
- REAL, PARAMETER, PRIVATE:: Ef_si = 0.05
- REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95
- REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75
- REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95
-
-!..Minimum microphys values
-!.. R1 value, 1.E-12, cannot be set lower because of numerical
-!.. problems with Paul Field's moments and should not be set larger
-!.. because of truncation problems in snow/ice growth.
- REAL, PARAMETER, PRIVATE:: R1 = 1.E-12
- REAL, PARAMETER, PRIVATE:: R2 = 1.E-8
- REAL, PARAMETER, PRIVATE:: eps = 1.E-29
-
-!..Constants in Cooper curve relation for cloud ice number.
- REAL, PARAMETER, PRIVATE:: TNO = 5.0
- REAL, PARAMETER, PRIVATE:: ATO = 0.304
-
-!..Rho_not used in fallspeed relations (rho_not/rho)**.5 adjustment.
- REAL, PARAMETER, PRIVATE:: rho_not = 101325.0/(287.05*298.0)
-
-!..Schmidt number
- REAL, PARAMETER, PRIVATE:: Sc = 0.632
- REAL, PRIVATE:: Sc3
-
-!..Homogeneous freezing temperature
- REAL, PARAMETER, PRIVATE:: HGFR = 235.16
-
-!..Water vapor and air gas constants at constant pressure
- REAL, PARAMETER, PRIVATE:: Rv = 461.5
- REAL, PARAMETER, PRIVATE:: oRv = 1./Rv
- REAL, PARAMETER, PRIVATE:: R = 287.04
- REAL, PARAMETER, PRIVATE:: Cp = 1004.0
-
-!..Enthalpy of sublimation, vaporization, and fusion at 0C.
- REAL, PARAMETER, PRIVATE:: lsub = 2.834E6
- REAL, PARAMETER, PRIVATE:: lvap0 = 2.5E6
- REAL, PARAMETER, PRIVATE:: lfus = lsub - lvap0
- REAL, PARAMETER, PRIVATE:: olfus = 1./lfus
-
-!..Ice initiates with this mass (kg), corresponding diameter calc.
-!..Min diameters and mass of cloud, rain, snow, and graupel (m, kg).
- REAL, PARAMETER, PRIVATE:: xm0i = 1.E-12
- REAL, PARAMETER, PRIVATE:: D0c = 1.E-6
- REAL, PARAMETER, PRIVATE:: D0r = 50.E-6
- REAL, PARAMETER, PRIVATE:: D0s = 200.E-6
- REAL, PARAMETER, PRIVATE:: D0g = 250.E-6
- REAL, PRIVATE:: D0i, xm0s, xm0g
-
-!..Lookup table dimensions
- INTEGER, PARAMETER, PRIVATE:: nbins = 100
- INTEGER, PARAMETER, PRIVATE:: nbc = nbins
- INTEGER, PARAMETER, PRIVATE:: nbi = nbins
- INTEGER, PARAMETER, PRIVATE:: nbr = nbins
- INTEGER, PARAMETER, PRIVATE:: nbs = nbins
- INTEGER, PARAMETER, PRIVATE:: nbg = nbins
- INTEGER, PARAMETER, PRIVATE:: ntb_c = 37
- INTEGER, PARAMETER, PRIVATE:: ntb_i = 64
- INTEGER, PARAMETER, PRIVATE:: ntb_r = 37
- INTEGER, PARAMETER, PRIVATE:: ntb_s = 28
- INTEGER, PARAMETER, PRIVATE:: ntb_g = 28
- INTEGER, PARAMETER, PRIVATE:: ntb_g1 = 28
- INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37
- INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55
- INTEGER, PARAMETER, PRIVATE:: ntb_t = 9
- INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3
-
- DOUBLE PRECISION, DIMENSION(nbins+1):: xDx
- DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc
- DOUBLE PRECISION, DIMENSION(nbi):: Di, dti
- DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr
- DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts
- DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg
-
-!..Lookup tables for cloud water content (kg/m**3).
- REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: &
- r_c = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
- 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
- 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
- 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
- 1.e-2/)
-
-!..Lookup tables for cloud ice content (kg/m**3).
- REAL, DIMENSION(ntb_i), PARAMETER, PRIVATE:: &
- r_i = (/1.e-10,2.e-10,3.e-10,4.e-10, &
- 5.e-10,6.e-10,7.e-10,8.e-10,9.e-10, &
- 1.e-9,2.e-9,3.e-9,4.e-9,5.e-9,6.e-9,7.e-9,8.e-9,9.e-9, &
- 1.e-8,2.e-8,3.e-8,4.e-8,5.e-8,6.e-8,7.e-8,8.e-8,9.e-8, &
- 1.e-7,2.e-7,3.e-7,4.e-7,5.e-7,6.e-7,7.e-7,8.e-7,9.e-7, &
- 1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
- 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
- 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
- 1.e-3/)
-
-!..Lookup tables for rain content (kg/m**3).
- REAL, DIMENSION(ntb_r), PARAMETER, PRIVATE:: &
- r_r = (/1.e-6,2.e-6,3.e-6,4.e-6,5.e-6,6.e-6,7.e-6,8.e-6,9.e-6, &
- 1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
- 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
- 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
- 1.e-2/)
-
-!..Lookup tables for graupel content (kg/m**3).
- REAL, DIMENSION(ntb_g), PARAMETER, PRIVATE:: &
- r_g = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
- 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
- 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
- 1.e-2/)
-
-!..Lookup tables for snow content (kg/m**3).
- REAL, DIMENSION(ntb_s), PARAMETER, PRIVATE:: &
- r_s = (/1.e-5,2.e-5,3.e-5,4.e-5,5.e-5,6.e-5,7.e-5,8.e-5,9.e-5, &
- 1.e-4,2.e-4,3.e-4,4.e-4,5.e-4,6.e-4,7.e-4,8.e-4,9.e-4, &
- 1.e-3,2.e-3,3.e-3,4.e-3,5.e-3,6.e-3,7.e-3,8.e-3,9.e-3, &
- 1.e-2/)
-
-!..Lookup tables for rain y-intercept parameter (/m**4).
- REAL, DIMENSION(ntb_r1), PARAMETER, PRIVATE:: &
- N0r_exp = (/1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, &
- 1.e7,2.e7,3.e7,4.e7,5.e7,6.e7,7.e7,8.e7,9.e7, &
- 1.e8,2.e8,3.e8,4.e8,5.e8,6.e8,7.e8,8.e8,9.e8, &
- 1.e9,2.e9,3.e9,4.e9,5.e9,6.e9,7.e9,8.e9,9.e9, &
- 1.e10/)
-
-!..Lookup tables for graupel y-intercept parameter (/m**4).
- REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: &
- N0g_exp = (/1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
- 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
- 1.e6,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, &
- 1.e7/)
-
-!..Lookup tables for ice number concentration (/m**3).
- REAL, DIMENSION(ntb_i1), PARAMETER, PRIVATE:: &
- Nt_i = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, &
- 1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, &
- 1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, &
- 1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, &
- 1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
- 1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
- 1.e6/)
-
-!..For snow moments conversions (from Field et al. 2005)
- REAL, DIMENSION(10), PARAMETER, PRIVATE:: &
- sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, &
- 0.31255, 0.000204, 0.003199, 0.0, -0.015952/)
- REAL, DIMENSION(10), PARAMETER, PRIVATE:: &
- sb = (/ 0.476221, -0.015896, 0.165977, 0.007468, -0.000141, &
- 0.060366, 0.000079, 0.000594, 0.0, -0.003577/)
-
-!..Temperatures (5 C interval 0 to -40) used in lookup tables.
- REAL, DIMENSION(ntb_t), PARAMETER, PRIVATE:: &
- Tc = (/-0.01, -5., -10., -15., -20., -25., -30., -35., -40./)
-
-!..Lookup tables for various accretion/collection terms.
-!.. ntb_x refers to the number of elements for rain, snow, graupel,
-!.. and temperature array indices. Variables beginning with t-p/c/m/n
-!.. represent lookup tables. Save compile-time memory by making
-!.. allocatable (2009Jun12, J. Michalakes).
- INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: &
- tcg_racg, tmr_racg, tcr_gacr, tmg_gacr, &
- tnr_racg, tnr_gacr
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:):: &
- tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2, &
- tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2, &
- tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: &
- tpi_qcfz, tni_qcfz
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: &
- tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: &
- tps_iaus, tni_iaus, tpi_ide
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw
- REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev
-
-!..Variables holding a bunch of exponents and gamma values (cloud water,
-!.. cloud ice, rain, snow, then graupel).
- REAL, DIMENSION(3), PRIVATE:: cce, ccg
- REAL, PRIVATE:: ocg1, ocg2
- REAL, DIMENSION(6), PRIVATE:: cie, cig
- REAL, PRIVATE:: oig1, oig2, obmi
- REAL, DIMENSION(13), PRIVATE:: cre, crg
- REAL, PRIVATE:: ore1, org1, org2, org3, obmr
- REAL, DIMENSION(18), PRIVATE:: cse, csg
- REAL, PRIVATE:: oams, obms, ocms
- REAL, DIMENSION(12), PRIVATE:: cge, cgg
- REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg
-
-!..Declaration of precomputed constants in various rate eqns.
- REAL:: t1_qr_qc, t1_qr_qi, t2_qr_qi, t1_qg_qc, t1_qs_qc, t1_qs_qi
- REAL:: t1_qr_ev, t2_qr_ev
- REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd
- REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me
-
- CHARACTER*256:: mp_debug
-
-!+---+
-!+---+-----------------------------------------------------------------+
-!..END DECLARATIONS
-!+---+-----------------------------------------------------------------+
-!+---+
-!ctrlL
-
- CONTAINS
-
- SUBROUTINE thompson_init
-
- IMPLICIT NONE
-
- INTEGER:: i, j, k, m, n
- LOGICAL:: micro_init
-
-!..Allocate space for lookup tables (J. Michalakes 2009Jun08).
- micro_init = .FALSE.
-
- if (.NOT. ALLOCATED(tcg_racg) ) then
- ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
- micro_init = .TRUE.
- endif
-
- if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
-
- if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
- if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
-
- if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45))
- if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45))
-
- if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45))
- if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45))
- if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45))
- if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45))
-
- if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1))
- if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1))
- if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1))
-
- if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc))
- if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc))
-
- if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r))
-
- if (micro_init) then
-
-!..From Martin et al. (1994), assign gamma shape parameter mu for cloud
-!.. drops according to general dispersion characteristics (disp=~0.25
-!.. for Maritime and 0.45 for Continental).
-!.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime
-!.. to 2 for really dirty air.
- mu_c = MIN(15., (1000.E6/Nt_c + 2.))
-
-!..Schmidt number to one-third used numerous times.
- Sc3 = Sc**(1./3.)
-
-!..Compute min ice diam from mass, min snow/graupel mass from diam.
- D0i = (xm0i/am_i)**(1./bm_i)
- xm0s = am_s * D0s**bm_s
- xm0g = am_g * D0g**bm_g
-
-!..These constants various exponents and gamma() assoc with cloud,
-!.. rain, snow, and graupel.
- cce(1) = mu_c + 1.
- cce(2) = bm_r + mu_c + 1.
- cce(3) = bm_r + mu_c + 4.
- ccg(1) = WGAMMA(cce(1))
- ccg(2) = WGAMMA(cce(2))
- ccg(3) = WGAMMA(cce(3))
- ocg1 = 1./ccg(1)
- ocg2 = 1./ccg(2)
-
- cie(1) = mu_i + 1.
- cie(2) = bm_i + mu_i + 1.
- cie(3) = bm_i + mu_i + bv_i + 1.
- cie(4) = mu_i + bv_i + 1.
- cie(5) = mu_i + 2.
- cie(6) = bm_i + bv_i
- cig(1) = WGAMMA(cie(1))
- cig(2) = WGAMMA(cie(2))
- cig(3) = WGAMMA(cie(3))
- cig(4) = WGAMMA(cie(4))
- cig(5) = WGAMMA(cie(5))
- cig(6) = WGAMMA(cie(6))
- oig1 = 1./cig(1)
- oig2 = 1./cig(2)
- obmi = 1./bm_i
-
- cre(1) = bm_r + 1.
- cre(2) = mu_r + 1.
- cre(3) = bm_r + mu_r + 1.
- cre(4) = bm_r*2. + mu_r + 1.
- cre(5) = mu_r + bv_r + 1.
- cre(6) = bm_r + mu_r + bv_r + 1.
- cre(7) = bm_r*0.5 + mu_r + bv_r + 1.
- cre(8) = bm_r + mu_r + bv_r + 3.
- cre(9) = mu_r + bv_r + 3.
- cre(10) = mu_r + 2.
- cre(11) = 0.5*(bv_r + 5. + 2.*mu_r)
- cre(12) = bm_r*0.5 + mu_r + 1.
- cre(13) = bm_r*2. + mu_r + bv_r + 1.
- do n = 1, 13
- crg(n) = WGAMMA(cre(n))
- enddo
- obmr = 1./bm_r
- ore1 = 1./cre(1)
- org1 = 1./crg(1)
- org2 = 1./crg(2)
- org3 = 1./crg(3)
-
- cse(1) = bm_s + 1.
- cse(2) = bm_s + 2.
- cse(3) = bm_s*2.
- cse(4) = bm_s + bv_s + 1.
- cse(5) = bm_s*2. + bv_s + 1.
- cse(6) = bm_s*2. + 1.
- cse(7) = bm_s + mu_s + 1.
- cse(8) = bm_s + mu_s + 2.
- cse(9) = bm_s + mu_s + 3.
- cse(10) = bm_s + mu_s + bv_s + 1.
- cse(11) = bm_s*2. + mu_s + bv_s + 2.
- cse(12) = bm_s*2. + mu_s + 1.
- cse(13) = bv_s + 2.
- cse(14) = bm_s + bv_s
- cse(15) = mu_s + 1.
- cse(16) = 1.0 + (1.0 + bv_s)/2.
- cse(17) = cse(16) + mu_s + 1.
- cse(18) = bv_s + mu_s + 3.
- do n = 1, 18
- csg(n) = WGAMMA(cse(n))
- enddo
- oams = 1./am_s
- obms = 1./bm_s
- ocms = oams**obms
-
- cge(1) = bm_g + 1.
- cge(2) = mu_g + 1.
- cge(3) = bm_g + mu_g + 1.
- cge(4) = bm_g*2. + mu_g + 1.
- cge(5) = bm_g*2. + mu_g + bv_g + 1.
- cge(6) = bm_g + mu_g + bv_g + 1.
- cge(7) = bm_g + mu_g + bv_g + 2.
- cge(8) = bm_g + mu_g + bv_g + 3.
- cge(9) = mu_g + bv_g + 3.
- cge(10) = mu_g + 2.
- cge(11) = 0.5*(bv_g + 5. + 2.*mu_g)
- cge(12) = 0.5*(bv_g + 5.) + mu_g
- do n = 1, 12
- cgg(n) = WGAMMA(cge(n))
- enddo
- oamg = 1./am_g
- obmg = 1./bm_g
- ocmg = oamg**obmg
- oge1 = 1./cge(1)
- ogg1 = 1./cgg(1)
- ogg2 = 1./cgg(2)
- ogg3 = 1./cgg(3)
-
-!+---+-----------------------------------------------------------------+
-!..Simplify various rate eqns the best we can now.
-!+---+-----------------------------------------------------------------+
-
-!..Rain collecting cloud water and cloud ice
- t1_qr_qc = PI*.25*av_r * crg(9)
- t1_qr_qi = PI*.25*av_r * crg(9)
- t2_qr_qi = PI*.25*am_r*av_r * crg(8)
-
-!..Graupel collecting cloud water
- t1_qg_qc = PI*.25*av_g * cgg(9)
-
-!..Snow collecting cloud water
- t1_qs_qc = PI*.25*av_s
-
-!..Snow collecting cloud ice
- t1_qs_qi = PI*.25*av_s
-
-!..Evaporation of rain; ignore depositional growth of rain.
- t1_qr_ev = 0.78 * crg(10)
- t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11)
-
-!..Sublimation/depositional growth of snow
- t1_qs_sd = 0.86
- t2_qs_sd = 0.28*Sc3*SQRT(av_s)
-
-!..Melting of snow
- t1_qs_me = PI*4.*C_sqrd*olfus * 0.86
- t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s)
-
-!..Sublimation/depositional growth of graupel
- t1_qg_sd = 0.86 * cgg(10)
- t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11)
-
-!..Melting of graupel
- t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10)
- t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11)
-
-!..Constants for helping find lookup table indexes.
- nic2 = NINT(ALOG10(r_c(1)))
- nii2 = NINT(ALOG10(r_i(1)))
- nii3 = NINT(ALOG10(Nt_i(1)))
- nir2 = NINT(ALOG10(r_r(1)))
- nir3 = NINT(ALOG10(N0r_exp(1)))
- nis2 = NINT(ALOG10(r_s(1)))
- nig2 = NINT(ALOG10(r_g(1)))
- nig3 = NINT(ALOG10(N0g_exp(1)))
-
-!..Create bins of cloud water (from min diameter up to 100 microns).
- Dc(1) = D0c*1.0d0
- dtc(1) = D0c*1.0d0
- do n = 2, nbc
- Dc(n) = Dc(n-1) + 1.0D-6
- dtc(n) = (Dc(n) - Dc(n-1))
- enddo
-
-!..Create bins of cloud ice (from min diameter up to 5x min snow size).
- xDx(1) = D0i*1.0d0
- xDx(nbi+1) = 5.0d0*D0s
- do n = 2, nbi
- xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) &
- *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1)))
- enddo
- do n = 1, nbi
- Di(n) = DSQRT(xDx(n)*xDx(n+1))
- dti(n) = xDx(n+1) - xDx(n)
- enddo
-
-!..Create bins of rain (from min diameter up to 5 mm).
- xDx(1) = D0r*1.0d0
- xDx(nbr+1) = 0.005d0
- do n = 2, nbr
- xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) &
- *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1)))
- enddo
- do n = 1, nbr
- Dr(n) = DSQRT(xDx(n)*xDx(n+1))
- dtr(n) = xDx(n+1) - xDx(n)
- enddo
-
-!..Create bins of snow (from min diameter up to 2 cm).
- xDx(1) = D0s*1.0d0
- xDx(nbs+1) = 0.02d0
- do n = 2, nbs
- xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) &
- *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1)))
- enddo
- do n = 1, nbs
- Ds(n) = DSQRT(xDx(n)*xDx(n+1))
- dts(n) = xDx(n+1) - xDx(n)
- enddo
-
-!..Create bins of graupel (from min diameter up to 5 cm).
- xDx(1) = D0g*1.0d0
- xDx(nbg+1) = 0.05d0
- do n = 2, nbg
- xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) &
- *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1)))
- enddo
- do n = 1, nbg
- Dg(n) = DSQRT(xDx(n)*xDx(n+1))
- dtg(n) = xDx(n+1) - xDx(n)
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Create lookup tables for most costly calculations.
-!+---+-----------------------------------------------------------------+
-
- do m = 1, ntb_r
- do k = 1, ntb_r1
- do j = 1, ntb_g
- do i = 1, ntb_g1
- tcg_racg(i,j,k,m) = 0.0d0
- tmr_racg(i,j,k,m) = 0.0d0
- tcr_gacr(i,j,k,m) = 0.0d0
- tmg_gacr(i,j,k,m) = 0.0d0
- tnr_racg(i,j,k,m) = 0.0d0
- tnr_gacr(i,j,k,m) = 0.0d0
- enddo
- enddo
- enddo
- enddo
-
- do m = 1, ntb_r
- do k = 1, ntb_r1
- do j = 1, ntb_t
- do i = 1, ntb_s
- tcs_racs1(i,j,k,m) = 0.0d0
- tmr_racs1(i,j,k,m) = 0.0d0
- tcs_racs2(i,j,k,m) = 0.0d0
- tmr_racs2(i,j,k,m) = 0.0d0
- tcr_sacr1(i,j,k,m) = 0.0d0
- tms_sacr1(i,j,k,m) = 0.0d0
- tcr_sacr2(i,j,k,m) = 0.0d0
- tms_sacr2(i,j,k,m) = 0.0d0
- tnr_racs1(i,j,k,m) = 0.0d0
- tnr_racs2(i,j,k,m) = 0.0d0
- tnr_sacr1(i,j,k,m) = 0.0d0
- tnr_sacr2(i,j,k,m) = 0.0d0
- enddo
- enddo
- enddo
- enddo
-
- do k = 1, 45
- do j = 1, ntb_r1
- do i = 1, ntb_r
- tpi_qrfz(i,j,k) = 0.0d0
- tni_qrfz(i,j,k) = 0.0d0
- tpg_qrfz(i,j,k) = 0.0d0
- tnr_qrfz(i,j,k) = 0.0d0
- enddo
- enddo
- do i = 1, ntb_c
- tpi_qcfz(i,k) = 0.0d0
- tni_qcfz(i,k) = 0.0d0
- enddo
- enddo
-
- do j = 1, ntb_i1
- do i = 1, ntb_i
- tps_iaus(i,j) = 0.0d0
- tni_iaus(i,j) = 0.0d0
- tpi_ide(i,j) = 0.0d0
- enddo
- enddo
-
- do j = 1, nbc
- do i = 1, nbr
- t_Efrw(i,j) = 0.0
- enddo
- do i = 1, nbs
- t_Efsw(i,j) = 0.0
- enddo
- enddo
-
- do k = 1, ntb_r
- do j = 1, ntb_r1
- do i = 1, nbr
- tnr_rev(i,j,k) = 0.0d0
- enddo
- enddo
- enddo
-
-! CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ')
-! WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') &
-! ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g
-! CALL wrf_debug(150, wrf_err_message)
-
-!..Collision efficiency between rain/snow and cloud water.
-! CALL wrf_debug(200, ' creating qc collision eff tables')
- call table_Efrw
- call table_Efsw
-
-!..Drop evaporation.
-! CALL wrf_debug(200, ' creating rain evap table')
-! call table_dropEvap
-
-!..Initialize various constants for computing radar reflectivity.
-! call radar_init
-
-!LDF begin (05-13-2010): read pre-calculated look-up tables.
- iiwarm = .false.
- l_qr_acr_qg = .false.
- l_qr_acr_qs = .false.
- l_qi_aut_qs = .false.
- l_freezeH2O = .false.
-
- inquire(file='./LOOKUP_TABLES/table_qr_acr_qg.dat',exist=l_qr_acr_qg)
- inquire(file='./LOOKUP_TABLES/table_qr_acr_qs.dat',exist=l_qr_acr_qs)
- inquire(file='./LOOKUP_TABLES/table_qi_aut_qs.dat',exist=l_qi_aut_qs)
- inquire(file='./LOOKUP_TABLES/table_freezeH2O.dat',exist=l_freezeH2O)
-
- IF(l_qr_acr_qg .AND. l_qr_acr_qs .AND. l_qi_aut_qs .AND. &
- l_freezeH2O) iiwarm = .true.
-
- if(iiwarm) then
- write(6,*) '--- BEGIN READ PRE-CALCULATED LOOK-UP TABLES'
-!..Rain collecting graupel & graupel collecting rain.
- open(unit=11,file='./LOOKUP_TABLES/table_qr_acr_qg.dat', &
- form='unformatted',status='old',readonly)
- read(11) tcg_racg
- read(11) tmr_racg
- read(11) tcr_gacr
- read(11) tmg_gacr
- read(11) tnr_racg
- read(11) tnr_gacr
- close(unit=11)
-
-!..Rain collecting snow & snow collecting rain.
- open(unit=11,file='./LOOKUP_TABLES/table_qr_acr_qs.dat', &
- form='unformatted',status='old',readonly)
- read(11) tcs_racs1
- read(11) tmr_racs1
- read(11) tcs_racs2
- read(11) tmr_racs2
- read(11) tcr_sacr1
- read(11) tms_sacr1
- read(11) tcr_sacr2
- read(11) tms_sacr2
- read(11) tnr_racs1
- read(11) tnr_racs2
- read(11) tnr_sacr1
- read(11) tnr_sacr2
- close(unit=11)
-
-!..Cloud water and rain freezing (Bigg, 1953).
- open(unit=11,file='./LOOKUP_TABLES/table_freezeH2O.dat', &
- form='unformatted',status='old',readonly)
- read(11) tpi_qrfz
- read(11) tni_qrfz
- read(11) tpg_qrfz
- read(11) tnr_qrfz
- read(11) tpi_qcfz
- read(11) tni_qcfz
- close(unit=11)
-
-!..Conversion of some ice mass into snow category.
- open(unit=11,file='./LOOKUP_TABLES/table_qi_aut_qs.dat', &
- form='unformatted',status='old',readonly)
- read(11) tpi_ide
- read(11) tps_iaus
- read(11) tni_iaus
- close(unit=11)
-
- write(6,*) '--- END PRE-CALCULATED LOOK-UP TABLES'
- iiwarm = .false.
-
- elseif (.not. iiwarm) then
-
-!..Rain collecting graupel & graupel collecting rain.
-! CALL wrf_debug(200, ' creating rain collecting graupel table')
- call qr_acr_qg
-
-!..Rain collecting snow & snow collecting rain.
-! CALL wrf_debug(200, ' creating rain collecting snow table')
- call qr_acr_qs
-
-!..Cloud water and rain freezing (Bigg, 1953).
-! CALL wrf_debug(200, ' creating freezing of water drops table')
- call freezeH2O
-
-!..Conversion of some ice mass into snow category.
-! CALL wrf_debug(200, ' creating ice converting to snow table')
- call qi_aut_qs
-
- endif
-
-! CALL wrf_debug(150, ' ... DONE microphysical lookup tables')
- endif
-
- END SUBROUTINE thompson_init
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..This is a wrapper routine designed to transfer values from 3D to 1D.
-!+---+-----------------------------------------------------------------+
- SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
- th, pii, p, dz, dt_in, itimestep, &
- RAINNC, RAINNCV, &
- SNOWNC, SNOWNCV, &
- GRAUPELNC, GRAUPELNCV, &
- SR, &
-! refl_10cm, grid_clock, grid_alarms, &
- ids,ide, jds,jde, kds,kde, & ! domain dims
- ims,ime, jms,jme, kms,kme, & ! memory dims
- its,ite, jts,jte, kts,kte) ! tile dims
-
- implicit none
-
-!..Subroutine arguments
- INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
- qv, qc, qr, qi, qs, qg, ni, nr, th
- REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
- pii, p, dz
- REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
- RAINNC, RAINNCV, SR
- REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: &
- SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV
-! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
-! refl_10cm
- REAL, INTENT(IN):: dt_in
- INTEGER, INTENT(IN):: itimestep
-
-! TYPE (WRFU_Clock):: grid_clock
-! TYPE (WRFU_Alarm), POINTER:: grid_alarms(:)
-
-!..Local variables
- REAL, DIMENSION(kts:kte):: &
- qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
- nr1d, t1d, p1d, dz1d, dBZ
- REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic
- REAL:: dt, pptrain, pptsnow, pptgraul, pptice
- REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max
- INTEGER:: i, j, k
- INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr
- INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr
- INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr
- INTEGER:: i_start, j_start, i_end, j_end
- LOGICAL:: dBZ_tstep
-
-!+---+
-
- dBZ_tstep = .false.
-! if ( Is_alarm_tstep(grid_clock, grid_alarms(HISTORY_ALARM)) ) then
-! dBZ_tstep = .true.
-! endif
-
- i_start = its
- j_start = jts
- i_end = ite
- j_end = jte
-! if ( (ite-its+1).gt.4 .and. (jte-jts+1).lt.4) then
-! i_start = its + 2
-! i_end = ite - 1
-! j_start = jts
-! j_end = jte
-! elseif ( (ite-its+1).lt.4 .and. (jte-jts+1).gt.4) then
-! i_start = its
-! i_end = ite
-! j_start = jts + 2
-! j_end = jte - 1
-! endif
-
- dt = dt_in
-
- qc_max = 0.
- qr_max = 0.
- qs_max = 0.
- qi_max = 0.
- qg_max = 0
- ni_max = 0.
- nr_max = 0.
- imax_qc = 0
- imax_qr = 0
- imax_qi = 0
- imax_qs = 0
- imax_qg = 0
- imax_ni = 0
- imax_nr = 0
- jmax_qc = 0
- jmax_qr = 0
- jmax_qi = 0
- jmax_qs = 0
- jmax_qg = 0
- jmax_ni = 0
- jmax_nr = 0
- kmax_qc = 0
- kmax_qr = 0
- kmax_qi = 0
- kmax_qs = 0
- kmax_qg = 0
- kmax_ni = 0
- kmax_nr = 0
- do i = 1, 256
- mp_debug(i:i) = char(0)
- enddo
-
- j_loop: do j = j_start, j_end
- i_loop: do i = i_start, i_end
-
- pptrain = 0.
- pptsnow = 0.
- pptgraul = 0.
- pptice = 0.
- RAINNCV(i,j) = 0.
- IF ( PRESENT (snowncv) ) THEN
- SNOWNCV(i,j) = 0.
- ENDIF
- IF ( PRESENT (graupelncv) ) THEN
- GRAUPELNCV(i,j) = 0.
- ENDIF
- SR(i,j) = 0.
-
- do k = kts, kte
- t1d(k) = th(i,k,j)*pii(i,k,j)
- p1d(k) = p(i,k,j)
- dz1d(k) = dz(i,k,j)
- qv1d(k) = qv(i,k,j)
- qc1d(k) = qc(i,k,j)
- qi1d(k) = qi(i,k,j)
- qr1d(k) = qr(i,k,j)
- qs1d(k) = qs(i,k,j)
- qg1d(k) = qg(i,k,j)
- ni1d(k) = ni(i,k,j)
- nr1d(k) = nr(i,k,j)
- enddo
-
- call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
- nr1d, t1d, p1d, dz1d, &
- pptrain, pptsnow, pptgraul, pptice, &
- kts, kte, dt, i, j)
-
- pcp_ra(i,j) = pptrain
- pcp_sn(i,j) = pptsnow
- pcp_gr(i,j) = pptgraul
- pcp_ic(i,j) = pptice
- RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice
- RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice
- IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN
- SNOWNCV(i,j) = pptsnow + pptice
- SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice
- ENDIF
- IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN
- GRAUPELNCV(i,j) = pptgraul
- GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul
- ENDIF
- SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12)
-
- do k = kts, kte
- qv(i,k,j) = qv1d(k)
- qc(i,k,j) = qc1d(k)
- qi(i,k,j) = qi1d(k)
- qr(i,k,j) = qr1d(k)
- qs(i,k,j) = qs1d(k)
- qg(i,k,j) = qg1d(k)
- ni(i,k,j) = ni1d(k)
- nr(i,k,j) = nr1d(k)
- th(i,k,j) = t1d(k)/pii(i,k,j)
- if (qc1d(k) .gt. qc_max) then
- imax_qc = i
- jmax_qc = j
- kmax_qc = k
- qc_max = qc1d(k)
- elseif (qc1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (qr1d(k) .gt. qr_max) then
- imax_qr = i
- jmax_qr = j
- kmax_qr = k
- qr_max = qr1d(k)
- elseif (qr1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (nr1d(k) .gt. nr_max) then
- imax_nr = i
- jmax_nr = j
- kmax_nr = k
- nr_max = nr1d(k)
- elseif (nr1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative nr ', nr1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (qs1d(k) .gt. qs_max) then
- imax_qs = i
- jmax_qs = j
- kmax_qs = k
- qs_max = qs1d(k)
- elseif (qs1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (qi1d(k) .gt. qi_max) then
- imax_qi = i
- jmax_qi = j
- kmax_qi = k
- qi_max = qi1d(k)
- elseif (qi1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (qg1d(k) .gt. qg_max) then
- imax_qg = i
- jmax_qg = j
- kmax_qg = k
- qg_max = qg1d(k)
- elseif (qg1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (ni1d(k) .gt. ni_max) then
- imax_ni = i
- jmax_ni = j
- kmax_ni = k
- ni_max = ni1d(k)
- elseif (ni1d(k) .lt. 0.0) then
- write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- if (qv1d(k) .lt. 0.0) then
- if (k.lt.kte-2 .and. k.gt.kts+1) then
- qv(i,k,j) = 0.5*(qv(i,k-1,j) + qv(i,k+1,j))
- else
- qv(i,k,j) = 1.E-7
- endif
- write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), &
- ' at i,j,k=', i,j,k
-! CALL wrf_debug(150, mp_debug)
- endif
- enddo
-
-! if (dBZ_tstep) then
-! call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, &
-! t1d, p1d, dBZ, kts, kte, i, j)
-! do k = kts, kte
-! refl_10cm(i,k,j) = MAX(-35., dBZ(k))
-! enddo
-! endif
-
- enddo i_loop
- enddo j_loop
-
-! DEBUG - GT
- write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', &
- 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', &
- 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', &
- 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', &
- 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', &
- 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', &
- 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', &
- 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')'
-! CALL wrf_debug(150, mp_debug)
-! END DEBUG - GT
-
- do i = 1, 256
- mp_debug(i:i) = char(0)
- enddo
-
- END SUBROUTINE mp_gt_driver
-
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!+---+-----------------------------------------------------------------+
-!.. This subroutine computes the moisture tendencies of water vapor,
-!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel.
-!.. Previously this code was based on Reisner et al (1998), but few of
-!.. those pieces remain. A complete description is now found in
-!.. Thompson et al. (2004, 2008).
-!+---+-----------------------------------------------------------------+
-!
- subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
- nr1d, t1d, p1d, dzq, &
- pptrain, pptsnow, pptgraul, pptice, &
- kts, kte, dt, ii, jj)
-
- implicit none
-
-!..Sub arguments
- INTEGER, INTENT(IN):: kts, kte, ii, jj
- REAL, DIMENSION(kts:kte), INTENT(INOUT):: &
- qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
- nr1d, t1d, p1d
- REAL, DIMENSION(kts:kte), INTENT(IN):: dzq
- REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice
- REAL, INTENT(IN):: dt
-
-!..Local variables
- REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, &
- qrten, qsten, qgten, niten, nrten
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, &
- prr_rcg, prr_sml, prr_gml, &
- prr_rci, prv_rev, &
- pnr_wau, pnr_rcs, pnr_rcg, &
- pnr_rci, pnr_sml, pnr_gml, &
- pnr_rev, pnr_rcr, pnr_rfz
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: pri_inu, pni_inu, pri_ihm, &
- pni_ihm, pri_wfz, pni_wfz, &
- pri_rfz, pni_rfz, pri_ide, &
- pni_ide, pri_rci, pni_rci, &
- pni_sci, pni_iau
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, &
- prs_scw, prs_sde, prs_ihm, &
- prs_ide
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: prg_scw, prg_rfz, prg_gde, &
- prg_gcw, prg_rci, prg_rcs, &
- prg_rcg, prg_ihm
-
- REAL, DIMENSION(kts:kte):: temp, pres, qv
- REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr
- REAL, DIMENSION(kts:kte):: rho, rhof, rhof2
- REAL, DIMENSION(kts:kte):: qvs, qvsi
- REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati
- REAL, DIMENSION(kts:kte):: diffu, visco, vsc2, &
- tcond, lvap, ocp, lvt2
-
- DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, N0_r, N0_g
- REAL, DIMENSION(kts:kte):: mvd_r, mvd_c
- REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, &
- smoc, smod, smoe, smof
-
- REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n
-
- REAL:: rgvm, delta_tp, orho, lfus2
- REAL, DIMENSION(4):: onstep
- DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg
- DOUBLE PRECISION:: lami, ilami
- REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m
- DOUBLE PRECISION:: Dr_star
- REAL:: zeta1, zeta, taud, tau
- REAL:: stoke_r, stoke_s, stoke_g, stoke_i
- REAL:: vti, vtr, vts, vtg
- REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk
- REAL, DIMENSION(kts:kte):: vts_boost
- REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow
- REAL:: a_, b_, loga_, A1, A2, tf
- REAL:: tempc, tc0, r_mvd1, r_mvd2, xkrat
- REAL:: xnc, xri, xni, xmi, oxmi, xrc, xrr, xnr
- REAL:: xsat, rate_max, sump, ratio
- REAL:: clap, fcd, dfcd
- REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl
- REAL:: r_frac, g_frac
- REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr
- REAL:: dtsave, odts, odt, odzq
- INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq
- INTEGER, DIMENSION(4):: ksed1
- INTEGER:: nir, nis, nig, nii, nic
- INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r, &
- idx_i1, idx_i, idx_c, idx, idx_d
- LOGICAL:: melti, no_micro
- LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg
- LOGICAL:: debug_flag
-
-!+---+
-
- debug_flag = .false.
-! if (ii.eq.319 .and. jj.eq.39) debug_flag = .true.
-
- no_micro = .true.
- dtsave = dt
- odt = 1./dt
- odts = 1./dtsave
- iexfrq = 1
-
-!+---+-----------------------------------------------------------------+
-!.. Source/sink terms. First 2 chars: "pr" represents source/sink of
-!.. mass while "pn" represents source/sink of number. Next char is one
-!.. of "v" for water vapor, "r" for rain, "i" for cloud ice, "w" for
-!.. cloud water, "s" for snow, and "g" for graupel. Next chars
-!.. represent processes: "de" for sublimation/deposition, "ev" for
-!.. evaporation, "fz" for freezing, "ml" for melting, "au" for
-!.. autoconversion, "nu" for ice nucleation, "hm" for Hallet/Mossop
-!.. secondary ice production, and "c" for collection followed by the
-!.. character for the species being collected. ALL of these terms are
-!.. positive (except for deposition/sublimation terms which can switch
-!.. signs based on super/subsaturation) and are treated as negatives
-!.. where necessary in the tendency equations.
-!+---+-----------------------------------------------------------------+
-
- do k = kts, kte
- tten(k) = 0.
- qvten(k) = 0.
- qcten(k) = 0.
- qiten(k) = 0.
- qrten(k) = 0.
- qsten(k) = 0.
- qgten(k) = 0.
- niten(k) = 0.
- nrten(k) = 0.
-
- prw_vcd(k) = 0.
-
- prv_rev(k) = 0.
- prr_wau(k) = 0.
- prr_rcw(k) = 0.
- prr_rcs(k) = 0.
- prr_rcg(k) = 0.
- prr_sml(k) = 0.
- prr_gml(k) = 0.
- prr_rci(k) = 0.
- pnr_wau(k) = 0.
- pnr_rcs(k) = 0.
- pnr_rcg(k) = 0.
- pnr_rci(k) = 0.
- pnr_sml(k) = 0.
- pnr_gml(k) = 0.
- pnr_rev(k) = 0.
- pnr_rcr(k) = 0.
- pnr_rfz(k) = 0.
-
- pri_inu(k) = 0.
- pni_inu(k) = 0.
- pri_ihm(k) = 0.
- pni_ihm(k) = 0.
- pri_wfz(k) = 0.
- pni_wfz(k) = 0.
- pri_rfz(k) = 0.
- pni_rfz(k) = 0.
- pri_ide(k) = 0.
- pni_ide(k) = 0.
- pri_rci(k) = 0.
- pni_rci(k) = 0.
- pni_sci(k) = 0.
- pni_iau(k) = 0.
-
- prs_iau(k) = 0.
- prs_sci(k) = 0.
- prs_rcs(k) = 0.
- prs_scw(k) = 0.
- prs_sde(k) = 0.
- prs_ihm(k) = 0.
- prs_ide(k) = 0.
-
- prg_scw(k) = 0.
- prg_rfz(k) = 0.
- prg_gde(k) = 0.
- prg_gcw(k) = 0.
- prg_rci(k) = 0.
- prg_rcs(k) = 0.
- prg_rcg(k) = 0.
- prg_ihm(k) = 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*temp(k)*(qv(k)+0.622))
- if (qc1d(k) .gt. R1) then
- no_micro = .false.
- rc(k) = qc1d(k)*rho(k)
- L_qc(k) = .true.
- else
- qc1d(k) = 0.0
- rc(k) = R1
- L_qc(k) = .false.
- endif
- if (qi1d(k) .gt. R1) then
- no_micro = .false.
- ri(k) = qi1d(k)*rho(k)
- ni(k) = MAX(1., ni1d(k)*rho(k))
- L_qi(k) = .true.
- lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
- ilami = 1./lami
- xDi = (bm_i + mu_i + 1.) * ilami
- if (xDi.lt. 20.E-6) then
- lami = cie(2)/20.E-6
- ni(k) = MIN(500.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
- elseif (xDi.gt. 300.E-6) then
- lami = cie(2)/300.E-6
- ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i
- endif
- else
- qi1d(k) = 0.0
- ni1d(k) = 0.0
- ri(k) = R1
- ni(k) = 0.01
- L_qi(k) = .false.
- endif
-
- if (qr1d(k) .gt. R1) then
- no_micro = .false.
- rr(k) = qr1d(k)*rho(k)
- nr(k) = MAX(1., nr1d(k)*rho(k))
- L_qr(k) = .true.
- if (nr(k) .gt. 1.0) then
- lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- if (mvd_r(k) .gt. 2.5E-3) then
- mvd_r(k) = 2.5E-3
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
- elseif (mvd_r(k) .lt. D0r*0.75) then
- mvd_r(k) = D0r*0.75
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
- endif
- else
- if (qr1d(k) .gt. R2) then
- mvd_r(k) = 2.5E-3
- else
- mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k)))
- endif
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
- endif
- else
- qr1d(k) = 0.0
- nr1d(k) = 0.0
- rr(k) = R1
- nr(k) = 1.0
- L_qr(k) = .false.
- endif
- if (qs1d(k) .gt. R1) then
- no_micro = .false.
- rs(k) = qs1d(k)*rho(k)
- L_qs(k) = .true.
- else
- qs1d(k) = 0.0
- rs(k) = R1
- L_qs(k) = .false.
- endif
- if (qg1d(k) .gt. R1) then
- no_micro = .false.
- rg(k) = qg1d(k)*rho(k)
- L_qg(k) = .true.
- else
- qg1d(k) = 0.0
- rg(k) = R1
- L_qg(k) = .false.
- endif
- enddo
-
-
-!+---+-----------------------------------------------------------------+
-!..Derive various thermodynamic variables frequently used.
-!.. Saturation vapor pressure (mixing ratio) over liquid/ice comes from
-!.. Flatau et al. 1992; enthalpy (latent heat) of vaporization from
-!.. Bohren & Albrecht 1998; others from Pruppacher & Klett 1978.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- tempc = temp(k) - 273.15
- rhof(k) = SQRT(RHO_NOT/rho(k))
- rhof2(k) = SQRT(rhof(k))
- qvs(k) = rslf(pres(k), temp(k))
- if (tempc .le. 0.0) then
- qvsi(k) = rsif(pres(k), temp(k))
- else
- qvsi(k) = qvs(k)
- endif
- satw(k) = qv(k)/qvs(k)
- sati(k) = qv(k)/qvsi(k)
- ssatw(k) = satw(k) - 1.
- ssati(k) = sati(k) - 1.
- if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
- if (abs(ssati(k)).lt. eps) ssati(k) = 0.0
- if (no_micro .and. ssati(k).gt. 0.0) no_micro = .false.
- diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
- if (tempc .ge. 0.0) then
- visco(k) = (1.718+0.0049*tempc)*1.0E-5
- else
- visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5
- endif
- ocp(k) = 1./(Cp*(1.+0.887*qv(k)))
- vsc2(k) = SQRT(rho(k)/visco(k))
- lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
- tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..If no existing hydrometeor species and no chance to initiate ice or
-!.. condense cloud water, just exit quickly!
-!+---+-----------------------------------------------------------------+
-
- if (no_micro) return
-
-!+---+-----------------------------------------------------------------+
-!..Calculate y-intercept, slope, and useful moments for snow.
-!+---+-----------------------------------------------------------------+
- if (.not. iiwarm) then
- do k = kts, kte
- if (.not. L_qs(k)) CYCLE
- tc0 = MIN(-0.1, temp(k)-273.15)
- smob(k) = rs(k)*oams
-
-!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
-!.. then we must compute actual 2nd moment and use as reference.
- if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
- smo2(k) = smob(k)
- else
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
- + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
- + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
- + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
- + sa(10)*bm_s*bm_s*bm_s
- a_ = 10.0**loga_
- b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
- + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
- + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
- + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
- + sb(10)*bm_s*bm_s*bm_s
- smo2(k) = (smob(k)/a_)**(1./b_)
- endif
-
-!..Calculate 0th moment. Represents snow number concentration.
- loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0
- a_ = 10.0**loga_
- b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0
- smo0(k) = a_ * smo2(k)**b_
-
-!..Calculate 1st moment. Useful for depositional growth and melting.
- loga_ = sa(1) + sa(2)*tc0 + sa(3) &
- + sa(4)*tc0 + sa(5)*tc0*tc0 &
- + sa(6) + sa(7)*tc0*tc0 &
- + sa(8)*tc0 + sa(9)*tc0*tc0*tc0 &
- + sa(10)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3) + sb(4)*tc0 &
- + sb(5)*tc0*tc0 + sb(6) &
- + sb(7)*tc0*tc0 + sb(8)*tc0 &
- + sb(9)*tc0*tc0*tc0 + sb(10)
- smo1(k) = a_ * smo2(k)**b_
-
-!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
- + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
- + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
- + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
- + sa(10)*cse(1)*cse(1)*cse(1)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
- + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
- + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
- + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
- smoc(k) = a_ * smo2(k)**b_
-
-!..Calculate bv_s+2 (th) moment. Useful for riming.
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(13) &
- + sa(4)*tc0*cse(13) + sa(5)*tc0*tc0 &
- + sa(6)*cse(13)*cse(13) + sa(7)*tc0*tc0*cse(13) &
- + sa(8)*tc0*cse(13)*cse(13) + sa(9)*tc0*tc0*tc0 &
- + sa(10)*cse(13)*cse(13)*cse(13)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(13) + sb(4)*tc0*cse(13) &
- + sb(5)*tc0*tc0 + sb(6)*cse(13)*cse(13) &
- + sb(7)*tc0*tc0*cse(13) + sb(8)*tc0*cse(13)*cse(13) &
- + sb(9)*tc0*tc0*tc0 + sb(10)*cse(13)*cse(13)*cse(13)
- smoe(k) = a_ * smo2(k)**b_
-
-!..Calculate 1+(bv_s+1)/2 (th) moment. Useful for depositional growth.
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(16) &
- + sa(4)*tc0*cse(16) + sa(5)*tc0*tc0 &
- + sa(6)*cse(16)*cse(16) + sa(7)*tc0*tc0*cse(16) &
- + sa(8)*tc0*cse(16)*cse(16) + sa(9)*tc0*tc0*tc0 &
- + sa(10)*cse(16)*cse(16)*cse(16)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(16) + sb(4)*tc0*cse(16) &
- + sb(5)*tc0*tc0 + sb(6)*cse(16)*cse(16) &
- + sb(7)*tc0*tc0*cse(16) + sb(8)*tc0*cse(16)*cse(16) &
- + sb(9)*tc0*tc0*tc0 + sb(10)*cse(16)*cse(16)*cse(16)
- smof(k) = a_ * smo2(k)**b_
-
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Calculate y-intercept, slope values for graupel.
-!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- N0_exp = (gonv_max-gonv_min)*0.5D0 &
- * tanh((0.01E-3-(rc(k)+rr(k)))/0.75E-3) &
- + (gonv_max+gonv_min)*0.5D0
-! N0_exp = (gonv_max-gonv_min)*0.5D0 &
-! * tanh((-15.-(temp(k)-273.15))/7.5) &
-! + (gonv_max+gonv_min)*0.5D0
- lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- ilamg(k) = 1./lamg
- N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
- enddo
-
- endif
-
-!+---+-----------------------------------------------------------------+
-!..Calculate y-intercept, slope values for rain.
-!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
- ilamr(k) = 1./lamr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- N0_r(k) = nr(k)*org2*lamr**cre(2)
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Compute warm-rain process terms (except evap done later).
-!+---+-----------------------------------------------------------------+
-
- do k = kts, kte
-
-!..Rain self-collection follows Seifert, 1994 and drop break-up
-!.. follows Verlinde and Cotton, 1993. RAIN2M
- if (L_qr(k) .and. mvd_r(k).gt. D0r) then
- if (mvd_r(k) .le. 1750.0E-6) then
- Ef_rr = 1.0
- else
- Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1750.0E-6))
- endif
- pnr_rcr(k) = Ef_rr * 8.*nr(k)*rr(k)
- endif
-
- if (.not. L_qc(k)) CYCLE
- xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6)
- lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr
- mvd_c(k) = (3.0+mu_c+0.672) / lamc
-
-!..Autoconversion follows Berry & Reinhardt (1974) with characteristic
-!.. diameters correctly computed from gamma distrib of cloud droplets.
- if (rc(k).gt. 0.01e-3) then
- Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6
- Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) &
- **(1./6.)
- zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) &
- + abs(6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4))
- zeta = 0.027*rc(k)*zeta1
- taud = 0.5*((0.5*Dc_b - 7.5) + abs(0.5*Dc_b - 7.5)) + R1
- tau = 3.72/(rc(k)*taud)
- prr_wau(k) = zeta/tau
- prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k))
- pnr_wau(k) = prr_wau(k) / (am_r*mu_c/3.*D0r*D0r*D0r/rho(k)) ! RAIN2M
- endif
-
-!..Rain collecting cloud water. In CE, assume Dc<<Dr and vtc=~0.
- if (L_qr(k) .and. mvd_r(k).gt. D0r .and. mvd_c(k).gt. D0c) then
- lamr = 1./ilamr(k)
- idx = 1 + INT(nbr*DLOG(mvd_r(k)/Dr(1))/DLOG(Dr(nbr)/Dr(1)))
- idx = MIN(idx, nbr)
- Ef_rw = t_Efrw(idx, INT(mvd_c(k)*1.E6))
- prr_rcw(k) = rhof(k)*t1_qr_qc*Ef_rw*rc(k)*N0_r(k) &
- *((lamr+fv_r)**(-cre(9)))
- prr_rcw(k) = MIN(DBLE(rc(k)*odts), prr_rcw(k))
- endif
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Compute all frozen hydrometeor species' process terms.
-!+---+-----------------------------------------------------------------+
- if (.not. iiwarm) then
- do k = kts, kte
- vts_boost(k) = 1.5
-
-!..Temperature lookup table indexes.
- tempc = temp(k) - 273.15
- idx_tc = MAX(1, MIN(NINT(-tempc), 45) )
- idx_t = INT( (tempc-2.5)/5. ) - 1
- idx_t = MAX(1, -idx_t)
- idx_t = MIN(idx_t, ntb_t)
- IT = MAX(1, MIN(NINT(-tempc), 31) )
-
-!..Cloud water lookup table index.
- if (rc(k).gt. r_c(1)) then
- nic = NINT(ALOG10(rc(k)))
- do nn = nic-1, nic+1
- n = nn
- if ( (rc(k)/10.**nn).ge.1.0 .and. &
- (rc(k)/10.**nn).lt.10.0) goto 141
- enddo
- 141 continue
- idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
- idx_c = MAX(1, MIN(idx_c, ntb_c))
- else
- idx_c = 1
- endif
-
-!..Cloud ice lookup table indexes.
- if (ri(k).gt. r_i(1)) then
- nii = NINT(ALOG10(ri(k)))
- do nn = nii-1, nii+1
- n = nn
- if ( (ri(k)/10.**nn).ge.1.0 .and. &
- (ri(k)/10.**nn).lt.10.0) goto 142
- enddo
- 142 continue
- idx_i = INT(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2)
- idx_i = MAX(1, MIN(idx_i, ntb_i))
- else
- idx_i = 1
- endif
-
- if (ni(k).gt. Nt_i(1)) then
- nii = NINT(ALOG10(ni(k)))
- do nn = nii-1, nii+1
- n = nn
- if ( (ni(k)/10.**nn).ge.1.0 .and. &
- (ni(k)/10.**nn).lt.10.0) goto 143
- enddo
- 143 continue
- idx_i1 = INT(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3)
- idx_i1 = MAX(1, MIN(idx_i1, ntb_i1))
- else
- idx_i1 = 1
- endif
-
-!..Rain lookup table indexes.
- if (rr(k).gt. r_r(1)) then
- nir = NINT(ALOG10(rr(k)))
- do nn = nir-1, nir+1
- n = nn
- if ( (rr(k)/10.**nn).ge.1.0 .and. &
- (rr(k)/10.**nn).lt.10.0) goto 144
- enddo
- 144 continue
- idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
- idx_r = MAX(1, MIN(idx_r, ntb_r))
-
- lamr = 1./ilamr(k)
- lam_exp = lamr * (crg(3)*org2*org1)**bm_r
- N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
- nir = NINT(DLOG10(N0_exp))
- do nn = nir-1, nir+1
- n = nn
- if ( (N0_exp/10.**nn).ge.1.0 .and. &
- (N0_exp/10.**nn).lt.10.0) goto 145
- enddo
- 145 continue
- idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
- idx_r1 = MAX(1, MIN(idx_r1, ntb_r1))
- else
- idx_r = 1
- idx_r1 = ntb_r1
- endif
-
-!..Snow lookup table index.
- if (rs(k).gt. r_s(1)) then
- nis = NINT(ALOG10(rs(k)))
- do nn = nis-1, nis+1
- n = nn
- if ( (rs(k)/10.**nn).ge.1.0 .and. &
- (rs(k)/10.**nn).lt.10.0) goto 146
- enddo
- 146 continue
- idx_s = INT(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2)
- idx_s = MAX(1, MIN(idx_s, ntb_s))
- else
- idx_s = 1
- endif
-
-!..Graupel lookup table index.
- if (rg(k).gt. r_g(1)) then
- nig = NINT(ALOG10(rg(k)))
- do nn = nig-1, nig+1
- n = nn
- if ( (rg(k)/10.**nn).ge.1.0 .and. &
- (rg(k)/10.**nn).lt.10.0) goto 147
- enddo
- 147 continue
- idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2)
- idx_g = MAX(1, MIN(idx_g, ntb_g))
-
- lamg = 1./ilamg(k)
- lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g
- N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1)
- nig = NINT(DLOG10(N0_exp))
- do nn = nig-1, nig+1
- n = nn
- if ( (N0_exp/10.**nn).ge.1.0 .and. &
- (N0_exp/10.**nn).lt.10.0) goto 148
- enddo
- 148 continue
- idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3)
- idx_g1 = MAX(1, MIN(idx_g1, ntb_g1))
- else
- idx_g = 1
- idx_g1 = ntb_g1
- endif
-
-!..Deposition/sublimation prefactor (from Srivastava & Coen 1992).
- otemp = 1./temp(k)
- rvs = rho(k)*qvsi(k)
- rvs_p = rvs*otemp*(lsub*otemp*oRv - 1.)
- rvs_pp = rvs * ( otemp*(lsub*otemp*oRv - 1.) &
- *otemp*(lsub*otemp*oRv - 1.) &
- + (-2.*lsub*otemp*otemp*otemp*oRv) &
- + otemp*otemp)
- gamsc = lsub*diffu(k)/tcond(k) * rvs_p
- alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
- * rvs_pp/rvs_p * rvs/rvs_p
- alphsc = MAX(1.E-9, alphsc)
- xsat = ssati(k)
- if (abs(xsat).lt. 1.E-9) xsat=0.
- t1_subl = 4.*PI*( 1.0 - alphsc*xsat &
- + 2.*alphsc*alphsc*xsat*xsat &
- - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
- / (1.+gamsc)
-
-!..Snow collecting cloud water. In CE, assume Dc<<Ds and vtc=~0.
- if (L_qc(k) .and. mvd_c(k).gt. D0c) then
- xDs = 0.0
- if (L_qs(k)) xDs = smoc(k) / smob(k)
- if (xDs .gt. D0s) then
- idx = 1 + INT(nbs*DLOG(xDs/Ds(1))/DLOG(Ds(nbs)/Ds(1)))
- idx = MIN(idx, nbs)
- Ef_sw = t_Efsw(idx, INT(mvd_c(k)*1.E6))
- prs_scw(k) = rhof(k)*t1_qs_qc*Ef_sw*rc(k)*smoe(k)
- endif
-
-!..Graupel collecting cloud water. In CE, assume Dc<<Dg and vtc=~0.
- if (rg(k).ge. r_g(1) .and. mvd_c(k).gt. D0c) then
- xDg = (bm_g + mu_g + 1.) * ilamg(k)
- vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
- stoke_g = mvd_c(k)*mvd_c(k)*vtg*rho_w/(9.*visco(k)*xDg)
- if (xDg.gt. D0g) then
- if (stoke_g.ge.0.4 .and. stoke_g.le.10.) then
- Ef_gw = 0.55*ALOG10(2.51*stoke_g)
- elseif (stoke_g.lt.0.4) then
- Ef_gw = 0.0
- elseif (stoke_g.gt.10) then
- Ef_gw = 0.77
- endif
- prg_gcw(k) = rhof(k)*t1_qg_qc*Ef_gw*rc(k)*N0_g(k) &
- *ilamg(k)**cge(9)
- endif
- endif
- endif
-
-!..Rain collecting snow. Cannot assume Wisner (1972) approximation
-!.. or Mizuno (1990) approach so we solve the CE explicitly and store
-!.. results in lookup table.
- if (rr(k).ge. r_r(1)) then
- if (rs(k).ge. r_s(1)) then
- if (temp(k).lt.T_0) then
- prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
- + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
- + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
- + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r))
- prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
- + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
- - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
- - tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
- prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
- + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
- + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
- + tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
- prr_rcs(k) = MAX(DBLE(-rr(k)*odts), prr_rcs(k))
- prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k))
- prg_rcs(k) = MIN(DBLE((rr(k)+rs(k))*odts), prg_rcs(k))
- pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M
- + tnr_racs2(idx_s,idx_t,idx_r1,idx_r) &
- + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
- + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
- else
- prs_rcs(k) = -(tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
- + tcs_racs2(idx_s,idx_t,idx_r1,idx_r))
- prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k))
- prr_rcs(k) = -prs_rcs(k)
- pnr_rcs(k) = tnr_racs2(idx_s,idx_t,idx_r1,idx_r) & ! RAIN2M
- + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
- endif
- pnr_rcs(k) = MIN(DBLE(nr(k)*odts), pnr_rcs(k))
- endif
-
-!..Rain collecting graupel. Cannot assume Wisner (1972) approximation
-!.. or Mizuno (1990) approach so we solve the CE explicitly and store
-!.. results in lookup table.
- if (rg(k).ge. r_g(1)) then
- if (temp(k).lt.T_0) then
- prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) &
- + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r)
- prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k))
- prr_rcg(k) = -prg_rcg(k)
- pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r) & ! RAIN2M
- + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r)
- pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k))
- else
- prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r)
- prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k))
- prg_rcg(k) = -prr_rcg(k)
- endif
- endif
- endif
-
-!+---+-----------------------------------------------------------------+
-!..Next IF block handles only those processes below 0C.
-!+---+-----------------------------------------------------------------+
-
- if (temp(k).lt.T_0) then
-
- vts_boost(k) = 1.0
- rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
-
-!..Freezing of water drops into graupel/cloud ice (Bigg 1953).
- if (rr(k).gt. r_r(1)) then
- prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc)*odts
- pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc)*odts
- pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc)*odts
- pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc)*odts ! RAIN2M
- pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k))
- elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then
- pri_rfz(k) = rr(k)*odts
- pnr_rfz(k) = nr(k)*odts ! RAIN2M
- pni_rfz(k) = pnr_rfz(k)
- endif
- if (rc(k).gt. r_c(1)) then
- pri_wfz(k) = tpi_qcfz(idx_c,idx_tc)*odts
- pri_wfz(k) = MIN(DBLE(rc(k)*odts), pri_wfz(k))
- pni_wfz(k) = tni_qcfz(idx_c,idx_tc)*odts
- pni_wfz(k) = MIN(DBLE(Nt_c*odts), pri_wfz(k)/(2.*xm0i), &
- pni_wfz(k))
- endif
-
-!..Nucleate ice from deposition & condensation freezing (Cooper 1986)
-!.. but only if water sat and T<-12C or 25%+ ice supersaturated.
- if ( (ssati(k).ge. 0.25) .or. (ssatw(k).gt. eps &
- .and. temp(k).lt.261.15) ) then
- xnc = MIN(250.E3, TNO*EXP(ATO*(T_0-temp(k))))
- xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave
- pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts
- pri_inu(k) = MIN(DBLE(rate_max), xm0i*pni_inu(k))
- pni_inu(k) = pri_inu(k)/xm0i
- endif
-
-!..Deposition/sublimation of cloud ice (Srivastava & Coen 1992).
- if (L_qi(k)) then
- lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
- ilami = 1./lami
- xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami)
- xmi = am_i*xDi**bm_i
- oxmi = 1./xmi
- pri_ide(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- *oig1*cig(5)*ni(k)*ilami
-
- if (pri_ide(k) .lt. 0.0) then
- pri_ide(k) = MAX(DBLE(-ri(k)*odts), pri_ide(k), DBLE(rate_max))
- pni_ide(k) = pri_ide(k)*oxmi
- pni_ide(k) = MAX(DBLE(-ni(k)*odts), pni_ide(k))
- else
- pri_ide(k) = MIN(pri_ide(k), DBLE(rate_max))
- prs_ide(k) = (1.0D0-tpi_ide(idx_i,idx_i1))*pri_ide(k)
- pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k)
- endif
-
-!..Some cloud ice needs to move into the snow category. Use lookup
-!.. table that resulted from explicit bin representation of distrib.
- if ( (idx_i.eq. ntb_i) .or. (xDi.gt. 5.0*D0s) ) then
- prs_iau(k) = ri(k)*.99*odts
- pni_iau(k) = ni(k)*.95*odts
- elseif (xDi.lt. 0.1*D0s) then
- prs_iau(k) = 0.
- pni_iau(k) = 0.
- else
- prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts
- prs_iau(k) = MIN(DBLE(ri(k)*.99*odts), prs_iau(k))
- pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts
- pni_iau(k) = MIN(DBLE(ni(k)*.95*odts), pni_iau(k))
- endif
- endif
-
-!..Deposition/sublimation of snow/graupel follows Srivastava & Coen
-!.. (1992).
- if (L_qs(k)) then
- C_snow = C_sqrd + (tempc+15.)*(C_cube-C_sqrd)/(-30.+15.)
- C_snow = MAX(C_sqrd, MIN(C_snow, C_cube))
- prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs &
- * (t1_qs_sd*smo1(k) &
- + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
- if (prs_sde(k).lt. 0.) then
- prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k), DBLE(rate_max))
- else
- prs_sde(k) = MIN(prs_sde(k), DBLE(rate_max))
- endif
- endif
-
- if (L_qg(k) .and. ssati(k).lt. -eps) then
- prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
- + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
- if (prg_gde(k).lt. 0.) then
- prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k), DBLE(rate_max))
- else
- prg_gde(k) = MIN(prg_gde(k), DBLE(rate_max))
- endif
- endif
-
-!..Snow collecting cloud ice. In CE, assume Di<<Ds and vti=~0.
- if (L_qi(k)) then
- lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
- ilami = 1./lami
- xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami)
- xmi = am_i*xDi**bm_i
- oxmi = 1./xmi
- if (rs(k).ge. r_s(1)) then
- prs_sci(k) = t1_qs_qi*rhof(k)*Ef_si*ri(k)*smoe(k)
- pni_sci(k) = prs_sci(k) * oxmi
- endif
-
-!..Rain collecting cloud ice. In CE, assume Di<<Dr and vti=~0.
- if (rr(k).ge. r_r(1) .and. mvd_r(k).gt. 4.*xDi) then
- lamr = 1./ilamr(k)
- pri_rci(k) = rhof(k)*t1_qr_qi*Ef_ri*ri(k)*N0_r(k) &
- *((lamr+fv_r)**(-cre(9)))
- pnr_rci(k) = rhof(k)*t1_qr_qi*Ef_ri*ni(k)*N0_r(k) & ! RAIN2M
- *((lamr+fv_r)**(-cre(9)))
- pni_rci(k) = pri_rci(k) * oxmi
- prr_rci(k) = rhof(k)*t2_qr_qi*Ef_ri*ni(k)*N0_r(k) &
- *((lamr+fv_r)**(-cre(8)))
- prr_rci(k) = MIN(DBLE(rr(k)*odts), prr_rci(k))
- prg_rci(k) = pri_rci(k) + prr_rci(k)
- endif
- endif
-
-!..Ice multiplication from rime-splinters (Hallet & Mossop 1974).
- if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then
- tf = 0.
- if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then
- tf = 0.5*(-3.0 - tempc)
- elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then
- tf = 0.33333333*(8.0 + tempc)
- endif
- pni_ihm(k) = 3.5E8*tf*prg_gcw(k)
- pri_ihm(k) = xm0i*pni_ihm(k)
- prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) &
- * pri_ihm(k)
- prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) &
- * pri_ihm(k)
- endif
-
-!..A portion of rimed snow converts to graupel but some remains snow.
-!.. Interp from 5 to 75% as riming factor increases from 5.0 to 30.0
-!.. 0.028 came from (.75-.05)/(30.-5.). This remains ad-hoc and should
-!.. be revisited.
- if (prs_scw(k).gt.5.0*prs_sde(k) .and. &
- prs_sde(k).gt.eps) then
- r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k))
- g_frac = MIN(0.75, 0.05 + (r_frac-5.)*.028)
- vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016)
- prg_scw(k) = g_frac*prs_scw(k)
- prs_scw(k) = (1. - g_frac)*prs_scw(k)
- endif
-
- else
-
-!..Melt snow and graupel and enhance from collisions with liquid.
-!.. We also need to sublimate snow and graupel if subsaturated.
- if (L_qs(k)) then
- prr_sml(k) = tempc*tcond(k)*(t1_qs_me*smo1(k) &
- + t2_qs_me*rhof2(k)*vsc2(k)*smof(k))
- prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
- * (prr_rcs(k)+prs_scw(k))
- prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k))
- pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.50*tempc) ! RAIN2M
- pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k))
- if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0
-
- if (ssati(k).lt. 0.) then
- prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- * (t1_qs_sd*smo1(k) &
- + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
- prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k))
- endif
- endif
-
- if (L_qg(k)) then
- prr_gml(k) = tempc*N0_g(k)*tcond(k) &
- *(t1_qg_me*ilamg(k)**cge(10) &
- + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11))
- prr_gml(k) = prr_gml(k) + 4218.*olfus*tempc &
- * (prr_rcg(k)+prg_gcw(k))
- prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k))
- pnr_gml(k) = (N0_g(k) / (cgg(1)*am_g*N0_g(k)/rg(k))**oge1) & ! RAIN2M
- / rg(k) * prr_gml(k) * 10.0**(-0.35*tempc)
- if (rg(k).lt.0.005E-3) pnr_gml(k)=0.0
-
- if (ssati(k).lt. 0.) then
- prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
- * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
- + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
- prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k))
- endif
- endif
-
- endif
-
- enddo
- endif
-
-!+---+-----------------------------------------------------------------+
-!..Ensure we do not deplete more hydrometeor species than exists.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
-
-!..If ice supersaturated, ensure sum of depos growth terms does not
-!.. deplete more vapor than possibly exists. If subsaturated, limit
-!.. sum of sublimation terms such that vapor does not reproduce ice
-!.. supersat again.
- sump = pri_inu(k) + pri_ide(k) + prs_ide(k) &
- + prs_sde(k) + prg_gde(k)
- rate_max = (qv(k)-qvsi(k))*odts*0.999
- if ( (sump.gt. eps .and. sump.gt. rate_max) .or. &
- (sump.lt. -eps .and. sump.lt. rate_max) ) then
- ratio = rate_max/sump
- pri_inu(k) = pri_inu(k) * ratio
- pri_ide(k) = pri_ide(k) * ratio
- pni_ide(k) = pni_ide(k) * ratio
- prs_ide(k) = prs_ide(k) * ratio
- prs_sde(k) = prs_sde(k) * ratio
- prg_gde(k) = prg_gde(k) * ratio
- endif
-
-!..Cloud water conservation.
- sump = -prr_wau(k) - pri_wfz(k) - prr_rcw(k) &
- - prs_scw(k) - prg_scw(k) - prg_gcw(k)
- rate_max = -rc(k)*odts
- if (sump.lt. rate_max .and. L_qc(k)) then
- ratio = rate_max/sump
- prr_wau(k) = prr_wau(k) * ratio
- pri_wfz(k) = pri_wfz(k) * ratio
- prr_rcw(k) = prr_rcw(k) * ratio
- prs_scw(k) = prs_scw(k) * ratio
- prg_scw(k) = prg_scw(k) * ratio
- prg_gcw(k) = prg_gcw(k) * ratio
- endif
-
-!..Cloud ice conservation.
- sump = pri_ide(k) - prs_iau(k) - prs_sci(k) &
- - pri_rci(k)
- rate_max = -ri(k)*odts
- if (sump.lt. rate_max .and. L_qi(k)) then
- ratio = rate_max/sump
- pri_ide(k) = pri_ide(k) * ratio
- prs_iau(k) = prs_iau(k) * ratio
- prs_sci(k) = prs_sci(k) * ratio
- pri_rci(k) = pri_rci(k) * ratio
- endif
-
-!..Rain conservation.
- sump = -prg_rfz(k) - pri_rfz(k) - prr_rci(k) &
- + prr_rcs(k) + prr_rcg(k)
- rate_max = -rr(k)*odts
- if (sump.lt. rate_max .and. L_qr(k)) then
- ratio = rate_max/sump
- prg_rfz(k) = prg_rfz(k) * ratio
- pri_rfz(k) = pri_rfz(k) * ratio
- prr_rci(k) = prr_rci(k) * ratio
- prr_rcs(k) = prr_rcs(k) * ratio
- prr_rcg(k) = prr_rcg(k) * ratio
- endif
-
-!..Snow conservation.
- sump = prs_sde(k) - prs_ihm(k) - prr_sml(k) &
- + prs_rcs(k)
- rate_max = -rs(k)*odts
- if (sump.lt. rate_max .and. L_qs(k)) then
- ratio = rate_max/sump
- prs_sde(k) = prs_sde(k) * ratio
- prs_ihm(k) = prs_ihm(k) * ratio
- prr_sml(k) = prr_sml(k) * ratio
- prs_rcs(k) = prs_rcs(k) * ratio
- endif
-
-!..Graupel conservation.
- sump = prg_gde(k) - prg_ihm(k) - prr_gml(k) &
- + prg_rcg(k)
- rate_max = -rg(k)*odts
- if (sump.lt. rate_max .and. L_qg(k)) then
- ratio = rate_max/sump
- prg_gde(k) = prg_gde(k) * ratio
- prg_ihm(k) = prg_ihm(k) * ratio
- prr_gml(k) = prr_gml(k) * ratio
- prg_rcg(k) = prg_rcg(k) * ratio
- endif
-
-!..Re-enforce proper mass conservation for subsequent elements in case
-!.. any of the above terms were altered. Thanks P. Blossey. 2009Sep28
- pri_ihm(k) = prs_ihm(k) + prg_ihm(k)
- ratio = MIN( ABS(prr_rcg(k)), ABS(prg_rcg(k)) )
- prr_rcg(k) = ratio * SIGN(1.0, SNGL(prr_rcg(k)))
- prg_rcg(k) = -prr_rcg(k)
- if (temp(k).lt.T_0) then
- prg_rcs(k) = prs_rcs(k) + prr_rcs(k)
- else
- ratio = MIN( ABS(prr_rcs(k)), ABS(prs_rcs(k)) )
- prr_rcs(k) = ratio * SIGN(1.0, SNGL(prr_rcs(k)))
- prs_rcs(k) = -prr_rcs(k)
- endif
-
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Calculate tendencies of all species but constrain the number of ice
-!.. to reasonable values.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- orho = 1./rho(k)
- lfus2 = lsub - lvap(k)
-
-!..Water vapor tendency
- qvten(k) = qvten(k) + (-pri_inu(k) - pri_ide(k) &
- - prs_ide(k) - prs_sde(k) - prg_gde(k)) &
- * orho
-
-!..Cloud water tendency
- qcten(k) = qcten(k) + (-prr_wau(k) - pri_wfz(k) &
- - prr_rcw(k) - prs_scw(k) - prg_scw(k) &
- - prg_gcw(k)) &
- * orho
-
-!..Cloud ice mixing ratio tendency
- qiten(k) = qiten(k) + (pri_inu(k) + pri_ihm(k) &
- + pri_wfz(k) + pri_rfz(k) + pri_ide(k) &
- - prs_iau(k) - prs_sci(k) - pri_rci(k)) &
- * orho
-
-!..Cloud ice number tendency.
- niten(k) = niten(k) + (pni_inu(k) + pni_ihm(k) &
- + pni_wfz(k) + pni_rfz(k) + pni_ide(k) &
- - pni_iau(k) - pni_sci(k) - pni_rci(k)) &
- * orho
-
-!..Cloud ice mass/number balance; keep mass-wt mean size between
-!.. 20 and 300 microns. Also no more than 500 xtals per liter.
- xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k))
- xni=MAX(1.,(ni1d(k) + niten(k)*dtsave)*rho(k))
- if (xri.gt. R1) then
- lami = (am_i*cig(2)*oig1*xni/xri)**obmi
- ilami = 1./lami
- xDi = (bm_i + mu_i + 1.) * ilami
- if (xDi.lt. 20.E-6) then
- lami = cie(2)/20.E-6
- xni = MIN(500.D3, cig(1)*oig2*xri/am_i*lami**bm_i)
- niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
- elseif (xDi.gt. 300.E-6) then
- lami = cie(2)/300.E-6
- xni = cig(1)*oig2*xri/am_i*lami**bm_i
- niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
- endif
- else
- niten(k) = -ni1d(k)*odts
- endif
- xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k))
- if (xni.gt.500.E3) &
- niten(k) = (500.E3-ni1d(k)*rho(k))*odts*orho
-
-!..Rain tendency
- qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) &
- + prr_sml(k) + prr_gml(k) + prr_rcs(k) &
- + prr_rcg(k) - prg_rfz(k) &
- - pri_rfz(k) - prr_rci(k)) &
- * orho
-
-!..Rain number tendency
- nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k) &
- - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k) &
- + pnr_rcs(k) + pnr_rci(k)) ) &
- * orho
-
-!..Rain mass/number balance; keep median volume diameter between
-!.. 37 microns (D0r*0.75) and 2.5 mm.
- xrr=MAX(R1,(qr1d(k) + qrten(k)*dtsave)*rho(k))
- xnr=MAX(1.,(nr1d(k) + nrten(k)*dtsave)*rho(k))
- if (xrr.gt. R1) then
- lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- if (mvd_r(k) .gt. 2.5E-3) then
- mvd_r(k) = 2.5E-3
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
- nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
- elseif (mvd_r(k) .lt. D0r*0.75) then
- mvd_r(k) = D0r*0.75
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
- nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
- endif
- else
- qrten(k) = -qr1d(k)*odts
- nrten(k) = -nr1d(k)*odts
- endif
-
-!..Snow tendency
- qsten(k) = qsten(k) + (prs_iau(k) + prs_sde(k) &
- + prs_sci(k) + prs_scw(k) + prs_rcs(k) &
- + prs_ide(k) - prs_ihm(k) - prr_sml(k)) &
- * orho
-
-!..Graupel tendency
- qgten(k) = qgten(k) + (prg_scw(k) + prg_rfz(k) &
- + prg_gde(k) + prg_rcg(k) + prg_gcw(k) &
- + prg_rci(k) + prg_rcs(k) - prg_ihm(k) &
- - prr_gml(k)) &
- * orho
-
-!..Temperature tendency
- if (temp(k).lt.T_0) then
- tten(k) = tten(k) &
- + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) &
- + prs_ide(k) + prs_sde(k) &
- + prg_gde(k)) &
- + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) &
- + prg_rfz(k) + prs_scw(k) &
- + prg_scw(k) + prg_gcw(k) &
- + prg_rcs(k) + prs_rcs(k) &
- + prr_rci(k) + prg_rcg(k)) &
- )*orho * (1-IFDRY)
- else
- tten(k) = tten(k) &
- + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) &
- - prr_rcg(k) - prr_rcs(k)) &
- + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) &
- )*orho * (1-IFDRY)
- endif
-
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Update variables for TAU+1 before condensation & sedimention.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- temp(k) = t1d(k) + DT*tten(k)
- otemp = 1./temp(k)
- tempc = temp(k) - 273.15
- qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
- rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
- rhof(k) = SQRT(RHO_NOT/rho(k))
- rhof2(k) = SQRT(rhof(k))
- qvs(k) = rslf(pres(k), temp(k))
- ssatw(k) = qv(k)/qvs(k) - 1.
- if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
- diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
- if (tempc .ge. 0.0) then
- visco(k) = (1.718+0.0049*tempc)*1.0E-5
- else
- visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5
- endif
- vsc2(k) = SQRT(rho(k)/visco(k))
- lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
- tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936
- ocp(k) = 1./(Cp*(1.+0.887*qv(k)))
- lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp
-
- if ((qc1d(k) + qcten(k)*DT) .gt. R1) then
- rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k)
- L_qc(k) = .true.
- else
- rc(k) = R1
- L_qc(k) = .false.
- endif
-
- if ((qi1d(k) + qiten(k)*DT) .gt. R1) then
- ri(k) = (qi1d(k) + qiten(k)*DT)*rho(k)
- ni(k) = MAX(1., (ni1d(k) + niten(k)*DT)*rho(k))
- L_qi(k) = .true.
- else
- ri(k) = R1
- ni(k) = 1.
- L_qi(k) = .false.
- endif
-
- if ((qr1d(k) + qrten(k)*DT) .gt. R1) then
- rr(k) = (qr1d(k) + qrten(k)*DT)*rho(k)
- nr(k) = MAX(1., (nr1d(k) + nrten(k)*DT)*rho(k))
- L_qr(k) = .true.
- lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- if (mvd_r(k) .gt. 2.5E-3) then
- mvd_r(k) = 2.5E-3
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
- elseif (mvd_r(k) .lt. D0r*0.75) then
- mvd_r(k) = D0r*0.75
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
- endif
- else
- rr(k) = R1
- nr(k) = 1.
- L_qr(k) = .false.
- endif
-
- if ((qs1d(k) + qsten(k)*DT) .gt. R1) then
- rs(k) = (qs1d(k) + qsten(k)*DT)*rho(k)
- L_qs(k) = .true.
- else
- rs(k) = R1
- L_qs(k) = .false.
- endif
-
- if ((qg1d(k) + qgten(k)*DT) .gt. R1) then
- rg(k) = (qg1d(k) + qgten(k)*DT)*rho(k)
- L_qg(k) = .true.
- else
- rg(k) = R1
- L_qg(k) = .false.
- endif
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..With tendency-updated mixing ratios, recalculate snow moments and
-!.. intercepts/slopes of graupel and rain.
-!+---+-----------------------------------------------------------------+
- if (.not. iiwarm) then
- do k = kts, kte
- if (.not. L_qs(k)) CYCLE
- tc0 = MIN(-0.1, temp(k)-273.15)
- smob(k) = rs(k)*oams
-
-!..All other moments based on reference, 2nd moment. If bm_s.ne.2,
-!.. then we must compute actual 2nd moment and use as reference.
- if (bm_s.gt.(2.0-1.e-3) .and. bm_s.lt.(2.0+1.e-3)) then
- smo2(k) = smob(k)
- else
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*bm_s &
- + sa(4)*tc0*bm_s + sa(5)*tc0*tc0 &
- + sa(6)*bm_s*bm_s + sa(7)*tc0*tc0*bm_s &
- + sa(8)*tc0*bm_s*bm_s + sa(9)*tc0*tc0*tc0 &
- + sa(10)*bm_s*bm_s*bm_s
- a_ = 10.0**loga_
- b_ = sb(1) + sb(2)*tc0 + sb(3)*bm_s &
- + sb(4)*tc0*bm_s + sb(5)*tc0*tc0 &
- + sb(6)*bm_s*bm_s + sb(7)*tc0*tc0*bm_s &
- + sb(8)*tc0*bm_s*bm_s + sb(9)*tc0*tc0*tc0 &
- + sb(10)*bm_s*bm_s*bm_s
- smo2(k) = (smob(k)/a_)**(1./b_)
- endif
-
-!..Calculate bm_s+1 (th) moment. Useful for diameter calcs.
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(1) &
- + sa(4)*tc0*cse(1) + sa(5)*tc0*tc0 &
- + sa(6)*cse(1)*cse(1) + sa(7)*tc0*tc0*cse(1) &
- + sa(8)*tc0*cse(1)*cse(1) + sa(9)*tc0*tc0*tc0 &
- + sa(10)*cse(1)*cse(1)*cse(1)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(1) + sb(4)*tc0*cse(1) &
- + sb(5)*tc0*tc0 + sb(6)*cse(1)*cse(1) &
- + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) &
- + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1)
- smoc(k) = a_ * smo2(k)**b_
-
-!..Calculate bm_s+bv_s (th) moment. Useful for sedimentation.
- loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) &
- + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 &
- + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) &
- + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 &
- + sa(10)*cse(14)*cse(14)*cse(14)
- a_ = 10.0**loga_
- b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) &
- + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) &
- + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) &
- + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14)
- smod(k) = a_ * smo2(k)**b_
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Calculate y-intercept, slope values for graupel.
-!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- N0_exp = (gonv_max-gonv_min)*0.5D0 &
- * tanh((0.01E-3-(rc(k)+rr(k)))/0.75E-3) &
- + (gonv_max+gonv_min)*0.5D0
- lam_exp = (N0_exp*am_g*cgg(1)/rg(k))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- ilamg(k) = 1./lamg
- N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
- enddo
-
- endif
-
-!+---+-----------------------------------------------------------------+
-!..Calculate y-intercept, slope values for rain.
-!+---+-----------------------------------------------------------------+
- do k = kte, kts, -1
- lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
- ilamr(k) = 1./lamr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- N0_r(k) = nr(k)*org2*lamr**cre(2)
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Cloud water condensation and evaporation. Newly formulated using
-!.. Newton-Raphson iterations (3 should suffice) as provided by B. Hall.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- if ( (ssatw(k).gt. eps) .or. (ssatw(k).lt. -eps .and. &
- L_qc(k)) ) then
- clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k))
- do n = 1, 3
- fcd = qvs(k)* EXP(lvt2(k)*clap) - qv(k) + clap
- dfcd = qvs(k)*lvt2(k)* EXP(lvt2(k)*clap) + 1.
- clap = clap - fcd/dfcd
- enddo
- xrc = rc(k) + clap
- if (xrc.gt. 0.0) then
- prw_vcd(k) = clap*odt
- else
- prw_vcd(k) = -rc(k)/rho(k)*odt
- endif
-
- qcten(k) = qcten(k) + prw_vcd(k)
- qvten(k) = qvten(k) - prw_vcd(k)
- tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)
- rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k))
- qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
- temp(k) = t1d(k) + DT*tten(k)
- rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
- qvs(k) = rslf(pres(k), temp(k))
- ssatw(k) = qv(k)/qvs(k) - 1.
- endif
- enddo
-
-!+---+-----------------------------------------------------------------+
-!.. If still subsaturated, allow rain to evaporate, following
-!.. Srivastava & Coen (1992).
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- if ( (ssatw(k).lt. -eps) .and. L_qr(k) &
- .and. (.not.(prw_vcd(k).gt. 0.)) ) then
- tempc = temp(k) - 273.15
- otemp = 1./temp(k)
- rhof(k) = SQRT(RHO_NOT/rho(k))
- rhof2(k) = SQRT(rhof(k))
- diffu(k) = 2.11E-5*(temp(k)/273.15)**1.94 * (101325./pres(k))
- if (tempc .ge. 0.0) then
- visco(k) = (1.718+0.0049*tempc)*1.0E-5
- else
- visco(k) = (1.718+0.0049*tempc-1.2E-5*tempc*tempc)*1.0E-5
- endif
- vsc2(k) = SQRT(rho(k)/visco(k))
- lvap(k) = lvap0 + (2106.0 - 4218.0)*tempc
- tcond(k) = (5.69 + 0.0168*tempc)*1.0E-5 * 418.936
- ocp(k) = 1./(Cp*(1.+0.887*qv(k)))
-
- rvs = rho(k)*qvs(k)
- rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.)
- rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) &
- *otemp*(lvap(k)*otemp*oRv - 1.) &
- + (-2.*lvap(k)*otemp*otemp*otemp*oRv) &
- + otemp*otemp)
- gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
- alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
- * rvs_pp/rvs_p * rvs/rvs_p
- alphsc = MAX(1.E-9, alphsc)
- xsat = ssatw(k)
- if (xsat.lt. -1.E-9) xsat = -1.E-9
- t1_evap = 2.*PI*( 1.0 - alphsc*xsat &
- + 2.*alphsc*alphsc*xsat*xsat &
- - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
- / (1.+gamsc)
-
- lamr = 1./ilamr(k)
- prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs &
- * (t1_qr_ev*ilamr(k)**cre(10) &
- + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11))))
- prv_rev(k) = MIN(DBLE(rr(k)/rho(k)*odts), &
- prv_rev(k)/rho(k))
- pnr_rev(k) = MIN(DBLE(nr(k)*0.99/rho(k)*odts), & ! RAIN2M
- prv_rev(k) * nr(k)/rr(k))
-
- qrten(k) = qrten(k) - prv_rev(k)
- qvten(k) = qvten(k) + prv_rev(k)
- nrten(k) = nrten(k) - pnr_rev(k)
- tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)
-
- rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k))
- qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
- nr(k) = MAX(1.,(nr1d(k) + DT*nrten(k))*rho(k))
- temp(k) = t1d(k) + DT*tten(k)
- rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
- endif
-
-!+---+-----------------------------------------------------------------+
-! if( debug_flag .and. k.lt.42) then
-! if (k.eq.1) write(mp_debug,*) 'DEBUG-GT: prg_scw, prg_rfz, prg_gde, prg_rcg, prg_gcw, prg_rci, prg_rcs, prg_ihm, prr_gml, rg, N0_g, ilamg'
-! if (k.eq.1) CALL wrf_debug(0, mp_debug)
-! write(mp_debug, 'a, i2, 1x, 12(1x,e13.6,1x)') ' GT,k= ', k, &
-! prg_scw(k), prg_rfz(k), prg_gde(k), prg_rcg(k), prg_gcw(k), &
-! prg_rci(k), prg_rcs(k), prg_ihm(k), prr_gml(k), &
-! rg(k), N0_g(k), ilamg(k)
-! CALL wrf_debug(0, mp_debug)
-! endif
-!+---+-----------------------------------------------------------------+
- enddo
-
-!+---+-----------------------------------------------------------------+
-!..Find max terminal fallspeed (distribution mass-weighted mean
-!.. velocity) and use it to determine if we need to split the timestep
-!.. (var nstep>1). Either way, only bother to do sedimentation below
-!.. 1st level that contains any sedimenting particles (k=ksed1 on down).
-!.. New in v3.0+ is computing separate for rain, ice, snow, and
-!.. graupel species thus making code faster with credit to J. Schmidt.
-!+---+-----------------------------------------------------------------+
- nstep = 0
- onstep(:) = 1.0
- ksed1(:) = 1
- do k = kte+1, kts, -1
- vtrk(k) = 0.
- vtnrk(k) = 0.
- vtik(k) = 0.
- vtnik(k) = 0.
- vtsk(k) = 0.
- vtgk(k) = 0.
- enddo
- do k = kte, kts, -1
- vtr = 0.
- rhof(k) = SQRT(RHO_NOT/rho(k))
-
- if (rr(k).gt. R2) then
- lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
- vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3) &
- *((lamr+fv_r)**(-cre(6)))
- vtrk(k) = vtr
-! First below is technically correct:
-! vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2) &
-! *((lamr+fv_r)**(-cre(5)))
-! Test: make number fall faster (but still slower than mass)
-! Goal: less prominent size sorting
- vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12) &
- *((lamr+fv_r)**(-cre(7)))
- vtnrk(k) = vtr
- endif
-
- if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then
- ksed1(1) = MAX(ksed1(1), k)
- delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k)))
- nstep = MAX(nstep, INT(DT/delta_tp + 1.))
- endif
- enddo
- if (ksed1(1) .eq. kte) ksed1(1) = kte-1
- if (nstep .gt. 0) onstep(1) = 1./REAL(nstep)
-
-!+---+-----------------------------------------------------------------+
-
- if (.not. iiwarm) then
-
- nstep = 0
- do k = kte, kts, -1
- vti = 0.
-
- if (ri(k).gt. R2) then
- lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
- ilami = 1./lami
- vti = rhof(k)*av_i*cig(3)*oig2 * ilami**bv_i
- vtik(k) = vti
- vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i
- vtnik(k) = vti
- endif
-
- if (vtik(k) .gt. 1.E-3) then
- ksed1(2) = MAX(ksed1(2), k)
- delta_tp = dzq(k)/vtik(k)
- nstep = MAX(nstep, INT(DT/delta_tp + 1.))
- endif
- enddo
- if (ksed1(2) .eq. kte) ksed1(2) = kte-1
- if (nstep .gt. 0) onstep(2) = 1./REAL(nstep)
-
-!+---+-----------------------------------------------------------------+
-
- nstep = 0
- do k = kte, kts, -1
- vts = 0.
-
- if (rs(k).gt. R2) then
- xDs = smoc(k) / smob(k)
- Mrat = 1./xDs
- ils1 = 1./(Mrat*Lam0 + fv_s)
- ils2 = 1./(Mrat*Lam1 + fv_s)
- t1_vts = Kap0*csg(4)*ils1**cse(4)
- t2_vts = Kap1*Mrat**mu_s*csg(10)*ils2**cse(10)
- ils1 = 1./(Mrat*Lam0)
- ils2 = 1./(Mrat*Lam1)
- t3_vts = Kap0*csg(1)*ils1**cse(1)
- t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7)
- vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts)
- if (temp(k).gt. T_0) then
- vtsk(k) = MAX(vts*vts_boost(k), vtrk(k))
- else
- vtsk(k) = vts*vts_boost(k)
- endif
- endif
-
- if (vtsk(k) .gt. 1.E-3) then
- ksed1(3) = MAX(ksed1(3), k)
- delta_tp = dzq(k)/vtsk(k)
- nstep = MAX(nstep, INT(DT/delta_tp + 1.))
- endif
- enddo
- if (ksed1(3) .eq. kte) ksed1(3) = kte-1
- if (nstep .gt. 0) onstep(3) = 1./REAL(nstep)
-
-!+---+-----------------------------------------------------------------+
-
- nstep = 0
- do k = kte, kts, -1
- vtg = 0.
-
- if (rg(k).gt. R2) then
- vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
- if (temp(k).gt. T_0) then
- vtgk(k) = MAX(vtg, vtrk(k))
- else
- vtgk(k) = vtg
- endif
- endif
-
- if (vtgk(k) .gt. 1.E-3) then
- ksed1(4) = MAX(ksed1(4), k)
- delta_tp = dzq(k)/vtgk(k)
- nstep = MAX(nstep, INT(DT/delta_tp + 1.))
- endif
- enddo
- if (ksed1(4) .eq. kte) ksed1(4) = kte-1
- if (nstep .gt. 0) onstep(4) = 1./REAL(nstep)
- endif
-
-!+---+-----------------------------------------------------------------+
-!..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD,
-!.. whereas neglect m(D) term for number concentration. Therefore,
-!.. cloud ice has proper differential sedimentation.
-!.. New in v3.0+ is computing separate for rain, ice, snow, and
-!.. graupel species thus making code faster with credit to J. Schmidt.
-!+---+-----------------------------------------------------------------+
-
- nstep = NINT(1./onstep(1))
- do n = 1, nstep
- do k = kte, kts, -1
- sed_r(k) = vtrk(k)*rr(k)
- sed_n(k) = vtnrk(k)*nr(k)
- enddo
- k = kte
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho
- nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho
- rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1))
- nr(k) = MAX(1., nr(k) - sed_n(k)*odzq*DT*onstep(1))
- do k = ksed1(1), kts, -1
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) &
- *odzq*onstep(1)*orho
- nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) &
- *odzq*onstep(1)*orho
- rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) &
- *odzq*DT*onstep(1))
- nr(k) = MAX(1., nr(k) + (sed_n(k+1)-sed_n(k)) &
- *odzq*DT*onstep(1))
- enddo
-
- pptrain = pptrain + sed_r(kts)*DT*onstep(1)
- enddo
-
-!+---+-----------------------------------------------------------------+
-
- nstep = NINT(1./onstep(2))
- do n = 1, nstep
- do k = kte, kts, -1
- sed_i(k) = vtik(k)*ri(k)
- sed_n(k) = vtnik(k)*ni(k)
- enddo
- k = kte
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho
- niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho
- ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2))
- ni(k) = MAX(1., ni(k) - sed_n(k)*odzq*DT*onstep(2))
- do k = ksed1(2), kts, -1
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) &
- *odzq*onstep(2)*orho
- niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) &
- *odzq*onstep(2)*orho
- ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) &
- *odzq*DT*onstep(2))
- ni(k) = MAX(1., ni(k) + (sed_n(k+1)-sed_n(k)) &
- *odzq*DT*onstep(2))
- enddo
-
- pptice = pptice + sed_i(kts)*DT*onstep(2)
- enddo
-
-!+---+-----------------------------------------------------------------+
-
- nstep = NINT(1./onstep(3))
- do n = 1, nstep
- do k = kte, kts, -1
- sed_s(k) = vtsk(k)*rs(k)
- enddo
- k = kte
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho
- rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3))
- do k = ksed1(3), kts, -1
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) &
- *odzq*onstep(3)*orho
- rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) &
- *odzq*DT*onstep(3))
- enddo
-
- pptsnow = pptsnow + sed_s(kts)*DT*onstep(3)
- enddo
-
-!+---+-----------------------------------------------------------------+
-
- nstep = NINT(1./onstep(4))
- do n = 1, nstep
- do k = kte, kts, -1
- sed_g(k) = vtgk(k)*rg(k)
- enddo
- k = kte
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho
- rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4))
- do k = ksed1(4), kts, -1
- odzq = 1./dzq(k)
- orho = 1./rho(k)
- qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) &
- *odzq*onstep(4)*orho
- rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) &
- *odzq*DT*onstep(4))
- enddo
-
- pptgraul = pptgraul + sed_g(kts)*DT*onstep(4)
- enddo
-
-!+---+-----------------------------------------------------------------+
-!.. Instantly melt any cloud ice into cloud water if above 0C and
-!.. instantly freeze any cloud water found below HGFR.
-!+---+-----------------------------------------------------------------+
- if (.not. iiwarm) then
- do k = kts, kte
- xri = MAX(0.0, qi1d(k) + qiten(k)*DT)
- if ( (temp(k).gt. T_0) .and. (xri.gt. 0.0) ) then
- qcten(k) = qcten(k) + xri*odt
- qiten(k) = qiten(k) - xri*odt
- niten(k) = -ni1d(k)*odt
- tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY)
- endif
-
- xrc = MAX(0.0, qc1d(k) + qcten(k)*DT)
- if ( (temp(k).lt. HGFR) .and. (xrc.gt. 0.0) ) then
- lfus2 = lsub - lvap(k)
- qiten(k) = qiten(k) + xrc*odt
- niten(k) = niten(k) + xrc/xm0i * odt
- qcten(k) = qcten(k) - xrc*odt
- tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY)
- endif
- enddo
- endif
-
-!+---+-----------------------------------------------------------------+
-!.. All tendencies computed, apply and pass back final values to parent.
-!+---+-----------------------------------------------------------------+
- do k = kts, kte
- t1d(k) = t1d(k) + tten(k)*DT
- qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT)
- qc1d(k) = qc1d(k) + qcten(k)*DT
- if (qc1d(k) .le. R1) qc1d(k) = 0.0
- qi1d(k) = qi1d(k) + qiten(k)*DT
- ni1d(k) = ni1d(k) + niten(k)*DT
- if (qi1d(k) .le. R1) then
- qi1d(k) = 0.0
- ni1d(k) = 0.0
- else
- if (ni1d(k) .gt. 1.0) then
- lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi
- ilami = 1./lami
- xDi = (bm_i + mu_i + 1.) * ilami
- if (xDi.lt. 20.E-6) then
- lami = cie(2)/20.E-6
- elseif (xDi.gt. 300.E-6) then
- lami = cie(2)/300.E-6
- endif
- else
- lami = cie(2)/D0s
- endif
- ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, &
- 500.D3/rho(k))
- endif
- qr1d(k) = qr1d(k) + qrten(k)*DT
- nr1d(k) = nr1d(k) + nrten(k)*DT
- if (qr1d(k) .le. R1) then
- qr1d(k) = 0.0
- nr1d(k) = 0.0
- else
- if (nr1d(k) .gt. 1.0) then
- lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr
- mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
- if (mvd_r(k) .gt. 2.5E-3) then
- mvd_r(k) = 2.5E-3
- elseif (mvd_r(k) .lt. D0r*0.75) then
- mvd_r(k) = D0r*0.75
- endif
- else
- if (qr1d(k) .gt. R2) then
- mvd_r(k) = 2.5E-3
- else
- mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k)))
- endif
- endif
- lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
- nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r
- endif
- qs1d(k) = qs1d(k) + qsten(k)*DT
- if (qs1d(k) .le. R1) qs1d(k) = 0.0
- qg1d(k) = qg1d(k) + qgten(k)*DT
- if (qg1d(k) .le. R1) qg1d(k) = 0.0
- enddo
-
- end subroutine mp_thompson
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Creation of the lookup tables and support functions found below here.
-!+---+-----------------------------------------------------------------+
-!..Rain collecting graupel (and inverse). Explicit CE integration.
-!+---+-----------------------------------------------------------------+
-
- subroutine qr_acr_qg
-
- implicit none
-
-!..Local variables
- INTEGER:: i, j, k, m, n, n2
- INTEGER:: km, km_s, km_e
- DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g
- DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r
- DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr
- DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2
-
-!+---+
-
- do n2 = 1, nbr
-! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
- vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) &
- + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) &
- - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2)
- enddo
- do n = 1, nbg
- vg(n) = av_g*Dg(n)**bv_g
- enddo
-
-!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
-!.. fortran indices. J. Michalakes, 2009Oct30.
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
- CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
-#else
- km_s = 0
- km_e = ntb_r*ntb_r1 - 1
-#endif
-
- do km = km_s, km_e
- m = km / ntb_r1 + 1
- k = mod( km , ntb_r1 ) + 1
-
- lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
- lamr = lam_exp * (crg(3)*org2*org1)**obmr
- N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
- do n2 = 1, nbr
- N_r(n2) = N0_r*Dr(n2)**mu_r *DEXP(-lamr*Dr(n2))*dtr(n2)
- enddo
-
- do j = 1, ntb_g
- do i = 1, ntb_g1
- lam_exp = (N0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1
- lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
- N0_g = N0g_exp(i)/(cgg(2)*lam_exp) * lamg**cge(2)
- do n = 1, nbg
- N_g(n) = N0_g*Dg(n)**mu_g * DEXP(-lamg*Dg(n))*dtg(n)
- enddo
-
- t1 = 0.0d0
- t2 = 0.0d0
- z1 = 0.0d0
- z2 = 0.0d0
- y1 = 0.0d0
- y2 = 0.0d0
- do n2 = 1, nbr
- massr = am_r * Dr(n2)**bm_r
- do n = 1, nbg
- massg = am_g * Dg(n)**bm_g
-
- dvg = 0.5d0*((vr(n2) - vg(n)) + DABS(vr(n2)-vg(n)))
- dvr = 0.5d0*((vg(n) - vr(n2)) + DABS(vg(n)-vr(n2)))
-
- t1 = t1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvg*massg * N_g(n)* N_r(n2)
- z1 = z1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvg*massr * N_g(n)* N_r(n2)
- y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvg * N_g(n)* N_r(n2)
-
- t2 = t2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvr*massr * N_g(n)* N_r(n2)
- y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvr * N_g(n)* N_r(n2)
- z2 = z2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
- *dvr*massg * N_g(n)* N_r(n2)
- enddo
- 97 continue
- enddo
- tcg_racg(i,j,k,m) = t1
- tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0)
- tcr_gacr(i,j,k,m) = t2
- tmg_gacr(i,j,k,m) = z2
- tnr_racg(i,j,k,m) = y1
- tnr_gacr(i,j,k,m) = y2
- enddo
- enddo
- enddo
-
-!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30).
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
- CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
-#endif
-
-
- end subroutine qr_acr_qg
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Rain collecting snow (and inverse). Explicit CE integration.
-!+---+-----------------------------------------------------------------+
-
- subroutine qr_acr_qs
-
- implicit none
-
-!..Local variables
- INTEGER:: i, j, k, m, n, n2
- INTEGER:: km, km_s, km_e
- DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r
- DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s
- DOUBLE PRECISION:: loga_, a_, b_, second, M0, M2, M3, Mrat, oM3
- DOUBLE PRECISION:: N0_r, lam_exp, lamr, slam1, slam2
- DOUBLE PRECISION:: dvs, dvr, masss, massr
- DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4
- DOUBLE PRECISION:: y1, y2, y3, y4
-
-!+---+
-
- do n2 = 1, nbr
-! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
- vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) &
- + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) &
- - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2)
- D1(n2) = (vr(n2)/av_s)**(1./bv_s)
- enddo
- do n = 1, nbs
- vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n))
- enddo
-
-!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
-!.. fortran indices. J. Michalakes, 2009Oct30.
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
- CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
-#else
- km_s = 0
- km_e = ntb_r*ntb_r1 - 1
-#endif
-
- do km = km_s, km_e
- m = km / ntb_r1 + 1
- k = mod( km , ntb_r1 ) + 1
-
- lam_exp = (N0r_exp(k)*am_r*crg(1)/r_r(m))**ore1
- lamr = lam_exp * (crg(3)*org2*org1)**obmr
- N0_r = N0r_exp(k)/(crg(2)*lam_exp) * lamr**cre(2)
- do n2 = 1, nbr
- N_r(n2) = N0_r*Dr(n2)**mu_r * DEXP(-lamr*Dr(n2))*dtr(n2)
- enddo
-
- do j = 1, ntb_t
- do i = 1, ntb_s
-
-!..From the bm_s moment, compute plus one moment. If we are not
-!.. using bm_s=2, then we must transform to the pure 2nd moment
-!.. (variable called "second") and then to the bm_s+1 moment.
-
- M2 = r_s(i)*oams *1.0d0
- if (bm_s.gt.2.0-1.E-3 .and. bm_s.lt.2.0+1.E-3) then
- loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*bm_s &
- + sa(4)*Tc(j)*bm_s + sa(5)*Tc(j)*Tc(j) &
- + sa(6)*bm_s*bm_s + sa(7)*Tc(j)*Tc(j)*bm_s &
- + sa(8)*Tc(j)*bm_s*bm_s + sa(9)*Tc(j)*Tc(j)*Tc(j) &
- + sa(10)*bm_s*bm_s*bm_s
- a_ = 10.0**loga_
- b_ = sb(1) + sb(2)*Tc(j) + sb(3)*bm_s &
- + sb(4)*Tc(j)*bm_s + sb(5)*Tc(j)*Tc(j) &
- + sb(6)*bm_s*bm_s + sb(7)*Tc(j)*Tc(j)*bm_s &
- + sb(8)*Tc(j)*bm_s*bm_s + sb(9)*Tc(j)*Tc(j)*Tc(j) &
- + sb(10)*bm_s*bm_s*bm_s
- second = (M2/a_)**(1./b_)
- else
- second = M2
- endif
-
- loga_ = sa(1) + sa(2)*Tc(j) + sa(3)*cse(1) &
- + sa(4)*Tc(j)*cse(1) + sa(5)*Tc(j)*Tc(j) &
- + sa(6)*cse(1)*cse(1) + sa(7)*Tc(j)*Tc(j)*cse(1) &
- + sa(8)*Tc(j)*cse(1)*cse(1) + sa(9)*Tc(j)*Tc(j)*Tc(j) &
- + sa(10)*cse(1)*cse(1)*cse(1)
- a_ = 10.0**loga_
- b_ = sb(1)+sb(2)*Tc(j)+sb(3)*cse(1) + sb(4)*Tc(j)*cse(1) &
- + sb(5)*Tc(j)*Tc(j) + sb(6)*cse(1)*cse(1) &
- + sb(7)*Tc(j)*Tc(j)*cse(1) + sb(8)*Tc(j)*cse(1)*cse(1) &
- + sb(9)*Tc(j)*Tc(j)*Tc(j)+sb(10)*cse(1)*cse(1)*cse(1)
- M3 = a_ * second**b_
-
- oM3 = 1./M3
- Mrat = M2*(M2*oM3)*(M2*oM3)*(M2*oM3)
- M0 = (M2*oM3)**mu_s
- slam1 = M2 * oM3 * Lam0
- slam2 = M2 * oM3 * Lam1
-
- do n = 1, nbs
- N_s(n) = Mrat*(Kap0*DEXP(-slam1*Ds(n)) &
- + Kap1*M0*Ds(n)**mu_s * DEXP(-slam2*Ds(n)))*dts(n)
- enddo
-
- t1 = 0.0d0
- t2 = 0.0d0
- t3 = 0.0d0
- t4 = 0.0d0
- z1 = 0.0d0
- z2 = 0.0d0
- z3 = 0.0d0
- z4 = 0.0d0
- y1 = 0.0d0
- y2 = 0.0d0
- y3 = 0.0d0
- y4 = 0.0d0
- do n2 = 1, nbr
- massr = am_r * Dr(n2)**bm_r
- do n = 1, nbs
- masss = am_s * Ds(n)**bm_s
-
- dvs = 0.5d0*((vr(n2) - vs(n)) + DABS(vr(n2)-vs(n)))
- dvr = 0.5d0*((vs(n) - vr(n2)) + DABS(vs(n)-vr(n2)))
-
- if (massr .gt. 2.5*masss) then
- t1 = t1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs*masss * N_s(n)* N_r(n2)
- z1 = z1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs*massr * N_s(n)* N_r(n2)
- y1 = y1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs * N_s(n)* N_r(n2)
- else
- t3 = t3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs*masss * N_s(n)* N_r(n2)
- z3 = z3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs*massr * N_s(n)* N_r(n2)
- y3 = y3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvs * N_s(n)* N_r(n2)
- endif
-
- if (massr .gt. 2.5*masss) then
- t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr*massr * N_s(n)* N_r(n2)
- y2 = y2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr * N_s(n)* N_r(n2)
- z2 = z2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr*masss * N_s(n)* N_r(n2)
- else
- t4 = t4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr*massr * N_s(n)* N_r(n2)
- y4 = y4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr * N_s(n)* N_r(n2)
- z4 = z4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
- *dvr*masss * N_s(n)* N_r(n2)
- endif
-
- enddo
- enddo
- tcs_racs1(i,j,k,m) = t1
- tmr_racs1(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0)
- tcs_racs2(i,j,k,m) = t3
- tmr_racs2(i,j,k,m) = z3
- tcr_sacr1(i,j,k,m) = t2
- tms_sacr1(i,j,k,m) = z2
- tcr_sacr2(i,j,k,m) = t4
- tms_sacr2(i,j,k,m) = z4
- tnr_racs1(i,j,k,m) = y1
- tnr_racs2(i,j,k,m) = y3
- tnr_sacr1(i,j,k,m) = y2
- tnr_sacr2(i,j,k,m) = y4
- enddo
- enddo
- enddo
-
-!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30).
-
-#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
- CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
- CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
-#endif
-
-
- end subroutine qr_acr_qs
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..This is a literal adaptation of Bigg (1954) probability of drops of
-!..a particular volume freezing. Given this probability, simply freeze
-!..the proportion of drops summing their masses.
-!+---+-----------------------------------------------------------------+
-
- subroutine freezeH2O
-
- implicit none
-
-!..Local variables
- INTEGER:: i, j, k, n, n2
- DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr
- DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc
- DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, &
- prob, vol, Texp, orho_w, &
- lam_exp, lamr, N0_r, lamc, N0_c, y
-
-!+---+
-
- orho_w = 1./rho_w
-
- do n2 = 1, nbr
- massr(n2) = am_r*Dr(n2)**bm_r
- enddo
- do n = 1, nbc
- massc(n) = am_r*Dc(n)**bm_r
- enddo
-
-!..Freeze water (smallest drops become cloud ice, otherwise graupel).
- do k = 1, 45
-! print*, ' Freezing water for temp = ', -k
- Texp = DEXP( DFLOAT(k) ) - 1.0D0
- do j = 1, ntb_r1
- do i = 1, ntb_r
- lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1
- lamr = lam_exp * (crg(3)*org2*org1)**obmr
- N0_r = N0r_exp(j)/(crg(2)*lam_exp) * lamr**cre(2)
- sum1 = 0.0d0
- sum2 = 0.0d0
- sumn1 = 0.0d0
- sumn2 = 0.0d0
- do n2 = 1, nbr
- N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2)
- vol = massr(n2)*orho_w
- prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)
- if (massr(n2) .lt. xm0g) then
- sumn1 = sumn1 + prob*N_r(n2)
- sum1 = sum1 + prob*N_r(n2)*massr(n2)
- else
- sumn2 = sumn2 + prob*N_r(n2)
- sum2 = sum2 + prob*N_r(n2)*massr(n2)
- endif
- enddo
- tpi_qrfz(i,j,k) = sum1
- tni_qrfz(i,j,k) = sumn1
- tpg_qrfz(i,j,k) = sum2
- tnr_qrfz(i,j,k) = sumn2
- enddo
- enddo
- do i = 1, ntb_c
- lamc = 1.0D-6 * (Nt_c*am_r* ccg(2) * ocg1 / r_c(i))**obmr
- N0_c = 1.0D-18 * Nt_c*ocg1 * lamc**cce(1)
- sum1 = 0.0d0
- sumn2 = 0.0d0
- do n = 1, nbc
- y = Dc(n)*1.0D6
- vol = massc(n)*orho_w
- prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)
- N_c(n) = N0_c* y**mu_c * EXP(-lamc*y)*dtc(n)
- N_c(n) = 1.0D24 * N_c(n)
- sumn2 = sumn2 + prob*N_c(n)
- sum1 = sum1 + prob*N_c(n)*massc(n)
- enddo
- tpi_qcfz(i,k) = sum1
- tni_qcfz(i,k) = sumn2
- enddo
- enddo
-
- end subroutine freezeH2O
-!+---+-----------------------------------------------------------------+
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Cloud ice converting to snow since portion greater than min snow
-!.. size. Given cloud ice content (kg/m**3), number concentration
-!.. (#/m**3) and gamma shape parameter, mu_i, break the distrib into
-!.. bins and figure out the mass/number of ice with sizes larger than
-!.. D0s. Also, compute incomplete gamma function for the integration
-!.. of ice depositional growth from diameter=0 to D0s. Amount of
-!.. ice depositional growth is this portion of distrib while larger
-!.. diameters contribute to snow growth (as in Harrington et al. 1995).
-!+---+-----------------------------------------------------------------+
-
- subroutine qi_aut_qs
-
- implicit none
-
-!..Local variables
- INTEGER:: i, j, n2
- DOUBLE PRECISION, DIMENSION(nbi):: N_i
- DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2
-
-!+---+
-
- do j = 1, ntb_i1
- do i = 1, ntb_i
- lami = (am_i*cig(2)*oig1*Nt_i(j)/r_i(i))**obmi
- Di_mean = (bm_i + mu_i + 1.) / lami
- N0_i = Nt_i(j)*oig1 * lami**cie(1)
- t1 = 0.0d0
- t2 = 0.0d0
- if (SNGL(Di_mean) .gt. 5.*D0s) then
- t1 = r_i(i)
- t2 = Nt_i(j)
- tpi_ide(i,j) = 0.0D0
- elseif (SNGL(Di_mean) .lt. D0i) then
- t1 = 0.0D0
- t2 = 0.0D0
- tpi_ide(i,j) = 1.0D0
- else
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
- tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=8)*D0s) * 1.0D0
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
- tpi_ide(i,j) = GAMMP(mu_i+2.0, REAL(lami,KIND=4)*D0s) * 1.0D0
-#else
-! This is a temporary hack assuming double precision is 8 bytes.
-#endif
- do n2 = 1, nbi
- N_i(n2) = N0_i*Di(n2)**mu_i * DEXP(-lami*Di(n2))*dti(n2)
- if (Di(n2).ge.D0s) then
- t1 = t1 + N_i(n2) * am_i*Di(n2)**bm_i
- t2 = t2 + N_i(n2)
- endif
- enddo
- endif
- tps_iaus(i,j) = t1
- tni_iaus(i,j) = t2
- enddo
- enddo
-
- end subroutine qi_aut_qs
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Variable collision efficiency for rain collecting cloud water using
-!.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise
-!.. uses polynomials to get close match of Pruppacher & Klett Fig 14-9.
-!+---+-----------------------------------------------------------------+
-
- subroutine table_Efrw
-
- implicit none
-
-!..Local variables
- DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw
- DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X
- INTEGER:: i, j
-
- do j = 1, nbc
- do i = 1, nbr
- Ef_rw = 0.0
- p = Dc(j)/Dr(i)
- if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then
- t_Efrw(i,j) = 0.0
- elseif (p.gt.0.25) then
- X = Dc(j)*1.D6
- if (Dr(i) .lt. 75.e-6) then
- Ef_rw = 0.026794*X - 0.20604
- elseif (Dr(i) .lt. 125.e-6) then
- Ef_rw = -0.00066842*X*X + 0.061542*X - 0.37089
- elseif (Dr(i) .lt. 175.e-6) then
- Ef_rw = 4.091e-06*X*X*X*X - 0.00030908*X*X*X &
- + 0.0066237*X*X - 0.0013687*X - 0.073022
- elseif (Dr(i) .lt. 250.e-6) then
- Ef_rw = 9.6719e-5*X*X*X - 0.0068901*X*X + 0.17305*X &
- - 0.65988
- elseif (Dr(i) .lt. 350.e-6) then
- Ef_rw = 9.0488e-5*X*X*X - 0.006585*X*X + 0.16606*X &
- - 0.56125
- else
- Ef_rw = 0.00010721*X*X*X - 0.0072962*X*X + 0.1704*X &
- - 0.46929
- endif
- else
- vtr = -0.1021 + 4.932E3*Dr(i) - 0.9551E6*Dr(i)*Dr(i) &
- + 0.07934E9*Dr(i)*Dr(i)*Dr(i) &
- - 0.002362E12*Dr(i)*Dr(i)*Dr(i)*Dr(i)
- stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i))
- reynolds = 9.*stokes/(p*p*rho_w)
-
- F = DLOG(reynolds)
- G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F
- K0 = DEXP(G)
- z = DLOG(stokes/(K0+1.D-15))
- H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z
- yc0 = 2.0D0/PI * ATAN(H)
- Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
-
- endif
-
- t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95))
-
- enddo
- enddo
-
- end subroutine table_Efrw
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Variable collision efficiency for snow collecting cloud water using
-!.. method of Wang and Ji, 2000 except equate melted snow diameter to
-!.. their "effective collision cross-section."
-!+---+-----------------------------------------------------------------+
-
- subroutine table_Efsw
-
- implicit none
-
-!..Local variables
- DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw
- DOUBLE PRECISION:: p, yc0, F, G, H, z, K0
- INTEGER:: i, j
-
- do j = 1, nbc
- vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0)
- do i = 1, nbs
- vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc
- Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr
- p = Dc(j)/Ds_m
- if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 &
- .or. vts.lt.1.E-3) then
- t_Efsw(i,j) = 0.0
- else
- stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m)
- reynolds = 9.*stokes/(p*p*rho_w)
-
- F = DLOG(reynolds)
- G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F
- K0 = DEXP(G)
- z = DLOG(stokes/(K0+1.D-15))
- H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z
- yc0 = 2.0D0/PI * ATAN(H)
- Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
-
- t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95))
- endif
-
- enddo
- enddo
-
- end subroutine table_Efsw
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!..Integrate rain size distribution from zero to D-star to compute the
-!.. number of drops smaller than D-star that evaporate in a single
-!.. timestep. Drops larger than D-star dont evaporate entirely so do
-!.. not affect number concentration.
-!+---+-----------------------------------------------------------------+
-
- subroutine table_dropEvap
-
- implicit none
-
-!..Local variables
- DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam
- INTEGER:: i, j, k
-
- do k = 1, ntb_r
- do j = 1, ntb_r1
- lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1
- lam = lam_exp * (crg(3)*org2*org1)**obmr
- N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2)
- Nt_r = N0 * crg(2) / lam**cre(2)
-
- do i = 1, nbr
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
- tnr_rev(i,j,k) = GAMMP(mu_r+1.0, REAL(Dr(i)*lam,KIND=8)) * Nt_r
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
- tnr_rev(i,j,k) = GAMMP(mu_r+1.0, REAL(Dr(i)*lam,KIND=4)) * Nt_r
-#else
-! This is a temporary hack assuming double precision is 8 bytes.
-#endif
- enddo
-
- enddo
- enddo
-
- end subroutine table_dropEvap
-
-! TO APPLY TABLE ABOVE
-!..Rain lookup table indexes.
-! Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) &
-! * 0.78*4.*diffu(k)*xsat*rvs/rho_w)
-! idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r) &
-! / DLOG(Dr(nbr)/D0r))
-! idx_d = MAX(1, MIN(idx_d, nbr))
-!
-! nir = NINT(ALOG10(rr(k)))
-! do nn = nir-1, nir+1
-! n = nn
-! if ( (rr(k)/10.**nn).ge.1.0 .and. &
-! (rr(k)/10.**nn).lt.10.0) goto 154
-! enddo
-!154 continue
-! idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
-! idx_r = MAX(1, MIN(idx_r, ntb_r))
-!
-! lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
-! lam_exp = lamr * (crg(3)*org2*org1)**bm_r
-! N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
-! nir = NINT(DLOG10(N0_exp))
-! do nn = nir-1, nir+1
-! n = nn
-! if ( (N0_exp/10.**nn).ge.1.0 .and. &
-! (N0_exp/10.**nn).lt.10.0) goto 155
-! enddo
-!155 continue
-! idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
-! idx_r1 = MAX(1, MIN(idx_r1, ntb_r1))
-!
-! pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) & ! RAIN2M
-! * odts))
-!
-!ctrlL
-!+---+-----------------------------------------------------------------+
-!+---+-----------------------------------------------------------------+
- SUBROUTINE GCF(GAMMCF,A,X,GLN)
-! --- RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS
-! --- CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS
-! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY
-! --- A MODIFIED LENTZ METHOD.
-! --- USES GAMMLN
- IMPLICIT NONE
- INTEGER, PARAMETER:: ITMAX=100
- REAL, PARAMETER:: gEPS=3.E-7
- REAL, PARAMETER:: FPMIN=1.E-30
- REAL, INTENT(IN):: A, X
- REAL:: GAMMCF,GLN
- INTEGER:: I
- REAL:: AN,B,C,D,DEL,H
- GLN=GAMMLN(A)
- B=X+1.-A
- C=1./FPMIN
- D=1./B
- H=D
- DO 11 I=1,ITMAX
- AN=-I*(I-A)
- B=B+2.
- D=AN*D+B
- IF(ABS(D).LT.FPMIN)D=FPMIN
- C=B+AN/C
- IF(ABS(C).LT.FPMIN)C=FPMIN
- D=1./D
- DEL=D*C
- H=H*DEL
- IF(ABS(DEL-1.).LT.gEPS)GOTO 1
- 11 CONTINUE
- PRINT *, 'A TOO LARGE, ITMAX TOO SMALL IN GCF'
- 1 GAMMCF=EXP(-X+A*LOG(X)-GLN)*H
- END SUBROUTINE GCF
-! (C) Copr. 1986-92 Numerical Recipes Software 2.02
-!+---+-----------------------------------------------------------------+
- SUBROUTINE GSER(GAMSER,A,X,GLN)
-! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS
-! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A))
-! --- AS GLN.
-! --- USES GAMMLN
- IMPLICIT NONE
- INTEGER, PARAMETER:: ITMAX=100
- REAL, PARAMETER:: gEPS=3.E-7
- REAL, INTENT(IN):: A, X
- REAL:: GAMSER,GLN
- INTEGER:: N
- REAL:: AP,DEL,SUM
- GLN=GAMMLN(A)
- IF(X.LE.0.)THEN
- IF(X.LT.0.) PRINT *, 'X < 0 IN GSER'
- GAMSER=0.
- RETURN
- ENDIF
- AP=A
- SUM=1./A
- DEL=SUM
- DO 11 N=1,ITMAX
- AP=AP+1.
- DEL=DEL*X/AP
- SUM=SUM+DEL
- IF(ABS(DEL).LT.ABS(SUM)*gEPS)GOTO 1
- 11 CONTINUE
- PRINT *,'A TOO LARGE, ITMAX TOO SMALL IN GSER'
- 1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN)
- END SUBROUTINE GSER
-! (C) Copr. 1986-92 Numerical Recipes Software 2.02
-!+---+-----------------------------------------------------------------+
- REAL FUNCTION GAMMLN(XX)
-! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0.
- IMPLICIT NONE
- REAL, INTENT(IN):: XX
- DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0
- DOUBLE PRECISION, DIMENSION(6), PARAMETER:: &
- COF = (/76.18009172947146D0, -86.50532032941677D0, &
- 24.01409824083091D0, -1.231739572450155D0, &
- .1208650973866179D-2, -.5395239384953D-5/)
- DOUBLE PRECISION:: SER,TMP,X,Y
- INTEGER:: J
-
- X=XX
- Y=X
- TMP=X+5.5D0
- TMP=(X+0.5D0)*LOG(TMP)-TMP
- SER=1.000000000190015D0
- DO 11 J=1,6
- Y=Y+1.D0
- SER=SER+COF(J)/Y
-11 CONTINUE
- GAMMLN=TMP+LOG(STP*SER/X)
- END FUNCTION GAMMLN
-! (C) Copr. 1986-92 Numerical Recipes Software 2.02
-!+---+-----------------------------------------------------------------+
- REAL FUNCTION GAMMP(A,X)
-! --- COMPUTES THE INCOMPLETE GAMMA FUNCTION P(A,X)
-! --- SEE ABRAMOWITZ AND STEGUN 6.5.1
-! --- USES GCF,GSER
- IMPLICIT NONE
- REAL, INTENT(IN):: A,X
- REAL:: GAMMCF,GAMSER,GLN
- GAMMP = 0.
- IF((X.LT.0.) .OR. (A.LE.0.)) THEN
- PRINT *, 'BAD ARGUMENTS IN GAMMP'
- RETURN
- ELSEIF(X.LT.A+1.)THEN
- CALL GSER(GAMSER,A,X,GLN)
- GAMMP=GAMSER
- ELSE
- CALL GCF(GAMMCF,A,X,GLN)
- GAMMP=1.-GAMMCF
- ENDIF
- END FUNCTION GAMMP
-! (C) Copr. 1986-92 Numerical Recipes Software 2.02
-!+---+-----------------------------------------------------------------+
- REAL FUNCTION WGAMMA(y)
-
- IMPLICIT NONE
- REAL, INTENT(IN):: y
-
- WGAMMA = EXP(GAMMLN(y))
-
- END FUNCTION WGAMMA
-!+---+-----------------------------------------------------------------+
-! THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS
-! A FUNCTION OF TEMPERATURE AND PRESSURE
-!
- REAL FUNCTION RSLF(P,T)
-
- IMPLICIT NONE
- REAL, INTENT(IN):: P, T
- REAL:: ESL,X
- REAL, PARAMETER:: C0= .611583699E03
- REAL, PARAMETER:: C1= .444606896E02
- REAL, PARAMETER:: C2= .143177157E01
- REAL, PARAMETER:: C3= .264224321E-1
- REAL, PARAMETER:: C4= .299291081E-3
- REAL, PARAMETER:: C5= .203154182E-5
- REAL, PARAMETER:: C6= .702620698E-8
- REAL, PARAMETER:: C7= .379534310E-11
- REAL, PARAMETER:: C8=-.321582393E-13
-
- X=MAX(-80.,T-273.16)
-
-! ESL=612.2*EXP(17.67*X/(T-29.65))
- ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
- RSLF=.622*ESL/(P-ESL)
-
-! ALTERNATIVE
-! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
-! supercooled water for atmospheric applications, Q. J. R.
-! Meteorol. Soc (2005), 131, pp. 1539-1565.
-! ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
-! + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
-! / T - 9.44523 * ALOG(T) + 0.014025 * T))
-
- END FUNCTION RSLF
-!+---+-----------------------------------------------------------------+
-! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR MIXING RATIO AS A
-! FUNCTION OF TEMPERATURE AND PRESSURE
-!
- REAL FUNCTION RSIF(P,T)
-
- IMPLICIT NONE
- REAL, INTENT(IN):: P, T
- REAL:: ESI,X
- REAL, PARAMETER:: C0= .609868993E03
- REAL, PARAMETER:: C1= .499320233E02
- REAL, PARAMETER:: C2= .184672631E01
- REAL, PARAMETER:: C3= .402737184E-1
- REAL, PARAMETER:: C4= .565392987E-3
- REAL, PARAMETER:: C5= .521693933E-5
- REAL, PARAMETER:: C6= .307839583E-7
- REAL, PARAMETER:: C7= .105785160E-9
- REAL, PARAMETER:: C8= .161444444E-12
-
- X=MAX(-80.,T-273.16)
- ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
- RSIF=.622*ESI/(P-ESI)
-
-! ALTERNATIVE
-! ; Source: Murphy and Koop, Review of the vapour pressure of ice and
-! supercooled water for atmospheric applications, Q. J. R.
-! Meteorol. Soc (2005), 131, pp. 1539-1565.
-! ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T)
-
- END FUNCTION RSIF
-!+---+-----------------------------------------------------------------+
-
-!+---+-----------------------------------------------------------------+
-END MODULE module_mp_thompson
-!+---+-----------------------------------------------------------------+
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_constants.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_constants.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_constants.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,31 +0,0 @@
-!==============================================================================
- MODULE module_physics_constants
- USE constants, R_d => rgas, g => gravity
-
- IMPLICIT NONE
- SAVE
-
-!DESCRIPTION:
-!This module defines the constants needed for the physics parameterizations.
-
-!==============================================================================
-
- REAL(KIND=RKIND),PARAMETER:: P0 = 100000.
- REAL(KIND=RKIND),PARAMETER:: R_v = 461.6
- REAL(KIND=RKIND),PARAMETER:: ep_1 = R_v/R_d-1.
- REAL(KIND=RKIND),PARAMETER:: ep_2 = R_d/R_v
- REAL(KIND=RKIND),PARAMETER:: rcp = r_d/cp
-
- REAL(KIND=RKIND),PARAMETER:: svp1 = 0.6112
- REAL(KIND=RKIND),PARAMETER:: svp2 = 17.67
- REAL(KIND=RKIND),PARAMETER:: svp3 = 29.65
- REAL(KIND=RKIND),PARAMETER:: svpt0 = 273.15
-
- REAL(KIND=RKIND),PARAMETER:: xlv0 = 3.15e6
- REAL(KIND=RKIND),PARAMETER:: xlv1 = 2370.
- REAL(KIND=RKIND),PARAMETER:: xls0 = 2.905e6
- REAL(KIND=RKIND),PARAMETER:: xls1 = 259.532
-
-!==============================================================================
- END MODULE module_physics_constants
-!==============================================================================
\ No newline at end of file
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_driver.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,381 +0,0 @@
-!==============================================================================
- MODULE module_physics_driver
- USE grid_types
- USE constants
-
- USE module_cu_kfeta
- USE module_mp_thompson
- USE module_physics_constants
- USE module_physics_manager
- USE module_physics_vars
-
- IMPLICIT NONE
- PRIVATE
- PUBLIC:: physics_driver
-
- CONTAINS
-
-!==============================================================================
- SUBROUTINE physics_driver(domain,itimestep)
-!==============================================================================
-
-!INPUT ARGUMENTS:
-!----------------
- INTEGER,INTENT(in):: itimestep
-
-!INOUT ARGUMENTS:
-!----------------
- TYPE(domain_type),INTENT(inout):: domain
-
-!LOCAL VARIABLES:
-!----------------
- TYPE(block_type),POINTER:: block
-
-!==============================================================================
-
- block => domain % blocklist
- DO WHILE(associated(block))
-
- !physics prep step:
- CALL physics_prep(block%mesh,block%time_levs(1)%state)
-
- !convection:
- CALL convection_driver(itimestep,block%mesh,block%time_levs(1)%state)
-
- !add all physics tendencies:
- CALL physics_add_tendencies
-
- block => block % next
- END DO
-
- END SUBROUTINE physics_driver
-
-!==============================================================================
- SUBROUTINE physics_prep(grid,vars)
-!==============================================================================
-
-!INPUT VARIABLES:
-!----------------
- TYPE(grid_meta),INTENT(in):: grid
- TYPE(grid_state),INTENT(in):: vars
-
-!LOCAL VARIABLES:
- INTEGER:: nCells,nCellsSolve,nLevels
- INTEGER:: i,itf,k,ktf,j,jtf
-
- REAL(KIND=RKIND):: tm
-
-!==============================================================================
- write(6,*) '--- enter SUBROUTINE PHYSICS_PREP:'
-
- nCells = grid%nCells
- nCellsSolve = grid%nCellsSolve
- nLevels = grid%nVertLevels
-
- write(6,*) ' nCells =', nCells
- write(6,*) ' nCellsSolve=', nCellsSolve
- write(6,*) ' nLevels =', nLevels
- write(6,*)
- write(6,*) ' IMS= ',ims,' IME=',ime
- write(6,*) ' JMS= ',jms,' JME=',jme
- write(6,*) ' KMS= ',kms,' KME=',kme
- write(6,*)
- write(6,*) ' IDS= ',ids,' IDE=',ide
- write(6,*) ' JDS= ',jds,' JDE=',jde
- write(6,*) ' KDS= ',kds,' KDE=',kde
- write(6,*)
- write(6,*) ' ITS= ',its,' ITE=',ite
- write(6,*) ' JTS= ',jts,' JTE=',jte
- write(6,*) ' KTS= ',kts,' KTE=',kte
-
-!INITIALIZATION:
- itf = ite
- jtf = jte
- ktf = kte-1
- write(6,*)
- write(6,*) ' ITS= ',its,' ITF=',itf
- write(6,*) ' JTS= ',jts,' JTF=',jtf
- write(6,*) ' KTS= ',kts,' KTF=',ktf
-
- DO j = jts,jtf
-
- DO k = kts,kte
- DO i = its,itf
- w_phy(i,k,j) = vars%w%array(k,i)
- ENDDO
- ENDDO
-
- DO k = kts,ktf
- DO i = its,itf
- u_phy(i,k,j) = vars%uReconstructZonal%array(k,i)
- v_phy(i,k,j) = vars%uReconstructMeridional%array(k,i)
-
- dz_phy(i,k,j) = (vars%geopotential%array(k+1,i) &
- - vars%geopotential%array(k,i)) / g
- p_phy(i,k,j) = (vars%pressure%array(k+1,i) &
- + vars%pressure%array(k,i)) / 2
- th_phy(i,k,j) = vars%theta%array(k,i)
- qv_phy(i,k,j) = vars%scalars%array(index_qv,k,i)
-
- pi_phy(i,k,j) = (p_phy(i,k,j)/p0)**(rgas/cp)
- t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
-
- tm = (1.+1.61*qv_phy(i,k,j))*th_phy(i,k,j)
- al_phy(i,k,j) = R_d/P0*tm*(p_phy(i,k,j)/P0)**cvpm
- rho_phy(i,k,j) = 1./al_phy(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-
- write(6,*) '--- end SUBROUTINE PHYSICS_PREP:'
-
-!FORMAT:
- 201 format(i3,1x,i6,i3,8(1x,e15.8))
-
- END SUBROUTINE physics_prep
-
-!==============================================================================
- SUBROUTINE convection_driver(itimestep,grid,vars,curr_secs,cudt, &
- adapt_step_flag)
-!==============================================================================
-
-!INPUT AND OUTPUT ARGUMENTS:
-!---------------------------
- LOGICAL,INTENT(in),OPTIONAL:: adapt_step_flag
- INTEGER,INTENT(in):: itimestep
- REAL(KIND=RKIND),INTENT(in),OPTIONAL:: cudt
- REAL(KIND=RKIND),INTENT(in),OPTIONAL:: curr_secs
-
- TYPE(grid_meta),INTENT(in):: grid
- TYPE(grid_state),INTENT(inout):: vars
-
-!LOCAL VARIABLES AND ARRAYS:
-!---------------------------
- LOGICAL:: log_convection
- LOGICAL:: adapt_step_flag_pass
- INTEGER:: iCell,nCells,nCellsSolve,nLevels
- INTEGER:: i,itf,k,ktf,j,jtf
- INTEGER:: icount
- REAL(KIND=RKIND):: dx
- REAL(KIND=RKIND):: cudt_pass,curr_secs_pass
-
-!==============================================================================
- write(6,*)
- write(6,*) '--- enter SUBROUTINE CONVECTION_DRIVER: dt_phys=',dt_cu
-
- nCells = grid%nCells
- nCellsSolve = grid%nCellsSolve
- nLevels = grid%nVertLevels
-
- write(6,*) '--- nCells =', nCells
- write(6,*) '--- nCellsSolve =', nCellsSolve
- write(6,*) '--- nLevels =', nLevels
-
- write(6,*) ' IMS= ',ims,' IME=',ime
- write(6,*) ' JMS= ',jms,' JME=',jme
- write(6,*) ' KMS= ',kms,' KME=',kme
- write(6,*)
- write(6,*) ' IDS= ',ids,' IDE=',ide
- write(6,*) ' JDS= ',jds,' JDE=',jde
- write(6,*) ' KDS= ',kds,' KDE=',kde
- write(6,*)
- write(6,*) ' ITS= ',its,' ITE=',ite
- write(6,*) ' JTS= ',jts,' JTE=',jte
- write(6,*) ' KTS= ',kts,' KTE=',kte
-
- itf = ite
- jtf = jte
- ktf = kte-1
- write(6,*)
- write(6,*) ' ITS= ',its,' ITF=',itf
- write(6,*) ' JTS= ',jts,' JTF=',jtf
- write(6,*) ' KTS= ',kts,' KTF=',ktf
-
-!INITIALIZATION:
- IF(.not. PRESENT(curr_secs)) THEN
- curr_secs_pass = -1
- ELSE
- curr_secs_pass = curr_secs
- ENDIF
- IF(.not. PRESENT(cudt)) THEN
- cudt_pass = -1
- ELSE
- cudt_pass = cudt
- ENDIF
- IF(.not. PRESENT(adapt_step_flag)) THEN
- adapt_step_flag_pass = .false.
- ELSE
- adapt_step_flag_pass = adapt_step_flag
- ENDIF
-
- dx = sqrt(maxval(grid%areaCell%array))
-
- write(6,*) 'curr_secs_pass =', curr_secs_pass
- write(6,*) 'cudt_pass =', cudt_pass
- write(6,*) 'adapt_step_flag_pass=', adapt_step_flag_pass
- write(6,*) 'dx =', dx
-
-!INITIALIZATION OF TIME-STEP PRECIPITATION VARIABLES ON THE GEODESIC GRID:
- DO iCell = 1, nCellsSolve
- vars%raincv%array(iCell) = 0.
- vars%pratec%array(iCell) = 0.
- ENDDO
-
-!COPY PHYSICS VARIABLES FROM THE GEODESIC GRID TO THE "WRF" GRID:
- DO j = jts, jtf
- DO i = its, itf
- nca_phy(i,j) = vars%nca%array(i)
- cubot_phy(i,j) = vars%cubot%array(i)
- cutop_phy(i,j) = vars%cutop%array(i)
- DO k = 1, nLevels
- w0avg_phy(i,k,j) = vars%w0avg%array(k,i)
- ENDDO
- ENDDO
- ENDDO
-
-!CALL TO KAIN-FRITSCH-ETA CONVECTION SCHEME:
- write(6,*)
- write(6,*) '--- begin subroutine KF_ETA_CPS:'
-
- CALL kf_eta_cps( &
- !WRF-like dimensions:
- ids,ide,jds,jde,kds,kde, &
- ims,ime,jms,jme,kms,kme, &
- its,itf,jts,jtf,kts,ktf, &
- dt_dyn,itimestep,dx,cudt_pass, &
- curr_secs_pass, &
- adapt_step_flag_pass, &
- rho_phy,raincv_phy,pratec_phy, &
- nca_phy, &
- u_phy,v_phy,th_phy,t_phy, &
- w_phy,dz_phy,p_phy,pi_phy, &
- w0avg_phy,xlv0,xlv1,xls0,xls1, &
- cp,R_d,g,ep_1,ep_2, &
- svp1,svp2,svp3,svpt0, &
- n_cu,cu_act_flag,warm_rain, &
- cutop_phy,cubot_phy,qv_phy, &
- f_qv,f_qc,f_qr,f_qi,f_qs, &
- rthcuten_phy,rqvcuten_phy, &
- rqccuten_phy,rqrcuten_phy, &
- rqicuten_phy,rqscuten_phy &
- )
-
- write(6,*) '--- end subroutine KF_ETA_CPS:'
- DO j = jts, jtf
- DO i = its, itf
- log_convection = .false.
- IF(cutop_phy(i,j) .GT. kts) THEN
- write(6,203) itimestep,j,i,cubot_phy(i,j),cutop_phy(i,j)
- log_convection = .true.
- IF(log_convection) THEN
- DO k = kts,ktf
- write(6,201) j,i,k,rthcuten_phy(i,k,j),rqvcuten_phy(i,k,j), &
- rqccuten_phy(i,k,j),rqrcuten_phy(i,k,j), &
- rqicuten_phy(i,k,j),rqscuten_phy(i,k,j)
- ENDDO
-! write(6,204) itimestep,j,i,raincv_phy(i,j),pratec_phy(i,j)
- ENDIF
- ENDIF
- ENDDO
- ENDDO
-
-!BACK TO DYNAMICAL CORE:
- DO j = jts, jtf
- DO k = kts, ktf
- DO i = its, itf
- vars%rthcuten%array(k,i) = rthcuten_phy(i,k,j)
- vars%rqvcuten%array(k,i) = rqvcuten_phy(i,k,j)
- vars%rqccuten%array(k,i) = rqccuten_phy(i,k,j)
- vars%rqrcuten%array(k,i) = rqrcuten_phy(i,k,j)
- vars%rqicuten%array(k,i) = rqicuten_phy(i,k,j)
- vars%rqscuten%array(k,i) = rqscuten_phy(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-
-!DIAGNOSTICS:
- DO i = its,itf
- DO j = jts,jtf
- vars%cubot%array(i) = cubot_phy(i,j)
- vars%cutop%array(i) = cutop_phy(i,j)
- vars%nca%array(i) = nca_phy(i,j)
- vars%pratec%array(i) = pratec_phy(i,j)
- vars%raincv%array(i) = raincv_phy(i,j)
- IF(vars%raincv%array(i) .GT. 0.) &
- write(6,204) itimestep,j,i,vars%raincv%array(i),raincv_phy(i,j)
- DO k = kts, ktf
- vars%w0avg%array(k,i) = w0avg_phy(i,k,j)
- ENDDO
- ENDDO
- vars%rainc%array(i) = vars%rainc%array(i) + vars%raincv%array(i)
- ENDDO
-
- write(6,*) '--- end SUBROUTINE CONVECTION_DRIVER:'
-
-!FORMAT:
- 201 FORMAT(i3,1x,i6,1x,i3,10(1x,e15.8))
- 202 FORMAT(2i6,10(1x,e15.8))
- 203 FORMAT('CONVECTION BEGINS:',3i6,2(1x,f6.1))
- 204 FORMAT('CONVECTIVE PRECIP:',3i6,2(1x,e15.8))
-
- END SUBROUTINE convection_driver
-
-!==============================================================================
- SUBROUTINE physics_add_tendencies
-!==============================================================================
-
-!LOCAL VARIABLES:
-!----------------
- INTEGER:: i,k,j
- INTEGER:: itf,ktf,jtf
-!==============================================================================
-
-!INITIALIZATION:
- itf = ite
- jtf = jte
- ktf = kte-1
-
-!POTENTIAL TEMPERATURE:
- DO j = jts,jte
- DO k = kts,kte
- DO i = its,ite
- rthten_phy(i,k,j) = rthten_phy(i,k,j) &
- + rthcuten_phy(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-
-!MIXING RATIOS:
- DO j = jts,jtf
- DO k = kts,ktf
- DO i = its,itf
- !water vapor:
- rqten_phy(i,k,j,index_qv) = rqten_phy(i,k,j,index_qv) &
- + rqvcuten_phy(i,k,j)
-
- !cloud water:
- rqten_phy(i,k,j,index_qc) = rqten_phy(i,k,j,index_qc) &
- + rqccuten_phy(i,k,j)
-
- !rain:
- rqten_phy(i,k,j,index_qr) = rqten_phy(i,k,j,index_qr) &
- + rqrcuten_phy(i,k,j)
-
- !cloud ice:
- rqten_phy(i,k,j,index_qi) = rqten_phy(i,k,j,index_qi) &
- + rqicuten_phy(i,k,j)
-
- !snow:
- rqten_phy(i,k,j,index_qs) = rqten_phy(i,k,j,index_qs) &
- + rqscuten_phy(i,k,j)
- ENDDO
- ENDDO
- ENDDO
-
-!NUMBER CONCENTRATIONS (none for now):
-
- END SUBROUTINE physics_add_tendencies
-
-!==============================================================================
- END MODULE module_physics_driver
-!==============================================================================
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_init.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_init.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_init.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,166 +0,0 @@
-!==============================================================================
- MODULE module_physics_init
- USE grid_types
- USE configure, only: restart => config_do_restart
-
- USE module_cu_kfeta
- USE module_mp_thompson
- USE module_physics_constants
- USE module_physics_vars
-
- IMPLICIT NONE
- PRIVATE
- PUBLIC:: physics_init
-
- CONTAINS
-
-!==============================================================================
- SUBROUTINE physics_init(grid,vars)
-!==============================================================================
-
-!INPUT AND OUTPUT ARGUMENTS:
-!---------------------------
- TYPE(grid_meta),INTENT(in):: grid
- TYPE(grid_state),INTENT(inout):: vars
-
-!LOCAL VARIABLES:
- INTEGER:: iCell,nCellsSolve,nVertLevels
- INTEGER:: i,k
-
-!==============================================================================
-
- nCellsSolve = grid%nCellsSolve
- nVertLevels = grid%nVertLevels
-
-!INITIALIZATION OF ARRAYS ON THE GEODESIC GRID:
-!IF(.not. config_do_restart) THEN
- IF(.not. restart) THEN
- DO iCell = 1, nCellsSolve
-
- !cloud microphysics:
- vars%rainnc%array(i) = 0.
- vars%snownc%array(i) = 0.
- vars%graupelnc%array(i) = 0.
- DO k = 1, nVertLevels
- vars%h_diabatic%array(k,i) = 0.
- ENDDO
-
- !convection:
- vars%nca%array(i) = 0.
- vars%cubot%array(i) = 0.
- vars%cutop%array(i) = 0.
- vars%pratec%array(i) = 0.
- vars%rainc%array(i) = 0.
- DO k = 1, nVertLevels
- vars%w0avg%array(k,i) = 0.
- vars%rthcuten%array(k,i) = 0.
- vars%rqvcuten%array(k,i) = 0.
- vars%rqccuten%array(k,i) = 0.
- vars%rqrcuten%array(k,i) = 0.
- vars%rqicuten%array(k,i) = 0.
- vars%rqscuten%array(k,i) = 0.
- ENDDO
-
- ENDDO
- ENDIF
-
-!INITIALIZATION OF PARAMETERIZED CONVECTIVE PROCESSES:
- CALL init_convection(grid,vars)
-
-!INITIALIZATION OF CLOUD MICROPHYSICS PROCESSES:
- write(6,*) '--- enter subroutine INIT_MICROPHYSICS:'
- CALL init_microphysics
- write(6,*) '--- end subroutine INIT_MICROPHYSICS:'
- write(6,*)
-
- END SUBROUTINE physics_init
-
-!==============================================================================
- SUBROUTINE init_convection(grid,vars)
-!==============================================================================
-
-!INPUT AND OUTPUT ARGUMENTS:
-!---------------------------
- TYPE(grid_meta),INTENT(in):: grid
- TYPE(grid_state),INTENT(inout):: vars
-
-!LOCAL VARIABLES AND ARRAYS:
-!---------------------------
-!LOGICAL:: allowed_to_read,restart
- LOGICAL:: allowed_to_read
- INTEGER:: i,k,j,p_qi,p_qs,p_first_scalar
-
-!==============================================================================
- write(6,*)
- write(6,*) '--- enter SUBROUTINE INIT_CONVECTION:'
- write(6,*) ' IMS= ',ims,' IME=',ime
- write(6,*) ' JMS= ',jms,' JME=',jme
- write(6,*) ' KMS= ',kms,' KME=',kme
- write(6,*)
- write(6,*) ' IDS= ',ids,' IDE=',ide
- write(6,*) ' JDS= ',jds,' JDE=',jde
- write(6,*) ' KDS= ',kds,' KDE=',kde
- write(6,*)
- write(6,*) ' ITS= ',its,' ITE=',ite
- write(6,*) ' JTS= ',jts,' JTE=',jte
- write(6,*) ' KTS= ',kts,' KTE=',kte
-
- allowed_to_read = .false.
- p_first_scalar = moist_start + 1
- p_qi = index_qi
- p_qs = index_qs
-
-!INITIALIZATION OF PHYSICS ARRAYS:
- DO j = jts, jte
- DO i = its, ite
- cutop_phy(i,j) = kts
- cubot_phy(i,j) = kte
- raincv_phy(i,j) = 0.0
- pratec_phy(i,j) = 0.0
- ENDDO
- ENDDO
-
-!INITIALIZATION OF KAIN-FRITSCH-ETA CONVECTION SCHEME:
- write(6,*)
- write(6,*) '--- enter subroutine KF_ETA_INIT:'
- CALL kf_eta_init(rthcuten_phy,rqvcuten_phy, &
- rqccuten_phy,rqrcuten_phy, &
- rqicuten_phy,rqscuten_phy, &
- nca_phy,w0avg_phy,p_qi,p_qs, &
- svp1,svp2,svp3,svpt0, &
- p_first_scalar,restart,allowed_to_read, &
- ids,ide,jds,jde,kds,kde, &
- ims,ime,jms,jme,kms,kme, &
- its,ite,jts,jte,kts,kte)
- write(6,*) '--- end subroutine KF_ETA_INIT:'
- write(6,*)
-
-!FORMAT:
- 201 FORMAT(i6,10(1x,e15.8))
-
- END SUBROUTINE init_convection
-
-!==============================================================================
- SUBROUTINE init_microphysics
-!==============================================================================
-
-!LOCAL VARIABLES:
-!----------------
- INTEGER:: i,j
-
-!==============================================================================
-
-!INITIALIZATION OF MICROPHYSICS ARRAYS:
- DO j = jts,jte
- DO i = its,ite
- rainncv_phy(i,j) = 0.0
- ENDDO
- ENDDO
-
- CALL thompson_init
-
- END SUBROUTINE init_microphysics
-
-!==============================================================================
- END MODULE module_physics_init
-!==============================================================================
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_manager.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_manager.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_manager.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,217 +0,0 @@
-!==============================================================================
- MODULE module_physics_manager
- USE configure
- USE grid_types
- USE module_physics_vars
-
- IMPLICIT NONE
- PRIVATE
- PUBLIC:: physics_timetracker,physics_wrf_allocate,physics_wrf_deallocate
-
- CONTAINS
-
-!==============================================================================
- SUBROUTINE physics_timetracker(itimestep,l_physics)
-!==============================================================================
-
-!INPUT ARGUMENTS:
-!----------------
- INTEGER,INTENT(in):: itimestep
-
-!INOUT ARGUMENTS:
-!----------------
- LOGICAL,INTENT(inout):: l_physics
-
-!==============================================================================
- write(6,*) '--- enter subroutine PHYSICS_TIMETRACKER'
- write(6,*) '--- itimestep=', itimestep
-
- if(mod(itimestep-1,config_n_physics) == 0) l_physics = .true.
- write(6,*) '--- PHYSICS_CONTROL:',itimestep,config_n_physics,l_physics
- write(6,*)
-
- END SUBROUTINE physics_timetracker
-
-!==============================================================================
- SUBROUTINE physics_wrf_allocate(grid)
-!==============================================================================
-
-!INPUT ARGUMENTS:
-!----------------
- TYPE(grid_meta),INTENT(in):: grid
-
-!==============================================================================
- write(6,*)
- write(6,*) '--- enter subroutine PHYSICS_WRF_ALLOCATE:'
-
-!INITIALIZATION OF WRF DIMENSIONS:
- ims=1 ; ime=grid%nCellsSolve
- jms=1 ; jme=1
- kms=1 ; kme=grid%nVertLevels+1
-
- ids=ims ; jds=jms ; kds=kms ; its=ims ; jts=jms ; kts=kms
- ide=ime ; jde=jme ; kde=kme ; ite=ime ; jte=jme ; kte=kme
-!ide=ime+1 ; jde=jme+1 ; kde=kme ; ite=ime ; jte=jme ; kte=kme
-
- write(6,*) ' IMS= ',ims,' IME=',ime
- write(6,*) ' JMS= ',jms,' JME=',jme
- write(6,*) ' KMS= ',kms,' KME=',kme
- write(6,*)
- write(6,*) ' IDS= ',ids,' IDE=',ide
- write(6,*) ' JDS= ',jds,' JDE=',jde
- write(6,*) ' KDS= ',kds,' KDE=',kde
- write(6,*)
- write(6,*) ' ITS= ',its,' ITE=',ite
- write(6,*) ' JTS= ',jts,' JTE=',jte
- write(6,*) ' KTS= ',kts,' KTE=',kte
-
-!INITIALIZATION OF PHYSICS, AND CONVECTION TIME-STEPS:
- dt_dyn = config_dt
- n_physics = config_n_physics
- n_microp = config_n_microp
- dt_physics = dt_dyn*n_physics
- dt_microp = nint(dt_dyn/n_microp)
-
-!ALLOCATION OF ALL PHYSICS ARRAYS:
- CALL physics_allocate_all
-
-!INITIALIZATION OF VARIABLES AND ALLOCATION OF ARRAYS RELATED TO MICROPHYSICS:
- CALL physics_allocate_microphysics
-
-!INITIALIZATION OF VARIABLES AND ALLOCATION OF ARRAYS RELATED TO CONVECTION:
- adapt_step_flag = .false.
- warm_rain = .false.
- cu_act_flag = .false.
- n_cu = n_physics !FOR NOW.
- dt_cu = dt_physics !FOR NOW.
-
- write(6,*) '--- end subroutine PHYSICS_WRF_ALLOCATE:'
- CALL physics_allocate_convection
-
- END SUBROUTINE physics_wrf_allocate
-
-!==============================================================================
- SUBROUTINE physics_allocate_all
-!==============================================================================
- IF(.NOT.ALLOCATED(u_phy) ) ALLOCATE(u_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(v_phy) ) ALLOCATE(v_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(w_phy) ) ALLOCATE(w_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(p_phy) ) ALLOCATE(p_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(pi_phy) ) ALLOCATE(pi_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(dz_phy) ) ALLOCATE(dz_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(t_phy) ) ALLOCATE(t_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(th_phy) ) ALLOCATE(th_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(al_phy) ) ALLOCATE(al_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(rho_phy) ) ALLOCATE(rho_phy(ims:ime,kms:kme,jms:jme) )
-
- IF(.NOT.ALLOCATED(qv_phy) ) ALLOCATE(qv_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qc_phy) ) ALLOCATE(qc_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qr_phy) ) ALLOCATE(qr_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qi_phy) ) ALLOCATE(qi_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qs_phy) ) ALLOCATE(qs_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qg_phy) ) ALLOCATE(qg_phy(ims:ime,kms:kme,jms:jme) )
-
- IF(.NOT.ALLOCATED(qnr_phy) ) ALLOCATE(qnr_phy(ims:ime,kms:kme,jms:jme) )
- IF(.NOT.ALLOCATED(qni_phy) ) ALLOCATE(qni_phy(ims:ime,kms:kme,jms:jme) )
-
- IF(.NOT.ALLOCATED(rthten_phy)) ALLOCATE(rthten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqten_phy) ) &
- ALLOCATE(rqten_phy(ims:ime,kms:kme,jms:jme,num_scalars) )
-
- END SUBROUTINE physics_allocate_all
-
-!==============================================================================
- SUBROUTINE physics_allocate_convection
-!==============================================================================
- IF(.NOT.ALLOCATED(cu_act_flag) ) ALLOCATE(cu_act_flag(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(cubot_phy) ) ALLOCATE(cubot_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(cutop_phy) ) ALLOCATE(cutop_phy(ims:ime,jms:jme) )
-
- IF(.NOT.ALLOCATED(raincv_phy) ) ALLOCATE(raincv_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(pratec_phy) ) ALLOCATE(pratec_phy(ims:ime,jms:jme) )
-
- IF(.NOT.ALLOCATED(nca_phy) ) ALLOCATE(nca_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(w0avg_phy) ) ALLOCATE(w0avg_phy(ims:ime,kms:kme,jms:jme))
-
- IF(.NOT.ALLOCATED(rthcuten_phy)) ALLOCATE(rthcuten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqvcuten_phy)) ALLOCATE(rqvcuten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqccuten_phy)) ALLOCATE(rqccuten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqrcuten_phy)) ALLOCATE(rqrcuten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqicuten_phy)) ALLOCATE(rqicuten_phy(ims:ime,kms:kme,jms:jme))
- IF(.NOT.ALLOCATED(rqscuten_phy)) ALLOCATE(rqscuten_phy(ims:ime,kms:kme,jms:jme))
-
- END SUBROUTINE physics_allocate_convection
-
-!==============================================================================
- SUBROUTINE physics_allocate_microphysics
-!==============================================================================
- IF(.NOT.ALLOCATED(sr_phy) ) ALLOCATE(sr_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(rainnc_phy) ) ALLOCATE(rainnc_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(rainncv_phy) ) ALLOCATE(rainncv_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(snownc_phy) ) ALLOCATE(snownc_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(snowncv_phy) ) ALLOCATE(snowncv_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(graupelnc_phy) ) ALLOCATE(graupelnc_phy(ims:ime,jms:jme) )
- IF(.NOT.ALLOCATED(graupelncv_phy)) ALLOCATE(graupelncv_phy(ims:ime,jms:jme) )
-
- END SUBROUTINE physics_allocate_microphysics
-
-!==============================================================================
- SUBROUTINE physics_wrf_deallocate
-!==============================================================================
-
-!DE-ALLOCATION OF ALL PHYSICS ARRAYS:
- IF(ALLOCATED(u_phy) ) DEALLOCATE(u_phy )
- IF(ALLOCATED(v_phy) ) DEALLOCATE(v_phy )
- IF(ALLOCATED(w_phy) ) DEALLOCATE(w_phy )
- IF(ALLOCATED(p_phy) ) DEALLOCATE(p_phy )
- IF(ALLOCATED(pi_phy) ) DEALLOCATE(pi_phy )
- IF(ALLOCATED(dz_phy) ) DEALLOCATE(dz_phy )
- IF(ALLOCATED(t_phy) ) DEALLOCATE(t_phy )
- IF(ALLOCATED(th_phy) ) DEALLOCATE(th_phy )
- IF(ALLOCATED(al_phy) ) DEALLOCATE(al_phy )
- IF(ALLOCATED(rho_phy) ) DEALLOCATE(rho_phy )
-
- IF(ALLOCATED(qv_phy) ) DEALLOCATE(qv_phy )
- IF(ALLOCATED(qc_phy) ) DEALLOCATE(qc_phy )
- IF(ALLOCATED(qr_phy) ) DEALLOCATE(qr_phy )
- IF(ALLOCATED(qi_phy) ) DEALLOCATE(qi_phy )
- IF(ALLOCATED(qs_phy) ) DEALLOCATE(qs_phy )
- IF(ALLOCATED(qg_phy) ) DEALLOCATE(qg_phy )
-
- IF(ALLOCATED(qnr_phy) ) DEALLOCATE(qnr_phy )
- IF(ALLOCATED(qni_phy) ) DEALLOCATE(qni_phy )
-
- IF(ALLOCATED(rthten_phy) ) DEALLOCATE(rthten_phy )
- IF(ALLOCATED(rqten_phy) ) DEALLOCATE(rqten_phy )
-
-!DEALLOCATE ARRAYS RELATED TO MICROPHYSICS:
- IF(ALLOCATED(sr_phy) ) DEALLOCATE(sr_phy )
- IF(ALLOCATED(rainnc_phy) ) DEALLOCATE(rainnc_phy )
- IF(ALLOCATED(rainncv_phy) ) DEALLOCATE(rainncv_phy )
- IF(ALLOCATED(snownc_phy) ) DEALLOCATE(snownc_phy )
- IF(ALLOCATED(snowncv_phy) ) DEALLOCATE(snowncv_phy )
- IF(ALLOCATED(graupelnc_phy) ) DEALLOCATE(graupelnc_phy )
- IF(ALLOCATED(graupelncv_phy)) DEALLOCATE(graupelncv_phy )
-
-!DEALLOCATE ARRAYS RELATED TO CONVECTION:
- IF(ALLOCATED(cu_act_flag) ) DEALLOCATE(cu_act_flag )
- IF(ALLOCATED(cubot_phy) ) DEALLOCATE(cubot_phy )
- IF(ALLOCATED(cutop_phy) ) DEALLOCATE(cutop_phy )
- IF(ALLOCATED(raincv_phy) ) DEALLOCATE(raincv_phy )
- IF(ALLOCATED(pratec_phy) ) DEALLOCATE(pratec_phy )
- IF(ALLOCATED(nca_phy) ) DEALLOCATE(nca_phy )
- IF(ALLOCATED(w0avg_phy) ) DEALLOCATE(w0avg_phy )
-
- IF(ALLOCATED(rthcuten_phy) ) DEALLOCATE(rthcuten_phy )
- IF(ALLOCATED(rqvcuten_phy) ) DEALLOCATE(rqvcuten_phy )
- IF(ALLOCATED(rqccuten_phy) ) DEALLOCATE(rqccuten_phy )
- IF(ALLOCATED(rqrcuten_phy) ) DEALLOCATE(rqrcuten_phy )
- IF(ALLOCATED(rqicuten_phy) ) DEALLOCATE(rqicuten_phy )
- IF(ALLOCATED(rqscuten_phy) ) DEALLOCATE(rqscuten_phy )
-
- END SUBROUTINE physics_wrf_deallocate
-
-!==============================================================================
- END MODULE module_physics_manager
-!==============================================================================
-
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_todynamics.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_todynamics.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_todynamics.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,124 +0,0 @@
-!==============================================================================
- MODULE module_physics_todynamics
- USE grid_types
- USE module_physics_vars
-
- IMPLICIT NONE
- PRIVATE
- PUBLIC:: physics_addtend
-
- CONTAINS
-
-!==============================================================================
- SUBROUTINE physics_init_tendencies
-!==============================================================================
-
- INTEGER:: n
-
-!==============================================================================
-
-!POTENTIAL TEMPERATURE:
- CALL zero_tend(rthten_phy)
-
-!MIXING RATIOS AND NUMBER CONCENTRATIONS:
- DO n = 1, num_scalars
- CALL zero_tend(rqten_phy(:,:,:,n))
- ENDDO
-
- END SUBROUTINE physics_init_tendencies
-
-!==============================================================================
- SUBROUTINE physics_addtend(tend,vars,grid)
-!==============================================================================
-
-!INPUT VARIABLES:
-!----------------
- TYPE(grid_meta),INTENT(in):: grid
- TYPE(grid_state),INTENT(in):: vars
-
-!INOUT VARIABLES:
-!----------------
- TYPE(grid_state),INTENT(inout):: tend
-
-!LOCAL VARIABLES:
-!----------------
- INTEGER:: iCell,nCellsSolve,nVertLevels
- INTEGER:: i,itf,iscalar,j,jtf,k,ktf
- REAL(KIND=RKIND),DIMENSION(:,:),POINTER:: h,h_diabatic
- REAL(KIND=RKIND),DIMENSION(:,:),POINTER:: rthcuten,rqvcuten,rqccuten, &
- rqrcuten,rqicuten,rqscuten
-
- REAL(KIND=RKIND),DIMENSION(:,:),POINTER :: tend_theta
- REAL(KIND=RKIND),DIMENSION(:,:,:),POINTER:: tend_scalars
-
-!==============================================================================
- write(6,*)
- write(6,*) '--- enter subroutine PHYSICS_ADD_TEND:'
-
- nCellsSolve = grid%nCellsSolve
- nVertLevels = grid%nVertLevels
-
- h => vars % h % array
- h_diabatic => vars % h_diabatic % array
- rthcuten => vars % rthcuten % array
- rqvcuten => vars % rqvcuten % array
- rqccuten => vars % rqccuten % array
- rqrcuten => vars % rqrcuten % array
- rqicuten => vars % rqicuten % array
- rqscuten => vars % rqscuten % array
-
- tend_theta => tend % theta % array
- tend_scalars => tend % scalars % array
-
-!INITIALIZATION:
- itf = ite
- jtf = jte
- ktf = kte-1
-
- tend_theta(:,:) = 0.0
- tend_scalars(:,:,:) = 0.0
-
-!ADD COUPLED POTENTIAL TEMPERATURE TENDENCY DUE TO CLOUD MICROPHYSICS ON
-!THE GEODESIC GRID:
- DO k = 1, nVertLevels
- DO iCell = 1, nCellsSolve
- tend_theta(k,i)=tend_theta(k,i)+h_diabatic(k,i)*h(k,i)
- ENDDO
- ENDDO
-
-!ADD COUPLED TENDENCIES DUE TO CONVECTION ON THE GEODESIC GRID:
- DO k = 1, nVertLevels
- DO iCell = 1, nCellsSolve
- tend_theta(k,i)=tend_theta(k,i)+rthcuten(k,i)*h(k,i)
- tend_scalars(index_qv,k,i)=tend_scalars(index_qv,k,i)+rqvcuten(k,i)*h(k,i)
- tend_scalars(index_qc,k,i)=tend_scalars(index_qc,k,i)+rqccuten(k,i)*h(k,i)
- tend_scalars(index_qr,k,i)=tend_scalars(index_qr,k,i)+rqrcuten(k,i)*h(k,i)
- tend_scalars(index_qi,k,i)=tend_scalars(index_qi,k,i)+rqicuten(k,i)*h(k,i)
- tend_scalars(index_qs,k,i)=tend_scalars(index_qs,k,i)+rqscuten(k,i)*h(k,i)
- ENDDO
- ENDDO
-
-!FORMATS:
- 201 format(i3,1x,i6,i3,8(1x,e15.8))
-
- END SUBROUTINE physics_addtend
-
-!==============================================================================
- SUBROUTINE zero_tend(tendency)
-!==============================================================================
- REAL(KIND=RKIND),INTENT(out),DIMENSION(ims:ime,kms:kme,jms:jme):: tendency
- INTEGER:: i,k,j
-
- DO j = jms,jme
- DO k = kms,kme
- DO i = ims,ime
- tendency(i,k,j) = 0.
- ENDDO
- ENDDO
- ENDDO
-
- END SUBROUTINE zero_tend
-
-!==============================================================================
- END MODULE module_physics_todynamics
-!==============================================================================
Deleted: branches/atmos_physics/src/core_hyd_phys/module_physics_vars.F
===================================================================
--- branches/atmos_physics/src/core_hyd_phys/module_physics_vars.F 2010-12-21 22:56:57 UTC (rev 659)
+++ branches/atmos_physics/src/core_hyd_phys/module_physics_vars.F 2010-12-21 23:01:03 UTC (rev 660)
@@ -1,101 +0,0 @@
-!==============================================================================
- MODULE module_physics_vars
-
- IMPLICIT NONE
- PUBLIC
- SAVE
-
-!WRF-VARIABLES: These variables are needed to keep calls to different physics
-!parameterizations as in WRF model.
- INTEGER,PUBLIC:: ids,ide,jds,jde,kds,kde
- INTEGER,PUBLIC:: ims,ime,jms,jme,kms,kme
- INTEGER,PUBLIC:: its,ite,jts,jte,kts,kte
- INTEGER,PUBLIC:: n_physics,n_microp
-
- REAL(KIND=RKIND),PUBLIC:: dt_dyn
- REAL(KIND=RKIND),PUBLIC:: dt_physics
- REAL(KIND=RKIND),PUBLIC:: dt_microp
-
-!... ARRAYS RELATED TO U- AND V-VELOCITIES INTERPOLATED TO THETA POINTS:
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- u_phy, &!u-velocity interpolated to theta points (m/s).
- v_phy !v-velocity interpolated to theta points (m/s).
-
-!... ARRAYS RELATED TO VERTICAL SOUNDING:
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- w_phy, &!vertical velocity (m/s).
- p_phy, &!pressure (Pa).
- pi_phy, &!(p_phy/P0)**(R_d/cp) (-).
- dz_phy, &!layer thickness (m).
- t_phy, &!temperature (K).
- th_phy, &!potential temperature (K).
- al_phy, &!inverse of air density (m3/kg).
- rho_phy !air density (kg/m3).
-
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- qv_phy, &!water vapor mixing ratio (kg/kg).
- qc_phy, &!cloud water mixing ratio (kg/kg).
- qr_phy, &!rain mixing ratio (kg/kg).
- qi_phy, &!cloud ice mixing ratio (kg/kg).
- qs_phy, &!snow mixing ratio (kg/kg).
- qg_phy !graupel mixing ratio (kg/kg).
-
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- qni_phy, &!number concentration for cloud ice (#/kg).
- qnr_phy !number concentration for rain (#/kg).
-
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- rthten_phy !total physics tendency for potential temperature (K/s).
-
- REAL(KIND=RKIND),DIMENSION(:,:,:,:),ALLOCATABLE:: &
- rqten_phy !total physics tendency for mixing ratio (kg/kg/s).
-
-!==============================================================================
-!... VARIABLES AND ARRAYS RELATED TO PARAMETERIZATION OF CLOUD MICROPHYSICS:
-!==============================================================================
- REAL(KIND=RKIND),DIMENSION(:,:),ALLOCATABLE:: &
- rainnc_phy, &!
- rainncv_phy, &!
- snownc_phy, &!
- snowncv_phy, &!
- graupelnc_phy, &!
- graupelncv_phy, &!
- sr_phy
-
-!==============================================================================
-!... VARIABLES AND ARRAYS RELATED TO PARAMETERIZATION OF CONVECTION:
-!==============================================================================
- LOGICAL,PUBLIC:: adapt_step_flag
- LOGICAL,PUBLIC:: warm_rain
- INTEGER,PUBLIC:: n_cu
- REAL(KIND=RKIND),PUBLIC:: dt_cu
-
- LOGICAL:: &
- f_qv, &!
- f_qc, &!
- f_qr, &!
- f_qi, &!
- f_qs, &!
- f_qg !
- LOGICAL,DIMENSION(:,:),ALLOCATABLE:: &
- cu_act_flag
- REAL(KIND=RKIND),DIMENSION(:,:),ALLOCATABLE:: &
- cubot_phy, &!lowest convective level (-).
- cutop_phy, &!highest convective level (-).
- nca_phy, &!counter for cloud relaxation time (-).
- raincv_phy, &!
- pratec_phy !
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- w0avg_phy !
-
- REAL(KIND=RKIND),DIMENSION(:,:,:),ALLOCATABLE:: &
- rthcuten_phy, &!
- rqvcuten_phy, &!
- rqccuten_phy, &!
- rqrcuten_phy, &!
- rqicuten_phy, &!
- rqscuten_phy
-
-!==============================================================================
- END MODULE module_physics_vars
-!==============================================================================
\ No newline at end of file
</font>
</pre>