PageRenderTime 85ms CodeModel.GetById 17ms RepoModel.GetById 1ms app.codeStats 1ms

/wrfv2_fire/phys/module_ra_cam.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 7901 lines | 4745 code | 545 blank | 2611 comment | 157 complexity | 1d2649a1c0515f0f3dc8a5f07df2f95b MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. MODULE module_ra_cam
    2. 

  2.   use module_ra_cam_support
    3. 

  3.   use module_cam_support, only: endrun
    4. 

  4. 

  5.   implicit none
    6. 

  6. ! 
    7. 

  7. ! A. Slingo's data for cloud particle radiative properties (from 'A GCM
    8. 

  8. ! Parameterization for the Shortwave Properties of Water Clouds' JAS
    9. 

  9. ! vol. 46 may 1989 pp 1419-1427)
    10. 

  10. ! 
    11. 

  11.    real(r8) abarl(4)         ! A coefficient for extinction optical depth
    12. 

  12.    real(r8) bbarl(4)         ! B coefficient for extinction optical depth
    13. 

  13.    real(r8) cbarl(4)         ! C coefficient for single scat albedo
    14. 

  14.    real(r8) dbarl(4)         ! D coefficient for single  scat albedo
    15. 

  15.    real(r8) ebarl(4)         ! E coefficient for asymmetry parameter
    16. 

  16.    real(r8) fbarl(4)         ! F coefficient for asymmetry parameter
    17. 

  17. 

  18.    save abarl, bbarl, cbarl, dbarl, ebarl, fbarl
    19. 

  19. 

  20.    data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/
    21. 

  21.    data bbarl/ 1.305    , 1.346    ,1.454    ,1.641    /
    22. 

  22.    data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201    /
    23. 

  23.    data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 /
    24. 

  24.    data ebarl/ 0.829    , 0.794    ,0.754    ,0.826    /
    25. 

  25.    data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/
    26. 

  26. 

  27. #if 0
    28. 

  28. ! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
    29. 

  29.    real(r8) abarli           ! A coefficient for current spectral band
    30. 

  30.    real(r8) bbarli           ! B coefficient for current spectral band
    31. 

  31.    real(r8) cbarli           ! C coefficient for current spectral band
    32. 

  32.    real(r8) dbarli           ! D coefficient for current spectral band
    33. 

  33.    real(r8) ebarli           ! E coefficient for current spectral band
    34. 

  34.    real(r8) fbarli           ! F coefficient for current spectral band
    35. 

  35. #endif
    36. 

  36. ! 
    37. 

  37. ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor
    38. 

  38. ! greater than 20 micro-meters
    39. 

  39. ! 
    40. 

  40. ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836)
    41. 

  41. ! 
    42. 

  42.    real(r8) abari(4)         ! a coefficient for extinction optical depth
    43. 

  43.    real(r8) bbari(4)         ! b coefficient for extinction optical depth
    44. 

  44.    real(r8) cbari(4)         ! c coefficient for single scat albedo
    45. 

  45.    real(r8) dbari(4)         ! d coefficient for single scat albedo
    46. 

  46.    real(r8) ebari(4)         ! e coefficient for asymmetry parameter
    47. 

  47.    real(r8) fbari(4)         ! f coefficient for asymmetry parameter
    48. 

  48. 

  49.    save abari, bbari, cbari, dbari, ebari, fbari
    50. 

  50. 

  51.    data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/
    52. 

  52.    data bbari/ 2.431    , 2.431    ,2.431    ,2.431    /
    53. 

  53.    data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658   /
    54. 

  54.    data dbari/ 0.0      , 1.405e-05,8.328e-04,2.05e-05 /
    55. 

  55.    data ebari/ 0.7661   , 0.7730   ,0.794    ,0.9595   /
    56. 

  56.    data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/
    57. 

  57. 

  58. #if 0
    59. 

  59. ! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
    60. 

  60.    real(r8) abarii           ! A coefficient for current spectral band
    61. 

  61.    real(r8) bbarii           ! B coefficient for current spectral band
    62. 

  62.    real(r8) cbarii           ! C coefficient for current spectral band
    63. 

  63.    real(r8) dbarii           ! D coefficient for current spectral band
    64. 

  64.    real(r8) ebarii           ! E coefficient for current spectral band
    65. 

  65.    real(r8) fbarii           ! F coefficient for current spectral band
    66. 

  66. #endif
    67. 

  67. ! 
    68. 

  68.    real(r8) delta            ! Pressure (in atm) for stratos. h2o limit
    69. 

  69.    real(r8) o2mmr            ! O2 mass mixing ratio:
    70. 

  70. 

  71.    save delta, o2mmr
    72. 

  72. 

  73. !
    74. 

  74. ! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4
    75. 

  75. !
    76. 

  76.    data delta / 0.0014257179260883 /
    77. 

  77. !
    78. 

  78. ! END UPDATE
    79. 

  79. !
    80. 

  80.    data o2mmr / .23143 /
    81. 

  81. 

  82. ! Next series depends on spectral interval
    83. 

  83. ! 
    84. 

  84.    real(r8) frcsol(nspint)   ! Fraction of solar flux in spectral interval
    85. 

  85.    real(r8) wavmin(nspint)   ! Min wavelength (micro-meters) of interval
    86. 

  86.    real(r8) wavmax(nspint)   ! Max wavelength (micro-meters) of interval
    87. 

  87.    real(r8) raytau(nspint)   ! Rayleigh scattering optical depth
    88. 

  88.    real(r8) abh2o(nspint)    ! Absorption coefficiant for h2o (cm2/g)
    89. 

  89.    real(r8) abo3 (nspint)    ! Absorption coefficiant for o3  (cm2/g)
    90. 

  90.    real(r8) abco2(nspint)    ! Absorption coefficiant for co2 (cm2/g)
    91. 

  91.    real(r8) abo2 (nspint)    ! Absorption coefficiant for o2  (cm2/g)
    92. 

  92.    real(r8) ph2o(nspint)     ! Weight of h2o in spectral interval
    93. 

  93.    real(r8) pco2(nspint)     ! Weight of co2 in spectral interval
    94. 

  94.    real(r8) po2 (nspint)     ! Weight of o2  in spectral interval
    95. 

  95.    real(r8) nirwgt(nspint)   ! Spectral Weights to simulate Nimbus-7 filter
    96. 

  96.    save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , &
    97. 

  97.         abco2  ,abo2   ,ph2o   ,pco2   ,po2   ,nirwgt
    98. 

  98. 

  99.    data frcsol / .001488, .001389, .001290, .001686, .002877, &
    100. 

  100.                  .003869, .026336, .360739, .065392, .526861, &
    101. 

  101.                  .526861, .526861, .526861, .526861, .526861, &
    102. 

  102.                  .526861, .006239, .001834, .001834/
    103. 

  103. ! 
    104. 

  104. ! weight for 0.64 - 0.7 microns  appropriate to clear skies over oceans
    105. 

  105. ! 
    106. 

  106.    data nirwgt /  0.0,   0.0,   0.0,      0.0,   0.0, &
    107. 

  107.                   0.0,   0.0,   0.0, 0.320518,   1.0,  1.0, &
    108. 

  108.                   1.0,   1.0,   1.0,      1.0,   1.0, &
    109. 

  109.                   1.0,   1.0,   1.0 /
    110. 

  110. 

  111.    data wavmin / .200,  .245,  .265,  .275,  .285, &
    112. 

  112.                  .295,  .305,  .350,  .640,  .700,  .701, &
    113. 

  113.                  .701,  .701,  .701,  .702,  .702, &
    114. 

  114.                  2.630, 4.160, 4.160/
    115. 

  115. 

  116.    data wavmax / .245,  .265,  .275,  .285,  .295, &
    117. 

  117.                  .305,  .350,  .640,  .700, 5.000, 5.000, &
    118. 

  118.                  5.000, 5.000, 5.000, 5.000, 5.000, &
    119. 

  119.                  2.860, 4.550, 4.550/
    120. 

  120. 

  121. !
    122. 

  122. ! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4
    123. 

  123. !
    124. 

  124.    real(r8) v_raytau_35
    125. 

  125.    real(r8) v_raytau_64
    126. 

  126.    real(r8) v_abo3_35
    127. 

  127.    real(r8) v_abo3_64
    128. 

  128.    parameter( &
    129. 

  129.         v_raytau_35 = 0.155208, &
    130. 

  130.         v_raytau_64 = 0.0392, &
    131. 

  131.         v_abo3_35 = 2.4058030e+01, &  
    132. 

  132.         v_abo3_64 = 2.210e+01 &
    133. 

  133.         )
    134. 

  134. 

  135.    data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, &
    136. 

  136.                   1.085, 0.730, v_raytau_35, v_raytau_64, &
    137. 

  137.                   0.02899756, 0.01356763, 0.00537341, &
    138. 

  138.                   0.00228515, 0.00105028, 0.00046631, &
    139. 

  139.                   0.00025734, &
    140. 

  140.                  .0001, .0001, .0001/
    141. 

  141. !
    142. 

  142. ! END UPDATE
    143. 

  143. !
    144. 

  144. 

  145. ! 
    146. 

  146. ! Absorption coefficients
    147. 

  147. ! 
    148. 

  148. !
    149. 

  149. ! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4
    150. 

  150. !
    151. 

  151.    data abh2o /    .000,     .000,    .000,    .000,    .000, &
    152. 

  152.                    .000,     .000,    .000,    .000,    &
    153. 

  153.                    0.00256608,  0.06310504,   0.42287445, 2.45397941, &
    154. 

  154.                   11.20070807, 47.66091389, 240.19010243, &
    155. 

  155.                    .000,    .000,    .000/
    156. 

  156. !
    157. 

  157. ! END UPDATE
    158. 

  158. !
    159. 

  159. 

  160.    data abo3  /5.370e+04, 13.080e+04,  9.292e+04, 4.530e+04, 1.616e+04, &
    161. 

  161.                4.441e+03,  1.775e+02, v_abo3_35, v_abo3_64,      .000, &
    162. 

  162.                .000,   .000    ,   .000   ,   .000   ,      .000, &
    163. 

  163.                .000,   .000    ,   .000   ,   .000    /
    164. 

  164. 

  165.    data abco2  /   .000,     .000,    .000,    .000,    .000, &
    166. 

  166.                    .000,     .000,    .000,    .000,    .000, &
    167. 

  167.                    .000,     .000,    .000,    .000,    .000, &
    168. 

  168.                    .000,     .094,    .196,   1.963/
    169. 

  169. 

  170.    data abo2  /    .000,     .000,    .000,    .000,    .000, &
    171. 

  171.                    .000,     .000,    .000,1.11e-05,6.69e-05, &
    172. 

  172.                    .000,     .000,    .000,    .000,    .000, &  
    173. 

  173.                    .000,     .000,    .000,    .000/
    174. 

  174. ! 
    175. 

  175. ! Spectral interval weights
    176. 

  176. ! 
    177. 

  177.    data ph2o  /    .000,     .000,    .000,    .000,    .000, &
    178. 

  178.         .000,     .000,    .000,    .000,    .505,     &
    179. 

  179.         .210,     .120,    .070,    .048,    .029,     &
    180. 

  180.         .018,     .000,    .000,    .000/
    181. 

  181. 

  182.    data pco2  /    .000,     .000,    .000,    .000,    .000, &
    183. 

  183.         .000,     .000,    .000,    .000,    .000,     &
    184. 

  184.         .000,     .000,    .000,    .000,    .000,     &
    185. 

  185.         .000,    1.000,    .640,    .360/
    186. 

  186. 

  187.    data po2   /    .000,     .000,    .000,    .000,    .000, &
    188. 

  188.         .000,     .000,    .000,   1.000,   1.000,     &
    189. 

  189.         .000,     .000,    .000,    .000,    .000,     &
    190. 

  190.         .000,     .000,    .000,    .000/
    191. 

  191. 

  192.    real(r8) amo                 ! Molecular weight of ozone (g/mol)
    193. 

  193.    save     amo
    194. 

  194. 

  195.    data amo   /  48.0000   /
    196. 

  196. 

  197. contains
    198. 

  198. subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
    199. 

  199.                      dolw,dosw,                                    &
    200. 

  200.                      SWUPT,SWUPTC,SWDNT,SWDNTC,                    &
    201. 

  201.                      LWUPT,LWUPTC,LWDNT,LWDNTC,                    &
    202. 

  202.                      SWUPB,SWUPBC,SWDNB,SWDNBC,                    &
    203. 

  203.                      LWUPB,LWUPBC,LWDNB,LWDNBC,                    &
    204. 

  204.                      swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr,   &
    205. 

  205.                      GSW,GLW,XLAT,XLONG,                           &
    206. 

  206.                      ALBEDO,t_phy,TSK,EMISS,                       &
    207. 

  207.                      QV3D,QC3D,QR3D,QI3D,QS3D,QG3D,                &
    208. 

  208.                      ALSWVISDIR,ALSWVISDIF,                        & !ssib  
    209. 

  209.                      ALSWNIRDIR,ALSWNIRDIF,                        & !ssib 
    210. 

  210.                      SWVISDIR,SWVISDIF,                            & !ssib 
    211. 

  211.                      SWNIRDIR,SWNIRDIF,                            & !ssib 
    212. 

  212.                      sf_surface_physics,                           & !ssib 
    213. 

  213.                      F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,                &
    214. 

  214.                      f_ice_phy,f_rain_phy,                         &
    215. 

  215.                      p_phy,p8w,z,pi_phy,rho_phy,dz8w,               &
    216. 

  216.                      CLDFRA,XLAND,XICE,SNOW,                        &
    217. 

  217.                      ozmixm,pin0,levsiz,num_months,                 &
    218. 

  218.                      m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0,       &
    219. 

  219.                      cam_abs_dim1, cam_abs_dim2,                    &
    220. 

  220.                      paerlev,naer_c,                                &
    221. 

  221.                      GMT,JULDAY,JULIAN,YR,DT,XTIME,DECLIN,SOLCON,         &
    222. 

  222.                      RADT,DEGRAD,n_cldadv,                                  &
    223. 

  223.                      abstot_3d, absnxt_3d, emstot_3d,              &
    224. 

  224.                      doabsems,                                     &
    225. 

  225.                      ids,ide, jds,jde, kds,kde,                    &
    226. 

  226.                      ims,ime, jms,jme, kms,kme,                    &
    227. 

  227.                      its,ite, jts,jte, kts,kte                     )
    228. 

  228. 

  229.    USE module_wrf_error
    230. 

  230.    USE module_state_description, ONLY : SSIBSCHEME              !ssib
    231. 

  231. 

  232. !------------------------------------------------------------------
    233. 

  233.    IMPLICIT NONE
    234. 

  234. !------------------------------------------------------------------
    235. 

  235. 

  236.    INTEGER,    INTENT(IN   ) ::        ids,ide, jds,jde, kds,kde, &
    237. 

  237.                                        ims,ime, jms,jme, kms,kme, &
    238. 

  238.                                        its,ite, jts,jte, kts,kte
    239. 

  239.    LOGICAL,    INTENT(IN   ) ::        F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
    240. 

  240.    LOGICAL,    INTENT(INout) ::        doabsems
    241. 

  241.    LOGICAL,    INTENT(IN   ) ::        dolw,dosw
    242. 

  242. 

  243.    INTEGER,    INTENT(IN  )  ::        n_cldadv
    244. 

  244.    INTEGER,    INTENT(IN  )  ::        JULDAY
    245. 

  245.    REAL,       INTENT(IN  )  ::        JULIAN
    246. 

  246.    INTEGER,    INTENT(IN  )  ::        YR
    247. 

  247.    REAL,       INTENT(IN  )  ::        DT
    248. 

  248.    INTEGER,      INTENT(IN   )    ::   levsiz, num_months
    249. 

  249.    INTEGER,      INTENT(IN   )    ::   paerlev, naer_c
    250. 

  250.    INTEGER,      INTENT(IN   )    ::   cam_abs_dim1, cam_abs_dim2
    251. 

  251. 

  252. 

  253.    REAL, INTENT(IN    )      ::        RADT,DEGRAD,             &
    254. 

  254.                                        XTIME,DECLIN,SOLCON,GMT
    255. 

  255. !
    256. 

  256. !
    257. 

  257.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
    258. 

  258.          INTENT(IN    ) ::                                   P_PHY, &
    259. 

  259.                                                            P8W, &
    260. 

  260.                                                              Z, &
    261. 

  261.                                                             pi_PHY, &
    262. 

  262.                                                            rho_PHY, &
    263. 

  263.                                                               dz8w, &
    264. 

  264.                                                              T_PHY, &
    265. 

  265.                                                             QV3D, &
    266. 

  266.                                                             QC3D, &
    267. 

  267.                                                             QR3D, &
    268. 

  268.                                                             QI3D, &
    269. 

  269.                                                             QS3D, &
    270. 

  270.                                                             QG3D, &
    271. 

  271.                                                         CLDFRA
    272. 

  272. 

  273.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
    274. 

  274.          INTENT(INOUT)  ::                              RTHRATENLW, &
    275. 

  275.                                                         RTHRATENSW
    276. 

  276. !
    277. 

  277.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    278. 

  278.          INTENT(IN   )  ::                                  XLAT, &
    279. 

  279.                                                            XLONG, &
    280. 

  280.                                                            XLAND, &
    281. 

  281.                                                            XICE, &
    282. 

  282.                                                            SNOW, &
    283. 

  283.                                                            EMISS, &
    284. 

  284.                                                              TSK, &
    285. 

  285.                                                              ALBEDO
    286. 

  286. 

  287.    REAL,  DIMENSION( ims:ime, levsiz, jms:jme, num_months ),      &
    288. 

  288.           INTENT(IN   ) ::                                  OZMIXM
    289. 

  289. 

  290.    REAL,  DIMENSION(levsiz), INTENT(IN )  ::                   PIN0
    291. 

  291. 

  292.    REAL,  DIMENSION(ims:ime,jms:jme), INTENT(IN )  ::      m_psp,m_psn
    293. 

  293.    REAL,  DIMENSION(paerlev), intent(in)             ::      m_hybi0
    294. 

  294.    REAL,  DIMENSION( ims:ime, paerlev, jms:jme, naer_c ),      &
    295. 

  295.           INTENT(IN   ) ::                    aerosolcp, aerosolcn
    296. 

  296. 

  297. !
    298. 

  298.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    299. 

  299.          INTENT(INOUT)  ::                                   GSW, GLW
    300. 

  300. 

  301. !---------SSiB variables (fds 06/2010)----------------
    302. 

  302.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    303. 

  303.          INTENT(IN)     ::                            ALSWVISDIR, &
    304. 

  304.                                                       ALSWVISDIF, &
    305. 

  305.                                                       ALSWNIRDIR, &
    306. 

  306.                                                       ALSWNIRDIF
    307. 

  307. 

  308.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    309. 

  309.          INTENT(OUT)    ::                              SWVISDIR, &
    310. 

  310.                                                         SWVISDIF, &
    311. 

  311.                                                         SWNIRDIR, &
    312. 

  312.                                                         SWNIRDIF
    313. 

  313.    INTEGER, INTENT(IN) :: sf_surface_physics
    314. 

  314. !--------------------------------------
    315. 

  315. ! saving arrays for doabsems reduction of radiation calcs
    316. 

  316. 

  317.    REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ),           &
    318. 

  318.          INTENT(INOUT)  ::                                  abstot_3d
    319. 

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

  320.          INTENT(INOUT)  ::                                  absnxt_3d
    321. 

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

  322.          INTENT(INOUT)  ::                                  emstot_3d
    323. 

  323. 

  324. 

  325. ! Added outputs of total and clearsky fluxes etc
    326. 

  326. ! Note that k=1 refers to the half level below the model lowest level (Sfc)
    327. 

  327. !           k=kme refers to the half level above the model highest level (TOA)
    328. 

  328. !
    329. 

  329. !   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                &
    330. 

  330. !         INTENT(INOUT)  ::                                  swup, &
    331. 

  331. !                                                       swupclear, &
    332. 

  332. !                                                            swdn, &
    333. 

  333. !                                                       swdnclear, &
    334. 

  334. !                                                            lwup, &
    335. 

  335. !                                                       lwupclear, &
    336. 

  336. !                                                            lwdn, &
    337. 

  337. !                                                       lwdnclear
    338. 

  338. 

  339.    REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
    340. 

  340.                     SWUPT,SWUPTC,SWDNT,SWDNTC,                    &
    341. 

  341.                     LWUPT,LWUPTC,LWDNT,LWDNTC,                    &
    342. 

  342.                     SWUPB,SWUPBC,SWDNB,SWDNBC,                    &
    343. 

  343.                     LWUPB,LWUPBC,LWDNB,LWDNBC
    344. 

  344. 

  345.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    346. 

  346.          INTENT(INOUT)  ::                                  swcf, &
    347. 

  347.                                                             lwcf, &
    348. 

  348.                                                              olr, &
    349. 

  349.                                                             coszr    
    350. 

  350.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
    351. 

  351.          INTENT(OUT   )  ::                               cemiss, &        ! cloud emissivity for isccp
    352. 

  352.                                                          taucldc, &        ! cloud water optical depth for isccp
    353. 

  353.                                                          taucldi           ! cloud ice optical depth for isccp
    354. 

  354. !
    355. 

  355. !
    356. 

  356.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                     &
    357. 

  357.          INTENT(IN   ) ::                                            &
    358. 

  358.                                                           F_ICE_PHY, &
    359. 

  359.                                                          F_RAIN_PHY
    360. 

  360. 

  361. 

  362. ! LOCAL VARIABLES
    363. 

  363.  
    364. 

  364.    INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp
    365. 

  365.    INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n
    366. 

  366.    integer :: begchunk, endchunk
    367. 

  367.    integer :: nyrm, nyrp
    368. 

  368.    real(r8) doymodel, doydatam, doydatap, deltat, fact1, fact2
    369. 

  369. 

  370.    REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24
    371. 

  371.  
    372. 

  372.    real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups
    373. 

  373.    real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps
    374. 

  374.    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t
    375. 

  375.    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) ::  pint, lnpint
    376. 

  376.    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q
    377. 

  377. !   real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm       ! reference pressures at midpoints
    378. 

  378. !   real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi       ! reference pressures at interfaces
    379. 

  379.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: cicewp      ! in-cloud cloud ice water path
    380. 

  380.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: cliqwp      ! in-cloud cloud liquid water path
    381. 

  381.     real(r8), dimension(  1:ite-its+1, 0:kte-kts+1 ) :: tauxcl      ! cloud water optical depth
    382. 

  382.     real(r8), dimension(  1:ite-its+1, 0:kte-kts+1 ) :: tauxci      ! cloud ice optical depth
    383. 

  383.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: emis        ! cloud emissivity
    384. 

  384.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: rel         ! effective drop radius (microns)
    385. 

  385.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: rei         ! ice effective drop size (microns)
    386. 

  386.     real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn      ! Maximum values of pressure for each
    387. 

  387.     integer , dimension(  1:ite-its+1 ) :: nmxrgn               ! Number of maximally overlapped regions
    388. 

  388. 

  389.    real(r8), dimension(  1:ite-its+1 ) :: fsns          ! Surface absorbed solar flux
    390. 

  390.    real(r8), dimension(  1:ite-its+1 ) :: fsnt          ! Net column abs solar flux at model top
    391. 

  391.    real(r8), dimension(  1:ite-its+1 ) :: flns          ! Srf longwave cooling (up-down) flux
    392. 

  392.    real(r8), dimension(  1:ite-its+1 ) :: flnt          ! Net outgoing lw flux at model top
    393. 

  393. ! Added outputs of total and clearsky fluxes etc
    394. 

  394.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsup        ! Upward total sky solar
    395. 

  395.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsupc       ! Upward clear sky solar
    396. 

  396.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsdn        ! Downward total sky solar
    397. 

  397.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsdnc       ! Downward clear sky solar
    398. 

  398.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: flup        ! Upward total sky longwave
    399. 

  399.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: flupc       ! Upward clear sky longwave
    400. 

  400.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fldn        ! Downward total sky longwave
    401. 

  401.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fldnc       ! Downward clear sky longwave
    402. 

  402.    real(r8), dimension(  1:ite-its+1 ) :: swcftoa                 ! Top of the atmosphere solar cloud forcing
    403. 

  403.    real(r8), dimension(  1:ite-its+1 ) :: lwcftoa                 ! Top of the atmosphere longwave cloud forcing
    404. 

  404.    real(r8), dimension(  1:ite-its+1 ) :: olrtoa                  ! Top of the atmosphere outgoing longwave 
    405. 

  405. !
    406. 

  406.    real(r8), dimension(  1:ite-its+1 ) :: sols          ! Downward solar rad onto surface (sw direct)
    407. 

  407.    real(r8), dimension(  1:ite-its+1 ) :: soll          ! Downward solar rad onto surface (lw direct)
    408. 

  408.    real(r8), dimension(  1:ite-its+1 ) :: solsd         ! Downward solar rad onto surface (sw diffuse)
    409. 

  409.    real(r8), dimension(  1:ite-its+1 ) :: solld         ! Downward solar rad onto surface (lw diffuse)
    410. 

  410.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: qrs      ! Solar heating rate
    411. 

  411.    real(r8), dimension(  1:ite-its+1 ) :: fsds          ! Flux Shortwave Downwelling Surface
    412. 

  412.    real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: qrl      ! Longwave cooling rate
    413. 

  413.    real(r8), dimension(  1:ite-its+1 ) :: flwds          ! Surface down longwave flux
    414. 

  414.    real(r8), dimension(  1:ite-its+1, levsiz, num_months ) :: ozmixmj        ! monthly ozone mixing ratio
    415. 

  415.    real(r8), dimension(  1:ite-its+1, levsiz ) :: ozmix          ! ozone mixing ratio (time interpolated)
    416. 

  416.    real(r8), dimension(levsiz)         :: pin            ! ozone pressure level
    417. 

  417.    real(r8), dimension(1:ite-its+1)    :: m_psjp,m_psjn          ! MATCH surface pressure
    418. 

  418.    real(r8), dimension(  1:ite-its+1, paerlev, naer_c ) :: aerosoljp        ! monthly aerosol concentrations
    419. 

  419.    real(r8), dimension(  1:ite-its+1, paerlev, naer_c ) :: aerosoljn        ! monthly aerosol concentrations
    420. 

  420.    real(r8), dimension(paerlev)                           :: m_hybi
    421. 

  421.    real(r8), dimension(1:ite-its+1 )          :: clat           ! latitude in radians for columns
    422. 

  422.    real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity
    423. 

  423.    real(r8), dimension(its:ite,kts:kte,4)           :: absnxt ! Total nearest layer absorptivity
    424. 

  424.    real(r8), dimension(its:ite,kts:kte+1)           :: emstot ! Total emissivity
    425. 

  425.    CHARACTER(LEN=256) :: msgstr
    426. 

  426. 

  427. #if !defined(MAC_KLUDGE)
    428. 

  428.    lchnk = 1
    429. 

  429.    begchunk = ims
    430. 

  430.    endchunk = ime
    431. 

  431.    ncol = ite - its + 1
    432. 

  432.    pcols= ite - its + 1
    433. 

  433.    pver = kte - kts + 1
    434. 

  434.    pverp= pver + 1
    435. 

  435.    pverr = kte - kts + 1
    436. 

  436.    pverrp= pverr + 1
    437. 

  437. ! number of advected constituents and non-advected constituents (including water vapor)
    438. 

  438.    ppcnst = n_cldadv
    439. 

  439. ! number of non-advected constituents
    440. 

  440.    pnats = 0
    441. 

  441.    pcnst = ppcnst-pnats
    442. 

  442. 

  443. ! check the # species defined for the input climatology and naer
    444. 

  444. 

  445. !  if(naer_c.ne.naer) then
    446. 

  446. !            WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer
    447. 

  447.    if(naer_c.ne.naer_all) then
    448. 

  448.              WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all
    449. 

  449.              CALL wrf_error_fatal ( wrf_err_message )
    450. 

  450.    endif 
    451. 

  451. 

  452. ! update CO2 volume mixing ratio (co2vmr)
    453. 

  453.   
    454. 

  454. ! determine time interpolation factors, check sanity
    455. 

  455. ! of interpolation factors to within 32-bit roundoff
    456. 

  456. ! assume that day of year is 1 for all input data
    457. 

  457. !
    458. 

  458.    nyrm     = yr - yrdata(1) + 1
    459. 

  459.    nyrp     = nyrm + 1
    460. 

  460.    doymodel = yr*365.    + julian
    461. 

  461.    doydatam = yrdata(nyrm)*365. + 1.
    462. 

  462.    doydatap = yrdata(nyrp)*365. + 1.
    463. 

  463.    deltat   = doydatap - doydatam
    464. 

  464.    fact1    = (doydatap - doymodel)/deltat
    465. 

  465.    fact2    = (doymodel - doydatam)/deltat
    466. 

  466.    co2vmr = (co2(nyrm)*fact1 + co2(nyrp)*fact2)*1.e-06
    467. 

  467. 

  468.    co2mmr=co2vmr*mwco2/mwdry
    469. 

  469. !
    470. 

  470. !===================================================
    471. 

  471. ! Radiation computations
    472. 

  472. !===================================================
    473. 

  473. 

  474.       do k=1,levsiz
    475. 

  475.       pin(k)=pin0(k)
    476. 

  476.       enddo
    477. 

  477. 

  478.       do k=1,paerlev
    479. 

  479.       m_hybi(k)=m_hybi0(k)
    480. 

  480.       enddo
    481. 

  481. 

  482. ! check for uninitialized arrays
    483. 

  483.       if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems .and. dolw)then
    484. 

  484.         CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart')
    485. 

  485.         doabsems = .true.
    486. 

  486.       endif
    487. 

  487. 

  488.    do j =jts,jte
    489. 

  489. 

  490. !
    491. 

  491. ! Cosine solar zenith angle for current time step
    492. 

  492. !
    493. 

  493. 

  494. !  call zenith (calday, clat, clon, coszrs, ncol)
    495. 

  495. 

  496.       do i = its,ite
    497. 

  497.       ii = i - its + 1
    498. 

  498.       ! XT24 is the fractional part of simulation days plus half of RADT expressed in 
    499. 

  499.       ! units of minutes
    500. 

  500.       ! JULIAN is in days
    501. 

  501.       ! RADT is in minutes
    502. 

  502.       XT24=MOD(XTIME+RADT*0.5,1440.)
    503. 

  503.       TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
    504. 

  504.       HRANG=15.*(TLOCTM-12.)*DEGRAD
    505. 

  505.       XXLAT=XLAT(I,J)*DEGRAD
    506. 

  506.       clat(ii)=xxlat
    507. 

  507.       coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
    508. 

  508.       enddo
    509. 

  509. 

  510. ! moist variables
    511. 

  511. 

  512.       do k = kts,kte
    513. 

  513.       kk = kte - k + kts 
    514. 

  514.       do i = its,ite
    515. 

  515.       ii = i - its + 1
    516. 

  516. !    convert to specific humidity
    517. 

  517.       q(ii,kk,1) = max(1.e-10,qv3d(i,k,j)/(1.+qv3d(i,k,j)))
    518. 

  518.      IF ( F_QI .and. F_QC .and. F_QS ) THEN
    519. 

  519.       q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
    520. 

  520.       q(ii,kk,ixcldice) = max(0.,(qi3d(i,k,j)+qs3d(i,k,j))/(1.+qv3d(i,k,j)))
    521. 

  521.      ELSE IF ( F_QC .and. F_QR ) THEN
    522. 

  522. ! Warm rain or simple ice
    523. 

  523.       q(ii,kk,ixcldliq) = 0.
    524. 

  524.       q(ii,kk,ixcldice) = 0.
    525. 

  525.       if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
    526. 

  526.       if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
    527. 

  527.      ELSE IF ( F_QC .and. F_QS ) THEN
    528. 

  528. ! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
    529. 

  529.       q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*f_ice_phy(i,k,j))
    530. 

  530.       q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j)))
    531. 

  531.      ELSE
    532. 

  532.       q(ii,kk,ixcldliq) = 0.
    533. 

  533.       q(ii,kk,ixcldice) = 0.
    534. 

  534.      ENDIF
    535. 

  535.       cld(ii,kk) = CLDFRA(I,K,J)
    536. 

  536.       enddo
    537. 

  537.       enddo
    538. 

  538. 

  539.       do i = its,ite
    540. 

  540.       ii = i - its + 1
    541. 

  541.       landfrac(ii) = 2.-XLAND(I,J)
    542. 

  542.       landm(ii) = landfrac(ii)
    543. 

  543.       snowh(ii) = 0.001*SNOW(I,J)
    544. 

  544.       icefrac(ii) = XICE(I,J)
    545. 

  545.       enddo
    546. 

  546. 

  547.       do m=1,num_months-1
    548. 

  548.       do k=1,levsiz
    549. 

  549.       do i = its,ite
    550. 

  550.       ii = i - its + 1
    551. 

  551.       ozmixmj(ii,k,m) = ozmixm(i,k,j,m+1)
    552. 

  552.       enddo
    553. 

  553.       enddo
    554. 

  554.       enddo
    555. 

  555. 

  556.       do i = its,ite
    557. 

  557.       ii = i - its + 1
    558. 

  558.       m_psjp(ii) = m_psp(i,j)
    559. 

  559.       m_psjn(ii) = m_psn(i,j)
    560. 

  560.       enddo
    561. 

  561. 

  562.       do n=1,naer_c
    563. 

  563.       do k=1,paerlev
    564. 

  564.       do i = its,ite
    565. 

  565.       ii = i - its + 1
    566. 

  566.       aerosoljp(ii,k,n) = aerosolcp(i,k,j,n)
    567. 

  567.       aerosoljn(ii,k,n) = aerosolcn(i,k,j,n)
    568. 

  568.       enddo
    569. 

  569.       enddo
    570. 

  570.       enddo
    571. 

  571. 

  572. !
    573. 

  573. ! Complete radiation calculations
    574. 

  574. !
    575. 

  575.       do i = its,ite
    576. 

  576.       ii = i - its + 1
    577. 

  577.       lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4
    578. 

  578.       enddo
    579. 

  579. 

  580.       do k = kts,kte+1
    581. 

  581.       kk = kte - k + kts + 1
    582. 

  582.       do i = its,ite
    583. 

  583.       ii = i - its + 1
    584. 

  584.       pint(ii,kk) = p8w(i,k,j)
    585. 

  585.       if(k.eq.kts)ps(ii)=pint(ii,kk)
    586. 

  586.       lnpint(ii,kk) = log(pint(ii,kk))
    587. 

  587.       enddo
    588. 

  588.       enddo
    589. 

  589. 

  590.       if(.not.doabsems .and. dolw)then
    591. 

  591. !      do kk = kts,kte+1
    592. 

  592.       do kk = 1,cam_abs_dim2
    593. 

  593.         do kk1 = kts,kte+1
    594. 

  594.           do i = its,ite
    595. 

  595.             abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j)
    596. 

  596.           enddo
    597. 

  597.         enddo
    598. 

  598.       enddo
    599. 

  599. !      do kk = 1,4
    600. 

  600.       do kk = 1,cam_abs_dim1
    601. 

  601.         do kk1 = kts,kte
    602. 

  602.           do i = its,ite
    603. 

  603.             absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j)
    604. 

  604.           enddo
    605. 

  605.         enddo
    606. 

  606.       enddo
    607. 

  607.       do kk = kts,kte+1
    608. 

  608.           do i = its,ite
    609. 

  609.             emstot(i,kk) = emstot_3d(i,kk,j)
    610. 

  610.           enddo
    611. 

  611.       enddo
    612. 

  612.       endif
    613. 

  613. 

  614.       do k = kts,kte
    615. 

  615.       kk = kte - k + kts 
    616. 

  616.       do i = its,ite
    617. 

  617.       ii = i - its + 1
    618. 

  618.       pmid(ii,kk) = p_phy(i,k,j)
    619. 

  619.       lnpmid(ii,kk) = log(pmid(ii,kk))
    620. 

  620.       lnpint(ii,kk) = log(pint(ii,kk))
    621. 

  621.       pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk)
    622. 

  622.       t(ii,kk) = t_phy(i,k,j)
    623. 

  623.       zm(ii,kk) = z(i,k,j)
    624. 

  624.       enddo
    625. 

  625.       enddo
    626. 

  626. 

  627. 

  628. ! Compute cloud water/ice paths and optical properties for input to radiation
    629. 

  629. 

  630.       call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, &
    631. 

  631.                                 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh)
    632. 

  632. 

  633. !-----fds (06/2010)----------------------------
    634. 

  634.    SELECT CASE(sf_surface_physics)
    635. 

  635.    CASE (SSIBSCHEME)
    636. 

  636.    if (xtime .gt. 1.0) then
    637. 

  637. !      call wrf_message("using SSiB albedoes for land points")
    638. 

  638.       do i = its,ite
    639. 

  639.          ii = i - its + 1
    640. 

  640.          if (xland(i,j).lt.1.5) then   !land points only
    641. 

  641.            asdir(ii) = ALSWVISDIR(i,j) ! SSiB visdir albedo
    642. 

  642.            asdif(ii) = ALSWVISDIF(i,j) ! SSiB visdif albedo
    643. 

  643.            aldir(ii) = ALSWNIRDIR(i,j) ! SSiB nirdir albedo
    644. 

  644.            aldif(ii) = ALSWNIRDIF(i,j) ! SSiB nirdif albedo
    645. 

  645.          else
    646. 

  646.            asdir(ii) = albedo(i,j)
    647. 

  647.            asdif(ii) = albedo(i,j)
    648. 

  648.            aldir(ii) = albedo(i,j)
    649. 

  649.            aldif(ii) = albedo(i,j)
    650. 

  650.          endif
    651. 

  651.       enddo
    652. 

  652.    else
    653. 

  653.       do i = its,ite
    654. 

  654.          ii = i - its + 1
    655. 

  655.          asdir(ii) = albedo(i,j)
    656. 

  656.          asdif(ii) = albedo(i,j)
    657. 

  657.          aldir(ii) = albedo(i,j)
    658. 

  658.          aldif(ii) = albedo(i,j)
    659. 

  659.       enddo
    660. 

  660.    endif
    661. 

  661.    CASE DEFAULT
    662. 

  662.       do i = its,ite
    663. 

  663.       ii = i - its + 1
    664. 

  664. ! use same albedo for direct and diffuse
    665. 

  665. ! change this when separate values are provided
    666. 

  666.       asdir(ii) = albedo(i,j)
    667. 

  667.       asdif(ii) = albedo(i,j)
    668. 

  668.       aldir(ii) = albedo(i,j)
    669. 

  669.       aldif(ii) = albedo(i,j)
    670. 

  670.       enddo
    671. 

  671.    END SELECT
    672. 

  672. !-----------------------------------------------
    673. 

  673. 

  674. ! WRF allocate space here (not needed if oznini is called)
    675. 

  675. !  allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90
    676. 

  676. 

  677.       call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid,             &
    678. 

  678.                    pint, lnpmid, lnpint, pdel, t, q,   &
    679. 

  679.                    cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif,               &
    680. 

  680.                    aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME,   &
    681. 

  681.                    pin, ozmixmj, ozmix, levsiz, num_months,  & 
    682. 

  682.                    m_psjp,m_psjn, aerosoljp, aerosoljn,  m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, &
    683. 

  683.                    dolw, dosw, doabsems, abstot, absnxt, emstot, &
    684. 

  684.                    fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa,  &
    685. 

  685.                    fsns, fsnt    ,flns    ,flnt    , &
    686. 

  686.                    qrs, qrl, flwds, rel, rei,                       &
    687. 

  687.                    sols, soll, solsd, solld,                  &
    688. 

  688.                    landfrac, zm, fsds)
    689. 

  689. 

  690.       do k = kts,kte
    691. 

  691.       kk = kte - k + kts 
    692. 

  692.       do i = its,ite
    693. 

  693.       ii = i - its + 1
    694. 

  694.       if(dolw)RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
    695. 

  695.       if(dosw)RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j))
    696. 

  696.       cemiss(i,k,j)     = emis(ii,kk)
    697. 

  697.       taucldc(i,k,j)    = tauxcl(ii,kk)
    698. 

  698.       taucldi(i,k,j)    = tauxci(ii,kk)
    699. 

  699.       enddo
    700. 

  700.       enddo
    701. 

  701. 

  702.       if(doabsems .and. dolw)then
    703. 

  703. !      do kk = kts,kte+1
    704. 

  704.       do kk = 1,cam_abs_dim2
    705. 

  705.         do kk1 = kts,kte+1
    706. 

  706.           do i = its,ite
    707. 

  707.             abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk)
    708. 

  708.           enddo
    709. 

  709.         enddo
    710. 

  710.       enddo
    711. 

  711. !      do kk = 1,4
    712. 

  712.       do kk = 1,cam_abs_dim1
    713. 

  713.         do kk1 = kts,kte
    714. 

  714.           do i = its,ite
    715. 

  715.             absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk)
    716. 

  716.           enddo
    717. 

  717.         enddo
    718. 

  718.       enddo
    719. 

  719.       do kk = kts,kte+1
    720. 

  720.           do i = its,ite
    721. 

  721.             emstot_3d(i,kk,j) = emstot(i,kk)
    722. 

  722.           enddo
    723. 

  723.       enddo
    724. 

  724.       endif
    725. 

  725. 

  726.       IF(PRESENT(SWUPT))THEN
    727. 

  727.       if(dosw)then
    728. 

  728. ! Added shortwave and longwave upward/downward total and clear sky fluxes
    729. 

  729.       do k = kts,kte+1
    730. 

  730.       kk = kte +1 - k + kts
    731. 

  731.       do i = its,ite
    732. 

  732.       ii = i - its + 1
    733. 

  733. !      swup(i,k,j)      = fsup(ii,kk)
    734. 

  734. !      swupclear(i,k,j) = fsupc(ii,kk)
    735. 

  735. !      swdn(i,k,j)      = fsdn(ii,kk)
    736. 

  736. !      swdnclear(i,k,j) = fsdnc(ii,kk)
    737. 

  737.        if(k.eq.kte+1)then
    738. 

  738.          swupt(i,j)     = fsup(ii,kk)
    739. 

  739.          swuptc(i,j)    = fsupc(ii,kk)
    740. 

  740.          swdnt(i,j)     = fsdn(ii,kk)
    741. 

  741.          swdntc(i,j)    = fsdnc(ii,kk)
    742. 

  742.        endif
    743. 

  743.        if(k.eq.kts)then
    744. 

  744.          swupb(i,j)     = fsup(ii,kk)
    745. 

  745.          swupbc(i,j)    = fsupc(ii,kk)
    746. 

  746.          swdnb(i,j)     = fsdn(ii,kk)
    747. 

  747.          swdnbc(i,j)    = fsdnc(ii,kk)
    748. 

  748.        endif
    749. 

  749. !            if(i.eq.30.and.j.eq.30) then
    750. 

  750. !            print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk)
    751. 

  751. !            1234 format (a6,4i4,4f10.3)
    752. 

  752. !            endif
    753. 

  753.      enddo
    754. 

  754.       enddo
    755. 

  755.       endif
    756. 

  756.       if(dolw)then
    757. 

  757. ! Added shortwave and longwave upward/downward total and clear sky fluxes
    758. 

  758.       do k = kts,kte+1
    759. 

  759.       kk = kte +1 - k + kts
    760. 

  760.       do i = its,ite
    761. 

  761.       ii = i - its + 1
    762. 

  762. !      lwup(i,k,j)      = flup(ii,kk)
    763. 

  763. !      lwupclear(i,k,j) = flupc(ii,kk)
    764. 

  764. !      lwdn(i,k,j)      = fldn(ii,kk)
    765. 

  765. !      lwdnclear(i,k,j) = fldnc(ii,kk)
    766. 

  766.        if(k.eq.kte+1)then
    767. 

  767.          lwupt(i,j)     = flup(ii,kk)
    768. 

  768.          lwuptc(i,j)    = flupc(ii,kk)
    769. 

  769.          lwdnt(i,j)     = fldn(ii,kk)
    770. 

  770.          lwdntc(i,j)    = fldnc(ii,kk)
    771. 

  771.        endif
    772. 

  772.        if(k.eq.kts)then
    773. 

  773.          lwupb(i,j)     = flup(ii,kk)
    774. 

  774.          lwupbc(i,j)    = flupc(ii,kk)
    775. 

  775.          lwdnb(i,j)     = fldn(ii,kk)
    776. 

  776.          lwdnbc(i,j)    = fldnc(ii,kk)
    777. 

  777.        endif
    778. 

  778. !            if(i.eq.30.and.j.eq.30) then
    779. 

  779. !            print 1234, 'long  ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk)
    780. 

  780. !            1234 format (a6,4i4,4f10.3)
    781. 

  781. !            endif
    782. 

  782.       enddo
    783. 

  783.       enddo
    784. 

  784.       endif
    785. 

  785.       ENDIF
    786. 

  786. 

  787.       do i = its,ite
    788. 

  788.       ii = i - its + 1
    789. 

  789. ! Added shortwave and longwave cloud forcing at TOA and surface
    790. 

  790.       if(dolw)then
    791. 

  791.         GLW(I,J) = flwds(ii)
    792. 

  792.         lwcf(i,j) = lwcftoa(ii)
    793. 

  793.         olr(i,j)  = olrtoa(ii)
    794. 

  794.       endif
    795. 

  795.       if(dosw)then
    796. 

  796.         GSW(I,J) = fsns(ii)
    797. 

  797.         swcf(i,j) = swcftoa(ii)
    798. 

  798.         coszr(i,j) = coszrs(ii)
    799. 

  799.       endif
    800. 

  800.       enddo
    801. 

  801. !-------fds (06/2010)---------
    802. 

  802.    SELECT CASE(sf_surface_physics)
    803. 

  803.    CASE (SSIBSCHEME)
    804. 

  804. !   call wrf_message("CAM using ssib albedo2")
    805. 

  805.       if(dosw)then
    806. 

  806.       do i = its,ite
    807. 

  807.         ii = i - its + 1
    808. 

  808.         SWVISDIR(I,J) = sols(ii)  !SSiB 
    809. 

  809.         SWVISDIF(I,J) = solsd(ii) !SSiB 
    810. 

  810.         SWNIRDIR(I,J) = soll(ii)  !SSiB 
    811. 

  811.         SWNIRDIF(I,J) = solld(ii) !SSiB 
    812. 

  812.       enddo
    813. 

  813.       endif
    814. 

  814.    END SELECT
    815. 

  815. !-----------------------------
    816. 

  816. 

  817.     enddo    ! j-loop
    818. 

  818. 

  819. #endif
    820. 

  820. 

  821. end subroutine camrad
    822. 

  822. !====================================================================
    823. 

  823.    SUBROUTINE camradinit(                                           &
    824. 

  824.                          R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop,               &
    825. 

  825.                          ozmixm,pin,levsiz,XLAT,num_months,         &
    826. 

  826.                          m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,    &
    827. 

  827.                          paerlev,naer_c,                            &
    828. 

  828.                      ids, ide, jds, jde, kds, kde,                  &
    829. 

  829.                      ims, ime, jms, jme, kms, kme,                  &
    830. 

  830.                      its, ite, jts, jte, kts, kte                   )
    831. 

  831. 

  832.    USE module_wrf_error
    833. 

  833.    USE module_state_description
    834. 

  834.    !USE module_configure
    835. 

  835. 

  836. !--------------------------------------------------------------------
    837. 

  837.    IMPLICIT NONE
    838. 

  838. !--------------------------------------------------------------------
    839. 

  839.    INTEGER , INTENT(IN)           :: ids, ide, jds, jde, kds, kde,  &
    840. 

  840.                                      ims, ime, jms, jme, kms, kme,  &
    841. 

  841.                                      its, ite, jts, jte, kts, kte
    842. 

  842.    REAL, intent(in)               :: pptop
    843. 

  843.    REAL, INTENT(IN)               :: R_D,R_V,CP,G,STBOLT,EP_2
    844. 

  844. 

  845.    REAL,     DIMENSION( kms:kme )  :: shalf
    846. 

  846. 

  847.    INTEGER,      INTENT(IN   )    ::   levsiz, num_months
    848. 

  848.    INTEGER,      INTENT(IN   )    ::   paerlev, naer_c
    849. 

  849. 

  850.    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )  :: XLAT
    851. 

  851. 

  852.    REAL,  DIMENSION( ims:ime, levsiz, jms:jme, num_months ),      &
    853. 

  853.           INTENT(INOUT   ) ::                                  OZMIXM
    854. 

  854. 

  855.    REAL,  DIMENSION(levsiz), INTENT(INOUT )  ::                   PIN
    856. 

  856.    REAL,  DIMENSION(ims:ime, jms:jme), INTENT(INOUT )  ::                  m_psp,m_psn
    857. 

  857.    REAL,  DIMENSION(paerlev), INTENT(INOUT )  ::               m_hybi
    858. 

  858.    REAL,  DIMENSION( ims:ime, paerlev, jms:jme, naer_c ),      &
    859. 

  859.           INTENT(INOUT) ::                             aerosolcp,aerosolcn
    860. 

  860. 

  861.    REAL(r8)    :: pstd
    862. 

  862.    REAL(r8)    :: rh2o, cpair
    863. 

  863. 

  864. ! These were made allocatable 20090612 to save static memory allocation. JM
    865. 

  865.    IF ( .NOT. ALLOCATED( ksul   ) ) ALLOCATE( ksul( nrh, nspint ) )
    866. 

  866.    IF ( .NOT. ALLOCATED( wsul   ) ) ALLOCATE( wsul( nrh, nspint ) )
    867. 

  867.    IF ( .NOT. ALLOCATED( gsul   ) ) ALLOCATE( gsul( nrh, nspint ) )
    868. 

  868.    IF ( .NOT. ALLOCATED( ksslt  ) ) ALLOCATE( ksslt( nrh, nspint ) )
    869. 

  869.    IF ( .NOT. ALLOCATED( wsslt  ) ) ALLOCATE( wsslt( nrh, nspint ) )
    870. 

  870.    IF ( .NOT. ALLOCATED( gsslt  ) ) ALLOCATE( gsslt( nrh, nspint ) )
    871. 

  871.    IF ( .NOT. ALLOCATED( kcphil ) ) ALLOCATE( kcphil( nrh, nspint ) )
    872. 

  872.    IF ( .NOT. ALLOCATED( wcphil ) ) ALLOCATE( wcphil( nrh, nspint ) )
    873. 

  873.    IF ( .NOT. ALLOCATED( gcphil ) ) ALLOCATE( gcphil( nrh, nspint ) )
    874. 

  874. 

  875.    IF ( .NOT. ALLOCATED(ah2onw  ) ) ALLOCATE( ah2onw(n_p, n_tp, n_u, n_te, n_rh) )
    876. 

  876.    IF ( .NOT. ALLOCATED(eh2onw  ) ) ALLOCATE( eh2onw(n_p, n_tp, n_u, n_te, n_rh) )
    877. 

  877.    IF ( .NOT. ALLOCATED(ah2ow   ) ) ALLOCATE( ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
    878. 

  878.    IF ( .NOT. ALLOCATED(cn_ah2ow) ) ALLOCATE( cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
    879. 

  879.    IF ( .NOT. ALLOCATED(cn_eh2ow) ) ALLOCATE( cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
    880. 

  880.    IF ( .NOT. ALLOCATED(ln_ah2ow) ) ALLOCATE( ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
    881. 

  881.    IF ( .NOT. ALLOCATED(ln_eh2ow) ) ALLOCATE( ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
    882. 

  882. 

  883. #if !defined(MAC_KLUDGE)
    884. 

  884.    ozncyc = .true.
    885. 

  885.    indirect = .true.
    886. 

  886.    ixcldliq = 2
    887. 

  887.    ixcldice = 3
    888. 

  888. #if (NMM_CORE != 1)
    889. 

  889. ! aerosol array is not in the NMM Registry 
    890. 

  890. !   since CAM radiation not available to NMM (yet)
    891. 

  891. !   so this is blocked out to enable CAM compilation with NMM
    892. 

  892.    idxSUL = P_SUL
    893. 

  893.    idxSSLT = P_SSLT
    894. 

  894.    idxDUSTfirst = P_DUST1
    895. 

  895.    idxOCPHO = P_OCPHO
    896. 

  896.    idxCARBONfirst = P_OCPHO
    897. 

  897.    idxBCPHO = P_BCPHO
    898. 

  898.    idxOCPHI = P_OCPHI
    899. 

  899.    idxBCPHI = P_BCPHI
    900. 

  900.    idxBG = P_BG
    901. 

  901.    idxVOLC = P_VOLC
    902. 

  902. #endif
    903. 

  903. 

  904.    pstd = 101325.0
    905. 

  905. ! from physconst module
    906. 

  906.    mwdry = 28.966            ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
    907. 

  907.    mwco2 =  44.              ! molecular weight co2
    908. 

  908.    mwh2o = 18.016            ! molecular weight water vapor (shr_const_mwwv)
    909. 

  909.    mwch4 =  16.              ! molecular weight ch4
    910. 

  910.    mwn2o =  44.              ! molecular weight n2o
    911. 

  911.    mwf11 = 136.              ! molecular weight cfc11
    912. 

  912.    mwf12 = 120.              ! molecular weight cfc12
    913. 

  913.    cappa = R_D/CP
    914. 

  914.    rair = R_D
    915. 

  915.    tmelt = 273.16            ! freezing T of fresh water ~ K 
    916. 

  916.    r_universal = 6.02214e26 * STBOLT   ! Universal gas constant ~ J/K/kmole
    917. 

  917.    latvap = 2.501e6          ! latent heat of evaporation ~ J/kg
    918. 

  918.    latice = 3.336e5          ! latent heat of fusion ~ J/kg
    919. 

  919.    zvir = R_V/R_D - 1.
    920. 

  920.    rh2o = R_V
    921. 

  921.    cpair = CP
    922. 

  922. !
    923. 

  923.    epsqs = EP_2
    924. 

  924. 

  925.    CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 )
    926. 

  926.    CALL esinti(epsqs  ,latvap  ,latice  ,rh2o    ,cpair   ,tmelt   )
    927. 

  927.    CALL oznini(ozmixm,pin,levsiz,num_months,XLAT,                   &
    928. 

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

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

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

  931.    CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop,    &
    932. 

  932.                      ids, ide, jds, jde, kds, kde,                  &
    933. 

  933.                      ims, ime, jms, jme, kms, kme,                  &
    934. 

  934.                      its, ite, jts, jte, kts, kte)
    935. 

  935. 

  936. #endif
    937. 

  937. 

  938.    END SUBROUTINE camradinit
    939. 

  939. #if !defined(MAC_KLUDGE)
    940. 

  940. 

  941. 

  942. subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
    943. 

  943. 

  944.       IMPLICIT NONE
    945. 

  945. 

  946.    INTEGER,      INTENT(IN   )    ::   levsiz, num_months,pcols
    947. 

  947. 

  948.    REAL(r8),  DIMENSION( pcols, levsiz, num_months ),      &
    949. 

  949.           INTENT(IN   ) ::                                  ozmixmj 
    950. 

  950. 

  951.    REAL, INTENT(IN    )      ::        XTIME,GMT
    952. 

  952.    INTEGER, INTENT(IN )      ::        JULDAY
    953. 

  953.    REAL,    INTENT(IN )      ::        JULIAN
    954. 

  954.    REAL,    INTENT(IN )      ::        DT
    955. 

  955. 

  956.    REAL(r8),  DIMENSION( pcols, levsiz ),      &
    957. 

  957.           INTENT(OUT  ) ::                                  ozmix
    958. 

  958.    !Local
    959. 

  959.    REAL(r8)  :: intJULIAN
    960. 

  960.    integer   :: np1,np,nm,m,k,i
    961. 

  961.    integer   :: IJUL
    962. 

  962.    integer, dimension(12) ::  date_oz
    963. 

  963.    data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
    964. 

  964.    real(r8) :: cdayozp, cdayozm
    965. 

  965.    real(r8) :: fact1, fact2
    966. 

  966.    logical  :: finddate
    967. 

  967.    CHARACTER(LEN=256) :: msgstr
    968. 

  968. 

  969.    ! JULIAN starts from 0.0 at 0Z on 1 Jan.
    970. 

  970.    intJULIAN = JULIAN + 1.0_r8    ! offset by one day
    971. 

  971. ! jan 1st 00z is julian=1.0 here
    972. 

  972.    IJUL=INT(intJULIAN)
    973. 

  973. !  Note that following will drift. 
    974. 

  974. !    Need to use actual month/day info to compute julian.
    975. 

  975.    intJULIAN=intJULIAN-FLOAT(IJUL)
    976. 

  976.    IJUL=MOD(IJUL,365)
    977. 

  977.    IF(IJUL.EQ.0)IJUL=365
    978. 

  978.    intJULIAN=intJULIAN+IJUL
    979. 

  979.    np1=1
    980. 

  980.    finddate=.false.
    981. 

  981. !   do m=1,num_months
    982. 

  982.    do m=1,12
    983. 

  983.    if(date_oz(m).gt.intjulian.and..not.finddate) then
    984. 

  984.      np1=m
    985. 

  985.      finddate=.true.
    986. 

  986.    endif
    987. 

  987.    enddo
    988. 

  988.    cdayozp=date_oz(np1)
    989. 

  989.    if(np1.gt.1) then
    990. 

  990.    cdayozm=date_oz(np1-1)
    991. 

  991.    np=np1
    992. 

  992.    nm=np-1
    993. 

  993.    else
    994. 

  994.    cdayozm=date_oz(12)
    995. 

  995.    np=np1
    996. 

  996.    nm=12
    997. 

  997.    endif
    998. 

  998.    call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, &
    999. 

  999.                     fact1, fact2) 
    1000. 

  1000. 

  1001. !
    1002. 

  1002. ! Time interpolation.
    1003. 

  1003. !
    1004. 

  1004.       do k=1,levsiz
    1005. 

  1005.          do i=1,pcols
    1006. 

  1006.             ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2
    1007. 

  1007.          end do
    1008. 

  1008.       end do
    1009. 

  1009. 

  1010. END subroutine oznint
    1011. 

  1011. 

  1012. 

  1013. subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
    1014. 

  1014.   aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale)
    1015. 

  1015. !------------------------------------------------------------------
    1016. 

  1016. !
    1017. 

  1017. !  Input:
    1018. 

  1018. !     time at which aerosol mmrs are needed (get_curr_calday())
    1019. 

  1019. !     chunk index
    1020. 

  1020. !     CAM's vertical grid (pint)
    1021. 

  1021. !
    1022. 

  1022. !  Output:
    1023. 

  1023. !     values for Aerosol Mass Mixing Ratios at specified time
    1024. 

  1024. !     on vertical grid specified by CAM (AEROSOLt)
    1025. 

  1025. !
    1026. 

  1026. !  Method:
    1027. 

  1027. !     first determine which indexs of aerosols are the bounding data sets
    1028. 

  1028. !     interpolate both onto vertical grid aerm(),aerp().
    1029. 

  1029. !     from those two, interpolate in time.
    1030. 

  1030. !
    1031. 

  1031. !------------------------------------------------------------------
    1032. 

  1032. 

  1033. !  use volcanicmass, only: get_volcanic_mass
    1034. 

  1034. !  use timeinterp, only: getfactors
    1035. 

  1035. !
    1036. 

  1036. ! aerosol fields interpolated to current time step
    1037. 

  1037. !   on pressure levels of this time step.
    1038. 

  1038. ! these should be made read-only for other modules
    1039. 

  1039. ! Is allocation done correctly here?
    1040. 

  1040. !
    1041. 

  1041.    integer, intent(in) :: c                   ! Chunk Id.
    1042. 

  1042.    integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp
    1043. 

  1043.    real(r8), intent(in) :: pint(pcols,pverp)  ! midpoint pres.
    1044. 

  1044.    real(r8), intent(in) :: scale(naer_all)    ! scale each aerosol by this amount
    1045. 

  1045.    REAL, INTENT(IN    )      ::        XTIME,GMT
    1046. 

  1046.    INTEGER, INTENT(IN )      ::        JULDAY
    1047. 

  1047.    REAL, INTENT(IN    )      ::        JULIAN
    1048. 

  1048.    REAL, INTENT(IN    )      ::        DT
    1049. 

  1049.    real(r8), intent(in   )      ::        m_psp(pcols),m_psn(pcols)  ! Match surface pressure
    1050. 

  1050.    real(r8), intent(in   )   ::        aerosoljp(pcols,paerlev,naer_c) 
    1051. 

  1051.    real(r8), intent(in   )   ::        aerosoljn(pcols,paerlev,naer_c) 
    1052. 

  1052.    real(r8), intent(in   )   ::        m_hybi(paerlev)
    1053. 

  1053. 

  1054.    real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
    1055. 

  1055. !
    1056. 

  1056. ! Local workspace
    1057. 

  1057. !
    1058. 

  1058.    real(r8) caldayloc                     ! calendar day of current timestep
    1059. 

  1059.    real(r8) fact1, fact2                  ! time interpolation factors
    1060. 

  1060. 

  1061.   integer :: nm = 1                ! index to prv month in array. init to 1 and toggle between 1 and 2
    1062. 

  1062.   integer :: np = 2                ! index to nxt month in array. init to 2 and toggle between 1 and 2
    1063. 

  1063.   integer :: mo_nxt = bigint       ! index to nxt month in file
    1064. 

  1064.   integer :: mo_prv                       ! index to previous month
    1065. 

  1065. 

  1066.   real(r8) :: cdaym = inf          ! calendar day of prv month
    1067. 

  1067.   real(r8) :: cdayp = inf          ! calendar day of next month
    1068. 

  1068.   real(r8) :: Mid(12)              ! Days into year for mid month date
    1069. 

  1069.   data Mid/16.5, 46.0, 75.5, 106.0, 136.5, 167.0, 197.5, 228.5, 259.0, 289.5, 320.0, 350.5 /
    1070. 

  1070. 

  1071.    integer i, k, j                        ! spatial indices
    1072. 

  1072.    integer m                              ! constituent index
    1073. 

  1073.    integer lats(pcols),lons(pcols)        ! latitude and longitudes of column
    1074. 

  1074.    integer ncol                           ! number of columns
    1075. 

  1075.    INTEGER IJUL
    1076. 

  1076.    REAL(r8) intJULIAN
    1077. 

  1077. 

  1078.    real(r8) speciesmin(naer)              ! minimal value for each species
    1079. 

  1079. !
    1080. 

  1080. ! values before current time step "the minus month"
    1081. 

  1081. ! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr
    1082. 

  1082. ! aerosolp(pcols,pver) is value of next month's aerosol mmr
    1083. 

  1083. !  (think minus and plus or values to left and right of point to be interpolated)
    1084. 

  1084. !
    1085. 

  1085.    real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month
    1086. 

  1086. !
    1087. 

  1087. ! values beyond (or at) current time step "the plus month"
    1088. 

  1088. !
    1089. 

  1089.    real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month
    1090. 

  1090.    CHARACTER(LEN=256) :: msgstr
    1091. 

  1091. 

  1092.    ! JULIAN starts from 0.0 at 0Z on 1 Jan.
    1093. 

  1093.    intJULIAN = JULIAN + 1.0_r8    ! offset by one day
    1094. 

  1094. ! jan 1st 00z is julian=1.0 here
    1095. 

  1095.    IJUL=INT(intJULIAN)
    1096. 

  1096. !  Note that following will drift. 
    1097. 

  1097. !    Need to use actual month/day info to compute julian.
    1098. 

  1098.    intJULIAN=intJULIAN-FLOAT(IJUL)
    1099. 

  1099.    IJUL=MOD(IJUL,365)
    1100. 

  1100.    IF(IJUL.EQ.0)IJUL=365
    1101. 

  1101.    caldayloc=intJULIAN+IJUL
    1102. 

  1102. 

  1103.    if (caldayloc < Mid(1)) then
    1104. 

  1104.       mo_prv = 12
    1105. 

  1105.       mo_nxt =  1
    1106. 

  1106.    else if (caldayloc >= Mid(12)) then
    1107. 

  1107.       mo_prv = 12
    1108. 

  1108.       mo_nxt =  1
    1109. 

  1109.    else
    1110. 

  1110.       do i = 2 , 12
    1111. 

  1111.          if (caldayloc < Mid(i)) then
    1112. 

  1112.             mo_prv = i-1
    1113. 

  1113.             mo_nxt = i
    1114. 

  1114.             exit
    1115. 

  1115.          end if
    1116. 

  1116.       end do
    1117. 

  1117.    end if
    1118. 

  1118. !
    1119. 

  1119. ! Set initial calendar day values
    1120. 

  1120. !
    1121. 

  1121.    cdaym = Mid(mo_prv)
    1122. 

  1122.    cdayp = Mid(mo_nxt)
    1123. 

  1123. 

  1124. !
    1125. 

  1125. ! Determine time interpolation factors.  1st arg says we are cycling 1 year of data
    1126. 

  1126. !
    1127. 

  1127.    call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, &
    1128. 

  1128.                     fact1, fact2)
    1129. 

  1129. !
    1130. 

  1130. ! interpolate (prv and nxt month) bounding datasets onto cam vertical grid.
    1131. 

  1131. ! compute mass mixing ratios on CAMS's pressure coordinate
    1132. 

  1132. !  for both the "minus" and "plus" months
    1133. 

  1133. !
    1134. 

  1134. !  ncol = get_ncols_p(c)
    1135. 

  1135.    ncol = pcols
    1136. 

  1136. 

  1137. !  call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c)
    1138. 

  1138. !  call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c)
    1139. 

  1139. 

  1140.    call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c)
    1141. 

  1141.    call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c)
    1142. 

  1142. 

  1143. !
    1144. 

  1144. ! Time interpolate.
    1145. 

  1145. !
    1146. 

  1146.    do m=1,naer
    1147. 

  1147.       do k=1,pver
    1148. 

  1148.          do i=1,ncol
    1149. 

  1149.             AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2
    1150. 

  1150.          end do
    1151. 

  1151.       end do
    1152. 

  1152.    end do
    1153. 

  1153. 

  1154. !  do i=1,ncol
    1155. 

  1155. !     Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2
    1156. 

  1156. !  end do
    1157. 

  1157. !
    1158. 

  1158. ! get background aerosol (tuning) field
    1159. 

  1159. !
    1160. 

  1160.    call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG))
    1161. 

  1161. 

  1162. !
    1163. 

  1163. ! find volcanic aerosol masses
    1164. 

  1164. !
    1165. 

  1165. ! if (strat_volcanic) then
    1166. 

  1166. !   call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC))
    1167. 

  1167. ! else
    1168. 

  1168.     AEROSOLt(:,:,idxVOLC) = 0._r8
    1169. 

  1169. ! endif
    1170. 

  1170. 

  1171. !
    1172. 

  1172. ! exit if mmr is negative (we have previously set
    1173. 

  1173. !  cumulative mass to be a decreasing function.)
    1174. 

  1174. !
    1175. 

  1175.    speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species
    1176. 

  1176. 

  1177.    do m=1,naer
    1178. 

  1178.       do k=1,pver
    1179. 

  1179.          do i=1,ncol
    1180. 

  1180.             if (AEROSOLt(i, k, m) < speciesmin(m)) then
    1181. 

  1181.                write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting'
    1182. 

  1182.                write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m)
    1183. 

  1183.                call endrun ()
    1184. 

  1184.             end if
    1185. 

  1185.          end do
    1186. 

  1186.       end do
    1187. 

  1187.    end do
    1188. 

  1188. !
    1189. 

  1189. ! scale any AEROSOLS as required
    1190. 

  1190. !
    1191. 

  1191.    call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale)
    1192. 

  1192. 

  1193.    return
    1194. 

  1194. end subroutine get_aerosol
    1195. 

  1195. 

  1196. 

  1197. subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
    1198. 

  1198. !--------------------------------------------------------------
    1199. 

  1199. ! Compute effect of sulfate on effective liquid water radius
    1200. 

  1200. !  Method of Martin et. al.
    1201. 

  1201. !--------------------------------------------------------------
    1202. 

  1202. 

  1203. ! use constituents, only: ppcnst, cnst_get_ind
    1204. 

  1204. ! use history, only: outfld
    1205. 

  1205. 

  1206. !#include <comctl.h>
    1207. 

  1207. 

  1208.   integer, intent(in) :: ncol                  ! number of atmospheric columns
    1209. 

  1209.   integer, intent(in) :: lchnk                 ! chunk identifier
    1210. 

  1210.   integer, intent(in) :: pcols,pver,ppcnst
    1211. 

  1211. 

  1212.   real(r8), intent(in) :: landfrac(pcols)      ! land fraction
    1213. 

  1213.   real(r8), intent(in) :: pmid(pcols,pver)     ! Model level pressures
    1214. 

  1214.   real(r8), intent(in) :: t(pcols,pver)        ! Model level temperatures
    1215. 

  1215.   real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
    1216. 

  1216.   real(r8), intent(in) :: cld(pcols,pver)      ! Fractional cloud cover
    1217. 

  1217.   real(r8), intent(in) :: zm(pcols,pver)       ! Height of midpoints (above surface)
    1218. 

  1218.   real(r8), intent(in) :: rel(pcols,pver)      ! liquid effective drop size (microns)
    1219. 

  1219. !
    1220. 

  1220. ! local variables
    1221. 

  1221. !
    1222. 

  1222.   real(r8) locrhoair(pcols,pver)  ! dry air density            [kg/m^3 ]
    1223. 

  1223.   real(r8) lwcwat(pcols,pver)     ! in-cloud liquid water path [kg/m^3 ]
    1224. 

  1224.   real(r8) sulfmix(pcols,pver)    ! sulfate mass mixing ratio  [kg/kg  ]
    1225. 

  1225.   real(r8) so4mass(pcols,pver)    ! sulfate mass concentration [g/cm^3 ]
    1226. 

  1226.   real(r8) Aso4(pcols,pver)       ! sulfate # concentration    [#/cm^3 ]
    1227. 

  1227.   real(r8) Ntot(pcols,pver)       ! ccn # concentration        [#/cm^3 ]
    1228. 

  1228.   real(r8) relmod(pcols,pver)     ! effective radius           [microns]
    1229. 

  1229. 

  1230.   real(r8) wrel(pcols,pver)       ! weighted effective radius    [microns]
    1231. 

  1231.   real(r8) wlwc(pcols,pver)       ! weighted liq. water content  [kg/m^3 ]
    1232. 

  1232.   real(r8) cldfrq(pcols,pver)     ! frequency of occurance of...
    1233. 

  1233. !                                  ! clouds (cld => 0.01)         [fraction]
    1234. 

  1234.   real(r8) locPi                  ! my piece of the pi
    1235. 

  1235.   real(r8) Rdryair                ! gas constant of dry air   [J/deg/kg]
    1236. 

  1236.   real(r8) rhowat                 ! density of water          [kg/m^3  ]
    1237. 

  1237.   real(r8) Acoef                  ! m->A conversion factor; assumes
    1238. 

  1238. !                                  ! Dbar=0.10, sigma=2.0      [g^-1    ]
    1239. 

  1239.   real(r8) rekappa                ! kappa in evaluation of re(lmod)
    1240. 

  1240.   real(r8) recoef                 ! temp. coeficient for calc of re(lmod)
    1241. 

  1241.   real(r8) reexp                  ! 1.0/3.0
    1242. 

  1242.   real(r8) Ntotb                  ! temp var to hold below cloud ccn
    1243. 

  1243. ! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)...
    1244. 

  1244.   real(r8) Cmarn                  ! Coef for CDNC_marine         [cm^-3]
    1245. 

  1245.   real(r8) Cland                  ! Coef for CDNC_land           [cm^-3]
    1246. 

  1246.   real(r8) Hmarn                  ! Scale height for CDNC_marine [m]
    1247. 

  1247.   real(r8) Hland                  ! Scale height for CDNC_land   [m]
    1248. 

  1248.   parameter ( Cmarn = 50.0, Cland = 100.0 )
    1249. 

  1249.   parameter ( Hmarn = 1000.0, Hland = 2000.0 )
    1250. 

  1250.   real(r8) bgaer                  ! temp var to hold background CDNC
    1251. 

    1252. 

  1252.   integer i,k     ! loop indices
    1253. 

  1253. !
    1254. 

  1254. ! Statement functions
    1255. 

  1255. !
    1256. 

  1256.   logical land    ! is this a column over land?
    1257. 

  1257.   land(i) = nint(landfrac(i)).gt.0.5_r8
    1258. 

    1259. 

  1259.   if (indirect) then
    1260. 

    1261. 

  1261. !   call endrun ('AEROSOL_INDIRECT:  indirect effect is obsolete')
    1262. 

    1263. 

  1263. !   ramping is not yet resolved so sulfmix is 0.
    1264. 

  1264.     sulfmix(1:ncol,1:pver) = 0._r8
    1265. 

    1266. 

  1266.     locPi = 3.141592654
    1267. 

  1267.     Rdryair = 287.04
    1268. 

  1268.     rhowat = 1000.0
    1269. 

  1269.     Acoef = 1.2930E14
    1270. 

  1270.     recoef = 3.0/(4.0*locPi*rhowat)
    1271. 

  1271.     reexp = 1.0/3.0
    1272. 

    1273. 

  1273. !   call cnst_get_ind('CLDLIQ', ixcldliq)
    1274. 

  1274.     do k=pver,1,-1
    1275. 

  1275.       do i = 1,ncol
    1276. 

  1276.         locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) )
    1277. 

  1277.         lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* &
    1278. 

  1278.                       locrhoair(i,k)
    1279. 

  1279. !          NOTE: 0.001 converts kg/m3 -> g/cm3
    1280. 

  1280.         so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001
    1281. 

  1281.         Aso4(i,k) = so4mass(i,k)*Acoef
    1282. 

    1283. 

  1283.         if (Aso4(i,k) <= 280.0) then
    1284. 

  1284.            Aso4(i,k) = max(36.0_r8,Aso4(i,k))
    1285. 

  1285.            Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30
    1286. 

  1286.            rekappa = 0.80
    1287. 

  1287.         else
    1288. 

  1288.            Aso4(i,k) = min(1500.0_r8,Aso4(i,k))
    1289. 

  1289.            Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9
    1290. 

  1290.            rekappa = 0.67
    1291. 

  1291.         end if
    1292. 

  1292.         if (land(i)) then ! Account for local background aerosol;
    1293. 

  1293.            bgaer = Cland*exp(-(zm(i,k)/Hland))
    1294. 

  1294.            Ntot(i,k) = max(bgaer,Ntot(i,k))
    1295. 

  1295.         else
    1296. 

  1296.            bgaer = Cmarn*exp(-(zm(i,k)/Hmarn))
    1297. 

  1297.            Ntot(i,k) = max(bgaer,Ntot(i,k))
    1298. 

  1298.         end if
    1299. 

    1300. 

  1300.         if (k == pver) then
    1301. 

  1301.            Ntotb = Ntot(i,k)
    1302. 

  1302.         else
    1303. 

  1303.            Ntotb = Ntot(i,k+1)
    1304. 

  1304.         end if
    1305. 

    1306. 

  1306.         relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0
    1307. 

  1307.         relmod(i,k) = max(4.0_r8,relmod(i,k))
    1308. 

  1308.         relmod(i,k) = min(20.0_r8,relmod(i,k))
    1309. 

  1309.         if (cld(i,k) >= 0.01) then
    1310. 

  1310.            cldfrq(i,k) = 1.0
    1311. 

  1311.         else
    1312. 

  1312.            cldfrq(i,k) = 0.0
    1313. 

  1313.         end if
    1314. 

  1314.         wrel(i,k) = relmod(i,k)*cldfrq(i,k)
    1315. 

  1315.         wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k)
    1316. 

  1316.       end do
    1317. 

  1317.     end do
    1318. 

  1318. !   call outfld('MSO4    ',so4mass,pcols,lchnk)
    1319. 

  1319. !   call outfld('LWC     ',lwcwat ,pcols,lchnk)
    1320. 

  1320. !   call outfld('CLDFRQ  ',cldfrq ,pcols,lchnk)
    1321. 

  1321. !   call outfld('WREL    ',wrel   ,pcols,lchnk)
    1322. 

  1322. !   call outfld('WLWC    ',wlwc   ,pcols,lchnk)
    1323. 

  1323. !   write(6,*)'WARNING: indirect calculation has no effects'
    1324. 

  1324.   else
    1325. 

  1325.     do k = 1, pver
    1326. 

  1326.       do i = 1, ncol
    1327. 

  1327.         relmod(i,k) = rel(i,k)
    1328. 

  1328.       end do
    1329. 

  1329.     end do
    1330. 

  1330.   endif
    1331. 

    1332. 

  1332. ! call outfld('REL     ',relmod ,pcols,lchnk)
    1333. 

    1334. 

  1334.   return
    1335. 

  1335. end subroutine aerosol_indirect
    1336. 

    1337. 

    1338. 

  1338.       subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp )
    1339. 

  1339. !
    1340. 

  1340. !     Purpose: Compute strat. aerosol transmissions needed in absorptivity/
    1341. 

  1341. !              emissivity calculations
    1342. 

  1342. !              aer_trn() is called by radclw() when doabsems is .true.
    1343. 

  1343. !
    1344. 

  1344. !     use shr_kind_mod, only: r8 => shr_kind_r8
    1345. 

  1345. !     use pmgrid
    1346. 

  1346. !     use ppgrid
    1347. 

  1347. !     use prescribed_aerosols, only: strat_volcanic
    1348. 

  1348.       implicit none
    1349. 

    1350. 

  1350. !     Input arguments
    1351. 

  1351. !
    1352. 

  1352. !       [kg m-2] Volcanics path above kth interface level
    1353. 

  1353. !
    1354. 

  1354.       integer, intent(in)         :: pcols, plev, plevp
    1355. 

  1355.       real(r8), intent(in) :: aer_mpp(pcols,plevp)
    1356. 

    1357. 

  1357. !     Output arguments
    1358. 

  1358. !
    1359. 

  1359. !       [fraction] Total volcanic transmission between interfaces k1 and k2
    1360. 

  1360. !
    1361. 

  1361.       real(r8), intent(out) ::  aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW)
    1362. 

    1363. 

  1363. !-------------------------------------------------------------------------
    1364. 

  1364. !     Local variables
    1365. 

    1366. 

  1366.       integer bnd_idx           ! LW band index
    1367. 

  1367.       integer i                 ! lon index
    1368. 

  1368.       integer k1                ! lev index
    1369. 

  1369.       integer k2                ! lev index
    1370. 

  1370.       real(r8) aer_pth_dlt      ! [kg m-2] Volcanics path between interface
    1371. 

  1371.                                 !          levels k1 and k2
    1372. 

  1372.       real(r8) odap_aer_ttl     ! [fraction] Total path absorption optical
    1373. 

  1373.                                 !            depth
    1374. 

    1375. 

  1375. !-------------------------------------------------------------------------
    1376. 

    1377. 

  1377.       if (strat_volcanic) then
    1378. 

  1378.         do bnd_idx=1,bnd_nbr_LW
    1379. 

  1379.            do i=1,pcols
    1380. 

  1380.               aer_trn_ttl(i,1,1,bnd_idx)=1.0
    1381. 

  1381.            end do
    1382. 

  1382.            do k1=2,plevp
    1383. 

  1383.               do i=1,pcols
    1384. 

  1384.                  aer_trn_ttl(i,k1,k1,bnd_idx)=1.0
    1385. 

    1386. 

  1386.                  aer_pth_dlt  = abs(aer_mpp(i,k1) - aer_mpp(i,1))
    1387. 

  1387.                  odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
    1388. 

    1389. 

  1389.                  aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl)
    1390. 

  1390.               end do
    1391. 

  1391.            end do
    1392. 

    1393. 

  1393.            do k1=2,plev
    1394. 

  1394.               do k2=k1+1,plevp
    1395. 

  1395.                  do i=1,pcols
    1396. 

  1396.                     aer_trn_ttl(i,k1,k2,bnd_idx) = &
    1397. 

  1397.                          aer_trn_ttl(i,1,k2,bnd_idx) / &
    1398. 

  1398.                          aer_trn_ttl(i,1,k1,bnd_idx)
    1399. 

  1399.                  end do
    1400. 

  1400.               end do
    1401. 

  1401.            end do
    1402. 

    1403. 

  1403.            do k1=2,plevp
    1404. 

  1404.               do k2=1,k1-1
    1405. 

  1405.                  do i=1,pcols
    1406. 

  1406.                     aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx)
    1407. 

  1407.                  end do
    1408. 

  1408.               end do
    1409. 

  1409.            end do
    1410. 

  1410.         end do
    1411. 

  1411.       else
    1412. 

  1412.         aer_trn_ttl = 1.0
    1413. 

  1413.       endif
    1414. 

    1415. 

  1415.       return
    1416. 

  1416.       end subroutine aer_trn
    1417. 

    1418. 

  1418.       subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp)
    1419. 

  1419. !------------------------------------------------------
    1420. 

  1420. !     Purpose: convert mass per layer to cumulative mass from Top
    1421. 

  1421. !------------------------------------------------------
    1422. 

  1422. !     use shr_kind_mod, only: r8 => shr_kind_r8
    1423. 

  1423. !     use ppgrid
    1424. 

  1424. !     use pmgrid
    1425. 

  1425.       implicit none
    1426. 

  1426. !#include <crdcon.h>
    1427. 

    1428. 

  1428. !     Parameters
    1429. 

  1429. !     Input
    1430. 

  1430.       integer, intent(in)        :: pcols, plev, plevp
    1431. 

  1431.       real(r8), intent(in):: aer_mass(pcols,plev)  ! Rad level aerosol mass mixing ratio
    1432. 

  1432.       integer, intent(in):: ncol
    1433. 

  1433. !
    1434. 

  1434. !     Output
    1435. 

  1435.       real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface
    1436. 

  1436. !
    1437. 

  1437. !     Local
    1438. 

  1438.       integer i      ! Column index
    1439. 

  1439.       integer k      ! Level index
    1440. 

  1440. !------------------------------------------------------
    1441. 

  1441. !------------------------------------------------------
    1442. 

    1443. 

  1443.       aer_mpp(1:ncol,1) =  0._r8
    1444. 

  1444.       do k=2,plevp
    1445. 

  1445.           aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1)
    1446. 

  1446.       enddo
    1447. 

  1447. !
    1448. 

  1448.       return
    1449. 

  1449.       end subroutine aer_pth
    1450. 

    1451. 

  1451. subroutine radctl(j, lchnk   ,ncol    , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst,  &
    1452. 

  1452.                   lwups   ,emis    ,          &
    1453. 

  1453.                   pmid    ,pint    ,pmln    ,piln    ,pdel    ,t       , &
    1454. 

  1454. !                 qm1     ,cld     ,cicewp  ,cliqwp  ,coszrs,  clat, &
    1455. 

  1455.                   qm1     ,cld     ,cicewp  ,cliqwp  ,tauxcl, tauxci, coszrs,  clat, &
    1456. 

  1456.                   asdir   ,asdif   ,aldir   ,aldif   ,solcon, GMT,JULDAY,JULIAN,DT,XTIME,  &
    1457. 

  1457.                   pin, ozmixmj, ozmix, levsiz, num_months,      &
    1458. 

  1458.                   m_psp, m_psn,  aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn  , &
    1459. 

  1459.                   nmxrgn  ,                   &
    1460. 

  1460.                   dolw, dosw, doabsems, abstot, absnxt, emstot, &
    1461. 

  1461.                   fsup    ,fsupc   ,fsdn    ,fsdnc   , &
    1462. 

  1462.                   flup    ,flupc   ,fldn    ,fldnc   , &
    1463. 

  1463.                   swcf    ,lwcf    ,flut    ,          &
    1464. 

  1464.                   fsns    ,fsnt    ,flns    ,flnt    , &
    1465. 

  1465.                   qrs     ,qrl     ,flwds   ,rel     ,rei     , &
    1466. 

  1466.                   sols    ,soll    ,solsd   ,solld   , &
    1467. 

  1467.                   landfrac,zm      ,fsds     )
    1468. 

  1468. !----------------------------------------------------------------------- 
    1469. 

  1469. ! 
    1470. 

  1470. ! Purpose: 
    1471. 

  1471. ! Driver for radiation computation.
    1472. 

  1472. ! 
    1473. 

  1473. ! Method: 
    1474. 

  1474. ! Radiation uses cgs units, so conversions must be done from
    1475. 

  1475. ! model fields to radiation fields.
    1476. 

  1476. !
    1477. 

  1477. ! Author: CCM1,  CMS Contact: J. Truesdale
    1478. 

  1478. ! 
    1479. 

  1479. !-----------------------------------------------------------------------
    1480. 

  1480. !  use shr_kind_mod, only: r8 => shr_kind_r8
    1481. 

  1481. !  use ppgrid
    1482. 

  1482. !  use pspect
    1483. 

  1483. !  use commap
    1484. 

  1484. !  use history, only: outfld
    1485. 

  1485. !  use constituents, only: ppcnst, cnst_get_ind
    1486. 

  1486. !  use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, &
    1487. 

  1487. !     aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC
    1488. 

  1488. !  use physics_types, only: physics_state
    1489. 

  1489. !  use wv_saturation, only: aqsat
    1490. 

  1490. !  use chemistry,    only: trace_gas
    1491. 

  1491. !  use physconst, only: cpair, epsilo
    1492. 

  1492. !  use aer_optics, only: idxVIS
    1493. 

  1493. !  use aerosol_intr, only: set_aerosol_from_prognostics
    1494. 

    1495. 

    1496. 

  1496.    implicit none
    1497. 

    1498. 

  1498. !
    1499. 

  1499. ! Input arguments
    1500. 

  1500. !
    1501. 

  1501.    integer, intent(in) :: lchnk,j                 ! chunk identifier
    1502. 

  1502.    integer, intent(in) :: ncol                  ! number of atmospheric columns
    1503. 

  1503.    integer, intent(in) :: levsiz                ! number of ozone data levels
    1504. 

  1504.    integer, intent(in) :: num_months            ! 12 months
    1505. 

  1505.    integer, intent(in) :: paerlev,naer_c          ! aerosol vertical level and # species
    1506. 

  1506.    integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst
    1507. 

  1507.    logical, intent(in) :: dolw,dosw,doabsems
    1508. 

    1509. 

    1510. 

  1510.    integer nspint            ! Num of spctrl intervals across solar spectrum
    1511. 

  1511.    integer naer_groups       ! Num of aerosol groups for optical diagnostics
    1512. 

  1512.    parameter ( nspint = 19 )
    1513. 

  1513.    parameter ( naer_groups = 7 )    ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols
    1514. 

    1515. 

    1516. 

  1516.    real(r8), intent(in) :: lwups(pcols)         ! Longwave up flux at surface
    1517. 

  1517.    real(r8), intent(in) :: emis(pcols,pver)     ! Cloud emissivity
    1518. 

  1518.    real(r8), intent(in) :: pmid(pcols,pver)     ! Model level pressures
    1519. 

  1519.    real(r8), intent(in) :: pint(pcols,pverp)    ! Model interface pressures
    1520. 

  1520.    real(r8), intent(in) :: pmln(pcols,pver)     ! Natural log of pmid
    1521. 

  1521.    real(r8), intent(in) :: rel(pcols,pver)      ! liquid effective drop size (microns)
    1522. 

  1522.    real(r8), intent(in) :: rei(pcols,pver)      ! ice effective drop size (microns)
    1523. 

  1523.    real(r8), intent(in) :: piln(pcols,pverp)    ! Natural log of pint
    1524. 

  1524.    real(r8), intent(in) :: pdel(pcols,pverp)    ! Pressure difference across layer 
    1525. 

  1525.    real(r8), intent(in) :: t(pcols,pver)        ! Model level temperatures
    1526. 

  1526.    real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
    1527. 

  1527.    real(r8), intent(in) :: cld(pcols,pver)      ! Fractional cloud cover
    1528. 

  1528.    real(r8), intent(in) :: cicewp(pcols,pver)   ! in-cloud cloud ice water path
    1529. 

  1529.    real(r8), intent(in) :: cliqwp(pcols,pver)   ! in-cloud cloud liquid water path
    1530. 

  1530.    real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth
    1531. 

  1531.    real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth
    1532. 

  1532.    real(r8), intent(in) :: coszrs(pcols)        ! Cosine solar zenith angle
    1533. 

  1533.    real(r8), intent(in) :: clat(pcols)          ! latitude in radians for columns 
    1534. 

  1534.    real(r8), intent(in) :: asdir(pcols)         ! albedo shortwave direct
    1535. 

  1535.    real(r8), intent(in) :: asdif(pcols)         ! albedo shortwave diffuse
    1536. 

  1536.    real(r8), intent(in) :: aldir(pcols)         ! albedo longwave direct
    1537. 

  1537.    real(r8), intent(in) :: aldif(pcols)         ! albedo longwave diffuse
    1538. 

  1538.    real(r8), intent(in) :: landfrac(pcols)      ! land fraction
    1539. 

  1539.    real(r8), intent(in) :: zm(pcols,pver)       ! Height of midpoints (above surface)
    1540. 

  1540.    real(r8), intent(in) :: pin(levsiz)          ! Pressure levels of ozone data
    1541. 

  1541.    real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months)  ! monthly ozone mixing ratio
    1542. 

  1542.    real(r8), intent(inout) :: ozmix(pcols,levsiz)  ! Ozone data
    1543. 

  1543.    real, intent(in) :: solcon               ! solar constant with eccentricity factor
    1544. 

  1544.    REAL, INTENT(IN    )      ::        XTIME,GMT              
    1545. 

  1545.    INTEGER, INTENT(IN )      ::        JULDAY
    1546. 

  1546.    REAL,    INTENT(IN )      ::        JULIAN
    1547. 

  1547.    REAL,    INTENT(IN )      ::        DT
    1548. 

  1548.    real(r8), intent(in)     :: m_psp(pcols),m_psn(pcols)       ! MATCH surface pressure
    1549. 

  1549.    real(r8), intent(in)     :: aerosoljp(pcols,paerlev,naer_c)   ! aerosol concentrations
    1550. 

  1550.    real(r8), intent(in)     :: aerosoljn(pcols,paerlev,naer_c)   ! aerosol concentrations
    1551. 

  1551.    real(r8), intent(in)     :: m_hybi(paerlev)
    1552. 

  1552. !  type(physics_state), intent(in) :: state     
    1553. 

  1553.    real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
    1554. 

  1554. !    maximally overlapped region.
    1555. 

  1555. !    0->pmxrgn(i,1) is range of pmid for
    1556. 

  1556. !    1st region, pmxrgn(i,1)->pmxrgn(i,2) for
    1557. 

  1557. !    2nd region, etc
    1558. 

  1558.    integer, intent(inout) :: nmxrgn(pcols)     ! Number of maximally overlapped regions
    1559. 

    1560. 

  1560.     real(r8) :: pmxrgnrf(pcols,pverp)             ! temporary copy of pmxrgn
    1561. 

  1561.     integer  :: nmxrgnrf(pcols)     ! temporary copy of nmxrgn
    1562. 

    1563. 

  1563. !
    1564. 

  1564. ! Output solar arguments
    1565. 

  1565. !
    1566. 

  1566.    real(r8), intent(out) :: fsns(pcols)          ! Surface absorbed solar flux
    1567. 

  1567.    real(r8), intent(out) :: fsnt(pcols)          ! Net column abs solar flux at model top
    1568. 

  1568.    real(r8), intent(out) :: flns(pcols)          ! Srf longwave cooling (up-down) flux
    1569. 

  1569.    real(r8), intent(out) :: flnt(pcols)          ! Net outgoing lw flux at model top
    1570. 

  1570.    real(r8), intent(out) :: sols(pcols)          ! Downward solar rad onto surface (sw direct)
    1571. 

  1571.    real(r8), intent(out) :: soll(pcols)          ! Downward solar rad onto surface (lw direct)
    1572. 

  1572.    real(r8), intent(out) :: solsd(pcols)         ! Downward solar rad onto surface (sw diffuse)
    1573. 

  1573.    real(r8), intent(out) :: solld(pcols)         ! Downward solar rad onto surface (lw diffuse)
    1574. 

  1574.    real(r8), intent(out) :: qrs(pcols,pver)      ! Solar heating rate
    1575. 

  1575.    real(r8), intent(out) :: fsds(pcols)          ! Flux Shortwave Downwelling Surface
    1576. 

  1576. ! Added outputs of total and clearsky fluxes etc
    1577. 

  1577.    real(r8), intent(out) :: fsup(pcols,pverp)    ! Upward total sky solar
    1578. 

  1578.    real(r8), intent(out) :: fsupc(pcols,pverp)   ! Upward clear sky solar
    1579. 

  1579.    real(r8), intent(out) :: fsdn(pcols,pverp)    ! Downward total sky solar
    1580. 

  1580.    real(r8), intent(out) :: fsdnc(pcols,pverp)   ! Downward clear sky solar
    1581. 

  1581.    real(r8), intent(out) :: flup(pcols,pverp)    ! Upward total sky longwave
    1582. 

  1582.    real(r8), intent(out) :: flupc(pcols,pverp)   ! Upward clear sky longwave
    1583. 

  1583.    real(r8), intent(out) :: fldn(pcols,pverp)    ! Downward total sky longwave
    1584. 

  1584.    real(r8), intent(out) :: fldnc(pcols,pverp)   ! Downward clear sky longwave
    1585. 

  1585.    real(r8), intent(out) :: swcf(pcols)          ! Top of the atmosphere solar cloud forcing
    1586. 

  1586.    real(r8), intent(out) :: lwcf(pcols)          ! Top of the atmosphere longwave cloud forcing
    1587. 

  1587.    real(r8), intent(out) :: flut(pcols)          ! Top of the atmosphere outgoing longwave
    1588. 

  1588. !
    1589. 

  1589. ! Output longwave arguments
    1590. 

  1590. !
    1591. 

  1591.    real(r8), intent(out) :: qrl(pcols,pver)      ! Longwave cooling rate
    1592. 

  1592.    real(r8), intent(out) :: flwds(pcols)         ! Surface down longwave flux
    1593. 

    1594. 

  1594.    real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
    1595. 

  1595.    real(r8), intent(inout) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
    1596. 

  1596.    real(r8), intent(inout) :: emstot(pcols,pverp)     ! Total emissivity
    1597. 

    1598. 

    1599. 

  1599. !
    1600. 

  1600. !---------------------------Local variables-----------------------------
    1601. 

  1601. !
    1602. 

  1602.    integer i, k              ! index
    1603. 

    1604. 

  1604.    integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array
    1605. 

    1606. 

  1606.    real(r8) solin(pcols)         ! Solar incident flux
    1607. 

  1607. !  real(r8) fsds(pcols)          ! Flux Shortwave Downwelling Surface
    1608. 

  1608.    real(r8) fsntoa(pcols)        ! Net solar flux at TOA
    1609. 

  1609.    real(r8) fsntoac(pcols)       ! Clear sky net solar flux at TOA
    1610. 

  1610.    real(r8) fsnirt(pcols)        ! Near-IR flux absorbed at toa
    1611. 

  1611.    real(r8) fsnrtc(pcols)        ! Clear sky near-IR flux absorbed at toa
    1612. 

  1612.    real(r8) fsnirtsq(pcols)      ! Near-IR flux absorbed at toa >= 0.7 microns
    1613. 

  1613.    real(r8) fsntc(pcols)         ! Clear sky total column abs solar flux
    1614. 

  1614.    real(r8) fsnsc(pcols)         ! Clear sky surface abs solar flux
    1615. 

  1615.    real(r8) fsdsc(pcols)         ! Clear sky surface downwelling solar flux
    1616. 

  1616. !  real(r8) flut(pcols)          ! Upward flux at top of model
    1617. 

  1617. !  real(r8) lwcf(pcols)          ! longwave cloud forcing
    1618. 

  1618. !  real(r8) swcf(pcols)          ! shortwave cloud forcing
    1619. 

  1619.    real(r8) flutc(pcols)         ! Upward Clear Sky flux at top of model
    1620. 

  1620.    real(r8) flntc(pcols)         ! Clear sky lw flux at model top
    1621. 

  1621.    real(r8) flnsc(pcols)         ! Clear sky lw flux at srf (up-down)
    1622. 

  1622.    real(r8) ftem(pcols,pver)     ! temporary array for outfld
    1623. 

    1624. 

  1624.    real(r8) pbr(pcols,pverr)     ! Model mid-level pressures (dynes/cm2)
    1625. 

  1625.    real(r8) pnm(pcols,pverrp)    ! Model interface pressures (dynes/cm2)
    1626. 

  1626.    real(r8) o3vmr(pcols,pverr)   ! Ozone volume mixing ratio
    1627. 

  1627.    real(r8) o3mmr(pcols,pverr)   ! Ozone mass mixing ratio
    1628. 

  1628.    real(r8) eccf                 ! Earth/sun distance factor
    1629. 

  1629.    real(r8) n2o(pcols,pver)      ! nitrous oxide mass mixing ratio
    1630. 

  1630.    real(r8) ch4(pcols,pver)      ! methane mass mixing ratio
    1631. 

  1631.    real(r8) cfc11(pcols,pver)    ! cfc11 mass mixing ratio
    1632. 

  1632.    real(r8) cfc12(pcols,pver)    ! cfc12 mass mixing ratio
    1633. 

  1633.    real(r8) rh(pcols,pverr)      ! level relative humidity (fraction)
    1634. 

  1634.    real(r8) lwupcgs(pcols)       ! Upward longwave flux in cgs units
    1635. 

    1636. 

  1636.    real(r8) esat(pcols,pverr)    ! saturation vapor pressure
    1637. 

  1637.    real(r8) qsat(pcols,pverr)    ! saturation specific humidity
    1638. 

    1639. 

  1639.    real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums
    1640. 

  1640.    real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
    1641. 

  1641.    real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
    1642. 

  1642.    real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
    1643. 

  1643.    real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
    1644. 

    1645. 

  1645.    real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios
    1646. 

  1646.    real(r8) scales(naer_all)               ! scaling factors for aerosols
    1647. 

    1648. 

    1649. 

  1649. !
    1650. 

  1650. ! Interpolate ozone volume mixing ratio to model levels
    1651. 

  1651. !
    1652. 

  1652. ! WRF: added pin, levsiz, ozmix here
    1653. 

  1653.    call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
    1654. 

    1655. 

  1655.    call radozn(lchnk   ,ncol    &
    1656. 

  1656.               ,pcols, pver &
    1657. 

  1657.               ,pmid    ,pin, levsiz, ozmix, o3vmr   )
    1658. 

    1659. 

  1659. !  call outfld('O3VMR   ',o3vmr ,pcols, lchnk)
    1660. 

    1661. 

  1661. !
    1662. 

  1662. ! Set chunk dependent radiation input
    1663. 

  1663. !
    1664. 

  1664.    call radinp(lchnk   ,ncol    ,pcols, pver, pverp,      &
    1665. 

  1665.                pmid    ,pint    ,o3vmr   , pbr     ,&
    1666. 

  1666.                pnm     ,eccf    ,o3mmr   )
    1667. 

    1668. 

  1668. !
    1669. 

  1669. ! Solar radiation computation
    1670. 

  1670. !
    1671. 

  1671.    if (dosw) then
    1672. 

    1673. 

  1673. !
    1674. 

  1674. ! calculate heating with aerosols
    1675. 

  1675. !
    1676. 

  1676.       call aqsat(t, pmid, esat, qsat, pcols, &
    1677. 

  1677.                  ncol, pver, 1, pver)
    1678. 

    1679. 

  1679.       ! calculate relative humidity
    1680. 

  1680. !     rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
    1681. 

  1681. !        ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
    1682. 

  1682. !        ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo)
    1683. 

  1683.       rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
    1684. 

  1684.          ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
    1685. 

  1685.          ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo)
    1686. 

    1687. 

  1687.       if (radforce) then
    1688. 

    1689. 

  1689.          pmxrgnrf = pmxrgn
    1690. 

  1690.          nmxrgnrf = nmxrgn
    1691. 

    1692. 

  1692.          call get_rf_scales(scales)
    1693. 

    1694. 

  1694.          call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
    1695. 

  1695.            aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
    1696. 

    1697. 

  1697.          ! overwrite with prognostics aerosols
    1698. 

    1699. 

  1699. !   no feedback from prognostic aerosols 
    1700. 

  1700. !        call set_aerosol_from_prognostics (ncol, q, aerosol)
    1701. 

    1702. 

  1702.          call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
    1703. 

  1703.    
    1704. 

  1704. !        call t_startf('radcswmx_rf')
    1705. 

  1705.          call radcswmx(j, lchnk   ,ncol ,pcols, pver, pverp,         &
    1706. 

  1706.                     pnm     ,pbr     ,qm1     ,rh      ,o3mmr   , &
    1707. 

  1707.                     aerosol ,cld     ,cicewp  ,cliqwp  ,rel     , &
    1708. 

  1708. !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
    1709. 

  1709.                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
    1710. 

  1710.                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgnrf, &
    1711. 

  1711.                     pmxrgnrf,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
    1712. 

  1712.                     fsntoac ,fsnirt  ,fsnrtc  ,fsnirtsq,fsns    , &
    1713. 

  1713.                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
    1714. 

  1714.                     solsd   ,solld   ,frc_day ,                   &
    1715. 

  1715.                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
    1716. 

  1716.                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
    1717. 

  1717. !        call t_stopf('radcswmx_rf')
    1718. 

    1719. 

  1719. !
    1720. 

  1720. ! Convert units of shortwave fields needed by rest of model from CGS to MKS
    1721. 

  1721. !
    1722. 

    1723. 

  1723.             do i = 1, ncol
    1724. 

  1724.             solin(i) = solin(i)*1.e-3
    1725. 

  1725.             fsnt(i)  = fsnt(i) *1.e-3
    1726. 

  1726.             fsns(i)  = fsns(i) *1.e-3
    1727. 

  1727.             fsntc(i) = fsntc(i)*1.e-3
    1728. 

  1728.             fsnsc(i) = fsnsc(i)*1.e-3
    1729. 

  1729.             end do
    1730. 

  1730.          ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
    1731. 

  1731. !
    1732. 

  1732. ! Dump shortwave radiation information to history tape buffer (diagnostics)
    1733. 

  1733. !
    1734. 

  1734. !        call outfld('QRS_RF  ',ftem  ,pcols,lchnk)
    1735. 

  1735. !        call outfld('FSNT_RF ',fsnt  ,pcols,lchnk)
    1736. 

  1736. !        call outfld('FSNS_RF ',fsns  ,pcols,lchnk)
    1737. 

  1737. !        call outfld('FSNTC_RF',fsntc ,pcols,lchnk)
    1738. 

  1738. !        call outfld('FSNSC_RF',fsnsc ,pcols,lchnk)
    1739. 

  1739.  
    1740. 

  1740.       endif ! if (radforce)
    1741. 

    1742. 

  1742.       call get_int_scales(scales)
    1743. 

    1744. 

  1744.       call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
    1745. 

  1745.              m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
    1746. 

    1747. 

  1747.       ! overwrite with prognostics aerosols
    1748. 

  1748. !     call set_aerosol_from_prognostics (ncol, q, aerosol)
    1749. 

    1750. 

  1750.       call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
    1751. 

  1751. !     call t_startf('radcswmx')
    1752. 

    1753. 

  1753.       call radcswmx(j, lchnk   ,ncol    ,pcols, pver, pverp,         &
    1754. 

  1754.                     pnm     ,pbr     ,qm1     ,rh      ,o3mmr   , &
    1755. 

  1755.                     aerosol ,cld     ,cicewp  ,cliqwp  ,rel     , &
    1756. 

  1756. !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
    1757. 

  1757.                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
    1758. 

  1758.                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgn  , &
    1759. 

  1759.                     pmxrgn  ,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
    1760. 

  1760.                     fsntoac ,fsnirt  ,fsnrtc  ,fsnirtsq,fsns    , &
    1761. 

  1761.                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
    1762. 

  1762.                     solsd   ,solld   ,frc_day ,                   &
    1763. 

  1763.                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
    1764. 

  1764.                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
    1765. 

  1765. !     call t_stopf('radcswmx')
    1766. 

    1767. 

  1767. ! -- tls ---------------------------------------------------------------2
    1768. 

  1768. !
    1769. 

  1769. ! Convert units of shortwave fields needed by rest of model from CGS to MKS
    1770. 

  1770. !
    1771. 

  1771.       do i=1,ncol
    1772. 

  1772.          solin(i) = solin(i)*1.e-3
    1773. 

  1773.          fsds(i)  = fsds(i)*1.e-3
    1774. 

  1774.          fsnirt(i)= fsnirt(i)*1.e-3
    1775. 

  1775.          fsnrtc(i)= fsnrtc(i)*1.e-3
    1776. 

  1776.          fsnirtsq(i)= fsnirtsq(i)*1.e-3
    1777. 

  1777.          fsnt(i)  = fsnt(i) *1.e-3
    1778. 

  1778.          fsns(i)  = fsns(i) *1.e-3
    1779. 

  1779.          fsntc(i) = fsntc(i)*1.e-3
    1780. 

  1780.          fsnsc(i) = fsnsc(i)*1.e-3
    1781. 

  1781.          fsdsc(i) = fsdsc(i)*1.e-3
    1782. 

  1782.          fsntoa(i)=fsntoa(i)*1.e-3
    1783. 

  1783.          fsntoac(i)=fsntoac(i)*1.e-3
    1784. 

  1784.          swcf(i)  = fsntoa(i) - fsntoac(i)
    1785. 

  1785.       end do
    1786. 

  1786.       ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
    1787. 

    1788. 

  1788. ! Added upward/downward total and clear sky fluxes
    1789. 

  1789.          do k = 1, pverp
    1790. 

  1790.             do i = 1, ncol
    1791. 

  1791.             fsup(i,k)  = fsup(i,k)*1.e-3
    1792. 

  1792.             fsupc(i,k) = fsupc(i,k)*1.e-3
    1793. 

  1793.             fsdn(i,k)  = fsdn(i,k)*1.e-3
    1794. 

  1794.             fsdnc(i,k) = fsdnc(i,k)*1.e-3
    1795. 

  1795.             end do
    1796. 

  1796.          end do
    1797. 

    1798. 

  1798. !
    1799. 

  1799. ! Dump shortwave radiation information to history tape buffer (diagnostics)
    1800. 

  1800. !
    1801. 

    1802. 

  1802. !     call outfld('frc_day ', frc_day, pcols, lchnk)
    1803. 

  1803. !     call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk)
    1804. 

  1804. !     call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk)
    1805. 

  1805. !     call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk)
    1806. 

  1806. !     call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk)
    1807. 

  1807. !     call outfld('BGOD_v  ', aertau(:,idxVIS,5) ,pcols,lchnk)
    1808. 

  1808. !     call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk)
    1809. 

  1809. !     call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk)
    1810. 

  1810. !     call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk)
    1811. 

  1811. !     call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk)
    1812. 

  1812. !     call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk)
    1813. 

  1813. !     call aerosol_diagnostics (lchnk, ncol, pdel, aerosol)
    1814. 

    1815. 

  1815. !     call outfld('QRS     ',ftem  ,pcols,lchnk)
    1816. 

  1816. !     call outfld('SOLIN   ',solin ,pcols,lchnk)
    1817. 

  1817. !     call outfld('FSDS    ',fsds  ,pcols,lchnk)
    1818. 

  1818. !     call outfld('FSNIRTOA',fsnirt,pcols,lchnk)
    1819. 

  1819. !     call outfld('FSNRTOAC',fsnrtc,pcols,lchnk)
    1820. 

  1820. !     call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk)
    1821. 

  1821. !     call outfld('FSNT    ',fsnt  ,pcols,lchnk)
    1822. 

  1822. !     call outfld('FSNS    ',fsns  ,pcols,lchnk)
    1823. 

  1823. !     call outfld('FSNTC   ',fsntc ,pcols,lchnk)
    1824. 

  1824. !     call outfld('FSNSC   ',fsnsc ,pcols,lchnk)
    1825. 

  1825. !     call outfld('FSDSC   ',fsdsc ,pcols,lchnk)
    1826. 

  1826. !     call outfld('FSNTOA  ',fsntoa,pcols,lchnk)
    1827. 

  1827. !     call outfld('FSNTOAC ',fsntoac,pcols,lchnk)
    1828. 

  1828. !     call outfld('SOLS    ',sols  ,pcols,lchnk)
    1829. 

  1829. !     call outfld('SOLL    ',soll  ,pcols,lchnk)
    1830. 

  1830. !     call outfld('SOLSD   ',solsd ,pcols,lchnk)
    1831. 

  1831. !     call outfld('SOLLD   ',solld ,pcols,lchnk)
    1832. 

    1833. 

  1833.    end if
    1834. 

  1834. !
    1835. 

  1835. ! Longwave radiation computation
    1836. 

  1836. !
    1837. 

  1837.    if (dolw) then
    1838. 

    1839. 

  1839.       call get_int_scales(scales)
    1840. 

    1841. 

  1841.       call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
    1842. 

  1842.              m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
    1843. 

    1844. 

  1844. !
    1845. 

  1845. ! Convert upward longwave flux units to CGS
    1846. 

  1846. !
    1847. 

  1847.       do i=1,ncol
    1848. 

  1848. !        lwupcgs(i) = lwup(i)*1000.
    1849. 

  1849.          lwupcgs(i) = lwups(i)
    1850. 

  1850.       end do
    1851. 

  1851. !
    1852. 

  1852. ! Do longwave computation. If not implementing greenhouse gas code then
    1853. 

  1853. ! first specify trace gas mixing ratios. If greenhouse gas code then:
    1854. 

  1854. !  o ixtrcg   => indx of advected n2o tracer
    1855. 

  1855. !  o ixtrcg+1 => indx of advected ch4 tracer
    1856. 

  1856. !  o ixtrcg+2 => indx of advected cfc11 tracer
    1857. 

  1857. !  o ixtrcg+3 => indx of advected cfc12 tracer
    1858. 

  1858. !
    1859. 

  1859.       if (trace_gas) then
    1860. 

  1860. !        call cnst_get_ind('N2O'  , in2o)
    1861. 

  1861. !        call cnst_get_ind('CH4'  , ich4)
    1862. 

  1862. !        call cnst_get_ind('CFC11', if11)
    1863. 

  1863. !        call cnst_get_ind('CFC12', if12)
    1864. 

  1864. !        call t_startf("radclwmx")
    1865. 

  1865.          call radclwmx(lchnk   ,ncol    ,pcols, pver, pverp ,        & 
    1866. 

  1866.                        lwupcgs ,t       ,qm1(1,1,1)       ,o3vmr ,   &
    1867. 

  1867.                        pbr     ,pnm     ,pmln    ,piln    ,          &
    1868. 

  1868.                        qm1(1,1,in2o)    ,qm1(1,1,ich4)    ,          &
    1869. 

  1869.                        qm1(1,1,if11)    ,qm1(1,1,if12)    ,          &
    1870. 

  1870.                        cld     ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
    1871. 

  1871.                        doabsems, abstot, absnxt, emstot,             &
    1872. 

  1872.                        flns    ,flnt    ,flnsc   ,flntc   ,flwds   , &
    1873. 

  1873.                        flut    ,flutc   ,                            &
    1874. 

  1874.                        flup    ,flupc   ,fldn    ,fldnc   ,          &
    1875. 

  1875.                        aerosol(:,:,idxVOLC))
    1876. 

  1876. !        call t_stopf("radclwmx")
    1877. 

  1877.       else
    1878. 

  1878.          call trcmix(lchnk   ,ncol    ,pcols, pver,  &
    1879. 

  1879.                      pmid    ,clat, n2o     ,ch4     ,                     &
    1880. 

  1880.                      cfc11   ,cfc12   )
    1881. 

    1882. 

  1882. !        call t_startf("radclwmx")
    1883. 

  1883.          call radclwmx(lchnk     ,ncol    ,pcols, pver, pverp ,        &
    1884. 

  1884.                        lwupcgs   ,t       ,qm1(1,1,1)       ,o3vmr ,   &
    1885. 

  1885.                        pbr       ,pnm     ,pmln    ,piln    ,          &
    1886. 

  1886.                        n2o       ,ch4     ,cfc11   ,cfc12   ,          &
    1887. 

  1887.                        cld       ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
    1888. 

  1888.                        doabsems, abstot, absnxt, emstot,             &
    1889. 

  1889.                        flns      ,flnt    ,flnsc   ,flntc   ,flwds   , &
    1890. 

  1890.                        flut      ,flutc   ,                            &
    1891. 

  1891.                        flup      ,flupc   ,fldn    ,fldnc   ,          &
    1892. 

  1892.                        aerosol(:,:,idxVOLC))
    1893. 

  1893. !        call t_stopf("radclwmx")
    1894. 

  1894.       endif
    1895. 

  1895. !
    1896. 

  1896. ! Convert units of longwave fields needed by rest of model from CGS to MKS
    1897. 

  1897. !
    1898. 

  1898.       do i=1,ncol
    1899. 

  1899.          flnt(i)  = flnt(i)*1.e-3
    1900. 

  1900.          flut(i)  = flut(i)*1.e-3
    1901. 

  1901.          flutc(i) = flutc(i)*1.e-3
    1902. 

  1902.          flns(i)  = flns(i)*1.e-3
    1903. 

  1903.          flntc(i) = flntc(i)*1.e-3
    1904. 

  1904.          flnsc(i) = flnsc(i)*1.e-3
    1905. 

  1905.          flwds(i) = flwds(i)*1.e-3
    1906. 

  1906.          lwcf(i)  = flutc(i) - flut(i)
    1907. 

  1907.       end do
    1908. 

    1909. 

  1909. ! Added upward/downward total and clear sky fluxes
    1910. 

  1910.          do k = 1, pverp
    1911. 

  1911.             do i = 1, ncol
    1912. 

  1912.             flup(i,k)  = flup(i,k)*1.e-3
    1913. 

  1913.             flupc(i,k) = flupc(i,k)*1.e-3
    1914. 

  1914.             fldn(i,k)  = fldn(i,k)*1.e-3
    1915. 

  1915.             fldnc(i,k) = fldnc(i,k)*1.e-3
    1916. 

  1916.             end do
    1917. 

  1917.          end do
    1918. 

  1918. !
    1919. 

  1919. ! Dump longwave radiation information to history tape buffer (diagnostics)
    1920. 

  1920. !
    1921. 

  1921. !     call outfld('QRL     ',qrl(:ncol,:)/cpair,ncol,lchnk)
    1922. 

  1922. !     call outfld('FLNT    ',flnt  ,pcols,lchnk)
    1923. 

  1923. !     call outfld('FLUT    ',flut  ,pcols,lchnk)
    1924. 

  1924. !     call outfld('FLUTC   ',flutc ,pcols,lchnk)
    1925. 

  1925. !     call outfld('FLNTC   ',flntc ,pcols,lchnk)
    1926. 

  1926. !     call outfld('FLNS    ',flns  ,pcols,lchnk)
    1927. 

  1927. !     call outfld('FLNSC   ',flnsc ,pcols,lchnk)
    1928. 

  1928. !     call outfld('LWCF    ',lwcf  ,pcols,lchnk)
    1929. 

  1929. !     call outfld('SWCF    ',swcf  ,pcols,lchnk)
    1930. 

  1930. !
    1931. 

  1931.    end if
    1932. 

  1932. !
    1933. 

  1933.    return
    1934. 

  1934. end subroutine radctl
    1935. 

  1935.   subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, &
    1936. 

  1936.                                   q, cldn, landfrac, landm,icefrac, &
    1937. 

  1937.         pdel,  t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh )
    1938. 

  1938. !
    1939. 

  1939. ! Compute (liquid+ice) water path and cloud water/ice diagnostics
    1940. 

  1940. ! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios
    1941. 

  1941. ! 
    1942. 

  1942. ! **** mixes interface and physics code temporarily
    1943. 

  1943. !-----------------------------------------------------------------------
    1944. 

  1944. !   use physics_types, only: physics_state
    1945. 

  1945. !   use history,       only: outfld
    1946. 

  1946. !   use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw
    1947. 

    1948. 

  1948.     implicit none
    1949. 

    1950. 

  1950. ! Arguments
    1951. 

  1951.     integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst
    1952. 

  1952.     real(r8), intent(in)  :: q(pcols,pver,ppcnst)     ! moisture arrays
    1953. 

  1953.     real(r8), intent(in)  :: cldn(pcols,pver)        ! new cloud fraction
    1954. 

  1954.     real(r8), intent(in)  :: pdel(pcols,pver)        ! pressure thickness
    1955. 

  1955.     real(r8), intent(in)  :: t(pcols,pver)           ! temperature
    1956. 

  1956.     real(r8), intent(in)  :: pmid(pcols,pver)        ! pressure 
    1957. 

  1957.     real(r8), intent(in)  :: pint(pcols,pverp)       ! pressure 
    1958. 

  1958.     real(r8), intent(in)  :: ps(pcols)               ! surface pressure 
    1959. 

  1959.     real(r8), intent(in)  :: landfrac(pcols)         ! Land fraction
    1960. 

  1960.     real(r8), intent(in)  :: icefrac(pcols)          ! Ice fraction
    1961. 

  1961.     real(r8), intent(in)  :: landm(pcols)            ! Land fraction ramped
    1962. 

  1962.     real(r8), intent(in) :: snowh(pcols)         ! Snow depth over land, water equivalent (m)
    1963. 

    1964. 

  1964. !!$    real(r8), intent(out) :: cwp   (pcols,pver)      ! in-cloud cloud (total) water path
    1965. 

  1965.     real(r8), intent(out) :: cicewp(pcols,pver)      ! in-cloud cloud ice water path
    1966. 

  1966.     real(r8), intent(out) :: cliqwp(pcols,pver)      ! in-cloud cloud liquid water path
    1967. 

  1967.     real(r8), intent(out) :: emis  (pcols,pver)      ! cloud emissivity
    1968. 

  1968.     real(r8), intent(out) :: rel   (pcols,pver)      ! effective drop radius (microns)
    1969. 

  1969.     real(r8), intent(out) :: rei   (pcols,pver)      ! ice effective drop size (microns)
    1970. 

  1970.     real(r8), intent(out) :: pmxrgn(pcols,pver+1)    ! Maximum values of pressure for each
    1971. 

  1971.     integer , intent(out) :: nmxrgn(pcols)           ! Number of maximally overlapped regions
    1972. 

    1973. 

  1973. ! Local variables
    1974. 

  1974.     real(r8) :: cwp   (pcols,pver)      ! in-cloud cloud (total) water path
    1975. 

  1975. !!$    real(r8) :: cicewp(pcols,pver)      ! in-cloud cloud ice water path
    1976. 

  1976. !!$    real(r8) :: cliqwp(pcols,pver)      ! in-cloud cloud liquid water path
    1977. 

  1977.     real(r8) :: effcld(pcols,pver)                   ! effective cloud=cld*emis
    1978. 

  1978.     real(r8) :: gicewp(pcols,pver)                   ! grid-box cloud ice water path
    1979. 

  1979.     real(r8) :: gliqwp(pcols,pver)                   ! grid-box cloud liquid water path
    1980. 

  1980.     real(r8) :: gwp   (pcols,pver)                   ! grid-box cloud (total) water path
    1981. 

  1981.     real(r8) :: hl     (pcols)                       ! Liquid water scale height
    1982. 

  1982.     real(r8) :: tgicewp(pcols)                       ! Vertically integrated ice water path
    1983. 

  1983.     real(r8) :: tgliqwp(pcols)                       ! Vertically integrated liquid water path
    1984. 

  1984.     real(r8) :: tgwp   (pcols)                       ! Vertically integrated (total) cloud water path
    1985. 

  1985.     real(r8) :: tpw    (pcols)                       ! total precipitable water
    1986. 

  1986.     real(r8) :: clwpold(pcols,pver)                  ! Presribed cloud liq. h2o path
    1987. 

  1987.     real(r8) :: ficemr (pcols,pver)                  ! Ice fraction from ice and liquid mixing ratios
    1988. 

    1989. 

  1989.     real(r8) :: rgrav                ! inverse gravitational acceleration
    1990. 

    1991. 

  1991.     integer :: i,k                                   ! loop indexes
    1992. 

  1992.     integer :: lchnk
    1993. 

    1994. 

  1994. !-----------------------------------------------------------------------
    1995. 

    1996. 

  1996. ! Compute liquid and ice water paths
    1997. 

  1997.     tgicewp(:ncol) = 0.
    1998. 

  1998.     tgliqwp(:ncol) = 0.
    1999. 

  1999.     do k=1,pver
    2000. 

  2000.        do i = 1,ncol
    2001. 

  2001.           gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0  ! Grid box ice water path.
    2002. 

  2002.           gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0  ! Grid box liquid water path.
    2003. 

  2003. !!$          gwp   (i,k) = gicewp(i,k) + gliqwp(i,k)
    2004. 

  2004.           cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud ice water path.
    2005. 

  2005.           cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud liquid water path.
    2006. 

  2006. !!$          cwp   (i,k) = gwp   (i,k) / max(0.01_r8,cldn(i,k))
    2007. 

  2007.           ficemr(i,k) = q(i,k,ixcldice) /                 &
    2008. 

  2008.                max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq)))
    2009. 

  2009.           
    2010. 

  2010.           tgicewp(i)  = tgicewp(i) + gicewp(i,k)
    2011. 

  2011.           tgliqwp(i)  = tgliqwp(i) + gliqwp(i,k)
    2012. 

  2012.        end do
    2013. 

  2013.     end do
    2014. 

  2014.     tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol)
    2015. 

  2015.     gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver) 
    2016. 

  2016.     cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) 
    2017. 

    2018. 

  2018. ! Compute total preciptable water in column (in mm)
    2019. 

  2019.     tpw(:ncol) = 0.0
    2020. 

  2020.     rgrav = 1.0/gravmks
    2021. 

  2021.     do k=1,pver
    2022. 

  2022.        do i=1,ncol
    2023. 

  2023.           tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav
    2024. 

  2024.        end do
    2025. 

  2025.     end do
    2026. 

    2027. 

  2027. ! Diagnostic liquid water path (old specified form)
    2028. 

  2028. !   call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl)
    2029. 

    2030. 

  2030. ! Cloud water and ice particle sizes
    2031. 

  2031.     call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
    2032. 

    2033. 

  2033. ! Cloud emissivity.
    2034. 

  2034.     call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis)
    2035. 

    2036. 

  2036. ! Effective cloud cover
    2037. 

  2037.     do k=1,pver
    2038. 

  2038.        do i=1,ncol
    2039. 

  2039.           effcld(i,k) = cldn(i,k)*emis(i,k)
    2040. 

  2040.        end do
    2041. 

  2041.     end do
    2042. 

    2043. 

  2043. ! Determine parameters for maximum/random overlap
    2044. 

  2044.     call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn)
    2045. 

    2046. 

  2046. !   call outfld('GCLDLWP' ,gwp    , pcols,lchnk)
    2047. 

  2047. !   call outfld('TGCLDCWP',tgwp   , pcols,lchnk)
    2048. 

  2048. !   call outfld('TGCLDLWP',tgliqwp, pcols,lchnk)
    2049. 

  2049. !   call outfld('TGCLDIWP',tgicewp, pcols,lchnk)
    2050. 

  2050. !   call outfld('ICLDLWP' ,cwp    , pcols,lchnk)
    2051. 

  2051. !   call outfld('SETLWP'  ,clwpold, pcols,lchnk)
    2052. 

  2052. !   call outfld('EFFCLD'  ,effcld , pcols,lchnk)
    2053. 

  2053. !   call outfld('LWSH'    ,hl     , pcols,lchnk)
    2054. 

    2055. 

  2055.   end subroutine param_cldoptics_calc
    2056. 

    2057. 

  2057. subroutine radabs(lchnk   ,ncol    ,pcols, pver, pverp,   &
    2058. 

  2058.    pbr    ,pnm     ,co2em    ,co2eml  ,tplnka  , &
    2059. 

  2059.    s2c    ,tcg     ,w        ,h2otr   ,plco2   , &
    2060. 

  2060.    plh2o  ,co2t    ,tint     ,tlayr   ,plol    , &
    2061. 

  2061.    plos   ,pmln    ,piln     ,ucfc11  ,ucfc12  , &
    2062. 

  2062.    un2o0  ,un2o1   ,uch4     ,uco211  ,uco212  , &
    2063. 

  2063.    uco213 ,uco221  ,uco222   ,uco223  ,uptype  , &
    2064. 

  2064.    bn2o0  ,bn2o1   ,bch4    ,abplnk1  ,abplnk2 , &
    2065. 

  2065.    abstot ,absnxt  ,plh2ob  ,wb       , &
    2066. 

  2066.    aer_mpp ,aer_trn_ttl)
    2067. 

  2067. !----------------------------------------------------------------------- 
    2068. 

  2068. ! 
    2069. 

  2069. ! Purpose: 
    2070. 

  2070. ! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12
    2071. 

  2071. ! 
    2072. 

  2072. ! Method: 
    2073. 

  2073. ! h2o  ....  Uses nonisothermal emissivity method for water vapor from
    2074. 

  2074. !            Ramanathan, V. and  P.Downey, 1986: A Nonisothermal
    2075. 

  2075. !            Emissivity and Absorptivity Formulation for Water Vapor
    2076. 

  2076. !            Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
    2077. 

  2077. !
    2078. 

  2078. !            Implementation updated by Collins, Hackney, and Edwards (2001)
    2079. 

  2079. !               using line-by-line calculations based upon Hitran 1996 and
    2080. 

  2080. !               CKD 2.1 for absorptivity and emissivity
    2081. 

  2081. !
    2082. 

  2082. !            Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
    2083. 

  2083. !               using line-by-line calculations based upon Hitran 2000 and
    2084. 

  2084. !               CKD 2.4 for absorptivity and emissivity
    2085. 

  2085. !
    2086. 

  2086. ! co2  ....  Uses absorptance parameterization of the 15 micro-meter
    2087. 

  2087. !            (500 - 800 cm-1) band system of Carbon Dioxide, from
    2088. 

  2088. !            Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
    2089. 

  2089. !            of the Absorptance Due to the 15 micro-meter Band System
    2090. 

  2090. !            of Carbon Dioxide Jouranl of Geophysical Research,
    2091. 

  2091. !            vol. 96., D5, pp 9013-9019.
    2092. 

  2092. !            Parameterizations for the 9.4 and 10.4 mircon bands of CO2
    2093. 

  2093. !            are also included.
    2094. 

  2094. !
    2095. 

  2095. ! o3   ....  Uses absorptance parameterization of the 9.6 micro-meter
    2096. 

  2096. !            band system of ozone, from Ramanathan, V. and R.Dickinson,
    2097. 

  2097. !            1979: The Role of stratospheric ozone in the zonal and
    2098. 

  2098. !            seasonal radiative energy balance of the earth-troposphere
    2099. 

  2099. !            system. Journal of the Atmospheric Sciences, Vol. 36,
    2100. 

  2100. !            pp 1084-1104
    2101. 

  2101. !
    2102. 

  2102. ! ch4  ....  Uses a broad band model for the 7.7 micron band of methane.
    2103. 

  2103. !
    2104. 

  2104. ! n20  ....  Uses a broad band model for the 7.8, 8.6 and 17.0 micron
    2105. 

  2105. !            bands of nitrous oxide
    2106. 

  2106. !
    2107. 

  2107. ! cfc11 ...  Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
    2108. 

  2108. !            micron bands of CFC11
    2109. 

  2109. !
    2110. 

  2110. ! cfc12 ...  Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
    2111. 

  2111. !            micron bands of CFC12
    2112. 

  2112. !
    2113. 

  2113. !
    2114. 

  2114. ! Computes individual absorptivities for non-adjacent layers, accounting
    2115. 

  2115. ! for band overlap, and sums to obtain the total; then, computes the
    2116. 

  2116. ! nearest layer contribution.
    2117. 

  2117. ! 
    2118. 

  2118. ! Author: W. Collins (H2O absorptivity) and J. Kiehl
    2119. 

  2119. ! 
    2120. 

  2120. !-----------------------------------------------------------------------
    2121. 

  2121. !------------------------------Arguments--------------------------------
    2122. 

  2122. !
    2123. 

  2123. ! Input arguments
    2124. 

  2124. !
    2125. 

  2125.    integer, intent(in) :: lchnk                       ! chunk identifier
    2126. 

  2126.    integer, intent(in) :: ncol                        ! number of atmospheric columns
    2127. 

  2127.    integer, intent(in) :: pcols, pver, pverp
    2128. 

    2129. 

  2129.    real(r8), intent(in) :: pbr(pcols,pver)            ! Prssr at mid-levels (dynes/cm2)
    2130. 

  2130.    real(r8), intent(in) :: pnm(pcols,pverp)           ! Prssr at interfaces (dynes/cm2)
    2131. 

  2131.    real(r8), intent(in) :: co2em(pcols,pverp)         ! Co2 emissivity function
    2132. 

  2132.    real(r8), intent(in) :: co2eml(pcols,pver)         ! Co2 emissivity function
    2133. 

  2133.    real(r8), intent(in) :: tplnka(pcols,pverp)        ! Planck fnctn level temperature
    2134. 

  2134.    real(r8), intent(in) :: s2c(pcols,pverp)           ! H2o continuum path length
    2135. 

  2135.    real(r8), intent(in) :: tcg(pcols,pverp)           ! H2o-mass-wgted temp. (Curtis-Godson approx.)
    2136. 

  2136.    real(r8), intent(in) :: w(pcols,pverp)             ! H2o prs wghted path
    2137. 

  2137.    real(r8), intent(in) :: h2otr(pcols,pverp)         ! H2o trnsmssn fnct for o3 overlap
    2138. 

  2138.    real(r8), intent(in) :: plco2(pcols,pverp)         ! Co2 prs wghted path length
    2139. 

  2139.    real(r8), intent(in) :: plh2o(pcols,pverp)         ! H2o prs wfhted path length
    2140. 

  2140.    real(r8), intent(in) :: co2t(pcols,pverp)          ! Tmp and prs wghted path length
    2141. 

  2141.    real(r8), intent(in) :: tint(pcols,pverp)          ! Interface temperatures
    2142. 

  2142.    real(r8), intent(in) :: tlayr(pcols,pverp)         ! K-1 level temperatures
    2143. 

  2143.    real(r8), intent(in) :: plol(pcols,pverp)          ! Ozone prs wghted path length
    2144. 

  2144.    real(r8), intent(in) :: plos(pcols,pverp)          ! Ozone path length
    2145. 

  2145.    real(r8), intent(in) :: pmln(pcols,pver)           ! Ln(pmidm1)
    2146. 

  2146.    real(r8), intent(in) :: piln(pcols,pverp)          ! Ln(pintm1)
    2147. 

  2147.    real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with 
    2148. 

  2148.                                                       !    Hulst-Curtis-Godson temp. factor 
    2149. 

  2149.                                                       !    for H2O bands 
    2150. 

  2150.    real(r8), intent(in) :: wb(nbands,pcols,pverp)     ! H2o path length with 
    2151. 

  2151.                                                       !    Hulst-Curtis-Godson temp. factor 
    2152. 

  2152.                                                       !    for H2O bands 
    2153. 

    2154. 

  2154.    real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level
    2155. 

  2155.    real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
    2156. 

    2157. 

    2158. 

  2158. !
    2159. 

  2159. ! Trace gas variables
    2160. 

  2160. !
    2161. 

  2161.    real(r8), intent(in) :: ucfc11(pcols,pverp)        ! CFC11 path length
    2162. 

  2162.    real(r8), intent(in) :: ucfc12(pcols,pverp)        ! CFC12 path length
    2163. 

  2163.    real(r8), intent(in) :: un2o0(pcols,pverp)         ! N2O path length
    2164. 

  2164.    real(r8), intent(in) :: un2o1(pcols,pverp)         ! N2O path length (hot band)
    2165. 

  2165.    real(r8), intent(in) :: uch4(pcols,pverp)          ! CH4 path length
    2166. 

  2166.    real(r8), intent(in) :: uco211(pcols,pverp)        ! CO2 9.4 micron band path length
    2167. 

  2167.    real(r8), intent(in) :: uco212(pcols,pverp)        ! CO2 9.4 micron band path length
    2168. 

  2168.    real(r8), intent(in) :: uco213(pcols,pverp)        ! CO2 9.4 micron band path length
    2169. 

  2169.    real(r8), intent(in) :: uco221(pcols,pverp)        ! CO2 10.4 micron band path length
    2170. 

  2170.    real(r8), intent(in) :: uco222(pcols,pverp)        ! CO2 10.4 micron band path length
    2171. 

  2171.    real(r8), intent(in) :: uco223(pcols,pverp)        ! CO2 10.4 micron band path length
    2172. 

  2172.    real(r8), intent(in) :: uptype(pcols,pverp)        ! continuum path length
    2173. 

  2173.    real(r8), intent(in) :: bn2o0(pcols,pverp)         ! pressure factor for n2o
    2174. 

  2174.    real(r8), intent(in) :: bn2o1(pcols,pverp)         ! pressure factor for n2o
    2175. 

  2175.    real(r8), intent(in) :: bch4(pcols,pverp)          ! pressure factor for ch4
    2176. 

  2176.    real(r8), intent(in) :: abplnk1(14,pcols,pverp)    ! non-nearest layer Planck factor
    2177. 

  2177.    real(r8), intent(in) :: abplnk2(14,pcols,pverp)    ! nearest layer factor
    2178. 

  2178. !
    2179. 

  2179. ! Output arguments
    2180. 

  2180. !
    2181. 

  2181.    real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity
    2182. 

  2182.    real(r8), intent(out) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
    2183. 

  2183. !
    2184. 

  2184. !---------------------------Local variables-----------------------------
    2185. 

  2185. !
    2186. 

  2186.    integer i                   ! Longitude index
    2187. 

  2187.    integer k                   ! Level index
    2188. 

  2188.    integer k1                  ! Level index
    2189. 

  2189.    integer k2                  ! Level index
    2190. 

  2190.    integer kn                  ! Nearest level index
    2191. 

  2191.    integer wvl                 ! Wavelength index
    2192. 

    2193. 

  2193.    real(r8) abstrc(pcols)              ! total trace gas absorptivity
    2194. 

  2194.    real(r8) bplnk(14,pcols,4)          ! Planck functions for sub-divided layers
    2195. 

  2195.    real(r8) pnew(pcols)        ! Effective pressure for H2O vapor linewidth
    2196. 

  2196.    real(r8) pnewb(nbands)      ! Effective pressure for h2o linewidth w/
    2197. 

  2197.                                !    Hulst-Curtis-Godson correction for
    2198. 

  2198.                                !    each band
    2199. 

  2199.    real(r8) u(pcols)           ! Pressure weighted H2O path length
    2200. 

  2200.    real(r8) ub(nbands)         ! Pressure weighted H2O path length with
    2201. 

  2201.                                !    Hulst-Curtis-Godson correction for
    2202. 

  2202.                                !    each band
    2203. 

  2203.    real(r8) tbar(pcols,4)      ! Mean layer temperature
    2204. 

  2204.    real(r8) emm(pcols,4)       ! Mean co2 emissivity
    2205. 

  2205.    real(r8) o3emm(pcols,4)     ! Mean o3 emissivity
    2206. 

  2206.    real(r8) o3bndi             ! Ozone band parameter
    2207. 

  2207.    real(r8) temh2o(pcols,4)    ! Mean layer temperature equivalent to tbar
    2208. 

  2208.    real(r8) k21                ! Exponential coefficient used to calculate
    2209. 

  2209. !                              !  rotation band transmissvty in the 650-800
    2210. 

  2210. !                              !  cm-1 region (tr1)
    2211. 

  2211.    real(r8) k22                ! Exponential coefficient used to calculate
    2212. 

  2212. !                              !  rotation band transmissvty in the 500-650
    2213. 

  2213. !                              !  cm-1 region (tr2)
    2214. 

  2214.    real(r8) uc1(pcols)         ! H2o continuum pathlength in 500-800 cm-1
    2215. 

  2215.    real(r8) to3h2o(pcols)      ! H2o trnsmsn for overlap with o3
    2216. 

  2216.    real(r8) pi                 ! For co2 absorptivity computation
    2217. 

  2217.    real(r8) sqti(pcols)        ! Used to store sqrt of mean temperature
    2218. 

  2218.    real(r8) et                 ! Co2 hot band factor
    2219. 

  2219.    real(r8) et2                ! Co2 hot band factor squared
    2220. 

  2220.    real(r8) et4                ! Co2 hot band factor to fourth power
    2221. 

  2221.    real(r8) omet               ! Co2 stimulated emission term
    2222. 

  2222.    real(r8) f1co2              ! Co2 central band factor
    2223. 

  2223.    real(r8) f2co2(pcols)       ! Co2 weak band factor
    2224. 

  2224.    real(r8) f3co2(pcols)       ! Co2 weak band factor
    2225. 

  2225.    real(r8) t1co2(pcols)       ! Overlap factr weak bands on strong band
    2226. 

  2226.    real(r8) sqwp               ! Sqrt of co2 pathlength
    2227. 

  2227.    real(r8) f1sqwp(pcols)      ! Main co2 band factor
    2228. 

  2228.    real(r8) oneme              ! Co2 stimulated emission term
    2229. 

  2229.    real(r8) alphat             ! Part of the co2 stimulated emission term
    2230. 

  2230.    real(r8) wco2               ! Constants used to define co2 pathlength
    2231. 

  2231.    real(r8) posqt              ! Effective pressure for co2 line width
    2232. 

  2232.    real(r8) u7(pcols)          ! Co2 hot band path length
    2233. 

  2233.    real(r8) u8                 ! Co2 hot band path length
    2234. 

  2234.    real(r8) u9                 ! Co2 hot band path length
    2235. 

  2235.    real(r8) u13                ! Co2 hot band path length
    2236. 

  2236.    real(r8) rbeta7(pcols)      ! Inverse of co2 hot band line width par
    2237. 

  2237.    real(r8) rbeta8             ! Inverse of co2 hot band line width par
    2238. 

  2238.    real(r8) rbeta9             ! Inverse of co2 hot band line width par
    2239. 

  2239.    real(r8) rbeta13            ! Inverse of co2 hot band line width par
    2240. 

  2240.    real(r8) tpatha             ! For absorptivity computation
    2241. 

  2241.    real(r8) abso(pcols,4)      ! Absorptivity for various gases/bands
    2242. 

  2242.    real(r8) dtx(pcols)         ! Planck temperature minus 250 K
    2243. 

  2243.    real(r8) dty(pcols)         ! Path temperature minus 250 K
    2244. 

  2244.    real(r8) term7(pcols,2)     ! Kl_inf(i) in eq(r8) of table A3a of R&D
    2245. 

  2245.    real(r8) term8(pcols,2)     ! Delta kl_inf(i) in eq(r8)
    2246. 

  2246.    real(r8) tr1                ! Eqn(6) in table A2 of R&D for 650-800
    2247. 

  2247.    real(r8) tr10(pcols)        ! Eqn (6) times eq(4) in table A2
    2248. 

  2248. !                              !  of R&D for 500-650 cm-1 region
    2249. 

  2249.    real(r8) tr2                ! Eqn(6) in table A2 of R&D for 500-650
    2250. 

  2250.    real(r8) tr5                ! Eqn(4) in table A2 of R&D for 650-800
    2251. 

  2251.    real(r8) tr6                ! Eqn(4) in table A2 of R&D for 500-650
    2252. 

  2252.    real(r8) tr9(pcols)         ! Equation (6) times eq(4) in table A2
    2253. 

  2253. !                              !  of R&D for 650-800 cm-1 region
    2254. 

  2254.    real(r8) sqrtu(pcols)       ! Sqrt of pressure weighted h20 pathlength
    2255. 

  2255.    real(r8) fwk(pcols)         ! Equation(33) in R&D far wing correction
    2256. 

  2256.    real(r8) fwku(pcols)        ! GU term in eqs(1) and (6) in table A2
    2257. 

  2257.    real(r8) to3co2(pcols)      ! P weighted temp in ozone band model
    2258. 

  2258.    real(r8) dpnm(pcols)        ! Pressure difference between two levels
    2259. 

  2259.    real(r8) pnmsq(pcols,pverp) ! Pressure squared
    2260. 

  2260.    real(r8) dw(pcols)          ! Amount of h2o between two levels
    2261. 

  2261.    real(r8) uinpl(pcols,4)     ! Nearest layer subdivision factor
    2262. 

  2262.    real(r8) winpl(pcols,4)     ! Nearest layer subdivision factor
    2263. 

  2263.    real(r8) zinpl(pcols,4)     ! Nearest layer subdivision factor
    2264. 

  2264.    real(r8) pinpl(pcols,4)     ! Nearest layer subdivision factor
    2265. 

  2265.    real(r8) dplh2o(pcols)      ! Difference in press weighted h2o amount
    2266. 

  2266.    real(r8) r293               ! 1/293
    2267. 

  2267.    real(r8) r250               ! 1/250
    2268. 

  2268.    real(r8) r3205              ! Line width factor for o3 (see R&Di)
    2269. 

  2269.    real(r8) r300               ! 1/300
    2270. 

  2270.    real(r8) rsslp              ! Reciprocal of sea level pressure
    2271. 

  2271.    real(r8) r2sslp             ! 1/2 of rsslp
    2272. 

  2272.    real(r8) ds2c               ! Y in eq(7) in table A2 of R&D
    2273. 

  2273.    real(r8)  dplos             ! Ozone pathlength eq(A2) in R&Di
    2274. 

  2274.    real(r8) dplol              ! Presure weighted ozone pathlength
    2275. 

  2275.    real(r8) tlocal             ! Local interface temperature
    2276. 

  2276.    real(r8) beta               ! Ozone mean line parameter eq(A3) in R&Di
    2277. 

  2277. !                               (includes Voigt line correction factor)
    2278. 

  2278.    real(r8) rphat              ! Effective pressure for ozone beta
    2279. 

  2279.    real(r8) tcrfac             ! Ozone temperature factor table 1 R&Di
    2280. 

  2280.    real(r8) tmp1               ! Ozone band factor see eq(A1) in R&Di
    2281. 

  2281.    real(r8) u1                 ! Effective ozone pathlength eq(A2) in R&Di
    2282. 

  2282.    real(r8) realnu             ! 1/beta factor in ozone band model eq(A1)
    2283. 

  2283.    real(r8) tmp2               ! Ozone band factor see eq(A1) in R&Di
    2284. 

  2284.    real(r8) u2                 ! Effective ozone pathlength eq(A2) in R&Di
    2285. 

  2285.    real(r8) rsqti              ! Reciprocal of sqrt of path temperature
    2286. 

  2286.    real(r8) tpath              ! Path temperature used in co2 band model
    2287. 

  2287.    real(r8) tmp3               ! Weak band factor see K&B
    2288. 

  2288.    real(r8) rdpnmsq            ! Reciprocal of difference in press^2
    2289. 

  2289.    real(r8) rdpnm              ! Reciprocal of difference in press
    2290. 

  2290.    real(r8) p1                 ! Mean pressure factor
    2291. 

  2291.    real(r8) p2                 ! Mean pressure factor
    2292. 

  2292.    real(r8) dtym10             ! T - 260 used in eq(9) and (10) table A3a
    2293. 

  2293.    real(r8) dplco2             ! Co2 path length
    2294. 

  2294.    real(r8) te                 ! A_0 T factor in ozone model table 1 of R&Di
    2295. 

  2295.    real(r8) denom              ! Denominator in eq(r8) of table A3a of R&D
    2296. 

  2296.    real(r8) th2o(pcols)        ! transmission due to H2O
    2297. 

  2297.    real(r8) tco2(pcols)        ! transmission due to CO2
    2298. 

  2298.    real(r8) to3(pcols)         ! transmission due to O3
    2299. 

  2299. !
    2300. 

  2300. ! Transmission terms for various spectral intervals:
    2301. 

  2301. !
    2302. 

  2302.    real(r8) trab2(pcols)       ! H2o   500 -  800 cm-1
    2303. 

  2303.    real(r8) absbnd             ! Proportional to co2 band absorptance
    2304. 

  2304.    real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3
    2305. 

  2305.    real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3
    2306. 

  2306. !
    2307. 

  2307. ! Variables for Collins/Hackney/Edwards (C/H/E) & 
    2308. 

  2308. !       Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization
    2309. 

    2310. 

  2310. !
    2311. 

  2311. ! Notation:
    2312. 

  2312. ! U   = integral (P/P_0 dW)  eq. 15 in Ramanathan/Downey 1986
    2313. 

  2313. ! P   = atmospheric pressure
    2314. 

  2314. ! P_0 = reference atmospheric pressure
    2315. 

  2315. ! W   = precipitable water path
    2316. 

  2316. ! T_e = emission temperature
    2317. 

  2317. ! T_p = path temperature
    2318. 

  2318. ! RH  = path relative humidity
    2319. 

  2319. !
    2320. 

  2320.    real(r8) fa               ! asymptotic value of abs. as U->infinity
    2321. 

  2321.    real(r8) a_star           ! normalized absorptivity for non-window
    2322. 

  2322.    real(r8) l_star           ! interpolated line transmission
    2323. 

  2323.    real(r8) c_star           ! interpolated continuum transmission
    2324. 

    2325. 

  2325.    real(r8) te1              ! emission temperature
    2326. 

  2326.    real(r8) te2              ! te^2
    2327. 

  2327.    real(r8) te3              ! te^3
    2328. 

  2328.    real(r8) te4              ! te^4
    2329. 

  2329.    real(r8) te5              ! te^5
    2330. 

    2331. 

  2331.    real(r8) log_u            ! log base 10 of U 
    2332. 

  2332.    real(r8) log_uc           ! log base 10 of H2O continuum path
    2333. 

  2333.    real(r8) log_p            ! log base 10 of P
    2334. 

  2334.    real(r8) t_p              ! T_p
    2335. 

  2335.    real(r8) t_e              ! T_e (offset by T_p)
    2336. 

    2337. 

  2337.    integer iu                ! index for log10(U)
    2338. 

  2338.    integer iu1               ! iu + 1
    2339. 

  2339.    integer iuc               ! index for log10(H2O continuum path)
    2340. 

  2340.    integer iuc1              ! iuc + 1
    2341. 

  2341.    integer ip                ! index for log10(P)
    2342. 

  2342.    integer ip1               ! ip + 1
    2343. 

  2343.    integer itp               ! index for T_p
    2344. 

  2344.    integer itp1              ! itp + 1
    2345. 

  2345.    integer ite               ! index for T_e
    2346. 

  2346.    integer ite1              ! ite + 1
    2347. 

  2347.    integer irh               ! index for RH
    2348. 

  2348.    integer irh1              ! irh + 1
    2349. 

    2350. 

  2350.    real(r8) dvar             ! normalized variation in T_p/T_e/P/U
    2351. 

  2351.    real(r8) uvar             ! U * diffusivity factor
    2352. 

  2352.    real(r8) uscl             ! factor for lineary scaling as U->0
    2353. 

    2354. 

  2354.    real(r8) wu               ! weight for U
    2355. 

  2355.    real(r8) wu1              ! 1 - wu
    2356. 

  2356.    real(r8) wuc              ! weight for H2O continuum path
    2357. 

  2357.    real(r8) wuc1             ! 1 - wuc
    2358. 

  2358.    real(r8) wp               ! weight for P
    2359. 

  2359.    real(r8) wp1              ! 1 - wp
    2360. 

  2360.    real(r8) wtp              ! weight for T_p
    2361. 

  2361.    real(r8) wtp1             ! 1 - wtp
    2362. 

  2362.    real(r8) wte              ! weight for T_e
    2363. 

  2363.    real(r8) wte1             ! 1 - wte
    2364. 

  2364.    real(r8) wrh              ! weight for RH
    2365. 

  2365.    real(r8) wrh1             ! 1 - wrh
    2366. 

    2367. 

  2367.    real(r8) w_0_0_           ! weight for Tp/Te combination
    2368. 

  2368.    real(r8) w_0_1_           ! weight for Tp/Te combination
    2369. 

  2369.    real(r8) w_1_0_           ! weight for Tp/Te combination
    2370. 

  2370.    real(r8) w_1_1_           ! weight for Tp/Te combination
    2371. 

    2372. 

  2372.    real(r8) w_0_00           ! weight for Tp/Te/RH combination
    2373. 

  2373.    real(r8) w_0_01           ! weight for Tp/Te/RH combination
    2374. 

  2374.    real(r8) w_0_10           ! weight for Tp/Te/RH combination
    2375. 

  2375.    real(r8) w_0_11           ! weight for Tp/Te/RH combination
    2376. 

  2376.    real(r8) w_1_00           ! weight for Tp/Te/RH combination
    2377. 

  2377.    real(r8) w_1_01           ! weight for Tp/Te/RH combination
    2378. 

  2378.    real(r8) w_1_10           ! weight for Tp/Te/RH combination
    2379. 

  2379.    real(r8) w_1_11           ! weight for Tp/Te/RH combination
    2380. 

    2381. 

  2381.    real(r8) w00_00           ! weight for P/Tp/Te/RH combination
    2382. 

  2382.    real(r8) w00_01           ! weight for P/Tp/Te/RH combination
    2383. 

  2383.    real(r8) w00_10           ! weight for P/Tp/Te/RH combination
    2384. 

  2384.    real(r8) w00_11           ! weight for P/Tp/Te/RH combination
    2385. 

  2385.    real(r8) w01_00           ! weight for P/Tp/Te/RH combination
    2386. 

  2386.    real(r8) w01_01           ! weight for P/Tp/Te/RH combination
    2387. 

  2387.    real(r8) w01_10           ! weight for P/Tp/Te/RH combination
    2388. 

  2388.    real(r8) w01_11           ! weight for P/Tp/Te/RH combination
    2389. 

  2389.    real(r8) w10_00           ! weight for P/Tp/Te/RH combination
    2390. 

  2390.    real(r8) w10_01           ! weight for P/Tp/Te/RH combination
    2391. 

  2391.    real(r8) w10_10           ! weight for P/Tp/Te/RH combination
    2392. 

  2392.    real(r8) w10_11           ! weight for P/Tp/Te/RH combination
    2393. 

  2393.    real(r8) w11_00           ! weight for P/Tp/Te/RH combination
    2394. 

  2394.    real(r8) w11_01           ! weight for P/Tp/Te/RH combination
    2395. 

  2395.    real(r8) w11_10           ! weight for P/Tp/Te/RH combination
    2396. 

  2396.    real(r8) w11_11           ! weight for P/Tp/Te/RH combination
    2397. 

    2398. 

  2398.    integer ib                ! spectral interval:
    2399. 

  2399.                              !   1 = 0-800 cm^-1 and 1200-2200 cm^-1
    2400. 

  2400.                              !   2 = 800-1200 cm^-1
    2401. 

    2402. 

    2403. 

  2403.    real(r8) pch2o            ! H2O continuum path
    2404. 

  2404.    real(r8) fch2o            ! temp. factor for continuum
    2405. 

  2405.    real(r8) uch2o            ! U corresponding to H2O cont. path (window)
    2406. 

    2407. 

  2407.    real(r8) fdif             ! secant(zenith angle) for diffusivity approx.
    2408. 

    2409. 

  2409.    real(r8) sslp_mks         ! Sea-level pressure in MKS units
    2410. 

  2410.    real(r8) esx              ! saturation vapor pressure returned by vqsatd
    2411. 

  2411.    real(r8) qsx              ! saturation mixing ratio returned by vqsatd
    2412. 

  2412.    real(r8) pnew_mks         ! pnew in MKS units
    2413. 

  2413.    real(r8) q_path           ! effective specific humidity along path
    2414. 

  2414.    real(r8) rh_path          ! effective relative humidity along path
    2415. 

  2415.    real(r8) omeps            ! 1 - epsilo
    2416. 

    2417. 

  2417.    integer  iest             ! index in estblh2o
    2418. 

    2419. 

  2419.       integer bnd_idx        ! LW band index
    2420. 

  2420.       real(r8) aer_pth_dlt   ! [kg m-2] STRAER path between interface levels k1 and k2
    2421. 

  2421.       real(r8) aer_pth_ngh(pcols)
    2422. 

  2422.                              ! [kg m-2] STRAER path between neighboring layers
    2423. 

  2423.       real(r8) odap_aer_ttl  ! [fraction] Total path absorption optical depth
    2424. 

  2424.       real(r8) aer_trn_ngh(pcols,bnd_nbr_LW) 
    2425. 

  2425.                              ! [fraction] Total transmission between 
    2426. 

  2426.                              !            nearest neighbor sub-levels
    2427. 

  2427. !
    2428. 

  2428. !--------------------------Statement function---------------------------
    2429. 

  2429. !
    2430. 

  2430.    real(r8) dbvt,t             ! Planck fnctn tmp derivative for o3
    2431. 

  2431. !
    2432. 

  2432.    dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
    2433. 

  2433.       (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
    2434. 

  2434. !
    2435. 

  2435. !
    2436. 

  2436. !-----------------------------------------------------------------------
    2437. 

  2437. !
    2438. 

  2438. ! Initialize
    2439. 

  2439. !
    2440. 

  2440.    do k2=1,ntoplw-1
    2441. 

  2441.       do k1=1,ntoplw-1
    2442. 

  2442.          abstot(:,k1,k2) = inf    ! set unused portions for lf95 restart write
    2443. 

  2443.       end do
    2444. 

  2444.    end do
    2445. 

  2445.    do k2=1,4
    2446. 

  2446.       do k1=1,ntoplw-1
    2447. 

  2447.          absnxt(:,k1,k2) = inf    ! set unused portions for lf95 restart write
    2448. 

  2448.       end do
    2449. 

  2449.    end do
    2450. 

    2451. 

  2451.    do k=ntoplw,pverp
    2452. 

  2452.       abstot(:,k,k) = inf         ! set unused portions for lf95 restart write
    2453. 

  2453.    end do
    2454. 

    2455. 

  2455.    do k=ntoplw,pver
    2456. 

  2456.       do i=1,ncol
    2457. 

  2457.          dbvtly(i,k) = dbvt(tlayr(i,k+1))
    2458. 

  2458.          dbvtit(i,k) = dbvt(tint(i,k))
    2459. 

  2459.       end do
    2460. 

  2460.    end do
    2461. 

  2461.    do i=1,ncol
    2462. 

  2462.       dbvtit(i,pverp) = dbvt(tint(i,pverp))
    2463. 

  2463.    end do
    2464. 

  2464. !
    2465. 

  2465.    r293    = 1./293.
    2466. 

  2466.    r250    = 1./250.
    2467. 

  2467.    r3205   = 1./.3205
    2468. 

  2468.    r300    = 1./300.
    2469. 

  2469.    rsslp   = 1./sslp
    2470. 

  2470.    r2sslp  = 1./(2.*sslp)
    2471. 

  2471. !
    2472. 

  2472. !Constants for computing U corresponding to H2O cont. path
    2473. 

  2473. !
    2474. 

  2474.    fdif       = 1.66
    2475. 

  2475.    sslp_mks   = sslp / 10.0
    2476. 

  2476.    omeps      = 1.0 - epsilo
    2477. 

  2477. !
    2478. 

  2478. ! Non-adjacent layer absorptivity:
    2479. 

  2479. !
    2480. 

  2480. ! abso(i,1)     0 -  800 cm-1   h2o rotation band
    2481. 

  2481. ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    2482. 

  2482. ! abso(i,2)   800 - 1200 cm-1   h2o window
    2483. 

  2483. !
    2484. 

  2484. ! Separation between rotation and vibration-rotation dropped, so
    2485. 

  2485. !                only 2 slots needed for H2O absorptivity
    2486. 

  2486. !
    2487. 

  2487. ! 500-800 cm^-1 H2o continuum/line overlap already included
    2488. 

  2488. !                in abso(i,1).  This used to be in abso(i,4)
    2489. 

  2489. !
    2490. 

  2490. ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
    2491. 

  2491. ! abso(i,4)   co2 15  micrometer band system
    2492. 

  2492. !
    2493. 

  2493.    do k=ntoplw,pverp
    2494. 

  2494.       do i=1,ncol
    2495. 

  2495.          pnmsq(i,k) = pnm(i,k)**2
    2496. 

  2496.          dtx(i) = tplnka(i,k) - 250.
    2497. 

  2497.       end do
    2498. 

  2498.    end do
    2499. 

  2499. !
    2500. 

  2500. ! Non-nearest layer level loops
    2501. 

  2501. !
    2502. 

  2502.    do k1=pverp,ntoplw,-1
    2503. 

  2503.       do k2=pverp,ntoplw,-1
    2504. 

  2504.          if (k1 == k2) cycle
    2505. 

  2505.          do i=1,ncol
    2506. 

  2506.             dplh2o(i) = plh2o(i,k1) - plh2o(i,k2)
    2507. 

  2507.             u(i)      = abs(dplh2o(i))
    2508. 

  2508.             sqrtu(i)  = sqrt(u(i))
    2509. 

  2509.             ds2c      = abs(s2c(i,k1) - s2c(i,k2))
    2510. 

  2510.             dw(i)     = abs(w(i,k1) - w(i,k2))
    2511. 

  2511.             uc1(i)    = (ds2c + 1.7e-3*u(i))*(1. +  2.*ds2c)/(1. + 15.*ds2c)
    2512. 

  2512.             pch2o     = ds2c
    2513. 

  2513.             pnew(i)   = u(i)/dw(i)
    2514. 

  2514.             pnew_mks  = pnew(i) * sslp_mks
    2515. 

  2515. !
    2516. 

  2516. ! Changed effective path temperature to std. Curtis-Godson form
    2517. 

  2517. !
    2518. 

  2518.             tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i)
    2519. 

  2519.             t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o)
    2520. 

  2520.             iest = floor(t_p) - min_tp_h2o
    2521. 

  2521.             esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
    2522. 

  2522.                  (t_p - min_tp_h2o - iest)
    2523. 

  2523.             qsx = epsilo * esx / (pnew_mks - omeps * esx)
    2524. 

  2524. !
    2525. 

  2525. ! Compute effective RH along path
    2526. 

  2526. !
    2527. 

  2527.             q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga
    2528. 

  2528. !
    2529. 

  2529. ! Calculate effective u, pnew for each band using
    2530. 

  2530. !        Hulst-Curtis-Godson approximation:
    2531. 

  2531. ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, 
    2532. 

  2532. !           2nd edition, Oxford University Press, 1989.
    2533. 

  2533. ! Effective H2O path (w)
    2534. 

  2534. !      eq. 6.24, p. 228
    2535. 

  2535. ! Effective H2O path pressure (pnew = u/w):
    2536. 

  2536. !      eq. 6.29, p. 228
    2537. 

  2537. !
    2538. 

  2538.             ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1)
    2539. 

  2539.             ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2)
    2540. 

  2540.             
    2541. 

  2541.             pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1)
    2542. 

  2542.             pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2)
    2543. 

    2544. 

  2544.             dtx(i)      = tplnka(i,k2) - 250.
    2545. 

  2545.             dty(i)      = tpatha       - 250.
    2546. 

    2547. 

  2547.             fwk(i)  = fwcoef + fwc1/(1. + fwc2*u(i))
    2548. 

  2548.             fwku(i) = fwk(i)*u(i)
    2549. 

  2549. !
    2550. 

  2550. ! Define variables for C/H/E (now C/LT/E) fit
    2551. 

  2551. !
    2552. 

  2552. ! abso(i,1)     0 -  800 cm-1   h2o rotation band
    2553. 

  2553. ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    2554. 

  2554. ! abso(i,2)   800 - 1200 cm-1   h2o window
    2555. 

  2555. !
    2556. 

  2556. ! Separation between rotation and vibration-rotation dropped, so
    2557. 

  2557. !                only 2 slots needed for H2O absorptivity
    2558. 

  2558. !
    2559. 

  2559. ! Notation:
    2560. 

  2560. ! U   = integral (P/P_0 dW)  
    2561. 

  2561. ! P   = atmospheric pressure
    2562. 

  2562. ! P_0 = reference atmospheric pressure
    2563. 

  2563. ! W   = precipitable water path
    2564. 

  2564. ! T_e = emission temperature
    2565. 

  2565. ! T_p = path temperature
    2566. 

  2566. ! RH  = path relative humidity
    2567. 

  2567. !
    2568. 

  2568. !
    2569. 

  2569. ! Terms for asymptotic value of emissivity
    2570. 

  2570. !
    2571. 

  2571.             te1  = tplnka(i,k2)
    2572. 

  2572.             te2  = te1 * te1
    2573. 

  2573.             te3  = te2 * te1
    2574. 

  2574.             te4  = te3 * te1
    2575. 

  2575.             te5  = te4 * te1
    2576. 

    2577. 

  2577. !
    2578. 

  2578. !  Band-independent indices for lines and continuum tables
    2579. 

  2579. !
    2580. 

  2580.             dvar = (t_p - min_tp_h2o) / dtp_h2o
    2581. 

  2581.             itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
    2582. 

  2582.             itp1 = itp + 1
    2583. 

  2583.             wtp = dvar - floor(dvar)
    2584. 

  2584.             wtp1 = 1.0 - wtp
    2585. 

  2585.             
    2586. 

  2586.             t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o)
    2587. 

  2587.             dvar = (t_e - min_te_h2o) / dte_h2o
    2588. 

  2588.             ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
    2589. 

  2589.             ite1 = ite + 1
    2590. 

  2590.             wte = dvar - floor(dvar)
    2591. 

  2591.             wte1 = 1.0 - wte
    2592. 

  2592.             
    2593. 

  2593.             rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
    2594. 

  2594.             dvar = (rh_path - min_rh_h2o) / drh_h2o
    2595. 

  2595.             irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
    2596. 

  2596.             irh1 = irh + 1
    2597. 

  2597.             wrh = dvar - floor(dvar)
    2598. 

  2598.             wrh1 = 1.0 - wrh
    2599. 

    2600. 

  2600.             w_0_0_ = wtp  * wte
    2601. 

  2601.             w_0_1_ = wtp  * wte1
    2602. 

  2602.             w_1_0_ = wtp1 * wte 
    2603. 

  2603.             w_1_1_ = wtp1 * wte1
    2604. 

  2604.             
    2605. 

  2605.             w_0_00 = w_0_0_ * wrh
    2606. 

  2606.             w_0_01 = w_0_0_ * wrh1
    2607. 

  2607.             w_0_10 = w_0_1_ * wrh
    2608. 

  2608.             w_0_11 = w_0_1_ * wrh1
    2609. 

  2609.             w_1_00 = w_1_0_ * wrh
    2610. 

  2610.             w_1_01 = w_1_0_ * wrh1
    2611. 

  2611.             w_1_10 = w_1_1_ * wrh
    2612. 

  2612.             w_1_11 = w_1_1_ * wrh1
    2613. 

    2614. 

  2614. !
    2615. 

  2615. ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
    2616. 

  2616. !
    2617. 

  2617. !    Assume foreign continuum dominates total H2O continuum in these bands
    2618. 

  2618. !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
    2619. 

  2619. !    Then the effective H2O path is just 
    2620. 

  2620. !         U_c = integral[ f(P) dW ]
    2621. 

  2621. !    where 
    2622. 

  2622. !           W = water-vapor mass and 
    2623. 

  2623. !        f(P) = dependence of foreign continuum on pressure 
    2624. 

  2624. !             = P / sslp
    2625. 

  2625. !    Then 
    2626. 

  2626. !         U_c = U (the same effective H2O path as for lines)
    2627. 

  2627. !
    2628. 

  2628. !
    2629. 

  2629. ! Continuum terms for 800-1200 cm^-1
    2630. 

  2630. !
    2631. 

  2631. !    Assume self continuum dominates total H2O continuum for this band
    2632. 

  2632. !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
    2633. 

  2633. !    Then the effective H2O self-continuum path is 
    2634. 

  2634. !         U_c = integral[ h(e,T) dW ]                        (*eq. 1*)
    2635. 

  2635. !    where 
    2636. 

  2636. !           W = water-vapor mass and 
    2637. 

  2637. !           e = partial pressure of H2O along path
    2638. 

  2638. !           T = temperature along path
    2639. 

  2639. !      h(e,T) = dependence of foreign continuum on e,T
    2640. 

  2640. !             = e / sslp * f(T)
    2641. 

  2641. !
    2642. 

  2642. !    Replacing
    2643. 

  2643. !           e =~ q * P / epsilo
    2644. 

  2644. !           q = mixing ratio of H2O
    2645. 

  2645. !     epsilo = 0.622
    2646. 

  2646. !
    2647. 

  2647. !    and using the definition
    2648. 

  2648. !           U = integral [ (P / sslp) dW ]
    2649. 

  2649. !             = (P / sslp) W                                 (homogeneous path)
    2650. 

  2650. !
    2651. 

  2651. !    the effective path length for the self continuum is
    2652. 

  2652. !         U_c = (q / epsilo) f(T) U                         (*eq. 2*)
    2653. 

  2653. !
    2654. 

  2654. !    Once values of T, U, and q have been calculated for the inhomogeneous
    2655. 

  2655. !        path, this sets U_c for the corresponding
    2656. 

  2656. !        homogeneous atmosphere.  However, this need not equal the
    2657. 

  2657. !        value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
    2658. 

  2658. !        under consideration.
    2659. 

  2659. !
    2660. 

  2660. !    Solution: hold T and q constant, solve for U' that gives U_c' by
    2661. 

  2661. !        inverting eq. (2):
    2662. 

  2662. !
    2663. 

  2663. !        U' = (U_c * epsilo) / (q * f(T))
    2664. 

  2664. !
    2665. 

  2665.             fch2o = fh2oself(t_p) 
    2666. 

  2666.             uch2o = (pch2o * epsilo) / (q_path * fch2o)
    2667. 

    2668. 

  2668. !
    2669. 

  2669. ! Band-dependent indices for non-window
    2670. 

  2670. !
    2671. 

  2671.             ib = 1
    2672. 

    2673. 

  2673.             uvar = ub(ib) * fdif
    2674. 

  2674.             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
    2675. 

  2675.             dvar = (log_u - min_lu_h2o) / dlu_h2o
    2676. 

  2676.             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    2677. 

  2677.             iu1 = iu + 1
    2678. 

  2678.             wu = dvar - floor(dvar)
    2679. 

  2679.             wu1 = 1.0 - wu
    2680. 

  2680.             
    2681. 

  2681.             log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
    2682. 

  2682.             dvar = (log_p - min_lp_h2o) / dlp_h2o
    2683. 

  2683.             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
    2684. 

  2684.             ip1 = ip + 1
    2685. 

  2685.             wp = dvar - floor(dvar)
    2686. 

  2686.             wp1 = 1.0 - wp
    2687. 

  2687.          
    2688. 

  2688.             w00_00 = wp  * w_0_00 
    2689. 

  2689.             w00_01 = wp  * w_0_01 
    2690. 

  2690.             w00_10 = wp  * w_0_10 
    2691. 

  2691.             w00_11 = wp  * w_0_11 
    2692. 

  2692.             w01_00 = wp  * w_1_00 
    2693. 

  2693.             w01_01 = wp  * w_1_01 
    2694. 

  2694.             w01_10 = wp  * w_1_10 
    2695. 

  2695.             w01_11 = wp  * w_1_11 
    2696. 

  2696.             w10_00 = wp1 * w_0_00 
    2697. 

  2697.             w10_01 = wp1 * w_0_01 
    2698. 

  2698.             w10_10 = wp1 * w_0_10 
    2699. 

  2699.             w10_11 = wp1 * w_0_11 
    2700. 

  2700.             w11_00 = wp1 * w_1_00 
    2701. 

  2701.             w11_01 = wp1 * w_1_01 
    2702. 

  2702.             w11_10 = wp1 * w_1_10 
    2703. 

  2703.             w11_11 = wp1 * w_1_11 
    2704. 

  2704. !
    2705. 

  2705. ! Asymptotic value of absorptivity as U->infinity
    2706. 

  2706. !
    2707. 

  2707.             fa = fat(1,ib) + &
    2708. 

  2708.                  fat(2,ib) * te1 + &
    2709. 

  2709.                  fat(3,ib) * te2 + &
    2710. 

  2710.                  fat(4,ib) * te3 + &
    2711. 

  2711.                  fat(5,ib) * te4 + &
    2712. 

  2712.                  fat(6,ib) * te5
    2713. 

    2714. 

  2714.             a_star = &
    2715. 

  2715.                  ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    2716. 

  2716.                  ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    2717. 

  2717.                  ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    2718. 

  2718.                  ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    2719. 

  2719.                  ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    2720. 

  2720.                  ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    2721. 

  2721.                  ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    2722. 

  2722.                  ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    2723. 

  2723.                  ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    2724. 

  2724.                  ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    2725. 

  2725.                  ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    2726. 

  2726.                  ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    2727. 

  2727.                  ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    2728. 

  2728.                  ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    2729. 

  2729.                  ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    2730. 

  2730.                  ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    2731. 

  2731.                  ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    2732. 

  2732.                  ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    2733. 

  2733.                  ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    2734. 

  2734.                  ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    2735. 

  2735.                  ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    2736. 

  2736.                  ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    2737. 

  2737.                  ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    2738. 

  2738.                  ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    2739. 

  2739.                  ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    2740. 

  2740.                  ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    2741. 

  2741.                  ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    2742. 

  2742.                  ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    2743. 

  2743.                  ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    2744. 

  2744.                  ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    2745. 

  2745.                  ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    2746. 

  2746.                  ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu 
    2747. 

  2747.             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
    2748. 

  2748.                                  aer_trn_ttl(i,k1,k2,ib)), &
    2749. 

  2749.                              0.0_r8), 1.0_r8)
    2750. 

  2750. !
    2751. 

  2751. ! Invoke linear limit for scaling wrt u below min_u_h2o
    2752. 

  2752. !
    2753. 

  2753.             if (uvar < min_u_h2o) then
    2754. 

  2754.                uscl = uvar / min_u_h2o
    2755. 

  2755.                abso(i,ib) = abso(i,ib) * uscl
    2756. 

  2756.             endif
    2757. 

  2757.                          
    2758. 

  2758. !
    2759. 

  2759. ! Band-dependent indices for window
    2760. 

  2760. !
    2761. 

  2761.             ib = 2
    2762. 

    2763. 

  2763.             uvar = ub(ib) * fdif
    2764. 

  2764.             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
    2765. 

  2765.             dvar = (log_u - min_lu_h2o) / dlu_h2o
    2766. 

  2766.             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    2767. 

  2767.             iu1 = iu + 1
    2768. 

  2768.             wu = dvar - floor(dvar)
    2769. 

  2769.             wu1 = 1.0 - wu
    2770. 

  2770.             
    2771. 

  2771.             log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
    2772. 

  2772.             dvar = (log_p - min_lp_h2o) / dlp_h2o
    2773. 

  2773.             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
    2774. 

  2774.             ip1 = ip + 1
    2775. 

  2775.             wp = dvar - floor(dvar)
    2776. 

  2776.             wp1 = 1.0 - wp
    2777. 

  2777.          
    2778. 

  2778.             w00_00 = wp  * w_0_00 
    2779. 

  2779.             w00_01 = wp  * w_0_01 
    2780. 

  2780.             w00_10 = wp  * w_0_10 
    2781. 

  2781.             w00_11 = wp  * w_0_11 
    2782. 

  2782.             w01_00 = wp  * w_1_00 
    2783. 

  2783.             w01_01 = wp  * w_1_01 
    2784. 

  2784.             w01_10 = wp  * w_1_10 
    2785. 

  2785.             w01_11 = wp  * w_1_11 
    2786. 

  2786.             w10_00 = wp1 * w_0_00 
    2787. 

  2787.             w10_01 = wp1 * w_0_01 
    2788. 

  2788.             w10_10 = wp1 * w_0_10 
    2789. 

  2789.             w10_11 = wp1 * w_0_11 
    2790. 

  2790.             w11_00 = wp1 * w_1_00 
    2791. 

  2791.             w11_01 = wp1 * w_1_01 
    2792. 

  2792.             w11_10 = wp1 * w_1_10 
    2793. 

  2793.             w11_11 = wp1 * w_1_11 
    2794. 

    2795. 

  2795.             log_uc  = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
    2796. 

  2796.             dvar = (log_uc - min_lu_h2o) / dlu_h2o
    2797. 

  2797.             iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    2798. 

  2798.             iuc1 = iuc + 1
    2799. 

  2799.             wuc = dvar - floor(dvar)
    2800. 

  2800.             wuc1 = 1.0 - wuc
    2801. 

  2801. !
    2802. 

  2802. ! Asymptotic value of absorptivity as U->infinity
    2803. 

  2803. !
    2804. 

  2804.             fa = fat(1,ib) + &
    2805. 

  2805.                  fat(2,ib) * te1 + &
    2806. 

  2806.                  fat(3,ib) * te2 + &
    2807. 

  2807.                  fat(4,ib) * te3 + &
    2808. 

  2808.                  fat(5,ib) * te4 + &
    2809. 

  2809.                  fat(6,ib) * te5
    2810. 

    2811. 

  2811.             l_star = &
    2812. 

  2812.                  ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    2813. 

  2813.                  ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    2814. 

  2814.                  ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    2815. 

  2815.                  ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    2816. 

  2816.                  ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    2817. 

  2817.                  ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    2818. 

  2818.                  ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    2819. 

  2819.                  ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    2820. 

  2820.                  ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    2821. 

  2821.                  ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    2822. 

  2822.                  ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    2823. 

  2823.                  ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    2824. 

  2824.                  ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    2825. 

  2825.                  ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    2826. 

  2826.                  ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    2827. 

  2827.                  ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    2828. 

  2828.                  ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    2829. 

  2829.                  ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    2830. 

  2830.                  ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    2831. 

  2831.                  ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    2832. 

  2832.                  ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    2833. 

  2833.                  ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    2834. 

  2834.                  ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    2835. 

  2835.                  ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    2836. 

  2836.                  ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    2837. 

  2837.                  ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    2838. 

  2838.                  ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    2839. 

  2839.                  ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    2840. 

  2840.                  ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    2841. 

  2841.                  ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    2842. 

  2842.                  ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    2843. 

  2843.                  ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu 
    2844. 

    2845. 

  2845.             c_star = &
    2846. 

  2846.                  cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
    2847. 

  2847.                  cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
    2848. 

  2848.                  cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
    2849. 

  2849.                  cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
    2850. 

  2850.                  cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc  + &
    2851. 

  2851.                  cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc  + &
    2852. 

  2852.                  cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc  + &
    2853. 

  2853.                  cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc  + &
    2854. 

  2854.                  cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
    2855. 

  2855.                  cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
    2856. 

  2856.                  cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
    2857. 

  2857.                  cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
    2858. 

  2858.                  cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc  + &
    2859. 

  2859.                  cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc  + &
    2860. 

  2860.                  cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc  + &
    2861. 

  2861.                  cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc  + &
    2862. 

  2862.                  cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
    2863. 

  2863.                  cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
    2864. 

  2864.                  cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
    2865. 

  2865.                  cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
    2866. 

  2866.                  cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc  + &
    2867. 

  2867.                  cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc  + &
    2868. 

  2868.                  cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc  + &
    2869. 

  2869.                  cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc  + &
    2870. 

  2870.                  cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
    2871. 

  2871.                  cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
    2872. 

  2872.                  cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
    2873. 

  2873.                  cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
    2874. 

  2874.                  cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc  + &
    2875. 

  2875.                  cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc  + &
    2876. 

  2876.                  cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc  + &
    2877. 

  2877.                  cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc 
    2878. 

  2878.             abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * &
    2879. 

  2879.                                  aer_trn_ttl(i,k1,k2,ib)), &
    2880. 

  2880.                              0.0_r8), 1.0_r8) 
    2881. 

  2881. !
    2882. 

  2882. ! Invoke linear limit for scaling wrt u below min_u_h2o
    2883. 

  2883. !
    2884. 

  2884.             if (uvar < min_u_h2o) then
    2885. 

  2885.                uscl = uvar / min_u_h2o
    2886. 

  2886.                abso(i,ib) = abso(i,ib) * uscl
    2887. 

  2887.             endif
    2888. 

    2889. 

  2889.          end do
    2890. 

  2890. !
    2891. 

  2891. ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
    2892. 

  2892. !
    2893. 

  2893.          do i=1,ncol
    2894. 

  2894.             term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
    2895. 

  2895.             term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
    2896. 

  2896.             term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
    2897. 

  2897.             term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
    2898. 

  2898.          end do
    2899. 

  2899. !
    2900. 

  2900. ! 500 -  800 cm-1   h2o rotation band overlap with co2
    2901. 

  2901. !
    2902. 

  2902.          do i=1,ncol
    2903. 

  2903.             k21    = term7(i,1) + term8(i,1)/ &
    2904. 

  2904.                (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i))
    2905. 

  2905.             k22    = term7(i,2) + term8(i,2)/ &
    2906. 

  2906.                (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i))
    2907. 

  2907.             tr1    = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
    2908. 

  2908.             tr2    = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
    2909. 

  2909.             tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800) 
    2910. 

  2910. !                                          ! H2O line+STRAER trn 650--800 cm-1
    2911. 

  2911.             tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650)
    2912. 

  2912. !                                          ! H2O line+STRAER trn 500--650 cm-1
    2913. 

  2913.             tr5    = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
    2914. 

  2914.             tr6    = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
    2915. 

  2915.             tr9(i)   = tr1*tr5
    2916. 

  2916.             tr10(i)  = tr2*tr6
    2917. 

  2917.             th2o(i) = tr10(i)
    2918. 

  2918.             trab2(i) = 0.65*tr9(i) + 0.35*tr10(i)
    2919. 

  2919.          end do
    2920. 

  2920.          if (k2 < k1) then
    2921. 

  2921.             do i=1,ncol
    2922. 

  2922.                to3h2o(i) = h2otr(i,k1)/h2otr(i,k2)
    2923. 

  2923.             end do
    2924. 

  2924.          else
    2925. 

  2925.             do i=1,ncol
    2926. 

  2926.                to3h2o(i) = h2otr(i,k2)/h2otr(i,k1)
    2927. 

  2927.             end do
    2928. 

  2928.          end if
    2929. 

  2929. !
    2930. 

  2930. ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
    2931. 

  2931. !
    2932. 

  2932.          do i=1,ncol
    2933. 

  2933.             dpnm(i)  = pnm(i,k1) - pnm(i,k2)
    2934. 

  2934.             to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i)
    2935. 

  2935.             te       = (to3co2(i)*r293)**.7
    2936. 

  2936.             dplos    = plos(i,k1) - plos(i,k2)
    2937. 

  2937.             dplol    = plol(i,k1) - plol(i,k2)
    2938. 

  2938.             u1       = 18.29*abs(dplos)/te
    2939. 

  2939.             u2       = .5649*abs(dplos)/te
    2940. 

  2940.             rphat    = dplol/dplos
    2941. 

  2941.             tlocal   = tint(i,k2)
    2942. 

  2942.             tcrfac   = sqrt(tlocal*r250)*te
    2943. 

  2943.             beta     = r3205*(rphat + dpfo3*tcrfac)
    2944. 

  2944.             realnu   = te/beta
    2945. 

  2945.             tmp1     = u1/sqrt(4. + u1*(1. + realnu))
    2946. 

  2946.             tmp2     = u2/sqrt(4. + u2*(1. + realnu))
    2947. 

  2947.             o3bndi    = 74.*te*log(1. + tmp1 + tmp2)
    2948. 

  2948.             abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2)
    2949. 

  2949.             to3(i)   = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
    2950. 

  2950.          end do
    2951. 

  2951. !
    2952. 

  2952. ! abso(i,4)      co2 15  micrometer band system
    2953. 

  2953. !
    2954. 

  2954.          do i=1,ncol
    2955. 

  2955.             sqwp      = sqrt(abs(plco2(i,k1) - plco2(i,k2)))
    2956. 

  2956.             et        = exp(-480./to3co2(i))
    2957. 

  2957.             sqti(i)   = sqrt(to3co2(i))
    2958. 

  2958.             rsqti     = 1./sqti(i)
    2959. 

  2959.             et2       = et*et
    2960. 

  2960.             et4       = et2*et2
    2961. 

  2961.             omet      = 1. - 1.5*et2
    2962. 

  2962.             f1co2     = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
    2963. 

  2963.             f1sqwp(i) = f1co2*sqwp
    2964. 

  2964.             t1co2(i)  = 1./(1. + (245.18*omet*sqwp*rsqti))
    2965. 

  2965.             oneme     = 1. - et2
    2966. 

  2966.             alphat    = oneme**3*rsqti
    2967. 

  2967.             pi        = abs(dpnm(i))
    2968. 

  2968.             wco2      =  2.5221*co2vmr*pi*rga
    2969. 

  2969.             u7(i)     =  4.9411e4*alphat*et2*wco2
    2970. 

  2970.             u8        =  3.9744e4*alphat*et4*wco2
    2971. 

  2971.             u9        =  1.0447e5*alphat*et4*et2*wco2
    2972. 

  2972.             u13       = 2.8388e3*alphat*et4*wco2
    2973. 

  2973.             tpath     = to3co2(i)
    2974. 

  2974.             tlocal    = tint(i,k2)
    2975. 

  2975.             tcrfac    = sqrt(tlocal*r250*tpath*r300)
    2976. 

  2976.             posqt     = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti
    2977. 

  2977.             rbeta7(i) = 1./(5.3228*posqt)
    2978. 

  2978.             rbeta8    = 1./(10.6576*posqt)
    2979. 

  2979.             rbeta9    = rbeta7(i)
    2980. 

  2980.             rbeta13   = rbeta9
    2981. 

  2981.             f2co2(i)  = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + &
    2982. 

  2982.                (u8   /sqrt(4. + u8*(1. + rbeta8))) + &
    2983. 

  2983.                (u9   /sqrt(4. + u9*(1. + rbeta9)))
    2984. 

  2984.             f3co2(i)  = u13/sqrt(4. + u13*(1. + rbeta13))
    2985. 

  2985.          end do
    2986. 

  2986.          if (k2 >= k1) then
    2987. 

  2987.             do i=1,ncol
    2988. 

  2988.                sqti(i) = sqrt(tlayr(i,k2))
    2989. 

  2989.             end do
    2990. 

  2990.          end if
    2991. 

  2991. !
    2992. 

  2992.          do i=1,ncol
    2993. 

  2993.             tmp1      = log(1. + f1sqwp(i))
    2994. 

  2994.             tmp2      = log(1. + f2co2(i))
    2995. 

  2995.             tmp3      = log(1. + f3co2(i))
    2996. 

  2996.             absbnd    = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
    2997. 

  2997.             abso(i,4) = trab2(i)*co2em(i,k2)*absbnd
    2998. 

  2998.             tco2(i)   = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))))
    2999. 

  2999.          end do
    3000. 

  3000. !
    3001. 

  3001. ! Calculate absorptivity due to trace gases, abstrc
    3002. 

  3002. !
    3003. 

  3003.          call trcab( lchnk   ,ncol    ,pcols, pverp,                   &
    3004. 

  3004.             k1      ,k2      ,ucfc11  ,ucfc12  ,un2o0   , &
    3005. 

  3005.             un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
    3006. 

  3006.             uco221  ,uco222  ,uco223  ,bn2o0   ,bn2o1   , &
    3007. 

  3007.             bch4    ,to3co2  ,pnm     ,dw      ,pnew    , &
    3008. 

  3008.             s2c     ,uptype  ,u       ,abplnk1 ,tco2    , &
    3009. 

  3009.             th2o    ,to3     ,abstrc  , &
    3010. 

  3010.             aer_trn_ttl)
    3011. 

  3011. !
    3012. 

  3012. ! Sum total absorptivity
    3013. 

  3013. !
    3014. 

  3014.          do i=1,ncol
    3015. 

  3015.             abstot(i,k1,k2) = abso(i,1) + abso(i,2) + &
    3016. 

  3016.                abso(i,3) + abso(i,4) + abstrc(i)
    3017. 

  3017.          end do
    3018. 

  3018.       end do ! do k2 = 
    3019. 

  3019.    end do ! do k1 = 
    3020. 

  3020. !
    3021. 

  3021. ! Adjacent layer absorptivity:
    3022. 

  3022. !
    3023. 

  3023. ! abso(i,1)     0 -  800 cm-1   h2o rotation band
    3024. 

  3024. ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    3025. 

  3025. ! abso(i,2)   800 - 1200 cm-1   h2o window
    3026. 

  3026. !
    3027. 

  3027. ! Separation between rotation and vibration-rotation dropped, so
    3028. 

  3028. !                only 2 slots needed for H2O absorptivity
    3029. 

  3029. !
    3030. 

  3030. ! 500-800 cm^-1 H2o continuum/line overlap already included
    3031. 

  3031. !                in abso(i,1).  This used to be in abso(i,4)
    3032. 

  3032. !
    3033. 

  3033. ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
    3034. 

  3034. ! abso(i,4)   co2 15  micrometer band system
    3035. 

  3035. !
    3036. 

  3036. ! Nearest layer level loop
    3037. 

  3037. !
    3038. 

  3038.    do k2=pver,ntoplw,-1
    3039. 

  3039.       do i=1,ncol
    3040. 

  3040.          tbar(i,1)   = 0.5*(tint(i,k2+1) + tlayr(i,k2+1))
    3041. 

  3041.          emm(i,1)    = 0.5*(co2em(i,k2+1) + co2eml(i,k2))
    3042. 

  3042.          tbar(i,2)   = 0.5*(tlayr(i,k2+1) + tint(i,k2))
    3043. 

  3043.          emm(i,2)    = 0.5*(co2em(i,k2) + co2eml(i,k2))
    3044. 

  3044.          tbar(i,3)   = 0.5*(tbar(i,2) + tbar(i,1))
    3045. 

  3045.          emm(i,3)    = emm(i,1)
    3046. 

  3046.          tbar(i,4)   = tbar(i,3)
    3047. 

  3047.          emm(i,4)    = emm(i,2)
    3048. 

  3048.          o3emm(i,1)  = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2))
    3049. 

  3049.          o3emm(i,2)  = 0.5*(dbvtit(i,k2) + dbvtly(i,k2))
    3050. 

  3050.          o3emm(i,3)  = o3emm(i,1)
    3051. 

  3051.          o3emm(i,4)  = o3emm(i,2)
    3052. 

  3052.          temh2o(i,1) = tbar(i,1)
    3053. 

  3053.          temh2o(i,2) = tbar(i,2)
    3054. 

  3054.          temh2o(i,3) = tbar(i,1)
    3055. 

  3055.          temh2o(i,4) = tbar(i,2)
    3056. 

  3056.          dpnm(i)     = pnm(i,k2+1) - pnm(i,k2)
    3057. 

  3057.       end do
    3058. 

  3058. !
    3059. 

  3059. !  Weighted Planck functions for trace gases
    3060. 

  3060. !
    3061. 

  3061.       do wvl = 1,14
    3062. 

  3062.          do i = 1,ncol
    3063. 

  3063.             bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2))
    3064. 

  3064.             bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2))
    3065. 

  3065.             bplnk(wvl,i,3) = bplnk(wvl,i,1)
    3066. 

  3066.             bplnk(wvl,i,4) = bplnk(wvl,i,2)
    3067. 

  3067.          end do
    3068. 

  3068.       end do
    3069. 

  3069.       
    3070. 

  3070.       do i=1,ncol
    3071. 

  3071.          rdpnmsq    = 1./(pnmsq(i,k2+1) - pnmsq(i,k2))
    3072. 

  3072.          rdpnm      = 1./dpnm(i)
    3073. 

  3073.          p1         = .5*(pbr(i,k2) + pnm(i,k2+1))
    3074. 

  3074.          p2         = .5*(pbr(i,k2) + pnm(i,k2  ))
    3075. 

  3075.          uinpl(i,1) =  (pnmsq(i,k2+1) - p1**2)*rdpnmsq
    3076. 

  3076.          uinpl(i,2) = -(pnmsq(i,k2  ) - p2**2)*rdpnmsq
    3077. 

  3077.          uinpl(i,3) = -(pnmsq(i,k2  ) - p1**2)*rdpnmsq
    3078. 

  3078.          uinpl(i,4) =  (pnmsq(i,k2+1) - p2**2)*rdpnmsq
    3079. 

  3079.          winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm
    3080. 

  3080.          winpl(i,2) = (.5*(-pnm(i,k2  ) + pbr(i,k2)))*rdpnm
    3081. 

  3081.          winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2  ))*rdpnm
    3082. 

  3082.          winpl(i,4) = (.5*(-pnm(i,k2  ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm
    3083. 

  3083.          tmp1       = 1./(piln(i,k2+1) - piln(i,k2))
    3084. 

  3084.          tmp2       = piln(i,k2+1) - pmln(i,k2)
    3085. 

  3085.          tmp3       = piln(i,k2  ) - pmln(i,k2)
    3086. 

  3086.          zinpl(i,1) = (.5*tmp2          )*tmp1
    3087. 

  3087.          zinpl(i,2) = (        - .5*tmp3)*tmp1
    3088. 

  3088.          zinpl(i,3) = (.5*tmp2 -    tmp3)*tmp1
    3089. 

  3089.          zinpl(i,4) = (   tmp2 - .5*tmp3)*tmp1
    3090. 

  3090.          pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1))
    3091. 

  3091.          pinpl(i,2) = 0.5*(p2 + pnm(i,k2  ))
    3092. 

  3092.          pinpl(i,3) = 0.5*(p1 + pnm(i,k2  ))
    3093. 

  3093.          pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1))
    3094. 

  3094.          if(strat_volcanic) then
    3095. 

  3095.            aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1))
    3096. 

  3096.          endif
    3097. 

  3097.       end do
    3098. 

  3098.       do kn=1,4
    3099. 

  3099.          do i=1,ncol
    3100. 

  3100.             u(i)     = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1))
    3101. 

  3101.             sqrtu(i) = sqrt(u(i))
    3102. 

  3102.             dw(i)    = abs(w(i,k2) - w(i,k2+1))
    3103. 

  3103.             pnew(i)  = u(i)/(winpl(i,kn)*dw(i))
    3104. 

  3104.             pnew_mks  = pnew(i) * sslp_mks
    3105. 

  3105.             t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o)
    3106. 

  3106.             iest = floor(t_p) - min_tp_h2o
    3107. 

  3107.             esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
    3108. 

  3108.                  (t_p - min_tp_h2o - iest)
    3109. 

  3109.             qsx = epsilo * esx / (pnew_mks - omeps * esx)
    3110. 

  3110.             q_path = dw(i) / ABS(dpnm(i)) / rga
    3111. 

  3111.             
    3112. 

  3112.             ds2c     = abs(s2c(i,k2) - s2c(i,k2+1))
    3113. 

  3113.             uc1(i)   = uinpl(i,kn)*ds2c
    3114. 

  3114.             pch2o    = uc1(i)
    3115. 

  3115.             uc1(i)   = (uc1(i) + 1.7e-3*u(i))*(1. +  2.*uc1(i))/(1. + 15.*uc1(i))
    3116. 

  3116.             dtx(i)      = temh2o(i,kn) - 250.
    3117. 

  3117.             dty(i)      = tbar(i,kn) - 250.
    3118. 

  3118.             
    3119. 

  3119.             fwk(i)    = fwcoef + fwc1/(1. + fwc2*u(i))
    3120. 

  3120.             fwku(i)   = fwk(i)*u(i)
    3121. 

    3122. 

  3122.             if(strat_volcanic) then
    3123. 

  3123.               aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i)
    3124. 

  3124.   
    3125. 

  3125.               do bnd_idx=1,bnd_nbr_LW
    3126. 

  3126.                  odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt 
    3127. 

  3127.                  aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl)
    3128. 

  3128.               end do
    3129. 

  3129.             else
    3130. 

  3130.               aer_trn_ngh(i,:) = 1.0
    3131. 

  3131.             endif
    3132. 

    3133. 

  3133. !
    3134. 

  3134. ! Define variables for C/H/E (now C/LT/E) fit
    3135. 

  3135. !
    3136. 

  3136. ! abso(i,1)     0 -  800 cm-1   h2o rotation band
    3137. 

  3137. ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    3138. 

  3138. ! abso(i,2)   800 - 1200 cm-1   h2o window
    3139. 

  3139. !
    3140. 

  3140. ! Separation between rotation and vibration-rotation dropped, so
    3141. 

  3141. !                only 2 slots needed for H2O absorptivity
    3142. 

  3142. !
    3143. 

  3143. ! Notation:
    3144. 

  3144. ! U   = integral (P/P_0 dW)  
    3145. 

  3145. ! P   = atmospheric pressure
    3146. 

  3146. ! P_0 = reference atmospheric pressure
    3147. 

  3147. ! W   = precipitable water path
    3148. 

  3148. ! T_e = emission temperature
    3149. 

  3149. ! T_p = path temperature
    3150. 

  3150. ! RH  = path relative humidity
    3151. 

  3151. !
    3152. 

  3152. !
    3153. 

  3153. ! Terms for asymptotic value of emissivity
    3154. 

  3154. !
    3155. 

  3155.             te1  = temh2o(i,kn)
    3156. 

  3156.             te2  = te1 * te1
    3157. 

  3157.             te3  = te2 * te1
    3158. 

  3158.             te4  = te3 * te1
    3159. 

  3159.             te5  = te4 * te1
    3160. 

    3161. 

  3161. !
    3162. 

  3162. ! Indices for lines and continuum tables 
    3163. 

  3163. ! Note: because we are dealing with the nearest layer,
    3164. 

  3164. !       the Hulst-Curtis-Godson corrections
    3165. 

  3165. !       for inhomogeneous paths are not applied.
    3166. 

  3166. !
    3167. 

  3167.             uvar = u(i)*fdif
    3168. 

  3168.             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
    3169. 

  3169.             dvar = (log_u - min_lu_h2o) / dlu_h2o
    3170. 

  3170.             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    3171. 

  3171.             iu1 = iu + 1
    3172. 

  3172.             wu = dvar - floor(dvar)
    3173. 

  3173.             wu1 = 1.0 - wu
    3174. 

  3174.             
    3175. 

  3175.             log_p  = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o)
    3176. 

  3176.             dvar = (log_p - min_lp_h2o) / dlp_h2o
    3177. 

  3177.             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
    3178. 

  3178.             ip1 = ip + 1
    3179. 

  3179.             wp = dvar - floor(dvar)
    3180. 

  3180.             wp1 = 1.0 - wp
    3181. 

  3181.             
    3182. 

  3182.             dvar = (t_p - min_tp_h2o) / dtp_h2o
    3183. 

  3183.             itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
    3184. 

  3184.             itp1 = itp + 1
    3185. 

  3185.             wtp = dvar - floor(dvar)
    3186. 

  3186.             wtp1 = 1.0 - wtp
    3187. 

  3187.             
    3188. 

  3188.             t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o)
    3189. 

  3189.             dvar = (t_e - min_te_h2o) / dte_h2o
    3190. 

  3190.             ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
    3191. 

  3191.             ite1 = ite + 1
    3192. 

  3192.             wte = dvar - floor(dvar)
    3193. 

  3193.             wte1 = 1.0 - wte
    3194. 

  3194.             
    3195. 

  3195.             rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
    3196. 

  3196.             dvar = (rh_path - min_rh_h2o) / drh_h2o
    3197. 

  3197.             irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
    3198. 

  3198.             irh1 = irh + 1
    3199. 

  3199.             wrh = dvar - floor(dvar)
    3200. 

  3200.             wrh1 = 1.0 - wrh
    3201. 

  3201.             
    3202. 

  3202.             w_0_0_ = wtp  * wte
    3203. 

  3203.             w_0_1_ = wtp  * wte1
    3204. 

  3204.             w_1_0_ = wtp1 * wte 
    3205. 

  3205.             w_1_1_ = wtp1 * wte1
    3206. 

  3206.             
    3207. 

  3207.             w_0_00 = w_0_0_ * wrh
    3208. 

  3208.             w_0_01 = w_0_0_ * wrh1
    3209. 

  3209.             w_0_10 = w_0_1_ * wrh
    3210. 

  3210.             w_0_11 = w_0_1_ * wrh1
    3211. 

  3211.             w_1_00 = w_1_0_ * wrh
    3212. 

  3212.             w_1_01 = w_1_0_ * wrh1
    3213. 

  3213.             w_1_10 = w_1_1_ * wrh
    3214. 

  3214.             w_1_11 = w_1_1_ * wrh1
    3215. 

  3215.             
    3216. 

  3216.             w00_00 = wp  * w_0_00 
    3217. 

  3217.             w00_01 = wp  * w_0_01 
    3218. 

  3218.             w00_10 = wp  * w_0_10 
    3219. 

  3219.             w00_11 = wp  * w_0_11 
    3220. 

  3220.             w01_00 = wp  * w_1_00 
    3221. 

  3221.             w01_01 = wp  * w_1_01 
    3222. 

  3222.             w01_10 = wp  * w_1_10 
    3223. 

  3223.             w01_11 = wp  * w_1_11 
    3224. 

  3224.             w10_00 = wp1 * w_0_00 
    3225. 

  3225.             w10_01 = wp1 * w_0_01 
    3226. 

  3226.             w10_10 = wp1 * w_0_10 
    3227. 

  3227.             w10_11 = wp1 * w_0_11 
    3228. 

  3228.             w11_00 = wp1 * w_1_00 
    3229. 

  3229.             w11_01 = wp1 * w_1_01 
    3230. 

  3230.             w11_10 = wp1 * w_1_10 
    3231. 

  3231.             w11_11 = wp1 * w_1_11 
    3232. 

    3233. 

  3233. !
    3234. 

  3234. ! Non-window absorptivity
    3235. 

  3235. !
    3236. 

  3236.             ib = 1
    3237. 

  3237.             
    3238. 

  3238.             fa = fat(1,ib) + &
    3239. 

  3239.                  fat(2,ib) * te1 + &
    3240. 

  3240.                  fat(3,ib) * te2 + &
    3241. 

  3241.                  fat(4,ib) * te3 + &
    3242. 

  3242.                  fat(5,ib) * te4 + &
    3243. 

  3243.                  fat(6,ib) * te5
    3244. 

  3244.             
    3245. 

  3245.             a_star = &
    3246. 

  3246.                  ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    3247. 

  3247.                  ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    3248. 

  3248.                  ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    3249. 

  3249.                  ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    3250. 

  3250.                  ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    3251. 

  3251.                  ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    3252. 

  3252.                  ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    3253. 

  3253.                  ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    3254. 

  3254.                  ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    3255. 

  3255.                  ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    3256. 

  3256.                  ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    3257. 

  3257.                  ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    3258. 

  3258.                  ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    3259. 

  3259.                  ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    3260. 

  3260.                  ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    3261. 

  3261.                  ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    3262. 

  3262.                  ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    3263. 

  3263.                  ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    3264. 

  3264.                  ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    3265. 

  3265.                  ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    3266. 

  3266.                  ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    3267. 

  3267.                  ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    3268. 

  3268.                  ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    3269. 

  3269.                  ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    3270. 

  3270.                  ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    3271. 

  3271.                  ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    3272. 

  3272.                  ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    3273. 

  3273.                  ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    3274. 

  3274.                  ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    3275. 

  3275.                  ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    3276. 

  3276.                  ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    3277. 

  3277.                  ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
    3278. 

  3278.             
    3279. 

  3279.             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
    3280. 

  3280.                                  aer_trn_ngh(i,ib)), &
    3281. 

  3281.                              0.0_r8), 1.0_r8)
    3282. 

    3283. 

  3283. !
    3284. 

  3284. ! Invoke linear limit for scaling wrt u below min_u_h2o
    3285. 

  3285. !
    3286. 

  3286.             if (uvar < min_u_h2o) then
    3287. 

  3287.                uscl = uvar / min_u_h2o
    3288. 

  3288.                abso(i,ib) = abso(i,ib) * uscl
    3289. 

  3289.             endif
    3290. 

  3290.             
    3291. 

  3291. !
    3292. 

  3292. ! Window absorptivity
    3293. 

  3293. !
    3294. 

  3294.             ib = 2
    3295. 

  3295.             
    3296. 

  3296.             fa = fat(1,ib) + &
    3297. 

  3297.                  fat(2,ib) * te1 + &
    3298. 

  3298.                  fat(3,ib) * te2 + &
    3299. 

  3299.                  fat(4,ib) * te3 + &
    3300. 

  3300.                  fat(5,ib) * te4 + &
    3301. 

  3301.                  fat(6,ib) * te5
    3302. 

  3302.             
    3303. 

  3303.             a_star = &
    3304. 

  3304.                  ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    3305. 

  3305.                  ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    3306. 

  3306.                  ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    3307. 

  3307.                  ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    3308. 

  3308.                  ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    3309. 

  3309.                  ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    3310. 

  3310.                  ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    3311. 

  3311.                  ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    3312. 

  3312.                  ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    3313. 

  3313.                  ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    3314. 

  3314.                  ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    3315. 

  3315.                  ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    3316. 

  3316.                  ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    3317. 

  3317.                  ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    3318. 

  3318.                  ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    3319. 

  3319.                  ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    3320. 

  3320.                  ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    3321. 

  3321.                  ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    3322. 

  3322.                  ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    3323. 

  3323.                  ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    3324. 

  3324.                  ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    3325. 

  3325.                  ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    3326. 

  3326.                  ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    3327. 

  3327.                  ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    3328. 

  3328.                  ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    3329. 

  3329.                  ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    3330. 

  3330.                  ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    3331. 

  3331.                  ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    3332. 

  3332.                  ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    3333. 

  3333.                  ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    3334. 

  3334.                  ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    3335. 

  3335.                  ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
    3336. 

  3336.             
    3337. 

  3337.             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
    3338. 

  3338.                                  aer_trn_ngh(i,ib)), &
    3339. 

  3339.                              0.0_r8), 1.0_r8)
    3340. 

    3341. 

  3341. !
    3342. 

  3342. ! Invoke linear limit for scaling wrt u below min_u_h2o
    3343. 

  3343. !
    3344. 

  3344.             if (uvar < min_u_h2o) then
    3345. 

  3345.                uscl = uvar / min_u_h2o
    3346. 

  3346.                abso(i,ib) = abso(i,ib) * uscl
    3347. 

  3347.             endif
    3348. 

  3348.             
    3349. 

  3349.          end do
    3350. 

  3350. !
    3351. 

  3351. ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
    3352. 

  3352. !
    3353. 

  3353.          do i=1,ncol
    3354. 

  3354.             term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
    3355. 

  3355.             term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
    3356. 

  3356.             term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
    3357. 

  3357.             term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
    3358. 

  3358.          end do
    3359. 

  3359. !
    3360. 

  3360. ! 500 -  800 cm-1   h2o rotation band overlap with co2
    3361. 

  3361. !
    3362. 

  3362.          do i=1,ncol
    3363. 

  3363.             dtym10     = dty(i) - 10.
    3364. 

  3364.             denom      = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i)
    3365. 

  3365.             k21        = term7(i,1) + term8(i,1)/denom
    3366. 

  3366.             denom      = 1. + (c28 + c29*dtym10       )*sqrtu(i)
    3367. 

  3367.             k22        = term7(i,2) + term8(i,2)/denom
    3368. 

  3368.             tr1     = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
    3369. 

  3369.             tr2     = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
    3370. 

  3370.             tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800) 
    3371. 

  3371. !                                         ! H2O line+STRAER trn 650--800 cm-1
    3372. 

  3372.             tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650) 
    3373. 

  3373. !                                         ! H2O line+STRAER trn 500--650 cm-1
    3374. 

  3374.             tr5     = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
    3375. 

  3375.             tr6     = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
    3376. 

  3376.             tr9(i)  = tr1*tr5
    3377. 

  3377.             tr10(i) = tr2*tr6
    3378. 

  3378.             trab2(i)= 0.65*tr9(i) + 0.35*tr10(i)
    3379. 

  3379.             th2o(i) = tr10(i)
    3380. 

  3380.          end do
    3381. 

  3381. !
    3382. 

  3382. ! abso(i,3)  o3  9.6 micrometer (nu3 and nu1 bands)
    3383. 

  3383. !
    3384. 

  3384.          do i=1,ncol
    3385. 

  3385.             te        = (tbar(i,kn)*r293)**.7
    3386. 

  3386.             dplos     = abs(plos(i,k2+1) - plos(i,k2))
    3387. 

  3387.             u1        = zinpl(i,kn)*18.29*dplos/te
    3388. 

  3388.             u2        = zinpl(i,kn)*.5649*dplos/te
    3389. 

  3389.             tlocal    = tbar(i,kn)
    3390. 

  3390.             tcrfac    = sqrt(tlocal*r250)*te
    3391. 

  3391.             beta      = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac)
    3392. 

  3392.             realnu    = te/beta
    3393. 

  3393.             tmp1      = u1/sqrt(4. + u1*(1. + realnu))
    3394. 

  3394.             tmp2      = u2/sqrt(4. + u2*(1. + realnu))
    3395. 

  3395.             o3bndi    = 74.*te*log(1. + tmp1 + tmp2)
    3396. 

  3396.             abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2))
    3397. 

  3397.             to3(i)    = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
    3398. 

  3398.          end do
    3399. 

  3399. !
    3400. 

  3400. ! abso(i,4)   co2 15  micrometer band system
    3401. 

  3401. !
    3402. 

  3402.          do i=1,ncol
    3403. 

  3403.             dplco2   = plco2(i,k2+1) - plco2(i,k2)
    3404. 

  3404.             sqwp     = sqrt(uinpl(i,kn)*dplco2)
    3405. 

  3405.             et       = exp(-480./tbar(i,kn))
    3406. 

  3406.             sqti(i)  = sqrt(tbar(i,kn))
    3407. 

  3407.             rsqti    = 1./sqti(i)
    3408. 

  3408.             et2      = et*et
    3409. 

  3409.             et4      = et2*et2
    3410. 

  3410.             omet     = (1. - 1.5*et2)
    3411. 

  3411.             f1co2    = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
    3412. 

  3412.             f1sqwp(i)= f1co2*sqwp
    3413. 

  3413.             t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
    3414. 

  3414.             oneme    = 1. - et2
    3415. 

  3415.             alphat   = oneme**3*rsqti
    3416. 

  3416.             pi       = abs(dpnm(i))*winpl(i,kn)
    3417. 

  3417.             wco2     = 2.5221*co2vmr*pi*rga
    3418. 

  3418.             u7(i)    = 4.9411e4*alphat*et2*wco2
    3419. 

  3419.             u8       = 3.9744e4*alphat*et4*wco2
    3420. 

  3420.             u9       = 1.0447e5*alphat*et4*et2*wco2
    3421. 

  3421.             u13      = 2.8388e3*alphat*et4*wco2
    3422. 

  3422.             tpath    = tbar(i,kn)
    3423. 

  3423.             tlocal   = tbar(i,kn)
    3424. 

  3424.             tcrfac   = sqrt((tlocal*r250)*(tpath*r300))
    3425. 

  3425.             posqt    = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti
    3426. 

  3426.             rbeta7(i)= 1./(5.3228*posqt)
    3427. 

  3427.             rbeta8   = 1./(10.6576*posqt)
    3428. 

  3428.             rbeta9   = rbeta7(i)
    3429. 

  3429.             rbeta13  = rbeta9
    3430. 

  3430.             f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + &
    3431. 

  3431.                  u8   /sqrt(4. + u8*(1. + rbeta8)) + &
    3432. 

  3432.                  u9   /sqrt(4. + u9*(1. + rbeta9))
    3433. 

  3433.             f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
    3434. 

  3434.             tmp1     = log(1. + f1sqwp(i))
    3435. 

  3435.             tmp2     = log(1. + f2co2(i))
    3436. 

  3436.             tmp3     = log(1. + f3co2(i))
    3437. 

  3437.             absbnd   = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
    3438. 

  3438.             abso(i,4)= trab2(i)*emm(i,kn)*absbnd
    3439. 

  3439.             tco2(i)  = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))
    3440. 

  3440.          end do ! do i =
    3441. 

  3441. !
    3442. 

  3442. ! Calculate trace gas absorptivity for nearest layer, abstrc
    3443. 

  3443. !
    3444. 

  3444.          call trcabn(lchnk   ,ncol    ,pcols, pverp,                   &
    3445. 

  3445.               k2      ,kn      ,ucfc11  ,ucfc12  ,un2o0   , &
    3446. 

  3446.               un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
    3447. 

  3447.               uco221  ,uco222  ,uco223  ,tbar    ,bplnk   , &
    3448. 

  3448.               winpl   ,pinpl   ,tco2    ,th2o    ,to3     , &
    3449. 

  3449.               uptype  ,dw      ,s2c     ,u       ,pnew    , &
    3450. 

  3450.               abstrc  ,uinpl   , &
    3451. 

  3451.               aer_trn_ngh)
    3452. 

  3452. !
    3453. 

  3453. ! Total next layer absorptivity:
    3454. 

  3454. !
    3455. 

  3455.          do i=1,ncol
    3456. 

  3456.             absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + &
    3457. 

  3457.                  abso(i,3) + abso(i,4) + abstrc(i)
    3458. 

  3458.          end do
    3459. 

  3459.       end do ! do kn =
    3460. 

  3460.    end do ! do k2 =
    3461. 

    3462. 

  3462.    return
    3463. 

  3463. end subroutine radabs
    3464. 

    3465. 

    3466. 

    3467. 

  3467. subroutine radems(lchnk   ,ncol    ,pcols, pver, pverp,         &
    3468. 

  3468.                   s2c     ,tcg     ,w       ,tplnke  ,plh2o   , &
    3469. 

  3469.                   pnm     ,plco2   ,tint    ,tint4   ,tlayr   , &
    3470. 

  3470.                   tlayr4  ,plol    ,plos    ,ucfc11  ,ucfc12  , &
    3471. 

  3471.                   un2o0   ,un2o1   ,uch4    ,uco211 ,uco212   , &
    3472. 

  3472.                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
    3473. 

  3473.                   bn2o0   ,bn2o1   ,bch4    ,co2em   ,co2eml  , &
    3474. 

  3474.                   co2t    ,h2otr   ,abplnk1 ,abplnk2 ,emstot  , &
    3475. 

  3475.                   plh2ob  ,wb      , &
    3476. 

  3476.                   aer_trn_ttl)
    3477. 

  3477. !----------------------------------------------------------------------- 
    3478. 

  3478. ! 
    3479. 

  3479. ! Purpose: 
    3480. 

  3480. ! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12
    3481. 

  3481. ! 
    3482. 

  3482. ! Method: 
    3483. 

  3483. ! H2O  ....  Uses nonisothermal emissivity method for water vapor from
    3484. 

  3484. !            Ramanathan, V. and  P.Downey, 1986: A Nonisothermal
    3485. 

  3485. !            Emissivity and Absorptivity Formulation for Water Vapor
    3486. 

  3486. !            Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666
    3487. 

  3487. !
    3488. 

  3488. !            Implementation updated by Collins,Hackney, and Edwards 2001
    3489. 

  3489. !               using line-by-line calculations based upon Hitran 1996 and
    3490. 

  3490. !               CKD 2.1 for absorptivity and emissivity
    3491. 

  3491. !
    3492. 

  3492. !            Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
    3493. 

  3493. !               using line-by-line calculations based upon Hitran 2000 and
    3494. 

  3494. !               CKD 2.4 for absorptivity and emissivity
    3495. 

  3495. !
    3496. 

  3496. ! CO2  ....  Uses absorptance parameterization of the 15 micro-meter
    3497. 

  3497. !            (500 - 800 cm-1) band system of Carbon Dioxide, from
    3498. 

  3498. !            Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
    3499. 

  3499. !            of the Absorptance Due to the 15 micro-meter Band System
    3500. 

  3500. !            of Carbon Dioxide Jouranl of Geophysical Research,
    3501. 

  3501. !            vol. 96., D5, pp 9013-9019. Also includes the effects
    3502. 

  3502. !            of the 9.4 and 10.4 micron bands of CO2.
    3503. 

  3503. !
    3504. 

  3504. ! O3   ....  Uses absorptance parameterization of the 9.6 micro-meter
    3505. 

  3505. !            band system of ozone, from Ramanathan, V. and R. Dickinson,
    3506. 

  3506. !            1979: The Role of stratospheric ozone in the zonal and
    3507. 

  3507. !            seasonal radiative energy balance of the earth-troposphere
    3508. 

  3508. !            system. Journal of the Atmospheric Sciences, Vol. 36,
    3509. 

  3509. !            pp 1084-1104
    3510. 

  3510. !
    3511. 

  3511. ! ch4  ....  Uses a broad band model for the 7.7 micron band of methane.
    3512. 

  3512. !
    3513. 

  3513. ! n20  ....  Uses a broad band model for the 7.8, 8.6 and 17.0 micron
    3514. 

  3514. !            bands of nitrous oxide
    3515. 

  3515. !
    3516. 

  3516. ! cfc11 ...  Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
    3517. 

  3517. !            micron bands of CFC11
    3518. 

  3518. !
    3519. 

  3519. ! cfc12 ...  Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
    3520. 

  3520. !            micron bands of CFC12
    3521. 

  3521. !
    3522. 

  3522. !
    3523. 

  3523. ! Computes individual emissivities, accounting for band overlap, and
    3524. 

  3524. ! sums to obtain the total.
    3525. 

  3525. !
    3526. 

  3526. ! Author: W. Collins (H2O emissivity) and J. Kiehl
    3527. 

  3527. ! 
    3528. 

  3528. !-----------------------------------------------------------------------
    3529. 

  3529. !------------------------------Arguments--------------------------------
    3530. 

  3530. !
    3531. 

  3531. ! Input arguments
    3532. 

  3532. !
    3533. 

  3533.    integer, intent(in) :: lchnk                    ! chunk identifier
    3534. 

  3534.    integer, intent(in) :: ncol                     ! number of atmospheric columns
    3535. 

  3535.    integer, intent(in) :: pcols, pver, pverp
    3536. 

    3537. 

  3537.    real(r8), intent(in) :: s2c(pcols,pverp)        ! H2o continuum path length
    3538. 

  3538.    real(r8), intent(in) :: tcg(pcols,pverp)        ! H2o-mass-wgted temp. (Curtis-Godson approx.)
    3539. 

  3539.    real(r8), intent(in) :: w(pcols,pverp)          ! H2o path length
    3540. 

  3540.    real(r8), intent(in) :: tplnke(pcols)           ! Layer planck temperature
    3541. 

  3541.    real(r8), intent(in) :: plh2o(pcols,pverp)      ! H2o prs wghted path length
    3542. 

  3542.    real(r8), intent(in) :: pnm(pcols,pverp)        ! Model interface pressure
    3543. 

  3543.    real(r8), intent(in) :: plco2(pcols,pverp)      ! Prs wghted path of co2
    3544. 

  3544.    real(r8), intent(in) :: tint(pcols,pverp)       ! Model interface temperatures
    3545. 

  3545.    real(r8), intent(in) :: tint4(pcols,pverp)      ! Tint to the 4th power
    3546. 

  3546.    real(r8), intent(in) :: tlayr(pcols,pverp)      ! K-1 model layer temperature
    3547. 

  3547.    real(r8), intent(in) :: tlayr4(pcols,pverp)     ! Tlayr to the 4th power
    3548. 

  3548.    real(r8), intent(in) :: plol(pcols,pverp)       ! Pressure wghtd ozone path
    3549. 

  3549.    real(r8), intent(in) :: plos(pcols,pverp)       ! Ozone path
    3550. 

  3550.    real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with 
    3551. 

  3551.                                                       !    Hulst-Curtis-Godson temp. factor 
    3552. 

  3552.                                                       !    for H2O bands 
    3553. 

  3553.    real(r8), intent(in) :: wb(nbands,pcols,pverp)     ! H2o path length with 
    3554. 

  3554.                                                       !    Hulst-Curtis-Godson temp. factor 
    3555. 

  3555.                                                       !    for H2O bands 
    3556. 

    3557. 

  3557.    real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) 
    3558. 

  3558. !                               ! [fraction] Total strat. aerosol
    3559. 

  3559. !                               ! transmission between interfaces k1 and k2  
    3560. 

    3561. 

  3561. !
    3562. 

  3562. ! Trace gas variables
    3563. 

  3563. !
    3564. 

  3564.    real(r8), intent(in) :: ucfc11(pcols,pverp)     ! CFC11 path length
    3565. 

  3565.    real(r8), intent(in) :: ucfc12(pcols,pverp)     ! CFC12 path length
    3566. 

  3566.    real(r8), intent(in) :: un2o0(pcols,pverp)      ! N2O path length
    3567. 

  3567.    real(r8), intent(in) :: un2o1(pcols,pverp)      ! N2O path length (hot band)
    3568. 

  3568.    real(r8), intent(in) :: uch4(pcols,pverp)       ! CH4 path length
    3569. 

  3569.    real(r8), intent(in) :: uco211(pcols,pverp)     ! CO2 9.4 micron band path length
    3570. 

  3570.    real(r8), intent(in) :: uco212(pcols,pverp)     ! CO2 9.4 micron band path length
    3571. 

  3571.    real(r8), intent(in) :: uco213(pcols,pverp)     ! CO2 9.4 micron band path length
    3572. 

  3572.    real(r8), intent(in) :: uco221(pcols,pverp)     ! CO2 10.4 micron band path length
    3573. 

  3573.    real(r8), intent(in) :: uco222(pcols,pverp)     ! CO2 10.4 micron band path length
    3574. 

  3574.    real(r8), intent(in) :: uco223(pcols,pverp)     ! CO2 10.4 micron band path length
    3575. 

  3575.    real(r8), intent(in) :: bn2o0(pcols,pverp)      ! pressure factor for n2o
    3576. 

  3576.    real(r8), intent(in) :: bn2o1(pcols,pverp)      ! pressure factor for n2o
    3577. 

  3577.    real(r8), intent(in) :: bch4(pcols,pverp)       ! pressure factor for ch4
    3578. 

  3578.    real(r8), intent(in) :: uptype(pcols,pverp)     ! p-type continuum path length
    3579. 

  3579. !
    3580. 

  3580. ! Output arguments
    3581. 

  3581. !
    3582. 

  3582.    real(r8), intent(out) :: emstot(pcols,pverp)     ! Total emissivity
    3583. 

  3583.    real(r8), intent(out) :: co2em(pcols,pverp)      ! Layer co2 normalzd plnck funct drvtv
    3584. 

  3584.    real(r8), intent(out) :: co2eml(pcols,pver)      ! Intrfc co2 normalzd plnck func drvtv
    3585. 

  3585.    real(r8), intent(out) :: co2t(pcols,pverp)       ! Tmp and prs weighted path length
    3586. 

  3586.    real(r8), intent(out) :: h2otr(pcols,pverp)      ! H2o transmission over o3 band
    3587. 

  3587.    real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
    3588. 

  3588.    real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
    3589. 

    3590. 

  3590. !
    3591. 

  3591. !---------------------------Local variables-----------------------------
    3592. 

  3592. !
    3593. 

  3593.    integer i                    ! Longitude index
    3594. 

  3594.    integer k                    ! Level index]
    3595. 

  3595.    integer k1                   ! Level index
    3596. 

  3596. !
    3597. 

  3597. ! Local variables for H2O:
    3598. 

  3598. !
    3599. 

  3599.    real(r8) h2oems(pcols,pverp)     ! H2o emissivity
    3600. 

  3600.    real(r8) tpathe                  ! Used to compute h2o emissivity
    3601. 

  3601.    real(r8) dtx(pcols)              ! Planck temperature minus 250 K
    3602. 

  3602.    real(r8) dty(pcols)              ! Path temperature minus 250 K
    3603. 

  3603. !
    3604. 

  3604. ! The 500-800 cm^-1 emission in emis(i,4) has been combined
    3605. 

  3605. !              into the 0-800 cm^-1 emission in emis(i,1)
    3606. 

  3606. !
    3607. 

  3607.    real(r8) emis(pcols,2)           ! H2O emissivity 
    3608. 

  3608. !
    3609. 

  3609. !
    3610. 

  3610. !
    3611. 

  3611.    real(r8) term7(pcols,2)          ! Kl_inf(i) in eq(r8) of table A3a of R&D
    3612. 

  3612.    real(r8) term8(pcols,2)          ! Delta kl_inf(i) in eq(r8)
    3613. 

  3613.    real(r8) tr1(pcols)              ! Equation(6) in table A2 for 650-800
    3614. 

  3614.    real(r8) tr2(pcols)              ! Equation(6) in table A2 for 500-650
    3615. 

  3615.    real(r8) tr3(pcols)              ! Equation(4) in table A2 for 650-800
    3616. 

  3616.    real(r8) tr4(pcols)              ! Equation(4),table A2 of R&D for 500-650
    3617. 

  3617.    real(r8) tr7(pcols)              ! Equation (6) times eq(4) in table A2
    3618. 

  3618. !                                      of R&D for 650-800 cm-1 region
    3619. 

  3619.    real(r8) tr8(pcols)              ! Equation (6) times eq(4) in table A2
    3620. 

  3620. !                                      of R&D for 500-650 cm-1 region
    3621. 

  3621.    real(r8) k21(pcols)              ! Exponential coefficient used to calc
    3622. 

  3622. !                                     rot band transmissivity in the 650-800
    3623. 

  3623. !                                     cm-1 region (tr1)
    3624. 

  3624.    real(r8) k22(pcols)              ! Exponential coefficient used to calc
    3625. 

  3625. !                                     rot band transmissivity in the 500-650
    3626. 

  3626. !                                     cm-1 region (tr2)
    3627. 

  3627.    real(r8) u(pcols)                ! Pressure weighted H2O path length
    3628. 

  3628.    real(r8) ub(nbands)              ! Pressure weighted H2O path length with
    3629. 

  3629.                                     !  Hulst-Curtis-Godson correction for
    3630. 

  3630.                                     !  each band
    3631. 

  3631.    real(r8) pnew                    ! Effective pressure for h2o linewidth
    3632. 

  3632.    real(r8) pnewb(nbands)           ! Effective pressure for h2o linewidth w/
    3633. 

  3633.                                     !  Hulst-Curtis-Godson correction for
    3634. 

  3634.                                     !  each band
    3635. 

  3635.    real(r8) uc1(pcols)              ! H2o continuum pathlength 500-800 cm-1
    3636. 

  3636.    real(r8) fwk                     ! Equation(33) in R&D far wing correction
    3637. 

  3637.    real(r8) troco2(pcols,pverp)     ! H2o overlap factor for co2 absorption
    3638. 

  3638.    real(r8) emplnk(14,pcols)        ! emissivity Planck factor
    3639. 

  3639.    real(r8) emstrc(pcols,pverp)     ! total trace gas emissivity
    3640. 

  3640. !
    3641. 

  3641. ! Local variables for CO2:
    3642. 

  3642. !
    3643. 

  3643.    real(r8) co2ems(pcols,pverp)      ! Co2 emissivity
    3644. 

  3644.    real(r8) co2plk(pcols)            ! Used to compute co2 emissivity
    3645. 

  3645.    real(r8) sum(pcols)               ! Used to calculate path temperature
    3646. 

  3646.    real(r8) t1i                      ! Co2 hot band temperature factor
    3647. 

  3647.    real(r8) sqti                     ! Sqrt of temperature
    3648. 

  3648.    real(r8) pi                       ! Pressure used in co2 mean line width
    3649. 

  3649.    real(r8) et                       ! Co2 hot band factor
    3650. 

  3650.    real(r8) et2                      ! Co2 hot band factor
    3651. 

  3651.    real(r8) et4                      ! Co2 hot band factor
    3652. 

  3652.    real(r8) omet                     ! Co2 stimulated emission term
    3653. 

  3653.    real(r8) ex                       ! Part of co2 planck function
    3654. 

  3654.    real(r8) f1co2                    ! Co2 weak band factor
    3655. 

  3655.    real(r8) f2co2                    ! Co2 weak band factor
    3656. 

  3656.    real(r8) f3co2                    ! Co2 weak band factor
    3657. 

  3657.    real(r8) t1co2                    ! Overlap factor weak bands strong band
    3658. 

  3658.    real(r8) sqwp                     ! Sqrt of co2 pathlength
    3659. 

  3659.    real(r8) f1sqwp                   ! Main co2 band factor
    3660. 

  3660.    real(r8) oneme                    ! Co2 stimulated emission term
    3661. 

  3661.    real(r8) alphat                   ! Part of the co2 stimulated emiss term
    3662. 

  3662.    real(r8) wco2                     ! Consts used to define co2 pathlength
    3663. 

  3663.    real(r8) posqt                    ! Effective pressure for co2 line width
    3664. 

  3664.    real(r8) rbeta7                   ! Inverse of co2 hot band line width par
    3665. 

  3665.    real(r8) rbeta8                   ! Inverse of co2 hot band line width par
    3666. 

  3666.    real(r8) rbeta9                   ! Inverse of co2 hot band line width par
    3667. 

  3667.    real(r8) rbeta13                  ! Inverse of co2 hot band line width par
    3668. 

  3668.    real(r8) tpath                    ! Path temp used in co2 band model
    3669. 

  3669.    real(r8) tmp1                     ! Co2 band factor
    3670. 

  3670.    real(r8) tmp2                     ! Co2 band factor
    3671. 

  3671.    real(r8) tmp3                     ! Co2 band factor
    3672. 

  3672.    real(r8) tlayr5                   ! Temperature factor in co2 Planck func
    3673. 

  3673.    real(r8) rsqti                    ! Reciprocal of sqrt of temperature
    3674. 

  3674.    real(r8) exm1sq                   ! Part of co2 Planck function
    3675. 

  3675.    real(r8) u7                       ! Absorber amt for various co2 band systems
    3676. 

  3676.    real(r8) u8                       ! Absorber amt for various co2 band systems
    3677. 

  3677.    real(r8) u9                       ! Absorber amt for various co2 band systems
    3678. 

  3678.    real(r8) u13                      ! Absorber amt for various co2 band systems
    3679. 

  3679.    real(r8) r250                     ! Inverse 250K
    3680. 

  3680.    real(r8) r300                     ! Inverse 300K
    3681. 

  3681.    real(r8) rsslp                    ! Inverse standard sea-level pressure
    3682. 

  3682. !
    3683. 

  3683. ! Local variables for O3:
    3684. 

  3684. !
    3685. 

  3685.    real(r8) o3ems(pcols,pverp)       ! Ozone emissivity
    3686. 

  3686.    real(r8) dbvtt(pcols)             ! Tmp drvtv of planck fctn for tplnke
    3687. 

  3687.    real(r8) dbvt,fo3,t,ux,vx
    3688. 

  3688.    real(r8) te                       ! Temperature factor
    3689. 

  3689.    real(r8) u1                       ! Path length factor
    3690. 

  3690.    real(r8) u2                       ! Path length factor
    3691. 

  3691.    real(r8) phat                     ! Effecitive path length pressure
    3692. 

  3692.    real(r8) tlocal                   ! Local planck function temperature
    3693. 

  3693.    real(r8) tcrfac                   ! Scaled temperature factor
    3694. 

  3694.    real(r8) beta                     ! Absorption funct factor voigt effect
    3695. 

  3695.    real(r8) realnu                   ! Absorption function factor
    3696. 

  3696.    real(r8) o3bndi                   ! Band absorption factor
    3697. 

  3697. !
    3698. 

  3698. ! Transmission terms for various spectral intervals:
    3699. 

  3699. !
    3700. 

  3700.    real(r8) absbnd                   ! Proportional to co2 band absorptance
    3701. 

  3701.    real(r8) tco2(pcols)              ! co2 overlap factor
    3702. 

  3702.    real(r8) th2o(pcols)              ! h2o overlap factor
    3703. 

  3703.    real(r8) to3(pcols)               ! o3 overlap factor
    3704. 

  3704. !
    3705. 

  3705. ! Variables for new H2O parameterization
    3706. 

  3706. !
    3707. 

  3707. ! Notation:
    3708. 

  3708. ! U   = integral (P/P_0 dW)  eq. 15 in Ramanathan/Downey 1986
    3709. 

  3709. ! P   = atmospheric pressure
    3710. 

  3710. ! P_0 = reference atmospheric pressure
    3711. 

  3711. ! W   = precipitable water path
    3712. 

  3712. ! T_e = emission temperature
    3713. 

  3713. ! T_p = path temperature
    3714. 

  3714. ! RH  = path relative humidity
    3715. 

  3715. !
    3716. 

  3716.    real(r8) fe               ! asymptotic value of emis. as U->infinity
    3717. 

  3717.    real(r8) e_star           ! normalized non-window emissivity
    3718. 

  3718.    real(r8) l_star           ! interpolated line transmission
    3719. 

  3719.    real(r8) c_star           ! interpolated continuum transmission
    3720. 

    3721. 

  3721.    real(r8) te1              ! emission temperature
    3722. 

  3722.    real(r8) te2              ! te^2
    3723. 

  3723.    real(r8) te3              ! te^3
    3724. 

  3724.    real(r8) te4              ! te^4
    3725. 

  3725.    real(r8) te5              ! te^5
    3726. 

    3727. 

  3727.    real(r8) log_u            ! log base 10 of U 
    3728. 

  3728.    real(r8) log_uc           ! log base 10 of H2O continuum path
    3729. 

  3729.    real(r8) log_p            ! log base 10 of P
    3730. 

  3730.    real(r8) t_p              ! T_p
    3731. 

  3731.    real(r8) t_e              ! T_e (offset by T_p)
    3732. 

    3733. 

  3733.    integer iu                ! index for log10(U)
    3734. 

  3734.    integer iu1               ! iu + 1
    3735. 

  3735.    integer iuc               ! index for log10(H2O continuum path)
    3736. 

  3736.    integer iuc1              ! iuc + 1
    3737. 

  3737.    integer ip                ! index for log10(P)
    3738. 

  3738.    integer ip1               ! ip + 1
    3739. 

  3739.    integer itp               ! index for T_p
    3740. 

  3740.    integer itp1              ! itp + 1
    3741. 

  3741.    integer ite               ! index for T_e
    3742. 

  3742.    integer ite1              ! ite + 1
    3743. 

  3743.    integer irh               ! index for RH
    3744. 

  3744.    integer irh1              ! irh + 1
    3745. 

    3746. 

  3746.    real(r8) dvar             ! normalized variation in T_p/T_e/P/U
    3747. 

  3747.    real(r8) uvar             ! U * diffusivity factor
    3748. 

  3748.    real(r8) uscl             ! factor for lineary scaling as U->0
    3749. 

    3750. 

  3750.    real(r8) wu               ! weight for U
    3751. 

  3751.    real(r8) wu1              ! 1 - wu
    3752. 

  3752.    real(r8) wuc              ! weight for H2O continuum path
    3753. 

  3753.    real(r8) wuc1             ! 1 - wuc
    3754. 

  3754.    real(r8) wp               ! weight for P
    3755. 

  3755.    real(r8) wp1              ! 1 - wp
    3756. 

  3756.    real(r8) wtp              ! weight for T_p
    3757. 

  3757.    real(r8) wtp1             ! 1 - wtp
    3758. 

  3758.    real(r8) wte              ! weight for T_e
    3759. 

  3759.    real(r8) wte1             ! 1 - wte
    3760. 

  3760.    real(r8) wrh              ! weight for RH
    3761. 

  3761.    real(r8) wrh1             ! 1 - wrh
    3762. 

    3763. 

  3763.    real(r8) w_0_0_           ! weight for Tp/Te combination
    3764. 

  3764.    real(r8) w_0_1_           ! weight for Tp/Te combination
    3765. 

  3765.    real(r8) w_1_0_           ! weight for Tp/Te combination
    3766. 

  3766.    real(r8) w_1_1_           ! weight for Tp/Te combination
    3767. 

    3768. 

  3768.    real(r8) w_0_00           ! weight for Tp/Te/RH combination
    3769. 

  3769.    real(r8) w_0_01           ! weight for Tp/Te/RH combination
    3770. 

  3770.    real(r8) w_0_10           ! weight for Tp/Te/RH combination
    3771. 

  3771.    real(r8) w_0_11           ! weight for Tp/Te/RH combination
    3772. 

  3772.    real(r8) w_1_00           ! weight for Tp/Te/RH combination
    3773. 

  3773.    real(r8) w_1_01           ! weight for Tp/Te/RH combination
    3774. 

  3774.    real(r8) w_1_10           ! weight for Tp/Te/RH combination
    3775. 

  3775.    real(r8) w_1_11           ! weight for Tp/Te/RH combination
    3776. 

    3777. 

  3777.    real(r8) w00_00           ! weight for P/Tp/Te/RH combination
    3778. 

  3778.    real(r8) w00_01           ! weight for P/Tp/Te/RH combination
    3779. 

  3779.    real(r8) w00_10           ! weight for P/Tp/Te/RH combination
    3780. 

  3780.    real(r8) w00_11           ! weight for P/Tp/Te/RH combination
    3781. 

  3781.    real(r8) w01_00           ! weight for P/Tp/Te/RH combination
    3782. 

  3782.    real(r8) w01_01           ! weight for P/Tp/Te/RH combination
    3783. 

  3783.    real(r8) w01_10           ! weight for P/Tp/Te/RH combination
    3784. 

  3784.    real(r8) w01_11           ! weight for P/Tp/Te/RH combination
    3785. 

  3785.    real(r8) w10_00           ! weight for P/Tp/Te/RH combination
    3786. 

  3786.    real(r8) w10_01           ! weight for P/Tp/Te/RH combination
    3787. 

  3787.    real(r8) w10_10           ! weight for P/Tp/Te/RH combination
    3788. 

  3788.    real(r8) w10_11           ! weight for P/Tp/Te/RH combination
    3789. 

  3789.    real(r8) w11_00           ! weight for P/Tp/Te/RH combination
    3790. 

  3790.    real(r8) w11_01           ! weight for P/Tp/Te/RH combination
    3791. 

  3791.    real(r8) w11_10           ! weight for P/Tp/Te/RH combination
    3792. 

  3792.    real(r8) w11_11           ! weight for P/Tp/Te/RH combination
    3793. 

    3794. 

  3794.    integer ib                ! spectral interval:
    3795. 

  3795.                              !   1 = 0-800 cm^-1 and 1200-2200 cm^-1
    3796. 

  3796.                              !   2 = 800-1200 cm^-1
    3797. 

    3798. 

  3798.    real(r8) pch2o            ! H2O continuum path
    3799. 

  3799.    real(r8) fch2o            ! temp. factor for continuum
    3800. 

  3800.    real(r8) uch2o            ! U corresponding to H2O cont. path (window)
    3801. 

    3802. 

  3802.    real(r8) fdif             ! secant(zenith angle) for diffusivity approx.
    3803. 

    3804. 

  3804.    real(r8) sslp_mks         ! Sea-level pressure in MKS units
    3805. 

  3805.    real(r8) esx              ! saturation vapor pressure returned by vqsatd
    3806. 

  3806.    real(r8) qsx              ! saturation mixing ratio returned by vqsatd
    3807. 

  3807.    real(r8) pnew_mks         ! pnew in MKS units
    3808. 

  3808.    real(r8) q_path           ! effective specific humidity along path
    3809. 

  3809.    real(r8) rh_path          ! effective relative humidity along path
    3810. 

  3810.    real(r8) omeps            ! 1 - epsilo
    3811. 

    3812. 

  3812.    integer  iest             ! index in estblh2o
    3813. 

    3814. 

  3814. !
    3815. 

  3815. !---------------------------Statement functions-------------------------
    3816. 

  3816. !
    3817. 

  3817. ! Derivative of planck function at 9.6 micro-meter wavelength, and
    3818. 

  3818. ! an absorption function factor:
    3819. 

  3819. !
    3820. 

  3820. !
    3821. 

  3821.    dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
    3822. 

  3822.            (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
    3823. 

  3823. !
    3824. 

  3824.    fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx))
    3825. 

  3825. !
    3826. 

  3826. !
    3827. 

  3827. !
    3828. 

  3828. !-----------------------------------------------------------------------
    3829. 

  3829. !
    3830. 

  3830. ! Initialize
    3831. 

  3831. !
    3832. 

  3832.    r250  = 1./250.
    3833. 

  3833.    r300  = 1./300.
    3834. 

  3834.    rsslp = 1./sslp
    3835. 

  3835. !
    3836. 

  3836. ! Constants for computing U corresponding to H2O cont. path
    3837. 

  3837. !
    3838. 

  3838.    fdif       = 1.66
    3839. 

  3839.    sslp_mks   = sslp / 10.0
    3840. 

  3840.    omeps      = 1.0 - epsilo
    3841. 

  3841. !
    3842. 

  3842. ! Planck function for co2
    3843. 

  3843. !
    3844. 

  3844.    do i=1,ncol
    3845. 

  3845.       ex             = exp(960./tplnke(i))
    3846. 

  3846.       co2plk(i)      = 5.e8/((tplnke(i)**4)*(ex - 1.))
    3847. 

  3847.       co2t(i,ntoplw) = tplnke(i)
    3848. 

  3848.       sum(i)         = co2t(i,ntoplw)*pnm(i,ntoplw)
    3849. 

  3849.    end do
    3850. 

  3850.    k = ntoplw
    3851. 

  3851.    do k1=pverp,ntoplw+1,-1
    3852. 

  3852.       k = k + 1
    3853. 

  3853.       do i=1,ncol
    3854. 

  3854.          sum(i)         = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1))
    3855. 

  3855.          ex             = exp(960./tlayr(i,k1))
    3856. 

  3856.          tlayr5         = tlayr(i,k1)*tlayr4(i,k1)
    3857. 

  3857.          co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2)
    3858. 

  3858.          co2t(i,k)      = sum(i)/pnm(i,k)
    3859. 

  3859.       end do
    3860. 

  3860.    end do
    3861. 

  3861. !
    3862. 

  3862. ! Initialize planck function derivative for O3
    3863. 

  3863. !
    3864. 

  3864.    do i=1,ncol
    3865. 

  3865.       dbvtt(i) = dbvt(tplnke(i))
    3866. 

  3866.    end do
    3867. 

  3867. !
    3868. 

  3868. ! Calculate trace gas Planck functions
    3869. 

  3869. !
    3870. 

  3870.    call trcplk(lchnk   ,ncol    ,pcols, pver, pverp,         &
    3871. 

  3871.                tint    ,tlayr   ,tplnke  ,emplnk  ,abplnk1 , &
    3872. 

  3872.                abplnk2 )
    3873. 

  3873. !
    3874. 

  3874. ! Interface loop
    3875. 

  3875. !
    3876. 

  3876.    do k1=ntoplw,pverp
    3877. 

  3877. !
    3878. 

  3878. ! H2O emissivity
    3879. 

  3879. !
    3880. 

  3880. ! emis(i,1)     0 -  800 cm-1   h2o rotation band
    3881. 

  3881. ! emis(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    3882. 

  3882. ! emis(i,2)   800 - 1200 cm-1   h2o window
    3883. 

  3883. !
    3884. 

  3884. ! Separation between rotation and vibration-rotation dropped, so
    3885. 

  3885. !                only 2 slots needed for H2O emissivity
    3886. 

  3886. !
    3887. 

  3887. !      emis(i,3)   = 0.0
    3888. 

  3888. !
    3889. 

  3889. ! For the p type continuum
    3890. 

  3890. !
    3891. 

  3891.       do i=1,ncol
    3892. 

  3892.          u(i)        = plh2o(i,k1)
    3893. 

  3893.          pnew        = u(i)/w(i,k1)
    3894. 

  3894.          pnew_mks    = pnew * sslp_mks
    3895. 

  3895. !
    3896. 

  3896. ! Apply scaling factor for 500-800 continuum
    3897. 

  3897. !
    3898. 

  3898.          uc1(i)      = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ &
    3899. 

  3899.                        (1. + 15.*s2c(i,k1))
    3900. 

  3900.          pch2o       = s2c(i,k1)
    3901. 

  3901. !
    3902. 

  3902. ! Changed effective path temperature to std. Curtis-Godson form
    3903. 

  3903. !
    3904. 

  3904.          tpathe   = tcg(i,k1)/w(i,k1)
    3905. 

  3905.          t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o)
    3906. 

  3906.          iest = floor(t_p) - min_tp_h2o
    3907. 

  3907.          esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
    3908. 

  3908.                (t_p - min_tp_h2o - iest)
    3909. 

  3909.          qsx = epsilo * esx / (pnew_mks - omeps * esx)
    3910. 

  3910. !
    3911. 

  3911. ! Compute effective RH along path
    3912. 

  3912. !
    3913. 

  3913.          q_path = w(i,k1) / pnm(i,k1) / rga
    3914. 

  3914. !
    3915. 

  3915. ! Calculate effective u, pnew for each band using
    3916. 

  3916. !        Hulst-Curtis-Godson approximation:
    3917. 

  3917. ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis, 
    3918. 

  3918. !           2nd edition, Oxford University Press, 1989.
    3919. 

  3919. ! Effective H2O path (w)
    3920. 

  3920. !      eq. 6.24, p. 228
    3921. 

  3921. ! Effective H2O path pressure (pnew = u/w):
    3922. 

  3922. !      eq. 6.29, p. 228
    3923. 

  3923. !
    3924. 

  3924.          ub(1) = plh2ob(1,i,k1) / psi(t_p,1)
    3925. 

  3925.          ub(2) = plh2ob(2,i,k1) / psi(t_p,2)
    3926. 

    3927. 

  3927.          pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1)
    3928. 

  3928.          pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2)
    3929. 

  3929. !
    3930. 

  3930. !
    3931. 

  3931. !
    3932. 

  3932.          dtx(i) = tplnke(i) - 250.
    3933. 

  3933.          dty(i) = tpathe - 250.
    3934. 

  3934. !
    3935. 

  3935. ! Define variables for C/H/E (now C/LT/E) fit
    3936. 

  3936. !
    3937. 

  3937. ! emis(i,1)     0 -  800 cm-1   h2o rotation band
    3938. 

  3938. ! emis(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
    3939. 

  3939. ! emis(i,2)   800 - 1200 cm-1   h2o window
    3940. 

  3940. !
    3941. 

  3941. ! Separation between rotation and vibration-rotation dropped, so
    3942. 

  3942. !                only 2 slots needed for H2O emissivity
    3943. 

  3943. !
    3944. 

  3944. ! emis(i,3)   = 0.0
    3945. 

  3945. !
    3946. 

  3946. ! Notation:
    3947. 

  3947. ! U   = integral (P/P_0 dW)  
    3948. 

  3948. ! P   = atmospheric pressure
    3949. 

  3949. ! P_0 = reference atmospheric pressure
    3950. 

  3950. ! W   = precipitable water path
    3951. 

  3951. ! T_e = emission temperature
    3952. 

  3952. ! T_p = path temperature
    3953. 

  3953. ! RH  = path relative humidity
    3954. 

  3954. !
    3955. 

  3955. ! Terms for asymptotic value of emissivity
    3956. 

  3956. !
    3957. 

  3957.          te1  = tplnke(i)
    3958. 

  3958.          te2  = te1 * te1
    3959. 

  3959.          te3  = te2 * te1
    3960. 

  3960.          te4  = te3 * te1
    3961. 

  3961.          te5  = te4 * te1
    3962. 

  3962. !
    3963. 

  3963. ! Band-independent indices for lines and continuum tables
    3964. 

  3964. !
    3965. 

  3965.          dvar = (t_p - min_tp_h2o) / dtp_h2o
    3966. 

  3966.          itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
    3967. 

  3967.          itp1 = itp + 1
    3968. 

  3968.          wtp = dvar - floor(dvar)
    3969. 

  3969.          wtp1 = 1.0 - wtp
    3970. 

    3971. 

  3971.          t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o)
    3972. 

  3972.          dvar = (t_e - min_te_h2o) / dte_h2o
    3973. 

  3973.          ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
    3974. 

  3974.          ite1 = ite + 1
    3975. 

  3975.          wte = dvar - floor(dvar)
    3976. 

  3976.          wte1 = 1.0 - wte
    3977. 

    3978. 

  3978.          rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
    3979. 

  3979.          dvar = (rh_path - min_rh_h2o) / drh_h2o
    3980. 

  3980.          irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
    3981. 

  3981.          irh1 = irh + 1
    3982. 

  3982.          wrh = dvar - floor(dvar)
    3983. 

  3983.          wrh1 = 1.0 - wrh
    3984. 

    3985. 

  3985.          w_0_0_ = wtp  * wte
    3986. 

  3986.          w_0_1_ = wtp  * wte1
    3987. 

  3987.          w_1_0_ = wtp1 * wte 
    3988. 

  3988.          w_1_1_ = wtp1 * wte1
    3989. 

    3990. 

  3990.          w_0_00 = w_0_0_ * wrh
    3991. 

  3991.          w_0_01 = w_0_0_ * wrh1
    3992. 

  3992.          w_0_10 = w_0_1_ * wrh
    3993. 

  3993.          w_0_11 = w_0_1_ * wrh1
    3994. 

  3994.          w_1_00 = w_1_0_ * wrh
    3995. 

  3995.          w_1_01 = w_1_0_ * wrh1
    3996. 

  3996.          w_1_10 = w_1_1_ * wrh
    3997. 

  3997.          w_1_11 = w_1_1_ * wrh1
    3998. 

  3998. !
    3999. 

  3999. ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
    4000. 

  4000. !
    4001. 

  4001. !    Assume foreign continuum dominates total H2O continuum in these bands
    4002. 

  4002. !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
    4003. 

  4003. !    Then the effective H2O path is just 
    4004. 

  4004. !         U_c = integral[ f(P) dW ]
    4005. 

  4005. !    where 
    4006. 

  4006. !           W = water-vapor mass and 
    4007. 

  4007. !        f(P) = dependence of foreign continuum on pressure 
    4008. 

  4008. !             = P / sslp
    4009. 

  4009. !    Then 
    4010. 

  4010. !         U_c = U (the same effective H2O path as for lines)
    4011. 

  4011. !
    4012. 

  4012. !
    4013. 

  4013. ! Continuum terms for 800-1200 cm^-1
    4014. 

  4014. !
    4015. 

  4015. !    Assume self continuum dominates total H2O continuum for this band
    4016. 

  4016. !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
    4017. 

  4017. !    Then the effective H2O self-continuum path is 
    4018. 

  4018. !         U_c = integral[ h(e,T) dW ]                        (*eq. 1*)
    4019. 

  4019. !    where 
    4020. 

  4020. !           W = water-vapor mass and 
    4021. 

  4021. !           e = partial pressure of H2O along path
    4022. 

  4022. !           T = temperature along path
    4023. 

  4023. !      h(e,T) = dependence of foreign continuum on e,T
    4024. 

  4024. !             = e / sslp * f(T)
    4025. 

  4025. !
    4026. 

  4026. !    Replacing
    4027. 

  4027. !           e =~ q * P / epsilo
    4028. 

  4028. !           q = mixing ratio of H2O
    4029. 

  4029. !     epsilo = 0.622
    4030. 

  4030. !
    4031. 

  4031. !    and using the definition
    4032. 

  4032. !           U = integral [ (P / sslp) dW ]
    4033. 

  4033. !             = (P / sslp) W                                 (homogeneous path)
    4034. 

  4034. !
    4035. 

  4035. !    the effective path length for the self continuum is
    4036. 

  4036. !         U_c = (q / epsilo) f(T) U                         (*eq. 2*)
    4037. 

  4037. !
    4038. 

  4038. !    Once values of T, U, and q have been calculated for the inhomogeneous
    4039. 

  4039. !        path, this sets U_c for the corresponding
    4040. 

  4040. !        homogeneous atmosphere.  However, this need not equal the
    4041. 

  4041. !        value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
    4042. 

  4042. !        under consideration.
    4043. 

  4043. !
    4044. 

  4044. !    Solution: hold T and q constant, solve for U' that gives U_c' by
    4045. 

  4045. !        inverting eq. (2):
    4046. 

  4046. !
    4047. 

  4047. !        U' = (U_c * epsilo) / (q * f(T))
    4048. 

  4048. !
    4049. 

  4049.          fch2o = fh2oself(t_p)
    4050. 

  4050.          uch2o = (pch2o * epsilo) / (q_path * fch2o)
    4051. 

    4052. 

  4052. !
    4053. 

  4053. ! Band-dependent indices for non-window
    4054. 

  4054. !
    4055. 

  4055.          ib = 1
    4056. 

    4057. 

  4057.          uvar = ub(ib) * fdif
    4058. 

  4058.          log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
    4059. 

  4059.          dvar = (log_u - min_lu_h2o) / dlu_h2o
    4060. 

  4060.          iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    4061. 

  4061.          iu1 = iu + 1
    4062. 

  4062.          wu = dvar - floor(dvar)
    4063. 

  4063.          wu1 = 1.0 - wu
    4064. 

  4064.          
    4065. 

  4065.          log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
    4066. 

  4066.          dvar = (log_p - min_lp_h2o) / dlp_h2o
    4067. 

  4067.          ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
    4068. 

  4068.          ip1 = ip + 1
    4069. 

  4069.          wp = dvar - floor(dvar)
    4070. 

  4070.          wp1 = 1.0 - wp
    4071. 

    4072. 

  4072.          w00_00 = wp  * w_0_00 
    4073. 

  4073.          w00_01 = wp  * w_0_01 
    4074. 

  4074.          w00_10 = wp  * w_0_10 
    4075. 

  4075.          w00_11 = wp  * w_0_11 
    4076. 

  4076.          w01_00 = wp  * w_1_00 
    4077. 

  4077.          w01_01 = wp  * w_1_01 
    4078. 

  4078.          w01_10 = wp  * w_1_10 
    4079. 

  4079.          w01_11 = wp  * w_1_11 
    4080. 

  4080.          w10_00 = wp1 * w_0_00 
    4081. 

  4081.          w10_01 = wp1 * w_0_01 
    4082. 

  4082.          w10_10 = wp1 * w_0_10 
    4083. 

  4083.          w10_11 = wp1 * w_0_11 
    4084. 

  4084.          w11_00 = wp1 * w_1_00 
    4085. 

  4085.          w11_01 = wp1 * w_1_01 
    4086. 

  4086.          w11_10 = wp1 * w_1_10 
    4087. 

  4087.          w11_11 = wp1 * w_1_11 
    4088. 

    4089. 

  4089. !
    4090. 

  4090. ! Asymptotic value of emissivity as U->infinity
    4091. 

  4091. !
    4092. 

  4092.          fe = fet(1,ib) + &
    4093. 

  4093.               fet(2,ib) * te1 + &
    4094. 

  4094.               fet(3,ib) * te2 + &
    4095. 

  4095.               fet(4,ib) * te3 + &
    4096. 

  4096.               fet(5,ib) * te4 + &
    4097. 

  4097.               fet(6,ib) * te5
    4098. 

    4099. 

  4099.          e_star = &
    4100. 

  4100.               eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    4101. 

  4101.               eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    4102. 

  4102.               eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    4103. 

  4103.               eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    4104. 

  4104.               eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    4105. 

  4105.               eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    4106. 

  4106.               eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    4107. 

  4107.               eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    4108. 

  4108.               eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    4109. 

  4109.               eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    4110. 

  4110.               eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    4111. 

  4111.               eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    4112. 

  4112.               eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    4113. 

  4113.               eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    4114. 

  4114.               eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    4115. 

  4115.               eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    4116. 

  4116.               eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    4117. 

  4117.               eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    4118. 

  4118.               eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    4119. 

  4119.               eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    4120. 

  4120.               eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    4121. 

  4121.               eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    4122. 

  4122.               eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    4123. 

  4123.               eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    4124. 

  4124.               eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    4125. 

  4125.               eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    4126. 

  4126.               eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    4127. 

  4127.               eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    4128. 

  4128.               eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    4129. 

  4129.               eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    4130. 

  4130.               eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    4131. 

  4131.               eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu 
    4132. 

  4132.          emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * &
    4133. 

  4133.                               aer_trn_ttl(i,k1,1,ib)), &
    4134. 

  4134.                           0.0_r8), 1.0_r8)
    4135. 

  4135. !
    4136. 

  4136. ! Invoke linear limit for scaling wrt u below min_u_h2o
    4137. 

  4137. !
    4138. 

  4138.          if (uvar < min_u_h2o) then
    4139. 

  4139.             uscl = uvar / min_u_h2o
    4140. 

  4140.             emis(i,ib) = emis(i,ib) * uscl
    4141. 

  4141.          endif
    4142. 

    4143. 

  4143.                       
    4144. 

    4145. 

  4145. !
    4146. 

  4146. ! Band-dependent indices for window
    4147. 

  4147. !
    4148. 

  4148.          ib = 2
    4149. 

    4150. 

  4150.          uvar = ub(ib) * fdif
    4151. 

  4151.          log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
    4152. 

  4152.          dvar = (log_u - min_lu_h2o) / dlu_h2o
    4153. 

  4153.          iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    4154. 

  4154.          iu1 = iu + 1
    4155. 

  4155.          wu = dvar - floor(dvar)
    4156. 

  4156.          wu1 = 1.0 - wu
    4157. 

  4157.          
    4158. 

  4158.          log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
    4159. 

  4159.          dvar = (log_p - min_lp_h2o) / dlp_h2o
    4160. 

  4160.          ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
    4161. 

  4161.          ip1 = ip + 1
    4162. 

  4162.          wp = dvar - floor(dvar)
    4163. 

  4163.          wp1 = 1.0 - wp
    4164. 

    4165. 

  4165.          w00_00 = wp  * w_0_00 
    4166. 

  4166.          w00_01 = wp  * w_0_01 
    4167. 

  4167.          w00_10 = wp  * w_0_10 
    4168. 

  4168.          w00_11 = wp  * w_0_11 
    4169. 

  4169.          w01_00 = wp  * w_1_00 
    4170. 

  4170.          w01_01 = wp  * w_1_01 
    4171. 

  4171.          w01_10 = wp  * w_1_10 
    4172. 

  4172.          w01_11 = wp  * w_1_11 
    4173. 

  4173.          w10_00 = wp1 * w_0_00 
    4174. 

  4174.          w10_01 = wp1 * w_0_01 
    4175. 

  4175.          w10_10 = wp1 * w_0_10 
    4176. 

  4176.          w10_11 = wp1 * w_0_11 
    4177. 

  4177.          w11_00 = wp1 * w_1_00 
    4178. 

  4178.          w11_01 = wp1 * w_1_01 
    4179. 

  4179.          w11_10 = wp1 * w_1_10 
    4180. 

  4180.          w11_11 = wp1 * w_1_11 
    4181. 

    4182. 

  4182.          log_uc  = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
    4183. 

  4183.          dvar = (log_uc - min_lu_h2o) / dlu_h2o
    4184. 

  4184.          iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
    4185. 

  4185.          iuc1 = iuc + 1
    4186. 

  4186.          wuc = dvar - floor(dvar)
    4187. 

  4187.          wuc1 = 1.0 - wuc
    4188. 

  4188. !
    4189. 

  4189. ! Asymptotic value of emissivity as U->infinity
    4190. 

  4190. !
    4191. 

  4191.          fe = fet(1,ib) + &
    4192. 

  4192.               fet(2,ib) * te1 + &
    4193. 

  4193.               fet(3,ib) * te2 + &
    4194. 

  4194.               fet(4,ib) * te3 + &
    4195. 

  4195.               fet(5,ib) * te4 + &
    4196. 

  4196.               fet(6,ib) * te5
    4197. 

    4198. 

  4198.          l_star = &
    4199. 

  4199.               ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
    4200. 

  4200.               ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
    4201. 

  4201.               ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
    4202. 

  4202.               ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
    4203. 

  4203.               ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
    4204. 

  4204.               ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
    4205. 

  4205.               ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
    4206. 

  4206.               ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
    4207. 

  4207.               ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
    4208. 

  4208.               ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
    4209. 

  4209.               ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
    4210. 

  4210.               ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
    4211. 

  4211.               ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
    4212. 

  4212.               ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
    4213. 

  4213.               ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
    4214. 

  4214.               ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
    4215. 

  4215.               ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
    4216. 

  4216.               ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
    4217. 

  4217.               ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
    4218. 

  4218.               ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
    4219. 

  4219.               ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
    4220. 

  4220.               ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
    4221. 

  4221.               ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
    4222. 

  4222.               ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
    4223. 

  4223.               ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
    4224. 

  4224.               ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
    4225. 

  4225.               ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
    4226. 

  4226.               ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
    4227. 

  4227.               ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
    4228. 

  4228.               ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
    4229. 

  4229.               ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
    4230. 

  4230.               ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu 
    4231. 

    4232. 

  4232.          c_star = &
    4233. 

  4233.               cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
    4234. 

  4234.               cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
    4235. 

  4235.               cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
    4236. 

  4236.               cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
    4237. 

  4237.               cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc  + &
    4238. 

  4238.               cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc  + &
    4239. 

  4239.               cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc  + &
    4240. 

  4240.               cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc  + &
    4241. 

  4241.               cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
    4242. 

  4242.               cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
    4243. 

  4243.               cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
    4244. 

  4244.               cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
    4245. 

  4245.               cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc  + &
    4246. 

  4246.               cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc  + &
    4247. 

  4247.               cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc  + &
    4248. 

  4248.               cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc  + &
    4249. 

  4249.               cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
    4250. 

  4250.               cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
    4251. 

  4251.               cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
    4252. 

  4252.               cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
    4253. 

  4253.               cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc  + &
    4254. 

  4254.               cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc  + &
    4255. 

  4255.               cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc  + &
    4256. 

  4256.               cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc  + &
    4257. 

  4257.               cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
    4258. 

  4258.               cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
    4259. 

  4259.               cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
    4260. 

  4260.               cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
    4261. 

  4261.               cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc  + &
    4262. 

  4262.               cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc  + &
    4263. 

  4263.               cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc  + &
    4264. 

  4264.               cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc 
    4265. 

  4265.          emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * &
    4266. 

  4266.                               aer_trn_ttl(i,k1,1,ib)), &
    4267. 

  4267.                           0.0_r8), 1.0_r8) 
    4268. 

  4268. !
    4269. 

  4269. ! Invoke linear limit for scaling wrt u below min_u_h2o
    4270. 

  4270. !
    4271. 

  4271.          if (uvar < min_u_h2o) then
    4272. 

  4272.             uscl = uvar / min_u_h2o
    4273. 

  4273.             emis(i,ib) = emis(i,ib) * uscl
    4274. 

  4274.          endif
    4275. 

    4276. 

  4276.                       
    4277. 

  4277. !
    4278. 

  4278. ! Compute total emissivity for H2O
    4279. 

  4279. !
    4280. 

  4280.          h2oems(i,k1) = emis(i,1)+emis(i,2)
    4281. 

    4282. 

  4282.       end do
    4283. 

  4283. !
    4284. 

  4284. !
    4285. 

  4285. !
    4286. 

    4287. 

  4287.       do i=1,ncol
    4288. 

  4288.          term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i))
    4289. 

  4289.          term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i))
    4290. 

  4290.          term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i))
    4291. 

  4291.          term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i))
    4292. 

  4292.       end do
    4293. 

  4293.       do i=1,ncol
    4294. 

  4294. !
    4295. 

  4295. ! 500 -  800 cm-1   rotation band overlap with co2
    4296. 

  4296. !
    4297. 

  4297.          k21(i) = term7(i,1) + term8(i,1)/ &
    4298. 

  4298.                  (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i)))
    4299. 

  4299.          k22(i) = term7(i,2) + term8(i,2)/ &
    4300. 

  4300.                  (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i)))
    4301. 

  4301.          fwk    = fwcoef + fwc1/(1.+fwc2*u(i))
    4302. 

  4302.          tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
    4303. 

  4303.          tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
    4304. 

  4304.          tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800) 
    4305. 

  4305. !                                            ! H2O line+aer trn 650--800 cm-1
    4306. 

  4306.          tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650) 
    4307. 

  4307. !                                            ! H2O line+aer trn 500--650 cm-1
    4308. 

  4308.          tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i)))
    4309. 

  4309.          tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i)))
    4310. 

  4310.          tr7(i) = tr1(i)*tr3(i)
    4311. 

  4311.          tr8(i) = tr2(i)*tr4(i)
    4312. 

  4312.          troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i)
    4313. 

  4313.          th2o(i) = tr8(i)
    4314. 

  4314.       end do
    4315. 

  4315. !
    4316. 

  4316. ! CO2 emissivity for 15 micron band system
    4317. 

  4317. !
    4318. 

  4318.       do i=1,ncol
    4319. 

  4319.          t1i    = exp(-480./co2t(i,k1))
    4320. 

  4320.          sqti   = sqrt(co2t(i,k1))
    4321. 

  4321.          rsqti  = 1./sqti
    4322. 

  4322.          et     = t1i
    4323. 

  4323.          et2    = et*et
    4324. 

  4324.          et4    = et2*et2
    4325. 

  4325.          omet   = 1. - 1.5*et2
    4326. 

  4326.          f1co2  = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
    4327. 

  4327.          sqwp   = sqrt(plco2(i,k1))
    4328. 

  4328.          f1sqwp = f1co2*sqwp
    4329. 

  4329.          t1co2  = 1./(1. + 245.18*omet*sqwp*rsqti)
    4330. 

  4330.          oneme  = 1. - et2
    4331. 

  4331.          alphat = oneme**3*rsqti
    4332. 

  4332.          wco2   = 2.5221*co2vmr*pnm(i,k1)*rga
    4333. 

  4333.          u7     = 4.9411e4*alphat*et2*wco2
    4334. 

  4334.          u8     = 3.9744e4*alphat*et4*wco2
    4335. 

  4335.          u9     = 1.0447e5*alphat*et4*et2*wco2
    4336. 

  4336.          u13    = 2.8388e3*alphat*et4*wco2
    4337. 

  4337. !
    4338. 

  4338.          tpath  = co2t(i,k1)
    4339. 

  4339.          tlocal = tplnke(i)
    4340. 

  4340.          tcrfac = sqrt((tlocal*r250)*(tpath*r300))
    4341. 

  4341.          pi     = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac
    4342. 

  4342.          posqt  = pi/(2.*sqti)
    4343. 

  4343.          rbeta7 =  1./( 5.3288*posqt)
    4344. 

  4344.          rbeta8 = 1./ (10.6576*posqt)
    4345. 

  4345.          rbeta9 = rbeta7
    4346. 

  4346.          rbeta13= rbeta9
    4347. 

  4347.          f2co2  = (u7/sqrt(4. + u7*(1. + rbeta7))) + &
    4348. 

  4348.                   (u8/sqrt(4. + u8*(1. + rbeta8))) + &
    4349. 

  4349.                   (u9/sqrt(4. + u9*(1. + rbeta9)))
    4350. 

  4350.          f3co2  = u13/sqrt(4. + u13*(1. + rbeta13))
    4351. 

  4351.          tmp1   = log(1. + f1sqwp)
    4352. 

  4352.          tmp2   = log(1. +  f2co2)
    4353. 

  4353.          tmp3   = log(1. +  f3co2)
    4354. 

  4354.          absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti
    4355. 

  4355.          tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7))))
    4356. 

  4356.          co2ems(i,k1)  = troco2(i,k1)*absbnd*co2plk(i)
    4357. 

  4357.          ex     = exp(960./tint(i,k1))
    4358. 

  4358.          exm1sq = (ex - 1.)**2
    4359. 

  4359.          co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq)
    4360. 

  4360.       end do
    4361. 

  4361. !
    4362. 

  4362. ! O3 emissivity
    4363. 

  4363. !
    4364. 

  4364.       do i=1,ncol
    4365. 

  4365.          h2otr(i,k1) = exp(-12.*s2c(i,k1))
    4366. 

  4366.           h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200)
    4367. 

  4367.          te          = (co2t(i,k1)/293.)**.7
    4368. 

  4368.          u1          = 18.29*plos(i,k1)/te
    4369. 

  4369.          u2          = .5649*plos(i,k1)/te
    4370. 

  4370.          phat        = plos(i,k1)/plol(i,k1)
    4371. 

  4371.          tlocal      = tplnke(i)
    4372. 

  4372.          tcrfac      = sqrt(tlocal*r250)*te
    4373. 

  4373.          beta        = (1./.3205)*((1./phat) + (dpfo3*tcrfac))
    4374. 

  4374.          realnu      = (1./beta)*te
    4375. 

  4375.          o3bndi      = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu))
    4376. 

  4376.          o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi
    4377. 

  4377.          to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu))
    4378. 

  4378.       end do
    4379. 

  4379. !
    4380. 

  4380. !   Calculate trace gas emissivities
    4381. 

  4381. !
    4382. 

  4382.       call trcems(lchnk   ,ncol    ,pcols, pverp,               &
    4383. 

  4383.                   k1      ,co2t    ,pnm     ,ucfc11  ,ucfc12  , &
    4384. 

  4384.                   un2o0   ,un2o1   ,bn2o0   ,bn2o1   ,uch4    , &
    4385. 

  4385.                   bch4    ,uco211  ,uco212  ,uco213  ,uco221  , &
    4386. 

  4386.                   uco222  ,uco223  ,uptype  ,w       ,s2c     , &
    4387. 

  4387.                   u       ,emplnk  ,th2o    ,tco2    ,to3     , &
    4388. 

  4388.                   emstrc  , &
    4389. 

  4389.                   aer_trn_ttl)
    4390. 

  4390. !
    4391. 

  4391. ! Total emissivity:
    4392. 

  4392. !
    4393. 

  4393.       do i=1,ncol
    4394. 

  4394.          emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1)  &
    4395. 

  4395.                         + emstrc(i,k1)
    4396. 

  4396.       end do
    4397. 

  4397.    end do ! End of interface loop
    4398. 

    4399. 

  4399.    return
    4400. 

  4400. end subroutine radems
    4401. 

    4402. 

  4402. subroutine radtpl(lchnk   ,ncol    ,pcols, pver, pverp,                 &
    4403. 

  4403.                   tnm     ,lwupcgs ,qnm     ,pnm     ,plco2   ,plh2o   , &
    4404. 

  4404.                   tplnka  ,s2c     ,tcg     ,w       ,tplnke  , &
    4405. 

  4405.                   tint    ,tint4   ,tlayr   ,tlayr4  ,pmln    , &
    4406. 

  4406.                   piln    ,plh2ob  ,wb      )
    4407. 

  4407. !--------------------------------------------------------------------
    4408. 

  4408. !
    4409. 

  4409. ! Purpose:
    4410. 

  4410. ! Compute temperatures and path lengths for longwave radiation
    4411. 

  4411. !
    4412. 

  4412. ! Method:
    4413. 

  4413. ! <Describe the algorithm(s) used in the routine.>
    4414. 

  4414. ! <Also include any applicable external references.>
    4415. 

  4415. !
    4416. 

  4416. ! Author: CCM1
    4417. 

  4417. !
    4418. 

  4418. !--------------------------------------------------------------------
    4419. 

    4420. 

  4420. !------------------------------Arguments-----------------------------
    4421. 

  4421. !
    4422. 

  4422. ! Input arguments
    4423. 

  4423. !
    4424. 

  4424.    integer, intent(in) :: lchnk                 ! chunk identifier
    4425. 

  4425.    integer, intent(in) :: ncol                  ! number of atmospheric columns
    4426. 

  4426.    integer, intent(in) :: pcols, pver, pverp
    4427. 

    4428. 

  4428.    real(r8), intent(in) :: tnm(pcols,pver)      ! Model level temperatures
    4429. 

  4429.    real(r8), intent(in) :: lwupcgs(pcols)       ! Surface longwave up flux
    4430. 

  4430.    real(r8), intent(in) :: qnm(pcols,pver)      ! Model level specific humidity
    4431. 

  4431.    real(r8), intent(in) :: pnm(pcols,pverp)     ! Pressure at model interfaces (dynes/cm2)
    4432. 

  4432.    real(r8), intent(in) :: pmln(pcols,pver)     ! Ln(pmidm1)
    4433. 

  4433.    real(r8), intent(in) :: piln(pcols,pverp)    ! Ln(pintm1)
    4434. 

  4434. !
    4435. 

  4435. ! Output arguments
    4436. 

  4436. !
    4437. 

  4437.    real(r8), intent(out) :: plco2(pcols,pverp)   ! Pressure weighted co2 path
    4438. 

  4438.    real(r8), intent(out) :: plh2o(pcols,pverp)   ! Pressure weighted h2o path
    4439. 

  4439.    real(r8), intent(out) :: tplnka(pcols,pverp)  ! Level temperature from interface temperatures
    4440. 

  4440.    real(r8), intent(out) :: s2c(pcols,pverp)     ! H2o continuum path length
    4441. 

  4441.    real(r8), intent(out) :: tcg(pcols,pverp)     ! H2o-mass-wgted temp. (Curtis-Godson approx.)
    4442. 

  4442.    real(r8), intent(out) :: w(pcols,pverp)       ! H2o path length
    4443. 

  4443.    real(r8), intent(out) :: tplnke(pcols)        ! Equal to tplnka
    4444. 

  4444.    real(r8), intent(out) :: tint(pcols,pverp)    ! Layer interface temperature
    4445. 

  4445.    real(r8), intent(out) :: tint4(pcols,pverp)   ! Tint to the 4th power
    4446. 

  4446.    real(r8), intent(out) :: tlayr(pcols,pverp)   ! K-1 level temperature
    4447. 

  4447.    real(r8), intent(out) :: tlayr4(pcols,pverp)  ! Tlayr to the 4th power
    4448. 

  4448.    real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with 
    4449. 

  4449.                                                       !    Hulst-Curtis-Godson temp. factor 
    4450. 

  4450.                                                       !    for H2O bands 
    4451. 

  4451.    real(r8), intent(out) :: wb(nbands,pcols,pverp)    ! H2o path length with 
    4452. 

  4452.                                                       !    Hulst-Curtis-Godson temp. factor 
    4453. 

  4453.                                                       !    for H2O bands 
    4454. 

    4455. 

  4455. !
    4456. 

  4456. !---------------------------Local variables--------------------------
    4457. 

  4457. !
    4458. 

  4458.    integer i                 ! Longitude index
    4459. 

  4459.    integer k                 ! Level index
    4460. 

  4460.    integer kp1               ! Level index + 1
    4461. 

    4462. 

  4462.    real(r8) repsil               ! Inver ratio mol weight h2o to dry air
    4463. 

  4463.    real(r8) dy                   ! Thickness of layer for tmp interp
    4464. 

  4464.    real(r8) dpnm                 ! Pressure thickness of layer
    4465. 

  4465.    real(r8) dpnmsq               ! Prs squared difference across layer
    4466. 

  4466.    real(r8) dw                   ! Increment in H2O path length
    4467. 

  4467.    real(r8) dplh2o               ! Increment in plh2o
    4468. 

  4468.    real(r8) cpwpl                ! Const in co2 mix ratio to path length conversn
    4469. 

    4470. 

  4470. !--------------------------------------------------------------------
    4471. 

  4471. !
    4472. 

  4472.    repsil = 1./epsilo
    4473. 

  4473. !
    4474. 

  4474. ! Compute co2 and h2o paths
    4475. 

  4475. !
    4476. 

  4476.    cpwpl = amco2/amd * 0.5/(gravit*p0)
    4477. 

  4477.    do i=1,ncol
    4478. 

  4478.       plh2o(i,ntoplw)  = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw)
    4479. 

  4479.       plco2(i,ntoplw)  = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw)
    4480. 

  4480.    end do
    4481. 

  4481.    do k=ntoplw,pver
    4482. 

  4482.       do i=1,ncol
    4483. 

  4483.          plh2o(i,k+1)  = plh2o(i,k) + rgsslp* &
    4484. 

  4484.                          (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k)
    4485. 

  4485.          plco2(i,k+1)  = co2vmr*cpwpl*pnm(i,k+1)**2
    4486. 

  4486.       end do
    4487. 

  4487.    end do
    4488. 

  4488. !
    4489. 

  4489. ! Set the top and bottom intermediate level temperatures,
    4490. 

  4490. ! top level planck temperature and top layer temp**4.
    4491. 

  4491. !
    4492. 

  4492. ! Tint is lower interface temperature
    4493. 

  4493. ! (not available for bottom layer, so use ground temperature)
    4494. 

  4494. !
    4495. 

  4495.    do i=1,ncol
    4496. 

  4496.       tint4(i,pverp)   = lwupcgs(i)/stebol
    4497. 

  4497.       tint(i,pverp)    = sqrt(sqrt(tint4(i,pverp)))
    4498. 

  4498.       tplnka(i,ntoplw) = tnm(i,ntoplw)
    4499. 

  4499.       tint(i,ntoplw)   = tplnka(i,ntoplw)
    4500. 

  4500.       tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4
    4501. 

  4501.       tint4(i,ntoplw)  = tlayr4(i,ntoplw)
    4502. 

  4502.    end do
    4503. 

  4503. !
    4504. 

  4504. ! Intermediate level temperatures are computed using temperature
    4505. 

  4505. ! at the full level below less dy*delta t,between the full level
    4506. 

  4506. !
    4507. 

  4507.    do k=ntoplw+1,pver
    4508. 

  4508.       do i=1,ncol
    4509. 

  4509.          dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k))
    4510. 

  4510.          tint(i,k)  = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1))
    4511. 

  4511.          tint4(i,k) = tint(i,k)**4
    4512. 

  4512.       end do
    4513. 

  4513.    end do
    4514. 

  4514. !
    4515. 

  4515. ! Now set the layer temp=full level temperatures and establish a
    4516. 

  4516. ! planck temperature for absorption (tplnka) which is the average
    4517. 

  4517. ! the intermediate level temperatures.  Note that tplnka is not
    4518. 

  4518. ! equal to the full level temperatures.
    4519. 

  4519. !
    4520. 

  4520.    do k=ntoplw+1,pverp
    4521. 

  4521.       do i=1,ncol
    4522. 

  4522.          tlayr(i,k)  = tnm(i,k-1)
    4523. 

  4523.          tlayr4(i,k) = tlayr(i,k)**4
    4524. 

  4524.          tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1))
    4525. 

  4525.       end do
    4526. 

  4526.    end do
    4527. 

  4527. !
    4528. 

  4528. ! Calculate tplank for emissivity calculation.
    4529. 

  4529. ! Assume isothermal tplnke i.e. all levels=ttop.
    4530. 

  4530. !
    4531. 

  4531.    do i=1,ncol
    4532. 

  4532.       tplnke(i)       = tplnka(i,ntoplw)
    4533. 

  4533.       tlayr(i,ntoplw) = tint(i,ntoplw)
    4534. 

  4534.    end do
    4535. 

  4535. !
    4536. 

  4536. ! Now compute h2o path fields:
    4537. 

  4537. !
    4538. 

  4538.    do i=1,ncol
    4539. 

  4539. !
    4540. 

  4540. ! Changed effective path temperature to std. Curtis-Godson form
    4541. 

  4541. !
    4542. 

  4542.       tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw)
    4543. 

  4543.       w(i,ntoplw)   = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw)
    4544. 

  4544. !
    4545. 

  4545. ! Hulst-Curtis-Godson scaling for H2O path
    4546. 

  4546. !
    4547. 

  4547.       wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1)
    4548. 

  4548.       wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2)
    4549. 

  4549. !
    4550. 

  4550. ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
    4551. 

  4551. !
    4552. 

  4552.       plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1)
    4553. 

  4553.       plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2)
    4554. 

    4555. 

  4555.       s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil
    4556. 

  4556.    end do
    4557. 

    4558. 

  4558.    do k=ntoplw,pver
    4559. 

  4559.       do i=1,ncol
    4560. 

  4560.          dpnm       = pnm(i,k+1) - pnm(i,k)
    4561. 

  4561.          dpnmsq     = pnm(i,k+1)**2 - pnm(i,k)**2
    4562. 

  4562.          dw         = rga*qnm(i,k)*dpnm
    4563. 

  4563.          kp1        = k+1
    4564. 

  4564.          w(i,kp1)   = w(i,k) + dw
    4565. 

  4565. !
    4566. 

  4566. ! Hulst-Curtis-Godson scaling for H2O path
    4567. 

  4567. !
    4568. 

  4568.          wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1)
    4569. 

  4569.          wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2)
    4570. 

  4570. !
    4571. 

  4571. ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
    4572. 

  4572. !
    4573. 

  4573.          dplh2o = plh2o(i,kp1) - plh2o(i,k)
    4574. 

    4575. 

  4575.          plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1)
    4576. 

  4576.          plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2)
    4577. 

  4577. !
    4578. 

  4578. ! Changed effective path temperature to std. Curtis-Godson form
    4579. 

  4579. !
    4580. 

  4580.          tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k)
    4581. 

  4581.          s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* &
    4582. 

  4582.                       fh2oself(tnm(i,k))*qnm(i,k)*repsil
    4583. 

  4583.       end do
    4584. 

  4584.    end do
    4585. 

  4585. !
    4586. 

  4586.    return
    4587. 

  4587. end subroutine radtpl
    4588. 

    4589. 

    4590. 

  4590. subroutine radclwmx(lchnk   ,ncol    ,pcols, pver, pverp,         &
    4591. 

  4591.                     lwupcgs ,tnm     ,qnm     ,o3vmr   , &
    4592. 

  4592.                     pmid    ,pint    ,pmln    ,piln    ,          &
    4593. 

  4593.                              n2o     ,ch4     ,cfc11   ,cfc12   , &
    4594. 

  4594.                     cld     ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
    4595. 

  4595.                     doabsems, abstot, absnxt, emstot,             &
    4596. 

  4596.                     flns    ,flnt    ,flnsc   ,flntc   ,flwds   , &
    4597. 

  4597.                     flut    ,flutc   , &
    4598. 

  4598.                     flup    ,flupc   ,fldn    ,fldnc   ,          &
    4599. 

  4599.                     aer_mass)
    4600. 

  4600. !----------------------------------------------------------------------- 
    4601. 

  4601. ! 
    4602. 

  4602. ! Purpose: 
    4603. 

  4603. ! Compute longwave radiation heating rates and boundary fluxes
    4604. 

  4604. ! 
    4605. 

  4605. ! Method: 
    4606. 

  4606. ! Uses broad band absorptivity/emissivity method to compute clear sky;
    4607. 

  4607. ! assumes randomly overlapped clouds with variable cloud emissivity to
    4608. 

  4608. ! include effects of clouds.
    4609. 

  4609. !
    4610. 

  4610. ! Computes clear sky absorptivity/emissivity at lower frequency (in
    4611. 

  4611. ! general) than the model radiation frequency; uses previously computed
    4612. 

  4612. ! and stored values for efficiency
    4613. 

  4613. !
    4614. 

  4614. ! Note: This subroutine contains vertical indexing which proceeds
    4615. 

  4615. !       from bottom to top rather than the top to bottom indexing
    4616. 

  4616. !       used in the rest of the model.
    4617. 

  4617. ! 
    4618. 

  4618. ! Author: B. Collins
    4619. 

  4619. ! 
    4620. 

  4620. !-----------------------------------------------------------------------
    4621. 

  4621. !  use shr_kind_mod, only: r8 => shr_kind_r8
    4622. 

  4622. !  use ppgrid
    4623. 

  4623. !  use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d
    4624. 

  4624. !  use volcrad
    4625. 

    4626. 

  4626.    implicit none
    4627. 

    4628. 

  4628.    integer pverp2,pverp3,pverp4
    4629. 

  4629. !  parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4)
    4630. 

    4631. 

  4631.    real(r8) cldmin
    4632. 

  4632.    parameter (cldmin = 1.0d-80)
    4633. 

  4633. !------------------------------Commons----------------------------------
    4634. 

  4634. !-----------------------------------------------------------------------
    4635. 

  4635. !------------------------------Arguments--------------------------------
    4636. 

  4636. !
    4637. 

  4637. ! Input arguments
    4638. 

  4638. !
    4639. 

  4639.    integer, intent(in) :: lchnk                 ! chunk identifier
    4640. 

  4640.    integer, intent(in) :: pcols, pver, pverp
    4641. 

  4641.    integer, intent(in) :: ncol                  ! number of atmospheric columns
    4642. 

  4642. !    maximally overlapped region.
    4643. 

  4643. !    0->pmxrgn(i,1) is range of pmid for
    4644. 

  4644. !    1st region, pmxrgn(i,1)->pmxrgn(i,2) for
    4645. 

  4645. !    2nd region, etc
    4646. 

  4646.    integer, intent(in) :: nmxrgn(pcols)         ! Number of maximally overlapped regions
    4647. 

  4647.    logical, intent(in) :: doabsems
    4648. 

    4649. 

  4649.    real(r8), intent(in) :: pmxrgn(pcols,pverp)  ! Maximum values of pmid for each
    4650. 

  4650.    real(r8), intent(in) :: lwupcgs(pcols)       ! Longwave up flux in CGS units
    4651. 

  4651. !
    4652. 

  4652. ! Input arguments which are only passed to other routines
    4653. 

  4653. !
    4654. 

  4654.    real(r8), intent(in) :: tnm(pcols,pver)      ! Level temperature
    4655. 

  4655.    real(r8), intent(in) :: qnm(pcols,pver)      ! Level moisture field
    4656. 

  4656.    real(r8), intent(in) :: o3vmr(pcols,pver)    ! ozone volume mixing ratio
    4657. 

  4657.    real(r8), intent(in) :: pmid(pcols,pver)     ! Level pressure
    4658. 

  4658.    real(r8), intent(in) :: pint(pcols,pverp)    ! Model interface pressure
    4659. 

  4659.    real(r8), intent(in) :: pmln(pcols,pver)     ! Ln(pmid)
    4660. 

  4660.    real(r8), intent(in) :: piln(pcols,pverp)    ! Ln(pint)
    4661. 

  4661.    real(r8), intent(in) :: n2o(pcols,pver)      ! nitrous oxide mass mixing ratio
    4662. 

  4662.    real(r8), intent(in) :: ch4(pcols,pver)      ! methane mass mixing ratio
    4663. 

  4663.    real(r8), intent(in) :: cfc11(pcols,pver)    ! cfc11 mass mixing ratio
    4664. 

  4664.    real(r8), intent(in) :: cfc12(pcols,pver)    ! cfc12 mass mixing ratio
    4665. 

  4665.    real(r8), intent(in) :: cld(pcols,pver)      ! Cloud cover
    4666. 

  4666.    real(r8), intent(in) :: emis(pcols,pver)     ! Cloud emissivity
    4667. 

  4667.    real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer
    4668. 

    4669. 

  4669. !
    4670. 

  4670. ! Output arguments
    4671. 

  4671. !
    4672. 

  4672.    real(r8), intent(out) :: qrl(pcols,pver)      ! Longwave heating rate
    4673. 

  4673.    real(r8), intent(out) :: flns(pcols)          ! Surface cooling flux
    4674. 

  4674.    real(r8), intent(out) :: flnt(pcols)          ! Net outgoing flux
    4675. 

  4675.    real(r8), intent(out) :: flut(pcols)          ! Upward flux at top of model
    4676. 

  4676.    real(r8), intent(out) :: flnsc(pcols)         ! Clear sky surface cooing
    4677. 

  4677.    real(r8), intent(out) :: flntc(pcols)         ! Net clear sky outgoing flux
    4678. 

  4678.    real(r8), intent(out) :: flutc(pcols)         ! Upward clear-sky flux at top of model
    4679. 

  4679.    real(r8), intent(out) :: flwds(pcols)         ! Down longwave flux at surface
    4680. 

  4680. ! Added downward/upward total and clear sky fluxes
    4681. 

  4681.    real(r8), intent(out) :: flup(pcols,pverp)      ! Total sky upward longwave flux 
    4682. 

  4682.    real(r8), intent(out) :: flupc(pcols,pverp)     ! Clear sky upward longwave flux 
    4683. 

  4683.    real(r8), intent(out) :: fldn(pcols,pverp)      ! Total sky downward longwave flux 
    4684. 

  4684.    real(r8), intent(out) :: fldnc(pcols,pverp)     ! Clear sky downward longwave flux
    4685. 

  4685. !
    4686. 

  4686.    real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
    4687. 

  4687.    real(r8), intent(inout) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
    4688. 

  4688.    real(r8), intent(inout) :: emstot(pcols,pverp)     ! Total emissivity
    4689. 

    4690. 

  4690. !---------------------------Local variables-----------------------------
    4691. 

  4691. !
    4692. 

  4692.    integer i                 ! Longitude index
    4693. 

  4693.    integer ilon              ! Longitude index
    4694. 

  4694.    integer ii                ! Longitude index
    4695. 

  4695.    integer iimx              ! Longitude index (max overlap)
    4696. 

  4696.    integer k                 ! Level index
    4697. 

  4697.    integer k1                ! Level index
    4698. 

  4698.    integer k2                ! Level index
    4699. 

  4699.    integer k3                ! Level index
    4700. 

  4700.    integer km                ! Level index
    4701. 

  4701.    integer km1               ! Level index
    4702. 

  4702.    integer km3               ! Level index
    4703. 

  4703.    integer km4               ! Level index
    4704. 

  4704.    integer irgn              ! Index for max-overlap regions
    4705. 

  4705.    integer l                 ! Index for clouds to overlap
    4706. 

  4706.    integer l1                ! Index for clouds to overlap
    4707. 

  4707.    integer n                 ! Counter
    4708. 

    4709. 

  4709. !
    4710. 

  4710.    real(r8) :: plco2(pcols,pverp)   ! Path length co2
    4711. 

  4711.    real(r8) :: plh2o(pcols,pverp)   ! Path length h2o
    4712. 

  4712.    real(r8) tmp(pcols)           ! Temporary workspace
    4713. 

  4713.    real(r8) tmp2(pcols)          ! Temporary workspace
    4714. 

  4714.    real(r8) absbt(pcols)         ! Downward emission at model top
    4715. 

  4715.    real(r8) plol(pcols,pverp)    ! O3 pressure wghted path length
    4716. 

  4716.    real(r8) plos(pcols,pverp)    ! O3 path length
    4717. 

  4717.    real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level
    4718. 

  4718.    real(r8) co2em(pcols,pverp)   ! Layer co2 normalized planck funct. derivative
    4719. 

  4719.    real(r8) co2eml(pcols,pver)   ! Interface co2 normalized planck funct. deriv.
    4720. 

  4720.    real(r8) delt(pcols)          ! Diff t**4 mid layer to top interface
    4721. 

  4721.    real(r8) delt1(pcols)         ! Diff t**4 lower intrfc to mid layer
    4722. 

  4722.    real(r8) bk1(pcols)           ! Absrptvty for vertical quadrature
    4723. 

  4723.    real(r8) bk2(pcols)           ! Absrptvty for vertical quadrature
    4724. 

  4724.    real(r8) cldp(pcols,pverp)    ! Cloud cover with extra layer
    4725. 

  4725.    real(r8) ful(pcols,pverp)     ! Total upwards longwave flux
    4726. 

  4726.    real(r8) fsul(pcols,pverp)    ! Clear sky upwards longwave flux
    4727. 

  4727.    real(r8) fdl(pcols,pverp)     ! Total downwards longwave flux
    4728. 

  4728.    real(r8) fsdl(pcols,pverp)    ! Clear sky downwards longwv flux
    4729. 

  4729.    real(r8) fclb4(pcols,-1:pver)    ! Sig t**4 for cld bottom interfc
    4730. 

  4730.    real(r8) fclt4(pcols,0:pver)    ! Sig t**4 for cloud top interfc
    4731. 

  4731.    real(r8) s(pcols,pverp,pverp) ! Flx integral sum
    4732. 

  4732.    real(r8) tplnka(pcols,pverp)  ! Planck fnctn temperature
    4733. 

  4733.    real(r8) s2c(pcols,pverp)     ! H2o cont amount
    4734. 

  4734.    real(r8) tcg(pcols,pverp)     ! H2o-mass-wgted temp. (Curtis-Godson approx.)
    4735. 

  4735.    real(r8) w(pcols,pverp)       ! H2o path
    4736. 

  4736.    real(r8) tplnke(pcols)        ! Planck fnctn temperature
    4737. 

  4737.    real(r8) h2otr(pcols,pverp)   ! H2o trnmsn for o3 overlap
    4738. 

  4738.    real(r8) co2t(pcols,pverp)    ! Prs wghted temperature path
    4739. 

  4739.    real(r8) tint(pcols,pverp)    ! Interface temperature
    4740. 

  4740.    real(r8) tint4(pcols,pverp)   ! Interface temperature**4
    4741. 

  4741.    real(r8) tlayr(pcols,pverp)   ! Level temperature
    4742. 

  4742.    real(r8) tlayr4(pcols,pverp)  ! Level temperature**4
    4743. 

  4743.    real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with 
    4744. 

  4744.                                       !    Hulst-Curtis-Godson temp. factor 
    4745. 

  4745.                                       !    for H2O bands 
    4746. 

  4746.    real(r8) wb(nbands,pcols,pverp)    ! H2o path length with 
    4747. 

  4747.                                       !    Hulst-Curtis-Godson temp. factor 
    4748. 

  4748.                                       !    for H2O bands 
    4749. 

    4750. 

  4750.    real(r8) cld0                 ! previous cloud amt (for max overlap)
    4751. 

  4751.    real(r8) cld1                 ! next cloud amt (for max overlap)
    4752. 

  4752.    real(r8) emx(0:pverp)         ! Emissivity factors (max overlap)
    4753. 

  4753.    real(r8) emx0                 ! Emissivity factors for BCs (max overlap)
    4754. 

  4754.    real(r8) trans                ! 1 - emis
    4755. 

  4755.    real(r8) asort(pver)          ! 1 - cloud amounts to be sorted for max ovrlp.
    4756. 

  4756.    real(r8) atmp                 ! Temporary storage for sort when nxs = 2
    4757. 

  4757.    real(r8) maxcld(pcols)        ! Maximum cloud at any layer
    4758. 

    4759. 

  4759.    integer indx(pcols)       ! index vector of gathered array values
    4760. 

  4760. !!$   integer indxmx(pcols+1,pverp)! index vector of gathered array values
    4761. 

  4761.    integer indxmx(pcols,pverp)! index vector of gathered array values
    4762. 

  4762. !    (max overlap)
    4763. 

  4763.    integer nrgn(pcols)       ! Number of max overlap regions at longitude
    4764. 

  4764.    integer npts              ! number of values satisfying some criterion
    4765. 

  4765.    integer ncolmx(pverp)     ! number of columns with clds in region
    4766. 

  4766.    integer kx1(pcols,pverp)  ! Level index for top of max-overlap region
    4767. 

  4767.    integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region
    4768. 

  4768.    integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld()
    4769. 

  4769. !    in descending order
    4770. 

  4770.    integer nxs(pcols,pverp)  ! Number of cloudy layers between kx1 and kx2
    4771. 

  4771.    integer nxsk              ! Number of cloudy layers between (kx1/kx2)&k
    4772. 

  4772.    integer ksort(0:pverp)    ! Level indices of cloud amounts to be sorted
    4773. 

  4773. !    for max ovrlp. calculation
    4774. 

  4774.    integer ktmp              ! Temporary storage for sort when nxs = 2
    4775. 

    4776. 

  4776. !  real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
    4777. 

  4777.   real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
    4778. 

  4778. !                               ! transmission between interfaces k1 and k2  
    4779. 

  4779. !
    4780. 

  4780. ! Pointer variables to 3d structures
    4781. 

  4781. !
    4782. 

  4782. !  real(r8), pointer :: abstot(:,:,:)
    4783. 

  4783. !  real(r8), pointer :: absnxt(:,:,:)
    4784. 

  4784. !  real(r8), pointer :: emstot(:,:)
    4785. 

    4786. 

  4786. !
    4787. 

  4787. ! Trace gas variables
    4788. 

  4788. !
    4789. 

  4789.    real(r8) ucfc11(pcols,pverp)  ! CFC11 path length
    4790. 

  4790.    real(r8) ucfc12(pcols,pverp)  ! CFC12 path length
    4791. 

  4791.    real(r8) un2o0(pcols,pverp)   ! N2O path length
    4792. 

  4792.    real(r8) un2o1(pcols,pverp)   ! N2O path length (hot band)
    4793. 

  4793.    real(r8) uch4(pcols,pverp)    ! CH4 path length
    4794. 

  4794.    real(r8) uco211(pcols,pverp)  ! CO2 9.4 micron band path length
    4795. 

  4795.    real(r8) uco212(pcols,pverp)  ! CO2 9.4 micron band path length
    4796. 

  4796.    real(r8) uco213(pcols,pverp)  ! CO2 9.4 micron band path length
    4797. 

  4797.    real(r8) uco221(pcols,pverp)  ! CO2 10.4 micron band path length
    4798. 

  4798.    real(r8) uco222(pcols,pverp)  ! CO2 10.4 micron band path length
    4799. 

  4799.    real(r8) uco223(pcols,pverp)  ! CO2 10.4 micron band path length
    4800. 

  4800.    real(r8) bn2o0(pcols,pverp)   ! pressure factor for n2o
    4801. 

  4801.    real(r8) bn2o1(pcols,pverp)   ! pressure factor for n2o
    4802. 

  4802.    real(r8) bch4(pcols,pverp)    ! pressure factor for ch4
    4803. 

  4803.    real(r8) uptype(pcols,pverp)  ! p-type continuum path length
    4804. 

  4804.    real(r8) abplnk1(14,pcols,pverp)  ! non-nearest layer Plack factor
    4805. 

  4805.    real(r8) abplnk2(14,pcols,pverp)  ! nearest layer factor
    4806. 

  4806. !
    4807. 

  4807. !
    4808. 

  4808. !-----------------------------------------------------------------------
    4809. 

  4809. !
    4810. 

  4810. !
    4811. 

  4811.    pverp2=pver+2
    4812. 

  4812.    pverp3=pver+3
    4813. 

  4813.    pverp4=pver+4
    4814. 

  4814. !
    4815. 

  4815. ! Set pointer variables
    4816. 

  4816. !
    4817. 

  4817. !  abstot => abstot_3d(:,:,:,lchnk)
    4818. 

  4818. !  absnxt => absnxt_3d(:,:,:,lchnk)
    4819. 

  4819. !  emstot => emstot_3d(:,:,lchnk)
    4820. 

  4820. !
    4821. 

  4821. ! accumulate mass path from top of atmosphere
    4822. 

  4822. !
    4823. 

  4823.   call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp)
    4824. 

    4825. 

  4825. !
    4826. 

  4826. ! Calculate some temperatures needed to derive absorptivity and
    4827. 

  4827. ! emissivity, as well as some h2o path lengths
    4828. 

  4828. !
    4829. 

  4829.    call radtpl(lchnk   ,ncol    ,pcols, pver, pverp,                  &
    4830. 

  4830.                tnm     ,lwupcgs ,qnm     ,pint    ,plco2   ,plh2o   , &
    4831. 

  4831.                tplnka  ,s2c     ,tcg     ,w       ,tplnke  , &
    4832. 

  4832.                tint    ,tint4   ,tlayr   ,tlayr4  ,pmln    , &
    4833. 

  4833.                piln    ,plh2ob  ,wb      )
    4834. 

  4834.    if (doabsems) then
    4835. 

  4835. !
    4836. 

  4836. ! Compute ozone path lengths at frequency of a/e calculation.
    4837. 

  4837. !
    4838. 

  4838.       call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr   ,pint    ,plol    ,plos, ntoplw    )
    4839. 

  4839. !
    4840. 

  4840. ! Compute trace gas path lengths
    4841. 

  4841. !
    4842. 

  4842.       call trcpth(lchnk   ,ncol    ,pcols, pver, pverp,         &
    4843. 

  4843.                   tnm     ,pint    ,cfc11   ,cfc12   ,n2o     , &
    4844. 

  4844.                   ch4     ,qnm     ,ucfc11  ,ucfc12  ,un2o0   , &
    4845. 

  4845.                   un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
    4846. 

  4846.                   uco221  ,uco222  ,uco223  ,bn2o0   ,bn2o1   , &
    4847. 

  4847.                   bch4    ,uptype  )
    4848. 

    4849. 

  4849. !     Compute transmission through STRAER absorption continuum
    4850. 

  4850.       call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp)
    4851. 

    4852. 

  4852. !
    4853. 

  4853. !
    4854. 

  4854. ! Compute total emissivity:
    4855. 

  4855. !
    4856. 

  4856.       call radems(lchnk   ,ncol    ,pcols, pver, pverp,         &
    4857. 

  4857.                   s2c     ,tcg     ,w       ,tplnke  ,plh2o   , &
    4858. 

  4858.                   pint    ,plco2   ,tint    ,tint4   ,tlayr   , &
    4859. 

  4859.                   tlayr4  ,plol    ,plos    ,ucfc11  ,ucfc12  , &
    4860. 

  4860.                   un2o0   ,un2o1   ,uch4    ,uco211  ,uco212  , &
    4861. 

  4861.                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
    4862. 

  4862.                   bn2o0   ,bn2o1   ,bch4    ,co2em   ,co2eml  , &
    4863. 

  4863.                   co2t    ,h2otr   ,abplnk1 ,abplnk2 ,emstot  , &
    4864. 

  4864.                   plh2ob  ,wb      , &
    4865. 

  4865.                   aer_trn_ttl)
    4866. 

  4866. !
    4867. 

  4867. ! Compute total absorptivity:
    4868. 

  4868. !
    4869. 

  4869.       call radabs(lchnk   ,ncol    ,pcols, pver, pverp,         &
    4870. 

  4870.                   pmid    ,pint    ,co2em   ,co2eml  ,tplnka  , &
    4871. 

  4871.                   s2c     ,tcg     ,w       ,h2otr   ,plco2   , &
    4872. 

  4872.                   plh2o   ,co2t    ,tint    ,tlayr   ,plol    , &
    4873. 

  4873.                   plos    ,pmln    ,piln    ,ucfc11  ,ucfc12  , &
    4874. 

  4874.                   un2o0   ,un2o1   ,uch4    ,uco211  ,uco212  , &
    4875. 

  4875.                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
    4876. 

  4876.                   bn2o0   ,bn2o1   ,bch4    ,abplnk1 ,abplnk2 , &
    4877. 

  4877.                   abstot  ,absnxt  ,plh2ob  ,wb      , &
    4878. 

  4878.                   aer_mpp ,aer_trn_ttl)
    4879. 

  4879.    end if
    4880. 

  4880. !
    4881. 

  4881. ! Compute sums used in integrals (all longitude points)
    4882. 

  4882. !
    4883. 

  4883. ! Definition of bk1 & bk2 depends on finite differencing.  for
    4884. 

  4884. ! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent
    4885. 

  4885. ! layers only.
    4886. 

  4886. !
    4887. 

  4887. ! delt=t**4 in layer above current sigma level km.
    4888. 

  4888. ! delt1=t**4 in layer below current sigma level km.
    4889. 

  4889. !
    4890. 

  4890.    do i=1,ncol
    4891. 

  4891.       delt(i) = tint4(i,pver) - tlayr4(i,pverp)
    4892. 

  4892.       delt1(i) = tlayr4(i,pverp) - tint4(i,pverp)
    4893. 

  4893.       s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4))
    4894. 

  4894.       s(i,pver,pverp)  = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3))
    4895. 

  4895.    end do
    4896. 

  4896.    do k=ntoplw,pver-1
    4897. 

  4897.       do i=1,ncol
    4898. 

  4898.          bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5
    4899. 

  4899.          bk1(i) = bk2(i)
    4900. 

  4900.          s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
    4901. 

  4901.       end do
    4902. 

  4902.    end do
    4903. 

  4903. !
    4904. 

  4904. ! All k, km>1
    4905. 

  4905. !
    4906. 

  4906.    do km=pver,ntoplw+1,-1
    4907. 

  4907.       do i=1,ncol
    4908. 

  4908.          delt(i)  = tint4(i,km-1) - tlayr4(i,km)
    4909. 

  4909.          delt1(i) = tlayr4(i,km) - tint4(i,km)
    4910. 

  4910.       end do
    4911. 

  4911.       do k=pverp,ntoplw,-1
    4912. 

  4912.          if (k == km) then
    4913. 

  4913.             do i=1,ncol
    4914. 

  4914.                bk2(i) = absnxt(i,km-1,4)
    4915. 

  4915.                bk1(i) = absnxt(i,km-1,1)
    4916. 

  4916.             end do
    4917. 

  4917.          else if (k == km-1) then
    4918. 

  4918.             do i=1,ncol
    4919. 

  4919.                bk2(i) = absnxt(i,km-1,2)
    4920. 

  4920.                bk1(i) = absnxt(i,km-1,3)
    4921. 

  4921.             end do
    4922. 

  4922.          else
    4923. 

  4923.             do i=1,ncol
    4924. 

  4924.                bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5
    4925. 

  4925.                bk1(i) = bk2(i)
    4926. 

  4926.             end do
    4927. 

  4927.          end if
    4928. 

  4928.          do i=1,ncol
    4929. 

  4929.             s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
    4930. 

  4930.          end do
    4931. 

  4931.       end do
    4932. 

  4932.    end do
    4933. 

  4933. !
    4934. 

  4934. ! Computation of clear sky fluxes always set first level of fsul
    4935. 

  4935. !
    4936. 

  4936.    do i=1,ncol
    4937. 

  4937.       fsul(i,pverp) = lwupcgs(i)
    4938. 

  4938.    end do
    4939. 

  4939. !
    4940. 

  4940. ! Downward clear sky fluxes store intermediate quantities in down flux
    4941. 

  4941. ! Initialize fluxes to clear sky values.
    4942. 

  4942. !
    4943. 

  4943.    do i=1,ncol
    4944. 

  4944.       tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp)
    4945. 

  4945.       fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1)
    4946. 

  4946.       fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw)
    4947. 

  4947.    end do
    4948. 

  4948. !
    4949. 

  4949. ! fsdl(i,pverp) assumes isothermal layer
    4950. 

  4950. !
    4951. 

  4951.    do k=ntoplw+1,pver
    4952. 

  4952.       do i=1,ncol
    4953. 

  4953.          fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1)
    4954. 

  4954.          fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1))
    4955. 

  4955.       end do
    4956. 

  4956.    end do
    4957. 

  4957. !
    4958. 

  4958. ! Store the downward emission from level 1 = total gas emission * sigma
    4959. 

  4959. ! t**4.  fsdl does not yet include all terms
    4960. 

  4960. !
    4961. 

  4961.    do i=1,ncol
    4962. 

  4962.       absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp)
    4963. 

  4963.       fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1)
    4964. 

  4964.    end do
    4965. 

  4965. !
    4966. 

  4966. !----------------------------------------------------------------------
    4967. 

  4967. ! Modifications for clouds -- max/random overlap assumption
    4968. 

  4968. !
    4969. 

  4969. ! The column is divided into sets of adjacent layers, called regions,
    4970. 

  4970. !   in which the clouds are maximally overlapped.  The clouds are
    4971. 

  4971. !   randomly overlapped between different regions.  The number of
    4972. 

  4972. !   regions in a column is set by nmxrgn, and the range of pressures
    4973. 

  4973. !   included in each region is set by pmxrgn.  The max/random overlap
    4974. 

  4974. !   can be written in terms of the solutions of random overlap with
    4975. 

  4975. !   cloud amounts = 1.  The random overlap assumption is equivalent to
    4976. 

  4976. !   setting the flux boundary conditions (BCs) at the edges of each region
    4977. 

  4977. !   equal to the mean all-sky flux at those boundaries.  Since the
    4978. 

  4978. !   emissivity array for propogating BCs is only computed for the
    4979. 

  4979. !   TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated
    4980. 

  4980. !   in terms of solutions to the random overlap equations.  This is done
    4981. 

  4981. !   by writing the flux BCs as the sum of a clear-sky flux and emission
    4982. 

  4982. !   from a cloud outside the region weighted by an emissivity.  This
    4983. 

  4983. !   emissivity is determined from the location of the cloud and the
    4984. 

  4984. !   flux BC.
    4985. 

  4985. !
    4986. 

  4986. ! Copy cloud amounts to buffer with extra layer (needed for overlap logic)
    4987. 

  4987. !
    4988. 

  4988.    cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver)
    4989. 

  4989.    cldp(:ncol,pverp) = 0.0
    4990. 

  4990. !
    4991. 

  4991. !
    4992. 

  4992. ! Select only those locations where there are no clouds
    4993. 

  4993. !    (maximum cloud fraction <= 1.e-3 treated as clear)
    4994. 

  4994. !    Set all-sky fluxes to clear-sky values.
    4995. 

  4995. !
    4996. 

  4996.    maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2)
    4997. 

    4998. 

  4998.    npts = 0
    4999. 

  4999.    do i=1,ncol
    5000. 

  5000.       if (maxcld(i) < cldmin) then
    5001. 

  5001.          npts = npts + 1
    5002. 

  5002.          indx(npts) = i
    5003. 

  5003.       end if
    5004. 

  5004.    end do
    5005. 

    5006. 

  5006.    do ii = 1, npts
    5007. 

  5007.       i = indx(ii)
    5008. 

  5008.       do k = ntoplw, pverp
    5009. 

  5009.          fdl(i,k) = fsdl(i,k)
    5010. 

  5010.          ful(i,k) = fsul(i,k)
    5011. 

  5011.       end do
    5012. 

  5012.    end do
    5013. 

  5013. !
    5014. 

  5014. ! Select only those locations where there are clouds
    5015. 

  5015. !
    5016. 

  5016.    npts = 0
    5017. 

  5017.    do i=1,ncol
    5018. 

  5018.       if (maxcld(i) >= cldmin) then
    5019. 

  5019.          npts = npts + 1
    5020. 

  5020.          indx(npts) = i
    5021. 

  5021.       end if
    5022. 

  5022.    end do
    5023. 

    5024. 

  5024. !
    5025. 

  5025. ! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions
    5026. 

  5026. !
    5027. 

  5027.    do ii = 1, npts
    5028. 

  5028.       i = indx(ii)
    5029. 

  5029.       fdl(i,ntoplw) = fsdl(i,ntoplw)
    5030. 

  5030.       fdl(i,pverp)  = 0.0
    5031. 

  5031.       ful(i,ntoplw) = 0.0
    5032. 

  5032.       ful(i,pverp)  = fsul(i,pverp)
    5033. 

  5033.       do k = ntoplw+1, pver
    5034. 

  5034.          fdl(i,k) = 0.0
    5035. 

  5035.          ful(i,k) = 0.0
    5036. 

  5036.       end do
    5037. 

  5037. !
    5038. 

  5038. ! Initialize Planck emission from layer boundaries
    5039. 

  5039. !
    5040. 

  5040.       do k = ntoplw, pver
    5041. 

  5041.          fclt4(i,k-1) = stebol*tint4(i,k)
    5042. 

  5042.          fclb4(i,k-1) = stebol*tint4(i,k+1)
    5043. 

  5043.       enddo
    5044. 

  5044.       fclb4(i,ntoplw-2) =  stebol*tint4(i,ntoplw)
    5045. 

  5045.       fclt4(i,pver)     = stebol*tint4(i,pverp)
    5046. 

  5046. !
    5047. 

  5047. ! Initialize indices for layers to be max-overlapped
    5048. 

  5048. !
    5049. 

  5049.       do irgn = 0, nmxrgn(i)
    5050. 

  5050.          kx2(i,irgn) = ntoplw-1
    5051. 

  5051.       end do
    5052. 

  5052.       nrgn(i) = 0
    5053. 

  5053.    end do
    5054. 

    5055. 

  5055. !----------------------------------------------------------------------
    5056. 

  5056. ! INDEX CALCULATIONS FOR MAX OVERLAP
    5057. 

    5058. 

  5058.    do ii = 1, npts
    5059. 

  5059.       ilon = indx(ii)
    5060. 

    5061. 

  5061. !
    5062. 

  5062. ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
    5063. 

  5063. !
    5064. 

  5064.       do irgn = 1, nmxrgn(ilon)
    5065. 

  5065. !
    5066. 

  5066. ! Calculate min/max layer indices inside region.
    5067. 

  5067. !
    5068. 

  5068.          n = 0
    5069. 

  5069.          if (kx2(ilon,irgn-1) < pver) then
    5070. 

  5070.             nrgn(ilon) = irgn
    5071. 

  5071.             k1 = kx2(ilon,irgn-1)+1
    5072. 

  5072.             kx1(ilon,irgn) = k1
    5073. 

  5073.             kx2(ilon,irgn) = 0
    5074. 

  5074.             do k2 = pver, k1, -1
    5075. 

  5075.                if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then
    5076. 

  5076.                   kx2(ilon,irgn) = k2
    5077. 

  5077.                   exit
    5078. 

  5078.                end if
    5079. 

  5079.             end do
    5080. 

  5080. !
    5081. 

  5081. ! Identify columns with clouds in the given region.
    5082. 

  5082. !
    5083. 

  5083.             do k = k1, k2
    5084. 

  5084.                if (cldp(ilon,k) >= cldmin) then
    5085. 

  5085.                   n = n+1
    5086. 

  5086.                   indxmx(n,irgn) = ilon
    5087. 

  5087.                   exit
    5088. 

  5088.                endif
    5089. 

  5089.             end do
    5090. 

  5090.          endif
    5091. 

  5091.          ncolmx(irgn) = n
    5092. 

  5092. !
    5093. 

  5093. ! Dummy value for handling clear-sky regions
    5094. 

  5094. !
    5095. 

  5095. !!$         indxmx(ncolmx(irgn)+1,irgn) = ncol+1
    5096. 

  5096. !
    5097. 

  5097. ! Outer loop over columns with clouds in the max-overlap region
    5098. 

  5098. !
    5099. 

  5099.          do iimx = 1, ncolmx(irgn)
    5100. 

  5100.             i = indxmx(iimx,irgn)
    5101. 

  5101. !
    5102. 

  5102. ! Sort cloud areas and corresponding level indices.
    5103. 

  5103. !
    5104. 

  5104.             n = 0
    5105. 

  5105.             do k = kx1(i,irgn),kx2(i,irgn)
    5106. 

  5106.                if (cldp(i,k) >= cldmin) then
    5107. 

  5107.                   n = n+1
    5108. 

  5108.                   ksort(n) = k
    5109. 

  5109. !
    5110. 

  5110. ! We need indices for clouds in order of largest to smallest, so
    5111. 

  5111. !    sort 1-cld in ascending order
    5112. 

  5112. !
    5113. 

  5113.                   asort(n) = 1.0-cldp(i,k)
    5114. 

  5114.                end if
    5115. 

  5115.             end do
    5116. 

  5116.             nxs(i,irgn) = n
    5117. 

  5117. !
    5118. 

  5118. ! If nxs(i,irgn) eq 1, no need to sort.
    5119. 

  5119. ! If nxs(i,irgn) eq 2, sort by swapping if necessary
    5120. 

  5120. ! If nxs(i,irgn) ge 3, sort using local sort routine
    5121. 

  5121. !
    5122. 

  5122.             if (nxs(i,irgn) == 2) then
    5123. 

  5123.                if (asort(2) < asort(1)) then
    5124. 

  5124.                   ktmp = ksort(1)
    5125. 

  5125.                   ksort(1) = ksort(2)
    5126. 

  5126.                   ksort(2) = ktmp
    5127. 

    5128. 

  5128.                   atmp = asort(1)
    5129. 

  5129.                   asort(1) = asort(2)
    5130. 

  5130.                   asort(2) = atmp
    5131. 

  5131.                endif
    5132. 

  5132.             else if (nxs(i,irgn) >= 3) then
    5133. 

  5133.                call sortarray(nxs(i,irgn),asort,ksort(1:))
    5134. 

  5134.             endif
    5135. 

    5136. 

  5136.             do l = 1, nxs(i,irgn)
    5137. 

  5137.                kxs(l,i,irgn) = ksort(l)
    5138. 

  5138.             end do
    5139. 

  5139. !
    5140. 

  5140. ! End loop over longitude i for fluxes
    5141. 

  5141. !
    5142. 

  5142.          end do
    5143. 

  5143. !
    5144. 

  5144. ! End loop over regions irgn for max-overlap
    5145. 

  5145. !
    5146. 

  5146.       end do
    5147. 

  5147. !
    5148. 

  5148. !----------------------------------------------------------------------
    5149. 

  5149. ! DOWNWARD FLUXES:
    5150. 

  5150. ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
    5151. 

  5151. !
    5152. 

  5152.       do irgn = 1, nmxrgn(ilon)
    5153. 

  5153. !
    5154. 

  5154. ! Compute clear-sky fluxes for regions without clouds
    5155. 

  5155. !
    5156. 

  5156.          iimx = 1
    5157. 

  5157.          if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
    5158. 

  5158. !
    5159. 

  5159. ! Calculate emissivity so that downward flux at upper boundary of region
    5160. 

  5160. !    can be cast in form of solution for downward flux from cloud above
    5161. 

  5161. !    that boundary.  Then solutions for fluxes at other levels take form of
    5162. 

  5162. !    random overlap expressions.  Try to locate "cloud" as close as possible
    5163. 

  5163. !    to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
    5164. 

  5164. !
    5165. 

  5165.             k1 = kx1(ilon,irgn)
    5166. 

  5166.             do km1 = ntoplw-2, k1-2
    5167. 

  5167.                km4 = km1+3
    5168. 

  5168.                k2 = k1
    5169. 

  5169.                k3 = k2+1
    5170. 

  5170.                tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
    5171. 

  5171.                emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ &
    5172. 

  5172.                       ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1))
    5173. 

  5173.                if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
    5174. 

  5174.             end do
    5175. 

  5175.             km1 = min(km1,k1-2)
    5176. 

  5176.             do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1
    5177. 

  5177.                k3 = k2+1
    5178. 

  5178.                tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
    5179. 

  5179.                fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + &
    5180. 

  5180.                                emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))
    5181. 

  5181.             end do
    5182. 

  5182.          else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
    5183. 

  5183.             iimx = iimx+1
    5184. 

  5184.          end if
    5185. 

  5185. !
    5186. 

  5186. ! Outer loop over columns with clouds in the max-overlap region
    5187. 

  5187. !
    5188. 

  5188.          do iimx = 1, ncolmx(irgn)
    5189. 

  5189.             i = indxmx(iimx,irgn)
    5190. 

    5191. 

  5191. !
    5192. 

  5192. ! Calculate emissivity so that downward flux at upper boundary of region
    5193. 

  5193. !    can be cast in form of solution for downward flux from cloud above that
    5194. 

  5194. !    boundary.  Then solutions for fluxes at other levels take form of
    5195. 

  5195. !    random overlap expressions.  Try to locate "cloud" as close as possible
    5196. 

  5196. !    to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
    5197. 

  5197. !
    5198. 

  5198.             k1 = kx1(i,irgn)
    5199. 

  5199.             do km1 = ntoplw-2,k1-2
    5200. 

  5200.                km4 = km1+3
    5201. 

  5201.                k2 = k1
    5202. 

  5202.                k3 = k2 + 1
    5203. 

  5203.                tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
    5204. 

  5204.                tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4)
    5205. 

  5205.                emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1))
    5206. 

  5206.                if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
    5207. 

  5207.             end do
    5208. 

  5208.             km1 = min(km1,k1-2)
    5209. 

  5209.             ksort(0) = km1 + 1
    5210. 

  5210. !
    5211. 

  5211. ! Loop to calculate fluxes at level k
    5212. 

  5212. !
    5213. 

  5213.             nxsk = 0
    5214. 

  5214.             do k = kx1(i,irgn), kx2(i,irgn)
    5215. 

  5215. !
    5216. 

  5216. ! Identify clouds (largest to smallest area) between kx1 and k
    5217. 

  5217. !    Since nxsk will increase with increasing k up to nxs(i,irgn), once
    5218. 

  5218. !    nxsk == nxs(i,irgn) then use the list constructed for previous k
    5219. 

  5219. !
    5220. 

  5220.                if (nxsk < nxs(i,irgn)) then
    5221. 

  5221.                   nxsk = 0
    5222. 

  5222.                   do l = 1, nxs(i,irgn)
    5223. 

  5223.                      k1 = kxs(l,i,irgn)
    5224. 

  5224.                      if (k >= k1) then
    5225. 

  5225.                         nxsk = nxsk + 1
    5226. 

  5226.                         ksort(nxsk) = k1
    5227. 

  5227.                      endif
    5228. 

  5228.                   end do
    5229. 

  5229.                endif
    5230. 

  5230. !
    5231. 

  5231. ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
    5232. 

  5232. !
    5233. 

  5233.                ksort(nxsk+1) = pverp
    5234. 

  5234. !
    5235. 

  5235. ! Initialize iterated emissivity factors
    5236. 

  5236. !
    5237. 

  5237.                do l = 1, nxsk
    5238. 

  5238.                   emx(l) = emis(i,ksort(l))
    5239. 

  5239.                end do
    5240. 

  5240. !
    5241. 

  5241. ! Initialize iterated emissivity factor for bnd. condition at upper interface
    5242. 

  5242. !
    5243. 

  5243.                emx(0) = emx0
    5244. 

  5244. !
    5245. 

  5245. ! Initialize previous cloud amounts
    5246. 

  5246. !
    5247. 

  5247.                cld0 = 1.0
    5248. 

  5248. !
    5249. 

  5249. ! Indices for flux calculations
    5250. 

  5250. !
    5251. 

  5251.                k2 = k+1
    5252. 

  5252.                k3 = k2+1
    5253. 

  5253.                tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
    5254. 

  5254. !
    5255. 

  5255. ! Loop over number of cloud levels inside region (biggest to smallest cld area)
    5256. 

  5256. !
    5257. 

  5257.                do l = 1, nxsk+1
    5258. 

  5258. !
    5259. 

  5259. ! Calculate downward fluxes
    5260. 

  5260. !
    5261. 

  5261.                   cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
    5262. 

  5262.                   if (cld0 /= cld1) then
    5263. 

  5263.                      fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2)
    5264. 

  5264.                      do l1 = 0, l - 1
    5265. 

  5265.                         km1 = ksort(l1)-1
    5266. 

  5266.                         km4 = km1+3
    5267. 

  5267.                         tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4)
    5268. 

  5268.                         fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- &
    5269. 

  5269.                                     fsdl(i,k2))
    5270. 

  5270.                      end do
    5271. 

  5271.                   endif
    5272. 

  5272.                   cld0 = cld1
    5273. 

  5273. !
    5274. 

  5274. ! Multiply emissivity factors by current cloud transmissivity
    5275. 

  5275. !
    5276. 

  5276.                   if (l <= nxsk) then
    5277. 

  5277.                      k1 = ksort(l)
    5278. 

  5278.                      trans = 1.0-emis(i,k1)
    5279. 

  5279. !
    5280. 

  5280. ! Ideally the upper bound on l1 would be l-1, but the sort routine
    5281. 

  5281. !    scrambles the order of layers with identical cloud amounts
    5282. 

  5282. !
    5283. 

  5283.                      do l1 = 0, nxsk
    5284. 

  5284.                         if (ksort(l1) < k1) then
    5285. 

  5285.                            emx(l1) = emx(l1)*trans
    5286. 

  5286.                         endif
    5287. 

  5287.                      end do
    5288. 

  5288.                   end if
    5289. 

  5289. !
    5290. 

  5290. ! End loop over number l of cloud levels
    5291. 

  5291. !
    5292. 

  5292.                end do
    5293. 

  5293. !
    5294. 

  5294. ! End loop over level k for fluxes
    5295. 

  5295. !
    5296. 

  5296.             end do
    5297. 

  5297. !
    5298. 

  5298. ! End loop over longitude i for fluxes
    5299. 

  5299. !
    5300. 

  5300.          end do
    5301. 

  5301. !
    5302. 

  5302. ! End loop over regions irgn for max-overlap
    5303. 

  5303. !
    5304. 

  5304.       end do
    5305. 

    5306. 

  5306. !
    5307. 

  5307. !----------------------------------------------------------------------
    5308. 

  5308. ! UPWARD FLUXES:
    5309. 

  5309. ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
    5310. 

  5310. !
    5311. 

  5311.       do irgn = nmxrgn(ilon), 1, -1
    5312. 

  5312. !
    5313. 

  5313. ! Compute clear-sky fluxes for regions without clouds
    5314. 

  5314. !
    5315. 

  5315.          iimx = 1
    5316. 

  5316.          if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
    5317. 

  5317. !
    5318. 

  5318. ! Calculate emissivity so that upward flux at lower boundary of region
    5319. 

  5319. !    can be cast in form of solution for upward flux from cloud below that
    5320. 

  5320. !    boundary.  Then solutions for fluxes at other levels take form of
    5321. 

  5321. !    random overlap expressions.  Try to locate "cloud" as close as possible
    5322. 

  5322. !    to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
    5323. 

  5323. ! Include allowance for surface emissivity (both numerator and denominator
    5324. 

  5324. !    equal 1)
    5325. 

  5325. !
    5326. 

  5326.             k1 = kx2(ilon,irgn)+1
    5327. 

  5327.             if (k1 < pverp) then
    5328. 

  5328.                do km1 = pver-1,kx2(ilon,irgn),-1
    5329. 

  5329.                   km3 = km1+2
    5330. 

  5330.                   k2 = k1
    5331. 

  5331.                   k3 = k2+1
    5332. 

  5332.                   tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
    5333. 

  5333.                   emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ &
    5334. 

  5334.                          ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1))
    5335. 

  5335.                   if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
    5336. 

  5336.                end do
    5337. 

  5337.                km1 = max(km1,kx2(ilon,irgn))
    5338. 

  5338.             else
    5339. 

  5339.                km1 = k1-1
    5340. 

  5340.                km3 = km1+2
    5341. 

  5341.                emx0 = 1.0
    5342. 

  5342.             endif
    5343. 

    5344. 

  5344.             do k2 = kx1(ilon,irgn), kx2(ilon,irgn)
    5345. 

  5345.                k3 = k2+1
    5346. 

  5346. !
    5347. 

  5347. ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
    5348. 

  5348. !
    5349. 

  5349.                tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
    5350. 

  5350.                ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* &
    5351. 

  5351.                              (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))
    5352. 

  5352.             end do
    5353. 

  5353.          else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
    5354. 

  5354.             iimx = iimx+1
    5355. 

  5355.          end if
    5356. 

  5356. !
    5357. 

  5357. ! Outer loop over columns with clouds in the max-overlap region
    5358. 

  5358. !
    5359. 

  5359.          do iimx = 1, ncolmx(irgn)
    5360. 

  5360.             i = indxmx(iimx,irgn)
    5361. 

    5362. 

  5362. !
    5363. 

  5363. ! Calculate emissivity so that upward flux at lower boundary of region
    5364. 

  5364. !    can be cast in form of solution for upward flux from cloud at that
    5365. 

  5365. !    boundary.  Then solutions for fluxes at other levels take form of
    5366. 

  5366. !    random overlap expressions.  Try to locate "cloud" as close as possible
    5367. 

  5367. !    to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
    5368. 

  5368. ! Include allowance for surface emissivity (both numerator and denominator
    5369. 

  5369. !    equal 1)
    5370. 

  5370. !
    5371. 

  5371.             k1 = kx2(i,irgn)+1
    5372. 

  5372.             if (k1 < pverp) then
    5373. 

  5373.                do km1 = pver-1,kx2(i,irgn),-1
    5374. 

  5374.                   km3 = km1+2
    5375. 

  5375.                   k2 = k1
    5376. 

  5376.                   k3 = k2+1
    5377. 

  5377.                   tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3)
    5378. 

  5378.                   emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1))
    5379. 

  5379.                   if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
    5380. 

  5380.                end do
    5381. 

  5381.                km1 = max(km1,kx2(i,irgn))
    5382. 

  5382.             else
    5383. 

  5383.                emx0 = 1.0
    5384. 

  5384.                km1 = k1-1
    5385. 

  5385.             endif
    5386. 

  5386.             ksort(0) = km1 + 1
    5387. 

    5388. 

  5388. !
    5389. 

  5389. ! Loop to calculate fluxes at level k
    5390. 

  5390. !
    5391. 

  5391.             nxsk = 0
    5392. 

  5392.             do k = kx2(i,irgn), kx1(i,irgn), -1
    5393. 

  5393. !
    5394. 

  5394. ! Identify clouds (largest to smallest area) between k and kx2
    5395. 

  5395. !    Since nxsk will increase with decreasing k up to nxs(i,irgn), once
    5396. 

  5396. !    nxsk == nxs(i,irgn) then use the list constructed for previous k
    5397. 

  5397. !
    5398. 

  5398.                if (nxsk < nxs(i,irgn)) then
    5399. 

  5399.                   nxsk = 0
    5400. 

  5400.                   do l = 1, nxs(i,irgn)
    5401. 

  5401.                      k1 = kxs(l,i,irgn)
    5402. 

  5402.                      if (k <= k1) then
    5403. 

  5403.                         nxsk = nxsk + 1
    5404. 

  5404.                         ksort(nxsk) = k1
    5405. 

  5405.                      endif
    5406. 

  5406.                   end do
    5407. 

  5407.                endif
    5408. 

  5408. !
    5409. 

  5409. ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
    5410. 

  5410. !
    5411. 

  5411.                ksort(nxsk+1) = pverp
    5412. 

  5412. !
    5413. 

  5413. ! Initialize iterated emissivity factors
    5414. 

  5414. !
    5415. 

  5415.                do l = 1, nxsk
    5416. 

  5416.                   emx(l) = emis(i,ksort(l))
    5417. 

  5417.                end do
    5418. 

  5418. !
    5419. 

  5419. ! Initialize iterated emissivity factor for bnd. condition at lower interface
    5420. 

  5420. !
    5421. 

  5421.                emx(0) = emx0
    5422. 

  5422. !
    5423. 

  5423. ! Initialize previous cloud amounts
    5424. 

  5424. !
    5425. 

  5425.                cld0 = 1.0
    5426. 

  5426. !
    5427. 

  5427. ! Indices for flux calculations
    5428. 

  5428. !
    5429. 

  5429.                k2 = k
    5430. 

  5430.                k3 = k2+1
    5431. 

  5431. !
    5432. 

  5432. ! Loop over number of cloud levels inside region (biggest to smallest cld area)
    5433. 

  5433. !
    5434. 

  5434.                do l = 1, nxsk+1
    5435. 

  5435. !
    5436. 

  5436. ! Calculate upward fluxes
    5437. 

  5437. !
    5438. 

  5438.                   cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
    5439. 

  5439.                   if (cld0 /= cld1) then
    5440. 

  5440.                      ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2)
    5441. 

  5441.                      do l1 = 0, l - 1
    5442. 

  5442.                         km1 = ksort(l1)-1
    5443. 

  5443.                         km3 = km1+2
    5444. 

  5444. !
    5445. 

  5445. ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
    5446. 

  5446. !
    5447. 

  5447.                         tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3)
    5448. 

  5448.                         ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* &
    5449. 

  5449.                                    (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2))
    5450. 

  5450.                      end do
    5451. 

  5451.                   endif
    5452. 

  5452.                   cld0 = cld1
    5453. 

  5453. !
    5454. 

  5454. ! Multiply emissivity factors by current cloud transmissivity
    5455. 

  5455. !
    5456. 

  5456.                   if (l <= nxsk) then
    5457. 

  5457.                      k1 = ksort(l)
    5458. 

  5458.                      trans = 1.0-emis(i,k1)
    5459. 

  5459. !
    5460. 

  5460. ! Ideally the upper bound on l1 would be l-1, but the sort routine
    5461. 

  5461. !    scrambles the order of layers with identical cloud amounts
    5462. 

  5462. !
    5463. 

  5463.                      do l1 = 0, nxsk
    5464. 

  5464.                         if (ksort(l1) > k1) then
    5465. 

  5465.                            emx(l1) = emx(l1)*trans
    5466. 

  5466.                         endif
    5467. 

  5467.                      end do
    5468. 

  5468.                   end if
    5469. 

  5469. !
    5470. 

  5470. ! End loop over number l of cloud levels
    5471. 

  5471. !
    5472. 

  5472.                end do
    5473. 

  5473. !
    5474. 

  5474. ! End loop over level k for fluxes
    5475. 

  5475. !
    5476. 

  5476.             end do
    5477. 

  5477. !
    5478. 

  5478. ! End loop over longitude i for fluxes
    5479. 

  5479. !
    5480. 

  5480.          end do
    5481. 

  5481. !
    5482. 

  5482. ! End loop over regions irgn for max-overlap
    5483. 

  5483. !
    5484. 

  5484.       end do
    5485. 

  5485. !
    5486. 

  5486. ! End outermost longitude loop
    5487. 

  5487. !
    5488. 

  5488.    end do
    5489. 

  5489. !
    5490. 

  5490. ! End cloud modification loops
    5491. 

  5491. !
    5492. 

  5492. !----------------------------------------------------------------------
    5493. 

  5493. ! All longitudes: store history tape quantities
    5494. 

  5494. !
    5495. 

  5495.    do i=1,ncol
    5496. 

  5496.       flwds(i) = fdl (i,pverp )
    5497. 

  5497.       flns(i)  = ful (i,pverp ) - fdl (i,pverp )
    5498. 

  5498.       flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp )
    5499. 

  5499.       flnt(i)  = ful (i,ntoplw) - fdl (i,ntoplw)
    5500. 

  5500.       flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw)
    5501. 

  5501.       flut(i)  = ful (i,ntoplw)
    5502. 

  5502.       flutc(i) = fsul(i,ntoplw)
    5503. 

  5503.    end do
    5504. 

  5504. !
    5505. 

  5505. ! Computation of longwave heating (J/kg/s)
    5506. 

  5506. !
    5507. 

  5507.    do k=ntoplw,pver
    5508. 

  5508.       do i=1,ncol
    5509. 

  5509.          qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* &
    5510. 

  5510.                      1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
    5511. 

  5511.       end do
    5512. 

  5512.    end do
    5513. 

  5513. ! Return 0 above solution domain
    5514. 

  5514.    if ( ntoplw > 1 )then
    5515. 

  5515.       qrl(:ncol,:ntoplw-1) = 0.
    5516. 

  5516.    end if
    5517. 

    5518. 

  5518. ! Added downward/upward total and clear sky fluxes
    5519. 

  5519. !
    5520. 

  5520.    do k=ntoplw,pverp
    5521. 

  5521.       do i=1,ncol
    5522. 

  5522.         flup(i,k)  = ful(i,k)
    5523. 

  5523.         flupc(i,k) = fsul(i,k)
    5524. 

  5524.         fldn(i,k)  = fdl(i,k)
    5525. 

  5525.         fldnc(i,k) = fsdl(i,k)
    5526. 

  5526.       end do
    5527. 

  5527.    end do
    5528. 

  5528. ! Return 0 above solution domain
    5529. 

  5529.    if ( ntoplw > 1 )then
    5530. 

  5530.       flup(:ncol,:ntoplw-1) = 0.
    5531. 

  5531.       flupc(:ncol,:ntoplw-1) = 0.
    5532. 

  5532.       fldn(:ncol,:ntoplw-1) = 0.
    5533. 

  5533.       fldnc(:ncol,:ntoplw-1) = 0.
    5534. 

  5534.    end if
    5535. 

  5535. !
    5536. 

  5536.    return
    5537. 

  5537. end subroutine radclwmx
    5538. 

    5539. 

  5539. subroutine radcswmx(jj, lchnk   ,ncol    ,pcols, pver, pverp,         &
    5540. 

  5540.                     pint    ,pmid    ,h2ommr  ,rh      ,o3mmr   , &
    5541. 

  5541.                     aermmr  ,cld     ,cicewp  ,cliqwp  ,rel     , &
    5542. 

  5542. !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon,  &
    5543. 

  5543.                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon,  &
    5544. 

  5544.                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgn  , &
    5545. 

  5545.                     pmxrgn  ,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
    5546. 

  5546.                     fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns    , &
    5547. 

  5547.                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
    5548. 

  5548.                     solsd   ,solld   ,frc_day ,                   &
    5549. 

  5549.                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
    5550. 

  5550.                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
    5551. 

  5551. !-----------------------------------------------------------------------
    5552. 

  5552. ! 
    5553. 

  5553. ! Purpose: 
    5554. 

  5554. ! Solar radiation code
    5555. 

  5555. ! 
    5556. 

  5556. ! Method: 
    5557. 

  5557. ! Basic method is Delta-Eddington as described in:
    5558. 

  5558. ! 
    5559. 

  5559. ! Briegleb, Bruce P., 1992: Delta-Eddington
    5560. 

  5560. ! Approximation for Solar Radiation in the NCAR Community Climate Model,
    5561. 

  5561. ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
    5562. 

  5562. ! 
    5563. 

  5563. ! Five changes to the basic method described above are:
    5564. 

  5564. ! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993)
    5565. 

  5565. ! (2) the distinction between liquid and ice particle clouds 
    5566. 

  5566. ! (Kiehl et al, 1996);
    5567. 

  5567. ! (3) provision for calculating TOA fluxes with spectral response to
    5568. 

  5568. ! match Nimbus-7 visible/near-IR radiometers (Collins, 1998);
    5569. 

  5569. ! (4) max-random overlap (Collins, 2001)
    5570. 

  5570. ! (5) The near-IR absorption by H2O was updated in 2003 by Collins, 
    5571. 

  5571. !     Lee-Taylor, and Edwards for consistency with the new line data in
    5572. 

  5572. !     Hitran 2000 and the H2O continuum version CKD 2.4.  Modifications
    5573. 

  5573. !     were optimized by reducing RMS errors in heating rates relative
    5574. 

  5574. !     to a series of benchmark calculations for the 5 standard AFGL 
    5575. 

  5575. !     atmospheres.  The benchmarks were performed using DISORT2 combined
    5576. 

  5576. !     with GENLN3.  The near-IR scattering optical depths for Rayleigh
    5577. 

  5577. !     scattering were also adjusted, as well as the correction for
    5578. 

  5578. !     stratospheric heating by H2O.
    5579. 

  5579. !
    5580. 

  5580. ! The treatment of maximum-random overlap is described in the
    5581. 

  5581. ! comment block "INDEX CALCULATIONS FOR MAX OVERLAP".
    5582. 

  5582. ! 
    5583. 

  5583. ! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters.
    5584. 

  5584. ! solar flux fractions specified for each interval. allows for
    5585. 

  5585. ! seasonally and diurnally varying solar input.  Includes molecular,
    5586. 

  5586. ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud, 
    5587. 

  5587. ! and surface absorption. Computes delta-eddington reflections and
    5588. 

  5588. ! transmissions assuming homogeneously mixed layers. Adds the layers 
    5589. 

  5589. ! assuming scattering between layers to be isotropic, and distinguishes 
    5590. 

  5590. ! direct solar beam from scattered radiation.
    5591. 

  5591. ! 
    5592. 

  5592. ! Longitude loops are broken into 1 or 2 sections, so that only daylight
    5593. 

  5593. ! (i.e. coszrs > 0) computations are done.
    5594. 

  5594. ! 
    5595. 

  5595. ! Note that an extra layer above the model top layer is added.
    5596. 

  5596. ! 
    5597. 

  5597. ! cgs units are used.
    5598. 

  5598. ! 
    5599. 

  5599. ! Special diagnostic calculation of the clear sky surface and total column
    5600. 

  5600. ! absorbed flux is also done for cloud forcing diagnostics.
    5601. 

  5601. ! 
    5602. 

  5602. !-----------------------------------------------------------------------
    5603. 

  5603. !  use shr_kind_mod, only: r8 => shr_kind_r8
    5604. 

  5604. !  use ppgrid
    5605. 

  5605. !  use ghg_surfvals, only: co2mmr
    5606. 

  5606. !  use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, &
    5607. 

  5607. !    idxDUSTfirst, numDUST, idxVOLC, naer_all
    5608. 

  5608. !  use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, &
    5609. 

  5609. !    ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, &
    5610. 

  5610. !    kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc
    5611. 

  5611. !  use abortutils, only: endrun
    5612. 

    5613. 

  5613.    implicit none
    5614. 

    5615. 

  5615.    integer nspint            ! Num of spctrl intervals across solar spectrum
    5616. 

  5616.    integer naer_groups       ! Num of aerosol groups for optical diagnostics
    5617. 

    5618. 

  5618.    parameter ( nspint = 19 )
    5619. 

  5619.    parameter ( naer_groups = 7 )    ! current groupings are sul, sslt, all carbons, all dust, and all aerosols
    5620. 

  5620. !-----------------------Constants for new band (640-700 nm)-------------
    5621. 

    5622. 

  5622. !-------------Parameters for accelerating max-random solution-------------
    5623. 

  5623. ! 
    5624. 

  5624. ! The solution time scales like prod(j:1->N) (1 + n_j) where 
    5625. 

  5625. ! N   = number of max-overlap regions (nmxrgn)
    5626. 

  5626. ! n_j = number of unique cloud amounts in region j
    5627. 

  5627. ! 
    5628. 

  5628. ! Therefore the solution cost can be reduced by decreasing n_j.
    5629. 

  5629. ! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky.
    5630. 

  5630. ! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps)
    5631. 

  5631. ! decimal places as identical
    5632. 

  5632. ! 
    5633. 

  5633. ! areamin reduces the cost by dropping configurations that occupy
    5634. 

  5634. ! a surface area < areamin of the model grid box.  The surface area
    5635. 

  5635. ! for a configuration C(j,k_j), where j is the region number and k_j is the
    5636. 

  5636. ! index for a unique cloud amount (in descending order from biggest to
    5637. 

  5637. ! smallest clouds) in region j, is
    5638. 

  5638. ! 
    5639. 

  5639. ! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)]
    5640. 

  5640. ! 
    5641. 

  5641. ! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0.
    5642. 

  5642. ! 
    5643. 

  5643. ! nconfgmax reduces the cost and improves load balancing by setting an upper
    5644. 

  5644. ! bound on the number of cloud configurations in the solution.  If the number
    5645. 

  5645. ! of configurations exceeds nconfgmax, the nconfgmax configurations with the
    5646. 

  5646. ! largest area are retained, and the fluxes are normalized by the total area
    5647. 

  5647. ! of these nconfgmax configurations.  For the current max/random overlap 
    5648. 

  5648. ! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount 
    5649. 

  5649. ! parameterization, the mean and RMS number of configurations are 
    5650. 

  5650. ! both roughly 5.  nconfgmax has been set to the mean+2*RMS number, or 15.
    5651. 

  5651. ! 
    5652. 

  5652. ! Minimum cloud amount (as a fraction of the grid-box area) to 
    5653. 

  5653. ! distinguish from clear sky
    5654. 

  5654. ! 
    5655. 

  5655.    real(r8) cldmin
    5656. 

  5656.    parameter (cldmin = 1.0e-80_r8)
    5657. 

  5657. ! 
    5658. 

  5658. ! Minimimum horizontal area (as a fraction of the grid-box area) to retain 
    5659. 

  5659. ! for a unique cloud configuration in the max-random solution
    5660. 

  5660. ! 
    5661. 

  5661.    real(r8) areamin
    5662. 

  5662.    parameter (areamin = 0.01_r8)
    5663. 

  5663. ! 
    5664. 

  5664. ! Decimal precision of cloud amount (0 -> preserve full resolution;
    5665. 

  5665. ! 10^-n -> preserve n digits of cloud amount)
    5666. 

  5666. ! 
    5667. 

  5667.    real(r8) cldeps
    5668. 

  5668.    parameter (cldeps = 0.0_r8)
    5669. 

  5669. ! 
    5670. 

  5670. ! Maximum number of configurations to include in solution
    5671. 

  5671. ! 
    5672. 

  5672.    integer nconfgmax
    5673. 

  5673.    parameter (nconfgmax = 15)
    5674. 

  5674. !------------------------------Commons----------------------------------
    5675. 

  5675. ! 
    5676. 

  5676. ! Input arguments
    5677. 

  5677. ! 
    5678. 

  5678.    integer, intent(in) :: lchnk,jj             ! chunk identifier
    5679. 

  5679.    integer, intent(in) :: pcols, pver, pverp
    5680. 

  5680.    integer, intent(in) :: ncol              ! number of atmospheric columns
    5681. 

    5682. 

  5682.    real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
    5683. 

  5683.    real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
    5684. 

  5684.    real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio)
    5685. 

  5685.    real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
    5686. 

  5686.    real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio
    5687. 

  5687.    real(r8), intent(in) :: rh(pcols,pver)   ! Relative humidity (fraction)
    5688. 

  5688. ! 
    5689. 

  5689.    real(r8), intent(in) :: cld(pcols,pver)  ! Fractional cloud cover
    5690. 

  5690.    real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
    5691. 

  5691.    real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
    5692. 

  5692.    real(r8), intent(in) :: rel(pcols,pver)  ! Liquid effective drop size (microns)
    5693. 

  5693.    real(r8), intent(in) :: rei(pcols,pver)  ! Ice effective drop size (microns)
    5694. 

  5694. ! 
    5695. 

  5695.    real(r8), intent(in) :: eccf             ! Eccentricity factor (1./earth-sun dist^2)
    5696. 

  5696.    real, intent(in) :: solcon           ! solar constant with eccentricity factor
    5697. 

  5697.    real(r8), intent(in) :: coszrs(pcols)    ! Cosine solar zenith angle
    5698. 

  5698.    real(r8), intent(in) :: asdir(pcols)     ! 0.2-0.7 micro-meter srfc alb: direct rad
    5699. 

  5699.    real(r8), intent(in) :: aldir(pcols)     ! 0.7-5.0 micro-meter srfc alb: direct rad
    5700. 

  5700.    real(r8), intent(in) :: asdif(pcols)     ! 0.2-0.7 micro-meter srfc alb: diffuse rad
    5701. 

  5701.    real(r8), intent(in) :: aldif(pcols)     ! 0.7-5.0 micro-meter srfc alb: diffuse rad
    5702. 

    5703. 

  5703.    real(r8), intent(in) :: scon             ! solar constant 
    5704. 

  5704. ! 
    5705. 

  5705. ! IN/OUT arguments
    5706. 

  5706. ! 
    5707. 

  5707.    real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each
    5708. 

  5708. !                                                 !    maximally overlapped region. 
    5709. 

  5709. !                                                 !    0->pmxrgn(i,1) is range of pressure for
    5710. 

  5710. !                                                 !    1st region,pmxrgn(i,1)->pmxrgn(i,2) for
    5711. 

  5711. !                                                 !    2nd region, etc
    5712. 

  5712.    integer, intent(inout) ::  nmxrgn(pcols)    ! Number of maximally overlapped regions
    5713. 

  5713. ! 
    5714. 

  5714. ! Output arguments
    5715. 

  5715. ! 
    5716. 

    5717. 

  5717.    real(r8), intent(out) :: solin(pcols)     ! Incident solar flux
    5718. 

  5718.    real(r8), intent(out) :: qrs(pcols,pver)  ! Solar heating rate
    5719. 

  5719.    real(r8), intent(out) :: fsns(pcols)      ! Surface absorbed solar flux
    5720. 

  5720.    real(r8), intent(out) :: fsnt(pcols)      ! Total column absorbed solar flux
    5721. 

  5721.    real(r8), intent(out) :: fsntoa(pcols)    ! Net solar flux at TOA
    5722. 

  5722.    real(r8), intent(out) :: fsds(pcols)      ! Flux shortwave downwelling surface
    5723. 

  5723. ! 
    5724. 

  5724.    real(r8), intent(out) :: fsnsc(pcols)     ! Clear sky surface absorbed solar flux
    5725. 

  5725.    real(r8), intent(out) :: fsdsc(pcols)     ! Clear sky surface downwelling solar flux
    5726. 

  5726.    real(r8), intent(out) :: fsntc(pcols)     ! Clear sky total column absorbed solar flx
    5727. 

  5727.    real(r8), intent(out) :: fsntoac(pcols)   ! Clear sky net solar flx at TOA
    5728. 

  5728.    real(r8), intent(out) :: sols(pcols)      ! Direct solar rad on surface (< 0.7)
    5729. 

  5729.    real(r8), intent(out) :: soll(pcols)      ! Direct solar rad on surface (>= 0.7)
    5730. 

  5730.    real(r8), intent(out) :: solsd(pcols)     ! Diffuse solar rad on surface (< 0.7)
    5731. 

  5731.    real(r8), intent(out) :: solld(pcols)     ! Diffuse solar rad on surface (>= 0.7)
    5732. 

  5732.    real(r8), intent(out) :: fsnirtoa(pcols)  ! Near-IR flux absorbed at toa
    5733. 

  5733.    real(r8), intent(out) :: fsnrtoac(pcols)  ! Clear sky near-IR flux absorbed at toa
    5734. 

  5734.    real(r8), intent(out) :: fsnrtoaq(pcols)  ! Net near-IR flux at toa >= 0.7 microns
    5735. 

  5735.    real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
    5736. 

  5736.    real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
    5737. 

    5738. 

  5738. ! Added downward/upward total and clear sky fluxes
    5739. 

  5739.    real(r8), intent(out) :: fsup(pcols,pverp)      ! Total sky upward solar flux (spectrally summed)
    5740. 

  5740.    real(r8), intent(out) :: fsupc(pcols,pverp)     ! Clear sky upward solar flux (spectrally summed)
    5741. 

  5741.    real(r8), intent(out) :: fsdn(pcols,pverp)      ! Total sky downward solar flux (spectrally summed)
    5742. 

  5742.    real(r8), intent(out) :: fsdnc(pcols,pverp)     ! Clear sky downward solar flux (spectrally summed)
    5743. 

  5743. !
    5744. 

  5744.    real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns
    5745. 

  5745.    real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
    5746. 

  5746.    real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
    5747. 

  5747.    real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
    5748. 

  5748.    real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
    5749. 

  5749. !  real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
    5750. 

  5750. !  real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
    5751. 

  5751. !  real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
    5752. 

  5752. !  real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
    5753. 

  5753. ! 
    5754. 

  5754. !---------------------------Local variables-----------------------------
    5755. 

  5755. ! 
    5756. 

  5756. ! Max/random overlap variables
    5757. 

  5757. ! 
    5758. 

  5758.    real(r8) asort(pverp)     ! 1 - cloud amounts to be sorted for max ovrlp.
    5759. 

  5759.    real(r8) atmp             ! Temporary storage for sort when nxs = 2
    5760. 

  5760.    real(r8) cld0             ! 1 - (cld amt) used to make wstr, cstr, nstr
    5761. 

  5761.    real(r8) totwgt           ! Total of xwgts = total fractional area of 
    5762. 

  5762. !   grid-box covered by cloud configurations
    5763. 

  5763. !   included in solution to fluxes
    5764. 

    5765. 

  5765.    real(r8) wgtv(nconfgmax)  ! Weights for fluxes
    5766. 

  5766. !   1st index is configuration number
    5767. 

  5767.    real(r8) wstr(pverp,pverp) ! area weighting factors for streams
    5768. 

  5768. !   1st index is for stream #, 
    5769. 

  5769. !   2nd index is for region #
    5770. 

    5771. 

  5771.    real(r8) xexpt            ! solar direct beam trans. for layer above
    5772. 

  5772.    real(r8) xrdnd            ! diffuse reflectivity for layer above
    5773. 

  5773.    real(r8) xrupd            ! diffuse reflectivity for layer below
    5774. 

  5774.    real(r8) xrups            ! direct-beam reflectivity for layer below
    5775. 

  5775.    real(r8) xtdnt            ! total trans for layers above
    5776. 

    5777. 

  5777.    real(r8) xwgt             ! product of cloud amounts
    5778. 

    5779. 

  5779.    real(r8) yexpt            ! solar direct beam trans. for layer above
    5780. 

  5780.    real(r8) yrdnd            ! diffuse reflectivity for layer above
    5781. 

  5781.    real(r8) yrupd            ! diffuse reflectivity for layer below
    5782. 

  5782.    real(r8) ytdnd            ! dif-beam transmission for layers above
    5783. 

  5783.    real(r8) ytupd            ! dif-beam transmission for layers below
    5784. 

    5785. 

  5785.    real(r8) zexpt            ! solar direct beam trans. for layer above
    5786. 

  5786.    real(r8) zrdnd            ! diffuse reflectivity for layer above
    5787. 

  5787.    real(r8) zrupd            ! diffuse reflectivity for layer below
    5788. 

  5788.    real(r8) zrups            ! direct-beam reflectivity for layer below
    5789. 

  5789.    real(r8) ztdnt            ! total trans for layers above
    5790. 

    5791. 

  5791.    logical new_term          ! Flag for configurations to include in fluxes
    5792. 

  5792.    logical region_found      ! flag for identifying regions
    5793. 

    5794. 

  5794.    integer ccon(0:pverp,nconfgmax)                                
    5795. 

  5795. ! flags for presence of clouds
    5796. 

  5796. !   1st index is for level # (including 
    5797. 

  5797. !    layer above top of model and at surface)
    5798. 

  5798. !   2nd index is for configuration #
    5799. 

  5799.    integer cstr(0:pverp,pverp)                                
    5800. 

  5800. ! flags for presence of clouds
    5801. 

  5801. !   1st index is for level # (including 
    5802. 

  5802. !    layer above top of model and at surface)
    5803. 

  5803. !   2nd index is for stream #
    5804. 

  5804.    integer icond(0:pverp,nconfgmax)
    5805. 

  5805. ! Indices for copying rad. properties from
    5806. 

  5806. !     one identical downward cld config.
    5807. 

  5807. !     to another in adding method (step 2)
    5808. 

  5808. !   1st index is for interface # (including 
    5809. 

  5809. !     layer above top of model and at surface)
    5810. 

  5810. !   2nd index is for configuration # range
    5811. 

  5811.    integer iconu(0:pverp,nconfgmax)
    5812. 

  5812. ! Indices for copying rad. properties from
    5813. 

  5813. !     one identical upward configuration
    5814. 

  5814. !     to another in adding method (step 2)
    5815. 

  5815. !   1st index is for interface # (including 
    5816. 

  5816. !     layer above top of model and at surface)
    5817. 

  5817. !   2nd index is for configuration # range
    5818. 

  5818.    integer iconfig           ! Counter for random-ovrlap configurations
    5819. 

  5819.    integer irgn              ! Index for max-overlap regions
    5820. 

  5820.    integer is0               ! Lower end of stream index range
    5821. 

  5821.    integer is1               ! Upper end of stream index range
    5822. 

  5822.    integer isn               ! Stream index
    5823. 

  5823.    integer istr(pverp+1)     ! index for stream #s during flux calculation
    5824. 

  5824.    integer istrtd(0:pverp,0:nconfgmax+1)
    5825. 

  5825. ! indices into icond 
    5826. 

  5826. !   1st index is for interface # (including 
    5827. 

  5827. !     layer above top of model and at surface)
    5828. 

  5828. !   2nd index is for configuration # range
    5829. 

  5829.    integer istrtu(0:pverp,0:nconfgmax+1)
    5830. 

  5830. ! indices into iconu 
    5831. 

  5831. !   1st index is for interface # (including 
    5832. 

  5832. !     layer above top of model and at surface)
    5833. 

  5833. !   2nd index is for configuration # range
    5834. 

  5834.    integer j                 ! Configuration index
    5835. 

  5835.    integer k1                ! Level index
    5836. 

  5836.    integer k2                ! Level index
    5837. 

  5837.    integer ksort(pverp)      ! Level indices of cloud amounts to be sorted
    5838. 

  5838.    integer ktmp              ! Temporary storage for sort when nxs = 2
    5839. 

  5839.    integer kx1(0:pverp)      ! Level index for top of max-overlap region
    5840. 

  5840.    integer kx2(0:pverp)      ! Level index for bottom of max-overlap region
    5841. 

  5841.    integer l                 ! Index 
    5842. 

  5842.    integer l0                ! Index
    5843. 

  5843.    integer mrgn              ! Counter for nrgn
    5844. 

  5844.    integer mstr              ! Counter for nstr
    5845. 

  5845.    integer n0                ! Number of configurations with ccon(k,:)==0
    5846. 

  5846.    integer n1                ! Number of configurations with ccon(k,:)==1
    5847. 

  5847.    integer nconfig           ! Number of random-ovrlap configurations
    5848. 

  5848.    integer nconfigm          ! Value of config before testing for areamin,
    5849. 

  5849. !    nconfgmax
    5850. 

  5850.    integer npasses           ! number of passes over the indexing loop
    5851. 

  5851.    integer nrgn              ! Number of max overlap regions at current 
    5852. 

  5852. !    longitude
    5853. 

  5853.    integer nstr(pverp)       ! Number of unique cloud configurations
    5854. 

  5854. !   ("streams") in a max-overlapped region
    5855. 

  5855. !   1st index is for region #
    5856. 

  5856.    integer nuniq             ! # of unique cloud configurations
    5857. 

  5857.    integer nuniqd(0:pverp)   ! # of unique cloud configurations: TOA 
    5858. 

  5858. !   to level k
    5859. 

  5859.    integer nuniqu(0:pverp)   ! # of unique cloud configurations: surface
    5860. 

  5860. !   to level k 
    5861. 

  5861.    integer nxs               ! Number of cloudy layers between k1 and k2 
    5862. 

  5862.    integer ptr0(nconfgmax)   ! Indices of configurations with ccon(k,:)==0
    5863. 

  5863.    integer ptr1(nconfgmax)   ! Indices of configurations with ccon(k,:)==1
    5864. 

  5864.    integer ptrc(nconfgmax)   ! Pointer for configurations sorted by wgtv
    5865. 

  5865. !  integer findvalue         ! Function for finding kth smallest element
    5866. 

  5866. !   in a vector
    5867. 

  5867. !  external findvalue
    5868. 

    5869. 

  5869. ! 
    5870. 

  5870. ! Other
    5871. 

  5871. ! 
    5872. 

  5872.    integer ns                ! Spectral loop index
    5873. 

  5873.    integer i                 ! Longitude loop index
    5874. 

  5874.    integer k                 ! Level loop index
    5875. 

  5875.    integer km1               ! k - 1
    5876. 

  5876.    integer kp1               ! k + 1
    5877. 

  5877.    integer n                 ! Loop index for daylight
    5878. 

  5878.    integer ndayc             ! Number of daylight columns
    5879. 

  5879.    integer idayc(pcols)      ! Daytime column indices
    5880. 

  5880.    integer indxsl            ! Index for cloud particle properties
    5881. 

  5881.    integer ksz               ! dust size bin index
    5882. 

  5882.    integer krh               ! relative humidity bin index
    5883. 

  5883.    integer kaer              ! aerosol group index
    5884. 

  5884.    real(r8) wrh              ! weight for linear interpolation between lut points
    5885. 

  5885.    real(r8) :: rhtrunc       ! rh, truncated for the purposes of extrapolating
    5886. 

  5886.                              ! aerosol optical properties 
    5887. 

  5887.    real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad
    5888. 

  5888.    real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad
    5889. 

  5889. ! 
    5890. 

  5890.    real(r8) wgtint           ! Weight for specific spectral interval
    5891. 

    5892. 

  5892. ! 
    5893. 

  5893. ! Diagnostic and accumulation arrays; note that sfltot, fswup, and
    5894. 

  5894. ! fswdn are not used in the computation,but are retained for future use.
    5895. 

  5895. ! 
    5896. 

  5896.    real(r8) solflx           ! Solar flux in current interval
    5897. 

  5897.    real(r8) sfltot           ! Spectrally summed total solar flux
    5898. 

  5898.    real(r8) totfld(0:pver)   ! Spectrally summed flux divergence
    5899. 

  5899.    real(r8) fswup(0:pverp)   ! Spectrally summed up flux
    5900. 

  5900.    real(r8) fswdn(0:pverp)   ! Spectrally summed down flux
    5901. 

  5901.    real(r8) fswupc(0:pverp)  ! Spectrally summed up clear sky flux
    5902. 

  5902.    real(r8) fswdnc(0:pverp)  ! Spectrally summed down clear sky flux
    5903. 

  5903. ! 
    5904. 

  5904. ! Cloud radiative property arrays
    5905. 

  5905. ! 
    5906. 

  5906. !  real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth
    5907. 

  5907. !  real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth
    5908. 

  5908.    real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo
    5909. 

  5909.    real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
    5910. 

  5910.    real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
    5911. 

  5911.    real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo
    5912. 

  5912.    real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter
    5913. 

  5913.    real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction
    5914. 

  5914. !
    5915. 

  5915. ! Aerosol mass paths by species
    5916. 

  5916. !
    5917. 

  5917.   real(r8) usul(pcols,pver)   ! sulfate (SO4)
    5918. 

  5918.   real(r8) ubg(pcols,pver)    ! background aerosol
    5919. 

  5919.   real(r8) usslt(pcols,pver)  ! sea-salt (SSLT)
    5920. 

  5920.   real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI)
    5921. 

  5921.   real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO)
    5922. 

  5922.   real(r8) ucb(pcols,pver)    ! black carbon (BCPHI + BCPHO)
    5923. 

  5923.   real(r8) uvolc(pcols,pver) ! volcanic mass
    5924. 

  5924.   real(r8) udst(ndstsz,pcols,pver) ! dust
    5925. 

    5926. 

  5926. !
    5927. 

  5927. ! local variables used for the external mixing of aerosol species
    5928. 

  5928. !
    5929. 

  5929.   real(r8) tau_sul             ! optical depth, sulfate
    5930. 

  5930.   real(r8) tau_bg              ! optical depth, background aerosol
    5931. 

  5931.   real(r8) tau_sslt            ! optical depth, sea-salt
    5932. 

  5932.   real(r8) tau_cphil           ! optical depth, hydrophilic carbon
    5933. 

  5933.   real(r8) tau_cphob           ! optical depth, hydrophobic carbon
    5934. 

  5934.   real(r8) tau_cb              ! optical depth, black carbon
    5935. 

  5935.   real(r8) tau_volc            ! optical depth, volcanic
    5936. 

  5936.   real(r8) tau_dst(ndstsz)     ! optical depth, dust, by size category
    5937. 

  5937.   real(r8) tau_dst_tot         ! optical depth, total dust
    5938. 

  5938.   real(r8) tau_tot             ! optical depth, total aerosol
    5939. 

    5940. 

  5940.   real(r8) tau_w_sul           ! optical depth * single scattering albedo, sulfate
    5941. 

  5941.   real(r8) tau_w_bg            ! optical depth * single scattering albedo, background aerosol
    5942. 

  5942.   real(r8) tau_w_sslt          ! optical depth * single scattering albedo, sea-salt
    5943. 

  5943.   real(r8) tau_w_cphil         ! optical depth * single scattering albedo, hydrophilic carbon
    5944. 

  5944.   real(r8) tau_w_cphob         ! optical depth * single scattering albedo, hydrophobic carbon
    5945. 

  5945.   real(r8) tau_w_cb            ! optical depth * single scattering albedo, black carbon
    5946. 

  5946.   real(r8) tau_w_volc          ! optical depth * single scattering albedo, volcanic
    5947. 

  5947.   real(r8) tau_w_dst(ndstsz)   ! optical depth * single scattering albedo, dust, by size
    5948. 

  5948.   real(r8) tau_w_dst_tot       ! optical depth * single scattering albedo, total dust
    5949. 

  5949.   real(r8) tau_w_tot           ! optical depth * single scattering albedo, total aerosol
    5950. 

    5951. 

  5951.   real(r8) tau_w_g_sul         ! optical depth * single scattering albedo * asymmetry parameter, sulfate
    5952. 

  5952.   real(r8) tau_w_g_bg          ! optical depth * single scattering albedo * asymmetry parameter, background aerosol
    5953. 

  5953.   real(r8) tau_w_g_sslt        ! optical depth * single scattering albedo * asymmetry parameter, sea-salt
    5954. 

  5954.   real(r8) tau_w_g_cphil       ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon
    5955. 

  5955.   real(r8) tau_w_g_cphob       ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon
    5956. 

  5956.   real(r8) tau_w_g_cb          ! optical depth * single scattering albedo * asymmetry parameter, black carbon
    5957. 

  5957.   real(r8) tau_w_g_volc        ! optical depth * single scattering albedo * asymmetry parameter, volcanic
    5958. 

  5958.   real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size
    5959. 

  5959.   real(r8) tau_w_g_dst_tot     ! optical depth * single scattering albedo * asymmetry parameter, total dust
    5960. 

  5960.   real(r8) tau_w_g_tot         ! optical depth * single scattering albedo * asymmetry parameter, total aerosol
    5961. 

    5962. 

  5962.   real(r8) f_sul               ! forward scattering fraction, sulfate
    5963. 

  5963.   real(r8) f_bg                ! forward scattering fraction, background aerosol
    5964. 

  5964.   real(r8) f_sslt              ! forward scattering fraction, sea-salt
    5965. 

  5965.   real(r8) f_cphil             ! forward scattering fraction, hydrophilic carbon
    5966. 

  5966.   real(r8) f_cphob             ! forward scattering fraction, hydrophobic carbon
    5967. 

  5967.   real(r8) f_cb                ! forward scattering fraction, black carbon
    5968. 

  5968.   real(r8) f_volc              ! forward scattering fraction, volcanic
    5969. 

  5969.   real(r8) f_dst(ndstsz)       ! forward scattering fraction, dust, by size
    5970. 

  5970.   real(r8) f_dst_tot           ! forward scattering fraction, total dust
    5971. 

  5971.   real(r8) f_tot               ! forward scattering fraction, total aerosol
    5972. 

    5973. 

  5973.   real(r8) tau_w_f_sul         ! optical depth * forward scattering fraction * single scattering albedo, sulfate
    5974. 

  5974.   real(r8) tau_w_f_bg          ! optical depth * forward scattering fraction * single scattering albedo, background
    5975. 

  5975.   real(r8) tau_w_f_sslt        ! optical depth * forward scattering fraction * single scattering albedo, sea-salt
    5976. 

  5976.   real(r8) tau_w_f_cphil       ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C
    5977. 

  5977.   real(r8) tau_w_f_cphob       ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C
    5978. 

  5978.   real(r8) tau_w_f_cb          ! optical depth * forward scattering fraction * single scattering albedo, black C
    5979. 

  5979.   real(r8) tau_w_f_volc        ! optical depth * forward scattering fraction * single scattering albedo, volcanic
    5980. 

  5980.   real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size
    5981. 

  5981.   real(r8) tau_w_f_dst_tot     ! optical depth * forward scattering fraction * single scattering albedo, total dust
    5982. 

  5982.   real(r8) tau_w_f_tot         ! optical depth * forward scattering fraction * single scattering albedo, total aerosol
    5983. 

  5983.   real(r8) w_dst_tot           ! single scattering albedo, total dust
    5984. 

  5984.   real(r8) w_tot               ! single scattering albedo, total aerosol
    5985. 

  5985.   real(r8) g_dst_tot           ! asymmetry parameter, total dust
    5986. 

  5986.   real(r8) g_tot               ! asymmetry parameter, total aerosol
    5987. 

  5987.   real(r8) ksuli               ! specific extinction interpolated between rh look-up-table points, sulfate
    5988. 

  5988.   real(r8) ksslti              ! specific extinction interpolated between rh look-up-table points, sea-salt
    5989. 

  5989.   real(r8) kcphili             ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon
    5990. 

  5990.   real(r8) wsuli               ! single scattering albedo interpolated between rh look-up-table points, sulfate
    5991. 

  5991.   real(r8) wsslti              ! single scattering albedo interpolated between rh look-up-table points, sea-salt
    5992. 

  5992.   real(r8) wcphili             ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon
    5993. 

  5993.   real(r8) gsuli               ! asymmetry parameter interpolated between rh look-up-table points, sulfate
    5994. 

  5994.   real(r8) gsslti              ! asymmetry parameter interpolated between rh look-up-table points, sea-salt
    5995. 

  5995.   real(r8) gcphili             ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon
    5996. 

  5996. ! 
    5997. 

  5997. ! Aerosol radiative property arrays
    5998. 

  5998. ! 
    5999. 

  5999.    real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth
    6000. 

  6000.    real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo
    6001. 

  6001.    real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter
    6002. 

  6002.    real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction
    6003. 

    6004. 

  6004. ! 
    6005. 

  6005. ! Various arrays and other constants:
    6006. 

  6006. ! 
    6007. 

  6007.    real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer
    6008. 

  6008.    real(r8) zenfac(pcols)    ! Square root of cos solar zenith angle
    6009. 

  6009.    real(r8) sqrco2           ! Square root of the co2 mass mixg ratio
    6010. 

  6010.    real(r8) tmp1             ! Temporary constant array
    6011. 

  6011.    real(r8) tmp2             ! Temporary constant array
    6012. 

  6012.    real(r8) pdel             ! Pressure difference across layer
    6013. 

  6013.    real(r8) path             ! Mass path of layer
    6014. 

  6014.    real(r8) ptop             ! Lower interface pressure of extra layer
    6015. 

  6015.    real(r8) ptho2            ! Used to compute mass path of o2
    6016. 

  6016.    real(r8) ptho3            ! Used to compute mass path of o3
    6017. 

  6017.    real(r8) pthco2           ! Used to compute mass path of co2
    6018. 

  6018.    real(r8) pthh2o           ! Used to compute mass path of h2o
    6019. 

  6019.    real(r8) h2ostr           ! Inverse sq. root h2o mass mixing ratio
    6020. 

  6020.    real(r8) wavmid(nspint)   ! Spectral interval middle wavelength
    6021. 

  6021.    real(r8) trayoslp         ! Rayleigh optical depth/standard pressure
    6022. 

  6022.    real(r8) tmp1l            ! Temporary constant array
    6023. 

  6023.    real(r8) tmp2l            ! Temporary constant array
    6024. 

  6024.    real(r8) tmp3l            ! Temporary constant array
    6025. 

  6025.    real(r8) tmp1i            ! Temporary constant array
    6026. 

  6026.    real(r8) tmp2i            ! Temporary constant array
    6027. 

  6027.    real(r8) tmp3i            ! Temporary constant array
    6028. 

  6028.    real(r8) rdenom           ! Multiple scattering term
    6029. 

  6029.    real(r8) rdirexp          ! layer direct ref times exp transmission
    6030. 

  6030.    real(r8) tdnmexp          ! total transmission - exp transmission
    6031. 

  6031.    real(r8) psf(nspint)      ! Frac of solar flux in spect interval
    6032. 

  6032. ! 
    6033. 

  6033. ! Layer absorber amounts; note that 0 refers to the extra layer added
    6034. 

  6034. ! above the top model layer
    6035. 

  6035. ! 
    6036. 

  6036.    real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o
    6037. 

  6037.    real(r8) uo3(pcols,0:pver) ! Layer absorber amount of  o3
    6038. 

  6038.    real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2
    6039. 

  6039.    real(r8) uo2(pcols,0:pver) ! Layer absorber amount of  o2
    6040. 

  6040.    real(r8) uaer(pcols,0:pver) ! Layer aerosol amount 
    6041. 

  6041. ! 
    6042. 

  6042. ! Total column absorber amounts:
    6043. 

  6043. ! 
    6044. 

  6044.    real(r8) uth2o(pcols)     ! Total column  absorber amount of  h2o
    6045. 

  6045.    real(r8) uto3(pcols)      ! Total column  absorber amount of  o3
    6046. 

  6046.    real(r8) utco2(pcols)     ! Total column  absorber amount of  co2
    6047. 

  6047.    real(r8) uto2(pcols)      ! Total column  absorber amount of  o2
    6048. 

  6048. ! 
    6049. 

  6049. ! These arrays are defined for pver model layers; 0 refers to the extra
    6050. 

  6050. ! layer on top:
    6051. 

  6051. ! 
    6052. 

  6052.    real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
    6053. 

  6053.    real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
    6054. 

  6054.    real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
    6055. 

  6055.    real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
    6056. 

  6056.    real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer
    6057. 

    6058. 

  6058.    real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad
    6059. 

  6059.    real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad
    6060. 

  6060.    real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad
    6061. 

  6061.    real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad
    6062. 

  6062.    real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer
    6063. 

    6064. 

  6064.    real(r8) flxdiv           ! Flux divergence for layer
    6065. 

  6065. ! 
    6066. 

  6066. ! 
    6067. 

  6067. ! Radiative Properties:
    6068. 

  6068. ! 
    6069. 

  6069. ! There are 1 classes of properties:
    6070. 

  6070. ! (1. All-sky bulk properties
    6071. 

  6071. ! (2. Clear-sky properties
    6072. 

  6072. ! 
    6073. 

  6073. ! The first set of properties are generated during step 2 of the solution.
    6074. 

  6074. ! 
    6075. 

  6075. ! These arrays are defined at model interfaces; in 1st index (for level #),
    6076. 

  6076. ! 0 is the top of the extra layer above the model top, and
    6077. 

  6077. ! pverp is the earth surface.  2nd index is for cloud configuration
    6078. 

  6078. ! defined over a whole column.
    6079. 

  6079. ! 
    6080. 

  6080.    real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above
    6081. 

  6081.    real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above
    6082. 

  6082.    real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below
    6083. 

  6083.    real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below
    6084. 

  6084.    real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above
    6085. 

  6085. ! 
    6086. 

  6086. ! Bulk properties used during the clear-sky calculation.
    6087. 

  6087. ! 
    6088. 

  6088.    real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above
    6089. 

  6089.    real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above
    6090. 

  6090.    real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below
    6091. 

  6091.    real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below
    6092. 

  6092.    real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above
    6093. 

    6094. 

  6094.    real(r8) fluxup(0:pverp)  ! Up   flux at model interface
    6095. 

  6095.    real(r8) fluxdn(0:pverp)  ! Down flux at model interface
    6096. 

  6096.    real(r8) wexptdn          ! Direct solar beam trans. to surface
    6097. 

    6098. 

  6098. ! moved to here from the module storage above, because these have to be thread-private.  JM 20100217
    6099. 

  6099.    real(r8) abarli           ! A coefficient for current spectral band
    6100. 

  6100.    real(r8) bbarli           ! B coefficient for current spectral band
    6101. 

  6101.    real(r8) cbarli           ! C coefficient for current spectral band
    6102. 

  6102.    real(r8) dbarli           ! D coefficient for current spectral band
    6103. 

  6103.    real(r8) ebarli           ! E coefficient for current spectral band
    6104. 

  6104.    real(r8) fbarli           ! F coefficient for current spectral band
    6105. 

    6106. 

  6106.    real(r8) abarii           ! A coefficient for current spectral band
    6107. 

  6107.    real(r8) bbarii           ! B coefficient for current spectral band
    6108. 

  6108.    real(r8) cbarii           ! C coefficient for current spectral band
    6109. 

  6109.    real(r8) dbarii           ! D coefficient for current spectral band
    6110. 

  6110.    real(r8) ebarii           ! E coefficient for current spectral band
    6111. 

  6111.    real(r8) fbarii           ! F coefficient for current spectral band
    6112. 

  6112. ! JM 20100217
    6113. 

    6114. 

  6114. ! 
    6115. 

  6115. !-----------------------------------------------------------------------
    6116. 

  6116. ! START OF CALCULATION
    6117. 

  6117. !-----------------------------------------------------------------------
    6118. 

  6118. ! 
    6119. 

  6119. !  write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk
    6120. 

    6121. 

  6121.    do i=1, ncol
    6122. 

  6122. ! 
    6123. 

  6123. ! Initialize output fields:
    6124. 

  6124. ! 
    6125. 

  6125.       fsds(i)     = 0.0_r8
    6126. 

    6127. 

  6127.       fsnirtoa(i) = 0.0_r8
    6128. 

  6128.       fsnrtoac(i) = 0.0_r8
    6129. 

  6129.       fsnrtoaq(i) = 0.0_r8
    6130. 

    6131. 

  6131.       fsns(i)     = 0.0_r8
    6132. 

  6132.       fsnsc(i)    = 0.0_r8
    6133. 

  6133.       fsdsc(i)    = 0.0_r8
    6134. 

    6135. 

  6135.       fsnt(i)     = 0.0_r8
    6136. 

  6136.       fsntc(i)    = 0.0_r8
    6137. 

  6137.       fsntoa(i)   = 0.0_r8
    6138. 

  6138.       fsntoac(i)  = 0.0_r8
    6139. 

    6140. 

  6140.       solin(i)    = 0.0_r8
    6141. 

    6142. 

  6142.       sols(i)     = 0.0_r8
    6143. 

  6143.       soll(i)     = 0.0_r8
    6144. 

  6144.       solsd(i)    = 0.0_r8
    6145. 

  6145.       solld(i)    = 0.0_r8
    6146. 

    6147. 

  6147. ! initialize added downward/upward total and clear sky fluxes
    6148. 

    6149. 

  6149.          do k=1,pverp
    6150. 

  6150.             fsup(i,k)  = 0.0_r8
    6151. 

  6151.             fsupc(i,k) = 0.0_r8
    6152. 

  6152.             fsdn(i,k)  = 0.0_r8
    6153. 

  6153.             fsdnc(i,k) = 0.0_r8
    6154. 

  6154.             tauxcl(i,k-1) = 0.0_r8
    6155. 

  6155.             tauxci(i,k-1) = 0.0_r8
    6156. 

  6156.          end do
    6157. 

    6158. 

  6158.       do k=1, pver
    6159. 

  6159.          qrs(i,k) = 0.0_r8
    6160. 

  6160.       end do
    6161. 

    6162. 

  6162.       ! initialize aerosol diagnostic fields to 0.0 
    6163. 

  6163.       ! Average can be obtained by dividing <aerod>/<frc_day>
    6164. 

  6164.       do kaer = 1, naer_groups
    6165. 

  6165.          do ns = 1, nspint
    6166. 

  6166.             frc_day(i) = 0.0_r8
    6167. 

  6167.             aertau(i,ns,kaer) = 0.0_r8
    6168. 

  6168.             aerssa(i,ns,kaer) = 0.0_r8
    6169. 

  6169.             aerasm(i,ns,kaer) = 0.0_r8
    6170. 

  6170.             aerfwd(i,ns,kaer) = 0.0_r8
    6171. 

  6171.          end do
    6172. 

  6172.       end do
    6173. 

    6174. 

  6174.    end do
    6175. 

  6175. ! 
    6176. 

  6176. ! Compute starting, ending daytime loop indices:
    6177. 

  6177. !  *** Note this logic assumes day and night points are contiguous so
    6178. 

  6178. !  *** will not work in general with chunked data structure.
    6179. 

  6179. ! 
    6180. 

  6180.    ndayc = 0
    6181. 

  6181.    do i=1,ncol
    6182. 

  6182.       if (coszrs(i) > 0.0_r8) then
    6183. 

  6183.          ndayc = ndayc + 1
    6184. 

  6184.          idayc(ndayc) = i
    6185. 

  6185.       end if
    6186. 

  6186.    end do
    6187. 

  6187. ! 
    6188. 

  6188. ! If night everywhere, return:
    6189. 

  6189. ! 
    6190. 

  6190.    if (ndayc == 0) return
    6191. 

  6191. ! 
    6192. 

  6192. ! Perform other initializations
    6193. 

  6193. ! 
    6194. 

  6194.    tmp1   = 0.5_r8/(gravit*sslp)
    6195. 

  6195.    tmp2   = delta/gravit
    6196. 

  6196.    sqrco2 = sqrt(co2mmr)
    6197. 

    6198. 

  6198.    do n=1,ndayc
    6199. 

  6199.       i=idayc(n)
    6200. 

  6200. ! 
    6201. 

  6201. ! Define solar incident radiation and interface pressures:
    6202. 

  6202. ! 
    6203. 

  6203. !        solin(i)  = scon*eccf*coszrs(i)
    6204. 

  6204. !WRF use SOLCON (MKS) calculated outside
    6205. 

  6205.          solin(i)  = solcon*coszrs(i)*1000.
    6206. 

  6206.          pflx(i,0) = 0._r8
    6207. 

  6207.          do k=1,pverp
    6208. 

  6208.             pflx(i,k) = pint(i,k)
    6209. 

  6209.          end do
    6210. 

  6210. ! 
    6211. 

  6211. ! Compute optical paths:
    6212. 

  6212. ! 
    6213. 

  6213.          ptop      = pflx(i,1)
    6214. 

  6214.          ptho2     = o2mmr * ptop / gravit
    6215. 

  6215.          ptho3     = o3mmr(i,1) * ptop / gravit
    6216. 

  6216.          pthco2    = sqrco2 * (ptop / gravit)
    6217. 

  6217.          h2ostr    = sqrt( 1._r8 / h2ommr(i,1) )
    6218. 

  6218.          zenfac(i) = sqrt(coszrs(i))
    6219. 

  6219.          pthh2o    = ptop**2*tmp1 + (ptop*rga)* &
    6220. 

  6220.                     (h2ostr*zenfac(i)*delta)
    6221. 

  6221.          uh2o(i,0) = h2ommr(i,1)*pthh2o
    6222. 

  6222.          uco2(i,0) = zenfac(i)*pthco2
    6223. 

  6223.          uo2 (i,0) = zenfac(i)*ptho2
    6224. 

  6224.          uo3 (i,0) = ptho3
    6225. 

  6225.          uaer(i,0) = 0.0_r8
    6226. 

  6226.          do k=1,pver
    6227. 

  6227.             pdel      = pflx(i,k+1) - pflx(i,k)
    6228. 

  6228.             path      = pdel / gravit
    6229. 

  6229.             ptho2     = o2mmr * path
    6230. 

  6230.             ptho3     = o3mmr(i,k) * path
    6231. 

  6231.             pthco2    = sqrco2 * path
    6232. 

  6232.             h2ostr    = sqrt(1.0_r8/h2ommr(i,k))
    6233. 

  6233.             pthh2o    = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2
    6234. 

  6234.             uh2o(i,k) = h2ommr(i,k)*pthh2o
    6235. 

  6235.             uco2(i,k) = zenfac(i)*pthco2
    6236. 

  6236.             uo2 (i,k) = zenfac(i)*ptho2
    6237. 

  6237.             uo3 (i,k) = ptho3
    6238. 

  6238.             usul(i,k) = aermmr(i,k,idxSUL) * path 
    6239. 

  6239.             ubg(i,k) = aermmr(i,k,idxBG) * path 
    6240. 

  6240.             usslt(i,k) = aermmr(i,k,idxSSLT) * path
    6241. 

  6241.             if (usslt(i,k) .lt. 0.0) then  ! usslt is sometimes small and negative, will be fixed
    6242. 

  6242.               usslt(i,k) = 0.0
    6243. 

  6243.             end if
    6244. 

  6244.             ucphil(i,k) = aermmr(i,k,idxOCPHI) * path
    6245. 

  6245.             ucphob(i,k) = aermmr(i,k,idxOCPHO) * path
    6246. 

  6246.             ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path
    6247. 

  6247.             uvolc(i,k) =  aermmr(i,k,idxVOLC)
    6248. 

  6248.             do ksz = 1, ndstsz
    6249. 

  6249.               udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path
    6250. 

  6250.             end do
    6251. 

  6251.          end do
    6252. 

  6252. ! 
    6253. 

  6253. ! Compute column absorber amounts for the clear sky computation:
    6254. 

  6254. ! 
    6255. 

  6255.          uth2o(i) = 0.0_r8
    6256. 

  6256.          uto3(i)  = 0.0_r8
    6257. 

  6257.          utco2(i) = 0.0_r8
    6258. 

  6258.          uto2(i)  = 0.0_r8
    6259. 

    6260. 

  6260.          do k=1,pver
    6261. 

  6261.             uth2o(i) = uth2o(i) + uh2o(i,k)
    6262. 

  6262.             uto3(i)  = uto3(i)  + uo3(i,k)
    6263. 

  6263.             utco2(i) = utco2(i) + uco2(i,k)
    6264. 

  6264.             uto2(i)  = uto2(i)  + uo2(i,k)
    6265. 

  6265.          end do
    6266. 

  6266. ! 
    6267. 

  6267. ! Set cloud properties for top (0) layer; so long as tauxcl is zero,
    6268. 

  6268. ! there is no cloud above top of model; the other cloud properties
    6269. 

  6269. ! are arbitrary:
    6270. 

  6270. ! 
    6271. 

  6271.          tauxcl(i,0)  = 0._r8
    6272. 

  6272.          wcl(i,0)     = 0.999999_r8
    6273. 

  6273.          gcl(i,0)     = 0.85_r8
    6274. 

  6274.          fcl(i,0)     = 0.725_r8
    6275. 

  6275.          tauxci(i,0)  = 0._r8
    6276. 

  6276.          wci(i,0)     = 0.999999_r8
    6277. 

  6277.          gci(i,0)     = 0.85_r8
    6278. 

  6278.          fci(i,0)     = 0.725_r8
    6279. 

  6279. ! 
    6280. 

  6280. ! Aerosol 
    6281. 

  6281. ! 
    6282. 

  6282.          tauxar(i,0)  = 0._r8
    6283. 

  6283.          wa(i,0)      = 0.925_r8
    6284. 

  6284.          ga(i,0)      = 0.850_r8
    6285. 

  6285.          fa(i,0)      = 0.7225_r8
    6286. 

  6286. ! 
    6287. 

  6287. ! End  do n=1,ndayc
    6288. 

  6288. ! 
    6289. 

  6289.    end do
    6290. 

  6290. ! 
    6291. 

  6291. ! Begin spectral loop
    6292. 

  6292. ! 
    6293. 

  6293.    do ns=1,nspint
    6294. 

  6294. ! 
    6295. 

  6295. ! Set index for cloud particle properties based on the wavelength,
    6296. 

  6296. ! according to A. Slingo (1989) equations 1-3:
    6297. 

  6297. ! Use index 1 (0.25 to 0.69 micrometers) for visible
    6298. 

  6298. ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared
    6299. 

  6299. ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared
    6300. 

  6300. ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared
    6301. 

  6301. ! 
    6302. 

  6302. ! Note that the minimum wavelength is encoded (with .001, .002, .003)
    6303. 

  6303. ! in order to specify the index appropriate for the near-infrared
    6304. 

  6304. ! cloud absorption properties
    6305. 

  6305. ! 
    6306. 

  6306.       if(wavmax(ns) <= 0.7_r8) then
    6307. 

  6307.          indxsl = 1
    6308. 

  6308.       else if(wavmin(ns) == 0.700_r8) then
    6309. 

  6309.          indxsl = 2
    6310. 

  6310.       else if(wavmin(ns) == 0.701_r8) then
    6311. 

  6311.          indxsl = 3
    6312. 

  6312.       else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then
    6313. 

  6313.          indxsl = 4
    6314. 

  6314.       end if
    6315. 

  6315. ! 
    6316. 

  6316. ! Set cloud extinction optical depth, single scatter albedo,
    6317. 

  6317. ! asymmetry parameter, and forward scattered fraction:
    6318. 

  6318. ! 
    6319. 

  6319.       abarli = abarl(indxsl)
    6320. 

  6320.       bbarli = bbarl(indxsl)
    6321. 

  6321.       cbarli = cbarl(indxsl)
    6322. 

  6322.       dbarli = dbarl(indxsl)
    6323. 

  6323.       ebarli = ebarl(indxsl)
    6324. 

  6324.       fbarli = fbarl(indxsl)
    6325. 

  6325. ! 
    6326. 

  6326.       abarii = abari(indxsl)
    6327. 

  6327.       bbarii = bbari(indxsl)
    6328. 

  6328.       cbarii = cbari(indxsl)
    6329. 

  6329.       dbarii = dbari(indxsl)
    6330. 

  6330.       ebarii = ebari(indxsl)
    6331. 

  6331.       fbarii = fbari(indxsl)
    6332. 

  6332. ! 
    6333. 

  6333. ! adjustfraction within spectral interval to allow for the possibility of
    6334. 

  6334. ! sub-divisions within a particular interval:
    6335. 

  6335. ! 
    6336. 

  6336.       psf(ns) = 1.0_r8
    6337. 

  6337.       if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns)
    6338. 

  6338.       if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns)
    6339. 

  6339.       if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns)
    6340. 

    6341. 

  6341.       do n=1,ndayc
    6342. 

  6342.          i=idayc(n)
    6343. 

    6344. 

  6344.          frc_day(i) = 1.0_r8
    6345. 

  6345.          do kaer = 1, naer_groups
    6346. 

  6346.             aertau(i,ns,kaer) = 0.0
    6347. 

  6347.             aerssa(i,ns,kaer) = 0.0
    6348. 

  6348.             aerasm(i,ns,kaer) = 0.0
    6349. 

  6349.             aerfwd(i,ns,kaer) = 0.0
    6350. 

  6350.          end do
    6351. 

    6352. 

  6352.             do k=1,pver
    6353. 

  6353. ! 
    6354. 

  6354. ! liquid
    6355. 

  6355. ! 
    6356. 

  6356.                tmp1l = abarli + bbarli/rel(i,k)
    6357. 

  6357.                tmp2l = 1._r8 - cbarli - dbarli*rel(i,k)
    6358. 

  6358.                tmp3l = fbarli*rel(i,k)
    6359. 

  6359. ! 
    6360. 

  6360. ! ice
    6361. 

  6361. ! 
    6362. 

  6362.                tmp1i = abarii + bbarii/rei(i,k)
    6363. 

  6363.                tmp2i = 1._r8 - cbarii - dbarii*rei(i,k)
    6364. 

  6364.                tmp3i = fbarii*rei(i,k)
    6365. 

    6366. 

  6366.                if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
    6367. 

  6367.                   tauxcl(i,k) = cliqwp(i,k)*tmp1l
    6368. 

  6368.                   tauxci(i,k) = cicewp(i,k)*tmp1i
    6369. 

  6369.                else
    6370. 

  6370.                   tauxcl(i,k) = 0.0
    6371. 

  6371.                   tauxci(i,k) = 0.0
    6372. 

  6372.                endif
    6373. 

  6373. ! 
    6374. 

  6374. ! Do not let single scatter albedo be 1.  Delta-eddington solution
    6375. 

  6375. ! for non-conservative case has different analytic form from solution
    6376. 

  6376. ! for conservative case, and raddedmx is written for non-conservative case.
    6377. 

  6377. ! 
    6378. 

  6378.                wcl(i,k) = min(tmp2l,.999999_r8)
    6379. 

  6379.                gcl(i,k) = ebarli + tmp3l
    6380. 

  6380.                fcl(i,k) = gcl(i,k)*gcl(i,k)
    6381. 

  6381. ! 
    6382. 

  6382.                wci(i,k) = min(tmp2i,.999999_r8)
    6383. 

  6383.                gci(i,k) = ebarii + tmp3i
    6384. 

  6384.                fci(i,k) = gci(i,k)*gci(i,k)
    6385. 

  6385. ! 
    6386. 

  6386. ! Set aerosol properties
    6387. 

  6387. ! Conversion factor to adjust aerosol extinction (m2/g)
    6388. 

  6388. ! 
    6389. 

  6389.                rhtrunc = rh(i,k)
    6390. 

  6390.                rhtrunc = min(rh(i,k),1._r8)
    6391. 

  6391. !              if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX')
    6392. 

  6392.                krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1)
    6393. 

  6393.                wrh = rhtrunc * nrh - krh
    6394. 

    6395. 

  6395.                ! linear interpolation of optical properties between rh table points
    6396. 

  6396.                ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh
    6397. 

  6397.                ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh
    6398. 

  6398.                kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh
    6399. 

  6399.                wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh
    6400. 

  6400.                wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh
    6401. 

  6401.                wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh
    6402. 

  6402.                gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh
    6403. 

  6403.                gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh
    6404. 

  6404.                gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh
    6405. 

    6406. 

  6406.                tau_sul = 1.e4 * ksuli * usul(i,k)
    6407. 

  6407.                tau_sslt = 1.e4 * ksslti * usslt(i,k)
    6408. 

  6408.                tau_cphil = 1.e4 * kcphili * ucphil(i,k)
    6409. 

  6409.                tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k)
    6410. 

  6410.                tau_cb = 1.e4 * kcb(ns) * ucb(i,k)
    6411. 

  6411.                tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k)
    6412. 

  6412.                tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k)
    6413. 

  6413.                tau_bg = 1.e4 * kbg(ns) * ubg(i,k)
    6414. 

    6415. 

  6415.                tau_w_sul = tau_sul * wsuli
    6416. 

  6416.                tau_w_sslt = tau_sslt * wsslti
    6417. 

  6417.                tau_w_cphil = tau_cphil * wcphili
    6418. 

  6418.                tau_w_cphob = tau_cphob * wcphob(ns)
    6419. 

  6419.                tau_w_cb = tau_cb * wcb(ns)
    6420. 

  6420.                tau_w_volc = tau_volc * wvolc(ns)
    6421. 

  6421.                tau_w_dst(:) = tau_dst(:) * wdst(:,ns)
    6422. 

  6422.                tau_w_bg = tau_bg * wbg(ns)
    6423. 

    6424. 

  6424.                tau_w_g_sul = tau_w_sul * gsuli
    6425. 

  6425.                tau_w_g_sslt = tau_w_sslt * gsslti
    6426. 

  6426.                tau_w_g_cphil = tau_w_cphil * gcphili
    6427. 

  6427.                tau_w_g_cphob = tau_w_cphob * gcphob(ns)
    6428. 

  6428.                tau_w_g_cb = tau_w_cb * gcb(ns)
    6429. 

  6429.                tau_w_g_volc = tau_w_volc * gvolc(ns)
    6430. 

  6430.                tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns)
    6431. 

  6431.                tau_w_g_bg = tau_w_bg * gbg(ns)
    6432. 

    6433. 

  6433.                f_sul = gsuli * gsuli
    6434. 

  6434.                f_sslt = gsslti * gsslti
    6435. 

  6435.                f_cphil = gcphili * gcphili
    6436. 

  6436.                f_cphob = gcphob(ns) * gcphob(ns)
    6437. 

  6437.                f_cb = gcb(ns) * gcb(ns)
    6438. 

  6438.                f_volc = gvolc(ns) * gvolc(ns)
    6439. 

  6439.                f_dst(:) = gdst(:,ns) * gdst(:,ns)
    6440. 

  6440.                f_bg = gbg(ns) * gbg(ns)
    6441. 

    6442. 

  6442.                tau_w_f_sul = tau_w_sul * f_sul
    6443. 

  6443.                tau_w_f_bg = tau_w_bg * f_bg
    6444. 

  6444.                tau_w_f_sslt = tau_w_sslt * f_sslt
    6445. 

  6445.                tau_w_f_cphil = tau_w_cphil * f_cphil
    6446. 

  6446.                tau_w_f_cphob = tau_w_cphob * f_cphob
    6447. 

  6447.                tau_w_f_cb = tau_w_cb * f_cb
    6448. 

  6448.                tau_w_f_volc = tau_w_volc * f_volc
    6449. 

  6449.                tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:)
    6450. 

  6450. !
    6451. 

  6451. ! mix dust aerosol size bins
    6452. 

  6452. !   w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere
    6453. 

  6453. !   but calculate them anyway for future use
    6454. 

  6454. !
    6455. 

  6455.                tau_dst_tot = sum(tau_dst)
    6456. 

  6456.                tau_w_dst_tot = sum(tau_w_dst)
    6457. 

  6457.                tau_w_g_dst_tot = sum(tau_w_g_dst)
    6458. 

  6458.                tau_w_f_dst_tot = sum(tau_w_f_dst)
    6459. 

    6460. 

  6460.                if (tau_dst_tot .gt. 0.0) then
    6461. 

  6461.                  w_dst_tot = tau_w_dst_tot / tau_dst_tot
    6462. 

  6462.                else
    6463. 

  6463.                  w_dst_tot = 0.0
    6464. 

  6464.                endif
    6465. 

    6466. 

  6466.                if (tau_w_dst_tot .gt. 0.0) then
    6467. 

  6467.                  g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot
    6468. 

  6468.                  f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot
    6469. 

  6469.                else
    6470. 

  6470.                  g_dst_tot = 0.0
    6471. 

  6471.                  f_dst_tot = 0.0
    6472. 

  6472.                endif
    6473. 

  6473. !
    6474. 

  6474. ! mix aerosols
    6475. 

  6475. !
    6476. 

  6476.                tau_tot     = tau_sul + tau_sslt &
    6477. 

  6477.                            + tau_cphil + tau_cphob + tau_cb + tau_dst_tot
    6478. 

  6478.                tau_tot     = tau_tot + tau_bg + tau_volc
    6479. 

    6480. 

  6480.                tau_w_tot   = tau_w_sul + tau_w_sslt &
    6481. 

  6481.                            + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot
    6482. 

  6482.                tau_w_tot   = tau_w_tot + tau_w_bg + tau_w_volc
    6483. 

    6484. 

  6484.                tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt &
    6485. 

  6485.                            + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot
    6486. 

  6486.                tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc
    6487. 

    6488. 

  6488.                tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt &
    6489. 

  6489.                            + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot
    6490. 

  6490.                tau_w_f_tot = tau_w_f_tot + tau_w_f_bg  + tau_w_f_volc
    6491. 

    6492. 

  6492.                if (tau_tot .gt. 0.0) then
    6493. 

  6493.                  w_tot = tau_w_tot / tau_tot
    6494. 

  6494.                else
    6495. 

  6495.                  w_tot = 0.0
    6496. 

  6496.                endif
    6497. 

    6498. 

  6498.                if (tau_w_tot .gt. 0.0) then
    6499. 

  6499.                  g_tot = tau_w_g_tot / tau_w_tot
    6500. 

  6500.                  f_tot = tau_w_f_tot / tau_w_tot
    6501. 

  6501.                else
    6502. 

  6502.                  g_tot = 0.0
    6503. 

  6503.                  f_tot = 0.0
    6504. 

  6504.                endif
    6505. 

    6506. 

  6506.                tauxar(i,k) = tau_tot
    6507. 

  6507.                wa(i,k)     = min(w_tot, 0.999999_r8)
    6508. 

  6508.                if (g_tot.gt.1._r8) write(6,*) "g_tot > 1"
    6509. 

  6509.                if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1"
    6510. 

  6510. !              if (g_tot.gt.1._r8) call endrun ('RADCSWMX')
    6511. 

  6511. !              if (g_tot.lt.-1._r8) call endrun ('RADCSWMX')
    6512. 

  6512.                ga(i,k)     = g_tot
    6513. 

  6513.                if (f_tot.gt.1._r8) write(6,*)"f_tot > 1"
    6514. 

  6514.                if (f_tot.lt.0._r8) write(6,*)"f_tot < 0"
    6515. 

  6515. !              if (f_tot.gt.1._r8) call endrun ('RADCSWMX')
    6516. 

  6516. !              if (f_tot.lt.0._r8) call endrun ('RADCSWMX')
    6517. 

  6517.                fa(i,k)     = f_tot
    6518. 

    6519. 

  6519.                aertau(i,ns,1) = aertau(i,ns,1) + tau_sul
    6520. 

  6520.                aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt
    6521. 

  6521.                aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb
    6522. 

  6522.                aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot
    6523. 

  6523.                aertau(i,ns,5) = aertau(i,ns,5) + tau_bg
    6524. 

  6524.                aertau(i,ns,6) = aertau(i,ns,6) + tau_volc
    6525. 

  6525.                aertau(i,ns,7) = aertau(i,ns,7) + tau_tot
    6526. 

    6527. 

  6527.                aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul
    6528. 

  6528.                aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt
    6529. 

  6529.                aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb
    6530. 

  6530.                aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot
    6531. 

  6531.                aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg
    6532. 

  6532.                aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc
    6533. 

  6533.                aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot
    6534. 

    6535. 

  6535.                aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul
    6536. 

  6536.                aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt
    6537. 

  6537.                aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb
    6538. 

  6538.                aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot
    6539. 

  6539.                aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg
    6540. 

  6540.                aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc
    6541. 

  6541.                aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot
    6542. 

    6543. 

  6543.                aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul
    6544. 

  6544.                aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt
    6545. 

  6545.                aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb
    6546. 

  6546.                aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot
    6547. 

  6547.                aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg
    6548. 

  6548.                aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc
    6549. 

  6549.                aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot
    6550. 

    6551. 

  6551. ! 
    6552. 

  6552. ! End do k=1,pver
    6553. 

  6553. ! 
    6554. 

  6554.             end do
    6555. 

    6556. 

  6556.             ! normalize aerosol optical diagnostic fields
    6557. 

  6557.             do kaer = 1, naer_groups
    6558. 

    6559. 

  6559.                if (aerssa(i,ns,kaer) .gt. 0.0) then   ! aerssa currently holds product of tau and ssa
    6560. 

  6560.                   aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer)
    6561. 

  6561.                   aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer)
    6562. 

  6562.                else
    6563. 

  6563.                   aerasm(i,ns,kaer) = 0.0_r8
    6564. 

  6564.                   aerfwd(i,ns,kaer) = 0.0_r8
    6565. 

  6565.                end if
    6566. 

    6567. 

  6567.                if (aertau(i,ns,kaer) .gt. 0.0) then
    6568. 

  6568.                   aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer)
    6569. 

  6569.                else
    6570. 

  6570.                   aerssa(i,ns,kaer) = 0.0_r8
    6571. 

  6571.                end if
    6572. 

    6573. 

  6573.             end do
    6574. 

    6575. 

    6576. 

  6576. ! 
    6577. 

  6577. ! End do n=1,ndayc
    6578. 

  6578. ! 
    6579. 

  6579.       end do
    6580. 

    6581. 

  6581. ! 
    6582. 

  6582. ! Set reflectivities for surface based on mid-point wavelength
    6583. 

  6583. ! 
    6584. 

  6584.       wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns))
    6585. 

  6585. ! 
    6586. 

  6586. ! Wavelength less  than 0.7 micro-meter
    6587. 

  6587. ! 
    6588. 

  6588.       if (wavmid(ns) < 0.7_r8 ) then
    6589. 

  6589.          do n=1,ndayc
    6590. 

  6590.             i=idayc(n)
    6591. 

  6591.                albdir(i,ns) = asdir(i)
    6592. 

  6592.                albdif(i,ns) = asdif(i)
    6593. 

  6593.          end do
    6594. 

  6594. ! 
    6595. 

  6595. ! Wavelength greater than 0.7 micro-meter
    6596. 

  6596. ! 
    6597. 

  6597.       else
    6598. 

  6598.          do n=1,ndayc
    6599. 

  6599.             i=idayc(n)
    6600. 

  6600.                albdir(i,ns) = aldir(i)
    6601. 

  6601.                albdif(i,ns) = aldif(i)
    6602. 

  6602.          end do
    6603. 

  6603.       end if
    6604. 

  6604.       trayoslp = raytau(ns)/sslp
    6605. 

  6605. ! 
    6606. 

  6606. ! Layer input properties now completely specified; compute the
    6607. 

  6607. ! delta-Eddington solution reflectivities and transmissivities
    6608. 

  6608. ! for each layer
    6609. 

  6609. ! 
    6610. 

  6610.       call raddedmx(pver, pverp, pcols, coszrs   ,ndayc    ,idayc   , &
    6611. 

  6611.               abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , &
    6612. 

  6612.               uh2o     ,uo3      ,uco2     ,uo2      , &
    6613. 

  6613.               trayoslp ,pflx     ,ns       , &
    6614. 

  6614.               tauxcl   ,wcl      ,gcl      ,fcl      , &
    6615. 

  6615.               tauxci   ,wci      ,gci      ,fci      , &
    6616. 

  6616.               tauxar   ,wa       ,ga       ,fa       , &
    6617. 

  6617.               rdir     ,rdif     ,tdir     ,tdif     ,explay  , &
    6618. 

  6618.               rdirc    ,rdifc    ,tdirc    ,tdifc    ,explayc )
    6619. 

  6619. ! 
    6620. 

  6620. ! End spectral loop
    6621. 

  6621. ! 
    6622. 

  6622.    end do
    6623. 

  6623. ! 
    6624. 

  6624. !----------------------------------------------------------------------
    6625. 

  6625. ! 
    6626. 

  6626. ! Solution for max/random cloud overlap.  
    6627. 

  6627. ! 
    6628. 

  6628. ! Steps:
    6629. 

  6629. ! (1. delta-Eddington solution for each layer (called above)
    6630. 

  6630. ! 
    6631. 

  6631. ! (2. The adding method is used to
    6632. 

  6632. ! compute the reflectivity and transmissivity to direct and diffuse
    6633. 

  6633. ! radiation from the top and bottom of the atmosphere for each
    6634. 

  6634. ! cloud configuration.  This calculation is based upon the
    6635. 

  6635. ! max-random overlap assumption.
    6636. 

  6636. ! 
    6637. 

  6637. ! (3. to solve for the fluxes, combine the
    6638. 

  6638. ! bulk properties of the atmosphere above/below the region.
    6639. 

  6639. ! 
    6640. 

  6640. ! Index calculations for steps 2-3 are performed outside spectral
    6641. 

  6641. ! loop to avoid redundant calculations.  Index calculations (with
    6642. 

  6642. ! application of areamin & nconfgmax conditions) are performed 
    6643. 

  6643. ! first to identify the minimum subset of terms for the configurations 
    6644. 

  6644. ! satisfying the areamin & nconfgmax conditions. This minimum set is 
    6645. 

  6645. ! used to identify the corresponding minimum subset of terms in 
    6646. 

  6646. ! steps 2 and 3.
    6647. 

  6647. ! 
    6648. 

    6649. 

  6649.    do n=1,ndayc
    6650. 

  6650.       i=idayc(n)
    6651. 

    6652. 

  6652. !----------------------------------------------------------------------
    6653. 

  6653. ! INDEX CALCULATIONS FOR MAX OVERLAP
    6654. 

  6654. ! 
    6655. 

  6655. ! The column is divided into sets of adjacent layers, called regions, 
    6656. 

  6656. ! in which the clouds are maximally overlapped.  The clouds are
    6657. 

  6657. ! randomly overlapped between different regions.  The number of
    6658. 

  6658. ! regions in a column is set by nmxrgn, and the range of pressures
    6659. 

  6659. ! included in each region is set by pmxrgn.  
    6660. 

  6660. ! 
    6661. 

  6661. ! The following calculations determine the number of unique cloud 
    6662. 

  6662. ! configurations (assuming maximum overlap), called "streams",
    6663. 

  6663. ! within each region. Each stream consists of a vector of binary
    6664. 

  6664. ! clouds (either 0 or 100% cloud cover).  Over the depth of the region, 
    6665. 

  6665. ! each stream requires a separate calculation of radiative properties. These
    6666. 

  6666. ! properties are generated using the adding method from
    6667. 

  6667. ! the radiative properties for each layer calculated by raddedmx.
    6668. 

  6668. ! 
    6669. 

  6669. ! The upward and downward-propagating streams are treated
    6670. 

  6670. ! separately.
    6671. 

  6671. ! 
    6672. 

  6672. ! We will refer to a particular configuration of binary clouds
    6673. 

  6673. ! within a single max-overlapped region as a "stream".  We will 
    6674. 

  6674. ! refer to a particular arrangement of binary clouds over the entire column
    6675. 

  6675. ! as a "configuration".
    6676. 

  6676. ! 
    6677. 

  6677. ! This section of the code generates the following information:
    6678. 

  6678. ! (1. nrgn    : the true number of max-overlap regions (need not = nmxrgn)
    6679. 

  6679. ! (2. nstr    : the number of streams in a region (>=1)
    6680. 

  6680. ! (3. cstr    : flags for presence of clouds at each layer in each stream
    6681. 

  6681. ! (4. wstr    : the fractional horizontal area of a grid box covered
    6682. 

  6682. ! by each stream
    6683. 

  6683. ! (5. kx1,2   : level indices for top/bottom of each region
    6684. 

  6684. ! 
    6685. 

  6685. ! The max-overlap calculation proceeds in 3 stages:
    6686. 

  6686. ! (1. compute layer radiative properties in raddedmx.
    6687. 

  6687. ! (2. combine these properties between layers 
    6688. 

  6688. ! (3. combine properties to compute fluxes at each interface.  
    6689. 

  6689. ! 
    6690. 

  6690. ! Most of the indexing information calculated here is used in steps 2-3
    6691. 

  6691. ! after the call to raddedmx.
    6692. 

  6692. ! 
    6693. 

  6693. ! Initialize indices for layers to be max-overlapped
    6694. 

  6694. ! 
    6695. 

  6695. ! Loop to handle fix in totwgt=0. For original overlap config 
    6696. 

  6696. ! from npasses = 0.
    6697. 

  6697. ! 
    6698. 

  6698.          npasses = 0
    6699. 

  6699.          do
    6700. 

  6700.             do irgn = 0, nmxrgn(i)
    6701. 

  6701.                kx2(irgn) = 0
    6702. 

  6702.             end do
    6703. 

  6703.             mrgn = 0
    6704. 

  6704. ! 
    6705. 

  6705. ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
    6706. 

  6706. ! 
    6707. 

  6707.             do irgn = 1, nmxrgn(i)
    6708. 

  6708. ! 
    6709. 

  6709. ! Calculate min/max layer indices inside region.  
    6710. 

  6710. ! 
    6711. 

  6711.                region_found = .false.
    6712. 

  6712.                if (kx2(irgn-1) < pver) then
    6713. 

  6713.                   k1 = kx2(irgn-1)+1
    6714. 

  6714.                   kx1(irgn) = k1
    6715. 

  6715.                   kx2(irgn) = k1-1
    6716. 

  6716.                   do k2 = pver, k1, -1
    6717. 

  6717.                      if (pmid(i,k2) <= pmxrgn(i,irgn)) then
    6718. 

  6718.                         kx2(irgn) = k2
    6719. 

  6719.                         mrgn = mrgn+1
    6720. 

  6720.                         region_found = .true.
    6721. 

  6721.                         exit
    6722. 

  6722.                      end if
    6723. 

  6723.                   end do
    6724. 

  6724.                else
    6725. 

  6725.                   exit
    6726. 

  6726.                endif
    6727. 

    6728. 

  6728.                if (region_found) then
    6729. 

  6729. ! 
    6730. 

  6730. ! Sort cloud areas and corresponding level indices.  
    6731. 

  6731. ! 
    6732. 

  6732.                   nxs = 0
    6733. 

  6733.                   if (cldeps > 0) then 
    6734. 

  6734.                      do k = k1,k2
    6735. 

  6735.                         if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
    6736. 

  6736.                            nxs = nxs+1
    6737. 

  6737.                            ksort(nxs) = k
    6738. 

  6738. ! 
    6739. 

  6739. ! We need indices for clouds in order of largest to smallest, so
    6740. 

  6740. ! sort 1-cld in ascending order
    6741. 

  6741. ! 
    6742. 

  6742.                            asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps)
    6743. 

  6743.                         end if
    6744. 

  6744.                      end do
    6745. 

  6745.                   else
    6746. 

  6746.                      do k = k1,k2
    6747. 

  6747.                         if (cld(i,k) >= cldmin) then
    6748. 

  6748.                            nxs = nxs+1
    6749. 

  6749.                            ksort(nxs) = k
    6750. 

  6750. ! 
    6751. 

  6751. ! We need indices for clouds in order of largest to smallest, so
    6752. 

  6752. ! sort 1-cld in ascending order
    6753. 

  6753. ! 
    6754. 

  6754.                            asort(nxs) = 1.0_r8-cld(i,k)
    6755. 

  6755.                         end if
    6756. 

  6756.                      end do
    6757. 

  6757.                   endif
    6758. 

  6758. ! 
    6759. 

  6759. ! If nxs eq 1, no need to sort. 
    6760. 

  6760. ! If nxs eq 2, sort by swapping if necessary
    6761. 

  6761. ! If nxs ge 3, sort using local sort routine
    6762. 

  6762. ! 
    6763. 

  6763.                   if (nxs == 2) then
    6764. 

  6764.                      if (asort(2) < asort(1)) then
    6765. 

  6765.                         ktmp = ksort(1)
    6766. 

  6766.                         ksort(1) = ksort(2)
    6767. 

  6767.                         ksort(2) = ktmp
    6768. 

    6769. 

  6769.                         atmp = asort(1)
    6770. 

  6770.                         asort(1) = asort(2)
    6771. 

  6771.                         asort(2) = atmp
    6772. 

  6772.                      endif
    6773. 

  6773.                   else if (nxs >= 3) then
    6774. 

  6774.                      call sortarray(nxs,asort,ksort)
    6775. 

  6775.                   endif
    6776. 

  6776. ! 
    6777. 

  6777. ! Construct wstr, cstr, nstr for this region
    6778. 

  6778. ! 
    6779. 

  6779.                   cstr(k1:k2,1:nxs+1) = 0
    6780. 

  6780.                   mstr = 1
    6781. 

  6781.                   cld0 = 0.0_r8
    6782. 

  6782.                   do l = 1, nxs
    6783. 

  6783.                      if (asort(l) /= cld0) then
    6784. 

  6784.                         wstr(mstr,mrgn) = asort(l) - cld0
    6785. 

  6785.                         cld0 = asort(l)
    6786. 

  6786.                         mstr = mstr + 1
    6787. 

  6787.                      endif
    6788. 

  6788.                      cstr(ksort(l),mstr:nxs+1) = 1
    6789. 

  6789.                   end do
    6790. 

  6790.                   nstr(mrgn) = mstr
    6791. 

  6791.                   wstr(mstr,mrgn) = 1.0_r8 - cld0
    6792. 

  6792. ! 
    6793. 

  6793. ! End test of region_found = true
    6794. 

  6794. ! 
    6795. 

  6795.                endif
    6796. 

  6796. ! 
    6797. 

  6797. ! End loop over regions irgn for max-overlap
    6798. 

  6798. ! 
    6799. 

  6799.             end do
    6800. 

  6800.             nrgn = mrgn
    6801. 

  6801. ! 
    6802. 

  6802. ! Finish construction of cstr for additional top layer
    6803. 

  6803. ! 
    6804. 

  6804.             cstr(0,1:nstr(1)) = 0
    6805. 

  6805. ! 
    6806. 

  6806. ! INDEX COMPUTATIONS FOR STEP 2-3
    6807. 

  6807. ! This section of the code generates the following information:
    6808. 

  6808. ! (1. totwgt     step 3     total frac. area of configurations satisfying
    6809. 

  6809. ! areamin & nconfgmax criteria
    6810. 

  6810. ! (2. wgtv       step 3     frac. area of configurations 
    6811. 

  6811. ! (3. ccon       step 2     binary flag for clouds in each configuration
    6812. 

  6812. ! (4. nconfig    steps 2-3  number of configurations
    6813. 

  6813. ! (5. nuniqu/d   step 2     Number of unique cloud configurations for
    6814. 

  6814. ! up/downwelling rad. between surface/TOA
    6815. 

  6815. ! and level k
    6816. 

  6816. ! (6. istrtu/d   step 2     Indices into iconu/d
    6817. 

  6817. ! (7. iconu/d    step 2     Cloud configurations which are identical
    6818. 

  6818. ! for up/downwelling rad. between surface/TOA
    6819. 

  6819. ! and level k
    6820. 

  6820. ! 
    6821. 

  6821. ! Number of configurations (all permutations of streams in each region)
    6822. 

  6822. ! 
    6823. 

  6823.             nconfigm = product(nstr(1: nrgn))
    6824. 

  6824. ! 
    6825. 

  6825. ! Construction of totwgt, wgtv, ccon, nconfig
    6826. 

  6826. ! 
    6827. 

  6827.             istr(1: nrgn) = 1
    6828. 

  6828.             nconfig = 0
    6829. 

  6829.             totwgt = 0.0_r8
    6830. 

  6830.             new_term = .true.
    6831. 

  6831.             do iconfig = 1, nconfigm
    6832. 

  6832.                xwgt = 1.0_r8
    6833. 

  6833.                do mrgn = 1,  nrgn
    6834. 

  6834.                   xwgt = xwgt * wstr(istr(mrgn),mrgn)
    6835. 

  6835.                end do
    6836. 

  6836.                if (xwgt >= areamin) then
    6837. 

  6837.                   nconfig = nconfig + 1
    6838. 

  6838.                   if (nconfig <= nconfgmax) then
    6839. 

  6839.                      j = nconfig
    6840. 

  6840.                      ptrc(nconfig) = nconfig
    6841. 

  6841.                   else
    6842. 

  6842.                      nconfig = nconfgmax
    6843. 

  6843.                      if (new_term) then
    6844. 

  6844.                         j = findvalue(1,nconfig,wgtv,ptrc)
    6845. 

  6845.                      endif
    6846. 

  6846.                      if (wgtv(j) < xwgt) then
    6847. 

  6847.                         totwgt = totwgt - wgtv(j)
    6848. 

  6848.                         new_term = .true.
    6849. 

  6849.                      else
    6850. 

  6850.                         new_term = .false.
    6851. 

  6851.                      endif
    6852. 

  6852.                   endif
    6853. 

  6853.                   if (new_term) then
    6854. 

  6854.                      wgtv(j) = xwgt
    6855. 

  6855.                      totwgt = totwgt + xwgt
    6856. 

  6856.                      do mrgn = 1, nrgn
    6857. 

  6857.                         ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn))
    6858. 

  6858.                      end do
    6859. 

  6859.                   endif
    6860. 

  6860.                endif
    6861. 

    6862. 

  6862.                mrgn =  nrgn
    6863. 

  6863.                istr(mrgn) = istr(mrgn) + 1
    6864. 

  6864.                do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1)
    6865. 

  6865.                   istr(mrgn) = 1
    6866. 

  6866.                   mrgn = mrgn - 1
    6867. 

  6867.                   istr(mrgn) = istr(mrgn) + 1
    6868. 

  6868.                end do
    6869. 

  6869. ! 
    6870. 

  6870. ! End do iconfig = 1, nconfigm
    6871. 

  6871. ! 
    6872. 

  6872.             end do
    6873. 

  6873. ! 
    6874. 

  6874. ! If totwgt = 0 implement maximum overlap and make another pass
    6875. 

  6875. ! if totwgt = 0 on this second pass then terminate.
    6876. 

  6876. ! 
    6877. 

  6877.             if (totwgt > 0.) then
    6878. 

  6878.                exit
    6879. 

  6879.             else
    6880. 

  6880.                npasses = npasses + 1
    6881. 

  6881.                if (npasses >= 2 ) then
    6882. 

  6882.                   write(6,*)'RADCSWMX: Maximum overlap of column ','failed'
    6883. 

  6883.                   call endrun
    6884. 

  6884.                endif
    6885. 

  6885.                nmxrgn(i)=1
    6886. 

  6886.                pmxrgn(i,1)=1.0e30
    6887. 

  6887.             end if
    6888. 

  6888. !
    6889. 

  6889. ! End npasses = 0, do
    6890. 

  6890. !
    6891. 

  6891.          end do
    6892. 

  6892. ! 
    6893. 

  6893. ! 
    6894. 

  6894. ! Finish construction of ccon
    6895. 

  6895. ! 
    6896. 

  6896.          ccon(0,:) = 0
    6897. 

  6897.          ccon(pverp,:) = 0
    6898. 

  6898. ! 
    6899. 

  6899. ! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree 
    6900. 

  6900. ! 
    6901. 

  6901.          nuniqd(0) = 1
    6902. 

  6902.          nuniqu(pverp) = 1
    6903. 

    6904. 

  6904.          istrtd(0,1) = 1
    6905. 

  6905.          istrtu(pverp,1) = 1
    6906. 

    6907. 

  6907.          do j = 1, nconfig
    6908. 

  6908.             icond(0,j)=j
    6909. 

  6909.             iconu(pverp,j)=j
    6910. 

  6910.          end do
    6911. 

    6912. 

  6912.          istrtd(0,2) = nconfig+1
    6913. 

  6913.          istrtu(pverp,2) = nconfig+1
    6914. 

    6915. 

  6915.          do k = 1, pverp
    6916. 

  6916.             km1 = k-1
    6917. 

  6917.             nuniq = 0
    6918. 

  6918.             istrtd(k,1) = 1
    6919. 

  6919.             do l0 = 1, nuniqd(km1)
    6920. 

  6920.                is0 = istrtd(km1,l0)
    6921. 

  6921.                is1 = istrtd(km1,l0+1)-1
    6922. 

  6922.                n0 = 0
    6923. 

  6923.                n1 = 0
    6924. 

  6924.                do isn = is0, is1
    6925. 

  6925.                   j = icond(km1,isn)
    6926. 

  6926.                   if (ccon(k,j) == 0) then
    6927. 

  6927.                      n0 = n0 + 1
    6928. 

  6928.                      ptr0(n0) = j
    6929. 

  6929.                   endif
    6930. 

  6930.                   if (ccon(k,j) == 1) then
    6931. 

  6931.                      n1 = n1 + 1
    6932. 

  6932.                      ptr1(n1) = j
    6933. 

  6933.                   endif
    6934. 

  6934.                end do
    6935. 

  6935.                if (n0 > 0) then
    6936. 

  6936.                   nuniq = nuniq + 1
    6937. 

  6937.                   istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0
    6938. 

  6938.                   icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) =  ptr0(1:n0)
    6939. 

  6939.                endif
    6940. 

  6940.                if (n1 > 0) then
    6941. 

  6941.                   nuniq = nuniq + 1
    6942. 

  6942.                   istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1
    6943. 

  6943.                   icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) =  ptr1(1:n1)
    6944. 

  6944.                endif
    6945. 

  6945.             end do
    6946. 

  6946.             nuniqd(k) = nuniq
    6947. 

  6947.          end do
    6948. 

    6949. 

  6949.          do k = pver, 0, -1
    6950. 

  6950.             kp1 = k+1
    6951. 

  6951.             nuniq = 0
    6952. 

  6952.             istrtu(k,1) = 1
    6953. 

  6953.             do l0 = 1, nuniqu(kp1)
    6954. 

  6954.                is0 = istrtu(kp1,l0)
    6955. 

  6955.                is1 = istrtu(kp1,l0+1)-1
    6956. 

  6956.                n0 = 0
    6957. 

  6957.                n1 = 0
    6958. 

  6958.                do isn = is0, is1
    6959. 

  6959.                   j = iconu(kp1,isn)
    6960. 

  6960.                   if (ccon(k,j) == 0) then
    6961. 

  6961.                      n0 = n0 + 1
    6962. 

  6962.                      ptr0(n0) = j
    6963. 

  6963.                   endif
    6964. 

  6964.                   if (ccon(k,j) == 1) then
    6965. 

  6965.                      n1 = n1 + 1
    6966. 

  6966.                      ptr1(n1) = j
    6967. 

  6967.                   endif
    6968. 

  6968.                end do
    6969. 

  6969.                if (n0 > 0) then
    6970. 

  6970.                   nuniq = nuniq + 1
    6971. 

  6971.                   istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0
    6972. 

  6972.                   iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) =  ptr0(1:n0)
    6973. 

  6973.                endif
    6974. 

  6974.                if (n1 > 0) then
    6975. 

  6975.                   nuniq = nuniq + 1
    6976. 

  6976.                   istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1
    6977. 

  6977.                   iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1)
    6978. 

  6978.                endif
    6979. 

  6979.             end do
    6980. 

  6980.             nuniqu(k) = nuniq
    6981. 

  6981.          end do
    6982. 

  6982. ! 
    6983. 

  6983. !----------------------------------------------------------------------
    6984. 

  6984. ! End of index calculations
    6985. 

  6985. !----------------------------------------------------------------------
    6986. 

    6987. 

    6988. 

  6988. !----------------------------------------------------------------------
    6989. 

  6989. ! Start of flux calculations
    6990. 

  6990. !----------------------------------------------------------------------
    6991. 

  6991. ! 
    6992. 

  6992. ! Initialize spectrally integrated totals:
    6993. 

  6993. ! 
    6994. 

  6994.          do k=0,pver
    6995. 

  6995.             totfld(k) = 0.0_r8
    6996. 

  6996.             fswup (k) = 0.0_r8
    6997. 

  6997.             fswdn (k) = 0.0_r8
    6998. 

  6998.             fswupc (k) = 0.0_r8
    6999. 

  6999.             fswdnc (k) = 0.0_r8
    7000. 

  7000.          end do
    7001. 

    7002. 

  7002.          sfltot        = 0.0_r8
    7003. 

  7003.          fswup (pverp) = 0.0_r8
    7004. 

  7004.          fswdn (pverp) = 0.0_r8
    7005. 

  7005.          fswupc (pverp) = 0.0_r8
    7006. 

  7006.          fswdnc (pverp) = 0.0_r8
    7007. 

  7007. ! 
    7008. 

  7008. ! Start spectral interval
    7009. 

  7009. ! 
    7010. 

  7010.          do ns = 1,nspint
    7011. 

  7011.             wgtint = nirwgt(ns)
    7012. 

  7012. !----------------------------------------------------------------------
    7013. 

  7013. ! STEP 2
    7014. 

  7014. ! 
    7015. 

  7015. ! 
    7016. 

  7016. ! Apply adding method to solve for radiative properties
    7017. 

  7017. ! 
    7018. 

  7018. ! First initialize the bulk properties at TOA
    7019. 

  7019. ! 
    7020. 

  7020.             rdndif(0,1:nconfig) = 0.0_r8
    7021. 

  7021.             exptdn(0,1:nconfig) = 1.0_r8
    7022. 

  7022.             tdntot(0,1:nconfig) = 1.0_r8
    7023. 

  7023. ! 
    7024. 

  7024. ! Solve for properties involving downward propagation of radiation.
    7025. 

  7025. ! The bulk properties are:
    7026. 

  7026. ! 
    7027. 

  7027. ! (1. exptdn   Sol. beam dwn. trans from layers above
    7028. 

  7028. ! (2. rdndif   Ref to dif rad for layers above
    7029. 

  7029. ! (3. tdntot   Total trans for layers above
    7030. 

  7030. ! 
    7031. 

  7031.             do k = 1, pverp
    7032. 

  7032.                km1 = k - 1
    7033. 

  7033.                do l0 = 1, nuniqd(km1)
    7034. 

  7034.                   is0 = istrtd(km1,l0)
    7035. 

  7035.                   is1 = istrtd(km1,l0+1)-1
    7036. 

    7037. 

  7037.                   j = icond(km1,is0)
    7038. 

    7039. 

  7039.                   xexpt   = exptdn(km1,j)
    7040. 

  7040.                   xrdnd   = rdndif(km1,j)
    7041. 

  7041.                   tdnmexp = tdntot(km1,j) - xexpt
    7042. 

    7043. 

  7043.                   if (ccon(km1,j) == 1) then
    7044. 

  7044. ! 
    7045. 

  7045. ! If cloud in layer, use cloudy layer radiative properties
    7046. 

  7046. ! 
    7047. 

  7047.                      ytdnd = tdif(ns,i,km1)
    7048. 

  7048.                      yrdnd = rdif(ns,i,km1)
    7049. 

    7050. 

  7050.                      rdenom  = 1._r8/(1._r8-yrdnd*xrdnd)
    7051. 

  7051.                      rdirexp = rdir(ns,i,km1)*xexpt
    7052. 

    7053. 

  7053.                      zexpt = xexpt * explay(ns,i,km1)
    7054. 

  7054.                      zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
    7055. 

  7055.                      ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom
    7056. 

  7056.                   else
    7057. 

  7057. ! 
    7058. 

  7058. ! If clear layer, use clear-sky layer radiative properties
    7059. 

  7059. ! 
    7060. 

  7060.                      ytdnd = tdifc(ns,i,km1)
    7061. 

  7061.                      yrdnd = rdifc(ns,i,km1)
    7062. 

    7063. 

  7063.                      rdenom  = 1._r8/(1._r8-yrdnd*xrdnd)
    7064. 

  7064.                      rdirexp = rdirc(ns,i,km1)*xexpt
    7065. 

    7066. 

  7066.                      zexpt = xexpt * explayc(ns,i,km1)
    7067. 

  7067.                      zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
    7068. 

  7068.                      ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* &
    7069. 

  7069.                                             (tdnmexp + xrdnd*rdirexp)*rdenom
    7070. 

  7070.                   endif
    7071. 

    7072. 

  7072. ! 
    7073. 

  7073. ! If 2 or more configurations share identical properties at a given level k,
    7074. 

  7074. ! the properties (at level k) are computed once and copied to 
    7075. 

  7075. ! all the configurations for efficiency.
    7076. 

  7076. ! 
    7077. 

  7077.                   do isn = is0, is1
    7078. 

  7078.                      j = icond(km1,isn)
    7079. 

  7079.                      exptdn(k,j) = zexpt
    7080. 

  7080.                      rdndif(k,j) = zrdnd
    7081. 

  7081.                      tdntot(k,j) = ztdnt
    7082. 

  7082.                   end do
    7083. 

  7083. ! 
    7084. 

  7084. ! end do l0 = 1, nuniqd(k)
    7085. 

  7085. ! 
    7086. 

  7086.                end do
    7087. 

  7087. ! 
    7088. 

  7088. ! end do k = 1, pverp
    7089. 

  7089. ! 
    7090. 

  7090.             end do
    7091. 

  7091. ! 
    7092. 

  7092. ! Solve for properties involving upward propagation of radiation.
    7093. 

  7093. ! The bulk properties are:
    7094. 

  7094. ! 
    7095. 

  7095. ! (1. rupdif   Ref to dif rad for layers below
    7096. 

  7096. ! (2. rupdir   Ref to dir rad for layers below
    7097. 

  7097. ! 
    7098. 

  7098. ! Specify surface boundary conditions (surface albedos)
    7099. 

  7099. ! 
    7100. 

  7100.             rupdir(pverp,1:nconfig) = albdir(i,ns)
    7101. 

  7101.             rupdif(pverp,1:nconfig) = albdif(i,ns)
    7102. 

    7103. 

  7103.             do k = pver, 0, -1
    7104. 

  7104.                do l0 = 1, nuniqu(k)
    7105. 

  7105.                   is0 = istrtu(k,l0)
    7106. 

  7106.                   is1 = istrtu(k,l0+1)-1
    7107. 

    7108. 

  7108.                   j = iconu(k,is0)
    7109. 

    7110. 

  7110.                   xrupd = rupdif(k+1,j)
    7111. 

  7111.                   xrups = rupdir(k+1,j)
    7112. 

    7113. 

  7113.                   if (ccon(k,j) == 1) then
    7114. 

  7114. ! 
    7115. 

  7115. ! If cloud in layer, use cloudy layer radiative properties
    7116. 

  7116. ! 
    7117. 

  7117.                      yexpt = explay(ns,i,k)
    7118. 

  7118.                      yrupd = rdif(ns,i,k)
    7119. 

  7119.                      ytupd = tdif(ns,i,k)
    7120. 

    7121. 

  7121.                      rdenom  = 1._r8/( 1._r8 - yrupd*xrupd)
    7122. 

  7122.                      tdnmexp = (tdir(ns,i,k)-yexpt)
    7123. 

  7123.                      rdirexp = xrups*yexpt
    7124. 

    7125. 

  7125.                      zrupd = yrupd + xrupd*(ytupd**2)*rdenom
    7126. 

  7126.                      zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
    7127. 

  7127.                   else
    7128. 

  7128. ! 
    7129. 

  7129. ! If clear layer, use clear-sky layer radiative properties
    7130. 

  7130. ! 
    7131. 

  7131.                      yexpt = explayc(ns,i,k)
    7132. 

  7132.                      yrupd = rdifc(ns,i,k)
    7133. 

  7133.                      ytupd = tdifc(ns,i,k)
    7134. 

    7135. 

  7135.                      rdenom  = 1._r8/( 1._r8 - yrupd*xrupd)
    7136. 

  7136.                      tdnmexp = (tdirc(ns,i,k)-yexpt)
    7137. 

  7137.                      rdirexp = xrups*yexpt
    7138. 

    7139. 

  7139.                      zrupd = yrupd + xrupd*(ytupd**2)*rdenom
    7140. 

  7140.                      zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
    7141. 

  7141.                   endif
    7142. 

    7143. 

  7143. ! 
    7144. 

  7144. ! If 2 or more configurations share identical properties at a given level k,
    7145. 

  7145. ! the properties (at level k) are computed once and copied to 
    7146. 

  7146. ! all the configurations for efficiency.
    7147. 

  7147. ! 
    7148. 

  7148.                   do isn = is0, is1
    7149. 

  7149.                      j = iconu(k,isn)
    7150. 

  7150.                      rupdif(k,j) = zrupd
    7151. 

  7151.                      rupdir(k,j) = zrups
    7152. 

  7152.                   end do
    7153. 

  7153. ! 
    7154. 

  7154. ! end do l0 = 1, nuniqu(k)
    7155. 

  7155. ! 
    7156. 

  7156.                end do
    7157. 

  7157. ! 
    7158. 

  7158. ! end do k = pver,0,-1
    7159. 

  7159. ! 
    7160. 

  7160.             end do
    7161. 

  7161. ! 
    7162. 

  7162. !----------------------------------------------------------------------
    7163. 

  7163. ! 
    7164. 

  7164. ! STEP 3
    7165. 

  7165. ! 
    7166. 

  7166. ! Compute up and down fluxes for each interface k.  This requires
    7167. 

  7167. ! adding up the contributions from all possible permutations
    7168. 

  7168. ! of streams in all max-overlap regions, weighted by the
    7169. 

  7169. ! product of the fractional areas of the streams in each region
    7170. 

  7170. ! (the random overlap assumption).  The adding principle has been
    7171. 

  7171. ! used in step 2 to combine the bulk radiative properties 
    7172. 

  7172. ! above and below the interface.
    7173. 

  7173. ! 
    7174. 

  7174.             do k = 0,pverp
    7175. 

  7175. ! 
    7176. 

  7176. ! Initialize the fluxes
    7177. 

  7177. ! 
    7178. 

  7178.                fluxup(k)=0.0_r8
    7179. 

  7179.                fluxdn(k)=0.0_r8
    7180. 

    7181. 

  7181.                do iconfig = 1, nconfig
    7182. 

  7182.                   xwgt = wgtv(iconfig)
    7183. 

  7183.                   xexpt = exptdn(k,iconfig)
    7184. 

  7184.                   xtdnt = tdntot(k,iconfig)
    7185. 

  7185.                   xrdnd = rdndif(k,iconfig)
    7186. 

  7186.                   xrupd = rupdif(k,iconfig)
    7187. 

  7187.                   xrups = rupdir(k,iconfig)
    7188. 

  7188. ! 
    7189. 

  7189. ! Flux computation
    7190. 

  7190. ! 
    7191. 

  7191.                   rdenom = 1._r8/(1._r8 - xrdnd * xrupd)
    7192. 

    7193. 

  7193.                   fluxup(k) = fluxup(k) + xwgt *  &
    7194. 

  7194.                               ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom)
    7195. 

  7195.                   fluxdn(k) = fluxdn(k) + xwgt *  &
    7196. 

  7196.                               (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom)
    7197. 

  7197. ! 
    7198. 

  7198. ! End do iconfig = 1, nconfig
    7199. 

  7199. ! 
    7200. 

  7200.                end do
    7201. 

  7201. ! 
    7202. 

  7202. ! Normalize by total area covered by cloud configurations included
    7203. 

  7203. ! in solution
    7204. 

  7204. ! 
    7205. 

  7205.                fluxup(k)=fluxup(k) / totwgt
    7206. 

  7206.                fluxdn(k)=fluxdn(k) / totwgt                  
    7207. 

  7207. ! 
    7208. 

  7208. ! End do k = 0,pverp
    7209. 

  7209. ! 
    7210. 

  7210.             end do
    7211. 

  7211. ! 
    7212. 

  7212. ! Initialize the direct-beam flux at surface
    7213. 

  7213. ! 
    7214. 

  7214.             wexptdn = 0.0_r8
    7215. 

    7216. 

  7216.             do iconfig = 1, nconfig
    7217. 

  7217.                wexptdn =  wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig)
    7218. 

  7218.             end do
    7219. 

    7220. 

  7220.             wexptdn = wexptdn / totwgt
    7221. 

  7221. ! 
    7222. 

  7222. ! Monochromatic computation completed; accumulate in totals
    7223. 

  7223. ! 
    7224. 

  7224.             solflx   = solin(i)*frcsol(ns)*psf(ns)
    7225. 

  7225.             fsnt(i)  = fsnt(i) + solflx*(fluxdn(1) - fluxup(1))
    7226. 

  7226.             fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0))
    7227. 

  7227.             fsns(i)  = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp))
    7228. 

  7228.             sfltot   = sfltot + solflx
    7229. 

  7229.             fswup(0) = fswup(0) + solflx*fluxup(0)
    7230. 

  7230.             fswdn(0) = fswdn(0) + solflx*fluxdn(0)
    7231. 

  7231. ! 
    7232. 

  7232. ! Down spectral fluxes need to be in mks; thus the .001 conversion factors
    7233. 

  7233. ! 
    7234. 

  7234.             if (wavmid(ns) < 0.7_r8) then
    7235. 

  7235.                sols(i)  = sols(i) + wexptdn*solflx*0.001_r8
    7236. 

  7236.                solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
    7237. 

  7237.             else
    7238. 

  7238.                soll(i)  = soll(i) + wexptdn*solflx*0.001_r8
    7239. 

  7239.                solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
    7240. 

  7240.                fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0))
    7241. 

  7241.             end if
    7242. 

  7242.             fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0))
    7243. 

    7244. 

  7244.             do k=0,pver
    7245. 

  7245. ! 
    7246. 

  7246. ! Compute flux divergence in each layer using the interface up and down
    7247. 

  7247. ! fluxes:
    7248. 

  7248. ! 
    7249. 

  7249.                kp1 = k+1
    7250. 

  7250.                flxdiv = (fluxdn(k  ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k  ))
    7251. 

  7251.                totfld(k)  = totfld(k)  + solflx*flxdiv
    7252. 

  7252.                fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1)
    7253. 

  7253.                fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1)
    7254. 

  7254.             end do
    7255. 

  7255. ! 
    7256. 

  7256. ! Perform clear-sky calculation
    7257. 

  7257. ! 
    7258. 

  7258.             exptdnc(0) =   1.0_r8
    7259. 

  7259.             rdndifc(0) =   0.0_r8
    7260. 

  7260.             tdntotc(0) =   1.0_r8
    7261. 

  7261.             rupdirc(pverp) = albdir(i,ns)
    7262. 

  7262.             rupdifc(pverp) = albdif(i,ns)
    7263. 

    7264. 

  7264.             do k = 1, pverp
    7265. 

  7265.                km1 = k - 1
    7266. 

  7266.                xexpt = exptdnc(km1)
    7267. 

  7267.                xrdnd = rdndifc(km1)
    7268. 

  7268.                yrdnd = rdifc(ns,i,km1)
    7269. 

  7269.                ytdnd = tdifc(ns,i,km1)
    7270. 

    7271. 

  7271.                exptdnc(k) = xexpt*explayc(ns,i,km1)
    7272. 

    7273. 

  7273.                rdenom  = 1._r8/(1._r8 - yrdnd*xrdnd)
    7274. 

  7274.                rdirexp = rdirc(ns,i,km1)*xexpt
    7275. 

  7275.                tdnmexp = tdntotc(km1) - xexpt
    7276. 

    7277. 

  7277.                tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* &
    7278. 

  7278.                                 rdenom
    7279. 

  7279.                rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom
    7280. 

  7280.             end do
    7281. 

    7282. 

  7282.             do k=pver,0,-1
    7283. 

  7283.                xrupd = rupdifc(k+1)
    7284. 

  7284.                yexpt = explayc(ns,i,k)
    7285. 

  7285.                yrupd = rdifc(ns,i,k)
    7286. 

  7286.                ytupd = tdifc(ns,i,k)
    7287. 

    7288. 

  7288.                rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
    7289. 

    7290. 

  7290.                rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + &
    7291. 

  7291.                             xrupd*(tdirc(ns,i,k)-yexpt))*rdenom
    7292. 

  7292.                rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom
    7293. 

  7293.             end do
    7294. 

    7295. 

  7295.             do k=0,1
    7296. 

  7296.                rdenom    = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
    7297. 

  7297.                fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
    7298. 

  7298.                            rdenom
    7299. 

  7299.                fluxdn(k) = exptdnc(k) + &
    7300. 

  7300.                            (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* &
    7301. 

  7301.                            rdenom
    7302. 

  7302.                fswupc(k) = fswupc(k) + solflx*fluxup(k)
    7303. 

  7303.                fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
    7304. 

  7304.             end do
    7305. 

  7305. !           k = pverp
    7306. 

  7306.             do k=2,pverp
    7307. 

  7307.             rdenom      = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
    7308. 

  7308.             fluxup(k)   = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
    7309. 

  7309.                            rdenom
    7310. 

  7310.             fluxdn(k)   = exptdnc(k) + (tdntotc(k) - exptdnc(k) + &
    7311. 

  7311.                           exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom
    7312. 

  7312.             fswupc(k)   = fswupc(k) + solflx*fluxup(k)
    7313. 

  7313.             fswdnc(k)   = fswdnc(k) + solflx*fluxdn(k)
    7314. 

  7314.             end do
    7315. 

    7316. 

  7316.             fsntc(i)    = fsntc(i)+solflx*(fluxdn(1)-fluxup(1))
    7317. 

  7317.             fsntoac(i)  = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0))
    7318. 

  7318.             fsnsc(i)    = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp))
    7319. 

  7319.             fsdsc(i)    = fsdsc(i)+solflx*(fluxdn(pverp))
    7320. 

  7320.             fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0))
    7321. 

  7321. ! 
    7322. 

  7322. ! End of clear sky calculation
    7323. 

  7323. ! 
    7324. 

    7325. 

  7325. ! 
    7326. 

  7326. ! End of spectral interval loop
    7327. 

  7327. ! 
    7328. 

  7328.          end do
    7329. 

  7329. ! 
    7330. 

  7330. ! Compute solar heating rate (J/kg/s)
    7331. 

  7331. ! 
    7332. 

  7332.          do k=1,pver
    7333. 

  7333.             qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1))
    7334. 

  7334.          end do
    7335. 

    7336. 

  7336. ! Added downward/upward total and clear sky fluxes
    7337. 

    7338. 

  7338.          do k=1,pverp
    7339. 

  7339.             fsup(i,k)  = fswup(k)
    7340. 

  7340.             fsupc(i,k) = fswupc(k)
    7341. 

  7341.             fsdn(i,k)  = fswdn(k)
    7342. 

  7342.             fsdnc(i,k) = fswdnc(k)
    7343. 

  7343.          end do
    7344. 

  7344. ! 
    7345. 

  7345. ! Set the downwelling flux at the surface 
    7346. 

  7346. ! 
    7347. 

  7347.          fsds(i) = fswdn(pverp)
    7348. 

  7348. ! 
    7349. 

  7349. ! End do n=1,ndayc
    7350. 

  7350. ! 
    7351. 

  7351.    end do
    7352. 

    7353. 

  7353. !  write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk
    7354. 

    7355. 

  7355.    return
    7356. 

  7356. end subroutine radcswmx
    7357. 

    7358. 

  7358. subroutine raddedmx(pver, pverp, pcols, coszrs  ,ndayc   ,idayc   ,abh2o   , &
    7359. 

  7359.                     abo3    ,abco2   ,abo2    ,uh2o    ,uo3     , &
    7360. 

  7360.                     uco2    ,uo2     ,trayoslp,pflx    ,ns      , &
    7361. 

  7361.                     tauxcl  ,wcl     ,gcl     ,fcl     ,tauxci  , &
    7362. 

  7362.                     wci     ,gci     ,fci     ,tauxar  ,wa      , &
    7363. 

  7363.                     ga      ,fa      ,rdir    ,rdif    ,tdir    , &
    7364. 

  7364.                     tdif    ,explay  ,rdirc   ,rdifc   ,tdirc   , &
    7365. 

  7365.                     tdifc   ,explayc )
    7366. 

  7366. !----------------------------------------------------------------------- 
    7367. 

  7367. ! 
    7368. 

  7368. ! Purpose: 
    7369. 

  7369. ! Computes layer reflectivities and transmissivities, from the top down
    7370. 

  7370. ! to the surface using the delta-Eddington solutions for each layer
    7371. 

  7371. ! 
    7372. 

  7372. ! Method: 
    7373. 

  7373. ! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington
    7374. 

  7374. ! Approximation for Solar Radiation in the NCAR Community Climate Model,
    7375. 

  7375. ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
    7376. 

  7376. !
    7377. 

  7377. ! Modified for maximum/random cloud overlap by Bill Collins and John
    7378. 

  7378. !    Truesdale
    7379. 

  7379. ! 
    7380. 

  7380. ! Author: Bill Collins
    7381. 

  7381. ! 
    7382. 

  7382. !-----------------------------------------------------------------------
    7383. 

  7383. !  use shr_kind_mod, only: r8 => shr_kind_r8
    7384. 

  7384. !  use ppgrid
    7385. 

    7386. 

  7386.    implicit none
    7387. 

    7388. 

  7388.    integer nspint           ! Num of spctrl intervals across solar spectrum
    7389. 

    7390. 

  7390.    parameter ( nspint = 19 )
    7391. 

  7391. !
    7392. 

  7392. ! Minimum total transmission below which no layer computation are done:
    7393. 

  7393. !
    7394. 

  7394.    real(r8) trmin                ! Minimum total transmission allowed
    7395. 

  7395.    real(r8) wray                 ! Rayleigh single scatter albedo
    7396. 

  7396.    real(r8) gray                 ! Rayleigh asymetry parameter
    7397. 

  7397.    real(r8) fray                 ! Rayleigh forward scattered fraction
    7398. 

    7399. 

  7399.    parameter (trmin = 1.e-3)
    7400. 

  7400.    parameter (wray = 0.999999)
    7401. 

  7401.    parameter (gray = 0.0)
    7402. 

  7402.    parameter (fray = 0.1)
    7403. 

  7403. !
    7404. 

  7404. !------------------------------Arguments--------------------------------
    7405. 

  7405. !
    7406. 

  7406. ! Input arguments
    7407. 

  7407. !
    7408. 

  7408.    integer, intent(in) :: pver, pverp, pcols
    7409. 

  7409.    real(r8), intent(in) :: coszrs(pcols)        ! Cosine zenith angle
    7410. 

  7410.    real(r8), intent(in) :: trayoslp             ! Tray/sslp
    7411. 

  7411.    real(r8), intent(in) :: pflx(pcols,0:pverp)  ! Interface pressure
    7412. 

  7412.    real(r8), intent(in) :: abh2o                ! Absorption coefficiant for h2o
    7413. 

  7413.    real(r8), intent(in) :: abo3                 ! Absorption coefficiant for o3
    7414. 

  7414.    real(r8), intent(in) :: abco2                ! Absorption coefficiant for co2
    7415. 

  7415.    real(r8), intent(in) :: abo2                 ! Absorption coefficiant for o2
    7416. 

  7416.    real(r8), intent(in) :: uh2o(pcols,0:pver)   ! Layer absorber amount of h2o
    7417. 

  7417.    real(r8), intent(in) :: uo3(pcols,0:pver)    ! Layer absorber amount of  o3
    7418. 

  7418.    real(r8), intent(in) :: uco2(pcols,0:pver)   ! Layer absorber amount of co2
    7419. 

  7419.    real(r8), intent(in) :: uo2(pcols,0:pver)    ! Layer absorber amount of  o2
    7420. 

  7420.    real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid)
    7421. 

  7421.    real(r8), intent(in) :: wcl(pcols,0:pver)    ! Cloud single scattering albedo (liquid)
    7422. 

  7422.    real(r8), intent(in) :: gcl(pcols,0:pver)    ! Cloud asymmetry parameter (liquid)
    7423. 

  7423.    real(r8), intent(in) :: fcl(pcols,0:pver)    ! Cloud forward scattered fraction (liquid)
    7424. 

  7424.    real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice)
    7425. 

  7425.    real(r8), intent(in) :: wci(pcols,0:pver)    ! Cloud single scattering albedo (ice)
    7426. 

  7426.    real(r8), intent(in) :: gci(pcols,0:pver)    ! Cloud asymmetry parameter (ice)
    7427. 

  7427.    real(r8), intent(in) :: fci(pcols,0:pver)    ! Cloud forward scattered fraction (ice)
    7428. 

  7428.    real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth
    7429. 

  7429.    real(r8), intent(in) :: wa(pcols,0:pver)     ! Aerosol single scattering albedo
    7430. 

  7430.    real(r8), intent(in) :: ga(pcols,0:pver)     ! Aerosol asymmetry parameter
    7431. 

  7431.    real(r8), intent(in) :: fa(pcols,0:pver)     ! Aerosol forward scattered fraction
    7432. 

    7433. 

  7433.    integer, intent(in) :: ndayc                 ! Number of daylight columns
    7434. 

  7434.    integer, intent(in) :: idayc(pcols)          ! Daylight column indices
    7435. 

  7435.    integer, intent(in) :: ns                    ! Index of spectral interval
    7436. 

  7436. !
    7437. 

  7437. ! Input/Output arguments
    7438. 

  7438. !
    7439. 

  7439. ! Following variables are defined for each layer; 0 refers to extra
    7440. 

  7440. ! layer above top of model:
    7441. 

  7441. !
    7442. 

  7442.    real(r8), intent(inout) :: rdir(nspint,pcols,0:pver)   ! Layer reflectivity to direct rad
    7443. 

  7443.    real(r8), intent(inout) :: rdif(nspint,pcols,0:pver)   ! Layer reflectivity to diffuse rad
    7444. 

  7444.    real(r8), intent(inout) :: tdir(nspint,pcols,0:pver)   ! Layer transmission to direct rad
    7445. 

  7445.    real(r8), intent(inout) :: tdif(nspint,pcols,0:pver)   ! Layer transmission to diffuse rad
    7446. 

  7446.    real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer
    7447. 

  7447. !
    7448. 

  7448. ! Corresponding quantities for clear-skies
    7449. 

  7449. !
    7450. 

  7450.    real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver)  ! Clear layer reflec. to direct rad
    7451. 

  7451.    real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver)  ! Clear layer reflec. to diffuse rad
    7452. 

  7452.    real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver)  ! Clear layer trans. to direct rad
    7453. 

  7453.    real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver)  ! Clear layer trans. to diffuse rad
    7454. 

  7454.    real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer
    7455. 

  7455. !
    7456. 

  7456. !---------------------------Local variables-----------------------------
    7457. 

  7457. !
    7458. 

  7458.    integer i                 ! Column indices
    7459. 

  7459.    integer k                 ! Level index
    7460. 

  7460.    integer nn                ! Index of column loops (max=ndayc)
    7461. 

    7462. 

  7462.    real(r8) taugab(pcols)        ! Layer total gas absorption optical depth
    7463. 

  7463.    real(r8) tauray(pcols)        ! Layer rayleigh optical depth
    7464. 

  7464.    real(r8) taucsc               ! Layer cloud scattering optical depth
    7465. 

  7465.    real(r8) tautot               ! Total layer optical depth
    7466. 

  7466.    real(r8) wtot                 ! Total layer single scatter albedo
    7467. 

  7467.    real(r8) gtot                 ! Total layer asymmetry parameter
    7468. 

  7468.    real(r8) ftot                 ! Total layer forward scatter fraction
    7469. 

  7469.    real(r8) wtau                 !  rayleigh layer scattering optical depth
    7470. 

  7470.    real(r8) wt                   !  layer total single scattering albedo
    7471. 

  7471.    real(r8) ts                   !  layer scaled extinction optical depth
    7472. 

  7472.    real(r8) ws                   !  layer scaled single scattering albedo
    7473. 

  7473.    real(r8) gs                   !  layer scaled asymmetry parameter
    7474. 

  7474. !
    7475. 

  7475. !---------------------------Statement functions-------------------------
    7476. 

  7476. !
    7477. 

  7477. ! Statement functions and other local variables
    7478. 

  7478. !
    7479. 

  7479.    real(r8) alpha                ! Term in direct reflect and transmissivity
    7480. 

  7480.    real(r8) gamma                ! Term in direct reflect and transmissivity
    7481. 

  7481.    real(r8) el                   ! Term in alpha,gamma,n,u
    7482. 

  7482.    real(r8) taus                 ! Scaled extinction optical depth
    7483. 

  7483.    real(r8) omgs                 ! Scaled single particle scattering albedo
    7484. 

  7484.    real(r8) asys                 ! Scaled asymmetry parameter
    7485. 

  7485.    real(r8) u                    ! Term in diffuse reflect and
    7486. 

  7486. !    transmissivity
    7487. 

  7487.    real(r8) n                    ! Term in diffuse reflect and
    7488. 

  7488. !    transmissivity
    7489. 

  7489.    real(r8) lm                   ! Temporary for el
    7490. 

  7490.    real(r8) ne                   ! Temporary for n
    7491. 

  7491.    real(r8) w                    ! Dummy argument for statement function
    7492. 

  7492.    real(r8) uu                   ! Dummy argument for statement function
    7493. 

  7493.    real(r8) g                    ! Dummy argument for statement function
    7494. 

  7494.    real(r8) e                    ! Dummy argument for statement function
    7495. 

  7495.    real(r8) f                    ! Dummy argument for statement function
    7496. 

  7496.    real(r8) t                    ! Dummy argument for statement function
    7497. 

  7497.    real(r8) et                   ! Dummy argument for statement function
    7498. 

  7498. !
    7499. 

  7499. ! Intermediate terms for delta-eddington solution
    7500. 

  7500. !
    7501. 

  7501.    real(r8) alp                  ! Temporary for alpha
    7502. 

  7502.    real(r8) gam                  ! Temporary for gamma
    7503. 

  7503.    real(r8) ue                   ! Temporary for u
    7504. 

  7504.    real(r8) arg                  ! Exponential argument
    7505. 

  7505.    real(r8) extins               ! Extinction
    7506. 

  7506.    real(r8) amg                  ! Alp - gam
    7507. 

  7507.    real(r8) apg                  ! Alp + gam
    7508. 

  7508. !
    7509. 

  7509.    alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu))
    7510. 

  7510.    gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu))
    7511. 

  7511.    el(w,g)         = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g))
    7512. 

  7512.    taus(w,f,t)     = (1._r8 - w*f)*t
    7513. 

  7513.    omgs(w,f)       = (1._r8 - f)*w/(1._r8 - w*f)
    7514. 

  7514.    asys(g,f)       = (g - f)/(1._r8 - f)
    7515. 

  7515.    u(w,g,e)        = 1.5_r8*(1._r8 - w*g)/e
    7516. 

  7516.    n(uu,et)        = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et)
    7517. 

  7517. !
    7518. 

  7518. !-----------------------------------------------------------------------
    7519. 

  7519. !
    7520. 

  7520. ! Compute layer radiative properties
    7521. 

  7521. !
    7522. 

  7522. ! Compute radiative properties (reflectivity and transmissivity for
    7523. 

  7523. !    direct and diffuse radiation incident from above, under clear
    7524. 

  7524. !    and cloudy conditions) and transmission of direct radiation
    7525. 

  7525. !    (under clear and cloudy conditions) for each layer.
    7526. 

  7526. !
    7527. 

  7527.    do k=0,pver
    7528. 

  7528.       do nn=1,ndayc
    7529. 

  7529.          i=idayc(nn)
    7530. 

  7530.             tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k))
    7531. 

  7531.             taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k)
    7532. 

  7532.             tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k)
    7533. 

  7533.             taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k)
    7534. 

  7534.             wtau   = wray*tauray(i)
    7535. 

  7535.             wt     = wtau + taucsc
    7536. 

  7536.             wtot   = wt/tautot
    7537. 

  7537.             gtot   = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) &
    7538. 

  7538.                      + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt
    7539. 

  7539.             ftot   = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) &
    7540. 

  7540.                      + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt
    7541. 

  7541.             ts   = taus(wtot,ftot,tautot)
    7542. 

  7542.             ws   = omgs(wtot,ftot)
    7543. 

  7543.             gs   = asys(gtot,ftot)
    7544. 

  7544.             lm   = el(ws,gs)
    7545. 

  7545.             alp  = alpha(ws,coszrs(i),gs,lm)
    7546. 

  7546.             gam  = gamma(ws,coszrs(i),gs,lm)
    7547. 

  7547.             ue   = u(ws,gs,lm)
    7548. 

  7548. !
    7549. 

  7549. !     Limit argument of exponential to 25, in case lm very large:
    7550. 

  7550. !
    7551. 

  7551.             arg  = min(lm*ts,25._r8)
    7552. 

  7552.             extins = exp(-arg)
    7553. 

  7553.             ne = n(ue,extins)
    7554. 

  7554.             rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
    7555. 

  7555.             tdif(ns,i,k)   =   4._r8*ue/ne
    7556. 

  7556. !
    7557. 

  7557. !     Limit argument of exponential to 25, in case coszrs is very small:
    7558. 

  7558. !
    7559. 

  7559.             arg       = min(ts/coszrs(i),25._r8)
    7560. 

  7560.             explay(ns,i,k) = exp(-arg)
    7561. 

  7561.             apg = alp + gam
    7562. 

  7562.             amg = alp - gam
    7563. 

  7563.             rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k)
    7564. 

  7564.             tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k)
    7565. 

  7565. !
    7566. 

  7566. !     Under rare conditions, reflectivies and transmissivities can be
    7567. 

  7567. !     negative; zero out any negative values
    7568. 

  7568. !
    7569. 

  7569.             rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8)
    7570. 

  7570.             tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8)
    7571. 

  7571.             rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8)
    7572. 

  7572.             tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8)
    7573. 

  7573. !
    7574. 

  7574. !     Clear-sky calculation
    7575. 

  7575. !
    7576. 

  7576.             if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then
    7577. 

    7578. 

  7578.                rdirc(ns,i,k) = rdir(ns,i,k)
    7579. 

  7579.                tdirc(ns,i,k) = tdir(ns,i,k)
    7580. 

  7580.                rdifc(ns,i,k) = rdif(ns,i,k)
    7581. 

  7581.                tdifc(ns,i,k) = tdif(ns,i,k)
    7582. 

  7582.                explayc(ns,i,k) = explay(ns,i,k)
    7583. 

  7583.             else
    7584. 

  7584.                tautot = tauray(i) + taugab(i) + tauxar(i,k)
    7585. 

  7585.                taucsc = tauxar(i,k)*wa(i,k)
    7586. 

  7586. !
    7587. 

  7587. ! wtau already computed for all-sky
    7588. 

  7588. !
    7589. 

  7589.                wt     = wtau + taucsc
    7590. 

  7590.                wtot   = wt/tautot
    7591. 

  7591.                gtot   = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt
    7592. 

  7592.                ftot   = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt
    7593. 

  7593.                ts   = taus(wtot,ftot,tautot)
    7594. 

  7594.                ws   = omgs(wtot,ftot)
    7595. 

  7595.                gs   = asys(gtot,ftot)
    7596. 

  7596.                lm   = el(ws,gs)
    7597. 

  7597.                alp  = alpha(ws,coszrs(i),gs,lm)
    7598. 

  7598.                gam  = gamma(ws,coszrs(i),gs,lm)
    7599. 

  7599.                ue   = u(ws,gs,lm)
    7600. 

  7600. !
    7601. 

  7601. !     Limit argument of exponential to 25, in case lm very large:
    7602. 

  7602. !
    7603. 

  7603.                arg  = min(lm*ts,25._r8)
    7604. 

  7604.                extins = exp(-arg)
    7605. 

  7605.                ne = n(ue,extins)
    7606. 

  7606.                rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
    7607. 

  7607.                tdifc(ns,i,k)   =   4._r8*ue/ne
    7608. 

  7608. !
    7609. 

  7609. !     Limit argument of exponential to 25, in case coszrs is very small:
    7610. 

  7610. !
    7611. 

  7611.                arg       = min(ts/coszrs(i),25._r8)
    7612. 

  7612.                explayc(ns,i,k) = exp(-arg)
    7613. 

  7613.                apg = alp + gam
    7614. 

  7614.                amg = alp - gam
    7615. 

  7615.                rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ &
    7616. 

  7616.                                apg*rdifc(ns,i,k)
    7617. 

  7617.                tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* &
    7618. 

  7618.                                explayc(ns,i,k)
    7619. 

  7619. !
    7620. 

  7620. !     Under rare conditions, reflectivies and transmissivities can be
    7621. 

  7621. !     negative; zero out any negative values
    7622. 

  7622. !
    7623. 

  7623.                rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8)
    7624. 

  7624.                tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8)
    7625. 

  7625.                rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8)
    7626. 

  7626.                tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8)
    7627. 

  7627.             end if
    7628. 

  7628.          end do
    7629. 

  7629.    end do
    7630. 

    7631. 

  7631.    return
    7632. 

  7632. end subroutine raddedmx
    7633. 

    7634. 

  7634. subroutine radinp(lchnk   ,ncol    , pcols, pver, pverp,     &
    7635. 

  7635.                   pmid    ,pint    ,o3vmr   , pmidrd  ,&
    7636. 

  7636.                   pintrd  ,eccf    ,o3mmr   )
    7637. 

  7637. !----------------------------------------------------------------------- 
    7638. 

  7638. ! 
    7639. 

  7639. ! Purpose: 
    7640. 

  7640. ! Set latitude and time dependent arrays for input to solar
    7641. 

  7641. ! and longwave radiation.
    7642. 

  7642. ! Convert model pressures to cgs, and compute ozone mixing ratio, needed for
    7643. 

  7643. ! the solar radiation.
    7644. 

  7644. ! 
    7645. 

  7645. ! Method: 
    7646. 

  7646. ! <Describe the algorithm(s) used in the routine.> 
    7647. 

  7647. ! <Also include any applicable external references.> 
    7648. 

  7648. ! 
    7649. 

  7649. ! Author: CCM1, CMS Contact J. Kiehl
    7650. 

  7650. ! 
    7651. 

  7651. !-----------------------------------------------------------------------
    7652. 

  7652. !  use shr_kind_mod, only: r8 => shr_kind_r8
    7653. 

  7653. !  use ppgrid
    7654. 

  7654. !  use time_manager, only: get_curr_calday
    7655. 

    7656. 

  7656.    implicit none
    7657. 

    7658. 

  7658. !------------------------------Arguments--------------------------------
    7659. 

  7659. !
    7660. 

  7660. ! Input arguments
    7661. 

  7661. !
    7662. 

  7662.    integer, intent(in) :: lchnk                ! chunk identifier
    7663. 

  7663.    integer, intent(in) :: pcols, pver, pverp
    7664. 

  7664.    integer, intent(in) :: ncol                 ! number of atmospheric columns
    7665. 

    7666. 

  7666.    real(r8), intent(in) :: pmid(pcols,pver)    ! Pressure at model mid-levels (pascals)
    7667. 

  7667.    real(r8), intent(in) :: pint(pcols,pverp)   ! Pressure at model interfaces (pascals)
    7668. 

  7668.    real(r8), intent(in) :: o3vmr(pcols,pver)   ! ozone volume mixing ratio
    7669. 

  7669. !
    7670. 

  7670. ! Output arguments
    7671. 

  7671. !
    7672. 

  7672.    real(r8), intent(out) :: pmidrd(pcols,pver)  ! Pressure at mid-levels (dynes/cm*2)
    7673. 

  7673.    real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2)
    7674. 

  7674.    real(r8), intent(out) :: eccf                ! Earth-sun distance factor
    7675. 

  7675.    real(r8), intent(out) :: o3mmr(pcols,pver)   ! Ozone mass mixing ratio
    7676. 

    7677. 

  7677. !
    7678. 

  7678. !---------------------------Local variables-----------------------------
    7679. 

  7679. !
    7680. 

  7680.    integer i                ! Longitude loop index
    7681. 

  7681.    integer k                ! Vertical loop index
    7682. 

    7683. 

  7683.    real(r8) :: calday           ! current calendar day
    7684. 

  7684.    real(r8) vmmr                ! Ozone volume mixing ratio
    7685. 

  7685.    real(r8) delta               ! Solar declination angle
    7686. 

    7687. 

  7687. !
    7688. 

  7688. !-----------------------------------------------------------------------
    7689. 

  7689. !
    7690. 

  7690. !  calday = get_curr_calday()
    7691. 

  7691.    eccf = 1. ! declared intent(out) so fill a value (not used in WRF)
    7692. 

  7692. !  call shr_orb_decl (calday  ,eccen     ,mvelpp  ,lambm0  ,obliqr  , &
    7693. 

  7693. !                     delta   ,eccf)
    7694. 

    7695. 

  7695. !
    7696. 

  7696. ! Convert pressure from pascals to dynes/cm2
    7697. 

  7697. !
    7698. 

  7698.    do k=1,pver
    7699. 

  7699.       do i=1,ncol
    7700. 

  7700.          pmidrd(i,k) = pmid(i,k)*10.0
    7701. 

  7701.          pintrd(i,k) = pint(i,k)*10.0
    7702. 

  7702.       end do
    7703. 

  7703.    end do
    7704. 

  7704.    do i=1,ncol
    7705. 

  7705.       pintrd(i,pverp) = pint(i,pverp)*10.0
    7706. 

  7706.    end do
    7707. 

  7707. !
    7708. 

  7708. ! Convert ozone volume mixing ratio to mass mixing ratio:
    7709. 

  7709. !
    7710. 

  7710.    vmmr = amo/amd
    7711. 

  7711.    do k=1,pver
    7712. 

  7712.       do i=1,ncol
    7713. 

  7713.          o3mmr(i,k) = vmmr*o3vmr(i,k)
    7714. 

  7714.       end do
    7715. 

  7715.    end do
    7716. 

  7716. !
    7717. 

  7717.    return
    7718. 

  7718. end subroutine radinp
    7719. 

  7719. subroutine radoz2(lchnk   ,ncol    ,pcols, pver, pverp, o3vmr   ,pint    ,plol    ,plos, ntoplw    )
    7720. 

  7720. !----------------------------------------------------------------------- 
    7721. 

  7721. ! 
    7722. 

  7722. ! Purpose: 
    7723. 

  7723. ! Computes the path length integrals to the model interfaces given the
    7724. 

  7724. ! ozone volume mixing ratio
    7725. 

  7725. ! 
    7726. 

  7726. ! Method: 
    7727. 

  7727. ! <Describe the algorithm(s) used in the routine.> 
    7728. 

  7728. ! <Also include any applicable external references.> 
    7729. 

  7729. ! 
    7730. 

  7730. ! Author: CCM1, CMS Contact J. Kiehl
    7731. 

  7731. ! 
    7732. 

  7732. !-----------------------------------------------------------------------
    7733. 

  7733. !  use shr_kind_mod, only: r8 => shr_kind_r8
    7734. 

  7734. !  use ppgrid
    7735. 

  7735. !  use comozp
    7736. 

    7737. 

  7737.    implicit none
    7738. 

  7738. !------------------------------Input arguments--------------------------
    7739. 

  7739. !
    7740. 

  7740.    integer, intent(in) :: lchnk                ! chunk identifier
    7741. 

  7741.    integer, intent(in) :: ncol                 ! number of atmospheric columns
    7742. 

  7742.    integer, intent(in) :: pcols, pver, pverp
    7743. 

    7744. 

  7744.    real(r8), intent(in) :: o3vmr(pcols,pver)   ! ozone volume mixing ratio
    7745. 

  7745.    real(r8), intent(in) :: pint(pcols,pverp)   ! Model interface pressures
    7746. 

    7747. 

  7747.    integer, intent(in) :: ntoplw               ! topmost level/layer longwave is solved for
    7748. 

    7749. 

  7749. !
    7750. 

  7750. !----------------------------Output arguments---------------------------
    7751. 

  7751. !
    7752. 

  7752.    real(r8), intent(out) :: plol(pcols,pverp)   ! Ozone prs weighted path length (cm)
    7753. 

  7753.    real(r8), intent(out) :: plos(pcols,pverp)   ! Ozone path length (cm)
    7754. 

    7755. 

  7755. !
    7756. 

  7756. !---------------------------Local workspace-----------------------------
    7757. 

  7757. !
    7758. 

  7758.    integer i                ! longitude index
    7759. 

  7759.    integer k                ! level index
    7760. 

  7760. !
    7761. 

  7761. !-----------------------------------------------------------------------
    7762. 

  7762. !
    7763. 

  7763. ! Evaluate the ozone path length integrals to interfaces;
    7764. 

  7764. ! factors of .1 and .01 to convert pressures from cgs to mks:
    7765. 

  7765. !
    7766. 

  7766.    do i=1,ncol
    7767. 

  7767.       plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw)
    7768. 

  7768.       plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw)
    7769. 

  7769.    end do
    7770. 

  7770.    do k=ntoplw+1,pverp
    7771. 

  7771.       do i=1,ncol
    7772. 

  7772.          plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1))
    7773. 

  7773.          plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* &
    7774. 

  7774.                     (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1))
    7775. 

  7775.       end do
    7776. 

  7776.    end do
    7777. 

  7777. !
    7778. 

  7778.    return
    7779. 

  7779. end subroutine radoz2
    7780. 

    7781. 

    7782. 

  7782. subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr)
    7783. 

  7783. !----------------------------------------------------------------------- 
    7784. 

  7784. ! 
    7785. 

  7785. ! Purpose: Interpolate ozone from current time-interpolated values to model levels
    7786. 

  7786. ! 
    7787. 

  7787. ! Method: Use pressure values to determine interpolation levels
    7788. 

  7788. ! 
    7789. 

  7789. ! Author: Bruce Briegleb
    7790. 

  7790. ! 
    7791. 

  7791. !--------------------------------------------------------------------------
    7792. 

  7792. !  use shr_kind_mod, only: r8 => shr_kind_r8
    7793. 

  7793. !  use ppgrid
    7794. 

  7794. !  use phys_grid,     only: get_lat_all_p, get_lon_all_p
    7795. 

  7795. !  use comozp
    7796. 

  7796. !  use abortutils, only: endrun
    7797. 

  7797. !--------------------------------------------------------------------------
    7798. 

  7798.    implicit none
    7799. 

  7799. !--------------------------------------------------------------------------
    7800. 

  7800. !
    7801. 

  7801. ! Arguments
    7802. 

  7802. !
    7803. 

  7803.    integer, intent(in) :: lchnk               ! chunk identifier
    7804. 

  7804.    integer, intent(in) :: pcols, pver
    7805. 

  7805.    integer, intent(in) :: ncol                ! number of atmospheric columns
    7806. 

  7806.    integer, intent(in) :: levsiz              ! number of ozone layers
    7807. 

    7808. 

  7808.    real(r8), intent(in) :: pmid(pcols,pver)   ! level pressures (mks)
    7809. 

  7809.    real(r8), intent(in) :: pin(levsiz)        ! ozone data level pressures (mks)
    7810. 

  7810.    real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio
    7811. 

    7812. 

  7812.    real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
    7813. 

  7813. !
    7814. 

  7814. ! local storage
    7815. 

  7815. !
    7816. 

  7816.    integer i                   ! longitude index
    7817. 

  7817.    integer k, kk, kkstart      ! level indices
    7818. 

  7818.    integer kupper(pcols)       ! Level indices for interpolation
    7819. 

  7819.    integer kount               ! Counter
    7820. 

  7820.    integer lats(pcols)         ! latitude indices
    7821. 

  7821.    integer lons(pcols)         ! latitude indices
    7822. 

    7823. 

  7823.    real(r8) dpu                ! upper level pressure difference
    7824. 

  7824.    real(r8) dpl                ! lower level pressure difference
    7825. 

  7825. !
    7826. 

  7826. ! Initialize latitude indices
    7827. 

  7827. !
    7828. 

  7828. !  call get_lat_all_p(lchnk, ncol, lats)
    7829. 

  7829. !  call get_lon_all_p(lchnk, ncol, lons)
    7830. 

  7830. !
    7831. 

  7831. ! Initialize index array
    7832. 

  7832. !
    7833. 

  7833.    do i=1,ncol
    7834. 

  7834.       kupper(i) = 1
    7835. 

  7835.    end do
    7836. 

    7837. 

  7837.    do k=1,pver
    7838. 

  7838. !
    7839. 

  7839. ! Top level we need to start looking is the top level for the previous k
    7840. 

  7840. ! for all longitude points
    7841. 

  7841. !
    7842. 

  7842.       kkstart = levsiz
    7843. 

  7843.       do i=1,ncol
    7844. 

  7844.          kkstart = min0(kkstart,kupper(i))
    7845. 

  7845.       end do
    7846. 

  7846.       kount = 0
    7847. 

  7847. !
    7848. 

  7848. ! Store level indices for interpolation
    7849. 

  7849. !
    7850. 

  7850.       do kk=kkstart,levsiz-1
    7851. 

  7851.          do i=1,ncol
    7852. 

  7852.             if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then
    7853. 

  7853.                kupper(i) = kk
    7854. 

  7854.                kount = kount + 1
    7855. 

  7855.             end if
    7856. 

  7856.          end do
    7857. 

  7857. !
    7858. 

  7858. ! If all indices for this level have been found, do the interpolation and
    7859. 

  7859. ! go to the next level
    7860. 

  7860. !
    7861. 

  7861.          if (kount.eq.ncol) then
    7862. 

  7862.             do i=1,ncol
    7863. 

  7863.                dpu = pmid(i,k) - pin(kupper(i))
    7864. 

  7864.                dpl = pin(kupper(i)+1) - pmid(i,k)
    7865. 

  7865.                o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
    7866. 

  7866.                              ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
    7867. 

  7867.             end do
    7868. 

  7868.             goto 35
    7869. 

  7869.          end if
    7870. 

  7870.       end do
    7871. 

  7871. !
    7872. 

  7872. ! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
    7873. 

  7873. ! must extrapolate from the bottom or top ozone data level for at least some
    7874. 

  7874. ! of the longitude points.
    7875. 

  7875. !
    7876. 

  7876.       do i=1,ncol
    7877. 

  7877.          if (pmid(i,k) .lt. pin(1)) then
    7878. 

  7878.             o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1)
    7879. 

  7879.          else if (pmid(i,k) .gt. pin(levsiz)) then
    7880. 

  7880.             o3vmr(i,k) = ozmix(i,levsiz)
    7881. 

  7881.          else
    7882. 

  7882.             dpu = pmid(i,k) - pin(kupper(i))
    7883. 

  7883.             dpl = pin(kupper(i)+1) - pmid(i,k)
    7884. 

  7884.             o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
    7885. 

  7885.                           ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
    7886. 

  7886.          end if
    7887. 

  7887.       end do
    7888. 

    7889. 

  7889.       if (kount.gt.ncol) then
    7890. 

  7890.          call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected')
    7891. 

  7891.       end if
    7892. 

  7892. 35    continue
    7893. 

  7893.    end do
    7894. 

    7895. 

  7895.    return
    7896. 

  7896. end subroutine radozn
    7897. 

    7898. 

    7899. 

  7899. #endif
    7900. 

    7901. 

  7901. end MODULE module_ra_cam
    7902. 

    7903.