PageRenderTime 93ms CodeModel.GetById 26ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/phys/module_cu_gd.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 4555 lines | 3062 code | 317 blank | 1176 comment | 192 complexity | f99ad882e1f460753dbe05b590e319d4 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !WRF:MODEL_LAYER:PHYSICS
    2. 

  2. !
    3. 

  3. 

  4. MODULE module_cu_gd
    5. 

  5. 

  6. CONTAINS
    7. 

  7. 

  8. !-------------------------------------------------------------
    9. 

  9.    SUBROUTINE GRELLDRV(                                         &
    10. 

  10.                DT,itimestep,DX                                  &
    11. 

  11.               ,rho,RAINCV,PRATEC                                &
    12. 

  12.               ,U,V,t,W,q,p,pi                                   &
    13. 

  13.               ,dz8w,p8w,XLV,CP,G,r_v                            &
    14. 

  14.               ,STEPCU,htop,hbot                                 &
    15. 

  15.               ,CU_ACT_FLAG,warm_rain                            &
    16. 

  16.               ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS                &
    17. 

  17.               ,APR_CAPMA,APR_CAPME,APR_CAPMI                    &
    18. 

  18.               ,MASS_FLUX,XF_ENS,PR_ENS,HT,XLAND,gsw             &
    19. 

  19.               ,GDC,GDC2                                         &
    20. 

  20.               ,ensdim,maxiens,maxens,maxens2,maxens3            &
    21. 

  21.               ,ids,ide, jds,jde, kds,kde                        &
    22. 

  22.               ,ims,ime, jms,jme, kms,kme                        &
    23. 

  23.               ,its,ite, jts,jte, kts,kte                        &
    24. 

  24.               ,periodic_x,periodic_y                            &
    25. 

  25.               ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
    26. 

  26.               ,RQVFTEN,RQVBLTEN                                 &
    27. 

  27.               ,RTHFTEN,RTHCUTEN,RTHRATEN,RTHBLTEN               &
    28. 

  28.               ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS         &
    29. 

  29.               ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux             )
    30. 

  30. 

  31. !-------------------------------------------------------------
    32. 

  32.    IMPLICIT NONE
    33. 

  33. !-------------------------------------------------------------
    34. 

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

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

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

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

  38.    LOGICAL periodic_x,periodic_y
    39. 

  39. 

  40.    integer, intent (in   )              ::                      &
    41. 

  41.                        ensdim,maxiens,maxens,maxens2,maxens3
    42. 

  42.   
    43. 

  43.    INTEGER,      INTENT(IN   ) :: STEPCU, ITIMESTEP
    44. 

  44.    LOGICAL,      INTENT(IN   ) :: warm_rain
    45. 

  45. 

  46.    REAL,         INTENT(IN   ) :: XLV, R_v
    47. 

  47.    REAL,         INTENT(IN   ) :: CP,G
    48. 

  48. 

  49.    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
    50. 

  50.           INTENT(IN   ) ::                                      &
    51. 

  51.                                                           U,    &
    52. 

  52.                                                           V,    &
    53. 

  53.                                                           W,    &
    54. 

  54.                                                          pi,    &
    55. 

  55.                                                           t,    &
    56. 

  56.                                                           q,    &
    57. 

  57.                                                           p,    &
    58. 

  58.                                                        dz8w,    &
    59. 

  59.                                                        p8w,    &
    60. 

  60.                                                         rho
    61. 

  61.    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
    62. 

  62.           OPTIONAL                                         ,    &
    63. 

  63.           INTENT(INOUT   ) ::                                   &
    64. 

  64.                GDC,GDC2
    65. 

  65. 

  66. 

  67.    REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: GSW,HT,XLAND
    68. 

  68. !
    69. 

  69.    REAL, INTENT(IN   ) :: DT, DX
    70. 

  70. !
    71. 

  71. 

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

  73.          INTENT(INOUT) ::         RAINCV, PRATEC, MASS_FLUX,    &
    74. 

  74.                           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,    &
    75. 

  75.                               APR_CAPMA,APR_CAPME,APR_CAPMI,htop,hbot
    76. 

  76. !+lxz
    77. 

  77. !  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
    78. 

  78. !        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
    79. 

  79. !        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
    80. 

  80. !                   ! HBOT>HTOP follow physics leveling convention
    81. 

  81. 

  82.    LOGICAL, DIMENSION( ims:ime , jms:jme ),                     &
    83. 

  83.          INTENT(INOUT) ::                       CU_ACT_FLAG
    84. 

  84. 

  85. !
    86. 

  86. ! Optionals
    87. 

  87. !
    88. 

  88.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
    89. 

  89.          OPTIONAL,                                              &
    90. 

  90.          INTENT(INOUT) ::                           RTHFTEN,    &
    91. 

  91.                                                     RQVFTEN
    92. 

  92. 

  93.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
    94. 

  94.          OPTIONAL,                                              &
    95. 

  95.          INTENT(IN   ) ::                                       &
    96. 

  96.                                                    RTHRATEN,    &
    97. 

  97.                                                    RTHBLTEN,    &
    98. 

  98.                                                    RQVBLTEN
    99. 

  99.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
    100. 

  100.          OPTIONAL,                                              &
    101. 

  101.          INTENT(INOUT) ::                                       &
    102. 

  102.                                                    RTHCUTEN,    &
    103. 

  103.                                                    RQVCUTEN,    &
    104. 

  104.                                                    RQCCUTEN,    &
    105. 

  105.                                                    RQICUTEN
    106. 

  106.    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
    107. 

  107.          OPTIONAL,                                              &
    108. 

  108.          INTENT(INOUT) ::                                       &
    109. 

  109.                                                    CFU1,        &
    110. 

  110.                                                    CFD1,        &
    111. 

  111.                                                    DFU1,        &
    112. 

  112.                                                    EFU1,        &
    113. 

  113.                                                    DFD1,        &
    114. 

  114.                                                    EFD1
    115. 

  115. !
    116. 

  116. ! Flags relating to the optional tendency arrays declared above
    117. 

  117. ! Models that carry the optional tendencies will provdide the
    118. 

  118. ! optional arguments at compile time; these flags all the model
    119. 

  119. ! to determine at run-time whether a particular tracer is in
    120. 

  120. ! use or not.
    121. 

  121. !
    122. 

  122.    LOGICAL, OPTIONAL ::                                      &
    123. 

  123.                                                    F_QV      &
    124. 

  124.                                                   ,F_QC      &
    125. 

  125.                                                   ,F_QR      &
    126. 

  126.                                                   ,F_QI      &
    127. 

  127.                                                   ,F_QS
    128. 

  128.    LOGICAL, intent(in), OPTIONAL ::                f_flux
    129. 

  129. 

  130. 

  131. 

  132. ! LOCAL VARS
    133. 

  133.      real,    dimension ( ims:ime , jms:jme , 1:ensdim) ::      &
    134. 

  134.         massfln,xf_ens,pr_ens
    135. 

  135.      real,    dimension (its:ite,kts:kte+1) ::                    &
    136. 

  136.         OUTT,OUTQ,OUTQC,phh,cupclw,     &
    137. 

  137.         outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
    138. 

  138.      logical :: l_flux
    139. 

  139.      real,    dimension (its:ite)         ::                    &
    140. 

  140.         pret, ter11, aa0, fp
    141. 

  141. !+lxz
    142. 

  142.      integer, dimension (its:ite) ::                            &
    143. 

  143.         kbcon, ktop
    144. 

  144. !.lxz
    145. 

  145.      integer, dimension (its:ite,jts:jte) ::                    &
    146. 

  146.         iact_old_gr
    147. 

  147.      integer :: ichoice,iens,ibeg,iend,jbeg,jend
    148. 

  148. 

  149. !
    150. 

  150. ! basic environmental input includes moisture convergence (mconv)
    151. 

  151. ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off
    152. 

  152. ! convection for this call only and at that particular gridpoint
    153. 

  153. !
    154. 

  154.      real,    dimension (its:ite,kts:kte+1) ::                    &
    155. 

  155.         T2d,TN,q2d,qo,PO,P2d,US,VS,omeg
    156. 

  156.      real, dimension (its:ite)            ::                    &
    157. 

  157.         Z1,PSUR,AAEQ,direction,mconv,cuten,umean,vmean,pmean
    158. 

  158. 

  159.    INTEGER :: i,j,k,ICLDCK,ipr,jpr
    160. 

  160.    REAL    :: tcrit,dp,dq
    161. 

  161.    INTEGER :: itf,jtf,ktf
    162. 

  162.    REAL    :: rkbcon,rktop        !-lxz
    163. 

  163. 

  164.    l_flux=.FALSE.
    165. 

  165.    if (present(f_flux)) l_flux=f_flux
    166. 

  166.    if (l_flux) then
    167. 

  167.       l_flux = l_flux .and. present(cfu1) .and. present(cfd1)   &
    168. 

  168.                .and. present(dfu1) .and. present(efu1)          &
    169. 

  169.                .and. present(dfd1) .and. present(efd1)
    170. 

  170.    endif
    171. 

  171. 

  172.    ichoice=0
    173. 

  173.    iens=1
    174. 

  174.      ipr=0
    175. 

  175.      jpr=0
    176. 

  176. 

  177.    IF ( periodic_x ) THEN
    178. 

  178.       ibeg=max(its,ids)
    179. 

  179.       iend=min(ite,ide-1)
    180. 

  180.    ELSE
    181. 

  181.       ibeg=max(its,ids+4)
    182. 

  182.       iend=min(ite,ide-5)
    183. 

  183.    END IF
    184. 

  184.    IF ( periodic_y ) THEN
    185. 

  185.       jbeg=max(jts,jds)
    186. 

  186.       jend=min(jte,jde-1)
    187. 

  187.    ELSE
    188. 

  188.       jbeg=max(jts,jds+4)
    189. 

  189.       jend=min(jte,jde-5)
    190. 

  190.    END IF
    191. 

  191. 

  192. 

  193.    tcrit=258.
    194. 

  194. 

  195.    itf=MIN(ite,ide-1)
    196. 

  196.    ktf=MIN(kte,kde-1)
    197. 

  197.    jtf=MIN(jte,jde-1)
    198. 

  198. !                                                                      
    199. 

  199.      DO 100 J = jts,jtf  
    200. 

  200.      DO I= its,itf
    201. 

  201.         cuten(i)=0.
    202. 

  202.         iact_old_gr(i,j)=0
    203. 

  203.         mass_flux(i,j)=0.
    204. 

  204.         pratec(i,j) = 0.
    205. 

  205.         raincv(i,j)=0.
    206. 

  206.         CU_ACT_FLAG(i,j) = .true.
    207. 

  207.      ENDDO
    208. 

  208.      DO k=1,ensdim
    209. 

  209.      DO I= its,itf
    210. 

  210.         massfln(i,j,k)=0.
    211. 

  211.      ENDDO
    212. 

  212.      ENDDO
    213. 

  213. #if ( EM_CORE == 1 )
    214. 

  214.      DO k= kts,ktf
    215. 

  215.      DO I= its,itf
    216. 

  216.         RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j))*pi(i,k,j)
    217. 

  217.         RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j)
    218. 

  218.      ENDDO
    219. 

  219.      ENDDO
    220. 

  220. #endif
    221. 

  221.      !  put hydrostatic pressure on half levels
    222. 

  222.      DO K=kts,ktf
    223. 

  223.      DO I=ITS,ITF
    224. 

  224.          phh(i,k) = p(i,k,j)
    225. 

  225.      ENDDO
    226. 

  226.      ENDDO
    227. 

  227.      DO I=ITS,ITF
    228. 

  228.          PSUR(I)=p8w(I,1,J)*.01
    229. 

  229.          TER11(I)=HT(i,j)
    230. 

  230.          mconv(i)=0.
    231. 

  231.          aaeq(i)=0.
    232. 

  232.          direction(i)=0.
    233. 

  233.          pret(i)=0.
    234. 

  234.          umean(i)=0.
    235. 

  235.          vmean(i)=0.
    236. 

  236.          pmean(i)=0.
    237. 

  237.      ENDDO
    238. 

  238.      DO K=kts,ktf
    239. 

  239.      DO I=ITS,ITF
    240. 

  240.          omeg(i,k)=0.
    241. 

  241. !        cupclw(i,k)=0.
    242. 

  242.          po(i,k)=phh(i,k)*.01
    243. 

  243.          P2d(I,K)=PO(i,k)
    244. 

  244.          US(I,K) =u(i,k,j)
    245. 

  245.          VS(I,K) =v(i,k,j)
    246. 

  246.          T2d(I,K)=t(i,k,j)
    247. 

  247.          q2d(I,K)=q(i,k,j)
    248. 

  248.          omeg(I,K)= -g*rho(i,k,j)*w(i,k,j)
    249. 

  249.          TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt
    250. 

  250.          IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
    251. 

  251.          QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt
    252. 

  252.          IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
    253. 

  253.          IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
    254. 

  254.          OUTT(I,K)=0.
    255. 

  255.          OUTQ(I,K)=0.
    256. 

  256.          OUTQC(I,K)=0.
    257. 

  257. !        RTHFTEN(i,k,j)=0.
    258. 

  258. !        RQVFTEN(i,k,j)=0.
    259. 

  259.      ENDDO
    260. 

  260.      ENDDO
    261. 

  261.       do k=  kts+1,ktf-1
    262. 

  262.       DO I = its,itf
    263. 

  263.          if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
    264. 

  264.             dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
    265. 

  265.             umean(i)=umean(i)+us(i,k)*dp
    266. 

  266.             vmean(i)=vmean(i)+vs(i,k)*dp
    267. 

  267.             pmean(i)=pmean(i)+dp
    268. 

  268.          endif
    269. 

  269.       enddo
    270. 

  270.       enddo
    271. 

  271.       DO I = its,itf
    272. 

  272.          if(pmean(i).gt.0)then
    273. 

  273.             umean(i)=umean(i)/pmean(i)
    274. 

  274.             vmean(i)=vmean(i)/pmean(i)
    275. 

  275.             direction(i)=(atan2(umean(i),vmean(i))+3.1415926)*57.29578
    276. 

  276.             if(direction(i).gt.360.)direction(i)=direction(i)-360.
    277. 

  277.          endif
    278. 

  278.       ENDDO
    279. 

  279.       DO K=kts,ktf-1
    280. 

  280.       DO I = its,itf
    281. 

  281.         dq=(q2d(i,k+1)-q2d(i,k))
    282. 

  282.         mconv(i)=mconv(i)+omeg(i,k)*dq/g
    283. 

  283.       ENDDO
    284. 

  284.       ENDDO
    285. 

  285.       DO I = its,itf
    286. 

  286.         if(mconv(i).lt.0.)mconv(i)=0.
    287. 

  287.       ENDDO
    288. 

  288. !
    289. 

  289. !---- CALL CUMULUS PARAMETERIZATION
    290. 

  290. !
    291. 

  291.       CALL CUP_enss(outqc,j,AAEQ,T2d,Q2d,TER11,TN,QO,PO,PRET,     &
    292. 

  292.            P2d,OUTT,OUTQ,DT,PSUR,US,VS,tcrit,iens,                &
    293. 

  293.            mconv,massfln,iact_old_gr,omeg,direction,MASS_FLUX,    &
    294. 

  294.            maxiens,maxens,maxens2,maxens3,ensdim,                 &
    295. 

  295.            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                     &
    296. 

  296.            APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,              &
    297. 

  297.            xf_ens,pr_ens,XLAND,gsw,cupclw,                        &
    298. 

  298.            xlv,r_v,cp,g,ichoice,ipr,jpr,                          &
    299. 

  299.            outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux,&
    300. 

  300.            ids,ide, jds,jde, kds,kde,                             &
    301. 

  301.            ims,ime, jms,jme, kms,kme,                             &
    302. 

  302.            its,ite, jts,jte, kts,kte                             )
    303. 

  303. 

  304.       CALL neg_check(dt,q2d,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
    305. 

  305.       if(j.ge.jbeg.and.j.le.jend)then
    306. 

  306. 

  307.             DO I=its,itf
    308. 

  308. !             cuten(i)=0.
    309. 

  309.               if(i.ge.ibeg.and.i.le.iend)then
    310. 

  310.               if(pret(i).gt.0.)then
    311. 

  311.                  pratec(i,j)=pret(i)
    312. 

  312.                  raincv(i,j)=pret(i)*dt
    313. 

  313.                  cuten(i)=1.
    314. 

  314.                  rkbcon = kte+kts - kbcon(i)
    315. 

  315.                  rktop  = kte+kts -  ktop(i)
    316. 

  316.                  if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
    317. 

  317.                  if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
    318. 

  318.               endif
    319. 

  319.               else
    320. 

  320.                pret(i)=0.
    321. 

  321.               endif
    322. 

  322.             ENDDO
    323. 

  323.             DO K=kts,ktf
    324. 

  324.             DO I=its,itf
    325. 

  325.                RTHCUTEN(I,K,J)=outt(i,k)*cuten(i)/pi(i,k,j)
    326. 

  326.                RQVCUTEN(I,K,J)=outq(i,k)*cuten(i)
    327. 

  327.             ENDDO
    328. 

  328.             ENDDO
    329. 

  329. 

  330.             IF(PRESENT(RQCCUTEN)) THEN
    331. 

  331.               IF ( F_QC ) THEN
    332. 

  332.                 DO K=kts,ktf
    333. 

  333.                 DO I=its,itf
    334. 

  334.                    RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
    335. 

  335.                    IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
    336. 

  336.                    IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
    337. 

  337.                 ENDDO
    338. 

  338.                 ENDDO
    339. 

  339.               ENDIF
    340. 

  340.             ENDIF
    341. 

  341. 

  342. !......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)     
    343. 

  343. 

  344.             IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
    345. 

  345.               IF (F_QI) THEN
    346. 

  346.                 DO K=kts,ktf
    347. 

  347.                 DO I=its,itf
    348. 

  348.                    if(t2d(i,k).lt.258.)then
    349. 

  349.                       RQICUTEN(I,K,J)=outqc(I,K)*cuten(i)
    350. 

  350.                       RQCCUTEN(I,K,J)=0.
    351. 

  351.                       IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i)
    352. 

  352.                    else
    353. 

  353.                       RQICUTEN(I,K,J)=0.
    354. 

  354.                       RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
    355. 

  355.                       IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
    356. 

  356.                    endif
    357. 

  357.                 ENDDO
    358. 

  358.                 ENDDO
    359. 

  359.               ENDIF
    360. 

  360.             ENDIF
    361. 

  361. 

  362.             if (l_flux) then
    363. 

  363.                DO K=kts,ktf
    364. 

  364.                DO I=its,itf
    365. 

  365.                   cfu1(i,k,j)=outcfu1(i,k)*cuten(i)
    366. 

  366.                   cfd1(i,k,j)=outcfd1(i,k)*cuten(i)
    367. 

  367.                   dfu1(i,k,j)=outdfu1(i,k)*cuten(i)
    368. 

  368.                   efu1(i,k,j)=outefu1(i,k)*cuten(i)
    369. 

  369.                   dfd1(i,k,j)=outdfd1(i,k)*cuten(i)
    370. 

  370.                   efd1(i,k,j)=outefd1(i,k)*cuten(i)
    371. 

  371.                enddo
    372. 

  372.                enddo
    373. 

  373.             endif
    374. 

  374.         endif !jbeg,jend
    375. 

  375. 

  376.  100    continue
    377. 

  377. 

  378.    END SUBROUTINE GRELLDRV
    379. 

  379. 

  380. 

  381.    SUBROUTINE CUP_enss(OUTQC,J,AAEQ,T,Q,Z1,                            &
    382. 

  382.               TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,PSUR,US,VS,               &
    383. 

  383.               TCRIT,iens,mconv,massfln,iact,                           &
    384. 

  384.               omeg,direction,massflx,maxiens,                          &
    385. 

  385.               maxens,maxens2,maxens3,ensdim,                           &
    386. 

  386.               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                       &
    387. 

  387.               APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,                &   !-lxz
    388. 

  388.               xf_ens,pr_ens,xland,gsw,cupclw,                          &
    389. 

  389.               xl,rv,cp,g,ichoice,ipr,jpr,                              &
    390. 

  390.               outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux,  &
    391. 

  391.               ids,ide, jds,jde, kds,kde,                               &
    392. 

  392.               ims,ime, jms,jme, kms,kme,                               &
    393. 

  393.               its,ite, jts,jte, kts,kte                               )
    394. 

  394. 

  395.    IMPLICIT NONE
    396. 

  396. 

  397.      integer                                                           &
    398. 

  398.         ,intent (in   )                   ::                           &
    399. 

  399.         ids,ide, jds,jde, kds,kde,                                     &
    400. 

  400.         ims,ime, jms,jme, kms,kme,                                     &
    401. 

  401.         its,ite, jts,jte, kts,kte,ipr,jpr
    402. 

  402.      integer, intent (in   )              ::                           &
    403. 

  403.         j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens
    404. 

  404.   !
    405. 

  405.   ! 
    406. 

  406.   !
    407. 

  407.      real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
    408. 

  408.         ,intent (inout)                   ::                           &
    409. 

  409.         massfln,xf_ens,pr_ens
    410. 

  410.      real,    dimension (ims:ime,jms:jme)                              &
    411. 

  411.         ,intent (inout )                  ::                           &
    412. 

  412.                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,     &
    413. 

  413.                APR_CAPME,APR_CAPMI,massflx
    414. 

  414.      real,    dimension (ims:ime,jms:jme)                              &
    415. 

  415.         ,intent (in   )                   ::                           &
    416. 

  416.                xland,gsw
    417. 

  417.      integer, dimension (its:ite,jts:jte)                              &
    418. 

  418.         ,intent (in   )                   ::                           &
    419. 

  419.         iact
    420. 

  420.   ! outtem = output temp tendency (per s)
    421. 

  421.   ! outq   = output q tendency (per s)
    422. 

  422.   ! outqc  = output qc tendency (per s)
    423. 

  423.   ! pre    = output precip
    424. 

  424.      real,    dimension (its:ite,kts:kte)                              &
    425. 

  425.         ,intent (out  )                   ::                           &
    426. 

  426.         OUTT,OUTQ,OUTQC,CUPCLW,                                        &
    427. 

  427.         outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
    428. 

  428.      logical, intent(in) :: l_flux
    429. 

  429.      real,    dimension (its:ite)                                      &
    430. 

  430.         ,intent (out  )                   ::                           &
    431. 

  431.         pre
    432. 

  432. !+lxz
    433. 

  433.      integer,    dimension (its:ite)                                   &
    434. 

  434.         ,intent (out  )                   ::                           &
    435. 

  435.         kbcon,ktop
    436. 

  436. !.lxz
    437. 

  437.   !
    438. 

  438.   ! basic environmental input includes moisture convergence (mconv)
    439. 

  439.   ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off
    440. 

  440.   ! convection for this call only and at that particular gridpoint
    441. 

  441.   !
    442. 

  442.      real,    dimension (its:ite,kts:kte)                              &
    443. 

  443.         ,intent (in   )                   ::                           &
    444. 

  444.         T,TN,PO,P,US,VS,omeg
    445. 

  445.      real,    dimension (its:ite,kts:kte)                              &
    446. 

  446.         ,intent (inout)                   ::                           &
    447. 

  447.          Q,QO
    448. 

  448.      real, dimension (its:ite)                                         &
    449. 

  449.         ,intent (in   )                   ::                           &
    450. 

  450.         Z1,PSUR,AAEQ,direction,mconv
    451. 

  451. 

  452.        
    453. 

  453.        real                                                            &
    454. 

  454.         ,intent (in   )                   ::                           &
    455. 

  455.         dtime,tcrit,xl,cp,rv,g
    456. 

  456. 

  457. 

  458. !
    459. 

  459. !  local ensemble dependent variables in this routine
    460. 

  460. !
    461. 

  461.      real,    dimension (its:ite,1:maxens)  ::                         &
    462. 

  462.         xaa0_ens
    463. 

  463.      real,    dimension (1:maxens)  ::                                 &
    464. 

  464.         mbdt_ens
    465. 

  465.      real,    dimension (1:maxens2) ::                                 &
    466. 

  466.         edt_ens
    467. 

  467.      real,    dimension (its:ite,1:maxens2) ::                         &
    468. 

  468.         edtc
    469. 

  469.      real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
    470. 

  470.         dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens
    471. 

  471.      real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
    472. 

  472.         CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens
    473. 

  473. !
    474. 

  474. !
    475. 

  475. !
    476. 

  476. !***************** the following are your basic environmental
    477. 

  477. !                  variables. They carry a "_cup" if they are
    478. 

  478. !                  on model cloud levels (staggered). They carry
    479. 

  479. !                  an "o"-ending (z becomes zo), if they are the forced
    480. 

  480. !                  variables. They are preceded by x (z becomes xz)
    481. 

  481. !                  to indicate modification by some typ of cloud
    482. 

  482. !
    483. 

  483.   ! z           = heights of model levels
    484. 

  484.   ! q           = environmental mixing ratio
    485. 

  485.   ! qes         = environmental saturation mixing ratio
    486. 

  486.   ! t           = environmental temp
    487. 

  487.   ! p           = environmental pressure
    488. 

  488.   ! he          = environmental moist static energy
    489. 

  489.   ! hes         = environmental saturation moist static energy
    490. 

  490.   ! z_cup       = heights of model cloud levels
    491. 

  491.   ! q_cup       = environmental q on model cloud levels
    492. 

  492.   ! qes_cup     = saturation q on model cloud levels
    493. 

  493.   ! t_cup       = temperature (Kelvin) on model cloud levels
    494. 

  494.   ! p_cup       = environmental pressure
    495. 

  495.   ! he_cup = moist static energy on model cloud levels
    496. 

  496.   ! hes_cup = saturation moist static energy on model cloud levels
    497. 

  497.   ! gamma_cup = gamma on model cloud levels
    498. 

  498. !
    499. 

  499. !
    500. 

  500.   ! hcd = moist static energy in downdraft
    501. 

  501.   ! zd normalized downdraft mass flux
    502. 

  502.   ! dby = buoancy term
    503. 

  503.   ! entr = entrainment rate
    504. 

  504.   ! zd   = downdraft normalized mass flux
    505. 

  505.   ! entr= entrainment rate
    506. 

  506.   ! hcd = h in model cloud
    507. 

  507.   ! bu = buoancy term
    508. 

  508.   ! zd = normalized downdraft mass flux
    509. 

  509.   ! gamma_cup = gamma on model cloud levels
    510. 

  510.   ! mentr_rate = entrainment rate
    511. 

  511.   ! qcd = cloud q (including liquid water) after entrainment
    512. 

  512.   ! qrch = saturation q in cloud
    513. 

  513.   ! pwd = evaporate at that level
    514. 

  514.   ! pwev = total normalized integrated evaoprate (I2)
    515. 

  515.   ! entr= entrainment rate
    516. 

  516.   ! z1 = terrain elevation
    517. 

  517.   ! entr = downdraft entrainment rate
    518. 

  518.   ! jmin = downdraft originating level
    519. 

  519.   ! kdet = level above ground where downdraft start detraining
    520. 

  520.   ! psur        = surface pressure
    521. 

  521.   ! z1          = terrain elevation
    522. 

  522.   ! pr_ens = precipitation ensemble
    523. 

  523.   ! xf_ens = mass flux ensembles
    524. 

  524.   ! massfln = downdraft mass flux ensembles used in next timestep
    525. 

  525.   ! omeg = omega from large scale model
    526. 

  526.   ! mconv = moisture convergence from large scale model
    527. 

  527.   ! zd      = downdraft normalized mass flux
    528. 

  528.   ! zu      = updraft normalized mass flux
    529. 

  529.   ! dir     = "storm motion"
    530. 

  530.   ! mbdt    = arbitrary numerical parameter
    531. 

  531.   ! dtime   = dt over which forcing is applied
    532. 

  532.   ! iact_gr_old = flag to tell where convection was active
    533. 

  533.   ! kbcon       = LFC of parcel from k22
    534. 

  534.   ! k22         = updraft originating level
    535. 

  535.   ! icoic       = flag if only want one closure (usually set to zero!)
    536. 

  536.   ! dby = buoancy term
    537. 

  537.   ! ktop = cloud top (output)
    538. 

  538.   ! xmb    = total base mass flux
    539. 

  539.   ! hc = cloud moist static energy
    540. 

  540.   ! hkb = moist static energy at originating level
    541. 

  541.   ! mentr_rate = entrainment rate
    542. 

  542. 

  543.      real,    dimension (its:ite,kts:kte) ::                           &
    544. 

  544.         he,hes,qes,z,                                                  &
    545. 

  545.         heo,heso,qeso,zo,                                              &
    546. 

  546.         xhe,xhes,xqes,xz,xt,xq,                                        &
    547. 

  547. 

  548.         qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
    549. 

  549.         qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
    550. 

  550.         tn_cup,                                                        &
    551. 

  551.         xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup,     &
    552. 

  552.         xt_cup,                                                        &
    553. 

  553. 

  554.         dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all,          &
    555. 

  555.         dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo,      &
    556. 

  556.         xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd,            &
    557. 

  557. 

  558.   ! cd  = detrainment function for updraft
    559. 

  559.   ! cdd = detrainment function for downdraft
    560. 

  560.   ! dellat = change of temperature per unit mass flux of cloud ensemble
    561. 

  561.   ! dellaq = change of q per unit mass flux of cloud ensemble
    562. 

  562.   ! dellaqc = change of qc per unit mass flux of cloud ensemble
    563. 

  563. 

  564.         cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC,                      &
    565. 

  565.         CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
    566. 

  566. 

  567.   ! aa0 cloud work function for downdraft
    568. 

  568.   ! edt = epsilon
    569. 

  569.   ! aa0     = cloud work function without forcing effects
    570. 

  570.   ! aa1     = cloud work function with forcing effects
    571. 

  571.   ! xaa0    = cloud work function with cloud effects (ensemble dependent)
    572. 

  572.   ! edt     = epsilon
    573. 

  573.      real,    dimension (its:ite) ::                                   &
    574. 

  574.        edt,edto,edtx,AA1,AA0,XAA0,HKB,HKBO,aad,XHKB,QKB,QKBO,          &
    575. 

  575.        XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,PWEVO,BU,BUO,cap_max,xland1,     &
    576. 

  576.        cap_max_increment,closure_n
    577. 

  577.      integer,    dimension (its:ite) ::                                &
    578. 

  578.        kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x,                     &   !-lxz
    579. 

  579.        KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX 
    580. 

  580. 

  581.      integer                              ::                           &
    582. 

  582.        nall,iedt,nens,nens3,ki,I,K,KK,iresult
    583. 

  583.      real                                 ::                           &
    584. 

  584.       day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate,  &
    585. 

  585.       zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop,            &
    586. 

  586.       massfld,dh,cap_maxs
    587. 

  587. 

  588.      integer :: itf,jtf,ktf
    589. 

  589.      integer :: jmini
    590. 

  590.      logical :: keep_going
    591. 

  591. 

  592.      itf=MIN(ite,ide-1)
    593. 

  593.      ktf=MIN(kte,kde-1)
    594. 

  594.      jtf=MIN(jte,jde-1)
    595. 

  595. 

  596. !sms$distribute end
    597. 

  597.       day=86400.
    598. 

  598.       do i=its,itf
    599. 

  599.         closure_n(i)=16.
    600. 

  600.         xland1(i)=1.
    601. 

  601.         if(xland(i,j).gt.1.5)xland1(i)=0.
    602. 

  602.         cap_max_increment(i)=25.
    603. 

  603.       enddo
    604. 

  604. !
    605. 

  605. !--- specify entrainmentrate and detrainmentrate
    606. 

  606. !
    607. 

  607.       if(iens.le.4)then
    608. 

  608.       radius=14000.-float(iens)*2000.
    609. 

  609.       else
    610. 

  610.       radius=12000.
    611. 

  611.       endif
    612. 

  612. !
    613. 

  613. !--- gross entrainment rate (these may be changed later on in the
    614. 

  614. !--- program, depending what your detrainment is!!)
    615. 

  615. !
    616. 

  616.       entr_rate=.2/radius
    617. 

  617. !
    618. 

  618. !--- entrainment of mass
    619. 

  619. !
    620. 

  620.       mentrd_rate=0.
    621. 

  621.       mentr_rate=entr_rate
    622. 

  622. !
    623. 

  623. !--- initial detrainmentrates
    624. 

  624. !
    625. 

  625.       do k=kts,ktf
    626. 

  626.       do i=its,itf
    627. 

  627.         cupclw(i,k)=0.
    628. 

  628.         cd(i,k)=0.1*entr_rate
    629. 

  629.         cdd(i,k)=0.
    630. 

  630.       enddo
    631. 

  631.       enddo
    632. 

  632. !
    633. 

  633. !--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
    634. 

  634. !    base mass flux
    635. 

  635. !
    636. 

  636.       edtmax=.8
    637. 

  637.       edtmin=.2
    638. 

  638. !
    639. 

  639. !--- minimum depth (m), clouds must have
    640. 

  640. !
    641. 

  641.       depth_min=500.
    642. 

  642. !
    643. 

  643. !--- maximum depth (mb) of capping 
    644. 

  644. !--- inversion (larger cap = no convection)
    645. 

  645. !
    646. 

  646.       cap_maxs=75.
    647. 

  647. !sms$to_local(grid_dh: <1, mix :size>, <2, mjx :size>) begin
    648. 

  648.       DO 7 i=its,itf
    649. 

  649.         kbmax(i)=1
    650. 

  650.         aa0(i)=0.
    651. 

  651.         aa1(i)=0.
    652. 

  652.         aad(i)=0.
    653. 

  653.         edt(i)=0.
    654. 

  654.         kstabm(i)=ktf-1
    655. 

  655.         IERR(i)=0
    656. 

  656.         IERR2(i)=0
    657. 

  657.         IERR3(i)=0
    658. 

  658.         if(aaeq(i).lt.-1.)then
    659. 

  659.            ierr(i)=20
    660. 

  660.         endif
    661. 

  661.  7    CONTINUE
    662. 

  662. !
    663. 

  663. !--- first check for upstream convection
    664. 

  664. !
    665. 

  665.       do i=its,itf
    666. 

  666.           cap_max(i)=cap_maxs
    667. 

  667. !         if(tkmax(i,j).lt.2.)cap_max(i)=25.
    668. 

  668.           if(gsw(i,j).lt.1.)cap_max(i)=25.
    669. 

  669. 

  670.         iresult=0
    671. 

  671. !       massfld=0.
    672. 

  672. !     call cup_direction2(i,j,direction,iact, &
    673. 

  673. !          cu_mfx,iresult,0,massfld,  &
    674. 

  674. !          ids,ide, jds,jde, kds,kde, &
    675. 

  675. !          ims,ime, jms,jme, kms,kme, &
    676. 

  676. !          its,ite, jts,jte, kts,kte)
    677. 

  677. !         cap_max(i)=cap_maxs
    678. 

  678.        if(iresult.eq.1)then
    679. 

  679.           cap_max(i)=cap_maxs+20.
    680. 

  680.        endif
    681. 

  681. !      endif
    682. 

  682.       enddo
    683. 

  683. !
    684. 

  684. !--- max height(m) above ground where updraft air can originate
    685. 

  685. !
    686. 

  686.       zkbmax=4000.
    687. 

  687. !
    688. 

  688. !--- height(m) above which no downdrafts are allowed to originate
    689. 

  689. !
    690. 

  690.       zcutdown=3000.
    691. 

  691. !
    692. 

  692. !--- depth(m) over which downdraft detrains all its mass
    693. 

  693. !
    694. 

  694.       z_detr=1250.
    695. 

  695. !
    696. 

  696.       do nens=1,maxens
    697. 

  697.          mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03
    698. 

  698.       enddo
    699. 

  699.       do nens=1,maxens2
    700. 

  700.          edt_ens(nens)=.95-float(nens)*.01
    701. 

  701.       enddo
    702. 

  702. !     if(j.eq.jpr)then
    703. 

  703. !       print *,'radius ensemble ',iens,radius
    704. 

  704. !       print *,mbdt_ens
    705. 

  705. !       print *,edt_ens
    706. 

  706. !     endif
    707. 

  707. !
    708. 

  708. !--- environmental conditions, FIRST HEIGHTS
    709. 

  709. !
    710. 

  710.       do i=its,itf
    711. 

  711.          if(ierr(i).ne.20)then
    712. 

  712.             do k=1,maxens*maxens2*maxens3
    713. 

  713.                xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
    714. 

  714.                pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
    715. 

  715.             enddo
    716. 

  716.          endif
    717. 

  717.       enddo
    718. 

  718. !
    719. 

  719. !--- calculate moist static energy, heights, qes
    720. 

  720. !
    721. 

  721.       call cup_env(z,qes,he,hes,t,q,p,z1, &
    722. 

  722.            psur,ierr,tcrit,0,xl,cp,   &
    723. 

  723.            ids,ide, jds,jde, kds,kde, &
    724. 

  724.            ims,ime, jms,jme, kms,kme, &
    725. 

  725.            its,ite, jts,jte, kts,kte)
    726. 

  726.       call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, &
    727. 

  727.            psur,ierr,tcrit,0,xl,cp,   &
    728. 

  728.            ids,ide, jds,jde, kds,kde, &
    729. 

  729.            ims,ime, jms,jme, kms,kme, &
    730. 

  730.            its,ite, jts,jte, kts,kte)
    731. 

  731. !
    732. 

  732. !--- environmental values on cloud levels
    733. 

  733. !
    734. 

  734.       call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, &
    735. 

  735.            hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
    736. 

  736.            ierr,z1,xl,rv,cp,          &
    737. 

  737.            ids,ide, jds,jde, kds,kde, &
    738. 

  738.            ims,ime, jms,jme, kms,kme, &
    739. 

  739.            its,ite, jts,jte, kts,kte)
    740. 

  740.       call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
    741. 

  741.            heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
    742. 

  742.            ierr,z1,xl,rv,cp,          &
    743. 

  743.            ids,ide, jds,jde, kds,kde, &
    744. 

  744.            ims,ime, jms,jme, kms,kme, &
    745. 

  745.            its,ite, jts,jte, kts,kte)
    746. 

  746.       do i=its,itf
    747. 

  747.       if(ierr(i).eq.0)then
    748. 

  748. !
    749. 

  749.       do k=kts,ktf-2
    750. 

  750.         if(zo_cup(i,k).gt.zkbmax+z1(i))then
    751. 

  751.           kbmax(i)=k
    752. 

  752.           go to 25
    753. 

  753.         endif
    754. 

  754.       enddo
    755. 

  755.  25   continue
    756. 

  756. !
    757. 

  757. !
    758. 

  758. !--- level where detrainment for downdraft starts
    759. 

  759. !
    760. 

  760.       do k=kts,ktf
    761. 

  761.         if(zo_cup(i,k).gt.z_detr+z1(i))then
    762. 

  762.           kdet(i)=k
    763. 

  763.           go to 26
    764. 

  764.         endif
    765. 

  765.       enddo
    766. 

  766.  26   continue
    767. 

  767. !
    768. 

  768.       endif
    769. 

  769.       enddo
    770. 

  770. !
    771. 

  771. !
    772. 

  772. !
    773. 

  773. !------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
    774. 

  774. !
    775. 

  775.       CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22,ierr, &
    776. 

  776.            ids,ide, jds,jde, kds,kde, &
    777. 

  777.            ims,ime, jms,jme, kms,kme, &
    778. 

  778.            its,ite, jts,jte, kts,kte)
    779. 

  779.        DO 36 i=its,itf
    780. 

  780.          IF(ierr(I).eq.0.)THEN
    781. 

  781.          IF(K22(I).GE.KBMAX(i))ierr(i)=2
    782. 

  782.          endif
    783. 

  783.  36   CONTINUE
    784. 

  784. !
    785. 

  785. !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
    786. 

  786. !
    787. 

  787.       call cup_kbcon(cap_max_increment,1,k22,kbcon,heo_cup,heso_cup, &
    788. 

  788.            ierr,kbmax,po_cup,cap_max, &
    789. 

  789.            ids,ide, jds,jde, kds,kde, &
    790. 

  790.            ims,ime, jms,jme, kms,kme, &
    791. 

  791.            its,ite, jts,jte, kts,kte)
    792. 

  792. !     call cup_kbcon_cin(1,k22,kbcon,heo_cup,heso_cup,z,tn_cup, &
    793. 

  793. !          qeso_cup,ierr,kbmax,po_cup,cap_max,xl,cp,&
    794. 

  794. !          ids,ide, jds,jde, kds,kde, &
    795. 

  795. !          ims,ime, jms,jme, kms,kme, &
    796. 

  796. !          its,ite, jts,jte, kts,kte)
    797. 

  797. !
    798. 

  798. !--- increase detrainment in stable layers
    799. 

  799. !
    800. 

  800.       CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr,  &
    801. 

  801.            ids,ide, jds,jde, kds,kde, &
    802. 

  802.            ims,ime, jms,jme, kms,kme, &
    803. 

  803.            its,ite, jts,jte, kts,kte)
    804. 

  804.       do i=its,itf
    805. 

  805.       IF(ierr(I).eq.0.)THEN
    806. 

  806.         if(kstabm(i)-1.gt.kstabi(i))then
    807. 

  807.            do k=kstabi(i),kstabm(i)-1
    808. 

  808.              cd(i,k)=cd(i,k-1)+1.5*entr_rate
    809. 

  809.              if(cd(i,k).gt.10.0*entr_rate)cd(i,k)=10.0*entr_rate
    810. 

  810.            enddo
    811. 

  811.         ENDIF
    812. 

  812.       ENDIF
    813. 

  813.       ENDDO
    814. 

  814. !
    815. 

  815. !--- calculate incloud moist static energy
    816. 

  816. !
    817. 

  817.       call cup_up_he(k22,hkb,z_cup,cd,mentr_rate,he_cup,hc, &
    818. 

  818.            kbcon,ierr,dby,he,hes_cup, &
    819. 

  819.            ids,ide, jds,jde, kds,kde, &
    820. 

  820.            ims,ime, jms,jme, kms,kme, &
    821. 

  821.            its,ite, jts,jte, kts,kte)
    822. 

  822.       call cup_up_he(k22,hkbo,zo_cup,cd,mentr_rate,heo_cup,hco, &
    823. 

  823.            kbcon,ierr,dbyo,heo,heso_cup, &
    824. 

  824.            ids,ide, jds,jde, kds,kde, &
    825. 

  825.            ims,ime, jms,jme, kms,kme, &
    826. 

  826.            its,ite, jts,jte, kts,kte)
    827. 

  827. 

  828. !--- DETERMINE CLOUD TOP - KTOP
    829. 

  829. !
    830. 

  830.       call cup_ktop(1,dbyo,kbcon,ktop,ierr, &
    831. 

  831.            ids,ide, jds,jde, kds,kde, &
    832. 

  832.            ims,ime, jms,jme, kms,kme, &
    833. 

  833.            its,ite, jts,jte, kts,kte)
    834. 

  834.       DO 37 i=its,itf
    835. 

  835.          kzdown(i)=0
    836. 

  836.          if(ierr(i).eq.0)then
    837. 

  837.             zktop=(zo_cup(i,ktop(i))-z1(i))*.6
    838. 

  838.             zktop=min(zktop+z1(i),zcutdown+z1(i))
    839. 

  839.             do k=kts,kte
    840. 

  840.               if(zo_cup(i,k).gt.zktop)then
    841. 

  841.                  kzdown(i)=k
    842. 

  842.                  go to 37
    843. 

  843.               endif
    844. 

  844.               enddo
    845. 

  845.          endif
    846. 

  846.  37   CONTINUE
    847. 

  847. !
    848. 

  848. !--- DOWNDRAFT ORIGINATING LEVEL - JMIN
    849. 

  849. !
    850. 

  850.       call cup_minimi(HEso_cup,K22,kzdown,JMIN,ierr, &
    851. 

  851.            ids,ide, jds,jde, kds,kde, &
    852. 

  852.            ims,ime, jms,jme, kms,kme, &
    853. 

  853.            its,ite, jts,jte, kts,kte)
    854. 

  854.       DO 100 i=its,ite
    855. 

  855.         IF(ierr(I).eq.0.)THEN
    856. 

  856. !
    857. 

  857. !--- check whether it would have buoyancy, if there where
    858. 

  858. !--- no entrainment/detrainment
    859. 

  859. !
    860. 

  860. !jm begin 20061212:  the following code replaces code that
    861. 

  861. !   was too complex and causing problem for optimization.
    862. 

  862. !   Done in consultation with G. Grell.
    863. 

  863.         jmini = jmin(i)
    864. 

  864.         keep_going = .TRUE.
    865. 

  865.         DO WHILE ( keep_going )
    866. 

  866.           keep_going = .FALSE.
    867. 

  867.           if ( jmini - 1 .lt. kdet(i)   ) kdet(i) = jmini-1
    868. 

  868.           if ( jmini     .ge. ktop(i)-1 ) jmini = ktop(i) - 2
    869. 

  869.           ki = jmini
    870. 

  870.           hcdo(i,ki)=heso_cup(i,ki)
    871. 

  871.           DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki)
    872. 

  872.           dh=0.
    873. 

  873.           DO k=ki-1,1,-1
    874. 

  874.             hcdo(i,k)=heso_cup(i,jmini)
    875. 

  875.             DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
    876. 

  876.             dh=dh+dz*(HCDo(i,K)-heso_cup(i,k))
    877. 

  877.             IF(dh.gt.0.)THEN
    878. 

  878.               jmini=jmini-1
    879. 

  879.               IF ( jmini .gt. 3 ) THEN
    880. 

  880.                 keep_going = .TRUE.
    881. 

  881.               ELSE
    882. 

  882.                 ierr(i) = 9
    883. 

  883.                 EXIT
    884. 

  884.               ENDIF
    885. 

  885.             ENDIF
    886. 

  886.           ENDDO
    887. 

  887.         ENDDO
    888. 

  888.         jmin(i) = jmini
    889. 

  889.         IF ( jmini .le. 3 ) THEN
    890. 

  890.           ierr(i)=4
    891. 

  891.         ENDIF
    892. 

  892. !jm end 20061212
    893. 

  893.       ENDIF
    894. 

  894. 100   CONTINUE
    895. 

  895. !
    896. 

  896. ! - Must have at least depth_min m between cloud convective base
    897. 

  897. !     and cloud top.
    898. 

  898. !
    899. 

  899.       do i=its,itf
    900. 

  900.       IF(ierr(I).eq.0.)THEN
    901. 

  901.       IF(-zo_cup(I,KBCON(I))+zo_cup(I,KTOP(I)).LT.depth_min)then
    902. 

  902.             ierr(i)=6
    903. 

  903.       endif
    904. 

  904.       endif
    905. 

  905.       enddo
    906. 

  906. 

  907. !
    908. 

  908. !c--- normalized updraft mass flux profile
    909. 

  909. !
    910. 

  910.       call cup_up_nms(zu,z_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, &
    911. 

  911.            ids,ide, jds,jde, kds,kde, &
    912. 

  912.            ims,ime, jms,jme, kms,kme, &
    913. 

  913.            its,ite, jts,jte, kts,kte)
    914. 

  914.       call cup_up_nms(zuo,zo_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, &
    915. 

  915.            ids,ide, jds,jde, kds,kde, &
    916. 

  916.            ims,ime, jms,jme, kms,kme, &
    917. 

  917.            its,ite, jts,jte, kts,kte)
    918. 

  918. !
    919. 

  919. !c--- normalized downdraft mass flux profile,also work on bottom detrainment
    920. 

  920. !--- in this routine
    921. 

  921. !
    922. 

  922.       call cup_dd_nms(zd,z_cup,cdd,mentrd_rate,jmin,ierr, &
    923. 

  923.            0,kdet,z1,                 &
    924. 

  924.            ids,ide, jds,jde, kds,kde, &
    925. 

  925.            ims,ime, jms,jme, kms,kme, &
    926. 

  926.            its,ite, jts,jte, kts,kte)
    927. 

  927.       call cup_dd_nms(zdo,zo_cup,cdd,mentrd_rate,jmin,ierr, &
    928. 

  928.            1,kdet,z1,                 &
    929. 

  929.            ids,ide, jds,jde, kds,kde, &
    930. 

  930.            ims,ime, jms,jme, kms,kme, &
    931. 

  931.            its,ite, jts,jte, kts,kte)
    932. 

  932. !
    933. 

  933. !--- downdraft moist static energy
    934. 

  934. !
    935. 

  935.       call cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,mentrd_rate, &
    936. 

  936.            jmin,ierr,he,dbyd,he_cup,  &
    937. 

  937.            ids,ide, jds,jde, kds,kde, &
    938. 

  938.            ims,ime, jms,jme, kms,kme, &
    939. 

  939.            its,ite, jts,jte, kts,kte)
    940. 

  940.       call cup_dd_he(heso_cup,zdo,hcdo,zo_cup,cdd,mentrd_rate, &
    941. 

  941.            jmin,ierr,heo,dbydo,he_cup,&
    942. 

  942.            ids,ide, jds,jde, kds,kde, &
    943. 

  943.            ims,ime, jms,jme, kms,kme, &
    944. 

  944.            its,ite, jts,jte, kts,kte)
    945. 

  945. !
    946. 

  946. !--- calculate moisture properties of downdraft
    947. 

  947. !
    948. 

  948.       call cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup, &
    949. 

  949.            pwd,q_cup,z_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, &
    950. 

  950.            pwev,bu,qrcd,q,he,t_cup,2,xl, &
    951. 

  951.            ids,ide, jds,jde, kds,kde, &
    952. 

  952.            ims,ime, jms,jme, kms,kme, &
    953. 

  953.            its,ite, jts,jte, kts,kte)
    954. 

  954.       call cup_dd_moisture(zdo,hcdo,heso_cup,qcdo,qeso_cup, &
    955. 

  955.            pwdo,qo_cup,zo_cup,cdd,mentrd_rate,jmin,ierr,gammao_cup, &
    956. 

  956.            pwevo,bu,qrcdo,qo,heo,tn_cup,1,xl, &
    957. 

  957.            ids,ide, jds,jde, kds,kde, &
    958. 

  958.            ims,ime, jms,jme, kms,kme, &
    959. 

  959.            its,ite, jts,jte, kts,kte)
    960. 

  960. !
    961. 

  961. !--- calculate moisture properties of updraft
    962. 

  962. !
    963. 

  963.       call cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav, &
    964. 

  964.            kbcon,ktop,cd,dby,mentr_rate,clw_all,      &
    965. 

  965.            q,GAMMA_cup,zu,qes_cup,k22,q_cup,xl, &
    966. 

  966.            ids,ide, jds,jde, kds,kde, &
    967. 

  967.            ims,ime, jms,jme, kms,kme, &
    968. 

  968.            its,ite, jts,jte, kts,kte)
    969. 

  969.       do k=kts,ktf
    970. 

  970.       do i=its,itf
    971. 

  971.          cupclw(i,k)=qrc(i,k)
    972. 

  972.       enddo
    973. 

  973.       enddo
    974. 

  974.       call cup_up_moisture(ierr,zo_cup,qco,qrco,pwo,pwavo, &
    975. 

  975.            kbcon,ktop,cd,dbyo,mentr_rate,clw_all, &
    976. 

  976.            qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,&
    977. 

  977.            ids,ide, jds,jde, kds,kde, &
    978. 

  978.            ims,ime, jms,jme, kms,kme, &
    979. 

  979.            its,ite, jts,jte, kts,kte)
    980. 

  980. !
    981. 

  981. !--- calculate workfunctions for updrafts
    982. 

  982. !
    983. 

  983.       call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
    984. 

  984.            kbcon,ktop,ierr,           &
    985. 

  985.            ids,ide, jds,jde, kds,kde, &
    986. 

  986.            ims,ime, jms,jme, kms,kme, &
    987. 

  987.            its,ite, jts,jte, kts,kte)
    988. 

  988.       call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
    989. 

  989.            kbcon,ktop,ierr,           &
    990. 

  990.            ids,ide, jds,jde, kds,kde, &
    991. 

  991.            ims,ime, jms,jme, kms,kme, &
    992. 

  992.            its,ite, jts,jte, kts,kte)
    993. 

  993.       do i=its,itf
    994. 

  994.          if(ierr(i).eq.0)then
    995. 

  995.            if(aa1(i).eq.0.)then
    996. 

  996.                ierr(i)=17
    997. 

  997.            endif
    998. 

  998.          endif
    999. 

  999.       enddo
    1000. 

  1000. !
    1001. 

  1001. !--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
    1002. 

  1002. !
    1003. 

  1003.       call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, &
    1004. 

  1004.            pwevo,edtmax,edtmin,maxens2,edtc, &
    1005. 

  1005.            ids,ide, jds,jde, kds,kde, &
    1006. 

  1006.            ims,ime, jms,jme, kms,kme, &
    1007. 

  1007.            its,ite, jts,jte, kts,kte)
    1008. 

  1008.       do 250 iedt=1,maxens2
    1009. 

  1009.         do i=its,itf
    1010. 

  1010.          if(ierr(i).eq.0)then
    1011. 

  1011.          edt(i)=edtc(i,iedt)
    1012. 

  1012.          edto(i)=edtc(i,iedt)
    1013. 

  1013.          edtx(i)=edtc(i,iedt)
    1014. 

  1014.          endif
    1015. 

  1015.         enddo
    1016. 

  1016.         do k=kts,ktf
    1017. 

  1017.         do i=its,itf
    1018. 

  1018.            dellat_ens(i,k,iedt)=0.
    1019. 

  1019.            dellaq_ens(i,k,iedt)=0.
    1020. 

  1020.            dellaqc_ens(i,k,iedt)=0.
    1021. 

  1021.            pwo_ens(i,k,iedt)=0.
    1022. 

  1022.         enddo
    1023. 

  1023.         enddo
    1024. 

  1024.         if (l_flux) then
    1025. 

  1025.            do k=kts,ktf
    1026. 

  1026.               do i=its,itf
    1027. 

  1027.                  cfu1_ens(i,k,iedt)=0.
    1028. 

  1028.                  cfd1_ens(i,k,iedt)=0.
    1029. 

  1029.                  dfu1_ens(i,k,iedt)=0.
    1030. 

  1030.                  efu1_ens(i,k,iedt)=0.
    1031. 

  1031.                  dfd1_ens(i,k,iedt)=0.
    1032. 

  1032.                  efd1_ens(i,k,iedt)=0.
    1033. 

  1033.               enddo
    1034. 

  1034.            enddo
    1035. 

  1035.         endif
    1036. 

  1036. !
    1037. 

  1037.       do i=its,itf
    1038. 

  1038.         aad(i)=0.
    1039. 

  1039.       enddo
    1040. 

  1040. !     do i=its,itf
    1041. 

  1041. !       if(ierr(i).eq.0)then
    1042. 

  1042. !        eddt(i,j)=edt(i)
    1043. 

  1043. !        EDTX(I)=EDT(I)
    1044. 

  1044. !        BU(I)=0.
    1045. 

  1045. !        BUO(I)=0.
    1046. 

  1046. !       endif
    1047. 

  1047. !     enddo
    1048. 

  1048. !
    1049. 

  1049. !---downdraft workfunctions
    1050. 

  1050. !
    1051. 

  1051. !     call cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, &
    1052. 

  1052. !          hcd,hes_cup,z,zd,          &
    1053. 

  1053. !          ids,ide, jds,jde, kds,kde, &
    1054. 

  1054. !          ims,ime, jms,jme, kms,kme, &
    1055. 

  1055. !          its,ite, jts,jte, kts,kte)
    1056. 

  1056. !     call cup_dd_aa0(edto,ierr,aad,jmin,gammao_cup,tn_cup, &
    1057. 

  1057. !          hcdo,heso_cup,zo,zdo,      &
    1058. 

  1058. !          ids,ide, jds,jde, kds,kde, &
    1059. 

  1059. !          ims,ime, jms,jme, kms,kme, &
    1060. 

  1060. !          its,ite, jts,jte, kts,kte)
    1061. 

  1061. !
    1062. 

  1062. !--- change per unit mass that a model cloud would modify the environment
    1063. 

  1063. !
    1064. 

  1064. !--- 1. in bottom layer
    1065. 

  1065. !
    1066. 

  1066.       call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, &
    1067. 

  1067.            zuo,zdo,cdd,heo,dellah,j,mentrd_rate,zo,g, &
    1068. 

  1068.            CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,               &
    1069. 

  1069.            ids,ide, jds,jde, kds,kde, &
    1070. 

  1070.            ims,ime, jms,jme, kms,kme, &
    1071. 

  1071.            its,ite, jts,jte, kts,kte)
    1072. 

  1072.       call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, &
    1073. 

  1073.            zuo,zdo,cdd,qo,dellaq,j,mentrd_rate,zo,g,&
    1074. 

  1074.            CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE.,               &
    1075. 

  1075.            ids,ide, jds,jde, kds,kde, &
    1076. 

  1076.            ims,ime, jms,jme, kms,kme, &
    1077. 

  1077.            its,ite, jts,jte, kts,kte)
    1078. 

  1078. !
    1079. 

  1079. !--- 2. everywhere else
    1080. 

  1080. !
    1081. 

  1081.       call cup_dellas(ierr,zo_cup,po_cup,hcdo,edto,zdo,cdd,    &
    1082. 

  1082.            heo,dellah,j,mentrd_rate,zuo,g,                     &
    1083. 

  1083.            cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, &
    1084. 

  1084.            k22,ipr,jpr,'deep',                                 &
    1085. 

  1085.            CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,               &
    1086. 

  1086.            ids,ide, jds,jde, kds,kde, &
    1087. 

  1087.            ims,ime, jms,jme, kms,kme, &
    1088. 

  1088.            its,ite, jts,jte, kts,kte)
    1089. 

  1089. !
    1090. 

  1090. !-- take out cloud liquid water for detrainment
    1091. 

  1091. !
    1092. 

  1092. !??   do k=kts,ktf
    1093. 

  1093.       do k=kts,ktf-1
    1094. 

  1094.       do i=its,itf
    1095. 

  1095.        scr1(i,k)=0.
    1096. 

  1096.        dellaqc(i,k)=0.
    1097. 

  1097.        if(ierr(i).eq.0)then
    1098. 

  1098. !       print *,'in vupnewg, after della ',ierr(i),aa0(i),i,j
    1099. 

  1099.          scr1(i,k)=qco(i,k)-qrco(i,k)
    1100. 

  1100.          if(k.eq.ktop(i)-0)dellaqc(i,k)= &
    1101. 

  1101.                       .01*zuo(i,ktop(i))*qrco(i,ktop(i))* &
    1102. 

  1102.                       9.81/(po_cup(i,k)-po_cup(i,k+1))
    1103. 

  1103.          if(k.lt.ktop(i).and.k.gt.kbcon(i))then
    1104. 

  1104.            dz=zo_cup(i,k+1)-zo_cup(i,k)
    1105. 

  1105.            dellaqc(i,k)=.01*9.81*cd(i,k)*dz*zuo(i,k) &
    1106. 

  1106.                         *.5*(qrco(i,k)+qrco(i,k+1))/ &
    1107. 

  1107.                         (po_cup(i,k)-po_cup(i,k+1))
    1108. 

  1108.          endif
    1109. 

  1109.        endif
    1110. 

  1110.       enddo
    1111. 

  1111.       enddo
    1112. 

  1112.       call cup_dellas(ierr,zo_cup,po_cup,qrcdo,edto,zdo,cdd, &
    1113. 

  1113.            qo,dellaq,j,mentrd_rate,zuo,g, &
    1114. 

  1114.            cd,scr1,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, &
    1115. 

  1115.            k22,ipr,jpr,'deep',               &
    1116. 

  1116.            CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE.,            &
    1117. 

  1117.               ids,ide, jds,jde, kds,kde,                     &
    1118. 

  1118.               ims,ime, jms,jme, kms,kme,                     &
    1119. 

  1119.               its,ite, jts,jte, kts,kte    )
    1120. 

  1120. !
    1121. 

  1121. !--- using dellas, calculate changed environmental profiles
    1122. 

  1122. !
    1123. 

  1123. !     do 200 nens=1,maxens
    1124. 

  1124.       mbdt=mbdt_ens(2)
    1125. 

  1125.       do i=its,itf
    1126. 

  1126.       xaa0_ens(i,1)=0.
    1127. 

  1127.       xaa0_ens(i,2)=0.
    1128. 

  1128.       xaa0_ens(i,3)=0.
    1129. 

  1129.       enddo
    1130. 

  1130. 

  1131. !     mbdt=mbdt_ens(nens)
    1132. 

  1132. !     do i=its,itf 
    1133. 

  1133. !     xaa0_ens(i,nens)=0.
    1134. 

  1134. !     enddo
    1135. 

  1135.       do k=kts,ktf
    1136. 

  1136.       do i=its,itf
    1137. 

  1137.          dellat(i,k)=0.
    1138. 

  1138.          if(ierr(i).eq.0)then
    1139. 

  1139.             XHE(I,K)=DELLAH(I,K)*MBDT+HEO(I,K)
    1140. 

  1140.             XQ(I,K)=DELLAQ(I,K)*MBDT+QO(I,K)
    1141. 

  1141.             DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
    1142. 

  1142.             XT(I,K)= DELLAT(I,K)*MBDT+TN(I,K)
    1143. 

  1143.             IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
    1144. 

  1144. !            if(i.eq.ipr.and.j.eq.jpr)then
    1145. 

  1145. !              print *,k,DELLAH(I,K),DELLAQ(I,K),DELLAT(I,K)
    1146. 

  1146. !            endif
    1147. 

  1147.          ENDIF
    1148. 

  1148.       enddo
    1149. 

  1149.       enddo
    1150. 

  1150.       do i=its,itf
    1151. 

  1151.       if(ierr(i).eq.0)then
    1152. 

  1152.       XHE(I,ktf)=HEO(I,ktf)
    1153. 

  1153.       XQ(I,ktf)=QO(I,ktf)
    1154. 

  1154.       XT(I,ktf)=TN(I,ktf)
    1155. 

  1155.       IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08
    1156. 

  1156.       endif
    1157. 

  1157.       enddo
    1158. 

  1158. !
    1159. 

  1159. !--- calculate moist static energy, heights, qes
    1160. 

  1160. !
    1161. 

  1161.       call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
    1162. 

  1162.            psur,ierr,tcrit,2,xl,cp,   &
    1163. 

  1163.            ids,ide, jds,jde, kds,kde, &
    1164. 

  1164.            ims,ime, jms,jme, kms,kme, &
    1165. 

  1165.            its,ite, jts,jte, kts,kte)
    1166. 

  1166. !
    1167. 

  1167. !--- environmental values on cloud levels
    1168. 

  1168. !
    1169. 

  1169.       call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
    1170. 

  1170.            xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
    1171. 

  1171.            ierr,z1,xl,rv,cp,          &
    1172. 

  1172.            ids,ide, jds,jde, kds,kde, &
    1173. 

  1173.            ims,ime, jms,jme, kms,kme, &
    1174. 

  1174.            its,ite, jts,jte, kts,kte)
    1175. 

  1175. !
    1176. 

  1176. !
    1177. 

  1177. !**************************** static control
    1178. 

  1178. !
    1179. 

  1179. !--- moist static energy inside cloud
    1180. 

  1180. !
    1181. 

  1181.       do i=its,itf
    1182. 

  1182.         if(ierr(i).eq.0)then
    1183. 

  1183.           xhkb(i)=xhe(i,k22(i))
    1184. 

  1184.         endif
    1185. 

  1185.       enddo
    1186. 

  1186.       call cup_up_he(k22,xhkb,xz_cup,cd,mentr_rate,xhe_cup,xhc, &
    1187. 

  1187.            kbcon,ierr,xdby,xhe,xhes_cup, &
    1188. 

  1188.            ids,ide, jds,jde, kds,kde, &
    1189. 

  1189.            ims,ime, jms,jme, kms,kme, &
    1190. 

  1190.            its,ite, jts,jte, kts,kte)
    1191. 

  1191. !
    1192. 

  1192. !c--- normalized mass flux profile
    1193. 

  1193. !
    1194. 

  1194.       call cup_up_nms(xzu,xz_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, &
    1195. 

  1195.            ids,ide, jds,jde, kds,kde, &
    1196. 

  1196.            ims,ime, jms,jme, kms,kme, &
    1197. 

  1197.            its,ite, jts,jte, kts,kte)
    1198. 

  1198. !
    1199. 

  1199. !--- moisture downdraft
    1200. 

  1200. !
    1201. 

  1201.       call cup_dd_nms(xzd,xz_cup,cdd,mentrd_rate,jmin,ierr, &
    1202. 

  1202.            1,kdet,z1,                 &
    1203. 

  1203.            ids,ide, jds,jde, kds,kde, &
    1204. 

  1204.            ims,ime, jms,jme, kms,kme, &
    1205. 

  1205.            its,ite, jts,jte, kts,kte)
    1206. 

  1206.       call cup_dd_he(xhes_cup,xzd,xhcd,xz_cup,cdd,mentrd_rate, &
    1207. 

  1207.            jmin,ierr,xhe,dbyd,xhe_cup,&
    1208. 

  1208.            ids,ide, jds,jde, kds,kde, &
    1209. 

  1209.            ims,ime, jms,jme, kms,kme, &
    1210. 

  1210.            its,ite, jts,jte, kts,kte)
    1211. 

  1211.       call cup_dd_moisture(xzd,xhcd,xhes_cup,xqcd,xqes_cup, &
    1212. 

  1212.            xpwd,xq_cup,xz_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, &
    1213. 

  1213.            xpwev,bu,xqrcd,xq,xhe,xt_cup,3,xl, &
    1214. 

  1214.            ids,ide, jds,jde, kds,kde, &
    1215. 

  1215.            ims,ime, jms,jme, kms,kme, &
    1216. 

  1216.            its,ite, jts,jte, kts,kte)
    1217. 

  1217. 

  1218. !
    1219. 

  1219. !------- MOISTURE updraft
    1220. 

  1220. !
    1221. 

  1221.       call cup_up_moisture(ierr,xz_cup,xqc,xqrc,xpw,xpwav, &
    1222. 

  1222.            kbcon,ktop,cd,xdby,mentr_rate,clw_all, &
    1223. 

  1223.            xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, &
    1224. 

  1224.            ids,ide, jds,jde, kds,kde, &
    1225. 

  1225.            ims,ime, jms,jme, kms,kme, &
    1226. 

  1226.            its,ite, jts,jte, kts,kte)
    1227. 

  1227. !
    1228. 

  1228. !--- workfunctions for updraft
    1229. 

  1229. !
    1230. 

  1230.       call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
    1231. 

  1231.            kbcon,ktop,ierr,           &
    1232. 

  1232.            ids,ide, jds,jde, kds,kde, &
    1233. 

  1233.            ims,ime, jms,jme, kms,kme, &
    1234. 

  1234.            its,ite, jts,jte, kts,kte)
    1235. 

  1235. !
    1236. 

  1236. !--- workfunctions for downdraft
    1237. 

  1237. !
    1238. 

  1238. !
    1239. 

  1239. !     call cup_dd_aa0(edtx,ierr,xaa0,jmin,gamma_cup,xt_cup, &
    1240. 

  1240. !          xhcd,xhes_cup,xz,xzd,      &
    1241. 

  1241. !          ids,ide, jds,jde, kds,kde, &
    1242. 

  1242. !          ims,ime, jms,jme, kms,kme, &
    1243. 

  1243. !          its,ite, jts,jte, kts,kte)
    1244. 

  1244.       do 200 nens=1,maxens
    1245. 

  1245.       do i=its,itf 
    1246. 

  1246.          if(ierr(i).eq.0)then
    1247. 

  1247.            xaa0_ens(i,nens)=xaa0(i)
    1248. 

  1248.            nall=(iens-1)*maxens3*maxens*maxens2 &
    1249. 

  1249.                 +(iedt-1)*maxens*maxens3 &
    1250. 

  1250.                 +(nens-1)*maxens3
    1251. 

  1251.            do k=kts,ktf
    1252. 

  1252.               if(k.le.ktop(i))then
    1253. 

  1253.                  do nens3=1,maxens3
    1254. 

  1254.                  if(nens3.eq.7)then
    1255. 

  1255. !--- b=0
    1256. 

  1256.                  pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
    1257. 

  1257.                                     pwo(i,k) 
    1258. 

  1258. !                                  +edto(i)*pwdo(i,k)
    1259. 

  1259. !--- b=beta
    1260. 

  1260.                  else if(nens3.eq.8)then
    1261. 

  1261.                  pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
    1262. 

  1262.                                     pwo(i,k)
    1263. 

  1263. !--- b=beta/2
    1264. 

  1264.                  else if(nens3.eq.9)then
    1265. 

  1265.                  pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
    1266. 

  1266.                                     pwo(i,k)
    1267. 

  1267. !                                  +.5*edto(i)*pwdo(i,k)
    1268. 

  1268.                  else
    1269. 

  1269.                  pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
    1270. 

  1270.                                     pwo(i,k)+edto(i)*pwdo(i,k)
    1271. 

  1271.                  endif
    1272. 

  1272.                  enddo
    1273. 

  1273.               endif
    1274. 

  1274.            enddo
    1275. 

  1275.          if(pr_ens(i,j,nall+7).lt.1.e-6)then
    1276. 

  1276.             ierr(i)=18
    1277. 

  1277.             do nens3=1,maxens3
    1278. 

  1278.                pr_ens(i,j,nall+nens3)=0.
    1279. 

  1279.             enddo
    1280. 

  1280.          endif
    1281. 

  1281.          do nens3=1,maxens3
    1282. 

  1282.            if(pr_ens(i,j,nall+nens3).lt.1.e-4)then
    1283. 

  1283.             pr_ens(i,j,nall+nens3)=0.
    1284. 

  1284.            endif
    1285. 

  1285.          enddo
    1286. 

  1286.          endif
    1287. 

  1287.       enddo
    1288. 

  1288.  200  continue
    1289. 

  1289. !
    1290. 

  1290. !--- LARGE SCALE FORCING
    1291. 

  1291. !
    1292. 

  1292. !
    1293. 

  1293. !------- CHECK wether aa0 should have been zero
    1294. 

  1294. !
    1295. 

  1295. !
    1296. 

  1296.       CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
    1297. 

  1297.            ids,ide, jds,jde, kds,kde, &
    1298. 

  1298.            ims,ime, jms,jme, kms,kme, &
    1299. 

  1299.            its,ite, jts,jte, kts,kte)
    1300. 

  1300.       do i=its,itf
    1301. 

  1301.          ierr2(i)=ierr(i)
    1302. 

  1302.          ierr3(i)=ierr(i)
    1303. 

  1303.       enddo
    1304. 

  1304.       call cup_kbcon(cap_max_increment,2,k22x,kbconx,heo_cup, &
    1305. 

  1305.            heso_cup,ierr2,kbmax,po_cup,cap_max, &
    1306. 

  1306.            ids,ide, jds,jde, kds,kde, &
    1307. 

  1307.            ims,ime, jms,jme, kms,kme, &
    1308. 

  1308.            its,ite, jts,jte, kts,kte)
    1309. 

  1309.       call cup_kbcon(cap_max_increment,3,k22x,kbconx,heo_cup, &
    1310. 

  1310.            heso_cup,ierr3,kbmax,po_cup,cap_max, &
    1311. 

  1311.            ids,ide, jds,jde, kds,kde, &
    1312. 

  1312.            ims,ime, jms,jme, kms,kme, &
    1313. 

  1313.            its,ite, jts,jte, kts,kte)
    1314. 

  1314. !
    1315. 

  1315. !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
    1316. 

  1316. !
    1317. 

  1317.       call cup_forcing_ens(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime,   &
    1318. 

  1318.            ierr,ierr2,ierr3,xf_ens,j,'deeps',                 &
    1319. 

  1319.            maxens,iens,iedt,maxens2,maxens3,mconv,            &
    1320. 

  1320.            po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon,    &
    1321. 

  1321.            massflx,iact,direction,ensdim,massfln,ichoice,     &
    1322. 

  1322.            ids,ide, jds,jde, kds,kde, &
    1323. 

  1323.            ims,ime, jms,jme, kms,kme, &
    1324. 

  1324.            its,ite, jts,jte, kts,kte)
    1325. 

  1325. !
    1326. 

  1326.       do k=kts,ktf
    1327. 

  1327.       do i=its,itf
    1328. 

  1328.         if(ierr(i).eq.0)then
    1329. 

  1329.            dellat_ens(i,k,iedt)=dellat(i,k)
    1330. 

  1330.            dellaq_ens(i,k,iedt)=dellaq(i,k)
    1331. 

  1331.            dellaqc_ens(i,k,iedt)=dellaqc(i,k)
    1332. 

  1332.            pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k)
    1333. 

  1333.         else 
    1334. 

  1334.            dellat_ens(i,k,iedt)=0.
    1335. 

  1335.            dellaq_ens(i,k,iedt)=0.
    1336. 

  1336.            dellaqc_ens(i,k,iedt)=0.
    1337. 

  1337.            pwo_ens(i,k,iedt)=0.
    1338. 

  1338.         endif
    1339. 

  1339. !      if(i.eq.ipr.and.j.eq.jpr)then
    1340. 

  1340. !        print *,iens,iedt,dellat(i,k),dellat_ens(i,k,iedt), &
    1341. 

  1341. !          dellaq(i,k), dellaqc(i,k)
    1342. 

  1342. !      endif
    1343. 

  1343.       enddo
    1344. 

  1344.       enddo
    1345. 

  1345.       if (l_flux) then
    1346. 

  1346.          do k=kts,ktf
    1347. 

  1347.             do i=its,itf
    1348. 

  1348.                if(ierr(i).eq.0)then
    1349. 

  1349.                  cfu1_ens(i,k,iedt)=cfu1(i,k)
    1350. 

  1350.                  cfd1_ens(i,k,iedt)=cfd1(i,k)
    1351. 

  1351.                  dfu1_ens(i,k,iedt)=dfu1(i,k)
    1352. 

  1352.                  efu1_ens(i,k,iedt)=efu1(i,k)
    1353. 

  1353.                  dfd1_ens(i,k,iedt)=dfd1(i,k)
    1354. 

  1354.                  efd1_ens(i,k,iedt)=efd1(i,k)
    1355. 

  1355.               else
    1356. 

  1356.                  cfu1_ens(i,k,iedt)=0.
    1357. 

  1357.                  cfd1_ens(i,k,iedt)=0.
    1358. 

  1358.                  dfu1_ens(i,k,iedt)=0.
    1359. 

  1359.                  efu1_ens(i,k,iedt)=0.
    1360. 

  1360.                  dfd1_ens(i,k,iedt)=0.
    1361. 

  1361.                  efd1_ens(i,k,iedt)=0.
    1362. 

  1362.               end if
    1363. 

  1363.            end do
    1364. 

  1364.          end do
    1365. 

  1365.       end if
    1366. 

  1366. 

  1367.  250  continue
    1368. 

  1368. !
    1369. 

  1369. !--- FEEDBACK
    1370. 

  1370. !
    1371. 

  1371.       call cup_output_ens(xf_ens,ierr,dellat_ens,dellaq_ens, &
    1372. 

  1372.            dellaqc_ens,outt,outq,outqc,pre,pwo_ens,xmb,ktop, &
    1373. 

  1373.            j,'deep',maxens2,maxens,iens,ierr2,ierr3,         &
    1374. 

  1374.            pr_ens,maxens3,ensdim,massfln,                    &
    1375. 

  1375.            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                &
    1376. 

  1376.            APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,   &
    1377. 

  1377.            outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,  &
    1378. 

  1378.            CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens,  &
    1379. 

  1379.            l_flux,                                           &
    1380. 

  1380.            ids,ide, jds,jde, kds,kde, &
    1381. 

  1381.            ims,ime, jms,jme, kms,kme, &
    1382. 

  1382.            its,ite, jts,jte, kts,kte)
    1383. 

  1383.       do i=its,itf
    1384. 

  1384.            PRE(I)=MAX(PRE(I),0.)
    1385. 

  1385.       enddo
    1386. 

  1386. !
    1387. 

  1387. !---------------------------done------------------------------
    1388. 

  1388. !
    1389. 

  1389. 

  1390.    END SUBROUTINE CUP_enss
    1391. 

  1391. 

  1392. 

  1393.    SUBROUTINE cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, &
    1394. 

  1394.               hcd,hes_cup,z,zd,                             &
    1395. 

  1395.               ids,ide, jds,jde, kds,kde,                    &
    1396. 

  1396.               ims,ime, jms,jme, kms,kme,                    &
    1397. 

  1397.               its,ite, jts,jte, kts,kte                    )
    1398. 

  1398. 

  1399.    IMPLICIT NONE
    1400. 

  1400. !
    1401. 

  1401. !  on input
    1402. 

  1402. !
    1403. 

  1403. 

  1404.    ! only local wrf dimensions are need as of now in this routine
    1405. 

  1405. 

  1406.      integer                                                           &
    1407. 

  1407.         ,intent (in   )                   ::                           &
    1408. 

  1408.         ids,ide, jds,jde, kds,kde,                                     &
    1409. 

  1409.         ims,ime, jms,jme, kms,kme,                                     &
    1410. 

  1410.         its,ite, jts,jte, kts,kte
    1411. 

  1411.   ! aa0 cloud work function for downdraft
    1412. 

  1412.   ! gamma_cup = gamma on model cloud levels
    1413. 

  1413.   ! t_cup = temperature (Kelvin) on model cloud levels
    1414. 

  1414.   ! hes_cup = saturation moist static energy on model cloud levels
    1415. 

  1415.   ! hcd = moist static energy in downdraft
    1416. 

  1416.   ! edt = epsilon
    1417. 

  1417.   ! zd normalized downdraft mass flux
    1418. 

  1418.   ! z = heights of model levels 
    1419. 

  1419.   ! ierr error value, maybe modified in this routine
    1420. 

  1420.   !
    1421. 

  1421.      real,    dimension (its:ite,kts:kte)                              &
    1422. 

  1422.         ,intent (in   )                   ::                           &
    1423. 

  1423.         z,zd,gamma_cup,t_cup,hes_cup,hcd
    1424. 

  1424.      real,    dimension (its:ite)                                      &
    1425. 

  1425.         ,intent (in   )                   ::                           &
    1426. 

  1426.         edt
    1427. 

  1427.      integer, dimension (its:ite)                                      &
    1428. 

  1428.         ,intent (in   )                   ::                           &
    1429. 

  1429.         jmin
    1430. 

  1430. !
    1431. 

  1431. ! input and output
    1432. 

  1432. !
    1433. 

  1433. 

  1434. 

  1435.      integer, dimension (its:ite)                                      &
    1436. 

  1436.         ,intent (inout)                   ::                           &
    1437. 

  1437.         ierr
    1438. 

  1438.      real,    dimension (its:ite)                                      &
    1439. 

  1439.         ,intent (out  )                   ::                           &
    1440. 

  1440.         aa0
    1441. 

  1441. !
    1442. 

  1442. !  local variables in this routine
    1443. 

  1443. !
    1444. 

  1444. 

  1445.      integer                              ::                           &
    1446. 

  1446.         i,k,kk
    1447. 

  1447.      real                                 ::                           &
    1448. 

  1448.         dz
    1449. 

  1449. !
    1450. 

  1450.      integer :: itf, ktf
    1451. 

  1451. !
    1452. 

  1452.      itf=MIN(ite,ide-1)
    1453. 

  1453.      ktf=MIN(kte,kde-1)
    1454. 

  1454. !
    1455. 

  1455. !??    DO k=kts,kte-1
    1456. 

  1456.        DO k=kts,ktf-1
    1457. 

  1457.        do i=its,itf
    1458. 

  1458.          IF(ierr(I).eq.0.and.k.lt.jmin(i))then
    1459. 

  1459.          KK=JMIN(I)-K
    1460. 

  1460. !
    1461. 

  1461. !--- ORIGINAL
    1462. 

  1462. !
    1463. 

  1463.          DZ=(Z(I,KK)-Z(I,KK+1))
    1464. 

  1464.          AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(9.81/(1004.*T_cup(I,KK))) &
    1465. 

  1465.             *((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk)))
    1466. 

  1466.          endif
    1467. 

  1467.       enddo
    1468. 

  1468.       enddo
    1469. 

  1469. 

  1470.    END SUBROUTINE CUP_dd_aa0
    1471. 

  1471. 

  1472. 

  1473.    SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, &
    1474. 

  1474.               pwev,edtmax,edtmin,maxens2,edtc,               &
    1475. 

  1475.               ids,ide, jds,jde, kds,kde,                     &
    1476. 

  1476.               ims,ime, jms,jme, kms,kme,                     &
    1477. 

  1477.               its,ite, jts,jte, kts,kte                     )
    1478. 

  1478. 

  1479.    IMPLICIT NONE
    1480. 

  1480. 

  1481.      integer                                                           &
    1482. 

  1482.         ,intent (in   )                   ::                           &
    1483. 

  1483.         ids,ide, jds,jde, kds,kde,           &
    1484. 

  1484.         ims,ime, jms,jme, kms,kme,           &
    1485. 

  1485.         its,ite, jts,jte, kts,kte
    1486. 

  1486.      integer, intent (in   )              ::                           &
    1487. 

  1487.         maxens2
    1488. 

  1488.   !
    1489. 

  1489.   ! ierr error value, maybe modified in this routine
    1490. 

  1490.   !
    1491. 

  1491.      real,    dimension (its:ite,kts:kte)                              &
    1492. 

  1492.         ,intent (in   )                   ::                           &
    1493. 

  1493.         us,vs,z,p
    1494. 

  1494.      real,    dimension (its:ite,1:maxens2)                            &
    1495. 

  1495.         ,intent (out  )                   ::                           &
    1496. 

  1496.         edtc
    1497. 

  1497.      real,    dimension (its:ite)                                      &
    1498. 

  1498.         ,intent (out  )                   ::                           &
    1499. 

  1499.         edt
    1500. 

  1500.      real,    dimension (its:ite)                                      &
    1501. 

  1501.         ,intent (in   )                   ::                           &
    1502. 

  1502.         pwav,pwev
    1503. 

  1503.      real                                                              &
    1504. 

  1504.         ,intent (in   )                   ::                           &
    1505. 

  1505.         edtmax,edtmin
    1506. 

  1506.      integer, dimension (its:ite)                                      &
    1507. 

  1507.         ,intent (in   )                   ::                           &
    1508. 

  1508.         ktop,kbcon
    1509. 

  1509.      integer, dimension (its:ite)                                      &
    1510. 

  1510.         ,intent (inout)                   ::                           &
    1511. 

  1511.         ierr
    1512. 

  1512. !
    1513. 

  1513. !  local variables in this routine
    1514. 

  1514. !
    1515. 

  1515. 

  1516.      integer i,k,kk
    1517. 

  1517.      real    einc,pef,pefb,prezk,zkbc
    1518. 

  1518.      real,    dimension (its:ite)         ::                           &
    1519. 

  1519.       vshear,sdp,vws
    1520. 

  1520. 

  1521.      integer :: itf, ktf
    1522. 

  1522. 

  1523.      itf=MIN(ite,ide-1)
    1524. 

  1524.      ktf=MIN(kte,kde-1)
    1525. 

  1525. !
    1526. 

  1526. !--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
    1527. 

  1527. !
    1528. 

  1528. ! */ calculate an average wind shear over the depth of the cloud
    1529. 

  1529. !
    1530. 

  1530.        do i=its,itf
    1531. 

  1531.         edt(i)=0.
    1532. 

  1532.         vws(i)=0.
    1533. 

  1533.         sdp(i)=0.
    1534. 

  1534.         vshear(i)=0.
    1535. 

  1535.        enddo
    1536. 

  1536.        do kk = kts,ktf-1
    1537. 

  1537.          do 62 i=its,itf
    1538. 

  1538.           IF(ierr(i).ne.0)GO TO 62
    1539. 

  1539.           if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then
    1540. 

  1540.              vws(i) = vws(i)+ &
    1541. 

  1541.               (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) &
    1542. 

  1542.           +   abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * &
    1543. 

  1543.               (p(i,kk) - p(i,kk+1))
    1544. 

  1544.             sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1)
    1545. 

  1545.           endif
    1546. 

  1546.           if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i)
    1547. 

  1547.    62   continue
    1548. 

  1548.        end do
    1549. 

  1549.       do i=its,itf
    1550. 

  1550.          IF(ierr(i).eq.0)then
    1551. 

  1551.             pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) &
    1552. 

  1552.                -.00496*(VSHEAR(I)**3))
    1553. 

  1553.             if(pef.gt.edtmax)pef=edtmax
    1554. 

  1554.             if(pef.lt.edtmin)pef=edtmin
    1555. 

  1555. !
    1556. 

  1556. !--- cloud base precip efficiency
    1557. 

  1557. !
    1558. 

  1558.             zkbc=z(i,kbcon(i))*3.281e-3
    1559. 

  1559.             prezk=.02
    1560. 

  1560.             if(zkbc.gt.3.)then
    1561. 

  1561.                prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc &
    1562. 

  1562.                *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6))))
    1563. 

  1563.             endif
    1564. 

  1564.             if(zkbc.gt.25)then
    1565. 

  1565.                prezk=2.4
    1566. 

  1566.             endif
    1567. 

  1567.             pefb=1./(1.+prezk)
    1568. 

  1568.             if(pefb.gt.edtmax)pefb=edtmax
    1569. 

  1569.             if(pefb.lt.edtmin)pefb=edtmin
    1570. 

  1570.             EDT(I)=1.-.5*(pefb+pef)
    1571. 

  1571. !--- edt here is 1-precipeff!
    1572. 

  1572. !           einc=(1.-edt(i))/float(maxens2)
    1573. 

  1573. !           einc=edt(i)/float(maxens2+1)
    1574. 

  1574. !--- 20 percent
    1575. 

  1575.             einc=.2*edt(i)
    1576. 

  1576.             do k=1,maxens2
    1577. 

  1577.                 edtc(i,k)=edt(i)+float(k-2)*einc
    1578. 

  1578.             enddo
    1579. 

  1579.          endif
    1580. 

  1580.       enddo
    1581. 

  1581.       do i=its,itf
    1582. 

  1582.          IF(ierr(i).eq.0)then
    1583. 

  1583.             do k=1,maxens2
    1584. 

  1584.                EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I)
    1585. 

  1585.                IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax
    1586. 

  1586.                IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin
    1587. 

  1587.             enddo
    1588. 

  1588.          endif
    1589. 

  1589.       enddo
    1590. 

  1590. 

  1591.    END SUBROUTINE cup_dd_edt
    1592. 

  1592. 

  1593. 

  1594.    SUBROUTINE cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,entr,       &
    1595. 

  1595.               jmin,ierr,he,dby,he_cup,                       &
    1596. 

  1596.               ids,ide, jds,jde, kds,kde,                     &
    1597. 

  1597.               ims,ime, jms,jme, kms,kme,                     &
    1598. 

  1598.               its,ite, jts,jte, kts,kte                     )
    1599. 

  1599. 

  1600.    IMPLICIT NONE
    1601. 

  1601. !
    1602. 

  1602. !  on input
    1603. 

  1603. !
    1604. 

  1604. 

  1605.    ! only local wrf dimensions are need as of now in this routine
    1606. 

  1606. 

  1607.      integer                                                           &
    1608. 

  1608.         ,intent (in   )                   ::                           &
    1609. 

  1609.                                   ids,ide, jds,jde, kds,kde,           &
    1610. 

  1610.                                   ims,ime, jms,jme, kms,kme,           &
    1611. 

  1611.                                   its,ite, jts,jte, kts,kte
    1612. 

  1612.   ! hcd = downdraft moist static energy
    1613. 

  1613.   ! he = moist static energy on model levels
    1614. 

  1614.   ! he_cup = moist static energy on model cloud levels
    1615. 

  1615.   ! hes_cup = saturation moist static energy on model cloud levels
    1616. 

  1616.   ! dby = buoancy term
    1617. 

  1617.   ! cdd= detrainment function 
    1618. 

  1618.   ! z_cup = heights of model cloud levels 
    1619. 

  1619.   ! entr = entrainment rate
    1620. 

  1620.   ! zd   = downdraft normalized mass flux
    1621. 

  1621.   !
    1622. 

  1622.      real,    dimension (its:ite,kts:kte)                              &
    1623. 

  1623.         ,intent (in   )                   ::                           &
    1624. 

  1624.         he,he_cup,hes_cup,z_cup,cdd,zd
    1625. 

  1625.   ! entr= entrainment rate 
    1626. 

  1626.      real                                                              &
    1627. 

  1627.         ,intent (in   )                   ::                           &
    1628. 

  1628.         entr
    1629. 

  1629.      integer, dimension (its:ite)                                      &
    1630. 

  1630.         ,intent (in   )                   ::                           &
    1631. 

  1631.         jmin
    1632. 

  1632. !
    1633. 

  1633. ! input and output
    1634. 

  1634. !
    1635. 

  1635. 

  1636.    ! ierr error value, maybe modified in this routine
    1637. 

  1637. 

  1638.      integer, dimension (its:ite)                                      &
    1639. 

  1639.         ,intent (inout)                   ::                           &
    1640. 

  1640.         ierr
    1641. 

  1641. 

  1642.      real,    dimension (its:ite,kts:kte)                              &
    1643. 

  1643.         ,intent (out  )                   ::                           &
    1644. 

  1644.         hcd,dby
    1645. 

  1645. !
    1646. 

  1646. !  local variables in this routine
    1647. 

  1647. !
    1648. 

  1648. 

  1649.      integer                              ::                           &
    1650. 

  1650.         i,k,ki
    1651. 

  1651.      real                                 ::                           &
    1652. 

  1652.         dz
    1653. 

  1653. 

  1654.      integer :: itf, ktf
    1655. 

  1655. 

  1656.      itf=MIN(ite,ide-1)
    1657. 

  1657.      ktf=MIN(kte,kde-1)
    1658. 

  1658. 

  1659.       do k=kts+1,ktf
    1660. 

  1660.       do i=its,itf
    1661. 

  1661.       dby(i,k)=0.
    1662. 

  1662.       IF(ierr(I).eq.0)then
    1663. 

  1663.          hcd(i,k)=hes_cup(i,k)
    1664. 

  1664.       endif
    1665. 

  1665.       enddo
    1666. 

  1666.       enddo
    1667. 

  1667. !
    1668. 

  1668.       do 100 i=its,itf
    1669. 

  1669.       IF(ierr(I).eq.0)then
    1670. 

  1670.       k=jmin(i)
    1671. 

  1671.       hcd(i,k)=hes_cup(i,k)
    1672. 

  1672.       dby(i,k)=hcd(i,jmin(i))-hes_cup(i,k)
    1673. 

  1673. !
    1674. 

  1674.       do ki=jmin(i)-1,1,-1
    1675. 

  1675.          DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
    1676. 

  1676.          HCD(i,Ki)=(HCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
    1677. 

  1677.                   +entr*DZ*HE(i,Ki) &
    1678. 

  1678.                   )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
    1679. 

  1679.          dby(i,ki)=HCD(i,Ki)-hes_cup(i,ki)
    1680. 

  1680.       enddo
    1681. 

  1681. !
    1682. 

  1682.       endif
    1683. 

  1683. !--- end loop over i
    1684. 

  1684. 100    continue
    1685. 

  1685. 

  1686. 

  1687.    END SUBROUTINE cup_dd_he
    1688. 

  1688. 

  1689. 

  1690.    SUBROUTINE cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup,    &
    1691. 

  1691.               pwd,q_cup,z_cup,cdd,entr,jmin,ierr,            &
    1692. 

  1692.               gamma_cup,pwev,bu,qrcd,                        &
    1693. 

  1693.               q,he,t_cup,iloop,xl,                           &
    1694. 

  1694.               ids,ide, jds,jde, kds,kde,                     &
    1695. 

  1695.               ims,ime, jms,jme, kms,kme,                     &
    1696. 

  1696.               its,ite, jts,jte, kts,kte                     )
    1697. 

  1697. 

  1698.    IMPLICIT NONE
    1699. 

  1699. 

  1700.      integer                                                           &
    1701. 

  1701.         ,intent (in   )                   ::                           &
    1702. 

  1702.                                   ids,ide, jds,jde, kds,kde,           &
    1703. 

  1703.                                   ims,ime, jms,jme, kms,kme,           &
    1704. 

  1704.                                   its,ite, jts,jte, kts,kte
    1705. 

  1705.   ! cdd= detrainment function 
    1706. 

  1706.   ! q = environmental q on model levels
    1707. 

  1707.   ! q_cup = environmental q on model cloud levels
    1708. 

  1708.   ! qes_cup = saturation q on model cloud levels
    1709. 

  1709.   ! hes_cup = saturation h on model cloud levels
    1710. 

  1710.   ! hcd = h in model cloud
    1711. 

  1711.   ! bu = buoancy term
    1712. 

  1712.   ! zd = normalized downdraft mass flux
    1713. 

  1713.   ! gamma_cup = gamma on model cloud levels
    1714. 

  1714.   ! mentr_rate = entrainment rate
    1715. 

  1715.   ! qcd = cloud q (including liquid water) after entrainment
    1716. 

  1716.   ! qrch = saturation q in cloud
    1717. 

  1717.   ! pwd = evaporate at that level
    1718. 

  1718.   ! pwev = total normalized integrated evaoprate (I2)
    1719. 

  1719.   ! entr= entrainment rate 
    1720. 

  1720.   !
    1721. 

  1721.      real,    dimension (its:ite,kts:kte)                              &
    1722. 

  1722.         ,intent (in   )                   ::                           &
    1723. 

  1723.         zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,cdd,gamma_cup,q,he 
    1724. 

  1724.      real                                                              &
    1725. 

  1725.         ,intent (in   )                   ::                           &
    1726. 

  1726.         entr,xl
    1727. 

  1727.      integer                                                           &
    1728. 

  1728.         ,intent (in   )                   ::                           &
    1729. 

  1729.         iloop
    1730. 

  1730.      integer, dimension (its:ite)                                      &
    1731. 

  1731.         ,intent (in   )                   ::                           &
    1732. 

  1732.         jmin
    1733. 

  1733.      integer, dimension (its:ite)                                      &
    1734. 

  1734.         ,intent (inout)                   ::                           &
    1735. 

  1735.         ierr
    1736. 

  1736.      real,    dimension (its:ite,kts:kte)                              &
    1737. 

  1737.         ,intent (out  )                   ::                           &
    1738. 

  1738.         qcd,qrcd,pwd
    1739. 

  1739.      real,    dimension (its:ite)                                      &
    1740. 

  1740.         ,intent (out  )                   ::                           &
    1741. 

  1741.         pwev,bu
    1742. 

  1742. !
    1743. 

  1743. !  local variables in this routine
    1744. 

  1744. !
    1745. 

  1745. 

  1746.      integer                              ::                           &
    1747. 

  1747.         i,k,ki
    1748. 

  1748.      real                                 ::                           &
    1749. 

  1749.         dh,dz,dqeva
    1750. 

  1750. 

  1751.      integer :: itf, ktf
    1752. 

  1752. 

  1753.      itf=MIN(ite,ide-1)
    1754. 

  1754.      ktf=MIN(kte,kde-1)
    1755. 

  1755. 

  1756.       do i=its,itf
    1757. 

  1757.          bu(i)=0.
    1758. 

  1758.          pwev(i)=0.
    1759. 

  1759.       enddo
    1760. 

  1760.       do k=kts,ktf
    1761. 

  1761.       do i=its,itf
    1762. 

  1762.          qcd(i,k)=0.
    1763. 

  1763.          qrcd(i,k)=0.
    1764. 

  1764.          pwd(i,k)=0.
    1765. 

  1765.       enddo
    1766. 

  1766.       enddo
    1767. 

  1767. !
    1768. 

  1768. !
    1769. 

  1769. !
    1770. 

  1770.       do 100 i=its,itf
    1771. 

  1771.       IF(ierr(I).eq.0)then
    1772. 

  1772.       k=jmin(i)
    1773. 

  1773.       DZ=Z_cup(i,K+1)-Z_cup(i,K)
    1774. 

  1774.       qcd(i,k)=q_cup(i,k)
    1775. 

  1775. !     qcd(i,k)=.5*(qes_cup(i,k)+q_cup(i,k))
    1776. 

  1776.       qrcd(i,k)=qes_cup(i,k)
    1777. 

  1777.       pwd(i,jmin(i))=min(0.,qcd(i,k)-qrcd(i,k))
    1778. 

  1778.       pwev(i)=pwev(i)+pwd(i,jmin(i))
    1779. 

  1779.       qcd(i,k)=qes_cup(i,k)
    1780. 

  1780. !
    1781. 

  1781.       DH=HCD(I,k)-HES_cup(I,K)
    1782. 

  1782.       bu(i)=dz*dh
    1783. 

  1783.       do ki=jmin(i)-1,1,-1
    1784. 

  1784.          DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
    1785. 

  1785.          QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
    1786. 

  1786.                   +entr*DZ*q(i,Ki) &
    1787. 

  1787.                   )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
    1788. 

  1788. !
    1789. 

  1789. !--- to be negatively buoyant, hcd should be smaller than hes!
    1790. 

  1790. !
    1791. 

  1791.          DH=HCD(I,ki)-HES_cup(I,Ki)
    1792. 

  1792.          bu(i)=bu(i)+dz*dh
    1793. 

  1793.          QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) &
    1794. 

  1794.                   /(1.+GAMMA_cup(i,ki)))*DH
    1795. 

  1795.          dqeva=qcd(i,ki)-qrcd(i,ki)
    1796. 

  1796.          if(dqeva.gt.0.)dqeva=0.
    1797. 

  1797.          pwd(i,ki)=zd(i,ki)*dqeva
    1798. 

  1798.          qcd(i,ki)=qrcd(i,ki)
    1799. 

  1799.          pwev(i)=pwev(i)+pwd(i,ki)
    1800. 

  1800. !        if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then
    1801. 

  1801. !         print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva
    1802. 

  1802. !        endif
    1803. 

  1803.       enddo
    1804. 

  1804. !
    1805. 

  1805. !--- end loop over i
    1806. 

  1806.        if(pwev(I).eq.0.and.iloop.eq.1)then
    1807. 

  1807. !        print *,'problem with buoy in cup_dd_moisture',i
    1808. 

  1808.          ierr(i)=7
    1809. 

  1809.        endif
    1810. 

  1810.        if(BU(I).GE.0.and.iloop.eq.1)then
    1811. 

  1811. !        print *,'problem with buoy in cup_dd_moisture',i
    1812. 

  1812.          ierr(i)=7
    1813. 

  1813.        endif
    1814. 

  1814.       endif
    1815. 

  1815. 100    continue
    1816. 

  1816. 

  1817.    END SUBROUTINE cup_dd_moisture
    1818. 

  1818. 

  1819. 

  1820.    SUBROUTINE cup_dd_nms(zd,z_cup,cdd,entr,jmin,ierr,        &
    1821. 

  1821.               itest,kdet,z1,                                 &
    1822. 

  1822.               ids,ide, jds,jde, kds,kde,                     &
    1823. 

  1823.               ims,ime, jms,jme, kms,kme,                     &
    1824. 

  1824.               its,ite, jts,jte, kts,kte                     )
    1825. 

  1825. 

  1826.    IMPLICIT NONE
    1827. 

  1827. !
    1828. 

  1828. !  on input
    1829. 

  1829. !
    1830. 

  1830. 

  1831.    ! only local wrf dimensions are need as of now in this routine
    1832. 

  1832. 

  1833.      integer                                                           &
    1834. 

  1834.         ,intent (in   )                   ::                           &
    1835. 

  1835.                                   ids,ide, jds,jde, kds,kde,           &
    1836. 

  1836.                                   ims,ime, jms,jme, kms,kme,           &
    1837. 

  1837.                                   its,ite, jts,jte, kts,kte
    1838. 

  1838.   ! z_cup = height of cloud model level
    1839. 

  1839.   ! z1 = terrain elevation
    1840. 

  1840.   ! entr = downdraft entrainment rate
    1841. 

  1841.   ! jmin = downdraft originating level
    1842. 

  1842.   ! kdet = level above ground where downdraft start detraining
    1843. 

  1843.   ! itest = flag to whether to calculate cdd
    1844. 

  1844.   
    1845. 

  1845.      real,    dimension (its:ite,kts:kte)                              &
    1846. 

  1846.         ,intent (in   )                   ::                           &
    1847. 

  1847.         z_cup
    1848. 

  1848.      real,    dimension (its:ite)                                      &
    1849. 

  1849.         ,intent (in   )                   ::                           &
    1850. 

  1850.         z1 
    1851. 

  1851.      real                                                              &
    1852. 

  1852.         ,intent (in   )                   ::                           &
    1853. 

  1853.         entr 
    1854. 

  1854.      integer, dimension (its:ite)                                      &
    1855. 

  1855.         ,intent (in   )                   ::                           &
    1856. 

  1856.         jmin,kdet
    1857. 

  1857.      integer                                                           &
    1858. 

  1858.         ,intent (in   )                   ::                           &
    1859. 

  1859.         itest
    1860. 

  1860. !
    1861. 

  1861. ! input and output
    1862. 

  1862. !
    1863. 

  1863. 

  1864.    ! ierr error value, maybe modified in this routine
    1865. 

  1865. 

  1866.      integer, dimension (its:ite)                                      &
    1867. 

  1867.         ,intent (inout)                   ::                           &
    1868. 

  1868.                                                                  ierr
    1869. 

  1869.    ! zd is the normalized downdraft mass flux
    1870. 

  1870.    ! cdd is the downdraft detrainmen function
    1871. 

  1871. 

  1872.      real,    dimension (its:ite,kts:kte)                              &
    1873. 

  1873.         ,intent (out  )                   ::                           &
    1874. 

  1874.                                                              zd
    1875. 

  1875.      real,    dimension (its:ite,kts:kte)                              &
    1876. 

  1876.         ,intent (inout)                   ::                           &
    1877. 

  1877.                                                              cdd
    1878. 

  1878. !
    1879. 

  1879. !  local variables in this routine
    1880. 

  1880. !
    1881. 

  1881. 

  1882.      integer                              ::                           &
    1883. 

  1883.                                                   i,k,ki
    1884. 

  1884.      real                                 ::                           &
    1885. 

  1885.                                             a,perc,dz
    1886. 

  1886. 

  1887.      integer :: itf, ktf
    1888. 

  1888. 

  1889.      itf=MIN(ite,ide-1)
    1890. 

  1890.      ktf=MIN(kte,kde-1)
    1891. 

  1891. !
    1892. 

  1892. !--- perc is the percentage of mass left when hitting the ground
    1893. 

  1893. !
    1894. 

  1894.       perc=.03
    1895. 

  1895. 

  1896.       do k=kts,ktf
    1897. 

  1897.       do i=its,itf
    1898. 

  1898.          zd(i,k)=0.
    1899. 

  1899.          if(itest.eq.0)cdd(i,k)=0.
    1900. 

  1900.       enddo
    1901. 

  1901.       enddo
    1902. 

  1902.       a=1.-perc
    1903. 

  1903. !
    1904. 

  1904. !
    1905. 

  1905. !
    1906. 

  1906.       do 100 i=its,itf
    1907. 

  1907.       IF(ierr(I).eq.0)then
    1908. 

  1908.       zd(i,jmin(i))=1.
    1909. 

  1909. !
    1910. 

  1910. !--- integrate downward, specify detrainment(cdd)!
    1911. 

  1911. !
    1912. 

  1912.       do ki=jmin(i)-1,1,-1
    1913. 

  1913.          DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
    1914. 

  1914.          if(ki.le.kdet(i).and.itest.eq.0)then
    1915. 

  1915.            cdd(i,ki)=entr+(1.- (a*(z_cup(i,ki)-z1(i)) &
    1916. 

  1916.                      +perc*(z_cup(i,kdet(i))-z1(i)) ) &
    1917. 

  1917.                          /(a*(z_cup(i,ki+1)-z1(i)) &
    1918. 

  1918.                       +perc*(z_cup(i,kdet(i))-z1(i))))/dz
    1919. 

  1919.          endif
    1920. 

  1920.          zd(i,ki)=zd(i,ki+1)*(1.+(entr-cdd(i,ki))*dz)
    1921. 

  1921.       enddo
    1922. 

  1922. !
    1923. 

  1923.       endif
    1924. 

  1924. !--- end loop over i
    1925. 

  1925. 100    continue
    1926. 

  1926. 

  1927.    END SUBROUTINE cup_dd_nms
    1928. 

  1928. 

  1929. 

  1930.    SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup,  &
    1931. 

  1931.               hcd,edt,zu,zd,cdd,he,della,j,mentrd_rate,z,g,     &
    1932. 

  1932.               CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,  &
    1933. 

  1933.               ids,ide, jds,jde, kds,kde,                     &
    1934. 

  1934.               ims,ime, jms,jme, kms,kme,                     &
    1935. 

  1935.               its,ite, jts,jte, kts,kte                     )
    1936. 

  1936. 

  1937.    IMPLICIT NONE
    1938. 

  1938. 

  1939.      integer                                                           &
    1940. 

  1940.         ,intent (in   )                   ::                           &
    1941. 

  1941.         ids,ide, jds,jde, kds,kde,           &
    1942. 

  1942.         ims,ime, jms,jme, kms,kme,           &
    1943. 

  1943.         its,ite, jts,jte, kts,kte
    1944. 

  1944.      integer, intent (in   )              ::                           &
    1945. 

  1945.         j,ipr,jpr
    1946. 

  1946.   !
    1947. 

  1947.   ! ierr error value, maybe modified in this routine
    1948. 

  1948.   !
    1949. 

  1949.      real,    dimension (its:ite,kts:kte)                              &
    1950. 

  1950.         ,intent (out  )                   ::                           &
    1951. 

  1951.         della
    1952. 

  1952.      real,    dimension (its:ite,kts:kte)                              &
    1953. 

  1953.         ,intent (in  )                   ::                           &
    1954. 

  1954.         z_cup,p_cup,hcd,zu,zd,cdd,he,z,he_cup
    1955. 

  1955.      real,    dimension (its:ite)                                      &
    1956. 

  1956.         ,intent (in   )                   ::                           &
    1957. 

  1957.         edt
    1958. 

  1958.      real                                                              &
    1959. 

  1959.         ,intent (in   )                   ::                           &
    1960. 

  1960.         g,mentrd_rate
    1961. 

  1961.      integer, dimension (its:ite)                                      &
    1962. 

  1962.         ,intent (inout)                   ::                           &
    1963. 

  1963.         ierr
    1964. 

  1964.      real,    dimension (its:ite,kts:kte)                              &
    1965. 

  1965.         ,intent (inout  )                 ::                           &
    1966. 

  1966.         CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
    1967. 

  1967.      logical, intent(in) :: l_flux
    1968. 

  1968. !
    1969. 

  1969. !  local variables in this routine
    1970. 

  1970. !
    1971. 

  1971. 

  1972.       integer i
    1973. 

  1973.       real detdo,detdo1,detdo2,entdo,dp,dz,subin,                      &
    1974. 

  1974.       totmas
    1975. 

  1975. !
    1976. 

  1976.      integer :: itf, ktf
    1977. 

  1977. 

  1978.      itf=MIN(ite,ide-1)
    1979. 

  1979.      ktf=MIN(kte,kde-1)
    1980. 

  1980. !
    1981. 

  1981. !
    1982. 

  1982. !      if(j.eq.jpr)print *,'in cup dellabot '
    1983. 

  1983.       do 100 i=its,itf
    1984. 

  1984.       if (l_flux) then
    1985. 

  1985.          cfu1(i,1)=0.
    1986. 

  1986.          cfd1(i,1)=0.
    1987. 

  1987.          cfu1(i,2)=0.
    1988. 

  1988.          cfd1(i,2)=0.
    1989. 

  1989.          dfu1(i,1)=0.
    1990. 

  1990.          efu1(i,1)=0.
    1991. 

  1991.          dfd1(i,1)=0.
    1992. 

  1992.          efd1(i,1)=0.
    1993. 

  1993.       endif
    1994. 

  1994.       della(i,1)=0.
    1995. 

  1995.       if(ierr(i).ne.0)go to 100
    1996. 

  1996.       dz=z_cup(i,2)-z_cup(i,1)
    1997. 

  1997.       DP=100.*(p_cup(i,1)-P_cup(i,2))
    1998. 

  1998.       detdo1=edt(i)*zd(i,2)*CDD(i,1)*DZ
    1999. 

  1999.       detdo2=edt(i)*zd(i,1)
    2000. 

  2000.       entdo=edt(i)*zd(i,2)*mentrd_rate*dz
    2001. 

  2001.       subin=-EDT(I)*zd(i,2)
    2002. 

  2002.       detdo=detdo1+detdo2-entdo+subin
    2003. 

  2003.       DELLA(I,1)=(detdo1*.5*(HCD(i,1)+HCD(i,2)) &
    2004. 

  2004.                  +detdo2*hcd(i,1) &
    2005. 

  2005.                  +subin*he_cup(i,2) &
    2006. 

  2006.                  -entdo*he(i,1))*g/dp
    2007. 

  2007.       if (l_flux) then
    2008. 

  2008.          cfd1(i,2)   = -edt(i)*zd(i,2)  !only contribution to subin, subdown=0
    2009. 

  2009.          dfd1(i,1)   =  detdo1+detdo2
    2010. 

  2010.          efd1(i,1)   = -entdo
    2011. 

  2011.       endif
    2012. 

  2012.  100  CONTINUE
    2013. 

  2013. 

  2014.    END SUBROUTINE cup_dellabot
    2015. 

  2015. 

  2016. 

  2017.    SUBROUTINE cup_dellas(ierr,z_cup,p_cup,hcd,edt,zd,cdd,              &
    2018. 

  2018.               he,della,j,mentrd_rate,zu,g,                             &
    2019. 

  2019.               cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl,   &
    2020. 

  2020.               ipr,jpr,name,                                            &
    2021. 

  2021.               CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,  &
    2022. 

  2022.               ids,ide, jds,jde, kds,kde,                               &
    2023. 

  2023.               ims,ime, jms,jme, kms,kme,                               &
    2024. 

  2024.               its,ite, jts,jte, kts,kte                               )
    2025. 

  2025. 

  2026.    IMPLICIT NONE
    2027. 

  2027. 

  2028.      integer                                                           &
    2029. 

  2029.         ,intent (in   )                   ::                           &
    2030. 

  2030.         ids,ide, jds,jde, kds,kde,           &
    2031. 

  2031.         ims,ime, jms,jme, kms,kme,           &
    2032. 

  2032.         its,ite, jts,jte, kts,kte
    2033. 

  2033.      integer, intent (in   )              ::                           &
    2034. 

  2034.         j,ipr,jpr
    2035. 

  2035.   !
    2036. 

  2036.   ! ierr error value, maybe modified in this routine
    2037. 

  2037.   !
    2038. 

  2038.      real,    dimension (its:ite,kts:kte)                              &
    2039. 

  2039.         ,intent (out  )                   ::                           &
    2040. 

  2040.         della
    2041. 

  2041.      real,    dimension (its:ite,kts:kte)                              &
    2042. 

  2042.         ,intent (in  )                   ::                           &
    2043. 

  2043.         z_cup,p_cup,hcd,zd,cdd,he,hc,cd,zu,he_cup
    2044. 

  2044.      real,    dimension (its:ite)                                      &
    2045. 

  2045.         ,intent (in   )                   ::                           &
    2046. 

  2046.         edt
    2047. 

  2047.      real                                                              &
    2048. 

  2048.         ,intent (in   )                   ::                           &
    2049. 

  2049.         g,mentrd_rate,mentr_rate
    2050. 

  2050.      integer, dimension (its:ite)                                      &
    2051. 

  2051.         ,intent (in   )                   ::                           &
    2052. 

  2052.         kbcon,ktop,k22,jmin,kdet,kpbl
    2053. 

  2053.      integer, dimension (its:ite)                                      &
    2054. 

  2054.         ,intent (inout)                   ::                           &
    2055. 

  2055.         ierr
    2056. 

  2056.       character *(*), intent (in)        ::                           &
    2057. 

  2057.        name
    2058. 

  2058.      real,    dimension (its:ite,kts:kte)                              &
    2059. 

  2059.         ,intent (inout  )                 ::                           &
    2060. 

  2060.         CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
    2061. 

  2061.      logical, intent(in) :: l_flux
    2062. 

  2062. !
    2063. 

  2063. !  local variables in this routine
    2064. 

  2064. !
    2065. 

  2065. 

  2066.       integer i,k
    2067. 

  2067.       real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup,                &
    2068. 

  2068.       detup,subdown,entdoj,entupk,detupk,totmas
    2069. 

  2069. !
    2070. 

  2070.      integer :: itf, ktf
    2071. 

  2071. 

  2072.      itf=MIN(ite,ide-1)
    2073. 

  2073.      ktf=MIN(kte,kde-1)
    2074. 

  2074. !
    2075. 

  2075. !
    2076. 

  2076.       i=ipr
    2077. 

  2077. !      if(j.eq.jpr)then
    2078. 

  2078. !        print *,'in dellas kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)'
    2079. 

  2079. !        print *,kpbl(i),k22(i),kbcon(i),ktop(i),jmin(i)
    2080. 

  2080. !      endif
    2081. 

  2081.        DO K=kts+1,ktf
    2082. 

  2082.        do i=its,itf
    2083. 

  2083.           della(i,k)=0.
    2084. 

  2084.        enddo
    2085. 

  2085.        enddo
    2086. 

  2086.        if (l_flux) then
    2087. 

  2087.           DO K=kts+1,ktf-1
    2088. 

  2088.              do i=its,itf
    2089. 

  2089.                 cfu1(i,k+1)=0.
    2090. 

  2090.                 cfd1(i,k+1)=0.
    2091. 

  2091.              enddo
    2092. 

  2092.           enddo
    2093. 

  2093.           DO K=kts+1,ktf
    2094. 

  2094.              do i=its,itf
    2095. 

  2095.                 dfu1(i,k)=0.
    2096. 

  2096.                 efu1(i,k)=0.
    2097. 

  2097.                 dfd1(i,k)=0.
    2098. 

  2098.                 efd1(i,k)=0.
    2099. 

  2099.              enddo
    2100. 

  2100.           enddo
    2101. 

  2101.        endif
    2102. 

  2102. !
    2103. 

  2103.        DO 100 k=kts+1,ktf-1
    2104. 

  2104.        DO 100 i=its,ite
    2105. 

  2105.          IF(ierr(i).ne.0)GO TO 100
    2106. 

  2106.          IF(K.Gt.KTOP(I))GO TO 100
    2107. 

  2107. !
    2108. 

  2108. !--- SPECIFY DETRAINMENT OF DOWNDRAFT, HAS TO BE CONSISTENT
    2109. 

  2109. !--- WITH ZD CALCULATIONS IN SOUNDD.
    2110. 

  2110. !
    2111. 

  2111.          DZ=Z_cup(I,K+1)-Z_cup(I,K)
    2112. 

  2112.          detdo=edt(i)*CDD(i,K)*DZ*ZD(i,k+1)
    2113. 

  2113.          entdo=edt(i)*mentrd_rate*dz*zd(i,k+1)
    2114. 

  2114.          subin=zu(i,k+1)-zd(i,k+1)*edt(i)
    2115. 

  2115.          entup=0.
    2116. 

  2116.          detup=0.
    2117. 

  2117.          if(k.ge.kbcon(i).and.k.lt.ktop(i))then
    2118. 

  2118.             entup=mentr_rate*dz*zu(i,k)
    2119. 

  2119.             detup=CD(i,K+1)*DZ*ZU(i,k)
    2120. 

  2120.          endif
    2121. 

  2121.          subdown=(zu(i,k)-zd(i,k)*edt(i))
    2122. 

  2122.          entdoj=0.
    2123. 

  2123.          entupk=0.
    2124. 

  2124.          detupk=0.
    2125. 

  2125. !
    2126. 

  2126.          if(k.eq.jmin(i))then
    2127. 

  2127.          entdoj=edt(i)*zd(i,k)
    2128. 

  2128.          endif
    2129. 

  2129. 

  2130.          if(k.eq.k22(i)-1)then
    2131. 

  2131.          entupk=zu(i,kpbl(i))
    2132. 

  2132.          endif
    2133. 

  2133. 

  2134.          if(k.gt.kdet(i))then
    2135. 

  2135.             detdo=0.
    2136. 

  2136.          endif
    2137. 

  2137. 

  2138.          if(k.eq.ktop(i)-0)then
    2139. 

  2139.          detupk=zu(i,ktop(i))
    2140. 

  2140.          subin=0.
    2141. 

  2141.          endif
    2142. 

  2142.          if(k.lt.kbcon(i))then
    2143. 

  2143.             detup=0.
    2144. 

  2144.          endif
    2145. 

  2145.          if (l_flux) then
    2146. 

  2146. ! z_cup(k+1):      zu(k+1), -zd(k+1) ==> subin   ==> cf[du]1   (k+1)  (full-eta level k+1)
    2147. 

  2147. !
    2148. 

  2148. ! z(k)      :      detup, detdo, entup, entdo    ==> [de]f[du]1 (k)   (half-eta level  k )
    2149. 

  2149. !
    2150. 

  2150. ! z_cup(k)  :      zu(k), -zd(k)     ==> subdown ==> cf[du]1    (k)   (full-eta level  k )
    2151. 

  2151. 

  2152. ! Store downdraft/updraft mass fluxes at full eta level k (z_cup(k)) in cf[ud]1(k):
    2153. 

  2153.             cfu1(i,k+1)   =  zu(i,k+1)
    2154. 

  2154.             cfd1(i,k+1)   = -edt(i)*zd(i,k+1)
    2155. 

  2155. ! Store detrainment/entrainment mass fluxes at half eta level k (z(k)) in [de]f[du]1(k):
    2156. 

  2156.             dfu1(i,k) =   detup+detupk
    2157. 

  2157.             efu1(i,k) = -(entup+entupk)
    2158. 

  2158.             dfd1(i,k) =   detdo
    2159. 

  2159.             efd1(i,k) = -(entdo+entdoj)
    2160. 

  2160.          endif
    2161. 

  2161. !C
    2162. 

  2162. !C--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT
    2163. 

  2163. !C
    2164. 

  2164.          totmas=subin-subdown+detup-entup-entdo+ &
    2165. 

  2165.                  detdo-entupk-entdoj+detupk
    2166. 

  2166. !         if(j.eq.jpr.and.i.eq.ipr)print *,'k,totmas,sui,sud = ',k,
    2167. 

  2167. !     1   totmas,subin,subdown
    2168. 

  2168. !         if(j.eq.jpr.and.i.eq.ipr)print *,'updr stuff = ',detup,
    2169. 

  2169. !     1      entup,entupk,detupk
    2170. 

  2170. !         if(j.eq.jpr.and.i.eq.ipr)print *,'dddr stuff = ',entdo,
    2171. 

  2171. !     1      detdo,entdoj
    2172. 

  2172.          if(abs(totmas).gt.1.e-6)then
    2173. 

  2173. !           print *,'*********************',i,j,k,totmas,name
    2174. 

  2174. !           print *,kpbl(i),k22(i),kbcon(i),ktop(i)
    2175. 

  2175. !c          print *,'updr stuff = ',subin,
    2176. 

  2176. !c    1      subdown,detup,entup,entupk,detupk
    2177. 

  2177. !c          print *,'dddr stuff = ',entdo,
    2178. 

  2178. !c    1      detdo,entdoj
    2179. 

  2179. !        call wrf_error_fatal ( 'totmas .gt.1.e-6' )
    2180. 

  2180.          endif
    2181. 

  2181.          dp=100.*(p_cup(i,k-1)-p_cup(i,k))
    2182. 

  2182.          della(i,k)=(subin*he_cup(i,k+1) &
    2183. 

  2183.                     -subdown*he_cup(i,k) &
    2184. 

  2184.                     +detup*.5*(HC(i,K+1)+HC(i,K)) &
    2185. 

  2185.                     +detdo*.5*(HCD(i,K+1)+HCD(i,K)) &
    2186. 

  2186.                     -entup*he(i,k) &
    2187. 

  2187.                     -entdo*he(i,k) &
    2188. 

  2188.                     -entupk*he_cup(i,k22(i)) &
    2189. 

  2189.                     -entdoj*he_cup(i,jmin(i)) &
    2190. 

  2190.                     +detupk*hc(i,ktop(i)) &
    2191. 

  2191.                      )*g/dp
    2192. 

  2192. !      if(i.eq.ipr.and.j.eq.jpr)then
    2193. 

  2193. !        print *,k,della(i,k),subin*he_cup(i,k+1),subdown*he_cup(i,k),
    2194. 

  2194. !     1            detdo*.5*(HCD(i,K+1)+HCD(i,K))
    2195. 

  2195. !        print *,k,detup*.5*(HC(i,K+1)+HC(i,K)),detupk*hc(i,ktop(i)),
    2196. 

  2196. !     1         entup*he(i,k),entdo*he(i,k)
    2197. 

  2197. !        print *,k,he_cup(i,k+1),he_cup(i,k),entupk*he_cup(i,k)
    2198. 

  2198. !      endif
    2199. 

  2199. 

  2200.  100  CONTINUE
    2201. 

  2201. 

  2202.    END SUBROUTINE cup_dellas
    2203. 

  2203. 

  2204. 

  2205.    SUBROUTINE cup_direction2(i,j,dir,id,massflx,             &
    2206. 

  2206.               iresult,imass,massfld,                         &
    2207. 

  2207.               ids,ide, jds,jde, kds,kde,                     &
    2208. 

  2208.               ims,ime, jms,jme, kms,kme,                     &
    2209. 

  2209.               its,ite, jts,jte, kts,kte                     )
    2210. 

  2210. 

  2211.    IMPLICIT NONE
    2212. 

  2212. 

  2213.      integer                                                           &
    2214. 

  2214.         ,intent (in   )                   ::                           &
    2215. 

  2215.         ids,ide, jds,jde, kds,kde,           &
    2216. 

  2216.         ims,ime, jms,jme, kms,kme,           &
    2217. 

  2217.         its,ite, jts,jte, kts,kte
    2218. 

  2218.      integer, intent (in   )              ::                           &
    2219. 

  2219.         i,j,imass
    2220. 

  2220.      integer, intent (out  )              ::                           &
    2221. 

  2221.         iresult
    2222. 

  2222.   !
    2223. 

  2223.   ! ierr error value, maybe modified in this routine
    2224. 

  2224.   !
    2225. 

  2225.      integer,    dimension (ims:ime,jms:jme)                           &
    2226. 

  2226.         ,intent (in   )                   ::                           &
    2227. 

  2227.         id
    2228. 

  2228.      real,    dimension (ims:ime,jms:jme)                              &
    2229. 

  2229.         ,intent (in   )                   ::                           &
    2230. 

  2230.         massflx
    2231. 

  2231.      real,    dimension (its:ite)                                      &
    2232. 

  2232.         ,intent (inout)                   ::                           &
    2233. 

  2233.         dir
    2234. 

  2234.      real                                                              &
    2235. 

  2235.         ,intent (out  )                   ::                           &
    2236. 

  2236.         massfld
    2237. 

  2237. !
    2238. 

  2238. !  local variables in this routine
    2239. 

  2239. !
    2240. 

  2240. 

  2241.        integer k,ia,ja,ib,jb
    2242. 

  2242.        real diff
    2243. 

  2243. !
    2244. 

  2244. !
    2245. 

  2245. !
    2246. 

  2246.        if(imass.eq.1)then
    2247. 

  2247.            massfld=massflx(i,j)
    2248. 

  2248.        endif
    2249. 

  2249.        iresult=0
    2250. 

  2250. !      return
    2251. 

  2251.        diff=22.5
    2252. 

  2252.        if(dir(i).lt.22.5)dir(i)=360.+dir(i)
    2253. 

  2253.        if(id(i,j).eq.1)iresult=1
    2254. 

  2254. !      ja=max(2,j-1)
    2255. 

  2255. !      ia=max(2,i-1)
    2256. 

  2256. !      jb=min(mjx-1,j+1)
    2257. 

  2257. !      ib=min(mix-1,i+1)
    2258. 

  2258.        ja=j-1
    2259. 

  2259.        ia=i-1
    2260. 

  2260.        jb=j+1
    2261. 

  2261.        ib=i+1
    2262. 

  2262.         if(dir(i).gt.90.-diff.and.dir(i).le.90.+diff)then
    2263. 

  2263. !--- steering flow from the east
    2264. 

  2264.           if(id(ib,j).eq.1)then
    2265. 

  2265.             iresult=1
    2266. 

  2266.             if(imass.eq.1)then
    2267. 

  2267.                massfld=max(massflx(ib,j),massflx(i,j))
    2268. 

  2268.             endif
    2269. 

  2269.             return
    2270. 

  2270.           endif
    2271. 

  2271.         else if(dir(i).gt.135.-diff.and.dir(i).le.135.+diff)then
    2272. 

  2272. !--- steering flow from the south-east
    2273. 

  2273.           if(id(ib,ja).eq.1)then
    2274. 

  2274.             iresult=1
    2275. 

  2275.             if(imass.eq.1)then
    2276. 

  2276.                massfld=max(massflx(ib,ja),massflx(i,j))
    2277. 

  2277.             endif
    2278. 

  2278.             return
    2279. 

  2279.           endif
    2280. 

  2280. !--- steering flow from the south
    2281. 

  2281.         else if(dir(i).gt.180.-diff.and.dir(i).le.180.+diff)then
    2282. 

  2282.           if(id(i,ja).eq.1)then
    2283. 

  2283.             iresult=1
    2284. 

  2284.             if(imass.eq.1)then
    2285. 

  2285.                massfld=max(massflx(i,ja),massflx(i,j))
    2286. 

  2286.             endif
    2287. 

  2287.             return
    2288. 

  2288.           endif
    2289. 

  2289. !--- steering flow from the south west
    2290. 

  2290.         else if(dir(i).gt.225.-diff.and.dir(i).le.225.+diff)then
    2291. 

  2291.           if(id(ia,ja).eq.1)then
    2292. 

  2292.             iresult=1
    2293. 

  2293.             if(imass.eq.1)then
    2294. 

  2294.                massfld=max(massflx(ia,ja),massflx(i,j))
    2295. 

  2295.             endif
    2296. 

  2296.             return
    2297. 

  2297.           endif
    2298. 

  2298. !--- steering flow from the west
    2299. 

  2299.         else if(dir(i).gt.270.-diff.and.dir(i).le.270.+diff)then
    2300. 

  2300.           if(id(ia,j).eq.1)then
    2301. 

  2301.             iresult=1
    2302. 

  2302.             if(imass.eq.1)then
    2303. 

  2303.                massfld=max(massflx(ia,j),massflx(i,j))
    2304. 

  2304.             endif
    2305. 

  2305.             return
    2306. 

  2306.           endif
    2307. 

  2307. !--- steering flow from the north-west
    2308. 

  2308.         else if(dir(i).gt.305.-diff.and.dir(i).le.305.+diff)then
    2309. 

  2309.           if(id(ia,jb).eq.1)then
    2310. 

  2310.             iresult=1
    2311. 

  2311.             if(imass.eq.1)then
    2312. 

  2312.                massfld=max(massflx(ia,jb),massflx(i,j))
    2313. 

  2313.             endif
    2314. 

  2314.             return
    2315. 

  2315.           endif
    2316. 

  2316. !--- steering flow from the north
    2317. 

  2317.         else if(dir(i).gt.360.-diff.and.dir(i).le.360.+diff)then
    2318. 

  2318.           if(id(i,jb).eq.1)then
    2319. 

  2319.             iresult=1
    2320. 

  2320.             if(imass.eq.1)then
    2321. 

  2321.                massfld=max(massflx(i,jb),massflx(i,j))
    2322. 

  2322.             endif
    2323. 

  2323.             return
    2324. 

  2324.           endif
    2325. 

  2325. !--- steering flow from the north-east
    2326. 

  2326.         else if(dir(i).gt.45.-diff.and.dir(i).le.45.+diff)then
    2327. 

  2327.           if(id(ib,jb).eq.1)then
    2328. 

  2328.             iresult=1
    2329. 

  2329.             if(imass.eq.1)then
    2330. 

  2330.                massfld=max(massflx(ib,jb),massflx(i,j))
    2331. 

  2331.             endif
    2332. 

  2332.             return
    2333. 

  2333.           endif
    2334. 

  2334.         endif
    2335. 

  2335. 

  2336.    END SUBROUTINE cup_direction2
    2337. 

  2337. 

  2338. 

  2339.    SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1,                 &
    2340. 

  2340.               psur,ierr,tcrit,itest,xl,cp,                   &
    2341. 

  2341.               ids,ide, jds,jde, kds,kde,                     &
    2342. 

  2342.               ims,ime, jms,jme, kms,kme,                     &
    2343. 

  2343.               its,ite, jts,jte, kts,kte                     )
    2344. 

  2344. 

  2345.    IMPLICIT NONE
    2346. 

  2346. 

  2347.      integer                                                           &
    2348. 

  2348.         ,intent (in   )                   ::                           &
    2349. 

  2349.         ids,ide, jds,jde, kds,kde,           &
    2350. 

  2350.         ims,ime, jms,jme, kms,kme,           &
    2351. 

  2351.         its,ite, jts,jte, kts,kte
    2352. 

  2352.   !
    2353. 

  2353.   ! ierr error value, maybe modified in this routine
    2354. 

  2354.   ! q           = environmental mixing ratio
    2355. 

  2355.   ! qes         = environmental saturation mixing ratio
    2356. 

  2356.   ! t           = environmental temp
    2357. 

  2357.   ! tv          = environmental virtual temp
    2358. 

  2358.   ! p           = environmental pressure
    2359. 

  2359.   ! z           = environmental heights
    2360. 

  2360.   ! he          = environmental moist static energy
    2361. 

  2361.   ! hes         = environmental saturation moist static energy
    2362. 

  2362.   ! psur        = surface pressure
    2363. 

  2363.   ! z1          = terrain elevation
    2364. 

  2364.   ! 
    2365. 

  2365.   !
    2366. 

  2366.      real,    dimension (its:ite,kts:kte)                              &
    2367. 

  2367.         ,intent (in   )                   ::                           &
    2368. 

  2368.         p,t
    2369. 

  2369.      real,    dimension (its:ite,kts:kte)                              &
    2370. 

  2370.         ,intent (out  )                   ::                           &
    2371. 

  2371.         he,hes,qes
    2372. 

  2372.      real,    dimension (its:ite,kts:kte)                              &
    2373. 

  2373.         ,intent (inout)                   ::                           &
    2374. 

  2374.         z,q
    2375. 

  2375.      real,    dimension (its:ite)                                      &
    2376. 

  2376.         ,intent (in   )                   ::                           &
    2377. 

  2377.         psur,z1
    2378. 

  2378.      real                                                              &
    2379. 

  2379.         ,intent (in   )                   ::                           &
    2380. 

  2380.         xl,cp
    2381. 

  2381.      integer, dimension (its:ite)                                      &
    2382. 

  2382.         ,intent (inout)                   ::                           &
    2383. 

  2383.         ierr
    2384. 

  2384.      integer                                                           &
    2385. 

  2385.         ,intent (in   )                   ::                           &
    2386. 

  2386.         itest
    2387. 

  2387. !
    2388. 

  2388. !  local variables in this routine
    2389. 

  2389. !
    2390. 

  2390. 

  2391.      integer                              ::                           &
    2392. 

  2392.        i,k,iph
    2393. 

  2393.       real, dimension (1:2) :: AE,BE,HT
    2394. 

  2394.       real, dimension (its:ite,kts:kte) :: tv
    2395. 

  2395.       real :: tcrit,e,tvbar
    2396. 

  2396. 

  2397.      integer :: itf, ktf
    2398. 

  2398. 

  2399.      itf=MIN(ite,ide-1)
    2400. 

  2400.      ktf=MIN(kte,kde-1)
    2401. 

  2401. 

  2402.       HT(1)=XL/CP
    2403. 

  2403.       HT(2)=2.834E6/CP
    2404. 

  2404.       BE(1)=.622*HT(1)/.286
    2405. 

  2405.       AE(1)=BE(1)/273.+ALOG(610.71)
    2406. 

  2406.       BE(2)=.622*HT(2)/.286
    2407. 

  2407.       AE(2)=BE(2)/273.+ALOG(610.71)
    2408. 

  2408. !      print *, 'TCRIT = ', tcrit,its,ite
    2409. 

  2409.       DO k=kts,ktf
    2410. 

  2410.       do i=its,itf
    2411. 

  2411.         if(ierr(i).eq.0)then
    2412. 

  2412. !Csgb - IPH is for phase, dependent on TCRIT (water or ice)
    2413. 

  2413.         IPH=1
    2414. 

  2414.         IF(T(I,K).LE.TCRIT)IPH=2
    2415. 

  2415. !       print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k
    2416. 

  2416.         E=EXP(AE(IPH)-BE(IPH)/T(I,K))
    2417. 

  2417. !       print *, 'P, E = ', P(I,K), E
    2418. 

  2418.         QES(I,K)=.622*E/(100.*P(I,K)-E)
    2419. 

  2419.         IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08
    2420. 

  2420.         IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K)
    2421. 

  2421.         TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K)
    2422. 

  2422.         endif
    2423. 

  2423.       enddo
    2424. 

  2424.       enddo
    2425. 

  2425. !
    2426. 

  2426. !--- z's are calculated with changed h's and q's and t's
    2427. 

  2427. !--- if itest=2
    2428. 

  2428. !
    2429. 

  2429.       if(itest.ne.2)then
    2430. 

  2430.          do i=its,itf
    2431. 

  2431.            if(ierr(i).eq.0)then
    2432. 

  2432.              Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- &
    2433. 

  2433.                  ALOG(PSUR(I)))*287.*TV(I,1)/9.81
    2434. 

  2434.            endif
    2435. 

  2435.          enddo
    2436. 

  2436. 

  2437. ! --- calculate heights
    2438. 

  2438.          DO K=kts+1,ktf
    2439. 

  2439.          do i=its,itf
    2440. 

  2440.            if(ierr(i).eq.0)then
    2441. 

  2441.               TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
    2442. 

  2442.               Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
    2443. 

  2443.                ALOG(P(I,K-1)))*287.*TVBAR/9.81
    2444. 

  2444.            endif
    2445. 

  2445.          enddo
    2446. 

  2446.          enddo
    2447. 

  2447.       else
    2448. 

  2448.          do k=kts,ktf
    2449. 

  2449.          do i=its,itf
    2450. 

  2450.            if(ierr(i).eq.0)then
    2451. 

  2451.              z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81
    2452. 

  2452.              z(i,k)=max(1.e-3,z(i,k))
    2453. 

  2453.            endif
    2454. 

  2454.          enddo
    2455. 

  2455.          enddo
    2456. 

  2456.       endif
    2457. 

  2457. !
    2458. 

  2458. !--- calculate moist static energy - HE
    2459. 

  2459. !    saturated moist static energy - HES
    2460. 

  2460. !
    2461. 

  2461.        DO k=kts,ktf
    2462. 

  2462.        do i=its,itf
    2463. 

  2463.          if(ierr(i).eq.0)then
    2464. 

  2464.          if(itest.eq.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K)
    2465. 

  2465.          HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K)
    2466. 

  2466.          IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
    2467. 

  2467. !         if(i.eq.2)then
    2468. 

  2468. !           print *,k,z(i,k),t(i,k),p(i,k),he(i,k),hes(i,k)
    2469. 

  2469. !         endif
    2470. 

  2470.          endif
    2471. 

  2471.       enddo
    2472. 

  2472.       enddo
    2473. 

  2473. 

  2474.    END SUBROUTINE cup_env
    2475. 

  2475. 

  2476. 

  2477.    SUBROUTINE cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,   &
    2478. 

  2478.               he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
    2479. 

  2479.               ierr,z1,xl,rv,cp,                                &
    2480. 

  2480.               ids,ide, jds,jde, kds,kde,                       &
    2481. 

  2481.               ims,ime, jms,jme, kms,kme,                       &
    2482. 

  2482.               its,ite, jts,jte, kts,kte                       )
    2483. 

  2483. 

  2484.    IMPLICIT NONE
    2485. 

  2485. 

  2486.      integer                                                           &
    2487. 

  2487.         ,intent (in   )                   ::                           &
    2488. 

  2488.         ids,ide, jds,jde, kds,kde,           &
    2489. 

  2489.         ims,ime, jms,jme, kms,kme,           &
    2490. 

  2490.         its,ite, jts,jte, kts,kte
    2491. 

  2491.   !
    2492. 

  2492.   ! ierr error value, maybe modified in this routine
    2493. 

  2493.   ! q           = environmental mixing ratio
    2494. 

  2494.   ! q_cup       = environmental mixing ratio on cloud levels
    2495. 

  2495.   ! qes         = environmental saturation mixing ratio
    2496. 

  2496.   ! qes_cup     = environmental saturation mixing ratio on cloud levels
    2497. 

  2497.   ! t           = environmental temp
    2498. 

  2498.   ! t_cup       = environmental temp on cloud levels
    2499. 

  2499.   ! p           = environmental pressure
    2500. 

  2500.   ! p_cup       = environmental pressure on cloud levels
    2501. 

  2501.   ! z           = environmental heights
    2502. 

  2502.   ! z_cup       = environmental heights on cloud levels
    2503. 

  2503.   ! he          = environmental moist static energy
    2504. 

  2504.   ! he_cup      = environmental moist static energy on cloud levels
    2505. 

  2505.   ! hes         = environmental saturation moist static energy
    2506. 

  2506.   ! hes_cup     = environmental saturation moist static energy on cloud levels
    2507. 

  2507.   ! gamma_cup   = gamma on cloud levels
    2508. 

  2508.   ! psur        = surface pressure
    2509. 

  2509.   ! z1          = terrain elevation
    2510. 

  2510.   ! 
    2511. 

  2511.   !
    2512. 

  2512.      real,    dimension (its:ite,kts:kte)                              &
    2513. 

  2513.         ,intent (in   )                   ::                           &
    2514. 

  2514.         qes,q,he,hes,z,p,t
    2515. 

  2515.      real,    dimension (its:ite,kts:kte)                              &
    2516. 

  2516.         ,intent (out  )                   ::                           &
    2517. 

  2517.         qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup
    2518. 

  2518.      real,    dimension (its:ite)                                      &
    2519. 

  2519.         ,intent (in   )                   ::                           &
    2520. 

  2520.         psur,z1
    2521. 

  2521.      real                                                              &
    2522. 

  2522.         ,intent (in   )                   ::                           &
    2523. 

  2523.         xl,rv,cp
    2524. 

  2524.      integer, dimension (its:ite)                                      &
    2525. 

  2525.         ,intent (inout)                   ::                           &
    2526. 

  2526.         ierr
    2527. 

  2527. !
    2528. 

  2528. !  local variables in this routine
    2529. 

  2529. !
    2530. 

  2530. 

  2531.      integer                              ::                           &
    2532. 

  2532.        i,k
    2533. 

  2533. 

  2534.      integer :: itf, ktf
    2535. 

  2535. 

  2536.      itf=MIN(ite,ide-1)
    2537. 

  2537.      ktf=MIN(kte,kde-1)
    2538. 

  2538. 

  2539.       do k=kts+1,ktf
    2540. 

  2540.       do i=its,itf
    2541. 

  2541.         if(ierr(i).eq.0)then
    2542. 

  2542.         qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
    2543. 

  2543.         q_cup(i,k)=.5*(q(i,k-1)+q(i,k))
    2544. 

  2544.         hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
    2545. 

  2545.         he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
    2546. 

  2546.         if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
    2547. 

  2547.         z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
    2548. 

  2548.         p_cup(i,k)=.5*(p(i,k-1)+p(i,k))
    2549. 

  2549.         t_cup(i,k)=.5*(t(i,k-1)+t(i,k))
    2550. 

  2550.         gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) &
    2551. 

  2551.                        *t_cup(i,k)))*qes_cup(i,k)
    2552. 

  2552.         endif
    2553. 

  2553.       enddo
    2554. 

  2554.       enddo
    2555. 

  2555.       do i=its,itf
    2556. 

  2556.         if(ierr(i).eq.0)then
    2557. 

  2557.         qes_cup(i,1)=qes(i,1)
    2558. 

  2558.         q_cup(i,1)=q(i,1)
    2559. 

  2559.         hes_cup(i,1)=hes(i,1)
    2560. 

  2560.         he_cup(i,1)=he(i,1)
    2561. 

  2561.         z_cup(i,1)=.5*(z(i,1)+z1(i))
    2562. 

  2562.         p_cup(i,1)=.5*(p(i,1)+psur(i))
    2563. 

  2563.         t_cup(i,1)=t(i,1)
    2564. 

  2564.         gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) &
    2565. 

  2565.                        *t_cup(i,1)))*qes_cup(i,1)
    2566. 

  2566.         endif
    2567. 

  2567.       enddo
    2568. 

  2568. 

  2569.    END SUBROUTINE cup_env_clev
    2570. 

  2570. 

  2571. 

  2572.    SUBROUTINE cup_forcing_ens(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,&
    2573. 

  2573.               xf_ens,j,name,maxens,iens,iedt,maxens2,maxens3,mconv,    &
    2574. 

  2574.               p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,massflx,      &
    2575. 

  2575.               iact_old_gr,dir,ensdim,massfln,icoic,                    &
    2576. 

  2576.               ids,ide, jds,jde, kds,kde,                               &
    2577. 

  2577.               ims,ime, jms,jme, kms,kme,                               &
    2578. 

  2578.               its,ite, jts,jte, kts,kte                               )
    2579. 

  2579. 

  2580.    IMPLICIT NONE
    2581. 

  2581. 

  2582.      integer                                                           &
    2583. 

  2583.         ,intent (in   )                   ::                           &
    2584. 

  2584.         ids,ide, jds,jde, kds,kde,           &
    2585. 

  2585.         ims,ime, jms,jme, kms,kme,           &
    2586. 

  2586.         its,ite, jts,jte, kts,kte
    2587. 

  2587.      integer, intent (in   )              ::                           &
    2588. 

  2588.         j,ensdim,maxens,iens,iedt,maxens2,maxens3
    2589. 

  2589.   !
    2590. 

  2590.   ! ierr error value, maybe modified in this routine
    2591. 

  2591.   ! pr_ens = precipitation ensemble
    2592. 

  2592.   ! xf_ens = mass flux ensembles
    2593. 

  2593.   ! massfln = downdraft mass flux ensembles used in next timestep
    2594. 

  2594.   ! omeg = omega from large scale model
    2595. 

  2595.   ! mconv = moisture convergence from large scale model
    2596. 

  2596.   ! zd      = downdraft normalized mass flux
    2597. 

  2597.   ! zu      = updraft normalized mass flux
    2598. 

  2598.   ! aa0     = cloud work function without forcing effects
    2599. 

  2599.   ! aa1     = cloud work function with forcing effects
    2600. 

  2600.   ! xaa0    = cloud work function with cloud effects (ensemble dependent)
    2601. 

  2601.   ! edt     = epsilon
    2602. 

  2602.   ! dir     = "storm motion"
    2603. 

  2603.   ! mbdt    = arbitrary numerical parameter
    2604. 

  2604.   ! dtime   = dt over which forcing is applied
    2605. 

  2605.   ! iact_gr_old = flag to tell where convection was active
    2606. 

  2606.   ! kbcon       = LFC of parcel from k22
    2607. 

  2607.   ! k22         = updraft originating level
    2608. 

  2608.   ! icoic       = flag if only want one closure (usually set to zero!)
    2609. 

  2609.   ! name        = deep or shallow convection flag
    2610. 

  2610.   !
    2611. 

  2611.      real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
    2612. 

  2612.         ,intent (inout)                   ::                           &
    2613. 

  2613.         pr_ens
    2614. 

  2614.      real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
    2615. 

  2615.         ,intent (out  )                   ::                           &
    2616. 

  2616.         xf_ens,massfln
    2617. 

  2617.      real,    dimension (ims:ime,jms:jme)                              &
    2618. 

  2618.         ,intent (in   )                   ::                           &
    2619. 

  2619.         massflx
    2620. 

  2620.      real,    dimension (its:ite,kts:kte)                              &
    2621. 

  2621.         ,intent (in   )                   ::                           &
    2622. 

  2622.         omeg,zd,zu,p_cup
    2623. 

  2623.      real,    dimension (its:ite,1:maxens)                             &
    2624. 

  2624.         ,intent (in   )                   ::                           &
    2625. 

  2625.         xaa0
    2626. 

  2626.      real,    dimension (its:ite)                                      &
    2627. 

  2627.         ,intent (in   )                   ::                           &
    2628. 

  2628.         aa1,edt,dir,mconv,xland
    2629. 

  2629.      real,    dimension (its:ite)                                      &
    2630. 

  2630.         ,intent (inout)                   ::                           &
    2631. 

  2631.         aa0,closure_n
    2632. 

  2632.      real,    dimension (1:maxens)                                     &
    2633. 

  2633.         ,intent (in   )                   ::                           &
    2634. 

  2634.         mbdt
    2635. 

  2635.      real                                                              &
    2636. 

  2636.         ,intent (in   )                   ::                           &
    2637. 

  2637.         dtime
    2638. 

  2638.      integer, dimension (its:ite,jts:jte)                              &
    2639. 

  2639.         ,intent (in   )                   ::                           &
    2640. 

  2640.         iact_old_gr
    2641. 

  2641.      integer, dimension (its:ite)                                      &
    2642. 

  2642.         ,intent (in   )                   ::                           &
    2643. 

  2643.         k22,kbcon,ktop
    2644. 

  2644.      integer, dimension (its:ite)                                      &
    2645. 

  2645.         ,intent (inout)                   ::                           &
    2646. 

  2646.         ierr,ierr2,ierr3
    2647. 

  2647.      integer                                                           &
    2648. 

  2648.         ,intent (in   )                   ::                           &
    2649. 

  2649.         icoic
    2650. 

  2650.       character *(*), intent (in)         ::                           &
    2651. 

  2651.        name
    2652. 

  2652. !
    2653. 

  2653. !  local variables in this routine
    2654. 

  2654. !
    2655. 

  2655. 

  2656.      real,    dimension (1:maxens3)       ::                           &
    2657. 

  2657.        xff_ens3
    2658. 

  2658.      real,    dimension (1:maxens)        ::                           &
    2659. 

  2659.        xk
    2660. 

  2660.      integer                              ::                           &
    2661. 

  2661.        i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim
    2662. 

  2662.      parameter (mkxcrt=15)
    2663. 

  2663.      real                                 ::                           &
    2664. 

  2664.        a1,massfld,xff0,xomg,aclim1,aclim2,aclim3,aclim4
    2665. 

  2665.      real,    dimension(1:mkxcrt)         ::                           &
    2666. 

  2666.        pcrit,acrit,acritt
    2667. 

  2667. 

  2668.      integer :: itf,nall2
    2669. 

  2669. 

  2670.      itf=MIN(ite,ide-1)
    2671. 

  2671. 

  2672.       DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
    2673. 

  2673.                  350.,300.,250.,200.,150./
    2674. 

  2674.       DATA ACRIT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,       &
    2675. 

  2675.                  .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
    2676. 

  2676. !  GDAS DERIVED ACRIT
    2677. 

  2677.       DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688,             &
    2678. 

  2678.                   .743,.813,.886,.947,1.138,1.377,1.896/
    2679. 

  2679. !
    2680. 

  2680.        nens=0
    2681. 

  2681. 

  2682. !--- LARGE SCALE FORCING
    2683. 

  2683. !
    2684. 

  2684.        DO 100 i=its,itf
    2685. 

  2685. !       if(i.eq.ipr.and.j.eq.jpr)print *,'ierr = ',ierr(i)
    2686. 

  2686.           if(name.eq.'deeps'.and.ierr(i).gt.995)then
    2687. 

  2687. !          print *,i,j,ierr(i),aa0(i)
    2688. 

  2688.            aa0(i)=0.
    2689. 

  2689.            ierr(i)=0
    2690. 

  2690.           endif
    2691. 

  2691.           IF(ierr(i).eq.0)then
    2692. 

  2692. !           kclim=0
    2693. 

  2693.            do k=mkxcrt,1,-1
    2694. 

  2694.              if(p_cup(i,ktop(i)).lt.pcrit(k))then
    2695. 

  2695.                kclim=k
    2696. 

  2696.                go to 9
    2697. 

  2697.              endif
    2698. 

  2698.            enddo
    2699. 

  2699.            if(p_cup(i,ktop(i)).ge.pcrit(1))kclim=1
    2700. 

  2700.  9         continue
    2701. 

  2701.            kclim=max(kclim,1)
    2702. 

  2702.            k=max(kclim-1,1)
    2703. 

  2703.            aclim1=acrit(kclim)*1.e3
    2704. 

  2704.            aclim2=acrit(k)*1.e3
    2705. 

  2705.            aclim3=acritt(kclim)*1.e3
    2706. 

  2706.            aclim4=acritt(k)*1.e3
    2707. 

  2707. !           print *,'p_cup(ktop(i)),kclim,pcrit(kclim)'
    2708. 

  2708. !           print *,p_cup(i,ktop(i)),kclim,pcrit(kclim)
    2709. 

  2709. !           print *,'aclim1,aclim2,aclim3,aclim4'
    2710. 

  2710. !           print *,aclim1,aclim2,aclim3,aclim4
    2711. 

  2711. !           print *,dtime,name,ierr(i),aa1(i),aa0(i)
    2712. 

  2712. !          print *,dtime,name,ierr(i),aa1(i),aa0(i)
    2713. 

  2713. !
    2714. 

  2714. !--- treatment different for this closure
    2715. 

  2715. !
    2716. 

  2716.              if(name.eq.'deeps')then
    2717. 

  2717. !
    2718. 

  2718.                 xff0= (AA1(I)-AA0(I))/DTIME
    2719. 

  2719.                 xff_ens3(1)=(AA1(I)-AA0(I))/dtime
    2720. 

  2720.                 xff_ens3(2)=.9*xff_ens3(1)
    2721. 

  2721.                 xff_ens3(3)=1.1*xff_ens3(1)
    2722. 

  2722. !   
    2723. 

  2723. !--- more original Arakawa-Schubert (climatologic value of aa0)
    2724. 

  2724. !
    2725. 

  2725. !
    2726. 

  2726. !--- omeg is in bar/s, mconv done with omeg in Pa/s
    2727. 

  2727. !     more like Brown (1979), or Frank-Cohen (199?)
    2728. 

  2728. !
    2729. 

  2729.                 xff_ens3(4)=-omeg(i,k22(i))/9.81
    2730. 

  2730.                 xff_ens3(5)=-omeg(i,kbcon(i))/9.81
    2731. 

  2731.                 xff_ens3(6)=-omeg(i,1)/9.81
    2732. 

  2732.                 do k=2,kbcon(i)-1
    2733. 

  2733.                   xomg=-omeg(i,k)/9.81
    2734. 

  2734.                   if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg
    2735. 

  2735.                 enddo
    2736. 

  2736. !
    2737. 

  2737. !--- more like Krishnamurti et al.
    2738. 

  2738. !
    2739. 

  2739.                 xff_ens3(7)=mconv(i)
    2740. 

  2740.                 xff_ens3(8)=mconv(i)
    2741. 

  2741.                 xff_ens3(9)=mconv(i)
    2742. 

  2742. !
    2743. 

  2743. !--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
    2744. 

  2744. !
    2745. 

  2745.                 xff_ens3(10)=AA1(I)/(60.*20.)
    2746. 

  2746.                 xff_ens3(11)=AA1(I)/(60.*30.)
    2747. 

  2747.                 xff_ens3(12)=AA1(I)/(60.*40.)
    2748. 

  2748. !  
    2749. 

  2749. !--- more original Arakawa-Schubert (climatologic value of aa0)
    2750. 

  2750. !
    2751. 

  2751.                 xff_ens3(13)=max(0.,(AA1(I)-aclim1)/dtime)
    2752. 

  2752.                 xff_ens3(14)=max(0.,(AA1(I)-aclim2)/dtime)
    2753. 

  2753.                 xff_ens3(15)=max(0.,(AA1(I)-aclim3)/dtime)
    2754. 

  2754.                 xff_ens3(16)=max(0.,(AA1(I)-aclim4)/dtime)
    2755. 

  2755. !               if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
    2756. 

  2756. !                 xff_ens3(10)=0.
    2757. 

  2757. !                 xff_ens3(11)=0.
    2758. 

  2758. !                 xff_ens3(12)=0.
    2759. 

  2759. !                 xff_ens3(13)=0.
    2760. 

  2760. !                 xff_ens3(14)=0.
    2761. 

  2761. !                 xff_ens3(15)=0.
    2762. 

  2762. !                 xff_ens3(16)=0.
    2763. 

  2763. !               endif
    2764. 

  2764. 

  2765.                 do nens=1,maxens
    2766. 

  2766.                    XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(2)
    2767. 

  2767.                    if(xk(nens).le.0.and.xk(nens).gt.-1.e-6) &
    2768. 

  2768.                            xk(nens)=-1.e-6
    2769. 

  2769.                    if(xk(nens).gt.0.and.xk(nens).lt.1.e-6) &
    2770. 

  2770.                            xk(nens)=1.e-6
    2771. 

  2771.                 enddo
    2772. 

  2772. !
    2773. 

  2773. !--- add up all ensembles
    2774. 

  2774. !
    2775. 

  2775.                 do 350 ne=1,maxens
    2776. 

  2776. !
    2777. 

  2777. !--- for every xk, we have maxens3 xffs
    2778. 

  2778. !--- iens is from outermost ensemble (most expensive!
    2779. 

  2779. !
    2780. 

  2780. !--- iedt (maxens2 belongs to it)
    2781. 

  2781. !--- is from second, next outermost, not so expensive
    2782. 

  2782. !
    2783. 

  2783. !--- so, for every outermost loop, we have maxens*maxens2*3
    2784. 

  2784. !--- ensembles!!! nall would be 0, if everything is on first
    2785. 

  2785. !--- loop index, then ne would start counting, then iedt, then iens....
    2786. 

  2786. !
    2787. 

  2787.                    iresult=0
    2788. 

  2788.                    iresultd=0
    2789. 

  2789.                    iresulte=0
    2790. 

  2790.                    nall=(iens-1)*maxens3*maxens*maxens2 &
    2791. 

  2791.                         +(iedt-1)*maxens*maxens3 &
    2792. 

  2792.                         +(ne-1)*maxens3
    2793. 

  2793. !
    2794. 

  2794. ! over water, enfor!e small cap for some of the closures
    2795. 

  2795. !
    2796. 

  2796.                 if(xland(i).lt.0.1)then
    2797. 

  2797.                  if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
    2798. 

  2798. !       - ierr2 - 75 mb cap thickness, ierr3 - 125 cap thickness
    2799. 

  2799. 

  2800. ! - for larger cap, set Grell closure to zero
    2801. 

  2801.                       xff_ens3(1) =0.
    2802. 

  2802.                       massfln(i,j,nall+1)=0.
    2803. 

  2803.                       xff_ens3(2) =0.
    2804. 

  2804.                       massfln(i,j,nall+2)=0.
    2805. 

  2805.                       xff_ens3(3) =0.
    2806. 

  2806.                       massfln(i,j,nall+3)=0.
    2807. 

  2807.                       closure_n(i)=closure_n(i)-1.
    2808. 

  2808. 

  2809.                       xff_ens3(7) =0.
    2810. 

  2810.                       massfln(i,j,nall+7)=0.
    2811. 

  2811.                       xff_ens3(8) =0.
    2812. 

  2812.                       massfln(i,j,nall+8)=0.
    2813. 

  2813.                       xff_ens3(9) =0.
    2814. 

  2814. !                     massfln(i,j,nall+9)=0.
    2815. 

  2815.                       closure_n(i)=closure_n(i)-1.
    2816. 

  2816.                 endif
    2817. 

  2817. !
    2818. 

  2818. !   also take out some closures in general
    2819. 

  2819. !
    2820. 

  2820.                       xff_ens3(4) =0.
    2821. 

  2821.                       massfln(i,j,nall+4)=0.
    2822. 

  2822.                       xff_ens3(5) =0.
    2823. 

  2823.                       massfln(i,j,nall+5)=0.
    2824. 

  2824.                       xff_ens3(6) =0.
    2825. 

  2825.                       massfln(i,j,nall+6)=0.
    2826. 

  2826.                       closure_n(i)=closure_n(i)-3.
    2827. 

  2827. 

  2828.                       xff_ens3(10)=0.
    2829. 

  2829.                       massfln(i,j,nall+10)=0.
    2830. 

  2830.                       xff_ens3(11)=0.
    2831. 

  2831.                       massfln(i,j,nall+11)=0.
    2832. 

  2832.                       xff_ens3(12)=0.
    2833. 

  2833.                       massfln(i,j,nall+12)=0.
    2834. 

  2834.                       if(ne.eq.1)closure_n(i)=closure_n(i)-3
    2835. 

  2835.                       xff_ens3(13)=0.
    2836. 

  2836.                       massfln(i,j,nall+13)=0.
    2837. 

  2837.                       xff_ens3(14)=0.
    2838. 

  2838.                       massfln(i,j,nall+14)=0.
    2839. 

  2839.                       xff_ens3(15)=0.
    2840. 

  2840.                       massfln(i,j,nall+15)=0.
    2841. 

  2841.                       massfln(i,j,nall+16)=0.
    2842. 

  2842.                       if(ne.eq.1)closure_n(i)=closure_n(i)-4
    2843. 

  2843. 

  2844.                 endif
    2845. 

  2845. !
    2846. 

  2846. ! end water treatment
    2847. 

  2847. !
    2848. 

  2848. !--- check for upwind convection
    2849. 

  2849. !                  iresult=0
    2850. 

  2850.                    massfld=0.
    2851. 

  2851. 

  2852. !                  call cup_direction2(i,j,dir,iact_old_gr, &
    2853. 

  2853. !                       massflx,iresult,1,                  &
    2854. 

  2854. !                       massfld,                            &
    2855. 

  2855. !                       ids,ide, jds,jde, kds,kde,          &
    2856. 

  2856. !                       ims,ime, jms,jme, kms,kme,          &
    2857. 

  2857. !                       its,ite, jts,jte, kts,kte          )
    2858. 

  2858. !                  if(i.eq.ipr.and.j.eq.jpr.and.iedt.eq.1.and.ne.eq.1)then
    2859. 

  2859. !                  if(iedt.eq.1.and.ne.eq.1)then
    2860. 

  2860. !                   print *,massfld,ne,iedt,iens
    2861. 

  2861. !                   print *,xk(ne),xff_ens3(1),xff_ens3(2),xff_ens3(3)
    2862. 

  2862. !                  endif
    2863. 

  2863. !                  print *,i,j,massfld,aa0(i),aa1(i)
    2864. 

  2864.                    IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1
    2865. 

  2865.                    iresulte=max(iresult,iresultd)
    2866. 

  2866.                    iresulte=1
    2867. 

  2867.                    if(iresulte.eq.1)then
    2868. 

  2868. !
    2869. 

  2869. !--- special treatment for stability closures
    2870. 

  2870. !
    2871. 

  2871. 

  2872.                       if(xff0.gt.0.)then
    2873. 

  2873.                          xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne)) &
    2874. 

  2874.                                         +massfld
    2875. 

  2875.                          xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne)) &
    2876. 

  2876.                                         +massfld
    2877. 

  2877.                          xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne)) &
    2878. 

  2878.                                         +massfld
    2879. 

  2879.                          xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne)) &
    2880. 

  2880.                                         +massfld
    2881. 

  2881.                          xf_ens(i,j,nall+14)=max(0.,-xff_ens3(14)/xk(ne)) &
    2882. 

  2882.                                         +massfld
    2883. 

  2883.                          xf_ens(i,j,nall+15)=max(0.,-xff_ens3(15)/xk(ne)) &
    2884. 

  2884.                                         +massfld
    2885. 

  2885.                          xf_ens(i,j,nall+16)=max(0.,-xff_ens3(16)/xk(ne)) &
    2886. 

  2886.                                         +massfld
    2887. 

  2887.                       else
    2888. 

  2888.                          xf_ens(i,j,nall+1)=massfld
    2889. 

  2889.                          xf_ens(i,j,nall+2)=massfld
    2890. 

  2890.                          xf_ens(i,j,nall+3)=massfld
    2891. 

  2891.                          xf_ens(i,j,nall+13)=massfld
    2892. 

  2892.                          xf_ens(i,j,nall+14)=massfld
    2893. 

  2893.                          xf_ens(i,j,nall+15)=massfld
    2894. 

  2894.                          xf_ens(i,j,nall+16)=massfld
    2895. 

  2895.                       endif
    2896. 

  2896. !
    2897. 

  2897. !--- if iresult.eq.1, following independent of xff0
    2898. 

  2898. !
    2899. 

  2899.                          xf_ens(i,j,nall+4)=max(0.,xff_ens3(4) &
    2900. 

  2900.                             +massfld)
    2901. 

  2901.                          xf_ens(i,j,nall+5)=max(0.,xff_ens3(5) &
    2902. 

  2902.                                         +massfld)
    2903. 

  2903.                          xf_ens(i,j,nall+6)=max(0.,xff_ens3(6) &
    2904. 

  2904.                                         +massfld)
    2905. 

  2905.                          a1=max(1.e-3,pr_ens(i,j,nall+7))
    2906. 

  2906.                          xf_ens(i,j,nall+7)=max(0.,xff_ens3(7) &
    2907. 

  2907.                                      /a1)
    2908. 

  2908.                          a1=max(1.e-3,pr_ens(i,j,nall+8))
    2909. 

  2909.                          xf_ens(i,j,nall+8)=max(0.,xff_ens3(8) &
    2910. 

  2910.                                      /a1)
    2911. 

  2911.                          a1=max(1.e-3,pr_ens(i,j,nall+9))
    2912. 

  2912.                          xf_ens(i,j,nall+9)=max(0.,xff_ens3(9) &
    2913. 

  2913.                                      /a1)
    2914. 

  2914.                          if(XK(ne).lt.0.)then
    2915. 

  2915.                             xf_ens(i,j,nall+10)=max(0., &
    2916. 

  2916.                                         -xff_ens3(10)/xk(ne)) &
    2917. 

  2917.                                         +massfld
    2918. 

  2918.                             xf_ens(i,j,nall+11)=max(0., &
    2919. 

  2919.                                         -xff_ens3(11)/xk(ne)) &
    2920. 

  2920.                                         +massfld
    2921. 

  2921.                             xf_ens(i,j,nall+12)=max(0., &
    2922. 

  2922.                                         -xff_ens3(12)/xk(ne)) &
    2923. 

  2923.                                         +massfld
    2924. 

  2924.                          else
    2925. 

  2925.                             xf_ens(i,j,nall+10)=massfld
    2926. 

  2926.                             xf_ens(i,j,nall+11)=massfld
    2927. 

  2927.                             xf_ens(i,j,nall+12)=massfld
    2928. 

  2928.                          endif
    2929. 

  2929.                       if(icoic.ge.1)then
    2930. 

  2930.                       closure_n(i)=0.
    2931. 

  2931.                       xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic)
    2932. 

  2932.                       xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic)
    2933. 

  2933.                       xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic)
    2934. 

  2934.                       xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic)
    2935. 

  2935.                       xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic)
    2936. 

  2936.                       xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic)
    2937. 

  2937.                       xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic)
    2938. 

  2938.                       xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic)
    2939. 

  2939.                       xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic)
    2940. 

  2940.                       xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic)
    2941. 

  2941.                       xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic)
    2942. 

  2942.                       xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic)
    2943. 

  2943.                       xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic)
    2944. 

  2944.                       xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic)
    2945. 

  2945.                       xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic)
    2946. 

  2946.                       xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic)
    2947. 

  2947.                       endif
    2948. 

  2948. !
    2949. 

  2949. ! replace 13-16 for now with other stab closures
    2950. 

  2950. ! (13 gave problems for mass model)
    2951. 

  2951. !
    2952. 

  2952. !                     xf_ens(i,j,nall+13)=xf_ens(i,j,nall+1)
    2953. 

  2953.                       if(icoic.eq.0)xf_ens(i,j,nall+14)=xf_ens(i,j,nall+13)
    2954. 

  2954. !                     xf_ens(i,j,nall+15)=xf_ens(i,j,nall+11)
    2955. 

  2955. !                     xf_ens(i,j,nall+16)=xf_ens(i,j,nall+11)
    2956. 

  2956. !                     xf_ens(i,j,nall+7)=xf_ens(i,j,nall+4)
    2957. 

  2957. !                     xf_ens(i,j,nall+8)=xf_ens(i,j,nall+5)
    2958. 

  2958. !                     xf_ens(i,j,nall+9)=xf_ens(i,j,nall+6)
    2959. 

  2959. !
    2960. 

  2960. !--- store new for next time step
    2961. 

  2961. !
    2962. 

  2962.                       do nens3=1,maxens3
    2963. 

  2963.                         massfln(i,j,nall+nens3)=edt(i) &
    2964. 

  2964.                                                 *xf_ens(i,j,nall+nens3)
    2965. 

  2965.                         massfln(i,j,nall+nens3)=max(0., &
    2966. 

  2966.                                               massfln(i,j,nall+nens3))
    2967. 

  2967.                       enddo
    2968. 

  2968. !
    2969. 

  2969. !
    2970. 

  2970. !--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,....
    2971. 

  2971. !
    2972. 

  2972. !     do not care for caps here for closure groups 1 and 5,
    2973. 

  2973. !     they are fine, do not turn them off here
    2974. 

  2974. !
    2975. 

  2975. !
    2976. 

  2976.                 if(ne.eq.2.and.ierr2(i).gt.0)then
    2977. 

  2977.                       xf_ens(i,j,nall+1) =0.
    2978. 

  2978.                       xf_ens(i,j,nall+2) =0.
    2979. 

  2979.                       xf_ens(i,j,nall+3) =0.
    2980. 

  2980.                       xf_ens(i,j,nall+4) =0.
    2981. 

  2981.                       xf_ens(i,j,nall+5) =0.
    2982. 

  2982.                       xf_ens(i,j,nall+6) =0.
    2983. 

  2983.                       xf_ens(i,j,nall+7) =0.
    2984. 

  2984.                       xf_ens(i,j,nall+8) =0.
    2985. 

  2985.                       xf_ens(i,j,nall+9) =0.
    2986. 

  2986.                       xf_ens(i,j,nall+10)=0.
    2987. 

  2987.                       xf_ens(i,j,nall+11)=0.
    2988. 

  2988.                       xf_ens(i,j,nall+12)=0.
    2989. 

  2989.                       xf_ens(i,j,nall+13)=0.
    2990. 

  2990.                       xf_ens(i,j,nall+14)=0.
    2991. 

  2991.                       xf_ens(i,j,nall+15)=0.
    2992. 

  2992.                       xf_ens(i,j,nall+16)=0.
    2993. 

  2993.                       massfln(i,j,nall+1)=0.
    2994. 

  2994.                       massfln(i,j,nall+2)=0.
    2995. 

  2995.                       massfln(i,j,nall+3)=0.
    2996. 

  2996.                       massfln(i,j,nall+4)=0.
    2997. 

  2997.                       massfln(i,j,nall+5)=0.
    2998. 

  2998.                       massfln(i,j,nall+6)=0.
    2999. 

  2999.                       massfln(i,j,nall+7)=0.
    3000. 

  3000.                       massfln(i,j,nall+8)=0.
    3001. 

  3001.                       massfln(i,j,nall+9)=0.
    3002. 

  3002.                       massfln(i,j,nall+10)=0.
    3003. 

  3003.                       massfln(i,j,nall+11)=0.
    3004. 

  3004.                       massfln(i,j,nall+12)=0.
    3005. 

  3005.                       massfln(i,j,nall+13)=0.
    3006. 

  3006.                       massfln(i,j,nall+14)=0.
    3007. 

  3007.                       massfln(i,j,nall+15)=0.
    3008. 

  3008.                       massfln(i,j,nall+16)=0.
    3009. 

  3009.                 endif
    3010. 

  3010.                 if(ne.eq.3.and.ierr3(i).gt.0)then
    3011. 

  3011.                       xf_ens(i,j,nall+1) =0.
    3012. 

  3012.                       xf_ens(i,j,nall+2) =0.
    3013. 

  3013.                       xf_ens(i,j,nall+3) =0.
    3014. 

  3014.                       xf_ens(i,j,nall+4) =0.
    3015. 

  3015.                       xf_ens(i,j,nall+5) =0.
    3016. 

  3016.                       xf_ens(i,j,nall+6) =0.
    3017. 

  3017.                       xf_ens(i,j,nall+7) =0.
    3018. 

  3018.                       xf_ens(i,j,nall+8) =0.
    3019. 

  3019.                       xf_ens(i,j,nall+9) =0.
    3020. 

  3020.                       xf_ens(i,j,nall+10)=0.
    3021. 

  3021.                       xf_ens(i,j,nall+11)=0.
    3022. 

  3022.                       xf_ens(i,j,nall+12)=0.
    3023. 

  3023.                       xf_ens(i,j,nall+13)=0.
    3024. 

  3024.                       xf_ens(i,j,nall+14)=0.
    3025. 

  3025.                       xf_ens(i,j,nall+15)=0.
    3026. 

  3026.                       xf_ens(i,j,nall+16)=0.
    3027. 

  3027.                       massfln(i,j,nall+1)=0.
    3028. 

  3028.                       massfln(i,j,nall+2)=0.
    3029. 

  3029.                       massfln(i,j,nall+3)=0.
    3030. 

  3030.                       massfln(i,j,nall+4)=0.
    3031. 

  3031.                       massfln(i,j,nall+5)=0.
    3032. 

  3032.                       massfln(i,j,nall+6)=0.
    3033. 

  3033.                       massfln(i,j,nall+7)=0.
    3034. 

  3034.                       massfln(i,j,nall+8)=0.
    3035. 

  3035.                       massfln(i,j,nall+9)=0.
    3036. 

  3036.                       massfln(i,j,nall+10)=0.
    3037. 

  3037.                       massfln(i,j,nall+11)=0.
    3038. 

  3038.                       massfln(i,j,nall+12)=0.
    3039. 

  3039.                       massfln(i,j,nall+13)=0.
    3040. 

  3040.                       massfln(i,j,nall+14)=0.
    3041. 

  3041.                       massfln(i,j,nall+15)=0.
    3042. 

  3042.                       massfln(i,j,nall+16)=0.
    3043. 

  3043.                 endif
    3044. 

  3044. 

  3045.                    endif
    3046. 

  3046.  350            continue
    3047. 

  3047. ! ne=1, cap=175
    3048. 

  3048. !
    3049. 

  3049.                    nall=(iens-1)*maxens3*maxens*maxens2 &
    3050. 

  3050.                         +(iedt-1)*maxens*maxens3
    3051. 

  3051. ! ne=2, cap=100
    3052. 

  3052. !
    3053. 

  3053.                    nall2=(iens-1)*maxens3*maxens*maxens2 &
    3054. 

  3054.                         +(iedt-1)*maxens*maxens3 &
    3055. 

  3055.                         +(2-1)*maxens3
    3056. 

  3056.                       xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4)
    3057. 

  3057.                       xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5)
    3058. 

  3058.                       xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6)
    3059. 

  3059.                       xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7)
    3060. 

  3060.                       xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8)
    3061. 

  3061.                       xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9)
    3062. 

  3062.                       xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10)
    3063. 

  3063.                       xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11)
    3064. 

  3064.                       xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12)
    3065. 

  3065.                 go to 100
    3066. 

  3066.              endif
    3067. 

  3067.           elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
    3068. 

  3068.              do n=1,ensdim
    3069. 

  3069.                xf_ens(i,j,n)=0.
    3070. 

  3070.                massfln(i,j,n)=0.
    3071. 

  3071.              enddo
    3072. 

  3072.           endif
    3073. 

  3073.  100   continue
    3074. 

  3074. 

  3075.    END SUBROUTINE cup_forcing_ens
    3076. 

  3076. 

  3077. 

  3078.    SUBROUTINE cup_kbcon(cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
    3079. 

  3079.               ierr,kbmax,p_cup,cap_max,                         &
    3080. 

  3080.               ids,ide, jds,jde, kds,kde,                        &
    3081. 

  3081.               ims,ime, jms,jme, kms,kme,                        &
    3082. 

  3082.               its,ite, jts,jte, kts,kte                        )
    3083. 

  3083. 

  3084.    IMPLICIT NONE
    3085. 

  3085. !
    3086. 

  3086. 

  3087.    ! only local wrf dimensions are need as of now in this routine
    3088. 

  3088. 

  3089.      integer                                                           &
    3090. 

  3090.         ,intent (in   )                   ::                           &
    3091. 

  3091.         ids,ide, jds,jde, kds,kde,           &
    3092. 

  3092.         ims,ime, jms,jme, kms,kme,           &
    3093. 

  3093.         its,ite, jts,jte, kts,kte
    3094. 

  3094.   ! 
    3095. 

  3095.   ! 
    3096. 

  3096.   ! 
    3097. 

  3097.   ! ierr error value, maybe modified in this routine
    3098. 

  3098.   !
    3099. 

  3099.      real,    dimension (its:ite,kts:kte)                              &
    3100. 

  3100.         ,intent (in   )                   ::                           &
    3101. 

  3101.         he_cup,hes_cup,p_cup
    3102. 

  3102.      real,    dimension (its:ite)                                      &
    3103. 

  3103.         ,intent (in   )                   ::                           &
    3104. 

  3104.         cap_max,cap_inc
    3105. 

  3105.      integer, dimension (its:ite)                                      &
    3106. 

  3106.         ,intent (in   )                   ::                           &
    3107. 

  3107.         kbmax
    3108. 

  3108.      integer, dimension (its:ite)                                      &
    3109. 

  3109.         ,intent (inout)                   ::                           &
    3110. 

  3110.         kbcon,k22,ierr
    3111. 

  3111.      integer                                                           &
    3112. 

  3112.         ,intent (in   )                   ::                           &
    3113. 

  3113.         iloop
    3114. 

  3114. !
    3115. 

  3115. !  local variables in this routine
    3116. 

  3116. !
    3117. 

  3117. 

  3118.      integer                              ::                           &
    3119. 

  3119.         i
    3120. 

  3120.      real                                 ::                           &
    3121. 

  3121.         pbcdif,plus
    3122. 

  3122.      integer :: itf
    3123. 

  3123. 

  3124.      itf=MIN(ite,ide-1)
    3125. 

  3125. !
    3126. 

  3126. !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
    3127. 

  3127. !
    3128. 

  3128.        DO 27 i=its,itf
    3129. 

  3129.       kbcon(i)=1
    3130. 

  3130.       IF(ierr(I).ne.0)GO TO 27
    3131. 

  3131.       KBCON(I)=K22(I)
    3132. 

  3132.       GO TO 32
    3133. 

  3133.  31   CONTINUE
    3134. 

  3134.       KBCON(I)=KBCON(I)+1
    3135. 

  3135.       IF(KBCON(I).GT.KBMAX(i)+2)THEN
    3136. 

  3136.          if(iloop.lt.4)ierr(i)=3
    3137. 

  3137. !        if(iloop.lt.4)ierr(i)=997
    3138. 

  3138.         GO TO 27
    3139. 

  3139.       ENDIF
    3140. 

  3140.  32   CONTINUE
    3141. 

  3141.       IF(HE_cup(I,K22(I)).LT.HES_cup(I,KBCON(I)))GO TO 31
    3142. 

  3142. 

  3143. !     cloud base pressure and max moist static energy pressure
    3144. 

  3144. !     i.e., the depth (in mb) of the layer of negative buoyancy
    3145. 

  3145.       if(KBCON(I)-K22(I).eq.1)go to 27
    3146. 

  3146.       PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I))
    3147. 

  3147.       plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i))
    3148. 

  3148.       if(iloop.eq.4)plus=cap_max(i)
    3149. 

  3149.       IF(PBCDIF.GT.plus)THEN
    3150. 

  3150.         K22(I)=K22(I)+1
    3151. 

  3151.         KBCON(I)=K22(I)
    3152. 

  3152.         GO TO 32
    3153. 

  3153.       ENDIF
    3154. 

  3154.  27   CONTINUE
    3155. 

  3155. 

  3156.    END SUBROUTINE cup_kbcon
    3157. 

  3157. 

  3158. 

  3159.    SUBROUTINE cup_kbcon_cin(iloop,k22,kbcon,he_cup,hes_cup,  &
    3160. 

  3160.               z,tmean,qes,ierr,kbmax,p_cup,cap_max,xl,cp,    &
    3161. 

  3161.               ids,ide, jds,jde, kds,kde,                     &
    3162. 

  3162.               ims,ime, jms,jme, kms,kme,                     &
    3163. 

  3163.               its,ite, jts,jte, kts,kte                     )
    3164. 

  3164. 

  3165.    IMPLICIT NONE
    3166. 

  3166. !
    3167. 

  3167. 

  3168.    ! only local wrf dimensions are need as of now in this routine
    3169. 

  3169. 

  3170.      integer                                                           &
    3171. 

  3171.         ,intent (in   )                   ::                           &
    3172. 

  3172.         ids,ide, jds,jde, kds,kde,           &
    3173. 

  3173.         ims,ime, jms,jme, kms,kme,           &
    3174. 

  3174.         its,ite, jts,jte, kts,kte
    3175. 

  3175.   ! 
    3176. 

  3176.   ! 
    3177. 

  3177.   ! 
    3178. 

  3178.   ! ierr error value, maybe modified in this routine
    3179. 

  3179.   !
    3180. 

  3180.      real,    dimension (its:ite,kts:kte)                              &
    3181. 

  3181.         ,intent (in   )                   ::                           &
    3182. 

  3182.         he_cup,hes_cup,p_cup,z,tmean,qes
    3183. 

  3183.      real,    dimension (its:ite)                                      &
    3184. 

  3184.         ,intent (in   )                   ::                           &
    3185. 

  3185.         cap_max
    3186. 

  3186.      real                                                              &
    3187. 

  3187.         ,intent (in   )                   ::                           &
    3188. 

  3188.         xl,cp
    3189. 

  3189.      integer, dimension (its:ite)                                      &
    3190. 

  3190.         ,intent (in   )                   ::                           &
    3191. 

  3191.         kbmax
    3192. 

  3192.      integer, dimension (its:ite)                                      &
    3193. 

  3193.         ,intent (inout)                   ::                           &
    3194. 

  3194.         kbcon,k22,ierr
    3195. 

  3195.      integer                                                           &
    3196. 

  3196.         ,intent (in   )                   ::                           &
    3197. 

  3197.         iloop
    3198. 

  3198. !
    3199. 

  3199. !  local variables in this routine
    3200. 

  3200. !
    3201. 

  3201. 

  3202.      integer                              ::                           &
    3203. 

  3203.         i,k
    3204. 

  3204.      real                                 ::                           &
    3205. 

  3205.         cin,cin_max,dh,tprim,gamma
    3206. 

  3206. !
    3207. 

  3207.      integer :: itf
    3208. 

  3208. 

  3209.      itf=MIN(ite,ide-1)
    3210. 

  3210. !
    3211. 

  3211. !
    3212. 

  3212.     
    3213. 

  3213. !
    3214. 

  3214. !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
    3215. 

  3215. !
    3216. 

  3216.        DO 27 i=its,itf
    3217. 

  3217.       cin_max=-cap_max(i)
    3218. 

  3218.       kbcon(i)=1
    3219. 

  3219.       cin = 0.
    3220. 

  3220.       IF(ierr(I).ne.0)GO TO 27
    3221. 

  3221.       KBCON(I)=K22(I)
    3222. 

  3222.       GO TO 32
    3223. 

  3223.  31   CONTINUE
    3224. 

  3224.       KBCON(I)=KBCON(I)+1
    3225. 

  3225.       IF(KBCON(I).GT.KBMAX(i)+2)THEN
    3226. 

  3226.          if(iloop.eq.1)ierr(i)=3
    3227. 

  3227. !        if(iloop.eq.2)ierr(i)=997
    3228. 

  3228.         GO TO 27
    3229. 

  3229.       ENDIF
    3230. 

  3230.  32   CONTINUE
    3231. 

  3231.       dh      = HE_cup(I,K22(I)) - HES_cup(I,KBCON(I))
    3232. 

  3232.       if (dh.lt. 0.) then
    3233. 

  3233.         GAMMA=(xl/cp)*(xl/(461.525*(Tmean(I,K22(i))**2)))*QES(I,K22(i))
    3234. 

  3234.         tprim = dh/(cp*(1.+gamma))
    3235. 

  3235. 

  3236.         cin = cin + 9.8066 * tprim &
    3237. 

  3237.               *(z(i,k22(i))-z(i,k22(i)-1)) / tmean(i,k22(i))
    3238. 

  3238.         go to 31
    3239. 

  3239.       end if
    3240. 

  3240. 

  3241. 

  3242. !     If negative energy in negatively buoyant layer
    3243. 

  3243. !       exceeds convective inhibition (CIN) threshold,
    3244. 

  3244. !       then set K22 level one level up and see if that
    3245. 

  3245. !       will work.
    3246. 

  3246. 

  3247.       IF(cin.lT.cin_max)THEN
    3248. 

  3248. !       print *,i,cin,cin_max,k22(i),kbcon(i)
    3249. 

  3249.         K22(I)=K22(I)+1
    3250. 

  3250.         KBCON(I)=K22(I)
    3251. 

  3251.         GO TO 32
    3252. 

  3252.       ENDIF
    3253. 

  3253.  27   CONTINUE
    3254. 

  3254. 

  3255.    END SUBROUTINE cup_kbcon_cin
    3256. 

  3256. 

  3257. 

  3258.    SUBROUTINE cup_ktop(ilo,dby,kbcon,ktop,ierr,              &
    3259. 

  3259.               ids,ide, jds,jde, kds,kde,                     &
    3260. 

  3260.               ims,ime, jms,jme, kms,kme,                     &
    3261. 

  3261.               its,ite, jts,jte, kts,kte                     )
    3262. 

  3262. 

  3263.    IMPLICIT NONE
    3264. 

  3264. !
    3265. 

  3265. !  on input
    3266. 

  3266. !
    3267. 

  3267. 

  3268.    ! only local wrf dimensions are need as of now in this routine
    3269. 

  3269. 

  3270.      integer                                                           &
    3271. 

  3271.         ,intent (in   )                   ::                           &
    3272. 

  3272.         ids,ide, jds,jde, kds,kde,           &
    3273. 

  3273.         ims,ime, jms,jme, kms,kme,           &
    3274. 

  3274.         its,ite, jts,jte, kts,kte
    3275. 

  3275.   ! dby = buoancy term
    3276. 

  3276.   ! ktop = cloud top (output)
    3277. 

  3277.   ! ilo  = flag
    3278. 

  3278.   ! ierr error value, maybe modified in this routine
    3279. 

  3279.   !
    3280. 

  3280.      real,    dimension (its:ite,kts:kte)                              &
    3281. 

  3281.         ,intent (inout)                   ::                           &
    3282. 

  3282.         dby
    3283. 

  3283.      integer, dimension (its:ite)                                      &
    3284. 

  3284.         ,intent (in   )                   ::                           &
    3285. 

  3285.         kbcon
    3286. 

  3286.      integer                                                           &
    3287. 

  3287.         ,intent (in   )                   ::                           &
    3288. 

  3288.         ilo
    3289. 

  3289.      integer, dimension (its:ite)                                      &
    3290. 

  3290.         ,intent (out  )                   ::                           &
    3291. 

  3291.         ktop
    3292. 

  3292.      integer, dimension (its:ite)                                      &
    3293. 

  3293.         ,intent (inout)                   ::                           &
    3294. 

  3294.         ierr
    3295. 

  3295. !
    3296. 

  3296. !  local variables in this routine
    3297. 

  3297. !
    3298. 

  3298. 

  3299.      integer                              ::                           &
    3300. 

  3300.         i,k
    3301. 

  3301. !
    3302. 

  3302.      integer :: itf, ktf
    3303. 

  3303. 

  3304.      itf=MIN(ite,ide-1)
    3305. 

  3305.      ktf=MIN(kte,kde-1)
    3306. 

  3306. !
    3307. 

  3307. !
    3308. 

  3308.         DO 42 i=its,itf
    3309. 

  3309.         ktop(i)=1
    3310. 

  3310.          IF(ierr(I).EQ.0)then
    3311. 

  3311.           DO 40 K=KBCON(I)+1,ktf-1
    3312. 

  3312.             IF(DBY(I,K).LE.0.)THEN
    3313. 

  3313.                 KTOP(I)=K-1
    3314. 

  3314.                 GO TO 41
    3315. 

  3315.              ENDIF
    3316. 

  3316.   40      CONTINUE
    3317. 

  3317.           if(ilo.eq.1)ierr(i)=5
    3318. 

  3318. !         if(ilo.eq.2)ierr(i)=998
    3319. 

  3319.           GO TO 42
    3320. 

  3320.   41     CONTINUE
    3321. 

  3321.          do k=ktop(i)+1,ktf
    3322. 

  3322.            dby(i,k)=0.
    3323. 

  3323.          enddo
    3324. 

  3324.          endif
    3325. 

  3325.   42     CONTINUE
    3326. 

  3326. 

  3327.    END SUBROUTINE cup_ktop
    3328. 

  3328. 

  3329. 

  3330.    SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr,              &
    3331. 

  3331.               ids,ide, jds,jde, kds,kde,                     &
    3332. 

  3332.               ims,ime, jms,jme, kms,kme,                     &
    3333. 

  3333.               its,ite, jts,jte, kts,kte                     )
    3334. 

  3334. 

  3335.    IMPLICIT NONE
    3336. 

  3336. !
    3337. 

  3337. !  on input
    3338. 

  3338. !
    3339. 

  3339. 

  3340.    ! only local wrf dimensions are need as of now in this routine
    3341. 

  3341. 

  3342.      integer                                                           &
    3343. 

  3343.         ,intent (in   )                   ::                           &
    3344. 

  3344.          ids,ide, jds,jde, kds,kde,                                    &
    3345. 

  3345.          ims,ime, jms,jme, kms,kme,                                    &
    3346. 

  3346.          its,ite, jts,jte, kts,kte
    3347. 

  3347.   ! array input array
    3348. 

  3348.   ! x output array with return values
    3349. 

  3349.   ! kt output array of levels
    3350. 

  3350.   ! ks,kend  check-range
    3351. 

  3351.      real,    dimension (its:ite,kts:kte)                              &
    3352. 

  3352.         ,intent (in   )                   ::                           &
    3353. 

  3353.          array
    3354. 

  3354.      integer, dimension (its:ite)                                      &
    3355. 

  3355.         ,intent (in   )                   ::                           &
    3356. 

  3356.          ierr,ke
    3357. 

  3357.      integer                                                           &
    3358. 

  3358.         ,intent (in   )                   ::                           &
    3359. 

  3359.          ks
    3360. 

  3360.      integer, dimension (its:ite)                                      &
    3361. 

  3361.         ,intent (out  )                   ::                           &
    3362. 

  3362.          maxx
    3363. 

  3363.      real,    dimension (its:ite)         ::                           &
    3364. 

  3364.          x
    3365. 

  3365.      real                                 ::                           &
    3366. 

  3366.          xar
    3367. 

  3367.      integer                              ::                           &
    3368. 

  3368.          i,k
    3369. 

  3369.      integer :: itf
    3370. 

  3370. 

  3371.      itf=MIN(ite,ide-1)
    3372. 

  3372. 

  3373.        DO 200 i=its,itf
    3374. 

  3374.        MAXX(I)=KS
    3375. 

  3375.        if(ierr(i).eq.0)then
    3376. 

  3376.       X(I)=ARRAY(I,KS)
    3377. 

  3377. !
    3378. 

  3378.        DO 100 K=KS,KE(i)
    3379. 

  3379.          XAR=ARRAY(I,K)
    3380. 

  3380.          IF(XAR.GE.X(I)) THEN
    3381. 

  3381.             X(I)=XAR
    3382. 

  3382.             MAXX(I)=K
    3383. 

  3383.          ENDIF
    3384. 

  3384.  100  CONTINUE
    3385. 

  3385.       endif
    3386. 

  3386.  200  CONTINUE
    3387. 

  3387. 

  3388.    END SUBROUTINE cup_MAXIMI
    3389. 

  3389. 

  3390. 

  3391.    SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr,              &
    3392. 

  3392.               ids,ide, jds,jde, kds,kde,                     &
    3393. 

  3393.               ims,ime, jms,jme, kms,kme,                     &
    3394. 

  3394.               its,ite, jts,jte, kts,kte                     )
    3395. 

  3395. 

  3396.    IMPLICIT NONE
    3397. 

  3397. !
    3398. 

  3398. !  on input
    3399. 

  3399. !
    3400. 

  3400. 

  3401.    ! only local wrf dimensions are need as of now in this routine
    3402. 

  3402. 

  3403.      integer                                                           &
    3404. 

  3404.         ,intent (in   )                   ::                           &
    3405. 

  3405.          ids,ide, jds,jde, kds,kde,                                    &
    3406. 

  3406.          ims,ime, jms,jme, kms,kme,                                    &
    3407. 

  3407.          its,ite, jts,jte, kts,kte
    3408. 

  3408.   ! array input array
    3409. 

  3409.   ! x output array with return values
    3410. 

  3410.   ! kt output array of levels
    3411. 

  3411.   ! ks,kend  check-range
    3412. 

  3412.      real,    dimension (its:ite,kts:kte)                              &
    3413. 

  3413.         ,intent (in   )                   ::                           &
    3414. 

  3414.          array
    3415. 

  3415.      integer, dimension (its:ite)                                      &
    3416. 

  3416.         ,intent (in   )                   ::                           &
    3417. 

  3417.          ierr,ks,kend
    3418. 

  3418.      integer, dimension (its:ite)                                      &
    3419. 

  3419.         ,intent (out  )                   ::                           &
    3420. 

  3420.          kt
    3421. 

  3421.      real,    dimension (its:ite)         ::                           &
    3422. 

  3422.          x
    3423. 

  3423.      integer                              ::                           &
    3424. 

  3424.          i,k,kstop
    3425. 

  3425. 

  3426.      integer :: itf
    3427. 

  3427. 

  3428.      itf=MIN(ite,ide-1)
    3429. 

  3429. 

  3430.        DO 200 i=its,itf
    3431. 

  3431.       KT(I)=KS(I)
    3432. 

  3432.       if(ierr(i).eq.0)then
    3433. 

  3433.       X(I)=ARRAY(I,KS(I))
    3434. 

  3434.        KSTOP=MAX(KS(I)+1,KEND(I))
    3435. 

  3435. !
    3436. 

  3436.        DO 100 K=KS(I)+1,KSTOP
    3437. 

  3437.          IF(ARRAY(I,K).LT.X(I)) THEN
    3438. 

  3438.               X(I)=ARRAY(I,K)
    3439. 

  3439.               KT(I)=K
    3440. 

  3440.          ENDIF
    3441. 

  3441.  100  CONTINUE
    3442. 

  3442.       endif
    3443. 

  3443.  200  CONTINUE
    3444. 

  3444. 

  3445.    END SUBROUTINE cup_MINIMI
    3446. 

  3446. 

  3447. 

  3448.    SUBROUTINE cup_output_ens(xf_ens,ierr,dellat,dellaq,dellaqc,  &
    3449. 

  3449.               outtem,outq,outqc,pre,pw,xmb,ktop,                 &
    3450. 

  3450.               j,name,nx,nx2,iens,ierr2,ierr3,pr_ens,             &
    3451. 

  3451.               maxens3,ensdim,massfln,                            &
    3452. 

  3452.               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                 &
    3453. 

  3453.               APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,    &
    3454. 

  3454.               outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,  &
    3455. 

  3455.               CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens,  &
    3456. 

  3456.               l_flux,                                           &
    3457. 

  3457.               ids,ide, jds,jde, kds,kde, &
    3458. 

  3458.               ims,ime, jms,jme, kms,kme, &
    3459. 

  3459.               its,ite, jts,jte, kts,kte)
    3460. 

  3460. 

  3461.    IMPLICIT NONE
    3462. 

  3462. !
    3463. 

  3463. !  on input
    3464. 

  3464. !
    3465. 

  3465. 

  3466.    ! only local wrf dimensions are need as of now in this routine
    3467. 

  3467. 

  3468.      integer                                                           &
    3469. 

  3469.         ,intent (in   )                   ::                           &
    3470. 

  3470.         ids,ide, jds,jde, kds,kde,           &
    3471. 

  3471.         ims,ime, jms,jme, kms,kme,           &
    3472. 

  3472.         its,ite, jts,jte, kts,kte
    3473. 

  3473.      integer, intent (in   )              ::                           &
    3474. 

  3474.         j,ensdim,nx,nx2,iens,maxens3
    3475. 

  3475.   ! xf_ens = ensemble mass fluxes
    3476. 

  3476.   ! pr_ens = precipitation ensembles
    3477. 

  3477.   ! dellat = change of temperature per unit mass flux of cloud ensemble
    3478. 

  3478.   ! dellaq = change of q per unit mass flux of cloud ensemble
    3479. 

  3479.   ! dellaqc = change of qc per unit mass flux of cloud ensemble
    3480. 

  3480.   ! outtem = output temp tendency (per s)
    3481. 

  3481.   ! outq   = output q tendency (per s)
    3482. 

  3482.   ! outqc  = output qc tendency (per s)
    3483. 

  3483.   ! pre    = output precip
    3484. 

  3484.   ! xmb    = total base mass flux
    3485. 

  3485.   ! xfac1  = correction factor
    3486. 

  3486.   ! pw = pw -epsilon*pd (ensemble dependent)
    3487. 

  3487.   ! ierr error value, maybe modified in this routine
    3488. 

  3488.   !
    3489. 

  3489.      real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
    3490. 

  3490.         ,intent (inout)                   ::                           &
    3491. 

  3491.        xf_ens,pr_ens,massfln
    3492. 

  3492.      real,    dimension (ims:ime,jms:jme)                              &
    3493. 

  3493.         ,intent (inout)                   ::                           &
    3494. 

  3494.                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,            &
    3495. 

  3495.                APR_CAPME,APR_CAPMI 
    3496. 

  3496. 

  3497.      real,    dimension (its:ite,kts:kte)                              &
    3498. 

  3498.         ,intent (out  )                   ::                           &
    3499. 

  3499.         outtem,outq,outqc
    3500. 

  3500.      real,    dimension (its:ite)                                      &
    3501. 

  3501.         ,intent (out  )                   ::                           &
    3502. 

  3502.         pre,xmb
    3503. 

  3503.      real,    dimension (its:ite)                                      &
    3504. 

  3504.         ,intent (inout  )                   ::                           &
    3505. 

  3505.         closure_n,xland1
    3506. 

  3506.      real,    dimension (its:ite,kts:kte,1:nx)                         &
    3507. 

  3507.         ,intent (in   )                   ::                           &
    3508. 

  3508.        dellat,dellaqc,dellaq,pw
    3509. 

  3509.      integer, dimension (its:ite)                                      &
    3510. 

  3510.         ,intent (in   )                   ::                           &
    3511. 

  3511.         ktop
    3512. 

  3512.      integer, dimension (its:ite)                                      &
    3513. 

  3513.         ,intent (inout)                   ::                           &
    3514. 

  3514.         ierr,ierr2,ierr3
    3515. 

  3515.      real,    dimension (its:ite,kts:kte,1:ensdim)                     &
    3516. 

  3516.         ,intent (in   )                   ::                           &
    3517. 

  3517.        CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens
    3518. 

  3518.      real,    dimension (its:ite,kts:kte)                     &
    3519. 

  3519.         ,intent (out)                   ::                           &
    3520. 

  3520.            outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
    3521. 

  3521.      logical, intent(in) :: l_flux
    3522. 

  3522. 

  3523. !
    3524. 

  3524. !  local variables in this routine
    3525. 

  3525. !
    3526. 

  3526. 

  3527.      integer                              ::                           &
    3528. 

  3528.         i,k,n,ncount
    3529. 

  3529.      real                                 ::                           &
    3530. 

  3530.         outtes,ddtes,dtt,dtq,dtqc,dtpw,tuning,prerate,clos_wei
    3531. 

  3531.      real,    dimension (its:ite)         ::                           &
    3532. 

  3532.        xfac1
    3533. 

  3533.      real,    dimension (its:ite)::                           &
    3534. 

  3534.        xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight
    3535. 

  3535.      real,    dimension (its:ite)::                           &
    3536. 

  3536.        pr_ske,pr_ave,pr_std,pr_cur
    3537. 

  3537.      real,    dimension (its:ite,jts:jte)::                           &
    3538. 

  3538.                pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma,     &
    3539. 

  3539.                pr_capme,pr_capmi
    3540. 

  3540.      integer :: iedt, kk
    3541. 

  3541. 

  3542. !
    3543. 

  3543.       character *(*), intent (in)        ::                           &
    3544. 

  3544.        name
    3545. 

  3545. !
    3546. 

  3546.      integer :: itf, ktf
    3547. 

  3547. 

  3548.      itf=MIN(ite,ide-1)
    3549. 

  3549.      ktf=MIN(kte,kde-1)
    3550. 

  3550.      tuning=0.
    3551. 

  3551. !
    3552. 

  3552. !
    3553. 

  3553.       DO k=kts,ktf
    3554. 

  3554.       do i=its,itf
    3555. 

  3555.         outtem(i,k)=0.
    3556. 

  3556.         outq(i,k)=0.
    3557. 

  3557.         outqc(i,k)=0.
    3558. 

  3558.       enddo
    3559. 

  3559.       enddo
    3560. 

  3560.       do i=its,itf
    3561. 

  3561.         pre(i)=0.
    3562. 

  3562.         xmb(i)=0.
    3563. 

  3563.          xfac1(i)=1.
    3564. 

  3564.         xmbweight(i)=1.
    3565. 

  3565.       enddo
    3566. 

  3566.       do i=its,itf
    3567. 

  3567.         IF(ierr(i).eq.0)then
    3568. 

  3568.         do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
    3569. 

  3569.            if(pr_ens(i,j,n).le.0.)then
    3570. 

  3570.              xf_ens(i,j,n)=0.
    3571. 

  3571.            endif
    3572. 

  3572.         enddo
    3573. 

  3573.         endif
    3574. 

  3574.       enddo
    3575. 

  3575. !
    3576. 

  3576. !--- calculate ensemble average mass fluxes
    3577. 

  3577. !
    3578. 

  3578.        call massflx_stats(xf_ens,ensdim,nx2,nx,maxens3,      &
    3579. 

  3579.             xmb_ave,xmb_std,xmb_cur,xmb_ske,j,ierr,1,    &
    3580. 

  3580.             APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
    3581. 

  3581.             APR_CAPMA,APR_CAPME,APR_CAPMI,               &
    3582. 

  3582.             pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
    3583. 

  3583.             pr_capma,pr_capme,pr_capmi,                  &
    3584. 

  3584.             ids,ide, jds,jde, kds,kde,                   &
    3585. 

  3585.             ims,ime, jms,jme, kms,kme,                   &
    3586. 

  3586.             its,ite, jts,jte, kts,kte                   )
    3587. 

  3587.        call massflx_stats(pr_ens,ensdim,nx2,nx,maxens3,  &
    3588. 

  3588.             pr_ave,pr_std,pr_cur,pr_ske,j,ierr,2,        &
    3589. 

  3589.             APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
    3590. 

  3590.             APR_CAPMA,APR_CAPME,APR_CAPMI,               &
    3591. 

  3591.             pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
    3592. 

  3592.             pr_capma,pr_capme,pr_capmi,                  &
    3593. 

  3593.             ids,ide, jds,jde, kds,kde,                   &
    3594. 

  3594.             ims,ime, jms,jme, kms,kme,                   &
    3595. 

  3595.             its,ite, jts,jte, kts,kte                   )
    3596. 

  3596. !
    3597. 

  3597. !-- now do feedback
    3598. 

  3598. !
    3599. 

  3599.       ddtes=200.
    3600. 

  3600. !     if(name.eq.'shal')ddtes=200.
    3601. 

  3601.       do i=its,itf
    3602. 

  3602.         if(ierr(i).eq.0)then
    3603. 

  3603.          if(xmb_ave(i).le.0.)then
    3604. 

  3604.               ierr(i)=13
    3605. 

  3605.               xmb_ave(i)=0.
    3606. 

  3606.          endif
    3607. 

  3607. !        xmb(i)=max(0.,xmb_ave(i))
    3608. 

  3608.          xmb(i)=max(.1*xmb_ave(i),xmb_ave(i)-tuning*xmb_std(i))
    3609. 

  3609. ! --- Now use proper count of how many closures were actually
    3610. 

  3610. !       used in cup_forcing_ens (including screening of some
    3611. 

  3611. !       closures over water) to properly normalize xmb
    3612. 

  3612.            clos_wei=16./max(1.,closure_n(i))
    3613. 

  3613.            if (xland1(i).lt.0.5)xmb(i)=xmb(i)*clos_wei
    3614. 

  3614.            if(xmb(i).eq.0.)then
    3615. 

  3615.               ierr(i)=19
    3616. 

  3616.            endif
    3617. 

  3617.            if(xmb(i).gt.100.)then
    3618. 

  3618.               ierr(i)=19
    3619. 

  3619.            endif
    3620. 

  3620.            xfac1(i)=xmb(i)
    3621. 

  3621. 

  3622.         endif
    3623. 

  3623.         xfac1(i)=xmb_ave(i)
    3624. 

  3624.       ENDDO
    3625. 

  3625.       DO k=kts,ktf
    3626. 

  3626.       do i=its,itf
    3627. 

  3627.             dtt=0.
    3628. 

  3628.             dtq=0.
    3629. 

  3629.             dtqc=0.
    3630. 

  3630.             dtpw=0.
    3631. 

  3631.         IF(ierr(i).eq.0.and.k.le.ktop(i))then
    3632. 

  3632.            do n=1,nx
    3633. 

  3633.               dtt=dtt+dellat(i,k,n)
    3634. 

  3634.               dtq=dtq+dellaq(i,k,n)
    3635. 

  3635.               dtqc=dtqc+dellaqc(i,k,n)
    3636. 

  3636.               dtpw=dtpw+pw(i,k,n)
    3637. 

  3637.            enddo
    3638. 

  3638.            outtes=dtt*XMB(I)*86400./float(nx)
    3639. 

  3639.            IF((OUTTES.GT.2.*ddtes.and.k.gt.2))THEN
    3640. 

  3640.              XMB(I)= 2.*ddtes/outtes * xmb(i)
    3641. 

  3641.              outtes=1.*ddtes
    3642. 

  3642.            endif
    3643. 

  3643.            if (outtes .lt. -ddtes) then
    3644. 

  3644.              XMB(I)= -ddtes/outtes * xmb(i)
    3645. 

  3645.              outtes=-ddtes
    3646. 

  3646.            endif
    3647. 

  3647.            if (outtes .gt. .5*ddtes.and.k.le.2) then
    3648. 

  3648.              XMB(I)= ddtes/outtes * xmb(i)
    3649. 

  3649.              outtes=.5*ddtes
    3650. 

  3650.            endif
    3651. 

  3651.            OUTTEM(I,K)=XMB(I)*dtt/float(nx)
    3652. 

  3652.            OUTQ(I,K)=XMB(I)*dtq/float(nx)
    3653. 

  3653.            OUTQC(I,K)=XMB(I)*dtqc/float(nx)
    3654. 

  3654.            PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx)
    3655. 

  3655.         endif
    3656. 

  3656.       enddo
    3657. 

  3657.       enddo
    3658. 

  3658.       do i=its,itf
    3659. 

  3659.         if(ierr(i).eq.0)then
    3660. 

  3660.            prerate=pre(i)*3600.
    3661. 

  3661.            if(prerate.lt.0.1)then
    3662. 

  3662.               if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
    3663. 

  3663.                  pre(i)=0.
    3664. 

  3664.                  ierr(i)=221
    3665. 

  3665.                  do k=kts,ktf
    3666. 

  3666.                     outtem(i,k)=0.
    3667. 

  3667.                     outq(i,k)=0.
    3668. 

  3668.                     outqc(i,k)=0.
    3669. 

  3669.                  enddo
    3670. 

  3670.                  do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
    3671. 

  3671.                    massfln(i,j,k)=0.
    3672. 

  3672.                    xf_ens(i,j,k)=0.
    3673. 

  3673.                  enddo
    3674. 

  3674.                endif
    3675. 

  3675.             endif
    3676. 

  3676. 

  3677.         endif
    3678. 

  3678.       ENDDO
    3679. 

  3679. 

  3680.       do i=its,itf
    3681. 

  3681.         if(ierr(i).eq.0)then
    3682. 

  3682.         xfac1(i)=xmb(i)/xfac1(i)
    3683. 

  3683.         do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
    3684. 

  3684.           massfln(i,j,k)=massfln(i,j,k)*xfac1(i)
    3685. 

  3685.           xf_ens(i,j,k)=xf_ens(i,j,k)*xfac1(i)
    3686. 

  3686.         enddo
    3687. 

  3687.         endif
    3688. 

  3688.       ENDDO
    3689. 

  3689.       if (l_flux) then
    3690. 

  3690.          if (iens .eq. 1) then  ! Only do deep convection mass fluxes
    3691. 

  3691.             do k=kts,ktf
    3692. 

  3692.                do i=its,itf
    3693. 

  3693.                   outcfu1(i,k)=0.
    3694. 

  3694.                   outcfd1(i,k)=0.
    3695. 

  3695.                   outdfu1(i,k)=0.
    3696. 

  3696.                   outefu1(i,k)=0.
    3697. 

  3697.                   outdfd1(i,k)=0.
    3698. 

  3698.                   outefd1(i,k)=0.
    3699. 

  3699.                   if (ierr(i) .eq. 0) then
    3700. 

  3700.                      do iedt=1,nx
    3701. 

  3701.                         do kk=1,nx2*maxens3
    3702. 

  3702.                            n=(iens-1)*nx*nx2*maxens3 + &
    3703. 

  3703.                                 (iedt-1)*nx2*maxens3 + kk
    3704. 

  3704.                            outcfu1(i,k)=outcfu1(i,k)+cfu1_ens(i,k,iedt)*xf_ens(i,j,n)
    3705. 

  3705.                            outcfd1(i,k)=outcfd1(i,k)+cfd1_ens(i,k,iedt)*xf_ens(i,j,n)
    3706. 

  3706.                            outdfu1(i,k)=outdfu1(i,k)+dfu1_ens(i,k,iedt)*xf_ens(i,j,n)
    3707. 

  3707.                            outefu1(i,k)=outefu1(i,k)+efu1_ens(i,k,iedt)*xf_ens(i,j,n)
    3708. 

  3708.                            outdfd1(i,k)=outdfd1(i,k)+dfd1_ens(i,k,iedt)*xf_ens(i,j,n)
    3709. 

  3709.                            outefd1(i,k)=outefd1(i,k)+efd1_ens(i,k,iedt)*xf_ens(i,j,n)
    3710. 

  3710.                         end do
    3711. 

  3711.                      end do
    3712. 

  3712.                      outcfu1(i,k)=outcfu1(i,k)/ensdim
    3713. 

  3713.                      outcfd1(i,k)=outcfd1(i,k)/ensdim
    3714. 

  3714.                      outdfu1(i,k)=outdfu1(i,k)/ensdim
    3715. 

  3715.                      outefu1(i,k)=outefu1(i,k)/ensdim
    3716. 

  3716.                      outdfd1(i,k)=outdfd1(i,k)/ensdim
    3717. 

  3717.                      outefd1(i,k)=outefd1(i,k)/ensdim
    3718. 

  3718.                   end if !ierr
    3719. 

  3719.                end do !i 
    3720. 

  3720.             end do !k
    3721. 

  3721.          end if !iens .eq. 1
    3722. 

  3722.       end if !l_flux
    3723. 

  3723. 

  3724.    END SUBROUTINE cup_output_ens
    3725. 

  3725. 

  3726. 

  3727.    SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,       &
    3728. 

  3728.               kbcon,ktop,ierr,                               &
    3729. 

  3729.               ids,ide, jds,jde, kds,kde,                     &
    3730. 

  3730.               ims,ime, jms,jme, kms,kme,                     &
    3731. 

  3731.               its,ite, jts,jte, kts,kte                     )
    3732. 

  3732. 

  3733.    IMPLICIT NONE
    3734. 

  3734. !
    3735. 

  3735. !  on input
    3736. 

  3736. !
    3737. 

  3737. 

  3738.    ! only local wrf dimensions are need as of now in this routine
    3739. 

  3739. 

  3740.      integer                                                           &
    3741. 

  3741.         ,intent (in   )                   ::                           &
    3742. 

  3742.         ids,ide, jds,jde, kds,kde,                                     &
    3743. 

  3743.         ims,ime, jms,jme, kms,kme,                                     &
    3744. 

  3744.         its,ite, jts,jte, kts,kte
    3745. 

  3745.   ! aa0 cloud work function
    3746. 

  3746.   ! gamma_cup = gamma on model cloud levels
    3747. 

  3747.   ! t_cup = temperature (Kelvin) on model cloud levels
    3748. 

  3748.   ! dby = buoancy term
    3749. 

  3749.   ! zu= normalized updraft mass flux
    3750. 

  3750.   ! z = heights of model levels 
    3751. 

  3751.   ! ierr error value, maybe modified in this routine
    3752. 

  3752.   !
    3753. 

  3753.      real,    dimension (its:ite,kts:kte)                              &
    3754. 

  3754.         ,intent (in   )                   ::                           &
    3755. 

  3755.         z,zu,gamma_cup,t_cup,dby
    3756. 

  3756.      integer, dimension (its:ite)                                      &
    3757. 

  3757.         ,intent (in   )                   ::                           &
    3758. 

  3758.         kbcon,ktop
    3759. 

  3759. !
    3760. 

  3760. ! input and output
    3761. 

  3761. !
    3762. 

  3762. 

  3763. 

  3764.      integer, dimension (its:ite)                                      &
    3765. 

  3765.         ,intent (inout)                   ::                           &
    3766. 

  3766.         ierr
    3767. 

  3767.      real,    dimension (its:ite)                                      &
    3768. 

  3768.         ,intent (out  )                   ::                           &
    3769. 

  3769.         aa0
    3770. 

  3770. !
    3771. 

  3771. !  local variables in this routine
    3772. 

  3772. !
    3773. 

  3773. 

  3774.      integer                              ::                           &
    3775. 

  3775.         i,k
    3776. 

  3776.      real                                 ::                           &
    3777. 

  3777.         dz,da
    3778. 

  3778. !
    3779. 

  3779.      integer :: itf, ktf
    3780. 

  3780. 

  3781.      itf = MIN(ite,ide-1)
    3782. 

  3782.      ktf = MIN(kte,kde-1)
    3783. 

  3783. 

  3784.         do i=its,itf
    3785. 

  3785.          aa0(i)=0.
    3786. 

  3786.         enddo
    3787. 

  3787.         DO 100 k=kts+1,ktf
    3788. 

  3788.         DO 100 i=its,itf
    3789. 

  3789.          IF(ierr(i).ne.0)GO TO 100
    3790. 

  3790.          IF(K.LE.KBCON(I))GO TO 100
    3791. 

  3791.          IF(K.Gt.KTOP(I))GO TO 100
    3792. 

  3792.          DZ=Z(I,K)-Z(I,K-1)
    3793. 

  3793.          da=zu(i,k)*DZ*(9.81/(1004.*( &
    3794. 

  3794.                 (T_cup(I,K)))))*DBY(I,K-1)/ &
    3795. 

  3795.              (1.+GAMMA_CUP(I,K))
    3796. 

  3796.          IF(K.eq.KTOP(I).and.da.le.0.)go to 100
    3797. 

  3797.          AA0(I)=AA0(I)+da
    3798. 

  3798.          if(aa0(i).lt.0.)aa0(i)=0.
    3799. 

  3799. 100     continue
    3800. 

  3800. 

  3801.    END SUBROUTINE cup_up_aa0
    3802. 

  3802. 

  3803. 

  3804.    SUBROUTINE cup_up_he(k22,hkb,z_cup,cd,entr,he_cup,hc,     &
    3805. 

  3805.               kbcon,ierr,dby,he,hes_cup,                     &
    3806. 

  3806.               ids,ide, jds,jde, kds,kde,                     &
    3807. 

  3807.               ims,ime, jms,jme, kms,kme,                     &
    3808. 

  3808.               its,ite, jts,jte, kts,kte                     )
    3809. 

  3809. 

  3810.    IMPLICIT NONE
    3811. 

  3811. !
    3812. 

  3812. !  on input
    3813. 

  3813. !
    3814. 

  3814. 

  3815.    ! only local wrf dimensions are need as of now in this routine
    3816. 

  3816. 

  3817.      integer                                                           &
    3818. 

  3818.         ,intent (in   )                   ::                           &
    3819. 

  3819.                                   ids,ide, jds,jde, kds,kde,           &
    3820. 

  3820.                                   ims,ime, jms,jme, kms,kme,           &
    3821. 

  3821.                                   its,ite, jts,jte, kts,kte
    3822. 

  3822.   ! hc = cloud moist static energy
    3823. 

  3823.   ! hkb = moist static energy at originating level
    3824. 

  3824.   ! he = moist static energy on model levels
    3825. 

  3825.   ! he_cup = moist static energy on model cloud levels
    3826. 

  3826.   ! hes_cup = saturation moist static energy on model cloud levels
    3827. 

  3827.   ! dby = buoancy term
    3828. 

  3828.   ! cd= detrainment function 
    3829. 

  3829.   ! z_cup = heights of model cloud levels 
    3830. 

  3830.   ! entr = entrainment rate
    3831. 

  3831.   !
    3832. 

  3832.      real,    dimension (its:ite,kts:kte)                              &
    3833. 

  3833.         ,intent (in   )                   ::                           &
    3834. 

  3834.         he,he_cup,hes_cup,z_cup,cd
    3835. 

  3835.   ! entr= entrainment rate 
    3836. 

  3836.      real                                                              &
    3837. 

  3837.         ,intent (in   )                   ::                           &
    3838. 

  3838.         entr
    3839. 

  3839.      integer, dimension (its:ite)                                      &
    3840. 

  3840.         ,intent (in   )                   ::                           &
    3841. 

  3841.         kbcon,k22
    3842. 

  3842. !
    3843. 

  3843. ! input and output
    3844. 

  3844. !
    3845. 

  3845. 

  3846.    ! ierr error value, maybe modified in this routine
    3847. 

  3847. 

  3848.      integer, dimension (its:ite)                                      &
    3849. 

  3849.         ,intent (inout)                   ::                           &
    3850. 

  3850.         ierr
    3851. 

  3851. 

  3852.      real,    dimension (its:ite,kts:kte)                              &
    3853. 

  3853.         ,intent (out  )                   ::                           &
    3854. 

  3854.         hc,dby
    3855. 

  3855.      real,    dimension (its:ite)                                      &
    3856. 

  3856.         ,intent (out  )                   ::                           &
    3857. 

  3857.         hkb
    3858. 

  3858. !
    3859. 

  3859. !  local variables in this routine
    3860. 

  3860. !
    3861. 

  3861. 

  3862.      integer                              ::                           &
    3863. 

  3863.         i,k
    3864. 

  3864.      real                                 ::                           &
    3865. 

  3865.         dz
    3866. 

  3866. !
    3867. 

  3867.      integer :: itf, ktf
    3868. 

  3868. 

  3869.      itf = MIN(ite,ide-1)
    3870. 

  3870.      ktf = MIN(kte,kde-1)
    3871. 

  3871. !
    3872. 

  3872. !--- moist static energy inside cloud
    3873. 

  3873. !
    3874. 

  3874.       do i=its,itf
    3875. 

  3875.       if(ierr(i).eq.0.)then
    3876. 

  3876.       hkb(i)=he_cup(i,k22(i))
    3877. 

  3877.       do k=1,k22(i)
    3878. 

  3878.         hc(i,k)=he_cup(i,k)
    3879. 

  3879.         DBY(I,K)=0.
    3880. 

  3880.       enddo
    3881. 

  3881.       do k=k22(i),kbcon(i)-1
    3882. 

  3882.         hc(i,k)=hkb(i)
    3883. 

  3883.         DBY(I,K)=0.
    3884. 

  3884.       enddo
    3885. 

  3885.         k=kbcon(i)
    3886. 

  3886.         hc(i,k)=hkb(i)
    3887. 

  3887.         DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K)
    3888. 

  3888.       endif
    3889. 

  3889.       enddo
    3890. 

  3890.       do k=kts+1,ktf
    3891. 

  3891.       do i=its,itf
    3892. 

  3892.         if(k.gt.kbcon(i).and.ierr(i).eq.0.)then
    3893. 

  3893.            DZ=Z_cup(i,K)-Z_cup(i,K-1)
    3894. 

  3894.            HC(i,K)=(HC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* &
    3895. 

  3895.                 DZ*HE(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz)
    3896. 

  3896.            DBY(I,K)=HC(I,K)-HES_cup(I,K)
    3897. 

  3897.         endif
    3898. 

  3898.       enddo
    3899. 

  3899. 

  3900.       enddo
    3901. 

  3901. 

  3902.    END SUBROUTINE cup_up_he
    3903. 

  3903. 

  3904. 

  3905.    SUBROUTINE cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav,     &
    3906. 

  3906.               kbcon,ktop,cd,dby,mentr_rate,clw_all,          &
    3907. 

  3907.               q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl,          &
    3908. 

  3908.               ids,ide, jds,jde, kds,kde,                     &
    3909. 

  3909.               ims,ime, jms,jme, kms,kme,                     &
    3910. 

  3910.               its,ite, jts,jte, kts,kte                     )
    3911. 

  3911. 

  3912.    IMPLICIT NONE
    3913. 

  3913. !
    3914. 

  3914. !  on input
    3915. 

  3915. !
    3916. 

  3916. 

  3917.    ! only local wrf dimensions are need as of now in this routine
    3918. 

  3918. 

  3919.      integer                                                           &
    3920. 

  3920.         ,intent (in   )                   ::                           &
    3921. 

  3921.                                   ids,ide, jds,jde, kds,kde,           &
    3922. 

  3922.                                   ims,ime, jms,jme, kms,kme,           &
    3923. 

  3923.                                   its,ite, jts,jte, kts,kte
    3924. 

  3924.   ! cd= detrainment function 
    3925. 

  3925.   ! q = environmental q on model levels
    3926. 

  3926.   ! qe_cup = environmental q on model cloud levels
    3927. 

  3927.   ! qes_cup = saturation q on model cloud levels
    3928. 

  3928.   ! dby = buoancy term
    3929. 

  3929.   ! cd= detrainment function 
    3930. 

  3930.   ! zu = normalized updraft mass flux
    3931. 

  3931.   ! gamma_cup = gamma on model cloud levels
    3932. 

  3932.   ! mentr_rate = entrainment rate
    3933. 

  3933.   !
    3934. 

  3934.      real,    dimension (its:ite,kts:kte)                              &
    3935. 

  3935.         ,intent (in   )                   ::                           &
    3936. 

  3936.         q,zu,gamma_cup,qe_cup,dby,qes_cup,z_cup,cd
    3937. 

  3937.   ! entr= entrainment rate 
    3938. 

  3938.      real                                                              &
    3939. 

  3939.         ,intent (in   )                   ::                           &
    3940. 

  3940.         mentr_rate,xl
    3941. 

  3941.      integer, dimension (its:ite)                                      &
    3942. 

  3942.         ,intent (in   )                   ::                           &
    3943. 

  3943.         kbcon,ktop,k22
    3944. 

  3944. !
    3945. 

  3945. ! input and output
    3946. 

  3946. !
    3947. 

  3947. 

  3948.    ! ierr error value, maybe modified in this routine
    3949. 

  3949. 

  3950.      integer, dimension (its:ite)                                      &
    3951. 

  3951.         ,intent (inout)                   ::                           &
    3952. 

  3952.         ierr
    3953. 

  3953.    ! qc = cloud q (including liquid water) after entrainment
    3954. 

  3954.    ! qrch = saturation q in cloud
    3955. 

  3955.    ! qrc = liquid water content in cloud after rainout
    3956. 

  3956.    ! pw = condensate that will fall out at that level
    3957. 

  3957.    ! pwav = totan normalized integrated condensate (I1)
    3958. 

  3958.    ! c0 = conversion rate (cloud to rain)
    3959. 

  3959. 

  3960.      real,    dimension (its:ite,kts:kte)                              &
    3961. 

  3961.         ,intent (out  )                   ::                           &
    3962. 

  3962.         qc,qrc,pw,clw_all
    3963. 

  3963.      real,    dimension (its:ite)                                      &
    3964. 

  3964.         ,intent (out  )                   ::                           &
    3965. 

  3965.         pwav
    3966. 

  3966. !
    3967. 

  3967. !  local variables in this routine
    3968. 

  3968. !
    3969. 

  3969. 

  3970.      integer                              ::                           &
    3971. 

  3971.         iall,i,k
    3972. 

  3972.      real                                 ::                           &
    3973. 

  3973.         dh,qrch,c0,dz,radius
    3974. 

  3974. !
    3975. 

  3975.      integer :: itf, ktf
    3976. 

  3976. 

  3977.      itf = MIN(ite,ide-1)
    3978. 

  3978.      ktf = MIN(kte,kde-1)
    3979. 

  3979. 

  3980.         iall=0
    3981. 

  3981.         c0=.002
    3982. 

  3982. !
    3983. 

  3983. !--- no precip for small clouds
    3984. 

  3984. !
    3985. 

  3985.         if(mentr_rate.gt.0.)then
    3986. 

  3986.           radius=.2/mentr_rate
    3987. 

  3987.           if(radius.lt.900.)c0=0.
    3988. 

  3988. !         if(radius.lt.900.)iall=0
    3989. 

  3989.         endif
    3990. 

  3990.         do i=its,itf
    3991. 

  3991.           pwav(i)=0.
    3992. 

  3992.         enddo
    3993. 

  3993.         do k=kts,ktf
    3994. 

  3994.         do i=its,itf
    3995. 

  3995.           pw(i,k)=0.
    3996. 

  3996.           if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k)
    3997. 

  3997.           clw_all(i,k)=0.
    3998. 

  3998.           qrc(i,k)=0.
    3999. 

  3999.         enddo
    4000. 

  4000.         enddo
    4001. 

  4001.       do i=its,itf
    4002. 

  4002.       if(ierr(i).eq.0.)then
    4003. 

  4003.       do k=k22(i),kbcon(i)-1
    4004. 

  4004.         qc(i,k)=qe_cup(i,k22(i))
    4005. 

  4005.       enddo
    4006. 

  4006.       endif
    4007. 

  4007.       enddo
    4008. 

  4008. 

  4009.         DO 100 k=kts+1,ktf
    4010. 

  4010.         DO 100 i=its,itf
    4011. 

  4011.          IF(ierr(i).ne.0)GO TO 100
    4012. 

  4012.          IF(K.Lt.KBCON(I))GO TO 100
    4013. 

  4013.          IF(K.Gt.KTOP(I))GO TO 100
    4014. 

  4014.          DZ=Z_cup(i,K)-Z_cup(i,K-1)
    4015. 

  4015. !
    4016. 

  4016. !------    1. steady state plume equation, for what could
    4017. 

  4017. !------       be in cloud without condensation
    4018. 

  4018. !
    4019. 

  4019. !
    4020. 

  4020.         QC(i,K)=(QC(i,K-1)*(1.-.5*CD(i,K)*DZ)+mentr_rate* &
    4021. 

  4021.                 DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz)
    4022. 

  4022. !
    4023. 

  4023. !--- saturation  in cloud, this is what is allowed to be in it
    4024. 

  4024. !
    4025. 

  4025.          QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) &
    4026. 

  4026.               /(1.+GAMMA_cup(i,k)))*DBY(I,K)
    4027. 

  4027. !
    4028. 

  4028. !------- LIQUID WATER CONTENT IN cloud after rainout
    4029. 

  4029. !
    4030. 

  4030.         clw_all(i,k)=QC(I,K)-QRCH
    4031. 

  4031.         QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ*zu(i,k))
    4032. 

  4032.         if(qrc(i,k).lt.0.)then
    4033. 

  4033.           qrc(i,k)=0.
    4034. 

  4034.         endif
    4035. 

  4035. !
    4036. 

  4036. !-------   3.Condensation
    4037. 

  4037. !
    4038. 

  4038.          PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
    4039. 

  4039.         if(iall.eq.1)then
    4040. 

  4040.           qrc(i,k)=0.
    4041. 

  4041.           pw(i,k)=(QC(I,K)-QRCH)*zu(i,k)
    4042. 

  4042.           if(pw(i,k).lt.0.)pw(i,k)=0.
    4043. 

  4043.         endif
    4044. 

  4044. !
    4045. 

  4045. !----- set next level
    4046. 

  4046. !
    4047. 

  4047.          QC(I,K)=QRC(I,K)+qrch
    4048. 

  4048. !
    4049. 

  4049. !--- integrated normalized ondensate
    4050. 

  4050. !
    4051. 

  4051.          PWAV(I)=PWAV(I)+PW(I,K)
    4052. 

  4052.  100     CONTINUE
    4053. 

  4053. 

  4054.    END SUBROUTINE cup_up_moisture
    4055. 

  4055. 

  4056. 

  4057.    SUBROUTINE cup_up_nms(zu,z_cup,entr,cd,kbcon,ktop,ierr,k22,  &
    4058. 

  4058.               ids,ide, jds,jde, kds,kde,                        &
    4059. 

  4059.               ims,ime, jms,jme, kms,kme,                        &
    4060. 

  4060.               its,ite, jts,jte, kts,kte                        )
    4061. 

  4061. 

  4062.    IMPLICIT NONE
    4063. 

  4063. 

  4064. !
    4065. 

  4065. !  on input
    4066. 

  4066. !
    4067. 

  4067. 

  4068.    ! only local wrf dimensions are need as of now in this routine
    4069. 

  4069. 

  4070.      integer                                                           &
    4071. 

  4071.         ,intent (in   )                   ::                           &
    4072. 

  4072.          ids,ide, jds,jde, kds,kde,                                    &
    4073. 

  4073.          ims,ime, jms,jme, kms,kme,                                    &
    4074. 

  4074.          its,ite, jts,jte, kts,kte
    4075. 

  4075.   ! cd= detrainment function 
    4076. 

  4076.      real,    dimension (its:ite,kts:kte)                              &
    4077. 

  4077.         ,intent (in   )                   ::                           &
    4078. 

  4078.          z_cup,cd
    4079. 

  4079.   ! entr= entrainment rate 
    4080. 

  4080.      real                                                              &
    4081. 

  4081.         ,intent (in   )                   ::                           &
    4082. 

  4082.          entr
    4083. 

  4083.      integer, dimension (its:ite)                                      &
    4084. 

  4084.         ,intent (in   )                   ::                           &
    4085. 

  4085.          kbcon,ktop,k22
    4086. 

  4086. !
    4087. 

  4087. ! input and output
    4088. 

  4088. !
    4089. 

  4089. 

  4090.    ! ierr error value, maybe modified in this routine
    4091. 

  4091. 

  4092.      integer, dimension (its:ite)                                      &
    4093. 

  4093.         ,intent (inout)                   ::                           &
    4094. 

  4094.          ierr
    4095. 

  4095.    ! zu is the normalized mass flux
    4096. 

  4096. 

  4097.      real,    dimension (its:ite,kts:kte)                              &
    4098. 

  4098.         ,intent (out  )                   ::                           &
    4099. 

  4099.          zu
    4100. 

  4100. !
    4101. 

  4101. !  local variables in this routine
    4102. 

  4102. !
    4103. 

  4103. 

  4104.      integer                              ::                           &
    4105. 

  4105.          i,k
    4106. 

  4106.      real                                 ::                           &
    4107. 

  4107.          dz
    4108. 

  4108.      integer :: itf, ktf
    4109. 

  4109. 

  4110.      itf = MIN(ite,ide-1)
    4111. 

  4111.      ktf = MIN(kte,kde-1)
    4112. 

  4112. !
    4113. 

  4113. !   initialize for this go around
    4114. 

  4114. !
    4115. 

  4115.        do k=kts,ktf
    4116. 

  4116.        do i=its,itf
    4117. 

  4117.          zu(i,k)=0.
    4118. 

  4118.        enddo
    4119. 

  4119.        enddo
    4120. 

  4120. !
    4121. 

  4121. ! do normalized mass budget
    4122. 

  4122. !
    4123. 

  4123.        do i=its,itf
    4124. 

  4124.           IF(ierr(I).eq.0)then
    4125. 

  4125.              do k=k22(i),kbcon(i)
    4126. 

  4126.                zu(i,k)=1.
    4127. 

  4127.              enddo
    4128. 

  4128.              DO K=KBcon(i)+1,KTOP(i)
    4129. 

  4129.                DZ=Z_cup(i,K)-Z_cup(i,K-1)
    4130. 

  4130.                ZU(i,K)=ZU(i,K-1)*(1.+(entr-cd(i,k))*DZ)
    4131. 

  4131.              enddo
    4132. 

  4132.           endif
    4133. 

  4133.        enddo
    4134. 

  4134. 

  4135.    END SUBROUTINE cup_up_nms
    4136. 

  4136. 

  4137. !====================================================================
    4138. 

  4138.    SUBROUTINE gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,           &
    4139. 

  4139.                         MASS_FLUX,cp,restart,                       &
    4140. 

  4140.                         P_QC,P_QI,P_FIRST_SCALAR,                   &
    4141. 

  4141.                         RTHFTEN, RQVFTEN,                           &
    4142. 

  4142.                         APR_GR,APR_W,APR_MC,APR_ST,APR_AS,          &
    4143. 

  4143.                         APR_CAPMA,APR_CAPME,APR_CAPMI,              &
    4144. 

  4144.                         allowed_to_read,                            &
    4145. 

  4145.                         ids, ide, jds, jde, kds, kde,               &
    4146. 

  4146.                         ims, ime, jms, jme, kms, kme,               &
    4147. 

  4147.                         its, ite, jts, jte, kts, kte               )
    4148. 

  4148. !--------------------------------------------------------------------   
    4149. 

  4149.    IMPLICIT NONE
    4150. 

  4150. !--------------------------------------------------------------------
    4151. 

  4151.    LOGICAL , INTENT(IN)           ::  restart,allowed_to_read
    4152. 

  4152.    INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
    4153. 

  4153.                                       ims, ime, jms, jme, kms, kme, &
    4154. 

  4154.                                       its, ite, jts, jte, kts, kte
    4155. 

  4155.    INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
    4156. 

  4156.    REAL,     INTENT(IN)           ::  cp
    4157. 

  4157. 

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

  4159.                                                           RTHCUTEN, &
    4160. 

  4160.                                                           RQVCUTEN, &
    4161. 

  4161.                                                           RQCCUTEN, &
    4162. 

  4162.                                                           RQICUTEN   
    4163. 

  4163. 

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

  4165.                                                           RTHFTEN,  &
    4166. 

  4166.                                                           RQVFTEN
    4167. 

  4167. 

  4168.    REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::        &
    4169. 

  4169.                                 APR_GR,APR_W,APR_MC,APR_ST,APR_AS,  &
    4170. 

  4170.                                 APR_CAPMA,APR_CAPME,APR_CAPMI,      &
    4171. 

  4171.                                 MASS_FLUX
    4172. 

  4172. 

  4173.    INTEGER :: i, j, k, itf, jtf, ktf
    4174. 

  4174.  
    4175. 

  4175.    jtf=min0(jte,jde-1)
    4176. 

  4176.    ktf=min0(kte,kde-1)
    4177. 

  4177.    itf=min0(ite,ide-1)
    4178. 

  4178.  
    4179. 

  4179.    IF(.not.restart)THEN
    4180. 

  4180.      DO j=jts,jtf
    4181. 

  4181.      DO k=kts,ktf
    4182. 

  4182.      DO i=its,itf
    4183. 

  4183.         RTHCUTEN(i,k,j)=0.
    4184. 

  4184.         RQVCUTEN(i,k,j)=0.
    4185. 

  4185.      ENDDO
    4186. 

  4186.      ENDDO
    4187. 

  4187.      ENDDO
    4188. 

  4188. 

  4189.      DO j=jts,jtf
    4190. 

  4190.      DO k=kts,ktf
    4191. 

  4191.      DO i=its,itf
    4192. 

  4192.         RTHFTEN(i,k,j)=0.
    4193. 

  4193.         RQVFTEN(i,k,j)=0.
    4194. 

  4194.      ENDDO
    4195. 

  4195.      ENDDO
    4196. 

  4196.      ENDDO
    4197. 

  4197. 

  4198.      IF (P_QC .ge. P_FIRST_SCALAR) THEN
    4199. 

  4199.         DO j=jts,jtf
    4200. 

  4200.         DO k=kts,ktf
    4201. 

  4201.         DO i=its,itf
    4202. 

  4202.            RQCCUTEN(i,k,j)=0.
    4203. 

  4203.         ENDDO
    4204. 

  4204.         ENDDO
    4205. 

  4205.         ENDDO
    4206. 

  4206.      ENDIF
    4207. 

  4207. 

  4208.      IF (P_QI .ge. P_FIRST_SCALAR) THEN
    4209. 

  4209.         DO j=jts,jtf
    4210. 

  4210.         DO k=kts,ktf
    4211. 

  4211.         DO i=its,itf
    4212. 

  4212.            RQICUTEN(i,k,j)=0.
    4213. 

  4213.         ENDDO
    4214. 

  4214.         ENDDO
    4215. 

  4215.         ENDDO
    4216. 

  4216.      ENDIF
    4217. 

  4217. 

  4218.      DO j=jts,jtf
    4219. 

  4219.      DO i=its,itf
    4220. 

  4220.         mass_flux(i,j)=0.
    4221. 

  4221.      ENDDO
    4222. 

  4222.      ENDDO
    4223. 

  4223. 

  4224.    ENDIF
    4225. 

  4225.      DO j=jts,jtf
    4226. 

  4226.      DO i=its,itf
    4227. 

  4227.         APR_GR(i,j)=0.
    4228. 

  4228.         APR_ST(i,j)=0.
    4229. 

  4229.         APR_W(i,j)=0.
    4230. 

  4230.         APR_MC(i,j)=0.
    4231. 

  4231.         APR_AS(i,j)=0.
    4232. 

  4232.         APR_CAPMA(i,j)=0.
    4233. 

  4233.         APR_CAPME(i,j)=0.
    4234. 

  4234.         APR_CAPMI(i,j)=0.
    4235. 

  4235.      ENDDO
    4236. 

  4236.      ENDDO
    4237. 

  4237. 

  4238.    END SUBROUTINE gdinit
    4239. 

  4239. 

  4240. 

  4241.    SUBROUTINE massflx_stats(xf_ens,ensdim,maxens,maxens2,maxens3, &
    4242. 

  4242.               xt_ave,xt_std,xt_cur,xt_ske,j,ierr,itest,           &
    4243. 

  4243.               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                  &
    4244. 

  4244.               APR_CAPMA,APR_CAPME,APR_CAPMI,                      &
    4245. 

  4245.               pr_gr,pr_w,pr_mc,pr_st,pr_as,                       &
    4246. 

  4246.               pr_capma,pr_capme,pr_capmi,                         &
    4247. 

  4247.               ids,ide, jds,jde, kds,kde,  &
    4248. 

  4248.               ims,ime, jms,jme, kms,kme,  &
    4249. 

  4249.               its,ite, jts,jte, kts,kte)
    4250. 

  4250. 

  4251.    IMPLICIT NONE
    4252. 

  4252. 

  4253.    integer, intent (in   )              ::                                    &
    4254. 

  4254.                      j,ensdim,maxens3,maxens,maxens2,itest
    4255. 

  4255.    INTEGER,      INTENT(IN   ) ::                                             &
    4256. 

  4256.                                   ids,ide, jds,jde, kds,kde,                  &
    4257. 

  4257.                                   ims,ime, jms,jme, kms,kme,                  &
    4258. 

  4258.                                   its,ite, jts,jte, kts,kte
    4259. 

  4259. 

  4260. 

  4261.      real, dimension (its:ite)                                                &
    4262. 

  4262.          , intent(inout) ::                                                   &
    4263. 

  4263.            xt_ave,xt_cur,xt_std,xt_ske
    4264. 

  4264.      integer, dimension (its:ite), intent (in) ::                             &
    4265. 

  4265.            ierr
    4266. 

  4266.      real, dimension (ims:ime,jms:jme,1:ensdim)                               &
    4267. 

  4267.          , intent(in   ) ::                                                   &
    4268. 

  4268.            xf_ens
    4269. 

  4269.      real, dimension (ims:ime,jms:jme)                                        &
    4270. 

  4270.          , intent(inout) ::                                                   &
    4271. 

  4271.            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                                 &
    4272. 

  4272.            APR_CAPMA,APR_CAPME,APR_CAPMI
    4273. 

  4273.      real, dimension (its:ite,jts:jte)                                        &
    4274. 

  4274.          , intent(inout) ::                                                   &
    4275. 

  4275.            pr_gr,pr_w,pr_mc,pr_st,pr_as,                                      &
    4276. 

  4276.            pr_capma,pr_capme,pr_capmi
    4277. 

  4277. 

  4278. !
    4279. 

  4279. ! local stuff
    4280. 

  4280. !
    4281. 

  4281.      real, dimension (its:ite , 1:maxens3 )       ::                          &
    4282. 

  4282.            x_ave,x_cur,x_std,x_ske
    4283. 

  4283.      real, dimension (its:ite , 1:maxens  )       ::                          &
    4284. 

  4284.            x_ave_cap
    4285. 

  4285. 

  4286. 

  4287.       integer, dimension (1:maxens3) :: nc1
    4288. 

  4288.       integer :: i,k
    4289. 

  4289.       integer :: num,kk,num2,iedt
    4290. 

  4290.       real :: a3,a4
    4291. 

  4291. 

  4292.       num=ensdim/maxens3
    4293. 

  4293.       num2=ensdim/maxens
    4294. 

  4294.       if(itest.eq.1)then
    4295. 

  4295.       do i=its,ite
    4296. 

  4296.        pr_gr(i,j) =  0.
    4297. 

  4297.        pr_w(i,j) =  0.
    4298. 

  4298.        pr_mc(i,j) = 0.
    4299. 

  4299.        pr_st(i,j) = 0.
    4300. 

  4300.        pr_as(i,j) = 0.
    4301. 

  4301.        pr_capma(i,j) =  0.
    4302. 

  4302.        pr_capme(i,j) = 0.
    4303. 

  4303.        pr_capmi(i,j) = 0.
    4304. 

  4304.       enddo
    4305. 

  4305.       endif
    4306. 

  4306. 

  4307.       do k=1,maxens
    4308. 

  4308.       do i=its,ite
    4309. 

  4309.         x_ave_cap(i,k)=0.
    4310. 

  4310.       enddo
    4311. 

  4311.       enddo
    4312. 

  4312.       do k=1,maxens3
    4313. 

  4313.       do i=its,ite
    4314. 

  4314.         x_ave(i,k)=0.
    4315. 

  4315.         x_std(i,k)=0.
    4316. 

  4316.         x_ske(i,k)=0.
    4317. 

  4317.         x_cur(i,k)=0.
    4318. 

  4318.       enddo
    4319. 

  4319.       enddo
    4320. 

  4320.       do i=its,ite
    4321. 

  4321.         xt_ave(i)=0.
    4322. 

  4322.         xt_std(i)=0.
    4323. 

  4323.         xt_ske(i)=0.
    4324. 

  4324.         xt_cur(i)=0.
    4325. 

  4325.       enddo
    4326. 

  4326.       do kk=1,num
    4327. 

  4327.       do k=1,maxens3
    4328. 

  4328.       do i=its,ite
    4329. 

  4329.         if(ierr(i).eq.0)then
    4330. 

  4330.         x_ave(i,k)=x_ave(i,k)+xf_ens(i,j,maxens3*(kk-1)+k)
    4331. 

  4331.         endif
    4332. 

  4332.       enddo
    4333. 

  4333.       enddo
    4334. 

  4334.       enddo
    4335. 

  4335.       do iedt=1,maxens2
    4336. 

  4336.       do k=1,maxens
    4337. 

  4337.       do kk=1,maxens3
    4338. 

  4338.       do i=its,ite
    4339. 

  4339.         if(ierr(i).eq.0)then
    4340. 

  4340.         x_ave_cap(i,k)=x_ave_cap(i,k)                               &
    4341. 

  4341.             +xf_ens(i,j,maxens3*(k-1)+(iedt-1)*maxens*maxens3+kk)
    4342. 

  4342.         endif
    4343. 

  4343.       enddo
    4344. 

  4344.       enddo
    4345. 

  4345.       enddo
    4346. 

  4346.       enddo
    4347. 

  4347.       do k=1,maxens
    4348. 

  4348.       do i=its,ite
    4349. 

  4349.         if(ierr(i).eq.0)then
    4350. 

  4350.         x_ave_cap(i,k)=x_ave_cap(i,k)/float(num2)
    4351. 

  4351.         endif
    4352. 

  4352.       enddo
    4353. 

  4353.       enddo
    4354. 

  4354. 

  4355.       do k=1,maxens3
    4356. 

  4356.       do i=its,ite
    4357. 

  4357.         if(ierr(i).eq.0)then
    4358. 

  4358.         x_ave(i,k)=x_ave(i,k)/float(num)
    4359. 

  4359.         endif
    4360. 

  4360.       enddo
    4361. 

  4361.       enddo
    4362. 

  4362.       do k=1,maxens3
    4363. 

  4363.       do i=its,ite
    4364. 

  4364.         if(ierr(i).eq.0)then
    4365. 

  4365.         xt_ave(i)=xt_ave(i)+x_ave(i,k)
    4366. 

  4366.         endif
    4367. 

  4367.       enddo
    4368. 

  4368.       enddo
    4369. 

  4369.       do i=its,ite
    4370. 

  4370.         if(ierr(i).eq.0)then
    4371. 

  4371.         xt_ave(i)=xt_ave(i)/float(maxens3)
    4372. 

  4372.         endif
    4373. 

  4373.       enddo
    4374. 

  4374. !
    4375. 

  4375. !--- now do std, skewness,curtosis
    4376. 

  4376. !
    4377. 

  4377.       do kk=1,num
    4378. 

  4378.       do k=1,maxens3
    4379. 

  4379.       do i=its,ite
    4380. 

  4380.         if(ierr(i).eq.0.and.x_ave(i,k).gt.0.)then
    4381. 

  4381. !       print *,i,j,k,kk,x_std(i,k),xf_ens(i,j,maxens3*(kk-1)+k),x_ave(i,k)
    4382. 

  4382.         x_std(i,k)=x_std(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**2
    4383. 

  4383.         x_ske(i,k)=x_ske(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**3
    4384. 

  4384.         x_cur(i,k)=x_cur(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**4
    4385. 

  4385.         endif
    4386. 

  4386.       enddo
    4387. 

  4387.       enddo
    4388. 

  4388.       enddo
    4389. 

  4389.       do k=1,maxens3
    4390. 

  4390.       do i=its,ite
    4391. 

  4391.         if(ierr(i).eq.0.and.xt_ave(i).gt.0.)then
    4392. 

  4392.         xt_std(i)=xt_std(i)+(x_ave(i,k)-xt_ave(i))**2
    4393. 

  4393.         xt_ske(i)=xt_ske(i)+(x_ave(i,k)-xt_ave(i))**3
    4394. 

  4394.         xt_cur(i)=xt_cur(i)+(x_ave(i,k)-xt_ave(i))**4
    4395. 

  4395.         endif
    4396. 

  4396.       enddo
    4397. 

  4397.       enddo
    4398. 

  4398.       do k=1,maxens3
    4399. 

  4399.       do i=its,ite
    4400. 

  4400.         if(ierr(i).eq.0.and.x_std(i,k).gt.0.)then
    4401. 

  4401.            x_std(i,k)=x_std(i,k)/float(num)
    4402. 

  4402.            a3=max(1.e-6,x_std(i,k))
    4403. 

  4403.            x_std(i,k)=sqrt(a3)
    4404. 

  4404.            a3=max(1.e-6,x_std(i,k)**3)
    4405. 

  4405.            a4=max(1.e-6,x_std(i,k)**4)
    4406. 

  4406.            x_ske(i,k)=x_ske(i,k)/float(num)/a3
    4407. 

  4407.            x_cur(i,k)=x_cur(i,k)/float(num)/a4
    4408. 

  4408.         endif
    4409. 

  4409. !       print*,'                               '
    4410. 

  4410. !       print*,'Some statistics at gridpoint i,j, ierr',i,j,ierr(i)
    4411. 

  4411. !       print*,'statistics for closure number ',k
    4412. 

  4412. !       print*,'Average= ',x_ave(i,k),'  Std= ',x_std(i,k)
    4413. 

  4413. !       print*,'Skewness= ',x_ske(i,k),' Curtosis= ',x_cur(i,k)
    4414. 

  4414. !       print*,'                               '
    4415. 

  4415. 

  4416.       enddo
    4417. 

  4417.       enddo
    4418. 

  4418.       do i=its,ite
    4419. 

  4419.         if(ierr(i).eq.0.and.xt_std(i).gt.0.)then
    4420. 

  4420.            xt_std(i)=xt_std(i)/float(maxens3)
    4421. 

  4421.            a3=max(1.e-6,xt_std(i))
    4422. 

  4422.            xt_std(i)=sqrt(a3)
    4423. 

  4423.            a3=max(1.e-6,xt_std(i)**3)
    4424. 

  4424.            a4=max(1.e-6,xt_std(i)**4)
    4425. 

  4425.            xt_ske(i)=xt_ske(i)/float(maxens3)/a3
    4426. 

  4426.            xt_cur(i)=xt_cur(i)/float(maxens3)/a4
    4427. 

  4427. !       print*,'                               '
    4428. 

  4428. !       print*,'Total ensemble independent statistics at i =',i
    4429. 

  4429. !       print*,'Average= ',xt_ave(i),'  Std= ',xt_std(i)
    4430. 

  4430. !       print*,'Skewness= ',xt_ske(i),' Curtosis= ',xt_cur(i)
    4431. 

  4431. !       print*,'                               '
    4432. 

  4432. !
    4433. 

  4433. !  first go around: store massflx for different closures/caps
    4434. 

  4434. !
    4435. 

  4435.       if(itest.eq.1)then
    4436. 

  4436.        pr_gr(i,j) = .333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3))
    4437. 

  4437.        pr_w(i,j) = .333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6))
    4438. 

  4438.        pr_mc(i,j) = .333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9))
    4439. 

  4439.        pr_st(i,j) = .333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))
    4440. 

  4440.        pr_as(i,j) = .25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15) &
    4441. 

  4441.                      + x_ave(i,16))
    4442. 

  4442.        pr_capma(i,j) = x_ave_cap(i,1)
    4443. 

  4443.        pr_capme(i,j) = x_ave_cap(i,2)
    4444. 

  4444.        pr_capmi(i,j) = x_ave_cap(i,3)
    4445. 

  4445. !
    4446. 

  4446. !  second go around: store preciprates (mm/hour) for different closures/caps
    4447. 

  4447. !
    4448. 

  4448.         else if (itest.eq.2)then
    4449. 

  4449.        APR_GR(i,j)=.333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3))*      &
    4450. 

  4450.                   3600.*pr_gr(i,j) +APR_GR(i,j)
    4451. 

  4451.        APR_W(i,j)=.333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6))*       &
    4452. 

  4452.                   3600.*pr_w(i,j) +APR_W(i,j)
    4453. 

  4453.        APR_MC(i,j)=.333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9))*      &
    4454. 

  4454.                   3600.*pr_mc(i,j) +APR_MC(i,j)
    4455. 

  4455.        APR_ST(i,j)=.333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))*   &
    4456. 

  4456.                   3600.*pr_st(i,j) +APR_ST(i,j)
    4457. 

  4457.        APR_AS(i,j)=.25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15)      &
    4458. 

  4458.                            + x_ave(i,16))*                       &
    4459. 

  4459.                   3600.*pr_as(i,j) +APR_AS(i,j)
    4460. 

  4460.        APR_CAPMA(i,j) = x_ave_cap(i,1)*                          &
    4461. 

  4461.                   3600.*pr_capma(i,j) +APR_CAPMA(i,j)
    4462. 

  4462.        APR_CAPME(i,j) = x_ave_cap(i,2)*                          &
    4463. 

  4463.                   3600.*pr_capme(i,j) +APR_CAPME(i,j)
    4464. 

  4464.        APR_CAPMI(i,j) = x_ave_cap(i,3)*                          &
    4465. 

  4465.                   3600.*pr_capmi(i,j) +APR_CAPMI(i,j)
    4466. 

  4466.         endif
    4467. 

  4467.         endif
    4468. 

  4468.       enddo
    4469. 

  4469. 

  4470.    END SUBROUTINE massflx_stats
    4471. 

  4471. 

  4472. 

  4473.    SUBROUTINE neg_check(dt,q,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
    4474. 

  4474. 

  4475.    INTEGER,      INTENT(IN   ) ::            its,ite,kts,kte,itf,ktf
    4476. 

  4476. 

  4477.      real, dimension (its:ite,kts:kte  )                    ,                 &
    4478. 

  4478.       intent(inout   ) ::                                                     &
    4479. 

  4479.        q,outq,outt,outqc
    4480. 

  4480.      real, dimension (its:ite  )                            ,                 &
    4481. 

  4481.       intent(inout   ) ::                                                     &
    4482. 

  4482.        pret
    4483. 

  4483.      real                                                                     &
    4484. 

  4484.         ,intent (in  )                   ::                                   &
    4485. 

  4485.         dt
    4486. 

  4486.      real :: thresh,qmem,qmemf,qmem2,qtest,qmem1
    4487. 

  4487. !
    4488. 

  4488. ! first do check on vertical heating rate
    4489. 

  4489. !
    4490. 

  4490.       thresh=200.01
    4491. 

  4491.       do i=its,itf
    4492. 

  4492.       qmemf=1.
    4493. 

  4493.       qmem=0.
    4494. 

  4494.       do k=kts,ktf
    4495. 

  4495.          qmem=outt(i,k)*86400.
    4496. 

  4496.          if(qmem.gt.2.*thresh)then
    4497. 

  4497.            qmem2=2.*thresh/qmem
    4498. 

  4498.            qmemf=min(qmemf,qmem2)
    4499. 

  4499. !
    4500. 

  4500. !
    4501. 

  4501. !          print *,'1',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf
    4502. 

  4502.          endif
    4503. 

  4503.          if(qmem.lt.-thresh)then
    4504. 

  4504.            qmem2=-thresh/qmem
    4505. 

  4505.            qmemf=min(qmemf,qmem2)
    4506. 

  4506. !
    4507. 

  4507. !
    4508. 

  4508. !          print *,'2',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf
    4509. 

  4509.          endif
    4510. 

  4510.       enddo
    4511. 

  4511.       do k=kts,ktf
    4512. 

  4512.          outq(i,k)=outq(i,k)*qmemf
    4513. 

  4513.          outt(i,k)=outt(i,k)*qmemf
    4514. 

  4514.          outqc(i,k)=outqc(i,k)*qmemf
    4515. 

  4515.       enddo
    4516. 

  4516.       pret(i)=pret(i)*qmemf 
    4517. 

  4517.       enddo
    4518. 

  4518. !
    4519. 

  4519. ! check whether routine produces negative q's. This can happen, since 
    4520. 

  4520. ! tendencies are calculated based on forced q's. This should have no
    4521. 

  4521. ! influence on conservation properties, it scales linear through all
    4522. 

  4522. ! tendencies
    4523. 

  4523. !
    4524. 

  4524.       thresh=1.e-10
    4525. 

  4525.       do i=its,itf
    4526. 

  4526.       qmemf=1.
    4527. 

  4527.       do k=kts,ktf
    4528. 

  4528.          qmem=outq(i,k)
    4529. 

  4529.          if(abs(qmem).gt.0.)then
    4530. 

  4530.          qtest=q(i,k)+outq(i,k)*dt
    4531. 

  4531.          if(qtest.lt.thresh)then
    4532. 

  4532. !
    4533. 

  4533. ! qmem2 would be the maximum allowable tendency
    4534. 

  4534. !
    4535. 

  4535.            qmem1=outq(i,k)
    4536. 

  4536.            qmem2=(thresh-q(i,k))/dt
    4537. 

  4537.            qmemf=min(qmemf,qmem2/qmem1)
    4538. 

  4538. !          qmemf=max(0.,qmemf)
    4539. 

  4539. !          print *,'4 adjusted tendencies ',i,k,qmem,qmem2,qmemf
    4540. 

  4540.          endif
    4541. 

  4541.          endif
    4542. 

  4542.       enddo
    4543. 

  4543.       do k=kts,ktf
    4544. 

  4544.          outq(i,k)=outq(i,k)*qmemf
    4545. 

  4545.          outt(i,k)=outt(i,k)*qmemf
    4546. 

  4546.          outqc(i,k)=outqc(i,k)*qmemf
    4547. 

  4547.       enddo
    4548. 

  4548.       pret(i)=pret(i)*qmemf 
    4549. 

  4549.       enddo
    4550. 

  4550. 

  4551.    END SUBROUTINE neg_check
    4552. 

  4552. 

  4553. 

  4554. !-------------------------------------------------------
    4555. 

  4555. END MODULE module_cu_gd
    4556. 

  4556.