PageRenderTime 59ms CodeModel.GetById 21ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/phys/module_cu_bmj.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 2151 lines | 1171 code | 20 blank | 960 comment | 0 complexity | 684e203bda51d1281539c4c7c149847f MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

    

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

  2. !
    3. 

  3. !WRF:MODEL_LAYER:PHYSICS
    4. 

  4. !
    5. 

  5. !-----------------------------------------------------------------------
    6. 

  6. !
    7. 

  7.       MODULE MODULE_CU_BMJ
    8. 

  8. !
    9. 

  9. !-----------------------------------------------------------------------
    10. 

  10.       USE MODULE_MODEL_CONSTANTS
    11. 

  11. !-----------------------------------------------------------------------
    12. 

  12. !
    13. 

  13.       REAL,PARAMETER ::                                                 &
    14. 

  14.      &                  DSPC=-3000.                                     &
    15. 

  15.      &                 ,DTTOP=0.,EFIFC=5.0,EFIMN=0.20,EFMNT=0.70        & 
    16. 

  16.      &                 ,ELIWV=2.683E6,ENPLO=20000.,ENPUP=15000.         &
    17. 

  17.      &                 ,EPSDN=1.05,EPSDT=0.                             &
    18. 

  18.      &                 ,EPSNTP=.0001,EPSNTT=.0001,EPSPR=1.E-7           &
    19. 

  19.      &                 ,EPSUP=1.00                                      &
    20. 

  20.      &                 ,FR=1.00,FSL=0.85,FSS=0.85                       &
    21. 

  21.      &                 ,FUP=0.                                          &
    22. 

  22.      &                 ,PBM=13000.,PFRZ=15000.,PNO=1000.                &
    23. 

  23.      &                 ,PONE=2500.,PQM=20000.                           &
    24. 

  24.      &                 ,PSH=20000.,PSHU=45000.                          &
    25. 

  25.      &                 ,RENDP=1./(ENPLO-ENPUP)                          &
    26. 

  26.      &                 ,RHLSC=0.00,RHHSC=1.10                           &
    27. 

  27.      &                 ,ROW=1.E3                                        &
    28. 

  28.      &                 ,STABDF=0.90,STABDS=0.90                         &
    29. 

  29.      &                 ,STABS=1.0,STRESH=1.10                           &
    30. 

  30.      &                 ,DTSHAL=-1.0,TREL=2400.
    31. 

  31. !
    32. 

  32.       REAL,PARAMETER :: DTtrigr=-0.0                                    &
    33. 

  33.                        ,DTPtrigr=DTtrigr*PONE      !<-- Average parcel virtual temperature deficit over depth PONE.
    34. 

  34.                                                    !<-- NOTE: CAPEtrigr is scaled by the cloud base temperature (see below)
    35. 

  35. !
    36. 

  36.       REAL,PARAMETER :: DSPBFL=-3875.*FR                                &
    37. 

  37.      &                 ,DSP0FL=-5875.*FR                                &
    38. 

  38.      &                 ,DSPTFL=-1875.*FR                                &
    39. 

  39.      &                 ,DSPBFS=-3875.                                   &
    40. 

  40.      &                 ,DSP0FS=-5875.                                   &
    41. 

  41.      &                 ,DSPTFS=-1875.
    42. 

  42. !
    43. 

  43.       REAL,PARAMETER :: PL=2500.,PLQ=70000.,PH=105000.                  &
    44. 

  44.      &                 ,THL=210.,THH=365.,THHQ=325.
    45. 

  45. !
    46. 

  46.       INTEGER,PARAMETER :: ITB=76,JTB=134,ITBQ=152,JTBQ=440
    47. 

  47. !
    48. 

  48.       INTEGER,PARAMETER :: ITREFI_MAX=3
    49. 

  49. !
    50. 

  50. !***  ARRAYS FOR LOOKUP TABLES
    51. 

  51. !
    52. 

  52.       REAL,DIMENSION(ITB),PRIVATE,SAVE :: STHE,THE0
    53. 

  53.       REAL,DIMENSION(JTB),PRIVATE,SAVE :: QS0,SQS
    54. 

  54.       REAL,DIMENSION(ITBQ),PRIVATE,SAVE :: STHEQ,THE0Q
    55. 

  55.       REAL,DIMENSION(ITB,JTB),PRIVATE,SAVE :: PTBL
    56. 

  56.       REAL,DIMENSION(JTB,ITB),PRIVATE,SAVE :: TTBL
    57. 

  57.       REAL,DIMENSION(JTBQ,ITBQ),PRIVATE,SAVE :: TTBLQ
    58. 

  58. 

  59. !***  SHARE COPIES FOR MODULE_BL_MYJPBL
    60. 

  60. !
    61. 

  61.       REAL,DIMENSION(JTB) :: QS0_EXP,SQS_EXP
    62. 

  62.       REAL,DIMENSION(ITB,JTB) :: PTBL_EXP
    63. 

  63. !
    64. 

  64.       REAL,PARAMETER :: RDP=(ITB-1.)/(PH-PL),RDPQ=(ITBQ-1.)/(PH-PLQ)  &
    65. 

  65.      &                 ,RDQ=ITB-1,RDTH=(JTB-1.)/(THH-THL)             &
    66. 

  66.      &                 ,RDTHE=JTB-1.,RDTHEQ=JTBQ-1.                   &
    67. 

  67.      &                 ,RSFCP=1./101300.
    68. 

  68. !
    69. 

  69.       REAL,PARAMETER :: AVGEFI=(EFIMN+1.)*0.5
    70. 

  70. !
    71. 

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

  72. !
    73. 

  73. CONTAINS
    74. 

  74. !
    75. 

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

  76.       SUBROUTINE BMJDRV(                                                &
    77. 

  77.      &                  IDS,IDE,JDS,JDE,KDS,KDE                         &
    78. 

  78.      &                 ,IMS,IME,JMS,JME,KMS,KME                         &
    79. 

  79.      &                 ,ITS,ITE,JTS,JTE,KTS,KTE                         &
    80. 

  80.      &                 ,DT,ITIMESTEP,STEPCU                             &
    81. 

  81.      &                 ,CUDT, CURR_SECS, ADAPT_STEP_FLAG                &
    82. 

  82.      &                 ,CUDTACTTIME                                     & 
    83. 

  83.      &                 ,RAINCV,PRATEC,CUTOP,CUBOT,KPBL                  &
    84. 

  84.      &                 ,TH,T,QV                                         &
    85. 

  85.      &                 ,PINT,PMID,PI,RHO,DZ8W                           &
    86. 

  86.      &                 ,CP,R,ELWV,ELIV,G,TFRZ,D608                      &
    87. 

  87.      &                 ,CLDEFI,LOWLYR,XLAND,CU_ACT_FLAG                 &
    88. 

  88.                       ! optional
    89. 

  89.      &                 ,RTHCUTEN, RQVCUTEN                              &
    90. 

  90.      &                                                                  )
    91. 

  91. !-----------------------------------------------------------------------
    92. 

  92.       IMPLICIT NONE
    93. 

  93. !-----------------------------------------------------------------------
    94. 

  94.       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
    95. 

  95.      &                     ,IMS,IME,JMS,JME,KMS,KME                     & 
    96. 

  96.      &                     ,ITS,ITE,JTS,JTE,KTS,KTE
    97. 

  97. !
    98. 

  98.       INTEGER,INTENT(IN) :: ITIMESTEP,STEPCU
    99. 

  99. !
    100. 

  100.       INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: KPBL,LOWLYR
    101. 

  101. !
    102. 

  102.       REAL,INTENT(IN) :: CP,DT,ELIV,ELWV,G,R,TFRZ,D608
    103. 

  103. !
    104. 

  104.       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: XLAND
    105. 

  105. !
    106. 

  106.       REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ8W        &
    107. 

  107.      &                                                     ,PI,PINT     &
    108. 

  108.      &                                                     ,PMID,QV     &
    109. 

  109.      &                                                     ,RHO,T,TH
    110. 

  110. !
    111. 

  111.       REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME)                           &
    112. 

  112.      &    ,OPTIONAL                                                     &
    113. 

  113.      &    ,INTENT(INOUT) ::                        RQVCUTEN,RTHCUTEN 
    114. 

  114. ! 
    115. 

  115.       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CLDEFI,RAINCV,   &
    116. 

  116.            PRATEC
    117. 

  117. !
    118. 

  118.       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CUBOT,CUTOP
    119. 

  119. !
    120. 

  120.       LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CU_ACT_FLAG
    121. 

  121. 

  122. ! Adaptive time-step variables
    123. 

  123.       REAL,  INTENT(IN   ) :: CUDT
    124. 

  124.       REAL,  INTENT(IN   ) :: CURR_SECS
    125. 

  125.       LOGICAL,OPTIONAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
    126. 

  126.       REAL,  INTENT (INOUT) :: CUDTACTTIME       
    127. 

  127. !
    128. 

  128. !-----------------------------------------------------------------------
    129. 

  129. !***
    130. 

  130. !***  LOCAL VARIABLES
    131. 

  131. !***
    132. 

  132. !-----------------------------------------------------------------------
    133. 

  133.       INTEGER :: LBOT,LPBL,LTOP
    134. 

  134. !
    135. 

  135.       REAL :: DTCNVC,LANDMASK,PCPCOL,PSFC,PTOP
    136. 

  136. ! 
    137. 

  137.       REAL,DIMENSION(KTS:KTE) :: DPCOL,DQDT,DTDT,PCOL,QCOL,TCOL
    138. 

  138. !
    139. 

  139.       INTEGER :: I,J,K,KFLIP,LMH
    140. 

  140. 

  141.       LOGICAL :: run_param , doing_adapt_dt , decided
    142. 

  142. !     
    143. 

  143. !***  Begin debugging convection
    144. 

  144.       REAL :: DELQ,DELT,PLYR
    145. 

  145.       INTEGER :: IMD,JMD
    146. 

  146.       LOGICAL :: PRINT_DIAG
    147. 

  147. !***  End debugging convection
    148. 

  148. !
    149. 

  149. !-----------------------------------------------------------------------
    150. 

  150. !*********************************************************************** 
    151. 

  151. !-----------------------------------------------------------------------
    152. 

  152. !
    153. 

  153. !***  PREPARE TO CALL BMJ CONVECTION SCHEME
    154. 

  154. !
    155. 

  155. !-----------------------------------------------------------------------
    156. 

  156. !
    157. 

  157. !***  CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
    158. 

  158. !                                                                        
    159. 

  159. 

  160. !  Initialization for adaptive time step.
    161. 

  161. 

  162.    doing_adapt_dt = .FALSE.
    163. 

  163.    IF ( PRESENT(adapt_step_flag) ) THEN
    164. 

  164.       IF ( adapt_step_flag ) THEN
    165. 

  165.          doing_adapt_dt = .TRUE.
    166. 

  166.          IF ( cudtacttime .EQ. 0. ) THEN
    167. 

  167.             cudtacttime = curr_secs + cudt*60.
    168. 

  168.          END IF
    169. 

  169.       END IF
    170. 

  170.    END IF
    171. 

  171. 

  172. !  Do we run through this scheme or not?
    173. 

  173. 

  174. !    Test 1:  If this is the initial model time, then yes.
    175. 

  175. !                ITIMESTEP=1
    176. 

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

  177. !                CUDT=0 or STEPCU=1
    178. 

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

  179. !                MOD(ITIMESTEP,STEPCU)=0
    180. 

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

  181. !                CURR_SECS >= CUDTACTTIME
    182. 

  182. 

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

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

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

  186. 

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

  188. !  cumulus run.
    189. 

  189. 

  190.    decided = .FALSE.
    191. 

  191.    run_param = .FALSE.
    192. 

  192.    IF ( ( .NOT. decided ) .AND. &
    193. 

  193.         ( itimestep .EQ. 1 ) ) THEN
    194. 

  194.       run_param   = .TRUE.
    195. 

  195.       decided     = .TRUE.
    196. 

  196.    END IF
    197. 

  197. 

  198.    IF ( ( .NOT. decided ) .AND. &
    199. 

  199.         ( ( cudt .EQ. 0. ) .OR. ( stepcu .EQ. 1 ) ) ) THEN
    200. 

  200.       run_param   = .TRUE.
    201. 

  201.       decided     = .TRUE.
    202. 

  202.    END IF
    203. 

  203. 

  204. 

  205.    IF ( ( .NOT. decided ) .AND. &
    206. 

  206.         ( .NOT. doing_adapt_dt ) .AND. &
    207. 

  207.         ( MOD(itimestep,stepcu) .EQ. 0 ) ) THEN
    208. 

  208.       run_param   = .TRUE.
    209. 

  209.       decided     = .TRUE.
    210. 

  210.    END IF
    211. 

  211. 

  212.    IF ( ( .NOT. decided ) .AND. &
    213. 

  213.         ( doing_adapt_dt ) .AND. &
    214. 

  214.         ( curr_secs .GE. cudtacttime ) ) THEN
    215. 

  215.       run_param   = .TRUE.
    216. 

  216.       decided     = .TRUE.
    217. 

  217.       cudtacttime = curr_secs + cudt*60
    218. 

  218.    END IF
    219. 

  219. 

  220. !-----------------------------------------------------------------------
    221. 

  221. !                                                                      
    222. 

  222. !***  COMPUTE CONVECTION EVERY STEPCU*DT/60.0 MINUTES
    223. 

  223. !                                                                     
    224. 

  224. !***  Begin debugging convection
    225. 

  225.       IMD=(IMS+IME)/2
    226. 

  226.       JMD=(JMS+JME)/2
    227. 

  227.       PRINT_DIAG=.FALSE.
    228. 

  228. !***  End debugging convection
    229. 

  229. 

  230.       IF(run_param)THEN
    231. 

  231. !
    232. 

  232.         DO J=JTS,JTE
    233. 

  233.         DO I=ITS,ITE
    234. 

  234.           CU_ACT_FLAG(I,J)=.TRUE.
    235. 

  235.         ENDDO
    236. 

  236.         ENDDO
    237. 

  237. 

  238. !
    239. 

  239.         DTCNVC=DT*STEPCU
    240. 

  240. !
    241. 

  241.         DO J=JTS,JTE  
    242. 

  242.         DO I=ITS,ITE
    243. 

  243. !
    244. 

  244.           DO K=KTS,KTE
    245. 

  245.             DQDT(K)=0.
    246. 

  246.             DTDT(K)=0.
    247. 

  247.           ENDDO
    248. 

  248. !
    249. 

  249.           RAINCV(I,J)=0.
    250. 

  250.           PRATEC(I,J)=0.
    251. 

  251.           PCPCOL=0.
    252. 

  252.           PSFC=PINT(I,LOWLYR(I,J),J)
    253. 

  253.           PTOP=PINT(I,KTE+1,J)      ! KTE+1=KME
    254. 

  254. !
    255. 

  255. !***  CONVERT TO BMJ LAND MASK (1.0 FOR SEA; 0.0 FOR LAND)
    256. 

  256. !
    257. 

  257.           LANDMASK=XLAND(I,J)-1.
    258. 

  258. !
    259. 

  259. !***  FILL 1-D VERTICAL ARRAYS 
    260. 

  260. !***  AND FLIP DIRECTION SINCE BMJ SCHEME 
    261. 

  261. !***  COUNTS DOWNWARD FROM THE DOMAIN'S TOP
    262. 

  262. !
    263. 

  263.           DO K=KTS,KTE
    264. 

  264.             KFLIP=KTE+1-K
    265. 

  265. !
    266. 

  266. !***  CONVERT FROM MIXING RATIO TO SPECIFIC HUMIDITY
    267. 

  267. !
    268. 

  268.             QCOL(K)=MAX(EPSQ,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
    269. 

  269.             TCOL(K)=T(I,KFLIP,J)
    270. 

  270.             PCOL(K)=PMID(I,KFLIP,J)
    271. 

  271. !           DPCOL(K)=PINT(I,KFLIP,J)-PINT(I,KFLIP+1,J)
    272. 

  272.             DPCOL(K)=RHO(I,KFLIP,J)*G*DZ8W(I,KFLIP,J)
    273. 

  273.           ENDDO
    274. 

  274. !
    275. 

  275. !***  LOWEST LAYER ABOVE GROUND MUST ALSO BE FLIPPED
    276. 

  276. !
    277. 

  277.           LMH=KTE+1-LOWLYR(I,J)
    278. 

  278.           LPBL=KTE+1-KPBL(I,J)
    279. 

  279. !-----------------------------------------------------------------------
    280. 

  280. !***
    281. 

  281. !***  CALL CONVECTION
    282. 

  282. !***
    283. 

  283. !-----------------------------------------------------------------------
    284. 

  284. !***  Begin debugging convection
    285. 

  285. !         PRINT_DIAG=.FALSE.
    286. 

  286. !         IF(I==IMD.AND.J==JMD)PRINT_DIAG=.TRUE.
    287. 

  287. !***  End debugging convection
    288. 

  288. !-----------------------------------------------------------------------
    289. 

  289.           CALL BMJ(ITIMESTEP,I,J,DTCNVC,LMH,LANDMASK,CLDEFI(I,J)        &
    290. 

  290.      &            ,DPCOL,PCOL,QCOL,TCOL,PSFC,PTOP                       &
    291. 

  291.      &            ,DQDT,DTDT,PCPCOL,LBOT,LTOP,LPBL                      &
    292. 

  292.      &            ,CP,R,ELWV,ELIV,G,TFRZ,D608                           &   
    293. 

  293.      &            ,PRINT_DIAG                                           &   
    294. 

  294.      &            ,IDS,IDE,JDS,JDE,KDS,KDE                              &     
    295. 

  295.      &            ,IMS,IME,JMS,JME,KMS,KME                              &
    296. 

  296.      &            ,ITS,ITE,JTS,JTE,KTS,KTE)
    297. 

  297. !-----------------------------------------------------------------------
    298. 

  298. ! 
    299. 

  299. !***  COMPUTE HEATING AND MOISTENING TENDENCIES
    300. 

  300. !
    301. 

  301.           IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN )) THEN
    302. 

  302.             DO K=KTS,KTE
    303. 

  303.               KFLIP=KTE+1-K
    304. 

  304.               RTHCUTEN(I,K,J)=DTDT(KFLIP)/PI(I,K,J)
    305. 

  305. !
    306. 

  306. !***  CONVERT FROM SPECIFIC HUMIDTY BACK TO MIXING RATIO
    307. 

  307. !
    308. 

  308.               RQVCUTEN(I,K,J)=DQDT(KFLIP)/(1.-QCOL(KFLIP))**2
    309. 

  309.             ENDDO
    310. 

  310.           ENDIF
    311. 

  311. !
    312. 

  312. !***  ALL UNITS IN BMJ SCHEME ARE MKS, THUS CONVERT PRECIP FROM METERS
    313. 

  313. !***  TO MILLIMETERS PER STEP FOR OUTPUT.
    314. 

  314. !
    315. 

  315.           RAINCV(I,J)=PCPCOL*1.E3/STEPCU
    316. 

  316.           PRATEC(I,J)=PCPCOL*1.E3/(STEPCU * DT)
    317. 

  317. !
    318. 

  318. !***  CONVECTIVE CLOUD TOP AND BOTTOM FROM THIS CALL
    319. 

  319. !
    320. 

  320.           CUTOP(I,J)=REAL(KTE+1-LTOP)
    321. 

  321.           CUBOT(I,J)=REAL(KTE+1-LBOT)
    322. 

  322. !
    323. 

  323. !-----------------------------------------------------------------------
    324. 

  324. !***  Begin debugging convection
    325. 

  325.           IF(PRINT_DIAG)THEN
    326. 

  326.             DELT=0.
    327. 

  327.             DELQ=0.
    328. 

  328.             PLYR=0.
    329. 

  329.             IF(LBOT>0.AND.LTOP<LBOT)THEN
    330. 

  330.               DO K=LTOP,LBOT
    331. 

  331.                 PLYR=PLYR+DPCOL(K)
    332. 

  332.                 DELQ=DELQ+DPCOL(K)*DTCNVC*ABS(DQDT(K))
    333. 

  333.                 DELT=DELT+DPCOL(K)*DTCNVC*ABS(DTDT(K))
    334. 

  334.               ENDDO
    335. 

  335.               DELQ=DELQ/PLYR
    336. 

  336.               DELT=DELT/PLYR
    337. 

  337.             ENDIF
    338. 

  338. !
    339. 

  339.             WRITE(6,"(2a,2i4,3e12.4,f7.2,4i3)") &
    340. 

  340.                  '{cu3 i,j,PCPCOL,DTavg,DQavg,PLYR,'  &
    341. 

  341.                  ,'LBOT,LTOP,CUBOT,CUTOP = '  &
    342. 

  342.                  ,i,j, PCPCOL,DELT,1000.*DELQ,.01*PLYR  &
    343. 

  343.                  ,LBOT,LTOP,NINT(CUBOT(I,J)),NINT(CUTOP(I,J))
    344. 

  344. !
    345. 

  345.             IF(PLYR> 0.)THEN
    346. 

  346.               DO K=LBOT,LTOP,-1
    347. 

  347.                 KFLIP=KTE+1-K
    348. 

  348.                 WRITE(6,"(a,i3,2e12.4,f7.2)") '{cu3a KFLIP,DT,DQ,DP = ' &
    349. 

  349.                      ,KFLIP,DTCNVC*DTDT(K),1000.*DTCNVC*DQDT(K),.01*DPCOL(K)
    350. 

  350.               ENDDO
    351. 

  351.             ENDIF
    352. 

  352.           ENDIF
    353. 

  353. !***  End debugging convection
    354. 

  354. !-----------------------------------------------------------------------
    355. 

  355. !
    356. 

  356.         ENDDO
    357. 

  357.         ENDDO
    358. 

  358. !
    359. 

  359.       ENDIF
    360. 

  360. !
    361. 

  361.       END SUBROUTINE BMJDRV
    362. 

  362. !-----------------------------------------------------------------------
    363. 

  363. !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    364. 

  364. !-----------------------------------------------------------------------
    365. 

  365.                           SUBROUTINE BMJ                                &
    366. 

  366. !-----------------------------------------------------------------------
    367. 

  367.      & (ITIMESTEP,I,J,DTCNVC,LMH,SM,CLDEFI                              &
    368. 

  368.      & ,DPRS,PRSMID,Q,T,PSFC,PT                                         &
    369. 

  369.      & ,DQDT,DTDT,PCPCOL,LBOT,LTOP,LPBL                                 &
    370. 

  370.      & ,CP,R,ELWV,ELIV,G,TFRZ,D608                                      &
    371. 

  371.      & ,PRINT_DIAG                                                      &   
    372. 

  372.      & ,IDS,IDE,JDS,JDE,KDS,KDE                                         &
    373. 

  373.      & ,IMS,IME,JMS,JME,KMS,KME                                         &
    374. 

  374.      & ,ITS,ITE,JTS,JTE,KTS,KTE)
    375. 

  375. !-----------------------------------------------------------------------
    376. 

  376.       IMPLICIT NONE
    377. 

  377. !-----------------------------------------------------------------------
    378. 

  378.       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
    379. 

  379.                            ,IMS,IME,JMS,JME,KMS,KME                     &
    380. 

  380.                            ,ITS,ITE,JTS,JTE,KTS,KTE                     &
    381. 

  381.                            ,I,J,ITIMESTEP
    382. 

  382. ! 
    383. 

  383.       INTEGER,INTENT(IN) :: LMH,LPBL
    384. 

  384. !
    385. 

  385.       INTEGER,INTENT(OUT) :: LBOT,LTOP
    386. 

  386. !
    387. 

  387.       REAL,INTENT(IN) :: CP,D608,DTCNVC,ELIV,ELWV,G,PSFC,PT,R,SM,TFRZ
    388. 

  388. !
    389. 

  389.       REAL,DIMENSION(KTS:KTE),INTENT(IN) :: DPRS,PRSMID,Q,T
    390. 

  390. !
    391. 

  391.       REAL,INTENT(INOUT) :: CLDEFI,PCPCOL
    392. 

  392. !
    393. 

  393.       REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: DQDT,DTDT
    394. 

  394. !
    395. 

  395. !-----------------------------------------------------------------------
    396. 

  396. !***  DEFINE LOCAL VARIABLES
    397. 

  397. !-----------------------------------------------------------------------
    398. 

  398. !                                                            
    399. 

  399.       REAL,DIMENSION(KTS:KTE) :: APEK,APESK,EL,FPK                      &
    400. 

  400.                                 ,PK,PSK,QK,QREFK,QSATK                  &
    401. 

  401.                                 ,THERK,THEVRF,THSK                      &
    402. 

  402.                                 ,THVMOD,THVREF,TK,TREFK
    403. 

  403.       REAL,DIMENSION(KTS:KTE) :: APE,DIFQ,DIFT,THEE,THES,TREF
    404. 

  404. !
    405. 

  405.       REAL,DIMENSION(KTS:KTE) :: CPE,CPEcnv,DTV,DTVcnv,THEScnv    !<-- CPE for shallow convection buoyancy check (24 Aug 2006)
    406. 

  406. !
    407. 

  407.       LOGICAL :: DEEP,SHALLOW
    408. 

  408. !
    409. 

  409. !***  Begin debugging convection
    410. 

  410.       LOGICAL :: PRINT_DIAG
    411. 

  411. !***  End debugging convection
    412. 

  412. !
    413. 

  413. !-----------------------------------------------------------------------
    414. 

  414. !***
    415. 

  415. !***  LOCAL SCALARS
    416. 

  416. !***
    417. 

  417. !-----------------------------------------------------------------------
    418. 

  418.       REAL :: APEKL,APEKXX,APEKXY,APES,APESTS                           &
    419. 

  419.      &            ,AVRGT,AVRGTL,BQ,BQK,BQS00K,BQS10K                    &
    420. 

  420.      &            ,CAPA,CUP,DEN,DENTPY,DEPMIN,DEPTH                     &
    421. 

  421.      &            ,DEPWL,DHDT,DIFQL,DIFTL,DP,DPKL,DPLO,DPMIX,DPOT       &
    422. 

  422.      &            ,DPUP,DQREF,DRHDP,DRHEAT,DSP                          &
    423. 

  423.      &            ,DSP0,DSP0K,DSPB,DSPBK,DSPT,DSPTK                     &
    424. 

  424.      &            ,DSQ,DST,DSTQ,DTHEM,DTDP,EFI                          &
    425. 

  425.      &            ,FEFI,FFUP,FPRS,FPTK,HCORR                            &
    426. 

  426.      &            ,OTSUM,P,P00K,P01K,P10K,P11K                          &
    427. 

  427.      &            ,PART1,PART2,PART3,PBOT,PBOTFC,PBTK                   &
    428. 

  428.      &            ,PK0,PKB,PKL,PKT,PKXXXX,PKXXXY                        &
    429. 

  429.      &            ,PLMH,PELEVFC,PBTmx,plo,POTSUM,PP1,PPK,PRECK          &
    430. 

  430.      &            ,PRESK,PSP,PSUM,PTHRS,PTOP,PTPK,PUP                   &
    431. 

  431.      &            ,QBT,QKL,QNEW,QOTSUM,QQ1,QQK,QRFKL                    &
    432. 

  432.      &            ,QRFTP,QSP,QSUM,QUP,RDP0T                             &
    433. 

  433.      &            ,RDPSUM,RDTCNVC,RHH,RHL,RHMAX,ROTSUM,RTBAR,RHAVG      &
    434. 

  434.      &            ,SM1,SMIX,SQ,SQK,SQS00K,SQS10K,STABDL,SUMDE,SUMDP     &
    435. 

  435.      &            ,SUMDT,TAUK,TAUKSC,TCORR,THBT,THERKX,THERKY           &
    436. 

  436.      &            ,THESP,THSKL,THTPK,THVMKL,TKL,TNEW                    &
    437. 

  437.      &            ,TQ,TQK,TREFKX,TRFKL,trmlo,trmup,TSKL,tsp,TTH         &
    438. 

  438.      &            ,TTHK,TUP                                             &
    439. 

  439.      &            ,CAPEcnv,PSPcnv,THBTcnv,CAPEtrigr,CAPE                &
    440. 

  440.      &            ,TLEV2,QSAT1,QSAT2,RHSHmax
    441. 

  441. !
    442. 

  442.       INTEGER :: IQ,IQTB,IT,ITER,ITREFI,ITTB,ITTBK,KB,KNUMH,KNUML       &
    443. 

  443.      &          ,L,L0,L0M1,LB,LBM1,LCOR,LPT1                            &
    444. 

  444.      &          ,LQM,LSHU,LTP1,LTP2,LTSH, LBOTcnv,LTOPcnv,LMID
    445. 

  445. !-----------------------------------------------------------------------
    446. 

  446. !
    447. 

  447.       REAL,PARAMETER :: DSPBSL=DSPBFL*FSL,DSP0SL=DSP0FL*FSL             &
    448. 

  448.      &                 ,DSPTSL=DSPTFL*FSL                               &
    449. 

  449.      &                 ,DSPBSS=DSPBFS*FSS,DSP0SS=DSP0FS*FSS             &
    450. 

  450.      &                 ,DSPTSS=DSPTFS*FSS
    451. 

  451. !
    452. 

  452.       REAL,PARAMETER :: ELEVFC=0.6,STEFI=1.
    453. 

  453. !
    454. 

  454.       REAL,PARAMETER :: SLOPBL=(DSPBFL-DSPBSL)/(1.-EFIMN)               &
    455. 

  455.      &                 ,SLOP0L=(DSP0FL-DSP0SL)/(1.-EFIMN)               &
    456. 

  456.      &                 ,SLOPTL=(DSPTFL-DSPTSL)/(1.-EFIMN)               &
    457. 

  457.      &                 ,SLOPBS=(DSPBFS-DSPBSS)/(1.-EFIMN)               &
    458. 

  458.      &                 ,SLOP0S=(DSP0FS-DSP0SS)/(1.-EFIMN)               &
    459. 

  459.      &                 ,SLOPTS=(DSPTFS-DSPTSS)/(1.-EFIMN)               &
    460. 

  460.      &                 ,SLOPST=(STABDF-STABDS)/(1.-EFIMN)               &
    461. 

  461.      &                 ,SLOPE=(1.-EFMNT)/(1.-EFIMN)
    462. 

  462. !
    463. 

  463.       REAL :: A23M4L,CPRLG,ELOCP,RCP,QWAT
    464. 

  464. !-----------------------------------------------------------------------
    465. 

  465. !***********************************************************************
    466. 

  466. !-----------------------------------------------------------------------
    467. 

  467.       CAPA=R/CP
    468. 

  468.       CPRLG=CP/(ROW*G*ELWV)
    469. 

  469.       ELOCP=ELIWV/CP
    470. 

  470.       RCP=1./CP
    471. 

  471.       A23M4L=A2*(A3-A4)*ELWV
    472. 

  472.       RDTCNVC=1./DTCNVC
    473. 

  473.       DEPMIN=PSH*PSFC*RSFCP
    474. 

  474. !
    475. 

  475.       DEEP=.FALSE.
    476. 

  476.       SHALLOW=.FALSE.
    477. 

  477. !
    478. 

  478.       DSP0=0.
    479. 

  479.       DSPB=0.
    480. 

  480.       DSPT=0.
    481. 

  481. !-----------------------------------------------------------------------
    482. 

  482.       TAUK=DTCNVC/TREL
    483. 

  483.       TAUKSC=DTCNVC/(1.0*TREL) 
    484. 

  484. !-----------------------------------------------------------------------
    485. 

  485. !-----------------------------PREPARATIONS------------------------------
    486. 

  486. !-----------------------------------------------------------------------
    487. 

  487.       LBOT=LMH
    488. 

  488.       PCPCOL=0.
    489. 

  489.       TREF(KTS)=T(KTS)
    490. 

  490. !
    491. 

  491.       DO L=KTS,LMH
    492. 

  492.         APESTS=PRSMID(L)
    493. 

  493.         APE(L)=(1.E5/APESTS)**CAPA
    494. 

  494.         CPEcnv(L)=0.
    495. 

  495.         DTVcnv(L)=0.
    496. 

  496.         THEScnv(L)=0.
    497. 

  497.       ENDDO
    498. 

  498. !
    499. 

  499. !-----------------------------------------------------------------------
    500. 

  500. !----------------SEARCH FOR MAXIMUM BUOYANCY LEVEL----------------------
    501. 

  501. !-----------------------------------------------------------------------
    502. 

  502. !
    503. 

  503.       PLMH=PRSMID(LMH)
    504. 

  504.       PELEVFC=PLMH*ELEVFC
    505. 

  505.       PBTmx=PRSMID(LMH)-PONE
    506. 

  506.       CAPEcnv=0.
    507. 

  507.       PSPcnv=0.
    508. 

  508.       THBTcnv=0.
    509. 

  509.       LBOTcnv=LBOT
    510. 

  510.       LTOPcnv=LBOT
    511. 

  511. !
    512. 

  512. !-----------------------------------------------------------------------
    513. 

  513. !----------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-----------------
    514. 

  514. !-----------------------------------------------------------------------
    515. 

  515. !
    516. 

  516.       max_buoy_loop: DO KB=LMH,1,-1
    517. 

  517. !
    518. 

  518. !-----------------------------------------------------------------------
    519. 

  519. !
    520. 

  520.         PKL=PRSMID(KB)
    521. 

  521. !       IF (PKL<PELEVFC .OR. T(KB)<=TFRZ) EXIT
    522. 

  522.         IF (PKL<PELEVFC) EXIT
    523. 

  523.         LBOT=LMH
    524. 

  524.         LTOP=LMH
    525. 

  525. !
    526. 

  526. !-----------------------------------------------------------------------
    527. 

  527. !***  SEARCH OVER A SCALED DEPTH IN FINDING THE PARCEL
    528. 

  528. !***  WITH THE MAX THETA-E 
    529. 

  529. !-----------------------------------------------------------------------
    530. 

  530. !
    531. 

  531.         QBT=Q(KB)
    532. 

  532.         THBT=T(KB)*APE(KB)
    533. 

  533.         TTH=(THBT-THL)*RDTH
    534. 

  534.         QQ1=TTH-AINT(TTH)
    535. 

  535.         ITTB=INT(TTH)+1
    536. 

  536. !----------------KEEPING INDICES WITHIN THE TABLE-----------------------
    537. 

  537.         IF(ITTB<1)THEN
    538. 

  538.           ITTB=1
    539. 

  539.           QQ1=0.
    540. 

  540.         ELSE IF(ITTB>=JTB)THEN
    541. 

  541.           ITTB=JTB-1
    542. 

  542.           QQ1=0.
    543. 

  543.         ENDIF
    544. 

  544. !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY---------------
    545. 

  545.         ITTBK=ITTB
    546. 

  546.         BQS00K=QS0(ITTBK)
    547. 

  547.         SQS00K=SQS(ITTBK)
    548. 

  548.         BQS10K=QS0(ITTBK+1)
    549. 

  549.         SQS10K=SQS(ITTBK+1)
    550. 

  550. !--------------SCALING SPEC. HUMIDITY & TABLE INDEX---------------------
    551. 

  551.         BQ=(BQS10K-BQS00K)*QQ1+BQS00K
    552. 

  552.         SQ=(SQS10K-SQS00K)*QQ1+SQS00K
    553. 

  553.         TQ=(QBT-BQ)/SQ*RDQ
    554. 

  554.         PP1=TQ-AINT(TQ)
    555. 

  555.         IQTB=INT(TQ)+1
    556. 

  556. !----------------KEEPING INDICES WITHIN THE TABLE-----------------------
    557. 

  557.         IF(IQTB<1)THEN
    558. 

  558.           IQTB=1
    559. 

  559.           PP1=0.
    560. 

  560.         ELSE IF(IQTB>=ITB)THEN
    561. 

  561.           IQTB=ITB-1
    562. 

  562.           PP1=0.
    563. 

  563.         ENDIF
    564. 

  564. !--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.-------
    565. 

  565.         IQ=IQTB
    566. 

  566.         IT=ITTB
    567. 

  567.         P00K=PTBL(IQ  ,IT  )
    568. 

  568.         P10K=PTBL(IQ+1,IT  )
    569. 

  569.         P01K=PTBL(IQ  ,IT+1)
    570. 

  570.         P11K=PTBL(IQ+1,IT+1)
    571. 

  571. !
    572. 

  572. !--------------SATURATION POINT VARIABLES AT THE BOTTOM-----------------
    573. 

  573. !
    574. 

  574.         PSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1                        &
    575. 

  575.      &          +(P00K-P10K-P01K+P11K)*PP1*QQ1
    576. 

  576.         APES=(1.E5/PSP)**CAPA
    577. 

  577.         THESP=THBT*EXP(ELOCP*QBT*APES/THBT)
    578. 

  578. !
    579. 

  579. !-----------------------------------------------------------------------
    580. 

  580. !-----------CHOOSE CLOUD BASE AS MODEL LEVEL JUST BELOW PSP-------------
    581. 

  581. !-----------------------------------------------------------------------
    582. 

  582. !
    583. 

  583.         DO L=KTS,LMH-1
    584. 

  584.           P=PRSMID(L)
    585. 

  585.           IF(P<PSP.AND.P>=PQM)LBOT=L+1
    586. 

  586.         ENDDO
    587. 

  587. !***
    588. 

  588. !*** WARNING: LBOT MUST NOT BE > LMH-1 IN SHALLOW CONVECTION
    589. 

  589. !*** MAKE SURE CLOUD BASE IS AT LEAST PONE ABOVE THE SURFACE
    590. 

  590. !***
    591. 

  591.         PBOT=PRSMID(LBOT)
    592. 

  592.         IF(PBOT>=PBTmx.OR.LBOT>=LMH)THEN
    593. 

  593.           DO L=KTS,LMH-1
    594. 

  594.             P=PRSMID(L)
    595. 

  595.             IF(P<PBTmx)LBOT=L
    596. 

  596.           ENDDO
    597. 

  597.           PBOT=PRSMID(LBOT)
    598. 

  598.         ENDIF 
    599. 

  599. !
    600. 

  600. !-----------------------------------------------------------------------
    601. 

  601. !----------------CLOUD TOP COMPUTATION----------------------------------
    602. 

  602. !-----------------------------------------------------------------------
    603. 

  603. !
    604. 

  604.         LTOP=LBOT
    605. 

  605.         PTOP=PBOT
    606. 

  606.         DO L=LMH,KTS,-1
    607. 

  607.           THES(L)=THESP
    608. 

  608.         ENDDO
    609. 

  609. !
    610. 

  610. !-----------------------------------------------------------------------
    611. 

  611. !### BEGIN: ###########  WARNING  ###########  WARNING  ###########
    612. 

  612. !-----------------------------------------------------------------------
    613. 

  613. !
    614. 

  614. !### IMPORTANT: THIS "DO KB=LMH,1,-1" loop must be broken up into two
    615. 

  615. !    separate loops in order for entrainment as programmed below to work
    616. 

  616. !    properly.  
    617. 

  617. !
    618. 

  618. !---------------  ENTRAINMENT DURING PARCEL ASCENT  --------------------
    619. 

  619. !
    620. 

  620. !        DO L=LMH,KB,-1
    621. 

  621. !          THES(L)=THESP
    622. 

  622. !        ENDDO
    623. 

  623. !
    624. 

  624. !        DO L=KTS,LMH
    625. 

  625. !          THEE(L)=THES(L)
    626. 

  626. !        ENDDO
    627. 

  627. !!
    628. 

  628. !        FEFI=(CLDEFI-EFIMN)*SLOPE+EFMNT
    629. 

  629. !        FFUP=FUP/(FEFI*FEFI)
    630. 

  630. !!
    631. 

  631. !        IF(PBOT>ENPLO)THEN
    632. 

  632. !          FPRS=1.
    633. 

  633. !        ELSEIF(PBOT>ENPUP)THEN
    634. 

  634. !          FPRS=(PBOT-ENPUP)*RENDP
    635. 

  635. !        ELSE
    636. 

  636. !          FPRS=0.
    637. 

  637. !        ENDIF
    638. 

  638. !!
    639. 

  639. !        FFUP=FFUP*FPRS*FPRS*0.5
    640. 

  640. !        DPUP=DPRS(KB)
    641. 

  641. !!
    642. 

  642. !        DO L=KB-1,KTS,-1
    643. 

  643. !          DPLO=DPUP
    644. 

  644. !          DPUP=DPRS(L)
    645. 

  645. !!
    646. 

  646. !          THES(L)=((-FFUP*DPLO+1.)*THES(L+1)                           &
    647. 

  647. !     &            +(THEE(L)*DPUP+THEE(L+1)*DPLO)*FFUP)                 &
    648. 

  648. !     &           /(FFUP*DPUP+1.)
    649. 

  649. !      ENDDO
    650. 

  650. !
    651. 

  651. !-----------------------------------------------------------------------
    652. 

  652. !### END: ###########  WARNING  ###########  WARNING  ###########
    653. 

  653. !-----------------------------------------------------------------------
    654. 

  654. !!
    655. 

  655. !-----------------------------------------------------------------------
    656. 

  656. !!***  COMPUTE PARCEL TEMPERATURE ALONG THE ASCENT TRAJECTORY
    657. 

  657. !!***  SCALING PRESSURE & TT TABLE INDEX.
    658. 

  658. !-----------------------------------------------------------------------
    659. 

  659. !!
    660. 

  660. !!
    661. 

  661. !       DO L=LMH,KTS,-1
    662. 

  662. !!
    663. 

  663. !         PRESK=PRSMID(L)
    664. 

  664. !!
    665. 

  665. !         IF(PRESK<PLQ)THEN
    666. 

  666. !           CALL TTBLEX(ITB,JTB,PL,PRESK,RDP,RDTHE                      &
    667. 

  667. !     &                ,STHE,THE0,THES(L),TTBL,TREF(L))
    668. 

  668. !         ELSE
    669. 

  669. !           CALL TTBLEX(ITBQ,JTBQ,PLQ,PRESK,RDPQ,RDTHEQ                 &
    670. 

  670. !     &                ,STHEQ,THE0Q,THES(L),TTBLQ,TREF(L))
    671. 

  671. !         ENDIF
    672. 

  672. !!
    673. 

  673. !       ENDDO
    674. 

  674. !!
    675. 

  675. !!-----------------------------------------------------------------------
    676. 

  676. !!----------------BUOYANCY CHECK-----------------------------------------
    677. 

  677. !!-----------------------------------------------------------------------
    678. 

  678. !!
    679. 

  679. !       DO L=LMH,KTS,-1
    680. 

  680. !         IF(TREF(L)>T(L)-DTTOP)LTOP=L
    681. 

  681. !       ENDDO
    682. 

  682. !!
    683. 

  683. !!***  CLOUD TOP PRESSURE
    684. 

  684. !!
    685. 

  685. !       PTOP=PRSMID(LTOP)
    686. 

  686. !
    687. 

  687. !------------------FIRST ENTROPY CHECK----------------------------------
    688. 

  688. !
    689. 

  689.         DO L=KTS,LMH
    690. 

  690.           CPE(L)=0.
    691. 

  691.           DTV(L)=0.
    692. 

  692.         ENDDO
    693. 

  693. !-----------------------------------------------------------------------
    694. 

  694. !       lbot_ltop: IF(LBOT>LTOP)THEN
    695. 

  695. !-----------------------------------------------------------------------
    696. 

  696. !-- Begin: Buoyancy check including deep convection (24 Aug 2006) 
    697. 

  697. !-----------------------------------------------------------------------
    698. 

  698.           DENTPY=0.
    699. 

  699.           L=KB
    700. 

  700.           PLO=PRSMID(L)
    701. 

  701.           TRMLO=0.
    702. 

  702.           CAPEtrigr=DTPtrigr/T(LBOT)
    703. 

  703. !
    704. 

  704. !--- Below cloud base
    705. 

  705. !
    706. 

  706.           IF(KB>LBOT) THEN
    707. 

  707.             DO L=KB-1,LBOT+1,-1
    708. 

  708.               PUP=PRSMID(L)
    709. 

  709.               TUP=THBT/APE(L)
    710. 

  710.               DP=PLO-PUP
    711. 

  711.               TRMUP=(TUP*(QBT*0.608+1.)                                 &
    712. 

  712.      &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
    713. 

  713.      &             /(T(L)*(Q(L)*0.608+1.))
    714. 

  714.               DTV(L)=TRMLO+TRMUP
    715. 

  715.               DENTPY=DTV(L)*DP+DENTPY
    716. 

  716.               CPE(L)=DENTPY
    717. 

  717.               IF (DENTPY < CAPEtrigr) GO TO 170
    718. 

  718.               PLO=PUP
    719. 

  719.               TRMLO=TRMUP
    720. 

  720.             ENDDO
    721. 

  721.           ELSE
    722. 

  722.             L=LBOT+1
    723. 

  723.             PLO=PRSMID(L)
    724. 

  724.             TUP=THBT/APE(L)
    725. 

  725.             TRMLO=(TUP*(QBT*0.608+1.)                                   &
    726. 

  726.      &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
    727. 

  727.      &             /(T(L)*(Q(L)*0.608+1.))
    728. 

  728.           ENDIF  ! IF(KB>LBOT) THEN
    729. 

  729. !
    730. 

  730. !--- At cloud base
    731. 

  731. !
    732. 

  732.           L=LBOT
    733. 

  733.           PUP=PSP
    734. 

  734.           TUP=THBT/APES
    735. 

  735.           TSP=(T(L+1)-T(L))/(PLO-PBOT)                                  &
    736. 

  736.      &       *(PUP-PBOT)+T(L)
    737. 

  737.           QSP=(Q(L+1)-Q(L))/(PLO-PBOT)                                  &
    738. 

  738.      &       *(PUP-PBOT)+Q(L)
    739. 

  739.           DP=PLO-PUP
    740. 

  740.           TRMUP=(TUP*(QBT*0.608+1.)                                     &
    741. 

  741.      &          -TSP*(QSP*0.608+1.))*0.5                                &
    742. 

  742.      &         /(TSP*(QSP*0.608+1.))
    743. 

  743.           DTV(L)=TRMLO+TRMUP
    744. 

  744.           DENTPY=DTV(L)*DP+DENTPY
    745. 

  745.           CPE(L)=DENTPY
    746. 

  746.           DTV(L)=DTV(L)*DP
    747. 

  747.           PLO=PUP
    748. 

  748.           TRMLO=TRMUP
    749. 

  749.           PUP=PRSMID(L)
    750. 

  750. !
    751. 

  751. !--- Calculate updraft temperature along moist adiabat (TUP)
    752. 

  752. !
    753. 

  753.           IF(PUP<PLQ)THEN
    754. 

  754.             CALL TTBLEX(ITB,JTB,PL,PUP,RDP,RDTHE                        &
    755. 

  755.      &                 ,STHE,THE0,THES(L),TTBL,TUP)
    756. 

  756.           ELSE
    757. 

  757.             CALL TTBLEX(ITBQ,JTBQ,PLQ,PUP,RDPQ,RDTHEQ                   &
    758. 

  758.      &                 ,STHEQ,THE0Q,THES(L),TTBLQ,TUP)
    759. 

  759.           ENDIF
    760. 

  760. !
    761. 

  761.           QUP=PQ0/PUP*EXP(A2*(TUP-A3)/(TUP-A4))
    762. 

  762.           QWAT=QBT-QUP  !-- Water loading effects, reversible adiabat
    763. 

  763.           DP=PLO-PUP
    764. 

  764.           TRMUP=(TUP*(QUP*0.608+1.-QWAT)                                &
    765. 

  765.      &          -T(L)*(Q(L)*0.608+1.))*0.5                              &
    766. 

  766.      &         /(T(L)*(Q(L)*0.608+1.))
    767. 

  767.           DENTPY=(TRMLO+TRMUP)*DP+DENTPY
    768. 

  768.           CPE(L)=DENTPY
    769. 

  769.           DTV(L)=(DTV(L)+(TRMLO+TRMUP)*DP)/(PRSMID(LBOT+1)-PRSMID(LBOT))
    770. 

  770. !
    771. 

  771.           IF (DENTPY < CAPEtrigr) GO TO 170
    772. 

  772. !
    773. 

  773.           PLO=PUP
    774. 

  774.           TRMLO=TRMUP
    775. 

  775. !
    776. 

  776. !-----------------------------------------------------------------------
    777. 

  777. !--- In cloud above cloud base
    778. 

  778. !-----------------------------------------------------------------------
    779. 

  779. !
    780. 

  780.           DO L=LBOT-1,KTS,-1
    781. 

  781.             PUP=PRSMID(L)
    782. 

  782. !
    783. 

  783. !--- Calculate updraft temperature along moist adiabat (TUP)
    784. 

  784. !
    785. 

  785.             IF(PUP<PLQ)THEN
    786. 

  786.               CALL TTBLEX(ITB,JTB,PL,PUP,RDP,RDTHE                      &
    787. 

  787.        &                 ,STHE,THE0,THES(L),TTBL,TUP)
    788. 

  788.             ELSE
    789. 

  789.               CALL TTBLEX(ITBQ,JTBQ,PLQ,PUP,RDPQ,RDTHEQ                 &
    790. 

  790.        &                 ,STHEQ,THE0Q,THES(L),TTBLQ,TUP)
    791. 

  791.             ENDIF
    792. 

  792. !
    793. 

  793.             QUP=PQ0/PUP*EXP(A2*(TUP-A3)/(TUP-A4))
    794. 

  794.             QWAT=QBT-QUP  !-- Water loading effects, reversible adiabat
    795. 

  795.             DP=PLO-PUP
    796. 

  796.             TRMUP=(TUP*(QUP*0.608+1.-QWAT)                              &
    797. 

  797.      &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
    798. 

  798.      &           /(T(L)*(Q(L)*0.608+1.))
    799. 

  799.             DTV(L)=TRMLO+TRMUP
    800. 

  800.             DENTPY=DTV(L)*DP+DENTPY
    801. 

  801.             CPE(L)=DENTPY
    802. 

  802. !
    803. 

  803.             IF (DENTPY < CAPEtrigr) GO TO 170
    804. 

  804. !
    805. 

  805.             PLO=PUP
    806. 

  806.             TRMLO=TRMUP
    807. 

  807.           ENDDO
    808. 

  808. !
    809. 

  809. !-----------------------------------------------------------------------
    810. 

  810. !
    811. 

  811. 170       LTP1=KB
    812. 

  812.           CAPE=0.
    813. 

  813. !
    814. 

  814. !-----------------------------------------------------------------------
    815. 

  815. !--- Cloud top level (LTOP) is located where CAPE is a maximum
    816. 

  816. !--- Exit cloud-top search if CAPE < CAPEtrigr
    817. 

  817. !-----------------------------------------------------------------------
    818. 

  818. !
    819. 

  819.           DO L=KB,KTS,-1
    820. 

  820.             IF (CPE(L) < CAPEtrigr) THEN
    821. 

  821.               EXIT
    822. 

  822.             ELSE IF (CPE(L) > CAPE) THEN
    823. 

  823.               LTP1=L
    824. 

  824.               CAPE=CPE(L)
    825. 

  825.             ENDIF
    826. 

  826.           ENDDO      !-- End DO L=KB,KTS,-1
    827. 

  827. !
    828. 

  828.           LTOP=MIN(LTP1,LBOT)
    829. 

  829. ! 
    830. 

  830. !-----------------------------------------------------------------------
    831. 

  831. !--------------- CHECK FOR MAXIMUM INSTABILITY  ------------------------
    832. 

  832. !-----------------------------------------------------------------------
    833. 

  833.           IF(CAPE > CAPEcnv) THEN
    834. 

  834.             CAPEcnv=CAPE
    835. 

  835.             PSPcnv=PSP
    836. 

  836.             THBTcnv=THBT
    837. 

  837.             LBOTcnv=LBOT
    838. 

  838.             LTOPcnv=LTOP
    839. 

  839.             DO L=LMH,KTS,-1
    840. 

  840.               CPEcnv(L)=CPE(L)
    841. 

  841.               DTVcnv(L)=DTV(L)
    842. 

  842.               THEScnv(L)=THES(L)
    843. 

  843.             ENDDO
    844. 

  844.           ENDIF    ! End IF(CAPE > CAPEcnv) THEN
    845. 

  845. !
    846. 

  846. !       ENDIF lbot_ltop
    847. 

  847. !
    848. 

  848. !-----------------------------------------------------------------------
    849. 

  849. !
    850. 

  850.       ENDDO max_buoy_loop
    851. 

  851. !
    852. 

  852. !-----------------------------------------------------------------------
    853. 

  853. !------------------------  MAXIMUM INSTABILITY  ------------------------
    854. 

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

  855. !
    856. 

  856.       IF(CAPEcnv > 0.) THEN
    857. 

  857.         PSP=PSPcnv
    858. 

  858.         THBT=THBTcnv
    859. 

  859.         LBOT=LBOTcnv
    860. 

  860.         LTOP=LTOPcnv
    861. 

  861.         PBOT=PRSMID(LBOT)
    862. 

  862.         PTOP=PRSMID(LTOP)
    863. 

  863. !
    864. 

  864.         DO L=LMH,KTS,-1
    865. 

  865.           CPE(L)=CPEcnv(L)
    866. 

  866.           DTV(L)=DTVcnv(L)
    867. 

  867.           THES(L)=THEScnv(L)
    868. 

  868.         ENDDO
    869. 

  869. !
    870. 

  870.       ENDIF
    871. 

  871. !
    872. 

  872. !-----------------------------------------------------------------------
    873. 

  873. !-----  Quick exit if cloud is too thin or no CAPE is present  ---------
    874. 

  874. !-----------------------------------------------------------------------
    875. 

  875. !
    876. 

  876.       IF(PTOP>PBOT-PNO.OR.LTOP>LBOT-2.OR.CAPEcnv<=0.)THEN
    877. 

  877.         LBOT=0
    878. 

  878.         LTOP=KTE
    879. 

  879.         PBOT=PRSMID(LMH)
    880. 

  880.         PTOP=PBOT
    881. 

  881.         CLDEFI=AVGEFI*SM+STEFI*(1.-SM)
    882. 

  882.         GO TO 800
    883. 

  883.       ENDIF
    884. 

  884. !
    885. 

  885. !***  DEPTH OF CLOUD REQUIRED TO MAKE THE POINT A DEEP CONVECTION POINT
    886. 

  886. !***  IS A SCALED VALUE OF PSFC.
    887. 

  887. !
    888. 

  888.       DEPTH=PBOT-PTOP
    889. 

  889. !
    890. 

  890.       IF(DEPTH>=DEPMIN) THEN
    891. 

  891.         DEEP=.TRUE.
    892. 

  892.       ELSE
    893. 

  893.         SHALLOW=.TRUE.
    894. 

  894.         GO TO 600
    895. 

  895.       ENDIF
    896. 

  896. !
    897. 

  897. !-----------------------------------------------------------------------
    898. 

  898. !DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    899. 

  899. !DCDCDCDCDCDCDCDCDCDCDC    DEEP CONVECTION   DCDCDCDCDCDCDCDCDCDCDCDCDCD
    900. 

  900. !DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    901. 

  901. !-----------------------------------------------------------------------
    902. 

  902. !
    903. 

  903.   300 CONTINUE
    904. 

  904. !
    905. 

  905.       LB =LBOT
    906. 

  906.       EFI=CLDEFI
    907. 

  907. !-----------------------------------------------------------------------
    908. 

  908. !--------------INITIALIZE VARIABLES IN THE CONVECTIVE COLUMN------------
    909. 

  909. !-----------------------------------------------------------------------
    910. 

  910. !***
    911. 

  911. !***  ONE SHOULD NOTE THAT THE VALUES ASSIGNED TO THE ARRAY TREFK
    912. 

  912. !***  IN THE FOLLOWING LOOP ARE REALLY ONLY RELEVANT IN ANCHORING THE
    913. 

  913. !***  REFERENCE TEMPERATURE PROFILE AT LEVEL LB.  WHEN BUILDING THE
    914. 

  914. !***  REFERENCE PROFILE FROM CLOUD BASE, THEN ASSIGNING THE
    915. 

  915. !***  AMBIENT TEMPERATURE TO TREFK IS ACCEPTABLE.  HOWEVER, WHEN
    916. 

  916. !***  BUILDING THE REFERENCE PROFILE FROM SOME OTHER LEVEL (SUCH AS
    917. 

  917. !***  ONE LEVEL ABOVE THE GROUND), THEN TREFK SHOULD BE FILLED WITH
    918. 

  918. !***  THE TEMPERATURES IN TREF(L) WHICH ARE THE TEMPERATURES OF
    919. 

  919. !***  THE MOIST ADIABAT THROUGH CLOUD BASE.  BY THE TIME THE LINE 
    920. 

  920. !***  NUMBERED 450 HAS BEEN REACHED, TREFK ACTUALLY DOES HOLD THE
    921. 

  921. !***  REFERENCE TEMPERATURE PROFILE.
    922. 

  922. !***
    923. 

  923.       DO L=KTS,LMH
    924. 

  924.         DIFT  (L)=0.
    925. 

  925.         DIFQ  (L)=0.
    926. 

  926.         TKL      =T(L)
    927. 

  927.         TK    (L)=TKL
    928. 

  928.         TREFK (L)=TKL
    929. 

  929.         QKL      =Q(L)
    930. 

  930.         QK    (L)=QKL
    931. 

  931.         QREFK (L)=QKL
    932. 

  932.         PKL      =PRSMID(L)
    933. 

  933.         PK    (L)=PKL
    934. 

  934.         PSK   (L)=PKL
    935. 

  935.         APEKL    =APE(L)
    936. 

  936.         APEK  (L)=APEKL
    937. 

  937. !
    938. 

  938. !--- Calculate temperature along moist adiabat (TREF)
    939. 

  939. !
    940. 

  940.         IF(PKL<PLQ)THEN
    941. 

  941.           CALL TTBLEX(ITB,JTB,PL,PKL,RDP,RDTHE                          &
    942. 

  942.      &               ,STHE,THE0,THES(L),TTBL,TREF(L))
    943. 

  943.         ELSE
    944. 

  944.           CALL TTBLEX(ITBQ,JTBQ,PLQ,PKL,RDPQ,RDTHEQ                     &
    945. 

  945.      &               ,STHEQ,THE0Q,THES(L),TTBLQ,TREF(L))
    946. 

  946.         ENDIF
    947. 

  947.         THERK (L)=TREF(L)*APEKL
    948. 

  948.       ENDDO
    949. 

  949. !
    950. 

  950. !------------DEEP CONVECTION REFERENCE TEMPERATURE PROFILE------------
    951. 

  951. !
    952. 

  952.       LTP1=LTOP+1
    953. 

  953.       LBM1=LB-1
    954. 

  954.       PKB=PK(LB)
    955. 

  955.       PKT=PK(LTOP)
    956. 

  956.       STABDL=(EFI-EFIMN)*SLOPST+STABDS
    957. 

  957. !
    958. 

  958. !------------TEMPERATURE REFERENCE PROFILE BELOW FREEZING LEVEL-------
    959. 

  959. !
    960. 

  960.       EL(LB) = ELWV    
    961. 

  961.       L0=LB
    962. 

  962.       PK0=PK(LB)
    963. 

  963.       TREFKX=TREFK(LB)
    964. 

  964.       THERKX=THERK(LB)
    965. 

  965.       APEKXX=APEK(LB)
    966. 

  966.       THERKY=THERK(LBM1)
    967. 

  967.       APEKXY=APEK(LBM1)
    968. 

  968. !
    969. 

  969.       DO L=LBM1,LTOP,-1
    970. 

  970.         IF(T(L+1)<TFRZ)GO TO 430
    971. 

  971.         TREFKX=((THERKY-THERKX)*STABDL                                  &
    972. 

  972.      &          +TREFKX*APEKXX)/APEKXY
    973. 

  973.         TREFK(L)=TREFKX
    974. 

  974.         EL(L)=ELWV
    975. 

  975.         APEKXX=APEKXY
    976. 

  976.         THERKX=THERKY
    977. 

  977.         APEKXY=APEK(L-1)
    978. 

  978.         THERKY=THERK(L-1)
    979. 

  979.         L0=L
    980. 

  980.         PK0=PK(L0)
    981. 

  981.       ENDDO
    982. 

  982. !
    983. 

  983. !--------------FREEZING LEVEL AT OR ABOVE THE CLOUD TOP-----------------
    984. 

  984. !
    985. 

  985.       GO TO 450
    986. 

  986. !
    987. 

  987. !--------------TEMPERATURE REFERENCE PROFILE ABOVE FREEZING LEVEL-------
    988. 

  988. !
    989. 

  989.   430 L0M1=L0-1
    990. 

  990.       RDP0T=1./(PK0-PKT)
    991. 

  991.       DTHEM=THERK(L0)-TREFK(L0)*APEK(L0)
    992. 

  992. !
    993. 

  993.       DO L=LTOP,L0M1
    994. 

  994.         TREFK(L)=(THERK(L)-(PK(L)-PKT)*DTHEM*RDP0T)/APEK(L)
    995. 

  995.         EL(L)=ELWV !ELIV
    996. 

  996.       ENDDO
    997. 

  997. !
    998. 

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

  999. !--------------DEEP CONVECTION REFERENCE HUMIDITY PROFILE---------------
    1000. 

  1000. !-----------------------------------------------------------------------
    1001. 

  1001. !
    1002. 

  1002. !***  DEPWL IS THE PRESSURE DIFFERENCE BETWEEN CLOUD BASE AND
    1003. 

  1003. !***  THE FREEZING LEVEL
    1004. 

  1004. !
    1005. 

  1005.   450 CONTINUE
    1006. 

  1006.       DEPWL=PKB-PK0
    1007. 

  1007.       DEPTH=PFRZ*PSFC*RSFCP
    1008. 

  1008.       SM1=1.-SM
    1009. 

  1009.       PBOTFC=1.
    1010. 

  1010. !
    1011. 

  1011. !-------------FIRST ADJUSTMENT OF TEMPERATURE PROFILE-------------------
    1012. 

  1012. !!
    1013. 

  1013. !      SUMDT=0.
    1014. 

  1014. !      SUMDP=0.
    1015. 

  1015. !!
    1016. 

  1016. !      DO L=LTOP,LB
    1017. 

  1017. !        SUMDT=(TK(L)-TREFK(L))*DPRS(L)+SUMDT
    1018. 

  1018. !        SUMDP=SUMDP+DPRS(L)
    1019. 

  1019. !      ENDDO
    1020. 

  1020. !!
    1021. 

  1021. !      TCORR=SUMDT/SUMDP
    1022. 

  1022. !!
    1023. 

  1023. !      DO L=LTOP,LB
    1024. 

  1024. !        TREFK(L)=TREFK(L)+TCORR
    1025. 

  1025. !      ENDDO
    1026. 

  1026. !!
    1027. 

  1027. !-----------------------------------------------------------------------
    1028. 

  1028. !--------------- ITERATION LOOP FOR CLOUD EFFICIENCY -------------------
    1029. 

  1029. !-----------------------------------------------------------------------
    1030. 

  1030. !
    1031. 

  1031.       cloud_efficiency : DO ITREFI=1,ITREFI_MAX  
    1032. 

  1032. !
    1033. 

  1033. !-----------------------------------------------------------------------
    1034. 

  1034.         DSPBK=((EFI-EFIMN)*SLOPBS+DSPBSS*PBOTFC)*SM                     &
    1035. 

  1035.      &       +((EFI-EFIMN)*SLOPBL+DSPBSL*PBOTFC)*SM1
    1036. 

  1036.         DSP0K=((EFI-EFIMN)*SLOP0S+DSP0SS*PBOTFC)*SM                     &
    1037. 

  1037.      &       +((EFI-EFIMN)*SLOP0L+DSP0SL*PBOTFC)*SM1
    1038. 

  1038.         DSPTK=((EFI-EFIMN)*SLOPTS+DSPTSS*PBOTFC)*SM                     &
    1039. 

  1039.      &       +((EFI-EFIMN)*SLOPTL+DSPTSL*PBOTFC)*SM1
    1040. 

  1040. !
    1041. 

  1041. !-----------------------------------------------------------------------
    1042. 

  1042. !
    1043. 

  1043.         DO L=LTOP,LB
    1044. 

  1044. !
    1045. 

  1045. !***
    1046. 

  1046. !***  SATURATION PRESSURE DIFFERENCE
    1047. 

  1047. !***
    1048. 

  1048.           IF(DEPWL>=DEPTH)THEN
    1049. 

  1049.             IF(L<L0)THEN
    1050. 

  1050.               DSP=((PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
    1051. 

  1051.             ELSE
    1052. 

  1052.               DSP=((PKB-PK(L))*DSP0K+(PK(L)-PK0)*DSPBK)/(PKB-PK0)
    1053. 

  1053.             ENDIF
    1054. 

  1054.           ELSE
    1055. 

  1055.             DSP=DSP0K
    1056. 

  1056.             IF(L<L0)THEN
    1057. 

  1057.               DSP=((PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
    1058. 

  1058.             ENDIF
    1059. 

  1059.           ENDIF
    1060. 

  1060. !***
    1061. 

  1061. !***  HUMIDITY PROFILE
    1062. 

  1062. !***
    1063. 

  1063.           IF(PK(L)>PQM)THEN
    1064. 

  1064.             PSK(L)=PK(L)+DSP
    1065. 

  1065.             APESK(L)=(1.E5/PSK(L))**CAPA
    1066. 

  1066.             THSK(L)=TREFK(L)*APEK(L)
    1067. 

  1067.             QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSK(L)-A3*APESK(L))            &
    1068. 

  1068.      &                                /(THSK(L)-A4*APESK(L)))
    1069. 

  1069.           ELSE
    1070. 

  1070.             QREFK(L)=QK(L)
    1071. 

  1071.           ENDIF
    1072. 

  1072. !
    1073. 

  1073.         ENDDO
    1074. 

  1074. !-----------------------------------------------------------------------
    1075. 

  1075. !***
    1076. 

  1076. !***  ENTHALPY CONSERVATION INTEGRAL
    1077. 

  1077. !***
    1078. 

  1078. !-----------------------------------------------------------------------
    1079. 

  1079.         enthalpy_conservation : DO ITER=1,2
    1080. 

  1080. !
    1081. 

  1081.           SUMDE=0.
    1082. 

  1082.           SUMDP=0.
    1083. 

  1083. !
    1084. 

  1084.           DO L=LTOP,LB
    1085. 

  1085.             SUMDE=((TK(L)-TREFK(L))*CP+(QK(L)-QREFK(L))*EL(L))*DPRS(L)  &
    1086. 

  1086.      &            +SUMDE
    1087. 

  1087.             SUMDP=SUMDP+DPRS(L)
    1088. 

  1088.           ENDDO
    1089. 

  1089. !
    1090. 

  1090.           HCORR=SUMDE/(SUMDP-DPRS(LTOP))
    1091. 

  1091.           LCOR=LTOP+1
    1092. 

  1092. !***
    1093. 

  1093. !***  FIND LQM
    1094. 

  1094. !***
    1095. 

  1095.           LQM=1
    1096. 

  1096.           DO L=KTS,LB
    1097. 

  1097.             IF(PK(L)<=PQM)LQM=L
    1098. 

  1098.           ENDDO
    1099. 

  1099. !***
    1100. 

  1100. !***  ABOVE LQM CORRECT TEMPERATURE ONLY
    1101. 

  1101. !***
    1102. 

  1102.           IF(LCOR<=LQM)THEN
    1103. 

  1103.             DO L=LCOR,LQM
    1104. 

  1104.               TREFK(L)=TREFK(L)+HCORR*RCP
    1105. 

  1105.             ENDDO
    1106. 

  1106.             LCOR=LQM+1
    1107. 

  1107.           ENDIF
    1108. 

  1108. !***
    1109. 

  1109. !***  BELOW LQM CORRECT BOTH TEMPERATURE AND MOISTURE
    1110. 

  1110. !***
    1111. 

  1111.           DO L=LCOR,LB
    1112. 

  1112.             TSKL=TREFK(L)*APEK(L)/APESK(L)
    1113. 

  1113.             DHDT=QREFK(L)*A23M4L/(TSKL-A4)**2+CP
    1114. 

  1114.             TREFK(L)=HCORR/DHDT+TREFK(L)
    1115. 

  1115.             THSKL=TREFK(L)*APEK(L)
    1116. 

  1116.             QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSKL-A3*APESK(L))              &
    1117. 

  1117.      &                                /(THSKL-A4*APESK(L)))
    1118. 

  1118.           ENDDO
    1119. 

  1119. !
    1120. 

  1120.         ENDDO  enthalpy_conservation
    1121. 

  1121. !-----------------------------------------------------------------------
    1122. 

  1122. !
    1123. 

  1123. !***  HEATING, MOISTENING, PRECIPITATION
    1124. 

  1124. !
    1125. 

  1125. !-----------------------------------------------------------------------
    1126. 

  1126.         AVRGT=0.
    1127. 

  1127.         PRECK=0.
    1128. 

  1128.         DSQ=0.
    1129. 

  1129.         DST=0.
    1130. 

  1130. !
    1131. 

  1131.         DO L=LTOP,LB
    1132. 

  1132.           TKL=TK(L)
    1133. 

  1133.           DIFTL=(TREFK(L)-TKL  )*TAUK
    1134. 

  1134.           DIFQL=(QREFK(L)-QK(L))*TAUK
    1135. 

  1135.           AVRGTL=(TKL+TKL+DIFTL)
    1136. 

  1136.           DPOT=DPRS(L)/AVRGTL
    1137. 

  1137.           DST=DIFTL*DPOT+DST
    1138. 

  1138.           DSQ=DIFQL*EL(L)*DPOT+DSQ
    1139. 

  1139.           AVRGT=AVRGTL*DPRS(L)+AVRGT
    1140. 

  1140.           PRECK=DIFTL*DPRS(L)+PRECK
    1141. 

  1141.           DIFT(L)=DIFTL
    1142. 

  1142.           DIFQ(L)=DIFQL
    1143. 

  1143.         ENDDO
    1144. 

  1144. !
    1145. 

  1145.         DST=(DST+DST)*CP
    1146. 

  1146.         DSQ=DSQ+DSQ
    1147. 

  1147.         DENTPY=DST+DSQ
    1148. 

  1148.         AVRGT=AVRGT/(SUMDP+SUMDP)
    1149. 

  1149. !
    1150. 

  1150. !        DRHEAT=PRECK*CP/AVRGT
    1151. 

  1151.         DRHEAT=(PRECK*SM+MAX(1.E-7,PRECK)*(1.-SM))*CP/AVRGT !As in Eta!
    1152. 

  1152.         DRHEAT=MAX(DRHEAT,1.E-20)
    1153. 

  1153.         EFI=EFIFC*DENTPY/DRHEAT
    1154. 

  1154. !-----------------------------------------------------------------------
    1155. 

  1155.         EFI=MIN(EFI,1.)
    1156. 

  1156.         EFI=MAX(EFI,EFIMN)
    1157. 

  1157. !-----------------------------------------------------------------------
    1158. 

  1158. !
    1159. 

  1159.       ENDDO  cloud_efficiency
    1160. 

  1160. !
    1161. 

  1161. !-----------------------------------------------------------------------
    1162. 

  1162. !
    1163. 

  1163. !-----------------------------------------------------------------------
    1164. 

  1164. !---------------------- DEEP CONVECTION --------------------------------
    1165. 

  1165. !-----------------------------------------------------------------------
    1166. 

  1166. !
    1167. 

  1167.       IF(DENTPY>=EPSNTP.AND.PRECK>EPSPR)THEN
    1168. 

  1168. !
    1169. 

  1169.         CLDEFI=EFI
    1170. 

  1170.         FEFI=EFMNT+SLOPE*(EFI-EFIMN)
    1171. 

  1171.         FEFI=(DENTPY-EPSNTP)*FEFI/DENTPY
    1172. 

  1172.         PRECK=PRECK*FEFI
    1173. 

  1173. !
    1174. 

  1174. !***  UPDATE PRECIPITATION AND TENDENCIES OF TEMPERATURE AND MOISTURE
    1175. 

  1175. !
    1176. 

  1176.         CUP=PRECK*CPRLG
    1177. 

  1177.         PCPCOL=CUP
    1178. 

  1178. !
    1179. 

  1179.         DO L=LTOP,LB
    1180. 

  1180.           DTDT(L)=DIFT(L)*FEFI*RDTCNVC
    1181. 

  1181.           DQDT(L)=DIFQ(L)*FEFI*RDTCNVC
    1182. 

  1182.         ENDDO
    1183. 

  1183. !
    1184. 

  1184.       ELSE
    1185. 

  1185. !
    1186. 

  1186. !-----------------------------------------------------------------------
    1187. 

  1187. !***  REDUCE THE CLOUD TOP
    1188. 

  1188. !-----------------------------------------------------------------------
    1189. 

  1189. !
    1190. 

  1190. !        LTOP=LTOP+3
    1191. 

  1191. !        PTOP=PRSMID(LTOP)
    1192. 

  1192. !        DEPMIN=PSH*PSFC*RSFCP
    1193. 

  1193. !        DEPTH=PBOT-PTOP
    1194. 

  1194. !***
    1195. 

  1195. !***  ITERATE DEEP CONVECTION PROCEDURE IF NEEDED
    1196. 

  1196. !***
    1197. 

  1197. !        IF(DEPTH>=DEPMIN)THEN
    1198. 

  1198. !          GO TO 300
    1199. 

  1199. !        ENDIF
    1200. 

  1200. !
    1201. 

  1201. !        CLDEFI=AVGEFI
    1202. 

  1202.          CLDEFI=EFIMN*SM+STEFI*(1.-SM)
    1203. 

  1203. !***
    1204. 

  1204. !***  SEARCH FOR SHALLOW CLOUD TOP
    1205. 

  1205. !***
    1206. 

  1206. !        LTSH=LBOT
    1207. 

  1207. !        LBM1=LBOT-1
    1208. 

  1208. !        PBTK=PK(LBOT)
    1209. 

  1209. !        DEPMIN=PSH*PSFC*RSFCP
    1210. 

  1210. !        PTPK=PBTK-DEPMIN
    1211. 

  1211.         PTPK=MAX(PSHU, PK(LBOT)-DEPMIN)
    1212. 

  1212. !***
    1213. 

  1213. !***  CLOUD TOP IS THE LEVEL JUST BELOW PBTK-PSH or JUST BELOW PSHU
    1214. 

  1214. !***
    1215. 

  1215.         DO L=KTS,LMH
    1216. 

  1216.           IF(PK(L)<=PTPK)LTOP=L+1
    1217. 

  1217.         ENDDO
    1218. 

  1218. !
    1219. 

  1219. !        PTPK=PK(LTOP)
    1220. 

  1220. !!***
    1221. 

  1221. !!***  HIGHEST LEVEL ALLOWED IS LEVEL JUST BELOW PSHU
    1222. 

  1222. !!***
    1223. 

  1223. !        IF(PTPK<=PSHU)THEN
    1224. 

  1224. !!
    1225. 

  1225. !          DO L=KTS,LMH
    1226. 

  1226. !            IF(PK(L)<=PSHU)LSHU=L+1
    1227. 

  1227. !          ENDDO
    1228. 

  1228. !!
    1229. 

  1229. !          LTOP=LSHU
    1230. 

  1230. !          PTPK=PK(LTOP)
    1231. 

  1231. !        ENDIF
    1232. 

  1232. !
    1233. 

  1233. !        if(ltop>=lbot)then
    1234. 

  1234. !!!!!!     lbot=0
    1235. 

  1235. !          ltop=lmh
    1236. 

  1236. !!!!!!     pbot=pk(lbot)
    1237. 

  1237. !          ptop=pk(ltop)
    1238. 

  1238. !          pbot=ptop
    1239. 

  1239. !          go to 600
    1240. 

  1240. !        endif
    1241. 

  1241. !
    1242. 

  1242. !        LTP1=LTOP+1
    1243. 

  1243. !        LTP2=LTOP+2
    1244. 

  1244. !!
    1245. 

  1245. !        DO L=LTOP,LBOT
    1246. 

  1246. !          QSATK(L)=PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
    1247. 

  1247. !        ENDDO
    1248. 

  1248. !!
    1249. 

  1249. !        RHH=QK(LTOP)/QSATK(LTOP)
    1250. 

  1250. !        RHMAX=0.
    1251. 

  1251. !        LTSH=LTOP
    1252. 

  1252. !!
    1253. 

  1253. !        DO L=LTP1,LBM1
    1254. 

  1254. !          RHL=QK(L)/QSATK(L)
    1255. 

  1255. !          DRHDP=(RHH-RHL)/(PK(L-1)-PK(L))
    1256. 

  1256. !!
    1257. 

  1257. !          IF(DRHDP>RHMAX)THEN
    1258. 

  1258. !            LTSH=L-1
    1259. 

  1259. !            RHMAX=DRHDP
    1260. 

  1260. !          ENDIF
    1261. 

  1261. !!
    1262. 

  1262. !          RHH=RHL
    1263. 

  1263. !        ENDDO
    1264. 

  1264. !
    1265. 

  1265. !-----------------------------------------------------------------------
    1266. 

  1266. !-- Make shallow cloud top a function of virtual temperature excess (DTV)
    1267. 

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

  1268. !
    1269. 

  1269.         LTP1=LBOT
    1270. 

  1270.         DO L=LBOT-1,LTOP,-1
    1271. 

  1271.           IF (DTV(L) > 0.) THEN
    1272. 

  1272.             LTP1=L
    1273. 

  1273.           ELSE
    1274. 

  1274.             EXIT
    1275. 

  1275.           ENDIF
    1276. 

  1276.         ENDDO
    1277. 

  1277.         LTOP=MIN(LTP1,LBOT)
    1278. 

  1278. !***
    1279. 

  1279. !***  CLOUD MUST BE AT LEAST TWO LAYERS THICK
    1280. 

  1280. !***
    1281. 

  1281. !        IF(LBOT-LTOP<2)LTOP=LBOT-2  (eliminate this criterion)
    1282. 

  1282. !
    1283. 

  1283. !-- End: Buoyancy check (24 Aug 2006)
    1284. 

  1284. !
    1285. 

  1285.         PTOP=PK(LTOP)
    1286. 

  1286.         SHALLOW=.TRUE.
    1287. 

  1287.         DEEP=.FALSE.
    1288. 

  1288. !
    1289. 

  1289.       ENDIF
    1290. 

  1290. !DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    1291. 

  1291. !DCDCDCDCDCDCDC          END OF DEEP CONVECTION            DCDCDCDCDCDCD
    1292. 

  1292. !DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
    1293. 

  1293. !
    1294. 

  1294. !-----------------------------------------------------------------------
    1295. 

  1295. !-----------------------------------------------------------------------
    1296. 

  1296.   600 CONTINUE
    1297. 

  1297. !-----------------------------------------------------------------------
    1298. 

  1298. !-----------------------------------------------------------------------
    1299. 

  1299. !
    1300. 

  1300. !----------------GATHER SHALLOW CONVECTION POINTS-----------------------
    1301. 

  1301. !
    1302. 

  1302. !      IF(PTOP<=PBOT-PNO.AND.LTOP<=LBOT-2)THEN
    1303. 

  1303. !         DEPMIN=PSH*PSFC*RSFCP
    1304. 

  1304. !!
    1305. 

  1305. !!        if(lpbl<lbot)lbot=lpbl
    1306. 

  1306. !!        if(lbot>lmh-1)lbot=lmh-1
    1307. 

  1307. !!        pbot=prsmid(lbot)
    1308. 

  1308. !!
    1309. 

  1309. !         IF(PTOP+1.>=PBOT-DEPMIN)SHALLOW=.TRUE.
    1310. 

  1310. !      ELSE
    1311. 

  1311. !         LBOT=0
    1312. 

  1312. !         LTOP=KTE
    1313. 

  1313. !      ENDIF
    1314. 

  1314. !
    1315. 

  1315. !***********************************************************************
    1316. 

  1316. !-----------------------------------------------------------------------
    1317. 

  1317. !***  Begin debugging convection
    1318. 

  1318.       IF(PRINT_DIAG)THEN
    1319. 

  1319.         WRITE(6,"(a,2i3,L2,3e12.4)")  &
    1320. 

  1320.              '{cu2a lbot,ltop,shallow,pbot,ptop,depmin = ' &
    1321. 

  1321.              ,lbot,ltop,shallow,pbot,ptop,depmin
    1322. 

  1322.       ENDIF
    1323. 

  1323. !***  End debugging convection
    1324. 

  1324. !-----------------------------------------------------------------------
    1325. 

  1325. !
    1326. 

  1326.       IF(.NOT.SHALLOW)GO TO 800
    1327. 

  1327. !
    1328. 

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

  1329. !***********************************************************************
    1330. 

  1330. !-----------------------------------------------------------------------
    1331. 

  1331. !SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    1332. 

  1332. !SCSCSCSCSCSCSC         SHALLOW CONVECTION          CSCSCSCSCSCSCSCSCSCS
    1333. 

  1333. !SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
    1334. 

  1334. !-----------------------------------------------------------------------
    1335. 

  1335.       DO L=KTS,LMH
    1336. 

  1336.         TKL      =T(L)
    1337. 

  1337.         TK   (L) =TKL
    1338. 

  1338.         TREFK(L) =TKL
    1339. 

  1339.         QKL      =Q(L)
    1340. 

  1340.         QK   (L) =QKL
    1341. 

  1341.         QREFK(L) =QKL
    1342. 

  1342.         PKL      =PRSMID(L)
    1343. 

  1343.         PK   (L) =PKL
    1344. 

  1344.         QSATK(L) =PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
    1345. 

  1345.         APEKL    =APE(L)
    1346. 

  1346.         APEK (L) =APEKL
    1347. 

  1347.         THVMKL   =TKL*APEKL*(QKL*D608+1.)
    1348. 

  1348.         THVREF(L)=THVMKL
    1349. 

  1349. !
    1350. 

  1350. !        IF(TKL>=TFRZ)THEN
    1351. 

  1351.           EL(L)=ELWV
    1352. 

  1352. !        ELSE
    1353. 

  1353. !          EL(L)=ELIV
    1354. 

  1354. !        ENDIF
    1355. 

  1355.       ENDDO
    1356. 

  1356. !
    1357. 

  1357. !-----------------------------------------------------------------------
    1358. 

  1358. !-- Begin: Raise cloud top if avg RH>RHSHmax and CAPE>0
    1359. 

  1359. !   RHSHmax=RH at cloud base associated with a DSP of PONE
    1360. 

  1360. !-----------------------------------------------------------------------
    1361. 

  1361. !
    1362. 

  1362.       TLEV2=T(LBOT)*((PK(LBOT)-PONE)/PK(LBOT))**CAPA
    1363. 

  1363.       QSAT1=PQ0/PK(LBOT)*EXP(A2*(T(LBOT)-A3)/(TK(LBOT)-A4))
    1364. 

  1364.       QSAT2=PQ0/(PK(LBOT)-PONE)*EXP(A2*(TLEV2-A3)/(TLEV2-A4))
    1365. 

  1365.       RHSHmax=QSAT2/QSAT1
    1366. 

  1366.       SUMDP=0.
    1367. 

  1367.       RHAVG=0.
    1368. 

  1368. !
    1369. 

  1369.       DO L=LBOT,LTOP,-1
    1370. 

  1370.         RHAVG=RHAVG+DPRS(L)*QK(L)/QSATK(L)
    1371. 

  1371.         SUMDP=SUMDP+DPRS(L)
    1372. 

  1372.       ENDDO
    1373. 

  1373. !
    1374. 

  1374.       IF (RHAVG/SUMDP > RHSHmax) THEN
    1375. 

  1375.         LTSH=LTOP
    1376. 

  1376.         DO L=LTOP-1,KTS,-1
    1377. 

  1377.           RHAVG=RHAVG+DPRS(L)*QK(L)/QSATK(L)
    1378. 

  1378.           SUMDP=SUMDP+DPRS(L)
    1379. 

  1379.           IF (CPE(L) > 0.) THEN
    1380. 

  1380.             LTSH=L
    1381. 

  1381.           ELSE
    1382. 

  1382.             EXIT
    1383. 

  1383.           ENDIF
    1384. 

  1384.           IF (RHAVG/SUMDP <= RHSHmax) EXIT
    1385. 

  1385.           IF (PK(L) <= PSHU) EXIT
    1386. 

  1386.         ENDDO
    1387. 

  1387.         LTOP=LTSH
    1388. 

  1388.       ENDIF
    1389. 

  1389. !
    1390. 

  1390. !-- End: Raise cloud top if avg RH>RHSHmax and CAPE>0
    1391. 

  1391. !
    1392. 

  1392. !---------------------------SHALLOW CLOUD TOP---------------------------
    1393. 

  1393.       LBM1=LBOT-1
    1394. 

  1394.       PTPK=PTOP
    1395. 

  1395.       LTP1=LTOP-1
    1396. 

  1396.       DEPTH=PBOT-PTOP
    1397. 

  1397. !-----------------------------------------------------------------------
    1398. 

  1398. !***  Begin debugging convection
    1399. 

  1399.       IF(PRINT_DIAG)THEN
    1400. 

  1400.         WRITE(6,"(a,4e12.4)") '{cu2b PBOT,PTOP,DEPTH,DEPMIN= ' &
    1401. 

  1401.              ,PBOT,PTOP,DEPTH,DEPMIN
    1402. 

  1402.       ENDIF
    1403. 

  1403. !***  End debugging convection
    1404. 

  1404. !-----------------------------------------------------------------------
    1405. 

  1405. !
    1406. 

  1406. !BSF      IF(DEPTH<DEPMIN)THEN
    1407. 

  1407. !BSF        GO TO 800
    1408. 

  1408. !BSF      ENDIF
    1409. 

  1409. !-----------------------------------------------------------------------
    1410. 

  1410.       IF(PTOP>PBOT-PNO.OR.LTOP>LBOT-2)THEN
    1411. 

  1411.         LBOT=0
    1412. 

  1412. !!!     LTOP=LBOT
    1413. 

  1413.         LTOP=KTE
    1414. 

  1414.         PTOP=PBOT
    1415. 

  1415.         GO TO 800
    1416. 

  1416.       ENDIF
    1417. 

  1417. !
    1418. 

  1418. !--------------SCALING POTENTIAL TEMPERATURE & TABLE INDEX AT TOP-------
    1419. 

  1419. !
    1420. 

  1420.       THTPK=T(LTP1)*APE(LTP1)
    1421. 

  1421. !
    1422. 

  1422.       TTHK=(THTPK-THL)*RDTH
    1423. 

  1423.       QQK =TTHK-AINT(TTHK)
    1424. 

  1424.       IT  =INT(TTHK)+1
    1425. 

  1425. !
    1426. 

  1426.       IF(IT<1)THEN
    1427. 

  1427.         IT=1
    1428. 

  1428.         QQK=0.
    1429. 

  1429.       ENDIF
    1430. 

  1430. !
    1431. 

  1431.       IF(IT>=JTB)THEN
    1432. 

  1432.         IT=JTB-1
    1433. 

  1433.         QQK=0.
    1434. 

  1434.       ENDIF
    1435. 

  1435. !
    1436. 

  1436. !--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY AT TOP--------
    1437. 

  1437. !
    1438. 

  1438.       BQS00K=QS0(IT)
    1439. 

  1439.       SQS00K=SQS(IT)
    1440. 

  1440.       BQS10K=QS0(IT+1)
    1441. 

  1441.       SQS10K=SQS(IT+1)
    1442. 

  1442. !
    1443. 

  1443. !--------------SCALING SPEC. HUMIDITY & TABLE INDEX AT TOP--------------
    1444. 

  1444. !
    1445. 

  1445.       BQK=(BQS10K-BQS00K)*QQK+BQS00K
    1446. 

  1446.       SQK=(SQS10K-SQS00K)*QQK+SQS00K
    1447. 

  1447. !
    1448. 

  1448. !     TQK=(Q(LTOP)-BQK)/SQK*RDQ
    1449. 

  1449.       TQK=(Q(LTP1)-BQK)/SQK*RDQ
    1450. 

  1450. !
    1451. 

  1451.       PPK=TQK-AINT(TQK)
    1452. 

  1452.       IQ =INT(TQK)+1
    1453. 

  1453. !
    1454. 

  1454.       IF(IQ<1)THEN
    1455. 

  1455.         IQ=1
    1456. 

  1456.         PPK=0.
    1457. 

  1457.       ENDIF
    1458. 

  1458. !
    1459. 

  1459.       IF(IQ>=ITB)THEN
    1460. 

  1460.         IQ=ITB-1
    1461. 

  1461.         PPK=0.
    1462. 

  1462.       ENDIF
    1463. 

  1463. !
    1464. 

  1464. !----------------CLOUD TOP SATURATION POINT PRESSURE--------------------
    1465. 

  1465. !
    1466. 

  1466.       PART1=(PTBL(IQ+1,IT)-PTBL(IQ,IT))*PPK
    1467. 

  1467.       PART2=(PTBL(IQ,IT+1)-PTBL(IQ,IT))*QQK
    1468. 

  1468.       PART3=(PTBL(IQ  ,IT  )-PTBL(IQ+1,IT  )                            &
    1469. 

  1469.      &      -PTBL(IQ  ,IT+1)+PTBL(IQ+1,IT+1))*PPK*QQK
    1470. 

  1470.       PTPK=PTBL(IQ,IT)+PART1+PART2+PART3
    1471. 

  1471. !-----------------------------------------------------------------------
    1472. 

  1472.       DPMIX=PTPK-PSP
    1473. 

  1473.       IF(ABS(DPMIX).LT.3000.)DPMIX=-3000.
    1474. 

  1474. !
    1475. 

  1475. !----------------TEMPERATURE PROFILE SLOPE------------------------------
    1476. 

  1476. !
    1477. 

  1477.       SMIX=(THTPK-THBT)/DPMIX*STABS
    1478. 

  1478. !
    1479. 

  1479.       TREFKX=TREFK(LBOT+1)
    1480. 

  1480.       PKXXXX=PK(LBOT+1)
    1481. 

  1481.       PKXXXY=PK(LBOT)
    1482. 

  1482.       APEKXX=APEK(LBO…
    1483.

Large files files are truncated, but you can click here to view the full file