MODULE module_cu_gfdrvr use module_gfs_physcons, g => con_g, & cp => con_cp, & xlv => con_hvap, & r_v => con_rv use module_cu_gf_deep, only: cup_gf,neg_check use module_cu_gf_sh, only: cup_gf_sh CONTAINS SUBROUTINE GFDRVR( & DT,DX2D,DY & ,rho,RAINCV,PRATEC & ,U,V,t,W,q,p,pi & ,dz8w,p8w & ,htop,hbot,ktop_deep & ,HT,hfx,qfx,XLAND & ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow & ,ktop_shallow,xmb_shallow & ,ierr_shallow & ,ishallow_g3 & ,ichoice & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & ,periodic_x,periodic_y & ,RQVCUTEN,RQCCUTEN & ,RQICUTEN & ,RQVFTEN,RTHFTEN,RTHCUTEN,RTHRATEN & ,rqvblten,rthblten & ,RUCUTEN,RVCUTEN & ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & ,SCALEFUN & ,SIGMU & ) IMPLICIT NONE integer, parameter :: ideep=1 integer, parameter :: imid_gf=0 integer, parameter :: ichoicem=0 integer, parameter :: ichoice_s=2 real, parameter :: aodccn=0.1 integer, parameter :: dicycle=1 integer, parameter :: dicycle_m=0 INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte LOGICAL periodic_x,periodic_y real :: beta,betam,dts,fpi,fp INTEGER, INTENT(IN ) :: ishallow_g3,ichoice REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(IN ) :: & U, & V, & W, & pi, & t, & q, & p, & dz8w, & p8w, & rho REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & OPTIONAL , & INTENT(INOUT ) :: & GDC,GDC2 REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: hfx,qfx,HT,XLAND INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL INTEGER, DIMENSION( ims:ime , jms:jme ), & OPTIONAL , & INTENT(OUT) :: k22_shallow,kbcon_shallow,ktop_shallow REAL, DIMENSION( ims:ime, jms:jme ),INTENT(OUT ), & OPTIONAL :: xmb_shallow REAL, INTENT(IN ) :: DT, DY REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: DX2D REAL, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT) :: & pratec,RAINCV,htop,hbot INTEGER, DIMENSION( ims:ime, jms:jme ), & OPTIONAL, & INTENT( OUT) :: ktop_deep REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & OPTIONAL, & INTENT(INOUT) :: RTHFTEN, & RQVFTEN REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & OPTIONAL, & INTENT(INOUT) :: & RTHCUTEN, & RQVCUTEN, & RQVBLTEN, & RTHBLTEN, & RTHRATEN, & RQCCUTEN, & RQICUTEN REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) :: & RUCUTEN, & RVCUTEN LOGICAL, OPTIONAL :: & F_QV & ,F_QC & ,F_QR & ,F_QI & ,F_QS INTEGER, DIMENSION( ims:ime , jms:jme ), & OPTIONAL , & INTENT(OUT) :: ierr_shallow REAL, DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: scalefun REAL, DIMENSION( ims:ime, jms:jme ),INTENT(OUT) :: sigmu REAL, DIMENSION( its:ite ) :: rand_mom,rand_vmas REAL, DIMENSION(its:ite ,4 ) :: rand_clos real, dimension (its:ite,kts:kte) :: & dhdt real, dimension (its:ite,kts:kte) :: & OUTT,OUTQ,OUTQC,cupclw,outu,outv,cnvwt real, dimension (its:ite,kts:kte) :: & OUTTs,OUTQs,OUTQCs,cupclws,outus,outvs,cnvwts real, dimension (its:ite,kts:kte) :: & OUTTm,OUTQm,OUTQCm,cupclwm,outum,outvm,cnvwtm real, dimension (its:ite) :: & dxi,pret, prets,pretm,ter11, aa0, xlandi real, dimension (its:ite) :: & hfxi,qfxi integer, dimension (its:ite) :: & ierr,ierrs,ierrm integer, dimension (its:ite) :: & kbcon, kbcons, kbconm, & ktop, ktops, ktopm, & kpbli, k22, k22s, k22m integer :: ibegc,iendc,jbegc,jendc integer, dimension (its:ite) :: jmin,jminm real, dimension (its:ite,kts:kte) :: & zo,T2d,q2d,PO,P2d,US,VS,rhoi,tn,qo,tshall,qshall real, dimension (its:ite,kts:kte) :: & zus,zum,zu,zdm,zd real, dimension (its:ite,kts:kte) :: & omeg real, dimension (its:ite) :: & ccn,Z1,PSUR,cuten,cutens,cutenm, & xmb,xmbs, & xmbm,tau_ecmwf_out,xmb_dumm real, dimension (its:ite) :: & edt,edtm,mconv INTEGER :: i,j,k,ICLDCK,ipr,jpr REAL :: tcrit,dp,dq INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend character*50 :: ierrc(its:ite) character*50 :: ierrcs(its:ite) character*50 :: ierrcm(its:ite) real, dimension (its:ite,kts:kte) :: hco,hcdo,zdo real, dimension (its:ite,10) :: forcing,forcing2 integer, dimension (its:ite) :: cactiv real, dimension (its:ite,kts:kte) :: qcheck tcrit=258. rand_mom(:) = 0. rand_vmas(:) = 0. rand_clos(:,:) = 0. ipr=0 jpr=0 itf = ite ktf = kte jtf = jte ibegc = its iendc = ite jbegc = jts jendc = jte DO J = jts,jte do k=kts,kte DO I= its,ite rthcuten(i,k,j)=0. rqvcuten(i,k,j)=0. enddo enddo enddo IF(PRESENT(RQCCUTEN))then DO J = jts,jte do k=kts,kte DO I= its,ite rqccuten(i,k,j)=0. enddo enddo enddo ENDIF IF(PRESENT(RQICUTEN))then DO J = jts,jte do k=kts,kte DO I= its,ite rqicuten(i,k,j)=0. enddo enddo enddo ENDIF DO 100 J = jts,jtf DO I= its,itf ierrc(i)=" " ierrcs(i)=" " ierrcm(i)=" " ierr(i)=0 ierrs(i)=0 ierrm(i)=0 cuten(i)=0. cutenm(i)=0. cutens(i)=1. if(ishallow_g3.eq.0)cutens(i)=0. kbcon(i)=0 kbcons(i)=0 kbconm(i)=0 ktop(i)=0 ktops(i)=0 ktopm(i)=0 xmb(i)=0. xmbs(i)=0. xmbm(i)=0. xmb_dumm(i)=0. k22(i)=0 k22s(i)=0 k22m(i)=0 HBOT(I,J)=KTE HTOP(I,J)=KTS raincv(i,j)=0. pratec (i,j)=0. xlandi(i)=xland(i,j) hfxi(i)=hfx(i,j) qfxi(i)=qfx(i,j) cactiv(i) = 0 jmin(i) = 0 jminm(i) = 0 forcing(i,:)=0. forcing2(i,:)=0. tau_ecmwf_out(i) = 0. pret(i)=0. prets(i) = 0. pretm(i) = 0. dxi(i)=(dy*dy+dx2d(i,j)*dx2d(i,j))**0.5 mconv(i)=0. ccn(i)=150. ENDDO DO I=ITS,ITF PSUR(I)=p8w(I,1,J)*.01 TER11(I)=max(0.,HT(i,j)) kpbli(i)=kpbl(i,j) zo(i,kts)=ter11(i)+.5*dz8w(i,1,j) DO K=kts+1,ktf zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j)) enddo ENDDO DO K=kts,ktf DO I=ITS,ITF po(i,k)=p(i,k,j)*.01 P2d(I,K)=PO(i,k) rhoi(i,k)=rho(i,k,j) US(I,K) =u(i,k,j) VS(I,K) =v(i,k,j) T2d(I,K)=t(i,k,j) q2d(I,K)=q(i,k,j) IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08 OUTT(I,K)=0. OUTu(I,K)=0. OUTv(I,K)=0. OUTQ(I,K)=0. OUTQC(I,K)=0. OUTTm(I,K)=0. OUTum(I,K)=0. OUTvm(I,K)=0. OUTQm(I,K)=0. OUTQCm(I,K)=0. OUTTs(I,K)=0. OUTus(I,K)=0. OUTvs(I,K)=0. OUTQs(I,K)=0. OUTQCs(I,K)=0. TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j) QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt cupclw(i,k) = 0. cupclws(i,k) = 0. cupclwm(i,k) = 0. qcheck(i,k) = 0. ENDDO ENDDO DO K=kts,ktf DO I=ITS,ITF TN(I,K)=t2d(i,k) + RTHFTEN(i,k,j)*pi(i,k,j)*dt QO(I,K)=q2d(i,k) + RQVFTEN(i,k,j)*dt IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K) IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08 ENDDO ENDDO DO K=kts,ktf DO I=ITS,ITF omeg(I,K)= -g*rho(i,k,j)*w(i,k,j) enddo enddo if(ishallow_g3 == 1 )then call CUP_gf_sh ( & zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli, & rhoi,hfxi,qfxi,xlandi,ichoice_s,tcrit,dt, & zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs, & outts,outqs,outqcs,cnvwt,prets,cupclws, & itf,ktf,its,ite, kts,kte,ipr) do i=its,itf if(xmbs(i).le.0.)cutens(i)=0. enddo CALL neg_check('shallow',ipr,dt,q2d,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) endif if(imid_gf == 1)then call cup_gf( & itf,ktf,its,ite, kts,kte & ,dicycle_m & ,ichoicem & ,ipr & ,ccn & ,dt & ,imid_gf & ,kpbli & ,dhdt & ,xlandi & ,zo & ,forcing2 & ,t2d & ,q2d & ,ter11 & ,tshall & ,qshall & ,p2d & ,psur & ,us & ,vs & ,rhoi & ,hfxi & ,qfxi & ,dxi & ,mconv & ,omeg & ,cactiv & ,cnvwtm & ,zum & ,zdm & ,edtm & ,xmbm & ,xmb_dumm & ,xmbs & ,pretm & ,outum & ,outvm & ,outtm & ,outqm & ,outqcm & ,kbconm & ,ktopm & ,cupclwm & ,ierrm & ,ierrcm & ,rand_mom & ,rand_vmas & ,rand_clos & ,0 & ,k22m & ,jminm) DO I=its,itf DO K=kts,ktf qcheck(i,k)=q2d(i,k) +outqs(i,k)*dt enddo enddo CALL neg_check('mid',ipr,dt,qcheck,outqm,outtm,outum,outvm, & outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) endif if(ideep.eq.1)then call cup_gf( & itf,ktf,its,ite, kts,kte & ,dicycle & ,ichoice & ,ipr & ,ccn & ,dt & ,0 & ,kpbli & ,dhdt & ,xlandi & ,zo & ,forcing & ,t2d & ,q2d & ,ter11 & ,tn & ,qo & ,p2d & ,psur & ,us & ,vs & ,rhoi & ,hfxi & ,qfxi & ,dxi & ,mconv & ,omeg & ,cactiv & ,cnvwt & ,zu & ,zd & ,edt & ,xmb & ,xmbm & ,xmbs & ,pret & ,outu & ,outv & ,outt & ,outq & ,outqc & ,kbcon & ,ktop & ,cupclw & ,ierr & ,ierrc & ,rand_mom & ,rand_vmas & ,rand_clos & ,0 & ,k22 & ,jmin) jpr=0 ipr=0 DO I=its,itf DO K=kts,ktf qcheck(i,k)=q2d(i,k) +(outqs(i,k)+outqm(i,k))*dt enddo enddo CALL neg_check('deep',ipr,dt,qcheck,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) endif if(j.lt.jbegc.or.j.gt.jendc)go to 100 IF(PRESENT(k22_shallow)) THEN if(ishallow_g3.eq.1)then DO I=ibegc,iendc if (ierrs(i).eq.0) then xmb_shallow(i,j)=xmbs(i) k22_shallow(i,j)=k22s(i) kbcon_shallow(i,j)=kbcons(i) ktop_shallow(i,j)=ktops(i) if (ktops(i) > HTOP(i,j)) HTOP(i,j) = ktops(i) if (kbcons(i) < HBOT(i,j)) HBOT(i,j) = kbcons(i) endif ierr_shallow(i,j) = ierrs(i) ENDDO endif ENDIF DO I=ibegc,iendc cuten(i)=0. ktop_deep(i,j) = ktop(i) if(pret(i).gt.0.)then cuten(i)=1. else cuten(i)=0. kbcon(i)=0 ktop(i)=0 endif if(pretm(i).gt.0.)then cutenm(i)=1. else cutenm(i)=0. kbconm(i)=0 ktopm(i)=0 endif ENDDO DO I=ibegc,iendc DO K=kts,ktf RTHCUTEN(I,K,J)= (cutens(i)*outts(i,k)+ & cutenm(i)*outtm(i,k)+ & cuten(i)* outt(i,k) )/pi(i,k,j) RQVCUTEN(I,K,J)= cuten(i)*outq(i,k) + & cutens(i)*outqs(i,k)+ & cutenm(i)*outqm(i,k) RUCUTEN(I,J,K)=outum(i,k)*cutenm(i)+outu(i,k)*cuten(i) RVCUTEN(I,J,K)=outvm(i,k)*cutenm(i)+outv(i,k)*cuten(i) ENDDO ENDDO DO I=ibegc,iendc if(pret(i).gt.0.)then raincv(i,j)=pret(i)*dt pratec(i,j)=pret(i) if (ktop(i) > HTOP(i,j)) HTOP(i,j) = ktop(i) if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i) endif ENDDO IF(PRESENT(RQCCUTEN)) THEN IF ( F_QC ) THEN DO K=kts,ktf DO I=ibegc,iendc RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0. ENDDO ENDDO ENDIF ENDIF IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN IF (F_QI) THEN DO K=kts,ktf DO I=ibegc,iendc if(t2d(i,k).lt.258.)then RQICUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) RQCCUTEN(I,K,J)=0. IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) else RQICUTEN(I,K,J)=0. RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i) IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i) endif ENDDO ENDDO ENDIF ENDIF DO I=ibegc,iendc scalefun(i,j) = edt(i) sigmu(i,j) = xmb(i) ENDDO 100 continue END SUBROUTINE GFDRVR SUBROUTINE gfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & RUCUTEN,RVCUTEN, & restart, & P_QC,P_QI,P_FIRST_SCALAR, & RTHFTEN, RQVFTEN, & 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_FIRST_SCALAR, P_QI, P_QC REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & RTHCUTEN, & RQVCUTEN, & RQCCUTEN, & RQICUTEN REAL, DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) :: & RUCUTEN, & RVCUTEN REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & RTHFTEN, & RQVFTEN INTEGER :: i, j, k IF(.not.restart .or. .not.allowed_to_read)THEN DO j=jts,jte DO k=kts,kte DO i=its,ite RTHCUTEN(i,k,j)=0. RQVCUTEN(i,k,j)=0. ENDDO ENDDO ENDDO DO k=kts,kte DO j=jts,jte DO i=its,ite RUCUTEN(i,j,k)=0. RVCUTEN(i,j,k)=0. ENDDO ENDDO ENDDO DO j=jts,jte DO k=kts,kte DO i=its,ite RTHFTEN(i,k,j)=0. RQVFTEN(i,k,j)=0. ENDDO ENDDO ENDDO IF (P_QC .ge. P_FIRST_SCALAR) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite RQCCUTEN(i,k,j)=0. ENDDO ENDDO ENDDO ENDIF IF (P_QI .ge. P_FIRST_SCALAR) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite RQICUTEN(i,k,j)=0. ENDDO ENDDO ENDDO ENDIF ENDIF END SUBROUTINE gfinit END MODULE module_cu_gfdrvr