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

/wrfv2_fire/phys/module_mp_gsfcgce.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 2838 lines | 1694 code | 322 blank | 822 comment | 147 complexity | 4686bc158b95f5e42c5d6615ed17ee47 MD5 | raw file
Possible License(s): AGPL-1.0

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

    

  1. !WRF:MODEL_LAYER:PHYSICS
    2. 

  2. !
    3. 

  3. 

  4. MODULE module_mp_gsfcgce
    5. 

  5. 

  6.    USE     module_wrf_error
    7. 

  7. 

  8. !JJS 1/3/2008     vvvvv
    9. 

  9. 

  10. !  common /bt/
    11. 

  11.    REAL,    PRIVATE ::          rd1,  rd2,   al,   cp
    12. 

  12. 

  13. !  common /cont/
    14. 

  14.    REAL,    PRIVATE ::          c38, c358, c610, c149, &
    15. 

  15.                                c879, c172, c409,  c76, &
    16. 

  16.                                c218, c580, c141
    17. 

  17. !  common /b3cs/
    18. 

  18.    REAL,    PRIVATE ::           ag,   bg,   as,   bs, &
    19. 

  19.                                  aw,   bw,  bgh,  bgq, &
    20. 

  20.                                 bsh,  bsq,  bwh,  bwq
    21. 

  21. 

  22. !  common /size/
    23. 

  23.    REAL,    PRIVATE ::          tnw,  tns,  tng,       &
    24. 

  24.                                roqs, roqg, roqr
    25. 

  25. 

  26. !  common /bterv/
    27. 

  27.    REAL,    PRIVATE ::          zrc,  zgc,  zsc,       &
    28. 

  28.                                 vrc,  vgc,  vsc
    29. 

  29. 

  30. !  common /bsnw/
    31. 

  31.    REAL,    PRIVATE ::          alv,  alf,  als,   t0,   t00,     &
    32. 

  32.                                 avc,  afc,  asc,  rn1,  bnd1,     &
    33. 

  33.                                 rn2, bnd2,  rn3,  rn4,   rn5,     &
    34. 

  34.                                 rn6,  rn7,  rn8,  rn9,  rn10,     &
    35. 

  35.                               rn101,rn10a, rn11,rn11a,  rn12
    36. 

  36. 

  37.    REAL,    PRIVATE ::         rn14, rn15,rn15a, rn16,  rn17,     &
    38. 

  38.                               rn17a,rn17b,rn17c, rn18, rn18a,     &
    39. 

  39.                                rn19,rn19a,rn19b, rn20, rn20a,     &
    40. 

  40.                               rn20b, bnd3, rn21, rn22,  rn23,     &
    41. 

  41.                               rn23a,rn23b, rn25,rn30a, rn30b,     &
    42. 

  42.                               rn30c, rn31, beta, rn32
    43. 

  43. 

  44.    REAL,    PRIVATE, DIMENSION( 31 ) ::    rn12a, rn12b, rn13, rn25a
    45. 

  45. 

  46. !  common /rsnw1/
    47. 

  47.    REAL,    PRIVATE ::         rn10b, rn10c, rnn191, rnn192,  rn30,     &
    48. 

  48.                              rnn30a,  rn33,  rn331,  rn332
    49. 

  49. 

  50. !
    51. 

  51.    REAL,    PRIVATE, DIMENSION( 31 )  ::      aa1,  aa2
    52. 

  52.    DATA aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5,     &
    53. 

  53.            .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6,     &
    54. 

  54.            .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4,     &
    55. 

  55.            .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6,     &
    56. 

  56.            .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6,     &
    57. 

  57.            .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6,     &
    58. 

  58.            .4834e-6/
    59. 

  59.    DATA aa2/.4006, .4831, .5320, .5307, .5319,      &
    60. 

  60.            .5249, .4888, .3894, .4047, .4318,      &
    61. 

  61.            .4771, .5183, .5463, .5651, .5813,      &
    62. 

  62.            .5655, .5478, .5203, .4906, .4447,      &
    63. 

  63.            .4126, .3960, .4149, .4320, .4506,      &
    64. 

  64.            .4483, .4460, .4433, .4413, .4382,      &
    65. 

  65.            .4361/
    66. 

  66. 

  67. !JJS 1/3/2008     ^^^^^
    68. 

  68. 

  69. CONTAINS
    70. 

  70. 

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

  72. !  NASA/GSFC GCE
    73. 

  73. !  Tao et al, 2001, Meteo. & Atmos. Phy., 97-137
    74. 

  74. !-------------------------------------------------------------------
    75. 

  75. !  SUBROUTINE gsfcgce(  th, th_old,                                 &
    76. 

  76.   SUBROUTINE gsfcgce(  th,                                         &
    77. 

  77.                        qv, ql,                                     &
    78. 

  78.                        qr, qi,                                     &
    79. 

  79.                        qs,                                         &
    80. 

  80. !                       qvold, qlold,                               &
    81. 

  81. !                       qrold, qiold,                               &
    82. 

  82. !                       qsold,                                      &
    83. 

  83.                        rho, pii, p, dt_in, z,                      &
    84. 

  84.                        ht, dz8w, grav,                             &
    85. 

  85.                        rhowater, rhosnow,                          &
    86. 

  86.                        itimestep,                                  &
    87. 

  87.                        ids,ide, jds,jde, kds,kde,                  & ! domain dims
    88. 

  88.                        ims,ime, jms,jme, kms,kme,                  & ! memory dims
    89. 

  89.                        its,ite, jts,jte, kts,kte,                  & ! tile   dims
    90. 

  90.                        rainnc, rainncv,                            &
    91. 

  91.                        snownc, snowncv, sr,                        &
    92. 

  92.                        graupelnc, graupelncv,                      &
    93. 

  93. !                       f_qg, qg, pgold,                            &
    94. 

  94.                        f_qg, qg,                                   &
    95. 

  95.                        ihail, ice2                                 &
    96. 

  96.                                                                    )
    97. 

  97. 

  98. !-------------------------------------------------------------------
    99. 

  99.   IMPLICIT NONE
    100. 

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

  101. !
    102. 

  102. ! JJS 2/15/2005
    103. 

  103. !
    104. 

  104.   INTEGER,      INTENT(IN   )    ::   ids,ide, jds,jde, kds,kde , &
    105. 

  105.                                       ims,ime, jms,jme, kms,kme , &
    106. 

  106.                                       its,ite, jts,jte, kts,kte 
    107. 

  107.   INTEGER,      INTENT(IN   )    ::   itimestep, ihail, ice2 
    108. 

  108. 

  109.   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
    110. 

  110.         INTENT(INOUT) ::                                          &
    111. 

  111.                                                               th, &
    112. 

  112.                                                               qv, &
    113. 

  113.                                                               ql, &
    114. 

  114.                                                               qr, &
    115. 

  115.                                                               qi, &
    116. 

  116.                                                               qs, &
    117. 

  117.                                                               qg
    118. 

  118. !
    119. 

  119.   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
    120. 

  120.         INTENT(IN   ) ::                                          &
    121. 

  121. !                                                         th_old, &
    122. 

  122. !                                                          qvold, &
    123. 

  123. !                                                          qlold, &
    124. 

  124. !                                                          qrold, &
    125. 

  125. !                                                          qiold, &
    126. 

  126. !                                                          qsold, &
    127. 

  127. !                                                          qgold, &
    128. 

  128.                                                              rho, &
    129. 

  129.                                                              pii, &
    130. 

  130.                                                                p, &
    131. 

  131.                                                             dz8w, &
    132. 

  132.                                                                z
    133. 

  133. 

  134.   REAL, DIMENSION( ims:ime , jms:jme ),                           &
    135. 

  135.         INTENT(INOUT) ::                               rainnc,    &
    136. 

  136.                                                        rainncv,   &
    137. 

  137.                                                        snownc,    &   
    138. 

  138.                                                        snowncv,   &
    139. 

  139.                                                        sr,        &
    140. 

  140.                                                        graupelnc, &
    141. 

  141.                                                        graupelncv 
    142. 

  142. 

  143.   REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::       ht
    144. 

  144. 

  145.   REAL, INTENT(IN   ) ::                                   dt_in, &
    146. 

  146.                                                             grav, &
    147. 

  147.                                                         rhowater, &
    148. 

  148.                                                          rhosnow
    149. 

  149. 

  150.   LOGICAL, INTENT(IN), OPTIONAL :: F_QG
    151. 

  151. 

  152. !  LOCAL VAR
    153. 

  153. 

  154. 

  155. !jjs  INTEGER             ::                            min_q, max_q
    156. 

  156. 

  157. !jjs  REAL, DIMENSION( its:ite , jts:jte )                            &
    158. 

  158. !jjs                               ::        rain, snow, graupel,ice
    159. 

  159. 

  160. !
    161. 

  161. !  INTEGER :: IHAIL, itaobraun, ice2, istatmin, new_ice_sat, id
    162. 

  162.   INTEGER ::  itaobraun, istatmin, new_ice_sat, id
    163. 

  163. 

  164.   INTEGER :: i, j, k
    165. 

  165.   INTEGER :: iskip, ih, icount, ibud, i24h 
    166. 

  166.   REAL    :: hour
    167. 

  167.   REAL    , PARAMETER :: cmin=1.e-20
    168. 

  168.   REAL    :: dth, dqv, dqrest, dqall, dqall1, rhotot, a1, a2 
    169. 

  169. !  REAL, DIMENSION( its:ite , kts:kte , jts:jte ) ::                   &
    170. 

  170. !                         th1, qv1, ql1, qr1, qi1, qs1, qg1
    171. 

  171.  
    172. 

  172.   LOGICAL :: flag_qg
    173. 

  173. 

  174. !
    175. 

  175. !c  ihail = 0    for graupel, for tropical region
    176. 

  176. !c  ihail = 1    for hail, for mid-lat region
    177. 

  177. 

  178. ! itaobraun: 0 for Tao's constantis, 1 for Braun's constants
    179. 

  179. !c        if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23;   cn0=1.e-6
    180. 

  180. !c        if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30;    cn0=1.e-8
    181. 

  181.    itaobraun = 1
    182. 

  182. 

  183. !c  ice2 = 0    for 3 ice --- ice, snow and graupel/hail
    184. 

  184. !c  ice2 = 1    for 2 ice --- ice and snow only
    185. 

  185. !c  ice2 = 2    for 2 ice --- ice and graupel only, use ihail = 0 only
    186. 

  186. !c  ice2 = 3    for 0 ice --- no ice, warm only
    187. 

  187. 

  188. !  if (ice2 .eq. 2) ihail = 0
    189. 

  189. 

  190.   i24h=nint(86400./dt_in)
    191. 

  191.   if (mod(itimestep,i24h).eq.1) then
    192. 

  192.      write(6,*) 'ihail=',ihail,'  ice2=',ice2
    193. 

  193.      if (ice2.eq.0) then
    194. 

  194.         write(6,*) 'Running 3-ice scheme in GSFCGCE with'
    195. 

  195.         if (ihail.eq.0) then 
    196. 

  196.            write(6,*) '     ice, snow and graupel'
    197. 

  197.         else if (ihail.eq.1) then
    198. 

  198.                 write(6,*) '     ice, snow and hail'
    199. 

  199.         else
    200. 

  200.              write(6,*) 'ihail has to be either 1 or 0'
    201. 

  201.              stop
    202. 

  202.         endif !ihail
    203. 

  203.      else if (ice2.eq.1) then
    204. 

  204.              write(6,*) 'Running 2-ice scheme in GSFCGCE with'
    205. 

  205.              write(6,*) '     ice and snow'
    206. 

  206.      else if (ice2.eq.2) then
    207. 

  207.              write(6,*) 'Running 2-ice scheme in GSFCGCE with'
    208. 

  208.              write(6,*) '     ice and graupel'
    209. 

  209.      else if (ice2.eq.3) then
    210. 

  210.              write(6,*) 'Running warm rain only scheme in GSFCGCE without any ice'
    211. 

  211.      else
    212. 

  212.              write(6,*) 'gsfcgce_2ice in namelist.input has to be 0, 1, 2, or 3'
    213. 

  213.              stop
    214. 

  214.      endif !ice2
    215. 

  215.   endif !itimestep
    216. 

  216. 

  217. !c  new_ice_sat = 0, 1 or 2 
    218. 

  218.     new_ice_sat = 2 
    219. 

  219. 

  220. !c istatmin
    221. 

  221.     istatmin = 180
    222. 

  222. 

  223. !c id = 0  without in-line staticstics
    224. 

  224. !c id = 1  with in-line staticstics
    225. 

  225.     id = 0
    226. 

  226. 

  227. !c ibud = 0 no calculation of dth, dqv, dqrest and dqall
    228. 

  228. !c ibud = 1 yes
    229. 

  229.     ibud = 0
    230. 

  230. 

  231. !jjs   dt=dt_in
    232. 

  232. !jjs   rhoe_s=1.29
    233. 

  233. !
    234. 

  234. !   IF (P_QI .lt. P_FIRST_SCALAR .or. P_QS .lt. P_FIRST_SCALAR) THEN
    235. 

  235. !      CALL wrf_error_fatal3 ( "module_mp_lin.b" , 130 ,  'module_mp_lin: Improper use of Lin et al scheme; no ice phase. Please chose another one.')
    236. 

  236. !   ENDIF
    237. 

  237. 

  238. ! calculte fallflux and precipiation in MKS system
    239. 

  239. 

  240.    call fall_flux(dt_in, qr, qi, qs, qg, p,                   &
    241. 

  241.                       rho, z, dz8w, ht, rainnc,               &
    242. 

  242.                       rainncv, grav,itimestep,                &
    243. 

  243.                       rhowater, rhosnow,                      &
    244. 

  244.                       snownc, snowncv, sr,                    &
    245. 

  245.                       graupelnc, graupelncv,                  &
    246. 

  246.                       ihail, ice2,                            &
    247. 

  247.                       ims,ime, jms,jme, kms,kme,              & ! memory dims
    248. 

  248.                       its,ite, jts,jte, kts,kte               ) ! tile   dims
    249. 

  249. !-----------------------------------------------------------------------
    250. 

  250. 

  251. !c  set up constants used internally in GCE
    252. 

  252. 

  253.    call consat_s (ihail, itaobraun)
    254. 

  254. 

  255. 

  256. !c Negative values correction
    257. 

  257. 

  258.    iskip = 1
    259. 

  259.  
    260. 

  260.    if (iskip.eq.0) then
    261. 

  261.       call negcor(qv,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    262. 

  262.                            itimestep,1,             &
    263. 

  263.                            its,ite,jts,jte,kts,kte)
    264. 

  264.       call negcor(ql,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    265. 

  265.                            itimestep,2,             &
    266. 

  266.                            its,ite,jts,jte,kts,kte)
    267. 

  267.       call negcor(qr,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    268. 

  268.                            itimestep,3,             &
    269. 

  269.                            its,ite,jts,jte,kts,kte)
    270. 

  270.       call negcor(qi,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    271. 

  271.                            itimestep,4,             &
    272. 

  272.                            its,ite,jts,jte,kts,kte)
    273. 

  273.       call negcor(qs,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    274. 

  274.                            itimestep,5,             &
    275. 

  275.                            its,ite,jts,jte,kts,kte)
    276. 

  276.       call negcor(qg,rho,dz8w,ims,ime,jms,jme,kms,kme, &
    277. 

  277.                            itimestep,6,             &
    278. 

  278.                            its,ite,jts,jte,kts,kte)
    279. 

  279. !   else if (mod(itimestep,i24h).eq.1) then
    280. 

  280. !      print *,'no neg correction in mp at timestep=',itimestep
    281. 

  281.    endif ! iskip
    282. 

  282. 

  283. !c microphysics in GCE
    284. 

  284. 

  285.    call SATICEL_S( dt_in, IHAIL, itaobraun, ICE2, istatmin,     &
    286. 

  286.                    new_ice_sat, id,                             &
    287. 

  287. !                   th, th_old, qv, ql, qr,                      &
    288. 

  288.                    th, qv, ql, qr,                      &
    289. 

  289.                    qi, qs, qg,                                  &
    290. 

  290. !                   qvold, qlold, qrold,                         &
    291. 

  291. !                   qiold, qsold, qgold,                         &
    292. 

  292.                    rho, pii, p, itimestep,                      & 
    293. 

  293.                    ids,ide, jds,jde, kds,kde,                   & ! domain dims
    294. 

  294.                    ims,ime, jms,jme, kms,kme,                   & ! memory dims
    295. 

  295.                    its,ite, jts,jte, kts,kte                    & ! tile   dims
    296. 

  296.                                                                 ) 
    297. 

  297. 

  298.    END SUBROUTINE gsfcgce
    299. 

  299. 

  300. !-----------------------------------------------------------------------
    301. 

  301.    SUBROUTINE fall_flux ( dt, qr, qi, qs, qg, p,              &
    302. 

  302.                       rho, z, dz8w, topo, rainnc,             &
    303. 

  303.                       rainncv, grav, itimestep,               &
    304. 

  304.                       rhowater, rhosnow,                      &
    305. 

  305.                       snownc, snowncv, sr,                    &
    306. 

  306.                       graupelnc, graupelncv,                  &
    307. 

  307.                       ihail, ice2,                            &
    308. 

  308.                       ims,ime, jms,jme, kms,kme,              & ! memory dims
    309. 

  309.                       its,ite, jts,jte, kts,kte               ) ! tile   dims
    310. 

  310. !-----------------------------------------------------------------------
    311. 

  311. ! adopted from Jiun-Dar Chern's codes for Purdue Regional Model
    312. 

  312. ! adopted by Jainn J. Shi, 6/10/2005
    313. 

  313. !-----------------------------------------------------------------------
    314. 

  314. 

  315.   IMPLICIT NONE
    316. 

  316.   INTEGER, INTENT(IN   )               :: ihail, ice2,                &
    317. 

  317.                                           ims,ime, jms,jme, kms,kme,  &
    318. 

  318.                                           its,ite, jts,jte, kts,kte 
    319. 

  319.   INTEGER, INTENT(IN   )               :: itimestep
    320. 

  320.   REAL,    DIMENSION( ims:ime , kms:kme , jms:jme ),                  &
    321. 

  321.            INTENT(INOUT)               :: qr, qi, qs, qg       
    322. 

  322.   REAL,    DIMENSION( ims:ime , jms:jme ),                            &
    323. 

  323.            INTENT(INOUT)               :: rainnc, rainncv,            &
    324. 

  324.                                           snownc, snowncv, sr,        &
    325. 

  325.                                           graupelnc, graupelncv
    326. 

  326.   REAL,    DIMENSION( ims:ime , kms:kme , jms:jme ),                  &
    327. 

  327.            INTENT(IN   )               :: rho, z, dz8w, p     
    328. 

  328. 

  329.   REAL,    INTENT(IN   )               :: dt, grav, rhowater, rhosnow
    330. 

  330. 

  331. 

  332.   REAL,    DIMENSION( ims:ime , jms:jme ),                            &
    333. 

  333.            INTENT(IN   )               :: topo   
    334. 

  334. 

  335. ! temperary vars
    336. 

  336. 

  337.   REAL,    DIMENSION( kts:kte )           :: sqrhoz
    338. 

  338.   REAL                                    :: tmp1, term0
    339. 

  339.   REAL                                :: pptrain, pptsnow,        &
    340. 

  340.                                          pptgraul, pptice
    341. 

  341.   REAL,    DIMENSION( kts:kte )       :: qrz, qiz, qsz, qgz,      &
    342. 

  342.                                          zz, dzw, prez, rhoz,     &
    343. 

  343.                                          orhoz
    344. 

  344. 

  345. 

  346.    INTEGER                    :: k, i, j
    347. 

  347. !
    348. 

  348. 

  349.   REAL, DIMENSION( kts:kte )    :: vtr, vts, vtg, vti
    350. 

  350. 

  351.   REAL                          :: dtb, pi, consta, constc, gambp4,    &
    352. 

  352.                                    gamdp4, gam4pt5, gam4bbar
    353. 

  353. 

  354. !  Lin
    355. 

  355.    REAL    , PARAMETER ::     xnor = 8.0e6
    356. 

  356. !   REAL    , PARAMETER ::     xnos = 3.0e6
    357. 

  357.    REAL    , PARAMETER ::     xnos = 1.6e7   ! Tao's value
    358. 

  358.    REAL    , PARAMETER ::                              &
    359. 

  359. !             constb = 0.8, constd = 0.25, o6 = 1./6.,           &
    360. 

  360.              constb = 0.8, constd = 0.11, o6 = 1./6.,           &
    361. 

  361.              cdrag = 0.6
    362. 

  362. !  Lin
    363. 

  363. !  REAL    , PARAMETER ::     xnoh = 4.0e4
    364. 

  364.   REAL    , PARAMETER ::     xnoh = 2.0e5    ! Tao's value
    365. 

  365.   REAL    , PARAMETER ::     rhohail = 917.
    366. 

  366. 

  367. ! Hobbs
    368. 

  368.   REAL    , PARAMETER ::     xnog = 4.0e6
    369. 

  369.   REAL    , PARAMETER ::     rhograul = 400.
    370. 

  370.   REAL    , PARAMETER ::     abar = 19.3, bbar = 0.37,      &
    371. 

  371.                                       p0 = 1.0e5
    372. 

  372. 

  373.   REAL    , PARAMETER ::     rhoe_s = 1.29
    374. 

  374. 

  375. ! for terminal velocity flux
    376. 

  376.   INTEGER                       :: min_q, max_q
    377. 

  377.   REAL                          :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz
    378. 

  378.   LOGICAL                       :: notlast
    379. 

  379. 

  380. !  if (itimestep.eq.1) then
    381. 

  381. !     write(6, *) 'in fall_flux'
    382. 

  382. !     write(6, *) 'ims=', ims, '  ime=', ime
    383. 

  383. !     write(6, *) 'jms=', jms, '  jme=', jme
    384. 

  384. !     write(6, *) 'kms=', kms, '  kme=', kme
    385. 

  385. !     write(6, *) 'its=', its, '  ite=', ite
    386. 

  386. !     write(6, *) 'jts=', jts, '  jte=', jte
    387. 

  387. !     write(6, *) 'kts=', kts, '  kte=', kte
    388. 

  388. !     write(6, *) 'dt=', dt
    389. 

  389. !     write(6, *) 'ihail=', ihail
    390. 

  390. !     write(6, *) 'ICE2=', ICE2
    391. 

  391. !     write(6, *) 'dt=', dt
    392. 

  392. !   endif 
    393. 

  393. 

  394. !-----------------------------------------------------------------------
    395. 

  395. !  This program calculates precipitation fluxes due to terminal velocities.
    396. 

  396. !-----------------------------------------------------------------------
    397. 

  397. 

  398.    dtb=dt
    399. 

  399.    pi=acos(-1.)
    400. 

  400.    consta=2115.0*0.01**(1-constb)
    401. 

  401. !   constc=152.93*0.01**(1-constd)
    402. 

  402.    constc=78.63*0.01**(1-constd)
    403. 

  403. 

  404. !  Gamma function
    405. 

  405.    gambp4=ggamma(constb+4.)
    406. 

  406.    gamdp4=ggamma(constd+4.)
    407. 

  407.    gam4pt5=ggamma(4.5)
    408. 

  408.    gam4bbar=ggamma(4.+bbar)
    409. 

  409. 

  410. !***********************************************************************
    411. 

  411. ! Calculate precipitation fluxes due to terminal velocities.
    412. 

  412. !***********************************************************************
    413. 

  413. !
    414. 

  414. !- Calculate termianl velocity (vt?)  of precipitation q?z
    415. 

  415. !- Find maximum vt? to determine the small delta t
    416. 

  416. 

  417.  j_loop:  do j = jts, jte
    418. 

  418.  i_loop:  do i = its, ite
    419. 

  419. 

  420.    pptrain = 0.
    421. 

  421.    pptsnow = 0.
    422. 

  422.    pptgraul = 0.
    423. 

  423.    pptice  = 0.
    424. 

  424. 

  425.    do k = kts, kte
    426. 

  426.       qrz(k)=qr(i,k,j)
    427. 

  427.       rhoz(k)=rho(i,k,j)
    428. 

  428.       orhoz(k)=1./rhoz(k)
    429. 

  429.       prez(k)=p(i,k,j)
    430. 

  430.       sqrhoz(k)=sqrt(rhoe_s/rhoz(k))
    431. 

  431.       zz(k)=z(i,k,j)
    432. 

  432.       dzw(k)=dz8w(i,k,j)
    433. 

  433.    enddo !k
    434. 

  434. 

  435.       DO k = kts, kte
    436. 

  436.          qiz(k)=qi(i,k,j)
    437. 

  437.       ENDDO
    438. 

  438. 

  439.       DO k = kts, kte
    440. 

  440.          qsz(k)=qs(i,k,j)
    441. 

  441.       ENDDO
    442. 

  442. 

  443.    IF (ice2 .eq. 0) THEN
    444. 

  444.       DO k = kts, kte
    445. 

  445.          qgz(k)=qg(i,k,j)
    446. 

  446.       ENDDO
    447. 

  447.    ELSE
    448. 

  448.       DO k = kts, kte
    449. 

  449.          qgz(k)=0.
    450. 

  450.       ENDDO
    451. 

  451.    ENDIF
    452. 

  452. 

  453. 

  454. !
    455. 

  455. !-- rain
    456. 

  456. !
    457. 

  457.     t_del_tv=0.
    458. 

  458.     del_tv=dtb
    459. 

  459.     notlast=.true.
    460. 

  460.     DO while (notlast)
    461. 

  461. !
    462. 

  462.       min_q=kte
    463. 

  463.       max_q=kts-1
    464. 

  464. !
    465. 

  465.       do k=kts,kte-1
    466. 

  466.          if (qrz(k) .gt. 1.0e-8) then
    467. 

  467.             min_q=min0(min_q,k)
    468. 

  468.             max_q=max0(max_q,k)
    469. 

  469.             tmp1=sqrt(pi*rhowater*xnor/rhoz(k)/qrz(k))
    470. 

  470.             tmp1=sqrt(tmp1)
    471. 

  471.             vtr(k)=consta*gambp4*sqrhoz(k)/tmp1**constb
    472. 

  472.             vtr(k)=vtr(k)/6.
    473. 

  473.             if (k .eq. 1) then
    474. 

  474.                del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtr(k))
    475. 

  475.             else
    476. 

  476.                del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtr(k))
    477. 

  477.             endif
    478. 

  478.          else
    479. 

  479.             vtr(k)=0.
    480. 

  480.          endif
    481. 

  481.       enddo
    482. 

  482. 

  483.       if (max_q .ge. min_q) then
    484. 

  484. !
    485. 

  485. !- Check if the summation of the small delta t >=  big delta t
    486. 

  486. !             (t_del_tv)          (del_tv)             (dtb)
    487. 

  487. 

  488.          t_del_tv=t_del_tv+del_tv
    489. 

  489. !
    490. 

  490.          if ( t_del_tv .ge. dtb ) then
    491. 

  491.               notlast=.false.
    492. 

  492.               del_tv=dtb+del_tv-t_del_tv
    493. 

  493.          endif
    494. 

  494. 

  495. ! use small delta t to calculate the qrz flux
    496. 

  496. ! termi is the qrz flux pass in the grid box through the upper boundary
    497. 

  497. ! termo is the qrz flux pass out the grid box through the lower boundary
    498. 

  498. !
    499. 

  499.          fluxin=0.
    500. 

  500.          do k=max_q,min_q,-1
    501. 

  501.             fluxout=rhoz(k)*vtr(k)*qrz(k)
    502. 

  502.             flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
    503. 

  503. !            tmpqrz=qrz(k)
    504. 

  504.             qrz(k)=qrz(k)+del_tv*flux
    505. 

  505.             qrz(k)=amax1(0.,qrz(k))
    506. 

  506.             qr(i,k,j)=qrz(k)
    507. 

  507.             fluxin=fluxout
    508. 

  508.          enddo
    509. 

  509.          if (min_q .eq. 1) then
    510. 

  510.             pptrain=pptrain+fluxin*del_tv
    511. 

  511.          else
    512. 

  512.             qrz(min_q-1)=qrz(min_q-1)+del_tv*  &
    513. 

  513.                           fluxin/rhoz(min_q-1)/dzw(min_q-1)
    514. 

  514.             qr(i,min_q-1,j)=qrz(min_q-1)
    515. 

  515.          endif
    516. 

  516. !
    517. 

  517.       else
    518. 

  518.          notlast=.false.
    519. 

  519.       endif
    520. 

  520.     ENDDO
    521. 

  521. 

  522. !
    523. 

  523. !-- snow
    524. 

  524. !
    525. 

  525.     t_del_tv=0.
    526. 

  526.     del_tv=dtb
    527. 

  527.     notlast=.true.
    528. 

  528. 

  529.     DO while (notlast)
    530. 

  530. !
    531. 

  531.       min_q=kte
    532. 

  532.       max_q=kts-1
    533. 

  533. !
    534. 

  534.       do k=kts,kte-1
    535. 

  535.          if (qsz(k) .gt. 1.0e-8) then
    536. 

  536.             min_q=min0(min_q,k)
    537. 

  537.             max_q=max0(max_q,k)
    538. 

  538.             tmp1=sqrt(pi*rhosnow*xnos/rhoz(k)/qsz(k))
    539. 

  539.             tmp1=sqrt(tmp1)
    540. 

  540.             vts(k)=constc*gamdp4*sqrhoz(k)/tmp1**constd
    541. 

  541.             vts(k)=vts(k)/6.
    542. 

  542.             if (k .eq. 1) then
    543. 

  543.                del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vts(k))
    544. 

  544.             else
    545. 

  545.                del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vts(k))
    546. 

  546.             endif
    547. 

  547.          else
    548. 

  548.             vts(k)=0.
    549. 

  549.          endif
    550. 

  550.       enddo
    551. 

  551. 

  552.       if (max_q .ge. min_q) then
    553. 

  553. !
    554. 

  554. !
    555. 

  555. !- Check if the summation of the small delta t >=  big delta t
    556. 

  556. !             (t_del_tv)          (del_tv)             (dtb)
    557. 

  557. 

  558.          t_del_tv=t_del_tv+del_tv
    559. 

  559. 

  560.          if ( t_del_tv .ge. dtb ) then
    561. 

  561.               notlast=.false.
    562. 

  562.               del_tv=dtb+del_tv-t_del_tv
    563. 

  563.          endif
    564. 

  564. 

  565. ! use small delta t to calculate the qsz flux
    566. 

  566. ! termi is the qsz flux pass in the grid box through the upper boundary
    567. 

  567. ! termo is the qsz flux pass out the grid box through the lower boundary
    568. 

  568. !
    569. 

  569.          fluxin=0.
    570. 

  570.          do k=max_q,min_q,-1
    571. 

  571.             fluxout=rhoz(k)*vts(k)*qsz(k)
    572. 

  572.             flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
    573. 

  573.             qsz(k)=qsz(k)+del_tv*flux
    574. 

  574.             qsz(k)=amax1(0.,qsz(k))
    575. 

  575.             qs(i,k,j)=qsz(k)
    576. 

  576.             fluxin=fluxout
    577. 

  577.          enddo
    578. 

  578.          if (min_q .eq. 1) then
    579. 

  579.             pptsnow=pptsnow+fluxin*del_tv
    580. 

  580.          else
    581. 

  581.             qsz(min_q-1)=qsz(min_q-1)+del_tv*  &
    582. 

  582.                          fluxin/rhoz(min_q-1)/dzw(min_q-1)
    583. 

  583.             qs(i,min_q-1,j)=qsz(min_q-1)
    584. 

  584.          endif
    585. 

  585. !
    586. 

  586.       else
    587. 

  587.          notlast=.false.
    588. 

  588.       endif
    589. 

  589. 

  590.     ENDDO
    591. 

  591. 

  592. !
    593. 

  593. !   ice2=0 --- with hail/graupel 
    594. 

  594. !   ice2=1 --- without hail/graupel 
    595. 

  595. !
    596. 

  596.   if (ice2.eq.0) then 
    597. 

  597. !
    598. 

  598. !-- If IHAIL=1, use hail.
    599. 

  599. !-- If IHAIL=0, use graupel.
    600. 

  600. !
    601. 

  601. !    if (ihail .eq. 1) then
    602. 

  602. !       xnog = xnoh
    603. 

  603. !       rhograul = rhohail
    604. 

  604. !    endif
    605. 

  605. 

  606.     t_del_tv=0.
    607. 

  607.     del_tv=dtb
    608. 

  608.     notlast=.true.
    609. 

  609. !
    610. 

  610.     DO while (notlast)
    611. 

  611. !
    612. 

  612.       min_q=kte
    613. 

  613.       max_q=kts-1
    614. 

  614. !
    615. 

  615.       do k=kts,kte-1
    616. 

  616.          if (qgz(k) .gt. 1.0e-8) then
    617. 

  617.             if (ihail .eq. 1) then
    618. 

  618. !  for hail, based on Lin et al (1983)
    619. 

  619.               min_q=min0(min_q,k)
    620. 

  620.               max_q=max0(max_q,k)
    621. 

  621.               tmp1=sqrt(pi*rhohail*xnoh/rhoz(k)/qgz(k))
    622. 

  622.               tmp1=sqrt(tmp1)
    623. 

  623.               term0=sqrt(4.*grav*rhohail/3./rhoz(k)/cdrag)
    624. 

  624.               vtg(k)=gam4pt5*term0*sqrt(1./tmp1)
    625. 

  625.               vtg(k)=vtg(k)/6.
    626. 

  626.               if (k .eq. 1) then
    627. 

  627.                  del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k))
    628. 

  628.               else
    629. 

  629.                  del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k))
    630. 

  630.               endif !k
    631. 

  631.             else
    632. 

  632. ! added by JJS
    633. 

  633. ! for graupel, based on RH (1984)
    634. 

  634.               min_q=min0(min_q,k)
    635. 

  635.               max_q=max0(max_q,k)
    636. 

  636.               tmp1=sqrt(pi*rhograul*xnog/rhoz(k)/qgz(k))
    637. 

  637.               tmp1=sqrt(tmp1)
    638. 

  638.               tmp1=tmp1**bbar
    639. 

  639.               tmp1=1./tmp1
    640. 

  640.               term0=abar*gam4bbar/6.
    641. 

  641.               vtg(k)=term0*tmp1*(p0/prez(k))**0.4
    642. 

  642.               if (k .eq. 1) then
    643. 

  643.                  del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k))
    644. 

  644.               else
    645. 

  645.                  del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k))
    646. 

  646.               endif !k
    647. 

  647.             endif !ihail
    648. 

  648.          else
    649. 

  649.             vtg(k)=0.
    650. 

  650.          endif !qgz
    651. 

  651.       enddo !k
    652. 

  652. 

  653.       if (max_q .ge. min_q) then
    654. 

  654. !
    655. 

  655. !
    656. 

  656. !- Check if the summation of the small delta t >=  big delta t
    657. 

  657. !             (t_del_tv)          (del_tv)             (dtb)
    658. 

  658. 

  659.          t_del_tv=t_del_tv+del_tv
    660. 

  660. 

  661.          if ( t_del_tv .ge. dtb ) then
    662. 

  662.               notlast=.false.
    663. 

  663.               del_tv=dtb+del_tv-t_del_tv
    664. 

  664.          endif
    665. 

  665. 

  666. ! use small delta t to calculate the qgz flux
    667. 

  667. ! termi is the qgz flux pass in the grid box through the upper boundary
    668. 

  668. ! termo is the qgz flux pass out the grid box through the lower boundary
    669. 

  669. !
    670. 

  670.          fluxin=0.
    671. 

  671.          do k=max_q,min_q,-1
    672. 

  672.             fluxout=rhoz(k)*vtg(k)*qgz(k)
    673. 

  673.             flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
    674. 

  674.             qgz(k)=qgz(k)+del_tv*flux
    675. 

  675.             qgz(k)=amax1(0.,qgz(k))
    676. 

  676.             qg(i,k,j)=qgz(k)
    677. 

  677.             fluxin=fluxout
    678. 

  678.          enddo
    679. 

  679.          if (min_q .eq. 1) then
    680. 

  680.             pptgraul=pptgraul+fluxin*del_tv
    681. 

  681.          else
    682. 

  682.             qgz(min_q-1)=qgz(min_q-1)+del_tv*  &
    683. 

  683.                          fluxin/rhoz(min_q-1)/dzw(min_q-1)
    684. 

  684.             qg(i,min_q-1,j)=qgz(min_q-1)
    685. 

  685.          endif
    686. 

  686. !
    687. 

  687.       else
    688. 

  688.          notlast=.false.
    689. 

  689.       endif
    690. 

  690. !
    691. 

  691.     ENDDO
    692. 

  692.  ENDIF !ice2
    693. 

  693. !
    694. 

  694. !-- cloud ice  (03/21/02) follow Vaughan T.J. Phillips at GFDL
    695. 

  695. !
    696. 

  696. 

  697.     t_del_tv=0.
    698. 

  698.     del_tv=dtb
    699. 

  699.     notlast=.true.
    700. 

  700. !
    701. 

  701.     DO while (notlast)
    702. 

  702. !
    703. 

  703.       min_q=kte
    704. 

  704.       max_q=kts-1
    705. 

  705. !
    706. 

  706.       do k=kts,kte-1
    707. 

  707.          if (qiz(k) .gt. 1.0e-8) then
    708. 

  708.             min_q=min0(min_q,k)
    709. 

  709.             max_q=max0(max_q,k)
    710. 

  710.             vti(k)= 3.29 * (rhoz(k)* qiz(k))** 0.16  ! Heymsfield and Donner
    711. 

  711.             if (k .eq. 1) then
    712. 

  712.                del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vti(k))
    713. 

  713.             else
    714. 

  714.                del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vti(k))
    715. 

  715.             endif
    716. 

  716.          else
    717. 

  717.             vti(k)=0.
    718. 

  718.          endif
    719. 

  719.       enddo
    720. 

  720. 

  721.       if (max_q .ge. min_q) then
    722. 

  722. !
    723. 

  723. !
    724. 

  724. !- Check if the summation of the small delta t >=  big delta t
    725. 

  725. !             (t_del_tv)          (del_tv)             (dtb)
    726. 

  726. 

  727.          t_del_tv=t_del_tv+del_tv
    728. 

  728. 

  729.          if ( t_del_tv .ge. dtb ) then
    730. 

  730.               notlast=.false.
    731. 

  731.               del_tv=dtb+del_tv-t_del_tv
    732. 

  732.          endif
    733. 

  733. 

  734. ! use small delta t to calculate the qiz flux
    735. 

  735. ! termi is the qiz flux pass in the grid box through the upper boundary
    736. 

  736. ! termo is the qiz flux pass out the grid box through the lower boundary
    737. 

  737. !
    738. 

  738. 

  739.          fluxin=0.
    740. 

  740.          do k=max_q,min_q,-1
    741. 

  741.             fluxout=rhoz(k)*vti(k)*qiz(k)
    742. 

  742.             flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
    743. 

  743.             qiz(k)=qiz(k)+del_tv*flux
    744. 

  744.             qiz(k)=amax1(0.,qiz(k))
    745. 

  745.             qi(i,k,j)=qiz(k)
    746. 

  746.             fluxin=fluxout
    747. 

  747.          enddo
    748. 

  748.          if (min_q .eq. 1) then
    749. 

  749.             pptice=pptice+fluxin*del_tv
    750. 

  750.          else
    751. 

  751.             qiz(min_q-1)=qiz(min_q-1)+del_tv*  &
    752. 

  752.                          fluxin/rhoz(min_q-1)/dzw(min_q-1)
    753. 

  753.             qi(i,min_q-1,j)=qiz(min_q-1)
    754. 

  754.          endif
    755. 

  755. !
    756. 

  756.       else
    757. 

  757.          notlast=.false.
    758. 

  758.       endif
    759. 

  759. !
    760. 

  760.    ENDDO !notlast
    761. 

  761. 

  762. !   prnc(i,j)=prnc(i,j)+pptrain
    763. 

  763. !   psnowc(i,j)=psnowc(i,j)+pptsnow
    764. 

  764. !   pgrauc(i,j)=pgrauc(i,j)+pptgraul
    765. 

  765. !   picec(i,j)=picec(i,j)+pptice
    766. 

  766. !                     
    767. 

  767. 

  768. !   write(6,*) 'i=',i,' j=',j,'   ', pptrain, pptsnow, pptgraul, pptice
    769. 

  769. !   call flush(6)
    770. 

  770. 

  771.    snowncv(i,j) = pptsnow
    772. 

  772.    snownc(i,j) = snownc(i,j) + pptsnow
    773. 

  773.    graupelncv(i,j) = pptgraul
    774. 

  774.    graupelnc(i,j) = graupelnc(i,j) + pptgraul 
    775. 

  775.    RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice                 
    776. 

  776.    RAINNC(i,j)  = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice
    777. 

  777.    sr(i,j) = 0.
    778. 

  778.    if (RAINNCV(i,j) .gt. 0.) sr(i,j) = (pptsnow + pptgraul + pptice) / RAINNCV(i,j) 
    779. 

  779. 

  780.   ENDDO i_loop
    781. 

  781.   ENDDO j_loop
    782. 

  782. 

  783. !  if (itimestep.eq.6480) then
    784. 

  784. !     write(51,*) 'in the end of fallflux, itimestep=',itimestep
    785. 

  785. !     do j=jts,jte
    786. 

  786. !        do i=its,ite 
    787. 

  787. !           if (rainnc(i,j).gt.400.) then
    788. 

  788. !              write(50,*) 'i=',i,' j=',j,' rainnc=',rainnc
    789. 

  789. !           endif
    790. 

  790. !        enddo
    791. 

  791. !     enddo
    792. 

  792. !  endif
    793. 

  793. 

  794.   END SUBROUTINE fall_flux
    795. 

  795. 

  796. !----------------------------------------------------------------
    797. 

  797.    REAL FUNCTION ggamma(X)
    798. 

  798. !----------------------------------------------------------------
    799. 

  799.    IMPLICIT NONE
    800. 

  800. !----------------------------------------------------------------
    801. 

  801.       REAL, INTENT(IN   ) :: x
    802. 

  802.       REAL, DIMENSION(8)  :: B
    803. 

  803.       INTEGER             ::j, K1
    804. 

  804.       REAL                ::PF, G1TO2 ,TEMP
    805. 

  805. 

  806.       DATA B/-.577191652,.988205891,-.897056937,.918206857,  &
    807. 

  807.              -.756704078,.482199394,-.193527818,.035868343/
    808. 

  808. 

  809.       PF=1.
    810. 

  810.       TEMP=X
    811. 

  811.       DO 10 J=1,200
    812. 

  812.       IF (TEMP .LE. 2) GO TO 20
    813. 

  813.       TEMP=TEMP-1.
    814. 

  814.    10 PF=PF*TEMP
    815. 

  815.   100 FORMAT(//,5X,'module_gsfcgce: INPUT TO GAMMA FUNCTION TOO LARGE, X=',E12.5)
    816. 

  816.       WRITE(wrf_err_message,100)X
    817. 

  817.       CALL wrf_error_fatal(wrf_err_message)
    818. 

  818.    20 G1TO2=1.
    819. 

  819.       TEMP=TEMP - 1.
    820. 

  820.       DO 30 K1=1,8
    821. 

  821.    30 G1TO2=G1TO2 + B(K1)*TEMP**K1
    822. 

  822.       ggamma=PF*G1TO2
    823. 

  823. 

  824.       END FUNCTION ggamma
    825. 

  825. 

  826. !-----------------------------------------------------------------------
    827. 

  827. !c Correction of negative values  
    828. 

  828.    SUBROUTINE negcor ( X, rho, dz8w,                         &
    829. 

  829.                       ims,ime, jms,jme, kms,kme,              & ! memory dims
    830. 

  830.                       itimestep, ics,                         &
    831. 

  831.                       its,ite, jts,jte, kts,kte               ) ! tile   dims
    832. 

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

  833.   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
    834. 

  834.         INTENT(INOUT) ::                                     X   
    835. 

  835.   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
    836. 

  836.         INTENT(IN   ) ::                              rho, dz8w  
    837. 

  837.   integer, INTENT(IN   ) ::                           itimestep, ics 
    838. 

  838. 

  839. !c Local variables
    840. 

  840. !  REAL, DIMENSION( kts:kte ) ::  Y1, Y2
    841. 

  841.   REAL   ::   A0, A1, A2
    842. 

  842. 

  843.   A1=0.
    844. 

  844.   A2=0.
    845. 

  845.   do k=kts,kte
    846. 

  846.      do j=jts,jte
    847. 

  847.         do i=its,ite
    848. 

  848.         A1=A1+max(X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j)
    849. 

  849.         A2=A2+max(-X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j)
    850. 

  850.         enddo
    851. 

  851.      enddo
    852. 

  852.   enddo
    853. 

  853. 

  854. !  A1=0.0
    855. 

  855. !  A2=0.0
    856. 

  856. !  do k=kts,kte
    857. 

  857. !     A1=A1+Y1(k)
    858. 

  858. !     A2=A2+Y2(k)
    859. 

  859. !  enddo
    860. 

  860. 

  861.   A0=0.0
    862. 

  862. 

  863.   if (A1.NE.0.0.and.A1.GT.A2) then 
    864. 

  864.      A0=(A1-A2)/A1
    865. 

  865. 

  866.   if (mod(itimestep,540).eq.0) then
    867. 

  867.      if (ics.eq.1) then
    868. 

  868.         write(61,*) 'kms=',kms,'  kme=',kme,'  kts=',kts,'  kte=',kte
    869. 

  869.         write(61,*) 'jms=',jms,'  jme=',jme,'  jts=',jts,'  jte=',jte 
    870. 

  870.         write(61,*) 'ims=',ims,'  ime=',ime,'  its=',its,'  ite=',ite 
    871. 

  871.      endif 
    872. 

  872.      if (ics.eq.1) then
    873. 

  873.          write(61,*) 'qv timestep=',itimestep
    874. 

  874.          write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    875. 

  875.      else if (ics.eq.2) then
    876. 

  876.              write(61,*) 'ql timestep=',itimestep
    877. 

  877.              write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    878. 

  878.      else if (ics.eq.3) then
    879. 

  879.              write(61,*) 'qr timestep=',itimestep
    880. 

  880.              write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    881. 

  881.      else if (ics.eq.4) then
    882. 

  882.              write(61,*) 'qi timestep=',itimestep
    883. 

  883.              write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    884. 

  884.      else if (ics.eq.5) then
    885. 

  885.              write(61,*) 'qs timestep=',itimestep
    886. 

  886.              write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    887. 

  887.      else if (ics.eq.6) then
    888. 

  888.              write(61,*) 'qg timestep=',itimestep
    889. 

  889.              write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
    890. 

  890.      else
    891. 

  891.              write(61,*) 'wrong cloud specieis number'
    892. 

  892.      endif 
    893. 

  893.   endif 
    894. 

  894. 

  895.      do k=kts,kte
    896. 

  896.         do j=jts,jte
    897. 

  897.            do i=its,ite
    898. 

  898.            X(i,k,j)=A0*AMAX1(X(i,k,j), 0.0)
    899. 

  899.            enddo
    900. 

  900.         enddo
    901. 

  901.      enddo
    902. 

  902.   endif
    903. 

  903. 

  904.   END SUBROUTINE negcor
    905. 

  905. 

  906.  SUBROUTINE consat_s (ihail,itaobraun)
    907. 

  907. 

  908. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    909. 

  909. !                                                                      c
    910. 

  910. !   Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical     c
    911. 

  911. !   squall-type convective line. J. Atmos. Sci., 46, 177-202.          c
    912. 

  912. !                                                                      c
    913. 

  913. !   Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water         c
    914. 

  914. !   saturation adjustment. Mon. Wea. Rev., 117, 231-235.               c
    915. 

  915. !                                                                      c
    916. 

  916. !   Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble     c
    917. 

  917. !   Model. Part I: Model description. Terrestrial, Atmospheric and     c
    918. 

  918. !   Oceanic Sciences, 4, 35-72.                                        c
    919. 

  919. !                                                                      c
    920. 

  920. !   Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B.         c
    921. 

  921. !   Ferrier,D. Johnson, A. Khain, S. Lang,  B. Lynn, C.-L. Shie,       c
    922. 

  922. !   D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics,    c
    923. 

  923. !   radiation and surface processes in the Goddard Cumulus Ensemble    c
    924. 

  924. !   (GCE) model, A Special Issue on Non-hydrostatic Mesoscale          c
    925. 

  925. !   Modeling, Meteorology and Atmospheric Physics, 82, 97-137.         c
    926. 

  926. !                                                                      c
    927. 

  927. !   Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S.        c
    928. 

  928. !   Rutledge, and J. Simpson, 2007: Improving simulations of           c
    929. 

  929. !   convective system from TRMM LBA: Easterly and Westerly regimes.    c
    930. 

  930. !   J. Atmos. Sci., 64, 1141-1164.                                     c
    931. 

  931. !                                                                      c
    932. 

  932. !   Coded by Tao (1989-2003), modified by S. Lang (2006/07)            c
    933. 

  933. !                                                                      c
    934. 

  934. !   Implemented into WRF  by Roger Shi 2006/2007                       c
    935. 

  935. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    936. 

  936. 

  937. !        itaobraun=0   ! see Tao and Simpson (1993)
    938. 

  938. !        itaobraun=1   ! see Tao et al. (2003)
    939. 

  939. 

  940.  integer :: itaobraun
    941. 

  941.  real    :: cn0
    942. 

  942. 

  943. !JJS 1/3/2008  vvvvv
    944. 

  944. !JJS   the following common blocks have been moved to the top of
    945. 

  945. !JJS   module_mp_gsfcgce_driver_instat.F
    946. 

  946. !
    947. 

  947. ! real,   dimension (1:31) ::  a1, a2
    948. 

  948. ! data a1/.7939e-7,.7841e-6,.3369e-5,.4336e-5,.5285e-5,.3728e-5, &
    949. 

  949. !         .1852e-5,.2991e-6,.4248e-6,.7434e-6,.1812e-5,.4394e-5,.9145e-5, &
    950. 

  950. !         .1725e-4,.3348e-4,.1725e-4,.9175e-5,.4412e-5,.2252e-5,.9115e-6, &
    951. 

  951. !         .4876e-6,.3473e-6,.4758e-6,.6306e-6,.8573e-6,.7868e-6,.7192e-6, &
    952. 

  952. !         .6513e-6,.5956e-6,.5333e-6,.4834e-6/
    953. 

  953. ! data a2/.4006,.4831,.5320,.5307,.5319,.5249,.4888,.3894,.4047, &
    954. 

  954. !         .4318,.4771,.5183,.5463,.5651,.5813,.5655,.5478,.5203,.4906, &
    955. 

  955. !         .4447,.4126,.3960,.4149,.4320,.4506,.4483,.4460,.4433,.4413, &
    956. 

  956. !         .4382,.4361/
    957. 

  957. !JJS 1/3/2008  ^^^^^
    958. 

  958. 

  959. 

  960. !     ******************************************************************
    961. 

  961. !JJS
    962. 

  962.       al = 2.5e10
    963. 

  963.       cp = 1.004e7
    964. 

  964.       rd1 = 1.e-3
    965. 

  965.       rd2 = 2.2
    966. 

  966. !JJS
    967. 

  967.       cpi=4.*atan(1.)
    968. 

  968.       cpi2=cpi*cpi
    969. 

  969.       grvt=980.
    970. 

  970.       cd1=6.e-1
    971. 

  971.       cd2=4.*grvt/(3.*cd1)
    972. 

  972.       tca=2.43e3
    973. 

  973.       dwv=.226
    974. 

  974.       dva=1.718e-4
    975. 

  975.       amw=18.016
    976. 

  976.       ars=8.314e7
    977. 

  977.       scv=2.2904487
    978. 

  978.       t0=273.16
    979. 

  979.       t00=238.16
    980. 

  980.       alv=2.5e10
    981. 

  981.       alf=3.336e9
    982. 

  982.       als=2.8336e10
    983. 

  983.       avc=alv/cp
    984. 

  984.       afc=alf/cp
    985. 

  985.       asc=als/cp
    986. 

  986.       rw=4.615e6
    987. 

  987.       cw=4.187e7
    988. 

  988.       ci=2.093e7
    989. 

  989.       c76=7.66
    990. 

  990.       c358=35.86
    991. 

  991.       c172=17.26939
    992. 

  992.       c409=4098.026
    993. 

  993.       c218=21.87456
    994. 

  994.       c580=5807.695
    995. 

  995.       c610=6.1078e3
    996. 

  996.       c149=1.496286e-5
    997. 

  997.       c879=8.794142
    998. 

  998.       c141=1.4144354e7
    999. 

  999. !***   DEFINE THE COEFFICIENTS USED IN TERMINAL VELOCITY
    1000. 

  1000. !***   DEFINE THE DENSITY AND SIZE DISTRIBUTION OF PRECIPITATION
    1001. 

  1001. !**********   HAIL OR GRAUPEL PARAMETERS   **********
    1002. 

  1002.       if(ihail .eq. 1) then
    1003. 

  1003.          roqg=.9
    1004. 

  1004.          ag=sqrt(cd2*roqg)
    1005. 

  1005.          bg=.5
    1006. 

  1006.          tng=.002
    1007. 

  1007.       else
    1008. 

  1008.          roqg=.4
    1009. 

  1009.          ag=351.2
    1010. 

  1010. !        AG=372.3 ! if ice913=1 6/15/02 tao's
    1011. 

  1011.          bg=.37
    1012. 

  1012.          tng=.04
    1013. 

  1013.       endif
    1014. 

  1014. !**********         SNOW PARAMETERS        **********
    1015. 

  1015. !ccshie 6/15/02 tao's
    1016. 

  1016. !      TNS=1.
    1017. 

  1017. !      TNS=.08 ! if ice913=1, tao's
    1018. 

  1018.       tns=.16 ! if ice913=0, tao's
    1019. 

  1019.       roqs=.1
    1020. 

  1020. !      AS=152.93
    1021. 

  1021.       as=78.63
    1022. 

  1022. !      BS=.25
    1023. 

  1023.       bs=.11
    1024. 

  1024. !**********         RAIN PARAMETERS        **********
    1025. 

  1025.       aw=2115.
    1026. 

  1026.       bw=.8
    1027. 

  1027.       roqr=1.
    1028. 

  1028.       tnw=.08
    1029. 

  1029. !*****************************************************************
    1030. 

  1030.       bgh=.5*bg
    1031. 

  1031.       bsh=.5*bs
    1032. 

  1032.       bwh=.5*bw
    1033. 

  1033.       bgq=.25*bg
    1034. 

  1034.       bsq=.25*bs
    1035. 

  1035.       bwq=.25*bw
    1036. 

  1036. !**********GAMMA FUNCTION CALCULATIONS*************
    1037. 

  1037.       ga3b  = gammagce(3.+bw)
    1038. 

  1038.       ga4b  = gammagce(4.+bw)
    1039. 

  1039.       ga6b  = gammagce(6.+bw)
    1040. 

  1040.       ga5bh = gammagce((5.+bw)/2.)
    1041. 

  1041.       ga3g  = gammagce(3.+bg)
    1042. 

  1042.       ga4g  = gammagce(4.+bg)
    1043. 

  1043.       ga5gh = gammagce((5.+bg)/2.)
    1044. 

  1044.       ga3d  = gammagce(3.+bs)
    1045. 

  1045.       ga4d  = gammagce(4.+bs)
    1046. 

  1046.       ga5dh = gammagce((5.+bs)/2.)
    1047. 

  1047. !CCCCC        LIN ET AL., 1983 OR LORD ET AL., 1984   CCCCCCCCCCCCCCCCC
    1048. 

  1048.       ac1=aw
    1049. 

  1049. !JJS
    1050. 

  1050.       ac2=ag
    1051. 

  1051.       ac3=as
    1052. 

  1052. !JJS
    1053. 

  1053.       bc1=bw
    1054. 

  1054.       cc1=as
    1055. 

  1055.       dc1=bs
    1056. 

  1056.       zrc=(cpi*roqr*tnw)**0.25
    1057. 

  1057.       zsc=(cpi*roqs*tns)**0.25
    1058. 

  1058.       zgc=(cpi*roqg*tng)**0.25
    1059. 

  1059.       vrc=aw*ga4b/(6.*zrc**bw)
    1060. 

  1060.       vsc=as*ga4d/(6.*zsc**bs)
    1061. 

  1061.       vgc=ag*ga4g/(6.*zgc**bg)
    1062. 

  1062. !     ****************************
    1063. 

  1063. !     RN1=1.E-3
    1064. 

  1064.       rn1=9.4e-15 ! 6/15/02 tao's
    1065. 

  1065.       bnd1=6.e-4
    1066. 

  1066.       rn2=1.e-3
    1067. 

  1067. !     BND2=1.25E-3
    1068. 

  1068. !     BND2=1.5E-3 ! if ice913=1 6/15/02 tao's
    1069. 

  1069.       bnd2=2.0e-3 ! if ice913=0 6/15/02 tao's
    1070. 

  1070.       rn3=.25*cpi*tns*cc1*ga3d
    1071. 

  1071.       esw=1.
    1072. 

  1072.       rn4=.25*cpi*esw*tns*cc1*ga3d
    1073. 

  1073. !     ERI=1.
    1074. 

  1074.       eri=.1  ! 6/17/02 tao's ice913=0 (not 1)
    1075. 

  1075.       rn5=.25*cpi*eri*tnw*ac1*ga3b
    1076. 

  1076. !     AMI=1./(24.*4.19E-10)
    1077. 

  1077.       ami=1./(24.*6.e-9) ! 6/15/02 tao's
    1078. 

  1078.       rn6=cpi2*eri*tnw*ac1*roqr*ga6b*ami
    1079. 

  1079. !     ESR=1. ! also if ice913=1 for tao's
    1080. 

  1080.       esr=.5 ! 6/15/02 for ice913=0 tao's
    1081. 

  1081.       rn7=cpi2*esr*tnw*tns*roqs
    1082. 

  1082.       esr=1.
    1083. 

  1083.       rn8=cpi2*esr*tnw*tns*roqr
    1084. 

  1084.       rn9=cpi2*tns*tng*roqs
    1085. 

  1085.       rn10=2.*cpi*tns
    1086. 

  1086.       rn101=.31*ga5dh*sqrt(cc1)
    1087. 

  1087.       rn10a=als*als/rw
    1088. 

  1088. !JJS
    1089. 

  1089.        rn10b=alv/tca
    1090. 

  1090.        rn10c=ars/(dwv*amw)
    1091. 

  1091. !JJS
    1092. 

  1092.       rn11=2.*cpi*tns/alf
    1093. 

  1093.       rn11a=cw/alf
    1094. 

  1094. !     AMI50=1.51e-7
    1095. 

  1095.       ami50=3.84e-6 ! 6/15/02 tao's
    1096. 

  1096. !     AMI40=2.41e-8
    1097. 

  1097.       ami40=3.08e-8 ! 6/15/02 tao's
    1098. 

  1098.       eiw=1.
    1099. 

  1099. !     UI50=20.
    1100. 

  1100.       ui50=100. ! 6/15/02 tao's
    1101. 

  1101.       ri50=2.*5.e-3
    1102. 

  1102.       cmn=1.05e-15
    1103. 

  1103.       rn12=cpi*eiw*ui50*ri50**2
    1104. 

  1104. 

  1105.       do 10 k=1,31
    1106. 

  1106.          y1=1.-aa2(k)
    1107. 

  1107.          rn13(k)=aa1(k)*y1/(ami50**y1-ami40**y1)
    1108. 

  1108.          rn12a(k)=rn13(k)/ami50
    1109. 

  1109.          rn12b(k)=aa1(k)*ami50**aa2(k)
    1110. 

  1110.          rn25a(k)=aa1(k)*cmn**aa2(k)
    1111. 

  1111.    10 continue
    1112. 

  1112. 

  1113.       egw=1.
    1114. 

  1114.       rn14=.25*cpi*egw*tng*ga3g*ag
    1115. 

  1115.       egi=.1
    1116. 

  1116.       rn15=.25*cpi*egi*tng*ga3g*ag
    1117. 

  1117.       egi=1.
    1118. 

  1118.       rn15a=.25*cpi*egi*tng*ga3g*ag
    1119. 

  1119.       egr=1.
    1120. 

  1120.       rn16=cpi2*egr*tng*tnw*roqr
    1121. 

  1121.       rn17=2.*cpi*tng
    1122. 

  1122.       rn17a=.31*ga5gh*sqrt(ag)
    1123. 

  1123.       rn17b=cw-ci
    1124. 

  1124.       rn17c=cw
    1125. 

  1125.       apri=.66
    1126. 

  1126.       bpri=1.e-4
    1127. 

  1127.       bpri=0.5*bpri ! 6/17/02 tao's
    1128. 

  1128.       rn18=20.*cpi2*bpri*tnw*roqr
    1129. 

  1129.       rn18a=apri
    1130. 

  1130.       rn19=2.*cpi*tng/alf
    1131. 

  1131.       rn19a=.31*ga5gh*sqrt(ag)
    1132. 

  1132.       rn19b=cw/alf
    1133. 

  1133. !
    1134. 

  1134.        rnn191=.78
    1135. 

  1135.        rnn192=.31*ga5gh*sqrt(ac2/dva)
    1136. 

  1136. !
    1137. 

  1137.       rn20=2.*cpi*tng
    1138. 

  1138.       rn20a=als*als/rw
    1139. 

  1139.       rn20b=.31*ga5gh*sqrt(ag)
    1140. 

  1140.       bnd3=2.e-3
    1141. 

  1141.       rn21=1.e3*1.569e-12/0.15
    1142. 

  1142.       erw=1.
    1143. 

  1143.       rn22=.25*cpi*erw*ac1*tnw*ga3b
    1144. 

  1144.       rn23=2.*cpi*tnw
    1145. 

  1145.       rn23a=.31*ga5bh*sqrt(ac1)
    1146. 

  1146.       rn23b=alv*alv/rw
    1147. 

  1147. 

  1148. 

  1149. !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1150. 

  1150. !cc
    1151. 

  1151. !cc        "c0" in routine      "consat" (2d), "consatrh" (3d)
    1152. 

  1152. !cc        if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23;   cn0=1.e-6
    1153. 

  1153. !cc        if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30;    cn0=1.e-8
    1154. 

  1154. 

  1155.        if (itaobraun .eq. 0) then
    1156. 

  1156.          cn0=1.e-8
    1157. 

  1157.          beta=-.6
    1158. 

  1158.        elseif (itaobraun .eq. 1) then
    1159. 

  1159.          cn0=1.e-6
    1160. 

  1160.          beta=-.46
    1161. 

  1161.        endif
    1162. 

  1162. !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1163. 

  1163. !      CN0=1.E-6
    1164. 

  1164. !      CN0=1.E-8 ! 6/15/02 tao's
    1165. 

  1165. !      BETA=-.46
    1166. 

  1166. !      BETA=-.6  ! 6/15/02 tao's
    1167. 

    1168. 

  1168.       rn25=cn0
    1169. 

  1169.       rn30a=alv*als*amw/(tca*ars)
    1170. 

  1170.       rn30b=alv/tca
    1171. 

  1171.       rn30c=ars/(dwv*amw)
    1172. 

  1172.       rn31=1.e-17
    1173. 

  1173. 

  1174.       rn32=4.*51.545e-4
    1175. 

  1175. !
    1176. 

  1176.       rn30=2.*cpi*tng
    1177. 

  1177.       rnn30a=alv*alv*amw/(tca*ars)
    1178. 

  1178. !
    1179. 

  1179.       rn33=4.*tns
    1180. 

  1180.        rn331=.65
    1181. 

  1181.        rn332=.44*sqrt(ac3/dva)*ga5dh
    1182. 

  1182. !
    1183. 

  1183. 

  1184.     return
    1185. 

  1185.  END SUBROUTINE consat_s
    1186. 

  1186. 

  1187.  SUBROUTINE saticel_s (dt, ihail, itaobraun, ice2, istatmin, &
    1188. 

  1188.                        new_ice_sat, id, &
    1189. 

  1189.                        ptwrf, qvwrf, qlwrf, qrwrf, &
    1190. 

  1190.                        qiwrf, qswrf, qgwrf, &
    1191. 

  1191.                        rho_mks, pi_mks, p0_mks,itimestep, &
    1192. 

  1192.                        ids,ide, jds,jde, kds,kde, &
    1193. 

  1193.                        ims,ime, jms,jme, kms,kme, &
    1194. 

  1194.                        its,ite, jts,jte, kts,kte  &
    1195. 

  1195.                            )
    1196. 

  1196.     IMPLICIT NONE
    1197. 

  1197. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1198. 

  1198. !                                                                      c
    1199. 

  1199. !   Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical     c
    1200. 

  1200. !   squall-type convective line. J. Atmos. Sci., 46, 177-202.          c
    1201. 

  1201. !                                                                      c
    1202. 

  1202. !   Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water         c
    1203. 

  1203. !   saturation adjustment. Mon. Wea. Rev., 117, 231-235.               c
    1204. 

  1204. !                                                                      c
    1205. 

  1205. !   Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble     c
    1206. 

  1206. !   Model. Part I: Model description. Terrestrial, Atmospheric and     c
    1207. 

  1207. !   Oceanic Sciences, 4, 35-72.                                        c
    1208. 

  1208. !                                                                      c
    1209. 

  1209. !   Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B.         c
    1210. 

  1210. !   Ferrier,D. Johnson, A. Khain, S. Lang,  B. Lynn, C.-L. Shie,       c
    1211. 

  1211. !   D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics,    c
    1212. 

  1212. !   radiation and surface processes in the Goddard Cumulus Ensemble    c
    1213. 

  1213. !   (GCE) model, A Special Issue on Non-hydrostatic Mesoscale          c
    1214. 

  1214. !   Modeling, Meteorology and Atmospheric Physics, 82, 97-137.         c
    1215. 

  1215. !                                                                      c
    1216. 

  1216. !   Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S.        c
    1217. 

  1217. !   Rutledge, and J. Simpson, 2007: Improving simulations of           c
    1218. 

  1218. !   convective system from TRMM LBA: Easterly and Westerly regimes.    c
    1219. 

  1219. !   J. Atmos. Sci., 64, 1141-1164.                                     c
    1220. 

  1220. !                                                                      c
    1221. 

  1221. !   Tao, W.-K., J. J. Shi,  S. Lang, C. Peters-Lidard, A. Hou, S.      c
    1222. 

  1222. !   Braun, and J. Simpson, 2007: New, improved bulk-microphysical      c
    1223. 

  1223. !   schemes for studying precipitation processes in WRF. Part I:       c
    1224. 

  1224. !   Comparisons with other schemes. to appear on Mon. Wea. Rev.        C
    1225. 

  1225. !                                                                      c
    1226. 

  1226. !   Coded by Tao (1989-2003), modified by S. Lang (2006/07)            c
    1227. 

  1227. !                                                                      c
    1228. 

  1228. !   Implemented into WRF  by Roger Shi 2006/2007                       c
    1229. 

  1229. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
    1230. 

  1230. !
    1231. 

  1231. !      COMPUTE ICE PHASE MICROPHYSICS AND SATURATION PROCESSES
    1232. 

  1232. !
    1233. 

  1233.   integer,    parameter ::  nt=2880, nt2=2*nt 
    1234. 

  1234. 

  1235. !cc   using scott braun's way for pint, pidep computations
    1236. 

  1236.   integer  ::   itaobraun,ice2,ihail,new_ice_sat,id,istatmin
    1237. 

  1237.   integer  ::   itimestep
    1238. 

  1238.   real     ::   tairccri, cn0, dt
    1239. 

  1239. !cc
    1240. 

  1240. 

  1241. !JJS      common/bxyz/ n,isec,nran,kt1,kt2
    1242. 

  1242. !JJS      common/option/ lipps,ijkadv,istatmin,iwater,itoga,imlifting,lin,
    1243. 

  1243. !JJS     1   irf,iadvh,irfg,ismg,id
    1244. 

  1244. 

  1245. !JJS      common/timestat/ ndt_stat,idq
    1246. 

  1246. !JJS      common/iice/ new_ice_sat
    1247. 

  1247. !JJS      common/bt/ dt,d2t,rijl2,dts,f5,rd1,rd2,bound,al,cp,ra,ck,ce,eps,
    1248. 

  1248. !JJS     1    psfc,fcor,sec,aminut,rdt
    1249. 

  1249. 

  1250. !JJS   the following common blocks have been moved to the top of 
    1251. 

  1251. !JJS   module_mp_gsfcgce_driver_instat.F
    1252. 

  1252. 

  1253. !      common/bt/ rd1,rd2,al,cp
    1254. 

  1254. !
    1255. 

  1255. !
    1256. 

  1256. !      common/bterv/ zrc,zgc,zsc,vrc,vgc,vsc
    1257. 

  1257. !      common/size/ tnw,tns,tng,roqs,roqg,roqr
    1258. 

  1258. !      common/cont/ c38,c358,c610,c149,c879,c172,c409,c76,c218,c580,c141
    1259. 

  1259. !        common/b3cs/ ag,bg,as,bs,aw,bw,bgh,bgq,bsh,bsq,bwh,bwq
    1260. 

  1260. !      common/bsnw/ alv,alf,als,t0,t00,avc,afc,asc,rn1,bnd1,rn2,bnd2, &
    1261. 

  1261. !         rn3,rn4,rn5,rn6,rn7,rn8,rn9,rn10,rn101,rn10a,rn11,rn11a, &
    1262. 

  1262. !         rn12,rn12a(31),rn12b(31),rn13(31),rn14,rn15,rn15a,rn16,rn17, &
    1263. 

  1263. !         rn17a,rn17b,rn17c,rn18,rn18a,rn19,rn19a,rn19b,rn20,rn20a,rn20b, &
    1264. 

  1264. !         bnd3,rn21,rn22,rn23,rn23a,rn23b,rn25,rn25a(31),rn30a,rn30b, &
    1265. 

  1265. !         rn30c,rn31,beta,rn32
    1266. 

  1266. !      common/rsnw1/ rn10b,rn10c,rnn191,rnn192,rn30,rnn30a,rn33,rn331, &
    1267. 

  1267. !                    rn332
    1268. 

  1268. !JJS
    1269. 

  1269. 

  1270.   integer ids,ide,jds,jde,kds,kde
    1271. 

  1271.   integer ims,ime,jms,jme,kms,kme
    1272. 

  1272.   integer its,ite,jts,jte,kts,kte
    1273. 

  1273.   integer i,j,k, kp
    1274. 

  1274. 

  1275.   real :: a0 ,a1 ,a2 ,afcp ,alvr ,ami100 ,ami40 ,ami50 ,ascp ,avcp ,betah &
    1276. 

  1276.    ,bg3 ,bgh5 ,bs3 ,bs6 ,bsh5 ,bw3 ,bw6 ,bwh5 ,cmin ,cmin1 ,cmin2 ,cp409 &
    1277. 

  1277.    ,cp580 ,cs580 ,cv409 ,d2t ,del ,dwvp ,ee1 ,ee2 ,f00 ,f2 ,f3 ,ft ,fv0 ,fvs &
    1278. 

  1278.    ,pi0 ,pir ,pr0 ,qb0 ,r00 ,r0s ,r101f ,r10ar ,r10t ,r11at ,r11rt ,r12r ,r14f &
    1279. 

  1279.    ,r14r ,r15af ,r15ar ,r15f ,r15r ,r16r ,r17aq ,r17as ,r17r ,r18r ,r19aq ,r19as &
    1280. 

  1280.    ,r19bt ,r19rt ,r20bq ,r20bs ,r20t ,r22f ,r23af ,r23br ,r23t ,r25a ,r25rt ,r2ice &
    1281. 

  1281.    ,r31r ,r32rt ,r3f ,r4f ,r5f ,r6f ,r7r ,r8r ,r9r ,r_nci ,rft ,rijl2 ,rp0 ,rr0 &
    1282. 

  1282.    ,rrq ,rrs ,rt0 ,scc ,sccc ,sddd ,see ,seee ,sfff ,smmm ,ssss ,tb0 ,temp ,ucog &
    1283. 

  1283.    ,ucor ,ucos ,uwet ,vgcf ,vgcr ,vrcf ,vscf ,zgr ,zrr ,zsr
    1284. 

  1284. 

  1285. 

  1286.   real, dimension (its:ite,jts:jte,kts:kte) ::  fv
    1287. 

  1287.   real, dimension (its:ite,jts:jte,kts:kte) ::  dpt, dqv
    1288. 

  1288.   real, dimension (its:ite,jts:jte,kts:kte) ::  qcl, qrn,      &
    1289. 

  1289.                                                 qci, qcs, qcg
    1290. 

  1290. !JJS 10/16/06    vvvv
    1291. 

  1291. !      real dpt1(ims:ime,jms:jme,kms:kme)
    1292. 

  1292. !      real dqv1(ims:ime,jms:jme,kms:kme),
    1293. 

  1293. !     1             qcl1(ims:ime,jms:jme,kms:kme)
    1294. 

  1294. !      real qrn1(ims:ime,jms:jme,kms:kme),
    1295. 

  1295. !     1             qci1(ims:ime,jms:jme,kms:kme)
    1296. 

  1296. !      real qcs1(ims:ime,jms:jme,kms:kme),
    1297. 

  1297. !     1             qcg1(ims:ime,jms:jme,kms:kme)
    1298. 

  1298. !JJS 10/16/06    ^^^^
    1299. 

  1299. 

  1300. !JJS
    1301. 

  1301. 

  1302.   real, dimension (ims:ime, kms:kme, jms:jme) ::  ptwrf, qvwrf 
    1303. 

  1303.   real, dimension (ims:ime, kms:kme, jms:jme) ::  qlwrf, qrwrf,        &
    1304. 

  1304.                                                   qiwrf, qswrf, qgwrf
    1305. 

  1305. !JJS 10/16/06    vvvv
    1306. 

  1306. !      real ptwrfold(ims:ime, kms:kme, jms:jme)
    1307. 

  1307. !      real qvwrfold(ims:ime, kms:kme, jms:jme),
    1308. 

  1308. !     1             qlwrfold(ims:ime, kms:kme, jms:jme)
    1309. 

  1309. !      real qrwrfold(ims:ime, kms:kme, jms:jme),
    1310. 

  1310. !     1             qiwrfold(ims:ime, kms:kme, jms:jme)
    1311. 

  1311. !      real qswrfold(ims:ime, kms:kme, jms:jme),
    1312. 

  1312. !     1             qgwrfold(ims:ime, kms:kme, jms:jme)
    1313. 

  1313. !JJS 10/16/06    ^^^^
    1314. 

  1314. 

  1315. !JJS in MKS
    1316. 

  1316.   real, dimension (ims:ime, kms:kme, jms:jme) ::  rho_mks
    1317. 

  1317.   real, dimension (ims:ime, kms:kme, jms:jme) ::  pi_mks
    1318. 

  1318.   real, dimension (ims:ime, kms:kme, jms:jme) ::  p0_mks
    1319. 

  1319. !JJS
    1320. 

  1320. !  real, dimension (its:ite,jts:jte,kts:kte) ::  ww1
    1321. 

  1321. !  real, dimension (its:ite,jts:jte,kts:kte) ::  rsw
    1322. 

  1322. !  real, dimension (its:ite,jts:jte,kts:kte) ::  rlw
    1323. 

  1323. 

  1324. !JJS      COMMON /BADV/
    1325. 

  1325.   real, dimension (its:ite,jts:jte) ::        &
    1326. 

  1326.            vg,      zg,       &
    1327. 

  1327.            ps,      pg,       &
    1328. 

  1328.           prn,     psn,       &
    1329. 

  1329.         pwacs,   wgacr,       &
    1330. 

  1330.         pidep,    pint,       &
    1331. 

  1331.           qsi,     ssi,       &
    1332. 

  1332.           esi,     esw,       &
    1333. 

  1333.           qsw,      pr,       &
    1334. 

  1334.           ssw,   pihom,       &
    1335. 

  1335.          pidw,   pimlt,       &
    1336. 

  1336.         psaut,   qracs,       &
    1337. 

  1337.         psaci,   psacw,       &
    1338. 

  1338.         qsacw,   praci,       &
    1339. 

  1339.         pmlts,   pmltg,       &
    1340. 

  1340.         asss,       y1,    y2
    1341. 

  1341. !JJS       Y2(its:ite,jts:jte),    DDE(NB)
    1342. 

  1342. 

  1343. !JJS      COMMON/BSAT/
    1344. 

  1344.   real, dimension (its:ite,jts:jte) ::        &
    1345. 

  1345.         praut,   pracw,       &
    1346. 

  1346.          psfw,    psfi,       &
    1347. 

  1347.         dgacs,   dgacw,       &
    1348. 

  1348.         dgaci,   dgacr,       &
    1349. 

  1349.         pgacs,   wgacs,       &
    1350. 

  1350.         qgacw,   wgaci,       &
    1351. 

  1351.         qgacr,   pgwet,       &
    1352. 

  1352.         pgaut,   pracs,       &
    1353. 

  1353.         psacr,   qsacr,       &
    1354. 

  1354.          pgfr,   psmlt,       &
    1355. 

  1355.         pgmlt,   psdep,       &
    1356. 

  1356.         pgdep,   piacr,       &
    1357. 

  1357.            y5,     scv,       &
    1358. 

  1358.           tca,     dwv,       &
    1359. 

  1359.           egs,      y3,       &
    1360. 

  1360.            y4,     ddb
    1361. 

  1361. 

  1362. !JJS      COMMON/BSAT1/
    1363. 

  1363.   real, dimension (its:ite,jts:jte) ::        &
    1364. 

  1364.            pt,      qv,       &
    1365. 

  1365.            qc,      qr,       &
    1366. 

  1366.            qi,      qs,       &
    1367. 

  1367.            qg,    tair,       &
    1368. 

  1368.         tairc,   rtair,       &
    1369. 

  1369.           dep,      dd,       &
    1370. 

  1370.           dd1,     qvs,       &
    1371. 

  1371.            dm,      rq,       &
    1372. 

  1372.         rsub1,     col,       &
    1373. 

  1373.           cnd,     ern,       &
    1374. 

  1374.          dlt1,    dlt2,       &
    1375. 

  1375.          dlt3,    dlt4,       &
    1376. 

  1376.            zr,      vr,       &
    1377. 

  1377.            zs,      vs,       &
    1378. 

  1378.                  pssub,       &
    1379. 

  1379.         pgsub,     dda
    1380. 

  1380. 

  1381. !JJS      COMMON/B5/
    1382. 

  1382.   real, dimension (its:ite,jts:jte,kts:kte) ::  rho
    1383. 

  1383.   real, dimension (kts:kte) ::                 & 
    1384. 

  1384.            tb,      qb,    rho1,              &
    1385. 

  1385.            ta,      qa,     ta1,     qa1,     &
    1386. 

  1386.          coef,      z1,      z2,      z3,     &
    1387. 

  1387.            am,     am1,      ub,      vb,     &
    1388. 

  1388.            wb,     ub1,     vb1,    rrho,     &
    1389. 

  1389.         rrho1,     wbx
    1390. 

  1390. 

  1391. !JJS      COMMON/B6/
    1392. 

  1392.   real, dimension (its:ite,jts:jte,kts:kte) ::  p0, pi, f0
    1393. 

  1393.   real, dimension (kts:kte) ::    & 
    1394. 

  1394.            fd,      fe,        &
    1395. 

  1395.            st,      sv,        &
    1396. 

  1396.            sq,      sc,        &
    1397. 

  1397.            se,     sqa
    1398. 

  1398. 

  1399. !JJS      COMMON/BRH1/
    1400. 

  1400.   real, dimension (kts:kte) ::    & 
    1401. 

  1401.          srro,    qrro,    sqc,    sqr,    &
    1402. 

  1402.           sqi,     sqs,    sqg,   stqc,    &
    1403. 

  1403.          stqr,    stqi,   stqs,   stqg
    1404. 

  1404.   real, dimension (nt) ::    & 
    1405. 

  1405.           tqc,     tqr,    tqi,    tqs,    tqg
    1406. 

  1406. 

  1407. !JJS     common/bls/ y0(nx,ny),ts0new(nx,ny),qss0new(nx,ny)
    1408. 

  1408. 

  1409. !JJS      COMMON/BLS/
    1410. 

  1410.   real, dimension (ims:ime,jms:jme) ::     &
    1411. 

  1411.            y0,     ts0,   qss0
    1412. 

  1412. 

  1413. !JJS      COMMON/BI/ IT(its:ite,jts:jte), ICS(its:ite,jts:jte,4)
    1414. 

  1414.   integer, dimension (its:ite,jts:jte) ::        it  
    1415. 

  1415.   integer, dimension (its:ite,jts:jte, 4) ::    ics 
    1416. 

  1416. 

  1417.   integer :: i24h
    1418. 

  1418.   integer :: iwarm
    1419. 

  1419.   real :: r2is, r2ig
    1420. 

  1420.   
    1421. 

  1421. 

  1422. !JJS      COMMON/MICRO/
    1423. 

  1423. !  real, dimension (ims:ime,kms:kme,jms:jme)  ::    dbz 
    1424. 

  1424. 

  1425. !23456789012345678901234567890123456789012345678901234567890123456789012
    1426. 

  1426. 

  1427. !
    1428. 

  1428. !JJS 1/3/2008  vvvvv
    1429. 

  1429. !JJS   the following common blocks have been moved to the top of
    1430. 

  1430. !JJS   module_mp_gsfcgce_driver.F
    1431. 

  1431. 

  1432. !  real, dimension (31)   ::      aa1,  aa2
    1433. 

  1433. !  data aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5,     &
    1434. 

  1434. !           .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6,     &
    1435. 

  1435. !           .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4,     &
    1436. 

  1436. !           .1725e-4, .9175e-5, .44…
    1437.

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