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

/wrfv2_fire/phys/module_cu_kf.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 2669 lines | 1750 code | 115 blank | 804 comment | 3 complexity | 6487caca6f6ab8133f78922b148dcf06 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. !WRF:MODEL_LAYER:PHYSICS
    2. 

  2. !
    3. 

  3. 

  4. MODULE module_cu_kf
    5. 

  5. 

  6.    USE module_wrf_error
    7. 

  7. 

  8.    REAL    , PARAMETER :: RAD          = 1500.
    9. 

  9. 

  10. CONTAINS
    11. 

  11. 

  12. !-------------------------------------------------------------
    13. 

  13.    SUBROUTINE KFCPS(                                         &
    14. 

  14.                ids,ide, jds,jde, kds,kde                     &
    15. 

  15.               ,ims,ime, jms,jme, kms,kme                     &
    16. 

  16.               ,its,ite, jts,jte, kts,kte                     &
    17. 

  17.               ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG     &
    18. 

  18.               ,CUDTACTTIME                                   & 
    19. 

  19.               ,rho                                           &
    20. 

  20.               ,RAINCV,PRATEC,NCA                             &
    21. 

  21.               ,U,V,TH,T,W,QV,dz8w,Pcps,pi                    &
    22. 

  22.               ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1          &
    23. 

  23.               ,EP2,SVP1,SVP2,SVP3,SVPT0                      &
    24. 

  24.               ,STEPCU,CU_ACT_FLAG,warm_rain                  &
    25. 

  25.             ! optional arguments
    26. 

  26.               ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS      &
    27. 

  27.               ,RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN  &
    28. 

  28.               ,RTHCUTEN                                      &
    29. 

  29.                                                              )
    30. 

  30. !-------------------------------------------------------------
    31. 

  31.    IMPLICIT NONE
    32. 

  32. !-------------------------------------------------------------
    33. 

  33.    INTEGER,      INTENT(IN   ) ::                            &
    34. 

  34.                                   ids,ide, jds,jde, kds,kde, & 
    35. 

  35.                                   ims,ime, jms,jme, kms,kme, & 
    36. 

  36.                                   its,ite, jts,jte, kts,kte
    37. 

  37. 

  38.    INTEGER,      INTENT(IN   ) :: STEPCU
    39. 

  39.    LOGICAL,      INTENT(IN   ) :: warm_rain
    40. 

  40. 

  41.    REAL,         INTENT(IN   ) :: XLV0,XLV1,XLS0,XLS1
    42. 

  42.    REAL,         INTENT(IN   ) :: CP,R,G,EP1,EP2
    43. 

  43.    REAL,         INTENT(IN   ) :: SVP1,SVP2,SVP3,SVPT0
    44. 

  44. 

  45.    INTEGER,      INTENT(IN   ) :: KTAU                   
    46. 

  46. 

  47.    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
    48. 

  48.           INTENT(IN   ) ::                                   &
    49. 

  49.                                                           U, &
    50. 

  50.                                                           V, &
    51. 

  51.                                                           W, &
    52. 

  52.                                                          TH, &
    53. 

  53.                                                          QV, &
    54. 

  54.                                                           T, &
    55. 

  55.                                                        dz8w, &
    56. 

  56.                                                        Pcps, &
    57. 

  57.                                                         rho, &
    58. 

  58.                                                          pi
    59. 

  59. !
    60. 

  60.    REAL,  INTENT(IN   ) :: DT, DX
    61. 

  61.    REAL,  INTENT(IN   ) :: CUDT
    62. 

  62.    REAL,  INTENT(IN   ) :: CURR_SECS
    63. 

  63.    LOGICAL,OPTIONAL, INTENT(IN  ) :: ADAPT_STEP_FLAG
    64. 

  64.    REAL,  INTENT (INOUT) :: CUDTACTTIME       
    65. 

  65. 

  66.    REAL, DIMENSION( ims:ime , jms:jme ),                     &
    67. 

  67.           INTENT(INOUT) ::                                   &
    68. 

  68.                                                      RAINCV  &
    69. 

  69.                                                     ,PRATEC  &
    70. 

  70.                                                     ,   NCA
    71. 

  71. 

  72.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),           &
    73. 

  73.           INTENT(INOUT) ::                                   &
    74. 

  74.                                                       W0AVG
    75. 

  75. 

  76.    LOGICAL, DIMENSION( ims:ime , jms:jme ),                  &
    77. 

  77.           INTENT(INOUT) :: CU_ACT_FLAG
    78. 

  78. 

  79. !
    80. 

  80. ! Optional arguments
    81. 

  81. !
    82. 

  82. 

  83.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),           &
    84. 

  84.          OPTIONAL,                                           &
    85. 

  85.          INTENT(INOUT) ::                                    &
    86. 

  86.                                                    RTHCUTEN  &
    87. 

  87.                                                   ,RQVCUTEN  &
    88. 

  88.                                                   ,RQCCUTEN  &
    89. 

  89.                                                   ,RQRCUTEN  &
    90. 

  90.                                                   ,RQICUTEN  &
    91. 

  91.                                                   ,RQSCUTEN
    92. 

  92. 

  93. !
    94. 

  94. ! Flags relating to the optional tendency arrays declared above
    95. 

  95. ! Models that carry the optional tendencies will provdide the
    96. 

  96. ! optional arguments at compile time; these flags all the model
    97. 

  97. ! to determine at run-time whether a particular tracer is in 
    98. 

  98. ! use or not. 
    99. 

  99. !
    100. 

  100. 

  101.    LOGICAL, OPTIONAL ::                                      &
    102. 

  102.                                                    F_QV      &
    103. 

  103.                                                   ,F_QC      &
    104. 

  104.                                                   ,F_QR      &
    105. 

  105.                                                   ,F_QI      &
    106. 

  106.                                                   ,F_QS
    107. 

  107. 

  108. 

  109. 

  110. ! LOCAL VARS
    111. 

  111. 

  112.    REAL, DIMENSION( kts:kte ) ::                             &
    113. 

  113.                                                         U1D, &
    114. 

  114.                                                         V1D, &
    115. 

  115.                                                         T1D, &
    116. 

  116.                                                        DZ1D, &
    117. 

  117.                                                        QV1D, &
    118. 

  118.                                                         P1D, &
    119. 

  119.                                                       RHO1D, &
    120. 

  120.                                                     W0AVG1D
    121. 

  121. 

  122.    REAL, DIMENSION( kts:kte )::                              &
    123. 

  123.                                                        DQDT, &
    124. 

  124.                                                       DQIDT, &
    125. 

  125.                                                       DQCDT, &
    126. 

  126.                                                       DQRDT, &
    127. 

  127.                                                       DQSDT, &
    128. 

  128.                                                        DTDT
    129. 

  129. 

  130.    REAL    ::         TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp
    131. 

  131. 

  132.    INTEGER :: i,j,k,NTST,ICLDCK
    133. 

  133. 

  134.    LOGICAL :: qi_flag , qs_flag
    135. 

  135. ! adjustable time step changes
    136. 

  136.    REAL    :: lastdt = -1.0
    137. 

  137.    REAL    :: W0AVGfctr, W0fctr, W0den
    138. 

  138.    LOGICAL :: run_param , doing_adapt_dt , decided
    139. 

  139. 

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

  141. 

  142. !--- CALL CUMULUS PARAMETERIZATION                                        
    143. 

  143. !                                                                        
    144. 

  144. !...TST IS THE NUMBER OF TIME STEPS IN 10 MINUTES...W0AVG IS CLOSE TO A    
    145. 

  145. !...RUNNING MEAN VERTICAL VELOCITY...NOTE THAT IF YOU CHANGE TST, IT WIL  
    146. 

  146. !...CHANGE THE FREQUENCY OF THE CONVECTIVE INTITIATION CHECK (SEE BELOW) 
    147. 

  147. !...NOTE THAT THE ORDERING OF VERTICAL LAYERS MUST BE REVERSED FOR W0AVG
    148. 

  148. !...BECAUSE THE ORDERING IS REVERSED IN KFPARA...                         
    149. 

  149. !                                                                           
    150. 

  150.    DXSQ=DX*DX
    151. 

  151.    qi_flag = .FALSE.
    152. 

  152.    qs_flag = .FALSE.
    153. 

  153.    IF ( PRESENT( F_QI ) ) qi_flag = f_qi
    154. 

  154.    IF ( PRESENT( F_QS ) ) qs_flag = f_qs
    155. 

  155. 

  156. !----------------------
    157. 

  157.    NTST=STEPCU
    158. 

  158.    TST=float(NTST*2)                                                         
    159. 

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

  160. !  NTST=NINT(1200./(DT*2.))                                                 
    161. 

  161. !  TST=float(NTST)                                                         
    162. 

  162. !  NTST=NINT(0.5*TST)                                                   
    163. 

  163. !  NTST=MAX0(NTST,1)                                                   
    164. 

  164. !----------------------
    165. 

  165. !  ICLDCK=MOD(KTAU,NTST)                                              
    166. 

  166. !----------------------
    167. 

  167. !  write(0,*) 'DT = ',DT,'  KTAU = ',KTAU,' DX = ',DX
    168. 

  168. !  write(0,*) 'CUDT = ',CUDT,'  CURR_SECS = ',CURR_SECS
    169. 

  169. !  write(0,*) 'ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG,' IDS = ',IDS
    170. 

  170. !  write(0,*) 'STEPCU = ',STEPCU,' warm_rain = ',warm_rain
    171. 

  171. !  write(0,*) 'F_QV = ',F_QV,' F_QC = ',F_QV
    172. 

  172. !  write(0,*) 'F_QI = ',F_QI,' F_QS = ',F_QS
    173. 

  173. !  write(0,*) 'F_QR = ',F_QR
    174. 

  174. !  stop
    175. 

  175.    if (lastdt < 0) then
    176. 

  176.       lastdt = dt
    177. 

  177.    endif
    178. 

  178. 

  179.    if (ADAPT_STEP_FLAG) then
    180. 

  180.       W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt
    181. 

  181.       W0fctr = dt
    182. 

  182.       W0den = 2 * MAX(CUDT*60,dt)
    183. 

  183.    else
    184. 

  184.       W0AVGfctr = (TST-1.)
    185. 

  185.       W0fctr = 1.
    186. 

  186.       W0den = TST
    187. 

  187.    endif
    188. 

  188. 

  189.    DO J = jts,jte  
    190. 

  190.       DO K=kts,kte
    191. 

  191.          DO I= its,ite
    192. 

  192. !           SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J))
    193. 

  193. !           TV=T(I,K,J)*(1.+EP1*QV(I,K,J))
    194. 

  194. !           RHOE=Pcps(I,K,J)/(R*TV)
    195. 

  195. !           W0=-101.9368*SCR1/RHOE
    196. 

  196.             W0=0.5*(w(I,K,J)+w(I,K+1,J))
    197. 

  197. 

  198. !           Old:
    199. 

  199. !
    200. 

  200. !           W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST
    201. 

  201. !           New, to support adaptive time step:
    202. 

  202. !
    203. 

  203.             W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den
    204. 

  204. 

  205.          ENDDO
    206. 

  206.       ENDDO
    207. 

  207.    ENDDO
    208. 

  208.    lastdt = dt
    209. 

  209. 

  210. !  Initialization for adaptive time step.
    211. 

  211. 

  212.    doing_adapt_dt = .FALSE.
    213. 

  213.    IF ( PRESENT(adapt_step_flag) ) THEN
    214. 

  214.       IF ( adapt_step_flag ) THEN
    215. 

  215.          doing_adapt_dt = .TRUE.
    216. 

  216.          IF ( cudtacttime .EQ. 0. ) THEN
    217. 

  217.             cudtacttime = curr_secs + cudt*60.
    218. 

  218.          END IF
    219. 

  219.       END IF
    220. 

  220.    END IF
    221. 

  221. 

  222. !  Do we run through this scheme or not?
    223. 

  223. 

  224. !    Test 1:  If this is the initial model time, then yes.  
    225. 

  225. !                KTAU=1
    226. 

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

  227. !                CUDT=0 or STEPCU=1
    228. 

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

  229. !                MOD(KTAU,NST)=0
    230. 

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

  231. !                CURR_SECS >= CUDTACTTIME
    232. 

  232. 

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

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

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

  236. 

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

  238. !  cumulus run.
    239. 

  239. 

  240.    decided = .FALSE.
    241. 

  241.    run_param = .FALSE.
    242. 

  242.    IF ( ( .NOT. decided ) .AND. &
    243. 

  243.         ( ktau .EQ. 1 ) ) THEN
    244. 

  244.       run_param   = .TRUE.
    245. 

  245.       decided     = .TRUE.
    246. 

  246.    END IF
    247. 

  247. 

  248.    IF ( ( .NOT. decided ) .AND. &
    249. 

  249.         ( ( cudt .EQ. 0. ) .OR. ( stepcu .EQ. 1 ) ) ) THEN
    250. 

  250.       run_param   = .TRUE.
    251. 

  251.       decided     = .TRUE.
    252. 

  252.    END IF
    253. 

  253. 

  254.    IF ( ( .NOT. decided ) .AND. &
    255. 

  255.         ( .NOT. doing_adapt_dt ) .AND. &
    256. 

  256.         ( MOD(ktau,ntst) .EQ. 0 ) ) THEN
    257. 

  257.       run_param   = .TRUE.
    258. 

  258.       decided     = .TRUE.
    259. 

  259.    END IF
    260. 

  260. 

  261.    IF ( ( .NOT. decided ) .AND. &
    262. 

  262.         ( doing_adapt_dt ) .AND. &
    263. 

  263.         ( curr_secs .GE. cudtacttime ) ) THEN
    264. 

  264.       run_param   = .TRUE.
    265. 

  265.       decided     = .TRUE.
    266. 

  266.       cudtacttime = curr_secs + cudt*60
    267. 

  267.    END IF
    268. 

  268. 

  269.    IF (run_param) then
    270. 

  270.      DO J = jts,jte  
    271. 

  271.      DO I= its,ite
    272. 

  272.         CU_ACT_FLAG(i,j) = .true.
    273. 

  273.      ENDDO
    274. 

  274.      ENDDO
    275. 

  275. 

  276.      DO J = jts,jte  
    277. 

  277.         DO I=its,ite
    278. 

  278. ! if (i.eq. 110 .and. j .eq. 59 ) then
    279. 

  279. !   write(0,*) 'nca = ',nca(i,j),' CU_ACT_FLAG = ',CU_ACT_FLAG(i,j)
    280. 

  280. !   write(0,*) 'dt = ',dt,' ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG
    281. 

  281. ! endif
    282. 

  282. !        IF ( NINT(NCA(I,J)) .gt. 0 ) then
    283. 

  283.          IF ( NCA(I,J) .gt. 0.5*DT ) then
    284. 

  284.             CU_ACT_FLAG(i,j) = .false. 
    285. 

  285.          ELSE
    286. 

  286. 

  287.             DO k=kts,kte
    288. 

  288.                DQDT(k)=0.
    289. 

  289.                DQIDT(k)=0.      
    290. 

  290.                DQCDT(k)=0.      
    291. 

  291.                DQRDT(k)=0.      
    292. 

  292.                DQSDT(k)=0.      
    293. 

  293.                DTDT(k)=0.
    294. 

  294.             ENDDO
    295. 

  295.             RAINCV(I,J)=0.
    296. 

  296. 	    PRATEC(I,J)=0.
    297. 

  297. !
    298. 

  298. ! assign vars from 3D to 1D
    299. 

  299. 

  300.             DO K=kts,kte
    301. 

  301.                U1D(K) =U(I,K,J)
    302. 

  302.                V1D(K) =V(I,K,J)
    303. 

  303.                T1D(K) =T(I,K,J)
    304. 

  304.                RHO1D(K) =rho(I,K,J)
    305. 

  305.                QV1D(K)=QV(I,K,J)
    306. 

  306.                P1D(K) =Pcps(I,K,J)
    307. 

  307.                W0AVG1D(K) =W0AVG(I,K,J)
    308. 

  308.                DZ1D(k)=dz8w(I,K,J)
    309. 

  309.             ENDDO
    310. 

  310. 

  311. !
    312. 

  312.             CALL KFPARA(I, J,                       &
    313. 

  313.                  U1D,V1D,T1D,QV1D,P1D,DZ1D,         &
    314. 

  314.                  W0AVG1D,DT,DX,DXSQ,RHO1D,          &
    315. 

  315.                  XLV0,XLV1,XLS0,XLS1,CP,R,G,        &
    316. 

  316.                  EP2,SVP1,SVP2,SVP3,SVPT0,          &
    317. 

  317.                  DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &
    318. 

  318.                  RAINCV,PRATEC,NCA,                 &
    319. 

  319.                  warm_rain,qi_flag,qs_flag,         &
    320. 

  320.                  ids,ide, jds,jde, kds,kde,         &        
    321. 

  321.                  ims,ime, jms,jme, kms,kme,         &
    322. 

  322.                  its,ite, jts,jte, kts,kte          )
    323. 

  323.  
    324. 

  324.             IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN ) ) THEN
    325. 

  325.               DO K=kts,kte
    326. 

  326.                  RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J)
    327. 

  327.                  RQVCUTEN(I,K,J)=DQDT(K)
    328. 

  328.               ENDDO
    329. 

  329.             ENDIF
    330. 

  330. 

  331.             IF( PRESENT(RQRCUTEN) .AND. PRESENT(RQCCUTEN) .AND. &
    332. 

  332.                 PRESENT(F_QR)                                    ) THEN
    333. 

  333.               IF ( F_QR            ) THEN
    334. 

  334.                  DO K=kts,kte
    335. 

  335.                     RQRCUTEN(I,K,J)=DQRDT(K)
    336. 

  336.                     RQCCUTEN(I,K,J)=DQCDT(K)
    337. 

  337.                  ENDDO
    338. 

  338.                ELSE
    339. 

  339. ! This is the case for Eta microphysics without 3d rain field
    340. 

  340.                  DO K=kts,kte
    341. 

  341.                     RQRCUTEN(I,K,J)=0.
    342. 

  342.                     RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K)
    343. 

  343.                  ENDDO
    344. 

  344.               ENDIF
    345. 

  345.             ENDIF
    346. 

  346. 

  347. !......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)     
    348. 

  348. 

  349.             IF( PRESENT( RQICUTEN ) .AND. qi_flag )THEN
    350. 

  350.               DO K=kts,kte
    351. 

  351.                  RQICUTEN(I,K,J)=DQIDT(K)
    352. 

  352.               ENDDO
    353. 

  353.             ENDIF
    354. 

  354. 

  355.             IF( PRESENT ( RQSCUTEN ) .AND. qs_flag )THEN
    356. 

  356.               DO K=kts,kte
    357. 

  357.                  RQSCUTEN(I,K,J)=DQSDT(K)
    358. 

  358.               ENDDO
    359. 

  359.             ENDIF                                                         
    360. 

  360. !
    361. 

  361.          ENDIF                                                         
    362. 

  362.        ENDDO
    363. 

  363.      ENDDO
    364. 

  364. 

  365.    ENDIF
    366. 

  366. 

  367.    END SUBROUTINE KFCPS
    368. 

  368.    
    369. 

  369. !-----------------------------------------------------------
    370. 

  370.    SUBROUTINE KFPARA (I, J,                                &
    371. 

  371.                       U0,V0,T0,QV0,P0,DZQ,W0AVG1D,         &
    372. 

  372.                       DT,DX,DXSQ,rho,                      &
    373. 

  373.                       XLV0,XLV1,XLS0,XLS1,CP,R,G,          &
    374. 

  374.                       EP2,SVP1,SVP2,SVP3,SVPT0,            &
    375. 

  375.                       DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT,   &
    376. 

  376.                       RAINCV,PRATEC,NCA,                   &
    377. 

  377.                       warm_rain,qi_flag,qs_flag,           &
    378. 

  378.                       ids,ide, jds,jde, kds,kde,           & 
    379. 

  379.                       ims,ime, jms,jme, kms,kme,           &
    380. 

  380.                       its,ite, jts,jte, kts,kte            )
    381. 

  381. !-----------------------------------------------------------
    382. 

  382.       IMPLICIT NONE
    383. 

  383. !-----------------------------------------------------------
    384. 

  384.       INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde, &
    385. 

  385.                                 ims,ime, jms,jme, kms,kme, &
    386. 

  386.                                 its,ite, jts,jte, kts,kte, &
    387. 

  387.                                 I,J
    388. 

  388.       LOGICAL, INTENT(IN   ) :: warm_rain
    389. 

  389.       LOGICAL           :: qi_flag, qs_flag
    390. 

  390. 

  391. !
    392. 

  392.       REAL, DIMENSION( kts:kte ),                          &
    393. 

  393.             INTENT(IN   ) ::                           U0, &
    394. 

  394.                                                        V0, &
    395. 

  395.                                                        T0, &
    396. 

  396.                                                       QV0, &
    397. 

  397.                                                        P0, &
    398. 

  398.                                                       rho, &
    399. 

  399.                                                       DZQ, &
    400. 

  400.                                                   W0AVG1D
    401. 

  401. !
    402. 

  402.       REAL,  INTENT(IN   ) :: DT,DX,DXSQ
    403. 

  403. !
    404. 

  404. 

  405.       REAL,  INTENT(IN   ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G
    406. 

  406.       REAL,  INTENT(IN   ) :: EP2,SVP1,SVP2,SVP3,SVPT0
    407. 

  407. !
    408. 

  408.       REAL, DIMENSION( kts:kte ), INTENT(INOUT) ::         &
    409. 

  409.                                                      DQDT, &
    410. 

  410.                                                     DQIDT, &
    411. 

  411.                                                     DQCDT, &
    412. 

  412.                                                     DQRDT, &
    413. 

  413.                                                     DQSDT, &
    414. 

  414.                                                      DTDT
    415. 

  415. 

  416.       REAL, DIMENSION( ims:ime , jms:jme ),                &
    417. 

  417.             INTENT(INOUT) ::                       RAINCV, &
    418. 

  418.                                                    PRATEC, &
    419. 

  419.                                                       NCA
    420. 

  420. !
    421. 

  421. !...DEFINE LOCAL VARIABLES...                                
    422. 

  422. !                                                            
    423. 

  423.       REAL, DIMENSION( kts:kte ) ::                        &
    424. 

  424.             Q0,Z0,TV0,TU,TVU,QU,TZ,TVD,                    &
    425. 

  425.             QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD,      &
    426. 

  426.             UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2,             &
    427. 

  427.             UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE,          &
    428. 

  428.             THTAU,THETEU,THTAD,THETED,QLIQ,QICE,           &
    429. 

  429.             QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC,       &
    430. 

  430.             DETLQ2,DETIC2,RATIO,RATIO2
    431. 

  431. 

  432.       REAL, DIMENSION( kts:kte ) ::                        &
    433. 

  433.             DOMGDP,EXN,RHOE,TVQU,DP,RH,EQFRC,WSPD,         &
    434. 

  434.             QDT,FXM,THTAG,THTESG,THPA,THFXTOP,             &
    435. 

  435.             THFXBOT,QPA,QFXTOP,QFXBOT,QLPA,QLFXIN,         &
    436. 

  436.             QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA,              &
    437. 

  437.             QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT,            &
    438. 

  438.             QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG
    439. 

  439.                                          
    440. 

  440.       REAL, DIMENSION( kts:kte+1 ) :: OMG
    441. 

  441.       REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB
    442. 

  442. 

  443. ! LOCAL VARS
    444. 

  444. 

  445.       REAL    :: P00,T00,CV,B61,RLF,RHIC,RHBC,PIE,         &
    446. 

  446.                  TTFRZ,TBFRZ,C5,RATE
    447. 

  447.       REAL    :: GDRY,ROCP,ALIQ,BLIQ,                      & 
    448. 

  448.                  CLIQ,DLIQ,AICE,BICE,CICE,DICE
    449. 

  449.       REAL    :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX,   &
    450. 

  450.                  ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL,     &
    451. 

  451.                  CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR,   &
    452. 

  452.                  ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,&
    453. 

  453.                  TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD,   &
    454. 

  454.                  UPNEW,ABE,WKLCL,THTUDL,TUDL,TTEMP,FRC1,   &
    455. 

  455.                  QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,&
    456. 

  456.                  DZZ,WSQ,UDLBE,REI,EE2,UD2,TTMP,F1,F2,     &
    457. 

  457.                  THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1,  &
    458. 

  458.                  UD1,CLDHGT,DPTT,QNEWLQ,DUMFDP,EE,TSAT,    &
    459. 

  459.                  THTA,P150,USR,VCONV,TIMEC,SHSIGN,VWS,PEF, &
    460. 

  460.                  CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN,   &
    461. 

  461.                  DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1,     &
    462. 

  462.                  DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF,   &
    463. 

  463.                  UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF,     &
    464. 

  464.                  DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, &
    465. 

  465.                  AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1,     &
    466. 

  466.                  DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF,   &
    467. 

  467.                  TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR,     &
    468. 

  468.                  UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2,    &
    469. 

  469.                  RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, &
    470. 

  470.                  DDFRC,TDC,DEFRC         
    471. 

  471. 

  472.       INTEGER :: KX,K,KL
    473. 

  473. !                                                    
    474. 

  474.       INTEGER :: ISTOP,ML,L5,L4,KMIX,LOW,                  &
    475. 

  475.                  LC,MXLAYR,LLFC,NLAYRS,NK,                 &
    476. 

  476.                  KPBL,KLCL,LCL,LET,IFLAG,                  &
    477. 

  477.                  KFRZ,NK1,LTOP,NJ,LTOP1,                   &
    478. 

  478.                  LTOPM1,LVF,KSTART,KMIN,LFS,               &
    479. 

  479.                  ND,NIC,LDB,LDT,ND1,NDK,                   &
    480. 

  480.                  NM,LMAX,NCOUNT,NOITR,                     &
    481. 

  481.                  NSTEP,NTC
    482. 

  482. !                                                    
    483. 

  483.       DATA P00,T00/1.E5,273.16/                     
    484. 

  484.       DATA CV,B61,RLF/717.,0.608,3.339E5/          
    485. 

  485.       DATA RHIC,RHBC/1.,0.90/                                    
    486. 

  486.       DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/
    487. 

  487.       DATA RATE/0.01/                                           
    488. 

  488. !-----------------------------------------------------------
    489. 

  489.       GDRY=-G/CP                                               
    490. 

  490.       ROCP=R/CP
    491. 

  491.       KL=kte
    492. 

  492.       KX=kte
    493. 

  493. !
    494. 

  494. !     ALIQ = 613.3   
    495. 

  495. !     BLIQ = 17.502                                                   
    496. 

  496. !     CLIQ = 4780.8                                                  
    497. 

  497. !     DLIQ = 32.19                                                  
    498. 

  498.       ALIQ = SVP1*1000.
    499. 

  499.       BLIQ = SVP2
    500. 

  500.       CLIQ = SVP2*SVPT0
    501. 

  501.       DLIQ = SVP3
    502. 

  502.       AICE = 613.2  
    503. 

  503.       BICE = 22.452                                         
    504. 

  504.       CICE = 6133.0                                        
    505. 

  505.       DICE = 0.61                                         
    506. 

  506. !
    507. 

  507. 

  508. !...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER      
    509. 

  509. !...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL)      
    510. 

  510. !...FIELD.  'FBFRC' IS THE FRACTION OF AVAILABLE       
    511. 

  511. !...PRECIPITATION TO BE FED BACK (0.0 - 1.0)...      
    512. 

  512. !                                                   
    513. 

  513.       FBFRC=0.0                                    
    514. 

  514. !                                                                       
    515. 

  515. !...SCHEME IS CALLED ONCE  ON EACH NORTH-SOUTH SLICE, THE LOOP BELOW   
    516. 

  516. !...CHECKS FOR THE POSSIBILITY OF INITIATING PARAMETERIZED            
    517. 

  517. !...CONVECTION AT EACH POINT WITHIN THE SLICE                        
    518. 

  518. !                                                                   
    519. 

  519. !...SEE IF IT IS NECESSARY TO CHECK FOR CONVECTIVE TRIGGERING AT THIS 
    520. 

  520. !...GRID POINT. IF NCA>0, CONVECTION IS ALREADY ACTIVE AT THIS POINT,
    521. 

  521. !...JUST FEED BACK THE TENDENCIES SAVED FROM THE TIME WHEN CONVECTION  
    522. 

  522. !...WAS INITIATED.  IF NCA<0, CONVECTION IS NOT ACTIVE                
    523. 

  523. !...AND YOU MAY WANT TO CHECK TO SEE IF IT CAN BE ACTIVATED FOR THE  
    524. 

  524. !...CURRENT CONDITIONS.  IN PREVIOUS APLICATIONS OF THIS SCHEME,    
    525. 

  525. !...THE VARIABLE ICLDCK WAS USED BELOW TO SAVE TIME BY ONLY CHECKING   
    526. 

  526. !...FOR THE POSSIBILITY OF CONVECTIVE INITIATION EVERY 5 OR 10        
    527. 

  527. !...MINUTES...                                                       
    528. 

  528. !                                                                   
    529. 

  529. 

  530. !  10 CONTINUE                                                 
    531. 

  531. !SUE  P300=1000.*(PSB(I,J)*A(KL)+PTOP-30.)+PP3D(I,J,KL)              
    532. 

  532. 

  533.       P300=P0(1)-30000.
    534. 

  534. !                                                                     
    535. 

  535. !...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF       
    536. 

  536. !...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND 
    537. 

  537. !...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION...                       
    538. 

  538. !                                                                       
    539. 

  539. !...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED  
    540. 

  540. !...FROM BOTTOM-UP IN THE KF SCHEME...                                
    541. 

  541. !                                                                    
    542. 

  542.       ML=0                                                        
    543. 

  543. !SUE  tmprpsb=1./PSB(I,J)
    544. 

  544. !SUE  CELL=PTOP*tmprpsb
    545. 

  545. 

  546.       DO 15 K=1,KX                                               
    547. 

  547. !SUE     P0(K)=1.E3*(A(NK)*PSB(I,J)+PTOP)+PP3D(I,J,NK)          
    548. 

  548. !                                                                        
    549. 

  549. !...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL...   
    550. 

  550. !                                                                      
    551. 

  551.          ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ))                 
    552. 

  552.          QES(K)=EP2*ES/(P0(K)-ES)                                 
    553. 

  553.          Q0(K)=AMIN1(QES(K),QV0(K))                                 
    554. 

  554.          Q0(K)=AMAX1(0.000001,Q0(K))                                 
    555. 

  555.          QL0(K)=0.                                                
    556. 

  556.          QI0(K)=0.                                               
    557. 

  557.          QR0(K)=0.                                              
    558. 

  558.          QS0(K)=0.                                             
    559. 

  559. 

  560.          TV0(K)=T0(K)*(1.+B61*Q0(K))                                 
    561. 

  561.          RHOE(K)=P0(K)/(R*TV0(K))                                  
    562. 

  562. 

  563.          DP(K)=rho(k)*g*DZQ(k)
    564. 

  564. !                                                                         
    565. 

  565. !...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL 
    566. 

  566. !   DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS...            
    567. 

  567. !                                                                      
    568. 

  568.          IF(P0(K).GE.500E2)L5=K                                       
    569. 

  569.          IF(P0(K).GE.400E2)L4=K                                      
    570. 

  570.          IF(P0(K).GE.P300)LLFC=K                                    
    571. 

  571.          IF(T0(K).GT.T00)ML=K                                      
    572. 

  572.    15   CONTINUE                                                   
    573. 

  573. 

  574.         Z0(1)=.5*DZQ(1)   
    575. 

  575.         DO 20 K=2,KL                                              
    576. 

  576.           Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1))   
    577. 

  577.           DZA(K-1)=Z0(K)-Z0(K-1)                                 
    578. 

  578.    20   CONTINUE                                                       
    579. 

  579.         DZA(KL)=0.                                                    
    580. 

  580.         KMIX=1                                                       
    581. 

  581.    25   LOW=KMIX                                                    
    582. 

  582. 

  583.         IF(LOW.GT.LLFC)GOTO 325                                    
    584. 

  584. 

  585.         LC=LOW                                                    
    586. 

  586.         MXLAYR=0                                                 
    587. 

  587. !                                                                        
    588. 

  588. !...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF 
    589. 

  589. !...UNSTABLE AIR 50 TO 100 mb DEEP...TO APPROXIMATE THIS, ISOLATE A      
    590. 

  590. !...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL   
    591. 

  591. !...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 60 mb..  
    592. 

  592. !                                                                        
    593. 

  593.         NLAYRS=0                                                        
    594. 

  594.         DPTHMX=0.                                                      
    595. 

  595.         DO 63 NK=LC,KX                                                
    596. 

  596.           DPTHMX=DPTHMX+DP(NK)                                            
    597. 

  597.           NLAYRS=NLAYRS+1                                                
    598. 

  598.    63   IF(DPTHMX.GT.6.E3)GOTO 64                                       
    599. 

  599.         GOTO 325                                                       
    600. 

  600.    64   KPBL=LC+NLAYRS-1                                              
    601. 

  601.         KMIX=LC+1                                                        
    602. 

  602.    18   THMIX=0.                                                        
    603. 

  603.         QMIX=0.                                                        
    604. 

  604.         ZMIX=0.                                                       
    605. 

  605.         PMIX=0.                                                             
    606. 

  606.         DPTHMX=0.                                                          
    607. 

  607. !                                                                         
    608. 

  608. !...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY              
    609. 

  609. !...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL         
    610. 

  610. !...LAYERS...                                                         
    611. 

  611. !                                                                    
    612. 

  612.         DO 17 NK=LC,KPBL                                            
    613. 

  613.           DPTHMX=DPTHMX+DP(NK)                                     
    614. 

  614.           ROCPQ=0.2854*(1.-0.28*Q0(NK))                           
    615. 

  615.           THMIX=THMIX+DP(NK)*T0(NK)*(P00/P0(NK))**ROCPQ          
    616. 

  616.           QMIX=QMIX+DP(NK)*Q0(NK)                               
    617. 

  617.           ZMIX=ZMIX+DP(NK)*Z0(NK)                              
    618. 

  618.    17   PMIX=PMIX+DP(NK)*P0(NK)                               
    619. 

  619.         THMIX=THMIX/DPTHMX                                   
    620. 

  620.         QMIX=QMIX/DPTHMX                                    
    621. 

  621.         ZMIX=ZMIX/DPTHMX                                   
    622. 

  622.         PMIX=PMIX/DPTHMX                                  
    623. 

  623.         ROCPQ=0.2854*(1.-0.28*QMIX)                               
    624. 

  624.         TMIX=THMIX*(PMIX/P00)**ROCPQ                             
    625. 

  625.         EMIX=QMIX*PMIX/(EP2+QMIX)                             
    626. 

  626. !                                                              
    627. 

  627. !...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL, PRESSURE       
    628. 

  628. !...LEVEL OF LCL...                                               
    629. 

  629. !                                                                
    630. 

  630.         TLOG=ALOG(EMIX/ALIQ)                                    
    631. 

  631.         TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG)                             
    632. 

  632.         TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-  &
    633. 

  633.              TDPT)                                                    
    634. 

  634.         TLCL=AMIN1(TLCL,TMIX)                                       
    635. 

  635.         TVLCL=TLCL*(1.+0.608*QMIX)                                 
    636. 

  636.         CPORQ=1./ROCPQ                                            
    637. 

  637.         PLCL=P00*(TLCL/THMIX)**CPORQ                             
    638. 

  638.         DO 29 NK=LC,KL                                          
    639. 

  639.           KLCL=NK                                              
    640. 

  640.           IF(PLCL.GE.P0(NK))GOTO 35                           
    641. 

  641.    29   CONTINUE                                            
    642. 

  642.         GOTO 325                                                       
    643. 

  643.    35   K=KLCL-1                                                      
    644. 

  644.         DLP=ALOG(PLCL/P0(K))/ALOG(P0(KLCL)/P0(K))                    
    645. 

  645. !                                                                   
    646. 

  646. !...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL...
    647. 

  647. !                                                                   
    648. 

  648.         TENV=T0(K)+(T0(KLCL)-T0(K))*DLP                            
    649. 

  649.         QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP                           
    650. 

  650.         TVEN=TENV*(1.+0.608*QENV)                                
    651. 

  651.         TVBAR=0.5*(TV0(K)+TVEN)                                 
    652. 

  652. !        ZLCL=Z0(K)+R*TVBAR*ALOG(P0(K)/PLCL)/G                 
    653. 

  653.         ZLCL=Z0(K)+(Z0(KLCL)-Z0(K))*DLP                                 
    654. 

  654. !                                                                      
    655. 

  655. !...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER  
    656. 

  656. !...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0AVG IS AN     
    657. 

  657. !...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL      
    658. 

  658. !...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION 
    659. 

  659. !...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE            
    660. 

  660. !...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST         
    661. 

  661. !...SUCCESS AT GRID LENGTHS NEAR 25 km.  FOR DIFFERENT GRID-LENGTHS,     
    662. 

  662. !...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID         
    663. 

  663. !...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH...          
    664. 

  664. !                                                                     
    665. 

  665.         WKLCL=0.02*ZLCL/2.5E3                                             
    666. 

  666.         WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3- & 
    667. 

  667.             WKLCL                                                           
    668. 

  668.         WABS=ABS(WKL)+1.E-10                                               
    669. 

  669.         WSIGNE=WKL/WABS                                                   
    670. 

  670.         DTLCL=4.64*WSIGNE*WABS**0.33                                     
    671. 

  671.         GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN)                        
    672. 

  672.         WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10)                        
    673. 

  673.         IF(TLCL+DTLCL.GT.TENV)GOTO 45                                 
    674. 

  674.         IF(KPBL.GE.LLFC)GOTO 325                                     
    675. 

  675.         GOTO 25                                                     
    676. 

  676. !                                                                       
    677. 

  677. !...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE           
    678. 

  678. !...EQUIVALENT POTENTIAL TEMPERATURE                                     
    679. 

  679. !...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL...    
    680. 

  680. !                                                                       
    681. 

  681.    45   THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & 
    682. 

  682.                   EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX))     
    683. 

  683.         ES=ALIQ*EXP((TENV*BLIQ-CLIQ)/(TENV-DLIQ))                     
    684. 

  684.         TVAVG=0.5*(TV0(KLCL)+TENV*(1.+0.608*QENV))                   
    685. 

  685.         PLCL=P0(KLCL)*EXP(G/(R*TVAVG)*(Z0(KLCL)-ZLCL))              
    686. 

  686.         QESE=EP2*ES/(PLCL-ES)                                    
    687. 

  687.         GDT=G*DTLCL*(ZLCL-Z0(LC))/(TV0(LC)+TVEN)                  
    688. 

  688.         WLCL=1.+.5*WSIGNE*SQRT(ABS(GDT)+1.E-10)                      
    689. 

  689.         THTES(K)=TENV*(1.E5/PLCL)**(0.2854*(1.-0.28*QESE))* &    
    690. 

  690.                  EXP((3374.6525/TENV-2.5403)*QESE*(1.+0.81*QESE))           
    691. 

  691.         WTW=WLCL*WLCL                                                      
    692. 

  692.         IF(WLCL.LT.0.)GOTO 25                                             
    693. 

  693.         TVLCL=TLCL*(1.+0.608*QMIX)                                       
    694. 

  694.         RHOLCL=PLCL/(R*TVLCL)                                           
    695. 

  695. !                                                                      
    696. 

  696.         LCL=KLCL                                                      
    697. 

  697.         LET=LCL                                                            
    698. 

  698. !                                                                         
    699. 

  699. !*******************************************************************     
    700. 

  700. !                                                                  *    
    701. 

  701. !                 COMPUTE UPDRAFT PROPERTIES                       *   
    702. 

  702. !                                                                  *  
    703. 

  703. !******************************************************************* 
    704. 

  704. !                                                                   
    705. 

  705. !                                                                  
    706. 

  706. !...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))...                
    707. 

  707. !                                                                
    708. 

  708.         WU(K)=WLCL                                                          
    709. 

  709.         AU0=PIE*RAD*RAD                                                    
    710. 

  710.         UMF(K)=RHOLCL*AU0                                                 
    711. 

  711.         VMFLCL=UMF(K)                                                    
    712. 

  712.         UPOLD=VMFLCL                                                    
    713. 

  713.         UPNEW=UPOLD                                                    
    714. 

  714. !                                                                     
    715. 

  715. !...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1),        
    716. 

  716. !...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE BUOYANT ENERGY,   
    717. 

  717. !   TRPPT IS THE TOTAL RATE OF PRECIPITATION PRODUCTION...               
    718. 

  718. !                                                                         
    719. 

  719.         RATIO2(K)=0.                                                    
    720. 

  720.         UER(K)=0.                                                      
    721. 

  721.         ABE=0.                                                        
    722. 

  722.         TRPPT=0.                                                     
    723. 

  723.         TU(K)=TLCL                                                  
    724. 

  724.         TVU(K)=TVLCL                                               
    725. 

  725.         QU(K)=QMIX                                                
    726. 

  726.         EQFRC(K)=1.                                              
    727. 

  727.         QLIQ(K)=0.                                              
    728. 

  728.         QICE(K)=0.                                             
    729. 

  729.         QLQOUT(K)=0.                                          
    730. 

  730.         QICOUT(K)=0.                                         
    731. 

  731.         DETLQ(K)=0.                                         
    732. 

  732.         DETIC(K)=0.                                        
    733. 

  733.         PPTLIQ(K)=0.                                     
    734. 

  734.         PPTICE(K)=0.                                    
    735. 

  735.         IFLAG=0                                        
    736. 

  736.         KFRZ=LC                                       
    737. 

  737. !                                                    
    738. 

  738. !...THE AMOUNT OF CONV AVAIL POT ENERGY (CAPE) IS CALCULATED WITH   
    739. 

  739. !   RESPECT TO UNDILUTE PARCEL ASCENT; EQ POT TEMP OF UNDILUTE     
    740. 

  740. !   PARCEL IS THTUDL, UNDILUTE TEMPERATURE IS GIVEN BY TUDL...    
    741. 

  741. !                                                                
    742. 

  742.         THTUDL=THETEU(K)                                        
    743. 

  743.         TUDL=TLCL                                              
    744. 

  744. !                                                             
    745. 

  745. !...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION        
    746. 

  746. !   PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH        
    747. 

  747. !   FREEZING IS SPECIFIED TO BEGIN.  WITHIN THE GLACIATION         
    748. 

  748. !   INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE          
    749. 

  749. !   PREVIOUS MODEL LEVEL...                                      
    750. 

  750. !                                                               
    751. 

  751.         TTEMP=TTFRZ                                                   
    752. 

  752. !                                                                    
    753. 

  753. !...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP,    
    754. 

  754. !   MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND   
    755. 

  755. !   MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL...               
    756. 

  756. !                                                                     
    757. 

  757.         DO 60 NK=K,KL-1
    758. 

  758.           NK1=NK+1                                                         
    759. 

  759.           RATIO2(NK1)=RATIO2(NK)                                          
    760. 

  760. !                                                                        
    761. 

  761. !...UPDATE UPDRAFT PROPERTIES AT THE NEXT MODEL LVL TO REFLECT          
    762. 

  762. !   ENTRAINMENT OF ENVIRONMENTAL AIR...                                     
    763. 

  763. !                                                                          
    764. 

  764.           FRC1=0.                                                         
    765. 

  765.           TU(NK1)=T0(NK1)                                                
    766. 

  766.           THETEU(NK1)=THETEU(NK)                                        
    767. 

  767.           QU(NK1)=QU(NK)                                               
    768. 

  768.           QLIQ(NK1)=QLIQ(NK)                                          
    769. 

  769.           QICE(NK1)=QICE(NK)                                         
    770. 

  770. 

  771.           CALL TPMIX(P0(NK1),THETEU(NK1),TU(NK1),QU(NK1),QLIQ(NK1), & 
    772. 

  772.                QICE(NK1),QNEWLQ,QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0, &
    773. 

  773.                XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE)        
    774. 

  774.           TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1))                      
    775. 

  775. !                                                                 
    776. 

  776. !...CHECK TO SEE IF UPDRAFT TEMP IS WITHIN THE FREEZING INTERVAL,
    777. 

  777. !   IF IT IS, CALCULATE THE FRACTIONAL CONVERSION TO GLACIATION     
    778. 

  778. !   AND ADJUST QNEWLQ TO REFLECT THE GRADUAL CHANGE IN THETAU      
    779. 

  779. !   SINCE THE LAST MODEL LEVEL...THE GLACIATION EFFECTS WILL BE   
    780. 

  780. !   DETERMINED AFTER THE AMOUNT OF CONDENSATE AVAILABLE AFTER    
    781. 

  781. !   PRECIP FALLOUT IS DETERMINED...TTFRZ IS THE TEMP AT WHICH   
    782. 

  782. !   GLACIATION BEGINS, TBFRZ THE TEMP AT WHICH IT ENDS...     
    783. 

  783. !                                                            
    784. 

  784.           IF(TU(NK1).LE.TTFRZ.AND.IFLAG.LT.1)THEN                    
    785. 

  785.             IF(TU(NK1).GT.TBFRZ)THEN                                
    786. 

  786.               IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ                        
    787. 

  787.               FRC1=(TTEMP-TU(NK1))/(TTFRZ-TBFRZ)                  
    788. 

  788.               R1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ)                   
    789. 

  789.             ELSE                                                
    790. 

  790.               FRC1=(TTEMP-TBFRZ)/(TTFRZ-TBFRZ)                
    791. 

  791.               R1=1.                                          
    792. 

  792.               IFLAG=1                                       
    793. 

  793.             ENDIF                                          
    794. 

  794.             QNWFRZ=QNEWLQ                                 
    795. 

  795.             QNEWIC=QNEWIC+QNEWLQ*R1*0.5                  
    796. 

  796.             QNEWLQ=QNEWLQ-QNEWLQ*R1*0.5                 
    797. 

  797.             EFFQ=(TTFRZ-TBFRZ)/(TTEMP-TBFRZ)           
    798. 

  798.             TTEMP=TU(NK1)                             
    799. 

  799.           ENDIF                                      
    800. 

  800. !                                                  
    801. 

  801. !  CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT...  
    802. 

  802. !                                                                   
    803. 

  803.           IF(NK.EQ.K)THEN                                          
    804. 

  804.             BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1.                
    805. 

  805.             BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5                    
    806. 

  806.             ENTERM=0.                                           
    807. 

  807.             DZZ=Z0(NK1)-ZLCL                                   
    808. 

  808.           ELSE                                                
    809. 

  809.             BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1.      
    810. 

  810.             BOTERM=2.*DZA(NK)*G*BE/1.5                                        
    811. 

  811.             ENTERM=2.*UER(NK)*WTW/UPOLD                                      
    812. 

  812.             DZZ=DZA(NK)                                                     
    813. 

  813.           ENDIF                                                            
    814. 

  814.           WSQ=WTW                                                         
    815. 

  815.           CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM,RATE, & 
    816. 

  816.                QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1), G)                    
    817. 

  817.                                                               
    818. 

  818. !...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND,     
    819. 

  819. !   IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS...         
    820. 

  820. !                                                                    
    821. 

  821.           IF(WTW.LE.0.)GOTO 65                                      
    822. 

  822.           WABS=SQRT(ABS(WTW))                                      
    823. 

  823.           WU(NK1)=WTW/WABS                                        
    824. 

  824. !                                                                
    825. 

  825. !  UPDATE THE ABE FOR UNDILUTE ASCENT...                        
    826. 

  826. !                                                                         
    827. 

  827.           THTES(NK1)=T0(NK1)*(1.E5/P0(NK1))**(0.2854*(1.-0.28*QES(NK1))) & 
    828. 

  828.                      *                                                   &
    829. 

  829.                      EXP((3374.6525/T0(NK1)-2.5403)*QES(NK1)*(1.+0.81*   &
    830. 

  830.                      QES(NK1)))                                          
    831. 

  831.           UDLBE=((2.*THTUDL)/(THTES(NK)+THTES(NK1))-1.)*DZZ             
    832. 

  832.           IF(UDLBE.GT.0.)ABE=ABE+UDLBE*G                               
    833. 

  833. !                                                                     
    834. 

  834. !  DETERMINE THE EFFECTS OF CLOUD GLACIATION IF WITHIN THE SPECIFIED 
    835. 

  835. !  TEMP INTERVAL...                                                 
    836. 

  836. !                                                                  
    837. 

  837.           IF(FRC1.GT.1.E-6)THEN                                   
    838. 

  838.             CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QLIQ(NK1), & 
    839. 

  839.                  QICE(NK1),RATIO2(NK1),TTFRZ,TBFRZ,QNWFRZ,RL,FRC1,EFFQ,  &
    840. 

  840.                  IFLAG,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE &  
    841. 

  841.                  ,CICE,DICE)                                     
    842. 

  842.           ENDIF                                                 
    843. 

  843. !                                                              
    844. 

  844. !  CALL SUBROUTINE TO CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMP.      
    845. 

  845. !  WITHIN GLACIATION INTERVAL, THETAE MUST BE CALCULATED WITH RESPECT TO     
    846. 

  846. !  SAME DEGREE OF GLACIATION FOR ALL ENTRAINING AIR...                      
    847. 

  847. !                                                                          
    848. 

  848.           CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),RATIO2(NK1), &
    849. 

  849.                RL,EP2,ALIQ,BLIQ,CLIQ,DLIQ,AICE,BICE,CICE,DICE)                
    850. 

  850.                                                                          
    851. 

  851. !...REI IS THE RATE OF ENVIRONMENTAL INFLOW...                          
    852. 

  852. !                                                                      
    853. 

  853.           REI=VMFLCL*DP(NK1)*0.03/RAD                                 
    854. 

  854.           TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1))   
    855. 

  855. !                                                                   
    856. 

  856. !...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, NO 
    857. 

  857. !   ENTRAINMENT IS ALLOWED AT THIS LEVEL...                               
    858. 

  858. !                                                                        
    859. 

  859.           IF(TVQU(NK1).LE.TV0(NK1))THEN                                 
    860. 

  860.             UER(NK1)=0.0                                               
    861. 

  861.             UDR(NK1)=REI                                              
    862. 

  862.             EE2=0.                                                   
    863. 

  863.             UD2=1.                                                  
    864. 

  864.             EQFRC(NK1)=0.                                          
    865. 

  865.             GOTO 55                                                        
    866. 

  866.           ENDIF                                                          
    867. 

  867.           LET=NK1                                                       
    868. 

  868.           TTMP=TVQU(NK1)                                               
    869. 

  869. !                                                                          
    870. 

  870. !...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL    
    871. 

  871. !   AIR FOR ESTIMATION OF ENTRAINMENT AND DETRAINMENT RATES...           
    872. 

  872. !                                                                       
    873. 

  873.           F1=0.95                                                      
    874. 

  874.           F2=1.-F1                                                    
    875. 

  875.           THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)                       
    876. 

  876.           QTMP=F1*Q0(NK1)+F2*QU(NK1)                                
    877. 

  877.           TMPLIQ=F2*QLIQ(NK1)                                      
    878. 

  878.           TMPICE=F2*QICE(NK1)                                                
    879. 

  879.           CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ,      & 
    880. 

  880.                QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, &
    881. 

  881.                DLIQ,AICE,BICE,CICE,DICE)                                    
    882. 

  882.           TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)                          
    883. 

  883.           IF(TU95.GT.TV0(NK1))THEN                                        
    884. 

  884.             EE2=1.                                                       
    885. 

  885.             UD2=0.                                                      
    886. 

  886.             EQFRC(NK1)=1.0                                             
    887. 

  887.             GOTO 50                                                   
    888. 

  888.           ENDIF                                                              
    889. 

  889.           F1=0.10                                                           
    890. 

  890.           F2=1.-F1                                                         
    891. 

  891.           THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1)                            
    892. 

  892.           QTMP=F1*Q0(NK1)+F2*QU(NK1)                                    
    893. 

  893.           TMPLIQ=F2*QLIQ(NK1)                                            
    894. 

  894.           TMPICE=F2*QICE(NK1)                                               
    895. 

  895.           CALL TPMIX(P0(NK1),THTTMP,TTMP,QTMP,TMPLIQ,TMPICE,QNEWLQ,      & 
    896. 

  896.                QNEWIC,RATIO2(NK1),RL,XLV0,XLV1,XLS0,XLS1,EP2,ALIQ,BLIQ,CLIQ, &
    897. 

  897.                DLIQ,AICE,BICE,CICE,DICE)                                   
    898. 

  898.           TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE)                         
    899. 

  899.           IF(TU10.EQ.TVQU(NK1))THEN                                      
    900. 

  900.             EE2=1.                                                      
    901. 

  901.             UD2=0.                                                     
    902. 

  902.             EQFRC(NK1)=1.0                                            
    903. 

  903.             GOTO 50                                                  
    904. 

  904.           ENDIF                                                     
    905. 

  905.           EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1))      
    906. 

  906.           EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1))                        
    907. 

  907.           EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1))                       
    908. 

  908.           IF(EQFRC(NK1).EQ.1)THEN                               
    909. 

  909.             EE2=1.                                             
    910. 

  910.             UD2=0.                                            
    911. 

  911.             GOTO 50                                          
    912. 

  912.           ELSEIF(EQFRC(NK1).EQ.0.)THEN                                       
    913. 

  913.             EE2=0.                                                          
    914. 

  914.             UD2=1.                                                         
    915. 

  915.             GOTO 50                                                       
    916. 

  916.           ELSE                                                           
    917. 

  917. !                                                                       
    918. 

  918. !...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE
    919. 

  919. !   FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES...                   
    920. 

  920. !                                                                    
    921. 

  921.             CALL PROF5(EQFRC(NK1),EE2,UD2)                          
    922. 

  922.           ENDIF                                                    
    923. 

  923. !                                                                 
    924. 

  924.    50     IF(NK.EQ.K)THEN                                        
    925. 

  925.             EE1=1.                                              
    926. 

  926.             UD1=0.                                             
    927. 

  927.           ENDIF                                               
    928. 

  928. !                                                            
    929. 

  929. !...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE         
    930. 

  930. !   FRACTIONAL VALUES IN THE LAYER...                                     
    931. 

  931. !                                                                        
    932. 

  932.           UER(NK1)=0.5*REI*(EE1+EE2)                                    
    933. 

  933.           UDR(NK1)=0.5*REI*(UD1+UD2)                                   
    934. 

  934. !                                                                     
    935. 

  935. !...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL  
    936. 

  936. !   UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATION    
    937. 

  937. !                                                                          
    938. 

  938.    55     IF(UMF(NK)-UDR(NK1).LT.10.)THEN                                
    939. 

  939. !                                                                       
    940. 

  940. !...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL    
    941. 

  941. !   UPDRAFT FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE     
    942. 

  942. !   PREVIOUS MODEL                                                   
    943. 

  943. !                                                       …
    944.

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