!-----------------------------------------------------------------------
!
MODULE MODULE_MICROPHYSICS_NMM
!
!-----------------------------------------------------------------------
!
!*** THE MICROPHYSICS DRIVERS AND PACKAGES
! 11-06-2009 W. Wang put NAM micorphysics into a single module
! 02-10-2010 W. Wang added wsm6
!-----------------------------------------------------------------------
!
! HISTORY LOG:
!
! 11-06-2009 W. Wang - Put NAM/Ferrier microphysics into
! a single module.
!
!-----------------------------------------------------------------------
!
USE MODULE_INCLUDE
!
USE MODULE_CONSTANTS,ONLY : CICE,CLIQ,CPV,EP_1,EP_2,EPSILON,G &
,P608,PSAT,R_D,R_V,RHOAIR0,RHOWATER &
,SVPT0,XLF,XLV &
,CAPPA,CP,EPSQ
!
USE MODULE_CONTROL,ONLY : NMMB_FINALIZE
! MP options
USE MODULE_MP_ETANEW
USE MODULE_MP_FER_HIRES
USE MODULE_MP_WSM6
USE MODULE_MP_THOMPSON
USE MODULE_MP_GFS
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
PRIVATE
!
! PUBLIC :: FERRIER_INIT,FPVS,GSMDRIVE,WSM3INIT
PUBLIC :: GSMDRIVE
!
!-----------------------------------------------------------------------
!
INTEGER :: MYPE
REAL, PRIVATE,PARAMETER :: &
!--- Physical constants follow:
XLS=2.834E6,R_G=1./G
!
INTEGER,PUBLIC,PARAMETER :: MICRO_RESTART=7501
!
CONTAINS
!
!-----------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!-----------------------------------------------------------------------
SUBROUTINE GSMDRIVE(ITIMESTEP,DT,NPHS &
,DX,DY,SM,FIS &
,DSG2,SGML2,PDSG1,PSGML1,PT,PD &
,T,Q,CWM,OMGALF &
,TRAIN,SR &
,F_ICE,F_RAIN,F_RIMEF &
,QV,QC,QR,QI,QS,QG,NI,NR &
,F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_NI,F_NR &
,PREC,ACPREC,AVRAIN &
,acpcp_ra,acpcp_sn,acpcp_gr, refl_10cm &
,re_cloud,re_ice,re_snow &
,has_reqc,has_reqi,has_reqs &
,MP_RESTART_STATE &
,TBPVS_STATE,TBPVS0_STATE &
,SPECIFIED,NESTED &
,MICROPHYSICS &
,TP1,QP1,PSP1 &
,USE_RADAR &
,DFI_TTEN &
,IDS,IDE,JDS,JDE,LM &
,IMS,IME,JMS,JME &
,ITS,ITE,JTS,JTE &
,ITS_B1,ITE_B1,JTS_B1,JTE_B1,MPRATES,D_SS)
!***********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! SUBPROGRAM: GSMDRIVE MICROPHYSICS OUTER DRIVER
! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-26
!
! ABSTRACT:
! RADIATION SERVES AS THE INTERFACE BETWEEN THE NMMB PHYSICS COMPONENT
! AND THE WRF MICROPHYSICS DRIVER.
!
! PROGRAM HISTORY LOG:
! 02-03-26 BLACK - ORIGINATOR
! 04-11-18 BLACK - THREADED
! 06-07-31 BLACK - BUILT INTO NMMB PHYSICS COMPONENT
! 08-08 JANJIC - Synchronize WATER array and Q.
!
! USAGE: CALL GSMDRIVE FROM PHY_RUN
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM
!$$$
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
!------------------------
!*** Argument Variables
!------------------------
!
INTEGER,INTENT(IN) :: D_SS,ITIMESTEP,NPHS &
,IDS,IDE,JDS,JDE,LM &
,IMS,IME,JMS,JME &
,ITS,ITE,JTS,JTE &
,ITS_B1,ITE_B1,JTS_B1,JTE_B1
!
INTEGER,INTENT(IN) :: USE_RADAR
!
REAL,INTENT(IN) :: DT,DX,DY,PT
!
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM,D_SS) :: MPRATES
!
REAL,DIMENSION(1:LM),INTENT(IN) :: DSG2,PDSG1,PSGML1,SGML2
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FIS,PD,SM
!
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: OMGALF &
,DFI_TTEN
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC &
,AVRAIN !<-- Was a scalar
! G. Thompson added next 4 lines.
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: acpcp_ra,acpcp_sn,acpcp_gr
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: refl_10cm
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: re_cloud, re_ice, re_snow
INTEGER,INTENT(IN):: has_reqc, has_reqi, has_reqs
!
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: CWM,Q,T &
,TRAIN
!
REAL(kind=KFPT),DIMENSION(:,:,:),POINTER,INTENT(INOUT) :: &
& QV,QC,QI,QR,QS,QG,NI,NR
!
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT) :: F_ICE &
,F_RAIN &
,F_RIMEF
!
REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR
!
CHARACTER(99),INTENT(IN) :: MICROPHYSICS
!
LOGICAL,INTENT(IN) :: NESTED,SPECIFIED
!
LOGICAL,INTENT(IN) :: F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_NI,F_NR
!
!*** State Variables for ETAMPNEW Microphysics
!
REAL,DIMENSION(:),INTENT(INOUT) :: MP_RESTART_STATE &
,TBPVS_STATE,TBPVS0_STATE
!*** GFS microphysics
REAL, DIMENSION(IMS:IME,JMS:JME,1:LM), INTENT(INOUT) :: TP1,QP1
REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: PSP1
!
!---------------------
!*** Local Variables
!---------------------
!
INTEGER :: I,IJ,J,K,MP_PHYSICS,N,NTSD
INTEGER :: ITSLOC,ITELOC,JTSLOC,JTELOC
!
INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR
!
REAL :: DPL,DTPHS,PCPCOL,PDSL,PHMID,QW,RDTPHS,TNEW
REAL :: MP_TTEN,mytten
!
REAL,DIMENSION(1:LM) :: QL,TL
!
REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,RAINNC,RAINNCV &
,SNOWNC,SNOWNCV,XLAND &
,graupelnc,graupelncv
!
REAL,DIMENSION(IMS:IME,JMS:JME,1:LM) :: DZ &
,P_PHY,PI_PHY &
,RR,TH_PHY
!
LOGICAL :: WARM_RAIN,F_QT
!
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
NTSD=ITIMESTEP
DTPHS=NPHS*DT
RDTPHS=1./DTPHS
!
!-- AVRAIN was a scalar but changed to a 2D array to allow for updates in ESMF
!
DO J=JTS,JTE
DO I=ITS,ITE
AVRAIN(I,J)=AVRAIN(I,J)+1.
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!*** NOTE: THE NMMB HAS IJK STORAGE WITH LAYER 1 AT THE TOP.
!*** THE WRF PHYSICS DRIVERS HAVE IKJ STORAGE WITH LAYER 1
!*** AT THE BOTTOM.
!-----------------------------------------------------------------------
!
!!! DO J=JTS_B1,JTE_B1
!!! DO I=ITS_B1,ITE_B1
!.......................................................................
!$omp parallel do &
!$omp& private(j,i,k,pdsl,dpl,phmid,ql,tl)
!.......................................................................
DO J=JTS,JTE
DO I=ITS,ITE
!
PDSL=PD(I,J)
LOWLYR(I,J)=1
XLAND(I,J)=SM(I,J)+1.
!
!-----------------------------------------------------------------------
!*** FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE
!*** ACCUMULATED RAIN BUT NOT YET USED BY NMM)
!*** COULD BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC)
!-----------------------------------------------------------------------
!..The NC variables were designed to hold simulation total accumulations
!.. whereas the NCV variables hold timestep only values, so change below
!.. to zero out only the timestep amount preparing to go into each
!.. micro routine while allowing NC vars to accumulate continually.
!.. But, the fact is, the total accum variables are local, never saved
!.. nor written so they go nowhere at the moment.
!
RAINNCv(I,J)=0.
SNOWNCv(I,J)=0.
graupelncv(i,j) = 0.0
!
!-----------------------------------------------------------------------
!*** FILL THE SINGLE-COLUMN INPUT
!-----------------------------------------------------------------------
!
DO K=LM,1,-1 ! We are moving down from the top in the flipped arrays
!
DPL=DSG2(K)*PDSL+PDSG1(K)
PHMID=SGML2(K)*PDSL+PSGML1(K)
TL(K)=T(I,J,K)
QL(K)=AMAX1(Q(I,J,K),EPSQ)
!
RR(I,J,K)=PHMID/(R_D*TL(K)*(P608*QL(K)+1.))
PI_PHY(I,J,K)=(PHMID*1.E-5)**CAPPA
TH_PHY(I,J,K)=TL(K)/PI_PHY(I,J,K)
P_PHY(I,J,K)=PHMID
DZ(I,J,K)=DPL*R_G/RR(I,J,K)
!
ENDDO !- DO K=LM,1,-1
!
ENDDO !- DO I=ITS,ITE
ENDDO !- DO J=JTS,JTE
!.......................................................................
!$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!*** SYNCHRONIZE MIXING RATIO IN WATER ARRAY WITH SPECIFIC HUMIDITY.
!-----------------------------------------------------------------------
!
!.......................................................................
!$omp parallel do &
!$omp& private(i,j,k)
!.......................................................................
DO K=1,LM
DO J=JMS,JME
DO I=IMS,IME
QV(I,J,K)=Q(I,J,K)/(1.-Q(I,J,K))
ENDDO
ENDDO
ENDDO
!
!.......................................................................
!$omp end parallel do
!.......................................................................
!-----------------------------------------------------------------------
!
!*** CALL MICROPHYSICS
!
!-----------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------
!*** TRANSLATE THE MICROPHYSICS OPTIONS IN THE CONFIG FILE TO THEIR
!*** ANALOGS IN THE WRF REGISTRY SO THAT THE WRF MICROPHYSICS DRIVER
!*** REMAINS UNTOUCHED.
!-----------------------------------------------------------------------
!
! SELECT CASE (TRIM(MICROPHYSICS))
! CASE ('fer')
! MP_PHYSICS=5
! CASE ('kes')
! MP_PHYSICS=1
! CASE ('lin')
! MP_PHYSICS=2
! CASE ('wsm3')
! MP_PHYSICS=3
! CASE ('tho')
! MP_PHYSICS=8
! CASE DEFAULT
! WRITE(0,*)' User selected MICROPHYSICS=',MICROPHYSICS
! WRITE(0,*)' Improper selection of Microphysics scheme in GSMDRIVE'
!!! CALL ESMF_Finalize(endflag=ESMF_END_ABORT)
! CALL NMMB_FINALIZE
! END SELECT
!
!---------------------------------------------------------------------
! Check for microphysics type. We need a clean way to
! specify these things!
!---------------------------------------------------------------------
ITSLOC = MAX(ITS_B1,IDS)
ITELOC = MIN(ITE_B1,IDE-1)
JTSLOC = MAX(JTS_B1,JDS)
JTELOC = MIN(JTE_B1,JDE-1)
micro_select: SELECT CASE (TRIM(MICROPHYSICS))
!
CASE ('fer')
CALL ETAMP_NEW( &
ITIMESTEP=ntsd,DT=dtphs,DX=dx,DY=dy &
,DZ8W=dz,RHO_PHY=rr,P_PHY=p_phy,PI_PHY=pi_phy,TH_PHY=th_phy &
,Q=Q &
,QC=QC &
,QS=QS &
,QR=QR &
,QT=cwm &
,LOWLYR=LOWLYR,SR=SR &
,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN &
,F_RIMEF_PHY=F_RIMEF &
,RAINNC=rainnc,RAINNCV=rainncv &
,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 &
,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM &
,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM &
,MP_RESTART_STATE=mp_restart_state &
,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state &
,D_SS=d_ss,MPRATES=mprates &
)
CASE ('fer_hires')
CALL FER_HIRES( &
ITIMESTEP=ntsd,DT=dtphs,DX=dx,DY=dy &
,DZ8W=dz,RHO_PHY=rr,P_PHY=p_phy,PI_PHY=pi_phy,TH_PHY=th_phy &
,Q=Q &
,QC=QC &
,QS=QS &
,QR=QR &
,QT=cwm &
,LOWLYR=LOWLYR,SR=SR &
,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN &
,F_RIMEF_PHY=F_RIMEF &
,RAINNC=rainnc,RAINNCV=rainncv &
,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 &
,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM &
,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM &
,MP_RESTART_STATE=mp_restart_state &
,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state &
,D_SS=d_ss,MPRATES=mprates &
)
CASE ('gfs')
CALL GFSMP(DT=dtphs, &
dz8w=dz,rho_phy=rr,p_phy=p_phy,pi_phy=pi_phy,th_phy=th_phy, &
SR=SR,QT=CWM, F_ICE_PHY=F_ICE, &
RAINNC=RAINNC,RAINNCV=RAINNCV, &
Q=Q,QC=QC,QI=QI, &
F_QC=F_QC,F_QI=F_QI, &
TP1=TP1,QP1=QP1,PSP1=PSP1, &
IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1, &
IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM , &
ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM )
CASE ('wsm6')
! write(0,*)'call wsm6'
CALL wsm6( &
TH=th_phy &
,Q=QV &
,QC=QC &
,QR=QR &
,QI=QI &
,QS=QS &
,QG=QG &
,DEN=rr,PII=pi_phy,P=p_phy,DELZ=dz &
,DELT=dtphs,G=g,CPD=cp,CPV=cpv &
,RD=r_d,RV=r_v,T0C=svpt0 &
,EP1=ep_1, EP2=ep_2, QMIN=epsilon &
,XLS=xls, XLV0=xlv, XLF0=xlf &
,DEN0=rhoair0, DENR=rhowater &
,CLIQ=cliq,CICE=cice,PSAT=psat &
,RAIN=rainnc ,RAINNCV=rainncv &
,SNOW=snownc ,SNOWNCV=snowncv &
,SR=sr &
,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv &
,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 &
,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM &
,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM &
,D_SS=d_ss,MPRATES=mprates)
DO K=1,LM
DO J=JMS,JME
DO I=IMS,IME
Q(I,J,K)=QV(I,J,K)/(1.+QV(I,J,K)) !To s.h.
CWM(I,J,K)=QC(i,j,k)+QR(i,j,k)+QI(i,j,k) &
+QS(i,j,k)+QG(i,j,k)
ENDDO
ENDDO
ENDDO
!+---+-----------------------------------------------------------------+
CASE ('thompson')
! write(6,*)'DEBUG-GT, calling mp_gt_driver'
CALL mp_gt_driver( &
qv=qv &
,qc=qc &
,qr=qr &
,qi=qi &
,qs=qs &
,qg=qg &
,ni=ni &
,nr=nr &
,TH=th_phy,PII=pi_phy,P=p_phy,dz=dz,dt_in=dtphs &
,itimestep=ntsd &
,RAINNC=rainnc ,RAINNCV=rainncv &
,SNOWNC=snownc ,SNOWNCV=snowncv &
,GRAUPELNC=graupelnc ,GRAUPELNCV=graupelncv &
,SR=sr &
,refl_10cm=refl_10cm(ims,jms,1) &
,diagflag=.true. &
,do_radar_ref=1 &
,re_cloud=re_cloud(ims,jms,1) &
,re_ice=re_ice(ims,jms,1) &
,re_snow=re_snow(ims,jms,1) &
,has_reqc=has_reqc &
,has_reqi=has_reqi &
,has_reqs=has_reqs &
,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=1,KDE=LM+1 &
,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=1,KME=LM &
,ITS=itsloc,ITE=iteloc, JTS=jtsloc,JTE=jteloc, KTS=1,KTE=LM &
)
DO K=1,LM
DO J=JMS,JME
DO I=IMS,IME
Q(I,J,K)=QV(I,J,K)/(1.+QV(I,J,K)) !To s.h.
CWM(I,J,K)=QC(i,j,k)+QR(i,j,k)+QI(i,j,k) &
+QS(i,j,k)+QG(i,j,k)
ENDDO
ENDDO
ENDDO
!..rainncv is actually all precip, so need to subtract snow/graupel to isolate rain only
DO J=JMS,JME
DO I=IMS,IME
acpcp_sn(I,J) = acpcp_sn(I,J) + snowncv(i,j)
acpcp_gr(I,J) = acpcp_gr(I,J) + graupelncv(i,j)
acpcp_ra(I,J) = acpcp_ra(I,J) &
+ MAX(0., rainncv(i,j)-snowncv(i,j)-graupelncv(i,j))
ENDDO
ENDDO
!+---+-----------------------------------------------------------------+
CASE DEFAULT
WRITE(0,*)' The microphysics option does not exist: MICROPHYSICS = ',TRIM(MICROPHYSICS)
CALL NMMB_FINALIZE
END SELECT micro_select
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!*** THE FOLLOWING MUST BE RECONCILED WHEN THREADING IS TURNED ON.
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!jaa!$omp parallel do &
!jaa!$omp& private(ij)
! DO IJ=1,NUM_TILES
! CALL MICROPHYSICS_ZERO_OUT( &
! WATER,N_MOIST,CONFIG_FLAGS &
! ,IDS,IDE,JDS,JDE,KDS,KDE &
! ,IMS,IME,JMS,JME,KMS,KME &
! ,GRID%I_START(IJ),GRID%I_END(IJ) &
! ,GRID%J_START(IJ),GRID%J_END(IJ) &
! ,KTS,KTE )
! ENDDO
!
!-----------------------------------------------------------------------
!
!.......................................................................
!$omp parallel do &
!$omp& private(i,j,k,tnew)
!.......................................................................
DO K=1,LM
DO J=JTS_B1,JTE_B1
DO I=ITS_B1,ITE_B1
!
!-----------------------------------------------------------------------
!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING.
!-----------------------------------------------------------------------
!
TNEW=TH_PHY(I,J,K)*PI_PHY(I,J,K)
TRAIN(I,J,K)=TRAIN(I,J,K)+(TNEW-T(I,J,K))*RDTPHS
IF (USE_RADAR==1) THEN
MP_TTEN=(TNEW-T(I,J,K))*RDTPHS
IF(DFI_TTEN(I,J,K)>MP_TTEN.AND.DFI_TTEN(I,J,K)<0.1)THEN
MP_TTEN=DFI_TTEN(I,J,K)
END IF
T(I,J,K)=T(I,J,K)+MP_TTEN/RDTPHS
ELSE
T(I,J,K)=TNEW
ENDIF
ENDDO
ENDDO
ENDDO
!.......................................................................
!$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!*** UPDATE PRECIPITATION
!-----------------------------------------------------------------------
!
!jaa!$omp parallel do &
!jaa!$omp& private(i,j,pcpcol)
DO J=JTS_B1,JTE_B1
DO I=ITS_B1,ITE_B1
PCPCOL=RAINNCV(I,J)*1.E-3
PREC(I,J)=PREC(I,J)+PCPCOL
ACPREC(I,J)=ACPREC(I,J)+PCPCOL
!
! NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT OUT ABOVE
! SINCE IT IS ONLY A LOCAL ARRAY FOR NOW
!
ENDDO
ENDDO
!
!-----------------------------------------------------------------------
!
END SUBROUTINE GSMDRIVE
!-----------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!-----------------------------------------------------------------------
END MODULE MODULE_MICROPHYSICS_NMM
!-----------------------------------------------------------------------