!-----------------------------------------------------------------------
!
MODULE MODULE_CONVECTION
!
!-----------------------------------------------------------------------
!
!*** THE CONVECTION DRIVERS AND PACKAGES
!
!-----------------------------------------------------------------------
!
USE MODULE_KINDS
!
USE MODULE_CONSTANTS ,ONLY : CAPPA,EPSQ,G,R_D
USE MODULE_CU_BMJ
USE MODULE_CU_SAS
USE MODULE_CU_SASHUR
USE MODULE_CU_SCALE
!
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
!
PRIVATE
!
PUBLIC :: CUCNVC
!
!-----------------------------------------------------------------------
!
CONTAINS
!
!-----------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!-----------------------------------------------------------------------
SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL,MINUTES_HISTORY &
,ENTRAIN,NEWALL,NEWSWAP,NEWUPUP,NODEEP &
,FRES,FR,FSL,FSS &
,CLDEFI &
,U_PHY,V_PHY &
,F_ICE,F_RAIN &
,QC,QR,QI,QS,QG &
,F_QC,F_QR,F_QI,F_QS,F_QG &
,PHINT,PHMID &
,area &
,T,Q,CWM,TCUCN &
,VVL &
,FIS &
,PREC,ACPREC,CUPREC,CUPPT,CPRATE &
,CNVBOT,CNVTOP,SM &
,HTOP,HTOPD,HTOPS &
,HBOT,HBOTD,HBOTS &
,AVCNVC,ACUTIM &
,RSWIN,RSWOUT &
,CONVECTION,MICROPHYSICS &
,SICE,QWBS,TWBS,PBLH,DTDT_PHY,DUDT_PHY,DVDT_PHY &
,MOMMIX,PGCON,SAS_MASS_FLUX &
,SHALCONV,SHAL_PGCON &
,IMS,IME,LM &
)
!***********************************************************************
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . .
! SUBPROGRAM: CUCNVC CONVECTIVE PRECIPITATION OUTER DRIVER
! PRGRMMR: BLACK ORG: W/NP22 DATE: 02-03-21
!
! ABSTRACT:
! CUCVNC DRIVES THE WRF CONVECTION SCHEMES
!
! PROGRAM HISTORY LOG:
! 02-03-21 BLACK - ORIGINATOR
! 04-11-18 BLACK - THREADED
! 06-10-11 BLACK - BUILT INTO UMO PHYSICS COMPONENT
! 08-08 JANJIC - Synchronize WATER array and Q.
! 10-10-26 WEIGUO WANG - add GFS SAS convection
! 14-06-19 WEIGUO WANG - add hurricane SAS (moved from hwrf)
! 16-08-29 WEIGUO WANG - add scale-aware convection schemes
! USAGE: CALL CUCNVC FROM PHY_RUN
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 90
! MACHINE : IBM
!$$$
!-----------------------------------------------------------------------
!
IMPLICIT NONE
!
!-----------------------------------------------------------------------
integer(kind=kint),parameter:: jms=1,jme=1
!-----------------------------------------------------------------------
character(99),intent(in):: &
convection,microphysics
!
logical(kind=klog),intent(in):: &
entrain,newall,newswap,newupup,nodeep &
,f_qc,f_qr,f_qi,f_qs,f_qg
!
integer(kind=kint),intent(in):: &
ims,ime,lm &
,ncnvc,minutes_history &
,nrads,nradl,ntsd
!
real(kind=kfpt),intent(in):: &
dt,fres,fr,fsl,fss
!
real(kind=kfpt),intent(inout):: &
acutim,avcnvc
!
real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: &
fis &
,rswin,rswout,sm,area
!
real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout):: &
acprec,cldefi &
,cnvbot,cnvtop &
,cuppt,cuprec &
,hbot,htop &
,hbotd,htopd &
,hbots,htops &
,prec,cprate
!
real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: &
sice,qwbs,twbs,pblh !fOR SAS
REAL(kind=kfpt), OPTIONAL, INTENT(IN) :: &
PGCON,sas_mass_flux,shal_pgcon,mommix,shalconv !sashur
!
real(kind=kfpt),dimension(ims:ime,1:lm) ,intent(in):: &
vvl,phmid
!
real(kind=kfpt),dimension(ims:ime,1:lm+1),intent(in):: &
phint
!
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(out):: &
dudt_phy,dvdt_phy,dtdt_phy
!
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: &
q,t &
,f_ice &
,f_rain &
,cwm &
,u_phy,v_phy &
,tcucn,QC,QI,QR,QS,QG
!
!-----------------------------------------------------------------------
!*** LOCAL VARIABLES
!-----------------------------------------------------------------------
!
logical(kind=klog):: &
warm_rain,F_QGr
!
logical(kind=klog),dimension(ims:ime,jms:jme):: &
cu_act_flag
!
integer(kind=kint):: &
i,j &
,k &
,mnto &
,n,ncubot,ncutop,n_timstps_output
!
integer(kind=kint),dimension(ims:ime,jms:jme):: &
LBOT,LTOP
!
real(kind=kfpt):: &
cf_hi,dtcnvc,fice,frain,g_inv &
,pcpcol,ql,ql_k,rdtcnvc &
,QCW,QCI,QRain,QSnow,QGraup &
,tl
!
REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME):: &
CUBOT,CUTOP,NCA &
,RAINC,RAINCV,SFCZ,XLAND
!
REAL(kind=kfpt),DIMENSION(IMS:IME,JMS:JME,1:LM):: &
DZ,exner &
,th,rr &
,RQCCUTEN,RQRCUTEN &
,RQICUTEN,RQSCUTEN &
,RQCUTEN,RTHCUTEN &
,RQGCUTEN
!-----------------------------------------------------------------------
REAL(kind=kfpt) :: TCHANGE
!-----------------------------------------------------------------------
!***********************************************************************
!
!-----------------------------------------------------------------------
!*** RESET THE HBOT/HTOP CONVECTIVE CLOUD BOTTOM (BASE) AND TOP ARRAYS
!*** USED IN RADIATION. THEY STORE THE MAXIMUM VERTICAL LIMITS OF
!*** CONVECTIVE CLOUD BETWEEN RADIATION CALLS. THESE ARRAYS ARE OUT
!*** OF THE WRF PHYSICS AND THUS THEIR VALUES INCREASE UPWARD.
!*** CUPPT IS THE ACCUMULATED CONVECTIVE PRECIPITATION BETWEEN
!*** RADIATION CALLS.
!-----------------------------------------------------------------------
!
IF(MOD(NTSD,NRADS)==0.OR.MOD(NTSD,NRADL)==0)THEN
DO J=JMS,JME
DO I=IMS,IME
HTOP(I,J)=0.
HBOT(I,J)=REAL(LM+1)
CUPPT(I,J)=0.
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='bmj')RETURN
IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='sas')RETURN
IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='sashur')RETURN
IF(MOD(NTSD,NCNVC)/=0.AND.CONVECTION=='scalecu')RETURN
!-----------------------------------------------------------------------
!
IF(MICROPHYSICS=='fer' .OR. MICROPHYSICS=='fer_hires') THEN
F_QGr=.FALSE.
ELSE
F_QGr=F_QG
ENDIF
!
!-----------------------------------------------------------------------
!*** GENERAL PREPARATION
!-----------------------------------------------------------------------
!
AVCNVC=AVCNVC+1.
ACUTIM=ACUTIM+1.
!
DTCNVC=NCNVC*DT
RDTCNVC=1./DTCNVC
G_INV=1./G
!
!.......................................................................
!zj$omp parallel do &
!zj$omp& private(j,i,k,ql,tl)
!.......................................................................
DO J=JMS,JME
DO I=IMS,IME
!
RAINCV(I,J)=0.
RAINC(I,J)=0.
XLAND(I,J)=SM(I,J)+1.
NCA(I,J)=0.
SFCZ(I,J)=FIS(I,J)*G_INV
!
CUTOP(I,J)=999.
CUBOT(I,J)=999.
!
!-----------------------------------------------------------------------
!*** FILL VERTICAL WORKING ARRAYS.
!-----------------------------------------------------------------------
!
DO K=1,LM
!
QL=MAX(Q(I,J,K),EPSQ)
TL=T(I,J,K)
RR(I,J,K)=PHMID(I,K)/(R_D*TL*(.608*ql+1.))
T(I,J,K)=TL
!
EXNER(I,J,K)=(PHMID(I,K)*1.E-5)**CAPPA
TH(I,J,K)=TL/EXNER(I,J,K)
!
ENDDO
ENDDO
ENDDO
!.......................................................................
!zj$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!*** Compute velocity components at mass points.
!-----------------------------------------------------------------------
!
!.......................................................................
!zj$omp parallel do &
!zj$omp& private(j,i,k)
!.......................................................................
do k=1,lm
do j=jms,jme
do i=ims,ime
RTHCUTEN(I,J,K)=0.
RQCUTEN(I,J,K)=0.
RQCCUTEN(I,J,K)=0.
RQRCUTEN(I,J,K)=0.
RQICUTEN(I,J,K)=0.
RQSCUTEN(I,J,K)=0.
RQGCUTEN(I,J,K)=0.
dtdt_phy(i,j,k)=0.
dudt_phy(i,j,k)=0.
dvdt_phy(i,j,k)=0.
enddo
enddo
enddo
!.......................................................................
!zj$omp end parallel do
!.......................................................................
!-----------------------------------------------------------------------
!.......................................................................
!zj$omp parallel do &
!zj$omp private(i,j,k,ql_k)
!.......................................................................
DO J=JMS,JME
DO I=IMS,IME
DZ(I,J,LM)=T(I,J,LM)*(.608*Q(I,J,LM)+1.)*R_D &
*(PHINT(I,LM+1)-PHINT(I,LM)) &
/(PHMID(I,LM)*G)
ENDDO
!
DO K=LM-1,1,-1
DO I=IMS,IME
QL_K=MAX(Q(I,J,K),EPSQ)
DZ(I,J,K)=T(I,J,K)*(.608*QL_K+1.)*R_D &
*(PHINT(I,K+1)-PHINT(I,K)) &
/(PHMID(I,K)*G)
ENDDO
ENDDO
!
ENDDO
!
!-----------------------------------------------------------------------
!
!*** SINGLE-COLUMN CONVECTION
!
!-----------------------------------------------------------------------
!
IF(trim(CONVECTION) == 'bmj') then
!
call bmjdrv( &
ims,ime,jms,jme,lm &
,entrain,newall,newswap,newupup,nodeep &
,fres,fr,fsl,fss &
,dt,ntsd,ncnvc &
,raincv,cutop,cubot &
,th,t,q,u_phy,v_phy,dudt_phy,dvdt_phy &
,phint,phmid,exner &
,cldefi,xland,cu_act_flag &
! optional
,rthcuten,rqcuten &
)
!
ELSEIF(trim(CONVECTION) == 'sas') then
!
call sasdrv( &
ims,ime,jms,jme,lm &
,dt,ntsd,ncnvc &
,th,t,sice,twbs,qwbs,pblh,u_phy,v_phy &
,q,qc,qr,qi,qs,qg &
,f_qc,f_qr,f_qi,f_qs,F_QGr &
,phint,phmid,exner,rr,dz &
,xland,cu_act_flag &
,vvl &
,raincv,cutop,cubot &
,dudt_phy,dvdt_phy &
! optional
,rthcuten, rqcuten &
,rqccuten, rqrcuten &
,rqicuten, rqscuten &
,rqgcuten &
)
!
ELSEIF(trim(CONVECTION) == 'sashur') then
!
call sasdrv_hur( &
ims,ime,jms,jme,lm &
,dt,ntsd,ncnvc &
,th,t,sice,vvl,twbs,qwbs,pblh,u_phy,v_phy &
,q,qc,qr,qi,qs,qg &
,f_qc,f_qr,f_qi,f_qs,F_QGr &
,phint,phmid,exner,rr,dz &
,xland,cu_act_flag &
,MOMMIX,PGCON,SAS_MASS_FLUX &
,SHALCONV,SHAL_PGCON &
,raincv,cutop,cubot &
,dudt_phy,dvdt_phy &
! optional
,rthcuten, rqcuten &
,rqccuten, rqrcuten &
,rqicuten, rqscuten &
,rqgcuten &
)
!
ELSEIF(trim(CONVECTION) == 'scalecu') then
!
call scalecudrv( &
ims,ime,jms,jme,lm &
,dt,ntsd,ncnvc &
,th,t,sice,vvl,twbs,qwbs,pblh,u_phy,v_phy &
,q,qc,qr,qi,qs,qg &
,f_qc,f_qr,f_qi,f_qs,F_QGr &
,phint,phmid,exner,rr,dz &
,xland,cu_act_flag &
,area &
,MOMMIX,PGCON,SAS_MASS_FLUX &
,SHALCONV,SHAL_PGCON &
,raincv,cutop,cubot &
,dudt_phy,dvdt_phy &
! optional
,rthcuten, rqcuten &
,rqccuten, rqrcuten &
,rqicuten, rqscuten &
,rqgcuten &
)
!
END IF
!
!-----------------------------------------------------------------------
!
!*** CNVTOP/CNVBOT HOLD THE MAXIMUM VERTICAL LIMITS OF CONVECTIVE CLOUD
!*** BETWEEN HISTORY OUTPUT TIMES. HBOTS/HTOPS STORE SIMILIAR INFORMATION
!*** FOR SHALLOW (NONPRECIPITATING) CONVECTION, AND HBOTD/HTOPD ARE FOR
!*** DEEP (PRECIPITATING) CONVECTION.
!
CF_HI=REAL(MINUTES_HISTORY)/60.
N_TIMSTPS_OUTPUT=NINT(3600.*CF_HI/DT)
MNTO=MOD(NTSD,N_TIMSTPS_OUTPUT)
!
IF(MNTO>0.AND.MNTO<=NCNVC)THEN
DO J=JMS,JME
DO I=IMS,IME
CNVBOT(I,J)=REAL(LM+1.)
CNVTOP(I,J)=0.
HBOTD(I,J)=REAL(LM+1.)
HTOPD(I,J)=0.
HBOTS(I,J)=REAL(LM+1.)
HTOPS(I,J)=0.
ENDDO
ENDDO
ENDIF
!
!-----------------------------------------------------------------------
!.......................................................................
!zj$omp parallel do &
!zj$omp& private(j,k,i,tchange,pcpcol,ncubot,ncutop,QCW,QRain,QCI,QSnow,QGraup)
!.......................................................................
!-----------------------------------------------------------------------
do j=jms,jme
do i=ims,ime
!-----------------------------------------------------------------------
!
!*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING.
!
DO K=1,LM
!
!rv ------------ update is now in the SOLVER ------------
DTDT_PHY(I,J,K)=RTHCUTEN(I,J,K)*exner(I,J,K)
!rv T(I,J,K)=T(I,J,K)+DTDT_PHY(I,J,K)*DTCNVC
Q(I,J,K)=Q(I,J,K)+RQCUTEN(I,J,K)*DTCNVC
!rv U_PHY(I,J,K)=U_PHY(I,J,K)+DUDT_PHY(I,J,K)*DTCNVC
!rv V_PHY(I,J,K)=V_PHY(I,J,K)+DVDT_PHY(I,J,K)*DTCNVC
TCUCN(I,J,K)=TCUCN(I,J,K)+DTDT_PHY(I,J,K)
sas_test: IF(CONVECTION=='sas') THEN
QC(I,J,K)=QC(I,J,K)+DTCNVC*RQCCUTEN(I,J,K)
QCW=QC(I,J,K)
QRain=0.
QCI=0.
QSnow=0.
QGraup=0.
IF(F_QR) THEN
QR(I,J,K)=QR(I,J,K)+DTCNVC*RQRCUTEN(I,J,K)
QRain=QR(I,J,K)
ENDIF
IF(F_QI) THEN
QI(I,J,K)=QI(I,J,K)+DTCNVC*RQICUTEN(I,J,K)
QCI=QI(I,J,K)
ENDIF
IF(F_QS) THEN
QS(I,J,K)=QS(I,J,K)+DTCNVC*RQSCUTEN(I,J,K)
QSnow=QS(I,J,K)
ENDIF
IF(F_QGr) THEN
QG(I,J,K)=QG(I,J,K)+DTCNVC*RQGCUTEN(I,J,K)
QGraup=QG(I,J,K)
ENDIF
!-- Couple CWM, F_ice, & F_rain arrays
CWM(I,J,K)=QCW+QRain+QCI+QSnow+QGraup
F_ICE(I,J,K)=0.
F_RAIN(I,J,K)=0.
IF(CWM(I,J,K)>EPSQ) F_ICE(I,J,K)=(QCI+QSnow+QGraup)/CWM(I,J,K)
IF(QRain>EPSQ) F_RAIN(I,J,K)=QRain/(QCW+QRain)
ENDIF sas_test
!
ENDDO
!
!*** UPDATE PRECIPITATION
!
PCPCOL=RAINCV(I,J)*1.E-3*NCNVC
PREC(I,J)=PREC(I,J)+PCPCOL
ACPREC(I,J)=ACPREC(I,J)+PCPCOL
CUPREC(I,J)=CUPREC(I,J)+PCPCOL
CUPPT(I,J)=CUPPT(I,J)+PCPCOL
CPRATE(I,J)=PCPCOL
!
!*** SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND
!*** FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS.
!*** MUST BE TREATED SEPARATELY FROM EACH OTHER.
!
NCUTOP=NINT(CUTOP(I,J))
NCUBOT=NINT(CUBOT(I,J))
!
IF(NCUTOP>1.AND.NCUTOP<LM+1)THEN
HTOP(I,J)=MAX(CUTOP(I,J),HTOP(I,J))
CNVTOP(I,J)=MAX(CUTOP(I,J),CNVTOP(I,J))
IF(PCPCOL>0.)THEN
HTOPD(I,J)=MAX(CUTOP(I,J),HTOPD(I,J))
ELSE
HTOPS(I,J)=MAX(CUTOP(I,J),HTOPS(I,J))
ENDIF
ENDIF
IF(NCUBOT>0.AND.NCUBOT<LM+1)THEN
HBOT(I,J)=MIN(CUBOT(I,J),HBOT(I,J))
CNVBOT(I,J)=MIN(CUBOT(I,J),CNVBOT(I,J))
IF(PCPCOL>0.)THEN
HBOTD(I,J)=MIN(CUBOT(I,J),HBOTD(I,J))
ELSE
HBOTS(I,J)=MIN(CUBOT(I,J),HBOTS(I,J))
ENDIF
ENDIF
!
ENDDO
ENDDO
!.......................................................................
!zj$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!
END SUBROUTINE CUCNVC
!
!-----------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!-----------------------------------------------------------------------
!
END MODULE MODULE_CONVECTION
!
!-----------------------------------------------------------------------