wrfv2_fire/phys/module_cu_tiedtke.F

   1 !-----------------------------------------------------------------------
   2 !
   3 !WRF:MODEL_LAYER:PHYSICS
   4 !
   5 !####################TIEDTKE SCHEME#########################
   6 !   Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii
   7 !   Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010
   8 !   refenrence: Tiedtke (1989, MWR, 117, 1779-1800)
   9 !               Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment
  10 !               Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements
  11 !                                                  for cloud top detrainment
  12 !                       (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds
  13 !                        (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation
  14 !   This scheme is on testing
  15 !###########################################################
  16 MODULE module_cu_tiedtke
  17 !
  18 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  19 ! epsl--- allowed minimum value for floating calculation
  20 !---------------------------------------------------------------
  21       real,parameter ::  epsl  = 1.0e-20
  22       real,parameter ::  t000  = 273.15
  23       real,parameter ::  hgfr  = 233.15   ! defined in param.f in explct
  24 !-------------------------------------------------------------
  25 !  Ends the parameters set
  26 !++++++++++++++++++++++++++++
  27      REAL,PRIVATE :: G
  28      REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2,CPV,   &
  29              RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, &
  30              C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG
  31
  32      REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC,    &
  33              CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0,  &
  34              fdbk,ZTAU
  35
  36      INTEGER :: nentr
  37
  38      REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC
  39
  40
  41      PARAMETER(A=6371.22E03,                                    &
  42       ALV=2.5008E6,                 &
  43       ALS=2.8345E6,                 &
  44       ALF=ALS-ALV,                  &
  45       CPD=1005.46,                  &
  46       CPV=1869.46,                  & ! CPV in module is 1846.4
  47       RCPD=1.0/CPD,                 &
  48       RHOH2O=1.0E03,                &
  49       TMELT=273.16,                 &
  50       G=9.806,                      & ! G=9.806
  51       ZRG=1.0/G,                    &
  52       RD=287.05,                    &
  53       RV=461.51,                    &
  54       C1ES=610.78,                  &
  55       C2ES=C1ES*RD/RV,              &
  56       C3LES=17.269,                 &
  57       C4LES=35.86,                  &
  58       C5LES=C3LES*(TMELT-C4LES),    &
  59       C3IES=21.875,                 &
  60       C4IES=7.66,                   &
  61       C5IES=C3IES*(TMELT-C4IES),    &
  62       API=3.141593,                 & ! API=2.0*ASIN(1.)
  63       VTMPC1=RV/RD-1.0,             &
  64       VTMPC2=CPV/CPD-1.0,           &
  65       CVDIFTS=1.0,                  &
  66       CEVAPCU1=1.93E-6*261.,        &
  67       CEVAPCU2=1.E3/(38.3*0.293) )
  68
  69
  70 !                SPECIFY PARAMETERS FOR MASSFLUX-SCHEME
  71 !                  --------------------------------------
  72 !                   These are tunable parameters
  73 !
  74 !     ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
  75 !     -------
  76 !
  77       PARAMETER(ENTRPEN=1.0E-4)
  78 !
  79 !     ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION
  80 !     -------
  81 !
  82       PARAMETER(ENTRSCV=1.2E-3)
  83 !
  84 !     ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
  85 !     -------
  86 !
  87       PARAMETER(ENTRMID=1.0E-4)
  88 !
  89 !     ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS
  90 !     ------
  91 !
  92       PARAMETER(ENTRDD =2.0E-4)
  93 !
  94 !     CMFCTOP:   RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL
  95 !     -------
  96 !
  97       PARAMETER(CMFCTOP=0.26)
  98 !
  99 !     CMFCMAX:   MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
 100 !     -------
 101 !
 102       PARAMETER(CMFCMAX=1.0)
 103 !
 104 !     CMFCMIN:   MINIMUM MASSFLUX VALUE (FOR SAFETY)
 105 !     -------
 106 !
 107       PARAMETER(CMFCMIN=1.E-10)
 108 !
 109 !     CMFDEPS:   FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
 110 !     -------
 111 !
 112       PARAMETER(CMFDEPS=0.30)
 113 !
 114 !     CPRCON:  COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER
 115 !
 116       PARAMETER(CPRCON = 2.0E-3/G)
 117 !
 118 !     ZDNOPRC: The pressure depth below which no precipitation
 119 !
 120       PARAMETER(ZDNOPRC = 1.5E4)
 121 !--------------------
 122      PARAMETER(nentr=1)   ! Old entrainment rate parameterization   ! chn1,2,4
 123 !      PARAMETER(nentr=2)   ! New entrainment rate parameterization    ! chn3
 124 !
 125 !--------------------
 126       PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50)
 127 !--------------------
 128       PARAMETER(CRIRH=0.80,fdbk = 1.0,ZTAU = 3600.0)
 129 !--------------------
 130       LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV
 131       PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.)
 132 !--------------------
 133 !#################### END of Variables definition##########################
 134 !-----------------------------------------------------------------------
 135 !
 136 CONTAINS
 137 !-----------------------------------------------------------------------
 138       SUBROUTINE CU_TIEDTKE(                                    &
 139                  DT,ITIMESTEP,STEPCU                            &
 140                 ,RAINCV,PRATEC,QFX,ZNU                          &
 141                 ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D        &
 142                 ,QVFTEN,QVPBLTEN                                &
 143                 ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG                &
 144                 ,CUDT, CURR_SECS, ADAPT_STEP_FLAG               &
 145                 ,ids,ide, jds,jde, kds,kde                      &
 146                 ,ims,ime, jms,jme, kms,kme                      &
 147                 ,its,ite, jts,jte, kts,kte                      &
 148                 ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN            &
 149                 ,RUCUTEN, RVCUTEN                               &
 150                 ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS       &
 151                                                                 )
 152
 153 !-------------------------------------------------------------------
 154       IMPLICIT NONE
 155 !-------------------------------------------------------------------
 156 !-- U3D         3D u-velocity interpolated to theta points (m/s)
 157 !-- V3D         3D v-velocity interpolated to theta points (m/s)
 158 !-- TH3D        3D potential temperature (K)
 159 !-- T3D         temperature (K)
 160 !-- QV3D        3D water vapor mixing ratio (Kg/Kg)
 161 !-- QC3D        3D cloud mixing ratio (Kg/Kg)
 162 !-- QI3D        3D ice mixing ratio (Kg/Kg)
 163 !-- RHO3D       3D air density (kg/m^3)
 164 !-- P8w         3D hydrostatic pressure at full levels (Pa)
 165 !-- Pcps        3D hydrostatic pressure at half levels (Pa)
 166 !-- PI3D        3D exner function (dimensionless)
 167 !-- RTHCUTEN      Theta tendency due to
 168 !                 cumulus scheme precipitation (K/s)
 169 !-- RUCUTEN       U wind tendency due to
 170 !                 cumulus scheme precipitation (K/s)
 171 !-- RVCUTEN       V wind tendency due to
 172 !                 cumulus scheme precipitation (K/s)
 173 !-- RQVCUTEN      Qv tendency due to
 174 !                 cumulus scheme precipitation (kg/kg/s)
 175 !-- RQRCUTEN      Qr tendency due to
 176 !                 cumulus scheme precipitation (kg/kg/s)
 177 !-- RQCCUTEN      Qc tendency due to
 178 !                 cumulus scheme precipitation (kg/kg/s)
 179 !-- RQSCUTEN      Qs tendency due to
 180 !                 cumulus scheme precipitation (kg/kg/s)
 181 !-- RQICUTEN      Qi tendency due to
 182 !                 cumulus scheme precipitation (kg/kg/s)
 183 !-- RAINC         accumulated total cumulus scheme precipitation (mm)
 184 !-- RAINCV        cumulus scheme precipitation (mm)
 185 !-- PRATEC        precipitiation rate from cumulus scheme (mm/s)
 186 !-- dz8w        dz between full levels (m)
 187 !-- QFX         upward moisture flux at the surface (kg/m^2/s)
 188 !-- DT          time step (s)
 189 !-- ids         start index for i in domain
 190 !-- ide         end index for i in domain
 191 !-- jds         start index for j in domain
 192 !-- jde         end index for j in domain
 193 !-- kds         start index for k in domain
 194 !-- kde         end index for k in domain
 195 !-- ims         start index for i in memory
 196 !-- ime         end index for i in memory
 197 !-- jms         start index for j in memory
 198 !-- jme         end index for j in memory
 199 !-- kms         start index for k in memory
 200 !-- kme         end index for k in memory
 201 !-- its         start index for i in tile
 202 !-- ite         end index for i in tile
 203 !-- jts         start index for j in tile
 204 !-- jte         end index for j in tile
 205 !-- kts         start index for k in tile
 206 !-- kte         end index for k in tile
 207 !-------------------------------------------------------------------
 208       INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
 209                                         ims,ime, jms,jme, kms,kme,      &
 210                                         its,ite, jts,jte, kts,kte,      &
 211                                         ITIMESTEP,                      &
 212                                         STEPCU
 213
 214       REAL,    INTENT(IN) ::                                            &
 215                                         DT
 216
 217
 218       REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
 219                                         XLAND
 220
 221       REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
 222                                         RAINCV, PRATEC
 223
 224       LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) ::             &
 225                                         CU_ACT_FLAG
 226
 227
 228       REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
 229                                         DZ8W,                           &
 230                                         P8w,                            &
 231                                         Pcps,                           &
 232                                         PI3D,                           &
 233                                         QC3D,                           &
 234                                         QVFTEN,                         &
 235                                         QVPBLTEN,                       &
 236                                         QI3D,                           &
 237                                         QV3D,                           &
 238                                         RHO3D,                          &
 239                                         T3D,                            &
 240                                         U3D,                            &
 241                                         V3D,                            &
 242                                         W
 243
 244 !--------------------------- OPTIONAL VARS ----------------------------
 245
 246       REAL, DIMENSION(ims:ime, kms:kme, jms:jme),                       &
 247                OPTIONAL, INTENT(INOUT) ::                               &
 248                                         RQCCUTEN,                       &
 249                                         RQICUTEN,                       &
 250                                         RQVCUTEN,                       &
 251                                         RTHCUTEN,                       &
 252                                         RUCUTEN,                        &
 253                                         RVCUTEN
 254
 255 !
 256 ! Flags relating to the optional tendency arrays declared above
 257 ! Models that carry the optional tendencies will provdide the
 258 ! optional arguments at compile time; these flags all the model
 259 ! to determine at run-time whether a particular tracer is in
 260 ! use or not.
 261 !
 262      LOGICAL, OPTIONAL ::                                    &
 263                                                    F_QV      &
 264                                                   ,F_QC      &
 265                                                   ,F_QR      &
 266                                                   ,F_QI      &
 267                                                   ,F_QS
 268
 269 ! Adaptive time-step variables
 270       REAL,  INTENT(IN   ) :: CUDT
 271       REAL,  INTENT(IN   ) :: CURR_SECS
 272       LOGICAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
 273
 274 !--------------------------- LOCAL VARS ------------------------------
 275
 276       REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
 277                                         QFX
 278
 279       REAL      ::                                      &
 280                                         DELT,                           &
 281                                         RDELT
 282
 283       REAL     , DIMENSION(its:ite) ::                  &
 284                                         RCS,                            &
 285                                         RN,                             &
 286                                         EVAP
 287       INTEGER  , DIMENSION(its:ite) ::  SLIMSK
 288
 289
 290       REAL     , DIMENSION(its:ite, kts:kte+1) ::       &
 291                                         PRSI
 292
 293       REAL     , DIMENSION(its:ite, kts:kte) ::         &
 294                                         DEL,                            &
 295                                         DOT,                            &
 296                                         PHIL,                           &
 297                                         PRSL,                           &
 298                                         Q1,                             &
 299                                         Q2,                             &
 300                                         Q3,                             &
 301                                         Q1B,                            &
 302                                         Q1BL,                           &
 303                                         Q11,                            &
 304                                         Q12,                            &
 305                                         T1,                             &
 306                                         U1,                             &
 307                                         V1,                             &
 308                                         ZI,                             &
 309                                         ZL,                             &
 310                                         OMG,                            &
 311                                         GHT
 312
 313       INTEGER, DIMENSION(its:ite) ::                                    &
 314                                         KBOT,                           &
 315                                         KTOP
 316
 317       INTEGER ::                                                        &
 318                                         I,                              &
 319                                         IM,                             &
 320                                         J,                              &
 321                                         K,                              &
 322                                         KM,                             &
 323                                         KP,                             &
 324                                         KX
 325
 326
 327       LOGICAL :: run_param
 328
 329 !-------other local variables----
 330       INTEGER,DIMENSION( its:ite ) :: KTYPE
 331       REAL, DIMENSION( kts:kte )   :: sig1      ! half sigma levels
 332       REAL, DIMENSION( kms:kme )   :: ZNU
 333       INTEGER                      :: zz
 334 !-----------------------------------------------------------------------
 335 !
 336 !***  CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
 337 !
 338       if (adapt_step_flag) then
 339          if ( (ITIMESTEP .eq. 1) .or. (cudt .eq. 0) .or. &
 340           ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
 341            run_param = .TRUE.
 342          else
 343            run_param = .FALSE.
 344          endif
 345       else
 346          if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 1) then
 347             run_param = .TRUE.
 348          else
 349             run_param = .FALSE.
 350          endif
 351       endif
 352
 353 !-----------------------------------------------------------------------
 354    IF(run_param) THEN
 355
 356       DO J=JTS,JTE
 357          DO I=ITS,ITE
 358             CU_ACT_FLAG(I,J)=.TRUE.
 359          ENDDO
 360       ENDDO
 361
 362       IM=ITE-ITS+1
 363       KX=KTE-KTS+1
 364       DELT=DT*STEPCU
 365       RDELT=1./DELT
 366
 367 !-------------  J LOOP (OUTER) --------------------------------------------------
 368
 369    DO J=jts,jte
 370
 371 ! --------------- compute zi and zl -----------------------------------------
 372       DO i=its,ite
 373         ZI(I,KTS)=0.0
 374       ENDDO
 375
 376       DO k=kts+1,kte
 377         KM=k-1
 378         DO i=its,ite
 379           ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
 380         ENDDO
 381       ENDDO
 382
 383       DO k=kts+1,kte
 384         KM=k-1
 385         DO i=its,ite
 386           ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
 387         ENDDO
 388       ENDDO
 389
 390       DO i=its,ite
 391         ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
 392       ENDDO
 393
 394 ! --------------- end compute zi and zl -------------------------------------
 395       DO i=its,ite
 396         SLIMSK(i)=int(ABS(XLAND(i,j)-2.))
 397       ENDDO
 398
 399       DO k=kts,kte
 400         kp=k+1
 401         DO i=its,ite
 402           DOT(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
 403         ENDDO
 404       ENDDO
 405
 406       DO k=kts,kte
 407         zz = kte+1-k
 408         DO i=its,ite
 409           U1(i,zz)=U3D(i,k,j)
 410           V1(i,zz)=V3D(i,k,j)
 411           T1(i,zz)=T3D(i,k,j)
 412           Q1(i,zz)= QV3D(i,k,j)
 413           if(itimestep == 1) then
 414              Q1B(i,zz)=0.
 415              Q1BL(i,zz)=0.
 416           else
 417              Q1B(i,zz)=QVFTEN(i,k,j)
 418              Q1BL(i,zz)=QVPBLTEN(i,k,j)
 419           endif
 420           Q2(i,zz)=QC3D(i,k,j)
 421           Q3(i,zz)=QI3D(i,k,j)
 422           OMG(i,zz)=DOT(i,k)
 423           GHT(i,zz)=ZL(i,k)
 424           PRSL(i,zz) = Pcps(i,k,j)
 425         ENDDO
 426       ENDDO
 427
 428       DO k=kts,kte+1
 429         zz = kte+2-k
 430         DO i=its,ite
 431           PRSI(i,zz) = P8w(i,k,j)
 432         ENDDO
 433       ENDDO
 434
 435       DO k=kts,kte
 436          zz = kte+1-k
 437          sig1(zz) = ZNU(k)
 438       ENDDO
 439
 440 !###############before call TIECNV, we need EVAP########################
 441 !       EVAP is the vapor flux at the surface
 442 !########################################################################
 443 !
 444       DO i=its,ite
 445         EVAP(i) = QFX(i,j)
 446       ENDDO
 447 !########################################################################
 448       CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP,             &
 449                   RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT)
 450
 451       DO I=ITS,ITE
 452          RAINCV(I,J)=RN(I)/STEPCU
 453          PRATEC(I,J)=RN(I)/(STEPCU * DT)
 454       ENDDO
 455
 456       DO K=KTS,KTE
 457         zz = kte+1-k
 458         DO I=ITS,ITE
 459           RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
 460           RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT
 461           RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT
 462           RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT
 463         ENDDO
 464       ENDDO
 465
 466       IF(PRESENT(RQCCUTEN))THEN
 467         IF ( F_QC ) THEN
 468           DO K=KTS,KTE
 469             zz = kte+1-k
 470             DO I=ITS,ITE
 471               RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT
 472             ENDDO
 473           ENDDO
 474         ENDIF
 475       ENDIF
 476
 477       IF(PRESENT(RQICUTEN))THEN
 478         IF ( F_QI ) THEN
 479           DO K=KTS,KTE
 480             zz = kte+1-k
 481             DO I=ITS,ITE
 482               RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT
 483             ENDDO
 484           ENDDO
 485         ENDIF
 486       ENDIF
 487
 488
 489    ENDDO
 490
 491    ENDIF
 492
 493    END SUBROUTINE CU_TIEDTKE
 494
 495 !====================================================================
 496    SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
 497                      RUCUTEN,RVCUTEN,                                   &
 498                      RESTART,P_QC,P_QI,P_FIRST_SCALAR,                  &
 499                      allowed_to_read,                                   &
 500                      ids, ide, jds, jde, kds, kde,                      &
 501                      ims, ime, jms, jme, kms, kme,                      &
 502                      its, ite, jts, jte, kts, kte)
 503 !--------------------------------------------------------------------
 504    IMPLICIT NONE
 505 !--------------------------------------------------------------------
 506    LOGICAL , INTENT(IN)           ::  allowed_to_read,restart
 507    INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
 508                                       ims, ime, jms, jme, kms, kme, &
 509                                       its, ite, jts, jte, kts, kte
 510    INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
 511
 512    REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::  &
 513                                                               RTHCUTEN, &
 514                                                               RQVCUTEN, &
 515                                                               RQCCUTEN, &
 516                                                               RQICUTEN, &
 517                                                               RUCUTEN,RVCUTEN
 518
 519    INTEGER :: i, j, k, itf, jtf, ktf
 520
 521    jtf=min0(jte,jde-1)
 522    ktf=min0(kte,kde-1)
 523    itf=min0(ite,ide-1)
 524
 525    IF(.not.restart)THEN
 526      DO j=jts,jtf
 527      DO k=kts,ktf
 528      DO i=its,itf
 529        RTHCUTEN(i,k,j)=0.
 530        RQVCUTEN(i,k,j)=0.
 531        RUCUTEN(i,k,j)=0.
 532        RVCUTEN(i,k,j)=0.
 533      ENDDO
 534      ENDDO
 535      ENDDO
 536
 537      IF (P_QC .ge. P_FIRST_SCALAR) THEN
 538         DO j=jts,jtf
 539         DO k=kts,ktf
 540         DO i=its,itf
 541            RQCCUTEN(i,k,j)=0.
 542         ENDDO
 543         ENDDO
 544         ENDDO
 545      ENDIF
 546
 547      IF (P_QI .ge. P_FIRST_SCALAR) THEN
 548         DO j=jts,jtf
 549         DO k=kts,ktf
 550         DO i=its,itf
 551            RQICUTEN(i,k,j)=0.
 552         ENDDO
 553         ENDDO
 554         ENDDO
 555      ENDIF
 556    ENDIF
 557
 558       END SUBROUTINE tiedtkeinit
 559
 560 ! ------------------------------------------------------------------------
 561
 562 !------------This is the combined version for tiedtke---------------
 563 !----------------------------------------------------------------
 564 !  In this module only the mass flux convection scheme of the ECMWF is included
 565 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 566 !#############################################################
 567 !
 568 !             LEVEL 1 SUBROUTINEs
 569 !
 570 !#############################################################
 571 !********************************************************
 572 !        subroutine TIECNV
 573 !********************************************************
 574       SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg,  &
 575                pap,paph,evap,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt)
 576 !-----------------------------------------------------------------
 577 !  This is the interface between the meso-scale model and the mass
 578 !  flux convection module
 579 !-----------------------------------------------------------------
 580       implicit none
 581
 582       real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km)
 583       real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km)
 584
 585       REAL PUM1(lq,km),    PVM1(lq,km),                             &
 586           PTTE(lq,km),    PQTE(lq,km),  PVOM(lq,km),  PVOL(lq,km),  &
 587           PVERV(lq,km),   PGEO(lq,km),  PAP(lq,km),   PAPH(lq,km1)
 588       REAL PQHFL(lq),      ZQQ(lq,km),   PAPRC(lq),    PAPRS(lq),   &
 589           PRSFC(lq),      PSSFC(lq),    PAPRSM(lq),   PCTE(lq,km)
 590       REAL ZTP1(lq,km),    ZQP1(lq,km),  ZTU(lq,km),   ZQU(lq,km),  &
 591           ZLU(lq,km),     ZLUDE(lq,km), ZMFU(lq,km),  ZMFD(lq,km),  &
 592           ZQSAT(lq,km),   pqc(lq,km),   pqi(lq,km),   ZRAIN(lq)
 593
 594       REAL sig(km1),sig1(km)
 595       INTEGER ICBOT(lq),   ICTOP(lq),     KTYPE(lq),   lndj(lq)
 596       REAL  dt
 597       LOGICAL LOCUM(lq)
 598
 599       real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT
 600       real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF
 601       integer i,j,k,lq,lp,km,km1
 602 !     real TLUCUA
 603 !     external TLUCUA
 604
 605       ZTMST=dt
 606 !  Masv flux diagnostics.
 607
 608       PSHEAT=0.0
 609       PSRAIN=0.0
 610       PSEVAP=0.0
 611       PSMELT=0.0
 612       PSDISS=0.0
 613       DO 8 j=1,lq
 614         ZRAIN(j)=0.0
 615         LOCUM(j)=.FALSE.
 616         PRSFC(j)=0.0
 617         PSSFC(j)=0.0
 618         PAPRC(j)=0.0
 619         PAPRS(j)=0.0
 620         PAPRSM(j)=0.0
 621         PQHFL(j)=evap(j)
 622     8 CONTINUE
 623
 624 !     CONVERT MODEL VARIABLES FOR MFLUX SCHEME
 625
 626       DO 10 k=1,km
 627         DO 10 j=1,lq
 628           PTTE(j,k)=0.0
 629           PCTE(j,k)=0.0
 630           PVOM(j,k)=0.0
 631           PVOL(j,k)=0.0
 632           ZTP1(j,k)=pt(j,k)
 633           ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k))
 634           PUM1(j,k)=pu(j,k)
 635           PVM1(j,k)=pv(j,k)
 636           PVERV(j,k)=pomg(j,k)
 637           PGEO(j,k)=G*poz(j,k)
 638           TT=ZTP1(j,k)
 639           ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k)
 640           ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k))
 641           ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k))
 642           PQTE(j,k)=pqvf(j,k)+pqvbl(j,k)
 643           ZQQ(j,k)=PQTE(j,k)
 644    10 CONTINUE
 645 !
 646 !-----------------------------------------------------------------------
 647 !*    2.     CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION)
 648 !
 649       CALL CUMASTR_NEW &
 650          (lq,       km,       km1,      km-1,    ZTP1,   &
 651           ZQP1,     PUM1,     PVM1,     PVERV,   ZQSAT,  &
 652           PQHFL,    ZTMST,    PAP,      PAPH,    PGEO,   &
 653           PTTE,     PQTE,     PVOM,     PVOL,    PRSFC,  &
 654           PSSFC,    PAPRC,    PAPRSM,   PAPRS,   LOCUM,  &
 655           KTYPE,    ICBOT,    ICTOP,    ZTU,     ZQU,    &
 656           ZLU,      ZLUDE,    ZMFU,     ZMFD,    ZRAIN,  &
 657           PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,  PSMELT, &
 658           PCTE,     sig1,     lndj)
 659 !
 660 !     TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION
 661 !
 662       IF(fdbk.ge.1.0e-9) THEN
 663       DO 20 K=1,km
 664       DO 20 j=1,lq
 665       If(PCTE(j,k).GT.0.0) then
 666         ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST
 667         if(ZTPP1.ge.t000) then
 668            fliq=1.0
 669            ZALF=0.0
 670         else if(ZTPP1.le.hgfr) then
 671            fliq=0.0
 672            ZALF=ALF
 673         else
 674            ZTC=ZTPP1-t000
 675            fliq=0.0059+0.9941*exp(-0.003102*ZTC*ZTC)
 676            ZALF=ALF
 677         endif
 678         fice=1.0-fliq
 679         pqc(j,k)=pqc(j,k)+fliq*PCTE(j,k)*ZTMST
 680         pqi(j,k)=pqi(j,k)+fice*PCTE(j,k)*ZTMST
 681         PTTE(j,k)=PTTE(j,k)-ZALF*RCPD*fliq*PCTE(j,k)
 682       Endif
 683    20 CONTINUE
 684       ENDIF
 685 !
 686       DO 75 k=1,km
 687         DO 75 j=1,lq
 688           pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST
 689           ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST
 690           pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k))
 691    75 CONTINUE
 692       DO 85 j=1,lq
 693         zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST)
 694    85 CONTINUE
 695       IF (LMFDUDV) THEN
 696         DO 100 k=1,km
 697           DO 100 j=1,lq
 698             pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST
 699             pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST
 700   100   CONTINUE
 701       ENDIF
 702 !
 703       RETURN
 704       END SUBROUTINE TIECNV
 705
 706 !#############################################################
 707 !
 708 !             LEVEL 2 SUBROUTINEs
 709 !
 710 !#############################################################
 711 !***********************************************************
 712 !           SUBROUTINE CUMASTR_NEW
 713 !***********************************************************
 714       SUBROUTINE CUMASTR_NEW                             &
 715          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
 716           PQEN,     PUEN,     PVEN,     PVERV,    PQSEN, &
 717           PQHFL,    ZTMST,    PAP,      PAPH,     PGEO,  &
 718           PTTE,     PQTE,     PVOM,     PVOL,     PRSFC, &
 719           PSSFC,    PAPRC,    PAPRSM,   PAPRS,    LDCUM, &
 720           KTYPE,    KCBOT,    KCTOP,    PTU,      PQU,   &
 721           PLU,      PLUDE,    PMFU,     PMFD,     PRAIN, &
 722           PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,   PSMELT,&
 723           PCTE,     sig1,     lndj)
 724 !
 725 !***CUMASTR*  MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME
 726 !     M.TIEDTKE      E.C.M.W.F.     1986/1987/1989
 727 !***PURPOSE
 728 !   -------
 729 !          THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
 730 !     PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES.
 731 !     PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF
 732 !     PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE,
 733 !     SATURATED CUMULUS DOWNDRAFTS.
 734 !***INTERFACE.
 735 !   ----------
 736 !          *CUMASTR* IS CALLED FROM *MSSFLX*
 737 !     THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE
 738 !     T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES.
 739 !     IT RETURNS ITS OUTPUT TO THE SAME SPACE
 740 !      1.MODIFIED TENDENCIES OF MODEL VARIABLES
 741 !      2.RATES OF CONVECTIVE PRECIPITATION
 742 !        (USED IN SUBROUTINE SURF)
 743 !      3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION
 744 !        (USED IN SUBROUTINE CLOUD)
 745 !***METHOD
 746 !   ------
 747 !     PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME.
 748 !        (1) DEFINE CONSTANTS AND PARAMETERS
 749 !        (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND
 750 !            INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI'
 751 !        (3) CALCULATE CLOUD BASE IN 'CUBASE'
 752 !            AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET
 753 !        (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS
 754 !        (5) DO DOWNDRAFT CALCULATIONS:
 755 !              (A) DETERMINE VALUES AT LFS IN 'CUDLFS'
 756 !              (B) DETERMINE MOIST DESCENT IN 'CUDDRAF'
 757 !              (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE
 758 !                  EFFECT OF CU-DOWNDRAFTS
 759 !        (6) DO FINAL CLOUD ASCENT IN 'CUASC'
 760 !        (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX',
 761 !            DO EVAPORATION IN SUBCLOUD LAYER
 762 !        (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ'
 763 !        (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV'
 764 !***EXTERNALS.
 765 !   ----------
 766 !       CUINI:  INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR.
 767 !       CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION
 768 !       CUASC:  CLOUD ASCENT FOR ENTRAINING PLUME
 769 !       CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS
 770 !       CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS
 771 !       CUFLX:  FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL)
 772 !       CUDQDT: UPDATES TENDENCIES FOR T AND Q
 773 !       CUDUDV: UPDATES TENDENCIES FOR U AND V
 774 !***SWITCHES.
 775 !   --------
 776 !          LMFPEN=.T.   PENETRATIVE CONVECTION IS SWITCHED ON
 777 !          LMFSCV=.T.   SHALLOW CONVECTION IS SWITCHED ON
 778 !          LMFMID=.T.   MIDLEVEL CONVECTION IS SWITCHED ON
 779 !          LMFDD=.T.    CUMULUS DOWNDRAFTS SWITCHED ON
 780 !          LMFDUDV=.T.  CUMULUS FRICTION SWITCHED ON
 781 !***
 782 !     MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM)
 783 !     ------------------------------------------------
 784 !     ENTRPEN    ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
 785 !     ENTRSCV    ENTRAINMENT RATE FOR SHALLOW CONVECTION
 786 !     ENTRMID    ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
 787 !     ENTRDD     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
 788 !     CMFCTOP    RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY
 789 !                LEVEL
 790 !     CMFCMAX    MAXIMUM MASSFLUX VALUE ALLOWED FOR
 791 !     CMFCMIN    MINIMUM MASSFLUX VALUE (FOR SAFETY)
 792 !     CMFDEPS    FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
 793 !     CPRCON     COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN
 794 !***REFERENCE.
 795 !   ----------
 796 !          PAPER ON MASSFLUX SCHEME (TIEDTKE,1989)
 797 !-----------------------------------------------------------------
 798 !-------------------------------------------------------------------
 799       IMPLICIT NONE
 800 !-------------------------------------------------------------------
 801       INTEGER   KLON, KLEV, KLEVP1
 802       INTEGER   KLEVM1
 803       REAL      ZTMST
 804       REAL      PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2
 805       INTEGER   JK,JL,IKB
 806       REAL      ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV
 807       REAL      ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH
 808       REAL      ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS
 809       INTEGER   ICUM, ITOPM2
 810       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV), &
 811               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
 812               PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
 813               PVOM(KLON,KLEV),        PVOL(KLON,KLEV),  &
 814               PQSEN(KLON,KLEV),       PGEO(KLON,KLEV),  &
 815               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),&
 816               PVERV(KLON,KLEV),       PQHFL(KLON)
 817       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),  &
 818               PLU(KLON,KLEV),         PLUDE(KLON,KLEV), &
 819               PMFU(KLON,KLEV),        PMFD(KLON,KLEV),  &
 820               PAPRC(KLON),            PAPRS(KLON),      &
 821               PAPRSM(KLON),           PRAIN(KLON),      &
 822               PRSFC(KLON),            PSSFC(KLON)
 823       REAL     ZTENH(KLON,KLEV),       ZQENH(KLON,KLEV),&
 824               ZGEOH(KLON,KLEV),       ZQSENH(KLON,KLEV),&
 825               ZTD(KLON,KLEV),         ZQD(KLON,KLEV),   &
 826               ZMFUS(KLON,KLEV),       ZMFDS(KLON,KLEV), &
 827               ZMFUQ(KLON,KLEV),       ZMFDQ(KLON,KLEV), &
 828               ZDMFUP(KLON,KLEV),      ZDMFDP(KLON,KLEV),&
 829               ZMFUL(KLON,KLEV),       ZRFL(KLON),       &
 830               ZUU(KLON,KLEV),         ZVU(KLON,KLEV),   &
 831               ZUD(KLON,KLEV),         ZVD(KLON,KLEV)
 832       REAL     ZENTR(KLON),            ZHCBASE(KLON),   &
 833               ZMFUB(KLON),            ZMFUB1(KLON),     &
 834               ZDQPBL(KLON),           ZDQCV(KLON)
 835       REAL     ZSFL(KLON),             ZDPMEL(KLON,KLEV), &
 836               PCTE(KLON,KLEV),        ZCAPE(KLON),        &
 837               ZHEAT(KLON),            ZHHATT(KLON,KLEV),  &
 838               ZHMIN(KLON),            ZRELH(KLON)
 839       REAL     sig1(KLEV)
 840       INTEGER  ILAB(KLON,KLEV),        IDTOP(KLON),   &
 841               ICTOP0(KLON),           ILWMIN(KLON)
 842       INTEGER  KCBOT(KLON),            KCTOP(KLON),   &
 843               KTYPE(KLON),            IHMIN(KLON),    &
 844               KTOP0,                  lndj(KLON)
 845       LOGICAL  LDCUM(KLON)
 846       LOGICAL  LODDRAF(KLON),          LLO1
 847 !-------------------------------------------
 848 !     1.    SPECIFY CONSTANTS AND PARAMETERS
 849 !-------------------------------------------
 850   100 CONTINUE
 851       ZCONS2=1./(G*ZTMST)
 852 !--------------------------------------------------------------
 853 !*    2.    INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI'
 854 !--------------------------------------------------------------
 855   200 CONTINUE
 856       CALL CUINI &
 857          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
 858           PQEN,     PQSEN,    PUEN,     PVEN,     PVERV, &
 859           PGEO,     PAPH,     ZGEOH,    ZTENH,    ZQENH,  &
 860           ZQSENH,   ILWMIN,   PTU,      PQU,      ZTD,   &
 861           ZQD,      ZUU,      ZVU,      ZUD,      ZVD,   &
 862           PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ, &
 863           ZMFDQ,    ZDMFUP,   ZDMFDP,   ZDPMEL,   PLU,  &
 864           PLUDE,    ILAB)
 865 !----------------------------------
 866 !*    3.0   CLOUD BASE CALCULATIONS
 867 !----------------------------------
 868   300 CONTINUE
 869 !*         (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE'
 870 !          -------------------------------------------
 871       CALL CUBASE &
 872          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH, &
 873           ZQENH,    ZGEOH,    PAPH,     PTU,      PQU,   &
 874           PLU,      PUEN,     PVEN,     ZUU,      ZVU,   &
 875           LDCUM,    KCBOT,    ILAB)
 876 !*          (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND
 877 !*              THEN DECIDE ON TYPE OF CUMULUS CONVECTION
 878 !               -----------------------------------------
 879        JK=1
 880        DO 310 JL=1,KLON
 881        ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
 882        ZDQPBL(JL)=0.0
 883        IDTOP(JL)=0
 884   310  CONTINUE
 885        DO 320 JK=2,KLEV
 886        DO 315 JL=1,KLON
 887        ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
 888        IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK)  &
 889                                     *(PAPH(JL,JK+1)-PAPH(JL,JK))
 890   315 CONTINUE
 891   320 CONTINUE
 892       DO 340 JL=1,KLON
 893          KTYPE(JL)=0
 894       IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN
 895          KTYPE(JL)=1
 896       ELSE
 897          KTYPE(JL)=2
 898       ENDIF
 899 !*         (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER
 900 !*             AND DETERMINE CLOUD BASE MASSFLUX IGNORING
 901 !*             THE EFFECTS OF DOWNDRAFTS AT THIS STAGE
 902 !              ------------------------------------------
 903       IKB=KCBOT(JL)
 904       ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB)
 905       ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
 906       IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN
 907          ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
 908       ELSE
 909          ZMFUB(JL)=0.01
 910          LDCUM(JL)=.FALSE.
 911       ENDIF
 912       ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
 913       ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX)
 914 !------------------------------------------------------
 915 !*    4.0   DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
 916 !------------------------------------------------------
 917   400 CONTINUE
 918 !*         (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT
 919 !*             CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT
 920 !*             FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974)
 921 ! -------------------------------------------------------------
 922       IKB=KCBOT(JL)
 923       ZHCBASE(JL)=CPD*PTU(JL,IKB)+ZGEOH(JL,IKB)+ALV*PQU(JL,IKB)
 924       ICTOP0(JL)=KCBOT(JL)-1
 925   340 CONTINUE
 926       ZALVDCP=ALV/CPD
 927       ZQALV=1./ALV
 928       DO 420 JK=KLEVM1,3,-1
 929       DO 420 JL=1,KLON
 930       ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
 931       ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/  &
 932           ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
 933       ZZZ=CPD*ZTENH(JL,JK)*0.608
 934       ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
 935                  MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
 936       ZHHATT(JL,JK)=ZHHAT
 937       IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK
 938   420 CONTINUE
 939       DO 430 JL=1,KLON
 940       JK=KCBOT(JL)
 941       ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
 942       ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/   &
 943           ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
 944       ZZZ=CPD*ZTENH(JL,JK)*0.608
 945       ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
 946                  MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
 947       ZHHATT(JL,JK)=ZHHAT
 948   430 CONTINUE
 949 !
 950 ! Find lowest possible org. detrainment level
 951 !
 952       DO 440 JL = 1, KLON
 953          ZHMIN(JL) = 0.
 954          IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN
 955             IHMIN(JL) = KCBOT(JL)
 956          ELSE
 957             IHMIN(JL) = -1
 958          END IF
 959  440  CONTINUE
 960 !
 961       ZBI = 1./(25.*G)
 962       DO 450 JK = KLEV, 1, -1
 963       DO 450 JL = 1, KLON
 964       LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL)
 965       IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN
 966         IKB = KCBOT(JL)
 967         ZRO = RD*ZTENH(JL,JK)/(G*PAPH(JL,JK))
 968         ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO
 969         ZDHDZ=(CPD*(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV*(PQEN(JL,JK-1)-   &
 970           PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL,      &
 971           JK-1)-PGEO(JL,JK))
 972         ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB)
 973         ZFAC = SQRT(1.+ZDEPTH*ZBI)
 974         ZHMIN(JL) = ZHMIN(JL) + ZDHDZ*ZFAC*ZDZ
 975         ZRH = -ALV*(ZQSENH(JL,JK)-ZQENH(JL,JK))*ZFAC
 976         IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK
 977       END IF
 978  450  CONTINUE
 979       DO 460 JL = 1, KLON
 980       IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
 981         IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL)
 982       END IF
 983       if(nentr.eq.1) then
 984         IF(KTYPE(JL).EQ.1) THEN
 985           ZENTR(JL)=ENTRPEN
 986         ELSE
 987           ZENTR(JL)=ENTRSCV
 988         ENDIF
 989         if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
 990       else
 991         ZDEPTH=ZRG*(ZGEOH(JL,ICTOP0(JL))-ZGEOH(JL,KCBOT(JL)))
 992         ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
 993         if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
 994       endif
 995  460  CONTINUE
 996 !*         (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS
 997 !----------------------------------------------------------
 998       CALL CUASC_NEW &
 999          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,   &
1000           ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,    &
1001           PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,    &
1002           PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE, &
1003           KTYPE,    ILAB,     PTU,      PQU,      PLU,     &
1004           ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,   &
1005           ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP,  &
1006           KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,   &
1007           IHMIN,    ZHHATT,   ZQSENH)
1008       IF(ICUM.EQ.0) GO TO 1000
1009 !*     (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY
1010 !          CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION)
1011 !------------------------------------------------------------------
1012       DO 480 JL=1,KLON
1013       ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL))
1014       IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL)
1015       IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2
1016       IF(KTYPE(JL).EQ.2.and.nentr.eq.1) then
1017         ZENTR(JL)=ENTRSCV
1018         if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
1019       endif
1020       if(nentr.eq.2) then
1021         ZDEPTH=ZRG*(ZGEOH(JL,KCTOP(JL))-ZGEOH(JL,KCBOT(JL)))
1022         ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
1023         if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
1024       endif
1025       ZRFL(JL)=ZDMFUP(JL,1)
1026   480 CONTINUE
1027       DO 490 JK=2,KLEV
1028       DO 490 JL=1,KLON
1029           ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK)
1030   490 CONTINUE
1031 !-----------------------------------------
1032 !*    5.0   CUMULUS DOWNDRAFT CALCULATIONS
1033 !-----------------------------------------
1034   500 CONTINUE
1035       IF(LMFDD) THEN
1036 !*      (A) DETERMINE LFS IN 'CUDLFS'
1037 !--------------------------------------
1038          CALL CUDLFS &
1039          (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
1040           PUEN,     PVEN,     ZGEOH,    PAPH,     PTU,    &
1041           PQU,      ZUU,      ZVU,      LDCUM,    KCBOT,  &
1042           KCTOP,    ZMFUB,    ZRFL,     ZTD,      ZQD,    &
1043           ZUD,      ZVD,      PMFD,     ZMFDS,    ZMFDQ,  &
1044           ZDMFDP,   IDTOP,    LODDRAF)
1045 !*     (B)  DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF'
1046 !------------------------------------------------------------
1047          CALL CUDDRAF &
1048          (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
1049           PUEN,     PVEN,     ZGEOH,    PAPH,     ZRFL,   &
1050           LODDRAF,  ZTD,      ZQD,      ZUD,      ZVD,    &
1051           PMFD,     ZMFDS,    ZMFDQ,    ZDMFDP)
1052 !*     (C)  RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
1053 !           DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
1054 !-----------------------------------------------------------
1055       END IF
1056 !
1057 !-- 5.1 Recalculate cloud base massflux from a cape closure
1058 !       for deep convection (ktype=1) and by PBL equilibrium
1059 !       taking downdrafts into account for shallow convection
1060 !       (ktype=2)
1061 !       implemented by Y. WANG based on ECHAM4 in Nov. 2001.
1062 !
1063       DO 510 JL=1,KLON
1064         ZHEAT(JL)=0.0
1065         ZCAPE(JL)=0.0
1066         ZRELH(JL)=0.0
1067         ZMFUB1(JL)=ZMFUB(JL)
1068   510 CONTINUE
1069 !
1070       DO 511 JL=1,KLON
1071       IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
1072       KTOP0=MAX(12,KCTOP(JL))
1073        DO JK=2,KLEV
1074        IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN
1075          ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK))
1076          ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO)
1077          ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK)   &
1078            +G*ZDZ/CPD)/ZTENH(JL,JK)+0.608*(PQEN(JL,JK-1)-  &
1079            PQEN(JL,JK)))*(PMFU(JL,JK)+PMFD(JL,JK))*G/ZRO
1080          ZCAPE(JL)=ZCAPE(JL)+G*((PTU(JL,JK)*(1.+.608*PQU(JL,JK) &
1081            -PLU(JL,JK)))/(ZTENH(JL,JK)*(1.+.608*ZQENH(JL,JK))) &
1082            -1.0)*ZDZ
1083        ENDIF
1084        IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN
1085          dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))-  &
1086             PAPH(JL,KTOP0))
1087          ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK)
1088        ENDIF
1089        ENDDO
1090 !
1091        IF(ZRELH(JL).GE.CRIRH) THEN
1092          IKB=KCBOT(JL)
1093 !         ZHT=MAX(0.0,(ZCAPE(JL)-300.0))/(ZTAU*ZHEAT(JL))
1094          ZHT=MAX(0.0,(ZCAPE(JL)-0.0))/(ZTAU*ZHEAT(JL))
1095          ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01)
1096          ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
1097          ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
1098        ELSE
1099          ZMFUB1(JL)=0.01
1100          ZMFUB(JL)=0.01
1101          LDCUM(JL)=.FALSE.
1102         ENDIF
1103        ENDIF
1104   511  CONTINUE
1105 !
1106 !*  5.2   RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
1107 !         DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
1108 !--------------------------------------------------------
1109        DO 512 JL=1,KLON
1110         IF(KTYPE(JL).NE.1) THEN
1111            IKB=KCBOT(JL)
1112            IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN
1113               ZEPS=CMFDEPS
1114            ELSE
1115               ZEPS=0.
1116            ENDIF
1117            ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-          &
1118                  ZEPS*ZQD(JL,IKB)-(1.-ZEPS)*ZQENH(JL,IKB)
1119            ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
1120            ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
1121            IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) &
1122              .AND.ZMFUB(JL).LT.ZMFMAX) THEN
1123               ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
1124            ELSE
1125               ZMFUB1(JL)=ZMFUB(JL)
1126            ENDIF
1127            LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL)  &
1128                 -ZMFUB(JL)).LT.0.2*ZMFUB(JL)
1129            IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL)
1130            ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
1131         END IF
1132   512   CONTINUE
1133         DO 530 JK=1,KLEV
1134         DO 530 JL=1,KLON
1135         IF(LDCUM(JL)) THEN
1136            ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10)
1137            PMFD(JL,JK)=PMFD(JL,JK)*ZFAC
1138            ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC
1139            ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC
1140            ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC
1141         ELSE
1142            PMFD(JL,JK)=0.0
1143            ZMFDS(JL,JK)=0.0
1144            ZMFDQ(JL,JK)=0.0
1145            ZDMFDP(JL,JK)=0.0
1146         ENDIF
1147   530   CONTINUE
1148         DO 538 JL=1,KLON
1149            IF(LDCUM(JL)) THEN
1150               ZMFUB(JL)=ZMFUB1(JL)
1151            ELSE
1152               ZMFUB(JL)=0.0
1153            ENDIF
1154   538   CONTINUE
1155 !
1156 !---------------------------------------------------------------
1157 !*    6.0      DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME
1158 !*             FOR PENETRATIVE CONVECTION (TYPE=1),
1159 !*             FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2)
1160 !*             AND FOR MID-LEVEL CONVECTION (TYPE=3).
1161 !---------------------------------------------------------------
1162   600 CONTINUE
1163       CALL CUASC_NEW &
1164          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,  &
1165           ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
1166           PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,   &
1167           PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE,&
1168           KTYPE,    ILAB,     PTU,      PQU,      PLU,    &
1169           ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,  &
1170           ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP, &
1171           KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,  &
1172           IHMIN,    ZHHATT,   ZQSENH)
1173 !----------------------------------------------------------
1174 !*    7.0      DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX'
1175 !----------------------------------------------------------
1176   700 CONTINUE
1177       CALL CUFLX &
1178          (KLON,     KLEV,     KLEVP1,   PQEN,     PQSEN,  &
1179           ZTENH,    ZQENH,    PAPH,     ZGEOH,    KCBOT,  &
1180           KCTOP,    IDTOP,    KTYPE,    LODDRAF,  LDCUM,  &
1181           PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ,  &
1182           ZMFDQ,    ZMFUL,    PLUDE,    ZDMFUP,   ZDMFDP, &
1183           ZRFL,     PRAIN,    PTEN,     ZSFL,     ZDPMEL, &
1184           ITOPM2,   ZTMST,    sig1)
1185 !----------------------------------------------------------------
1186 !*    8.0      UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ
1187 !----------------------------------------------------------------
1188   800 CONTINUE
1189       CALL CUDTDQ                                          &
1190          (KLON,     KLEV,     KLEVP1,   ITOPM2,   PAPH,    &
1191           LDCUM,    PTEN,     PTTE,     PQTE,     ZMFUS,   &
1192           ZMFDS,    ZMFUQ,    ZMFDQ,    ZMFUL,    ZDMFUP,  &
1193           ZDMFDP,   ZTMST,    ZDPMEL,   PRAIN,    ZRFL,    &
1194           ZSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT,  &
1195           PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,   &
1196           PQEN,     PQSEN,    PLUDE,    PCTE)
1197 !----------------------------------------------------------------
1198 !*    9.0      UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV
1199 !----------------------------------------------------------------
1200   900 CONTINUE
1201       IF(LMFDUDV) THEN
1202       CALL CUDUDV  &
1203          (KLON,     KLEV,     KLEVP1,   ITOPM2,   KTYPE,   &
1204           KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,    &
1205           PVOM,     PVOL,     ZUU,      ZUD,      ZVU,     &
1206           ZVD,      PMFU,     PMFD,     PSDISS)
1207       END IF
1208  1000 CONTINUE
1209       RETURN
1210       END SUBROUTINE CUMASTR_NEW
1211 !
1212
1213 !#############################################################
1214 !
1215 !             LEVEL 3 SUBROUTINEs
1216 !
1217 !#############################################################
1218 !**********************************************
1219 !       SUBROUTINE CUINI
1220 !**********************************************
1221 !
1222       SUBROUTINE CUINI                                    &
1223          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,   &
1224           PQEN,     PQSEN,    PUEN,     PVEN,     PVERV,  &
1225           PGEO,     PAPH,     PGEOH,    PTENH,    PQENH,  &
1226           PQSENH,   KLWMIN,   PTU,      PQU,      PTD,    &
1227           PQD,      PUU,      PVU,      PUD,      PVD,    &
1228           PMFU,     PMFD,     PMFUS,    PMFDS,    PMFUQ,  &
1229           PMFDQ,    PDMFUP,   PDMFDP,   PDPMEL,   PLU,    &
1230           PLUDE,    KLAB)
1231 !      M.TIEDTKE         E.C.M.W.F.     12/89
1232 !***PURPOSE
1233 !   -------
1234 !          THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
1235 !          TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
1236 !          AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS
1237 !***INTERFACE
1238 !   ---------
1239 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
1240 !***METHOD.
1241 !  --------
1242 !          FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989)
1243 !***EXTERNALS
1244 !   ---------
1245 !          *CUADJTQ* TO SPECIFY QS AT HALF LEVELS
1246 ! ----------------------------------------------------------------
1247 !-------------------------------------------------------------------
1248       IMPLICIT NONE
1249 !-------------------------------------------------------------------
1250       INTEGER   KLON, KLEV, KLEVP1
1251       INTEGER   klevm1
1252       INTEGER   JK,JL,IK, ICALL
1253       REAL      ZDP, ZZS
1254       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),    &
1255               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
1256               PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),    &
1257               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),    &
1258               PAPH(KLON,KLEVP1),      PTENH(KLON,KLEV),    &
1259               PQENH(KLON,KLEV),       PQSENH(KLON,KLEV)
1260       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),     &
1261               PTD(KLON,KLEV),         PQD(KLON,KLEV),      &
1262               PUU(KLON,KLEV),         PUD(KLON,KLEV),      &
1263               PVU(KLON,KLEV),         PVD(KLON,KLEV),      &
1264               PMFU(KLON,KLEV),        PMFD(KLON,KLEV),     &
1265               PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),    &
1266               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),    &
1267               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),   &
1268               PLU(KLON,KLEV),         PLUDE(KLON,KLEV)
1269       REAL     ZWMAX(KLON),            ZPH(KLON),          &
1270               PDPMEL(KLON,KLEV)
1271       INTEGER  KLAB(KLON,KLEV),        KLWMIN(KLON)
1272       LOGICAL  LOFLAG(KLON)
1273 !------------------------------------------------------------
1274 !*    1.       SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
1275 !*             ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
1276 !*             FIND LEVEL OF MAXIMUM VERTICAL VELOCITY
1277 ! -----------------------------------------------------------
1278   100 CONTINUE
1279       ZDP=0.5
1280       DO 130 JK=2,KLEV
1281       DO 110 JL=1,KLON
1282       PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP
1283       PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1),   &
1284                   CPD*PTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))*RCPD
1285       PQSENH(JL,JK)=PQSEN(JL,JK-1)
1286       ZPH(JL)=PAPH(JL,JK)
1287       LOFLAG(JL)=.TRUE.
1288   110 CONTINUE
1289       IK=JK
1290       ICALL=0
1291       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL)
1292       DO 120 JL=1,KLON
1293       PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1))    &
1294                  +(PQSENH(JL,JK)-PQSEN(JL,JK-1))
1295       PQENH(JL,JK)=MAX(PQENH(JL,JK),0.)
1296   120 CONTINUE
1297   130 CONTINUE
1298       DO 140 JL=1,KLON
1299       PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)-   &
1300                      PGEOH(JL,KLEV))*RCPD
1301       PQENH(JL,KLEV)=PQEN(JL,KLEV)
1302       PTENH(JL,1)=PTEN(JL,1)
1303       PQENH(JL,1)=PQEN(JL,1)
1304       PGEOH(JL,1)=PGEO(JL,1)
1305       KLWMIN(JL)=KLEV
1306       ZWMAX(JL)=0.
1307   140 CONTINUE
1308       DO 160 JK=KLEVM1,2,-1
1309       DO 150 JL=1,KLON
1310       ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK),   &
1311              CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))
1312       PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD
1313   150 CONTINUE
1314   160 CONTINUE
1315       DO 190 JK=KLEV,3,-1
1316       DO 180 JL=1,KLON
1317       IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN
1318          ZWMAX(JL)=PVERV(JL,JK)
1319          KLWMIN(JL)=JK
1320       END IF
1321   180 CONTINUE
1322   190 CONTINUE
1323 !-----------------------------------------------------------
1324 !*    2.0      INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
1325 !-----------------------------------------------------------
1326   200 CONTINUE
1327       DO 230 JK=1,KLEV
1328       IK=JK-1
1329       IF(JK.EQ.1) IK=1
1330       DO 220 JL=1,KLON
1331       PTU(JL,JK)=PTENH(JL,JK)
1332       PTD(JL,JK)=PTENH(JL,JK)
1333       PQU(JL,JK)=PQENH(JL,JK)
1334       PQD(JL,JK)=PQENH(JL,JK)
1335       PLU(JL,JK)=0.
1336       PUU(JL,JK)=PUEN(JL,IK)
1337       PUD(JL,JK)=PUEN(JL,IK)
1338       PVU(JL,JK)=PVEN(JL,IK)
1339       PVD(JL,JK)=PVEN(JL,IK)
1340       PMFU(JL,JK)=0.
1341       PMFD(JL,JK)=0.
1342       PMFUS(JL,JK)=0.
1343       PMFDS(JL,JK)=0.
1344       PMFUQ(JL,JK)=0.
1345       PMFDQ(JL,JK)=0.
1346       PDMFUP(JL,JK)=0.
1347       PDMFDP(JL,JK)=0.
1348       PDPMEL(JL,JK)=0.
1349       PLUDE(JL,JK)=0.
1350       KLAB(JL,JK)=0
1351   220 CONTINUE
1352   230 CONTINUE
1353       RETURN
1354       END SUBROUTINE CUINI
1355
1356 !**********************************************
1357 !       SUBROUTINE CUBASE
1358 !**********************************************
1359       SUBROUTINE CUBASE &
1360          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH, &
1361           PQENH,    PGEOH,    PAPH,     PTU,      PQU,   &
1362           PLU,      PUEN,     PVEN,     PUU,      PVU,   &
1363           LDCUM,    KCBOT,    KLAB)
1364 !      THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
1365 !      FOR CUMULUS PARAMETERIZATION
1366 !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
1367 !***PURPOSE.
1368 !   --------
1369 !          TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION
1370 !***INTERFACE
1371 !   ---------
1372 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
1373 !          INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
1374 !          IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
1375 !                 KLAB=1 FOR SUBCLOUD LEVELS
1376 !                 KLAB=2 FOR CONDENSATION LEVEL
1377 !***METHOD.
1378 !  --------
1379 !          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
1380 !          (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
1381 !***EXTERNALS
1382 !   ---------
1383 !          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
1384 ! ----------------------------------------------------------------
1385 !-------------------------------------------------------------------
1386       IMPLICIT NONE
1387 !-------------------------------------------------------------------
1388       INTEGER   KLON, KLEV, KLEVP1
1389       INTEGER   klevm1
1390       INTEGER   JL,JK,IS,IK,ICALL,IKB
1391       REAL      ZBUO,ZZ
1392       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
1393               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1)
1394       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
1395               PLU(KLON,KLEV)
1396       REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
1397               PUU(KLON,KLEV),         PVU(KLON,KLEV)
1398       REAL     ZQOLD(KLON,KLEV),       ZPH(KLON)
1399       INTEGER  KLAB(KLON,KLEV),        KCBOT(KLON)
1400       LOGICAL  LDCUM(KLON),            LOFLAG(KLON)
1401 !***INPUT VARIABLES:
1402 !       PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
1403 !       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
1404 !       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
1405 !       PAPH - Pressure of half levels. (MSSFLX)
1406 !***VARIABLES MODIFIED BY CUBASE:
1407 !       LDCUM - Logical denoting profiles. (CUBASE)
1408 !       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
1409 !                                 2: Stratocumulus (CUMASTR)
1410 !                                 3: Mid-level  (CUASC)
1411 !       PTU - Cloud Temperature.
1412 !       PQU - Cloud specific Humidity.
1413 !       PLU - Cloud Liquid Water (Moisture condensed out)
1414 !       KCBOT - Cloud Base Level. (CUBASE)
1415 !       KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE)
1416 !------------------------------------------------
1417 !     1.       INITIALIZE VALUES AT LIFTING LEVEL
1418 !------------------------------------------------
1419   100 CONTINUE
1420       DO 110 JL=1,KLON
1421         KLAB(JL,KLEV)=1
1422         KCBOT(JL)=KLEVM1
1423         LDCUM(JL)=.FALSE.
1424         PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
1425         PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
1426   110 CONTINUE
1427 !-------------------------------------------------------
1428 !     2.0      DO ASCENT IN SUBCLOUD LAYER,
1429 !              CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
1430 !              ADJUST T,Q AND L ACCORDINGLY IN *CUADJTQ*,
1431 !              CHECK FOR BUOYANCY AND SET FLAGS
1432 !-------------------------------------------------------
1433       DO 200 JK=1,KLEV
1434       DO 200 JL=1,KLON
1435         ZQOLD(JL,JK)=0.0
1436   200 CONTINUE
1437       DO 290 JK=KLEVM1,2,-1
1438         IS=0
1439         DO 210 JL=1,KLON
1440           IF(KLAB(JL,JK+1).EQ.1) THEN
1441              IS=IS+1
1442              LOFLAG(JL)=.TRUE.
1443           ELSE
1444              LOFLAG(JL)=.FALSE.
1445           ENDIF
1446           ZPH(JL)=PAPH(JL,JK)
1447   210   CONTINUE
1448         IF(IS.EQ.0) GO TO 290
1449         DO 220 JL=1,KLON
1450           IF(LOFLAG(JL)) THEN
1451              PQU(JL,JK)=PQU(JL,JK+1)
1452              PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1)  &
1453                        -PGEOH(JL,JK))*RCPD
1454              ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
1455                  PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
1456              IF(ZBUO.GT.0.) KLAB(JL,JK)=1
1457              ZQOLD(JL,JK)=PQU(JL,JK)
1458           END IF
1459   220   CONTINUE
1460         IK=JK
1461         ICALL=1
1462         CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
1463         DO 240 JL=1,KLON
1464           IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN
1465              KLAB(JL,JK)=2
1466              PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK)
1467              ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
1468                  PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
1469              IF(ZBUO.GT.0.) THEN
1470                 KCBOT(JL)=JK
1471                 LDCUM(JL)=.TRUE.
1472              END IF
1473           END IF
1474   240   CONTINUE
1475 !             CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,.
1476 !             THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES.
1477         IF(LMFDUDV) THEN
1478            DO 250 JL=1,KLON
1479              IF(JK.GE.KCBOT(JL)) THEN
1480                 PUU(JL,KLEV)=PUU(JL,KLEV)+           &
1481                           PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
1482                 PVU(JL,KLEV)=PVU(JL,KLEV)+           &
1483                           PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
1484              END IF
1485  250       CONTINUE
1486         END IF
1487   290 CONTINUE
1488       IF(LMFDUDV) THEN
1489          DO 310 JL=1,KLON
1490          IF(LDCUM(JL)) THEN
1491             IKB=KCBOT(JL)
1492             ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB))
1493             PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ
1494             PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ
1495          ELSE
1496             PUU(JL,KLEV)=PUEN(JL,KLEVM1)
1497             PVU(JL,KLEV)=PVEN(JL,KLEVM1)
1498          END IF
1499  310     CONTINUE
1500       END IF
1501       RETURN
1502       END SUBROUTINE CUBASE
1503
1504 !
1505 !**********************************************
1506 !       SUBROUTINE CUASC_NEW
1507 !**********************************************
1508       SUBROUTINE CUASC_NEW &
1509          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH,  &
1510           PQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
1511           PQSEN,    PGEO,     PGEOH,    PAP,      PAPH,   &
1512           PQTE,     PVERV,    KLWMIN,   LDCUM,    PHCBASE,&
1513           KTYPE,    KLAB,     PTU,      PQU,      PLU,    &
1514           PUU,      PVU,      PMFU,     PMFUB,    PENTR,  &
1515           PMFUS,    PMFUQ,    PMFUL,    PLUDE,    PDMFUP, &
1516           KCBOT,    KCTOP,    KCTOP0,   KCUM,     ZTMST,  &
1517           KHMIN,    PHHATT,   PQSENH)
1518 !     THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
1519 !     FOR CUMULUS PARAMETERIZATION
1520 !     M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
1521 !     Y.WANG            IPRC           11/01 MODIF.
1522 !***PURPOSE.
1523 !   --------
1524 !          TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION
1525 !          (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING
1526 !           FLUXES AS WELL AS PRECIPITATION RATES)
1527 !***INTERFACE
1528 !   ---------
1529 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
1530 !***METHOD.
1531 !  --------
1532 !          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
1533 !          AND THEN CALCULATE MOIST ASCENT FOR
1534 !          ENTRAINING/DETRAINING PLUME.
1535 !          ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR
1536 !          SHALLOW AND DEEP CUMULUS CONVECTION.
1537 !          IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION
1538 !          CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION
1539 !          (CLOUD BASE VALUES CALCULATED IN *CUBASMC*)
1540 !***EXTERNALS
1541 !   ---------
1542 !          *CUADJTQ* ADJUST T AND Q DUE TO CONDENSATION IN ASCENT
1543 !          *CUENTR_NEW*  CALCULATE ENTRAINMENT/DETRAINMENT RATES
1544 !          *CUBASMC* CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
1545 !***REFERENCE
1546 !   ---------
1547 !          (TIEDTKE,1989)
1548 !***INPUT VARIABLES:
1549 !       PTENH [ZTENH] - Environ Temperature on half levels. (CUINI)
1550 !       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
1551 !       PUEN - Environment wind u-component. (MSSFLX)
1552 !       PVEN - Environment wind v-component. (MSSFLX)
1553 !       PTEN - Environment Temperature. (MSSFLX)
1554 !       PQEN - Environment Specific Humidity. (MSSFLX)
1555 !       PQSEN - Environment Saturation Specific Humidity. (MSSFLX)
1556 !       PGEO - Geopotential. (MSSFLX)
1557 !       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
1558 !       PAP - Pressure in Pa.  (MSSFLX)
1559 !       PAPH - Pressure of half levels. (MSSFLX)
1560 !       PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX)
1561 !       PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX)
1562 !       KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI)
1563 !       KLAB [ILAB] - Level Label - 1: Sub-cloud layer.
1564 !                                   2: Condensation Level (Cloud Base)
1565 !       PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR)
1566 !***VARIABLES MODIFIED BY CUASC:
1567 !       LDCUM - Logical denoting profiles. (CUBASE)
1568 !       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
1569 !                                 2: Stratocumulus (CUMASTR)
1570 !                                 3: Mid-level  (CUASC)
1571 !       PTU - Cloud Temperature.
1572 !       PQU - Cloud specific Humidity.
1573 !       PLU - Cloud Liquid Water (Moisture condensed out)
1574 !       PUU [ZUU] - Cloud Momentum U-Component.
1575 !       PVU [ZVU] - Cloud Momentum V-Component.
1576 !       PMFU - Updraft Mass Flux.
1577 !       PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC)
1578 !       PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC)
1579 !       PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity.
1580 !       PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water.
1581 !       PLUDE - Liquid Water Returned to Environment by Detrainment.
1582 !       PDMFUP [ZMFUP] -
1583 !       KCBOT - Cloud Base Level. (CUBASE)
1584 !       KCTOP -
1585 !       KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR)
1586 !       KCUM [ICUM] -
1587 !-------------------------------------------------------------------
1588       IMPLICIT NONE
1589 !-------------------------------------------------------------------
1590       INTEGER   KLON, KLEV, KLEVP1
1591       INTEGER   klevm1,kcum
1592       REAL      ZTMST,ZCONS2,ZDZ,ZDRODZ
1593       INTEGER   JL,JK,IKB,IK,IS,IKT,ICALL
1594       REAL      ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX
1595       REAL      ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD
1596       REAL      ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK
1597       REAL      ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU
1598       REAL      ZBUOYZ,ZZDMF
1599       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV), &
1600               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
1601               PTEN(KLON,KLEV),        PQEN(KLON,KLEV),   &
1602               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),  &
1603               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1), &
1604               PQSEN(KLON,KLEV),       PQTE(KLON,KLEV),   &
1605               PVERV(KLON,KLEV),       PQSENH(KLON,KLEV)
1606       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
1607               PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
1608               PMFU(KLON,KLEV),        ZPH(KLON),         &
1609               PMFUB(KLON),            PENTR(KLON),       &
1610               PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
1611               PLU(KLON,KLEV),         PLUDE(KLON,KLEV),  &
1612               PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV)
1613       REAL     ZDMFEN(KLON),           ZDMFDE(KLON),     &
1614               ZMFUU(KLON),            ZMFUV(KLON),       &
1615               ZPBASE(KLON),           ZQOLD(KLON),       &
1616               PHHATT(KLON,KLEV),      ZODETR(KLON,KLEV), &
1617               ZOENTR(KLON,KLEV),      ZBUOY(KLON)
1618       REAL     PHCBASE(KLON)
1619       INTEGER  KLWMIN(KLON),           KTYPE(KLON),      &
1620               KLAB(KLON,KLEV),        KCBOT(KLON),       &
1621               KCTOP(KLON),            KCTOP0(KLON),      &
1622               KHMIN(KLON)
1623       LOGICAL  LDCUM(KLON),            LOFLAG(KLON)
1624 !--------------------------------
1625 !*    1.       SPECIFY PARAMETERS
1626 !--------------------------------
1627   100 CONTINUE
1628       ZCONS2=1./(G*ZTMST)
1629 !---------------------------------
1630 !     2.        SET DEFAULT VALUES
1631 !---------------------------------
1632   200 CONTINUE
1633       DO 210 JL=1,KLON
1634         ZMFUU(JL)=0.
1635         ZMFUV(JL)=0.
1636         ZBUOY(JL)=0.
1637         IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
1638   210 CONTINUE
1639       DO 230 JK=1,KLEV
1640       DO 230 JL=1,KLON
1641           PLU(JL,JK)=0.
1642           PMFU(JL,JK)=0.
1643           PMFUS(JL,JK)=0.
1644           PMFUQ(JL,JK)=0.
1645           PMFUL(JL,JK)=0.
1646           PLUDE(JL,JK)=0.
1647           PDMFUP(JL,JK)=0.
1648           ZOENTR(JL,JK)=0.
1649           ZODETR(JL,JK)=0.
1650           IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0
1651           IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK
1652   230 CONTINUE
1653 !------------------------------------------------
1654 !     3.0      INITIALIZE VALUES AT LIFTING LEVEL
1655 !------------------------------------------------
1656       DO 310 JL=1,KLON
1657         KCTOP(JL)=KLEVM1
1658         IF(.NOT.LDCUM(JL)) THEN
1659            KCBOT(JL)=KLEVM1
1660            PMFUB(JL)=0.
1661            PQU(JL,KLEV)=0.
1662         END IF
1663         PMFU(JL,KLEV)=PMFUB(JL)
1664         PMFUS(JL,KLEV)=PMFUB(JL)*(CPD*PTU(JL,KLEV)+PGEOH(JL,KLEV))
1665         PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV)
1666         IF(LMFDUDV) THEN
1667            ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV)
1668            ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV)
1669         END IF
1670   310 CONTINUE
1671 !
1672 !-- 3.1 Find organized entrainment at cloud base
1673 !
1674       DO 322 JL=1,KLON
1675       LDCUM(JL)=.FALSE.
1676       IF (KTYPE(JL).EQ.1) THEN
1677       IKB = KCBOT(JL)
1678       ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ &
1679                0.608*(PQU(JL,IKB)-PQENH(JL,IKB)))
1680        IF (ZBUOY(JL).GT.0.) THEN
1681         ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG
1682         ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ -  &
1683                  G/(RD*PTENH(JL,IKB))
1684         ZOENTR(JL,IKB-1)=ZBUOY(JL)*0.5/(1.+ZBUOY(JL)*ZDZ) &
1685                 +ZDRODZ
1686         ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3)
1687         ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.)
1688        END IF
1689       END IF
1690   322 CONTINUE
1691 !
1692 !-----------------------------------------------------------------
1693 !     4.       DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2)
1694 !              BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
1695 !              BY ADJUSTING T,Q AND L ACCORDINGLY IN *CUADJTQ*,
1696 !              THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
1697 !-----------------------------------------------------------------
1698   400 CONTINUE
1699       DO 480 JK=KLEVM1,2,-1
1700 !                  SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
1701 !                  IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION
1702 ! ---------------------------------------------------------------------
1703       IK=JK
1704       IF(LMFMID.AND.IK.LT.KLEVM1.AND.IK.GT.KLEV-13) THEN
1705       CALL CUBASMC  &
1706          (KLON,     KLEV,     KLEVM1,   IK,      PTEN,  &
1707           PQEN,     PQSEN,    PUEN,     PVEN,    PVERV, &
1708           PGEO,     PGEOH,    LDCUM,    KTYPE,   KLAB,  &
1709           PMFU,     PMFUB,    PENTR,    KCBOT,   PTU,   &
1710           PQU,      PLU,      PUU,     PVU,      PMFUS, &
1711           PMFUQ,    PMFUL,    PDMFUP,  ZMFUU,    ZMFUV)
1712       ENDIF
1713       IS=0
1714       DO 410 JL=1,KLON
1715         ZQOLD(JL)=0.0
1716         IS=IS+KLAB(JL,JK+1)
1717         IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0
1718         LOFLAG(JL)=KLAB(JL,JK+1).GT.0
1719         ZPH(JL)=PAPH(JL,JK)
1720         IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN
1721            ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2
1722            IF(PMFUB(JL).GT.ZMFMAX) THEN
1723               ZFAC=ZMFMAX/PMFUB(JL)
1724               PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC
1725               PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC
1726               PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC
1727               ZMFUU(JL)=ZMFUU(JL)*ZFAC
1728               ZMFUV(JL)=ZMFUV(JL)*ZFAC
1729               PMFUB(JL)=ZMFMAX
1730            END IF
1731         END IF
1732   410 CONTINUE
1733       IF(IS.EQ.0) GO TO 480
1734 !
1735 !*     SPECIFY ENTRAINMENT RATES IN *CUENTR_NEW*
1736 ! -------------------------------------
1737       IK=JK
1738       CALL CUENTR_NEW &
1739          (KLON,     KLEV,     KLEVP1,   IK,       PTENH,&
1740           PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM,&
1741           KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU, &
1742           PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
1743 !
1744 !      DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
1745 ! -------------------------------------------------------
1746 ! Do adiabatic ascent for entraining/detraining plume
1747 ! the cloud ensemble entrains environmental values
1748 ! in turbulent detrainment cloud ensemble values are detrained
1749 ! in organized detrainment the dry static energy and
1750 ! moisture that are neutral compared to the
1751 ! environmental air are detrained
1752 !
1753       DO 420 JL=1,KLON
1754       IF(LOFLAG(JL)) THEN
1755         IF(JK.LT.KCBOT(JL)) THEN
1756          ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
1757          ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2)
1758          ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.)
1759         END IF
1760         ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1))
1761         PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
1762         IF (JK.LT.kcbot(jl)) THEN
1763           zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
1764           zoentr(jl,jk) = zoentr(jl,jk)*zdprho*pmfu(jl,jk+1)
1765           zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk)
1766           zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2)
1767           zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.)
1768         END IF
1769 !
1770 ! limit organized detrainment to not allowing for too deep clouds
1771 !
1772         IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN
1773           zmse = cpd*ptu(jl,jk+1) + alv*pqu(jl,jk+1) + pgeoh(jl,jk+1)
1774           ikt = kctop0(jl)
1775           znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl,  &
1776                jk+1))*zrg
1777           IF (znevn.LE.0.) znevn = 1.
1778           zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
1779           zodmax = ((phcbase(jl)-zmse)/znevn)*zdprho*pmfu(jl,jk+1)
1780           zodmax = MAX(zodmax,0.)
1781           zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax)
1782         END IF
1783         zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk))
1784         pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk)
1785         ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL)
1786         zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk)
1787         ZSEEN=(CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFEN(JL)
1788         zseen=zseen+(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*  &
1789              zoentr(jl,jk)
1790         ZSCDE=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFDE(JL)
1791 ! find moist static energy that give nonbuoyant air
1792         zga = alv*pqsenh(jl,jk+1)/(rv*(ptenh(jl,jk+1)**2))
1793         zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, &
1794                jk+1)))/(1./ptenh(jl,jk+1)+0.608*zga)
1795         zscod = cpd*ptenh(jl,jk+1) + pgeoh(jl,jk+1) + cpd*zdt
1796         zscde = zscde + zodetr(jl,jk)*zscod
1797         zqude = pqu(jl,jk+1)*zdmfde(jl)
1798         zqcod = pqsenh(jl,jk+1) + zga*zdt
1799         zqude = zqude + zodetr(jl,jk)*zqcod
1800         plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
1801         plude(jl,jk) = plude(jl,jk)+plu(jl,jk+1)*zodetr(jl,jk)
1802         zmfusk = pmfus(jl,jk+1) + zseen - zscde
1803         zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude
1804         zmfulk = pmful(jl,jk+1) - plude(jl,jk)
1805         plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk)))
1806         pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk)))
1807         ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))-  &
1808             pgeoh(jl,jk))*rcpd
1809         ptu(jl,jk) = MAX(100.,ptu(jl,jk))
1810         ptu(jl,jk) = MIN(400.,ptu(jl,jk))
1811         zqold(jl) = pqu(jl,jk)
1812       END IF
1813   420 CONTINUE
1814 !*             DO CORRECTIONS FOR MOIST ASCENT
1815 !*             BY ADJUSTING T,Q AND L IN *CUADJTQ*
1816 !------------------------------------------------
1817       IK=JK
1818       ICALL=1
1819 !
1820       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
1821 !
1822       DO 440 JL=1,KLON
1823       IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN
1824          KLAB(JL,JK)=2
1825          PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK)
1826          ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK)-PLU(JL,JK))-  &
1827         PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
1828          IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0
1829          IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. &
1830                             JK.GE.KCTOP0(JL)) THEN
1831             KCTOP(JL)=JK
1832             LDCUM(JL)=.TRUE.
1833             IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN
1834                ZPRCON=CPRCON
1835             ELSE
1836                ZPRCON=0.
1837             ENDIF
1838             ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1)))
1839             PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK))
1840             PLU(JL,JK)=ZLNEW
1841          ELSE
1842             KLAB(JL,JK)=0
1843             PMFU(JL,JK)=0.
1844          END IF
1845       END IF
1846       IF(LOFLAG(JL)) THEN
1847          PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
1848          PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
1849          PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
1850       END IF
1851   440 CONTINUE
1852 !
1853       IF(LMFDUDV) THEN
1854 !
1855         DO 460 JL=1,KLON
1856         zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk)
1857         zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk)
1858            IF(LOFLAG(JL)) THEN
1859               IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN
1860                  IF(ZDMFEN(JL).LE.1.E-20) THEN
1861                     ZZ=3.
1862                  ELSE
1863                     ZZ=2.
1864                  ENDIF
1865               ELSE
1866                  IF(ZDMFEN(JL).LE.1.0E-20) THEN
1867                     ZZ=1.
1868                  ELSE
1869                     ZZ=0.
1870                  ENDIF
1871               END IF
1872               ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL)
1873               ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL)
1874               ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1))
1875               ZMFUU(JL)=ZMFUU(JL)+                              &
1876                        ZDMFEU*PUEN(JL,JK)-ZDMFDU*PUU(JL,JK+1)
1877               ZMFUV(JL)=ZMFUV(JL)+                              &
1878                        ZDMFEU*PVEN(JL,JK)-ZDMFDU*PVU(JL,JK+1)
1879               IF(PMFU(JL,JK).GT.0.) THEN
1880                  PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK))
1881                  PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK))
1882               END IF
1883            END IF
1884   460   CONTINUE
1885 !
1886         END IF
1887 !
1888 ! Compute organized entrainment
1889 ! for use at next level
1890 !
1891       DO 470 jl = 1, klon
1892        IF (loflag(jl).AND.ktype(jl).EQ.1) THEN
1893         zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+  &
1894               0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk))
1895         zbuoyz = MAX(zbuoyz,0.0)
1896         zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg
1897         zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz -  &
1898                  g/(rd*ptenh(jl,jk))
1899         zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz
1900         zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz
1901         zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
1902         zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
1903        END IF
1904   470 CONTINUE
1905 !
1906   480 CONTINUE
1907 ! -----------------------------------------------------------------
1908 !     5.       DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
1909 ! -----------------------------------------------------------------
1910 !                  (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
1911 !                         AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
1912 !                         FROM PREVIOUS CALCULATIONS ABOVE)
1913   500 CONTINUE
1914       DO 510 JL=1,KLON
1915       IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE.
1916       KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL))
1917   510 CONTINUE
1918       IS=0
1919       DO 520 JL=1,KLON
1920       IF(LDCUM(JL)) THEN
1921          IS=IS+1
1922       ENDIF
1923   520 CONTINUE
1924       KCUM=IS
1925       IF(IS.EQ.0) GO TO 800
1926       DO 530 JL=1,KLON
1927       IF(LDCUM(JL)) THEN
1928          JK=KCTOP(JL)-1
1929          ZZDMF=CMFCTOP
1930          ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1)
1931          PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1)
1932          PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL)
1933          PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
1934          PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
1935          PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
1936          PLUDE(JL,JK-1)=PMFUL(JL,JK)
1937          PDMFUP(JL,JK)=0.
1938       END IF
1939   530 CONTINUE
1940         IF(LMFDUDV) THEN
1941            DO 540 JL=1,KLON
1942            IF(LDCUM(JL)) THEN
1943               JK=KCTOP(JL)-1
1944               PUU(JL,JK)=PUU(JL,JK+1)
1945               PVU(JL,JK)=PVU(JL,JK+1)
1946            END IF
1947   540      CONTINUE
1948         END IF
1949   800 CONTINUE
1950       RETURN
1951       END SUBROUTINE CUASC_NEW
1952 !
1953
1954 !**********************************************
1955 !       SUBROUTINE CUDLFS
1956 !**********************************************
1957       SUBROUTINE CUDLFS &
1958          (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH,  &
1959           PUEN,     PVEN,     PGEOH,    PAPH,     PTU,    &
1960           PQU,      PUU,      PVU,      LDCUM,    KCBOT,  &
1961           KCTOP,    PMFUB,    PRFL,     PTD,      PQD,    &
1962           PUD,      PVD,      PMFD,     PMFDS,    PMFDQ,  &
1963           PDMFDP,   KDTOP,    LDDRAF)
1964 !      THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
1965 !      CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
1966 !      M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
1967 !***PURPOSE.
1968 !   --------
1969 !          TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
1970 !          FOR MASSFLUX CUMULUS PARAMETERIZATION
1971 !***INTERFACE
1972 !   ---------
1973 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
1974 !          INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
1975 !          AND UPDRAFT VALUES T,Q,U AND V AND ALSO
1976 !          CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
1977 !          IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
1978 !***METHOD.
1979 !  --------
1980 !          CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
1981 !          MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
1982 !***EXTERNALS
1983 !   ---------
1984 !          *CUADJTQ* FOR CALCULATING WET BULB T AND Q AT LFS
1985 ! ----------------------------------------------------------------
1986 !-------------------------------------------------------------------
1987       IMPLICIT NONE
1988 !-------------------------------------------------------------------
1989       INTEGER   KLON, KLEV, KLEVP1
1990       INTEGER   JL,KE,JK,IS,IK,ICALL
1991       REAL      ZTTEST, ZQTEST, ZBUO, ZMFTOP
1992       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
1993               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
1994               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1),   &
1995               PTU(KLON,KLEV),         PQU(KLON,KLEV),      &
1996               PUU(KLON,KLEV),         PVU(KLON,KLEV),      &
1997               PMFUB(KLON),            PRFL(KLON)
1998       REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),     &
1999               PUD(KLON,KLEV),         PVD(KLON,KLEV),      &
2000               PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),    &
2001               PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV)
2002       REAL     ZTENWB(KLON,KLEV),      ZQENWB(KLON,KLEV),  &
2003               ZCOND(KLON),            ZPH(KLON)
2004       INTEGER  KCBOT(KLON),            KCTOP(KLON),        &
2005               KDTOP(KLON)
2006       LOGICAL  LDCUM(KLON),            LLo2(KLON),         &
2007               LDDRAF(KLON)
2008 !-----------------------------------------------
2009 !     1.       SET DEFAULT VALUES FOR DOWNDRAFTS
2010 !-----------------------------------------------
2011   100 CONTINUE
2012       DO 110 JL=1,KLON
2013       LDDRAF(JL)=.FALSE.
2014       KDTOP(JL)=KLEVP1
2015   110 CONTINUE
2016       IF(.NOT.LMFDD) GO TO 300
2017 !------------------------------------------------------------
2018 !     2.       DETERMINE LEVEL OF FREE SINKING BY
2019 !              DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
2020 !              FOR EVERY POINT AND PROCEED AS FOLLOWS:
2021 !                (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
2022 !                (2) DO MIXING WITH CUMULUS CLOUD AIR
2023 !                (3) CHECK FOR NEGATIVE BUOYANCY
2024 !              THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
2025 !              OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
2026 !              TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
2027 !              EVAPORATION OF RAIN AND CLOUD WATER)
2028 !------------------------------------------------------------------
2029   200 CONTINUE
2030       KE=KLEV-3
2031       DO 290 JK=3,KE
2032 !   2.1      CALCULATE WET-BULB TEMPERATURE AND MOISTURE
2033 !            FOR ENVIRONMENTAL AIR IN *CUADJTQ*
2034 ! -----------------------------------------------------
2035   210 CONTINUE
2036       IS=0
2037       DO 212 JL=1,KLON
2038       ZTENWB(JL,JK)=PTENH(JL,JK)
2039       ZQENWB(JL,JK)=PQENH(JL,JK)
2040       ZPH(JL)=PAPH(JL,JK)
2041       LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. &
2042               (JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL))
2043       IF(LLO2(JL))THEN
2044          IS=IS+1
2045       ENDIF
2046   212 CONTINUE
2047       IF(IS.EQ.0) GO TO 290
2048       IK=JK
2049       ICALL=2
2050       CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL)
2051 !   2.2      DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
2052 !            AND CHECK FOR NEGATIVE BUOYANCY.
2053 !            THEN SET VALUES FOR DOWNDRAFT AT LFS.
2054 ! -----------------------------------------------------
2055   220 CONTINUE
2056       DO 222 JL=1,KLON
2057       IF(LLO2(JL)) THEN
2058          ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK))
2059          ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK))
2060          ZBUO=ZTTEST*(1.+VTMPC1*ZQTEST)-  &
2061              PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
2062          ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK)
2063          ZMFTOP=-CMFDEPS*PMFUB(JL)
2064          IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.*ZMFTOP*ZCOND(JL)) THEN
2065             KDTOP(JL)=JK
2066             LDDRAF(JL)=.TRUE.
2067             PTD(JL,JK)=ZTTEST
2068             PQD(JL,JK)=ZQTEST
2069             PMFD(JL,JK)=ZMFTOP
2070             PMFDS(JL,JK)=PMFD(JL,JK)*(CPD*PTD(JL,JK)+PGEOH(JL,JK))
2071             PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK)
2072             PDMFDP(JL,JK-1)=-0.5*PMFD(JL,JK)*ZCOND(JL)
2073             PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1)
2074          END IF
2075       END IF
2076   222 CONTINUE
2077          IF(LMFDUDV) THEN
2078             DO 224 JL=1,KLON
2079             IF(PMFD(JL,JK).LT.0.) THEN
2080                PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1))
2081                PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1))
2082             END IF
2083   224       CONTINUE
2084          END IF
2085   290 CONTINUE
2086  300  CONTINUE
2087       RETURN
2088       END SUBROUTINE CUDLFS
2089 !
2090
2091 !**********************************************
2092 !       SUBROUTINE CUDDRAF
2093 !**********************************************
2094       SUBROUTINE CUDDRAF &
2095          (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH, &
2096           PUEN,     PVEN,     PGEOH,    PAPH,     PRFL,  &
2097           LDDRAF,   PTD,      PQD,      PUD,      PVD,   &
2098           PMFD,     PMFDS,    PMFDQ,    PDMFDP)
2099 !     THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
2100 !     M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
2101 !***PURPOSE.
2102 !   --------
2103 !          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
2104 !          (I.E. T,Q,U AND V AND FLUXES)
2105 !***INTERFACE
2106 !   ---------
2107 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
2108 !          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
2109 !          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
2110 !          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
2111 !***METHOD.
2112 !  --------
2113 !          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
2114 !          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
2115 !          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
2116 !***EXTERNALS
2117 !   ---------
2118 !          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO EVAPORATION IN
2119 !          SATURATED DESCENT
2120 !***REFERENCE
2121 !   ---------
2122 !          (TIEDTKE,1989)
2123 ! ----------------------------------------------------------------
2124 !-------------------------------------------------------------------
2125       IMPLICIT NONE
2126 !-------------------------------------------------------------------
2127       INTEGER   KLON, KLEV, KLEVP1
2128       INTEGER   JK,IS,JL,ITOPDE, IK, ICALL
2129       REAL      ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK
2130       REAL      ZBUO, ZDMFDP, ZMFDUK, ZMFDVK
2131       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
2132               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),    &
2133               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1)
2134       REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),    &
2135               PUD(KLON,KLEV),         PVD(KLON,KLEV),     &
2136               PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),   &
2137               PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV),  &
2138               PRFL(KLON)
2139       REAL     ZDMFEN(KLON),           ZDMFDE(KLON),      &
2140               ZCOND(KLON),            ZPH(KLON)
2141       LOGICAL  LDDRAF(KLON),           LLO2(KLON)
2142 !--------------------------------------------------------------
2143 !     1.       CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
2144 !                (A) CALCULATING ENTRAINMENT RATES, ASSUMING
2145 !                     LINEAR DECREASE OF MASSFLUX IN PBL
2146 !                 (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
2147 !                     AND MOISTENING IS CALCULATED IN *CUADJTQ*
2148 !                 (C) CHECKING FOR NEGATIVE BUOYANCY AND
2149 !                     SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
2150 ! ----------------------------------------------------------------
2151   100 CONTINUE
2152       DO 180 JK=3,KLEV
2153       IS=0
2154       DO 110 JL=1,KLON
2155       ZPH(JL)=PAPH(JL,JK)
2156       LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0.
2157       IF(LLO2(JL)) THEN
2158          IS=IS+1
2159       ENDIF
2160   110 CONTINUE
2161       IF(IS.EQ.0) GO TO 180
2162       DO 122 JL=1,KLON
2163       IF(LLO2(JL)) THEN
2164          ZENTR=ENTRDD*PMFD(JL,JK-1)*RD*PTENH(JL,JK-1)/   &
2165               (G*PAPH(JL,JK-1))*(PAPH(JL,JK)-PAPH(JL,JK-1))
2166          ZDMFEN(JL)=ZENTR
2167          ZDMFDE(JL)=ZENTR
2168       END IF
2169   122 CONTINUE
2170       ITOPDE=KLEV-2
2171          IF(JK.GT.ITOPDE) THEN
2172             DO 124 JL=1,KLON
2173             IF(LLO2(JL)) THEN
2174                ZDMFEN(JL)=0.
2175                ZDMFDE(JL)=PMFD(JL,ITOPDE)*      &
2176               (PAPH(JL,JK)-PAPH(JL,JK-1))/     &
2177               (PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE))
2178             END IF
2179   124       CONTINUE
2180          END IF
2181       DO 126 JL=1,KLON
2182          IF(LLO2(JL)) THEN
2183             PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL)
2184             ZSEEN=(CPD*PTENH(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFEN(JL)
2185             ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL)
2186             ZSDDE=(CPD*PTD(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFDE(JL)
2187             ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL)
2188             ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE
2189             ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE
2190             PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2191             PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- &
2192                        PGEOH(JL,JK))*RCPD
2193             PTD(JL,JK)=MIN(400.,PTD(JL,JK))
2194             PTD(JL,JK)=MAX(100.,PTD(JL,JK))
2195             ZCOND(JL)=PQD(JL,JK)
2196          END IF
2197   126 CONTINUE
2198       IK=JK
2199       ICALL=2
2200       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL)
2201       DO 150 JL=1,KLON
2202          IF(LLO2(JL)) THEN
2203             ZCOND(JL)=ZCOND(JL)-PQD(JL,JK)
2204             ZBUO=PTD(JL,JK)*(1.+VTMPC1*PQD(JL,JK))- &
2205            PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
2206             IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN
2207                PMFD(JL,JK)=0.
2208             ENDIF
2209             PMFDS(JL,JK)=(CPD*PTD(JL,JK)+PGEOH(JL,JK))*PMFD(JL,JK)
2210             PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK)
2211             ZDMFDP=-PMFD(JL,JK)*ZCOND(JL)
2212             PDMFDP(JL,JK-1)=ZDMFDP
2213             PRFL(JL)=PRFL(JL)+ZDMFDP
2214          END IF
2215   150 CONTINUE
2216         IF(LMFDUDV) THEN
2217           DO 160 JL=1,KLON
2218              IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN
2219                 ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+   &
2220                ZDMFEN(JL)*PUEN(JL,JK-1)-ZDMFDE(JL)*PUD(JL,JK-1)
2221                 ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+   &
2222                ZDMFEN(JL)*PVEN(JL,JK-1)-ZDMFDE(JL)*PVD(JL,JK-1)
2223                 PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2224                 PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
2225              END IF
2226   160     CONTINUE
2227         END IF
2228   180 CONTINUE
2229       RETURN
2230       END SUBROUTINE CUDDRAF
2231 !
2232
2233 !**********************************************
2234 !       SUBROUTINE CUFLX
2235 !**********************************************
2236       SUBROUTINE CUFLX &
2237          (KLON,     KLEV,     KLEVP1,   PQEN,    PQSEN,     &
2238           PTENH,    PQENH,    PAPH,     PGEOH,   KCBOT,    &
2239           KCTOP,    KDTOP,    KTYPE,    LDDRAF,  LDCUM,  &
2240           PMFU,     PMFD,     PMFUS,    PMFDS,   PMFUQ,  &
2241           PMFDQ,    PMFUL,    PLUDE,    PDMFUP,  PDMFDP, &
2242           PRFL,     PRAIN,    PTEN,     PSFL,    PDPMEL, &
2243           KTOPM2,   ZTMST,    sig1)
2244 !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
2245 !***PURPOSE
2246 !   -------
2247 !          THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
2248 !          FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
2249 !***INTERFACE
2250 !   ---------
2251 !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
2252 !***EXTERNALS
2253 !   ---------
2254 !          NONE
2255 ! ----------------------------------------------------------------
2256 !-------------------------------------------------------------------
2257       IMPLICIT NONE
2258 !-------------------------------------------------------------------
2259       INTEGER   KLON, KLEV, KLEVP1
2260       INTEGER   KTOPM2, ITOP, JL, JK, IKB
2261       REAL      ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2
2262       REAL      ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW
2263       REAL      ZRMIN, ZRFLN, ZDRFL, ZDPEVAP
2264       REAL     PQEN(KLON,KLEV),        PQSEN(KLON,KLEV),  &
2265               PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
2266               PAPH(KLON,KLEVP1),      PGEOH(KLON,KLEV)
2267       REAL     PMFU(KLON,KLEV),        PMFD(KLON,KLEV),   &
2268               PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),   &
2269               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),   &
2270               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),  &
2271               PMFUL(KLON,KLEV),       PLUDE(KLON,KLEV),   &
2272               PRFL(KLON),             PRAIN(KLON)
2273       REAL     PTEN(KLON,KLEV),        PDPMEL(KLON,KLEV), &
2274               PSFL(KLON),             ZPSUBCL(KLON)
2275       REAL     sig1(KLEV)
2276       INTEGER  KCBOT(KLON),            KCTOP(KLON),     &
2277               KDTOP(KLON),            KTYPE(KLON)
2278       LOGICAL  LDDRAF(KLON),           LDCUM(KLON)
2279 !*       SPECIFY CONSTANTS
2280       ZCONS1=CPD/(ALF*G*ZTMST)
2281       ZCONS2=1./(G*ZTMST)
2282       ZCUCOV=0.05
2283       ZTMELP2=TMELT+2.
2284 !*  1.0      DETERMINE FINAL CONVECTIVE FLUXES
2285 !---------------------------------------------
2286   100 CONTINUE
2287       ITOP=KLEV
2288       DO 110 JL=1,KLON
2289       PRFL(JL)=0.
2290       PSFL(JL)=0.
2291       PRAIN(JL)=0.
2292 !     SWITCH OFF SHALLOW CONVECTION
2293       IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN
2294         LDCUM(JL)=.FALSE.
2295         LDDRAF(JL)=.FALSE.
2296       ENDIF
2297       ITOP=MIN(ITOP,KCTOP(JL))
2298       IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE.
2299       IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
2300   110 CONTINUE
2301       KTOPM2=ITOP-2
2302       DO 120 JK=KTOPM2,KLEV
2303       DO 115 JL=1,KLON
2304       IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN
2305          PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)*  &
2306                      (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
2307          PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK)
2308          IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN
2309             PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)*  &
2310                         (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
2311             PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK)
2312          ELSE
2313             PMFD(JL,JK)=0.
2314             PMFDS(JL,JK)=0.
2315             PMFDQ(JL,JK)=0.
2316             PDMFDP(JL,JK-1)=0.
2317          END IF
2318       ELSE
2319          PMFU(JL,JK)=0.
2320          PMFD(JL,JK)=0.
2321          PMFUS(JL,JK)=0.
2322          PMFDS(JL,JK)=0.
2323          PMFUQ(JL,JK)=0.
2324          PMFDQ(JL,JK)=0.
2325          PMFUL(JL,JK)=0.
2326          PDMFUP(JL,JK-1)=0.
2327          PDMFDP(JL,JK-1)=0.
2328          PLUDE(JL,JK-1)=0.
2329       END IF
2330   115 CONTINUE
2331   120 CONTINUE
2332       DO 130 JK=KTOPM2,KLEV
2333       DO 125 JL=1,KLON
2334       IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
2335          IKB=KCBOT(JL)
2336          ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
2337              (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
2338          IF(KTYPE(JL).EQ.3) THEN
2339             ZZP=ZZP**2
2340          ENDIF
2341          PMFU(JL,JK)=PMFU(JL,IKB)*ZZP
2342          PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP
2343          PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP
2344          PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP
2345       END IF
2346 !*    2.        CALCULATE RAIN/SNOW FALL RATES
2347 !*              CALCULATE MELTING OF SNOW
2348 !*              CALCULATE EVAPORATION OF PRECIP
2349 !----------------------------------------------
2350       IF(LDCUM(JL)) THEN
2351          PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK)
2352          IF(PTEN(JL,JK).GT.TMELT) THEN
2353             PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
2354             IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN
2355                ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK))
2356                ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2))
2357                PDPMEL(JL,JK)=ZSNMLT
2358                PSFL(JL)=PSFL(JL)-ZSNMLT
2359                PRFL(JL)=PRFL(JL)+ZSNMLT
2360             END IF
2361          ELSE
2362             PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
2363          END IF
2364       END IF
2365   125 CONTINUE
2366   130 CONTINUE
2367       DO 230 JL=1,KLON
2368         PRFL(JL)=MAX(PRFL(JL),0.)
2369         PSFL(JL)=MAX(PSFL(JL),0.)
2370         ZPSUBCL(JL)=PRFL(JL)+PSFL(JL)
2371   230 CONTINUE
2372       DO 240 JK=KTOPM2,KLEV
2373       DO 235 JL=1,KLON
2374       IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. &
2375              ZPSUBCL(JL).GT.1.E-20) THEN
2376           ZRFL=ZPSUBCL(JL)
2377           CEVAPCU=CEVAPCU1*SQRT(CEVAPCU2*SQRT(sig1(JK)))
2378           ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)-   &
2379                   CEVAPCU*(PAPH(JL,JK+1)-PAPH(JL,JK))* &
2380                 MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))**2*ZCUCOV
2381           ZRMIN=ZRFL-ZCUCOV*MAX(0.,0.8*PQSEN(JL,JK)-PQEN(JL,JK)) &
2382                *ZCONS2*(PAPH(JL,JK+1)-PAPH(JL,JK))
2383           ZRNEW=MAX(ZRNEW,ZRMIN)
2384           ZRFLN=MAX(ZRNEW,0.)
2385           ZDRFL=MIN(0.,ZRFLN-ZRFL)
2386           PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL
2387           ZPSUBCL(JL)=ZRFLN
2388       END IF
2389   235 CONTINUE
2390   240 CONTINUE
2391       DO 250 JL=1,KLON
2392         ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL))
2393         PRFL(JL)=PRFL(JL)+ZDPEVAP*PRFL(JL)*  &
2394                   (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
2395         PSFL(JL)=PSFL(JL)+ZDPEVAP*PSFL(JL)*  &
2396                   (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
2397   250 CONTINUE
2398       RETURN
2399       END SUBROUTINE CUFLX
2400 !
2401
2402 !**********************************************
2403 !       SUBROUTINE CUDTDQ
2404 !**********************************************
2405       SUBROUTINE CUDTDQ &
2406          (KLON,     KLEV,     KLEVP1,   KTOPM2,   PAPH,   &
2407           LDCUM,    PTEN,     PTTE,     PQTE,     PMFUS,  &
2408           PMFDS,    PMFUQ,    PMFDQ,    PMFUL,    PDMFUP, &
2409           PDMFDP,   ZTMST,    PDPMEL,   PRAIN,    PRFL,   &
2410           PSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT, &
2411           PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,  &
2412           PQEN,     PQSEN,    PLUDE,    PCTE)
2413 !**** *CUDTDQ* - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES
2414 !                DOES GLOBAL DIAGNOSTICS
2415 !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
2416 !***INTERFACE.
2417 !   ----------
2418 !          *CUDTDQ* IS CALLED FROM *CUMASTR*
2419 ! ----------------------------------------------------------------
2420 !-------------------------------------------------------------------
2421       IMPLICIT NONE
2422 !-------------------------------------------------------------------
2423       INTEGER   KLON, KLEV, KLEVP1
2424       INTEGER   KTOPM2,JL, JK
2425       REAL      ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW
2426       REAL      ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT
2427       REAL     PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
2428               PTEN(KLON,KLEV),        PLUDE(KLON,KLEV),  &
2429               PGEO(KLON,KLEV),        PAPH(KLON,KLEVP1), &
2430               PAPRC(KLON),            PAPRS(KLON),       &
2431               PAPRSM(KLON),           PCTE(KLON,KLEV),   &
2432               PRSFC(KLON),            PSSFC(KLON)
2433       REAL     PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV), &
2434               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV), &
2435               PMFUL(KLON,KLEV),       PQSEN(KLON,KLEV), &
2436               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),&
2437               PRFL(KLON),             PRAIN(KLON),      &
2438               PQEN(KLON,KLEV)
2439       REAL     PDPMEL(KLON,KLEV),      PSFL(KLON)
2440       REAL     ZSHEAT(KLON),           ZMELT(KLON)
2441       LOGICAL  LDCUM(KLON)
2442 !--------------------------------
2443 !*    1.0      SPECIFY PARAMETERS
2444 !--------------------------------
2445   100 CONTINUE
2446       ZDIAGT=ZTMST
2447       ZDIAGW=ZDIAGT/RHOH2O
2448 !--------------------------------------------------
2449 !*    2.0      INCREMENTATION OF T AND Q TENDENCIES
2450 !--------------------------------------------------
2451   200 CONTINUE
2452       DO 210 JL=1,KLON
2453       ZMELT(JL)=0.
2454       ZSHEAT(JL)=0.
2455   210 CONTINUE
2456       DO 250 JK=KTOPM2,KLEV
2457       IF(JK.LT.KLEV) THEN
2458          DO 220 JL=1,KLON
2459          IF(LDCUM(JL)) THEN
2460             IF(PTEN(JL,JK).GT.TMELT) THEN
2461                ZALV=ALV
2462             ELSE
2463                ZALV=ALS
2464             ENDIF
2465             RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
2466             RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
2467             pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
2468             ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*      &
2469               (PMFUS(JL,JK+1)-PMFUS(JL,JK)+                  &
2470               PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK)  &
2471               -ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-      &
2472               (PDMFUP(JL,JK)+PDMFDP(JL,JK))))
2473             PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
2474             ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*&
2475               (PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+       &
2476               PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+        &
2477               PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-  &
2478               (PDMFUP(JL,JK)+PDMFDP(JL,JK)))
2479             PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
2480             PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
2481             ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
2482             ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
2483          END IF
2484   220 CONTINUE
2485       ELSE
2486          DO 230 JL=1,KLON
2487          IF(LDCUM(JL)) THEN
2488             IF(PTEN(JL,JK).GT.TMELT) THEN
2489                ZALV=ALV
2490             ELSE
2491                ZALV=ALS
2492             ENDIF
2493             RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
2494             RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
2495             pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
2496             ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*           &
2497                 (PMFUS(JL,JK)+PMFDS(JL,JK)+ALF*PDPMEL(JL,JK)-ZALV* &
2498                 (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd))
2499             PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
2500             ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*                &
2501                      (PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+             &
2502                      (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)))
2503             PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
2504             PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
2505             ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
2506             ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
2507          END IF
2508   230    CONTINUE
2509       END IF
2510   250 CONTINUE
2511 !---------------------------------------------------------
2512 !      3.      UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS
2513 !---------------------------------------------------------
2514   300 CONTINUE
2515       DO 310 JL=1,KLON
2516       PRSFC(JL)=PRFL(JL)
2517       PSSFC(JL)=PSFL(JL)
2518       PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL))
2519       PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL)
2520       PSHEAT=PSHEAT+ZSHEAT(JL)
2521       PSRAIN=PSRAIN+PRAIN(JL)
2522       PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL))
2523       PSMELT=PSMELT+ZMELT(JL)
2524   310 CONTINUE
2525       PSEVAP=PSEVAP+PSRAIN
2526       RETURN
2527       END SUBROUTINE CUDTDQ
2528
2529 !
2530 !**********************************************
2531 !       SUBROUTINE CUDUDV
2532 !**********************************************
2533       SUBROUTINE CUDUDV &
2534          (KLON,     KLEV,     KLEVP1,   KTOPM2,   KTYPE,  &
2535           KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,   &
2536           PVOM,     PVOL,     PUU,      PUD,      PVU,    &
2537           PVD,      PMFU,     PMFD,     PSDISS)
2538 !**** *CUDUDV* - UPDATES U AND V TENDENCIES,
2539 !                DOES GLOBAL DIAGNOSTIC OF DISSIPATION
2540 !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
2541 !***INTERFACE.
2542 !   ----------
2543 !          *CUDUDV* IS CALLED FROM *CUMASTR*
2544 ! ----------------------------------------------------------------
2545 !-------------------------------------------------------------------
2546       IMPLICIT NONE
2547 !-------------------------------------------------------------------
2548       INTEGER   KLON, KLEV, KLEVP1
2549       INTEGER   KTOPM2, JK, IK, JL, IKB
2550       REAL      PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM
2551       REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
2552               PVOL(KLON,KLEV),        PVOM(KLON,KLEV),    &
2553               PAPH(KLON,KLEVP1)
2554       REAL     PUU(KLON,KLEV),         PUD(KLON,KLEV),    &
2555               PVU(KLON,KLEV),         PVD(KLON,KLEV),     &
2556               PMFU(KLON,KLEV),        PMFD(KLON,KLEV)
2557       REAL     ZMFUU(KLON,KLEV),       ZMFDU(KLON,KLEV),  &
2558               ZMFUV(KLON,KLEV),       ZMFDV(KLON,KLEV),   &
2559               ZDISS(KLON)
2560       INTEGER  KTYPE(KLON),            KCBOT(KLON)
2561       LOGICAL  LDCUM(KLON)
2562 !------------------------------------------------------------
2563 !*    1.0      CALCULATE FLUXES AND UPDATE U AND V TENDENCIES
2564 ! -----------------------------------------------------------
2565   100 CONTINUE
2566       DO 120 JK=KTOPM2,KLEV
2567       IK=JK-1
2568       DO 110 JL=1,KLON
2569       IF(LDCUM(JL)) THEN
2570         ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK))
2571         ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK))
2572         ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK))
2573         ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK))
2574       END IF
2575   110 CONTINUE
2576   120 CONTINUE
2577       DO 140 JK=KTOPM2,KLEV
2578       DO 130 JL=1,KLON
2579       IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
2580          IKB=KCBOT(JL)
2581          ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
2582              (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
2583          IF(KTYPE(JL).EQ.3) THEN
2584             ZZP=ZZP**2
2585          ENDIF
2586          ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP
2587          ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP
2588          ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP
2589          ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP
2590       END IF
2591   130 CONTINUE
2592   140 CONTINUE
2593       DO 150 JL=1,KLON
2594       ZDISS(JL)=0.
2595   150 CONTINUE
2596       DO 190 JK=KTOPM2,KLEV
2597       IF(JK.LT.KLEV) THEN
2598          DO 160 JL=1,KLON
2599             IF(LDCUM(JL)) THEN
2600                ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2601                     (ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+     &
2602                      ZMFDU(JL,JK+1)-ZMFDU(JL,JK))
2603                ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2604                     (ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+     &
2605                      ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
2606                ZDISS(JL)=ZDISS(JL)+        &
2607                         PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+   &
2608                                      ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+  &
2609                         PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+   &
2610                                      ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
2611                PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
2612                PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
2613             END IF
2614   160    CONTINUE
2615       ELSE
2616          DO 170 JL=1,KLON
2617             IF(LDCUM(JL)) THEN
2618                ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2619                         (ZMFUU(JL,JK)+ZMFDU(JL,JK))
2620                ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
2621                         (ZMFUV(JL,JK)+ZMFDV(JL,JK))
2622                ZDISS(JL)=ZDISS(JL)-        &
2623       (PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ &
2624       PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK)))
2625                PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
2626                PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
2627             END IF
2628   170    CONTINUE
2629        END IF
2630   190 CONTINUE
2631       ZSUM=SSUM(KLON,ZDISS(1),1)
2632       PSDISS=PSDISS+ZSUM
2633       RETURN
2634       END SUBROUTINE CUDUDV
2635 !
2636
2637 !#################################################################
2638 !
2639 !                 LEVEL 4 SUBROUTINES
2640 !
2641 !#################################################################
2642 !**************************************************************
2643 !             SUBROUTINE CUBASMC
2644 !**************************************************************
2645       SUBROUTINE CUBASMC   &
2646          (KLON,     KLEV,     KLEVM1,  KK,     PTEN,  &
2647           PQEN,     PQSEN,    PUEN,    PVEN,   PVERV, &
2648           PGEO,     PGEOH,    LDCUM,   KTYPE,  KLAB,  &
2649           PMFU,     PMFUB,    PENTR,   KCBOT,  PTU,   &
2650           PQU,      PLU,      PUU,     PVU,    PMFUS, &
2651           PMFUQ,    PMFUL,    PDMFUP,  PMFUU,  PMFUV)
2652 !      M.TIEDTKE         E.C.M.W.F.     12/89
2653 !***PURPOSE.
2654 !   --------
2655 !          THIS ROUTINE CALCULATES CLOUD BASE VALUES
2656 !          FOR MIDLEVEL CONVECTION
2657 !***INTERFACE
2658 !   ---------
2659 !          THIS ROUTINE IS CALLED FROM *CUASC*.
2660 !          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
2661 !          IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION
2662 !***METHOD.
2663 !   -------
2664 !          S. TIEDTKE (1989)
2665 !***EXTERNALS
2666 !   ---------
2667 !          NONE
2668 ! ----------------------------------------------------------------
2669 !-------------------------------------------------------------------
2670       IMPLICIT NONE
2671 !-------------------------------------------------------------------
2672       INTEGER   KLON, KLEV, KLEVP1
2673       INTEGER   KLEVM1,KK, JL
2674       REAL      zzzmb
2675       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),  &
2676               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
2677               PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),  &
2678               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV)
2679       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
2680               PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
2681               PLU(KLON,KLEV),         PMFU(KLON,KLEV),   &
2682               PMFUB(KLON),            PENTR(KLON),       &
2683               PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
2684               PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV), &
2685               PMFUU(KLON),            PMFUV(KLON)
2686       INTEGER  KTYPE(KLON),            KCBOT(KLON),      &
2687               KLAB(KLON,KLEV)
2688       LOGICAL  LDCUM(KLON)
2689 !--------------------------------------------------------
2690 !*    1.      CALCULATE ENTRAINMENT AND DETRAINMENT RATES
2691 ! -------------------------------------------------------
2692   100 CONTINUE
2693          DO 150 JL=1,KLON
2694           IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND.  &
2695              PQEN(JL,KK).GT.0.90*PQSEN(JL,KK)) THEN
2696             PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) &
2697                                *RCPD
2698             PQU(JL,KK+1)=PQEN(JL,KK)
2699             PLU(JL,KK+1)=0.
2700             ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G)
2701             ZZZMB=MIN(ZZZMB,CMFCMAX)
2702             PMFUB(JL)=ZZZMB
2703             PMFU(JL,KK+1)=PMFUB(JL)
2704             PMFUS(JL,KK+1)=PMFUB(JL)*(CPD*PTU(JL,KK+1)+PGEOH(JL,KK+1))
2705             PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1)
2706             PMFUL(JL,KK+1)=0.
2707             PDMFUP(JL,KK+1)=0.
2708             KCBOT(JL)=KK
2709             KLAB(JL,KK+1)=1
2710             KTYPE(JL)=3
2711             PENTR(JL)=ENTRMID
2712                IF(LMFDUDV) THEN
2713                   PUU(JL,KK+1)=PUEN(JL,KK)
2714                   PVU(JL,KK+1)=PVEN(JL,KK)
2715                   PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1)
2716                   PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1)
2717                END IF
2718          END IF
2719   150   CONTINUE
2720       RETURN
2721       END SUBROUTINE CUBASMC
2722
2723 !
2724 !**************************************************************
2725 !             SUBROUTINE CUADJTQ
2726 !**************************************************************
2727       SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL)
2728 !      M.TIEDTKE         E.C.M.W.F.     12/89
2729 !      D.SALMOND         CRAY(UK))      12/8/91
2730 !***PURPOSE.
2731 !   --------
2732 !          TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
2733 !***INTERFACE
2734 !   ---------
2735 !          THIS ROUTINE IS CALLED FROM SUBROUTINES:
2736 !              *CUBASE*   (T AND Q AT CONDENSTION LEVEL)
2737 !              *CUASC*    (T AND Q AT CLOUD LEVELS)
2738 !              *CUINI*    (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS)
2739 !          INPUT ARE UNADJUSTED T AND Q VALUES,
2740 !          IT RETURNS ADJUSTED VALUES OF T AND Q
2741 !          NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
2742 !               KCALL=0    ENV. T AND QS IN*CUINI*
2743 !               KCALL=1  CONDENSATION IN UPDRAFTS  (E.G.  CUBASE, CUASC)
2744 !               KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G.  CUDLFS,CUDDRAF
2745 !***EXTERNALS
2746 !   ---------
2747 !          3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC )
2748 !          FOR CONDENSATION CALCULATIONS.
2749 !          THE TABLES ARE INITIALISED IN *SETPHYS*.
2750 ! ----------------------------------------------------------------
2751 !-------------------------------------------------------------------
2752       IMPLICIT NONE
2753 !-------------------------------------------------------------------
2754       INTEGER   KLON, KLEV
2755       INTEGER   KK, KCALL, ISUM, JL
2756       REAL      ZQSAT, ZCOR, ZCOND1, TT
2757       REAL     PT(KLON,KLEV),          PQ(KLON,KLEV),  &
2758               ZCOND(KLON),            ZQP(KLON),       &
2759               PP(KLON)
2760       LOGICAL  LDFLAG(KLON)
2761 !------------------------------------------------------------------
2762 !     2.      CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY
2763 !------------------------------------------------------------------
2764   200 CONTINUE
2765       IF (KCALL.EQ.1 ) THEN
2766          ISUM=0
2767          DO 210 JL=1,KLON
2768          ZCOND(JL)=0.
2769          IF(LDFLAG(JL)) THEN
2770             ZQP(JL)=1./PP(JL)
2771             TT=PT(JL,KK)
2772             ZQSAT=TLUCUA(TT)*ZQP(JL)
2773             ZQSAT=MIN(0.5,ZQSAT)
2774             ZCOR=1./(1.-VTMPC1*ZQSAT)
2775             ZQSAT=ZQSAT*ZCOR
2776             ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2777             ZCOND(JL)=MAX(ZCOND(JL),0.)
2778             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2779             PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2780             IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2781          END IF
2782   210    CONTINUE
2783          IF(ISUM.EQ.0) GO TO 230
2784          DO 220 JL=1,KLON
2785          IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
2786             TT=PT(JL,KK)
2787             ZQSAT=TLUCUA(TT)*ZQP(JL)
2788             ZQSAT=MIN(0.5,ZQSAT)
2789             ZCOR=1./(1.-VTMPC1*ZQSAT)
2790             ZQSAT=ZQSAT*ZCOR
2791             ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2792             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2793             PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2794          END IF
2795   220    CONTINUE
2796   230    CONTINUE
2797       END IF
2798       IF(KCALL.EQ.2) THEN
2799          ISUM=0
2800          DO 310 JL=1,KLON
2801          ZCOND(JL)=0.
2802          IF(LDFLAG(JL)) THEN
2803             TT=PT(JL,KK)
2804             ZQP(JL)=1./PP(JL)
2805             ZQSAT=TLUCUA(TT)*ZQP(JL)
2806             ZQSAT=MIN(0.5,ZQSAT)
2807             ZCOR=1./(1.-VTMPC1*ZQSAT)
2808             ZQSAT=ZQSAT*ZCOR
2809             ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2810             ZCOND(JL)=MIN(ZCOND(JL),0.)
2811             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2812             PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2813             IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2814          END IF
2815   310    CONTINUE
2816          IF(ISUM.EQ.0) GO TO 330
2817          DO 320 JL=1,KLON
2818          IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
2819             TT=PT(JL,KK)
2820             ZQSAT=TLUCUA(TT)*ZQP(JL)
2821             ZQSAT=MIN(0.5,ZQSAT)
2822             ZCOR=1./(1.-VTMPC1*ZQSAT)
2823             ZQSAT=ZQSAT*ZCOR
2824             ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2825             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2826             PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2827          END IF
2828   320    CONTINUE
2829   330    CONTINUE
2830       END IF
2831       IF(KCALL.EQ.0) THEN
2832          ISUM=0
2833          DO 410 JL=1,KLON
2834            TT=PT(JL,KK)
2835            ZQP(JL)=1./PP(JL)
2836            ZQSAT=TLUCUA(TT)*ZQP(JL)
2837            ZQSAT=MIN(0.5,ZQSAT)
2838            ZCOR=1./(1.-VTMPC1*ZQSAT)
2839            ZQSAT=ZQSAT*ZCOR
2840            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2841            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2842            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2843            IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
2844   410    CONTINUE
2845          IF(ISUM.EQ.0) GO TO 430
2846          DO 420 JL=1,KLON
2847            TT=PT(JL,KK)
2848            ZQSAT=TLUCUA(TT)*ZQP(JL)
2849            ZQSAT=MIN(0.5,ZQSAT)
2850            ZCOR=1./(1.-VTMPC1*ZQSAT)
2851            ZQSAT=ZQSAT*ZCOR
2852            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2853            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2854            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2855   420    CONTINUE
2856   430    CONTINUE
2857       END IF
2858       IF(KCALL.EQ.4) THEN
2859          DO 510 JL=1,KLON
2860            TT=PT(JL,KK)
2861            ZQP(JL)=1./PP(JL)
2862            ZQSAT=TLUCUA(TT)*ZQP(JL)
2863            ZQSAT=MIN(0.5,ZQSAT)
2864            ZCOR=1./(1.-VTMPC1*ZQSAT)
2865            ZQSAT=ZQSAT*ZCOR
2866            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2867            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
2868            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
2869   510    CONTINUE
2870          DO 520 JL=1,KLON
2871            TT=PT(JL,KK)
2872            ZQSAT=TLUCUA(TT)*ZQP(JL)
2873            ZQSAT=MIN(0.5,ZQSAT)
2874            ZCOR=1./(1.-VTMPC1*ZQSAT)
2875            ZQSAT=ZQSAT*ZCOR
2876            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
2877            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
2878            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
2879   520    CONTINUE
2880       END IF
2881       RETURN
2882       END SUBROUTINE CUADJTQ
2883
2884 !
2885 !**********************************************************
2886 !        SUBROUTINE CUENTR_NEW
2887 !**********************************************************
2888       SUBROUTINE CUENTR_NEW                              &
2889          (KLON,     KLEV,     KLEVP1,   KK,       PTENH, &
2890           PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM, &
2891           KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU,  &
2892           PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
2893 !      M.TIEDTKE         E.C.M.W.F.     12/89
2894 !      Y.WANG            IPRC           11/01
2895 !***PURPOSE.
2896 !   --------
2897 !          THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES
2898 !          FOR UPDRAFTS IN CUMULUS PARAMETERIZATION
2899 !***INTERFACE
2900 !   ---------
2901 !          THIS ROUTINE IS CALLED FROM *CUASC*.
2902 !          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
2903 !          AND UPDRAFT VALUES T,Q ETC
2904 !          IT RETURNS ENTRAINMENT/DETRAINMENT RATES
2905 !***METHOD.
2906 !  --------
2907 !          S. TIEDTKE (1989), NORDENG(1996)
2908 !***EXTERNALS
2909 !   ---------
2910 !          NONE
2911 ! ----------------------------------------------------------------
2912 !-------------------------------------------------------------------
2913       IMPLICIT NONE
2914 !-------------------------------------------------------------------
2915       INTEGER   KLON, KLEV, KLEVP1
2916       INTEGER   KK, JL, IKLWMIN,IKB, IKT, IKH
2917       REAL      ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE
2918       REAL     PTENH(KLON,KLEV),                           &
2919               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),   &
2920               PMFU(KLON,KLEV),        PGEOH(KLON,KLEV),    &
2921               PENTR(KLON),            ZPBASE(KLON),        &
2922               ZDMFEN(KLON),           ZDMFDE(KLON),        &
2923               ZODETR(KLON,KLEV)
2924       INTEGER  KLWMIN(KLON),           KTYPE(KLON),        &
2925               KCBOT(KLON),            KCTOP0(KLON),        &
2926               KHMIN(KLON)
2927       LOGICAL  LDCUM(KLON),LLO1,LLO2
2928 !---------------------------------------------------------
2929 !*    1.       CALCULATE ENTRAINMENT AND DETRAINMENT RATES
2930 !---------------------------------------------------------
2931 !*    1.1      SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS
2932 !----------------------------------------------------------
2933 !*    1.2      SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS
2934 !-------------------------------------------------------
2935       DO jl = 1, klon
2936         zpbase(jl) = paph(jl,kcbot(jl))
2937         zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1)
2938         zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg
2939         zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl)))
2940         zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho
2941         llo1 = kk.LT.kcbot(jl).AND.ldcum(jl)
2942         if(llo1) then
2943            zdmfde(jl) = zentr
2944         else
2945            zdmfde(jl) = 0.0
2946         endif
2947         llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) &
2948              .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid)
2949         if(llo2) then
2950             zdmfen(jl) = zentr
2951         else
2952             zdmfen(jl) = 0.0
2953         endif
2954         iklwmin = MAX(klwmin(jl),kctop0(jl)+2)
2955         llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) &
2956              .GT.zpmid)
2957         IF (llo2) zdmfen(jl) = zentr
2958         llo2 = llo1.AND.ktype(jl).EQ.1
2959 ! Turbulent entrainment
2960         IF (llo2) zdmfen(jl) = zentr
2961 ! Organized detrainment, detrainment starts at khmin
2962         ikb = kcbot(jl)
2963         zodetr(jl,kk) = 0.
2964         IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN
2965           ikt = kctop0(jl)
2966           ikh = khmin(jl)
2967           IF (ikh.GT.ikt) THEN
2968             zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg
2969             ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg
2970             arg = 3.1415*(zzmzk/ztmzk)*0.5
2971             zorgde = TAN(arg)*3.1415*0.5/ztmzk
2972             zdprho = (paph(jl,kk+1)-paph(jl,kk))*(zrg*zrrho)
2973             zodetr(jl,kk) = MIN(zorgde,1.E-3)*pmfu(jl,kk+1)*zdprho
2974           END IF
2975         END IF
2976       ENDDO
2977 !
2978       RETURN
2979       END SUBROUTINE CUENTR_NEW
2980 !
2981
2982 !**********************************************************
2983 !        FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC
2984 !**********************************************************
2985       REAL FUNCTION SSUM ( N, X, IX )
2986 !
2987 ! COMPUTES SSUM = SUM OF [X(I)]
2988 !     FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X
2989 !
2990       IMPLICIT NONE
2991       REAL X(*)
2992       REAL ZSUM
2993       INTEGER N, IX, JX, JL
2994 !
2995       JX = 1
2996       ZSUM = 0.0
2997       DO JL = 1, N
2998         ZSUM = ZSUM + X(JX)
2999         JX = JX + IX
3000       enddo
3001 !
3002       SSUM=ZSUM
3003 !
3004       RETURN
3005       END FUNCTION SSUM
3006
3007       REAL FUNCTION TLUCUA(TT)
3008 !
3009 !  Set up lookup tables for cloud ascent calculations.
3010 !
3011       IMPLICIT NONE
3012       REAL ZCVM3,ZCVM4,TT !,TLUCUA
3013 !
3014       IF(TT-TMELT.GT.0.) THEN
3015          ZCVM3=C3LES
3016          ZCVM4=C4LES
3017       ELSE
3018          ZCVM3=C3IES
3019          ZCVM4=C4IES
3020       END IF
3021       TLUCUA=C2ES*EXP(ZCVM3*(TT-TMELT)*(1./(TT-ZCVM4)))
3022 !
3023       RETURN
3024       END FUNCTION TLUCUA
3025 !
3026       REAL FUNCTION TLUCUB(TT)
3027 !
3028 !  Set up lookup tables for cloud ascent calculations.
3029 !
3030       IMPLICIT NONE
3031       REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT !,TLUCUB
3032 !
3033       Z5ALVCP=C5LES*ALV/CPD
3034       Z5ALSCP=C5IES*ALS/CPD
3035       IF(TT-TMELT.GT.0.) THEN
3036          ZCVM4=C4LES
3037          ZCVM5=Z5ALVCP
3038       ELSE
3039          ZCVM4=C4IES
3040          ZCVM5=Z5ALSCP
3041       END IF
3042       TLUCUB=ZCVM5*(1./(TT-ZCVM4))**2
3043 !
3044       RETURN
3045       END FUNCTION TLUCUB
3046 !
3047       REAL FUNCTION TLUCUC(TT)
3048 !
3049 !  Set up lookup tables for cloud ascent calculations.
3050 !
3051       IMPLICIT NONE
3052       REAL ZALVDCP,ZALSDCP,TT,ZLDCP !,TLUCUC
3053 !
3054       ZALVDCP=ALV/CPD
3055       ZALSDCP=ALS/CPD
3056       IF(TT-TMELT.GT.0.) THEN
3057          ZLDCP=ZALVDCP
3058       ELSE
3059          ZLDCP=ZALSDCP
3060       END IF
3061       TLUCUC=ZLDCP
3062 !
3063       RETURN
3064       END FUNCTION TLUCUC
3065 !
3066
3067 END MODULE module_cu_tiedtke