PageRenderTime 73ms CodeModel.GetById 32ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/phys/module_ra_gsfcsw.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 3138 lines | 1778 code | 504 blank | 856 comment | 46 complexity | 1aade0c232781669363b83e248af8e59 MD5 | raw file
Possible License(s): AGPL-1.0

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

    

  1. !Comment the following out to turn off aerosol-radiation
    2. 

  2. !feedback between MOSAIC and GSFCSW. wig, 21-Feb-2005
    3. 

  3. 

  4. MODULE module_ra_gsfcsw
    5. 

  5. 

  6.    REAL,    PARAMETER, PRIVATE ::   thresh=1.e-9
    7. 

  7.    REAL,    SAVE               ::   center_lat
    8. 

  8. 

  9. !  Assign co2 and trace gases amount (units are parts/part by volumn)
    10. 

  10. 

  11.    REAL,    PARAMETER, PRIVATE ::   co2   = 300.e-6
    12. 

  12. 

  13. CONTAINS
    14. 

  14. 

  15.    SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong                   &
    16. 

  16.                    ,dz8w,rho_phy                                  &
    17. 

  17.                    ,alb,t3d,qv3d,qc3d,qr3d                        &
    18. 

  18.                    ,qi3d,qs3d,qg3d,qndrop3d                       &
    19. 

  19.                    ,p3d,p8w3d,pi3d,cldfra3d,rswtoa                &
    20. 

  20.                    ,gmt,cp,g,julday,xtime,declin,solcon           &
    21. 

  21.                    ,radfrq,degrad,taucldi,taucldc,warm_rain       &
    22. 

  22.                    ,tauaer300,tauaer400,tauaer600,tauaer999       & ! jcb
    23. 

  23.                    ,gaer300,gaer400,gaer600,gaer999               & ! jcb
    24. 

  24.                    ,waer300,waer400,waer600,waer999               & ! jcb
    25. 

  25.                    ,aer_ra_feedback                               &
    26. 

  26.                    ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop        &
    27. 

  27.                    ,ids,ide, jds,jde, kds,kde                     & 
    28. 

  28.                    ,ims,ime, jms,jme, kms,kme                     &
    29. 

  29.                    ,its,ite, jts,jte, kts,kte                     ) 
    30. 

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

  31.    IMPLICIT NONE
    32. 

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

  33.    INTEGER,    PARAMETER     ::        np    = 75
    34. 

  34. 

  35.    INTEGER,    INTENT(IN   ) ::        ids,ide, jds,jde, kds,kde, &
    36. 

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

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

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

  39. 

  40.    INTEGER,    INTENT(IN  )  ::                           JULDAY  
    41. 

  41. 

  42. 

  43.    REAL, INTENT(IN    )      ::        RADFRQ,DEGRAD,             &
    44. 

  44.                                        XTIME,DECLIN,SOLCON
    45. 

  45. !
    46. 

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

  47.          INTENT(IN    ) ::                                   P3D, &
    48. 

  48.                                                            P8W3D, &
    49. 

  49.                                                             pi3D, &
    50. 

  50.                                                              T3D, &
    51. 

  51.                                                             dz8w, &
    52. 

  52.                                                          rho_phy, &
    53. 

  53.                                                         CLDFRA3D
    54. 

  54. 

  55. 

  56.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
    57. 

  57.          INTENT(INOUT)  ::                              RTHRATEN
    58. 

  58.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
    59. 

  59.          OPTIONAL,                                                &
    60. 

  60.          INTENT(INOUT)  ::                               taucldi, &
    61. 

  61.                                                          taucldc
    62. 

  62. !
    63. 

  63.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    64. 

  64.          INTENT(IN   )  ::                                  XLAT, &
    65. 

  65.                                                            XLONG, &
    66. 

  66.                                                              ALB
    67. 

  67. !
    68. 

  68.    REAL, DIMENSION( ims:ime, jms:jme ),                           &
    69. 

  69.          INTENT(INOUT)  ::                                   GSW, &
    70. 

  70.                                                           RSWTOA
    71. 

  71. !
    72. 

  72.    REAL, INTENT(IN   )  ::                              GMT,CP,G
    73. 

  73. !
    74. 

  74. 

  75. !
    76. 

  76. ! Optional
    77. 

  77. !
    78. 

  78.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
    79. 

  79.          INTENT(IN    ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb
    80. 

  80.                                  gaer300,gaer400,gaer600,gaer999, & ! jcb
    81. 

  81.                                  waer300,waer400,waer600,waer999    ! jcb
    82. 

  82. 

  83.    INTEGER,    INTENT(IN  ), OPTIONAL   ::       aer_ra_feedback
    84. 

  84. 

  85.    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
    86. 

  86.          OPTIONAL,                                                &           
    87. 

  87.          INTENT(IN    ) ::                                        &
    88. 

  88.                                                             QV3D, &
    89. 

  89.                                                             QC3D, &
    90. 

  90.                                                             QR3D, &
    91. 

  91.                                                             QI3D, &
    92. 

  92.                                                             QS3D, &
    93. 

  93.                                                             QG3D, &
    94. 

  94.                                                         QNDROP3D
    95. 

  95. 

  96.    LOGICAL, OPTIONAL, INTENT(IN ) ::    &
    97. 

  97.                                    F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, &
    98. 

  98.                                                         F_QNDROP
    99. 

  99. 

  100. ! LOCAL VARS
    101. 

  101.  
    102. 

  102.    REAL, DIMENSION( its:ite ) ::                                  &
    103. 

  103.                                                               ts, &
    104. 

  104.                                                             cosz, &
    105. 

  105.                                                               fp, &
    106. 

  106.                                                           rsuvbm, &
    107. 

  107.                                                           rsuvdf, &
    108. 

  108.                                                           rsirbm, &
    109. 

  109.                                                           rsirdf, &
    110. 

  110.                                                             p400, &
    111. 

  111.                                                             p700
    112. 

  112. 

  113.    INTEGER, DIMENSION( its:ite ) ::                               &
    114. 

  114.                                                              ict, &
    115. 

  115.                                                              icb   
    116. 

  116. 

  117.    REAL, DIMENSION( its:ite, kts-1:kte, 2 ) ::            taucld
    118. 

  118. 

  119.    REAL, DIMENSION( its:ite, kts-1:kte+1 )  ::               flx, &
    120. 

  120.                                                             flxd
    121. 

  121. !
    122. 

  122.    REAL, DIMENSION( its:ite, kts-1:kte ) ::                     O3
    123. 

  123. !
    124. 

  124.    REAL, DIMENSION( its:ite, kts-1:kte, 11 ) ::                   &
    125. 

  125.                                                            taual, &
    126. 

  126.                                                            ssaal, &
    127. 

  127.                                                            asyal
    128. 

  128. 

  129.    REAL, DIMENSION( its:ite, kts-1:kte, 2 ) ::                    &
    130. 

  130.                                                             reff, &    
    131. 

  131.                                                              cwc    
    132. 

  132.    REAL, DIMENSION( its: ite, kts-1:kte+1 ) ::                    &
    133. 

  133.                                                            P8W2D
    134. 

  134.    REAL, DIMENSION( its: ite, kts-1:kte ) ::                      &
    135. 

  135.                                                           TTEN2D, &
    136. 

  136.                                                         qndrop2d, &
    137. 

  137.                                                             SH2D, &
    138. 

  138.                                                              P2D, &
    139. 

  139.                                                              T2D, &
    140. 

  140.                                                           fcld2D
    141. 

  141. 

  142.    REAL, DIMENSION( np, 5 ) ::                              pres, &
    143. 

  143.                                                            ozone
    144. 

  144.    REAL, DIMENSION( np )    ::                                 p
    145. 

  145. 

  146.    LOGICAL :: cldwater,overcast, predicate
    147. 

  147. !
    148. 

  148.    INTEGER :: i,j,K,NK,ib,kk,mix,mkx
    149. 

  149. 

  150. !  iprof = 1  :  mid-latitude summer profile
    151. 

  151. !        = 2  :  mid-latitude winter profile
    152. 

  152. !        = 3  :  sub-arctic   summer profile
    153. 

  153. !        = 4  :  sub-arctic   winter profile
    154. 

  154. !        = 5  :  tropical profile
    155. 

  155. !
    156. 

  156. 

  157.    INTEGER  ::                                             iprof, &
    158. 

  158.                                                        is_summer, &
    159. 

  159.                                                        ie_summer, &
    160. 

  160.                                                           lattmp
    161. 

  161. 

  162. 

  163. !
    164. 

  164.    REAL    :: XLAT0,XLONG0
    165. 

  165.    REAL    :: fac,latrmp
    166. 

  166.    REAL    :: xt24,tloctm,hrang,xxlat
    167. 

  167. 

  168.    real, dimension(11) :: midbands  ! jcb
    169. 

  169.    data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/   ! jcb
    170. 

  170.    real :: ang,slope ! jcb
    171. 

  171.    character(len=200) :: msg !wig
    172. 

  172.    real pi, third, relconst, lwpmin, rhoh2o
    173. 

  173. !
    174. 

  174. !--------------------------------------------------------------------------------
    175. 

  175. !   data set 1
    176. 

  176. !     mid-latitude summer (75 levels) :  p(mb)  o3(g/g)
    177. 

  177. !     surface temp = 294.0
    178. 

  178. !
    179. 

  179.       data (pres(i,1),i=1,np)/ &
    180. 

  180.           0.0006244,   0.0008759,   0.0012286,   0.0017234,   0.0024174, &
    181. 

  181.           0.0033909,   0.0047565,   0.0066720,   0.0093589,   0.0131278, &
    182. 

  182.           0.0184145,   0.0258302,   0.0362323,   0.0508234,   0.0712906, &
    183. 

  183.           0.1000000,   0.1402710,   0.1967600,   0.2759970,   0.3871430, &
    184. 

  184.           0.5430,    0.7617,    1.0685,    1.4988,    2.1024,    2.9490, &
    185. 

  185.           4.1366,    5.8025,    8.1392,   11.4170,   16.0147,   22.4640, &
    186. 

  186.          31.5105,   44.2001,   62.0000,   85.7750,  109.5500,  133.3250, &
    187. 

  187.         157.1000,  180.8750,  204.6500,  228.4250,  252.2000,  275.9750, &
    188. 

  188.         299.7500,  323.5250,  347.3000,  371.0750,  394.8500,  418.6250, &
    189. 

  189.         442.4000,  466.1750,  489.9500,  513.7250,  537.5000,  561.2750, &
    190. 

  190.         585.0500,  608.8250,  632.6000,  656.3750,  680.1500,  703.9250, &
    191. 

  191.         727.7000,  751.4750,  775.2500,  799.0250,  822.8000,  846.5750, &
    192. 

  192.         870.3500,  894.1250,  917.9000,  941.6750,  965.4500,  989.2250, &
    193. 

  193.        1013.0000/
    194. 

  194. !
    195. 

  195.       data (ozone(i,1),i=1,np)/ &
    196. 

  196.         0.1793E-06,  0.2228E-06,  0.2665E-06,  0.3104E-06,  0.3545E-06, &
    197. 

  197.         0.3989E-06,  0.4435E-06,  0.4883E-06,  0.5333E-06,  0.5786E-06, &
    198. 

  198.         0.6241E-06,  0.6698E-06,  0.7157E-06,  0.7622E-06,  0.8557E-06, &
    199. 

  199.         0.1150E-05,  0.1462E-05,  0.1793E-05,  0.2143E-05,  0.2512E-05, &
    200. 

  200.         0.2902E-05,  0.3313E-05,  0.4016E-05,  0.5193E-05,  0.6698E-05, &
    201. 

  201.         0.8483E-05,  0.9378E-05,  0.9792E-05,  0.1002E-04,  0.1014E-04, &
    202. 

  202.         0.9312E-05,  0.7834E-05,  0.6448E-05,  0.5159E-05,  0.3390E-05, &
    203. 

  203.         0.1937E-05,  0.1205E-05,  0.8778E-06,  0.6935E-06,  0.5112E-06, &
    204. 

  204.         0.3877E-06,  0.3262E-06,  0.2770E-06,  0.2266E-06,  0.2020E-06, &
    205. 

  205.         0.1845E-06,  0.1679E-06,  0.1519E-06,  0.1415E-06,  0.1317E-06, &
    206. 

  206.         0.1225E-06,  0.1137E-06,  0.1055E-06,  0.1001E-06,  0.9487E-07, &
    207. 

  207.         0.9016E-07,  0.8641E-07,  0.8276E-07,  0.7930E-07,  0.7635E-07, &
    208. 

  208.         0.7347E-07,  0.7065E-07,  0.6821E-07,  0.6593E-07,  0.6368E-07, &
    209. 

  209.         0.6148E-07,  0.5998E-07,  0.5859E-07,  0.5720E-07,  0.5582E-07, &
    210. 

  210.         0.5457E-07,  0.5339E-07,  0.5224E-07,  0.5110E-07,  0.4999E-07/
    211. 

  211. 

  212. !--------------------------------------------------------------------------------
    213. 

  213. !   data set 2
    214. 

  214. !   mid-latitude winter (75 levels) :  p(mb)  o3(g/g)
    215. 

  215. !   surface temp = 272.2
    216. 

  216. !
    217. 

  217.       data (pres(i,2),i=1,np)/ &
    218. 

  218.           0.0006244,   0.0008759,   0.0012286,   0.0017234,   0.0024174, &
    219. 

  219.           0.0033909,   0.0047565,   0.0066720,   0.0093589,   0.0131278, &
    220. 

  220.           0.0184145,   0.0258302,   0.0362323,   0.0508234,   0.0712906, &
    221. 

  221.           0.1000000,   0.1402710,   0.1967600,   0.2759970,   0.3871430, &
    222. 

  222.           0.5430,    0.7617,    1.0685,    1.4988,    2.1024,    2.9490, &
    223. 

  223.           4.1366,    5.8025,    8.1392,   11.4170,   16.0147,   22.4640, &
    224. 

  224.          31.5105,   44.2001,   62.0000,   85.9000,  109.8000,  133.7000, &
    225. 

  225.         157.6000,  181.5000,  205.4000,  229.3000,  253.2000,  277.1000, &
    226. 

  226.         301.0000,  324.9000,  348.8000,  372.7000,  396.6000,  420.5000, &
    227. 

  227.         444.4000,  468.3000,  492.2000,  516.1000,  540.0000,  563.9000, &
    228. 

  228.         587.8000,  611.7000,  635.6000,  659.5000,  683.4000,  707.3000, &
    229. 

  229.         731.2000,  755.1000,  779.0000,  802.9000,  826.8000,  850.7000, &
    230. 

  230.         874.6000,  898.5000,  922.4000,  946.3000,  970.2000,  994.1000, &
    231. 

  231.        1018.0000/
    232. 

  232. !
    233. 

  233.       data (ozone(i,2),i=1,np)/ &
    234. 

  234.         0.2353E-06,  0.3054E-06,  0.3771E-06,  0.4498E-06,  0.5236E-06, &
    235. 

  235.         0.5984E-06,  0.6742E-06,  0.7511E-06,  0.8290E-06,  0.9080E-06, &
    236. 

  236.         0.9881E-06,  0.1069E-05,  0.1152E-05,  0.1319E-05,  0.1725E-05, &
    237. 

  237.         0.2145E-05,  0.2581E-05,  0.3031E-05,  0.3497E-05,  0.3980E-05, &
    238. 

  238.         0.4478E-05,  0.5300E-05,  0.6725E-05,  0.8415E-05,  0.1035E-04, &
    239. 

  239.         0.1141E-04,  0.1155E-04,  0.1143E-04,  0.1093E-04,  0.1060E-04, &
    240. 

  240.         0.9720E-05,  0.8849E-05,  0.7424E-05,  0.6023E-05,  0.4310E-05, &
    241. 

  241.         0.2820E-05,  0.1990E-05,  0.1518E-05,  0.1206E-05,  0.9370E-06, &
    242. 

  242.         0.7177E-06,  0.5450E-06,  0.4131E-06,  0.3277E-06,  0.2563E-06, &
    243. 

  243.         0.2120E-06,  0.1711E-06,  0.1524E-06,  0.1344E-06,  0.1199E-06, &
    244. 

  244.         0.1066E-06,  0.9516E-07,  0.8858E-07,  0.8219E-07,  0.7598E-07, &
    245. 

  245.         0.6992E-07,  0.6403E-07,  0.5887E-07,  0.5712E-07,  0.5540E-07, &
    246. 

  246.         0.5370E-07,  0.5214E-07,  0.5069E-07,  0.4926E-07,  0.4785E-07, &
    247. 

  247.         0.4713E-07,  0.4694E-07,  0.4676E-07,  0.4658E-07,  0.4641E-07, &
    248. 

  248.         0.4634E-07,  0.4627E-07,  0.4619E-07,  0.4612E-07,  0.4605E-07/
    249. 

  249. 

  250. 

  251. !--------------------------------------------------------------------------------
    252. 

  252. !   data set 3
    253. 

  253. !   sub-arctic summer (75 levels) :  p(mb)  o3(g/g)
    254. 

  254. !   surface temp = 287.0
    255. 

  255. !
    256. 

  256.       data (pres(i,3),i=1,np)/ &
    257. 

  257.           0.0006244,   0.0008759,   0.0012286,   0.0017234,   0.0024174, &
    258. 

  258.           0.0033909,   0.0047565,   0.0066720,   0.0093589,   0.0131278, &
    259. 

  259.           0.0184145,   0.0258302,   0.0362323,   0.0508234,   0.0712906, &
    260. 

  260.           0.1000000,   0.1402710,   0.1967600,   0.2759970,   0.3871430, &
    261. 

  261.           0.5430,    0.7617,    1.0685,    1.4988,    2.1024,    2.9490, &
    262. 

  262.           4.1366,    5.8025,    8.1392,   11.4170,   16.0147,   22.4640, &
    263. 

  263.          31.5105,   44.2001,   62.0000,   85.7000,  109.4000,  133.1000, &
    264. 

  264.         156.8000,  180.5000,  204.2000,  227.9000,  251.6000,  275.3000, &
    265. 

  265.         299.0000,  322.7000,  346.4000,  370.1000,  393.8000,  417.5000, &
    266. 

  266.         441.2000,  464.9000,  488.6000,  512.3000,  536.0000,  559.7000, &
    267. 

  267.         583.4000,  607.1000,  630.8000,  654.5000,  678.2000,  701.9000, &
    268. 

  268.         725.6000,  749.3000,  773.0000,  796.7000,  820.4000,  844.1000, &
    269. 

  269.         867.8000,  891.5000,  915.2000,  938.9000,  962.6000,  986.3000, &
    270. 

  270.        1010.0000/
    271. 

  271. !
    272. 

  272.       data (ozone(i,3),i=1,np)/ &
    273. 

  273.         0.1728E-06,  0.2131E-06,  0.2537E-06,  0.2944E-06,  0.3353E-06, &
    274. 

  274.         0.3764E-06,  0.4176E-06,  0.4590E-06,  0.5006E-06,  0.5423E-06, &
    275. 

  275.         0.5842E-06,  0.6263E-06,  0.6685E-06,  0.7112E-06,  0.7631E-06, &
    276. 

  276.         0.1040E-05,  0.1340E-05,  0.1660E-05,  0.2001E-05,  0.2362E-05, &
    277. 

  277.         0.2746E-05,  0.3153E-05,  0.3762E-05,  0.4988E-05,  0.6518E-05, &
    278. 

  278.         0.8352E-05,  0.9328E-05,  0.9731E-05,  0.8985E-05,  0.7632E-05, &
    279. 

  279.         0.6814E-05,  0.6384E-05,  0.5718E-05,  0.4728E-05,  0.4136E-05, &
    280. 

  280.         0.3033E-05,  0.2000E-05,  0.1486E-05,  0.1121E-05,  0.8680E-06, &
    281. 

  281.         0.6474E-06,  0.5164E-06,  0.3921E-06,  0.2996E-06,  0.2562E-06, &
    282. 

  282.         0.2139E-06,  0.1723E-06,  0.1460E-06,  0.1360E-06,  0.1267E-06, &
    283. 

  283.         0.1189E-06,  0.1114E-06,  0.1040E-06,  0.9678E-07,  0.8969E-07, &
    284. 

  284.         0.8468E-07,  0.8025E-07,  0.7590E-07,  0.7250E-07,  0.6969E-07, &
    285. 

  285.         0.6694E-07,  0.6429E-07,  0.6208E-07,  0.5991E-07,  0.5778E-07, &
    286. 

  286.         0.5575E-07,  0.5403E-07,  0.5233E-07,  0.5067E-07,  0.4904E-07, &
    287. 

  287.         0.4721E-07,  0.4535E-07,  0.4353E-07,  0.4173E-07,  0.3997E-07/
    288. 

  288. 

  289. 

  290. !--------------------------------------------------------------------------------
    291. 

  291. !   data set 3
    292. 

  292. !   sub-arctic winter (75 levels) :   p(mb)  o3(g/g)
    293. 

  293. !   surface temp = 257.1
    294. 

  294. !
    295. 

  295.       data (pres(i,4),i=1,np)/ &
    296. 

  296.           0.0006244,   0.0008759,   0.0012286,   0.0017234,   0.0024174, &
    297. 

  297.           0.0033909,   0.0047565,   0.0066720,   0.0093589,   0.0131278, &
    298. 

  298.           0.0184145,   0.0258302,   0.0362323,   0.0508234,   0.0712906, &
    299. 

  299.           0.1000000,   0.1402710,   0.1967600,   0.2759970,   0.3871430, &
    300. 

  300.           0.5430,    0.7617,    1.0685,    1.4988,    2.1024,    2.9490, &
    301. 

  301.           4.1366,    5.8025,    8.1392,   11.4170,   16.0147,   22.4640, &
    302. 

  302.          31.5105,   44.2001,   62.0000,   85.7750,  109.5500,  133.3250, &
    303. 

  303.         157.1000,  180.8750,  204.6500,  228.4250,  252.2000,  275.9750, &
    304. 

  304.         299.7500,  323.5250,  347.3000,  371.0750,  394.8500,  418.6250, &
    305. 

  305.         442.4000,  466.1750,  489.9500,  513.7250,  537.5000,  561.2750, &
    306. 

  306.         585.0500,  608.8250,  632.6000,  656.3750,  680.1500,  703.9250, &
    307. 

  307.         727.7000,  751.4750,  775.2500,  799.0250,  822.8000,  846.5750, &
    308. 

  308.         870.3500,  894.1250,  917.9000,  941.6750,  965.4500,  989.2250, &
    309. 

  309.        1013.0000/
    310. 

  310. !
    311. 

  311.       data (ozone(i,4),i=1,np)/ &
    312. 

  312.         0.2683E-06,  0.3562E-06,  0.4464E-06,  0.5387E-06,  0.6333E-06, &
    313. 

  313.         0.7301E-06,  0.8291E-06,  0.9306E-06,  0.1034E-05,  0.1140E-05, &
    314. 

  314.         0.1249E-05,  0.1360E-05,  0.1474E-05,  0.1855E-05,  0.2357E-05, &
    315. 

  315.         0.2866E-05,  0.3383E-05,  0.3906E-05,  0.4437E-05,  0.4975E-05, &
    316. 

  316.         0.5513E-05,  0.6815E-05,  0.8157E-05,  0.1008E-04,  0.1200E-04, &
    317. 

  317.         0.1242E-04,  0.1250E-04,  0.1157E-04,  0.1010E-04,  0.9063E-05, &
    318. 

  318.         0.8836E-05,  0.8632E-05,  0.8391E-05,  0.7224E-05,  0.6054E-05, &
    319. 

  319.         0.4503E-05,  0.3204E-05,  0.2278E-05,  0.1833E-05,  0.1433E-05, &
    320. 

  320.         0.9996E-06,  0.7440E-06,  0.5471E-06,  0.3944E-06,  0.2852E-06, &
    321. 

  321.         0.1977E-06,  0.1559E-06,  0.1333E-06,  0.1126E-06,  0.9441E-07, &
    322. 

  322.         0.7678E-07,  0.7054E-07,  0.6684E-07,  0.6323E-07,  0.6028E-07, &
    323. 

  323.         0.5746E-07,  0.5468E-07,  0.5227E-07,  0.5006E-07,  0.4789E-07, &
    324. 

  324.         0.4576E-07,  0.4402E-07,  0.4230E-07,  0.4062E-07,  0.3897E-07, &
    325. 

  325.         0.3793E-07,  0.3697E-07,  0.3602E-07,  0.3506E-07,  0.3413E-07, &
    326. 

  326.         0.3326E-07,  0.3239E-07,  0.3153E-07,  0.3069E-07,  0.2987E-07/ 
    327. 

  327. 

  328. !--------------------------------------------------------------------------------
    329. 

  329. !   data set 4
    330. 

  330. !   tropical (75 levels) :   p(mb)  o3(g/g)
    331. 

  331. !   surface temp = 300.0
    332. 

  332. !
    333. 

  333.       data (pres(i,5),i=1,np)/ &
    334. 

  334.           0.0006244,   0.0008759,   0.0012286,   0.0017234,   0.0024174, &
    335. 

  335.           0.0033909,   0.0047565,   0.0066720,   0.0093589,   0.0131278, &
    336. 

  336.           0.0184145,   0.0258302,   0.0362323,   0.0508234,   0.0712906, &
    337. 

  337.           0.1000000,   0.1402710,   0.1967600,   0.2759970,   0.3871430, &
    338. 

  338.           0.5430,    0.7617,    1.0685,    1.4988,    2.1024,    2.9490, &
    339. 

  339.           4.1366,    5.8025,    8.1392,   11.4170,   16.0147,   22.4640, &
    340. 

  340.          31.5105,   44.2001,   62.0000,   85.7750,  109.5500,  133.3250, &
    341. 

  341.         157.1000,  180.8750,  204.6500,  228.4250,  252.2000,  275.9750, &
    342. 

  342.         299.7500,  323.5250,  347.3000,  371.0750,  394.8500,  418.6250, &
    343. 

  343.         442.4000,  466.1750,  489.9500,  513.7250,  537.5000,  561.2750, &
    344. 

  344.         585.0500,  608.8250,  632.6000,  656.3750,  680.1500,  703.9250, &
    345. 

  345.         727.7000,  751.4750,  775.2500,  799.0250,  822.8000,  846.5750, &
    346. 

  346.         870.3500,  894.1250,  917.9000,  941.6750,  965.4500,  989.2250, &
    347. 

  347.        1013.0000/
    348. 

  348. !
    349. 

  349.       data (ozone(i,5),i=1,np)/ &
    350. 

  350.         0.1993E-06,  0.2521E-06,  0.3051E-06,  0.3585E-06,  0.4121E-06, &
    351. 

  351.         0.4661E-06,  0.5203E-06,  0.5748E-06,  0.6296E-06,  0.6847E-06, &
    352. 

  352.         0.7402E-06,  0.7959E-06,  0.8519E-06,  0.9096E-06,  0.1125E-05, &
    353. 

  353.         0.1450E-05,  0.1794E-05,  0.2156E-05,  0.2538E-05,  0.2939E-05, &
    354. 

  354.         0.3362E-05,  0.3785E-05,  0.4753E-05,  0.6005E-05,  0.7804E-05, &
    355. 

  355.         0.9635E-05,  0.1023E-04,  0.1067E-04,  0.1177E-04,  0.1290E-04, &
    356. 

  356.         0.1134E-04,  0.9223E-05,  0.6667E-05,  0.3644E-05,  0.1545E-05, &
    357. 

  357.         0.5355E-06,  0.2523E-06,  0.2062E-06,  0.1734E-06,  0.1548E-06, &
    358. 

  358.         0.1360E-06,  0.1204E-06,  0.1074E-06,  0.9707E-07,  0.8960E-07, &
    359. 

  359.         0.8419E-07,  0.7962E-07,  0.7542E-07,  0.7290E-07,  0.7109E-07, &
    360. 

  360.         0.6940E-07,  0.6786E-07,  0.6635E-07,  0.6500E-07,  0.6370E-07, &
    361. 

  361.         0.6244E-07,  0.6132E-07,  0.6022E-07,  0.5914E-07,  0.5884E-07, &
    362. 

  362.         0.5855E-07,  0.5823E-07,  0.5772E-07,  0.5703E-07,  0.5635E-07, &
    363. 

  363.         0.5570E-07,  0.5492E-07,  0.5412E-07,  0.5335E-07,  0.5260E-07, &
    364. 

  364.         0.5167E-07,  0.5063E-07,  0.4961E-07,  0.4860E-07,  0.4761E-07/
    365. 

  365. 

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

  367. 

  368. #ifdef WRF_CHEM
    369. 

  369.    IF ( aer_ra_feedback == 1) then
    370. 

  370.    IF ( .NOT. &
    371. 

  371.       ( PRESENT(tauaer300) .AND. &
    372. 

  372.         PRESENT(tauaer400) .AND. &
    373. 

  373.         PRESENT(tauaer600) .AND. &
    374. 

  374.         PRESENT(tauaer999) .AND. &
    375. 

  375.         PRESENT(gaer300) .AND. &
    376. 

  376.         PRESENT(gaer400) .AND. &
    377. 

  377.         PRESENT(gaer600) .AND. &
    378. 

  378.         PRESENT(gaer999) .AND. &
    379. 

  379.         PRESENT(waer300) .AND. &
    380. 

  380.         PRESENT(waer400) .AND. &
    381. 

  381.         PRESENT(waer600) .AND. &
    382. 

  382.         PRESENT(waer999) ) ) THEN
    383. 

  383.       CALL wrf_error_fatal ( 'Warning: missing fields required for aerosol radiation' )
    384. 

  384.    ENDIF
    385. 

  385.    ENDIF
    386. 

  386. #endif
    387. 

  387.    cldwater = .true.
    388. 

  388.    overcast = .false.
    389. 

  389. 

  390.    mix=ite-its+1 
    391. 

  391.    mkx=kte-kts+1 
    392. 

  392. 

  393.    is_summer=80
    394. 

  394.    ie_summer=265
    395. 

  395. 

  396. ! testing, need to change iprof, which is function of lat and julian day
    397. 

  397. !  iprof = 1  :  mid-latitude summer profile
    398. 

  398. !        = 2  :  mid-latitude winter profile
    399. 

  399. !        = 3  :  sub-arctic   summer profile
    400. 

  400. !        = 4  :  sub-arctic   winter profile
    401. 

  401. !        = 5  :  tropical profile
    402. 

  402. 

  403.    IF (abs(center_lat) .le. 30. ) THEN ! tropic
    404. 

  404.       iprof = 5
    405. 

  405.    ELSE
    406. 

  406.       IF (center_lat .gt.  0.) THEN
    407. 

  407.          IF (center_lat .gt. 60. ) THEN !  arctic
    408. 

  408.             IF (JULDAY .gt. is_summer .and. JULDAY .lt. ie_summer ) THEN
    409. 

  409.                ! arctic summer
    410. 

  410.                iprof = 3
    411. 

  411.             ELSE
    412. 

  412.                ! arctic winter
    413. 

  413.                iprof = 4
    414. 

  414.             ENDIF
    415. 

  415.          ELSE        ! midlatitude
    416. 

  416.             IF (JULDAY .gt. is_summer .and. JULDAY .lt. ie_summer ) THEN
    417. 

  417.                ! north midlatitude summer
    418. 

  418.                iprof = 1
    419. 

  419.             ELSE
    420. 

  420.                ! north midlatitude winter
    421. 

  421.                iprof = 2
    422. 

  422.             ENDIF
    423. 

  423.          ENDIF
    424. 

  424. 

  425.       ELSE
    426. 

  426.          IF (center_lat .lt. -60. ) THEN !  antarctic
    427. 

  427.             IF (JULDAY .lt. is_summer .or. JULDAY .gt. ie_summer ) THEN
    428. 

  428.                ! antarctic summer
    429. 

  429.                iprof = 3
    430. 

  430.             ELSE
    431. 

  431.                ! antarctic winter
    432. 

  432.                iprof = 4
    433. 

  433.             ENDIF
    434. 

  434.          ELSE        ! midlatitude
    435. 

  435.             IF (JULDAY .lt. is_summer .or. JULDAY .gt. ie_summer ) THEN
    436. 

  436.                ! south midlatitude summer
    437. 

  437.                iprof = 1
    438. 

  438.             ELSE
    439. 

  439.                ! south midlatitude winter
    440. 

  440.                iprof = 2
    441. 

  441.             ENDIF
    442. 

  442.          ENDIF
    443. 

  443. 

  444.       ENDIF
    445. 

  445.    ENDIF
    446. 

  446. 

  447. 

  448.    j_loop: DO J=jts,jte
    449. 

  449. 

  450.       DO K=kts,kte          
    451. 

  451.       DO I=its,ite          
    452. 

  452.          cwc(i,k,1) = 0.
    453. 

  453.          cwc(i,k,2) = 0.
    454. 

  454.       ENDDO
    455. 

  455.       ENDDO
    456. 

  456. 

  457.       DO K=1,np
    458. 

  458.          p(k)=pres(k,iprof)
    459. 

  459.       ENDDO
    460. 

  460. 

  461. ! reverse vars 
    462. 

  462. !
    463. 

  463.       DO K=kts,kte+1
    464. 

  464.       DO I=its,ite
    465. 

  465.          NK=kme-K+kms
    466. 

  466.          P8W2D(I,K)=p8w3d(i,nk,j)*0.01   ! P8w2D is in mb
    467. 

  467.       ENDDO
    468. 

  468.       ENDDO
    469. 

  469. 

  470.       DO I=its,ite
    471. 

  471.          P8W2D(I,0)=.0
    472. 

  472.       ENDDO
    473. 

  473. !
    474. 

  474.       DO K=kts,kte
    475. 

  475.       DO I=its,ite
    476. 

  476.          NK=kme-1-K+kms
    477. 

  477.          TTEN2D(I,K)=0.
    478. 

  478.          T2D(I,K)=T3D(I,NK,J)
    479. 

  479. 

  480. ! SH2D specific humidity
    481. 

  481.          SH2D(I,K)=QV3D(I,NK,J)/(1.+QV3D(I,NK,J))
    482. 

  482.          SH2D(I,K)=max(0.,SH2D(I,K))
    483. 

  483.          cwc(I,K,2)=QC3D(I,NK,J)
    484. 

  484.          cwc(I,K,2)=max(0.,cwc(I,K,2))
    485. 

  485. 

  486.          P2D(I,K)=p3d(i,nk,j)*0.01      ! P2D is in mb
    487. 

  487.          fcld2D(I,K)=CLDFRA3D(I,NK,J)
    488. 

  488.       ENDDO
    489. 

  489.       ENDDO
    490. 

  490. 

  491. ! This logic is tortured because cannot test F_QI unless
    492. 

  492. ! it is present, and order of evaluation of expressions
    493. 

  493. ! is not specified in Fortran
    494. 

  494. 

  495.       IF ( PRESENT ( F_QI ) ) THEN
    496. 

  496.          predicate = F_QI
    497. 

  497.       ELSE
    498. 

  498.         predicate = .FALSE.
    499. 

  499.       ENDIF
    500. 

  500. 

  501.       IF (.NOT. warm_rain .AND. .NOT. predicate ) THEN
    502. 

  502.          DO K=kts,kte
    503. 

  503.          DO I=its,ite
    504. 

  504.             IF (T2D(I,K) .lt. 273.15) THEN
    505. 

  505.                cwc(I,K,1)=cwc(I,K,2)
    506. 

  506.                cwc(I,K,2)=0.
    507. 

  507.             ENDIF
    508. 

  508.          ENDDO
    509. 

  509.          ENDDO
    510. 

  510.       ENDIF
    511. 

  511. 

  512.        IF ( PRESENT( F_QNDROP ) ) THEN
    513. 

  513.          IF ( F_QNDROP ) THEN
    514. 

  514.             DO K=kts,kte
    515. 

  515.                DO I=its,ite
    516. 

  516.                   NK=kme-1-K+kms
    517. 

  517.                   qndrop2d(I,K)=qndrop3d(I,NK,j)
    518. 

  518.                ENDDO
    519. 

  519.             ENDDO
    520. 

  520.             qndrop2d(:,kts-1)=0.
    521. 

  521.          END IF
    522. 

  522.       END IF
    523. 

  523. 

  524.      DO I=its,ite
    525. 

  525.          TTEN2D(I,0)=0.
    526. 

  526.          T2D(I,0)=T2D(I,1)
    527. 

  527. ! SH2D specific humidity
    528. 

  528.          SH2D(I,0)=0.5*SH2D(i,1)
    529. 

  529.          cwc(I,0,2)=0.
    530. 

  530.          cwc(I,0,1)=0.
    531. 

  531.          P2D(I,0)=0.5*(P8W2D(I,0)+P8W2D(I,1))
    532. 

  532.          fcld2D(I,0)=0.
    533. 

  533.       ENDDO
    534. 

  534. !
    535. 

  535.       IF ( PRESENT( F_QI ) .AND. PRESENT( qi3d)  ) THEN
    536. 

  536. 	 IF ( (F_QI) ) THEN
    537. 

  537.             DO K=kts,kte          
    538. 

  538.             DO I=its,ite          
    539. 

  539.                NK=kme-1-K+kms
    540. 

  540.                cwc(I,K,1)=QI3D(I,NK,J)
    541. 

  541.                cwc(I,K,1)=max(0.,cwc(I,K,1))
    542. 

  542.             ENDDO
    543. 

  543.             ENDDO
    544. 

  544.          ENDIF
    545. 

  545.       ENDIF
    546. 

  546. !
    547. 

  547. ! ... Vertical profiles for ozone
    548. 

  548. !
    549. 

  549.       call o3prof (np, p, ozone(1,iprof), its, ite, kts-1, kte, P2D, O3)
    550. 

  550. 

  551. ! ... Vertical profiles for effective particle size
    552. 

  552. !
    553. 

  553.       pi = 4.*atan(1.0)
    554. 

  554.       third=1./3.
    555. 

  555.       rhoh2o=1.e3
    556. 

  556.       relconst=3/(4.*pi*rhoh2o)
    557. 

  557. !     minimun liquid water path to calculate rel
    558. 

  558. !     corresponds to optical depth of 1.e-3 for radius 4 microns.
    559. 

  559.       lwpmin=3.e-5
    560. 

  560.       do k = kts-1, kte
    561. 

  561.       do i = its, ite
    562. 

  562.          reff(i,k,2) = 10.
    563. 

  563.          if( PRESENT( F_QNDROP ) ) then
    564. 

  564.             if( F_QNDROP ) then
    565. 

  565.               if ( cwc(i,k,2)*(P8W2D(I,K+1)-P8W2D(I,K)).gt.lwpmin.and. &
    566. 

  566.                    qndrop2d(i,k).gt.1000. ) then
    567. 

  567.                reff(i,k,2)=(relconst*cwc(i,k,2)/qndrop2d(i,k))**third ! effective radius in m
    568. 

  568. !           apply scaling from Martin et al., JAS 51, 1830.
    569. 

  569.                reff(i,k,2)=1.1*reff(i,k,2)
    570. 

  570.                reff(i,k,2)=reff(i,k,2)*1.e6 ! convert from m to microns
    571. 

  571.                reff(i,k,2)=max(reff(i,k,2),4.)
    572. 

  572.                reff(i,k,2)=min(reff(i,k,2),20.)
    573. 

  573.               end if
    574. 

  574.             end if
    575. 

  575.          end if
    576. 

  576.          reff(i,k,1) = 80.
    577. 

  577.       end do
    578. 

  578.       end do
    579. 

  579. !
    580. 

  580. ! ... Level indices separating high, middle and low clouds
    581. 

  581. !
    582. 

  582.       do i = its, ite
    583. 

  583.          p400(i) = 1.e5
    584. 

  584.          p700(i) = 1.e5
    585. 

  585.       enddo
    586. 

  586. 

  587.       do k = kts-1,kte+1
    588. 

  588.          do i = its, ite
    589. 

  589.             if (abs(P8W2D(i,k) - 400.) .lt. p400(i)) then
    590. 

  590.                p400(i) = abs(P8W2D(i,k) - 400.)
    591. 

  591.                ict(i) = k
    592. 

  592.             endif
    593. 

  593.             if (abs(P8W2D(i,k) - 700.) .lt. p700(i)) then
    594. 

  594.                p700(i) = abs(P8W2D(i,k) - 700.)
    595. 

  595.                icb(i) = k
    596. 

  596.             endif
    597. 

  597.         end do
    598. 

  598.       end do
    599. 

  599. 

  600. !wig beg
    601. 

  601. ! ... Aerosol effects. Added aerosol feedbacks with MOSAIC, Dec. 2005.
    602. 

  602. !
    603. 

  603.       do ib = 1, 11
    604. 

  604.       do k = kts-1,kte
    605. 

  605.       do i = its,ite
    606. 

  606.          taual(i,k,ib) = 0.
    607. 

  607.          ssaal(i,k,ib) = 0.
    608. 

  608.          asyal(i,k,ib) = 0.
    609. 

  609.       end do
    610. 

  610.       end do
    611. 

  611.       end do
    612. 

  612. 

  613. #ifdef WRF_CHEM
    614. 

  614.    IF ( AER_RA_FEEDBACK == 1) then
    615. 

  615. !wig end
    616. 

  616.       do ib = 1, 11
    617. 

  617.       do k = kts-1,kte-1      !wig
    618. 

  618.       do i = its,ite
    619. 

  619. 

  620. !        taual(i,kte-k,ib) = 0.
    621. 

  621. !        ssaal(i,kte-k,ib) = 0.
    622. 

  622. !        asyal(i,kte-k,ib) = 0.
    623. 

  623. 

  624. !jcb beg
    625. 

  625. ! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
    626. 

  626. ! these are: 200,235,270,287.5,302.5,305,362.5,550,1920,1745,6135; why the emphasis on the UV?
    627. 

  627. ! taual - use angstrom exponent
    628. 

  628.         if(tauaer300(i,k+1,j).gt.thresh .and. tauaer999(i,k+1,j).gt.thresh) then
    629. 

  629.            ang=log(tauaer300(i,k+1,j)/tauaer999(i,k+1,j))/log(999./300.)
    630. 

  630. !       write(6,*)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j)
    631. 

  631.            taual(i,kte-k,ib)=tauaer400(i,k+1,j)*(0.4/midbands(ib))**ang ! notice reserved variable
    632. 

  632. !       write(6,10001)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j),midbands(ib),taual(i,k,ib)
    633. 

  633. !10001      format(i3,i3,5f12.6)
    634. 

  634. 

  635. ! ssa - linear interpolation; extrapolation
    636. 

  636.            slope=(waer600(i,k+1,j)-waer400(i,k+1,j))/.2
    637. 

  637.            ssaal(i,kte-k,ib) = slope*(midbands(ib)-.6)+waer600(i,k+1,j) ! notice reversed variables
    638. 

  638.            if(ssaal(i,kte-k,ib).lt.0.4) ssaal(i,kte-k,ib)=0.4
    639. 

  639.            if(ssaal(i,kte-k,ib).ge.1.0) ssaal(i,kte-k,ib)=1.0
    640. 

  640. 

  641. ! g - linear interpolation;extrapolation
    642. 

  642.            slope=(gaer600(i,k+1,j)-gaer400(i,k+1,j))/.2
    643. 

  643.            asyal(i,kte-k,ib) = slope*(midbands(ib)-.6)+gaer600(i,k+1,j) ! notice reversed varaibles
    644. 

  644.            if(asyal(i,kte-k,ib).lt.0.5) asyal(i,kte-k,ib)=0.5
    645. 

  645.            if(asyal(i,kte-k,ib).ge.1.0) asyal(i,kte-k,ib)=1.0
    646. 

  646.         endif
    647. 

  647. !jcb end
    648. 

  648.       end do
    649. 

  649.       end do
    650. 

  650.       end do
    651. 

  651. 

  652. !wig beg
    653. 

  653.       do ib = 1, 11
    654. 

  654.       do i = its,ite
    655. 

  655.          slope = 0.  !use slope as a sum holder
    656. 

  656.          do k = kts-1,kte
    657. 

  657.             slope = slope + taual(i,k,ib)
    658. 

  658.          end do
    659. 

  659.          if( slope < 0. ) then
    660. 

  660.             write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,ib=",3i5)') slope,i,j,ib
    661. 

  661.             call wrf_error_fatal(msg)
    662. 

  662.          else if( slope > 5. ) then
    663. 

  663.             call wrf_message("-------------------------")
    664. 

  664.             write(msg,'("WARNING: Large total optical depth of ",f8.2," at point i,j,ib=",3i5)') slope,i,j,ib
    665. 

  665.             call wrf_message(msg)
    666. 

  666. 

  667.             call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999")
    668. 

  668.             do k=kts,kte
    669. 

  669.                write(msg,'(i4,4f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
    670. 

  670.                     tauaer600(i,k,j), tauaer999(i,k,j)
    671. 

  671.                call wrf_message(msg)
    672. 

  672.             end do
    673. 

  673. 

  674.             call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600, gaer999")
    675. 

  675.             do k=kts,kte
    676. 

  676.                write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
    677. 

  677.                     gaer600(i,k,j), gaer999(i,k,j)
    678. 

  678.                call wrf_message(msg)
    679. 

  679.             end do
    680. 

  680. 

  681.             call wrf_message("Diagnostics 3: k, waer300, waer400, waer600, waer999")
    682. 

  682.             do k=kts,kte
    683. 

  683.                write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
    684. 

  684.                     waer600(i,k,j), waer999(i,k,j)
    685. 

  685.                call wrf_message(msg)
    686. 

  686.             end do
    687. 

  687. 

  688.             call wrf_message("Diagnostics 4: k, ssaal, asyal, taual")
    689. 

  689.             do k=kts-1,kte
    690. 

  690.                write(msg,'(i4,3f8.2)') k, ssaal(i,k,ib), asyal(i,k,ib), taual(i,k,ib)
    691. 

  691.                call wrf_message(msg)
    692. 

  692.             end do
    693. 

  693.             call wrf_message("-------------------------")
    694. 

  694.          end if
    695. 

  695.       end do
    696. 

  696.       end do
    697. 

  697. !wig end
    698. 

  698.       endif
    699. 

  699. #endif
    700. 

  700. !
    701. 

  701. ! ... Initialize output arrays
    702. 

  702. !
    703. 

  703.       do ib = 1, 2
    704. 

  704.       do k = kts-1, kte
    705. 

  705.       do i = its, ite
    706. 

  706.          taucld(i,k,ib) = 0.
    707. 

  707.       end do
    708. 

  708.       end do
    709. 

  709.       end do
    710. 

  710. !
    711. 

  711.       do k = kts-1,kte+1
    712. 

  712.       do i = its,ite
    713. 

  713.          flx(i,k)   = 0.
    714. 

  714.          flxd(i,k)  = 0.
    715. 

  715.       end do
    716. 

  716.       end do
    717. 

  717. !
    718. 

  718. ! ... Solar zenith angle
    719. 

  719. !
    720. 

  720.       do i = its,ite
    721. 

  721.         xt24 = mod(xtime + radfrq * 0.5, 1440.)
    722. 

  722.         tloctm = GMT + xt24 / 60. + XLONG(i,j) / 15.
    723. 

  723.         hrang = 15. * (tloctm - 12.) * degrad
    724. 

  724.         xxlat = XLAT(i,j) * degrad
    725. 

  725.         cosz(i) = sin(xxlat) * sin(declin) + &
    726. 

  726.                   cos(xxlat) * cos(declin) * cos(hrang)
    727. 

  727.         rsuvbm(i) = ALB(i,j)
    728. 

  728.         rsuvdf(i) = ALB(i,j)
    729. 

  729.         rsirbm(i) = ALB(i,j)
    730. 

  730.         rsirdf(i) = ALB(i,j)
    731. 

  731.       end do
    732. 

  732.                                   
    733. 

  733.       call sorad (mix,1,1,mkx+1,p8w2D,t2D,sh2D,o3,                 &
    734. 

  734.                   overcast,cldwater,cwc,taucld,reff,fcld2D,ict,icb,&
    735. 

  735.                   taual,ssaal,asyal,                               &
    736. 

  736.                   cosz,rsuvbm,rsuvdf,rsirbm,rsirdf,                &
    737. 

  737.                   flx,flxd)
    738. 

  738. !
    739. 

  739. ! ... Convert the units of flx and flc from fraction to w/m^2
    740. 

  740. !
    741. 

  741.       do k = kts, kte
    742. 

  742.       do i = its, ite
    743. 

  743.          nk=kme-1-k+kms
    744. 

  744.          if(present(taucldc)) taucldc(i,nk,j)=taucld(i,k,2)
    745. 

  745.          if(present(taucldi)) taucldi(i,nk,j)=taucld(i,k,1)
    746. 

  746.       enddo
    747. 

  747.       enddo
    748. 

  748.  
    749. 

  749.       do k = kts, kte+1
    750. 

  750.         do i = its, ite
    751. 

  751.           if (cosz(i) .lt. thresh) then
    752. 

  752.             flx(i,k) = 0.
    753. 

  753.           else
    754. 

  754.             flx(i,k) = flx(i,k) * SOLCON * cosz(i)
    755. 

  755.           endif
    756. 

  756.         end do
    757. 

  757.       end do
    758. 

  758. !
    759. 

  759. ! ... Calculate heating rate (deg/sec)
    760. 

  760. !
    761. 

  761.       fac = .01 * g / Cp
    762. 

  762.       do k = kts, kte
    763. 

  763.       do i = its, ite
    764. 

  764.          if (cosz(i) .gt. thresh) then
    765. 

  765.              TTEN2D(i,k) = - fac * (flx(i,k) - flx(i,k+1))/ &
    766. 

  766.                            (p8w2d(i,k)-p8w2d(i,k+1))
    767. 

  767.          endif
    768. 

  768.       end do
    769. 

  769.       end do
    770. 

  770. 

  771. !     upward top of atmosphere
    772. 

  772.       do i = its, ite
    773. 

  773.         if (cosz(i) .le. thresh) then
    774. 

  774.           RSWTOA(i,j) = 0.
    775. 

  775.         else
    776. 

  776.           RSWTOA(i,j) = flx(i,kts) - flxd(i,kts) * SOLCON * cosz(i)
    777. 

  777.         endif
    778. 

  778.       end do
    779. 

  779. !
    780. 

  780. ! ... Absorbed part in surface energy budget
    781. 

  781. !
    782. 

  782.       do i = its, ite
    783. 

  783.         if (cosz(i) .le. thresh) then
    784. 

  784.           GSW(i,j) = 0.
    785. 

  785.         else
    786. 

  786.           GSW(i,j) = (1. - rsuvbm(i)) * flxd(i,kte+1) * SOLCON * cosz(i)
    787. 

  787.         endif
    788. 

  788.       end do
    789. 

  789. 

  790.       DO K=kts,kte          
    791. 

  791.          NK=kme-1-K+kms
    792. 

  792.          DO I=its,ite
    793. 

  793. ! FIX FROM GODDARD FOR NEGATIVE VALUES
    794. 

  794.             TTEN2D(I,NK)=MAX(TTEN2D(I,NK),0.)
    795. 

  795.             RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+TTEN2D(I,NK)/pi3D(I,K,J)
    796. 

  796.          ENDDO
    797. 

  797.       ENDDO
    798. 

  798. !
    799. 

  799.    ENDDO j_loop                                          
    800. 

  800. 

  801.    END SUBROUTINE GSFCSWRAD
    802. 

  802. 

  803. !*********************   Version Solar-6 (May 8, 1997)  *****************
    804. 

  804. 

  805.       subroutine sorad (m,n,ndim,np,pl,ta,wa,oa,                        &
    806. 

  806.                         overcast,cldwater,cwc,taucld,reff,fcld,ict,icb, &
    807. 

  807.                         taual,ssaal,asyal,                              &
    808. 

  808.                         cosz,rsuvbm,rsuvdf,rsirbm,rsirdf,               &
    809. 

  809.                         flx,flxd)
    810. 

  810. 

  811. !************************************************************************
    812. 

  812. !
    813. 

  813. !                        Version Solar-6 (May 8, 1997)
    814. 

  814. !
    815. 

  815. !  New feature of this version is:
    816. 

  816. !   (1) An option is added for scaling the cloud optical thickness. If
    817. 

  817. !       the fractional cloud cover, fcld, in an atmospheric model is alway 
    818. 

  818. !       either 1 or 0 (i.e. partly cloudy sky is not allowed), it does
    819. 

  819. !       not require the scaling of cloud optical thickness, and the
    820. 

  820. !       option "overcast" can be set to .true.  Computation is faster
    821. 

  821. !       with this option than with overcast=.false.
    822. 

  822. !
    823. 

  823. !**********************************************************************
    824. 

  824. !
    825. 

  825. !                        Version Solar-5 (April 1997)
    826. 

  826. !
    827. 

  827. !  New features of this version are:
    828. 

  828. !   (1) Cloud optical properties can be computed from cloud water/ice
    829. 

  829. !       amount and the effective particle size.
    830. 

  830. !   (2) Aerosol optical properties are functions of height and band.
    831. 

  831. !   (3) A maximum-random cloud overlapping approximation is applied.
    832. 

  832. !
    833. 

  833. !*********************************************************************
    834. 

  834. !  
    835. 

  835. ! This routine computes solar fluxes due to the absoption by water
    836. 

  836. !  vapor, ozone, co2, o2, clouds, and aerosols and due to the
    837. 

  837. !  scattering by clouds, aerosols, and gases.
    838. 

  838. !
    839. 

  839. ! The solar spectrum is divided into one UV+visible band and three IR
    840. 

  840. !  bands separated by the wavelength 0.7 micron.  The UV+visible band
    841. 

  841. !  is further divided into eight sub-bands.
    842. 

  842. !
    843. 

  843. ! This is a vectorized code. It computes fluxes simultaneously for
    844. 

  844. !  (m x n) soundings, which is a subset of (m x ndim) soundings.
    845. 

  845. !  In a global climate model, m and ndim correspond to the numbers of
    846. 

  846. !  grid boxes in the zonal and meridional directions, respectively.
    847. 

  847. !
    848. 

  848. ! Ice and liquid cloud particles are allowed to co-exist in a layer. 
    849. 

  849. !
    850. 

  850. ! There is an option of providing either cloud ice/water mixing ratio 
    851. 

  851. !  (cwc) or thickness (taucld).  If the former is provided, set
    852. 

  852. !  cldwater=.true., and taucld will be computed from cwc and reff as a
    853. 

  853. !  function of spectra band. Otherwise, set cldwater=.false., and
    854. 

  854. !  specify taucld, independent of spectral band.
    855. 

  855. !
    856. 

  856. ! If no information is available for reff, a default value of
    857. 

  857. !  10 micron for liquid water and 75 micron for ice can be used.
    858. 

  858. !  For a clear layer, reff can be set to any values except zero.
    859. 

  859. !
    860. 

  860. ! The maximum-random assumption is applied for treating cloud
    861. 

  861. !  overlapping.
    862. 

  862. 

  863. ! Clouds are grouped into high, middle, and low clouds separated by
    864. 

  864. !  the level indices ict and icb.  For detail, see subroutine cldscale.
    865. 

  865. !
    866. 

  866. ! In a high spatial-resolution atmospheric model, fractional cloud cover
    867. 

  867. !  might be computed to be either 0 or 1.  In such a case, scaling of the
    868. 

  868. !  cloud optical thickness is not necessary, and the computation can be
    869. 

  869. !  made faster by setting overcast=.true.  The option overcast=.false.
    870. 

  870. !  can be applied to any values of the fractional cloud cover, but the
    871. 

  871. !  computation is slower.
    872. 

  872. !
    873. 

  873. ! Aerosol optical thickness, single-scattering albaedo, and asymmtry
    874. 

  874. !  factor can be specified as functions of height and spectral band.
    875. 

  875. !
    876. 

  876. !----- Input parameters:                           
    877. 

  877. !                                                   units      size
    878. 

  878. !  number of soundings in zonal direction (m)       n/d        1
    879. 

  879. !  number of soundings in meridional direction (n)  n/d        1
    880. 

  880. !  maximum number of soundings in                   n/d        1
    881. 

  881. !         meridional direction (ndim>=n)
    882. 

  882. !  number of atmospheric layers (np)                n/d        1
    883. 

  883. !  level pressure (pl)                              mb     m*ndim*(np+1)
    884. 

  884. !  layer temperature (ta)                           k        m*ndim*np
    885. 

  885. !  layer specific humidity (wa)                     gm/gm    m*ndim*np
    886. 

  886. !  layer ozone concentration (oa)                   gm/gm    m*ndim*np
    887. 

  887. !  co2 mixing ratio by volumn (co2)                 pppv       1
    888. 

  888. !  option for scaling cloud optical thickness       n/d        1
    889. 

  889. !        overcast="true" if scaling is NOT required
    890. 

  890. !        overcast="fasle" if scaling is required
    891. 

  891. !  option for cloud optical thickness               n/d        1
    892. 

  892. !        cldwater="true" if cwc is provided
    893. 

  893. !        cldwater="false" if taucld is provided
    894. 

  894. !  cloud water mixing ratio (cwc)                  gm/gm     m*ndim*np*2
    895. 

  895. !        index 1 for ice particles
    896. 

  896. !        index 2 for liquid drops
    897. 

  897. !  cloud optical thickness (taucld)                 n/d      m*ndim*np*2
    898. 

  898. !        index 1 for ice particles
    899. 

  899. !        index 2 for liquid drops
    900. 

  900. !  effective cloud-particle size (reff)          micrometer m*ndim*np*2
    901. 

  901. !        index 1 for ice particles
    902. 

  902. !        index 2 for liquid drops
    903. 

  903. !  cloud amount (fcld)                            fraction   m*ndim*np
    904. 

  904. !  level index separating high and middle           n/d        1
    905. 

  905. !        clouds (ict)
    906. 

  906. !  level index separating middle and low            n/d        1
    907. 

  907. !          clouds (icb)
    908. 

  908. !  aerosol optical thickness (taual)                n/d    m*ndim*np*11
    909. 

  909. !  aerosol single-scattering albedo (ssaal)         n/d    m*ndim*np*11
    910. 

  910. !  aerosol asymmetry factor (asyal)                 n/d    m*ndim*np*11
    911. 

  911. !        in the uv region :
    912. 

  912. !           index  1 for the 0.175-0.225 micron band
    913. 

  913. !           index  2 for the 0.225-0.245; 0.260-0.280 micron band
    914. 

  914. !           index  3 for the 0.245-0.260 micron band
    915. 

  915. !           index  4 for the 0.280-0.295 micron band
    916. 

  916. !           index  5 for the 0.295-0.310 micron band
    917. 

  917. !           index  6 for the 0.310-0.320 micron band
    918. 

  918. !           index  7 for the 0.325-0.400 micron band
    919. 

  919. !        in the par region :
    920. 

  920. !           index  8 for the 0.400-0.700 micron band
    921. 

  921. !        in the infrared region :
    922. 

  922. !           index  9 for the 0.700-1.220 micron band
    923. 

  923. !           index 10 for the 1.220-2.270 micron band
    924. 

  924. !           index 11 for the 2.270-10.00 micron band
    925. 

  925. !   cosine of solar zenith angle (cosz)              n/d      m*ndim
    926. 

  926. !   uv+visible sfc albedo for beam radiation
    927. 

  927. !        for wavelengths<0.7 micron (rsuvbm)    fraction   m*ndim
    928. 

  928. !   uv+visible sfc albedo for diffuse radiation
    929. 

  929. !        for wavelengths<0.7 micron (rsuvdf)    fraction   m*ndim
    930. 

  930. !   ir sfc albedo for beam radiation
    931. 

  931. !        for wavelengths>0.7 micron  (rsirbm)   fraction   m*ndim
    932. 

  932. !   ir sfc albedo for diffuse radiation (rsirdf)   fraction   m*ndim
    933. 

  933. !
    934. 

  934. !----- Output parameters
    935. 

  935. !
    936. 

  936. !   all-sky flux (downward minus upward) (flx)    fraction m*ndim*(np+1)
    937. 

  937. !   clear-sky flux (downward minus upward) (flc)  fraction m*ndim*(np+1)
    938. 

  938. !   all-sky direct downward uv (0.175-0.4 micron)
    939. 

  939. !                flux at the surface (fdiruv)      fraction   m*ndim
    940. 

  940. !   all-sky diffuse downward uv flux at
    941. 

  941. !                the surface (fdifuv)              fraction   m*ndim
    942. 

  942. !   all-sky direct downward par (0.4-0.7 micron)
    943. 

  943. !                flux at the surface (fdirpar)     fraction   m*ndim
    944. 

  944. !   all-sky diffuse downward par flux at
    945. 

  945. !                the surface (fdifpar)             fraction   m*ndim
    946. 

  946. !   all-sky direct downward ir (0.7-10 micron)
    947. 

  947. !                flux at the surface (fdirir)      fraction   m*ndim
    948. 

  948. !   all-sky diffuse downward ir flux at
    949. 

  949. !                the surface (fdifir)              fraction   m*ndim
    950. 

  950. !
    951. 

  951. !----- Notes:
    952. 

  952. !
    953. 

  953. !    (1) The unit of "flux" is fraction of the incoming solar radiation
    954. 

  954. !        at the top of the atmosphere.  Therefore, fluxes should
    955. 

  955. !        be equal to "flux" multiplied by the extra-terrestrial solar
    956. 

  956. !        flux and the cosine of solar zenith angle.
    957. 

  957. !    (2) pl(i,j,1) is the pressure at the top of the model, and
    958. 

  958. !        pl(i,j,np+1) is the surface pressure.
    959. 

  959. !    (3) the pressure levels ict and icb correspond approximately
    960. 

  960. !        to 400 and 700 mb.
    961. 

  961. !    (4) if overcast='true', the clear-sky flux, flc, is not computed.
    962. 

  962. !        
    963. 

  963. !**************************************************************************
    964. 

  964.       implicit none
    965. 

  965. !**************************************************************************
    966. 

  966. 

  967. !-----input parameters
    968. 

  968. 

  969.       integer m,n,ndim,np
    970. 

  970.       integer ict(m,ndim),icb(m,ndim)
    971. 

  971.       real pl(m,ndim,np+1),ta(m,ndim,np),wa(m,ndim,np),oa(m,ndim,np)
    972. 

  972.       real cwc(m,ndim,np,2),taucld(m,ndim,np,2),reff(m,ndim,np,2), &
    973. 

  973.              fcld(m,ndim,np)
    974. 

  974.       real taual(m,ndim,np,11),ssaal(m,ndim,np,11),asyal(m,ndim,np,11)
    975. 

  975.       real cosz(m,ndim),rsuvbm(m,ndim),rsuvdf(m,ndim), &
    976. 

  976.              rsirbm(m,ndim),rsirdf(m,ndim)           
    977. 

  977.       logical overcast,cldwater
    978. 

  978. 

  979. !-----output parameters
    980. 

  980. 

  981.       real flx(m,ndim,np+1),flc(m,ndim,np+1)
    982. 

  982.       real flxu(m,ndim,np+1),flxd(m,ndim,np+1)
    983. 

  983.       real fdiruv (m,ndim),fdifuv (m,ndim)
    984. 

  984.       real fdirpar(m,ndim),fdifpar(m,ndim)
    985. 

  985.       real fdirir (m,ndim),fdifir (m,ndim)
    986. 

  986. 

  987. !-----temporary array
    988. 

  988.  
    989. 

  989.       integer i,j,k
    990. 

  990.       real cwp(m,n,np,2)
    991. 

  991.       real dp(m,n,np),wh(m,n,np),oh(m,n,np),scal(m,n,np)
    992. 

  992.       real swh(m,n,np+1),so2(m,n,np+1),df(m,n,np+1)
    993. 

  993.       real sdf(m,n),sclr(m,n),csm(m,n),x
    994. 

  994.  
    995. 

  995.       do j= 1, n 
    996. 

  996.        do i= 1, m 
    997. 

  997.           if (pl(i,j,1) .eq. 0.0) then
    998. 

  998.               pl(i,j,1)=1.0e-4
    999. 

  999.           endif
    1000. 

  1000.        enddo
    1001. 

  1001.       enddo
    1002. 

  1002. 

  1003.       do j= 1, n 
    1004. 

  1004.        do i= 1, m 
    1005. 

  1005. 

  1006.          swh(i,j,1)=0. 
    1007. 

  1007.          so2(i,j,1)=0. 
    1008. 

  1008. 

  1009. !-----csm is the effective secant of the solar zenith angle
    1010. 

  1010. !     see equation (12) of Lacis and Hansen (1974, JAS)    
    1011. 

  1011.  
    1012. 

  1012.          csm(i,j)=35./sqrt(1224.*cosz(i,j)*cosz(i,j)+1.)
    1013. 

  1013. 

  1014.        enddo 
    1015. 

  1015.       enddo
    1016. 

  1016. 

  1017.       do k= 1, np
    1018. 

  1018.        do j= 1, n
    1019. 

  1019.          do i= 1, m
    1020. 

  1020. 

  1021. !-----compute layer thickness and pressure-scaling function. 
    1022. 

  1022. !     indices for the surface level and surface layer
    1023. 

  1023. !     are np+1 and np, respectively.
    1024. 

  1024.  
    1025. 

  1025.           dp(i,j,k)=pl(i,j,k+1)-pl(i,j,k)
    1026. 

  1026.           scal(i,j,k)=dp(i,j,k)*(.5*(pl(i,j,k)+pl(i,j,k+1))/300.)**.8
    1027. 

  1027.  
    1028. 

  1028. !-----compute scaled water vapor amount, unit is g/cm**2
    1029. 

  1029. !     note: the sign prior to the constant 0.00135 was incorrectly 
    1030. 

  1030. !           set to negative in the previous version
    1031. 

  1031. 

  1032.           wh(i,j,k)=1.02*wa(i,j,k)*scal(i,j,k)* &
    1033. 

  1033.                     (1.+0.00135*(ta(i,j,k)-240.)) +1.e-11
    1034. 

  1034.           swh(i,j,k+1)=swh(i,j,k)+wh(i,j,k)
    1035. 

  1035. 

  1036. !-----compute ozone amount, unit is (cm-atm)stp
    1037. 

  1037. !     the number 466.7 is a conversion factor from g/cm**2 to (cm-atm)stp
    1038. 

  1038.  
    1039. 

  1039.           oh(i,j,k)=1.02*oa(i,j,k)*dp(i,j,k)*466.7 +1.e-11
    1040. 

  1040. 

  1041. !-----compute layer cloud water amount (gm/m**2)
    1042. 

  1042. !     the index is 1 for ice crystals and 2 for liquid drops
    1043. 

  1043. 

  1044.           cwp(i,j,k,1)=1.02*10000.*cwc(i,j,k,1)*dp(i,j,k)
    1045. 

  1045.           cwp(i,j,k,2)=1.02*10000.*cwc(i,j,k,2)*dp(i,j,k)
    1046. 

  1046. 

  1047.         enddo
    1048. 

  1048.        enddo
    1049. 

  1049.       enddo
    1050. 

  1050. 

  1051. !-----initialize fluxes for all-sky (flx), clear-sky (flc), and
    1052. 

  1052. !     flux reduction (df)
    1053. 

  1053. 

  1054.       do k=1, np+1
    1055. 

  1055.        do j=1, n
    1056. 

  1056.         do i=1, m
    1057. 

  1057.           flx(i,j,k)=0.
    1058. 

  1058.           flc(i,j,k)=0.
    1059. 

  1059.           flxu(i,j,k)=0.
    1060. 

  1060.           flxd(i,j,k)=0.
    1061. 

  1061.           df(i,j,k)=0.
    1062. 

  1062.         enddo
    1063. 

  1063.        enddo
    1064. 

  1064.       enddo
    1065. 

  1065. 

  1066. !-----compute solar uv and par fluxes
    1067. 

  1067. 

  1068.       call soluv (m,n,ndim,np,oh,dp,overcast,cldwater,  &
    1069. 

  1069.                   cwp,taucld,reff,ict,icb,fcld,cosz,    &
    1070. 

  1070.                   taual,ssaal,asyal,csm,rsuvbm,rsuvdf,  &
    1071. 

  1071.                   flx,flc,flxu,flxd,fdiruv,fdifuv,fdirpar,fdifpar)
    1072. 

  1072. 

  1073. !-----compute and update solar ir fluxes
    1074. 

  1074. 

  1075.       call solir (m,n,ndim,np,wh,overcast,cldwater,     &
    1076. 

  1076.                   cwp,taucld,reff,ict,icb,fcld,cosz,    &
    1077. 

  1077.                   taual,ssaal,asyal,csm,rsirbm,rsirdf,  &
    1078. 

  1078.                   flx,flc,flxu,flxd,fdirir,fdifir)
    1079. 

  1079. 

  1080. !-----compute scaled o2 amount, unit is (cm-atm)stp.
    1081. 

  1081. 

  1082.       do k= 1, np
    1083. 

  1083.        do j= 1, n
    1084. 

  1084.         do i= 1, m
    1085. 

  1085.           so2(i,j,k+1)=so2(i,j,k)+165.22*scal(i,j,k)
    1086. 

  1086.         enddo
    1087. 

  1087.        enddo
    1088. 

  1088.       enddo
    1089. 

  1089. 

  1090. !-----compute flux reduction due to oxygen following
    1091. 

  1091. !      chou (J. climate, 1990). The fraction 0.0287 is the
    1092. 

  1092. !      extraterrestrial solar flux in the o2 bands.
    1093. 

  1093. 

  1094.        do k= 2, np+1
    1095. 

  1095.         do j= 1, n
    1096. 

  1096.          do i= 1, m
    1097. 

  1097.            x=so2(i,j,k)*csm(i,j)
    1098. 

  1098.            df(i,j,k)=df(i,j,k)+0.0287*(1.-exp(-0.00027*sqrt(x)))
    1099. 

  1099.          enddo
    1100. 

  1100.         enddo
    1101. 

  1101.        enddo          
    1102. 

  1102. 

  1103. !-----compute scaled co2 amounts. unit is (cm-atm)stp.
    1104. 

  1104. 

  1105.       do k= 1, np
    1106. 

  1106.        do j= 1, n
    1107. 

  1107.         do i= 1, m
    1108. 

  1108.          so2(i,j,k+1)=so2(i,j,k)+co2*789.*scal(i,j,k)+1.e-11
    1109. 

  1109.         enddo
    1110. 

  1110.        enddo
    1111. 

  1111.       enddo
    1112. 

  1112. 

  1113. !-----compute and update flux reduction due to co2 following
    1114. 

  1114. !     chou (J. Climate, 1990)
    1115. 

  1115. 

  1116.       call flxco2(m,n,np,so2,swh,csm,df)
    1117. 

  1117. 

  1118. !-----adjust for the effect of o2 cnd co2 on clear-sky fluxes.
    1119. 

  1119. 

  1120.       do k= 2, np+1
    1121. 

  1121.        do j= 1, n
    1122. 

  1122.         do i= 1, m
    1123. 

  1123.           flc(i,j,k)=flc(i,j,k)-df(i,j,k)
    1124. 

  1124.         enddo
    1125. 

  1125.        enddo
    1126. 

  1126.       enddo
    1127. 

  1127. 

  1128. !-----adjust for the all-sky fluxes due to o2 and co2.  It is
    1129. 

  1129. !     assumed that o2 and co2 have no effects on solar radiation
    1130. 

  1130. !     below clouds.
    1131. 

  1131. 

  1132.       do j=1,n
    1133. 

  1133.        do i=1,m
    1134. 

  1134.         sdf(i,j)=0.0
    1135. 

  1135.         sclr(i,j)=1.0
    1136. 

  1136.        enddo
    1137. 

  1137.       enddo
    1138. 

  1138. 

  1139.       do k=1,np
    1140. 

  1140.        do j=1,n
    1141. 

  1141.         do i=1,m
    1142. 

  1142. 

  1143. !-----sclr is the fraction of clear sky.
    1144. 

  1144. !     sdf is the flux reduction below clouds.
    1145. 

  1145. 

  1146.          if(fcld(i,j,k).gt.0.01) then
    1147. 

  1147.           sdf(i,j)=sdf(i,j)+df(i,j,k)*sclr(i,j)*fcld(i,j,k)
    1148. 

  1148.           sclr(i,j)=sclr(i,j)*(1.-fcld(i,j,k))
    1149. 

  1149.          endif
    1150. 

  1150.           flx(i,j,k+1)=flx(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j)
    1151. 

  1151.           flxu(i,j,k+1)=flxu(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j)
    1152. 

  1152.           flxd(i,j,k+1)=flxd(i,j,k+1)-sdf(i,j)-df(i,j,k+1)*sclr(i,j) ! SG: same as flux????
    1153. 

  1153. 

  1154.         enddo
    1155. 

  1155.        enddo
    1156. 

  1156.       enddo
    1157. 

  1157. 

  1158. !-----adjustment for the direct downward ir flux.
    1159. 

  1159. 

  1160.       do j= 1, n
    1161. 

  1161.        do i= 1, m
    1162. 

  1162.         flc(i,j,np+1)=flc(i,j,np+1)+df(i,j,np+1)*rsirbm(i,j)
    1163. 

  1163.         flx(i,j,np+1)=flx(i,j,np+1)+(sdf(i,j)+ &
    1164. 

  1164.                          df(i,j,np+1)*sclr(i,j))*rsirbm(i,j)
    1165. 

  1165.         flxu(i,j,np+1)=flxu(i,j,np+1)+(sdf(i,j)+ &
    1166. 

  1166.                          df(i,j,np+1)*sclr(i,j))*rsirbm(i,j)
    1167. 

  1167.         flxd(i,j,np+1)=flxd(i,j,np+1)+(sdf(i,j)+ &
    1168. 

  1168.                          df(i,j,np+1)*sclr(i,j))*rsirbm(i,j)
    1169. 

  1169.         fdirir(i,j)=fdirir(i,j)-(sdf(i,j)+df(i,j,np+1)*sclr(i,j))
    1170. 

  1170.        enddo
    1171. 

  1171.       enddo
    1172. 

  1172. 

  1173.       end subroutine sorad 
    1174. 

  1174. 

  1175. !************************************************************************
    1176. 

  1176. 

  1177.       subroutine soluv (m,n,ndim,np,oh,dp,overcast,cldwater,            &
    1178. 

  1178.                 cwp,taucld,reff,ict,icb,fcld,cosz,                      &
    1179. 

  1179.                 taual,ssaal,asyal,csm,rsuvbm,rsuvdf,                    &
    1180. 

  1180.                 flx,flc,flxu,flxd,fdiruv,fdifuv,fdirpar,fdifpar)
    1181. 

  1181. 

  1182. !************************************************************************
    1183. 

  1183. !  compute solar fluxes in the uv+par region. the spectrum is
    1184. 

  1184. !  grouped into 8 bands:
    1185. 

  1185. !  
    1186. 

  1186. !              Band     Micrometer
    1187. 

  1187. !
    1188. 

  1188. !       UV-C    1.     .175 - .225
    1189. 

  1189. !               2.     .225 - .245
    1190. 

  1190. !                      .260 - .280
    1191. 

  1191. !               3.     .245 - .260
    1192. 

  1192. !
    1193. 

  1193. !       UV-B    4.     .280 - .295
    1194. 

  1194. !               5.     .295 - .310
    1195. 

  1195. !               6.     .310 - .320
    1196. 

  1196. !      
    1197. 

  1197. !       UV-A    7.     .320 - .400
    1198. 

  1198. !      
    1199. 

  1199. !       PAR     8.     .400 - .700
    1200. 

  1200. !
    1201. 

  1201. !----- Input parameters:                            units      size
    1202. 

  1202. !
    1203. 

  1203. !  number of soundings in zonal direction (m)       n/d        1
    1204. 

  1204. !  number of soundings in meridional direction (n)  n/d        1
    1205. 

  1205. !  maximum number of soundings in                   n/d        1
    1206. 

  1206. !        meridional direction (ndim)
    1207. 

  1207. !  number of atmospheric layers (np)                n/d        1
    1208. 

  1208. !  layer ozone content (oh)                      (cm-atm)stp m*n*np
    1209. 

  1209. !  layer pressure thickness (dp)                    mb       m*n*np
    1210. 

  1210. !  option for scaling cloud optical thickness       n/d        1
    1211. 

  1211. !        overcast="true" if scaling is NOT required
    1212. 

  1212. !        overcast="fasle" if scaling is required
    1213. 

  1213. !  input option for cloud optical thickness         n/d        1
    1214. 

  1214. !        cldwater="true" if taucld is provided
    1215. 

  1215. !        cldwater="false" if cwp is provided
    1216. 

  1216. !  cloud water amount (cwp)                        gm/m**2   m*n*np*2
    1217. 

  1217. !        index 1 for ice particles
    1218. 

  1218. !        index 2 for liquid drops
    1219. 

  1219. !  cloud optical thickness (taucld)                 n/d     m*ndim*np*2
    1220. 

  1220. !       index 1 for ice paticles
    1221. 

  1221. !       index 2 for liquid particles
    1222. 

  1222. !  effective cloud-particle size (reff)          micrometer m*ndim*np*2
    1223. 

  1223. !       index 1 for ice paticles
    1224. 

  1224. !       index 2 for liquid particles
    1225. 

  1225. !  level indiex separating high and                 n/d      m*n
    1226. 

  1226. !       middle clouds (ict)
    1227. 

  1227. !  level indiex separating middle and               n/d      m*n
    1228. 

  1228. !       low clouds (icb)
    1229. 

  1229. !  cloud amount (fcld)                            fraction   m*ndim*np
    1230. 

  1230. !  cosine of solar zenith angle (cosz)              n/d      m*ndim
    1231. 

  1231. !  aerosol optical thickness (taual)                n/d    m*ndim*np*11
    1232. 

  1232. !  aerosol single-scattering albedo (ssaal)         n/d    m*ndim*np*11
    1233. 

  1233. !  aerosol asymmetry factor (asyal)                 n/d    m*ndim*np*11
    1234. 

  1234. !  cosecant of the solar zenith angle (csm)         n/d      m*n
    1235. 

  1235. !  uv+par surface albedo for beam                 fraction   m*ndim
    1236. 

  1236. !       radiation (rsuvbm)
    1237. 

  1237. !  uv+par surface albedo for diffuse              fraction   m*ndim
    1238. 

  1238. !       radiation (rsuvdf)
    1239. 

  1239. !
    1240. 

  1240. !---- temporary array
    1241. 

  1241. !
    1242. 

  1242. !  scaled cloud optical thickness                   n/d      m*n*np
    1243. 

  1243. !       for beam radiation (tauclb)
    1244. 

  1244. !  scaled cloud optical thickness                   n/d      m*n*np
    1245. 

  1245. !       for diffuse radiation  (tauclf)     
    1246. 

  1246. !
    1247. 

  1247. !----- output (updated) parameters:
    1248. 

  1248. !
    1249. 

  1249. !  all-sky net downward flux (flx)               fraction  m*ndim*(np+1)
    1250. 

  1250. !  cl…
    1251.

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