PageRenderTime 77ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/wrfv2_fire/phys/module_cu_tiedtke.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 3558 lines | 2424 code | 127 blank | 1007 comment | 44 complexity | 8096b897f66f6a9493ad2bce5123e39f MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !-----------------------------------------------------------------------
    2. 

  2. !
    3. 

  3. !WRF:MODEL_LAYER:PHYSICS
    4. 

  4. !
    5. 

  5. !####################TIEDTKE SCHEME#########################
    6. 

  6. !   Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii
    7. 

  7. !   Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010
    8. 

  8. !   refenrence: Tiedtke (1989, MWR, 117, 1779-1800)
    9. 

  9. !               Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment
    10. 

  10. !               Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements 
    11. 

  11. !                                                  for cloud top detrainment 
    12. 

  12. !                       (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds
    13. 

  13. !                        (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation
    14. 

  14. !   This scheme is on testing
    15. 

  15. !###########################################################
    16. 

  16. MODULE module_cu_tiedtke
    17. 

  17. !
    18. 

  18. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    19. 

  19. ! epsl--- allowed minimum value for floating calculation
    20. 

  20. !---------------------------------------------------------------
    21. 

  21.       real,parameter ::  epsl  = 1.0e-20
    22. 

  22.       real,parameter ::  t000  = 273.15
    23. 

  23.       real,parameter ::  hgfr  = 233.15   ! defined in param.f in explct
    24. 

  24. !-------------------------------------------------------------    
    25. 

  25. !  Ends the parameters set
    26. 

  26. !++++++++++++++++++++++++++++
    27. 

  27.      REAL,PRIVATE :: G,CPV
    28. 

  28.      REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2,   &
    29. 

  29.              RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, &
    30. 

  30.              C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG 
    31. 

  31.     
    32. 

  32.      REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC,    &
    33. 

  33.              CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0,  &
    34. 

  34.              fdbk,ZTAU
    35. 

  35.  
    36. 

  36.      INTEGER :: orgen,nturben,cutrigger
    37. 

  37. 

  38.      REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC
    39. 

  39.     
    40. 

  40.   
    41. 

  41.      PARAMETER(A=6371.22E03,                                    &
    42. 

  42.       ALV=2.5008E6,                 &                  
    43. 

  43.       ALS=2.8345E6,                 &
    44. 

  44.       ALF=ALS-ALV,                  &
    45. 

  45.       CPD=1005.46,                  &
    46. 

  46.       CPV=1869.46,                  & ! CPV in module is 1846.4
    47. 

  47.       RCPD=1.0/CPD,                 &
    48. 

  48.       RHOH2O=1.0E03,                & 
    49. 

  49.       TMELT=273.16,                 &
    50. 

  50.       G=9.806,                      & ! G=9.806
    51. 

  51.       ZRG=1.0/G,                    &
    52. 

  52.       RD=287.05,                    &
    53. 

  53.       RV=461.51,                    &
    54. 

  54.       C1ES=610.78,                  &
    55. 

  55.       C2ES=C1ES*RD/RV,              &
    56. 

  56.       C3LES=17.269,                 &
    57. 

  57.       C4LES=35.86,                  &
    58. 

  58.       C5LES=C3LES*(TMELT-C4LES),    &
    59. 

  59.       C3IES=21.875,                 &
    60. 

  60.       C4IES=7.66,                   &
    61. 

  61.       C5IES=C3IES*(TMELT-C4IES),    &
    62. 

  62.       API=3.141593,                 & ! API=2.0*ASIN(1.)
    63. 

  63.       VTMPC1=RV/RD-1.0,             &
    64. 

  64.       VTMPC2=CPV/CPD-1.0,           &
    65. 

  65.       CVDIFTS=1.0,                  &
    66. 

  66.       CEVAPCU1=1.93E-6*261.0*0.5/G, & 
    67. 

  67.       CEVAPCU2=1.E3/(38.3*0.293) )
    68. 

  68. 

  69.      
    70. 

  70. !                SPECIFY PARAMETERS FOR MASSFLUX-SCHEME
    71. 

  71. !                  --------------------------------------
    72. 

  72. !                   These are tunable parameters
    73. 

  73. !
    74. 

  74. !     ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
    75. 

  75. !     -------
    76. 

  76. !
    77. 

  77.       PARAMETER(ENTRPEN=1.0E-4)
    78. 

  78. !
    79. 

  79. !     ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION
    80. 

  80. !     -------
    81. 

  81. !
    82. 

  82.       PARAMETER(ENTRSCV=1.2E-3)
    83. 

  83. !
    84. 

  84. !     ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
    85. 

  85. !     -------
    86. 

  86. !
    87. 

  87.       PARAMETER(ENTRMID=1.0E-4)
    88. 

  88. !
    89. 

  89. !     ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS
    90. 

  90. !     ------
    91. 

  91. !
    92. 

  92.       PARAMETER(ENTRDD =2.0E-4)
    93. 

  93. !
    94. 

  94. !     CMFCTOP:   RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL
    95. 

  95. !     -------
    96. 

  96. !
    97. 

  97.       PARAMETER(CMFCTOP=0.30)
    98. 

  98. !
    99. 

  99. !     CMFCMAX:   MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
    100. 

  100. !     -------
    101. 

  101. !
    102. 

  102.       PARAMETER(CMFCMAX=1.0)
    103. 

  103. !
    104. 

  104. !     CMFCMIN:   MINIMUM MASSFLUX VALUE (FOR SAFETY)
    105. 

  105. !     -------
    106. 

  106. !
    107. 

  107.       PARAMETER(CMFCMIN=1.E-10)
    108. 

  108. !
    109. 

  109. !     CMFDEPS:   FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
    110. 

  110. !     -------
    111. 

  111. !
    112. 

  112.       PARAMETER(CMFDEPS=0.30)
    113. 

  113. !
    114. 

  114. !     CPRCON:  COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER
    115. 

  115. !
    116. 

  116.       PARAMETER(CPRCON = 1.1E-3/G)
    117. 

  117. !
    118. 

  118. !     ZDNOPRC: The pressure depth below which no precipitation
    119. 

  119. !
    120. 

  120.       PARAMETER(ZDNOPRC =1.5E4)
    121. 

  121. !--------------------
    122. 

  122.      PARAMETER(orgen=1)   ! Old organized entrainment rate
    123. 

  123. !      PARAMETER(orgen=2)   ! New organized entrainment rate
    124. 

  124. 

  125.      PARAMETER(nturben=1) ! old deep turburent entrainment/detrainment rate
    126. 

  126. !      PARAMETER(nturben=2) ! New deep turburent entrainment/detrainment rate
    127. 

  127. 

  128.      PARAMETER(cutrigger=1) ! Old trigger function
    129. 

  129. !      PARAMETER(cutrigger=2) ! New trigger function
    130. 

  130. !
    131. 

  131. !--------------------
    132. 

  132.       PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50)
    133. 

  133. !--------------------
    134. 

  134.       PARAMETER(CRIRH=0.70,fdbk = 1.0,ZTAU = 1800.0)
    135. 

  135. !--------------------
    136. 

  136.       LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV
    137. 

  137.       PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.)
    138. 

  138. !--------------------
    139. 

  139. !#################### END of Variables definition##########################
    140. 

  140. !-----------------------------------------------------------------------
    141. 

  141. !
    142. 

  142. CONTAINS
    143. 

  143. !-----------------------------------------------------------------------
    144. 

  144.      SUBROUTINE CU_TIEDTKE(                                    &
    145. 

  145.                  DT,ITIMESTEP,STEPCU                            &
    146. 

  146.                 ,RAINCV,PRATEC,QFX,HFX,ZNU                      &
    147. 

  147.                 ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D        &
    148. 

  148.                 ,QVFTEN,QVPBLTEN                                &
    149. 

  149.                 ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG                &
    150. 

  150.                 ,CUDT, CURR_SECS, ADAPT_STEP_FLAG               &
    151. 

  151.                 ,CUDTACTTIME                                    &
    152. 

  152.                 ,ids,ide, jds,jde, kds,kde                      &
    153. 

  153.                 ,ims,ime, jms,jme, kms,kme                      &
    154. 

  154.                 ,its,ite, jts,jte, kts,kte                      &
    155. 

  155.                 ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN            &
    156. 

  156.                 ,RUCUTEN, RVCUTEN                               &
    157. 

  157.                 ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS       &
    158. 

  158.                                                                 )
    159. 

  159. !-------------------------------------------------------------------
    160. 

  160.       IMPLICIT NONE
    161. 

  161. !-------------------------------------------------------------------
    162. 

  162. !-- U3D         3D u-velocity interpolated to theta points (m/s)
    163. 

  163. !-- V3D         3D v-velocity interpolated to theta points (m/s)
    164. 

  164. !-- TH3D        3D potential temperature (K)
    165. 

  165. !-- T3D         temperature (K)
    166. 

  166. !-- QV3D        3D water vapor mixing ratio (Kg/Kg)
    167. 

  167. !-- QC3D        3D cloud mixing ratio (Kg/Kg)
    168. 

  168. !-- QI3D        3D ice mixing ratio (Kg/Kg)
    169. 

  169. !-- RHO3D       3D air density (kg/m^3)
    170. 

  170. !-- P8w         3D hydrostatic pressure at full levels (Pa)
    171. 

  171. !-- Pcps        3D hydrostatic pressure at half levels (Pa)
    172. 

  172. !-- PI3D        3D exner function (dimensionless)
    173. 

  173. !-- RTHCUTEN      Theta tendency due to 
    174. 

  174. !                 cumulus scheme precipitation (K/s)
    175. 

  175. !-- RUCUTEN       U wind tendency due to 
    176. 

  176. !                 cumulus scheme precipitation (K/s)
    177. 

  177. !-- RVCUTEN       V wind tendency due to 
    178. 

  178. !                 cumulus scheme precipitation (K/s)
    179. 

  179. !-- RQVCUTEN      Qv tendency due to 
    180. 

  180. !                 cumulus scheme precipitation (kg/kg/s)
    181. 

  181. !-- RQRCUTEN      Qr tendency due to 
    182. 

  182. !                 cumulus scheme precipitation (kg/kg/s)
    183. 

  183. !-- RQCCUTEN      Qc tendency due to 
    184. 

  184. !                 cumulus scheme precipitation (kg/kg/s)
    185. 

  185. !-- RQSCUTEN      Qs tendency due to 
    186. 

  186. !                 cumulus scheme precipitation (kg/kg/s)
    187. 

  187. !-- RQICUTEN      Qi tendency due to 
    188. 

  188. !                 cumulus scheme precipitation (kg/kg/s)
    189. 

  189. !-- RAINC         accumulated total cumulus scheme precipitation (mm)
    190. 

  190. !-- RAINCV        cumulus scheme precipitation (mm)
    191. 

  191. !-- PRATEC        precipitiation rate from cumulus scheme (mm/s)
    192. 

  192. !-- dz8w        dz between full levels (m)
    193. 

  193. !-- QFX         upward moisture flux at the surface (kg/m^2/s)
    194. 

  194. !-- DT          time step (s)
    195. 

  195. !-- ids         start index for i in domain
    196. 

  196. !-- ide         end index for i in domain
    197. 

  197. !-- jds         start index for j in domain
    198. 

  198. !-- jde         end index for j in domain
    199. 

  199. !-- kds         start index for k in domain
    200. 

  200. !-- kde         end index for k in domain
    201. 

  201. !-- ims         start index for i in memory
    202. 

  202. !-- ime         end index for i in memory
    203. 

  203. !-- jms         start index for j in memory
    204. 

  204. !-- jme         end index for j in memory
    205. 

  205. !-- kms         start index for k in memory
    206. 

  206. !-- kme         end index for k in memory
    207. 

  207. !-- its         start index for i in tile
    208. 

  208. !-- ite         end index for i in tile
    209. 

  209. !-- jts         start index for j in tile
    210. 

  210. !-- jte         end index for j in tile
    211. 

  211. !-- kts         start index for k in tile
    212. 

  212. !-- kte         end index for k in tile
    213. 

  213. !-------------------------------------------------------------------
    214. 

  214.       INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
    215. 

  215.                                         ims,ime, jms,jme, kms,kme,      &
    216. 

  216.                                         its,ite, jts,jte, kts,kte,      &
    217. 

  217.                                         ITIMESTEP,                      &
    218. 

  218.                                         STEPCU
    219. 

  219. 

  220.       REAL,    INTENT(IN) ::                                            &
    221. 

  221.                                         DT
    222. 

  222. 

  223. 

  224.       REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
    225. 

  225.                                         XLAND
    226. 

  226. 

  227.       REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
    228. 

  228.                                         RAINCV, PRATEC
    229. 

  229. 

  230.       LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) ::             &
    231. 

  231.                                         CU_ACT_FLAG
    232. 

  232. 

  233. 

  234.       REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
    235. 

  235.                                         DZ8W,                           &
    236. 

  236.                                         P8w,                            &
    237. 

  237.                                         Pcps,                           &
    238. 

  238.                                         PI3D,                           &
    239. 

  239.                                         QC3D,                           &
    240. 

  240.                                         QVFTEN,                         &
    241. 

  241.                                         QVPBLTEN,                       &
    242. 

  242.                                         QI3D,                           &
    243. 

  243.                                         QV3D,                           &
    244. 

  244.                                         RHO3D,                          &
    245. 

  245.                                         T3D,                            &
    246. 

  246.                                         U3D,                            &
    247. 

  247.                                         V3D,                            &
    248. 

  248.                                         W                              
    249. 

  249. 

  250. !--------------------------- OPTIONAL VARS ----------------------------
    251. 

  251.                                                                                                       
    252. 

  252.       REAL, DIMENSION(ims:ime, kms:kme, jms:jme),                       &
    253. 

  253.                OPTIONAL, INTENT(INOUT) ::                               &
    254. 

  254.                                         RQCCUTEN,                       &
    255. 

  255.                                         RQICUTEN,                       &
    256. 

  256.                                         RQVCUTEN,                       &
    257. 

  257.                                         RTHCUTEN,                       &
    258. 

  258.                                         RUCUTEN,                        &
    259. 

  259.                                         RVCUTEN
    260. 

  260.                                                                                                       
    261. 

  261. !
    262. 

  262. ! Flags relating to the optional tendency arrays declared above
    263. 

  263. ! Models that carry the optional tendencies will provdide the
    264. 

  264. ! optional arguments at compile time; these flags all the model
    265. 

  265. ! to determine at run-time whether a particular tracer is in
    266. 

  266. ! use or not.
    267. 

  267. !
    268. 

  268.      LOGICAL, OPTIONAL ::                                      &
    269. 

  269.                                                    F_QV      &
    270. 

  270.                                                   ,F_QC      &
    271. 

  271.                                                   ,F_QR      &
    272. 

  272.                                                   ,F_QI      &
    273. 

  273.                                                   ,F_QS
    274. 

  274.  
    275. 

  275. ! Adaptive time-step variables
    276. 

  276.       REAL,  INTENT(IN   ) :: CUDT
    277. 

  277.       REAL,  INTENT(IN   ) :: CURR_SECS
    278. 

  278.       LOGICAL,INTENT(IN   ) , OPTIONAL :: ADAPT_STEP_FLAG
    279. 

  279.       REAL,  INTENT (INOUT) :: CUDTACTTIME
    280. 

  280. 

  281. !--------------------------- LOCAL VARS ------------------------------
    282. 

  282. 

  283.       REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
    284. 

  284.                                         QFX,                            &
    285. 

  285.                                         HFX        
    286. 

  286. 

  287.       REAL      ::                                      &
    288. 

  288.                                         DELT,                           &
    289. 

  289.                                         RDELT                          
    290. 

  290. 

  291.       REAL     , DIMENSION(its:ite) ::                  &
    292. 

  292.                                         RCS,                            &
    293. 

  293.                                         RN,                             &
    294. 

  294.                                         EVAP,                           &
    295. 

  295.                                         heatflux,                       &
    296. 

  296.                                         rho2d                            
    297. 

  297.       INTEGER  , DIMENSION(its:ite) ::  SLIMSK                         
    298. 

  298.       
    299. 

  299. 

  300.       REAL     , DIMENSION(its:ite, kts:kte+1) ::       &
    301. 

  301.                                         PRSI                            
    302. 

  302. 

  303.       REAL     , DIMENSION(its:ite, kts:kte) ::         &
    304. 

  304.                                         DEL,                            &
    305. 

  305.                                         DOT,                            &
    306. 

  306.                                         PHIL,                           &
    307. 

  307.                                         PRSL,                           &
    308. 

  308.                                         Q1,                             & 
    309. 

  309.                                         Q2,                             &
    310. 

  310.                                         Q3,                             &
    311. 

  311.                                         Q1B,                            &
    312. 

  312.                                         Q1BL,                           &
    313. 

  313.                                         Q11,                            &
    314. 

  314.                                         Q12,                            &  
    315. 

  315.                                         T1,                             & 
    316. 

  316.                                         U1,                             & 
    317. 

  317.                                         V1,                             & 
    318. 

  318.                                         ZI,                             & 
    319. 

  319.                                         ZL,                             &
    320. 

  320.                                         OMG,                            &
    321. 

  321.                                         GHT 
    322. 

  322. 

  323.       INTEGER, DIMENSION(its:ite) ::                                    &
    324. 

  324.                                         KBOT,                           &
    325. 

  325.                                         KTOP                           
    326. 

  326. 

  327.       INTEGER ::                                                        &
    328. 

  328.                                         I,                              &
    329. 

  329.                                         IM,                             &
    330. 

  330.                                         J,                              &
    331. 

  331.                                         K,                              &
    332. 

  332.                                         KM,                             &
    333. 

  333.                                         KP,                             &
    334. 

  334.                                         KX
    335. 

  335. 

  336. 

  337.       LOGICAL :: run_param, doing_adapt_dt , decided
    338. 

  338. 

  339. !-------other local variables----
    340. 

  340.       INTEGER,DIMENSION( its:ite ) :: KTYPE
    341. 

  341.       REAL, DIMENSION( kts:kte )   :: sig1      ! half sigma levels
    342. 

  342.       REAL, DIMENSION( kms:kme )   :: ZNU
    343. 

  343.       INTEGER                      :: zz 
    344. 

  344. !-----------------------------------------------------------------------
    345. 

  345. !
    346. 

  346. !
    347. 

  347. !***  CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
    348. 

  348. !
    349. 

  349. 

  350. !  Initialization for adaptive time step.
    351. 

  351. 

  352.    doing_adapt_dt = .FALSE.
    353. 

  353.    IF ( PRESENT(adapt_step_flag) ) THEN
    354. 

  354.       IF ( adapt_step_flag ) THEN
    355. 

  355.          doing_adapt_dt = .TRUE.
    356. 

  356.          IF ( cudtacttime .EQ. 0. ) THEN
    357. 

  357.             cudtacttime = curr_secs + cudt*60.
    358. 

  358.          END IF
    359. 

  359.       END IF
    360. 

  360.    END IF
    361. 

  361. 

  362. !  Do we run through this scheme or not?
    363. 

  363. 

  364. !    Test 1:  If this is the initial model time, then yes.
    365. 

  365. !                ITIMESTEP=1
    366. 

  366. !    Test 2:  If the user asked for the cumulus to be run every time step, then yes.
    367. 

  367. !                CUDT=0 or STEPCU=1
    368. 

  368. !    Test 3:  If not adaptive dt, and this is on the requested cumulus frequency, then yes.
    369. 

  369. !                MOD(ITIMESTEP,STEPCU)=0
    370. 

  370. !    Test 4:  If using adaptive dt and the current time is past the last requested activate cumulus time, then yes.
    371. 

  371. !                CURR_SECS >= CUDTACTTIME
    372. 

  372. 

  373. !  If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag
    374. 

  374. !  to TRUE.  The decided flag says that one of these tests was able to say "yes", run the scheme.
    375. 

  375. !  We only proceed to other tests if the previous tests all have left decided as FALSE.
    376. 

  376. 

  377. !  If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next
    378. 

  378. !  cumulus run.
    379. 

  379. 

  380.    decided = .FALSE.
    381. 

  381.    run_param = .FALSE.
    382. 

  382.    IF ( ( .NOT. decided ) .AND. &
    383. 

  383.         ( itimestep .EQ. 1 ) ) THEN
    384. 

  384.       run_param   = .TRUE.
    385. 

  385.       decided     = .TRUE.
    386. 

  386.    END IF
    387. 

  387. 

  388.    IF ( ( .NOT. decided ) .AND. &
    389. 

  389.         ( ( cudt .EQ. 0. ) .OR. ( stepcu .EQ. 1 ) ) ) THEN
    390. 

  390.       run_param   = .TRUE.
    391. 

  391.       decided     = .TRUE.
    392. 

  392.    END IF
    393. 

  393. 

  394.    IF ( ( .NOT. decided ) .AND. &
    395. 

  395.         ( .NOT. doing_adapt_dt ) .AND. &
    396. 

  396.         ( MOD(itimestep,stepcu) .EQ. 0 ) ) THEN
    397. 

  397.       run_param   = .TRUE.
    398. 

  398.       decided     = .TRUE.
    399. 

  399.    END IF
    400. 

  400. 

  401.    IF ( ( .NOT. decided ) .AND. &
    402. 

  402.         ( doing_adapt_dt ) .AND. &
    403. 

  403.         ( curr_secs .GE. cudtacttime ) ) THEN
    404. 

  404.       run_param   = .TRUE.
    405. 

  405.       decided     = .TRUE.
    406. 

  406.       cudtacttime = curr_secs + cudt*60
    407. 

  407.    END IF
    408. 

  408. 

  409. !-----------------------------------------------------------------------
    410. 

  410.    IF(run_param) THEN
    411. 

  411. 

  412.       DO J=JTS,JTE
    413. 

  413.          DO I=ITS,ITE
    414. 

  414.             CU_ACT_FLAG(I,J)=.TRUE.
    415. 

  415.          ENDDO
    416. 

  416.       ENDDO
    417. 

  417.  
    418. 

  418.       IM=ITE-ITS+1
    419. 

  419.       KX=KTE-KTS+1
    420. 

  420.       DELT=DT*STEPCU
    421. 

  421.       RDELT=1./DELT
    422. 

  422. 

  423. !-------------  J LOOP (OUTER) --------------------------------------------------
    424. 

  424. 

  425.    DO J=jts,jte
    426. 

  426. 

  427. ! --------------- compute zi and zl -----------------------------------------
    428. 

  428.       DO i=its,ite
    429. 

  429.         ZI(I,KTS)=0.0
    430. 

  430.       ENDDO
    431. 

  431. 

  432.       DO k=kts+1,kte
    433. 

  433.         KM=k-1
    434. 

  434.         DO i=its,ite
    435. 

  435.           ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
    436. 

  436.         ENDDO
    437. 

  437.       ENDDO
    438. 

  438. 

  439.       DO k=kts+1,kte
    440. 

  440.         KM=k-1
    441. 

  441.         DO i=its,ite
    442. 

  442.           ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
    443. 

  443.         ENDDO
    444. 

  444.       ENDDO
    445. 

  445. 

  446.       DO i=its,ite
    447. 

  447.         ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
    448. 

  448.       ENDDO
    449. 

  449. 

  450. ! --------------- end compute zi and zl -------------------------------------
    451. 

  451.       DO i=its,ite
    452. 

  452.         SLIMSK(i)=int(ABS(XLAND(i,j)-2.))
    453. 

  453.       ENDDO
    454. 

  454. 

  455.       DO k=kts,kte
    456. 

  456.         kp=k+1
    457. 

  457.         DO i=its,ite
    458. 

  458.           DOT(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
    459. 

  459.         ENDDO
    460. 

  460.       ENDDO
    461. 

  461. 

  462.       DO k=kts,kte
    463. 

  463.         zz = kte+1-k        
    464. 

  464.         DO i=its,ite
    465. 

  465.           U1(i,zz)=U3D(i,k,j)
    466. 

  466.           V1(i,zz)=V3D(i,k,j)
    467. 

  467.           T1(i,zz)=T3D(i,k,j)
    468. 

  468.           Q1(i,zz)= QV3D(i,k,j)
    469. 

  469.           if(itimestep == 1) then
    470. 

  470.              Q1B(i,zz)=0.
    471. 

  471.              Q1BL(i,zz)=0.
    472. 

  472.           else
    473. 

  473.              Q1B(i,zz)=QVFTEN(i,k,j)
    474. 

  474.              Q1BL(i,zz)=QVPBLTEN(i,k,j)
    475. 

  475.           endif
    476. 

  476.           Q2(i,zz)=QC3D(i,k,j)
    477. 

  477.           Q3(i,zz)=QI3D(i,k,j)
    478. 

  478.           OMG(i,zz)=DOT(i,k)
    479. 

  479.           GHT(i,zz)=ZL(i,k)
    480. 

  480.           PRSL(i,zz) = Pcps(i,k,j)
    481. 

  481.         ENDDO
    482. 

  482.       ENDDO
    483. 

  483. 

  484.       DO k=kts,kte+1
    485. 

  485.         zz = kte+2-k
    486. 

  486.         DO i=its,ite
    487. 

  487.           PRSI(i,zz) = P8w(i,k,j)
    488. 

  488.         ENDDO
    489. 

  489.       ENDDO 
    490. 

  490. 

  491.       DO k=kts,kte
    492. 

  492.          zz = kte+1-k
    493. 

  493.          sig1(zz) = ZNU(k)
    494. 

  494.       ENDDO
    495. 

  495. 

  496. !###############before call TIECNV, we need EVAP########################
    497. 

  497. !       EVAP is the vapor flux at the surface
    498. 

  498. !########################################################################
    499. 

  499. !
    500. 

  500.       DO i=its,ite
    501. 

  501.         EVAP(i) = QFX(i,j)
    502. 

  502.         heatflux(i)=HFX(i,j)
    503. 

  503.         rho2d(i) = rho3d(i,1,j)
    504. 

  504.       ENDDO
    505. 

  505. !########################################################################
    506. 

  506.       CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP,heatflux,rho2d,             &
    507. 

  507.                   RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT)      
    508. 

  508. 

  509.       DO I=ITS,ITE
    510. 

  510.          RAINCV(I,J)=RN(I)/STEPCU
    511. 

  511.          PRATEC(I,J)=RN(I)/(STEPCU * DT)
    512. 

  512.       ENDDO
    513. 

  513. 

  514.       DO K=KTS,KTE
    515. 

  515.         zz = kte+1-k
    516. 

  516.         DO I=ITS,ITE
    517. 

  517.           RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
    518. 

  518.           RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT
    519. 

  519.           RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT
    520. 

  520.           RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT 
    521. 

  521.         ENDDO
    522. 

  522.       ENDDO
    523. 

  523. 

  524.       IF(PRESENT(RQCCUTEN))THEN
    525. 

  525.         IF ( F_QC ) THEN
    526. 

  526.           DO K=KTS,KTE
    527. 

  527.             zz = kte+1-k
    528. 

  528.             DO I=ITS,ITE
    529. 

  529.               RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT
    530. 

  530.             ENDDO
    531. 

  531.           ENDDO
    532. 

  532.         ENDIF
    533. 

  533.       ENDIF
    534. 

  534. 

  535.       IF(PRESENT(RQICUTEN))THEN
    536. 

  536.         IF ( F_QI ) THEN
    537. 

  537.           DO K=KTS,KTE
    538. 

  538.             zz = kte+1-k
    539. 

  539.             DO I=ITS,ITE
    540. 

  540.               RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT
    541. 

  541.             ENDDO
    542. 

  542.           ENDDO
    543. 

  543.         ENDIF
    544. 

  544.       ENDIF
    545. 

  545. 

  546. 

  547.    ENDDO
    548. 

  548. 

  549.    ENDIF
    550. 

  550. 

  551.    END SUBROUTINE CU_TIEDTKE
    552. 

  552. 

  553. !====================================================================
    554. 

  554.    SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
    555. 

  555.                      RUCUTEN,RVCUTEN,                                   &
    556. 

  556.                      RESTART,P_QC,P_QI,P_FIRST_SCALAR,                  &
    557. 

  557.                      allowed_to_read,                                   &
    558. 

  558.                      ids, ide, jds, jde, kds, kde,                      &
    559. 

  559.                      ims, ime, jms, jme, kms, kme,                      &
    560. 

  560.                      its, ite, jts, jte, kts, kte)
    561. 

  561. !--------------------------------------------------------------------
    562. 

  562.    IMPLICIT NONE
    563. 

  563. !--------------------------------------------------------------------
    564. 

  564.    LOGICAL , INTENT(IN)           ::  allowed_to_read,restart
    565. 

  565.    INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
    566. 

  566.                                       ims, ime, jms, jme, kms, kme, &
    567. 

  567.                                       its, ite, jts, jte, kts, kte
    568. 

  568.    INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
    569. 

  569. 

  570.    REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::  &
    571. 

  571.                                                               RTHCUTEN, &
    572. 

  572.                                                               RQVCUTEN, &
    573. 

  573.                                                               RQCCUTEN, &
    574. 

  574.                                                               RQICUTEN, &
    575. 

  575.                                                               RUCUTEN,RVCUTEN 
    576. 

  576. 

  577.    INTEGER :: i, j, k, itf, jtf, ktf
    578. 

  578. 

  579.    jtf=min0(jte,jde-1)
    580. 

  580.    ktf=min0(kte,kde-1)
    581. 

  581.    itf=min0(ite,ide-1)
    582. 

  582. 

  583.    IF(.not.restart)THEN
    584. 

  584.      DO j=jts,jtf
    585. 

  585.      DO k=kts,ktf
    586. 

  586.      DO i=its,itf
    587. 

  587.        RTHCUTEN(i,k,j)=0.
    588. 

  588.        RQVCUTEN(i,k,j)=0.
    589. 

  589.        RUCUTEN(i,k,j)=0.
    590. 

  590.        RVCUTEN(i,k,j)=0.
    591. 

  591.      ENDDO
    592. 

  592.      ENDDO
    593. 

  593.      ENDDO
    594. 

  594. 

  595.      IF (P_QC .ge. P_FIRST_SCALAR) THEN
    596. 

  596.         DO j=jts,jtf
    597. 

  597.         DO k=kts,ktf
    598. 

  598.         DO i=its,itf
    599. 

  599.            RQCCUTEN(i,k,j)=0.
    600. 

  600.         ENDDO
    601. 

  601.         ENDDO
    602. 

  602.         ENDDO
    603. 

  603.      ENDIF
    604. 

  604. 

  605.      IF (P_QI .ge. P_FIRST_SCALAR) THEN
    606. 

  606.         DO j=jts,jtf
    607. 

  607.         DO k=kts,ktf
    608. 

  608.         DO i=its,itf
    609. 

  609.            RQICUTEN(i,k,j)=0.
    610. 

  610.         ENDDO
    611. 

  611.         ENDDO
    612. 

  612.         ENDDO
    613. 

  613.      ENDIF
    614. 

  614.    ENDIF
    615. 

  615. 

  616.       END SUBROUTINE tiedtkeinit
    617. 

  617. 

  618. ! ------------------------------------------------------------------------
    619. 

  619. 

  620. !------------This is the combined version for tiedtke---------------
    621. 

  621. !----------------------------------------------------------------
    622. 

  622. !  In this module only the mass flux convection scheme of the ECMWF is included
    623. 

  623. !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    624. 

  624. !#############################################################
    625. 

  625. !
    626. 

  626. !             LEVEL 1 SUBROUTINEs
    627. 

  627. !
    628. 

  628. !#############################################################
    629. 

  629. !********************************************************
    630. 

  630. !        subroutine TIECNV
    631. 

  631. !********************************************************
    632. 

  632.       SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg,  &
    633. 

  633.            pap,paph,evap,hfx,rho,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt)
    634. 

  634. !-----------------------------------------------------------------
    635. 

  635. !  This is the interface between the meso-scale model and the mass 
    636. 

  636. !  flux convection module
    637. 

  637. !-----------------------------------------------------------------
    638. 

  638.       implicit none
    639. 

  639. 

  640.       real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km)
    641. 

  641.       real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km)
    642. 

  642.       real PHHFL(lq),RHO(lq),hfx(lq)
    643. 

  643.       REAL PUM1(lq,km),    PVM1(lq,km),                             &
    644. 

  644.           PTTE(lq,km),    PQTE(lq,km),  PVOM(lq,km),  PVOL(lq,km),  &
    645. 

  645.           PVERV(lq,km),   PGEO(lq,km),  PAP(lq,km),   PAPH(lq,km1)
    646. 

  646.       REAL PQHFL(lq),      ZQQ(lq,km),   PAPRC(lq),    PAPRS(lq),   &
    647. 

  647.           PRSFC(lq),      PSSFC(lq),    PAPRSM(lq),   PCTE(lq,km)
    648. 

  648.       REAL ZTP1(lq,km),    ZQP1(lq,km),  ZTU(lq,km),   ZQU(lq,km),  &
    649. 

  649.           ZLU(lq,km),     ZLUDE(lq,km), ZMFU(lq,km),  ZMFD(lq,km),  &
    650. 

  650.           ZQSAT(lq,km),   pqc(lq,km),   pqi(lq,km),   ZRAIN(lq)
    651. 

  651. 

  652.       REAL sig(km1),sig1(km)
    653. 

  653.       INTEGER ICBOT(lq),   ICTOP(lq),     KTYPE(lq),   lndj(lq)
    654. 

  654.       REAL  dt
    655. 

  655.       LOGICAL LOCUM(lq)
    656. 

  656. 

  657.       real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT
    658. 

  658.       real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF
    659. 

  659.       integer i,j,k,lq,lp,km,km1
    660. 

  660. !      real TLUCUA
    661. 

  661. !      external TLUCUA
    662. 

  662. 

  663.       ZTMST=dt
    664. 

  664. !  Masv flux diagnostics.
    665. 

  665. 

  666.       PSHEAT=0.0
    667. 

  667.       PSRAIN=0.0
    668. 

  668.       PSEVAP=0.0
    669. 

  669.       PSMELT=0.0
    670. 

  670.       PSDISS=0.0
    671. 

  671.       DO 8 j=1,lq
    672. 

  672.         ZRAIN(j)=0.0
    673. 

  673.         LOCUM(j)=.FALSE.
    674. 

  674.         PRSFC(j)=0.0
    675. 

  675.         PSSFC(j)=0.0
    676. 

  676.         PAPRC(j)=0.0
    677. 

  677.         PAPRS(j)=0.0
    678. 

  678.         PAPRSM(j)=0.0
    679. 

  679.         PQHFL(j)=evap(j)
    680. 

  680.         PHHFL(j)=hfx(j)
    681. 

  681.     8 CONTINUE
    682. 

  682. 

  683. !     CONVERT MODEL VARIABLES FOR MFLUX SCHEME
    684. 

  684. 

  685.       DO 10 k=1,km
    686. 

  686.         DO 10 j=1,lq
    687. 

  687.           PTTE(j,k)=0.0
    688. 

  688.           PCTE(j,k)=0.0
    689. 

  689.           PVOM(j,k)=0.0
    690. 

  690.           PVOL(j,k)=0.0
    691. 

  691.           ZTP1(j,k)=pt(j,k)
    692. 

  692.           ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k))
    693. 

  693.           PUM1(j,k)=pu(j,k)
    694. 

  694.           PVM1(j,k)=pv(j,k)
    695. 

  695.           PVERV(j,k)=pomg(j,k)
    696. 

  696.           PGEO(j,k)=G*poz(j,k)
    697. 

  697.           TT=ZTP1(j,k)
    698. 

  698.           ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k)
    699. 

  699.           ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k))
    700. 

  700.           ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k))
    701. 

  701.           PQTE(j,k)=pqvf(j,k)+pqvbl(j,k)
    702. 

  702.           ZQQ(j,k)=PQTE(j,k)
    703. 

  703.    10 CONTINUE
    704. 

  704. !
    705. 

  705. !-----------------------------------------------------------------------
    706. 

  706. !*    2.     CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION)
    707. 

  707. !
    708. 

  708.       CALL CUMASTR_NEW &
    709. 

  709.          (lq,       km,       km1,      km-1,    ZTP1,   &
    710. 

  710.           ZQP1,     PUM1,     PVM1,     PVERV,   ZQSAT,  &
    711. 

  711.           PQHFL,    ZTMST,    PAP,      PAPH,    PGEO,   &
    712. 

  712.           PTTE,     PQTE,     PVOM,     PVOL,    PRSFC,  & 
    713. 

  713.           PSSFC,    PAPRC,    PAPRSM,   PAPRS,   LOCUM,  &
    714. 

  714.           KTYPE,    ICBOT,    ICTOP,    ZTU,     ZQU,    &
    715. 

  715.           ZLU,      ZLUDE,    ZMFU,     ZMFD,    ZRAIN,  &
    716. 

  716.           PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,  PSMELT, &
    717. 

  717.           PCTE,     PHHFL,       RHO,    sig1,     lndj)
    718. 

  718. !
    719. 

  719. !     TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION
    720. 

  720. !
    721. 

  721.       IF(fdbk.ge.1.0e-9) THEN
    722. 

  722.       DO 20 K=1,km
    723. 

  723.       DO 20 j=1,lq
    724. 

  724.       If(PCTE(j,k).GT.0.0) then
    725. 

  725.         ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST
    726. 

  726.         if(ZTPP1.ge.t000) then
    727. 

  727.            fliq=1.0
    728. 

  728.            ZALF=0.0
    729. 

  729.         else if(ZTPP1.le.hgfr) then
    730. 

  730.            fliq=0.0
    731. 

  731.            ZALF=ALF
    732. 

  732.         else
    733. 

  733.            ZTC=ZTPP1-t000
    734. 

  734.            fliq=0.0059+0.9941*exp(-0.003102*ZTC*ZTC)
    735. 

  735.            ZALF=ALF
    736. 

  736.         endif
    737. 

  737.         fice=1.0-fliq
    738. 

  738.         pqc(j,k)=pqc(j,k)+fliq*PCTE(j,k)*ZTMST
    739. 

  739.         pqi(j,k)=pqi(j,k)+fice*PCTE(j,k)*ZTMST
    740. 

  740.         PTTE(j,k)=PTTE(j,k)-ZALF*RCPD*fliq*PCTE(j,k)
    741. 

  741.       Endif
    742. 

  742.    20 CONTINUE
    743. 

  743.       ENDIF
    744. 

  744. !
    745. 

  745.       DO 75 k=1,km
    746. 

  746.         DO 75 j=1,lq
    747. 

  747.           pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST
    748. 

  748.           ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST
    749. 

  749.           pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k))
    750. 

  750.    75 CONTINUE
    751. 

  751.       DO 85 j=1,lq
    752. 

  752.         zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST)
    753. 

  753.    85 CONTINUE
    754. 

  754.       IF (LMFDUDV) THEN
    755. 

  755.         DO 100 k=1,km
    756. 

  756.           DO 100 j=1,lq
    757. 

  757.             pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST
    758. 

  758.             pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST
    759. 

  759.   100   CONTINUE
    760. 

  760.       ENDIF
    761. 

  761. !
    762. 

  762.       RETURN
    763. 

  763.       END SUBROUTINE TIECNV
    764. 

  764. 

  765. !#############################################################
    766. 

  766. !
    767. 

  767. !             LEVEL 2 SUBROUTINEs
    768. 

  768. !
    769. 

  769. !#############################################################
    770. 

  770. !***********************************************************
    771. 

  771. !           SUBROUTINE CUMASTR_NEW
    772. 

  772. !***********************************************************
    773. 

  773.       SUBROUTINE CUMASTR_NEW                             &
    774. 

  774.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
    775. 

  775.           PQEN,     PUEN,     PVEN,     PVERV,    PQSEN, &
    776. 

  776.           PQHFL,    ZTMST,    PAP,      PAPH,     PGEO,  &
    777. 

  777.           PTTE,     PQTE,     PVOM,     PVOL,     PRSFC, &
    778. 

  778.           PSSFC,    PAPRC,    PAPRSM,   PAPRS,    LDCUM, &
    779. 

  779.           KTYPE,    KCBOT,    KCTOP,    PTU,      PQU,   &
    780. 

  780.           PLU,      PLUDE,    PMFU,     PMFD,     PRAIN, &
    781. 

  781.           PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,   PSMELT,& 
    782. 

  782.           PCTE,     PHHFL,       RHO,     sig1,     lndj)
    783. 

  783. !
    784. 

  784. !***CUMASTR*  MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME
    785. 

  785. !     M.TIEDTKE      E.C.M.W.F.     1986/1987/1989
    786. 

  786. !***PURPOSE
    787. 

  787. !   -------
    788. 

  788. !          THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
    789. 

  789. !     PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES.
    790. 

  790. !     PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF
    791. 

  791. !     PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE,
    792. 

  792. !     SATURATED CUMULUS DOWNDRAFTS.
    793. 

  793. !***INTERFACE.
    794. 

  794. !   ----------
    795. 

  795. !          *CUMASTR* IS CALLED FROM *MSSFLX*
    796. 

  796. !     THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE
    797. 

  797. !     T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES.
    798. 

  798. !     IT RETURNS ITS OUTPUT TO THE SAME SPACE
    799. 

  799. !      1.MODIFIED TENDENCIES OF MODEL VARIABLES
    800. 

  800. !      2.RATES OF CONVECTIVE PRECIPITATION
    801. 

  801. !        (USED IN SUBROUTINE SURF)
    802. 

  802. !      3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION
    803. 

  803. !        (USED IN SUBROUTINE CLOUD)
    804. 

  804. !***METHOD
    805. 

  805. !   ------
    806. 

  806. !     PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME.
    807. 

  807. !        (1) DEFINE CONSTANTS AND PARAMETERS
    808. 

  808. !        (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND
    809. 

  809. !            INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI'
    810. 

  810. !        (3) CALCULATE CLOUD BASE IN 'CUBASE'
    811. 

  811. !            AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET
    812. 

  812. !        (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS
    813. 

  813. !        (5) DO DOWNDRAFT CALCULATIONS:
    814. 

  814. !              (A) DETERMINE VALUES AT LFS IN 'CUDLFS'
    815. 

  815. !              (B) DETERMINE MOIST DESCENT IN 'CUDDRAF'
    816. 

  816. !              (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE
    817. 

  817. !                  EFFECT OF CU-DOWNDRAFTS
    818. 

  818. !        (6) DO FINAL CLOUD ASCENT IN 'CUASC'
    819. 

  819. !        (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX',
    820. 

  820. !            DO EVAPORATION IN SUBCLOUD LAYER
    821. 

  821. !        (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ'
    822. 

  822. !        (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV'
    823. 

  823. !***EXTERNALS.
    824. 

  824. !   ----------
    825. 

  825. !       CUINI:  INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR.
    826. 

  826. !       CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION
    827. 

  827. !       CUASC:  CLOUD ASCENT FOR ENTRAINING PLUME
    828. 

  828. !       CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS
    829. 

  829. !       CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS
    830. 

  830. !       CUFLX:  FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL)
    831. 

  831. !       CUDQDT: UPDATES TENDENCIES FOR T AND Q
    832. 

  832. !       CUDUDV: UPDATES TENDENCIES FOR U AND V
    833. 

  833. !***SWITCHES.
    834. 

  834. !   --------
    835. 

  835. !          LMFPEN=.T.   PENETRATIVE CONVECTION IS SWITCHED ON
    836. 

  836. !          LMFSCV=.T.   SHALLOW CONVECTION IS SWITCHED ON
    837. 

  837. !          LMFMID=.T.   MIDLEVEL CONVECTION IS SWITCHED ON
    838. 

  838. !          LMFDD=.T.    CUMULUS DOWNDRAFTS SWITCHED ON
    839. 

  839. !          LMFDUDV=.T.  CUMULUS FRICTION SWITCHED ON
    840. 

  840. !***
    841. 

  841. !     MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM)
    842. 

  842. !     ------------------------------------------------
    843. 

  843. !     ENTRPEN    ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
    844. 

  844. !     ENTRSCV    ENTRAINMENT RATE FOR SHALLOW CONVECTION
    845. 

  845. !     ENTRMID    ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
    846. 

  846. !     ENTRDD     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
    847. 

  847. !     CMFCTOP    RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY
    848. 

  848. !                LEVEL
    849. 

  849. !     CMFCMAX    MAXIMUM MASSFLUX VALUE ALLOWED FOR
    850. 

  850. !     CMFCMIN    MINIMUM MASSFLUX VALUE (FOR SAFETY)
    851. 

  851. !     CMFDEPS    FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
    852. 

  852. !     CPRCON     COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN
    853. 

  853. !***REFERENCE.
    854. 

  854. !   ----------
    855. 

  855. !          PAPER ON MASSFLUX SCHEME (TIEDTKE,1989)
    856. 

  856. !-----------------------------------------------------------------
    857. 

  857. !-------------------------------------------------------------------
    858. 

  858.       IMPLICIT NONE
    859. 

  859. !-------------------------------------------------------------------
    860. 

  860.       INTEGER   KLON, KLEV, KLEVP1
    861. 

  861.       INTEGER   KLEVM1
    862. 

  862.       REAL      ZTMST
    863. 

  863.       REAL      PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2
    864. 

  864.       INTEGER   JK,JL,IKB
    865. 

  865.       REAL      ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV
    866. 

  866.       REAL      ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH
    867. 

  867.       REAL      ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS
    868. 

  868.       INTEGER   ICUM, ITOPM2
    869. 

  869.       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV), &
    870. 

  870.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
    871. 

  871.               PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
    872. 

  872.               PVOM(KLON,KLEV),        PVOL(KLON,KLEV),  &
    873. 

  873.               PQSEN(KLON,KLEV),       PGEO(KLON,KLEV),  &
    874. 

  874.               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),& 
    875. 

  875.               PVERV(KLON,KLEV),       PQHFL(KLON),      &
    876. 

  876.               PHHFL(KLON),            RHO(KLON)
    877. 

  877.       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),  &
    878. 

  878.               PLU(KLON,KLEV),         PLUDE(KLON,KLEV), &
    879. 

  879.               PMFU(KLON,KLEV),        PMFD(KLON,KLEV),  &
    880. 

  880.               PAPRC(KLON),            PAPRS(KLON),      &
    881. 

  881.               PAPRSM(KLON),           PRAIN(KLON),      &
    882. 

  882.               PRSFC(KLON),            PSSFC(KLON)
    883. 

  883.       REAL     ZTENH(KLON,KLEV),       ZQENH(KLON,KLEV),&
    884. 

  884.               ZGEOH(KLON,KLEV),       ZQSENH(KLON,KLEV),&
    885. 

  885.               ZTD(KLON,KLEV),         ZQD(KLON,KLEV),   &
    886. 

  886.               ZMFUS(KLON,KLEV),       ZMFDS(KLON,KLEV), &
    887. 

  887.               ZMFUQ(KLON,KLEV),       ZMFDQ(KLON,KLEV), &
    888. 

  888.               ZDMFUP(KLON,KLEV),      ZDMFDP(KLON,KLEV),& 
    889. 

  889.               ZMFUL(KLON,KLEV),       ZRFL(KLON),       &
    890. 

  890.               ZUU(KLON,KLEV),         ZVU(KLON,KLEV),   &
    891. 

  891.               ZUD(KLON,KLEV),         ZVD(KLON,KLEV)
    892. 

  892.       REAL     ZENTR(KLON),            ZHCBASE(KLON),   &
    893. 

  893.               ZMFUB(KLON),            ZMFUB1(KLON),     &
    894. 

  894.               ZDQPBL(KLON),           ZDQCV(KLON) 
    895. 

  895.       REAL     ZSFL(KLON),             ZDPMEL(KLON,KLEV), &
    896. 

  896.               PCTE(KLON,KLEV),        ZCAPE(KLON),        &
    897. 

  897.               ZHEAT(KLON),            ZHHATT(KLON,KLEV),  &
    898. 

  898.               ZHMIN(KLON),            ZRELH(KLON)
    899. 

  899.       REAL     sig1(KLEV)
    900. 

  900.       INTEGER  ILAB(KLON,KLEV),        IDTOP(KLON),   &
    901. 

  901.               ICTOP0(KLON),           ILWMIN(KLON)    
    902. 

  902.       INTEGER  KCBOT(KLON),            KCTOP(KLON),   &
    903. 

  903.               KTYPE(KLON),            IHMIN(KLON),    &
    904. 

  904.               KTOP0,                  lndj(KLON)
    905. 

  905.       LOGICAL  LDCUM(KLON)
    906. 

  906.       LOGICAL  LODDRAF(KLON),          LLO1
    907. 

  907.       REAL     CRIRH1
    908. 

  908. !-------------------------------------------
    909. 

  909. !     1.    SPECIFY CONSTANTS AND PARAMETERS
    910. 

  910. !-------------------------------------------
    911. 

  911.   100 CONTINUE
    912. 

  912.       ZCONS2=1./(G*ZTMST)
    913. 

  913. !--------------------------------------------------------------
    914. 

  914. !*    2.    INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI'
    915. 

  915. !--------------------------------------------------------------
    916. 

  916.   200 CONTINUE
    917. 

  917.       CALL CUINI &
    918. 

  918.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
    919. 

  919.           PQEN,     PQSEN,    PUEN,     PVEN,     PVERV, &
    920. 

  920.           PGEO,     PAPH,     ZGEOH,    ZTENH,    ZQENH,  &
    921. 

  921.           ZQSENH,   ILWMIN,   PTU,      PQU,      ZTD,   &
    922. 

  922.           ZQD,      ZUU,      ZVU,      ZUD,      ZVD,   &
    923. 

  923.           PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ, &
    924. 

  924.           ZMFDQ,    ZDMFUP,   ZDMFDP,   ZDPMEL,   PLU,  &
    925. 

  925.           PLUDE,    ILAB)
    926. 

  926. !----------------------------------
    927. 

  927. !*    3.0   CLOUD BASE CALCULATIONS
    928. 

  928. !----------------------------------
    929. 

  929.   300 CONTINUE
    930. 

  930. !*         (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE'
    931. 

  931. !          -------------------------------------------
    932. 

  932.       CALL CUBASE &
    933. 

  933.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH, &
    934. 

  934.           ZQENH,    ZGEOH,    PAPH,     PTU,      PQU,   &
    935. 

  935.           PLU,      PUEN,     PVEN,     ZUU,      ZVU,   &
    936. 

  936.           LDCUM,    KCBOT,    ILAB)
    937. 

  937. !*          (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND
    938. 

  938. !*              THEN DECIDE ON TYPE OF CUMULUS CONVECTION
    939. 

  939. !               -----------------------------------------
    940. 

  940.        JK=1
    941. 

  941.        DO 310 JL=1,KLON
    942. 

  942.        ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
    943. 

  943.        ZDQPBL(JL)=0.0
    944. 

  944.        IDTOP(JL)=0
    945. 

  945.   310  CONTINUE
    946. 

  946.        DO 320 JK=2,KLEV
    947. 

  947.        DO 315 JL=1,KLON
    948. 

  948.        ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
    949. 

  949.        IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK)  &
    950. 

  950.                                     *(PAPH(JL,JK+1)-PAPH(JL,JK))
    951. 

  951.   315 CONTINUE
    952. 

  952.   320 CONTINUE
    953. 

  953. 

  954.       if(cutrigger .eq. 1) then
    955. 

  955.         DO JL=1,KLON
    956. 

  956.          KTYPE(JL)=0
    957. 

  957.         IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN
    958. 

  958.          KTYPE(JL)=1
    959. 

  959.         ELSE
    960. 

  960.          KTYPE(JL)=2
    961. 

  961.         ENDIF
    962. 

  962.         END DO
    963. 

  963.       else if(cutrigger .eq. 2) then
    964. 

  964.          CALL CUTYPE  &
    965. 

  965.           ( KLON,     KLEV,     KLEVP1,   KLEVM1,  &
    966. 

  966.           ZTENH,   ZQENH,       ZQSENH,    ZGEOH,     PAPH,  &
    967. 

  967.           RHO,     PHHFL,         PQHFL,    KTYPE,    lndj   )
    968. 

  968.       end if
    969. 

  969. !*         (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER
    970. 

  970. !*             AND DETERMINE CLOUD BASE MASSFLUX IGNORING
    971. 

  971. !*             THE EFFECTS OF DOWNDRAFTS AT THIS STAGE
    972. 

  972. !              ------------------------------------------
    973. 

  973. !      do jl=1,klon
    974. 

  974. !        if(ktype(jl) .ge. 1 ) then
    975. 

  975. !              write(6,*)"ktype=", KTYPE(jl)
    976. 

  976. !        end if
    977. 

  977. !      end do
    978. 

  978. 

  979.       DO 340 JL=1,KLON
    980. 

  980.       IKB=KCBOT(JL)
    981. 

  981.       ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB)
    982. 

  982.       ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
    983. 

  983.       IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN
    984. 

  984.          ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
    985. 

  985.       ELSE
    986. 

  986.          ZMFUB(JL)=0.01
    987. 

  987.          LDCUM(JL)=.FALSE.
    988. 

  988.       ENDIF
    989. 

  989.       ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
    990. 

  990.       ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX)
    991. 

  991. !------------------------------------------------------
    992. 

  992. !*    4.0   DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
    993. 

  993. !------------------------------------------------------
    994. 

  994.   400 CONTINUE
    995. 

  995. !*         (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT
    996. 

  996. !*             CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT
    997. 

  997. !*             FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974)
    998. 

  998. ! -------------------------------------------------------------
    999. 

  999.       IKB=KCBOT(JL)
    1000. 

  1000.       ZHCBASE(JL)=CPD*PTU(JL,IKB)+ZGEOH(JL,IKB)+ALV*PQU(JL,IKB)
    1001. 

  1001.       ICTOP0(JL)=KCBOT(JL)-1
    1002. 

  1002.   340 CONTINUE
    1003. 

  1003.       ZALVDCP=ALV/CPD
    1004. 

  1004.       ZQALV=1./ALV
    1005. 

  1005.       DO 420 JK=KLEVM1,3,-1
    1006. 

  1006.       DO 420 JL=1,KLON
    1007. 

  1007.       ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
    1008. 

  1008.       ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/  &
    1009. 

  1009.           ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
    1010. 

  1010.       ZZZ=CPD*ZTENH(JL,JK)*0.608
    1011. 

  1011.       ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
    1012. 

  1012.                  MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
    1013. 

  1013.       ZHHATT(JL,JK)=ZHHAT
    1014. 

  1014.       IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK
    1015. 

  1015.   420 CONTINUE
    1016. 

  1016.       DO 430 JL=1,KLON
    1017. 

  1017.       JK=KCBOT(JL)
    1018. 

  1018.       ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
    1019. 

  1019.       ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/   &
    1020. 

  1020.           ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
    1021. 

  1021.       ZZZ=CPD*ZTENH(JL,JK)*0.608
    1022. 

  1022.       ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
    1023. 

  1023.                  MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
    1024. 

  1024.       ZHHATT(JL,JK)=ZHHAT
    1025. 

  1025.   430 CONTINUE
    1026. 

  1026. !
    1027. 

  1027. ! Find lowest possible org. detrainment level
    1028. 

  1028. !
    1029. 

  1029.       DO 440 JL = 1, KLON
    1030. 

  1030.          ZHMIN(JL) = 0.
    1031. 

  1031.          IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN
    1032. 

  1032.             IHMIN(JL) = KCBOT(JL)
    1033. 

  1033.          ELSE
    1034. 

  1034.             IHMIN(JL) = -1
    1035. 

  1035.          END IF
    1036. 

  1036.  440  CONTINUE 
    1037. 

  1037. !
    1038. 

  1038.       ZBI = 1./(25.*G)
    1039. 

  1039.       DO 450 JK = KLEV, 1, -1
    1040. 

  1040.       DO 450 JL = 1, KLON
    1041. 

  1041.       LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL)
    1042. 

  1042.       IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN
    1043. 

  1043.         IKB = KCBOT(JL)
    1044. 

  1044.         ZRO = RD*ZTENH(JL,JK)/(G*PAPH(JL,JK))
    1045. 

  1045.         ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO
    1046. 

  1046.         ZDHDZ=(CPD*(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV*(PQEN(JL,JK-1)-   &
    1047. 

  1047.           PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL,      &
    1048. 

  1048.           JK-1)-PGEO(JL,JK))
    1049. 

  1049.         ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB)
    1050. 

  1050.         ZFAC = SQRT(1.+ZDEPTH*ZBI)
    1051. 

  1051.         ZHMIN(JL) = ZHMIN(JL) + ZDHDZ*ZFAC*ZDZ
    1052. 

  1052.         ZRH = -ALV*(ZQSENH(JL,JK)-ZQENH(JL,JK))*ZFAC
    1053. 

  1053.         IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK
    1054. 

  1054.       END IF
    1055. 

  1055.  450  CONTINUE 
    1056. 

  1056.       DO 460 JL = 1, KLON
    1057. 

  1057.       IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
    1058. 

  1058.         IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL)
    1059. 

  1059.       END IF
    1060. 

  1060.       IF(KTYPE(JL).EQ.1) THEN
    1061. 

  1061.         ZENTR(JL)=ENTRPEN
    1062. 

  1062.       ELSE
    1063. 

  1063.         ZENTR(JL)=ENTRSCV
    1064. 

  1064.       ENDIF
    1065. 

  1065.       if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05
    1066. 

  1066.  460  CONTINUE 
    1067. 

  1067. !*         (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS
    1068. 

  1068. !----------------------------------------------------------
    1069. 

  1069.       CALL CUASC_NEW &
    1070. 

  1070.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,   &
    1071. 

  1071.           ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,    &
    1072. 

  1072.           PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,    &
    1073. 

  1073.           PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE, &
    1074. 

  1074.           KTYPE,    ILAB,     PTU,      PQU,      PLU,     &
    1075. 

  1075.           ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,   &
    1076. 

  1076.           ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP,  &
    1077. 

  1077.           KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,   &
    1078. 

  1078.           IHMIN,    ZHHATT,   ZQSENH)
    1079. 

  1079.       IF(ICUM.EQ.0) GO TO 1000
    1080. 

  1080. !*     (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY
    1081. 

  1081. !          CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION)
    1082. 

  1082. !------------------------------------------------------------------
    1083. 

  1083.       DO 480 JL=1,KLON
    1084. 

  1084.       ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL))
    1085. 

  1085.       IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL)
    1086. 

  1086.       IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2
    1087. 

  1087.       IF(KTYPE(JL).EQ.2) then
    1088. 

  1088.         ZENTR(JL)=ENTRSCV
    1089. 

  1089.         if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05
    1090. 

  1090.       endif
    1091. 

  1091.       ZRFL(JL)=ZDMFUP(JL,1)
    1092. 

  1092.   480 CONTINUE
    1093. 

  1093.       DO 490 JK=2,KLEV
    1094. 

  1094.       DO 490 JL=1,KLON
    1095. 

  1095.           ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK)
    1096. 

  1096.   490 CONTINUE
    1097. 

  1097. !-----------------------------------------
    1098. 

  1098. !*    5.0   CUMULUS DOWNDRAFT CALCULATIONS
    1099. 

  1099. !-----------------------------------------
    1100. 

  1100.   500 CONTINUE
    1101. 

  1101.       IF(LMFDD) THEN
    1102. 

  1102. !*      (A) DETERMINE LFS IN 'CUDLFS'
    1103. 

  1103. !--------------------------------------
    1104. 

  1104.          CALL CUDLFS &
    1105. 

  1105.          (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
    1106. 

  1106.           PUEN,     PVEN,     ZGEOH,    PAPH,     PTU,    &
    1107. 

  1107.           PQU,      ZUU,      ZVU,      LDCUM,    KCBOT,  &
    1108. 

  1108.           KCTOP,    ZMFUB,    ZRFL,     ZTD,      ZQD,    &
    1109. 

  1109.           ZUD,      ZVD,      PMFD,     ZMFDS,    ZMFDQ,  &
    1110. 

  1110.           ZDMFDP,   IDTOP,    LODDRAF)
    1111. 

  1111. !*     (B)  DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF'
    1112. 

  1112. !------------------------------------------------------------
    1113. 

  1113.          CALL CUDDRAF &
    1114. 

  1114.          (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
    1115. 

  1115.           PUEN,     PVEN,     ZGEOH,    PAPH,     ZRFL,   &
    1116. 

  1116.           LODDRAF,  ZTD,      ZQD,      ZUD,      ZVD,    &
    1117. 

  1117.           PMFD,     ZMFDS,    ZMFDQ,    ZDMFDP)
    1118. 

  1118. !*     (C)  RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
    1119. 

  1119. !           DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
    1120. 

  1120. !-----------------------------------------------------------
    1121. 

  1121.       END IF
    1122. 

  1122. !
    1123. 

  1123. !-- 5.1 Recalculate cloud base massflux from a cape closure
    1124. 

  1124. !       for deep convection (ktype=1) and by PBL equilibrium
    1125. 

  1125. !       taking downdrafts into account for shallow convection
    1126. 

  1126. !       (ktype=2)
    1127. 

  1127. !       implemented by Y. WANG based on ECHAM4 in Nov. 2001.
    1128. 

  1128. !
    1129. 

  1129.       DO 510 JL=1,KLON
    1130. 

  1130.         ZHEAT(JL)=0.0
    1131. 

  1131.         ZCAPE(JL)=0.0
    1132. 

  1132.         ZRELH(JL)=0.0
    1133. 

  1133.         ZMFUB1(JL)=ZMFUB(JL)
    1134. 

  1134.   510 CONTINUE
    1135. 

  1135. !
    1136. 

  1136.       DO 511 JL=1,KLON
    1137. 

  1137.       IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
    1138. 

  1138.       do jk=KLEVM1,2,-1
    1139. 

  1139.       if(abs(paph(jl,jk)*0.01 - 300) .lt. 50.) then
    1140. 

  1140.         KTOP0=MAX(jk,KCTOP(JL))
    1141. 

  1141.         exit
    1142. 

  1142.       end if
    1143. 

  1143.       end do
    1144. 

  1144. !      KTOP0=MAX(12,KCTOP(JL))
    1145. 

  1145.        DO JK=2,KLEV
    1146. 

  1146.        IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN
    1147. 

  1147.          ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK))
    1148. 

  1148.          ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO)
    1149. 

  1149.          ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK)   &
    1150. 

  1150.            +G*ZDZ/CPD)/ZTENH(JL,JK)+0.608*(PQEN(JL,JK-1)-  &
    1151. 

  1151.            PQEN(JL,JK)))*(PMFU(JL,JK)+PMFD(JL,JK))*G/ZRO
    1152. 

  1152.          ZCAPE(JL)=ZCAPE(JL)+G*((PTU(JL,JK)*(1.+.608*PQU(JL,JK) &
    1153. 

  1153.            -PLU(JL,JK)))/(ZTENH(JL,JK)*(1.+.608*ZQENH(JL,JK))) &
    1154. 

  1154.            -1.0)*ZDZ
    1155. 

  1155.        ENDIF
    1156. 

  1156.        IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN
    1157. 

  1157.          dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))-  &
    1158. 

  1158.             PAPH(JL,KTOP0))
    1159. 

  1159.          ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK)
    1160. 

  1160.        ENDIF
    1161. 

  1161.        ENDDO
    1162. 

  1162. !
    1163. 

  1163.        
    1164. 

  1164.        if(cutrigger .eq. 1 ) then 
    1165. 

  1165.          IF(lndj(JL).EQ.1) then
    1166. 

  1166.            CRIRH1=CRIRH*0.8
    1167. 

  1167.          ELSE
    1168. 

  1168.            CRIRH1=CRIRH
    1169. 

  1169.          ENDIF
    1170. 

  1170.        else
    1171. 

  1171.           CRIRH1=0.
    1172. 

  1172.        end if
    1173. 

  1173. 

  1174.        IF(ZRELH(JL).GE.CRIRH1 .AND. ZCAPE(JL) .GT. 100.) THEN
    1175. 

  1175.          IKB=KCBOT(JL)
    1176. 

  1176.          ZHT=ZCAPE(JL)/(ZTAU*ZHEAT(JL))
    1177. 

  1177.          ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01)
    1178. 

  1178.          ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
    1179. 

  1179.          ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
    1180. 

  1180.        ELSE
    1181. 

  1181.          ZMFUB1(JL)=0.01
    1182. 

  1182.          ZMFUB(JL)=0.01
    1183. 

  1183.          LDCUM(JL)=.FALSE.
    1184. 

  1184.         ENDIF
    1185. 

  1185.        ENDIF
    1186. 

  1186.   511  CONTINUE
    1187. 

  1187. !
    1188. 

  1188. !*  5.2   RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
    1189. 

  1189. !         DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
    1190. 

  1190. !--------------------------------------------------------
    1191. 

  1191.        DO 512 JL=1,KLON
    1192. 

  1192.         IF(KTYPE(JL).NE.1) THEN
    1193. 

  1193.            IKB=KCBOT(JL)
    1194. 

  1194.            IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN
    1195. 

  1195.               ZEPS=CMFDEPS
    1196. 

  1196.            ELSE
    1197. 

  1197.               ZEPS=0.
    1198. 

  1198.            ENDIF
    1199. 

  1199.            ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-          &
    1200. 

  1200.                  ZEPS*ZQD(JL,IKB)-(1.-ZEPS)*ZQENH(JL,IKB)
    1201. 

  1201.            ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
    1202. 

  1202.            ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
    1203. 

  1203.            IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) &
    1204. 

  1204.              .AND.ZMFUB(JL).LT.ZMFMAX) THEN
    1205. 

  1205.               ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
    1206. 

  1206.            ELSE
    1207. 

  1207.               ZMFUB1(JL)=ZMFUB(JL)
    1208. 

  1208.            ENDIF
    1209. 

  1209.            LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL)  &
    1210. 

  1210.                 -ZMFUB(JL)).LT.0.2*ZMFUB(JL)
    1211. 

  1211.            IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL)
    1212. 

  1212.            ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
    1213. 

  1213.         END IF
    1214. 

  1214.   512   CONTINUE
    1215. 

  1215.         DO 530 JK=1,KLEV
    1216. 

  1216.         DO 530 JL=1,KLON
    1217. 

  1217.         IF(LDCUM(JL)) THEN
    1218. 

  1218.            ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10)
    1219. 

  1219.            PMFD(JL,JK)=PMFD(JL,JK)*ZFAC
    1220. 

  1220.            ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC
    1221. 

  1221.            ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC
    1222. 

  1222.            ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC
    1223. 

  1223.         ELSE
    1224. 

  1224.            PMFD(JL,JK)=0.0
    1225. 

  1225.            ZMFDS(JL,JK)=0.0
    1226. 

  1226.            ZMFDQ(JL,JK)=0.0
    1227. 

  1227.            ZDMFDP(JL,JK)=0.0
    1228. 

  1228.         ENDIF
    1229. 

  1229.   530   CONTINUE
    1230. 

  1230.         DO 538 JL=1,KLON
    1231. 

  1231.            IF(LDCUM(JL)) THEN
    1232. 

  1232.               ZMFUB(JL)=ZMFUB1(JL)
    1233. 

  1233.            ELSE
    1234. 

  1234.               ZMFUB(JL)=0.0
    1235. 

  1235.            ENDIF
    1236. 

  1236.   538   CONTINUE
    1237. 

  1237. !
    1238. 

  1238. !---------------------------------------------------------------
    1239. 

  1239. !*    6.0      DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME
    1240. 

  1240. !*             FOR PENETRATIVE CONVECTION (TYPE=1),
    1241. 

  1241. !*             FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2)
    1242. 

  1242. !*             AND FOR MID-LEVEL CONVECTION (TYPE=3).
    1243. 

  1243. !---------------------------------------------------------------
    1244. 

  1244.   600 CONTINUE
    1245. 

  1245.       CALL CUASC_NEW &
    1246. 

  1246.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,  &
    1247. 

  1247.           ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
    1248. 

  1248.           PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,   &
    1249. 

  1249.           PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE,& 
    1250. 

  1250.           KTYPE,    ILAB,     PTU,      PQU,      PLU,    &
    1251. 

  1251.           ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,  &
    1252. 

  1252.           ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP, &
    1253. 

  1253.           KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,  &
    1254. 

  1254.           IHMIN,    ZHHATT,   ZQSENH)
    1255. 

  1255. !----------------------------------------------------------
    1256. 

  1256. !*    7.0      DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX'
    1257. 

  1257. !----------------------------------------------------------
    1258. 

  1258.   700 CONTINUE
    1259. 

  1259.       CALL CUFLX &
    1260. 

  1260.          (KLON,     KLEV,     KLEVP1,   PQEN,     PQSEN,  &
    1261. 

  1261.           ZTENH,    ZQENH,    PAPH,     ZGEOH,    KCBOT,  &
    1262. 

  1262.           KCTOP,    IDTOP,    KTYPE,    LODDRAF,  LDCUM,  &
    1263. 

  1263.           PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ,  &
    1264. 

  1264.           ZMFDQ,    ZMFUL,    PLUDE,    ZDMFUP,   ZDMFDP, &
    1265. 

  1265.           ZRFL,     PRAIN,    PTEN,     ZSFL,     ZDPMEL, &
    1266. 

  1266.           ITOPM2,   ZTMST,    sig1)
    1267. 

  1267. !----------------------------------------------------------------
    1268. 

  1268. !*    8.0      UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ
    1269. 

  1269. !----------------------------------------------------------------
    1270. 

  1270.   800 CONTINUE
    1271. 

  1271.       CALL CUDTDQ                                          &
    1272. 

  1272.          (KLON,     KLEV,     KLEVP1,   ITOPM2,   PAPH,    &
    1273. 

  1273.           LDCUM,    PTEN,     PTTE,     PQTE,     ZMFUS,   &
    1274. 

  1274.           ZMFDS,    ZMFUQ,    ZMFDQ,    ZMFUL,    ZDMFUP,  &
    1275. 

  1275.           ZDMFDP,   ZTMST,    ZDPMEL,   PRAIN,    ZRFL,    &
    1276. 

  1276.           ZSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT,  &
    1277. 

  1277.           PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,   &
    1278. 

  1278.           PQEN,     PQSEN,    PLUDE,    PCTE)
    1279. 

  1279. !----------------------------------------------------------------
    1280. 

  1280. !*    9.0      UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV
    1281. 

  1281. !----------------------------------------------------------------
    1282. 

  1282.   900 CONTINUE
    1283. 

  1283.       IF(LMFDUDV) THEN
    1284. 

  1284.       CALL CUDUDV  &
    1285. 

  1285.          (KLON,     KLEV,     KLEVP1,   ITOPM2,   KTYPE,   &
    1286. 

  1286.           KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,    &
    1287. 

  1287.           PVOM,     PVOL,     ZUU,      ZUD,      ZVU,     &
    1288. 

  1288.           ZVD,      PMFU,     PMFD,     PSDISS)
    1289. 

  1289.       END IF
    1290. 

  1290.  1000 CONTINUE
    1291. 

  1291.       RETURN
    1292. 

  1292.       END SUBROUTINE CUMASTR_NEW
    1293. 

  1293. !
    1294. 

  1294. 

  1295. !#############################################################
    1296. 

  1296. !
    1297. 

  1297. !             LEVEL 3 SUBROUTINEs
    1298. 

  1298. !
    1299. 

  1299. !#############################################################
    1300. 

  1300. !**********************************************
    1301. 

  1301. !       SUBROUTINE CUINI
    1302. 

  1302. !**********************************************
    1303. 

  1303. !
    1304. 

  1304.       SUBROUTINE CUINI                                    &
    1305. 

  1305.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,   &
    1306. 

  1306.           PQEN,     PQSEN,    PUEN,     PVEN,     PVERV,  &
    1307. 

  1307.           PGEO,     PAPH,     PGEOH,    PTENH,    PQENH,  &
    1308. 

  1308.           PQSENH,   KLWMIN,   PTU,      PQU,      PTD,    &
    1309. 

  1309.           PQD,      PUU,      PVU,      PUD,      PVD,    &
    1310. 

  1310.           PMFU,     PMFD,     PMFUS,    PMFDS,    PMFUQ,  &
    1311. 

  1311.           PMFDQ,    PDMFUP,   PDMFDP,   PDPMEL,   PLU,    &
    1312. 

  1312.           PLUDE,    KLAB)
    1313. 

  1313. !      M.TIEDTKE         E.C.M.W.F.     12/89
    1314. 

  1314. !***PURPOSE
    1315. 

  1315. !   -------
    1316. 

  1316. !          THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
    1317. 

  1317. !          TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
    1318. 

  1318. !          AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS
    1319. 

  1319. !***INTERFACE
    1320. 

  1320. !   ---------
    1321. 

  1321. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    1322. 

  1322. !***METHOD.
    1323. 

  1323. !  --------
    1324. 

  1324. !          FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989)
    1325. 

  1325. !***EXTERNALS
    1326. 

  1326. !   ---------
    1327. 

  1327. !          *CUADJTQ* TO SPECIFY QS AT HALF LEVELS
    1328. 

  1328. ! ----------------------------------------------------------------
    1329. 

  1329. !-------------------------------------------------------------------
    1330. 

  1330.       IMPLICIT NONE
    1331. 

  1331. !-------------------------------------------------------------------
    1332. 

  1332.       INTEGER   KLON, KLEV, KLEVP1
    1333. 

  1333.       INTEGER   klevm1
    1334. 

  1334.       INTEGER   JK,JL,IK, ICALL
    1335. 

  1335.       REAL      ZDP, ZZS
    1336. 

  1336.       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),    &
    1337. 

  1337.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
    1338. 

  1338.               PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),    &
    1339. 

  1339.               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),    &
    1340. 

  1340.               PAPH(KLON,KLEVP1),      PTENH(KLON,KLEV),    &
    1341. 

  1341.               PQENH(KLON,KLEV),       PQSENH(KLON,KLEV)
    1342. 

  1342.       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),     &
    1343. 

  1343.               PTD(KLON,KLEV),         PQD(KLON,KLEV),      &
    1344. 

  1344.               PUU(KLON,KLEV),         PUD(KLON,KLEV),      &
    1345. 

  1345.               PVU(KLON,KLEV),         PVD(KLON,KLEV),      &
    1346. 

  1346.               PMFU(KLON,KLEV),        PMFD(KLON,KLEV),     &
    1347. 

  1347.               PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),    &
    1348. 

  1348.               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),    &
    1349. 

  1349.               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),   & 
    1350. 

  1350.               PLU(KLON,KLEV),         PLUDE(KLON,KLEV)
    1351. 

  1351.       REAL     ZWMAX(KLON),            ZPH(KLON),          &
    1352. 

  1352.               PDPMEL(KLON,KLEV)
    1353. 

  1353.       INTEGER  KLAB(KLON,KLEV),        KLWMIN(KLON)
    1354. 

  1354.       LOGICAL  LOFLAG(KLON)
    1355. 

  1355. !------------------------------------------------------------
    1356. 

  1356. !*    1.       SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
    1357. 

  1357. !*             ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
    1358. 

  1358. !*             FIND LEVEL OF MAXIMUM VERTICAL VELOCITY
    1359. 

  1359. ! -----------------------------------------------------------
    1360. 

  1360.   100 CONTINUE
    1361. 

  1361.       ZDP=0.5
    1362. 

  1362.       DO 130 JK=2,KLEV
    1363. 

  1363.       DO 110 JL=1,KLON
    1364. 

  1364.       PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP
    1365. 

  1365.       PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1),   &
    1366. 

  1366.                   CPD*PTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))*RCPD
    1367. 

  1367.       PQSENH(JL,JK)=PQSEN(JL,JK-1)
    1368. 

  1368.       ZPH(JL)=PAPH(JL,JK)
    1369. 

  1369.       LOFLAG(JL)=.TRUE.
    1370. 

  1370.   110 CONTINUE
    1371. 

  1371.       IK=JK
    1372. 

  1372.       ICALL=0
    1373. 

  1373.       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL)
    1374. 

  1374.       DO 120 JL=1,KLON
    1375. 

  1375.       PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1))    &
    1376. 

  1376.                  +(PQSENH(JL,JK)-PQSEN(JL,JK-1))
    1377. 

  1377.       PQENH(JL,JK)=MAX(PQENH(JL,JK),0.)
    1378. 

  1378.   120 CONTINUE
    1379. 

  1379.   130 CONTINUE
    1380. 

  1380.       DO 140 JL=1,KLON
    1381. 

  1381.       PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)-   &
    1382. 

  1382.                      PGEOH(JL,KLEV))*RCPD
    1383. 

  1383.       PQENH(JL,KLEV)=PQEN(JL,KLEV)
    1384. 

  1384.       PTENH(JL,1)=PTEN(JL,1)
    1385. 

  1385.       PQENH(JL,1)=PQEN(JL,1)
    1386. 

  1386.       PGEOH(JL,1)=PGEO(JL,1)
    1387. 

  1387.       KLWMIN(JL)=KLEV
    1388. 

  1388.       ZWMAX(JL)=0.
    1389. 

  1389.   140 CONTINUE
    1390. 

  1390.       DO 160 JK=KLEVM1,2,-1
    1391. 

  1391.       DO 150 JL=1,KLON
    1392. 

  1392.       ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK),   &
    1393. 

  1393.              CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))
    1394. 

  1394.       PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD
    1395. 

  1395.   150 CONTINUE
    1396. 

  1396.   160 CONTINUE
    1397. 

  1397.       DO 190 JK=KLEV,3,-1
    1398. 

  1398.       DO 180 JL=1,KLON
    1399. 

  1399.       IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN
    1400. 

  1400.          ZWMAX(JL)=PVERV(JL,JK)
    1401. 

  1401.          KLWMIN(JL)=JK
    1402. 

  1402.       END IF
    1403. 

  1403.   180 CONTINUE
    1404. 

  1404.   190 CONTINUE
    1405. 

  1405. !-----------------------------------------------------------
    1406. 

  1406. !*    2.0      INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
    1407. 

  1407. !-----------------------------------------------------------
    1408. 

  1408.   200 CONTINUE
    1409. 

  1409.       DO 230 JK=1,KLEV
    1410. 

  1410.       IK=JK-1
    1411. 

  1411.       IF(JK.EQ.1) IK=1
    1412. 

  1412.       DO 220 JL=1,KLON
    1413. 

  1413.       PTU(JL,JK)=PTENH(JL,JK)
    1414. 

  1414.       PTD(JL,JK)=PTENH(JL,JK)
    1415. 

  1415.       PQU(JL,JK)=PQENH(JL,JK)
    1416. 

  1416.       PQD(JL,JK)=PQENH(JL,JK)
    1417. 

  1417.       PLU(JL,JK)=0.
    1418. 

  1418.       PUU(JL,JK)=PUEN(JL,IK)
    1419. 

  1419.       PUD(JL,JK)=PUEN(JL,IK)
    1420. 

  1420.       PVU(JL,JK)=PVEN(JL,IK)
    1421. 

  1421.       PVD(JL,JK)=PVEN(JL,IK)
    1422. 

  1422.       PMFU(JL,JK)=0.
    1423. 

  1423.       PMFD(JL,JK)=0.
    1424. 

  1424.       PMFUS(JL,JK)=0.
    1425. 

  1425.       PMFDS(JL,JK)=0.
    1426. 

  1426.       PMFUQ(JL,JK)=0.
    1427. 

  1427.       PMFDQ(JL,JK)=0.
    1428. 

  1428.       PDMFUP(JL,JK)=0.
    1429. 

  1429.       PDMFDP(JL,JK)=0.
    1430. 

  1430.       PDPMEL(JL,JK)=0.
    1431. 

  1431.       PLUDE(JL,JK)=0.
    1432. 

  1432.       KLAB(JL,JK)=0
    1433. 

  1433.   220 CONTINUE
    1434. 

  1434.   230 CONTINUE
    1435. 

  1435.       RETURN
    1436. 

  1436.       END SUBROUTINE CUINI   
    1437. 

  1437. 

  1438. !**********************************************
    1439. 

  1439. !       SUBROUTINE CUBASE
    1440. 

  1440. !********************************************** 
    1441. 

  1441.       SUBROUTINE CUBASE &
    1442. 

  1442.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH, &
    1443. 

  1443.           PQENH,    PGEOH,    PAPH,     PTU,      PQU,   &
    1444. 

  1444.           PLU,      PUEN,     PVEN,     PUU,      PVU,   &
    1445. 

  1445.           LDCUM,    KCBOT,    KLAB)
    1446. 

  1446. !      THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
    1447. 

  1447. !      FOR CUMULUS PARAMETERIZATION
    1448. 

  1448. !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
    1449. 

  1449. !***PURPOSE.
    1450. 

  1450. !   --------
    1451. 

  1451. !          TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION
    1452. 

  1452. !***INTERFACE
    1453. 

  1453. !   ---------
    1454. 

  1454. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    1455. 

  1455. !          INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
    1456. 

  1456. !          IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
    1457. 

  1457. !                 KLAB=1 FOR SUBCLOUD LEVELS
    1458. 

  1458. !                 KLAB=2 FOR CONDENSATION LEVEL
    1459. 

  1459. !***METHOD.
    1460. 

  1460. !  --------
    1461. 

  1461. !          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
    1462. 

  1462. !          (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
    1463. 

  1463. !***EXTERNALS
    1464. 

  1464. !   ---------
    1465. 

  1465. !          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
    1466. 

  1466. ! ----------------------------------------------------------------
    1467. 

  1467. !-------------------------------------------------------------------
    1468. 

  1468.       IMPLICIT NONE
    1469. 

  1469. !-------------------------------------------------------------------
    1470. 

  1470.       INTEGER   KLON, KLEV, KLEVP1
    1471. 

  1471.       INTEGER   klevm1
    1472. 

  1472.       INTEGER   JL,JK,IS,IK,ICALL,IKB
    1473. 

  1473.       REAL      ZBUO,ZZ
    1474. 

  1474.       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
    1475. 

  1475.               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1)
    1476. 

  1476.       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
    1477. 

  1477.               PLU(KLON,KLEV)
    1478. 

  1478.       REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
    1479. 

  1479.               PUU(KLON,KLEV),         PVU(KLON,KLEV) 
    1480. 

  1480.       REAL     ZQOLD(KLON,KLEV),       ZPH(KLON)
    1481. 

  1481.       INTEGER  KLAB(KLON,KLEV),        KCBOT(KLON)
    1482. 

  1482.       LOGICAL  LDCUM(KLON),            LOFLAG(KLON)
    1483. 

  1483. !***INPUT VARIABLES:
    1484. 

  1484. !       PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
    1485. 

  1485. !       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
    1486. 

  1486. !       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
    1487. 

  1487. !       PAPH - Pressure of half levels. (MSSFLX)
    1488. 

  1488. !***VARIABLES MODIFIED BY CUBASE:
    1489. 

  1489. !       LDCUM - Logical denoting profiles. (CUBASE)
    1490. 

  1490. !       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
    1491. 

  1491. !                                 2: Stratocumulus (CUMASTR)
    1492. 

  1492. !                                 3: Mid-level  (CUASC)
    1493. 

  1493. !       PTU - Cloud Temperature.
    1494. 

  1494. !       PQU - Cloud specific Humidity.
    1495. 

  1495. !       PLU - Cloud Liquid Water (Moisture condensed out)
    1496. 

  1496. !       KCBOT - Cloud Base Level. (CUBASE)
    1497. 

  1497. !       KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE)
    1498. 

  1498. !------------------------------------------------
    1499. 

  1499. !     1.       INITIALIZE VALUES AT LIFTING LEVEL
    1500. 

  1500. !------------------------------------------------
    1501. 

  1501.   100 CONTINUE
    1502. 

  1502.       DO 110 JL=1,KLON
    1503. 

  1503.         KLAB(JL,KLEV)=1
    1504. 

  1504.         KCBOT(JL)=KLEVM1
    1505. 

  1505.         LDCUM(JL)=.FALSE.
    1506. 

  1506.         PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
    1507. 

  1507.         PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
    1508. 

  1508.   110 CONTINUE
    1509. 

  1509. !-------------------------------------------------------
    1510. 

  1510. !     2.0      DO ASCENT IN SUBCLOUD LAYER,
    1511. 

  1511. !              CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
    1512. 

  1512. !              ADJUST T,Q AND L ACCORDINGLY IN *CUADJTQ*,
    1513. 

  1513. !              CHECK FOR BUOYANCY AND SET FLAGS
    1514. 

  1514. !-------------------------------------------------------
    1515. 

  1515.       DO 200 JK=1,KLEV
    1516. 

  1516.       DO 200 JL=1,KLON
    1517. 

  1517.         ZQOLD(JL,JK)=0.0
    1518. 

  1518.   200 CONTINUE
    1519. 

  1519.       DO 290 JK=KLEVM1,2,-1
    1520. 

  1520.         IS=0
    1521. 

  1521.         DO 210 JL=1,KLON
    1522. 

  1522.           IF(KLAB(JL,JK+1).EQ.1) THEN
    1523. 

  1523.              IS=IS+1
    1524. 

  1524.              LOFLAG(JL)=.TRUE.
    1525. 

  1525.           ELSE
    1526. 

  1526.              LOFLAG(JL)=.FALSE.
    1527. 

  1527.           ENDIF
    1528. 

  1528.           ZPH(JL)=PAPH(JL,JK)
    1529. 

  1529.   210   CONTINUE
    1530. 

  1530.         IF(IS.EQ.0) GO TO 290
    1531. 

  1531.         DO 220 JL=1,KLON
    1532. 

  1532.           IF(LOFLAG(JL)) THEN
    1533. 

  1533.              PQU(JL,JK)=PQU(JL,JK+1)
    1534. 

  1534.              PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1)  &
    1535. 

  1535.                        -PGEOH(JL,JK))*RCPD
    1536. 

  1536.              ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
    1537. 

  1537.                  PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
    1538. 

  1538.              IF(ZBUO.GT.0.) KLAB(JL,JK)=1
    1539. 

  1539.              ZQOLD(JL,JK)=PQU(JL,JK)
    1540. 

  1540.           END IF
    1541. 

  1541.   220   CONTINUE
    1542. 

  1542.         IK=JK
    1543. 

  1543.         ICALL=1
    1544. 

  1544.         CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
    1545. 

  1545.         DO 240 JL=1,KLON
    1546. 

  1546.           IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN
    1547. 

  1547.              KLAB(JL,JK)=2
    1548. 

  1548.              PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK)
    1549. 

  1549.              ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
    1550. 

  1550.                  PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
    1551. 

  1551.              IF(ZBUO.GT.0.) THEN
    1552. 

  1552.                 KCBOT(JL)=JK
    1553. 

  1553.                 LDCUM(JL)=.TRUE.
    1554. 

  1554.              END IF
    1555. 

  1555.           END IF
    1556. 

  1556.   240   CONTINUE
    1557. 

  1557. !             CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,.
    1558. 

  1558. !             THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES.
    1559. 

  1559.         IF(LMFDUDV) THEN
    1560. 

  1560.            DO 250 JL=1,KLON
    1561. 

  1561.              IF(JK.GE.KCBOT(JL)) THEN
    1562. 

  1562.                 PUU(JL,KLEV)=PUU(JL,KLEV)+           &
    1563. 

  1563.                           PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
    1564. 

  1564.                 PVU(JL,KLEV)=PVU(JL,KLEV)+           &
    1565. 

  1565.                           PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
    1566. 

  1566.              END IF
    1567. 

  1567.  250       CONTINUE
    1568. 

  1568.         END IF
    1569. 

  1569.   290 CONTINUE
    1570. 

  1570.       IF(LMFDUDV) THEN
    1571. 

  1571.          DO 310 JL=1,KLON
    1572. 

  1572.          IF(LDCUM(JL)) THEN
    1573. 

  1573.             IKB=KCBOT(JL)
    1574. 

  1574.             ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB))
    1575. 

  1575.             PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ
    1576. 

  1576.             PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ
    1577. 

  1577.          ELSE
    1578. 

  1578.             PUU(JL,KLEV)=PUEN(JL,KLEVM1)
    1579. 

  1579.             PVU(JL,KLEV)=PVEN(JL,KLEVM1)
    1580. 

  1580.          END IF
    1581. 

  1581.  310     CONTINUE
    1582. 

  1582.       END IF
    1583. 

  1583.       RETURN
    1584. 

  1584.       END SUBROUTINE CUBASE
    1585. 

  1585. 

  1586. !**********************************************
    1587. 

  1587. !       SUBROUTINE CUTYPE
    1588. 

  1588. !********************************************** 
    1589. 

  1589.       SUBROUTINE CUTYPE    &
    1590. 

  1590.         ( KLON,     KLEV,     KLEVP1,   KLEVM1,&
    1591. 

  1591.           PTENH,   PQENH,     PQSENH,    PGEOH,   PAPH,&
    1592. 

  1592.           RHO,      HFX,         QFX,    KTYPE,   lndj   )
    1593. 

  1593. !      THIS ROUTINE CALCULATES CLOUD BASE and TOP
    1594. 

  1594. !      AND RETURN CLOUD TYPES
    1595. 

  1595. !      ZHANG & WANG      IPRC           12/2010
    1596. 

  1596. !***PURPOSE.
    1597. 

  1597. !   --------
    1598. 

  1598. !          TO PRODUCE CLOUD TYPE for CU-PARAMETERIZATIONS
    1599. 

  1599. !***INTERFACE
    1600. 

  1600. !   ---------
    1601. 

  1601. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    1602. 

  1602. !          INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
    1603. 

  1603. !          IT RETURNS CLOUD TYPES AS FOLLOWS;
    1604. 

  1604. !                 KTYPE=1 FOR deep cumulus
    1605. 

  1605. !                 KTYPE=2 FOR shallow cumulus
    1606. 

  1606. !***METHOD.
    1607. 

  1607. !  --------
    1608. 

  1608. !          based on a simplified updraught equation
    1609. 

  1609. !            partial(Hup)/partial(z)=eta(H - Hup)
    1610. 

  1610. !            eta is the entrainment rate for test parcel
    1611. 

  1611. !            H stands for dry static energy or the total water specific humidity
    1612. 

  1612. !            references: Christian Jakob, 2003: A new subcloud model for mass-flux convection schemes
    1613. 

  1613. !                        influence on triggering, updraft properties, and model climate, Mon.Wea.Rev.
    1614. 

  1614. !                        131, 2765-2778
    1615. 

  1615. !            and
    1616. 

  1616. !                        IFS Documentation - Cy33r1 
    1617. 

  1617. !          
    1618. 

  1618. !***EXTERNALS
    1619. 

  1619. !   ---------
    1620. 

  1620. !          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
    1621. 

  1621. ! ----------------------------------------------------------------
    1622. 

  1622. !-------------------------------------------------------------------
    1623. 

  1623.       IMPLICIT NONE
    1624. 

  1624. !-------------------------------------------------------------------
    1625. 

  1625.       INTEGER   KLON, KLEV, KLEVP1
    1626. 

  1626.       INTEGER   klevm1
    1627. 

  1627.       INTEGER   JL,JK,IS,IK,ICALL,IKB,LEVELS
    1628. 

  1628.       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV), &
    1629. 

  1629.                                        PQSENH(KLON,KLEV),&
    1630. 

  1630.                PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1)
    1631. 

  1631.       REAL     ZRELH(KLON)
    1632. 

  1632.       REAL     QFX(KLON),RHO(KLON),HFX(KLON)
    1633. 

  1633.       REAL     ZQOLD(KLON,KLEV),       ZPH(KLON)
    1634. 

  1634.       INTEGER  KCTOP(KLON),KCBOT(KLON)
    1635. 

  1635.       INTEGER  KTYPE(KLON),LCLFLAG(KLON)
    1636. 

  1636.       LOGICAL  TOPFLAG(KLON),DEEPFLAG(KLON),MYFLAG(KLON)
    1637. 

  1637. 

  1638.       REAL     part1(klon), part2(klon), root(klon)
    1639. 

  1639.       REAL     conw(klon),deltT(klon),deltQ(klon)
    1640. 

  1640.       REAL     eta(klon),dz(klon),coef(klon)
    1641. 

  1641.       REAL     dhen(KLON,KLEV), dh(KLON,KLEV),qh(KLON,KLEV)
    1642. 

  1642.       REAL      Tup(KLON,KLEV),Qup(KLON,KLEV),ql(KLON,KLEV)
    1643. 

  1643.       REAL       ww(KLON,KLEV),Kup(KLON,KLEV)
    1644. 

  1644.       REAL     Vtup(KLON,KLEV),Vten(KLON,KLEV),buoy(KLON,KLEV)
    1645. 

  1645. 

  1646.       INTEGER  lndj(KLON)
    1647. 

  1647.       REAL     CRIRH1
    1648. 

  1648. !***INPUT VARIABLES:
    1649. 

  1649. !       PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
    1650. 

  1650. !       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
    1651. 

  1651. !       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
    1652. 

  1652. !       PAPH - Pressure of half levels. (MSSFLX)
    1653. 

  1653. !       RHO  - Density of the lowest Model level
    1654. 

  1654. !       QFX  - net upward moisture flux at the surface (kg/m^2/s)
    1655. 

  1655. !       HFX  - net upward heat flux at the surface (W/m^2)
    1656. 

  1656. !***VARIABLES OUTPUT BY CUTYPE:
    1657. 

  1657. !       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
    1658. 

  1658. !                                 2: Stratocumulus (CUMASTR)
    1659. 

  1659. !                                 3: Mid-level  (CUASC)
    1660. 

  1660. !--------------------------------------------------------------
    1661. 

  1661.       DO JL=1,KLON
    1662. 

  1662.         KCBOT(JL)=KLEVM1
    1663. 

  1663.         KCTOP(JL)=KLEVM1
    1664. 

  1664.         KTYPE(JL)=0
    1665. 

  1665.       END DO
    1666. 

  1666. !-----------------------------------------------------------
    1667. 

  1667. ! let's do test,and check the shallow convection first
    1668. 

  1668. ! the first level is JK+1
    1669. 

  1669. ! define deltaT and deltaQ
    1670. 

  1670. !-----------------------------------------------------------
    1671. 

  1671.       DO JK=1,KLEV
    1672. 

  1672.       DO JL=1,KLON
    1673. 

  1673.         ZQOLD(JL,JK)=0.0
    1674. 

  1674.            ql(jl,jk)=0.0  ! parcel liquid water
    1675. 

  1675.           Tup(jl,jk)=0.0  ! parcel temperature
    1676. 

  1676.           Qup(jl,jk)=0.0  ! parcel specific humidity
    1677. 

  1677.            dh(jl,jk)=0.0  ! parcel dry static energy
    1678. 

  1678.            qh(jl,jk)=0.0  ! parcel total water specific humidity
    1679. 

  1679.            ww(jl,jk)=0.0  ! parcel vertical speed (m/s)
    1680. 

  1680.          dhen(jl,jk)=0.0  ! environment dry static energy
    1681. 

  1681.           Kup(jl,jk)=0.0  ! updraught kinetic energy for parcel
    1682. 

  1682.          Vtup(jl,jk)=0.0  ! parcel virtual temperature considering water-loading
    1683. 

  1683.          Vten(jl,jk)=0.0  ! environment virtual temperature
    1684. 

  1684.          buoy(jl,jk)=0.0  ! parcel buoyancy
    1685. 

  1685.       END DO
    1686. 

  1686.       END DO
    1687. 

  1687. 

  1688.       do jl=1,klon
    1689. 

  1689.          lclflag(jl) = 0  ! flag for the condensation level
    1690. 

  1690.          conw(jl)    = 0.0 ! convective-scale velocity,also used for the vertical speed at the first level
    1691. 

  1691.          myflag(jl)  = .true. ! just as input for cuadjqt subroutine
    1692. 

  1692.         topflag(jl)  = .false.! flag for whether the cloud top is found
    1693. 

  1693.       end do
    1694. 

  1694. 

  1695. ! check the levels from lowest level to second top level
    1696. 

  1696.       do JK=KLEVM1,2,-1
    1697. 

  1697.         DO JL=1,KLON
    1698. 

  1698.           ZPH(JL)=PAPH(JL,JK)
    1699. 

  1699.         END DO
    1700. 

  1700. 

  1701. ! define the variables at the first level      
    1702. 

  1702.       if(jk .eq. KLEVM1) then
    1703. 

  1703.       do jl=1,klon
    1704. 

  1704.         part1(jl) = 1.5*0.4*pgeoh(jl,jk+1)/(rho(jl)*ptenh(jl,jk+1))
    1705. 

  1705.         part2(jl) = hfx(jl)/cpd+0.61*ptenh(jl,jk+1)*qfx(jl)
    1706. 

  1706.         root(jl) = 0.001-part1(jl)*part2(jl)
    1707. 

  1707.         if(root(jl) .gt. 0) then
    1708. 

  1708.           conw(jl) = 1.2*(root(jl))**(1.0/3.0)
    1709. 

  1709.         else
    1710. 

  1710.           conw(jl) = -1.2*(-root(jl))**(1.0/3.0)
    1711. 

  1711.         end if
    1712. 

  1712.         deltT(jl) = -1.5*hfx(jl)/(rho(jl)*cpd*conw(jl))
    1713. 

  1713.         deltQ(jl) = -1.5*qfx(jl)/(rho(jl)*conw(jl))
    1714. 

  1714. 

  1715.         Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl)
    1716. 

  1716.         Qup(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl)
    1717. 

  1717.          ql(jl,jk+1) = 0.
    1718. 

  1718.          dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd
    1719. 

  1719.          qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) + ql(jl,jk+1)
    1720. 

  1720.          ww(jl,jk+1) = conw(jl)
    1721. 

  1721.       end do
    1722. 

  1722.       end if
    1723. 

  1723. 

  1724. ! the next levels, we use the variables at the first level as initial values
    1725. 

  1725.       do jl=1,klon
    1726. 

  1726.       if(.not. topflag(jl)) then
    1727. 

  1727.         eta(jl) = 0.5*(0.55/(pgeoh(jl,jk)*zrg)+1.0e-3)
    1728. 

  1728.         dz(jl)  = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
    1729. 

  1729.         coef(jl)= eta(jl)*dz(jl)
    1730. 

  1730.         dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk)
    1731. 

  1731.         dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl))
    1732. 

  1732.         qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl))
    1733. 

  1733.         Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD
    1734. 

  1734.         Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1)
    1735. 

  1735.         zqold(jl,jk) = Qup(jl,jk)
    1736. 

  1736.       end if
    1737. 

  1737.       end do
    1738. 

  1738. ! check if the parcel is saturated
    1739. 

  1739.       ik=jk
    1740. 

  1740.       icall=1
    1741. 

  1741.       call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall)
    1742. 

  1742.       do jl=1,klon
    1743. 

  1743.         if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then
    1744. 

  1744.           lclflag(jl) = lclflag(jl) + 1
    1745. 

  1745.           ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk)
    1746. 

  1746.           dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk)
    1747. 

  1747.         end if
    1748. 

  1748.       end do
    1749. 

  1749. 

  1750. ! compute the updraft speed
    1751. 

  1751.       do jl=1,klon
    1752. 

  1752.         if(.not. topflag(jl))then
    1753. 

  1753.           Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2
    1754. 

  1754.           Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk))
    1755. 

  1755.           Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk))
    1756. 

  1756.           buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g
    1757. 

  1757.           Kup(jl,jk)  = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ &
    1758. 

  1758.                         (1+2*2*eta(jl)*dz(jl))
    1759. 

  1759.           if(Kup(jl,jk) .gt. 0 ) then
    1760. 

  1760.              ww(jl,jk) = sqrt(2*Kup(jl,jk))
    1761. 

  1761.              if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk
    1762. 

  1762.              if(jk .eq. 2) then
    1763. 

  1763.                 kctop(jl) = jk
    1764. 

  1764.                 topflag(jl)= .true.
    1765. 

  1765.              end if
    1766. 

  1766.           else
    1767. 

  1767.              ww(jl,jk) = 0
    1768. 

  1768.              kctop(jl) = jk + 1
    1769. 

  1769.              topflag(jl) = .true.
    1770. 

  1770.           end if
    1771. 

  1771.          end if
    1772. 

  1772.       end do
    1773. 

  1773.       end do ! end all the levels
    1774. 

  1774. 

  1775.       do jl=1,klon
    1776. 

  1776.         if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .lt. ZDNOPRC .and. &
    1777. 

  1777.           paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. 0 &
    1778. 

  1778.            .and. lclflag(jl) .gt. 0) then
    1779. 

  1779.            ktype(jl) = 2
    1780. 

  1780.          end if
    1781. 

  1781.       end do
    1782. 

  1782. 

  1783. !-----------------------------------------------------------
    1784. 

  1784. ! Next, let's check the deep convection
    1785. 

  1785. ! the first level is JK
    1786. 

  1786. ! define deltaT and deltaQ
    1787. 

  1787. !----------------------------------------------------------
    1788. 

  1788. ! we check the parcel starting level by level (from the second lowest level to the next 12th level,
    1789. 

  1789. ! usually, the 12th level around 700 hPa for common eta levels)
    1790. 

  1790.       do levels=KLEVM1-1,KLEVM1-12,-1
    1791. 

  1791.       DO JK=1,KLEV
    1792. 

  1792.       DO JL=1,KLON
    1793. 

  1793.         ZQOLD(JL,JK)=0.0
    1794. 

  1794.            ql(jl,jk)=0.0  ! parcel liquid water
    1795. 

  1795.           Tup(jl,jk)=0.0  ! parcel temperature
    1796. 

  1796.           Qup(jl,jk)=0.0  ! parcel specific humidity
    1797. 

  1797.            dh(jl,jk)=0.0  ! parcel dry static energy
    1798. 

  1798.            qh(jl,jk)=0.0  ! parcel total water specific humidity
    1799. 

  1799.            ww(jl,jk)=0.0  ! parcel vertical speed (m/s)
    1800. 

  1800.          dhen(jl,jk)=0.0  ! environment dry static energy
    1801. 

  1801.           Kup(jl,jk)=0.0  ! updraught kinetic energy for parcel
    1802. 

  1802.          Vtup(jl,jk)=0.0  ! parcel virtual temperature considering water-loading
    1803. 

  1803.          Vten(jl,jk)=0.0  ! environment virtual temperature
    1804. 

  1804.          buoy(jl,jk)=0.0  ! parcel buoyancy
    1805. 

  1805.       END DO
    1806. 

  1806.       END DO
    1807. 

  1807. 

  1808.       do jl=1,klon
    1809. 

  1809.          lclflag(jl) = 0  ! flag for the condensation level
    1810. 

  1810.          kctop(jl) = levels
    1811. 

  1811.          kcbot(jl) = levels
    1812. 

  1812.          myflag(jl)  = .true. ! just as input for cuadjqt subroutine
    1813. 

  1813.         topflag(jl)  = .false.! flag for whether the cloud top is found
    1814. 

  1814.       end do
    1815. 

  1815. 

  1816. ! check the levels from lowest level to second top level
    1817. 

  1817.       do JK=levels,2,-1
    1818. 

  1818.         DO JL=1,KLON
    1819. 

  1819.           ZPH(JL)=PAPH(JL,JK)
    1820. 

  1820.         END DO
    1821. 

  1821. 

  1822. ! define the variables at the first level      
    1823. 

  1823.       if(jk .eq. levels) then
    1824. 

  1824.       do jl=1,klon
    1825. 

  1825.         deltT(jl) = 0.2
    1826. 

  1826.         deltQ(jl) = 1.0e-4
    1827. 

  1827. 

  1828.         if(paph(jl,KLEVM1-1)-paph(jl,jk) .le. 6.e3) then
    1829. 

  1829.          ql(jl,jk+1) = 0.
    1830. 

  1830.         Tup(jl,jk+1) = 0.25*(ptenh(jl,jk+1)+ptenh(jl,jk)+ &
    1831. 

  1831.                              ptenh(jl,jk-1)+ptenh(jl,jk-2)) + &
    1832. 

  1832.                       deltT(jl)
    1833. 

  1833.         dh(jl,jk+1) = 0.25*(pgeoh(jl,jk+1)+pgeoh(jl,jk)+ &
    1834. 

  1834.                             pgeoh(jl,jk-1)+pgeoh(jl,jk-2)) + &
    1835. 

  1835.                       Tup(jl,jk+1)*cpd 
    1836. 

  1836.         qh(jl,jk+1) = 0.25*(pqenh(jl,jk+1)+pqenh(jl,jk)+ &
    1837. 

  1837.                             pqenh(jl,jk-1)+pqenh(jl,jk-2))+ &
    1838. 

  1838.                       deltQ(jl) + ql(jl,jk+1)
    1839. 

  1839.         Qup(jl,jk+1) = qh(jl,jk+1) - ql(jl,jk+1)
    1840. 

  1840.         else
    1841. 

  1841.          ql(jl,jk+1) = 0.
    1842. 

  1842.         Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl)
    1843. 

  1843.          dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd
    1844. 

  1844.          qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl)
    1845. 

  1845.         Qup(jl,jk+1) =    qh(jl,jk+1) - ql(jl,jk+1)
    1846. 

  1846.         end if
    1847. 

  1847.       ww(jl,jk+1) = 1.0
    1848. 

  1848. 

  1849.       end do
    1850. 

  1850.       end if
    1851. 

  1851. 

  1852. ! the next levels, we use the variables at the first level as initial values
    1853. 

  1853.       do jl=1,klon
    1854. 

  1854.       if(.not. topflag(jl)) then
    1855. 

  1855.         eta(jl) = 1.1e-4
    1856. 

  1856.         dz(jl)  = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
    1857. 

  1857.         coef(jl)= eta(jl)*dz(jl)
    1858. 

  1858.         dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk)
    1859. 

  1859.         dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl))
    1860. 

  1860.         qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl))
    1861. 

  1861.         Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD
    1862. 

  1862.         Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1)
    1863. 

  1863.         zqold(jl,jk) = Qup(jl,jk)
    1864. 

  1864.       end if
    1865. 

  1865.       end do
    1866. 

  1866. ! check if the parcel is saturated
    1867. 

  1867.       ik=jk
    1868. 

  1868.       icall=1
    1869. 

  1869.       call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall)
    1870. 

  1870.       do jl=1,klon
    1871. 

  1871.         if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then
    1872. 

  1872.           lclflag(jl) = lclflag(jl) + 1
    1873. 

  1873.           ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk)
    1874. 

  1874.           dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk)
    1875. 

  1875.         end if
    1876. 

  1876.       end do
    1877. 

  1877. 

  1878. ! compute the updraft speed
    1879. 

  1879.       do jl=1,klon
    1880. 

  1880.         if(.not. topflag(jl))then
    1881. 

  1881.           Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2
    1882. 

  1882.           Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk))
    1883. 

  1883.           Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk))
    1884. 

  1884.           buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g
    1885. 

  1885.           Kup(jl,jk)  = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ &
    1886. 

  1886.                         (1+2*2*eta(jl)*dz(jl))
    1887. 

  1887.           if(Kup(jl,jk) .gt. 0 ) then
    1888. 

  1888.              ww(jl,jk) = sqrt(2*Kup(jl,jk))
    1889. 

  1889.              if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk
    1890. 

  1890.              if(jk .eq. 2) then
    1891. 

  1891.                 kctop(jl) = jk
    1892. 

  1892.                 topflag(jl)= .true.
    1893. 

  1893.              end if
    1894. 

  1894.           else
    1895. 

  1895.              ww(jl,jk) = 0
    1896. 

  1896.              kctop(jl) = jk + 1
    1897. 

  1897.              topflag(jl) = .true.
    1898. 

  1898.           end if
    1899. 

  1899.          end if
    1900. 

  1900.       end do
    1901. 

  1901.       end do ! end all the levels
    1902. 

  1902. 

  1903.       do jl = 1, klon
    1904. 

  1904.        if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. ZDNOPRC .and. &
    1905. 

  1905.               lclflag(jl) .gt. 0 ) then
    1906. 

  1906.          ZRELH(JL) = 0.
    1907. 

  1907.          do jk=kcbot(jl),kctop(jl),-1
    1908. 

  1908.            ZRELH(JL)=ZRELH(JL)+ PQENH(JL,JK)/PQSENH(JL,JK)
    1909. 

  1909.          end do
    1910. 

  1910.          ZRELH(JL) = ZRELH(JL)/(kcbot(jl)-kctop(jl)+1)
    1911. 

  1911. 

  1912.          if(lndj(JL) .eq. 1) then
    1913. 

  1913.            CRIRH1 = CRIRH*0.8
    1914. 

  1914.          else
    1915. 

  1915.            CRIRH1 = CRIRH
    1916. 

  1916.          end if
    1917. 

  1917.          if(ZRELH(JL) .ge. CRIRH1) ktype(jl)  = 1
    1918. 

  1918.        end if
    1919. 

  1919.       end do
    1920. 

  1920. 

  1921.        end do ! end all cycles
    1922. 

  1922. 

  1923.       END SUBROUTINE CUTYPE
    1924. 

  1924. 

  1925. !
    1926. 

  1926. !**********************************************
    1927. 

  1927. !       SUBROUTINE CUASC_NEW
    1928. 

  1928. !********************************************** 
    1929. 

  1929.       SUBROUTINE CUASC_NEW &
    1930. 

  1930.          (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH,  &
    1931. 

  1931.           PQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
    1932. 

  1932.           PQSEN,    PGEO,     PGEOH,    PAP,      PAPH,   &
    1933. 

  1933.           PQTE,     PVERV,    KLWMIN,   LDCUM,    PHCBASE,& 
    1934. 

  1934.           KTYPE,    KLAB,     PTU,      PQU,      PLU,    &
    1935. 

  1935.           PUU,      PVU,      PMFU,     PMFUB,    PENTR,  &
    1936. 

  1936.           PMFUS,    PMFUQ,    PMFUL,    PLUDE,    PDMFUP, & 
    1937. 

  1937.           KCBOT,    KCTOP,    KCTOP0,   KCUM,     ZTMST,  &
    1938. 

  1938.           KHMIN,    PHHATT,   PQSENH)
    1939. 

  1939. !     THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
    1940. 

  1940. !     FOR CUMULUS PARAMETERIZATION
    1941. 

  1941. !     M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
    1942. 

  1942. !     Y.WANG            IPRC           11/01 MODIF.
    1943. 

  1943. !***PURPOSE.
    1944. 

  1944. !   --------
    1945. 

  1945. !          TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION
    1946. 

  1946. !          (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING
    1947. 

  1947. !           FLUXES AS WELL AS PRECIPITATION RATES)
    1948. 

  1948. !***INTERFACE
    1949. 

  1949. !   ---------
    1950. 

  1950. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    1951. 

  1951. !***METHOD.
    1952. 

  1952. !  --------
    1953. 

  1953. !          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
    1954. 

  1954. !          AND THEN CALCULATE MOIST ASCENT FOR
    1955. 

  1955. !          ENTRAINING/DETRAINING PLUME.
    1956. 

  1956. !          ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR
    1957. 

  1957. !          SHALLOW AND DEEP CUMULUS CONVECTION.
    1958. 

  1958. !          IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION
    1959. 

  1959. !          CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION
    1960. 

  1960. !          (CLOUD BASE VALUES CALCULATED IN *CUBASMC*)
    1961. 

  1961. !***EXTERNALS
    1962. 

  1962. !   ---------
    1963. 

  1963. !          *CUADJTQ* ADJUST T AND Q DUE TO CONDENSATION IN ASCENT
    1964. 

  1964. !          *CUENTR_NEW*  CALCULATE ENTRAINMENT/DETRAINMENT RATES
    1965. 

  1965. !          *CUBASMC* CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
    1966. 

  1966. !***REFERENCE
    1967. 

  1967. !   ---------
    1968. 

  1968. !          (TIEDTKE,1989)
    1969. 

  1969. !***INPUT VARIABLES:
    1970. 

  1970. !       PTENH [ZTENH] - Environ Temperature on half levels. (CUINI)
    1971. 

  1971. !       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
    1972. 

  1972. !       PUEN - Environment wind u-component. (MSSFLX)
    1973. 

  1973. !       PVEN - Environment wind v-component. (MSSFLX)
    1974. 

  1974. !       PTEN - Environment Temperature. (MSSFLX)
    1975. 

  1975. !       PQEN - Environment Specific Humidity. (MSSFLX)
    1976. 

  1976. !       PQSEN - Environment Saturation Specific Humidity. (MSSFLX)
    1977. 

  1977. !       PGEO - Geopotential. (MSSFLX)
    1978. 

  1978. !       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
    1979. 

  1979. !       PAP - Pressure in Pa.  (MSSFLX)
    1980. 

  1980. !       PAPH - Pressure of half levels. (MSSFLX)
    1981. 

  1981. !       PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX)
    1982. 

  1982. !       PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX)
    1983. 

  1983. !       KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI)
    1984. 

  1984. !       KLAB [ILAB] - Level Label - 1: Sub-cloud layer.
    1985. 

  1985. !                                   2: Condensation Level (Cloud Base)
    1986. 

  1986. !       PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR)
    1987. 

  1987. !***VARIABLES MODIFIED BY CUASC:
    1988. 

  1988. !       LDCUM - Logical denoting profiles. (CUBASE)
    1989. 

  1989. !       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
    1990. 

  1990. !                                 2: Stratocumulus (CUMASTR)
    1991. 

  1991. !                                 3: Mid-level  (CUASC)
    1992. 

  1992. !       PTU - Cloud Temperature.
    1993. 

  1993. !       PQU - Cloud specific Humidity.
    1994. 

  1994. !       PLU - Cloud Liquid Water (Moisture condensed out)
    1995. 

  1995. !       PUU [ZUU] - Cloud Momentum U-Component.
    1996. 

  1996. !       PVU [ZVU] - Cloud Momentum V-Component.
    1997. 

  1997. !       PMFU - Updraft Mass Flux.
    1998. 

  1998. !       PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC)
    1999. 

  1999. !       PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC)
    2000. 

  2000. !       PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity.
    2001. 

  2001. !       PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water.
    2002. 

  2002. !       PLUDE - Liquid Water Returned to Environment by Detrainment.
    2003. 

  2003. !       PDMFUP [ZMFUP] - FLUX DIFFERENCE OF PRECIP. IN UPDRAFTS
    2004. 

  2004. !       KCBOT - Cloud Base Level. (CUBASE)
    2005. 

  2005. !       KCTOP -
    2006. 

  2006. !       KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR)
    2007. 

  2007. !       KCUM [ICUM] -
    2008. 

  2008. !-------------------------------------------------------------------
    2009. 

  2009.       IMPLICIT NONE
    2010. 

  2010. !-------------------------------------------------------------------
    2011. 

  2011.       INTEGER   KLON, KLEV, KLEVP1
    2012. 

  2012.       INTEGER   klevm1,kcum
    2013. 

  2013.       REAL      ZTMST,ZCONS2,ZDZ,ZDRODZ
    2014. 

  2014.       INTEGER   JL,JK,IKB,IK,IS,IKT,ICALL
    2015. 

  2015.       REAL      ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX
    2016. 

  2016.       REAL      ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD
    2017. 

  2017.       REAL      ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK
    2018. 

  2018.       REAL      ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU
    2019. 

  2019.       REAL      ZBUOYZ,ZZDMF
    2020. 

  2020.       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV), &
    2021. 

  2021.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
    2022. 

  2022.               PTEN(KLON,KLEV),        PQEN(KLON,KLEV),   &
    2023. 

  2023.               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),  &
    2024. 

  2024.               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1), &
    2025. 

  2025.               PQSEN(KLON,KLEV),       PQTE(KLON,KLEV),   &
    2026. 

  2026.               PVERV(KLON,KLEV),       PQSENH(KLON,KLEV)  
    2027. 

  2027.       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
    2028. 

  2028.               PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
    2029. 

  2029.               PMFU(KLON,KLEV),        ZPH(KLON),         &
    2030. 

  2030.               PMFUB(KLON),            PENTR(KLON),       &
    2031. 

  2031.               PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
    2032. 

  2032.               PLU(KLON,KLEV),         PLUDE(KLON,KLEV),  &
    2033. 

  2033.               PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV)
    2034. 

  2034.       REAL     ZDMFEN(KLON),           ZDMFDE(KLON),     &
    2035. 

  2035.               ZMFUU(KLON),            ZMFUV(KLON),       &
    2036. 

  2036.               ZPBASE(KLON),           ZQOLD(KLON),       &
    2037. 

  2037.               PHHATT(KLON,KLEV),      ZODETR(KLON,KLEV), &
    2038. 

  2038.               ZOENTR(KLON,KLEV),      ZBUOY(KLON)
    2039. 

  2039.       REAL     PHCBASE(KLON)
    2040. 

  2040.       INTEGER  KLWMIN(KLON),           KTYPE(KLON),      &
    2041. 

  2041.               KLAB(KLON,KLEV),        KCBOT(KLON),       &
    2042. 

  2042.               KCTOP(KLON),            KCTOP0(KLON),      &
    2043. 

  2043.               KHMIN(KLON)
    2044. 

  2044.       LOGICAL LDCUM(KLON),            LOFLAG(KLON)
    2045. 

  2045.       integer leveltop,levelbot
    2046. 

  2046.       real    tt(klon),ttb(klon)
    2047. 

  2047.       real    zqsat(klon), zqsatb(klon)
    2048. 

  2048.       real    fscale(klon)
    2049. 

  2049. 

  2050. !--------------------------------
    2051. 

  2051. !*    1.       SPECIFY PARAMETERS
    2052. 

  2052. !--------------------------------
    2053. 

  2053.   100 CONTINUE
    2054. 

  2054.       ZCONS2=1./(G*ZTMST)
    2055. 

  2055. !---------------------------------
    2056. 

  2056. !     2.        SET DEFAULT VALUES
    2057. 

  2057. !---------------------------------
    2058. 

  2058.   200 CONTINUE
    2059. 

  2059.       DO 210 JL=1,KLON
    2060. 

  2060.         ZMFUU(JL)=0.
    2061. 

  2061.         ZMFUV(JL)=0.
    2062. 

  2062.         ZBUOY(JL)=0.
    2063. 

  2063.         IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
    2064. 

  2064.   210 CONTINUE
    2065. 

  2065.       DO 230 JK=1,KLEV
    2066. 

  2066.       DO 230 JL=1,KLON
    2067. 

  2067.           PLU(JL,JK)=0.
    2068. 

  2068.           PMFU(JL,JK)=0.
    2069. 

  2069.           PMFUS(JL,JK)=0.
    2070. 

  2070.           PMFUQ(JL,JK)=0.
    2071. 

  2071.           PMFUL(JL,JK)=0.
    2072. 

  2072.           PLUDE(JL,JK)=0.
    2073. 

  2073.           PDMFUP(JL,JK)=0.
    2074. 

  2074.           ZOENTR(JL,JK)=0.
    2075. 

  2075.           ZODETR(JL,JK)=0.
    2076. 

  2076.           IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0
    2077. 

  2077.           IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK
    2078. 

  2078.   230 CONTINUE
    2079. 

  2079. !------------------------------------------------
    2080. 

  2080. !     3.0      INITIALIZE VALUES AT LIFTING LEVEL
    2081. 

  2081. !------------------------------------------------
    2082. 

  2082.       DO 310 JL=1,KLON
    2083. 

  2083.         KCTOP(JL)=KLEVM1
    2084. 

  2084.         IF(.NOT.LDCUM(JL)) THEN
    2085. 

  2085.            KCBOT(JL)=KLEVM1
    2086. 

  2086.            PMFUB(JL)=0.
    2087. 

  2087.            PQU(JL,KLEV)=0.
    2088. 

  2088.         END IF
    2089. 

  2089.         PMFU(JL,KLEV)=PMFUB(JL)
    2090. 

  2090.         PMFUS(JL,KLEV)=PMFUB(JL)*(CPD*PTU(JL,KLEV)+PGEOH(JL,KLEV))
    2091. 

  2091.         PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV)
    2092. 

  2092.         IF(LMFDUDV) THEN
    2093. 

  2093.            ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV)
    2094. 

  2094.            ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV)
    2095. 

  2095.         END IF
    2096. 

  2096.   310 CONTINUE
    2097. 

  2097. !
    2098. 

  2098. !-- 3.1 Find organized entrainment at cloud base
    2099. 

  2099. !
    2100. 

  2100.       DO 322 JL=1,KLON
    2101. 

  2101.       LDCUM(JL)=.FALSE.
    2102. 

  2102.       IF (KTYPE(JL).EQ.1) THEN
    2103. 

  2103.        IKB = KCBOT(JL)
    2104. 

  2104.        if(orgen .eq. 1 ) then
    2105. 

  2105. ! old scheme
    2106. 

  2106.        ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ &
    2107. 

  2107.                0.608*(PQU(JL,IKB)-PQENH(JL,IKB)))
    2108. 

  2108.        IF (ZBUOY(JL).GT.0.) THEN
    2109. 

  2109.         ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG
    2110. 

  2110.         ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ -  &
    2111. 

  2111.                  G/(RD*PTENH(JL,IKB))
    2112. 

  2112.         ZOENTR(JL,IKB-1)=ZBUOY(JL)*0.5/(1.+ZBUOY(JL)*ZDZ) &
    2113. 

  2113.                 +ZDRODZ
    2114. 

  2114.         ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3)
    2115. 

  2115.         ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.)
    2116. 

  2116.        END IF
    2117. 

  2117. ! New scheme
    2118. 

  2118. ! Let's define the fscale
    2119. 

  2119.         else if(orgen .eq. 2 ) then
    2120. 

  2120.         tt(jl) = ptenh(jl,ikb)
    2121. 

  2121.         zqsat(jl) = TLUCUA(tt(jl))/paph(jl,ikb-1)
    2122. 

  2122.         zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl))
    2123. 

  2123.         ttb(jl) = ptenh(jl,ikb)
    2124. 

  2124.         zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,ikb)
    2125. 

  2125.         zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl))
    2126. 

  2126.         fscale(jl) = (zqsat(jl)/zqsatb(jl))**3
    2127. 

  2127. ! end of defining the fscale
    2128. 

  2128.         zoentr(jl,ikb-1) = 1.E-3*(1.3-PQEN(jl,ikb-1)/PQSEN(jl,ikb-1))*fscale(jl)
    2129. 

  2129.         zoentr(jl,ikb-1) = MIN(zoentr(jl,ikb-1),1.E-3)
    2130. 

  2130.         zoentr(jl,ikb-1) = MAX(zoentr(jl,ikb-1),0.)
    2131. 

  2131.        end if
    2132. 

  2132.       END IF
    2133. 

  2133.   322 CONTINUE 
    2134. 

  2134. !
    2135. 

  2135. !-----------------------------------------------------------------
    2136. 

  2136. !     4.       DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2)
    2137. 

  2137. !              BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
    2138. 

  2138. !              BY ADJUSTING T,Q AND L ACCORDINGLY IN *CUADJTQ*,
    2139. 

  2139. !              THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
    2140. 

  2140. !-----------------------------------------------------------------
    2141. 

  2141.   400 CONTINUE
    2142. 

  2142. 

  2143. ! let's define the levels in which the middle level convection could be activated
    2144. 

  2144.       do jk=KLEVM1,2,-1
    2145. 

  2145.       if(abs(paph(1,jk)*0.01 - 250) .lt. 50.) then
    2146. 

  2146.         leveltop = jk
    2147. 

  2147.         exit
    2148. 

  2148.       end if
    2149. 

  2149.       end do
    2150. 

  2150.       leveltop = min(KLEV-15,leveltop)
    2151. 

  2151.       levelbot = KLEVM1 - 4
    2152. 

  2152.         
    2153. 

  2153.       DO 480 JK=KLEVM1,2,-1
    2154. 

  2154. !                  SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
    2155. 

  2155. !                  IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION
    2156. 

  2156. ! ---------------------------------------------------------------------
    2157. 

  2157.       IK=JK
    2158. 

  2158.       IF(LMFMID.AND.IK.LT.levelbot.AND.IK.GT.leveltop) THEN
    2159. 

  2159.       CALL CUBASMC  &
    2160. 

  2160.          (KLON,     KLEV,     KLEVM1,   IK,      PTEN,  &
    2161. 

  2161.           PQEN,     PQSEN,    PUEN,     PVEN,    PVERV, &
    2162. 

  2162.           PGEO,     PGEOH,    LDCUM,    KTYPE,   KLAB,  &
    2163. 

  2163.           PMFU,     PMFUB,    PENTR,    KCBOT,   PTU,   &
    2164. 

  2164.           PQU,      PLU,      PUU,     PVU,      PMFUS, &
    2165. 

  2165.           PMFUQ,    PMFUL,    PDMFUP,  ZMFUU,    ZMFUV)
    2166. 

  2166.       ENDIF
    2167. 

  2167.       IS=0
    2168. 

  2168.       DO 410 JL=1,KLON
    2169. 

  2169.         ZQOLD(JL)=0.0
    2170. 

  2170.         IS=IS+KLAB(JL,JK+1)
    2171. 

  2171.         IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0
    2172. 

  2172.         LOFLAG(JL)=KLAB(JL,JK+1).GT.0
    2173. 

  2173.         ZPH(JL)=PAPH(JL,JK)
    2174. 

  2174.         IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN
    2175. 

  2175.            ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2
    2176. 

  2176.            IF(PMFUB(JL).GT.ZMFMAX) THEN
    2177. 

  2177.               ZFAC=ZMFMAX/PMFUB(JL)
    2178. 

  2178.               PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC
    2179. 

  2179.               PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC
    2180. 

  2180.               PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC
    2181. 

  2181.               ZMFUU(JL)=ZMFUU(JL)*ZFAC
    2182. 

  2182.               ZMFUV(JL)=ZMFUV(JL)*ZFAC
    2183. 

  2183.               PMFUB(JL)=ZMFMAX
    2184. 

  2184.            END IF
    2185. 

  2185.         END IF
    2186. 

  2186.   410 CONTINUE
    2187. 

  2187.       IF(IS.EQ.0) GO TO 480
    2188. 

  2188. !
    2189. 

  2189. !*     SPECIFY ENTRAINMENT RATES IN *CUENTR_NEW*
    2190. 

  2190. ! -------------------------------------
    2191. 

  2191.       IK=JK
    2192. 

  2192.       CALL CUENTR_NEW &
    2193. 

  2193.          (KLON,     KLEV,     KLEVP1,   IK,       PTENH,&
    2194. 

  2194.           PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM,&
    2195. 

  2195.           KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU, &
    2196. 

  2196.           PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
    2197. 

  2197. !
    2198. 

  2198. !      DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
    2199. 

  2199. ! -------------------------------------------------------
    2200. 

  2200. ! Do adiabatic ascent for entraining/detraining plume
    2201. 

  2201. ! the cloud ensemble entrains environmental values
    2202. 

  2202. ! in turbulent detrainment cloud ensemble values are detrained
    2203. 

  2203. ! in organized detrainment the dry static energy and
    2204. 

  2204. ! moisture that are neutral compared to the
    2205. 

  2205. ! environmental air are detrained
    2206. 

  2206. !
    2207. 

  2207.       DO 420 JL=1,KLON
    2208. 

  2208.       IF(LOFLAG(JL)) THEN
    2209. 

  2209.         IF(JK.LT.KCBOT(JL)) THEN
    2210. 

  2210.          ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
    2211. 

  2211.          ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2)
    2212. 

  2212.          ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.)
    2213. 

  2213.         END IF
    2214. 

  2214.         ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1))
    2215. 

  2215.         PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
    2216. 

  2216.         IF (JK.LT.kcbot(jl)) THEN
    2217. 

  2217.           zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
    2218. 

  2218.           zoentr(jl,jk) = zoentr(jl,jk)*zdprho*pmfu(jl,jk+1)
    2219. 

  2219.           zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk)
    2220. 

  2220.           zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2)
    2221. 

  2221.           zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.)
    2222. 

  2222.         END IF
    2223. 

  2223. !
    2224. 

  2224. ! limit organized detrainment to not allowing for too deep clouds
    2225. 

  2225. !
    2226. 

  2226.         IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN
    2227. 

  2227.           zmse = cpd*ptu(jl,jk+1) + alv*pqu(jl,jk+1) + pgeoh(jl,jk+1)
    2228. 

  2228.           ikt = kctop0(jl)
    2229. 

  2229.           znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl,  &
    2230. 

  2230.                jk+1))*zrg
    2231. 

  2231.           IF (znevn.LE.0.) znevn = 1.
    2232. 

  2232.           zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
    2233. 

  2233.           zodmax = ((phcbase(jl)-zmse)/znevn)*zdprho*pmfu(jl,jk+1)
    2234. 

  2234.           zodmax = MAX(zodmax,0.)
    2235. 

  2235.           zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax)
    2236. 

  2236.         END IF
    2237. 

  2237.         zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk))
    2238. 

  2238.         pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk)
    2239. 

  2239.         ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL)
    2240. 

  2240.         zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk)
    2241. 

  2241.         ZSEEN=(CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFEN(JL)
    2242. 

  2242.         zseen=zseen+(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*  &
    2243. 

  2243.              zoentr(jl,jk)
    2244. 

  2244.         ZSCDE=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFDE(JL)
    2245. 

  2245. ! find moist static energy that give nonbuoyant air
    2246. 

  2246.         zga = alv*pqsenh(jl,jk+1)/(rv*(ptenh(jl,jk+1)**2))
    2247. 

  2247.         zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, &
    2248. 

  2248.                jk+1)))/(1./ptenh(jl,jk+1)+0.608*zga)
    2249. 

  2249.         zscod = cpd*ptenh(jl,jk+1) + pgeoh(jl,jk+1) + cpd*zdt
    2250. 

  2250.         zscde = zscde + zodetr(jl,jk)*zscod
    2251. 

  2251.         zqude = pqu(jl,jk+1)*zdmfde(jl)
    2252. 

  2252.         zqcod = pqsenh(jl,jk+1) + zga*zdt
    2253. 

  2253.         zqude = zqude + zodetr(jl,jk)*zqcod
    2254. 

  2254.         plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
    2255. 

  2255.         plude(jl,jk) = plude(jl,jk)+plu(jl,jk+1)*zodetr(jl,jk)
    2256. 

  2256.         zmfusk = pmfus(jl,jk+1) + zseen - zscde
    2257. 

  2257.         zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude
    2258. 

  2258.         zmfulk = pmful(jl,jk+1) - plude(jl,jk)
    2259. 

  2259.         plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk)))
    2260. 

  2260.         pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk)))
    2261. 

  2261.         ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))-  &
    2262. 

  2262.             pgeoh(jl,jk))*rcpd
    2263. 

  2263.         ptu(jl,jk) = MAX(100.,ptu(jl,jk))
    2264. 

  2264.         ptu(jl,jk) = MIN(400.,ptu(jl,jk))
    2265. 

  2265.         zqold(jl) = pqu(jl,jk)
    2266. 

  2266.       END IF
    2267. 

  2267.   420 CONTINUE
    2268. 

  2268. !*             DO CORRECTIONS FOR MOIST ASCENT
    2269. 

  2269. !*             BY ADJUSTING T,Q AND L IN *CUADJTQ*
    2270. 

  2270. !------------------------------------------------
    2271. 

  2271.       IK=JK
    2272. 

  2272.       ICALL=1
    2273. 

  2273. !
    2274. 

  2274.       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
    2275. 

  2275. !
    2276. 

  2276.       DO 440 JL=1,KLON
    2277. 

  2277.       IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN
    2278. 

  2278.          KLAB(JL,JK)=2
    2279. 

  2279.          PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK)
    2280. 

  2280.          ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK)-PLU(JL,JK))-  &
    2281. 

  2281.         PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
    2282. 

  2282.          IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0
    2283. 

  2283.          IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. &
    2284. 

  2284.                             JK.GE.KCTOP0(JL)) THEN
    2285. 

  2285.             KCTOP(JL)=JK
    2286. 

  2286.             LDCUM(JL)=.TRUE.
    2287. 

  2287.             IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN
    2288. 

  2288.                ZPRCON=CPRCON
    2289. 

  2289.             ELSE
    2290. 

  2290.                ZPRCON=0.
    2291. 

  2291.             ENDIF
    2292. 

  2292.             ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1)))
    2293. 

  2293.             PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK))
    2294. 

  2294.             PLU(JL,JK)=ZLNEW
    2295. 

  2295.          ELSE
    2296. 

  2296.             KLAB(JL,JK)=0
    2297. 

  2297.             PMFU(JL,JK)=0.
    2298. 

  2298.          END IF
    2299. 

  2299.       END IF
    2300. 

  2300.       IF(LOFLAG(JL)) THEN
    2301. 

  2301.          PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
    2302. 

  2302.          PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
    2303. 

  2303.          PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
    2304. 

  2304.       END IF
    2305. 

  2305.   440 CONTINUE
    2306. 

  2306. !
    2307. 

  2307.       IF(LMFDUDV) THEN
    2308. 

  2308. !
    2309. 

  2309.         DO 460 JL=1,KLON
    2310. 

  2310.         zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk)
    2311. 

  2311.         zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk)
    2312. 

  2312.            IF(LOFLAG(JL)) THEN
    2313. 

  2313.               IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN
    2314. 

  2314.                  IF(ZDMFEN(JL).LE.1.E-20) THEN
    2315. 

  2315.                     ZZ=3.
    2316. 

  2316.                  ELSE
    2317. 

  2317.                     ZZ=2.
    2318. 

  2318.                  ENDIF
    2319. 

  2319.               ELSE
    2320. 

  2320.                  IF(ZDMFEN(JL).LE.1.0E-20) THEN
    2321. 

  2321.                     ZZ=1.
    2322. 

  2322.                  ELSE
    2323. 

  2323.                     ZZ=0.
    2324. 

  2324.                  ENDIF
    2325. 

  2325.               END IF
    2326. 

  2326.               ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL)
    2327. 

  2327.               ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL)
    2328. 

  2328.               ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1))
    2329. 

  2329.               ZMFUU(JL)=ZMFUU(JL)+                              &
    2330. 

  2330.                        ZDMFEU*PUEN(JL,JK)-ZDMFDU*PUU(JL,JK+1)   
    2331. 

  2331.               ZMFUV(JL)=ZMFUV(JL)+                              &
    2332. 

  2332.                        ZDMFEU*PVEN(JL,JK)-ZDMFDU*PVU(JL,JK+1)   
    2333. 

  2333.               IF(PMFU(JL,JK).GT.0.) THEN
    2334. 

  2334.                  PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK))
    2335. 

  2335.                  PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK))
    2336. 

  2336.               END IF
    2337. 

  2337.            END IF
    2338. 

  2338.   460   CONTINUE
    2339. 

  2339. !
    2340. 

  2340.         END IF
    2341. 

  2341. !
    2342. 

  2342. ! Compute organized entrainment
    2343. 

  2343. ! for use at next level
    2344. 

  2344. !
    2345. 

  2345.       DO 470 jl = 1, klon
    2346. 

  2346.        IF (loflag(jl).AND.ktype(jl).EQ.1) THEN
    2347. 

  2347. ! old scheme
    2348. 

  2348.        if(orgen .eq. 1 ) then
    2349. 

  2349.         zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+  &
    2350. 

  2350.               0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk))
    2351. 

  2351.         zbuoyz = MAX(zbuoyz,0.0)
    2352. 

  2352.         zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg
    2353. 

  2353.         zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz -  &
    2354. 

  2354.                  g/(rd*ptenh(jl,jk))
    2355. 

  2355.         zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz
    2356. 

  2356.         zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz
    2357. 

  2357.         zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
    2358. 

  2358.         zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
    2359. 

  2359.        else if(orgen .eq. 2 ) then
    2360. 

  2360. ! Let's define the fscale
    2361. 

  2361.         tt(jl) = ptenh(jl,jk-1)
    2362. 

  2362.         zqsat(jl) = TLUCUA(tt(jl))/paph(jl,jk-1)
    2363. 

  2363.         zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl))
    2364. 

  2364.         ttb(jl) = ptenh(jl,kcbot(jl))
    2365. 

  2365.         zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,kcbot(jl))
    2366. 

  2366.         zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl))
    2367. 

  2367.         fscale(jl) = (zqsat(jl)/zqsatb(jl))**3
    2368. 

  2368. ! end of defining the fscale
    2369. 

  2369.         zoentr(jl,jk-1) = 1.E-3*(1.3-PQEN(jl,jk-1)/PQSEN(jl,jk-1))*fscale(jl)
    2370. 

  2370.         zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
    2371. 

  2371.         zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
    2372. 

  2372. !        write(6,*) "zoentr=",zoentr(jl,jk-1) 
    2373. 

  2373.        end if
    2374. 

  2374.        END IF
    2375. 

  2375.   470 CONTINUE 
    2376. 

  2376. !
    2377. 

  2377.   480 CONTINUE
    2378. 

  2378. ! -----------------------------------------------------------------
    2379. 

  2379. !     5.       DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
    2380. 

  2380. ! -----------------------------------------------------------------
    2381. 

  2381. !                  (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
    2382. 

  2382. !                         AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
    2383. 

  2383. !                         FROM PREVIOUS CALCULATIONS ABOVE)
    2384. 

  2384.   500 CONTINUE
    2385. 

  2385.       DO 510 JL=1,KLON
    2386. 

  2386.       IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE.
    2387. 

  2387.       KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL))
    2388. 

  2388.   510 CONTINUE
    2389. 

  2389.       IS=0
    2390. 

  2390.       DO 520 JL=1,KLON
    2391. 

  2391.       IF(LDCUM(JL)) THEN
    2392. 

  2392.          IS=IS+1
    2393. 

  2393.       ENDIF
    2394. 

  2394.   520 CONTINUE
    2395. 

  2395.       KCUM=IS
    2396. 

  2396.       IF(IS.EQ.0) GO TO 800
    2397. 

  2397.       DO 530 JL=1,KLON
    2398. 

  2398.       IF(LDCUM(JL)) THEN
    2399. 

  2399.          JK=KCTOP(JL)-1
    2400. 

  2400.          ZZDMF=CMFCTOP
    2401. 

  2401.          ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1)
    2402. 

  2402.          PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1)
    2403. 

  2403.          PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL)
    2404. 

  2404.          PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
    2405. 

  2405.          PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
    2406. 

  2406.          PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
    2407. 

  2407.          PLUDE(JL,JK-1)=PMFUL(JL,JK)
    2408. 

  2408.          PDMFUP(JL,JK)=0.
    2409. 

  2409.       END IF
    2410. 

  2410.   530 CONTINUE
    2411. 

  2411.         IF(LMFDUDV) THEN
    2412. 

  2412.            DO 540 JL=1,KLON
    2413. 

  2413.            IF(LDCUM(JL)) THEN
    2414. 

  2414.               JK=KCTOP(JL)-1
    2415. 

  2415.               PUU(JL,JK)=PUU(JL,JK+1)
    2416. 

  2416.               PVU(JL,JK)=PVU(JL,JK+1)
    2417. 

  2417.            END IF
    2418. 

  2418.   540      CONTINUE
    2419. 

  2419.         END IF
    2420. 

  2420.   800 CONTINUE
    2421. 

  2421.       RETURN
    2422. 

  2422.       END SUBROUTINE CUASC_NEW
    2423. 

  2423. !
    2424. 

  2424. 

  2425. !**********************************************
    2426. 

  2426. !       SUBROUTINE CUDLFS
    2427. 

  2427. !********************************************** 
    2428. 

  2428.       SUBROUTINE CUDLFS &
    2429. 

  2429.          (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH,  &
    2430. 

  2430.           PUEN,     PVEN,     PGEOH,    PAPH,     PTU,    &
    2431. 

  2431.           PQU,      PUU,      PVU,      LDCUM,    KCBOT,  &
    2432. 

  2432.           KCTOP,    PMFUB,    PRFL,     PTD,      PQD,    &
    2433. 

  2433.           PUD,      PVD,      PMFD,     PMFDS,    PMFDQ,  &
    2434. 

  2434.           PDMFDP,   KDTOP,    LDDRAF)
    2435. 

  2435. !      THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
    2436. 

  2436. !      CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
    2437. 

  2437. !      M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
    2438. 

  2438. !***PURPOSE.
    2439. 

  2439. !   --------
    2440. 

  2440. !          TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
    2441. 

  2441. !          FOR MASSFLUX CUMULUS PARAMETERIZATION
    2442. 

  2442. !***INTERFACE
    2443. 

  2443. !   ---------
    2444. 

  2444. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    2445. 

  2445. !          INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
    2446. 

  2446. !          AND UPDRAFT VALUES T,Q,U AND V AND ALSO
    2447. 

  2447. !          CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
    2448. 

  2448. !          IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
    2449. 

  2449. !***METHOD.
    2450. 

  2450. !  --------
    2451. 

  2451. !          CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
    2452. 

  2452. !          MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
    2453. 

  2453. !***EXTERNALS
    2454. 

  2454. !   ---------
    2455. 

  2455. !          *CUADJTQ* FOR CALCULATING WET BULB T AND Q AT LFS
    2456. 

  2456. ! ----------------------------------------------------------------
    2457. 

  2457. !-------------------------------------------------------------------
    2458. 

  2458.       IMPLICIT NONE
    2459. 

  2459. !-------------------------------------------------------------------
    2460. 

  2460.       INTEGER   KLON, KLEV, KLEVP1
    2461. 

  2461.       INTEGER   JL,KE,JK,IS,IK,ICALL
    2462. 

  2462.       REAL      ZTTEST, ZQTEST, ZBUO, ZMFTOP
    2463. 

  2463.       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
    2464. 

  2464.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
    2465. 

  2465.               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1),   &
    2466. 

  2466.               PTU(KLON,KLEV),         PQU(KLON,KLEV),      &
    2467. 

  2467.               PUU(KLON,KLEV),         PVU(KLON,KLEV),      &
    2468. 

  2468.               PMFUB(KLON),            PRFL(KLON)
    2469. 

  2469.       REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),     &
    2470. 

  2470.               PUD(KLON,KLEV),         PVD(KLON,KLEV),      &
    2471. 

  2471.               PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),    &
    2472. 

  2472.               PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV)    
    2473. 

  2473.       REAL     ZTENWB(KLON,KLEV),      ZQENWB(KLON,KLEV),  &
    2474. 

  2474.               ZCOND(KLON),            ZPH(KLON)
    2475. 

  2475.       INTEGER  KCBOT(KLON),            KCTOP(KLON),        &
    2476. 

  2476.               KDTOP(KLON)
    2477. 

  2477.       LOGICAL  LDCUM(KLON),            LLo2(KLON),         &
    2478. 

  2478.               LDDRAF(KLON)
    2479. 

  2479. !-----------------------------------------------
    2480. 

  2480. !     1.       SET DEFAULT VALUES FOR DOWNDRAFTS
    2481. 

  2481. !-----------------------------------------------
    2482. 

  2482.   100 CONTINUE
    2483. 

  2483.       DO 110 JL=1,KLON
    2484. 

  2484.       LDDRAF(JL)=.FALSE.
    2485. 

  2485.       KDTOP(JL)=KLEVP1
    2486. 

  2486.   110 CONTINUE
    2487. 

  2487.       IF(.NOT.LMFDD) GO TO 300
    2488. 

  2488. !------------------------------------------------------------
    2489. 

  2489. !     2.       DETERMINE LEVEL OF FREE SINKING BY
    2490. 

  2490. !              DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
    2491. 

  2491. !              FOR EVERY POINT AND PROCEED AS FOLLOWS:
    2492. 

  2492. !                (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
    2493. 

  2493. !                (2) DO MIXING WITH CUMULUS CLOUD AIR
    2494. 

  2494. !                (3) CHECK FOR NEGATIVE BUOYANCY
    2495. 

  2495. !              THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
    2496. 

  2496. !              OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
    2497. 

  2497. !              TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
    2498. 

  2498. !              EVAPORATION OF RAIN AND CLOUD WATER)
    2499. 

  2499. !------------------------------------------------------------------
    2500. 

  2500.   200 CONTINUE
    2501. 

  2501.       KE=KLEV-3
    2502. 

  2502.       DO 290 JK=3,KE
    2503. 

  2503. !   2.1      CALCULATE WET-BULB TEMPERATURE AND MOISTURE
    2504. 

  2504. !            FOR ENVIRONMENTAL AIR IN *CUADJTQ*
    2505. 

  2505. ! -----------------------------------------------------
    2506. 

  2506.   210 CONTINUE
    2507. 

  2507.       IS=0
    2508. 

  2508.       DO 212 JL=1,KLON
    2509. 

  2509.       ZTENWB(JL,JK)=PTENH(JL,JK)
    2510. 

  2510.       ZQENWB(JL,JK)=PQENH(JL,JK)
    2511. 

  2511.       ZPH(JL)=PAPH(JL,JK)
    2512. 

  2512.       LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. &
    2513. 

  2513.               (JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL))
    2514. 

  2514.       IF(LLO2(JL))THEN
    2515. 

  2515.          IS=IS+1
    2516. 

  2516.       ENDIF
    2517. 

  2517.   212 CONTINUE
    2518. 

  2518.       IF(IS.EQ.0) GO TO 290
    2519. 

  2519.       IK=JK
    2520. 

  2520.       ICALL=2
    2521. 

  2521.       CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL)
    2522. 

  2522. !   2.2      DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
    2523. 

  2523. !            AND CHECK FOR NEGATIVE BUOYANCY.
    2524. 

  2524. !            THEN SET VALUES FOR DOWNDRAFT AT LFS.
    2525. 

  2525. ! -----------------------------------------------------
    2526. 

  2526.   220 CONTINUE
    2527. 

  2527.       DO 222 JL=1,KLON
    2528. 

  2528.       IF(LLO2(JL)) THEN
    2529. 

  2529.          ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK))
    2530. 

  2530.          ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK))
    2531. 

  2531.          ZBUO=ZTTEST*(1.+VTMPC1*ZQTEST)-  &
    2532. 

  2532.              PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
    2533. 

  2533.          ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK)
    2534. 

  2534.          ZMFTOP=-CMFDEPS*PMFUB(JL)
    2535. 

  2535.          IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.*ZMFTOP*ZCOND(JL)) THEN
    2536. 

  2536.             KDTOP(JL)=JK
    2537. 

  2537.             LDDRAF(JL)=.TRUE.
    2538. 

  2538.             PTD(JL,JK)=ZTTEST
    2539. 

  2539.             PQD(JL,JK)=ZQTEST
    2540. 

  2540.             PMFD(JL,JK)=ZMFTOP
    2541. 

  2541.             PMFDS(JL,JK)=PMFD(JL,JK)*(CPD*PTD(JL,JK)+PGEOH(JL,JK))
    2542. 

  2542.             PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK)
    2543. 

  2543.             PDMFDP(JL,JK-1)=-0.5*PMFD(JL,JK)*ZCOND(JL)
    2544. 

  2544.             PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1)
    2545. 

  2545.          END IF
    2546. 

  2546.       END IF
    2547. 

  2547.   222 CONTINUE
    2548. 

  2548.          IF(LMFDUDV) THEN
    2549. 

  2549.             DO 224 JL=1,KLON
    2550. 

  2550.             IF(PMFD(JL,JK).LT.0.) THEN
    2551. 

  2551.                PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1))
    2552. 

  2552.                PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1))
    2553. 

  2553.             END IF
    2554. 

  2554.   224       CONTINUE
    2555. 

  2555.          END IF
    2556. 

  2556.   290 CONTINUE
    2557. 

  2557.  300  CONTINUE
    2558. 

  2558.       RETURN
    2559. 

  2559.       END SUBROUTINE CUDLFS
    2560. 

  2560. !
    2561. 

  2561. 

  2562. !**********************************************
    2563. 

  2563. !       SUBROUTINE CUDDRAF
    2564. 

  2564. !********************************************** 
    2565. 

  2565.       SUBROUTINE CUDDRAF &
    2566. 

  2566.          (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH, &
    2567. 

  2567.           PUEN,     PVEN,     PGEOH,    PAPH,     PRFL,  &
    2568. 

  2568.           LDDRAF,   PTD,      PQD,      PUD,      PVD,   &
    2569. 

  2569.           PMFD,     PMFDS,    PMFDQ,    PDMFDP)
    2570. 

  2570. !     THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
    2571. 

  2571. !     M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
    2572. 

  2572. !***PURPOSE.
    2573. 

  2573. !   --------
    2574. 

  2574. !          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
    2575. 

  2575. !          (I.E. T,Q,U AND V AND FLUXES)
    2576. 

  2576. !***INTERFACE
    2577. 

  2577. !   ---------
    2578. 

  2578. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    2579. 

  2579. !          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
    2580. 

  2580. !          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
    2581. 

  2581. !          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
    2582. 

  2582. !***METHOD.
    2583. 

  2583. !  --------
    2584. 

  2584. !          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
    2585. 

  2585. !          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
    2586. 

  2586. !          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
    2587. 

  2587. !***EXTERNALS
    2588. 

  2588. !   ---------
    2589. 

  2589. !          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO EVAPORATION IN
    2590. 

  2590. !          SATURATED DESCENT
    2591. 

  2591. !***REFERENCE
    2592. 

  2592. !   ---------
    2593. 

  2593. !          (TIEDTKE,1989)
    2594. 

  2594. ! ----------------------------------------------------------------
    2595. 

  2595. !-------------------------------------------------------------------
    2596. 

  2596.       IMPLICIT NONE
    2597. 

  2597. !-------------------------------------------------------------------
    2598. 

  2598.       INTEGER   KLON, KLEV, KLEVP1
    2599. 

  2599.       INTEGER   JK,IS,JL,ITOPDE, IK, ICALL
    2600. 

  2600.       REAL      ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK
    2601. 

  2601.       REAL      ZBUO, ZDMFDP, ZMFDUK, ZMFDVK
    2602. 

  2602.       REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
    2603. 

  2603.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),    &
    2604. 

  2604.               PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1) 
    2605. 

  2605.       REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),    &
    2606. 

  2606.               PUD(KLON,KLEV),         PVD(KLON,KLEV),     &
    2607. 

  2607.               PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),   &
    2608. 

  2608.               PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV),  &
    2609. 

  2609.               PRFL(KLON)
    2610. 

  2610.       REAL     ZDMFEN(KLON),           ZDMFDE(KLON),      &
    2611. 

  2611.               ZCOND(KLON),            ZPH(KLON)       
    2612. 

  2612.       LOGICAL  LDDRAF(KLON),           LLO2(KLON)
    2613. 

  2613. !--------------------------------------------------------------
    2614. 

  2614. !     1.       CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
    2615. 

  2615. !                (A) CALCULATING ENTRAINMENT RATES, ASSUMING
    2616. 

  2616. !                     LINEAR DECREASE OF MASSFLUX IN PBL
    2617. 

  2617. !                 (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
    2618. 

  2618. !                     AND MOISTENING IS CALCULATED IN *CUADJTQ*
    2619. 

  2619. !                 (C) CHECKING FOR NEGATIVE BUOYANCY AND
    2620. 

  2620. !                     SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
    2621. 

  2621. ! ----------------------------------------------------------------
    2622. 

  2622.   100 CONTINUE
    2623. 

  2623.       DO 180 JK=3,KLEV
    2624. 

  2624.       IS=0
    2625. 

  2625.       DO 110 JL=1,KLON
    2626. 

  2626.       ZPH(JL)=PAPH(JL,JK)
    2627. 

  2627.       LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0.
    2628. 

  2628.       IF(LLO2(JL)) THEN
    2629. 

  2629.          IS=IS+1
    2630. 

  2630.       ENDIF
    2631. 

  2631.   110 CONTINUE
    2632. 

  2632.       IF(IS.EQ.0) GO TO 180
    2633. 

  2633.       DO 122 JL=1,KLON
    2634. 

  2634.       IF(LLO2(JL)) THEN
    2635. 

  2635.          ZENTR=ENTRDD*PMFD(JL,JK-1)*RD*PTENH(JL,JK-1)/   &
    2636. 

  2636.               (G*PAPH(JL,JK-1))*(PAPH(JL,JK)-PAPH(JL,JK-1))
    2637. 

  2637.          ZDMFEN(JL)=ZENTR
    2638. 

  2638.          ZDMFDE(JL)=ZENTR
    2639. 

  2639.       END IF
    2640. 

  2640.   122 CONTINUE
    2641. 

  2641.       ITOPDE=KLEV-2
    2642. 

  2642.          IF(JK.GT.ITOPDE) THEN
    2643. 

  2643.             DO 124 JL=1,KLON
    2644. 

  2644.             IF(LLO2(JL)) THEN
    2645. 

  2645.                ZDMFEN(JL)=0.
    2646. 

  2646.                ZDMFDE(JL)=PMFD(JL,ITOPDE)*      &
    2647. 

  2647.               (PAPH(JL,JK)-PAPH(JL,JK-1))/     &
    2648. 

  2648.               (PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE))
    2649. 

  2649.             END IF
    2650. 

  2650.   124       CONTINUE
    2651. 

  2651.          END IF
    2652. 

  2652.       DO 126 JL=1,KLON
    2653. 

  2653.          IF(LLO2(JL)) THEN
    2654. 

  2654.             PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL)
    2655. 

  2655.             ZSEEN=(CPD*PTENH(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFEN(JL)
    2656. 

  2656.             ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL)
    2657. 

  2657.             ZSDDE=(CPD*PTD(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFDE(JL)
    2658. 

  2658.             ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL)
    2659. 

  2659.             ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE
    2660. 

  2660.             ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE
    2661. 

  2661.             PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
    2662. 

  2662.             PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- &
    2663. 

  2663.                        PGEOH(JL,JK))*RCPD
    2664. 

  2664.             PTD(JL,JK)=MIN(400.,PTD(JL,JK))
    2665. 

  2665.             PTD(JL,JK)=MAX(100.,PTD(JL,JK))
    2666. 

  2666.             ZCOND(JL)=PQD(JL,JK)
    2667. 

  2667.          END IF
    2668. 

  2668.   126 CONTINUE
    2669. 

  2669.       IK=JK
    2670. 

  2670.       ICALL=2
    2671. 

  2671.       CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL)
    2672. 

  2672.       DO 150 JL=1,KLON
    2673. 

  2673.          IF(LLO2(JL)) THEN
    2674. 

  2674.             ZCOND(JL)=ZCOND(JL)-PQD(JL,JK)
    2675. 

  2675.             ZBUO=PTD(JL,JK)*(1.+VTMPC1*PQD(JL,JK))- &
    2676. 

  2676.            PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
    2677. 

  2677.             IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN
    2678. 

  2678.                PMFD(JL,JK)=0.
    2679. 

  2679.             ENDIF
    2680. 

  2680.             PMFDS(JL,JK)=(CPD*PTD(JL,JK)+PGEOH(JL,JK))*PMFD(JL,JK)
    2681. 

  2681.             PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK)
    2682. 

  2682.             ZDMFDP=-PMFD(JL,JK)*ZCOND(JL)
    2683. 

  2683.             PDMFDP(JL,JK-1)=ZDMFDP
    2684. 

  2684.             PRFL(JL)=PRFL(JL)+ZDMFDP
    2685. 

  2685.          END IF
    2686. 

  2686.   150 CONTINUE
    2687. 

  2687.         IF(LMFDUDV) THEN
    2688. 

  2688.           DO 160 JL=1,KLON
    2689. 

  2689.              IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN
    2690. 

  2690.                 ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+   &
    2691. 

  2691.                ZDMFEN(JL)*PUEN(JL,JK-1)-ZDMFDE(JL)*PUD(JL,JK-1)
    2692. 

  2692.                 ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+   &
    2693. 

  2693.                ZDMFEN(JL)*PVEN(JL,JK-1)-ZDMFDE(JL)*PVD(JL,JK-1)
    2694. 

  2694.                 PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
    2695. 

  2695.                 PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
    2696. 

  2696.              END IF
    2697. 

  2697.   160     CONTINUE
    2698. 

  2698.         END IF
    2699. 

  2699.   180 CONTINUE
    2700. 

  2700.       RETURN
    2701. 

  2701.       END SUBROUTINE CUDDRAF
    2702. 

  2702. !
    2703. 

  2703. 

  2704. !**********************************************
    2705. 

  2705. !       SUBROUTINE CUFLX
    2706. 

  2706. !********************************************** 
    2707. 

  2707.       SUBROUTINE CUFLX &
    2708. 

  2708.          (KLON,     KLEV,     KLEVP1,   PQEN,    PQSEN,     &
    2709. 

  2709.           PTENH,    PQENH,    PAPH,     PGEOH,   KCBOT,    &
    2710. 

  2710.           KCTOP,    KDTOP,    KTYPE,    LDDRAF,  LDCUM,  &
    2711. 

  2711.           PMFU,     PMFD,     PMFUS,    PMFDS,   PMFUQ,  &
    2712. 

  2712.           PMFDQ,    PMFUL,    PLUDE,    PDMFUP,  PDMFDP, &
    2713. 

  2713.           PRFL,     PRAIN,    PTEN,     PSFL,    PDPMEL, &
    2714. 

  2714.           KTOPM2,   ZTMST,    sig1)
    2715. 

  2715. !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
    2716. 

  2716. !***PURPOSE
    2717. 

  2717. !   -------
    2718. 

  2718. !          THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
    2719. 

  2719. !          FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
    2720. 

  2720. !***INTERFACE
    2721. 

  2721. !   ---------
    2722. 

  2722. !          THIS ROUTINE IS CALLED FROM *CUMASTR*.
    2723. 

  2723. !***EXTERNALS
    2724. 

  2724. !   ---------
    2725. 

  2725. !          NONE
    2726. 

  2726. ! ----------------------------------------------------------------
    2727. 

  2727. !-------------------------------------------------------------------
    2728. 

  2728.       IMPLICIT NONE
    2729. 

  2729. !-------------------------------------------------------------------
    2730. 

  2730.       INTEGER   KLON, KLEV, KLEVP1
    2731. 

  2731.       INTEGER   KTOPM2, ITOP, JL, JK, IKB
    2732. 

  2732.       REAL      ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2
    2733. 

  2733.       REAL      ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW
    2734. 

  2734.       REAL      ZRMIN, ZRFLN, ZDRFL, ZDPEVAP
    2735. 

  2735.       REAL     PQEN(KLON,KLEV),        PQSEN(KLON,KLEV),  &
    2736. 

  2736.               PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
    2737. 

  2737.               PAPH(KLON,KLEVP1),      PGEOH(KLON,KLEV)    
    2738. 

  2738.       REAL     PMFU(KLON,KLEV),        PMFD(KLON,KLEV),   &
    2739. 

  2739.               PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),   &
    2740. 

  2740.               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),   &
    2741. 

  2741.               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),  &
    2742. 

  2742.               PMFUL(KLON,KLEV),       PLUDE(KLON,KLEV),   &
    2743. 

  2743.               PRFL(KLON),             PRAIN(KLON)
    2744. 

  2744.       REAL     PTEN(KLON,KLEV),        PDPMEL(KLON,KLEV), &
    2745. 

  2745.               PSFL(KLON),             ZPSUBCL(KLON)
    2746. 

  2746.       REAL     sig1(KLEV)
    2747. 

  2747.       INTEGER  KCBOT(KLON),            KCTOP(KLON),     &
    2748. 

  2748.               KDTOP(KLON),            KTYPE(KLON)
    2749. 

  2749.       LOGICAL  LDDRAF(KLON),           LDCUM(KLON)
    2750. 

  2750. !*       SPECIFY CONSTANTS
    2751. 

  2751.       ZCONS1=CPD/(ALF*G*ZTMST)
    2752. 

  2752.       ZCONS2=1./(G*ZTMST)
    2753. 

  2753.       ZCUCOV=0.05
    2754. 

  2754.       ZTMELP2=TMELT+2.
    2755. 

  2755. !*  1.0      DETERMINE FINAL CONVECTIVE FLUXES
    2756. 

  2756. !---------------------------------------------
    2757. 

  2757.   100 CONTINUE
    2758. 

  2758.       ITOP=KLEV
    2759. 

  2759.       DO 110 JL=1,KLON
    2760. 

  2760.       PRFL(JL)=0.
    2761. 

  2761.       PSFL(JL)=0.
    2762. 

  2762.       PRAIN(JL)=0.
    2763. 

  2763. !     SWITCH OFF SHALLOW CONVECTION
    2764. 

  2764.       IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN
    2765. 

  2765.         LDCUM(JL)=.FALSE.
    2766. 

  2766.         LDDRAF(JL)=.FALSE.
    2767. 

  2767.       ENDIF
    2768. 

  2768.       ITOP=MIN(ITOP,KCTOP(JL))
    2769. 

  2769.       IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE.
    2770. 

  2770.       IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
    2771. 

  2771.   110 CONTINUE
    2772. 

  2772.       KTOPM2=ITOP-2
    2773. 

  2773.       DO 120 JK=KTOPM2,KLEV
    2774. 

  2774.       DO 115 JL=1,KLON
    2775. 

  2775.       IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN
    2776. 

  2776.          PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)*  &
    2777. 

  2777.                      (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
    2778. 

  2778.          PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK)
    2779. 

  2779.          IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN
    2780. 

  2780.             PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)*  &
    2781. 

  2781.                         (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
    2782. 

  2782.             PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK)
    2783. 

  2783.          ELSE
    2784. 

  2784.             PMFD(JL,JK)=0.
    2785. 

  2785.             PMFDS(JL,JK)=0.
    2786. 

  2786.             PMFDQ(JL,JK)=0.
    2787. 

  2787.             PDMFDP(JL,JK-1)=0.
    2788. 

  2788.          END IF
    2789. 

  2789.       ELSE
    2790. 

  2790.          PMFU(JL,JK)=0.
    2791. 

  2791.          PMFD(JL,JK)=0.
    2792. 

  2792.          PMFUS(JL,JK)=0.
    2793. 

  2793.          PMFDS(JL,JK)=0.
    2794. 

  2794.          PMFUQ(JL,JK)=0.
    2795. 

  2795.          PMFDQ(JL,JK)=0.
    2796. 

  2796.          PMFUL(JL,JK)=0.
    2797. 

  2797.          PDMFUP(JL,JK-1)=0.
    2798. 

  2798.          PDMFDP(JL,JK-1)=0.
    2799. 

  2799.          PLUDE(JL,JK-1)=0.
    2800. 

  2800.       END IF
    2801. 

  2801.   115 CONTINUE
    2802. 

  2802.   120 CONTINUE
    2803. 

  2803.       DO 130 JK=KTOPM2,KLEV
    2804. 

  2804.       DO 125 JL=1,KLON
    2805. 

  2805.       IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
    2806. 

  2806.          IKB=KCBOT(JL)
    2807. 

  2807.          ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
    2808. 

  2808.              (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
    2809. 

  2809.          IF(KTYPE(JL).EQ.3) THEN
    2810. 

  2810.             ZZP=ZZP**2
    2811. 

  2811.          ENDIF
    2812. 

  2812.          PMFU(JL,JK)=PMFU(JL,IKB)*ZZP
    2813. 

  2813.          PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP
    2814. 

  2814.          PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP
    2815. 

  2815.          PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP
    2816. 

  2816.       END IF
    2817. 

  2817. !*    2.        CALCULATE RAIN/SNOW FALL RATES
    2818. 

  2818. !*              CALCULATE MELTING OF SNOW
    2819. 

  2819. !*              CALCULATE EVAPORATION OF PRECIP
    2820. 

  2820. !----------------------------------------------
    2821. 

  2821.       IF(LDCUM(JL)) THEN
    2822. 

  2822.          PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK)
    2823. 

  2823.          IF(PTEN(JL,JK).GT.TMELT) THEN
    2824. 

  2824.             PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
    2825. 

  2825.             IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN
    2826. 

  2826.                ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK))
    2827. 

  2827.                ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2))
    2828. 

  2828.                PDPMEL(JL,JK)=ZSNMLT
    2829. 

  2829.                PSFL(JL)=PSFL(JL)-ZSNMLT
    2830. 

  2830.                PRFL(JL)=PRFL(JL)+ZSNMLT
    2831. 

  2831.             END IF
    2832. 

  2832.          ELSE
    2833. 

  2833.             PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
    2834. 

  2834.          END IF
    2835. 

  2835.       END IF
    2836. 

  2836.   125 CONTINUE
    2837. 

  2837.   130 CONTINUE
    2838. 

  2838.       DO 230 JL=1,KLON
    2839. 

  2839.         PRFL(JL)=MAX(PRFL(JL),0.)
    2840. 

  2840.         PSFL(JL)=MAX(PSFL(JL),0.)
    2841. 

  2841.         ZPSUBCL(JL)=PRFL(JL)+PSFL(JL)
    2842. 

  2842.   230 CONTINUE
    2843. 

  2843.       DO 240 JK=KTOPM2,KLEV
    2844. 

  2844.       DO 235 JL=1,KLON
    2845. 

  2845.       IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. &
    2846. 

  2846.              ZPSUBCL(JL).GT.1.E-20) THEN
    2847. 

  2847.           ZRFL=ZPSUBCL(JL)
    2848. 

  2848.           CEVAPCU=CEVAPCU1*SQRT(CEVAPCU2*SQRT(sig1(JK)))
    2849. 

  2849.           ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)-   &
    2850. 

  2850.                   CEVAPCU*(PAPH(JL,JK+1)-PAPH(JL,JK))* &
    2851. 

  2851.                 MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))**2*ZCUCOV
    2852. 

  2852.           ZRMIN=ZRFL-ZCUCOV*MAX(0.,0.8*PQSEN(JL,JK)-PQEN(JL,JK)) &
    2853. 

  2853.                *ZCONS2*(PAPH(JL,JK+1)-PAPH(JL,JK))
    2854. 

  2854.           ZRNEW=MAX(ZRNEW,ZRMIN)
    2855. 

  2855.           ZRFLN=MAX(ZRNEW,0.)
    2856. 

  2856.           ZDRFL=MIN(0.,ZRFLN-ZRFL)
    2857. 

  2857.           PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL
    2858. 

  2858.           ZPSUBCL(JL)=ZRFLN
    2859. 

  2859.       END IF
    2860. 

  2860.   235 CONTINUE
    2861. 

  2861.   240 CONTINUE
    2862. 

  2862.       DO 250 JL=1,KLON
    2863. 

  2863.         ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL))
    2864. 

  2864.         PRFL(JL)=PRFL(JL)+ZDPEVAP*PRFL(JL)*  &
    2865. 

  2865.                   (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
    2866. 

  2866.         PSFL(JL)=PSFL(JL)+ZDPEVAP*PSFL(JL)*  &
    2867. 

  2867.                   (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
    2868. 

  2868.   250 CONTINUE
    2869. 

  2869.       RETURN
    2870. 

  2870.       END SUBROUTINE CUFLX
    2871. 

  2871. !
    2872. 

  2872. 

  2873. !**********************************************
    2874. 

  2874. !       SUBROUTINE CUDTDQ
    2875. 

  2875. !********************************************** 
    2876. 

  2876.       SUBROUTINE CUDTDQ &
    2877. 

  2877.          (KLON,     KLEV,     KLEVP1,   KTOPM2,   PAPH,   &
    2878. 

  2878.           LDCUM,    PTEN,     PTTE,     PQTE,     PMFUS,  &
    2879. 

  2879.           PMFDS,    PMFUQ,    PMFDQ,    PMFUL,    PDMFUP, &
    2880. 

  2880.           PDMFDP,   ZTMST,    PDPMEL,   PRAIN,    PRFL,   &
    2881. 

  2881.           PSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT, &
    2882. 

  2882.           PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,  &
    2883. 

  2883.           PQEN,     PQSEN,    PLUDE,    PCTE)
    2884. 

  2884. !**** *CUDTDQ* - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES
    2885. 

  2885. !                DOES GLOBAL DIAGNOSTICS
    2886. 

  2886. !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
    2887. 

  2887. !***INTERFACE.
    2888. 

  2888. !   ----------
    2889. 

  2889. !          *CUDTDQ* IS CALLED FROM *CUMASTR*
    2890. 

  2890. ! ----------------------------------------------------------------
    2891. 

  2891. !-------------------------------------------------------------------
    2892. 

  2892.       IMPLICIT NONE
    2893. 

  2893. !-------------------------------------------------------------------
    2894. 

  2894.       INTEGER   KLON, KLEV, KLEVP1
    2895. 

  2895.       INTEGER   KTOPM2,JL, JK
    2896. 

  2896.       REAL      ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW
    2897. 

  2897.       REAL      ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT
    2898. 

  2898.       REAL     PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
    2899. 

  2899.               PTEN(KLON,KLEV),        PLUDE(KLON,KLEV),  &
    2900. 

  2900.               PGEO(KLON,KLEV),        PAPH(KLON,KLEVP1), &
    2901. 

  2901.               PAPRC(KLON),            PAPRS(KLON),       &
    2902. 

  2902.               PAPRSM(KLON),           PCTE(KLON,KLEV),   &
    2903. 

  2903.               PRSFC(KLON),            PSSFC(KLON)
    2904. 

  2904.       REAL     PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV), &
    2905. 

  2905.               PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV), &
    2906. 

  2906.               PMFUL(KLON,KLEV),       PQSEN(KLON,KLEV), &
    2907. 

  2907.               PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),& 
    2908. 

  2908.               PRFL(KLON),             PRAIN(KLON),      &
    2909. 

  2909.               PQEN(KLON,KLEV)
    2910. 

  2910.       REAL     PDPMEL(KLON,KLEV),      PSFL(KLON)
    2911. 

  2911.       REAL     ZSHEAT(KLON),           ZMELT(KLON)
    2912. 

  2912.       LOGICAL  LDCUM(KLON)
    2913. 

  2913. !--------------------------------
    2914. 

  2914. !*    1.0      SPECIFY PARAMETERS
    2915. 

  2915. !--------------------------------
    2916. 

  2916.   100 CONTINUE
    2917. 

  2917.       ZDIAGT=ZTMST
    2918. 

  2918.       ZDIAGW=ZDIAGT/RHOH2O
    2919. 

  2919. !--------------------------------------------------
    2920. 

  2920. !*    2.0      INCREMENTATION OF T AND Q TENDENCIES
    2921. 

  2921. !--------------------------------------------------
    2922. 

  2922.   200 CONTINUE
    2923. 

  2923.       DO 210 JL=1,KLON
    2924. 

  2924.       ZMELT(JL)=0.
    2925. 

  2925.       ZSHEAT(JL)=0.
    2926. 

  2926.   210 CONTINUE
    2927. 

  2927.       DO 250 JK=KTOPM2,KLEV
    2928. 

  2928.       IF(JK.LT.KLEV) THEN
    2929. 

  2929.          DO 220 JL=1,KLON
    2930. 

  2930.          IF(LDCUM(JL)) THEN
    2931. 

  2931.             IF(PTEN(JL,JK).GT.TMELT) THEN
    2932. 

  2932.                ZALV=ALV
    2933. 

  2933.             ELSE
    2934. 

  2934.                ZALV=ALS
    2935. 

  2935.             ENDIF
    2936. 

  2936.             RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
    2937. 

  2937.             RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
    2938. 

  2938.             pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
    2939. 

  2939.             ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*      &
    2940. 

  2940.               (PMFUS(JL,JK+1)-PMFUS(JL,JK)+                  &
    2941. 

  2941.               PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK)  &
    2942. 

  2942.               -ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-      &
    2943. 

  2943.               (PDMFUP(JL,JK)+PDMFDP(JL,JK))))
    2944. 

  2944.             PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
    2945. 

  2945.             ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*& 
    2946. 

  2946.               (PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+       &
    2947. 

  2947.               PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+        &
    2948. 

  2948.               PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-  &
    2949. 

  2949.               (PDMFUP(JL,JK)+PDMFDP(JL,JK)))
    2950. 

  2950.             PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
    2951. 

  2951.             PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
    2952. 

  2952.             ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
    2953. 

  2953.             ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
    2954. 

  2954.          END IF
    2955. 

  2955.   220 CONTINUE
    2956. 

  2956.       ELSE
    2957. 

  2957.          DO 230 JL=1,KLON
    2958. 

  2958.          IF(LDCUM(JL)) THEN
    2959. 

  2959.             IF(PTEN(JL,JK).GT.TMELT) THEN
    2960. 

  2960.                ZALV=ALV
    2961. 

  2961.             ELSE
    2962. 

  2962.                ZALV=ALS
    2963. 

  2963.             ENDIF
    2964. 

  2964.             RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
    2965. 

  2965.             RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
    2966. 

  2966.             pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
    2967. 

  2967.             ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*           &
    2968. 

  2968.                 (PMFUS(JL,JK)+PMFDS(JL,JK)+ALF*PDPMEL(JL,JK)-ZALV* &
    2969. 

  2969.                 (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd))  
    2970. 

  2970.             PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
    2971. 

  2971.             ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*                &
    2972. 

  2972.                      (PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+             &
    2973. 

  2973.                      (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)))   
    2974. 

  2974.             PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
    2975. 

  2975.             PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
    2976. 

  2976.             ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
    2977. 

  2977.             ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
    2978. 

  2978.          END IF
    2979. 

  2979.   230    CONTINUE
    2980. 

  2980.       END IF
    2981. 

  2981.   250 CONTINUE
    2982. 

  2982. !---------------------------------------------------------
    2983. 

  2983. !      3.      UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS
    2984. 

  2984. !---------------------------------------------------------
    2985. 

  2985.   300 CONTINUE
    2986. 

  2986.       DO 310 JL=1,KLON
    2987. 

  2987.       PRSFC(JL)=PRFL(JL)
    2988. 

  2988.       PSSFC(JL)=PSFL(JL)
    2989. 

  2989.       PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL))
    2990. 

  2990.       PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL)
    2991. 

  2991.       PSHEAT=PSHEAT+ZSHEAT(JL)
    2992. 

  2992.       PSRAIN=PSRAIN+PRAIN(JL)
    2993. 

  2993.       PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL))
    2994. 

  2994.       PSMELT=PSMELT+ZMELT(JL)
    2995. 

  2995.   310 CONTINUE
    2996. 

  2996.       PSEVAP=PSEVAP+PSRAIN
    2997. 

  2997.       RETURN
    2998. 

  2998.       END SUBROUTINE CUDTDQ
    2999. 

  2999. 

  3000. !
    3001. 

  3001. !**********************************************
    3002. 

  3002. !       SUBROUTINE CUDUDV
    3003. 

  3003. !********************************************** 
    3004. 

  3004.       SUBROUTINE CUDUDV &
    3005. 

  3005.          (KLON,     KLEV,     KLEVP1,   KTOPM2,   KTYPE,  &
    3006. 

  3006.           KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,   &
    3007. 

  3007.           PVOM,     PVOL,     PUU,      PUD,      PVU,    &
    3008. 

  3008.           PVD,      PMFU,     PMFD,     PSDISS)
    3009. 

  3009. !**** *CUDUDV* - UPDATES U AND V TENDENCIES,
    3010. 

  3010. !                DOES GLOBAL DIAGNOSTIC OF DISSIPATION
    3011. 

  3011. !      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
    3012. 

  3012. !***INTERFACE.
    3013. 

  3013. !   ----------
    3014. 

  3014. !          *CUDUDV* IS CALLED FROM *CUMASTR*
    3015. 

  3015. ! ----------------------------------------------------------------
    3016. 

  3016. !-------------------------------------------------------------------
    3017. 

  3017.       IMPLICIT NONE
    3018. 

  3018. !-------------------------------------------------------------------
    3019. 

  3019.       INTEGER   KLON, KLEV, KLEVP1
    3020. 

  3020.       INTEGER   KTOPM2, JK, IK, JL, IKB
    3021. 

  3021.       REAL      PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM
    3022. 

  3022.       REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
    3023. 

  3023.               PVOL(KLON,KLEV),        PVOM(KLON,KLEV),    &
    3024. 

  3024.               PAPH(KLON,KLEVP1)
    3025. 

  3025.       REAL     PUU(KLON,KLEV),         PUD(KLON,KLEV),    &
    3026. 

  3026.               PVU(KLON,KLEV),         PVD(KLON,KLEV),     &
    3027. 

  3027.               PMFU(KLON,KLEV),        PMFD(KLON,KLEV)
    3028. 

  3028.       REAL     ZMFUU(KLON,KLEV),       ZMFDU(KLON,KLEV),  &
    3029. 

  3029.               ZMFUV(KLON,KLEV),       ZMFDV(KLON,KLEV),   &
    3030. 

  3030.               ZDISS(KLON)
    3031. 

  3031.       INTEGER  KTYPE(KLON),            KCBOT(KLON)
    3032. 

  3032.       LOGICAL  LDCUM(KLON)
    3033. 

  3033. !------------------------------------------------------------
    3034. 

  3034. !*    1.0      CALCULATE FLUXES AND UPDATE U AND V TENDENCIES
    3035. 

  3035. ! -----------------------------------------------------------
    3036. 

  3036.   100 CONTINUE
    3037. 

  3037.       DO 120 JK=KTOPM2,KLEV
    3038. 

  3038.       IK=JK-1
    3039. 

  3039.       DO 110 JL=1,KLON
    3040. 

  3040.       IF(LDCUM(JL)) THEN
    3041. 

  3041.         ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK))
    3042. 

  3042.         ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK))
    3043. 

  3043.         ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK))
    3044. 

  3044.         ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK))
    3045. 

  3045.       END IF
    3046. 

  3046.   110 CONTINUE
    3047. 

  3047.   120 CONTINUE
    3048. 

  3048.       DO 140 JK=KTOPM2,KLEV
    3049. 

  3049.       DO 130 JL=1,KLON
    3050. 

  3050.       IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
    3051. 

  3051.          IKB=KCBOT(JL)
    3052. 

  3052.          ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
    3053. 

  3053.              (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
    3054. 

  3054.          IF(KTYPE(JL).EQ.3) THEN
    3055. 

  3055.             ZZP=ZZP**2
    3056. 

  3056.          ENDIF
    3057. 

  3057.          ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP
    3058. 

  3058.          ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP
    3059. 

  3059.          ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP
    3060. 

  3060.          ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP
    3061. 

  3061.       END IF
    3062. 

  3062.   130 CONTINUE
    3063. 

  3063.   140 CONTINUE
    3064. 

  3064.       DO 150 JL=1,KLON
    3065. 

  3065.       ZDISS(JL)=0.
    3066. 

  3066.   150 CONTINUE
    3067. 

  3067.       DO 190 JK=KTOPM2,KLEV
    3068. 

  3068.       IF(JK.LT.KLEV) THEN
    3069. 

  3069.          DO 160 JL=1,KLON
    3070. 

  3070.             IF(LDCUM(JL)) THEN
    3071. 

  3071.                ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
    3072. 

  3072.                     (ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+     &
    3073. 

  3073.                      ZMFDU(JL,JK+1)-ZMFDU(JL,JK))
    3074. 

  3074.                ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
    3075. 

  3075.                     (ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+     &
    3076. 

  3076.                      ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
    3077. 

  3077.                ZDISS(JL)=ZDISS(JL)+        &
    3078. 

  3078.                         PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+   &
    3079. 

  3079.                                      ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+  &
    3080. 

  3080.                         PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+   &
    3081. 

  3081.                                      ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
    3082. 

  3082.                PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
    3083. 

  3083.                PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
    3084. 

  3084.             END IF
    3085. 

  3085.   160    CONTINUE
    3086. 

  3086.       ELSE
    3087. 

  3087.          DO 170 JL=1,KLON
    3088. 

  3088.             IF(LDCUM(JL)) THEN
    3089. 

  3089.                ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
    3090. 

  3090.                         (ZMFUU(JL,JK)+ZMFDU(JL,JK))
    3091. 

  3091.                ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
    3092. 

  3092.                         (ZMFUV(JL,JK)+ZMFDV(JL,JK))
    3093. 

  3093.                ZDISS(JL)=ZDISS(JL)-        &
    3094. 

  3094.       (PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ &
    3095. 

  3095.       PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK)))
    3096. 

  3096.                PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
    3097. 

  3097.                PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
    3098. 

  3098.             END IF
    3099. 

  3099.   170    CONTINUE
    3100. 

  3100.        END IF
    3101. 

  3101.   190 CONTINUE
    3102. 

  3102.       ZSUM=SSUM(KLON,ZDISS(1),1)
    3103. 

  3103.       PSDISS=PSDISS+ZSUM
    3104. 

  3104.       RETURN
    3105. 

  3105.       END SUBROUTINE CUDUDV
    3106. 

  3106. !
    3107. 

  3107. 

  3108. !#################################################################
    3109. 

  3109. !
    3110. 

  3110. !                 LEVEL 4 SUBROUTINES
    3111. 

  3111. !
    3112. 

  3112. !#################################################################
    3113. 

  3113. !**************************************************************
    3114. 

  3114. !             SUBROUTINE CUBASMC
    3115. 

  3115. !**************************************************************
    3116. 

  3116.       SUBROUTINE CUBASMC   &
    3117. 

  3117.          (KLON,     KLEV,     KLEVM1,  KK,     PTEN,  &
    3118. 

  3118.           PQEN,     PQSEN,    PUEN,    PVEN,   PVERV, &
    3119. 

  3119.           PGEO,     PGEOH,    LDCUM,   KTYPE,  KLAB,  &
    3120. 

  3120.           PMFU,     PMFUB,    PENTR,   KCBOT,  PTU,   &
    3121. 

  3121.           PQU,      PLU,      PUU,     PVU,    PMFUS, &
    3122. 

  3122.           PMFUQ,    PMFUL,    PDMFUP,  PMFUU,  PMFUV) 
    3123. 

  3123. !      M.TIEDTKE         E.C.M.W.F.     12/89
    3124. 

  3124. !***PURPOSE.
    3125. 

  3125. !   --------
    3126. 

  3126. !          THIS ROUTINE CALCULATES CLOUD BASE VALUES
    3127. 

  3127. !          FOR MIDLEVEL CONVECTION
    3128. 

  3128. !***INTERFACE
    3129. 

  3129. !   ---------
    3130. 

  3130. !          THIS ROUTINE IS CALLED FROM *CUASC*.
    3131. 

  3131. !          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
    3132. 

  3132. !          IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION
    3133. 

  3133. !***METHOD.
    3134. 

  3134. !   -------
    3135. 

  3135. !          S. TIEDTKE (1989)
    3136. 

  3136. !***EXTERNALS
    3137. 

  3137. !   ---------
    3138. 

  3138. !          NONE
    3139. 

  3139. ! ----------------------------------------------------------------
    3140. 

  3140. !-------------------------------------------------------------------
    3141. 

  3141.       IMPLICIT NONE
    3142. 

  3142. !-------------------------------------------------------------------
    3143. 

  3143.       INTEGER   KLON, KLEV, KLEVP1
    3144. 

  3144.       INTEGER   KLEVM1,KK, JL
    3145. 

  3145.       REAL      zzzmb
    3146. 

  3146.       REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),  &
    3147. 

  3147.               PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
    3148. 

  3148.               PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),  & 
    3149. 

  3149.               PGEO(KLON,KLEV),        PGEOH(KLON,KLEV)
    3150. 

  3150.       REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
    3151. 

  3151.               PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
    3152. 

  3152.               PLU(KLON,KLEV),         PMFU(KLON,KLEV),   &
    3153. 

  3153.               PMFUB(KLON),            PENTR(KLON),       &
    3154. 

  3154.               PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
    3155. 

  3155.               PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV), &
    3156. 

  3156.               PMFUU(KLON),            PMFUV(KLON)
    3157. 

  3157.       INTEGER  KTYPE(KLON),            KCBOT(KLON),      &
    3158. 

  3158.               KLAB(KLON,KLEV)
    3159. 

  3159.       LOGICAL  LDCUM(KLON)
    3160. 

  3160. !--------------------------------------------------------
    3161. 

  3161. !*    1.      CALCULATE ENTRAINMENT AND DETRAINMENT RATES
    3162. 

  3162. ! -------------------------------------------------------
    3163. 

  3163.   100 CONTINUE
    3164. 

  3164.          DO 150 JL=1,KLON
    3165. 

  3165.           IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND.  &
    3166. 

  3166.              PQEN(JL,KK).GT.0.80*PQSEN(JL,KK)) THEN
    3167. 

  3167.             PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) &
    3168. 

  3168.                                *RCPD
    3169. 

  3169.             PQU(JL,KK+1)=PQEN(JL,KK)
    3170. 

  3170.             PLU(JL,KK+1)=0.
    3171. 

  3171.             ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G)
    3172. 

  3172.             ZZZMB=MIN(ZZZMB,CMFCMAX)
    3173. 

  3173.             PMFUB(JL)=ZZZMB
    3174. 

  3174.             PMFU(JL,KK+1)=PMFUB(JL)
    3175. 

  3175.             PMFUS(JL,KK+1)=PMFUB(JL)*(CPD*PTU(JL,KK+1)+PGEOH(JL,KK+1))
    3176. 

  3176.             PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1)
    3177. 

  3177.             PMFUL(JL,KK+1)=0.
    3178. 

  3178.             PDMFUP(JL,KK+1)=0.
    3179. 

  3179.             KCBOT(JL)=KK
    3180. 

  3180.             KLAB(JL,KK+1)=1
    3181. 

  3181.             KTYPE(JL)=3
    3182. 

  3182.             PENTR(JL)=ENTRMID
    3183. 

  3183.                IF(LMFDUDV) THEN
    3184. 

  3184.                   PUU(JL,KK+1)=PUEN(JL,KK)
    3185. 

  3185.                   PVU(JL,KK+1)=PVEN(JL,KK)
    3186. 

  3186.                   PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1)
    3187. 

  3187.                   PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1)
    3188. 

  3188.                END IF
    3189. 

  3189.          END IF
    3190. 

  3190.   150   CONTINUE
    3191. 

  3191.       RETURN
    3192. 

  3192.       END SUBROUTINE CUBASMC
    3193. 

  3193. 

  3194. !
    3195. 

  3195. !**************************************************************
    3196. 

  3196. !             SUBROUTINE CUADJTQ
    3197. 

  3197. !**************************************************************
    3198. 

  3198.       SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL)
    3199. 

  3199. !      M.TIEDTKE         E.C.M.W.F.     12/89
    3200. 

  3200. !      D.SALMOND         CRAY(UK))      12/8/91
    3201. 

  3201. !***PURPOSE.
    3202. 

  3202. !   --------
    3203. 

  3203. !          TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
    3204. 

  3204. !***INTERFACE
    3205. 

  3205. !   ---------
    3206. 

  3206. !          THIS ROUTINE IS CALLED FROM SUBROUTINES:
    3207. 

  3207. !              *CUBASE*   (T AND Q AT CONDENSTION LEVEL)
    3208. 

  3208. !              *CUASC*    (T AND Q AT CLOUD LEVELS)
    3209. 

  3209. !              *CUINI*    (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS)
    3210. 

  3210. !          INPUT ARE UNADJUSTED T AND Q VALUES,
    3211. 

  3211. !          IT RETURNS ADJUSTED VALUES OF T AND Q
    3212. 

  3212. !          NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
    3213. 

  3213. !               KCALL=0    ENV. T AND QS IN*CUINI*
    3214. 

  3214. !               KCALL=1  CONDENSATION IN UPDRAFTS  (E.G.  CUBASE, CUASC)
    3215. 

  3215. !               KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G.  CUDLFS,CUDDRAF
    3216. 

  3216. !***EXTERNALS
    3217. 

  3217. !   ---------
    3218. 

  3218. !          3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC )
    3219. 

  3219. !          FOR CONDENSATION CALCULATIONS.
    3220. 

  3220. !          THE TABLES ARE INITIALISED IN *SETPHYS*.
    3221. 

  3221. ! ----------------------------------------------------------------
    3222. 

  3222. !-------------------------------------------------------------------
    3223. 

  3223.       IMPLICIT NONE
    3224. 

  3224. !-------------------------------------------------------------------
    3225. 

  3225.       INTEGER   KLON, KLEV
    3226. 

  3226.       INTEGER   KK, KCALL, ISUM, JL
    3227. 

  3227.       REAL      ZQSAT, ZCOR, ZCOND1, TT
    3228. 

  3228.       REAL     PT(KLON,KLEV),          PQ(KLON,KLEV),  &
    3229. 

  3229.               ZCOND(KLON),            ZQP(KLON),       &
    3230. 

  3230.               PP(KLON)
    3231. 

  3231.       LOGICAL  LDFLAG(KLON)
    3232. 

  3232. !------------------------------------------------------------------
    3233. 

  3233. !     2.      CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY
    3234. 

  3234. !------------------------------------------------------------------
    3235. 

  3235.   200 CONTINUE
    3236. 

  3236.       IF (KCALL.EQ.1 ) THEN
    3237. 

  3237.          ISUM=0
    3238. 

  3238.          DO 210 JL=1,KLON
    3239. 

  3239.          ZCOND(JL)=0.
    3240. 

  3240.          IF(LDFLAG(JL)) THEN
    3241. 

  3241.             ZQP(JL)=1./PP(JL)
    3242. 

  3242.             TT=PT(JL,KK)
    3243. 

  3243.             ZQSAT=TLUCUA(TT)*ZQP(JL)
    3244. 

  3244.             ZQSAT=MIN(0.5,ZQSAT)
    3245. 

  3245.             ZCOR=1./(1.-VTMPC1*ZQSAT)
    3246. 

  3246.             ZQSAT=ZQSAT*ZCOR
    3247. 

  3247.             ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3248. 

  3248.             ZCOND(JL)=MAX(ZCOND(JL),0.)
    3249. 

  3249.             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
    3250. 

  3250.             PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
    3251. 

  3251.             IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
    3252. 

  3252.          END IF
    3253. 

  3253.   210    CONTINUE
    3254. 

  3254.          IF(ISUM.EQ.0) GO TO 230
    3255. 

  3255.          DO 220 JL=1,KLON
    3256. 

  3256.          IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
    3257. 

  3257.             TT=PT(JL,KK)
    3258. 

  3258.             ZQSAT=TLUCUA(TT)*ZQP(JL)
    3259. 

  3259.             ZQSAT=MIN(0.5,ZQSAT)
    3260. 

  3260.             ZCOR=1./(1.-VTMPC1*ZQSAT)
    3261. 

  3261.             ZQSAT=ZQSAT*ZCOR
    3262. 

  3262.             ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3263. 

  3263.             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
    3264. 

  3264.             PQ(JL,KK)=PQ(JL,KK)-ZCOND1
    3265. 

  3265.          END IF
    3266. 

  3266.   220    CONTINUE
    3267. 

  3267.   230    CONTINUE
    3268. 

  3268.       END IF
    3269. 

  3269.       IF(KCALL.EQ.2) THEN
    3270. 

  3270.          ISUM=0
    3271. 

  3271.          DO 310 JL=1,KLON
    3272. 

  3272.          ZCOND(JL)=0.
    3273. 

  3273.          IF(LDFLAG(JL)) THEN
    3274. 

  3274.             TT=PT(JL,KK)
    3275. 

  3275.             ZQP(JL)=1./PP(JL)
    3276. 

  3276.             ZQSAT=TLUCUA(TT)*ZQP(JL)
    3277. 

  3277.             ZQSAT=MIN(0.5,ZQSAT)
    3278. 

  3278.             ZCOR=1./(1.-VTMPC1*ZQSAT)
    3279. 

  3279.             ZQSAT=ZQSAT*ZCOR
    3280. 

  3280.             ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3281. 

  3281.             ZCOND(JL)=MIN(ZCOND(JL),0.)
    3282. 

  3282.             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
    3283. 

  3283.             PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
    3284. 

  3284.             IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
    3285. 

  3285.          END IF
    3286. 

  3286.   310    CONTINUE
    3287. 

  3287.          IF(ISUM.EQ.0) GO TO 330
    3288. 

  3288.          DO 320 JL=1,KLON
    3289. 

  3289.          IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
    3290. 

  3290.             TT=PT(JL,KK)
    3291. 

  3291.             ZQSAT=TLUCUA(TT)*ZQP(JL)
    3292. 

  3292.             ZQSAT=MIN(0.5,ZQSAT)
    3293. 

  3293.             ZCOR=1./(1.-VTMPC1*ZQSAT)
    3294. 

  3294.             ZQSAT=ZQSAT*ZCOR
    3295. 

  3295.             ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3296. 

  3296.             PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
    3297. 

  3297.             PQ(JL,KK)=PQ(JL,KK)-ZCOND1
    3298. 

  3298.          END IF
    3299. 

  3299.   320    CONTINUE
    3300. 

  3300.   330    CONTINUE
    3301. 

  3301.       END IF
    3302. 

  3302.       IF(KCALL.EQ.0) THEN
    3303. 

  3303.          ISUM=0
    3304. 

  3304.          DO 410 JL=1,KLON
    3305. 

  3305.            TT=PT(JL,KK)
    3306. 

  3306.            ZQP(JL)=1./PP(JL)
    3307. 

  3307.            ZQSAT=TLUCUA(TT)*ZQP(JL)
    3308. 

  3308.            ZQSAT=MIN(0.5,ZQSAT)
    3309. 

  3309.            ZCOR=1./(1.-VTMPC1*ZQSAT)
    3310. 

  3310.            ZQSAT=ZQSAT*ZCOR
    3311. 

  3311.            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3312. 

  3312.            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
    3313. 

  3313.            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
    3314. 

  3314.            IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
    3315. 

  3315.   410    CONTINUE
    3316. 

  3316.          IF(ISUM.EQ.0) GO TO 430
    3317. 

  3317.          DO 420 JL=1,KLON
    3318. 

  3318.            TT=PT(JL,KK)
    3319. 

  3319.            ZQSAT=TLUCUA(TT)*ZQP(JL)
    3320. 

  3320.            ZQSAT=MIN(0.5,ZQSAT)
    3321. 

  3321.            ZCOR=1./(1.-VTMPC1*ZQSAT)
    3322. 

  3322.            ZQSAT=ZQSAT*ZCOR
    3323. 

  3323.            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3324. 

  3324.            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
    3325. 

  3325.            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
    3326. 

  3326.   420    CONTINUE
    3327. 

  3327.   430    CONTINUE
    3328. 

  3328.       END IF
    3329. 

  3329.       IF(KCALL.EQ.4) THEN
    3330. 

  3330.          DO 510 JL=1,KLON
    3331. 

  3331.            TT=PT(JL,KK)
    3332. 

  3332.            ZQP(JL)=1./PP(JL)
    3333. 

  3333.            ZQSAT=TLUCUA(TT)*ZQP(JL)
    3334. 

  3334.            ZQSAT=MIN(0.5,ZQSAT)
    3335. 

  3335.            ZCOR=1./(1.-VTMPC1*ZQSAT)
    3336. 

  3336.            ZQSAT=ZQSAT*ZCOR
    3337. 

  3337.            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3338. 

  3338.            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
    3339. 

  3339.            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
    3340. 

  3340.   510    CONTINUE
    3341. 

  3341.          DO 520 JL=1,KLON
    3342. 

  3342.            TT=PT(JL,KK)
    3343. 

  3343.            ZQSAT=TLUCUA(TT)*ZQP(JL)
    3344. 

  3344.            ZQSAT=MIN(0.5,ZQSAT)
    3345. 

  3345.            ZCOR=1./(1.-VTMPC1*ZQSAT)
    3346. 

  3346.            ZQSAT=ZQSAT*ZCOR
    3347. 

  3347.            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
    3348. 

  3348.            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
    3349. 

  3349.            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
    3350. 

  3350.   520    CONTINUE
    3351. 

  3351.       END IF
    3352. 

  3352.       RETURN
    3353. 

  3353.       END SUBROUTINE CUADJTQ
    3354. 

  3354. 

  3355. !
    3356. 

  3356. !**********************************************************
    3357. 

  3357. !        SUBROUTINE CUENTR_NEW
    3358. 

  3358. !**********************************************************
    3359. 

  3359.       SUBROUTINE CUENTR_NEW                              &   
    3360. 

  3360.          (KLON,     KLEV,     KLEVP1,   KK,       PTENH, &
    3361. 

  3361.           PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM, &
    3362. 

  3362.           KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU,  &
    3363. 

  3363.           PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
    3364. 

  3364. !      M.TIEDTKE         E.C.M.W.F.     12/89
    3365. 

  3365. !      Y.WANG            IPRC           11/01
    3366. 

  3366. !***PURPOSE.
    3367. 

  3367. !   --------
    3368. 

  3368. !          THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES
    3369. 

  3369. !          FOR UPDRAFTS IN CUMULUS PARAMETERIZATION
    3370. 

  3370. !***INTERFACE
    3371. 

  3371. !   ---------
    3372. 

  3372. !          THIS ROUTINE IS CALLED FROM *CUASC*.
    3373. 

  3373. !          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
    3374. 

  3374. !          AND UPDRAFT VALUES T,Q ETC
    3375. 

  3375. !          IT RETURNS ENTRAINMENT/DETRAINMENT RATES
    3376. 

  3376. !***METHOD.
    3377. 

  3377. !  --------
    3378. 

  3378. !          S. TIEDTKE (1989), NORDENG(1996)
    3379. 

  3379. !***EXTERNALS
    3380. 

  3380. !   ---------
    3381. 

  3381. !          NONE
    3382. 

  3382. ! ----------------------------------------------------------------
    3383. 

  3383. !-------------------------------------------------------------------
    3384. 

  3384.       IMPLICIT NONE
    3385. 

  3385. !-------------------------------------------------------------------
    3386. 

  3386.       INTEGER   KLON, KLEV, KLEVP1
    3387. 

  3387.       INTEGER   KK, JL, IKLWMIN,IKB, IKT, IKH
    3388. 

  3388.       REAL      ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE
    3389. 

  3389.       REAL     PTENH(KLON,KLEV),                           &
    3390. 

  3390.               PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),   &
    3391. 

  3391.               PMFU(KLON,KLEV),        PGEOH(KLON,KLEV),    &
    3392. 

  3392.               PENTR(KLON),            ZPBASE(KLON),        &
    3393. 

  3393.               ZDMFEN(KLON),           ZDMFDE(KLON),        &
    3394. 

  3394.               ZODETR(KLON,KLEV)
    3395. 

  3395.       INTEGER  KLWMIN(KLON),           KTYPE(KLON),        &
    3396. 

  3396.               KCBOT(KLON),            KCTOP0(KLON),        &
    3397. 

  3397.               KHMIN(KLON)
    3398. 

  3398.       LOGICAL  LDCUM(KLON),LLO1,LLO2
    3399. 

  3399. 

  3400.       real    tt(klon),ttb(klon)
    3401. 

  3401.       real    zqsat(klon), zqsatb(klon)
    3402. 

  3402.       real    fscale(klon)
    3403. 

  3403. !---------------------------------------------------------
    3404. 

  3404. !*    1.       CALCULATE ENTRAINMENT AND DETRAINMENT RATES
    3405. 

  3405. !---------------------------------------------------------
    3406. 

  3406. !*    1.1      SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS
    3407. 

  3407. !----------------------------------------------------------
    3408. 

  3408. !*    1.2      SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS
    3409. 

  3409. !-------------------------------------------------------
    3410. 

  3410.       DO jl = 1, klon
    3411. 

  3411.         zpbase(jl) = paph(jl,kcbot(jl))
    3412. 

  3412.         zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1)
    3413. 

  3413.         zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg
    3414. 

  3414. ! old or new choice
    3415. 

  3415.         zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl)))
    3416. 

  3416.         zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho
    3417. 

  3417.         llo1 = kk.LT.kcbot(jl).AND.ldcum(jl)
    3418. 

  3418. ! old or new choice
    3419. 

  3419.         if(llo1) then
    3420. 

  3420.            if(nturben.eq.1) zdmfde(jl) = zentr
    3421. 

  3421.            if(nturben.eq.2) zdmfde(jl) = zentr*1.2
    3422. 

  3422.         else
    3423. 

  3423.           zdmfde(jl) = 0.0
    3424. 

  3424.         endif
    3425. 

  3425. ! old or new choice
    3426. 

  3426.         if(nturben .eq. 1) then
    3427. 

  3427.           fscale(jl) = 1.0
    3428. 

  3428.         elseif (nturben .eq. 2) then
    3429. 

  3429. ! defining the facale
    3430. 

  3430.         tt(jl) = ptenh(jl,kk+1)
    3431. 

  3431.         zqsat(jl) = TLUCUA(tt(jl))/paph(jl,kk+1)
    3432. 

  3432.         zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl))
    3433. 

  3433.         ttb(jl) = ptenh(jl,kcbot(jl))
    3434. 

  3434.         zqsatb(jl) = TLUCUA(ttb(jl))/zpbase(jl)
    3435. 

  3435.         zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl))
    3436. 

  3436.         fscale(jl) = 4.0*(zqsat(jl)/zqsatb(jl))**2
    3437. 

  3437.         end if
    3438. 

  3438. ! end of defining the fscale
    3439. 

  3439.         llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) &
    3440. 

  3440.              .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid)
    3441. 

  3441.         if(llo2) then
    3442. 

  3442.             zdmfen(jl) = zentr*fscale(jl)
    3443. 

  3443.         else
    3444. 

  3444.             zdmfen(jl) = 0.0
    3445. 

  3445.         endif
    3446. 

  3446.         iklwmin = MAX(klwmin(jl),kctop0(jl)+2)
    3447. 

  3447.         llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) &
    3448. 

  3448.              .GT.zpmid)
    3449. 

  3449.         IF (llo2) zdmfen(jl) = zentr*fscale(jl)
    3450. 

  3450.         llo2 = llo1.AND.ktype(jl).EQ.1
    3451. 

  3451. ! Turbulent entrainment
    3452. 

  3452.         IF (llo2) zdmfen(jl) = zentr*fscale(jl)
    3453. 

  3453. ! Organized detrainment, detrainment starts at khmin
    3454. 

  3454.         ikb = kcbot(jl)
    3455. 

  3455.         zodetr(jl,kk) = 0.
    3456. 

  3456.         IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN
    3457. 

  3457.           ikt = kctop0(jl)
    3458. 

  3458.           ikh = khmin(jl)
    3459. 

  3459.           IF (ikh.GT.ikt) THEN
    3460. 

  3460.             zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg
    3461. 

  3461.             ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg
    3462. 

  3462.             arg = 3.1415*(zzmzk/ztmzk)*0.5
    3463. 

  3463.             zorgde = TAN(arg)*3.1415*0.5/ztmzk
    3464. 

  3464.             zdprho = (paph(jl,kk+1)-paph(jl,kk))*(zrg*zrrho)
    3465. 

  3465.             zodetr(jl,kk) = MIN(zorgde,1.E-3)*pmfu(jl,kk+1)*zdprho
    3466. 

  3466.           END IF
    3467. 

  3467.         END IF
    3468. 

  3468.       ENDDO
    3469. 

  3469. !
    3470. 

  3470.       RETURN
    3471. 

  3471.       END SUBROUTINE CUENTR_NEW
    3472. 

  3472. 

  3473. !**********************************************************
    3474. 

  3474. !        FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC
    3475. 

  3475. !**********************************************************
    3476. 

  3476.       REAL FUNCTION SSUM ( N, X, IX )
    3477. 

  3477. !
    3478. 

  3478. ! COMPUTES SSUM = SUM OF [X(I)]
    3479. 

  3479. !     FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X
    3480. 

  3480. !
    3481. 

  3481.       IMPLICIT NONE
    3482. 

  3482.       REAL X(*)
    3483. 

  3483.       REAL ZSUM
    3484. 

  3484.       INTEGER N, IX, JX, JL
    3485. 

  3485. !
    3486. 

  3486.       JX = 1
    3487. 

  3487.       ZSUM = 0.0
    3488. 

  3488.       DO JL = 1, N
    3489. 

  3489.         ZSUM = ZSUM + X(JX)
    3490. 

  3490.         JX = JX + IX
    3491. 

  3491.       enddo
    3492. 

  3492. !
    3493. 

  3493.       SSUM=ZSUM
    3494. 

  3494. !
    3495. 

  3495.       RETURN
    3496. 

  3496.       END FUNCTION SSUM
    3497. 

  3497. 

  3498.       REAL FUNCTION TLUCUA(TT)
    3499. 

  3499. !
    3500. 

  3500. !  Set up lookup tables for cloud ascent calculations.
    3501. 

  3501. !
    3502. 

  3502.       IMPLICIT NONE
    3503. 

  3503.       REAL ZCVM3,ZCVM4,TT
    3504. 

  3504. !
    3505. 

  3505.       IF(TT-TMELT.GT.0.) THEN
    3506. 

  3506.          ZCVM3=C3LES
    3507. 

  3507.          ZCVM4=C4LES
    3508. 

  3508.       ELSE
    3509. 

  3509.          ZCVM3=C3IES
    3510. 

  3510.          ZCVM4=C4IES
    3511. 

  3511.       END IF
    3512. 

  3512.       TLUCUA=C2ES*EXP(ZCVM3*(TT-TMELT)*(1./(TT-ZCVM4)))
    3513. 

  3513. !
    3514. 

  3514.       RETURN
    3515. 

  3515.       END FUNCTION TLUCUA
    3516. 

  3516. !
    3517. 

  3517.       REAL FUNCTION TLUCUB(TT)
    3518. 

  3518. !
    3519. 

  3519. !  Set up lookup tables for cloud ascent calculations.
    3520. 

  3520. !
    3521. 

  3521.       IMPLICIT NONE
    3522. 

  3522.       REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT
    3523. 

  3523. !
    3524. 

  3524.       Z5ALVCP=C5LES*ALV/CPD
    3525. 

  3525.       Z5ALSCP=C5IES*ALS/CPD
    3526. 

  3526.       IF(TT-TMELT.GT.0.) THEN
    3527. 

  3527.          ZCVM4=C4LES
    3528. 

  3528.          ZCVM5=Z5ALVCP
    3529. 

  3529.       ELSE
    3530. 

  3530.          ZCVM4=C4IES
    3531. 

  3531.          ZCVM5=Z5ALSCP
    3532. 

  3532.       END IF
    3533. 

  3533.       TLUCUB=ZCVM5*(1./(TT-ZCVM4))**2
    3534. 

  3534. !
    3535. 

  3535.       RETURN
    3536. 

  3536.       END FUNCTION TLUCUB
    3537. 

  3537. !
    3538. 

  3538.       REAL FUNCTION TLUCUC(TT)
    3539. 

  3539. !
    3540. 

  3540. !  Set up lookup tables for cloud ascent calculations.
    3541. 

  3541. !
    3542. 

  3542.       IMPLICIT NONE
    3543. 

  3543.       REAL ZALVDCP,ZALSDCP,TT,ZLDCP
    3544. 

  3544. !
    3545. 

  3545.       ZALVDCP=ALV/CPD
    3546. 

  3546.       ZALSDCP=ALS/CPD
    3547. 

  3547.       IF(TT-TMELT.GT.0.) THEN
    3548. 

  3548.          ZLDCP=ZALVDCP
    3549. 

  3549.       ELSE
    3550. 

  3550.          ZLDCP=ZALSDCP
    3551. 

  3551.       END IF
    3552. 

  3552.       TLUCUC=ZLDCP
    3553. 

  3553. !
    3554. 

  3554.       RETURN
    3555. 

  3555.       END FUNCTION TLUCUC
    3556. 

  3556. !
    3557. 

  3557. 

  3558. END MODULE module_cu_tiedtke
    3559. 

  3559.