phys/module_cu_gf_wrfdrv.F

   1 !WRF:MODEL_LAYER:PHYSICS
   2 !
   3
   4 MODULE module_cu_gf_wrfdrv
   5 use module_gfs_physcons, g => con_g,                           &
   6                          cp => con_cp,                         &
   7                          xlv => con_hvap,                      &
   8                          r_v => con_rv
   9 use module_cu_gf_deep, only: cup_gf,neg_check,autoconv,aeroevap
  10 use module_cu_gf_sh, only: cup_gf_sh
  11 #if ( WRF_CHEM == 1 )
  12 use module_cu_gf_ctrans, only: neg_check_chem
  13 #endif
  14 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  15 !
  16 !     This convective parameterization is build to attempt     !
  17 !     a smooth transition to cloud resolving scales as proposed!
  18 !     by Arakawa et al (2011, ACP). It currently does not use  !
  19 !     subsidencespreading as in G3. Difference and details     !
  20 !     will be described in a forthcoming paper by              !
  21 !     Grell and Freitas (2013). The parameterization also      !
  22 !     offers options to couple with aerosols. Both, the smooth !
  23 !     transition part as well as the aerosol coupling are      !
  24 !     experimental. While the smooth transition part is turned !
  25 !     on, nd has been tested dow to a resolution of about 3km  !
  26 !     the aerosol coupling is turned off.                      !
  27 !     More clean-up as well as a direct coupling to chemistry  !
  28 !     will follow for V3.5.1                                   !
  29 !                                                              !
  30 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31 !
  32 !Isidora J. stochastic parameter perturbation added to closures
  33 !02/29/2016
  34 !
  35 CONTAINS
  36
  37 !-------------------------------------------------------------
  38    SUBROUTINE GFDRV(spp_conv,pattern_spp_conv,field_conv,       &
  39                DT,DX                                            &
  40               ,rho,RAINCV,PRATEC                                &
  41               ,U,V,t,W,q,p,pi                                   &
  42               ,dz8w,p8w                                         &
  43               ,htop,hbot,ktop_deep                              &
  44               ,HT,hfx,qfx,XLAND                                 &
  45               ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow         &
  46               ,ktop_shallow,xmb_shallow                         &
  47               ,ichoice,ishallow_g3                              &
  48               ,ids,ide, jds,jde, kds,kde                        &
  49               ,ims,ime, jms,jme, kms,kme                        &
  50               ,its,ite, jts,jte, kts,kte                        &
  51               ,periodic_x,periodic_y                            &
  52               ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
  53               ,RQVFTEN,RTHFTEN,RTHCUTEN,RTHRATEN                &
  54               ,rqvblten,rthblten                                &
  55               ,dudt_phy,dvdt_phy                                &
  56 #if ( WRF_DFI_RADAR == 1 )
  57                  ! Optional CAP suppress option
  58               ,do_capsuppress,cap_suppress_loc                  &
  59 #endif
  60 #if ( WRF_CHEM == 1 )
  61               ,chem,tracer,numgas                               &
  62               ,num_chem,chemopt,num_tracer,traceropt            &
  63               ,conv_tr_wetscav,conv_tr_aqchem,chem_conv_tr      &
  64 #endif
  65                                                                 )
  66 !-------------------------------------------------------------
  67    IMPLICIT NONE
  68       integer, parameter :: ideep=1
  69       integer, parameter :: imid_gf=0
  70       integer, parameter :: ichoicem=0  ! 0 1 2 8 11 GG
  71       integer, parameter :: ichoice_s=0 ! 0 1 2 3
  72       integer, parameter :: dicycle=1 !- diurnal cycle flag
  73       integer, parameter :: dicycle_m=0 !- diurnal cycle flag
  74       real, parameter :: aodccn=0.1
  75 !-------------------------------------------------------------
  76    INTEGER,      INTENT(IN   ) ::                               &
  77                                   ids,ide, jds,jde, kds,kde,    &
  78                                   ims,ime, jms,jme, kms,kme,    &
  79                                   its,ite, jts,jte, kts,kte
  80    LOGICAL periodic_x,periodic_y
  81    integer, intent (in   )              :: ichoice
  82
  83    INTEGER,      INTENT(IN   ) :: ishallow_g3
  84
  85    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
  86           INTENT(IN   ) ::                                      &
  87                                                           U,    &
  88                                                           V,    &
  89                                                           W,    &
  90                                                          pi,    &
  91                                                           t,    &
  92                                                           q,    &
  93                                                           p,    &
  94                                                        dz8w,    &
  95                                                        p8w,    &
  96                                                         rho
  97    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
  98           OPTIONAL                                         ,    &
  99           INTENT(INOUT   ) ::                                   &
 100                GDC,GDC2
 101
 102    REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: hfx,qfx,HT,XLAND
 103    INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL
 104    INTEGER, DIMENSION( ims:ime , jms:jme ),                     &
 105             OPTIONAL                      ,                     &
 106             INTENT(INOUT) :: k22_shallow,kbcon_shallow,ktop_shallow
 107    REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT  ),         &
 108             OPTIONAL  :: xmb_shallow
 109
 110    REAL, INTENT(IN   ) :: DT, DX
 111 !
 112
 113    REAL, DIMENSION( ims:ime , jms:jme ),                        &
 114          INTENT(INOUT) ::           pratec,RAINCV,htop,hbot
 115 !+lxz
 116 !  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
 117 !        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
 118 !        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
 119 !                   ! HBOT>HTOP follow physics leveling convention
 120
 121    INTEGER, DIMENSION( ims:ime,         jms:jme ),              &
 122          OPTIONAL,                                              &
 123          INTENT(  OUT) ::                           ktop_deep
 124
 125    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
 126          OPTIONAL,                                              &
 127          INTENT(INOUT) ::                           RTHFTEN,    &
 128                                                     RQVFTEN
 129
 130    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
 131          OPTIONAL,                                              &
 132          INTENT(INOUT) ::                                       &
 133                                                    RTHCUTEN,    &
 134                                                    RQVCUTEN,    &
 135                                                    RQVBLTEN,    &
 136                                                    RTHBLTEN,    &
 137                                                    RTHRATEN,    &
 138                                                    RQCCUTEN,    &
 139                                                    RQICUTEN
 140    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
 141          OPTIONAL,                                              &
 142          INTENT(INOUT) ::                          DUDT_PHY,    &
 143                                                    DVDT_PHY
 144
 145 #if ( WRF_CHEM == 1 )
 146    INTEGER,INTENT(IN   ) ::                                     &
 147                                  numgas,chemopt,traceropt,      &
 148                                  num_tracer,num_chem,           &
 149                                  conv_tr_wetscav,conv_tr_aqchem,&
 150                                  chem_conv_tr
 151    REAL,DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),     &
 152          INTENT(INOUT) ::                                       &
 153                                    chem
 154    REAL,DIMENSION( ims:ime , kms:kme , jms:jme, num_tracer ),   &
 155          INTENT(INOUT) ::                                       &
 156                                    tracer
 157 !local
 158    REAL,DIMENSION( its:ite , kts:kte , num_chem )::             &
 159                         chem2d,outchemts,outchemtm,             &
 160                         outchemt,totchemt
 161    REAL,DIMENSION( its:ite , kts:kte , num_tracer )::           &
 162                         tracer2d,outtracerts,outtracertm,       &
 163                         outtracert,tottracert
 164    INTEGER :: nv,iopt
 165    REAL:: epsilc
 166 #endif
 167
 168 !  Stochastic
 169    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL  ::pattern_spp_conv,field_conv
 170    REAL, DIMENSION( its:ite, 4 )                 ::   rstochcol !,fieldcol_conv
 171 ! Stochastiv required by GF
 172    REAL,  DIMENSION( its:ite )   :: rand_mom,rand_vmas
 173    REAL,  DIMENSION( its:ite,4 ) :: rand_clos
 174
 175 !
 176 ! Flags relating to the optional tendency arrays declared above
 177 ! Models that carry the optional tendencies will provdide the
 178 ! optional arguments at compile time; these flags all the model
 179 ! to determine at run-time whether a particular tracer is in
 180 ! use or not.
 181 !
 182
 183    INTEGER                                 :: spp_conv
 184
 185 #if ( WRF_DFI_RADAR == 1 )
 186 !
 187 !  option of cap suppress:
 188 !        do_capsuppress = 1   do
 189 !        do_capsuppress = other   don't
 190 !
 191 !
 192    INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
 193    REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN   ),OPTIONAL  :: cap_suppress_loc
 194    REAL, DIMENSION( its:ite ) :: cap_suppress_j
 195 #endif
 196 ! LOCAL VARS
 197      real,    dimension (its:ite,kts:kte) ::                    &
 198         dhdt
 199      real,    dimension (its:ite,kts:kte) ::                    &
 200         OUTT,OUTQ,OUTQC,cupclw,outu,outv,cnvwt
 201      real,    dimension (its:ite,kts:kte) ::                    &
 202         OUTTs,OUTQs,OUTQCs,cupclws,outus,outvs,cnvwts
 203      real,    dimension (its:ite,kts:kte) ::                    &
 204         OUTTm,OUTQm,OUTQCm,cupclwm,outum,outvm,cnvwtm
 205      real,    dimension (its:ite)         ::                    &
 206         pret, prets,pretm,ter11, aa0, xlandi
 207      real,    dimension (its:ite)         ::                    &
 208         hfxi,qfxi,dxi
 209 !+lxz
 210      integer, dimension (its:ite) ::                            &
 211         ierr,ierrs,ierrm
 212      integer, dimension (its:ite) ::                            &
 213         kbcon, kbcons, kbconm,                                  &
 214         ktop, ktops, ktopm,                                     &
 215         kpbli, k22, k22s, k22m
 216 !.lxz
 217      integer :: ibegc,iendc,jbegc,jendc
 218
 219      integer, dimension (its:ite)         :: jmin,jminm
 220
 221 !
 222 ! basic environmental input includes moisture convergence (mconv)
 223 ! omega (omeg), windspeed (us,vs)
 224 !
 225      real,    dimension (its:ite,kts:kte) ::                    &
 226         zo,T2d,q2d,PO,P2d,US,VS,rhoi,tn,qo,tshall,qshall
 227 ! output from cup routines, can be used for diagnostics
 228      real,    dimension (its:ite,kts:kte) ::                    &
 229         zus,zum,zu,zdm,zd
 230      real,    dimension (its:ite,kts:kte) ::                    &
 231         omeg
 232      real, dimension (its:ite)            ::                    &
 233         ccn,Z1,PSUR,cuten,cutens,cutenm,                        &
 234         umean,vmean,pmean,xmb,xmbs,                             &
 235         xmbm,xmb_out,tau_ecmwf_out,xmb_dumm
 236      real, dimension (its:ite)     ::                    &
 237         edt,edtm,mconv
 238
 239    INTEGER :: i,j,k,ICLDCK,ipr,jpr,n
 240    REAL    :: tcrit,dp,dq
 241    INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend
 242    REAL    :: rkbcon,rktop        !-lxz
 243    character*50 :: ierrc(its:ite)
 244    character*50 :: ierrcs(its:ite)
 245    character*50 :: ierrcm(its:ite)
 246
 247      real,    dimension (its:ite,kts:kte) :: hco,hcdo,zdo
 248      real,    dimension (its:ite,10)         :: forcing,forcing2
 249
 250      integer, dimension (its:ite) :: cactiv
 251      real,    dimension (its:ite,kts:kte) ::  qcheck
 252
 253 #if ( WRF_CHEM == 1 )
 254    epsilc=1.e-30
 255    iopt=0
 256 #endif
 257    tcrit=258.
 258    ipr=0 !639
 259    jpr=0 !141
 260    rand_mom(:)    = 0.
 261    rand_vmas(:)   = 0.
 262    rand_clos(:,:) = 0.
 263
 264    IF ( periodic_x ) THEN
 265       ibegc=max(its,ids)
 266       iendc=min(ite,ide-1)
 267    ELSE
 268       ibegc=max(its,ids+4)
 269       iendc=min(ite,ide-5)
 270    END IF
 271    IF ( periodic_y ) THEN
 272       jbegc=max(jts,jds)
 273       jendc=min(jte,jde-1)
 274    ELSE
 275       jbegc=max(jts,jds+4)
 276       jendc=min(jte,jde-5)
 277    END IF
 278    IF(PRESENT(k22_shallow)) THEN
 279    do j=jts,jte
 280    do i=its,ite
 281      k22_shallow(i,j)=0
 282      kbcon_shallow(i,j)=0
 283      ktop_shallow(i,j)=0
 284      xmb_shallow(i,j)=0
 285    enddo
 286    enddo
 287    endif
 288    rstochcol=0.0
 289    itf=MIN(ite,ide-1)
 290    ktf=MIN(kte,kde-1)
 291    jtf=MIN(jte,jde-1)
 292 !
 293      DO J = jts,jte
 294      DO I= its,ite
 295      do k=kts,kte
 296        rthcuten(i,k,j)=0.
 297        rqvcuten(i,k,j)=0.
 298        IF(PRESENT(RQCCUTEN))rqccuten(i,k,j)=0.
 299        IF(PRESENT(RQICUTEN))rqicuten(i,k,j)=0.
 300        DUDT_PHY(I,K,J)=0.
 301        DVDT_PHY(I,K,J)=0.
 302      enddo
 303      enddo
 304      enddo
 305
 306      DO 100 J = jts,jtf
 307
 308      DO I= its,itf
 309 ! Stochastic
 310         if (spp_conv==1) then
 311         do n=1,4
 312         rstochcol(i,n)= pattern_spp_conv(i,n,j)
 313         if (pattern_spp_conv(i,n,j) .le. -1.0) then
 314           rstochcol(i,n)= -1.0
 315         endif
 316         if (pattern_spp_conv(i,n,j) .ge.  1.0) then
 317           rstochcol(i,n)=  1.0
 318         endif
 319         enddo
 320         endif
 321         ierrc(i)=" "
 322         ierrcs(i)=" "
 323         ierrcm(i)=" "
 324         ierr(i)=0
 325         ierrs(i)=0
 326         ierrm(i)=0
 327
 328         cuten(i)=0.
 329         cutenm(i)=0.
 330         cutens(i)=1.
 331         if(ishallow_g3.eq.0)cutens(i)=0.
 332
 333         kbcon(i)=0
 334         kbcons(i)=0
 335         kbconm(i)=0
 336         ktop(i)=0
 337         ktops(i)=0
 338         ktopm(i)=0
 339         xmb(i)=0.
 340         xmbs(i)=0.
 341         xmbm(i)=0.
 342         xmb_out(i)=0.
 343         xmb_dumm(i)=0.
 344
 345         k22(i)=0
 346         k22s(i)=0
 347         k22m(i)=0
 348
 349         HBOT(I,J)  =REAL(KTE)
 350         HTOP(I,J)  =REAL(KTS)
 351         raincv(i,j)=0.
 352         pratec (i,j)=0.
 353         xlandi(i)=xland(i,j)
 354         hfxi(i)=hfx(i,j)
 355         qfxi(i)=qfx(i,j)
 356
 357         cactiv(i) = 0
 358         jmin(i) = 0
 359         jminm(i) = 0
 360         forcing(i,:)=0.
 361         forcing2(i,:)=0.
 362         tau_ecmwf_out(i) = 0.
 363
 364         pret(i)=0.
 365         prets(i) = 0.
 366         pretm(i) = 0.
 367
 368         mconv(i)=0.
 369         ccn(i)=150.
 370
 371      ENDDO
 372      DO I= its,itf
 373         mconv(i)=0.
 374      ENDDO
 375      do k=kts,kte
 376      DO I= its,itf
 377          omeg(i,k)=0.
 378      ENDDO
 379      ENDDO
 380
 381 !ipr= 33 !78
 382 !jpr= 17 !110
 383      DO I=ITS,ITF
 384          dxi(i)=dx
 385          PSUR(I)=p8w(I,1,J)*.01
 386 !        PSUR(I)=p(I,1,J)*.01
 387          TER11(I)=max(0.,HT(i,j))
 388 ! positive upward !!
 389          hfxi(i)=hfx(i,j)
 390          qfxi(i)=qfx(i,j)
 391          pret(i)=0.
 392          umean(i)=0.
 393          vmean(i)=0.
 394          pmean(i)=0.
 395          kpbli(i)=kpbl(i,j)
 396          zo(i,kts)=ter11(i)+.5*dz8w(i,1,j)
 397          DO K=kts+1,ktf
 398          zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j))
 399          enddo
 400      ENDDO
 401 !    if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr)
 402      DO K=kts,ktf
 403      DO I=ITS,ITF
 404          po(i,k)=p(i,k,j)*.01
 405          P2d(I,K)=PO(i,k)
 406          rhoi(i,k)=rho(i,k,j)
 407          US(I,K) =u(i,k,j)
 408          VS(I,K) =v(i,k,j)
 409          T2d(I,K)=t(i,k,j)
 410          q2d(I,K)=q(i,k,j)
 411          IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
 412          TN(I,K)=t2d(i,k)+(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j)) &
 413                           *pi(i,k,j)*dt
 414          QO(I,K)=q2d(i,k)+(RQVFTEN(i,k,j)+RQVBLTEN(i,k,j))*dt
 415          TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt
 416          DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j)
 417          QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt
 418          IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
 419          IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
 420          OUTT(I,K)=0.
 421          OUTu(I,K)=0.
 422          OUTv(I,K)=0.
 423          OUTQ(I,K)=0.
 424          OUTQC(I,K)=0.
 425          OUTTm(I,K)=0.
 426          OUTum(I,K)=0.
 427          OUTvm(I,K)=0.
 428          OUTQm(I,K)=0.
 429          OUTQCm(I,K)=0.
 430          OUTTs(I,K)=0.
 431          OUTus(I,K)=0.
 432          OUTvs(I,K)=0.
 433          OUTQs(I,K)=0.
 434          OUTQCs(I,K)=0.
 435          cupclws(i,k) = 0.
 436          cupclw(i,k) = 0.
 437          cupclwm(i,k) = 0.
 438          qcheck(i,k) = 0.
 439 #if ( WRF_CHEM == 1 )
 440          do nv=2,num_chem
 441            outchemts(I,K,nv)=0.
 442            outchemtm(I,K,nv)=0.
 443            outchemt(I,K,nv)=0.
 444            chem2d(I,K,nv)=max(epsilc,chem(i,k,j,nv))
 445          enddo
 446          do nv=2,num_tracer
 447            outtracerts(I,K,nv)=0.
 448            outtracertm(I,K,nv)=0.
 449            outtracert(I,K,nv)=0.
 450            tracer2d(I,K,nv)=max(epsilc,tracer(i,k,j,nv))
 451          enddo
 452 #endif
 453      ENDDO
 454      ENDDO
 455 #if (NMM_CORE==1)
 456 ! for NMM, tendencies have already been added to T,Q, and total tendencies
 457 ! are stored in *FTEN variables
 458      DO K=kts,ktf
 459      DO I=ITS,ITF
 460          TN(I,K)=t2d(i,k) + RTHFTEN(i,k,j)*pi(i,k,j)*dt
 461          QO(I,K)=q2d(i,k) + RQVFTEN(i,k,j)*dt
 462          IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
 463          IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
 464      ENDDO
 465      ENDDO
 466 #endif
 467 ! for EM_CORE, tendencies have not yet been added to T,Q, and *FTEN variables
 468 ! contain advective forcing only
 469      DO K=kts,ktf
 470      DO I=ITS,ITF
 471          omeg(I,K)= -g*rho(i,k,j)*w(i,k,j)
 472      enddo
 473      enddo
 474      do k=  kts+1,ktf-1
 475      DO I = its,itf
 476          if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
 477             dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
 478             umean(i)=umean(i)+us(i,k)*dp
 479             vmean(i)=vmean(i)+vs(i,k)*dp
 480             pmean(i)=pmean(i)+dp
 481          endif
 482      enddo
 483      enddo
 484       DO K=kts,ktf-1
 485       DO I = its,itf
 486         dq=(q2d(i,k+1)-q2d(i,k))
 487         mconv(i)=mconv(i)+omeg(i,k)*dq/g
 488       enddo
 489       ENDDO
 490       DO I = its,itf
 491         if(mconv(i).lt.0.)mconv(i)=0.
 492       ENDDO
 493 !
 494 !---- CALL CUMULUS PARAMETERIZATION
 495 !
 496 #if ( WRF_DFI_RADAR == 1 )
 497       if(do_capsuppress == 1 ) then
 498         DO I= its,itf
 499             cap_suppress_j(i)=cap_suppress_loc(i,j)
 500         ENDDO
 501       endif
 502 #endif
 503
 504        if(ishallow_g3 == 1 )then
 505
 506           call CUP_gf_sh (                                              &
 507 ! input variables, must be supplied
 508               zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli,      &
 509               rhoi,hfxi,qfxi,xlandi,ichoice_s,tcrit,dt,                  &
 510 ! input variables. Ierr should be initialized to zero or larger than zero for
 511 ! turning off shallow convection for grid points
 512               zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs,    &
 513 ! output tendencies
 514               outts,outqs,outqcs,cnvwt,prets,cupclws,             &
 515 #if ( WRF_CHEM == 1 )
 516               num_chem,chem2d,outchemts,          &
 517               num_tracer,tracer2d,outtracerts,    &
 518               numgas,chemopt,traceropt,           &
 519               conv_tr_wetscav,conv_tr_aqchem,     &
 520               chem_conv_tr,                       &
 521 #endif
 522 ! dimesnional variables
 523               itf,ktf,its,ite, kts,kte,ipr)
 524           do i=its,itf
 525            if(xmbs(i).le.0.)cutens(i)=0.
 526           enddo
 527           CALL neg_check('shallow',ipr,dt,q2d,outqs,outts,outus,outvs,   &
 528                                  outqcs,prets,its,ite,kts,kte,itf,ktf)
 529
 530         endif
 531 ! Mid-level convection
 532
 533    if(imid_gf == 1)then
 534
 535       call cup_gf(        &
 536                itf,ktf,its,ite, kts,kte  &
 537
 538               ,dicycle_m       &
 539               ,ichoicem       &
 540               ,ipr           &
 541               ,ccn           &
 542               ,dt         &
 543               ,imid_gf          &
 544
 545               ,kpbli         &
 546               ,dhdt          &
 547               ,xlandi        &
 548
 549               ,zo            &
 550               ,forcing2      &
 551               ,t2d           &
 552               ,q2d           &
 553               ,ter11         &
 554               ,tshall        &
 555               ,qshall        &
 556               ,p2d          &
 557               ,psur          &
 558               ,us            &
 559               ,vs            &
 560               ,rhoi          &
 561               ,hfxi          &
 562               ,qfxi          &
 563               ,dxi            &
 564               ,mconv         &
 565               ,omeg          &
 566
 567               ,cactiv        &
 568               ,cnvwtm        &
 569               ,zum           &
 570               ,zdm           &
 571               ,edtm          &
 572               ,xmbm          &
 573               ,xmb_dumm      &
 574               ,xmbs          &
 575               ,pretm         &
 576               ,outum         &
 577               ,outvm         &
 578               ,outtm         &
 579               ,outqm         &
 580               ,outqcm        &
 581               ,kbconm        &
 582               ,ktopm         &
 583               ,cupclwm       &
 584               ,ierrm         &
 585               ,ierrcm        &
 586 !    the following should be set to zero if not available
 587               ,rand_mom      & ! for stochastics mom, if temporal and spatial patterns exist
 588               ,rand_vmas     & ! for stochastics vertmass, if temporal and spatial patterns exist
 589               ,rand_clos     & ! for stochastics closures, if temporal and spatial patterns exist
 590               ,0             & ! flag to what you want perturbed
 591                                ! 1 = momentum transport
 592                                ! 2 = normalized vertical mass flux profile
 593                                ! 3 = closures
 594                                ! more is possible, talk to developer or
 595                                ! implement yourself. pattern is expected to be
 596                                ! betwee -1 and +1
 597 #if ( WRF_DFI_RADAR == 1 )
 598               ,do_capsuppress,cap_suppress_j &
 599 #endif
 600 #if ( WRF_CHEM == 1 )
 601               ,num_chem,chem2d,outchemtm       &
 602               ,num_tracer,tracer2d,outtracertm &
 603               ,numgas,chemopt,traceropt        &
 604               ,conv_tr_wetscav,conv_tr_aqchem  &
 605               ,chem_conv_tr                    &
 606 #endif
 607               ,k22m          &
 608               ,jminm)
 609
 610             DO I=its,itf
 611             DO K=kts,ktf
 612               qcheck(i,k)=q2d(i,k) +outqs(i,k)*dt
 613             enddo
 614             enddo
 615       CALL neg_check('mid',ipr,dt,qcheck,outqm,outtm,outum,outvm,   &
 616                      outqcm,pretm,its,ite,kts,kte,itf,ktf)
 617     endif
 618
 619 #if ( WRF_DFI_RADAR == 1 )
 620       if(do_capsuppress == 1 ) then
 621         DO I= its,itf
 622             cap_suppress_j(i)=cap_suppress_loc(i,j)
 623         ENDDO
 624       endif
 625 #endif
 626    if(ideep.eq.1)then
 627       call cup_gf(        &
 628                itf,ktf,its,ite, kts,kte  &
 629
 630               ,dicycle       &
 631               ,ichoice       &
 632               ,ipr           &
 633               ,ccn           &
 634               ,dt            &
 635               ,0             &
 636
 637               ,kpbli         &
 638               ,dhdt          &
 639               ,xlandi        &
 640
 641               ,zo            &
 642               ,forcing       &
 643               ,t2d           &
 644               ,q2d           &
 645               ,ter11         &
 646               ,tn            &
 647               ,qo            &
 648               ,p2d           &
 649               ,psur          &
 650               ,us            &
 651               ,vs            &
 652               ,rhoi          &
 653               ,hfxi          &
 654               ,qfxi          &
 655               ,dxi            &
 656               ,mconv         &
 657               ,omeg          &
 658
 659               ,cactiv       &
 660               ,cnvwt        &
 661               ,zu           &
 662               ,zd           &
 663               ,edt          &
 664               ,xmb          &
 665               ,xmbm         &
 666               ,xmbs         &
 667               ,pret         &
 668               ,outu         &
 669               ,outv         &
 670               ,outt         &
 671               ,outq         &
 672               ,outqc        &
 673               ,kbcon        &
 674               ,ktop         &
 675               ,cupclw       &
 676               ,ierr         &
 677               ,ierrc        &
 678 !    the following should be set to zero if not available
 679               ,rand_mom      & ! for stochastics mom, if temporal and spatial patterns exist
 680               ,rand_vmas     & ! for stochastics vertmass, if temporal and spatial patterns exist
 681               ,rand_clos     & ! for stochastics closures, if temporal and spatial patterns exist
 682               ,0             & ! flag to what you want perturbed
 683                                ! 1 = momentum transport
 684                                ! 2 = normalized vertical mass flux profile
 685                                ! 3 = closures
 686                                ! more is possible, talk to developer or
 687                                ! implement yourself. pattern is expected to be
 688                                ! betwee -1 and +1
 689 #if ( WRF_DFI_RADAR == 1 )
 690               ,do_capsuppress,cap_suppress_j &
 691 #endif
 692 #if ( WRF_CHEM == 1 )
 693               ,num_chem,chem2d,outchemt        &
 694               ,num_tracer,tracer2d,outtracert  &
 695               ,numgas,chemopt,traceropt        &
 696               ,conv_tr_wetscav,conv_tr_aqchem  &
 697               ,chem_conv_tr                    &
 698 #endif
 699               ,k22          &
 700               ,jmin)
 701         jpr=0
 702         ipr=0
 703             DO I=its,itf
 704             DO K=kts,ktf
 705               qcheck(i,k)=q2d(i,k) +(outqs(i,k)+outqm(i,k))*dt
 706             enddo
 707             enddo
 708       CALL neg_check('deep',ipr,dt,qcheck,outq,outt,outu,outv,   &
 709                                          outqc,pret,its,ite,kts,kte,itf,ktf)
 710 !
 711       endif
 712             if(j.lt.jbegc.or.j.gt.jendc)go to 100
 713         IF(PRESENT(k22_shallow)) THEN
 714              if(ishallow_g3.eq.1)then
 715                DO I=ibegc,iendc
 716                  xmb_shallow(i,j)=xmbs(i)
 717                  k22_shallow(i,j)=k22s(i)
 718                  kbcon_shallow(i,j)=kbcons(i)
 719                  ktop_shallow(i,j)=ktops(i)
 720                  ktop_deep(i,j) = ktop(i)
 721                ENDDO
 722             endif
 723          ENDIF
 724             DO I=ibegc,iendc
 725               cuten(i)=0.
 726               ktop_deep(i,j) = ktop(i)
 727               if(pret(i).gt.0.)then
 728                  cuten(i)=1.
 729               else
 730                  cuten(i)=0.
 731                  kbcon(i)=0
 732                  ktop(i)=0
 733               endif
 734               if(pretm(i).gt.0.)then
 735                  cutenm(i)=1.
 736               else
 737                  cutenm(i)=0.
 738                  kbconm(i)=0
 739                  ktopm(i)=0
 740               endif
 741
 742             ENDDO
 743             DO I=ibegc,iendc
 744             DO K=kts,ktf
 745                RTHCUTEN(I,K,J)= (cutens(i)*outts(i,k)+ &
 746                                  cutenm(i)*outtm(i,k)+ &
 747                                  cuten(i)* outt(i,k)  )/pi(i,k,j)
 748                RQVCUTEN(I,K,J)= cuten(i)*outq(i,k)   + &
 749                                 cutens(i)*outqs(i,k)+  &
 750                                 cutenm(i)*outqm(i,k)
 751                DUDT_PHY(I,K,J)=outum(i,k)*cutenm(i)+outu(i,k)*cuten(i)
 752                DVDT_PHY(I,K,J)=outvm(i,k)*cutenm(i)+outv(i,k)*cuten(i)
 753             ENDDO
 754             ENDDO
 755 #if ( WRF_CHEM == 1 )
 756             DO I=ibegc,iendc
 757             DO K=kts,ktf
 758                if ((chemopt>0) .and. (chem_conv_tr>0)) then
 759                do nv=2,num_chem
 760                  totchemt(i,k,nv)=outchemts(i,k,nv)*cutens(i)+ &
 761                                   outchemtm(i,k,nv)*cutenm(i)+ &
 762                                   outchemt(i,k,nv)*cuten(i)
 763                enddo ! nv
 764                endif
 765                if ((traceropt>0) .and. (chem_conv_tr>0)) then
 766                do nv=2,num_tracer
 767                  tottracert(I,K,nv)=outtracerts(i,k,nv)*cutens(i)+ &
 768                                     outtracertm(i,k,nv)*cutenm(i)+ &
 769                                     outtracert(i,k,nv)*cuten(i)
 770                enddo
 771                endif
 772             ENDDO
 773             ENDDO
 774 !neg_check
 775             if ((chemopt>0) .and. (chem_conv_tr>0)) then
 776               call neg_check_chem(ktop,dt,chem2d,totchemt,iopt,num_chem,    &
 777                                    its,ite,kts,kte,itf)
 778               DO I=ibegc,iendc
 779               DO K=kts,ktf
 780               do nv=2,num_chem
 781                 chem(I,K,J,nv)=max(epsilc,chem(i,k,j,nv)+totchemt(i,k,nv)*dt)
 782               enddo
 783               ENDDO
 784               ENDDO
 785             endif
 786             if ((traceropt>0) .and. (chem_conv_tr>0)) then
 787                call neg_check_chem(ktop,dt,tracer2d,tottracert,iopt,num_chem, &
 788                                    its,ite,kts,kte,itf)
 789               DO I=ibegc,iendc
 790               DO K=kts,ktf
 791               do nv=2,num_tracer
 792                  tracer(I,K,J,nv)=max(epsilc,tracer(i,k,j,nv)+tottracert(i,k,nv)*dt)
 793               enddo ! nv
 794               ENDDO
 795               ENDDO
 796             endif ! tracer_opt
 797 #endif
 798
 799             DO I=ibegc,iendc
 800               if(pret(i).gt.0. .or. pretm(i).gt.0. .or. prets(i).gt.0.)then
 801                  pratec(i,j)=cuten(i)*pret(i)+cutenm(i)*pretm(i)+cutens(i)*prets(i)
 802                  raincv(i,j)=pratec(i,j)*dt
 803                  rkbcon = kte+kts - kbcon(i)
 804                  rktop  = kte+kts -  ktop(i)
 805                  if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
 806                  if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
 807               endif
 808             ENDDO
 809
 810             IF(PRESENT(RQCCUTEN)) THEN
 811                 DO K=kts,ktf
 812                 DO I=ibegc,iendc
 813                    RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
 814                    IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
 815                    IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
 816                 ENDDO
 817                 ENDDO
 818             ENDIF
 819
 820             IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
 821                 DO K=kts,ktf
 822                   DO I=ibegc,iendc
 823                    if(t2d(i,k).lt.258.)then
 824                       RQICUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
 825                       RQCCUTEN(I,K,J)=0.
 826                       IF ( PRESENT( GDC2 ) ) THEN
 827                         GDC2(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
 828                         GDC(I,K,J) = 0.
 829                       ENDIF
 830                    else
 831                       RQICUTEN(I,K,J)=0.
 832                       RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
 833                       IF ( PRESENT( GDC ) ) THEN
 834                         GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
 835                         GDC2(I,K,J) = 0.
 836                       ENDIF
 837                    endif
 838                 ENDDO
 839                 ENDDO
 840             ENDIF
 841  100    continue
 842
 843    END SUBROUTINE GFDRV
 844 END MODULE MODULE_CU_GF_WRFDRV