wrfv2_fire/phys/module_ra_cam.F

   1 MODULE module_ra_cam
   2   use module_ra_cam_support
   3   implicit none
   4
   5
   6 contains
   7 subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
   8                      dolw,dosw,                                    &
   9                      SWUPT,SWUPTC,SWDNT,SWDNTC,                    &
  10                      LWUPT,LWUPTC,LWDNT,LWDNTC,                    &
  11                      SWUPB,SWUPBC,SWDNB,SWDNBC,                    &
  12                      LWUPB,LWUPBC,LWDNB,LWDNBC,                    &
  13                      swcf,lwcf,olr,cemiss,taucldc,taucldi,coszr,   &
  14                      GSW,GLW,XLAT,XLONG,                           &
  15                      ALBEDO,t_phy,TSK,EMISS,                       &
  16                      QV3D,QC3D,QR3D,QI3D,QS3D,QG3D,                &
  17                      F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,                &
  18                      f_ice_phy,f_rain_phy,                         &
  19                      p_phy,p8w,z,pi_phy,rho_phy,dz8w,               &
  20                      CLDFRA,XLAND,XICE,SNOW,                        &
  21                      ozmixm,pin0,levsiz,num_months,                 &
  22                      m_psp,m_psn,aerosolcp,aerosolcn,m_hybi0,       &
  23                      cam_abs_dim1, cam_abs_dim2,                    &
  24                      paerlev,naer_c,                                &
  25                      GMT,JULDAY,JULIAN,DT,XTIME,DECLIN,SOLCON,         &
  26                      RADT,DEGRAD,n_cldadv,                                  &
  27                      abstot_3d, absnxt_3d, emstot_3d,              &
  28                      doabsems,                                     &
  29                      ids,ide, jds,jde, kds,kde,                    &
  30                      ims,ime, jms,jme, kms,kme,                    &
  31                      its,ite, jts,jte, kts,kte                     )
  32
  33    USE module_wrf_error
  34
  35 !------------------------------------------------------------------
  36    IMPLICIT NONE
  37 !------------------------------------------------------------------
  38
  39    INTEGER,    INTENT(IN   ) ::        ids,ide, jds,jde, kds,kde, &
  40                                        ims,ime, jms,jme, kms,kme, &
  41                                        its,ite, jts,jte, kts,kte
  42    LOGICAL,    INTENT(IN   ) ::        F_QV,F_QC,F_QR,F_QI,F_QS,F_QG
  43    LOGICAL,    INTENT(INout) ::        doabsems
  44    LOGICAL,    INTENT(IN   ) ::        dolw,dosw
  45
  46    INTEGER,    INTENT(IN  )  ::        n_cldadv
  47    INTEGER,    INTENT(IN  )  ::        JULDAY
  48    REAL,       INTENT(IN  )  ::        JULIAN
  49    REAL,       INTENT(IN  )  ::        DT
  50    INTEGER,      INTENT(IN   )    ::   levsiz, num_months
  51    INTEGER,      INTENT(IN   )    ::   paerlev, naer_c
  52    INTEGER,      INTENT(IN   )    ::   cam_abs_dim1, cam_abs_dim2
  53
  54
  55    REAL, INTENT(IN    )      ::        RADT,DEGRAD,             &
  56                                        XTIME,DECLIN,SOLCON,GMT
  57 !
  58 !
  59    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
  60          INTENT(IN    ) ::                                   P_PHY, &
  61                                                            P8W, &
  62                                                              Z, &
  63                                                             pi_PHY, &
  64                                                            rho_PHY, &
  65                                                               dz8w, &
  66                                                              T_PHY, &
  67                                                             QV3D, &
  68                                                             QC3D, &
  69                                                             QR3D, &
  70                                                             QI3D, &
  71                                                             QS3D, &
  72                                                             QG3D, &
  73                                                         CLDFRA
  74
  75    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
  76          INTENT(INOUT)  ::                              RTHRATENLW, &
  77                                                         RTHRATENSW
  78 !
  79    REAL, DIMENSION( ims:ime, jms:jme ),                           &
  80          INTENT(IN   )  ::                                  XLAT, &
  81                                                            XLONG, &
  82                                                            XLAND, &
  83                                                            XICE, &
  84                                                            SNOW, &
  85                                                            EMISS, &
  86                                                              TSK, &
  87                                                              ALBEDO
  88
  89    REAL,  DIMENSION( ims:ime, levsiz, jms:jme, num_months ),      &
  90           INTENT(IN   ) ::                                  OZMIXM
  91
  92    REAL,  DIMENSION(levsiz), INTENT(IN )  ::                   PIN0
  93
  94    REAL,  DIMENSION(ims:ime,jms:jme), INTENT(IN )  ::      m_psp,m_psn
  95    REAL,  DIMENSION(paerlev), intent(in)             ::      m_hybi0
  96    REAL,  DIMENSION( ims:ime, paerlev, jms:jme, naer_c ),      &
  97           INTENT(IN   ) ::                    aerosolcp, aerosolcn
  98
  99 !
 100    REAL, DIMENSION( ims:ime, jms:jme ),                           &
 101          INTENT(INOUT)  ::                                   GSW, GLW
 102
 103 ! saving arrays for doabsems reduction of radiation calcs
 104
 105    REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2 , jms:jme ),           &
 106          INTENT(INOUT)  ::                                  abstot_3d
 107    REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim1 , jms:jme ),           &
 108          INTENT(INOUT)  ::                                  absnxt_3d
 109    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),           &
 110          INTENT(INOUT)  ::                                  emstot_3d
 111
 112
 113 ! Added outputs of total and clearsky fluxes etc
 114 ! Note that k=1 refers to the half level below the model lowest level (Sfc)
 115 !           k=kme refers to the half level above the model highest level (TOA)
 116 !
 117 !   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                &
 118 !         INTENT(INOUT)  ::                                  swup, &
 119 !                                                       swupclear, &
 120 !                                                            swdn, &
 121 !                                                       swdnclear, &
 122 !                                                            lwup, &
 123 !                                                       lwupclear, &
 124 !                                                            lwdn, &
 125 !                                                       lwdnclear
 126
 127    REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
 128                     SWUPT,SWUPTC,SWDNT,SWDNTC,                    &
 129                     LWUPT,LWUPTC,LWDNT,LWDNTC,                    &
 130                     SWUPB,SWUPBC,SWDNB,SWDNBC,                    &
 131                     LWUPB,LWUPBC,LWDNB,LWDNBC
 132
 133    REAL, DIMENSION( ims:ime, jms:jme ),                           &
 134          INTENT(INOUT)  ::                                  swcf, &
 135                                                             lwcf, &
 136                                                              olr, &
 137                                                             coszr
 138    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
 139          INTENT(OUT   )  ::                               cemiss, &        ! cloud emissivity for isccp
 140                                                          taucldc, &        ! cloud water optical depth for isccp
 141                                                          taucldi           ! cloud ice optical depth for isccp
 142 !
 143 !
 144    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                     &
 145          INTENT(IN   ) ::                                            &
 146                                                           F_ICE_PHY, &
 147                                                          F_RAIN_PHY
 148
 149
 150 ! LOCAL VARIABLES
 151
 152    INTEGER :: lchnk, ncol, pcols, pver, pverp, pverr, pverrp
 153    INTEGER :: pcnst, pnats, ppcnst, i, j, k, ii, kk, kk1, m, n
 154    integer :: begchunk, endchunk
 155
 156    REAL :: XT24, TLOCTM, HRANG, XXLAT, oldXT24
 157
 158    real(r8), DIMENSION( 1:ite-its+1 ) :: coszrs, landfrac, landm, snowh, icefrac, lwups
 159    real(r8), DIMENSION( 1:ite-its+1 ) :: asdir, asdif, aldir, aldif, ps
 160    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1 ) :: cld, pmid, lnpmid, pdel, zm, t
 161    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+2 ) ::  pint, lnpint
 162    real(r8), DIMENSION( its:ite , kts:kte+1 ) :: phyd
 163    real(r8), DIMENSION( its:ite , kts:kte   ) :: phydmid
 164    real(r8), DIMENSION( its:ite ) :: fp
 165    real(r8), DIMENSION( 1:ite-its+1, 1:kte-kts+1, n_cldadv) :: q
 166 !   real(r8), DIMENSION( 1:kte-kts+1 ) :: hypm       ! reference pressures at midpoints
 167 !   real(r8), DIMENSION( 1:kte-kts+2 ) :: hypi       ! reference pressures at interfaces
 168     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: cicewp      ! in-cloud cloud ice water path
 169     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: cliqwp      ! in-cloud cloud liquid water path
 170     real(r8), dimension(  1:ite-its+1, 0:kte-kts+1 ) :: tauxcl      ! cloud water optical depth
 171     real(r8), dimension(  1:ite-its+1, 0:kte-kts+1 ) :: tauxci      ! cloud ice optical depth
 172     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: emis        ! cloud emissivity
 173     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: rel         ! effective drop radius (microns)
 174     real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: rei         ! ice effective drop size (microns)
 175     real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 ) :: pmxrgn      ! Maximum values of pressure for each
 176     integer , dimension(  1:ite-its+1 ) :: nmxrgn               ! Number of maximally overlapped regions
 177
 178    real(r8), dimension(  1:ite-its+1 ) :: fsns          ! Surface absorbed solar flux
 179    real(r8), dimension(  1:ite-its+1 ) :: fsnt          ! Net column abs solar flux at model top
 180    real(r8), dimension(  1:ite-its+1 ) :: flns          ! Srf longwave cooling (up-down) flux
 181    real(r8), dimension(  1:ite-its+1 ) :: flnt          ! Net outgoing lw flux at model top
 182 ! Added outputs of total and clearsky fluxes etc
 183    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsup        ! Upward total sky solar
 184    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsupc       ! Upward clear sky solar
 185    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsdn        ! Downward total sky solar
 186    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fsdnc       ! Downward clear sky solar
 187    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: flup        ! Upward total sky longwave
 188    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: flupc       ! Upward clear sky longwave
 189    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fldn        ! Downward total sky longwave
 190    real(r8), dimension(  1:ite-its+1, 1:kte-kts+2 )  :: fldnc       ! Downward clear sky longwave
 191    real(r8), dimension(  1:ite-its+1 ) :: swcftoa                 ! Top of the atmosphere solar cloud forcing
 192    real(r8), dimension(  1:ite-its+1 ) :: lwcftoa                 ! Top of the atmosphere longwave cloud forcing
 193    real(r8), dimension(  1:ite-its+1 ) :: olrtoa                  ! Top of the atmosphere outgoing longwave
 194 !
 195    real(r8), dimension(  1:ite-its+1 ) :: sols          ! Downward solar rad onto surface (sw direct)
 196    real(r8), dimension(  1:ite-its+1 ) :: soll          ! Downward solar rad onto surface (lw direct)
 197    real(r8), dimension(  1:ite-its+1 ) :: solsd         ! Downward solar rad onto surface (sw diffuse)
 198    real(r8), dimension(  1:ite-its+1 ) :: solld         ! Downward solar rad onto surface (lw diffuse)
 199    real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: qrs      ! Solar heating rate
 200    real(r8), dimension(  1:ite-its+1 ) :: fsds          ! Flux Shortwave Downwelling Surface
 201    real(r8), dimension(  1:ite-its+1, 1:kte-kts+1 ) :: qrl      ! Longwave cooling rate
 202    real(r8), dimension(  1:ite-its+1 ) :: flwds          ! Surface down longwave flux
 203    real(r8), dimension(  1:ite-its+1, levsiz, num_months ) :: ozmixmj        ! monthly ozone mixing ratio
 204    real(r8), dimension(  1:ite-its+1, levsiz ) :: ozmix          ! ozone mixing ratio (time interpolated)
 205    real(r8), dimension(levsiz)         :: pin            ! ozone pressure level
 206    real(r8), dimension(1:ite-its+1)    :: m_psjp,m_psjn          ! MATCH surface pressure
 207    real(r8), dimension(  1:ite-its+1, paerlev, naer_c ) :: aerosoljp        ! monthly aerosol concentrations
 208    real(r8), dimension(  1:ite-its+1, paerlev, naer_c ) :: aerosoljn        ! monthly aerosol concentrations
 209    real(r8), dimension(paerlev)                           :: m_hybi
 210    real(r8), dimension(1:ite-its+1 )          :: clat           ! latitude in radians for columns
 211    real(r8), dimension(its:ite,kts:kte+1,kts:kte+1) :: abstot ! Total absorptivity
 212    real(r8), dimension(its:ite,kts:kte,4)           :: absnxt ! Total nearest layer absorptivity
 213    real(r8), dimension(its:ite,kts:kte+1)           :: emstot ! Total emissivity
 214    CHARACTER(LEN=256) :: msgstr
 215
 216 #if !defined(MAC_KLUDGE)
 217    lchnk = 1
 218    begchunk = ims
 219    endchunk = ime
 220    ncol = ite - its + 1
 221    pcols= ite - its + 1
 222    pver = kte - kts + 1
 223    pverp= pver + 1
 224    pverr = kte - kts + 1
 225    pverrp= pverr + 1
 226 ! number of advected constituents and non-advected constituents (including water vapor)
 227    ppcnst = n_cldadv
 228 ! number of non-advected constituents
 229    pnats = 0
 230    pcnst = ppcnst-pnats
 231
 232 ! check the # species defined for the input climatology and naer
 233
 234 !  if(naer_c.ne.naer) then
 235 !            WRITE( wrf_err_message , * ) 'naer_c ne naer ', naer_c, naer
 236    if(naer_c.ne.naer_all) then
 237              WRITE( wrf_err_message , * ) 'naer_c-1 ne naer_all ', naer_c, naer_all
 238              CALL wrf_error_fatal ( wrf_err_message )
 239    endif
 240 !
 241 !===================================================
 242 ! Radiation computations
 243 !===================================================
 244
 245       do k=1,levsiz
 246       pin(k)=pin0(k)
 247       enddo
 248
 249       do k=1,paerlev
 250       m_hybi(k)=m_hybi0(k)
 251       enddo
 252
 253 ! check for uninitialized arrays
 254       if(abstot_3d(its,kts,kts,jts) .eq. 0.0 .and. .not.doabsems .and. dolw)then
 255         CALL wrf_debug(0, 'camrad lw: CAUTION: re-calculating abstot, absnxt, emstot on restart')
 256         doabsems = .true.
 257       endif
 258
 259    do j =jts,jte
 260
 261 !
 262 ! Cosine solar zenith angle for current time step
 263 !
 264
 265 !  call zenith (calday, clat, clon, coszrs, ncol)
 266
 267       do i = its,ite
 268       ii = i - its + 1
 269       ! XT24 is the fractional part of simulation days plus half of RADT expressed in
 270       ! units of minutes
 271       ! JULIAN is in days
 272       ! RADT is in minutes
 273       XT24=MOD(XTIME+RADT*0.5,1440.)
 274       TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
 275       HRANG=15.*(TLOCTM-12.)*DEGRAD
 276       XXLAT=XLAT(I,J)*DEGRAD
 277       clat(ii)=xxlat
 278       coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
 279       enddo
 280
 281 ! moist variables
 282
 283       do k = kts,kte
 284       kk = kte - k + kts
 285       do i = its,ite
 286       ii = i - its + 1
 287       q(ii,kk,1) = max(1.e-10,qv3d(i,k,j))
 288      IF ( F_QI .and. F_QC .and. F_QS ) THEN
 289       q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j))
 290       q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)+qs3d(i,k,j))
 291      ELSE IF ( F_QC .and. F_QR ) THEN
 292 ! Warm rain or simple ice
 293       q(ii,kk,ixcldliq) = 0.
 294       q(ii,kk,ixcldice) = 0.
 295       if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j))
 296       if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j))
 297      ELSE IF ( F_QC .and. F_QS ) THEN
 298 ! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
 299       q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)*f_ice_phy(i,k,j))
 300       q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j)))
 301      ELSE
 302       q(ii,kk,ixcldliq) = 0.
 303       q(ii,kk,ixcldice) = 0.
 304      ENDIF
 305       cld(ii,kk) = CLDFRA(I,K,J)
 306       enddo
 307       enddo
 308
 309       do i = its,ite
 310       ii = i - its + 1
 311       landfrac(ii) = 2.-XLAND(I,J)
 312       landm(ii) = landfrac(ii)
 313       snowh(ii) = 0.001*SNOW(I,J)
 314       icefrac(ii) = XICE(I,J)
 315       enddo
 316
 317       do m=1,num_months-1
 318       do k=1,levsiz
 319       do i = its,ite
 320       ii = i - its + 1
 321       ozmixmj(ii,k,m) = ozmixm(i,k,j,m+1)
 322       enddo
 323       enddo
 324       enddo
 325
 326       do i = its,ite
 327       ii = i - its + 1
 328       m_psjp(ii) = m_psp(i,j)
 329       m_psjn(ii) = m_psn(i,j)
 330       enddo
 331
 332       do n=1,naer_c
 333       do k=1,paerlev
 334       do i = its,ite
 335       ii = i - its + 1
 336       aerosoljp(ii,k,n) = aerosolcp(i,k,j,n)
 337       aerosoljn(ii,k,n) = aerosolcn(i,k,j,n)
 338       enddo
 339       enddo
 340       enddo
 341
 342 !
 343 ! Complete radiation calculations
 344 !
 345       do i = its,ite
 346       ii = i - its + 1
 347       lwups(ii) = stebol*EMISS(I,J)*TSK(I,J)**4
 348       enddo
 349
 350 ! first guess
 351       do k = kts,kte+1
 352       do i = its,ite
 353       if(k.eq.kts)then
 354         phyd(i,k)=p8w(i,kts,j)
 355       else
 356         phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)
 357       endif
 358       enddo
 359       enddo
 360
 361 ! correction factor FP to match p8w(I,kts,J)-p8w(I,kte+1,J)
 362       do i = its,ite
 363         fp(i)=(p8w(I,kts,J)-p8w(I,kte+1,J))/(PHYD(i,KTS)-PHYD(i,KTE+1))
 364       enddo
 365
 366 ! final pass
 367       do k = kts+1,kte+1
 368       do i = its,ite
 369         phyd(i,k)=phyd(i,k-1) - gravmks*rho_phy(i,k-1,j)*dz8w(i,k-1,j)*fp(i)
 370         phydmid(i,k-1)=0.5*(phyd(i,k-1)+phyd(i,k))
 371       enddo
 372       enddo
 373
 374       do k = kts,kte+1
 375       kk = kte - k + kts + 1
 376       do i = its,ite
 377       ii = i - its + 1
 378       pint(ii,kk) = phyd(i,k)
 379       if(k.eq.kts)ps(ii)=pint(ii,kk)
 380       lnpint(ii,kk) = log(pint(ii,kk))
 381       enddo
 382       enddo
 383
 384       if(.not.doabsems .and. dolw)then
 385 !      do kk = kts,kte+1
 386       do kk = 1,cam_abs_dim2
 387         do kk1 = kts,kte+1
 388           do i = its,ite
 389             abstot(i,kk1,kk) = abstot_3d(i,kk1,kk,j)
 390           enddo
 391         enddo
 392       enddo
 393 !      do kk = 1,4
 394       do kk = 1,cam_abs_dim1
 395         do kk1 = kts,kte
 396           do i = its,ite
 397             absnxt(i,kk1,kk) = absnxt_3d(i,kk1,kk,j)
 398           enddo
 399         enddo
 400       enddo
 401       do kk = kts,kte+1
 402           do i = its,ite
 403             emstot(i,kk) = emstot_3d(i,kk,j)
 404           enddo
 405       enddo
 406       endif
 407
 408       do k = kts,kte
 409       kk = kte - k + kts
 410       do i = its,ite
 411       ii = i - its + 1
 412       pmid(ii,kk) = phydmid(i,k)
 413       lnpmid(ii,kk) = log(pmid(ii,kk))
 414       lnpint(ii,kk) = log(pint(ii,kk))
 415       pdel(ii,kk) = pint(ii,kk+1) - pint(ii,kk)
 416       t(ii,kk) = t_phy(i,k,j)
 417       zm(ii,kk) = z(i,k,j)
 418       enddo
 419       enddo
 420
 421
 422 ! Compute cloud water/ice paths and optical properties for input to radiation
 423
 424       call param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, q, cld, landfrac, landm,icefrac, &
 425                                 pdel, t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh)
 426
 427       do i = its,ite
 428       ii = i - its + 1
 429 ! use same albedo for direct and diffuse
 430 ! change this when separate values are provided
 431       asdir(ii) = albedo(i,j)
 432       asdif(ii) = albedo(i,j)
 433       aldir(ii) = albedo(i,j)
 434       aldif(ii) = albedo(i,j)
 435       enddo
 436
 437 ! WRF allocate space here (not needed if oznini is called)
 438 !  allocate (ozmix(pcols,levsiz,begchunk:endchunk)) ! This line from oznini.F90
 439
 440       call radctl (j,lchnk, ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst, lwups, emis, pmid,             &
 441                    pint, lnpmid, lnpint, pdel, t, q,   &
 442                    cld, cicewp, cliqwp, tauxcl, tauxci, coszrs, clat, asdir, asdif,               &
 443                    aldir, aldif, solcon, GMT,JULDAY,JULIAN,DT,XTIME,   &
 444                    pin, ozmixmj, ozmix, levsiz, num_months,  &
 445                    m_psjp,m_psjn, aerosoljp, aerosoljn,  m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, &
 446                    dolw, dosw, doabsems, abstot, absnxt, emstot, &
 447                    fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa,  &
 448                    fsns, fsnt    ,flns    ,flnt    , &
 449                    qrs, qrl, flwds, rel, rei,                       &
 450                    sols, soll, solsd, solld,                  &
 451                    landfrac, zm, fsds)
 452
 453       do k = kts,kte
 454       kk = kte - k + kts
 455       do i = its,ite
 456       ii = i - its + 1
 457       if(dolw)RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
 458       if(dosw)RTHRATENSW(I,K,J) = 1.e4*qrs(ii,kk)/(cpair*pi_phy(i,k,j))
 459       cemiss(i,k,j)     = emis(ii,kk)
 460       taucldc(i,k,j)    = tauxcl(ii,kk)
 461       taucldi(i,k,j)    = tauxci(ii,kk)
 462       enddo
 463       enddo
 464
 465       if(doabsems .and. dolw)then
 466 !      do kk = kts,kte+1
 467       do kk = 1,cam_abs_dim2
 468         do kk1 = kts,kte+1
 469           do i = its,ite
 470             abstot_3d(i,kk1,kk,j) = abstot(i,kk1,kk)
 471           enddo
 472         enddo
 473       enddo
 474 !      do kk = 1,4
 475       do kk = 1,cam_abs_dim1
 476         do kk1 = kts,kte
 477           do i = its,ite
 478             absnxt_3d(i,kk1,kk,j) = absnxt(i,kk1,kk)
 479           enddo
 480         enddo
 481       enddo
 482       do kk = kts,kte+1
 483           do i = its,ite
 484             emstot_3d(i,kk,j) = emstot(i,kk)
 485           enddo
 486       enddo
 487       endif
 488
 489       IF(PRESENT(SWUPT))THEN
 490       if(dosw)then
 491 ! Added shortwave and longwave upward/downward total and clear sky fluxes
 492       do k = kts,kte+1
 493       kk = kte +1 - k + kts
 494       do i = its,ite
 495       ii = i - its + 1
 496 !      swup(i,k,j)      = fsup(ii,kk)
 497 !      swupclear(i,k,j) = fsupc(ii,kk)
 498 !      swdn(i,k,j)      = fsdn(ii,kk)
 499 !      swdnclear(i,k,j) = fsdnc(ii,kk)
 500        if(k.eq.kte+1)then
 501          swupt(i,j)     = fsup(ii,kk)
 502          swuptc(i,j)    = fsupc(ii,kk)
 503          swdnt(i,j)     = fsdn(ii,kk)
 504          swdntc(i,j)    = fsdnc(ii,kk)
 505        endif
 506        if(k.eq.kts)then
 507          swupb(i,j)     = fsup(ii,kk)
 508          swupbc(i,j)    = fsupc(ii,kk)
 509          swdnb(i,j)     = fsdn(ii,kk)
 510          swdnbc(i,j)    = fsdnc(ii,kk)
 511        endif
 512 !            if(i.eq.30.and.j.eq.30) then
 513 !            print 1234, 'short ', i,ii,k,kk,fsup(ii,kk),fsupc(ii,kk),fsdn(ii,kk),fsdnc(ii,kk)
 514 !            1234 format (a6,4i4,4f10.3)
 515 !            endif
 516      enddo
 517       enddo
 518       endif
 519       if(dolw)then
 520 ! Added shortwave and longwave upward/downward total and clear sky fluxes
 521       do k = kts,kte+1
 522       kk = kte +1 - k + kts
 523       do i = its,ite
 524       ii = i - its + 1
 525 !      lwup(i,k,j)      = flup(ii,kk)
 526 !      lwupclear(i,k,j) = flupc(ii,kk)
 527 !      lwdn(i,k,j)      = fldn(ii,kk)
 528 !      lwdnclear(i,k,j) = fldnc(ii,kk)
 529        if(k.eq.kte+1)then
 530          lwupt(i,j)     = flup(ii,kk)
 531          lwuptc(i,j)    = flupc(ii,kk)
 532          lwdnt(i,j)     = fldn(ii,kk)
 533          lwdntc(i,j)    = fldnc(ii,kk)
 534        endif
 535        if(k.eq.kts)then
 536          lwupb(i,j)     = flup(ii,kk)
 537          lwupbc(i,j)    = flupc(ii,kk)
 538          lwdnb(i,j)     = fldn(ii,kk)
 539          lwdnbc(i,j)    = fldnc(ii,kk)
 540        endif
 541 !            if(i.eq.30.and.j.eq.30) then
 542 !            print 1234, 'long  ', i,ii,k,kk,flup(ii,kk),flupc(ii,kk),fldn(ii,kk),fldnc(ii,kk)
 543 !            1234 format (a6,4i4,4f10.3)
 544 !            endif
 545       enddo
 546       enddo
 547       endif
 548       ENDIF
 549
 550       do i = its,ite
 551       ii = i - its + 1
 552 ! Added shortwave and longwave cloud forcing at TOA and surface
 553       if(dolw)then
 554         GLW(I,J) = flwds(ii)
 555         lwcf(i,j) = lwcftoa(ii)
 556         olr(i,j)  = olrtoa(ii)
 557       endif
 558       if(dosw)then
 559         GSW(I,J) = fsns(ii)
 560         swcf(i,j) = swcftoa(ii)
 561         coszr(i,j) = coszrs(ii)
 562       endif
 563       enddo
 564
 565     enddo    ! j-loop
 566
 567 #endif
 568
 569 end subroutine camrad
 570 !====================================================================
 571    SUBROUTINE camradinit(                                           &
 572                          R_D,R_V,CP,G,STBOLT,EP_2,shalf,pptop,               &
 573                          ozmixm,pin,levsiz,XLAT,num_months,         &
 574                          m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,    &
 575                          paerlev,naer_c,                            &
 576                      ids, ide, jds, jde, kds, kde,                  &
 577                      ims, ime, jms, jme, kms, kme,                  &
 578                      its, ite, jts, jte, kts, kte                   )
 579
 580    USE module_wrf_error
 581    USE module_state_description
 582    !USE module_configure
 583
 584 !--------------------------------------------------------------------
 585    IMPLICIT NONE
 586 !--------------------------------------------------------------------
 587    INTEGER , INTENT(IN)           :: ids, ide, jds, jde, kds, kde,  &
 588                                      ims, ime, jms, jme, kms, kme,  &
 589                                      its, ite, jts, jte, kts, kte
 590    REAL, intent(in)               :: pptop
 591    REAL, INTENT(IN)               :: R_D,R_V,CP,G,STBOLT,EP_2
 592
 593    REAL,     DIMENSION( kms:kme )  :: shalf
 594
 595    INTEGER,      INTENT(IN   )    ::   levsiz, num_months
 596    INTEGER,      INTENT(IN   )    ::   paerlev, naer_c
 597
 598    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )  :: XLAT
 599
 600    REAL,  DIMENSION( ims:ime, levsiz, jms:jme, num_months ),      &
 601           INTENT(INOUT   ) ::                                  OZMIXM
 602
 603    REAL,  DIMENSION(levsiz), INTENT(INOUT )  ::                   PIN
 604    REAL,  DIMENSION(ims:ime, jms:jme), INTENT(INOUT )  ::                  m_psp,m_psn
 605    REAL,  DIMENSION(paerlev), INTENT(INOUT )  ::               m_hybi
 606    REAL,  DIMENSION( ims:ime, paerlev, jms:jme, naer_c ),      &
 607           INTENT(INOUT) ::                             aerosolcp,aerosolcn
 608
 609    REAL(r8)    :: pstd
 610    REAL(r8)    :: rh2o, cpair
 611
 612 #if !defined(MAC_KLUDGE)
 613    ozncyc = .true.
 614    indirect = .true.
 615    ixcldliq = 2
 616    ixcldice = 3
 617 #if (NMM_CORE != 1)
 618 ! aerosol array is not in the NMM Registry
 619 !   since CAM radiation not available to NMM (yet)
 620 !   so this is blocked out to enable CAM compilation with NMM
 621    idxSUL = P_SUL
 622    idxSSLT = P_SSLT
 623    idxDUSTfirst = P_DUST1
 624    idxOCPHO = P_OCPHO
 625    idxCARBONfirst = P_OCPHO
 626    idxBCPHO = P_BCPHO
 627    idxOCPHI = P_OCPHI
 628    idxBCPHI = P_BCPHI
 629    idxBG = P_BG
 630    idxVOLC = P_VOLC
 631 #endif
 632
 633    pstd = 101325.0
 634 ! from physconst module
 635    mwdry = 28.966            ! molecular weight dry air ~ kg/kmole (shr_const_mwdair)
 636    mwco2 =  44.              ! molecular weight co2
 637    mwh2o = 18.016            ! molecular weight water vapor (shr_const_mwwv)
 638    mwch4 =  16.              ! molecular weight ch4
 639    mwn2o =  44.              ! molecular weight n2o
 640    mwf11 = 136.              ! molecular weight cfc11
 641    mwf12 = 120.              ! molecular weight cfc12
 642    cappa = R_D/CP
 643    rair = R_D
 644    tmelt = 273.16            ! freezing T of fresh water ~ K
 645    r_universal = 6.02214e26 * STBOLT   ! Universal gas constant ~ J/K/kmole
 646    latvap = 2.501e6          ! latent heat of evaporation ~ J/kg
 647    latice = 3.336e5          ! latent heat of fusion ~ J/kg
 648    zvir = R_V/R_D - 1.
 649    rh2o = R_V
 650    cpair = CP
 651 !
 652    epsqs = EP_2
 653
 654    CALL radini(G, CP, EP_2, STBOLT, pstd*10.0 )
 655    CALL esinti(epsqs  ,latvap  ,latice  ,rh2o    ,cpair   ,tmelt   )
 656    CALL oznini(ozmixm,pin,levsiz,num_months,XLAT,                   &
 657                      ids, ide, jds, jde, kds, kde,                  &
 658                      ims, ime, jms, jme, kms, kme,                  &
 659                      its, ite, jts, jte, kts, kte)
 660    CALL aerosol_init(m_psp,m_psn,m_hybi,aerosolcp,aerosolcn,paerlev,naer_c,shalf,pptop,    &
 661                      ids, ide, jds, jde, kds, kde,                  &
 662                      ims, ime, jms, jme, kms, kme,                  &
 663                      its, ite, jts, jte, kts, kte)
 664
 665 #endif
 666
 667    END SUBROUTINE camradinit
 668 #if !defined(MAC_KLUDGE)
 669
 670
 671 subroutine oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
 672
 673       IMPLICIT NONE
 674
 675    INTEGER,      INTENT(IN   )    ::   levsiz, num_months,pcols
 676
 677    REAL(r8),  DIMENSION( pcols, levsiz, num_months ),      &
 678           INTENT(IN   ) ::                                  ozmixmj
 679
 680    REAL, INTENT(IN    )      ::        XTIME,GMT
 681    INTEGER, INTENT(IN )      ::        JULDAY
 682    REAL,    INTENT(IN )      ::        JULIAN
 683    REAL,    INTENT(IN )      ::        DT
 684
 685    REAL(r8),  DIMENSION( pcols, levsiz ),      &
 686           INTENT(OUT  ) ::                                  ozmix
 687    !Local
 688    REAL(r8)  :: intJULIAN
 689    integer   :: np1,np,nm,m,k,i
 690    integer   :: IJUL
 691    integer, dimension(12) ::  date_oz
 692    data date_oz/16, 45, 75, 105, 136, 166, 197, 228, 258, 289, 319, 350/
 693    real(r8) :: cdayozp, cdayozm
 694    real(r8) :: fact1, fact2
 695    logical  :: finddate
 696    CHARACTER(LEN=256) :: msgstr
 697
 698    ! JULIAN starts from 0.0 at 0Z on 1 Jan.
 699    intJULIAN = JULIAN + 1.0_r8    ! offset by one day
 700 ! jan 1st 00z is julian=1.0 here
 701    IJUL=INT(intJULIAN)
 702 !  Note that following will drift.
 703 !    Need to use actual month/day info to compute julian.
 704    intJULIAN=intJULIAN-FLOAT(IJUL)
 705    IJUL=MOD(IJUL,365)
 706    IF(IJUL.EQ.0)IJUL=365
 707    intJULIAN=intJULIAN+IJUL
 708    np1=1
 709    finddate=.false.
 710    do m=1,num_months
 711    if(date_oz(m).gt.intjulian.and..not.finddate) then
 712      np1=m
 713      finddate=.true.
 714    endif
 715    enddo
 716    cdayozp=date_oz(np1)
 717    if(np1.gt.1) then
 718    cdayozm=date_oz(np1-1)
 719    np=np1
 720    nm=np-1
 721    else
 722    cdayozm=date_oz(12)
 723    np=np1
 724    nm=12
 725    endif
 726    call getfactors(ozncyc,np1, cdayozm, cdayozp,intjulian, &
 727                     fact1, fact2)
 728
 729 !
 730 ! Time interpolation.
 731 !
 732       do k=1,levsiz
 733          do i=1,pcols
 734             ozmix(i,k) = ozmixmj(i,k,nm)*fact1 + ozmixmj(i,k,np)*fact2
 735          end do
 736       end do
 737
 738 END subroutine oznint
 739
 740
 741 subroutine get_aerosol(c, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
 742   aerosoljn, m_hybi, paerlev, naer_c, pint, pcols, pver, pverp, pverr, pverrp, AEROSOLt, scale)
 743 !------------------------------------------------------------------
 744 !
 745 !  Input:
 746 !     time at which aerosol mmrs are needed (get_curr_calday())
 747 !     chunk index
 748 !     CAM's vertical grid (pint)
 749 !
 750 !  Output:
 751 !     values for Aerosol Mass Mixing Ratios at specified time
 752 !     on vertical grid specified by CAM (AEROSOLt)
 753 !
 754 !  Method:
 755 !     first determine which indexs of aerosols are the bounding data sets
 756 !     interpolate both onto vertical grid aerm(),aerp().
 757 !     from those two, interpolate in time.
 758 !
 759 !------------------------------------------------------------------
 760
 761 !  use volcanicmass, only: get_volcanic_mass
 762 !  use timeinterp, only: getfactors
 763 !
 764 ! aerosol fields interpolated to current time step
 765 !   on pressure levels of this time step.
 766 ! these should be made read-only for other modules
 767 ! Is allocation done correctly here?
 768 !
 769    integer, intent(in) :: c                   ! Chunk Id.
 770    integer, intent(in) :: paerlev, naer_c, pcols, pver, pverp, pverr, pverrp
 771    real(r8), intent(in) :: pint(pcols,pverp)  ! midpoint pres.
 772    real(r8), intent(in) :: scale(naer_all)    ! scale each aerosol by this amount
 773    REAL, INTENT(IN    )      ::        XTIME,GMT
 774    INTEGER, INTENT(IN )      ::        JULDAY
 775    REAL, INTENT(IN    )      ::        JULIAN
 776    REAL, INTENT(IN    )      ::        DT
 777    real(r8), intent(in   )      ::        m_psp(pcols),m_psn(pcols)  ! Match surface pressure
 778    real(r8), intent(in   )   ::        aerosoljp(pcols,paerlev,naer_c)
 779    real(r8), intent(in   )   ::        aerosoljn(pcols,paerlev,naer_c)
 780    real(r8), intent(in   )   ::        m_hybi(paerlev)
 781
 782    real(r8), intent(out) :: AEROSOLt(pcols, pver, naer_all) ! aerosols
 783 !
 784 ! Local workspace
 785 !
 786    real(r8) caldayloc                     ! calendar day of current timestep
 787    real(r8) fact1, fact2                  ! time interpolation factors
 788
 789   integer :: nm = 1                ! index to prv month in array. init to 1 and toggle between 1 and 2
 790   integer :: np = 2                ! index to nxt month in array. init to 2 and toggle between 1 and 2
 791   integer :: mo_nxt = bigint       ! index to nxt month in file
 792   integer :: mo_prv                       ! index to previous month
 793
 794   real(r8) :: cdaym = inf          ! calendar day of prv month
 795   real(r8) :: cdayp = inf          ! calendar day of next month
 796   real(r8) :: Mid(12)              ! Days into year for mid month date
 797   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 /
 798
 799    integer i, k, j                        ! spatial indices
 800    integer m                              ! constituent index
 801    integer lats(pcols),lons(pcols)        ! latitude and longitudes of column
 802    integer ncol                           ! number of columns
 803    INTEGER IJUL
 804    REAL(r8) intJULIAN
 805
 806    real(r8) speciesmin(naer)              ! minimal value for each species
 807 !
 808 ! values before current time step "the minus month"
 809 ! aerosolm(pcols,pver) is value of preceeding month's aerosol mmr
 810 ! aerosolp(pcols,pver) is value of next month's aerosol mmr
 811 !  (think minus and plus or values to left and right of point to be interpolated)
 812 !
 813    real(r8) AEROSOLm(pcols,pver,naer) ! aerosol mmr from MATCH in column at previous (minus) month
 814 !
 815 ! values beyond (or at) current time step "the plus month"
 816 !
 817    real(r8) AEROSOLp(pcols,pver,naer) ! aerosol mmr from MATCH in column at next (plus) month
 818    CHARACTER(LEN=256) :: msgstr
 819
 820    ! JULIAN starts from 0.0 at 0Z on 1 Jan.
 821    intJULIAN = JULIAN + 1.0_r8    ! offset by one day
 822 ! jan 1st 00z is julian=1.0 here
 823    IJUL=INT(intJULIAN)
 824 !  Note that following will drift.
 825 !    Need to use actual month/day info to compute julian.
 826    intJULIAN=intJULIAN-FLOAT(IJUL)
 827    IJUL=MOD(IJUL,365)
 828    IF(IJUL.EQ.0)IJUL=365
 829    caldayloc=intJULIAN+IJUL
 830
 831    if (caldayloc < Mid(1)) then
 832       mo_prv = 12
 833       mo_nxt =  1
 834    else if (caldayloc >= Mid(12)) then
 835       mo_prv = 12
 836       mo_nxt =  1
 837    else
 838       do i = 2 , 12
 839          if (caldayloc < Mid(i)) then
 840             mo_prv = i-1
 841             mo_nxt = i
 842             exit
 843          end if
 844       end do
 845    end if
 846 !
 847 ! Set initial calendar day values
 848 !
 849    cdaym = Mid(mo_prv)
 850    cdayp = Mid(mo_nxt)
 851
 852 !
 853 ! Determine time interpolation factors.  1st arg says we are cycling 1 year of data
 854 !
 855    call getfactors (.true., mo_nxt, cdaym, cdayp, caldayloc, &
 856                     fact1, fact2)
 857 !
 858 ! interpolate (prv and nxt month) bounding datasets onto cam vertical grid.
 859 ! compute mass mixing ratios on CAMS's pressure coordinate
 860 !  for both the "minus" and "plus" months
 861 !
 862 !  ncol = get_ncols_p(c)
 863    ncol = pcols
 864
 865 !  call vert_interpolate (M_ps_cam_col(1,c,nm), pint, nm, AEROSOLm, ncol, c)
 866 !  call vert_interpolate (M_ps_cam_col(1,c,np), pint, np, AEROSOLp, ncol, c)
 867
 868    call vert_interpolate (m_psp, aerosoljp, m_hybi, paerlev, naer_c, pint, nm, AEROSOLm, pcols, pver, pverp, ncol, c)
 869    call vert_interpolate (m_psn, aerosoljn, m_hybi, paerlev, naer_c, pint, np, AEROSOLp, pcols, pver, pverp, ncol, c)
 870
 871 !
 872 ! Time interpolate.
 873 !
 874    do m=1,naer
 875       do k=1,pver
 876          do i=1,ncol
 877             AEROSOLt(i,k,m) = AEROSOLm(i,k,m)*fact1 + AEROSOLp(i,k,m)*fact2
 878          end do
 879       end do
 880    end do
 881
 882 !  do i=1,ncol
 883 !     Match_ps_chunk(i,c) = m_ps(i,nm)*fact1 + m_ps(i,np)*fact2
 884 !  end do
 885 !
 886 ! get background aerosol (tuning) field
 887 !
 888    call background (c, ncol, pint, pcols, pverr, pverrp, AEROSOLt(:, :, idxBG))
 889
 890 !
 891 ! find volcanic aerosol masses
 892 !
 893 ! if (strat_volcanic) then
 894 !   call get_volcanic_mass(c, AEROSOLt(:,:,idxVOLC))
 895 ! else
 896     AEROSOLt(:,:,idxVOLC) = 0._r8
 897 ! endif
 898
 899 !
 900 ! exit if mmr is negative (we have previously set
 901 !  cumulative mass to be a decreasing function.)
 902 !
 903    speciesmin(:) = 0. ! speciesmin(m) = 0 is minimum mmr for each species
 904
 905    do m=1,naer
 906       do k=1,pver
 907          do i=1,ncol
 908             if (AEROSOLt(i, k, m) < speciesmin(m)) then
 909                write(6,*) 'AEROSOL_INTERPOLATE: negative mass mixing ratio, exiting'
 910                write(6,*) 'm, column, pver',m, i, k ,AEROSOLt(i, k, m)
 911 !              call endrun ()
 912             end if
 913          end do
 914       end do
 915    end do
 916 !
 917 ! scale any AEROSOLS as required
 918 !
 919    call scale_aerosols (AEROSOLt, pcols, pver, ncol, c, scale)
 920
 921    return
 922 end subroutine get_aerosol
 923
 924
 925 subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
 926 !--------------------------------------------------------------
 927 ! Compute effect of sulfate on effective liquid water radius
 928 !  Method of Martin et. al.
 929 !--------------------------------------------------------------
 930
 931 ! use constituents, only: ppcnst, cnst_get_ind
 932 ! use history, only: outfld
 933
 934 !#include <comctl.h>
 935
 936   integer, intent(in) :: ncol                  ! number of atmospheric columns
 937   integer, intent(in) :: lchnk                 ! chunk identifier
 938   integer, intent(in) :: pcols,pver,ppcnst
 939
 940   real(r8), intent(in) :: landfrac(pcols)      ! land fraction
 941   real(r8), intent(in) :: pmid(pcols,pver)     ! Model level pressures
 942   real(r8), intent(in) :: t(pcols,pver)        ! Model level temperatures
 943   real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
 944   real(r8), intent(in) :: cld(pcols,pver)      ! Fractional cloud cover
 945   real(r8), intent(in) :: zm(pcols,pver)       ! Height of midpoints (above surface)
 946   real(r8), intent(in) :: rel(pcols,pver)      ! liquid effective drop size (microns)
 947 !
 948 ! local variables
 949 !
 950   real(r8) locrhoair(pcols,pver)  ! dry air density            [kg/m^3 ]
 951   real(r8) lwcwat(pcols,pver)     ! in-cloud liquid water path [kg/m^3 ]
 952   real(r8) sulfmix(pcols,pver)    ! sulfate mass mixing ratio  [kg/kg  ]
 953   real(r8) so4mass(pcols,pver)    ! sulfate mass concentration [g/cm^3 ]
 954   real(r8) Aso4(pcols,pver)       ! sulfate # concentration    [#/cm^3 ]
 955   real(r8) Ntot(pcols,pver)       ! ccn # concentration        [#/cm^3 ]
 956   real(r8) relmod(pcols,pver)     ! effective radius           [microns]
 957
 958   real(r8) wrel(pcols,pver)       ! weighted effective radius    [microns]
 959   real(r8) wlwc(pcols,pver)       ! weighted liq. water content  [kg/m^3 ]
 960   real(r8) cldfrq(pcols,pver)     ! frequency of occurance of...
 961 !                                  ! clouds (cld => 0.01)         [fraction]
 962   real(r8) locPi                  ! my piece of the pi
 963   real(r8) Rdryair                ! gas constant of dry air   [J/deg/kg]
 964   real(r8) rhowat                 ! density of water          [kg/m^3  ]
 965   real(r8) Acoef                  ! m->A conversion factor; assumes
 966 !                                  ! Dbar=0.10, sigma=2.0      [g^-1    ]
 967   real(r8) rekappa                ! kappa in evaluation of re(lmod)
 968   real(r8) recoef                 ! temp. coeficient for calc of re(lmod)
 969   real(r8) reexp                  ! 1.0/3.0
 970   real(r8) Ntotb                  ! temp var to hold below cloud ccn
 971 ! -- Parameters for background CDNC (from `ambient' non-sulfate aerosols)...
 972   real(r8) Cmarn                  ! Coef for CDNC_marine         [cm^-3]
 973   real(r8) Cland                  ! Coef for CDNC_land           [cm^-3]
 974   real(r8) Hmarn                  ! Scale height for CDNC_marine [m]
 975   real(r8) Hland                  ! Scale height for CDNC_land   [m]
 976   parameter ( Cmarn = 50.0, Cland = 100.0 )
 977   parameter ( Hmarn = 1000.0, Hland = 2000.0 )
 978   real(r8) bgaer                  ! temp var to hold background CDNC
 979
 980   integer i,k     ! loop indices
 981 !
 982 ! Statement functions
 983 !
 984   logical land    ! is this a column over land?
 985   land(i) = nint(landfrac(i)).gt.0.5_r8
 986
 987   if (indirect) then
 988
 989 !   call endrun ('AEROSOL_INDIRECT:  indirect effect is obsolete')
 990
 991 !   ramping is not yet resolved so sulfmix is 0.
 992     sulfmix(1:ncol,1:pver) = 0._r8
 993
 994     locPi = 3.141592654
 995     Rdryair = 287.04
 996     rhowat = 1000.0
 997     Acoef = 1.2930E14
 998     recoef = 3.0/(4.0*locPi*rhowat)
 999     reexp = 1.0/3.0
1000
1001 !   call cnst_get_ind('CLDLIQ', ixcldliq)
1002     do k=pver,1,-1
1003       do i = 1,ncol
1004         locrhoair(i,k) = pmid(i,k)/( Rdryair*t(i,k) )
1005         lwcwat(i,k) = ( qm1(i,k,ixcldliq)/max(0.01_r8,cld(i,k)) )* &
1006                       locrhoair(i,k)
1007 !          NOTE: 0.001 converts kg/m3 -> g/cm3
1008         so4mass(i,k) = sulfmix(i,k)*locrhoair(i,k)*0.001
1009         Aso4(i,k) = so4mass(i,k)*Acoef
1010
1011         if (Aso4(i,k) <= 280.0) then
1012            Aso4(i,k) = max(36.0_r8,Aso4(i,k))
1013            Ntot(i,k) = -1.15E-3*Aso4(i,k)**2 + 0.963*Aso4(i,k)+5.30
1014            rekappa = 0.80
1015         else
1016            Aso4(i,k) = min(1500.0_r8,Aso4(i,k))
1017            Ntot(i,k) = -2.10E-4*Aso4(i,k)**2 + 0.568*Aso4(i,k)-27.9
1018            rekappa = 0.67
1019         end if
1020         if (land(i)) then ! Account for local background aerosol;
1021            bgaer = Cland*exp(-(zm(i,k)/Hland))
1022            Ntot(i,k) = max(bgaer,Ntot(i,k))
1023         else
1024            bgaer = Cmarn*exp(-(zm(i,k)/Hmarn))
1025            Ntot(i,k) = max(bgaer,Ntot(i,k))
1026         end if
1027
1028         if (k == pver) then
1029            Ntotb = Ntot(i,k)
1030         else
1031            Ntotb = Ntot(i,k+1)
1032         end if
1033
1034         relmod(i,k) = (( (recoef*lwcwat(i,k))/(rekappa*Ntotb))**reexp)*10000.0
1035         relmod(i,k) = max(4.0_r8,relmod(i,k))
1036         relmod(i,k) = min(20.0_r8,relmod(i,k))
1037         if (cld(i,k) >= 0.01) then
1038            cldfrq(i,k) = 1.0
1039         else
1040            cldfrq(i,k) = 0.0
1041         end if
1042         wrel(i,k) = relmod(i,k)*cldfrq(i,k)
1043         wlwc(i,k) = lwcwat(i,k)*cldfrq(i,k)
1044       end do
1045     end do
1046 !   call outfld('MSO4    ',so4mass,pcols,lchnk)
1047 !   call outfld('LWC     ',lwcwat ,pcols,lchnk)
1048 !   call outfld('CLDFRQ  ',cldfrq ,pcols,lchnk)
1049 !   call outfld('WREL    ',wrel   ,pcols,lchnk)
1050 !   call outfld('WLWC    ',wlwc   ,pcols,lchnk)
1051 !   write(6,*)'WARNING: indirect calculation has no effects'
1052   else
1053     do k = 1, pver
1054       do i = 1, ncol
1055         relmod(i,k) = rel(i,k)
1056       end do
1057     end do
1058   endif
1059
1060 ! call outfld('REL     ',relmod ,pcols,lchnk)
1061
1062   return
1063 end subroutine aerosol_indirect
1064
1065
1066       subroutine aer_trn(aer_mpp, aer_trn_ttl, pcols, plev, plevp )
1067 !
1068 !     Purpose: Compute strat. aerosol transmissions needed in absorptivity/
1069 !              emissivity calculations
1070 !              aer_trn() is called by radclw() when doabsems is .true.
1071 !
1072 !     use shr_kind_mod, only: r8 => shr_kind_r8
1073 !     use pmgrid
1074 !     use ppgrid
1075 !     use prescribed_aerosols, only: strat_volcanic
1076       implicit none
1077
1078 !     Input arguments
1079 !
1080 !       [kg m-2] Volcanics path above kth interface level
1081 !
1082       integer, intent(in)         :: pcols, plev, plevp
1083       real(r8), intent(in) :: aer_mpp(pcols,plevp)
1084
1085 !     Output arguments
1086 !
1087 !       [fraction] Total volcanic transmission between interfaces k1 and k2
1088 !
1089       real(r8), intent(out) ::  aer_trn_ttl(pcols,plevp,plevp,bnd_nbr_LW)
1090
1091 !-------------------------------------------------------------------------
1092 !     Local variables
1093
1094       integer bnd_idx           ! LW band index
1095       integer i                 ! lon index
1096       integer k1                ! lev index
1097       integer k2                ! lev index
1098       real(r8) aer_pth_dlt      ! [kg m-2] Volcanics path between interface
1099                                 !          levels k1 and k2
1100       real(r8) odap_aer_ttl     ! [fraction] Total path absorption optical
1101                                 !            depth
1102
1103 !-------------------------------------------------------------------------
1104
1105       if (strat_volcanic) then
1106         do bnd_idx=1,bnd_nbr_LW
1107            do i=1,pcols
1108               aer_trn_ttl(i,1,1,bnd_idx)=1.0
1109            end do
1110            do k1=2,plevp
1111               do i=1,pcols
1112                  aer_trn_ttl(i,k1,k1,bnd_idx)=1.0
1113
1114                  aer_pth_dlt  = abs(aer_mpp(i,k1) - aer_mpp(i,1))
1115                  odap_aer_ttl = abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
1116
1117                  aer_trn_ttl(i,1,k1,bnd_idx) = exp(-1.66 * odap_aer_ttl)
1118               end do
1119            end do
1120
1121            do k1=2,plev
1122               do k2=k1+1,plevp
1123                  do i=1,pcols
1124                     aer_trn_ttl(i,k1,k2,bnd_idx) = &
1125                          aer_trn_ttl(i,1,k2,bnd_idx) / &
1126                          aer_trn_ttl(i,1,k1,bnd_idx)
1127                  end do
1128               end do
1129            end do
1130
1131            do k1=2,plevp
1132               do k2=1,k1-1
1133                  do i=1,pcols
1134                     aer_trn_ttl(i,k1,k2,bnd_idx)=aer_trn_ttl(i,k2,k1,bnd_idx)
1135                  end do
1136               end do
1137            end do
1138         end do
1139       else
1140         aer_trn_ttl = 1.0
1141       endif
1142
1143       return
1144       end subroutine aer_trn
1145
1146       subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp)
1147 !------------------------------------------------------
1148 !     Purpose: convert mass per layer to cumulative mass from Top
1149 !------------------------------------------------------
1150 !     use shr_kind_mod, only: r8 => shr_kind_r8
1151 !     use ppgrid
1152 !     use pmgrid
1153       implicit none
1154 !#include <crdcon.h>
1155
1156 !     Parameters
1157 !     Input
1158       integer, intent(in)        :: pcols, plev, plevp
1159       real(r8), intent(in):: aer_mass(pcols,plev)  ! Rad level aerosol mass mixing ratio
1160       integer, intent(in):: ncol
1161 !
1162 !     Output
1163       real(r8), intent(out):: aer_mpp(pcols,plevp) ! [kg m-2] Volcanics path above kth interface
1164 !
1165 !     Local
1166       integer i      ! Column index
1167       integer k      ! Level index
1168 !------------------------------------------------------
1169 !------------------------------------------------------
1170
1171       aer_mpp(1:ncol,1) =  0._r8
1172       do k=2,plevp
1173           aer_mpp(1:ncol,k) = aer_mpp(1:ncol,k-1) + aer_mass(1:ncol,k-1)
1174       enddo
1175 !
1176       return
1177       end subroutine aer_pth
1178
1179 subroutine radctl(j, lchnk   ,ncol    , pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst,  &
1180                   lwups   ,emis    ,          &
1181                   pmid    ,pint    ,pmln    ,piln    ,pdel    ,t       , &
1182 !                 qm1     ,cld     ,cicewp  ,cliqwp  ,coszrs,  clat, &
1183                   qm1     ,cld     ,cicewp  ,cliqwp  ,tauxcl, tauxci, coszrs,  clat, &
1184                   asdir   ,asdif   ,aldir   ,aldif   ,solcon, GMT,JULDAY,JULIAN,DT,XTIME,  &
1185                   pin, ozmixmj, ozmix, levsiz, num_months,      &
1186                   m_psp, m_psn,  aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn  , &
1187                   nmxrgn  ,                   &
1188                   dolw, dosw, doabsems, abstot, absnxt, emstot, &
1189                   fsup    ,fsupc   ,fsdn    ,fsdnc   , &
1190                   flup    ,flupc   ,fldn    ,fldnc   , &
1191                   swcf    ,lwcf    ,flut    ,          &
1192                   fsns    ,fsnt    ,flns    ,flnt    , &
1193                   qrs     ,qrl     ,flwds   ,rel     ,rei     , &
1194                   sols    ,soll    ,solsd   ,solld   , &
1195                   landfrac,zm      ,fsds     )
1196 !-----------------------------------------------------------------------
1197 !
1198 ! Purpose:
1199 ! Driver for radiation computation.
1200 !
1201 ! Method:
1202 ! Radiation uses cgs units, so conversions must be done from
1203 ! model fields to radiation fields.
1204 !
1205 ! Author: CCM1,  CMS Contact: J. Truesdale
1206 !
1207 !-----------------------------------------------------------------------
1208 !  use shr_kind_mod, only: r8 => shr_kind_r8
1209 !  use ppgrid
1210 !  use pspect
1211 !  use commap
1212 !  use history, only: outfld
1213 !  use constituents, only: ppcnst, cnst_get_ind
1214 !  use prescribed_aerosols, only: get_aerosol, naer_all, aerosol_diagnostics, &
1215 !     aerosol_indirect, get_rf_scales, get_int_scales, radforce, idxVOLC
1216 !  use physics_types, only: physics_state
1217 !  use wv_saturation, only: aqsat
1218 !  use chemistry,    only: trace_gas
1219 !  use physconst, only: cpair, epsilo
1220 !  use aer_optics, only: idxVIS
1221 !  use aerosol_intr, only: set_aerosol_from_prognostics
1222
1223
1224    implicit none
1225
1226 !
1227 ! Input arguments
1228 !
1229    integer, intent(in) :: lchnk,j                 ! chunk identifier
1230    integer, intent(in) :: ncol                  ! number of atmospheric columns
1231    integer, intent(in) :: levsiz                ! number of ozone data levels
1232    integer, intent(in) :: num_months            ! 12 months
1233    integer, intent(in) :: paerlev,naer_c          ! aerosol vertical level and # species
1234    integer, intent(in) :: pcols, pver, pverp, pverr, pverrp, ppcnst, pcnst
1235    logical, intent(in) :: dolw,dosw,doabsems
1236
1237
1238    integer nspint            ! Num of spctrl intervals across solar spectrum
1239    integer naer_groups       ! Num of aerosol groups for optical diagnostics
1240    parameter ( nspint = 19 )
1241    parameter ( naer_groups = 7 )    ! current groupings are sul, sslt, all carbons, all dust, background, and all aerosols
1242
1243
1244    real(r8), intent(in) :: lwups(pcols)         ! Longwave up flux at surface
1245    real(r8), intent(in) :: emis(pcols,pver)     ! Cloud emissivity
1246    real(r8), intent(in) :: pmid(pcols,pver)     ! Model level pressures
1247    real(r8), intent(in) :: pint(pcols,pverp)    ! Model interface pressures
1248    real(r8), intent(in) :: pmln(pcols,pver)     ! Natural log of pmid
1249    real(r8), intent(in) :: rel(pcols,pver)      ! liquid effective drop size (microns)
1250    real(r8), intent(in) :: rei(pcols,pver)      ! ice effective drop size (microns)
1251    real(r8), intent(in) :: piln(pcols,pverp)    ! Natural log of pint
1252    real(r8), intent(in) :: pdel(pcols,pverp)    ! Pressure difference across layer
1253    real(r8), intent(in) :: t(pcols,pver)        ! Model level temperatures
1254    real(r8), intent(in) :: qm1(pcols,pver,ppcnst) ! Specific humidity and tracers
1255    real(r8), intent(in) :: cld(pcols,pver)      ! Fractional cloud cover
1256    real(r8), intent(in) :: cicewp(pcols,pver)   ! in-cloud cloud ice water path
1257    real(r8), intent(in) :: cliqwp(pcols,pver)   ! in-cloud cloud liquid water path
1258    real(r8), intent(inout) :: tauxcl(pcols,0:pver) ! cloud water optical depth
1259    real(r8), intent(inout) :: tauxci(pcols,0:pver) ! cloud ice optical depth
1260    real(r8), intent(in) :: coszrs(pcols)        ! Cosine solar zenith angle
1261    real(r8), intent(in) :: clat(pcols)          ! latitude in radians for columns
1262    real(r8), intent(in) :: asdir(pcols)         ! albedo shortwave direct
1263    real(r8), intent(in) :: asdif(pcols)         ! albedo shortwave diffuse
1264    real(r8), intent(in) :: aldir(pcols)         ! albedo longwave direct
1265    real(r8), intent(in) :: aldif(pcols)         ! albedo longwave diffuse
1266    real(r8), intent(in) :: landfrac(pcols)      ! land fraction
1267    real(r8), intent(in) :: zm(pcols,pver)       ! Height of midpoints (above surface)
1268    real(r8), intent(in) :: pin(levsiz)          ! Pressure levels of ozone data
1269    real(r8), intent(in) :: ozmixmj(pcols,levsiz,num_months)  ! monthly ozone mixing ratio
1270    real(r8), intent(inout) :: ozmix(pcols,levsiz)  ! Ozone data
1271    real, intent(in) :: solcon               ! solar constant with eccentricity factor
1272    REAL, INTENT(IN    )      ::        XTIME,GMT
1273    INTEGER, INTENT(IN )      ::        JULDAY
1274    REAL,    INTENT(IN )      ::        JULIAN
1275    REAL,    INTENT(IN )      ::        DT
1276    real(r8), intent(in)     :: m_psp(pcols),m_psn(pcols)       ! MATCH surface pressure
1277    real(r8), intent(in)     :: aerosoljp(pcols,paerlev,naer_c)   ! aerosol concentrations
1278    real(r8), intent(in)     :: aerosoljn(pcols,paerlev,naer_c)   ! aerosol concentrations
1279    real(r8), intent(in)     :: m_hybi(paerlev)
1280 !  type(physics_state), intent(in) :: state
1281    real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pmid for each
1282 !    maximally overlapped region.
1283 !    0->pmxrgn(i,1) is range of pmid for
1284 !    1st region, pmxrgn(i,1)->pmxrgn(i,2) for
1285 !    2nd region, etc
1286    integer, intent(inout) :: nmxrgn(pcols)     ! Number of maximally overlapped regions
1287
1288     real(r8) :: pmxrgnrf(pcols,pverp)             ! temporary copy of pmxrgn
1289     integer  :: nmxrgnrf(pcols)     ! temporary copy of nmxrgn
1290
1291 !
1292 ! Output solar arguments
1293 !
1294    real(r8), intent(out) :: fsns(pcols)          ! Surface absorbed solar flux
1295    real(r8), intent(out) :: fsnt(pcols)          ! Net column abs solar flux at model top
1296    real(r8), intent(out) :: flns(pcols)          ! Srf longwave cooling (up-down) flux
1297    real(r8), intent(out) :: flnt(pcols)          ! Net outgoing lw flux at model top
1298    real(r8), intent(out) :: sols(pcols)          ! Downward solar rad onto surface (sw direct)
1299    real(r8), intent(out) :: soll(pcols)          ! Downward solar rad onto surface (lw direct)
1300    real(r8), intent(out) :: solsd(pcols)         ! Downward solar rad onto surface (sw diffuse)
1301    real(r8), intent(out) :: solld(pcols)         ! Downward solar rad onto surface (lw diffuse)
1302    real(r8), intent(out) :: qrs(pcols,pver)      ! Solar heating rate
1303    real(r8), intent(out) :: fsds(pcols)          ! Flux Shortwave Downwelling Surface
1304 ! Added outputs of total and clearsky fluxes etc
1305    real(r8), intent(out) :: fsup(pcols,pverp)    ! Upward total sky solar
1306    real(r8), intent(out) :: fsupc(pcols,pverp)   ! Upward clear sky solar
1307    real(r8), intent(out) :: fsdn(pcols,pverp)    ! Downward total sky solar
1308    real(r8), intent(out) :: fsdnc(pcols,pverp)   ! Downward clear sky solar
1309    real(r8), intent(out) :: flup(pcols,pverp)    ! Upward total sky longwave
1310    real(r8), intent(out) :: flupc(pcols,pverp)   ! Upward clear sky longwave
1311    real(r8), intent(out) :: fldn(pcols,pverp)    ! Downward total sky longwave
1312    real(r8), intent(out) :: fldnc(pcols,pverp)   ! Downward clear sky longwave
1313    real(r8), intent(out) :: swcf(pcols)          ! Top of the atmosphere solar cloud forcing
1314    real(r8), intent(out) :: lwcf(pcols)          ! Top of the atmosphere longwave cloud forcing
1315    real(r8), intent(out) :: flut(pcols)          ! Top of the atmosphere outgoing longwave
1316 !
1317 ! Output longwave arguments
1318 !
1319    real(r8), intent(out) :: qrl(pcols,pver)      ! Longwave cooling rate
1320    real(r8), intent(out) :: flwds(pcols)         ! Surface down longwave flux
1321
1322    real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
1323    real(r8), intent(inout) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
1324    real(r8), intent(inout) :: emstot(pcols,pverp)     ! Total emissivity
1325
1326
1327 !
1328 !---------------------------Local variables-----------------------------
1329 !
1330    integer i, k              ! index
1331
1332    integer :: in2o, ich4, if11, if12 ! indexes of gases in constituent array
1333
1334    real(r8) solin(pcols)         ! Solar incident flux
1335 !  real(r8) fsds(pcols)          ! Flux Shortwave Downwelling Surface
1336    real(r8) fsntoa(pcols)        ! Net solar flux at TOA
1337    real(r8) fsntoac(pcols)       ! Clear sky net solar flux at TOA
1338    real(r8) fsnirt(pcols)        ! Near-IR flux absorbed at toa
1339    real(r8) fsnrtc(pcols)        ! Clear sky near-IR flux absorbed at toa
1340    real(r8) fsnirtsq(pcols)      ! Near-IR flux absorbed at toa >= 0.7 microns
1341    real(r8) fsntc(pcols)         ! Clear sky total column abs solar flux
1342    real(r8) fsnsc(pcols)         ! Clear sky surface abs solar flux
1343    real(r8) fsdsc(pcols)         ! Clear sky surface downwelling solar flux
1344 !  real(r8) flut(pcols)          ! Upward flux at top of model
1345 !  real(r8) lwcf(pcols)          ! longwave cloud forcing
1346 !  real(r8) swcf(pcols)          ! shortwave cloud forcing
1347    real(r8) flutc(pcols)         ! Upward Clear Sky flux at top of model
1348    real(r8) flntc(pcols)         ! Clear sky lw flux at model top
1349    real(r8) flnsc(pcols)         ! Clear sky lw flux at srf (up-down)
1350    real(r8) ftem(pcols,pver)     ! temporary array for outfld
1351
1352    real(r8) pbr(pcols,pverr)     ! Model mid-level pressures (dynes/cm2)
1353    real(r8) pnm(pcols,pverrp)    ! Model interface pressures (dynes/cm2)
1354    real(r8) o3vmr(pcols,pverr)   ! Ozone volume mixing ratio
1355    real(r8) o3mmr(pcols,pverr)   ! Ozone mass mixing ratio
1356    real(r8) eccf                 ! Earth/sun distance factor
1357    real(r8) n2o(pcols,pver)      ! nitrous oxide mass mixing ratio
1358    real(r8) ch4(pcols,pver)      ! methane mass mixing ratio
1359    real(r8) cfc11(pcols,pver)    ! cfc11 mass mixing ratio
1360    real(r8) cfc12(pcols,pver)    ! cfc12 mass mixing ratio
1361    real(r8) rh(pcols,pverr)      ! level relative humidity (fraction)
1362    real(r8) lwupcgs(pcols)       ! Upward longwave flux in cgs units
1363
1364    real(r8) esat(pcols,pverr)    ! saturation vapor pressure
1365    real(r8) qsat(pcols,pverr)    ! saturation specific humidity
1366
1367    real(r8) :: frc_day(pcols) ! = 1 for daylight, =0 for night colums
1368    real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
1369    real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
1370    real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
1371    real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
1372
1373    real(r8) aerosol(pcols, pver, naer_all) ! aerosol mass mixing ratios
1374    real(r8) scales(naer_all)               ! scaling factors for aerosols
1375
1376
1377 !
1378 ! Interpolate ozone volume mixing ratio to model levels
1379 !
1380 ! WRF: added pin, levsiz, ozmix here
1381    call oznint(julday,julian,dt,gmt,xtime,ozmixmj,ozmix,levsiz,num_months,pcols)
1382
1383    call radozn(lchnk   ,ncol    &
1384               ,pcols, pver &
1385               ,pmid    ,pin, levsiz, ozmix, o3vmr   )
1386
1387 !  call outfld('O3VMR   ',o3vmr ,pcols, lchnk)
1388
1389 !
1390 ! Set chunk dependent radiation input
1391 !
1392    call radinp(lchnk   ,ncol    ,pcols, pver, pverp,      &
1393                pmid    ,pint    ,o3vmr   , pbr     ,&
1394                pnm     ,eccf    ,o3mmr   )
1395
1396 !
1397 ! Solar radiation computation
1398 !
1399    if (dosw) then
1400
1401 !
1402 ! calculate heating with aerosols
1403 !
1404       call aqsat(t, pmid, esat, qsat, pcols, &
1405                  ncol, pver, 1, pver)
1406
1407       ! calculate relative humidity
1408 !     rh(1:ncol,1:pver) = q(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
1409 !        ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
1410 !        ((1.0 - epsilo) * q(1:ncol,1:pver,1) + epsilo)
1411       rh(1:ncol,1:pver) = qm1(1:ncol,1:pver,1) / qsat(1:ncol,1:pver) * &
1412          ((1.0 - epsilo) * qsat(1:ncol,1:pver) + epsilo) / &
1413          ((1.0 - epsilo) * qm1(1:ncol,1:pver,1) + epsilo)
1414
1415       if (radforce) then
1416
1417          pmxrgnrf = pmxrgn
1418          nmxrgnrf = nmxrgn
1419
1420          call get_rf_scales(scales)
1421
1422          call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, &
1423            aerosoljn, m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
1424
1425          ! overwrite with prognostics aerosols
1426
1427 !   no feedback from prognostic aerosols
1428 !        call set_aerosol_from_prognostics (ncol, q, aerosol)
1429
1430          call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
1431
1432 !        call t_startf('radcswmx_rf')
1433          call radcswmx(j, lchnk   ,ncol ,pcols, pver, pverp,         &
1434                     pnm     ,pbr     ,qm1     ,rh      ,o3mmr   , &
1435                     aerosol ,cld     ,cicewp  ,cliqwp  ,rel     , &
1436 !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
1437                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
1438                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgnrf, &
1439                     pmxrgnrf,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
1440                     fsntoac ,fsnirt  ,fsnrtc  ,fsnirtsq,fsns    , &
1441                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
1442                     solsd   ,solld   ,frc_day ,                   &
1443                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
1444                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
1445 !        call t_stopf('radcswmx_rf')
1446
1447 !
1448 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
1449 !
1450
1451             do i = 1, ncol
1452             solin(i) = solin(i)*1.e-3
1453             fsnt(i)  = fsnt(i) *1.e-3
1454             fsns(i)  = fsns(i) *1.e-3
1455             fsntc(i) = fsntc(i)*1.e-3
1456             fsnsc(i) = fsnsc(i)*1.e-3
1457             end do
1458          ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
1459 !
1460 ! Dump shortwave radiation information to history tape buffer (diagnostics)
1461 !
1462 !        call outfld('QRS_RF  ',ftem  ,pcols,lchnk)
1463 !        call outfld('FSNT_RF ',fsnt  ,pcols,lchnk)
1464 !        call outfld('FSNS_RF ',fsns  ,pcols,lchnk)
1465 !        call outfld('FSNTC_RF',fsntc ,pcols,lchnk)
1466 !        call outfld('FSNSC_RF',fsnsc ,pcols,lchnk)
1467
1468       endif ! if (radforce)
1469
1470       call get_int_scales(scales)
1471
1472       call get_aerosol(lchnk, julday, julian, dt, gmt, xtime, m_psp, m_psn, aerosoljp, aerosoljn, &
1473              m_hybi, paerlev, naer, pint, pcols, pver, pverp, pverr, pverrp, aerosol, scales)
1474
1475       ! overwrite with prognostics aerosols
1476 !     call set_aerosol_from_prognostics (ncol, q, aerosol)
1477
1478       call aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld,zm,rel)
1479 !     call t_startf('radcswmx')
1480
1481       call radcswmx(j, lchnk   ,ncol    ,pcols, pver, pverp,         &
1482                     pnm     ,pbr     ,qm1     ,rh      ,o3mmr   , &
1483                     aerosol ,cld     ,cicewp  ,cliqwp  ,rel     , &
1484 !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
1485                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon , &
1486                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgn  , &
1487                     pmxrgn  ,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
1488                     fsntoac ,fsnirt  ,fsnrtc  ,fsnirtsq,fsns    , &
1489                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
1490                     solsd   ,solld   ,frc_day ,                   &
1491                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
1492                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
1493 !     call t_stopf('radcswmx')
1494
1495 ! -- tls ---------------------------------------------------------------2
1496 !
1497 ! Convert units of shortwave fields needed by rest of model from CGS to MKS
1498 !
1499       do i=1,ncol
1500          solin(i) = solin(i)*1.e-3
1501          fsds(i)  = fsds(i)*1.e-3
1502          fsnirt(i)= fsnirt(i)*1.e-3
1503          fsnrtc(i)= fsnrtc(i)*1.e-3
1504          fsnirtsq(i)= fsnirtsq(i)*1.e-3
1505          fsnt(i)  = fsnt(i) *1.e-3
1506          fsns(i)  = fsns(i) *1.e-3
1507          fsntc(i) = fsntc(i)*1.e-3
1508          fsnsc(i) = fsnsc(i)*1.e-3
1509          fsdsc(i) = fsdsc(i)*1.e-3
1510          fsntoa(i)=fsntoa(i)*1.e-3
1511          fsntoac(i)=fsntoac(i)*1.e-3
1512          swcf(i)  = fsntoa(i) - fsntoac(i)
1513       end do
1514       ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair
1515
1516 ! Added upward/downward total and clear sky fluxes
1517          do k = 1, pverp
1518             do i = 1, ncol
1519             fsup(i,k)  = fsup(i,k)*1.e-3
1520             fsupc(i,k) = fsupc(i,k)*1.e-3
1521             fsdn(i,k)  = fsdn(i,k)*1.e-3
1522             fsdnc(i,k) = fsdnc(i,k)*1.e-3
1523             end do
1524          end do
1525
1526 !
1527 ! Dump shortwave radiation information to history tape buffer (diagnostics)
1528 !
1529
1530 !     call outfld('frc_day ', frc_day, pcols, lchnk)
1531 !     call outfld('SULOD_v ', aertau(:,idxVIS,1) ,pcols,lchnk)
1532 !     call outfld('SSLTOD_v', aertau(:,idxVIS,2) ,pcols,lchnk)
1533 !     call outfld('CAROD_v ', aertau(:,idxVIS,3) ,pcols,lchnk)
1534 !     call outfld('DUSTOD_v', aertau(:,idxVIS,4) ,pcols,lchnk)
1535 !     call outfld('BGOD_v  ', aertau(:,idxVIS,5) ,pcols,lchnk)
1536 !     call outfld('VOLCOD_v', aertau(:,idxVIS,6) ,pcols,lchnk)
1537 !     call outfld('AEROD_v ', aertau(:,idxVIS,7) ,pcols,lchnk)
1538 !     call outfld('AERSSA_v', aerssa(:,idxVIS,7) ,pcols,lchnk)
1539 !     call outfld('AERASM_v', aerasm(:,idxVIS,7) ,pcols,lchnk)
1540 !     call outfld('AERFWD_v', aerfwd(:,idxVIS,7) ,pcols,lchnk)
1541 !     call aerosol_diagnostics (lchnk, ncol, pdel, aerosol)
1542
1543 !     call outfld('QRS     ',ftem  ,pcols,lchnk)
1544 !     call outfld('SOLIN   ',solin ,pcols,lchnk)
1545 !     call outfld('FSDS    ',fsds  ,pcols,lchnk)
1546 !     call outfld('FSNIRTOA',fsnirt,pcols,lchnk)
1547 !     call outfld('FSNRTOAC',fsnrtc,pcols,lchnk)
1548 !     call outfld('FSNRTOAS',fsnirtsq,pcols,lchnk)
1549 !     call outfld('FSNT    ',fsnt  ,pcols,lchnk)
1550 !     call outfld('FSNS    ',fsns  ,pcols,lchnk)
1551 !     call outfld('FSNTC   ',fsntc ,pcols,lchnk)
1552 !     call outfld('FSNSC   ',fsnsc ,pcols,lchnk)
1553 !     call outfld('FSDSC   ',fsdsc ,pcols,lchnk)
1554 !     call outfld('FSNTOA  ',fsntoa,pcols,lchnk)
1555 !     call outfld('FSNTOAC ',fsntoac,pcols,lchnk)
1556 !     call outfld('SOLS    ',sols  ,pcols,lchnk)
1557 !     call outfld('SOLL    ',soll  ,pcols,lchnk)
1558 !     call outfld('SOLSD   ',solsd ,pcols,lchnk)
1559 !     call outfld('SOLLD   ',solld ,pcols,lchnk)
1560
1561    end if
1562 !
1563 ! Longwave radiation computation
1564 !
1565    if (dolw) then
1566 !
1567 ! Convert upward longwave flux units to CGS
1568 !
1569       do i=1,ncol
1570 !        lwupcgs(i) = lwup(i)*1000.
1571          lwupcgs(i) = lwups(i)
1572       end do
1573 !
1574 ! Do longwave computation. If not implementing greenhouse gas code then
1575 ! first specify trace gas mixing ratios. If greenhouse gas code then:
1576 !  o ixtrcg   => indx of advected n2o tracer
1577 !  o ixtrcg+1 => indx of advected ch4 tracer
1578 !  o ixtrcg+2 => indx of advected cfc11 tracer
1579 !  o ixtrcg+3 => indx of advected cfc12 tracer
1580 !
1581       if (trace_gas) then
1582 !        call cnst_get_ind('N2O'  , in2o)
1583 !        call cnst_get_ind('CH4'  , ich4)
1584 !        call cnst_get_ind('CFC11', if11)
1585 !        call cnst_get_ind('CFC12', if12)
1586 !        call t_startf("radclwmx")
1587          call radclwmx(lchnk   ,ncol    ,pcols, pver, pverp ,        &
1588                        lwupcgs ,t       ,qm1(1,1,1)       ,o3vmr ,   &
1589                        pbr     ,pnm     ,pmln    ,piln    ,          &
1590                        qm1(1,1,in2o)    ,qm1(1,1,ich4)    ,          &
1591                        qm1(1,1,if11)    ,qm1(1,1,if12)    ,          &
1592                        cld     ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
1593                        doabsems, abstot, absnxt, emstot,             &
1594                        flns    ,flnt    ,flnsc   ,flntc   ,flwds   , &
1595                        flut    ,flutc   ,                            &
1596                        flup    ,flupc   ,fldn    ,fldnc   ,          &
1597                        aerosol(:,:,idxVOLC))
1598 !        call t_stopf("radclwmx")
1599       else
1600          call trcmix(lchnk   ,ncol    ,pcols, pver,  &
1601                      pmid    ,clat, n2o     ,ch4     ,                     &
1602                      cfc11   ,cfc12   )
1603
1604 !        call t_startf("radclwmx")
1605          call radclwmx(lchnk     ,ncol    ,pcols, pver, pverp ,        &
1606                        lwupcgs   ,t       ,qm1(1,1,1)       ,o3vmr ,   &
1607                        pbr       ,pnm     ,pmln    ,piln    ,          &
1608                        n2o       ,ch4     ,cfc11   ,cfc12   ,          &
1609                        cld       ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
1610                        doabsems, abstot, absnxt, emstot,             &
1611                        flns      ,flnt    ,flnsc   ,flntc   ,flwds   , &
1612                        flut      ,flutc   ,                            &
1613                        flup      ,flupc   ,fldn    ,fldnc   ,          &
1614                        aerosol(:,:,idxVOLC))
1615 !        call t_stopf("radclwmx")
1616       endif
1617 !
1618 ! Convert units of longwave fields needed by rest of model from CGS to MKS
1619 !
1620       do i=1,ncol
1621          flnt(i)  = flnt(i)*1.e-3
1622          flut(i)  = flut(i)*1.e-3
1623          flutc(i) = flutc(i)*1.e-3
1624          flns(i)  = flns(i)*1.e-3
1625          flntc(i) = flntc(i)*1.e-3
1626          flnsc(i) = flnsc(i)*1.e-3
1627          flwds(i) = flwds(i)*1.e-3
1628          lwcf(i)  = flutc(i) - flut(i)
1629       end do
1630
1631 ! Added upward/downward total and clear sky fluxes
1632          do k = 1, pverp
1633             do i = 1, ncol
1634             flup(i,k)  = flup(i,k)*1.e-3
1635             flupc(i,k) = flupc(i,k)*1.e-3
1636             fldn(i,k)  = fldn(i,k)*1.e-3
1637             fldnc(i,k) = fldnc(i,k)*1.e-3
1638             end do
1639          end do
1640 !
1641 ! Dump longwave radiation information to history tape buffer (diagnostics)
1642 !
1643 !     call outfld('QRL     ',qrl(:ncol,:)/cpair,ncol,lchnk)
1644 !     call outfld('FLNT    ',flnt  ,pcols,lchnk)
1645 !     call outfld('FLUT    ',flut  ,pcols,lchnk)
1646 !     call outfld('FLUTC   ',flutc ,pcols,lchnk)
1647 !     call outfld('FLNTC   ',flntc ,pcols,lchnk)
1648 !     call outfld('FLNS    ',flns  ,pcols,lchnk)
1649 !     call outfld('FLNSC   ',flnsc ,pcols,lchnk)
1650 !     call outfld('LWCF    ',lwcf  ,pcols,lchnk)
1651 !     call outfld('SWCF    ',swcf  ,pcols,lchnk)
1652 !
1653    end if
1654 !
1655    return
1656 end subroutine radctl
1657   subroutine param_cldoptics_calc(ncol, pcols, pver, pverp, pverr, pverrp, ppcnst, &
1658                                   q, cldn, landfrac, landm,icefrac, &
1659         pdel,  t, ps, pmid, pint, cicewp, cliqwp, emis, rel, rei, pmxrgn, nmxrgn, snowh )
1660 !
1661 ! Compute (liquid+ice) water path and cloud water/ice diagnostics
1662 ! *** soon this code will compute liquid and ice paths from input liquid and ice mixing ratios
1663 !
1664 ! **** mixes interface and physics code temporarily
1665 !-----------------------------------------------------------------------
1666 !   use physics_types, only: physics_state
1667 !   use history,       only: outfld
1668 !   use pkg_cldoptics, only: cldefr, cldems, cldovrlap, cldclw
1669
1670     implicit none
1671
1672 ! Arguments
1673     integer, intent(in) :: ncol, pcols, pver, pverp, pverr, pverrp, ppcnst
1674     real(r8), intent(in)  :: q(pcols,pver,ppcnst)     ! moisture arrays
1675     real(r8), intent(in)  :: cldn(pcols,pver)        ! new cloud fraction
1676     real(r8), intent(in)  :: pdel(pcols,pver)        ! pressure thickness
1677     real(r8), intent(in)  :: t(pcols,pver)           ! temperature
1678     real(r8), intent(in)  :: pmid(pcols,pver)        ! pressure
1679     real(r8), intent(in)  :: pint(pcols,pverp)       ! pressure
1680     real(r8), intent(in)  :: ps(pcols)               ! surface pressure
1681     real(r8), intent(in)  :: landfrac(pcols)         ! Land fraction
1682     real(r8), intent(in)  :: icefrac(pcols)          ! Ice fraction
1683     real(r8), intent(in)  :: landm(pcols)            ! Land fraction ramped
1684     real(r8), intent(in) :: snowh(pcols)         ! Snow depth over land, water equivalent (m)
1685
1686 !!$    real(r8), intent(out) :: cwp   (pcols,pver)      ! in-cloud cloud (total) water path
1687     real(r8), intent(out) :: cicewp(pcols,pver)      ! in-cloud cloud ice water path
1688     real(r8), intent(out) :: cliqwp(pcols,pver)      ! in-cloud cloud liquid water path
1689     real(r8), intent(out) :: emis  (pcols,pver)      ! cloud emissivity
1690     real(r8), intent(out) :: rel   (pcols,pver)      ! effective drop radius (microns)
1691     real(r8), intent(out) :: rei   (pcols,pver)      ! ice effective drop size (microns)
1692     real(r8), intent(out) :: pmxrgn(pcols,pver+1)    ! Maximum values of pressure for each
1693     integer , intent(out) :: nmxrgn(pcols)           ! Number of maximally overlapped regions
1694
1695 ! Local variables
1696     real(r8) :: cwp   (pcols,pver)      ! in-cloud cloud (total) water path
1697 !!$    real(r8) :: cicewp(pcols,pver)      ! in-cloud cloud ice water path
1698 !!$    real(r8) :: cliqwp(pcols,pver)      ! in-cloud cloud liquid water path
1699     real(r8) :: effcld(pcols,pver)                   ! effective cloud=cld*emis
1700     real(r8) :: gicewp(pcols,pver)                   ! grid-box cloud ice water path
1701     real(r8) :: gliqwp(pcols,pver)                   ! grid-box cloud liquid water path
1702     real(r8) :: gwp   (pcols,pver)                   ! grid-box cloud (total) water path
1703     real(r8) :: hl     (pcols)                       ! Liquid water scale height
1704     real(r8) :: tgicewp(pcols)                       ! Vertically integrated ice water path
1705     real(r8) :: tgliqwp(pcols)                       ! Vertically integrated liquid water path
1706     real(r8) :: tgwp   (pcols)                       ! Vertically integrated (total) cloud water path
1707     real(r8) :: tpw    (pcols)                       ! total precipitable water
1708     real(r8) :: clwpold(pcols,pver)                  ! Presribed cloud liq. h2o path
1709     real(r8) :: ficemr (pcols,pver)                  ! Ice fraction from ice and liquid mixing ratios
1710
1711     real(r8) :: rgrav                ! inverse gravitational acceleration
1712
1713     integer :: i,k                                   ! loop indexes
1714     integer :: lchnk
1715
1716 !-----------------------------------------------------------------------
1717
1718 ! Compute liquid and ice water paths
1719     tgicewp(:ncol) = 0.
1720     tgliqwp(:ncol) = 0.
1721     do k=1,pver
1722        do i = 1,ncol
1723           gicewp(i,k) = q(i,k,ixcldice)*pdel(i,k)/gravmks*1000.0  ! Grid box ice water path.
1724           gliqwp(i,k) = q(i,k,ixcldliq)*pdel(i,k)/gravmks*1000.0  ! Grid box liquid water path.
1725 !!$          gwp   (i,k) = gicewp(i,k) + gliqwp(i,k)
1726           cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud ice water path.
1727           cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k))                 ! In-cloud liquid water path.
1728 !!$          cwp   (i,k) = gwp   (i,k) / max(0.01_r8,cldn(i,k))
1729           ficemr(i,k) = q(i,k,ixcldice) /                 &
1730                max(1.e-10_r8,(q(i,k,ixcldice)+q(i,k,ixcldliq)))
1731
1732           tgicewp(i)  = tgicewp(i) + gicewp(i,k)
1733           tgliqwp(i)  = tgliqwp(i) + gliqwp(i,k)
1734        end do
1735     end do
1736     tgwp(:ncol) = tgicewp(:ncol) + tgliqwp(:ncol)
1737     gwp(:ncol,:pver) = gicewp(:ncol,:pver) + gliqwp(:ncol,:pver)
1738     cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
1739
1740 ! Compute total preciptable water in column (in mm)
1741     tpw(:ncol) = 0.0
1742     rgrav = 1.0/gravmks
1743     do k=1,pver
1744        do i=1,ncol
1745           tpw(i) = tpw(i) + pdel(i,k)*q(i,k,1)*rgrav
1746        end do
1747     end do
1748
1749 ! Diagnostic liquid water path (old specified form)
1750 !   call cldclw(lchnk, ncol, pcols, pver, pverp, state%zi, clwpold, tpw, hl)
1751
1752 ! Cloud water and ice particle sizes
1753     call cldefr(lchnk, ncol, pcols, pver, pverp, landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
1754
1755 ! Cloud emissivity.
1756     call cldems(lchnk, ncol, pcols, pver, pverp, cwp, ficemr, rei, emis)
1757
1758 ! Effective cloud cover
1759     do k=1,pver
1760        do i=1,ncol
1761           effcld(i,k) = cldn(i,k)*emis(i,k)
1762        end do
1763     end do
1764
1765 ! Determine parameters for maximum/random overlap
1766     call cldovrlap(lchnk, ncol, pcols, pver, pverp, pint, cldn, nmxrgn, pmxrgn)
1767
1768 !   call outfld('GCLDLWP' ,gwp    , pcols,lchnk)
1769 !   call outfld('TGCLDCWP',tgwp   , pcols,lchnk)
1770 !   call outfld('TGCLDLWP',tgliqwp, pcols,lchnk)
1771 !   call outfld('TGCLDIWP',tgicewp, pcols,lchnk)
1772 !   call outfld('ICLDLWP' ,cwp    , pcols,lchnk)
1773 !   call outfld('SETLWP'  ,clwpold, pcols,lchnk)
1774 !   call outfld('EFFCLD'  ,effcld , pcols,lchnk)
1775 !   call outfld('LWSH'    ,hl     , pcols,lchnk)
1776
1777   end subroutine param_cldoptics_calc
1778
1779 subroutine radabs(lchnk   ,ncol    ,pcols, pver, pverp,   &
1780    pbr    ,pnm     ,co2em    ,co2eml  ,tplnka  , &
1781    s2c    ,tcg     ,w        ,h2otr   ,plco2   , &
1782    plh2o  ,co2t    ,tint     ,tlayr   ,plol    , &
1783    plos   ,pmln    ,piln     ,ucfc11  ,ucfc12  , &
1784    un2o0  ,un2o1   ,uch4     ,uco211  ,uco212  , &
1785    uco213 ,uco221  ,uco222   ,uco223  ,uptype  , &
1786    bn2o0  ,bn2o1   ,bch4    ,abplnk1  ,abplnk2 , &
1787    abstot ,absnxt  ,plh2ob  ,wb       , &
1788    aer_mpp ,aer_trn_ttl)
1789 !-----------------------------------------------------------------------
1790 !
1791 ! Purpose:
1792 ! Compute absorptivities for h2o, co2, o3, ch4, n2o, cfc11 and cfc12
1793 !
1794 ! Method:
1795 ! h2o  ....  Uses nonisothermal emissivity method for water vapor from
1796 !            Ramanathan, V. and  P.Downey, 1986: A Nonisothermal
1797 !            Emissivity and Absorptivity Formulation for Water Vapor
1798 !            Journal of Geophysical Research, vol. 91., D8, pp 8649-8666
1799 !
1800 !            Implementation updated by Collins, Hackney, and Edwards (2001)
1801 !               using line-by-line calculations based upon Hitran 1996 and
1802 !               CKD 2.1 for absorptivity and emissivity
1803 !
1804 !            Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
1805 !               using line-by-line calculations based upon Hitran 2000 and
1806 !               CKD 2.4 for absorptivity and emissivity
1807 !
1808 ! co2  ....  Uses absorptance parameterization of the 15 micro-meter
1809 !            (500 - 800 cm-1) band system of Carbon Dioxide, from
1810 !            Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
1811 !            of the Absorptance Due to the 15 micro-meter Band System
1812 !            of Carbon Dioxide Jouranl of Geophysical Research,
1813 !            vol. 96., D5, pp 9013-9019.
1814 !            Parameterizations for the 9.4 and 10.4 mircon bands of CO2
1815 !            are also included.
1816 !
1817 ! o3   ....  Uses absorptance parameterization of the 9.6 micro-meter
1818 !            band system of ozone, from Ramanathan, V. and R.Dickinson,
1819 !            1979: The Role of stratospheric ozone in the zonal and
1820 !            seasonal radiative energy balance of the earth-troposphere
1821 !            system. Journal of the Atmospheric Sciences, Vol. 36,
1822 !            pp 1084-1104
1823 !
1824 ! ch4  ....  Uses a broad band model for the 7.7 micron band of methane.
1825 !
1826 ! n20  ....  Uses a broad band model for the 7.8, 8.6 and 17.0 micron
1827 !            bands of nitrous oxide
1828 !
1829 ! cfc11 ...  Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
1830 !            micron bands of CFC11
1831 !
1832 ! cfc12 ...  Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
1833 !            micron bands of CFC12
1834 !
1835 !
1836 ! Computes individual absorptivities for non-adjacent layers, accounting
1837 ! for band overlap, and sums to obtain the total; then, computes the
1838 ! nearest layer contribution.
1839 !
1840 ! Author: W. Collins (H2O absorptivity) and J. Kiehl
1841 !
1842 !-----------------------------------------------------------------------
1843 !------------------------------Arguments--------------------------------
1844 !
1845 ! Input arguments
1846 !
1847    integer, intent(in) :: lchnk                       ! chunk identifier
1848    integer, intent(in) :: ncol                        ! number of atmospheric columns
1849    integer, intent(in) :: pcols, pver, pverp
1850
1851    real(r8), intent(in) :: pbr(pcols,pver)            ! Prssr at mid-levels (dynes/cm2)
1852    real(r8), intent(in) :: pnm(pcols,pverp)           ! Prssr at interfaces (dynes/cm2)
1853    real(r8), intent(in) :: co2em(pcols,pverp)         ! Co2 emissivity function
1854    real(r8), intent(in) :: co2eml(pcols,pver)         ! Co2 emissivity function
1855    real(r8), intent(in) :: tplnka(pcols,pverp)        ! Planck fnctn level temperature
1856    real(r8), intent(in) :: s2c(pcols,pverp)           ! H2o continuum path length
1857    real(r8), intent(in) :: tcg(pcols,pverp)           ! H2o-mass-wgted temp. (Curtis-Godson approx.)
1858    real(r8), intent(in) :: w(pcols,pverp)             ! H2o prs wghted path
1859    real(r8), intent(in) :: h2otr(pcols,pverp)         ! H2o trnsmssn fnct for o3 overlap
1860    real(r8), intent(in) :: plco2(pcols,pverp)         ! Co2 prs wghted path length
1861    real(r8), intent(in) :: plh2o(pcols,pverp)         ! H2o prs wfhted path length
1862    real(r8), intent(in) :: co2t(pcols,pverp)          ! Tmp and prs wghted path length
1863    real(r8), intent(in) :: tint(pcols,pverp)          ! Interface temperatures
1864    real(r8), intent(in) :: tlayr(pcols,pverp)         ! K-1 level temperatures
1865    real(r8), intent(in) :: plol(pcols,pverp)          ! Ozone prs wghted path length
1866    real(r8), intent(in) :: plos(pcols,pverp)          ! Ozone path length
1867    real(r8), intent(in) :: pmln(pcols,pver)           ! Ln(pmidm1)
1868    real(r8), intent(in) :: piln(pcols,pverp)          ! Ln(pintm1)
1869    real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
1870                                                       !    Hulst-Curtis-Godson temp. factor
1871                                                       !    for H2O bands
1872    real(r8), intent(in) :: wb(nbands,pcols,pverp)     ! H2o path length with
1873                                                       !    Hulst-Curtis-Godson temp. factor
1874                                                       !    for H2O bands
1875
1876    real(r8), intent(in) :: aer_mpp(pcols,pverp) ! STRAER path above kth interface level
1877    real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! aer trn.
1878
1879
1880 !
1881 ! Trace gas variables
1882 !
1883    real(r8), intent(in) :: ucfc11(pcols,pverp)        ! CFC11 path length
1884    real(r8), intent(in) :: ucfc12(pcols,pverp)        ! CFC12 path length
1885    real(r8), intent(in) :: un2o0(pcols,pverp)         ! N2O path length
1886    real(r8), intent(in) :: un2o1(pcols,pverp)         ! N2O path length (hot band)
1887    real(r8), intent(in) :: uch4(pcols,pverp)          ! CH4 path length
1888    real(r8), intent(in) :: uco211(pcols,pverp)        ! CO2 9.4 micron band path length
1889    real(r8), intent(in) :: uco212(pcols,pverp)        ! CO2 9.4 micron band path length
1890    real(r8), intent(in) :: uco213(pcols,pverp)        ! CO2 9.4 micron band path length
1891    real(r8), intent(in) :: uco221(pcols,pverp)        ! CO2 10.4 micron band path length
1892    real(r8), intent(in) :: uco222(pcols,pverp)        ! CO2 10.4 micron band path length
1893    real(r8), intent(in) :: uco223(pcols,pverp)        ! CO2 10.4 micron band path length
1894    real(r8), intent(in) :: uptype(pcols,pverp)        ! continuum path length
1895    real(r8), intent(in) :: bn2o0(pcols,pverp)         ! pressure factor for n2o
1896    real(r8), intent(in) :: bn2o1(pcols,pverp)         ! pressure factor for n2o
1897    real(r8), intent(in) :: bch4(pcols,pverp)          ! pressure factor for ch4
1898    real(r8), intent(in) :: abplnk1(14,pcols,pverp)    ! non-nearest layer Planck factor
1899    real(r8), intent(in) :: abplnk2(14,pcols,pverp)    ! nearest layer factor
1900 !
1901 ! Output arguments
1902 !
1903    real(r8), intent(out) :: abstot(pcols,pverp,pverp) ! Total absorptivity
1904    real(r8), intent(out) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
1905 !
1906 !---------------------------Local variables-----------------------------
1907 !
1908    integer i                   ! Longitude index
1909    integer k                   ! Level index
1910    integer k1                  ! Level index
1911    integer k2                  ! Level index
1912    integer kn                  ! Nearest level index
1913    integer wvl                 ! Wavelength index
1914
1915    real(r8) abstrc(pcols)              ! total trace gas absorptivity
1916    real(r8) bplnk(14,pcols,4)          ! Planck functions for sub-divided layers
1917    real(r8) pnew(pcols)        ! Effective pressure for H2O vapor linewidth
1918    real(r8) pnewb(nbands)      ! Effective pressure for h2o linewidth w/
1919                                !    Hulst-Curtis-Godson correction for
1920                                !    each band
1921    real(r8) u(pcols)           ! Pressure weighted H2O path length
1922    real(r8) ub(nbands)         ! Pressure weighted H2O path length with
1923                                !    Hulst-Curtis-Godson correction for
1924                                !    each band
1925    real(r8) tbar(pcols,4)      ! Mean layer temperature
1926    real(r8) emm(pcols,4)       ! Mean co2 emissivity
1927    real(r8) o3emm(pcols,4)     ! Mean o3 emissivity
1928    real(r8) o3bndi             ! Ozone band parameter
1929    real(r8) temh2o(pcols,4)    ! Mean layer temperature equivalent to tbar
1930    real(r8) k21                ! Exponential coefficient used to calculate
1931 !                              !  rotation band transmissvty in the 650-800
1932 !                              !  cm-1 region (tr1)
1933    real(r8) k22                ! Exponential coefficient used to calculate
1934 !                              !  rotation band transmissvty in the 500-650
1935 !                              !  cm-1 region (tr2)
1936    real(r8) uc1(pcols)         ! H2o continuum pathlength in 500-800 cm-1
1937    real(r8) to3h2o(pcols)      ! H2o trnsmsn for overlap with o3
1938    real(r8) pi                 ! For co2 absorptivity computation
1939    real(r8) sqti(pcols)        ! Used to store sqrt of mean temperature
1940    real(r8) et                 ! Co2 hot band factor
1941    real(r8) et2                ! Co2 hot band factor squared
1942    real(r8) et4                ! Co2 hot band factor to fourth power
1943    real(r8) omet               ! Co2 stimulated emission term
1944    real(r8) f1co2              ! Co2 central band factor
1945    real(r8) f2co2(pcols)       ! Co2 weak band factor
1946    real(r8) f3co2(pcols)       ! Co2 weak band factor
1947    real(r8) t1co2(pcols)       ! Overlap factr weak bands on strong band
1948    real(r8) sqwp               ! Sqrt of co2 pathlength
1949    real(r8) f1sqwp(pcols)      ! Main co2 band factor
1950    real(r8) oneme              ! Co2 stimulated emission term
1951    real(r8) alphat             ! Part of the co2 stimulated emission term
1952    real(r8) wco2               ! Constants used to define co2 pathlength
1953    real(r8) posqt              ! Effective pressure for co2 line width
1954    real(r8) u7(pcols)          ! Co2 hot band path length
1955    real(r8) u8                 ! Co2 hot band path length
1956    real(r8) u9                 ! Co2 hot band path length
1957    real(r8) u13                ! Co2 hot band path length
1958    real(r8) rbeta7(pcols)      ! Inverse of co2 hot band line width par
1959    real(r8) rbeta8             ! Inverse of co2 hot band line width par
1960    real(r8) rbeta9             ! Inverse of co2 hot band line width par
1961    real(r8) rbeta13            ! Inverse of co2 hot band line width par
1962    real(r8) tpatha             ! For absorptivity computation
1963    real(r8) abso(pcols,4)      ! Absorptivity for various gases/bands
1964    real(r8) dtx(pcols)         ! Planck temperature minus 250 K
1965    real(r8) dty(pcols)         ! Path temperature minus 250 K
1966    real(r8) term7(pcols,2)     ! Kl_inf(i) in eq(r8) of table A3a of R&D
1967    real(r8) term8(pcols,2)     ! Delta kl_inf(i) in eq(r8)
1968    real(r8) tr1                ! Eqn(6) in table A2 of R&D for 650-800
1969    real(r8) tr10(pcols)        ! Eqn (6) times eq(4) in table A2
1970 !                              !  of R&D for 500-650 cm-1 region
1971    real(r8) tr2                ! Eqn(6) in table A2 of R&D for 500-650
1972    real(r8) tr5                ! Eqn(4) in table A2 of R&D for 650-800
1973    real(r8) tr6                ! Eqn(4) in table A2 of R&D for 500-650
1974    real(r8) tr9(pcols)         ! Equation (6) times eq(4) in table A2
1975 !                              !  of R&D for 650-800 cm-1 region
1976    real(r8) sqrtu(pcols)       ! Sqrt of pressure weighted h20 pathlength
1977    real(r8) fwk(pcols)         ! Equation(33) in R&D far wing correction
1978    real(r8) fwku(pcols)        ! GU term in eqs(1) and (6) in table A2
1979    real(r8) to3co2(pcols)      ! P weighted temp in ozone band model
1980    real(r8) dpnm(pcols)        ! Pressure difference between two levels
1981    real(r8) pnmsq(pcols,pverp) ! Pressure squared
1982    real(r8) dw(pcols)          ! Amount of h2o between two levels
1983    real(r8) uinpl(pcols,4)     ! Nearest layer subdivision factor
1984    real(r8) winpl(pcols,4)     ! Nearest layer subdivision factor
1985    real(r8) zinpl(pcols,4)     ! Nearest layer subdivision factor
1986    real(r8) pinpl(pcols,4)     ! Nearest layer subdivision factor
1987    real(r8) dplh2o(pcols)      ! Difference in press weighted h2o amount
1988    real(r8) r293               ! 1/293
1989    real(r8) r250               ! 1/250
1990    real(r8) r3205              ! Line width factor for o3 (see R&Di)
1991    real(r8) r300               ! 1/300
1992    real(r8) rsslp              ! Reciprocal of sea level pressure
1993    real(r8) r2sslp             ! 1/2 of rsslp
1994    real(r8) ds2c               ! Y in eq(7) in table A2 of R&D
1995    real(r8)  dplos             ! Ozone pathlength eq(A2) in R&Di
1996    real(r8) dplol              ! Presure weighted ozone pathlength
1997    real(r8) tlocal             ! Local interface temperature
1998    real(r8) beta               ! Ozone mean line parameter eq(A3) in R&Di
1999 !                               (includes Voigt line correction factor)
2000    real(r8) rphat              ! Effective pressure for ozone beta
2001    real(r8) tcrfac             ! Ozone temperature factor table 1 R&Di
2002    real(r8) tmp1               ! Ozone band factor see eq(A1) in R&Di
2003    real(r8) u1                 ! Effective ozone pathlength eq(A2) in R&Di
2004    real(r8) realnu             ! 1/beta factor in ozone band model eq(A1)
2005    real(r8) tmp2               ! Ozone band factor see eq(A1) in R&Di
2006    real(r8) u2                 ! Effective ozone pathlength eq(A2) in R&Di
2007    real(r8) rsqti              ! Reciprocal of sqrt of path temperature
2008    real(r8) tpath              ! Path temperature used in co2 band model
2009    real(r8) tmp3               ! Weak band factor see K&B
2010    real(r8) rdpnmsq            ! Reciprocal of difference in press^2
2011    real(r8) rdpnm              ! Reciprocal of difference in press
2012    real(r8) p1                 ! Mean pressure factor
2013    real(r8) p2                 ! Mean pressure factor
2014    real(r8) dtym10             ! T - 260 used in eq(9) and (10) table A3a
2015    real(r8) dplco2             ! Co2 path length
2016    real(r8) te                 ! A_0 T factor in ozone model table 1 of R&Di
2017    real(r8) denom              ! Denominator in eq(r8) of table A3a of R&D
2018    real(r8) th2o(pcols)        ! transmission due to H2O
2019    real(r8) tco2(pcols)        ! transmission due to CO2
2020    real(r8) to3(pcols)         ! transmission due to O3
2021 !
2022 ! Transmission terms for various spectral intervals:
2023 !
2024    real(r8) trab2(pcols)       ! H2o   500 -  800 cm-1
2025    real(r8) absbnd             ! Proportional to co2 band absorptance
2026    real(r8) dbvtit(pcols,pverp)! Intrfc drvtv plnck fnctn for o3
2027    real(r8) dbvtly(pcols,pver) ! Level drvtv plnck fnctn for o3
2028 !
2029 ! Variables for Collins/Hackney/Edwards (C/H/E) &
2030 !       Collins/Lee-Taylor/Edwards (C/LT/E) H2O parameterization
2031
2032 !
2033 ! Notation:
2034 ! U   = integral (P/P_0 dW)  eq. 15 in Ramanathan/Downey 1986
2035 ! P   = atmospheric pressure
2036 ! P_0 = reference atmospheric pressure
2037 ! W   = precipitable water path
2038 ! T_e = emission temperature
2039 ! T_p = path temperature
2040 ! RH  = path relative humidity
2041 !
2042    real(r8) fa               ! asymptotic value of abs. as U->infinity
2043    real(r8) a_star           ! normalized absorptivity for non-window
2044    real(r8) l_star           ! interpolated line transmission
2045    real(r8) c_star           ! interpolated continuum transmission
2046
2047    real(r8) te1              ! emission temperature
2048    real(r8) te2              ! te^2
2049    real(r8) te3              ! te^3
2050    real(r8) te4              ! te^4
2051    real(r8) te5              ! te^5
2052
2053    real(r8) log_u            ! log base 10 of U
2054    real(r8) log_uc           ! log base 10 of H2O continuum path
2055    real(r8) log_p            ! log base 10 of P
2056    real(r8) t_p              ! T_p
2057    real(r8) t_e              ! T_e (offset by T_p)
2058
2059    integer iu                ! index for log10(U)
2060    integer iu1               ! iu + 1
2061    integer iuc               ! index for log10(H2O continuum path)
2062    integer iuc1              ! iuc + 1
2063    integer ip                ! index for log10(P)
2064    integer ip1               ! ip + 1
2065    integer itp               ! index for T_p
2066    integer itp1              ! itp + 1
2067    integer ite               ! index for T_e
2068    integer ite1              ! ite + 1
2069    integer irh               ! index for RH
2070    integer irh1              ! irh + 1
2071
2072    real(r8) dvar             ! normalized variation in T_p/T_e/P/U
2073    real(r8) uvar             ! U * diffusivity factor
2074    real(r8) uscl             ! factor for lineary scaling as U->0
2075
2076    real(r8) wu               ! weight for U
2077    real(r8) wu1              ! 1 - wu
2078    real(r8) wuc              ! weight for H2O continuum path
2079    real(r8) wuc1             ! 1 - wuc
2080    real(r8) wp               ! weight for P
2081    real(r8) wp1              ! 1 - wp
2082    real(r8) wtp              ! weight for T_p
2083    real(r8) wtp1             ! 1 - wtp
2084    real(r8) wte              ! weight for T_e
2085    real(r8) wte1             ! 1 - wte
2086    real(r8) wrh              ! weight for RH
2087    real(r8) wrh1             ! 1 - wrh
2088
2089    real(r8) w_0_0_           ! weight for Tp/Te combination
2090    real(r8) w_0_1_           ! weight for Tp/Te combination
2091    real(r8) w_1_0_           ! weight for Tp/Te combination
2092    real(r8) w_1_1_           ! weight for Tp/Te combination
2093
2094    real(r8) w_0_00           ! weight for Tp/Te/RH combination
2095    real(r8) w_0_01           ! weight for Tp/Te/RH combination
2096    real(r8) w_0_10           ! weight for Tp/Te/RH combination
2097    real(r8) w_0_11           ! weight for Tp/Te/RH combination
2098    real(r8) w_1_00           ! weight for Tp/Te/RH combination
2099    real(r8) w_1_01           ! weight for Tp/Te/RH combination
2100    real(r8) w_1_10           ! weight for Tp/Te/RH combination
2101    real(r8) w_1_11           ! weight for Tp/Te/RH combination
2102
2103    real(r8) w00_00           ! weight for P/Tp/Te/RH combination
2104    real(r8) w00_01           ! weight for P/Tp/Te/RH combination
2105    real(r8) w00_10           ! weight for P/Tp/Te/RH combination
2106    real(r8) w00_11           ! weight for P/Tp/Te/RH combination
2107    real(r8) w01_00           ! weight for P/Tp/Te/RH combination
2108    real(r8) w01_01           ! weight for P/Tp/Te/RH combination
2109    real(r8) w01_10           ! weight for P/Tp/Te/RH combination
2110    real(r8) w01_11           ! weight for P/Tp/Te/RH combination
2111    real(r8) w10_00           ! weight for P/Tp/Te/RH combination
2112    real(r8) w10_01           ! weight for P/Tp/Te/RH combination
2113    real(r8) w10_10           ! weight for P/Tp/Te/RH combination
2114    real(r8) w10_11           ! weight for P/Tp/Te/RH combination
2115    real(r8) w11_00           ! weight for P/Tp/Te/RH combination
2116    real(r8) w11_01           ! weight for P/Tp/Te/RH combination
2117    real(r8) w11_10           ! weight for P/Tp/Te/RH combination
2118    real(r8) w11_11           ! weight for P/Tp/Te/RH combination
2119
2120    integer ib                ! spectral interval:
2121                              !   1 = 0-800 cm^-1 and 1200-2200 cm^-1
2122                              !   2 = 800-1200 cm^-1
2123
2124
2125    real(r8) pch2o            ! H2O continuum path
2126    real(r8) fch2o            ! temp. factor for continuum
2127    real(r8) uch2o            ! U corresponding to H2O cont. path (window)
2128
2129    real(r8) fdif             ! secant(zenith angle) for diffusivity approx.
2130
2131    real(r8) sslp_mks         ! Sea-level pressure in MKS units
2132    real(r8) esx              ! saturation vapor pressure returned by vqsatd
2133    real(r8) qsx              ! saturation mixing ratio returned by vqsatd
2134    real(r8) pnew_mks         ! pnew in MKS units
2135    real(r8) q_path           ! effective specific humidity along path
2136    real(r8) rh_path          ! effective relative humidity along path
2137    real(r8) omeps            ! 1 - epsilo
2138
2139    integer  iest             ! index in estblh2o
2140
2141       integer bnd_idx        ! LW band index
2142       real(r8) aer_pth_dlt   ! [kg m-2] STRAER path between interface levels k1 and k2
2143       real(r8) aer_pth_ngh(pcols)
2144                              ! [kg m-2] STRAER path between neighboring layers
2145       real(r8) odap_aer_ttl  ! [fraction] Total path absorption optical depth
2146       real(r8) aer_trn_ngh(pcols,bnd_nbr_LW)
2147                              ! [fraction] Total transmission between
2148                              !            nearest neighbor sub-levels
2149 !
2150 !--------------------------Statement function---------------------------
2151 !
2152    real(r8) dbvt,t             ! Planck fnctn tmp derivative for o3
2153 !
2154    dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
2155       (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
2156 !
2157 !
2158 !-----------------------------------------------------------------------
2159 !
2160 ! Initialize
2161 !
2162    do k2=1,ntoplw-1
2163       do k1=1,ntoplw-1
2164          abstot(:,k1,k2) = inf    ! set unused portions for lf95 restart write
2165       end do
2166    end do
2167    do k2=1,4
2168       do k1=1,ntoplw-1
2169          absnxt(:,k1,k2) = inf    ! set unused portions for lf95 restart write
2170       end do
2171    end do
2172
2173    do k=ntoplw,pverp
2174       abstot(:,k,k) = inf         ! set unused portions for lf95 restart write
2175    end do
2176
2177    do k=ntoplw,pver
2178       do i=1,ncol
2179          dbvtly(i,k) = dbvt(tlayr(i,k+1))
2180          dbvtit(i,k) = dbvt(tint(i,k))
2181       end do
2182    end do
2183    do i=1,ncol
2184       dbvtit(i,pverp) = dbvt(tint(i,pverp))
2185    end do
2186 !
2187    r293    = 1./293.
2188    r250    = 1./250.
2189    r3205   = 1./.3205
2190    r300    = 1./300.
2191    rsslp   = 1./sslp
2192    r2sslp  = 1./(2.*sslp)
2193 !
2194 !Constants for computing U corresponding to H2O cont. path
2195 !
2196    fdif       = 1.66
2197    sslp_mks   = sslp / 10.0
2198    omeps      = 1.0 - epsilo
2199 !
2200 ! Non-adjacent layer absorptivity:
2201 !
2202 ! abso(i,1)     0 -  800 cm-1   h2o rotation band
2203 ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
2204 ! abso(i,2)   800 - 1200 cm-1   h2o window
2205 !
2206 ! Separation between rotation and vibration-rotation dropped, so
2207 !                only 2 slots needed for H2O absorptivity
2208 !
2209 ! 500-800 cm^-1 H2o continuum/line overlap already included
2210 !                in abso(i,1).  This used to be in abso(i,4)
2211 !
2212 ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
2213 ! abso(i,4)   co2 15  micrometer band system
2214 !
2215    do k=ntoplw,pverp
2216       do i=1,ncol
2217          pnmsq(i,k) = pnm(i,k)**2
2218          dtx(i) = tplnka(i,k) - 250.
2219       end do
2220    end do
2221 !
2222 ! Non-nearest layer level loops
2223 !
2224    do k1=pverp,ntoplw,-1
2225       do k2=pverp,ntoplw,-1
2226          if (k1 == k2) cycle
2227          do i=1,ncol
2228             dplh2o(i) = plh2o(i,k1) - plh2o(i,k2)
2229             u(i)      = abs(dplh2o(i))
2230             sqrtu(i)  = sqrt(u(i))
2231             ds2c      = abs(s2c(i,k1) - s2c(i,k2))
2232             dw(i)     = abs(w(i,k1) - w(i,k2))
2233             uc1(i)    = (ds2c + 1.7e-3*u(i))*(1. +  2.*ds2c)/(1. + 15.*ds2c)
2234             pch2o     = ds2c
2235             pnew(i)   = u(i)/dw(i)
2236             pnew_mks  = pnew(i) * sslp_mks
2237 !
2238 ! Changed effective path temperature to std. Curtis-Godson form
2239 !
2240             tpatha = abs(tcg(i,k1) - tcg(i,k2))/dw(i)
2241             t_p = min(max(tpatha, min_tp_h2o), max_tp_h2o)
2242             iest = floor(t_p) - min_tp_h2o
2243             esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
2244                  (t_p - min_tp_h2o - iest)
2245             qsx = epsilo * esx / (pnew_mks - omeps * esx)
2246 !
2247 ! Compute effective RH along path
2248 !
2249             q_path = dw(i) / abs(pnm(i,k1) - pnm(i,k2)) / rga
2250 !
2251 ! Calculate effective u, pnew for each band using
2252 !        Hulst-Curtis-Godson approximation:
2253 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
2254 !           2nd edition, Oxford University Press, 1989.
2255 ! Effective H2O path (w)
2256 !      eq. 6.24, p. 228
2257 ! Effective H2O path pressure (pnew = u/w):
2258 !      eq. 6.29, p. 228
2259 !
2260             ub(1) = abs(plh2ob(1,i,k1) - plh2ob(1,i,k2)) / psi(t_p,1)
2261             ub(2) = abs(plh2ob(2,i,k1) - plh2ob(2,i,k2)) / psi(t_p,2)
2262
2263             pnewb(1) = ub(1) / abs(wb(1,i,k1) - wb(1,i,k2)) * phi(t_p,1)
2264             pnewb(2) = ub(2) / abs(wb(2,i,k1) - wb(2,i,k2)) * phi(t_p,2)
2265
2266             dtx(i)      = tplnka(i,k2) - 250.
2267             dty(i)      = tpatha       - 250.
2268
2269             fwk(i)  = fwcoef + fwc1/(1. + fwc2*u(i))
2270             fwku(i) = fwk(i)*u(i)
2271 !
2272 ! Define variables for C/H/E (now C/LT/E) fit
2273 !
2274 ! abso(i,1)     0 -  800 cm-1   h2o rotation band
2275 ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
2276 ! abso(i,2)   800 - 1200 cm-1   h2o window
2277 !
2278 ! Separation between rotation and vibration-rotation dropped, so
2279 !                only 2 slots needed for H2O absorptivity
2280 !
2281 ! Notation:
2282 ! U   = integral (P/P_0 dW)
2283 ! P   = atmospheric pressure
2284 ! P_0 = reference atmospheric pressure
2285 ! W   = precipitable water path
2286 ! T_e = emission temperature
2287 ! T_p = path temperature
2288 ! RH  = path relative humidity
2289 !
2290 !
2291 ! Terms for asymptotic value of emissivity
2292 !
2293             te1  = tplnka(i,k2)
2294             te2  = te1 * te1
2295             te3  = te2 * te1
2296             te4  = te3 * te1
2297             te5  = te4 * te1
2298
2299 !
2300 !  Band-independent indices for lines and continuum tables
2301 !
2302             dvar = (t_p - min_tp_h2o) / dtp_h2o
2303             itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
2304             itp1 = itp + 1
2305             wtp = dvar - floor(dvar)
2306             wtp1 = 1.0 - wtp
2307
2308             t_e = min(max(tplnka(i,k2)-t_p, min_te_h2o), max_te_h2o)
2309             dvar = (t_e - min_te_h2o) / dte_h2o
2310             ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
2311             ite1 = ite + 1
2312             wte = dvar - floor(dvar)
2313             wte1 = 1.0 - wte
2314
2315             rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
2316             dvar = (rh_path - min_rh_h2o) / drh_h2o
2317             irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
2318             irh1 = irh + 1
2319             wrh = dvar - floor(dvar)
2320             wrh1 = 1.0 - wrh
2321
2322             w_0_0_ = wtp  * wte
2323             w_0_1_ = wtp  * wte1
2324             w_1_0_ = wtp1 * wte
2325             w_1_1_ = wtp1 * wte1
2326
2327             w_0_00 = w_0_0_ * wrh
2328             w_0_01 = w_0_0_ * wrh1
2329             w_0_10 = w_0_1_ * wrh
2330             w_0_11 = w_0_1_ * wrh1
2331             w_1_00 = w_1_0_ * wrh
2332             w_1_01 = w_1_0_ * wrh1
2333             w_1_10 = w_1_1_ * wrh
2334             w_1_11 = w_1_1_ * wrh1
2335
2336 !
2337 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
2338 !
2339 !    Assume foreign continuum dominates total H2O continuum in these bands
2340 !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
2341 !    Then the effective H2O path is just
2342 !         U_c = integral[ f(P) dW ]
2343 !    where
2344 !           W = water-vapor mass and
2345 !        f(P) = dependence of foreign continuum on pressure
2346 !             = P / sslp
2347 !    Then
2348 !         U_c = U (the same effective H2O path as for lines)
2349 !
2350 !
2351 ! Continuum terms for 800-1200 cm^-1
2352 !
2353 !    Assume self continuum dominates total H2O continuum for this band
2354 !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
2355 !    Then the effective H2O self-continuum path is
2356 !         U_c = integral[ h(e,T) dW ]                        (*eq. 1*)
2357 !    where
2358 !           W = water-vapor mass and
2359 !           e = partial pressure of H2O along path
2360 !           T = temperature along path
2361 !      h(e,T) = dependence of foreign continuum on e,T
2362 !             = e / sslp * f(T)
2363 !
2364 !    Replacing
2365 !           e =~ q * P / epsilo
2366 !           q = mixing ratio of H2O
2367 !     epsilo = 0.622
2368 !
2369 !    and using the definition
2370 !           U = integral [ (P / sslp) dW ]
2371 !             = (P / sslp) W                                 (homogeneous path)
2372 !
2373 !    the effective path length for the self continuum is
2374 !         U_c = (q / epsilo) f(T) U                         (*eq. 2*)
2375 !
2376 !    Once values of T, U, and q have been calculated for the inhomogeneous
2377 !        path, this sets U_c for the corresponding
2378 !        homogeneous atmosphere.  However, this need not equal the
2379 !        value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
2380 !        under consideration.
2381 !
2382 !    Solution: hold T and q constant, solve for U' that gives U_c' by
2383 !        inverting eq. (2):
2384 !
2385 !        U' = (U_c * epsilo) / (q * f(T))
2386 !
2387             fch2o = fh2oself(t_p)
2388             uch2o = (pch2o * epsilo) / (q_path * fch2o)
2389
2390 !
2391 ! Band-dependent indices for non-window
2392 !
2393             ib = 1
2394
2395             uvar = ub(ib) * fdif
2396             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
2397             dvar = (log_u - min_lu_h2o) / dlu_h2o
2398             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2399             iu1 = iu + 1
2400             wu = dvar - floor(dvar)
2401             wu1 = 1.0 - wu
2402
2403             log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
2404             dvar = (log_p - min_lp_h2o) / dlp_h2o
2405             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
2406             ip1 = ip + 1
2407             wp = dvar - floor(dvar)
2408             wp1 = 1.0 - wp
2409
2410             w00_00 = wp  * w_0_00
2411             w00_01 = wp  * w_0_01
2412             w00_10 = wp  * w_0_10
2413             w00_11 = wp  * w_0_11
2414             w01_00 = wp  * w_1_00
2415             w01_01 = wp  * w_1_01
2416             w01_10 = wp  * w_1_10
2417             w01_11 = wp  * w_1_11
2418             w10_00 = wp1 * w_0_00
2419             w10_01 = wp1 * w_0_01
2420             w10_10 = wp1 * w_0_10
2421             w10_11 = wp1 * w_0_11
2422             w11_00 = wp1 * w_1_00
2423             w11_01 = wp1 * w_1_01
2424             w11_10 = wp1 * w_1_10
2425             w11_11 = wp1 * w_1_11
2426 !
2427 ! Asymptotic value of absorptivity as U->infinity
2428 !
2429             fa = fat(1,ib) + &
2430                  fat(2,ib) * te1 + &
2431                  fat(3,ib) * te2 + &
2432                  fat(4,ib) * te3 + &
2433                  fat(5,ib) * te4 + &
2434                  fat(6,ib) * te5
2435
2436             a_star = &
2437                  ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
2438                  ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
2439                  ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
2440                  ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
2441                  ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
2442                  ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
2443                  ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
2444                  ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
2445                  ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
2446                  ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
2447                  ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
2448                  ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
2449                  ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
2450                  ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
2451                  ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
2452                  ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
2453                  ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
2454                  ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
2455                  ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
2456                  ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
2457                  ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
2458                  ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
2459                  ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
2460                  ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
2461                  ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
2462                  ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
2463                  ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
2464                  ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
2465                  ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
2466                  ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
2467                  ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
2468                  ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
2469             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
2470                                  aer_trn_ttl(i,k1,k2,ib)), &
2471                              0.0_r8), 1.0_r8)
2472 !
2473 ! Invoke linear limit for scaling wrt u below min_u_h2o
2474 !
2475             if (uvar < min_u_h2o) then
2476                uscl = uvar / min_u_h2o
2477                abso(i,ib) = abso(i,ib) * uscl
2478             endif
2479
2480 !
2481 ! Band-dependent indices for window
2482 !
2483             ib = 2
2484
2485             uvar = ub(ib) * fdif
2486             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
2487             dvar = (log_u - min_lu_h2o) / dlu_h2o
2488             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2489             iu1 = iu + 1
2490             wu = dvar - floor(dvar)
2491             wu1 = 1.0 - wu
2492
2493             log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
2494             dvar = (log_p - min_lp_h2o) / dlp_h2o
2495             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
2496             ip1 = ip + 1
2497             wp = dvar - floor(dvar)
2498             wp1 = 1.0 - wp
2499
2500             w00_00 = wp  * w_0_00
2501             w00_01 = wp  * w_0_01
2502             w00_10 = wp  * w_0_10
2503             w00_11 = wp  * w_0_11
2504             w01_00 = wp  * w_1_00
2505             w01_01 = wp  * w_1_01
2506             w01_10 = wp  * w_1_10
2507             w01_11 = wp  * w_1_11
2508             w10_00 = wp1 * w_0_00
2509             w10_01 = wp1 * w_0_01
2510             w10_10 = wp1 * w_0_10
2511             w10_11 = wp1 * w_0_11
2512             w11_00 = wp1 * w_1_00
2513             w11_01 = wp1 * w_1_01
2514             w11_10 = wp1 * w_1_10
2515             w11_11 = wp1 * w_1_11
2516
2517             log_uc  = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
2518             dvar = (log_uc - min_lu_h2o) / dlu_h2o
2519             iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2520             iuc1 = iuc + 1
2521             wuc = dvar - floor(dvar)
2522             wuc1 = 1.0 - wuc
2523 !
2524 ! Asymptotic value of absorptivity as U->infinity
2525 !
2526             fa = fat(1,ib) + &
2527                  fat(2,ib) * te1 + &
2528                  fat(3,ib) * te2 + &
2529                  fat(4,ib) * te3 + &
2530                  fat(5,ib) * te4 + &
2531                  fat(6,ib) * te5
2532
2533             l_star = &
2534                  ln_ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
2535                  ln_ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
2536                  ln_ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
2537                  ln_ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
2538                  ln_ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
2539                  ln_ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
2540                  ln_ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
2541                  ln_ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
2542                  ln_ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
2543                  ln_ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
2544                  ln_ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
2545                  ln_ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
2546                  ln_ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
2547                  ln_ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
2548                  ln_ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
2549                  ln_ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
2550                  ln_ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
2551                  ln_ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
2552                  ln_ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
2553                  ln_ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
2554                  ln_ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
2555                  ln_ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
2556                  ln_ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
2557                  ln_ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
2558                  ln_ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
2559                  ln_ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
2560                  ln_ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
2561                  ln_ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
2562                  ln_ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
2563                  ln_ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
2564                  ln_ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
2565                  ln_ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
2566
2567             c_star = &
2568                  cn_ah2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
2569                  cn_ah2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
2570                  cn_ah2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
2571                  cn_ah2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
2572                  cn_ah2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc  + &
2573                  cn_ah2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc  + &
2574                  cn_ah2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc  + &
2575                  cn_ah2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc  + &
2576                  cn_ah2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
2577                  cn_ah2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
2578                  cn_ah2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
2579                  cn_ah2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
2580                  cn_ah2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc  + &
2581                  cn_ah2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc  + &
2582                  cn_ah2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc  + &
2583                  cn_ah2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc  + &
2584                  cn_ah2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
2585                  cn_ah2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
2586                  cn_ah2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
2587                  cn_ah2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
2588                  cn_ah2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc  + &
2589                  cn_ah2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc  + &
2590                  cn_ah2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc  + &
2591                  cn_ah2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc  + &
2592                  cn_ah2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
2593                  cn_ah2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
2594                  cn_ah2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
2595                  cn_ah2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
2596                  cn_ah2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc  + &
2597                  cn_ah2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc  + &
2598                  cn_ah2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc  + &
2599                  cn_ah2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
2600             abso(i,ib) = min(max(fa * (1.0 - l_star * c_star * &
2601                                  aer_trn_ttl(i,k1,k2,ib)), &
2602                              0.0_r8), 1.0_r8)
2603 !
2604 ! Invoke linear limit for scaling wrt u below min_u_h2o
2605 !
2606             if (uvar < min_u_h2o) then
2607                uscl = uvar / min_u_h2o
2608                abso(i,ib) = abso(i,ib) * uscl
2609             endif
2610
2611          end do
2612 !
2613 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
2614 !
2615          do i=1,ncol
2616             term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
2617             term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
2618             term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
2619             term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
2620          end do
2621 !
2622 ! 500 -  800 cm-1   h2o rotation band overlap with co2
2623 !
2624          do i=1,ncol
2625             k21    = term7(i,1) + term8(i,1)/ &
2626                (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrtu(i))
2627             k22    = term7(i,2) + term8(i,2)/ &
2628                (1. + (c28 + c29*(dty(i)-10.))*sqrtu(i))
2629             tr1    = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
2630             tr2    = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
2631             tr1=tr1*aer_trn_ttl(i,k1,k2,idx_LW_0650_0800)
2632 !                                          ! H2O line+STRAER trn 650--800 cm-1
2633             tr2=tr2*aer_trn_ttl(i,k1,k2,idx_LW_0500_0650)
2634 !                                          ! H2O line+STRAER trn 500--650 cm-1
2635             tr5    = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
2636             tr6    = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
2637             tr9(i)   = tr1*tr5
2638             tr10(i)  = tr2*tr6
2639             th2o(i) = tr10(i)
2640             trab2(i) = 0.65*tr9(i) + 0.35*tr10(i)
2641          end do
2642          if (k2 < k1) then
2643             do i=1,ncol
2644                to3h2o(i) = h2otr(i,k1)/h2otr(i,k2)
2645             end do
2646          else
2647             do i=1,ncol
2648                to3h2o(i) = h2otr(i,k2)/h2otr(i,k1)
2649             end do
2650          end if
2651 !
2652 ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
2653 !
2654          do i=1,ncol
2655             dpnm(i)  = pnm(i,k1) - pnm(i,k2)
2656             to3co2(i) = (pnm(i,k1)*co2t(i,k1) - pnm(i,k2)*co2t(i,k2))/dpnm(i)
2657             te       = (to3co2(i)*r293)**.7
2658             dplos    = plos(i,k1) - plos(i,k2)
2659             dplol    = plol(i,k1) - plol(i,k2)
2660             u1       = 18.29*abs(dplos)/te
2661             u2       = .5649*abs(dplos)/te
2662             rphat    = dplol/dplos
2663             tlocal   = tint(i,k2)
2664             tcrfac   = sqrt(tlocal*r250)*te
2665             beta     = r3205*(rphat + dpfo3*tcrfac)
2666             realnu   = te/beta
2667             tmp1     = u1/sqrt(4. + u1*(1. + realnu))
2668             tmp2     = u2/sqrt(4. + u2*(1. + realnu))
2669             o3bndi    = 74.*te*log(1. + tmp1 + tmp2)
2670             abso(i,3) = o3bndi*to3h2o(i)*dbvtit(i,k2)
2671             to3(i)   = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
2672          end do
2673 !
2674 ! abso(i,4)      co2 15  micrometer band system
2675 !
2676          do i=1,ncol
2677             sqwp      = sqrt(abs(plco2(i,k1) - plco2(i,k2)))
2678             et        = exp(-480./to3co2(i))
2679             sqti(i)   = sqrt(to3co2(i))
2680             rsqti     = 1./sqti(i)
2681             et2       = et*et
2682             et4       = et2*et2
2683             omet      = 1. - 1.5*et2
2684             f1co2     = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
2685             f1sqwp(i) = f1co2*sqwp
2686             t1co2(i)  = 1./(1. + (245.18*omet*sqwp*rsqti))
2687             oneme     = 1. - et2
2688             alphat    = oneme**3*rsqti
2689             pi        = abs(dpnm(i))
2690             wco2      =  2.5221*co2vmr*pi*rga
2691             u7(i)     =  4.9411e4*alphat*et2*wco2
2692             u8        =  3.9744e4*alphat*et4*wco2
2693             u9        =  1.0447e5*alphat*et4*et2*wco2
2694             u13       = 2.8388e3*alphat*et4*wco2
2695             tpath     = to3co2(i)
2696             tlocal    = tint(i,k2)
2697             tcrfac    = sqrt(tlocal*r250*tpath*r300)
2698             posqt     = ((pnm(i,k2) + pnm(i,k1))*r2sslp + dpfco2*tcrfac)*rsqti
2699             rbeta7(i) = 1./(5.3228*posqt)
2700             rbeta8    = 1./(10.6576*posqt)
2701             rbeta9    = rbeta7(i)
2702             rbeta13   = rbeta9
2703             f2co2(i)  = (u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))) + &
2704                (u8   /sqrt(4. + u8*(1. + rbeta8))) + &
2705                (u9   /sqrt(4. + u9*(1. + rbeta9)))
2706             f3co2(i)  = u13/sqrt(4. + u13*(1. + rbeta13))
2707          end do
2708          if (k2 >= k1) then
2709             do i=1,ncol
2710                sqti(i) = sqrt(tlayr(i,k2))
2711             end do
2712          end if
2713 !
2714          do i=1,ncol
2715             tmp1      = log(1. + f1sqwp(i))
2716             tmp2      = log(1. + f2co2(i))
2717             tmp3      = log(1. + f3co2(i))
2718             absbnd    = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
2719             abso(i,4) = trab2(i)*co2em(i,k2)*absbnd
2720             tco2(i)   = 1./(1.0+10.0*(u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i)))))
2721          end do
2722 !
2723 ! Calculate absorptivity due to trace gases, abstrc
2724 !
2725          call trcab( lchnk   ,ncol    ,pcols, pverp,                   &
2726             k1      ,k2      ,ucfc11  ,ucfc12  ,un2o0   , &
2727             un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
2728             uco221  ,uco222  ,uco223  ,bn2o0   ,bn2o1   , &
2729             bch4    ,to3co2  ,pnm     ,dw      ,pnew    , &
2730             s2c     ,uptype  ,u       ,abplnk1 ,tco2    , &
2731             th2o    ,to3     ,abstrc  , &
2732             aer_trn_ttl)
2733 !
2734 ! Sum total absorptivity
2735 !
2736          do i=1,ncol
2737             abstot(i,k1,k2) = abso(i,1) + abso(i,2) + &
2738                abso(i,3) + abso(i,4) + abstrc(i)
2739          end do
2740       end do ! do k2 =
2741    end do ! do k1 =
2742 !
2743 ! Adjacent layer absorptivity:
2744 !
2745 ! abso(i,1)     0 -  800 cm-1   h2o rotation band
2746 ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
2747 ! abso(i,2)   800 - 1200 cm-1   h2o window
2748 !
2749 ! Separation between rotation and vibration-rotation dropped, so
2750 !                only 2 slots needed for H2O absorptivity
2751 !
2752 ! 500-800 cm^-1 H2o continuum/line overlap already included
2753 !                in abso(i,1).  This used to be in abso(i,4)
2754 !
2755 ! abso(i,3)   o3  9.6 micrometer band (nu3 and nu1 bands)
2756 ! abso(i,4)   co2 15  micrometer band system
2757 !
2758 ! Nearest layer level loop
2759 !
2760    do k2=pver,ntoplw,-1
2761       do i=1,ncol
2762          tbar(i,1)   = 0.5*(tint(i,k2+1) + tlayr(i,k2+1))
2763          emm(i,1)    = 0.5*(co2em(i,k2+1) + co2eml(i,k2))
2764          tbar(i,2)   = 0.5*(tlayr(i,k2+1) + tint(i,k2))
2765          emm(i,2)    = 0.5*(co2em(i,k2) + co2eml(i,k2))
2766          tbar(i,3)   = 0.5*(tbar(i,2) + tbar(i,1))
2767          emm(i,3)    = emm(i,1)
2768          tbar(i,4)   = tbar(i,3)
2769          emm(i,4)    = emm(i,2)
2770          o3emm(i,1)  = 0.5*(dbvtit(i,k2+1) + dbvtly(i,k2))
2771          o3emm(i,2)  = 0.5*(dbvtit(i,k2) + dbvtly(i,k2))
2772          o3emm(i,3)  = o3emm(i,1)
2773          o3emm(i,4)  = o3emm(i,2)
2774          temh2o(i,1) = tbar(i,1)
2775          temh2o(i,2) = tbar(i,2)
2776          temh2o(i,3) = tbar(i,1)
2777          temh2o(i,4) = tbar(i,2)
2778          dpnm(i)     = pnm(i,k2+1) - pnm(i,k2)
2779       end do
2780 !
2781 !  Weighted Planck functions for trace gases
2782 !
2783       do wvl = 1,14
2784          do i = 1,ncol
2785             bplnk(wvl,i,1) = 0.5*(abplnk1(wvl,i,k2+1) + abplnk2(wvl,i,k2))
2786             bplnk(wvl,i,2) = 0.5*(abplnk1(wvl,i,k2) + abplnk2(wvl,i,k2))
2787             bplnk(wvl,i,3) = bplnk(wvl,i,1)
2788             bplnk(wvl,i,4) = bplnk(wvl,i,2)
2789          end do
2790       end do
2791
2792       do i=1,ncol
2793          rdpnmsq    = 1./(pnmsq(i,k2+1) - pnmsq(i,k2))
2794          rdpnm      = 1./dpnm(i)
2795          p1         = .5*(pbr(i,k2) + pnm(i,k2+1))
2796          p2         = .5*(pbr(i,k2) + pnm(i,k2  ))
2797          uinpl(i,1) =  (pnmsq(i,k2+1) - p1**2)*rdpnmsq
2798          uinpl(i,2) = -(pnmsq(i,k2  ) - p2**2)*rdpnmsq
2799          uinpl(i,3) = -(pnmsq(i,k2  ) - p1**2)*rdpnmsq
2800          uinpl(i,4) =  (pnmsq(i,k2+1) - p2**2)*rdpnmsq
2801          winpl(i,1) = (.5*( pnm(i,k2+1) - pbr(i,k2)))*rdpnm
2802          winpl(i,2) = (.5*(-pnm(i,k2  ) + pbr(i,k2)))*rdpnm
2803          winpl(i,3) = (.5*( pnm(i,k2+1) + pbr(i,k2)) - pnm(i,k2  ))*rdpnm
2804          winpl(i,4) = (.5*(-pnm(i,k2  ) - pbr(i,k2)) + pnm(i,k2+1))*rdpnm
2805          tmp1       = 1./(piln(i,k2+1) - piln(i,k2))
2806          tmp2       = piln(i,k2+1) - pmln(i,k2)
2807          tmp3       = piln(i,k2  ) - pmln(i,k2)
2808          zinpl(i,1) = (.5*tmp2          )*tmp1
2809          zinpl(i,2) = (        - .5*tmp3)*tmp1
2810          zinpl(i,3) = (.5*tmp2 -    tmp3)*tmp1
2811          zinpl(i,4) = (   tmp2 - .5*tmp3)*tmp1
2812          pinpl(i,1) = 0.5*(p1 + pnm(i,k2+1))
2813          pinpl(i,2) = 0.5*(p2 + pnm(i,k2  ))
2814          pinpl(i,3) = 0.5*(p1 + pnm(i,k2  ))
2815          pinpl(i,4) = 0.5*(p2 + pnm(i,k2+1))
2816          if(strat_volcanic) then
2817            aer_pth_ngh(i) = abs(aer_mpp(i,k2)-aer_mpp(i,k2+1))
2818          endif
2819       end do
2820       do kn=1,4
2821          do i=1,ncol
2822             u(i)     = uinpl(i,kn)*abs(plh2o(i,k2) - plh2o(i,k2+1))
2823             sqrtu(i) = sqrt(u(i))
2824             dw(i)    = abs(w(i,k2) - w(i,k2+1))
2825             pnew(i)  = u(i)/(winpl(i,kn)*dw(i))
2826             pnew_mks  = pnew(i) * sslp_mks
2827             t_p = min(max(tbar(i,kn), min_tp_h2o), max_tp_h2o)
2828             iest = floor(t_p) - min_tp_h2o
2829             esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
2830                  (t_p - min_tp_h2o - iest)
2831             qsx = epsilo * esx / (pnew_mks - omeps * esx)
2832             q_path = dw(i) / ABS(dpnm(i)) / rga
2833
2834             ds2c     = abs(s2c(i,k2) - s2c(i,k2+1))
2835             uc1(i)   = uinpl(i,kn)*ds2c
2836             pch2o    = uc1(i)
2837             uc1(i)   = (uc1(i) + 1.7e-3*u(i))*(1. +  2.*uc1(i))/(1. + 15.*uc1(i))
2838             dtx(i)      = temh2o(i,kn) - 250.
2839             dty(i)      = tbar(i,kn) - 250.
2840
2841             fwk(i)    = fwcoef + fwc1/(1. + fwc2*u(i))
2842             fwku(i)   = fwk(i)*u(i)
2843
2844             if(strat_volcanic) then
2845               aer_pth_dlt=uinpl(i,kn)*aer_pth_ngh(i)
2846
2847               do bnd_idx=1,bnd_nbr_LW
2848                  odap_aer_ttl=abs_cff_mss_aer(bnd_idx) * aer_pth_dlt
2849                  aer_trn_ngh(i,bnd_idx)=exp(-fdif * odap_aer_ttl)
2850               end do
2851             else
2852               aer_trn_ngh(i,:) = 1.0
2853             endif
2854
2855 !
2856 ! Define variables for C/H/E (now C/LT/E) fit
2857 !
2858 ! abso(i,1)     0 -  800 cm-1   h2o rotation band
2859 ! abso(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
2860 ! abso(i,2)   800 - 1200 cm-1   h2o window
2861 !
2862 ! Separation between rotation and vibration-rotation dropped, so
2863 !                only 2 slots needed for H2O absorptivity
2864 !
2865 ! Notation:
2866 ! U   = integral (P/P_0 dW)
2867 ! P   = atmospheric pressure
2868 ! P_0 = reference atmospheric pressure
2869 ! W   = precipitable water path
2870 ! T_e = emission temperature
2871 ! T_p = path temperature
2872 ! RH  = path relative humidity
2873 !
2874 !
2875 ! Terms for asymptotic value of emissivity
2876 !
2877             te1  = temh2o(i,kn)
2878             te2  = te1 * te1
2879             te3  = te2 * te1
2880             te4  = te3 * te1
2881             te5  = te4 * te1
2882
2883 !
2884 ! Indices for lines and continuum tables
2885 ! Note: because we are dealing with the nearest layer,
2886 !       the Hulst-Curtis-Godson corrections
2887 !       for inhomogeneous paths are not applied.
2888 !
2889             uvar = u(i)*fdif
2890             log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
2891             dvar = (log_u - min_lu_h2o) / dlu_h2o
2892             iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
2893             iu1 = iu + 1
2894             wu = dvar - floor(dvar)
2895             wu1 = 1.0 - wu
2896
2897             log_p  = min(log10(max(pnew(i), min_p_h2o)), max_lp_h2o)
2898             dvar = (log_p - min_lp_h2o) / dlp_h2o
2899             ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
2900             ip1 = ip + 1
2901             wp = dvar - floor(dvar)
2902             wp1 = 1.0 - wp
2903
2904             dvar = (t_p - min_tp_h2o) / dtp_h2o
2905             itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
2906             itp1 = itp + 1
2907             wtp = dvar - floor(dvar)
2908             wtp1 = 1.0 - wtp
2909
2910             t_e = min(max(temh2o(i,kn)-t_p,min_te_h2o),max_te_h2o)
2911             dvar = (t_e - min_te_h2o) / dte_h2o
2912             ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
2913             ite1 = ite + 1
2914             wte = dvar - floor(dvar)
2915             wte1 = 1.0 - wte
2916
2917             rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
2918             dvar = (rh_path - min_rh_h2o) / drh_h2o
2919             irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
2920             irh1 = irh + 1
2921             wrh = dvar - floor(dvar)
2922             wrh1 = 1.0 - wrh
2923
2924             w_0_0_ = wtp  * wte
2925             w_0_1_ = wtp  * wte1
2926             w_1_0_ = wtp1 * wte
2927             w_1_1_ = wtp1 * wte1
2928
2929             w_0_00 = w_0_0_ * wrh
2930             w_0_01 = w_0_0_ * wrh1
2931             w_0_10 = w_0_1_ * wrh
2932             w_0_11 = w_0_1_ * wrh1
2933             w_1_00 = w_1_0_ * wrh
2934             w_1_01 = w_1_0_ * wrh1
2935             w_1_10 = w_1_1_ * wrh
2936             w_1_11 = w_1_1_ * wrh1
2937
2938             w00_00 = wp  * w_0_00
2939             w00_01 = wp  * w_0_01
2940             w00_10 = wp  * w_0_10
2941             w00_11 = wp  * w_0_11
2942             w01_00 = wp  * w_1_00
2943             w01_01 = wp  * w_1_01
2944             w01_10 = wp  * w_1_10
2945             w01_11 = wp  * w_1_11
2946             w10_00 = wp1 * w_0_00
2947             w10_01 = wp1 * w_0_01
2948             w10_10 = wp1 * w_0_10
2949             w10_11 = wp1 * w_0_11
2950             w11_00 = wp1 * w_1_00
2951             w11_01 = wp1 * w_1_01
2952             w11_10 = wp1 * w_1_10
2953             w11_11 = wp1 * w_1_11
2954
2955 !
2956 ! Non-window absorptivity
2957 !
2958             ib = 1
2959
2960             fa = fat(1,ib) + &
2961                  fat(2,ib) * te1 + &
2962                  fat(3,ib) * te2 + &
2963                  fat(4,ib) * te3 + &
2964                  fat(5,ib) * te4 + &
2965                  fat(6,ib) * te5
2966
2967             a_star = &
2968                  ah2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
2969                  ah2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
2970                  ah2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
2971                  ah2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
2972                  ah2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
2973                  ah2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
2974                  ah2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
2975                  ah2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
2976                  ah2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
2977                  ah2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
2978                  ah2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
2979                  ah2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
2980                  ah2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
2981                  ah2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
2982                  ah2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
2983                  ah2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
2984                  ah2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
2985                  ah2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
2986                  ah2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
2987                  ah2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
2988                  ah2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
2989                  ah2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
2990                  ah2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
2991                  ah2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
2992                  ah2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
2993                  ah2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
2994                  ah2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
2995                  ah2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
2996                  ah2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
2997                  ah2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
2998                  ah2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
2999                  ah2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3000
3001             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
3002                                  aer_trn_ngh(i,ib)), &
3003                              0.0_r8), 1.0_r8)
3004
3005 !
3006 ! Invoke linear limit for scaling wrt u below min_u_h2o
3007 !
3008             if (uvar < min_u_h2o) then
3009                uscl = uvar / min_u_h2o
3010                abso(i,ib) = abso(i,ib) * uscl
3011             endif
3012
3013 !
3014 ! Window absorptivity
3015 !
3016             ib = 2
3017
3018             fa = fat(1,ib) + &
3019                  fat(2,ib) * te1 + &
3020                  fat(3,ib) * te2 + &
3021                  fat(4,ib) * te3 + &
3022                  fat(5,ib) * te4 + &
3023                  fat(6,ib) * te5
3024
3025             a_star = &
3026                  ah2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3027                  ah2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3028                  ah2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3029                  ah2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3030                  ah2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
3031                  ah2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
3032                  ah2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
3033                  ah2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
3034                  ah2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3035                  ah2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3036                  ah2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3037                  ah2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3038                  ah2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
3039                  ah2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
3040                  ah2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
3041                  ah2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
3042                  ah2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3043                  ah2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3044                  ah2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3045                  ah2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3046                  ah2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
3047                  ah2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
3048                  ah2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
3049                  ah2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
3050                  ah2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3051                  ah2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3052                  ah2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3053                  ah2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3054                  ah2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
3055                  ah2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
3056                  ah2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
3057                  ah2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3058
3059             abso(i,ib) = min(max(fa * (1.0 - (1.0 - a_star) * &
3060                                  aer_trn_ngh(i,ib)), &
3061                              0.0_r8), 1.0_r8)
3062
3063 !
3064 ! Invoke linear limit for scaling wrt u below min_u_h2o
3065 !
3066             if (uvar < min_u_h2o) then
3067                uscl = uvar / min_u_h2o
3068                abso(i,ib) = abso(i,ib) * uscl
3069             endif
3070
3071          end do
3072 !
3073 ! Line transmission in 800-1000 and 1000-1200 cm-1 intervals
3074 !
3075          do i=1,ncol
3076             term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1. + c16*dty(i))
3077             term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1. + c17*dty(i))
3078             term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1. + c26*dty(i))
3079             term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1. + c27*dty(i))
3080          end do
3081 !
3082 ! 500 -  800 cm-1   h2o rotation band overlap with co2
3083 !
3084          do i=1,ncol
3085             dtym10     = dty(i) - 10.
3086             denom      = 1. + (c30 + c31*dtym10*dtym10)*sqrtu(i)
3087             k21        = term7(i,1) + term8(i,1)/denom
3088             denom      = 1. + (c28 + c29*dtym10       )*sqrtu(i)
3089             k22        = term7(i,2) + term8(i,2)/denom
3090             tr1     = exp(-(k21*(sqrtu(i) + fc1*fwku(i))))
3091             tr2     = exp(-(k22*(sqrtu(i) + fc1*fwku(i))))
3092             tr1=tr1*aer_trn_ngh(i,idx_LW_0650_0800)
3093 !                                         ! H2O line+STRAER trn 650--800 cm-1
3094             tr2=tr2*aer_trn_ngh(i,idx_LW_0500_0650)
3095 !                                         ! H2O line+STRAER trn 500--650 cm-1
3096             tr5     = exp(-((coefh(1,3) + coefh(2,3)*dtx(i))*uc1(i)))
3097             tr6     = exp(-((coefh(1,4) + coefh(2,4)*dtx(i))*uc1(i)))
3098             tr9(i)  = tr1*tr5
3099             tr10(i) = tr2*tr6
3100             trab2(i)= 0.65*tr9(i) + 0.35*tr10(i)
3101             th2o(i) = tr10(i)
3102          end do
3103 !
3104 ! abso(i,3)  o3  9.6 micrometer (nu3 and nu1 bands)
3105 !
3106          do i=1,ncol
3107             te        = (tbar(i,kn)*r293)**.7
3108             dplos     = abs(plos(i,k2+1) - plos(i,k2))
3109             u1        = zinpl(i,kn)*18.29*dplos/te
3110             u2        = zinpl(i,kn)*.5649*dplos/te
3111             tlocal    = tbar(i,kn)
3112             tcrfac    = sqrt(tlocal*r250)*te
3113             beta      = r3205*(pinpl(i,kn)*rsslp + dpfo3*tcrfac)
3114             realnu    = te/beta
3115             tmp1      = u1/sqrt(4. + u1*(1. + realnu))
3116             tmp2      = u2/sqrt(4. + u2*(1. + realnu))
3117             o3bndi    = 74.*te*log(1. + tmp1 + tmp2)
3118             abso(i,3) = o3bndi*o3emm(i,kn)*(h2otr(i,k2+1)/h2otr(i,k2))
3119             to3(i)    = 1.0/(1. + 0.1*tmp1 + 0.1*tmp2)
3120          end do
3121 !
3122 ! abso(i,4)   co2 15  micrometer band system
3123 !
3124          do i=1,ncol
3125             dplco2   = plco2(i,k2+1) - plco2(i,k2)
3126             sqwp     = sqrt(uinpl(i,kn)*dplco2)
3127             et       = exp(-480./tbar(i,kn))
3128             sqti(i)  = sqrt(tbar(i,kn))
3129             rsqti    = 1./sqti(i)
3130             et2      = et*et
3131             et4      = et2*et2
3132             omet     = (1. - 1.5*et2)
3133             f1co2    = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
3134             f1sqwp(i)= f1co2*sqwp
3135             t1co2(i) = 1./(1. + (245.18*omet*sqwp*rsqti))
3136             oneme    = 1. - et2
3137             alphat   = oneme**3*rsqti
3138             pi       = abs(dpnm(i))*winpl(i,kn)
3139             wco2     = 2.5221*co2vmr*pi*rga
3140             u7(i)    = 4.9411e4*alphat*et2*wco2
3141             u8       = 3.9744e4*alphat*et4*wco2
3142             u9       = 1.0447e5*alphat*et4*et2*wco2
3143             u13      = 2.8388e3*alphat*et4*wco2
3144             tpath    = tbar(i,kn)
3145             tlocal   = tbar(i,kn)
3146             tcrfac   = sqrt((tlocal*r250)*(tpath*r300))
3147             posqt    = (pinpl(i,kn)*rsslp + dpfco2*tcrfac)*rsqti
3148             rbeta7(i)= 1./(5.3228*posqt)
3149             rbeta8   = 1./(10.6576*posqt)
3150             rbeta9   = rbeta7(i)
3151             rbeta13  = rbeta9
3152             f2co2(i) = u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))) + &
3153                  u8   /sqrt(4. + u8*(1. + rbeta8)) + &
3154                  u9   /sqrt(4. + u9*(1. + rbeta9))
3155             f3co2(i) = u13/sqrt(4. + u13*(1. + rbeta13))
3156             tmp1     = log(1. + f1sqwp(i))
3157             tmp2     = log(1. + f2co2(i))
3158             tmp3     = log(1. + f3co2(i))
3159             absbnd   = (tmp1 + 2.*t1co2(i)*tmp2 + 2.*tmp3)*sqti(i)
3160             abso(i,4)= trab2(i)*emm(i,kn)*absbnd
3161             tco2(i)  = 1.0/(1.0+ 10.0*u7(i)/sqrt(4. + u7(i)*(1. + rbeta7(i))))
3162          end do ! do i =
3163 !
3164 ! Calculate trace gas absorptivity for nearest layer, abstrc
3165 !
3166          call trcabn(lchnk   ,ncol    ,pcols, pverp,                   &
3167               k2      ,kn      ,ucfc11  ,ucfc12  ,un2o0   , &
3168               un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
3169               uco221  ,uco222  ,uco223  ,tbar    ,bplnk   , &
3170               winpl   ,pinpl   ,tco2    ,th2o    ,to3     , &
3171               uptype  ,dw      ,s2c     ,u       ,pnew    , &
3172               abstrc  ,uinpl   , &
3173               aer_trn_ngh)
3174 !
3175 ! Total next layer absorptivity:
3176 !
3177          do i=1,ncol
3178             absnxt(i,k2,kn) = abso(i,1) + abso(i,2) + &
3179                  abso(i,3) + abso(i,4) + abstrc(i)
3180          end do
3181       end do ! do kn =
3182    end do ! do k2 =
3183
3184    return
3185 end subroutine radabs
3186
3187
3188
3189 subroutine radems(lchnk   ,ncol    ,pcols, pver, pverp,         &
3190                   s2c     ,tcg     ,w       ,tplnke  ,plh2o   , &
3191                   pnm     ,plco2   ,tint    ,tint4   ,tlayr   , &
3192                   tlayr4  ,plol    ,plos    ,ucfc11  ,ucfc12  , &
3193                   un2o0   ,un2o1   ,uch4    ,uco211 ,uco212   , &
3194                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
3195                   bn2o0   ,bn2o1   ,bch4    ,co2em   ,co2eml  , &
3196                   co2t    ,h2otr   ,abplnk1 ,abplnk2 ,emstot  , &
3197                   plh2ob  ,wb      , &
3198                   aer_trn_ttl)
3199 !-----------------------------------------------------------------------
3200 !
3201 ! Purpose:
3202 ! Compute emissivity for H2O, CO2, O3, CH4, N2O, CFC11 and CFC12
3203 !
3204 ! Method:
3205 ! H2O  ....  Uses nonisothermal emissivity method for water vapor from
3206 !            Ramanathan, V. and  P.Downey, 1986: A Nonisothermal
3207 !            Emissivity and Absorptivity Formulation for Water Vapor
3208 !            Jouranl of Geophysical Research, vol. 91., D8, pp 8649-8666
3209 !
3210 !            Implementation updated by Collins,Hackney, and Edwards 2001
3211 !               using line-by-line calculations based upon Hitran 1996 and
3212 !               CKD 2.1 for absorptivity and emissivity
3213 !
3214 !            Implementation updated by Collins, Lee-Taylor, and Edwards (2003)
3215 !               using line-by-line calculations based upon Hitran 2000 and
3216 !               CKD 2.4 for absorptivity and emissivity
3217 !
3218 ! CO2  ....  Uses absorptance parameterization of the 15 micro-meter
3219 !            (500 - 800 cm-1) band system of Carbon Dioxide, from
3220 !            Kiehl, J.T. and B.P.Briegleb, 1991: A New Parameterization
3221 !            of the Absorptance Due to the 15 micro-meter Band System
3222 !            of Carbon Dioxide Jouranl of Geophysical Research,
3223 !            vol. 96., D5, pp 9013-9019. Also includes the effects
3224 !            of the 9.4 and 10.4 micron bands of CO2.
3225 !
3226 ! O3   ....  Uses absorptance parameterization of the 9.6 micro-meter
3227 !            band system of ozone, from Ramanathan, V. and R. Dickinson,
3228 !            1979: The Role of stratospheric ozone in the zonal and
3229 !            seasonal radiative energy balance of the earth-troposphere
3230 !            system. Journal of the Atmospheric Sciences, Vol. 36,
3231 !            pp 1084-1104
3232 !
3233 ! ch4  ....  Uses a broad band model for the 7.7 micron band of methane.
3234 !
3235 ! n20  ....  Uses a broad band model for the 7.8, 8.6 and 17.0 micron
3236 !            bands of nitrous oxide
3237 !
3238 ! cfc11 ...  Uses a quasi-linear model for the 9.2, 10.7, 11.8 and 12.5
3239 !            micron bands of CFC11
3240 !
3241 ! cfc12 ...  Uses a quasi-linear model for the 8.6, 9.1, 10.8 and 11.2
3242 !            micron bands of CFC12
3243 !
3244 !
3245 ! Computes individual emissivities, accounting for band overlap, and
3246 ! sums to obtain the total.
3247 !
3248 ! Author: W. Collins (H2O emissivity) and J. Kiehl
3249 !
3250 !-----------------------------------------------------------------------
3251 !------------------------------Arguments--------------------------------
3252 !
3253 ! Input arguments
3254 !
3255    integer, intent(in) :: lchnk                    ! chunk identifier
3256    integer, intent(in) :: ncol                     ! number of atmospheric columns
3257    integer, intent(in) :: pcols, pver, pverp
3258
3259    real(r8), intent(in) :: s2c(pcols,pverp)        ! H2o continuum path length
3260    real(r8), intent(in) :: tcg(pcols,pverp)        ! H2o-mass-wgted temp. (Curtis-Godson approx.)
3261    real(r8), intent(in) :: w(pcols,pverp)          ! H2o path length
3262    real(r8), intent(in) :: tplnke(pcols)           ! Layer planck temperature
3263    real(r8), intent(in) :: plh2o(pcols,pverp)      ! H2o prs wghted path length
3264    real(r8), intent(in) :: pnm(pcols,pverp)        ! Model interface pressure
3265    real(r8), intent(in) :: plco2(pcols,pverp)      ! Prs wghted path of co2
3266    real(r8), intent(in) :: tint(pcols,pverp)       ! Model interface temperatures
3267    real(r8), intent(in) :: tint4(pcols,pverp)      ! Tint to the 4th power
3268    real(r8), intent(in) :: tlayr(pcols,pverp)      ! K-1 model layer temperature
3269    real(r8), intent(in) :: tlayr4(pcols,pverp)     ! Tlayr to the 4th power
3270    real(r8), intent(in) :: plol(pcols,pverp)       ! Pressure wghtd ozone path
3271    real(r8), intent(in) :: plos(pcols,pverp)       ! Ozone path
3272    real(r8), intent(in) :: plh2ob(nbands,pcols,pverp) ! Pressure weighted h2o path with
3273                                                       !    Hulst-Curtis-Godson temp. factor
3274                                                       !    for H2O bands
3275    real(r8), intent(in) :: wb(nbands,pcols,pverp)     ! H2o path length with
3276                                                       !    Hulst-Curtis-Godson temp. factor
3277                                                       !    for H2O bands
3278
3279    real(r8), intent(in) :: aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW)
3280 !                               ! [fraction] Total strat. aerosol
3281 !                               ! transmission between interfaces k1 and k2
3282
3283 !
3284 ! Trace gas variables
3285 !
3286    real(r8), intent(in) :: ucfc11(pcols,pverp)     ! CFC11 path length
3287    real(r8), intent(in) :: ucfc12(pcols,pverp)     ! CFC12 path length
3288    real(r8), intent(in) :: un2o0(pcols,pverp)      ! N2O path length
3289    real(r8), intent(in) :: un2o1(pcols,pverp)      ! N2O path length (hot band)
3290    real(r8), intent(in) :: uch4(pcols,pverp)       ! CH4 path length
3291    real(r8), intent(in) :: uco211(pcols,pverp)     ! CO2 9.4 micron band path length
3292    real(r8), intent(in) :: uco212(pcols,pverp)     ! CO2 9.4 micron band path length
3293    real(r8), intent(in) :: uco213(pcols,pverp)     ! CO2 9.4 micron band path length
3294    real(r8), intent(in) :: uco221(pcols,pverp)     ! CO2 10.4 micron band path length
3295    real(r8), intent(in) :: uco222(pcols,pverp)     ! CO2 10.4 micron band path length
3296    real(r8), intent(in) :: uco223(pcols,pverp)     ! CO2 10.4 micron band path length
3297    real(r8), intent(in) :: bn2o0(pcols,pverp)      ! pressure factor for n2o
3298    real(r8), intent(in) :: bn2o1(pcols,pverp)      ! pressure factor for n2o
3299    real(r8), intent(in) :: bch4(pcols,pverp)       ! pressure factor for ch4
3300    real(r8), intent(in) :: uptype(pcols,pverp)     ! p-type continuum path length
3301 !
3302 ! Output arguments
3303 !
3304    real(r8), intent(out) :: emstot(pcols,pverp)     ! Total emissivity
3305    real(r8), intent(out) :: co2em(pcols,pverp)      ! Layer co2 normalzd plnck funct drvtv
3306    real(r8), intent(out) :: co2eml(pcols,pver)      ! Intrfc co2 normalzd plnck func drvtv
3307    real(r8), intent(out) :: co2t(pcols,pverp)       ! Tmp and prs weighted path length
3308    real(r8), intent(out) :: h2otr(pcols,pverp)      ! H2o transmission over o3 band
3309    real(r8), intent(out) :: abplnk1(14,pcols,pverp) ! non-nearest layer Plack factor
3310    real(r8), intent(out) :: abplnk2(14,pcols,pverp) ! nearest layer factor
3311
3312 !
3313 !---------------------------Local variables-----------------------------
3314 !
3315    integer i                    ! Longitude index
3316    integer k                    ! Level index]
3317    integer k1                   ! Level index
3318 !
3319 ! Local variables for H2O:
3320 !
3321    real(r8) h2oems(pcols,pverp)     ! H2o emissivity
3322    real(r8) tpathe                  ! Used to compute h2o emissivity
3323    real(r8) dtx(pcols)              ! Planck temperature minus 250 K
3324    real(r8) dty(pcols)              ! Path temperature minus 250 K
3325 !
3326 ! The 500-800 cm^-1 emission in emis(i,4) has been combined
3327 !              into the 0-800 cm^-1 emission in emis(i,1)
3328 !
3329    real(r8) emis(pcols,2)           ! H2O emissivity
3330 !
3331 !
3332 !
3333    real(r8) term7(pcols,2)          ! Kl_inf(i) in eq(r8) of table A3a of R&D
3334    real(r8) term8(pcols,2)          ! Delta kl_inf(i) in eq(r8)
3335    real(r8) tr1(pcols)              ! Equation(6) in table A2 for 650-800
3336    real(r8) tr2(pcols)              ! Equation(6) in table A2 for 500-650
3337    real(r8) tr3(pcols)              ! Equation(4) in table A2 for 650-800
3338    real(r8) tr4(pcols)              ! Equation(4),table A2 of R&D for 500-650
3339    real(r8) tr7(pcols)              ! Equation (6) times eq(4) in table A2
3340 !                                      of R&D for 650-800 cm-1 region
3341    real(r8) tr8(pcols)              ! Equation (6) times eq(4) in table A2
3342 !                                      of R&D for 500-650 cm-1 region
3343    real(r8) k21(pcols)              ! Exponential coefficient used to calc
3344 !                                     rot band transmissivity in the 650-800
3345 !                                     cm-1 region (tr1)
3346    real(r8) k22(pcols)              ! Exponential coefficient used to calc
3347 !                                     rot band transmissivity in the 500-650
3348 !                                     cm-1 region (tr2)
3349    real(r8) u(pcols)                ! Pressure weighted H2O path length
3350    real(r8) ub(nbands)              ! Pressure weighted H2O path length with
3351                                     !  Hulst-Curtis-Godson correction for
3352                                     !  each band
3353    real(r8) pnew                    ! Effective pressure for h2o linewidth
3354    real(r8) pnewb(nbands)           ! Effective pressure for h2o linewidth w/
3355                                     !  Hulst-Curtis-Godson correction for
3356                                     !  each band
3357    real(r8) uc1(pcols)              ! H2o continuum pathlength 500-800 cm-1
3358    real(r8) fwk                     ! Equation(33) in R&D far wing correction
3359    real(r8) troco2(pcols,pverp)     ! H2o overlap factor for co2 absorption
3360    real(r8) emplnk(14,pcols)        ! emissivity Planck factor
3361    real(r8) emstrc(pcols,pverp)     ! total trace gas emissivity
3362 !
3363 ! Local variables for CO2:
3364 !
3365    real(r8) co2ems(pcols,pverp)      ! Co2 emissivity
3366    real(r8) co2plk(pcols)            ! Used to compute co2 emissivity
3367    real(r8) sum(pcols)               ! Used to calculate path temperature
3368    real(r8) t1i                      ! Co2 hot band temperature factor
3369    real(r8) sqti                     ! Sqrt of temperature
3370    real(r8) pi                       ! Pressure used in co2 mean line width
3371    real(r8) et                       ! Co2 hot band factor
3372    real(r8) et2                      ! Co2 hot band factor
3373    real(r8) et4                      ! Co2 hot band factor
3374    real(r8) omet                     ! Co2 stimulated emission term
3375    real(r8) ex                       ! Part of co2 planck function
3376    real(r8) f1co2                    ! Co2 weak band factor
3377    real(r8) f2co2                    ! Co2 weak band factor
3378    real(r8) f3co2                    ! Co2 weak band factor
3379    real(r8) t1co2                    ! Overlap factor weak bands strong band
3380    real(r8) sqwp                     ! Sqrt of co2 pathlength
3381    real(r8) f1sqwp                   ! Main co2 band factor
3382    real(r8) oneme                    ! Co2 stimulated emission term
3383    real(r8) alphat                   ! Part of the co2 stimulated emiss term
3384    real(r8) wco2                     ! Consts used to define co2 pathlength
3385    real(r8) posqt                    ! Effective pressure for co2 line width
3386    real(r8) rbeta7                   ! Inverse of co2 hot band line width par
3387    real(r8) rbeta8                   ! Inverse of co2 hot band line width par
3388    real(r8) rbeta9                   ! Inverse of co2 hot band line width par
3389    real(r8) rbeta13                  ! Inverse of co2 hot band line width par
3390    real(r8) tpath                    ! Path temp used in co2 band model
3391    real(r8) tmp1                     ! Co2 band factor
3392    real(r8) tmp2                     ! Co2 band factor
3393    real(r8) tmp3                     ! Co2 band factor
3394    real(r8) tlayr5                   ! Temperature factor in co2 Planck func
3395    real(r8) rsqti                    ! Reciprocal of sqrt of temperature
3396    real(r8) exm1sq                   ! Part of co2 Planck function
3397    real(r8) u7                       ! Absorber amt for various co2 band systems
3398    real(r8) u8                       ! Absorber amt for various co2 band systems
3399    real(r8) u9                       ! Absorber amt for various co2 band systems
3400    real(r8) u13                      ! Absorber amt for various co2 band systems
3401    real(r8) r250                     ! Inverse 250K
3402    real(r8) r300                     ! Inverse 300K
3403    real(r8) rsslp                    ! Inverse standard sea-level pressure
3404 !
3405 ! Local variables for O3:
3406 !
3407    real(r8) o3ems(pcols,pverp)       ! Ozone emissivity
3408    real(r8) dbvtt(pcols)             ! Tmp drvtv of planck fctn for tplnke
3409    real(r8) dbvt,fo3,t,ux,vx
3410    real(r8) te                       ! Temperature factor
3411    real(r8) u1                       ! Path length factor
3412    real(r8) u2                       ! Path length factor
3413    real(r8) phat                     ! Effecitive path length pressure
3414    real(r8) tlocal                   ! Local planck function temperature
3415    real(r8) tcrfac                   ! Scaled temperature factor
3416    real(r8) beta                     ! Absorption funct factor voigt effect
3417    real(r8) realnu                   ! Absorption function factor
3418    real(r8) o3bndi                   ! Band absorption factor
3419 !
3420 ! Transmission terms for various spectral intervals:
3421 !
3422    real(r8) absbnd                   ! Proportional to co2 band absorptance
3423    real(r8) tco2(pcols)              ! co2 overlap factor
3424    real(r8) th2o(pcols)              ! h2o overlap factor
3425    real(r8) to3(pcols)               ! o3 overlap factor
3426 !
3427 ! Variables for new H2O parameterization
3428 !
3429 ! Notation:
3430 ! U   = integral (P/P_0 dW)  eq. 15 in Ramanathan/Downey 1986
3431 ! P   = atmospheric pressure
3432 ! P_0 = reference atmospheric pressure
3433 ! W   = precipitable water path
3434 ! T_e = emission temperature
3435 ! T_p = path temperature
3436 ! RH  = path relative humidity
3437 !
3438    real(r8) fe               ! asymptotic value of emis. as U->infinity
3439    real(r8) e_star           ! normalized non-window emissivity
3440    real(r8) l_star           ! interpolated line transmission
3441    real(r8) c_star           ! interpolated continuum transmission
3442
3443    real(r8) te1              ! emission temperature
3444    real(r8) te2              ! te^2
3445    real(r8) te3              ! te^3
3446    real(r8) te4              ! te^4
3447    real(r8) te5              ! te^5
3448
3449    real(r8) log_u            ! log base 10 of U
3450    real(r8) log_uc           ! log base 10 of H2O continuum path
3451    real(r8) log_p            ! log base 10 of P
3452    real(r8) t_p              ! T_p
3453    real(r8) t_e              ! T_e (offset by T_p)
3454
3455    integer iu                ! index for log10(U)
3456    integer iu1               ! iu + 1
3457    integer iuc               ! index for log10(H2O continuum path)
3458    integer iuc1              ! iuc + 1
3459    integer ip                ! index for log10(P)
3460    integer ip1               ! ip + 1
3461    integer itp               ! index for T_p
3462    integer itp1              ! itp + 1
3463    integer ite               ! index for T_e
3464    integer ite1              ! ite + 1
3465    integer irh               ! index for RH
3466    integer irh1              ! irh + 1
3467
3468    real(r8) dvar             ! normalized variation in T_p/T_e/P/U
3469    real(r8) uvar             ! U * diffusivity factor
3470    real(r8) uscl             ! factor for lineary scaling as U->0
3471
3472    real(r8) wu               ! weight for U
3473    real(r8) wu1              ! 1 - wu
3474    real(r8) wuc              ! weight for H2O continuum path
3475    real(r8) wuc1             ! 1 - wuc
3476    real(r8) wp               ! weight for P
3477    real(r8) wp1              ! 1 - wp
3478    real(r8) wtp              ! weight for T_p
3479    real(r8) wtp1             ! 1 - wtp
3480    real(r8) wte              ! weight for T_e
3481    real(r8) wte1             ! 1 - wte
3482    real(r8) wrh              ! weight for RH
3483    real(r8) wrh1             ! 1 - wrh
3484
3485    real(r8) w_0_0_           ! weight for Tp/Te combination
3486    real(r8) w_0_1_           ! weight for Tp/Te combination
3487    real(r8) w_1_0_           ! weight for Tp/Te combination
3488    real(r8) w_1_1_           ! weight for Tp/Te combination
3489
3490    real(r8) w_0_00           ! weight for Tp/Te/RH combination
3491    real(r8) w_0_01           ! weight for Tp/Te/RH combination
3492    real(r8) w_0_10           ! weight for Tp/Te/RH combination
3493    real(r8) w_0_11           ! weight for Tp/Te/RH combination
3494    real(r8) w_1_00           ! weight for Tp/Te/RH combination
3495    real(r8) w_1_01           ! weight for Tp/Te/RH combination
3496    real(r8) w_1_10           ! weight for Tp/Te/RH combination
3497    real(r8) w_1_11           ! weight for Tp/Te/RH combination
3498
3499    real(r8) w00_00           ! weight for P/Tp/Te/RH combination
3500    real(r8) w00_01           ! weight for P/Tp/Te/RH combination
3501    real(r8) w00_10           ! weight for P/Tp/Te/RH combination
3502    real(r8) w00_11           ! weight for P/Tp/Te/RH combination
3503    real(r8) w01_00           ! weight for P/Tp/Te/RH combination
3504    real(r8) w01_01           ! weight for P/Tp/Te/RH combination
3505    real(r8) w01_10           ! weight for P/Tp/Te/RH combination
3506    real(r8) w01_11           ! weight for P/Tp/Te/RH combination
3507    real(r8) w10_00           ! weight for P/Tp/Te/RH combination
3508    real(r8) w10_01           ! weight for P/Tp/Te/RH combination
3509    real(r8) w10_10           ! weight for P/Tp/Te/RH combination
3510    real(r8) w10_11           ! weight for P/Tp/Te/RH combination
3511    real(r8) w11_00           ! weight for P/Tp/Te/RH combination
3512    real(r8) w11_01           ! weight for P/Tp/Te/RH combination
3513    real(r8) w11_10           ! weight for P/Tp/Te/RH combination
3514    real(r8) w11_11           ! weight for P/Tp/Te/RH combination
3515
3516    integer ib                ! spectral interval:
3517                              !   1 = 0-800 cm^-1 and 1200-2200 cm^-1
3518                              !   2 = 800-1200 cm^-1
3519
3520    real(r8) pch2o            ! H2O continuum path
3521    real(r8) fch2o            ! temp. factor for continuum
3522    real(r8) uch2o            ! U corresponding to H2O cont. path (window)
3523
3524    real(r8) fdif             ! secant(zenith angle) for diffusivity approx.
3525
3526    real(r8) sslp_mks         ! Sea-level pressure in MKS units
3527    real(r8) esx              ! saturation vapor pressure returned by vqsatd
3528    real(r8) qsx              ! saturation mixing ratio returned by vqsatd
3529    real(r8) pnew_mks         ! pnew in MKS units
3530    real(r8) q_path           ! effective specific humidity along path
3531    real(r8) rh_path          ! effective relative humidity along path
3532    real(r8) omeps            ! 1 - epsilo
3533
3534    integer  iest             ! index in estblh2o
3535
3536 !
3537 !---------------------------Statement functions-------------------------
3538 !
3539 ! Derivative of planck function at 9.6 micro-meter wavelength, and
3540 ! an absorption function factor:
3541 !
3542 !
3543    dbvt(t)=(-2.8911366682e-4+(2.3771251896e-6+1.1305188929e-10*t)*t)/ &
3544            (1.0+(-6.1364820707e-3+1.5550319767e-5*t)*t)
3545 !
3546    fo3(ux,vx)=ux/sqrt(4.+ux*(1.+vx))
3547 !
3548 !
3549 !
3550 !-----------------------------------------------------------------------
3551 !
3552 ! Initialize
3553 !
3554    r250  = 1./250.
3555    r300  = 1./300.
3556    rsslp = 1./sslp
3557 !
3558 ! Constants for computing U corresponding to H2O cont. path
3559 !
3560    fdif       = 1.66
3561    sslp_mks   = sslp / 10.0
3562    omeps      = 1.0 - epsilo
3563 !
3564 ! Planck function for co2
3565 !
3566    do i=1,ncol
3567       ex             = exp(960./tplnke(i))
3568       co2plk(i)      = 5.e8/((tplnke(i)**4)*(ex - 1.))
3569       co2t(i,ntoplw) = tplnke(i)
3570       sum(i)         = co2t(i,ntoplw)*pnm(i,ntoplw)
3571    end do
3572    k = ntoplw
3573    do k1=pverp,ntoplw+1,-1
3574       k = k + 1
3575       do i=1,ncol
3576          sum(i)         = sum(i) + tlayr(i,k)*(pnm(i,k)-pnm(i,k-1))
3577          ex             = exp(960./tlayr(i,k1))
3578          tlayr5         = tlayr(i,k1)*tlayr4(i,k1)
3579          co2eml(i,k1-1) = 1.2e11*ex/(tlayr5*(ex - 1.)**2)
3580          co2t(i,k)      = sum(i)/pnm(i,k)
3581       end do
3582    end do
3583 !
3584 ! Initialize planck function derivative for O3
3585 !
3586    do i=1,ncol
3587       dbvtt(i) = dbvt(tplnke(i))
3588    end do
3589 !
3590 ! Calculate trace gas Planck functions
3591 !
3592    call trcplk(lchnk   ,ncol    ,pcols, pver, pverp,         &
3593                tint    ,tlayr   ,tplnke  ,emplnk  ,abplnk1 , &
3594                abplnk2 )
3595 !
3596 ! Interface loop
3597 !
3598    do k1=ntoplw,pverp
3599 !
3600 ! H2O emissivity
3601 !
3602 ! emis(i,1)     0 -  800 cm-1   h2o rotation band
3603 ! emis(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
3604 ! emis(i,2)   800 - 1200 cm-1   h2o window
3605 !
3606 ! Separation between rotation and vibration-rotation dropped, so
3607 !                only 2 slots needed for H2O emissivity
3608 !
3609 !      emis(i,3)   = 0.0
3610 !
3611 ! For the p type continuum
3612 !
3613       do i=1,ncol
3614          u(i)        = plh2o(i,k1)
3615          pnew        = u(i)/w(i,k1)
3616          pnew_mks    = pnew * sslp_mks
3617 !
3618 ! Apply scaling factor for 500-800 continuum
3619 !
3620          uc1(i)      = (s2c(i,k1) + 1.7e-3*plh2o(i,k1))*(1. + 2.*s2c(i,k1))/ &
3621                        (1. + 15.*s2c(i,k1))
3622          pch2o       = s2c(i,k1)
3623 !
3624 ! Changed effective path temperature to std. Curtis-Godson form
3625 !
3626          tpathe   = tcg(i,k1)/w(i,k1)
3627          t_p = min(max(tpathe, min_tp_h2o), max_tp_h2o)
3628          iest = floor(t_p) - min_tp_h2o
3629          esx = estblh2o(iest) + (estblh2o(iest+1)-estblh2o(iest)) * &
3630                (t_p - min_tp_h2o - iest)
3631          qsx = epsilo * esx / (pnew_mks - omeps * esx)
3632 !
3633 ! Compute effective RH along path
3634 !
3635          q_path = w(i,k1) / pnm(i,k1) / rga
3636 !
3637 ! Calculate effective u, pnew for each band using
3638 !        Hulst-Curtis-Godson approximation:
3639 ! Formulae: Goody and Yung, Atmospheric Radiation: Theoretical Basis,
3640 !           2nd edition, Oxford University Press, 1989.
3641 ! Effective H2O path (w)
3642 !      eq. 6.24, p. 228
3643 ! Effective H2O path pressure (pnew = u/w):
3644 !      eq. 6.29, p. 228
3645 !
3646          ub(1) = plh2ob(1,i,k1) / psi(t_p,1)
3647          ub(2) = plh2ob(2,i,k1) / psi(t_p,2)
3648
3649          pnewb(1) = ub(1) / wb(1,i,k1) * phi(t_p,1)
3650          pnewb(2) = ub(2) / wb(2,i,k1) * phi(t_p,2)
3651 !
3652 !
3653 !
3654          dtx(i) = tplnke(i) - 250.
3655          dty(i) = tpathe - 250.
3656 !
3657 ! Define variables for C/H/E (now C/LT/E) fit
3658 !
3659 ! emis(i,1)     0 -  800 cm-1   h2o rotation band
3660 ! emis(i,1)  1200 - 2200 cm-1   h2o vibration-rotation band
3661 ! emis(i,2)   800 - 1200 cm-1   h2o window
3662 !
3663 ! Separation between rotation and vibration-rotation dropped, so
3664 !                only 2 slots needed for H2O emissivity
3665 !
3666 ! emis(i,3)   = 0.0
3667 !
3668 ! Notation:
3669 ! U   = integral (P/P_0 dW)
3670 ! P   = atmospheric pressure
3671 ! P_0 = reference atmospheric pressure
3672 ! W   = precipitable water path
3673 ! T_e = emission temperature
3674 ! T_p = path temperature
3675 ! RH  = path relative humidity
3676 !
3677 ! Terms for asymptotic value of emissivity
3678 !
3679          te1  = tplnke(i)
3680          te2  = te1 * te1
3681          te3  = te2 * te1
3682          te4  = te3 * te1
3683          te5  = te4 * te1
3684 !
3685 ! Band-independent indices for lines and continuum tables
3686 !
3687          dvar = (t_p - min_tp_h2o) / dtp_h2o
3688          itp = min(max(int(aint(dvar,r8)) + 1, 1), n_tp - 1)
3689          itp1 = itp + 1
3690          wtp = dvar - floor(dvar)
3691          wtp1 = 1.0 - wtp
3692
3693          t_e = min(max(tplnke(i) - t_p, min_te_h2o), max_te_h2o)
3694          dvar = (t_e - min_te_h2o) / dte_h2o
3695          ite = min(max(int(aint(dvar,r8)) + 1, 1), n_te - 1)
3696          ite1 = ite + 1
3697          wte = dvar - floor(dvar)
3698          wte1 = 1.0 - wte
3699
3700          rh_path = min(max(q_path / qsx, min_rh_h2o), max_rh_h2o)
3701          dvar = (rh_path - min_rh_h2o) / drh_h2o
3702          irh = min(max(int(aint(dvar,r8)) + 1, 1), n_rh - 1)
3703          irh1 = irh + 1
3704          wrh = dvar - floor(dvar)
3705          wrh1 = 1.0 - wrh
3706
3707          w_0_0_ = wtp  * wte
3708          w_0_1_ = wtp  * wte1
3709          w_1_0_ = wtp1 * wte
3710          w_1_1_ = wtp1 * wte1
3711
3712          w_0_00 = w_0_0_ * wrh
3713          w_0_01 = w_0_0_ * wrh1
3714          w_0_10 = w_0_1_ * wrh
3715          w_0_11 = w_0_1_ * wrh1
3716          w_1_00 = w_1_0_ * wrh
3717          w_1_01 = w_1_0_ * wrh1
3718          w_1_10 = w_1_1_ * wrh
3719          w_1_11 = w_1_1_ * wrh1
3720 !
3721 ! H2O Continuum path for 0-800 and 1200-2200 cm^-1
3722 !
3723 !    Assume foreign continuum dominates total H2O continuum in these bands
3724 !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
3725 !    Then the effective H2O path is just
3726 !         U_c = integral[ f(P) dW ]
3727 !    where
3728 !           W = water-vapor mass and
3729 !        f(P) = dependence of foreign continuum on pressure
3730 !             = P / sslp
3731 !    Then
3732 !         U_c = U (the same effective H2O path as for lines)
3733 !
3734 !
3735 ! Continuum terms for 800-1200 cm^-1
3736 !
3737 !    Assume self continuum dominates total H2O continuum for this band
3738 !    per Clough et al, JGR, v. 97, no. D14 (Oct 20, 1992), p. 15776
3739 !    Then the effective H2O self-continuum path is
3740 !         U_c = integral[ h(e,T) dW ]                        (*eq. 1*)
3741 !    where
3742 !           W = water-vapor mass and
3743 !           e = partial pressure of H2O along path
3744 !           T = temperature along path
3745 !      h(e,T) = dependence of foreign continuum on e,T
3746 !             = e / sslp * f(T)
3747 !
3748 !    Replacing
3749 !           e =~ q * P / epsilo
3750 !           q = mixing ratio of H2O
3751 !     epsilo = 0.622
3752 !
3753 !    and using the definition
3754 !           U = integral [ (P / sslp) dW ]
3755 !             = (P / sslp) W                                 (homogeneous path)
3756 !
3757 !    the effective path length for the self continuum is
3758 !         U_c = (q / epsilo) f(T) U                         (*eq. 2*)
3759 !
3760 !    Once values of T, U, and q have been calculated for the inhomogeneous
3761 !        path, this sets U_c for the corresponding
3762 !        homogeneous atmosphere.  However, this need not equal the
3763 !        value of U_c' defined by eq. 1 for the actual inhomogeneous atmosphere
3764 !        under consideration.
3765 !
3766 !    Solution: hold T and q constant, solve for U' that gives U_c' by
3767 !        inverting eq. (2):
3768 !
3769 !        U' = (U_c * epsilo) / (q * f(T))
3770 !
3771          fch2o = fh2oself(t_p)
3772          uch2o = (pch2o * epsilo) / (q_path * fch2o)
3773
3774 !
3775 ! Band-dependent indices for non-window
3776 !
3777          ib = 1
3778
3779          uvar = ub(ib) * fdif
3780          log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
3781          dvar = (log_u - min_lu_h2o) / dlu_h2o
3782          iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3783          iu1 = iu + 1
3784          wu = dvar - floor(dvar)
3785          wu1 = 1.0 - wu
3786
3787          log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
3788          dvar = (log_p - min_lp_h2o) / dlp_h2o
3789          ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
3790          ip1 = ip + 1
3791          wp = dvar - floor(dvar)
3792          wp1 = 1.0 - wp
3793
3794          w00_00 = wp  * w_0_00
3795          w00_01 = wp  * w_0_01
3796          w00_10 = wp  * w_0_10
3797          w00_11 = wp  * w_0_11
3798          w01_00 = wp  * w_1_00
3799          w01_01 = wp  * w_1_01
3800          w01_10 = wp  * w_1_10
3801          w01_11 = wp  * w_1_11
3802          w10_00 = wp1 * w_0_00
3803          w10_01 = wp1 * w_0_01
3804          w10_10 = wp1 * w_0_10
3805          w10_11 = wp1 * w_0_11
3806          w11_00 = wp1 * w_1_00
3807          w11_01 = wp1 * w_1_01
3808          w11_10 = wp1 * w_1_10
3809          w11_11 = wp1 * w_1_11
3810
3811 !
3812 ! Asymptotic value of emissivity as U->infinity
3813 !
3814          fe = fet(1,ib) + &
3815               fet(2,ib) * te1 + &
3816               fet(3,ib) * te2 + &
3817               fet(4,ib) * te3 + &
3818               fet(5,ib) * te4 + &
3819               fet(6,ib) * te5
3820
3821          e_star = &
3822               eh2onw(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3823               eh2onw(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3824               eh2onw(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3825               eh2onw(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3826               eh2onw(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
3827               eh2onw(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
3828               eh2onw(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
3829               eh2onw(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
3830               eh2onw(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3831               eh2onw(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3832               eh2onw(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3833               eh2onw(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3834               eh2onw(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
3835               eh2onw(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
3836               eh2onw(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
3837               eh2onw(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
3838               eh2onw(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3839               eh2onw(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3840               eh2onw(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3841               eh2onw(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3842               eh2onw(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
3843               eh2onw(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
3844               eh2onw(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
3845               eh2onw(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
3846               eh2onw(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3847               eh2onw(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3848               eh2onw(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3849               eh2onw(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3850               eh2onw(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
3851               eh2onw(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
3852               eh2onw(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
3853               eh2onw(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3854          emis(i,ib) = min(max(fe * (1.0 - (1.0 - e_star) * &
3855                               aer_trn_ttl(i,k1,1,ib)), &
3856                           0.0_r8), 1.0_r8)
3857 !
3858 ! Invoke linear limit for scaling wrt u below min_u_h2o
3859 !
3860          if (uvar < min_u_h2o) then
3861             uscl = uvar / min_u_h2o
3862             emis(i,ib) = emis(i,ib) * uscl
3863          endif
3864
3865
3866
3867 !
3868 ! Band-dependent indices for window
3869 !
3870          ib = 2
3871
3872          uvar = ub(ib) * fdif
3873          log_u  = min(log10(max(uvar, min_u_h2o)), max_lu_h2o)
3874          dvar = (log_u - min_lu_h2o) / dlu_h2o
3875          iu = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3876          iu1 = iu + 1
3877          wu = dvar - floor(dvar)
3878          wu1 = 1.0 - wu
3879
3880          log_p  = min(log10(max(pnewb(ib), min_p_h2o)), max_lp_h2o)
3881          dvar = (log_p - min_lp_h2o) / dlp_h2o
3882          ip = min(max(int(aint(dvar,r8)) + 1, 1), n_p - 1)
3883          ip1 = ip + 1
3884          wp = dvar - floor(dvar)
3885          wp1 = 1.0 - wp
3886
3887          w00_00 = wp  * w_0_00
3888          w00_01 = wp  * w_0_01
3889          w00_10 = wp  * w_0_10
3890          w00_11 = wp  * w_0_11
3891          w01_00 = wp  * w_1_00
3892          w01_01 = wp  * w_1_01
3893          w01_10 = wp  * w_1_10
3894          w01_11 = wp  * w_1_11
3895          w10_00 = wp1 * w_0_00
3896          w10_01 = wp1 * w_0_01
3897          w10_10 = wp1 * w_0_10
3898          w10_11 = wp1 * w_0_11
3899          w11_00 = wp1 * w_1_00
3900          w11_01 = wp1 * w_1_01
3901          w11_10 = wp1 * w_1_10
3902          w11_11 = wp1 * w_1_11
3903
3904          log_uc  = min(log10(max(uch2o * fdif, min_u_h2o)), max_lu_h2o)
3905          dvar = (log_uc - min_lu_h2o) / dlu_h2o
3906          iuc = min(max(int(aint(dvar,r8)) + 1, 1), n_u - 1)
3907          iuc1 = iuc + 1
3908          wuc = dvar - floor(dvar)
3909          wuc1 = 1.0 - wuc
3910 !
3911 ! Asymptotic value of emissivity as U->infinity
3912 !
3913          fe = fet(1,ib) + &
3914               fet(2,ib) * te1 + &
3915               fet(3,ib) * te2 + &
3916               fet(4,ib) * te3 + &
3917               fet(5,ib) * te4 + &
3918               fet(6,ib) * te5
3919
3920          l_star = &
3921               ln_eh2ow(ip , itp , iu , ite , irh ) * w11_11 * wu1 + &
3922               ln_eh2ow(ip , itp , iu , ite , irh1) * w11_10 * wu1 + &
3923               ln_eh2ow(ip , itp , iu , ite1, irh ) * w11_01 * wu1 + &
3924               ln_eh2ow(ip , itp , iu , ite1, irh1) * w11_00 * wu1 + &
3925               ln_eh2ow(ip , itp , iu1, ite , irh ) * w11_11 * wu  + &
3926               ln_eh2ow(ip , itp , iu1, ite , irh1) * w11_10 * wu  + &
3927               ln_eh2ow(ip , itp , iu1, ite1, irh ) * w11_01 * wu  + &
3928               ln_eh2ow(ip , itp , iu1, ite1, irh1) * w11_00 * wu  + &
3929               ln_eh2ow(ip , itp1, iu , ite , irh ) * w10_11 * wu1 + &
3930               ln_eh2ow(ip , itp1, iu , ite , irh1) * w10_10 * wu1 + &
3931               ln_eh2ow(ip , itp1, iu , ite1, irh ) * w10_01 * wu1 + &
3932               ln_eh2ow(ip , itp1, iu , ite1, irh1) * w10_00 * wu1 + &
3933               ln_eh2ow(ip , itp1, iu1, ite , irh ) * w10_11 * wu  + &
3934               ln_eh2ow(ip , itp1, iu1, ite , irh1) * w10_10 * wu  + &
3935               ln_eh2ow(ip , itp1, iu1, ite1, irh ) * w10_01 * wu  + &
3936               ln_eh2ow(ip , itp1, iu1, ite1, irh1) * w10_00 * wu  + &
3937               ln_eh2ow(ip1, itp , iu , ite , irh ) * w01_11 * wu1 + &
3938               ln_eh2ow(ip1, itp , iu , ite , irh1) * w01_10 * wu1 + &
3939               ln_eh2ow(ip1, itp , iu , ite1, irh ) * w01_01 * wu1 + &
3940               ln_eh2ow(ip1, itp , iu , ite1, irh1) * w01_00 * wu1 + &
3941               ln_eh2ow(ip1, itp , iu1, ite , irh ) * w01_11 * wu  + &
3942               ln_eh2ow(ip1, itp , iu1, ite , irh1) * w01_10 * wu  + &
3943               ln_eh2ow(ip1, itp , iu1, ite1, irh ) * w01_01 * wu  + &
3944               ln_eh2ow(ip1, itp , iu1, ite1, irh1) * w01_00 * wu  + &
3945               ln_eh2ow(ip1, itp1, iu , ite , irh ) * w00_11 * wu1 + &
3946               ln_eh2ow(ip1, itp1, iu , ite , irh1) * w00_10 * wu1 + &
3947               ln_eh2ow(ip1, itp1, iu , ite1, irh ) * w00_01 * wu1 + &
3948               ln_eh2ow(ip1, itp1, iu , ite1, irh1) * w00_00 * wu1 + &
3949               ln_eh2ow(ip1, itp1, iu1, ite , irh ) * w00_11 * wu  + &
3950               ln_eh2ow(ip1, itp1, iu1, ite , irh1) * w00_10 * wu  + &
3951               ln_eh2ow(ip1, itp1, iu1, ite1, irh ) * w00_01 * wu  + &
3952               ln_eh2ow(ip1, itp1, iu1, ite1, irh1) * w00_00 * wu
3953
3954          c_star = &
3955               cn_eh2ow(ip , itp , iuc , ite , irh ) * w11_11 * wuc1 + &
3956               cn_eh2ow(ip , itp , iuc , ite , irh1) * w11_10 * wuc1 + &
3957               cn_eh2ow(ip , itp , iuc , ite1, irh ) * w11_01 * wuc1 + &
3958               cn_eh2ow(ip , itp , iuc , ite1, irh1) * w11_00 * wuc1 + &
3959               cn_eh2ow(ip , itp , iuc1, ite , irh ) * w11_11 * wuc  + &
3960               cn_eh2ow(ip , itp , iuc1, ite , irh1) * w11_10 * wuc  + &
3961               cn_eh2ow(ip , itp , iuc1, ite1, irh ) * w11_01 * wuc  + &
3962               cn_eh2ow(ip , itp , iuc1, ite1, irh1) * w11_00 * wuc  + &
3963               cn_eh2ow(ip , itp1, iuc , ite , irh ) * w10_11 * wuc1 + &
3964               cn_eh2ow(ip , itp1, iuc , ite , irh1) * w10_10 * wuc1 + &
3965               cn_eh2ow(ip , itp1, iuc , ite1, irh ) * w10_01 * wuc1 + &
3966               cn_eh2ow(ip , itp1, iuc , ite1, irh1) * w10_00 * wuc1 + &
3967               cn_eh2ow(ip , itp1, iuc1, ite , irh ) * w10_11 * wuc  + &
3968               cn_eh2ow(ip , itp1, iuc1, ite , irh1) * w10_10 * wuc  + &
3969               cn_eh2ow(ip , itp1, iuc1, ite1, irh ) * w10_01 * wuc  + &
3970               cn_eh2ow(ip , itp1, iuc1, ite1, irh1) * w10_00 * wuc  + &
3971               cn_eh2ow(ip1, itp , iuc , ite , irh ) * w01_11 * wuc1 + &
3972               cn_eh2ow(ip1, itp , iuc , ite , irh1) * w01_10 * wuc1 + &
3973               cn_eh2ow(ip1, itp , iuc , ite1, irh ) * w01_01 * wuc1 + &
3974               cn_eh2ow(ip1, itp , iuc , ite1, irh1) * w01_00 * wuc1 + &
3975               cn_eh2ow(ip1, itp , iuc1, ite , irh ) * w01_11 * wuc  + &
3976               cn_eh2ow(ip1, itp , iuc1, ite , irh1) * w01_10 * wuc  + &
3977               cn_eh2ow(ip1, itp , iuc1, ite1, irh ) * w01_01 * wuc  + &
3978               cn_eh2ow(ip1, itp , iuc1, ite1, irh1) * w01_00 * wuc  + &
3979               cn_eh2ow(ip1, itp1, iuc , ite , irh ) * w00_11 * wuc1 + &
3980               cn_eh2ow(ip1, itp1, iuc , ite , irh1) * w00_10 * wuc1 + &
3981               cn_eh2ow(ip1, itp1, iuc , ite1, irh ) * w00_01 * wuc1 + &
3982               cn_eh2ow(ip1, itp1, iuc , ite1, irh1) * w00_00 * wuc1 + &
3983               cn_eh2ow(ip1, itp1, iuc1, ite , irh ) * w00_11 * wuc  + &
3984               cn_eh2ow(ip1, itp1, iuc1, ite , irh1) * w00_10 * wuc  + &
3985               cn_eh2ow(ip1, itp1, iuc1, ite1, irh ) * w00_01 * wuc  + &
3986               cn_eh2ow(ip1, itp1, iuc1, ite1, irh1) * w00_00 * wuc
3987          emis(i,ib) = min(max(fe * (1.0 - l_star * c_star * &
3988                               aer_trn_ttl(i,k1,1,ib)), &
3989                           0.0_r8), 1.0_r8)
3990 !
3991 ! Invoke linear limit for scaling wrt u below min_u_h2o
3992 !
3993          if (uvar < min_u_h2o) then
3994             uscl = uvar / min_u_h2o
3995             emis(i,ib) = emis(i,ib) * uscl
3996          endif
3997
3998
3999 !
4000 ! Compute total emissivity for H2O
4001 !
4002          h2oems(i,k1) = emis(i,1)+emis(i,2)
4003
4004       end do
4005 !
4006 !
4007 !
4008
4009       do i=1,ncol
4010          term7(i,1) = coefj(1,1) + coefj(2,1)*dty(i)*(1.+c16*dty(i))
4011          term8(i,1) = coefk(1,1) + coefk(2,1)*dty(i)*(1.+c17*dty(i))
4012          term7(i,2) = coefj(1,2) + coefj(2,2)*dty(i)*(1.+c26*dty(i))
4013          term8(i,2) = coefk(1,2) + coefk(2,2)*dty(i)*(1.+c27*dty(i))
4014       end do
4015       do i=1,ncol
4016 !
4017 ! 500 -  800 cm-1   rotation band overlap with co2
4018 !
4019          k21(i) = term7(i,1) + term8(i,1)/ &
4020                  (1. + (c30 + c31*(dty(i)-10.)*(dty(i)-10.))*sqrt(u(i)))
4021          k22(i) = term7(i,2) + term8(i,2)/ &
4022                  (1. + (c28 + c29*(dty(i)-10.))*sqrt(u(i)))
4023          fwk    = fwcoef + fwc1/(1.+fwc2*u(i))
4024          tr1(i) = exp(-(k21(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
4025          tr2(i) = exp(-(k22(i)*(sqrt(u(i)) + fc1*fwk*u(i))))
4026          tr1(i)=tr1(i)*aer_trn_ttl(i,k1,1,idx_LW_0650_0800)
4027 !                                            ! H2O line+aer trn 650--800 cm-1
4028          tr2(i)=tr2(i)*aer_trn_ttl(i,k1,1,idx_LW_0500_0650)
4029 !                                            ! H2O line+aer trn 500--650 cm-1
4030          tr3(i) = exp(-((coefh(1,1) + coefh(2,1)*dtx(i))*uc1(i)))
4031          tr4(i) = exp(-((coefh(1,2) + coefh(2,2)*dtx(i))*uc1(i)))
4032          tr7(i) = tr1(i)*tr3(i)
4033          tr8(i) = tr2(i)*tr4(i)
4034          troco2(i,k1) = 0.65*tr7(i) + 0.35*tr8(i)
4035          th2o(i) = tr8(i)
4036       end do
4037 !
4038 ! CO2 emissivity for 15 micron band system
4039 !
4040       do i=1,ncol
4041          t1i    = exp(-480./co2t(i,k1))
4042          sqti   = sqrt(co2t(i,k1))
4043          rsqti  = 1./sqti
4044          et     = t1i
4045          et2    = et*et
4046          et4    = et2*et2
4047          omet   = 1. - 1.5*et2
4048          f1co2  = 899.70*omet*(1. + 1.94774*et + 4.73486*et2)*rsqti
4049          sqwp   = sqrt(plco2(i,k1))
4050          f1sqwp = f1co2*sqwp
4051          t1co2  = 1./(1. + 245.18*omet*sqwp*rsqti)
4052          oneme  = 1. - et2
4053          alphat = oneme**3*rsqti
4054          wco2   = 2.5221*co2vmr*pnm(i,k1)*rga
4055          u7     = 4.9411e4*alphat*et2*wco2
4056          u8     = 3.9744e4*alphat*et4*wco2
4057          u9     = 1.0447e5*alphat*et4*et2*wco2
4058          u13    = 2.8388e3*alphat*et4*wco2
4059 !
4060          tpath  = co2t(i,k1)
4061          tlocal = tplnke(i)
4062          tcrfac = sqrt((tlocal*r250)*(tpath*r300))
4063          pi     = pnm(i,k1)*rsslp + 2.*dpfco2*tcrfac
4064          posqt  = pi/(2.*sqti)
4065          rbeta7 =  1./( 5.3288*posqt)
4066          rbeta8 = 1./ (10.6576*posqt)
4067          rbeta9 = rbeta7
4068          rbeta13= rbeta9
4069          f2co2  = (u7/sqrt(4. + u7*(1. + rbeta7))) + &
4070                   (u8/sqrt(4. + u8*(1. + rbeta8))) + &
4071                   (u9/sqrt(4. + u9*(1. + rbeta9)))
4072          f3co2  = u13/sqrt(4. + u13*(1. + rbeta13))
4073          tmp1   = log(1. + f1sqwp)
4074          tmp2   = log(1. +  f2co2)
4075          tmp3   = log(1. +  f3co2)
4076          absbnd = (tmp1 + 2.*t1co2*tmp2 + 2.*tmp3)*sqti
4077          tco2(i)=1.0/(1.0+10.0*(u7/sqrt(4. + u7*(1. + rbeta7))))
4078          co2ems(i,k1)  = troco2(i,k1)*absbnd*co2plk(i)
4079          ex     = exp(960./tint(i,k1))
4080          exm1sq = (ex - 1.)**2
4081          co2em(i,k1) = 1.2e11*ex/(tint(i,k1)*tint4(i,k1)*exm1sq)
4082       end do
4083 !
4084 ! O3 emissivity
4085 !
4086       do i=1,ncol
4087          h2otr(i,k1) = exp(-12.*s2c(i,k1))
4088           h2otr(i,k1)=h2otr(i,k1)*aer_trn_ttl(i,k1,1,idx_LW_1000_1200)
4089          te          = (co2t(i,k1)/293.)**.7
4090          u1          = 18.29*plos(i,k1)/te
4091          u2          = .5649*plos(i,k1)/te
4092          phat        = plos(i,k1)/plol(i,k1)
4093          tlocal      = tplnke(i)
4094          tcrfac      = sqrt(tlocal*r250)*te
4095          beta        = (1./.3205)*((1./phat) + (dpfo3*tcrfac))
4096          realnu      = (1./beta)*te
4097          o3bndi      = 74.*te*(tplnke(i)/375.)*log(1. + fo3(u1,realnu) + fo3(u2,realnu))
4098          o3ems(i,k1) = dbvtt(i)*h2otr(i,k1)*o3bndi
4099          to3(i)=1.0/(1. + 0.1*fo3(u1,realnu) + 0.1*fo3(u2,realnu))
4100       end do
4101 !
4102 !   Calculate trace gas emissivities
4103 !
4104       call trcems(lchnk   ,ncol    ,pcols, pverp,               &
4105                   k1      ,co2t    ,pnm     ,ucfc11  ,ucfc12  , &
4106                   un2o0   ,un2o1   ,bn2o0   ,bn2o1   ,uch4    , &
4107                   bch4    ,uco211  ,uco212  ,uco213  ,uco221  , &
4108                   uco222  ,uco223  ,uptype  ,w       ,s2c     , &
4109                   u       ,emplnk  ,th2o    ,tco2    ,to3     , &
4110                   emstrc  , &
4111                   aer_trn_ttl)
4112 !
4113 ! Total emissivity:
4114 !
4115       do i=1,ncol
4116          emstot(i,k1) = h2oems(i,k1) + co2ems(i,k1) + o3ems(i,k1)  &
4117                         + emstrc(i,k1)
4118       end do
4119    end do ! End of interface loop
4120
4121    return
4122 end subroutine radems
4123
4124 subroutine radtpl(lchnk   ,ncol    ,pcols, pver, pverp,                 &
4125                   tnm     ,lwupcgs ,qnm     ,pnm     ,plco2   ,plh2o   , &
4126                   tplnka  ,s2c     ,tcg     ,w       ,tplnke  , &
4127                   tint    ,tint4   ,tlayr   ,tlayr4  ,pmln    , &
4128                   piln    ,plh2ob  ,wb      )
4129 !--------------------------------------------------------------------
4130 !
4131 ! Purpose:
4132 ! Compute temperatures and path lengths for longwave radiation
4133 !
4134 ! Method:
4135 ! <Describe the algorithm(s) used in the routine.>
4136 ! <Also include any applicable external references.>
4137 !
4138 ! Author: CCM1
4139 !
4140 !--------------------------------------------------------------------
4141
4142 !------------------------------Arguments-----------------------------
4143 !
4144 ! Input arguments
4145 !
4146    integer, intent(in) :: lchnk                 ! chunk identifier
4147    integer, intent(in) :: ncol                  ! number of atmospheric columns
4148    integer, intent(in) :: pcols, pver, pverp
4149
4150    real(r8), intent(in) :: tnm(pcols,pver)      ! Model level temperatures
4151    real(r8), intent(in) :: lwupcgs(pcols)       ! Surface longwave up flux
4152    real(r8), intent(in) :: qnm(pcols,pver)      ! Model level specific humidity
4153    real(r8), intent(in) :: pnm(pcols,pverp)     ! Pressure at model interfaces (dynes/cm2)
4154    real(r8), intent(in) :: pmln(pcols,pver)     ! Ln(pmidm1)
4155    real(r8), intent(in) :: piln(pcols,pverp)    ! Ln(pintm1)
4156 !
4157 ! Output arguments
4158 !
4159    real(r8), intent(out) :: plco2(pcols,pverp)   ! Pressure weighted co2 path
4160    real(r8), intent(out) :: plh2o(pcols,pverp)   ! Pressure weighted h2o path
4161    real(r8), intent(out) :: tplnka(pcols,pverp)  ! Level temperature from interface temperatures
4162    real(r8), intent(out) :: s2c(pcols,pverp)     ! H2o continuum path length
4163    real(r8), intent(out) :: tcg(pcols,pverp)     ! H2o-mass-wgted temp. (Curtis-Godson approx.)
4164    real(r8), intent(out) :: w(pcols,pverp)       ! H2o path length
4165    real(r8), intent(out) :: tplnke(pcols)        ! Equal to tplnka
4166    real(r8), intent(out) :: tint(pcols,pverp)    ! Layer interface temperature
4167    real(r8), intent(out) :: tint4(pcols,pverp)   ! Tint to the 4th power
4168    real(r8), intent(out) :: tlayr(pcols,pverp)   ! K-1 level temperature
4169    real(r8), intent(out) :: tlayr4(pcols,pverp)  ! Tlayr to the 4th power
4170    real(r8), intent(out) :: plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
4171                                                       !    Hulst-Curtis-Godson temp. factor
4172                                                       !    for H2O bands
4173    real(r8), intent(out) :: wb(nbands,pcols,pverp)    ! H2o path length with
4174                                                       !    Hulst-Curtis-Godson temp. factor
4175                                                       !    for H2O bands
4176
4177 !
4178 !---------------------------Local variables--------------------------
4179 !
4180    integer i                 ! Longitude index
4181    integer k                 ! Level index
4182    integer kp1               ! Level index + 1
4183
4184    real(r8) repsil               ! Inver ratio mol weight h2o to dry air
4185    real(r8) dy                   ! Thickness of layer for tmp interp
4186    real(r8) dpnm                 ! Pressure thickness of layer
4187    real(r8) dpnmsq               ! Prs squared difference across layer
4188    real(r8) dw                   ! Increment in H2O path length
4189    real(r8) dplh2o               ! Increment in plh2o
4190    real(r8) cpwpl                ! Const in co2 mix ratio to path length conversn
4191
4192 !--------------------------------------------------------------------
4193 !
4194    repsil = 1./epsilo
4195 !
4196 ! Compute co2 and h2o paths
4197 !
4198    cpwpl = amco2/amd * 0.5/(gravit*p0)
4199    do i=1,ncol
4200       plh2o(i,ntoplw)  = rgsslp*qnm(i,ntoplw)*pnm(i,ntoplw)*pnm(i,ntoplw)
4201       plco2(i,ntoplw)  = co2vmr*cpwpl*pnm(i,ntoplw)*pnm(i,ntoplw)
4202    end do
4203    do k=ntoplw,pver
4204       do i=1,ncol
4205          plh2o(i,k+1)  = plh2o(i,k) + rgsslp* &
4206                          (pnm(i,k+1)**2 - pnm(i,k)**2)*qnm(i,k)
4207          plco2(i,k+1)  = co2vmr*cpwpl*pnm(i,k+1)**2
4208       end do
4209    end do
4210 !
4211 ! Set the top and bottom intermediate level temperatures,
4212 ! top level planck temperature and top layer temp**4.
4213 !
4214 ! Tint is lower interface temperature
4215 ! (not available for bottom layer, so use ground temperature)
4216 !
4217    do i=1,ncol
4218       tint4(i,pverp)   = lwupcgs(i)/stebol
4219       tint(i,pverp)    = sqrt(sqrt(tint4(i,pverp)))
4220       tplnka(i,ntoplw) = tnm(i,ntoplw)
4221       tint(i,ntoplw)   = tplnka(i,ntoplw)
4222       tlayr4(i,ntoplw) = tplnka(i,ntoplw)**4
4223       tint4(i,ntoplw)  = tlayr4(i,ntoplw)
4224    end do
4225 !
4226 ! Intermediate level temperatures are computed using temperature
4227 ! at the full level below less dy*delta t,between the full level
4228 !
4229    do k=ntoplw+1,pver
4230       do i=1,ncol
4231          dy = (piln(i,k) - pmln(i,k))/(pmln(i,k-1) - pmln(i,k))
4232          tint(i,k)  = tnm(i,k) - dy*(tnm(i,k)-tnm(i,k-1))
4233          tint4(i,k) = tint(i,k)**4
4234       end do
4235    end do
4236 !
4237 ! Now set the layer temp=full level temperatures and establish a
4238 ! planck temperature for absorption (tplnka) which is the average
4239 ! the intermediate level temperatures.  Note that tplnka is not
4240 ! equal to the full level temperatures.
4241 !
4242    do k=ntoplw+1,pverp
4243       do i=1,ncol
4244          tlayr(i,k)  = tnm(i,k-1)
4245          tlayr4(i,k) = tlayr(i,k)**4
4246          tplnka(i,k) = .5*(tint(i,k) + tint(i,k-1))
4247       end do
4248    end do
4249 !
4250 ! Calculate tplank for emissivity calculation.
4251 ! Assume isothermal tplnke i.e. all levels=ttop.
4252 !
4253    do i=1,ncol
4254       tplnke(i)       = tplnka(i,ntoplw)
4255       tlayr(i,ntoplw) = tint(i,ntoplw)
4256    end do
4257 !
4258 ! Now compute h2o path fields:
4259 !
4260    do i=1,ncol
4261 !
4262 ! Changed effective path temperature to std. Curtis-Godson form
4263 !
4264       tcg(i,ntoplw) = rga*qnm(i,ntoplw)*pnm(i,ntoplw)*tnm(i,ntoplw)
4265       w(i,ntoplw)   = sslp * (plh2o(i,ntoplw)*2.) / pnm(i,ntoplw)
4266 !
4267 ! Hulst-Curtis-Godson scaling for H2O path
4268 !
4269       wb(1,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),1)
4270       wb(2,i,ntoplw) = w(i,ntoplw) * phi(tnm(i,ntoplw),2)
4271 !
4272 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
4273 !
4274       plh2ob(1,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),1)
4275       plh2ob(2,i,ntoplw) = plh2o(i,ntoplw) * psi(tnm(i,ntoplw),2)
4276
4277       s2c(i,ntoplw) = plh2o(i,ntoplw)*fh2oself(tnm(i,ntoplw))*qnm(i,ntoplw)*repsil
4278    end do
4279
4280    do k=ntoplw,pver
4281       do i=1,ncol
4282          dpnm       = pnm(i,k+1) - pnm(i,k)
4283          dpnmsq     = pnm(i,k+1)**2 - pnm(i,k)**2
4284          dw         = rga*qnm(i,k)*dpnm
4285          kp1        = k+1
4286          w(i,kp1)   = w(i,k) + dw
4287 !
4288 ! Hulst-Curtis-Godson scaling for H2O path
4289 !
4290          wb(1,i,kp1) = wb(1,i,k) + dw * phi(tnm(i,k),1)
4291          wb(2,i,kp1) = wb(2,i,k) + dw * phi(tnm(i,k),2)
4292 !
4293 ! Hulst-Curtis-Godson scaling for effective pressure along H2O path
4294 !
4295          dplh2o = plh2o(i,kp1) - plh2o(i,k)
4296
4297          plh2ob(1,i,kp1) = plh2ob(1,i,k) + dplh2o * psi(tnm(i,k),1)
4298          plh2ob(2,i,kp1) = plh2ob(2,i,k) + dplh2o * psi(tnm(i,k),2)
4299 !
4300 ! Changed effective path temperature to std. Curtis-Godson form
4301 !
4302          tcg(i,kp1) = tcg(i,k) + dw*tnm(i,k)
4303          s2c(i,kp1) = s2c(i,k) + rgsslp*dpnmsq*qnm(i,k)* &
4304                       fh2oself(tnm(i,k))*qnm(i,k)*repsil
4305       end do
4306    end do
4307 !
4308    return
4309 end subroutine radtpl
4310
4311
4312 subroutine radclwmx(lchnk   ,ncol    ,pcols, pver, pverp,         &
4313                     lwupcgs ,tnm     ,qnm     ,o3vmr   , &
4314                     pmid    ,pint    ,pmln    ,piln    ,          &
4315                              n2o     ,ch4     ,cfc11   ,cfc12   , &
4316                     cld     ,emis    ,pmxrgn  ,nmxrgn  ,qrl     , &
4317                     doabsems, abstot, absnxt, emstot,             &
4318                     flns    ,flnt    ,flnsc   ,flntc   ,flwds   , &
4319                     flut    ,flutc   , &
4320                     flup    ,flupc   ,fldn    ,fldnc   ,          &
4321                     aer_mass)
4322 !-----------------------------------------------------------------------
4323 !
4324 ! Purpose:
4325 ! Compute longwave radiation heating rates and boundary fluxes
4326 !
4327 ! Method:
4328 ! Uses broad band absorptivity/emissivity method to compute clear sky;
4329 ! assumes randomly overlapped clouds with variable cloud emissivity to
4330 ! include effects of clouds.
4331 !
4332 ! Computes clear sky absorptivity/emissivity at lower frequency (in
4333 ! general) than the model radiation frequency; uses previously computed
4334 ! and stored values for efficiency
4335 !
4336 ! Note: This subroutine contains vertical indexing which proceeds
4337 !       from bottom to top rather than the top to bottom indexing
4338 !       used in the rest of the model.
4339 !
4340 ! Author: B. Collins
4341 !
4342 !-----------------------------------------------------------------------
4343 !  use shr_kind_mod, only: r8 => shr_kind_r8
4344 !  use ppgrid
4345 !  use radae, only: nbands, radems, radabs, radtpl, abstot_3d, absnxt_3d, emstot_3d
4346 !  use volcrad
4347
4348    implicit none
4349
4350    integer pverp2,pverp3,pverp4
4351 !  parameter (pverp2=pver+2,pverp3=pver+3,pverp4=pver+4)
4352
4353    real(r8) cldmin
4354    parameter (cldmin = 1.0d-80)
4355 !------------------------------Commons----------------------------------
4356 !-----------------------------------------------------------------------
4357 !------------------------------Arguments--------------------------------
4358 !
4359 ! Input arguments
4360 !
4361    integer, intent(in) :: lchnk                 ! chunk identifier
4362    integer, intent(in) :: pcols, pver, pverp
4363    integer, intent(in) :: ncol                  ! number of atmospheric columns
4364 !    maximally overlapped region.
4365 !    0->pmxrgn(i,1) is range of pmid for
4366 !    1st region, pmxrgn(i,1)->pmxrgn(i,2) for
4367 !    2nd region, etc
4368    integer, intent(in) :: nmxrgn(pcols)         ! Number of maximally overlapped regions
4369    logical, intent(in) :: doabsems
4370
4371    real(r8), intent(in) :: pmxrgn(pcols,pverp)  ! Maximum values of pmid for each
4372    real(r8), intent(in) :: lwupcgs(pcols)       ! Longwave up flux in CGS units
4373 !
4374 ! Input arguments which are only passed to other routines
4375 !
4376    real(r8), intent(in) :: tnm(pcols,pver)      ! Level temperature
4377    real(r8), intent(in) :: qnm(pcols,pver)      ! Level moisture field
4378    real(r8), intent(in) :: o3vmr(pcols,pver)    ! ozone volume mixing ratio
4379    real(r8), intent(in) :: pmid(pcols,pver)     ! Level pressure
4380    real(r8), intent(in) :: pint(pcols,pverp)    ! Model interface pressure
4381    real(r8), intent(in) :: pmln(pcols,pver)     ! Ln(pmid)
4382    real(r8), intent(in) :: piln(pcols,pverp)    ! Ln(pint)
4383    real(r8), intent(in) :: n2o(pcols,pver)      ! nitrous oxide mass mixing ratio
4384    real(r8), intent(in) :: ch4(pcols,pver)      ! methane mass mixing ratio
4385    real(r8), intent(in) :: cfc11(pcols,pver)    ! cfc11 mass mixing ratio
4386    real(r8), intent(in) :: cfc12(pcols,pver)    ! cfc12 mass mixing ratio
4387    real(r8), intent(in) :: cld(pcols,pver)      ! Cloud cover
4388    real(r8), intent(in) :: emis(pcols,pver)     ! Cloud emissivity
4389    real(r8), intent(in) :: aer_mass(pcols,pver) ! STRAER mass in layer
4390
4391 !
4392 ! Output arguments
4393 !
4394    real(r8), intent(out) :: qrl(pcols,pver)      ! Longwave heating rate
4395    real(r8), intent(out) :: flns(pcols)          ! Surface cooling flux
4396    real(r8), intent(out) :: flnt(pcols)          ! Net outgoing flux
4397    real(r8), intent(out) :: flut(pcols)          ! Upward flux at top of model
4398    real(r8), intent(out) :: flnsc(pcols)         ! Clear sky surface cooing
4399    real(r8), intent(out) :: flntc(pcols)         ! Net clear sky outgoing flux
4400    real(r8), intent(out) :: flutc(pcols)         ! Upward clear-sky flux at top of model
4401    real(r8), intent(out) :: flwds(pcols)         ! Down longwave flux at surface
4402 ! Added downward/upward total and clear sky fluxes
4403    real(r8), intent(out) :: flup(pcols,pverp)      ! Total sky upward longwave flux
4404    real(r8), intent(out) :: flupc(pcols,pverp)     ! Clear sky upward longwave flux
4405    real(r8), intent(out) :: fldn(pcols,pverp)      ! Total sky downward longwave flux
4406    real(r8), intent(out) :: fldnc(pcols,pverp)     ! Clear sky downward longwave flux
4407 !
4408    real(r8), intent(inout) :: abstot(pcols,pverp,pverp) ! Total absorptivity
4409    real(r8), intent(inout) :: absnxt(pcols,pver,4)      ! Total nearest layer absorptivity
4410    real(r8), intent(inout) :: emstot(pcols,pverp)     ! Total emissivity
4411
4412 !---------------------------Local variables-----------------------------
4413 !
4414    integer i                 ! Longitude index
4415    integer ilon              ! Longitude index
4416    integer ii                ! Longitude index
4417    integer iimx              ! Longitude index (max overlap)
4418    integer k                 ! Level index
4419    integer k1                ! Level index
4420    integer k2                ! Level index
4421    integer k3                ! Level index
4422    integer km                ! Level index
4423    integer km1               ! Level index
4424    integer km3               ! Level index
4425    integer km4               ! Level index
4426    integer irgn              ! Index for max-overlap regions
4427    integer l                 ! Index for clouds to overlap
4428    integer l1                ! Index for clouds to overlap
4429    integer n                 ! Counter
4430
4431 !
4432    real(r8) :: plco2(pcols,pverp)   ! Path length co2
4433    real(r8) :: plh2o(pcols,pverp)   ! Path length h2o
4434    real(r8) tmp(pcols)           ! Temporary workspace
4435    real(r8) tmp2(pcols)          ! Temporary workspace
4436    real(r8) absbt(pcols)         ! Downward emission at model top
4437    real(r8) plol(pcols,pverp)    ! O3 pressure wghted path length
4438    real(r8) plos(pcols,pverp)    ! O3 path length
4439    real(r8) aer_mpp(pcols,pverp) ! STRAER path above kth interface level
4440    real(r8) co2em(pcols,pverp)   ! Layer co2 normalized planck funct. derivative
4441    real(r8) co2eml(pcols,pver)   ! Interface co2 normalized planck funct. deriv.
4442    real(r8) delt(pcols)          ! Diff t**4 mid layer to top interface
4443    real(r8) delt1(pcols)         ! Diff t**4 lower intrfc to mid layer
4444    real(r8) bk1(pcols)           ! Absrptvty for vertical quadrature
4445    real(r8) bk2(pcols)           ! Absrptvty for vertical quadrature
4446    real(r8) cldp(pcols,pverp)    ! Cloud cover with extra layer
4447    real(r8) ful(pcols,pverp)     ! Total upwards longwave flux
4448    real(r8) fsul(pcols,pverp)    ! Clear sky upwards longwave flux
4449    real(r8) fdl(pcols,pverp)     ! Total downwards longwave flux
4450    real(r8) fsdl(pcols,pverp)    ! Clear sky downwards longwv flux
4451    real(r8) fclb4(pcols,-1:pver)    ! Sig t**4 for cld bottom interfc
4452    real(r8) fclt4(pcols,0:pver)    ! Sig t**4 for cloud top interfc
4453    real(r8) s(pcols,pverp,pverp) ! Flx integral sum
4454    real(r8) tplnka(pcols,pverp)  ! Planck fnctn temperature
4455    real(r8) s2c(pcols,pverp)     ! H2o cont amount
4456    real(r8) tcg(pcols,pverp)     ! H2o-mass-wgted temp. (Curtis-Godson approx.)
4457    real(r8) w(pcols,pverp)       ! H2o path
4458    real(r8) tplnke(pcols)        ! Planck fnctn temperature
4459    real(r8) h2otr(pcols,pverp)   ! H2o trnmsn for o3 overlap
4460    real(r8) co2t(pcols,pverp)    ! Prs wghted temperature path
4461    real(r8) tint(pcols,pverp)    ! Interface temperature
4462    real(r8) tint4(pcols,pverp)   ! Interface temperature**4
4463    real(r8) tlayr(pcols,pverp)   ! Level temperature
4464    real(r8) tlayr4(pcols,pverp)  ! Level temperature**4
4465    real(r8) plh2ob(nbands,pcols,pverp)! Pressure weighted h2o path with
4466                                       !    Hulst-Curtis-Godson temp. factor
4467                                       !    for H2O bands
4468    real(r8) wb(nbands,pcols,pverp)    ! H2o path length with
4469                                       !    Hulst-Curtis-Godson temp. factor
4470                                       !    for H2O bands
4471
4472    real(r8) cld0                 ! previous cloud amt (for max overlap)
4473    real(r8) cld1                 ! next cloud amt (for max overlap)
4474    real(r8) emx(0:pverp)         ! Emissivity factors (max overlap)
4475    real(r8) emx0                 ! Emissivity factors for BCs (max overlap)
4476    real(r8) trans                ! 1 - emis
4477    real(r8) asort(pver)          ! 1 - cloud amounts to be sorted for max ovrlp.
4478    real(r8) atmp                 ! Temporary storage for sort when nxs = 2
4479    real(r8) maxcld(pcols)        ! Maximum cloud at any layer
4480
4481    integer indx(pcols)       ! index vector of gathered array values
4482 !!$   integer indxmx(pcols+1,pverp)! index vector of gathered array values
4483    integer indxmx(pcols,pverp)! index vector of gathered array values
4484 !    (max overlap)
4485    integer nrgn(pcols)       ! Number of max overlap regions at longitude
4486    integer npts              ! number of values satisfying some criterion
4487    integer ncolmx(pverp)     ! number of columns with clds in region
4488    integer kx1(pcols,pverp)  ! Level index for top of max-overlap region
4489    integer kx2(pcols,0:pverp)! Level index for bottom of max-overlap region
4490    integer kxs(0:pverp,pcols,pverp)! Level indices for cld layers sorted by cld()
4491 !    in descending order
4492    integer nxs(pcols,pverp)  ! Number of cloudy layers between kx1 and kx2
4493    integer nxsk              ! Number of cloudy layers between (kx1/kx2)&k
4494    integer ksort(0:pverp)    ! Level indices of cloud amounts to be sorted
4495 !    for max ovrlp. calculation
4496    integer ktmp              ! Temporary storage for sort when nxs = 2
4497
4498 !  real aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
4499   real(r8) aer_trn_ttl(pcols,pverp,pverp,bnd_nbr_LW) ! [fraction] Total
4500 !                               ! transmission between interfaces k1 and k2
4501 !
4502 ! Pointer variables to 3d structures
4503 !
4504 !  real(r8), pointer :: abstot(:,:,:)
4505 !  real(r8), pointer :: absnxt(:,:,:)
4506 !  real(r8), pointer :: emstot(:,:)
4507
4508 !
4509 ! Trace gas variables
4510 !
4511    real(r8) ucfc11(pcols,pverp)  ! CFC11 path length
4512    real(r8) ucfc12(pcols,pverp)  ! CFC12 path length
4513    real(r8) un2o0(pcols,pverp)   ! N2O path length
4514    real(r8) un2o1(pcols,pverp)   ! N2O path length (hot band)
4515    real(r8) uch4(pcols,pverp)    ! CH4 path length
4516    real(r8) uco211(pcols,pverp)  ! CO2 9.4 micron band path length
4517    real(r8) uco212(pcols,pverp)  ! CO2 9.4 micron band path length
4518    real(r8) uco213(pcols,pverp)  ! CO2 9.4 micron band path length
4519    real(r8) uco221(pcols,pverp)  ! CO2 10.4 micron band path length
4520    real(r8) uco222(pcols,pverp)  ! CO2 10.4 micron band path length
4521    real(r8) uco223(pcols,pverp)  ! CO2 10.4 micron band path length
4522    real(r8) bn2o0(pcols,pverp)   ! pressure factor for n2o
4523    real(r8) bn2o1(pcols,pverp)   ! pressure factor for n2o
4524    real(r8) bch4(pcols,pverp)    ! pressure factor for ch4
4525    real(r8) uptype(pcols,pverp)  ! p-type continuum path length
4526    real(r8) abplnk1(14,pcols,pverp)  ! non-nearest layer Plack factor
4527    real(r8) abplnk2(14,pcols,pverp)  ! nearest layer factor
4528 !
4529 !
4530 !-----------------------------------------------------------------------
4531 !
4532 !
4533    pverp2=pver+2
4534    pverp3=pver+3
4535    pverp4=pver+4
4536 !
4537 ! Set pointer variables
4538 !
4539 !  abstot => abstot_3d(:,:,:,lchnk)
4540 !  absnxt => absnxt_3d(:,:,:,lchnk)
4541 !  emstot => emstot_3d(:,:,lchnk)
4542 !
4543 ! accumulate mass path from top of atmosphere
4544 !
4545   call aer_pth(aer_mass, aer_mpp, ncol, pcols, pver, pverp)
4546
4547 !
4548 ! Calculate some temperatures needed to derive absorptivity and
4549 ! emissivity, as well as some h2o path lengths
4550 !
4551    call radtpl(lchnk   ,ncol    ,pcols, pver, pverp,                  &
4552                tnm     ,lwupcgs ,qnm     ,pint    ,plco2   ,plh2o   , &
4553                tplnka  ,s2c     ,tcg     ,w       ,tplnke  , &
4554                tint    ,tint4   ,tlayr   ,tlayr4  ,pmln    , &
4555                piln    ,plh2ob  ,wb      )
4556    if (doabsems) then
4557 !
4558 ! Compute ozone path lengths at frequency of a/e calculation.
4559 !
4560       call radoz2(lchnk, ncol, pcols, pver, pverp, o3vmr   ,pint    ,plol    ,plos, ntoplw    )
4561 !
4562 ! Compute trace gas path lengths
4563 !
4564       call trcpth(lchnk   ,ncol    ,pcols, pver, pverp,         &
4565                   tnm     ,pint    ,cfc11   ,cfc12   ,n2o     , &
4566                   ch4     ,qnm     ,ucfc11  ,ucfc12  ,un2o0   , &
4567                   un2o1   ,uch4    ,uco211  ,uco212  ,uco213  , &
4568                   uco221  ,uco222  ,uco223  ,bn2o0   ,bn2o1   , &
4569                   bch4    ,uptype  )
4570
4571 !     Compute transmission through STRAER absorption continuum
4572       call aer_trn(aer_mpp, aer_trn_ttl, pcols, pver, pverp)
4573
4574 !
4575 !
4576 ! Compute total emissivity:
4577 !
4578       call radems(lchnk   ,ncol    ,pcols, pver, pverp,         &
4579                   s2c     ,tcg     ,w       ,tplnke  ,plh2o   , &
4580                   pint    ,plco2   ,tint    ,tint4   ,tlayr   , &
4581                   tlayr4  ,plol    ,plos    ,ucfc11  ,ucfc12  , &
4582                   un2o0   ,un2o1   ,uch4    ,uco211  ,uco212  , &
4583                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
4584                   bn2o0   ,bn2o1   ,bch4    ,co2em   ,co2eml  , &
4585                   co2t    ,h2otr   ,abplnk1 ,abplnk2 ,emstot  , &
4586                   plh2ob  ,wb      , &
4587                   aer_trn_ttl)
4588 !
4589 ! Compute total absorptivity:
4590 !
4591       call radabs(lchnk   ,ncol    ,pcols, pver, pverp,         &
4592                   pmid    ,pint    ,co2em   ,co2eml  ,tplnka  , &
4593                   s2c     ,tcg     ,w       ,h2otr   ,plco2   , &
4594                   plh2o   ,co2t    ,tint    ,tlayr   ,plol    , &
4595                   plos    ,pmln    ,piln    ,ucfc11  ,ucfc12  , &
4596                   un2o0   ,un2o1   ,uch4    ,uco211  ,uco212  , &
4597                   uco213  ,uco221  ,uco222  ,uco223  ,uptype  , &
4598                   bn2o0   ,bn2o1   ,bch4    ,abplnk1 ,abplnk2 , &
4599                   abstot  ,absnxt  ,plh2ob  ,wb      , &
4600                   aer_mpp ,aer_trn_ttl)
4601    end if
4602 !
4603 ! Compute sums used in integrals (all longitude points)
4604 !
4605 ! Definition of bk1 & bk2 depends on finite differencing.  for
4606 ! trapezoidal rule bk1=bk2. trapezoidal rule applied for nonadjacent
4607 ! layers only.
4608 !
4609 ! delt=t**4 in layer above current sigma level km.
4610 ! delt1=t**4 in layer below current sigma level km.
4611 !
4612    do i=1,ncol
4613       delt(i) = tint4(i,pver) - tlayr4(i,pverp)
4614       delt1(i) = tlayr4(i,pverp) - tint4(i,pverp)
4615       s(i,pverp,pverp) = stebol*(delt1(i)*absnxt(i,pver,1) + delt (i)*absnxt(i,pver,4))
4616       s(i,pver,pverp)  = stebol*(delt (i)*absnxt(i,pver,2) + delt1(i)*absnxt(i,pver,3))
4617    end do
4618    do k=ntoplw,pver-1
4619       do i=1,ncol
4620          bk2(i) = (abstot(i,k,pver) + abstot(i,k,pverp))*0.5
4621          bk1(i) = bk2(i)
4622          s(i,k,pverp) = stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
4623       end do
4624    end do
4625 !
4626 ! All k, km>1
4627 !
4628    do km=pver,ntoplw+1,-1
4629       do i=1,ncol
4630          delt(i)  = tint4(i,km-1) - tlayr4(i,km)
4631          delt1(i) = tlayr4(i,km) - tint4(i,km)
4632       end do
4633       do k=pverp,ntoplw,-1
4634          if (k == km) then
4635             do i=1,ncol
4636                bk2(i) = absnxt(i,km-1,4)
4637                bk1(i) = absnxt(i,km-1,1)
4638             end do
4639          else if (k == km-1) then
4640             do i=1,ncol
4641                bk2(i) = absnxt(i,km-1,2)
4642                bk1(i) = absnxt(i,km-1,3)
4643             end do
4644          else
4645             do i=1,ncol
4646                bk2(i) = (abstot(i,k,km-1) + abstot(i,k,km))*0.5
4647                bk1(i) = bk2(i)
4648             end do
4649          end if
4650          do i=1,ncol
4651             s(i,k,km) = s(i,k,km+1) + stebol*(bk2(i)*delt(i) + bk1(i)*delt1(i))
4652          end do
4653       end do
4654    end do
4655 !
4656 ! Computation of clear sky fluxes always set first level of fsul
4657 !
4658    do i=1,ncol
4659       fsul(i,pverp) = lwupcgs(i)
4660    end do
4661 !
4662 ! Downward clear sky fluxes store intermediate quantities in down flux
4663 ! Initialize fluxes to clear sky values.
4664 !
4665    do i=1,ncol
4666       tmp(i) = fsul(i,pverp) - stebol*tint4(i,pverp)
4667       fsul(i,ntoplw) = fsul(i,pverp) - abstot(i,ntoplw,pverp)*tmp(i) + s(i,ntoplw,ntoplw+1)
4668       fsdl(i,ntoplw) = stebol*(tplnke(i)**4)*emstot(i,ntoplw)
4669    end do
4670 !
4671 ! fsdl(i,pverp) assumes isothermal layer
4672 !
4673    do k=ntoplw+1,pver
4674       do i=1,ncol
4675          fsul(i,k) = fsul(i,pverp) - abstot(i,k,pverp)*tmp(i) + s(i,k,k+1)
4676          fsdl(i,k) = stebol*(tplnke(i)**4)*emstot(i,k) - (s(i,k,ntoplw+1) - s(i,k,k+1))
4677       end do
4678    end do
4679 !
4680 ! Store the downward emission from level 1 = total gas emission * sigma
4681 ! t**4.  fsdl does not yet include all terms
4682 !
4683    do i=1,ncol
4684       absbt(i) = stebol*(tplnke(i)**4)*emstot(i,pverp)
4685       fsdl(i,pverp) = absbt(i) - s(i,pverp,ntoplw+1)
4686    end do
4687 !
4688 !----------------------------------------------------------------------
4689 ! Modifications for clouds -- max/random overlap assumption
4690 !
4691 ! The column is divided into sets of adjacent layers, called regions,
4692 !   in which the clouds are maximally overlapped.  The clouds are
4693 !   randomly overlapped between different regions.  The number of
4694 !   regions in a column is set by nmxrgn, and the range of pressures
4695 !   included in each region is set by pmxrgn.  The max/random overlap
4696 !   can be written in terms of the solutions of random overlap with
4697 !   cloud amounts = 1.  The random overlap assumption is equivalent to
4698 !   setting the flux boundary conditions (BCs) at the edges of each region
4699 !   equal to the mean all-sky flux at those boundaries.  Since the
4700 !   emissivity array for propogating BCs is only computed for the
4701 !   TOA BC, the flux BCs elsewhere in the atmosphere have to be formulated
4702 !   in terms of solutions to the random overlap equations.  This is done
4703 !   by writing the flux BCs as the sum of a clear-sky flux and emission
4704 !   from a cloud outside the region weighted by an emissivity.  This
4705 !   emissivity is determined from the location of the cloud and the
4706 !   flux BC.
4707 !
4708 ! Copy cloud amounts to buffer with extra layer (needed for overlap logic)
4709 !
4710    cldp(:ncol,ntoplw:pver) = cld(:ncol,ntoplw:pver)
4711    cldp(:ncol,pverp) = 0.0
4712 !
4713 !
4714 ! Select only those locations where there are no clouds
4715 !    (maximum cloud fraction <= 1.e-3 treated as clear)
4716 !    Set all-sky fluxes to clear-sky values.
4717 !
4718    maxcld(1:ncol) = maxval(cldp(1:ncol,ntoplw:pver),dim=2)
4719
4720    npts = 0
4721    do i=1,ncol
4722       if (maxcld(i) < cldmin) then
4723          npts = npts + 1
4724          indx(npts) = i
4725       end if
4726    end do
4727
4728    do ii = 1, npts
4729       i = indx(ii)
4730       do k = ntoplw, pverp
4731          fdl(i,k) = fsdl(i,k)
4732          ful(i,k) = fsul(i,k)
4733       end do
4734    end do
4735 !
4736 ! Select only those locations where there are clouds
4737 !
4738    npts = 0
4739    do i=1,ncol
4740       if (maxcld(i) >= cldmin) then
4741          npts = npts + 1
4742          indx(npts) = i
4743       end if
4744    end do
4745
4746 !
4747 ! Initialize all-sky fluxes. fdl(i,1) & ful(i,pverp) are boundary conditions
4748 !
4749    do ii = 1, npts
4750       i = indx(ii)
4751       fdl(i,ntoplw) = fsdl(i,ntoplw)
4752       fdl(i,pverp)  = 0.0
4753       ful(i,ntoplw) = 0.0
4754       ful(i,pverp)  = fsul(i,pverp)
4755       do k = ntoplw+1, pver
4756          fdl(i,k) = 0.0
4757          ful(i,k) = 0.0
4758       end do
4759 !
4760 ! Initialize Planck emission from layer boundaries
4761 !
4762       do k = ntoplw, pver
4763          fclt4(i,k-1) = stebol*tint4(i,k)
4764          fclb4(i,k-1) = stebol*tint4(i,k+1)
4765       enddo
4766       fclb4(i,ntoplw-2) =  stebol*tint4(i,ntoplw)
4767       fclt4(i,pver)     = stebol*tint4(i,pverp)
4768 !
4769 ! Initialize indices for layers to be max-overlapped
4770 !
4771       do irgn = 0, nmxrgn(i)
4772          kx2(i,irgn) = ntoplw-1
4773       end do
4774       nrgn(i) = 0
4775    end do
4776
4777 !----------------------------------------------------------------------
4778 ! INDEX CALCULATIONS FOR MAX OVERLAP
4779
4780    do ii = 1, npts
4781       ilon = indx(ii)
4782
4783 !
4784 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
4785 !
4786       do irgn = 1, nmxrgn(ilon)
4787 !
4788 ! Calculate min/max layer indices inside region.
4789 !
4790          n = 0
4791          if (kx2(ilon,irgn-1) < pver) then
4792             nrgn(ilon) = irgn
4793             k1 = kx2(ilon,irgn-1)+1
4794             kx1(ilon,irgn) = k1
4795             kx2(ilon,irgn) = 0
4796             do k2 = pver, k1, -1
4797                if (pmid(ilon,k2) <= pmxrgn(ilon,irgn)) then
4798                   kx2(ilon,irgn) = k2
4799                   exit
4800                end if
4801             end do
4802 !
4803 ! Identify columns with clouds in the given region.
4804 !
4805             do k = k1, k2
4806                if (cldp(ilon,k) >= cldmin) then
4807                   n = n+1
4808                   indxmx(n,irgn) = ilon
4809                   exit
4810                endif
4811             end do
4812          endif
4813          ncolmx(irgn) = n
4814 !
4815 ! Dummy value for handling clear-sky regions
4816 !
4817 !!$         indxmx(ncolmx(irgn)+1,irgn) = ncol+1
4818 !
4819 ! Outer loop over columns with clouds in the max-overlap region
4820 !
4821          do iimx = 1, ncolmx(irgn)
4822             i = indxmx(iimx,irgn)
4823 !
4824 ! Sort cloud areas and corresponding level indices.
4825 !
4826             n = 0
4827             do k = kx1(i,irgn),kx2(i,irgn)
4828                if (cldp(i,k) >= cldmin) then
4829                   n = n+1
4830                   ksort(n) = k
4831 !
4832 ! We need indices for clouds in order of largest to smallest, so
4833 !    sort 1-cld in ascending order
4834 !
4835                   asort(n) = 1.0-cldp(i,k)
4836                end if
4837             end do
4838             nxs(i,irgn) = n
4839 !
4840 ! If nxs(i,irgn) eq 1, no need to sort.
4841 ! If nxs(i,irgn) eq 2, sort by swapping if necessary
4842 ! If nxs(i,irgn) ge 3, sort using local sort routine
4843 !
4844             if (nxs(i,irgn) == 2) then
4845                if (asort(2) < asort(1)) then
4846                   ktmp = ksort(1)
4847                   ksort(1) = ksort(2)
4848                   ksort(2) = ktmp
4849
4850                   atmp = asort(1)
4851                   asort(1) = asort(2)
4852                   asort(2) = atmp
4853                endif
4854             else if (nxs(i,irgn) >= 3) then
4855                call sortarray(nxs(i,irgn),asort,ksort(1:))
4856             endif
4857
4858             do l = 1, nxs(i,irgn)
4859                kxs(l,i,irgn) = ksort(l)
4860             end do
4861 !
4862 ! End loop over longitude i for fluxes
4863 !
4864          end do
4865 !
4866 ! End loop over regions irgn for max-overlap
4867 !
4868       end do
4869 !
4870 !----------------------------------------------------------------------
4871 ! DOWNWARD FLUXES:
4872 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
4873 !
4874       do irgn = 1, nmxrgn(ilon)
4875 !
4876 ! Compute clear-sky fluxes for regions without clouds
4877 !
4878          iimx = 1
4879          if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
4880 !
4881 ! Calculate emissivity so that downward flux at upper boundary of region
4882 !    can be cast in form of solution for downward flux from cloud above
4883 !    that boundary.  Then solutions for fluxes at other levels take form of
4884 !    random overlap expressions.  Try to locate "cloud" as close as possible
4885 !    to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
4886 !
4887             k1 = kx1(ilon,irgn)
4888             do km1 = ntoplw-2, k1-2
4889                km4 = km1+3
4890                k2 = k1
4891                k3 = k2+1
4892                tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
4893                emx0 = (fdl(ilon,k1)-fsdl(ilon,k1))/ &
4894                       ((fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))- fsdl(ilon,k1))
4895                if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
4896             end do
4897             km1 = min(km1,k1-2)
4898             do k2 = kx1(ilon,irgn)+1, kx2(ilon,irgn)+1
4899                k3 = k2+1
4900                tmp(ilon) = s(ilon,k2,min(k3,pverp))*min(1,pverp2-k3)
4901                fdl(ilon,k2) = (1.0-emx0)*fsdl(ilon,k2) + &
4902                                emx0*(fclb4(ilon,km1)-s(ilon,k2,km4)+tmp(ilon))
4903             end do
4904          else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
4905             iimx = iimx+1
4906          end if
4907 !
4908 ! Outer loop over columns with clouds in the max-overlap region
4909 !
4910          do iimx = 1, ncolmx(irgn)
4911             i = indxmx(iimx,irgn)
4912
4913 !
4914 ! Calculate emissivity so that downward flux at upper boundary of region
4915 !    can be cast in form of solution for downward flux from cloud above that
4916 !    boundary.  Then solutions for fluxes at other levels take form of
4917 !    random overlap expressions.  Try to locate "cloud" as close as possible
4918 !    to TOA such that the "cloud" pseudo-emissivity is between 0 and 1.
4919 !
4920             k1 = kx1(i,irgn)
4921             do km1 = ntoplw-2,k1-2
4922                km4 = km1+3
4923                k2 = k1
4924                k3 = k2 + 1
4925                tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
4926                tmp2(i) = s(i,k2,min(km4,pverp))*min(1,pverp2-km4)
4927                emx0 = (fdl(i,k1)-fsdl(i,k1))/((fclb4(i,km1)-tmp2(i)+tmp(i))-fsdl(i,k1))
4928                if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
4929             end do
4930             km1 = min(km1,k1-2)
4931             ksort(0) = km1 + 1
4932 !
4933 ! Loop to calculate fluxes at level k
4934 !
4935             nxsk = 0
4936             do k = kx1(i,irgn), kx2(i,irgn)
4937 !
4938 ! Identify clouds (largest to smallest area) between kx1 and k
4939 !    Since nxsk will increase with increasing k up to nxs(i,irgn), once
4940 !    nxsk == nxs(i,irgn) then use the list constructed for previous k
4941 !
4942                if (nxsk < nxs(i,irgn)) then
4943                   nxsk = 0
4944                   do l = 1, nxs(i,irgn)
4945                      k1 = kxs(l,i,irgn)
4946                      if (k >= k1) then
4947                         nxsk = nxsk + 1
4948                         ksort(nxsk) = k1
4949                      endif
4950                   end do
4951                endif
4952 !
4953 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
4954 !
4955                ksort(nxsk+1) = pverp
4956 !
4957 ! Initialize iterated emissivity factors
4958 !
4959                do l = 1, nxsk
4960                   emx(l) = emis(i,ksort(l))
4961                end do
4962 !
4963 ! Initialize iterated emissivity factor for bnd. condition at upper interface
4964 !
4965                emx(0) = emx0
4966 !
4967 ! Initialize previous cloud amounts
4968 !
4969                cld0 = 1.0
4970 !
4971 ! Indices for flux calculations
4972 !
4973                k2 = k+1
4974                k3 = k2+1
4975                tmp(i) = s(i,k2,min(k3,pverp))*min(1,pverp2-k3)
4976 !
4977 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
4978 !
4979                do l = 1, nxsk+1
4980 !
4981 ! Calculate downward fluxes
4982 !
4983                   cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
4984                   if (cld0 /= cld1) then
4985                      fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*fsdl(i,k2)
4986                      do l1 = 0, l - 1
4987                         km1 = ksort(l1)-1
4988                         km4 = km1+3
4989                         tmp2(i) = s(i,k2,min(km4,pverp))* min(1,pverp2-km4)
4990                         fdl(i,k2) = fdl(i,k2)+(cld0-cld1)*emx(l1)*(fclb4(i,km1)-tmp2(i)+tmp(i)- &
4991                                     fsdl(i,k2))
4992                      end do
4993                   endif
4994                   cld0 = cld1
4995 !
4996 ! Multiply emissivity factors by current cloud transmissivity
4997 !
4998                   if (l <= nxsk) then
4999                      k1 = ksort(l)
5000                      trans = 1.0-emis(i,k1)
5001 !
5002 ! Ideally the upper bound on l1 would be l-1, but the sort routine
5003 !    scrambles the order of layers with identical cloud amounts
5004 !
5005                      do l1 = 0, nxsk
5006                         if (ksort(l1) < k1) then
5007                            emx(l1) = emx(l1)*trans
5008                         endif
5009                      end do
5010                   end if
5011 !
5012 ! End loop over number l of cloud levels
5013 !
5014                end do
5015 !
5016 ! End loop over level k for fluxes
5017 !
5018             end do
5019 !
5020 ! End loop over longitude i for fluxes
5021 !
5022          end do
5023 !
5024 ! End loop over regions irgn for max-overlap
5025 !
5026       end do
5027
5028 !
5029 !----------------------------------------------------------------------
5030 ! UPWARD FLUXES:
5031 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
5032 !
5033       do irgn = nmxrgn(ilon), 1, -1
5034 !
5035 ! Compute clear-sky fluxes for regions without clouds
5036 !
5037          iimx = 1
5038          if (ilon < indxmx(iimx,irgn) .and. irgn <= nrgn(ilon)) then
5039 !
5040 ! Calculate emissivity so that upward flux at lower boundary of region
5041 !    can be cast in form of solution for upward flux from cloud below that
5042 !    boundary.  Then solutions for fluxes at other levels take form of
5043 !    random overlap expressions.  Try to locate "cloud" as close as possible
5044 !    to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
5045 ! Include allowance for surface emissivity (both numerator and denominator
5046 !    equal 1)
5047 !
5048             k1 = kx2(ilon,irgn)+1
5049             if (k1 < pverp) then
5050                do km1 = pver-1,kx2(ilon,irgn),-1
5051                   km3 = km1+2
5052                   k2 = k1
5053                   k3 = k2+1
5054                   tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
5055                   emx0 = (ful(ilon,k1)-fsul(ilon,k1))/ &
5056                          ((fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))- fsul(ilon,k1))
5057                   if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5058                end do
5059                km1 = max(km1,kx2(ilon,irgn))
5060             else
5061                km1 = k1-1
5062                km3 = km1+2
5063                emx0 = 1.0
5064             endif
5065
5066             do k2 = kx1(ilon,irgn), kx2(ilon,irgn)
5067                k3 = k2+1
5068 !
5069 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
5070 !
5071                tmp(ilon) = s(ilon,k2,min(km3,pverp))* min(1,pverp2-km3)
5072                ful(ilon,k2) =(1.0-emx0)*fsul(ilon,k2) + emx0* &
5073                              (fclt4(ilon,km1)+s(ilon,k2,k3)-tmp(ilon))
5074             end do
5075          else if (ilon==indxmx(iimx,irgn) .and. iimx<=ncolmx(irgn)) then
5076             iimx = iimx+1
5077          end if
5078 !
5079 ! Outer loop over columns with clouds in the max-overlap region
5080 !
5081          do iimx = 1, ncolmx(irgn)
5082             i = indxmx(iimx,irgn)
5083
5084 !
5085 ! Calculate emissivity so that upward flux at lower boundary of region
5086 !    can be cast in form of solution for upward flux from cloud at that
5087 !    boundary.  Then solutions for fluxes at other levels take form of
5088 !    random overlap expressions.  Try to locate "cloud" as close as possible
5089 !    to surface such that the "cloud" pseudo-emissivity is between 0 and 1.
5090 ! Include allowance for surface emissivity (both numerator and denominator
5091 !    equal 1)
5092 !
5093             k1 = kx2(i,irgn)+1
5094             if (k1 < pverp) then
5095                do km1 = pver-1,kx2(i,irgn),-1
5096                   km3 = km1+2
5097                   k2 = k1
5098                   k3 = k2+1
5099                   tmp(i) = s(i,k2,min(km3,pverp))*min(1,pverp2-km3)
5100                   emx0 = (ful(i,k1)-fsul(i,k1))/((fclt4(i,km1)+s(i,k2,k3)-tmp(i))-fsul(i,k1))
5101                   if (emx0 >= 0.0 .and. emx0 <= 1.0) exit
5102                end do
5103                km1 = max(km1,kx2(i,irgn))
5104             else
5105                emx0 = 1.0
5106                km1 = k1-1
5107             endif
5108             ksort(0) = km1 + 1
5109
5110 !
5111 ! Loop to calculate fluxes at level k
5112 !
5113             nxsk = 0
5114             do k = kx2(i,irgn), kx1(i,irgn), -1
5115 !
5116 ! Identify clouds (largest to smallest area) between k and kx2
5117 !    Since nxsk will increase with decreasing k up to nxs(i,irgn), once
5118 !    nxsk == nxs(i,irgn) then use the list constructed for previous k
5119 !
5120                if (nxsk < nxs(i,irgn)) then
5121                   nxsk = 0
5122                   do l = 1, nxs(i,irgn)
5123                      k1 = kxs(l,i,irgn)
5124                      if (k <= k1) then
5125                         nxsk = nxsk + 1
5126                         ksort(nxsk) = k1
5127                      endif
5128                   end do
5129                endif
5130 !
5131 ! Dummy value of index to insure computation of cloud amt is valid for l=nxsk+1
5132 !
5133                ksort(nxsk+1) = pverp
5134 !
5135 ! Initialize iterated emissivity factors
5136 !
5137                do l = 1, nxsk
5138                   emx(l) = emis(i,ksort(l))
5139                end do
5140 !
5141 ! Initialize iterated emissivity factor for bnd. condition at lower interface
5142 !
5143                emx(0) = emx0
5144 !
5145 ! Initialize previous cloud amounts
5146 !
5147                cld0 = 1.0
5148 !
5149 ! Indices for flux calculations
5150 !
5151                k2 = k
5152                k3 = k2+1
5153 !
5154 ! Loop over number of cloud levels inside region (biggest to smallest cld area)
5155 !
5156                do l = 1, nxsk+1
5157 !
5158 ! Calculate upward fluxes
5159 !
5160                   cld1 = cldp(i,ksort(l))*min(1,nxsk+1-l)
5161                   if (cld0 /= cld1) then
5162                      ful(i,k2) = ful(i,k2)+(cld0-cld1)*fsul(i,k2)
5163                      do l1 = 0, l - 1
5164                         km1 = ksort(l1)-1
5165                         km3 = km1+2
5166 !
5167 ! If km3 == pver+2, one of the s integrals = 0 (integration limits both = p_s)
5168 !
5169                         tmp(i) = s(i,k2,min(km3,pverp))* min(1,pverp2-km3)
5170                         ful(i,k2) = ful(i,k2)+(cld0-cld1)*emx(l1)* &
5171                                    (fclt4(i,km1)+s(i,k2,k3)-tmp(i)- fsul(i,k2))
5172                      end do
5173                   endif
5174                   cld0 = cld1
5175 !
5176 ! Multiply emissivity factors by current cloud transmissivity
5177 !
5178                   if (l <= nxsk) then
5179                      k1 = ksort(l)
5180                      trans = 1.0-emis(i,k1)
5181 !
5182 ! Ideally the upper bound on l1 would be l-1, but the sort routine
5183 !    scrambles the order of layers with identical cloud amounts
5184 !
5185                      do l1 = 0, nxsk
5186                         if (ksort(l1) > k1) then
5187                            emx(l1) = emx(l1)*trans
5188                         endif
5189                      end do
5190                   end if
5191 !
5192 ! End loop over number l of cloud levels
5193 !
5194                end do
5195 !
5196 ! End loop over level k for fluxes
5197 !
5198             end do
5199 !
5200 ! End loop over longitude i for fluxes
5201 !
5202          end do
5203 !
5204 ! End loop over regions irgn for max-overlap
5205 !
5206       end do
5207 !
5208 ! End outermost longitude loop
5209 !
5210    end do
5211 !
5212 ! End cloud modification loops
5213 !
5214 !----------------------------------------------------------------------
5215 ! All longitudes: store history tape quantities
5216 !
5217    do i=1,ncol
5218       flwds(i) = fdl (i,pverp )
5219       flns(i)  = ful (i,pverp ) - fdl (i,pverp )
5220       flnsc(i) = fsul(i,pverp ) - fsdl(i,pverp )
5221       flnt(i)  = ful (i,ntoplw) - fdl (i,ntoplw)
5222       flntc(i) = fsul(i,ntoplw) - fsdl(i,ntoplw)
5223       flut(i)  = ful (i,ntoplw)
5224       flutc(i) = fsul(i,ntoplw)
5225    end do
5226 !
5227 ! Computation of longwave heating (J/kg/s)
5228 !
5229    do k=ntoplw,pver
5230       do i=1,ncol
5231          qrl(i,k) = (ful(i,k) - fdl(i,k) - ful(i,k+1) + fdl(i,k+1))* &
5232                      1.E-4*gravit/((pint(i,k) - pint(i,k+1)))
5233       end do
5234    end do
5235 ! Return 0 above solution domain
5236    if ( ntoplw > 1 )then
5237       qrl(:ncol,:ntoplw-1) = 0.
5238    end if
5239
5240 ! Added downward/upward total and clear sky fluxes
5241 !
5242    do k=ntoplw,pverp
5243       do i=1,ncol
5244         flup(i,k)  = ful(i,k)
5245         flupc(i,k) = fsul(i,k)
5246         fldn(i,k)  = fdl(i,k)
5247         fldnc(i,k) = fsdl(i,k)
5248       end do
5249    end do
5250 ! Return 0 above solution domain
5251    if ( ntoplw > 1 )then
5252       flup(:ncol,:ntoplw-1) = 0.
5253       flupc(:ncol,:ntoplw-1) = 0.
5254       fldn(:ncol,:ntoplw-1) = 0.
5255       fldnc(:ncol,:ntoplw-1) = 0.
5256    end if
5257 !
5258    return
5259 end subroutine radclwmx
5260
5261 subroutine radcswmx(jj, lchnk   ,ncol    ,pcols, pver, pverp,         &
5262                     pint    ,pmid    ,h2ommr  ,rh      ,o3mmr   , &
5263                     aermmr  ,cld     ,cicewp  ,cliqwp  ,rel     , &
5264 !                   rei     ,eccf    ,coszrs  ,scon    ,solin   ,solcon,  &
5265                     rei     ,tauxcl  ,tauxci  ,eccf    ,coszrs  ,scon    ,solin   ,solcon,  &
5266                     asdir   ,asdif   ,aldir   ,aldif   ,nmxrgn  , &
5267                     pmxrgn  ,qrs     ,fsnt    ,fsntc   ,fsntoa  , &
5268                     fsntoac ,fsnirtoa,fsnrtoac,fsnrtoaq,fsns    , &
5269                     fsnsc   ,fsdsc   ,fsds    ,sols    ,soll    , &
5270                     solsd   ,solld   ,frc_day ,                   &
5271                     fsup    ,fsupc   ,fsdn    ,fsdnc   ,          &
5272                     aertau  ,aerssa  ,aerasm  ,aerfwd             )
5273 !-----------------------------------------------------------------------
5274 !
5275 ! Purpose:
5276 ! Solar radiation code
5277 !
5278 ! Method:
5279 ! Basic method is Delta-Eddington as described in:
5280 !
5281 ! Briegleb, Bruce P., 1992: Delta-Eddington
5282 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
5283 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
5284 !
5285 ! Five changes to the basic method described above are:
5286 ! (1) addition of sulfate aerosols (Kiehl and Briegleb, 1993)
5287 ! (2) the distinction between liquid and ice particle clouds
5288 ! (Kiehl et al, 1996);
5289 ! (3) provision for calculating TOA fluxes with spectral response to
5290 ! match Nimbus-7 visible/near-IR radiometers (Collins, 1998);
5291 ! (4) max-random overlap (Collins, 2001)
5292 ! (5) The near-IR absorption by H2O was updated in 2003 by Collins,
5293 !     Lee-Taylor, and Edwards for consistency with the new line data in
5294 !     Hitran 2000 and the H2O continuum version CKD 2.4.  Modifications
5295 !     were optimized by reducing RMS errors in heating rates relative
5296 !     to a series of benchmark calculations for the 5 standard AFGL
5297 !     atmospheres.  The benchmarks were performed using DISORT2 combined
5298 !     with GENLN3.  The near-IR scattering optical depths for Rayleigh
5299 !     scattering were also adjusted, as well as the correction for
5300 !     stratospheric heating by H2O.
5301 !
5302 ! The treatment of maximum-random overlap is described in the
5303 ! comment block "INDEX CALCULATIONS FOR MAX OVERLAP".
5304 !
5305 ! Divides solar spectrum into 19 intervals from 0.2-5.0 micro-meters.
5306 ! solar flux fractions specified for each interval. allows for
5307 ! seasonally and diurnally varying solar input.  Includes molecular,
5308 ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud,
5309 ! and surface absorption. Computes delta-eddington reflections and
5310 ! transmissions assuming homogeneously mixed layers. Adds the layers
5311 ! assuming scattering between layers to be isotropic, and distinguishes
5312 ! direct solar beam from scattered radiation.
5313 !
5314 ! Longitude loops are broken into 1 or 2 sections, so that only daylight
5315 ! (i.e. coszrs > 0) computations are done.
5316 !
5317 ! Note that an extra layer above the model top layer is added.
5318 !
5319 ! cgs units are used.
5320 !
5321 ! Special diagnostic calculation of the clear sky surface and total column
5322 ! absorbed flux is also done for cloud forcing diagnostics.
5323 !
5324 !-----------------------------------------------------------------------
5325 !  use shr_kind_mod, only: r8 => shr_kind_r8
5326 !  use ppgrid
5327 !  use ghg_surfvals, only: co2mmr
5328 !  use prescribed_aerosols, only: idxBG, idxSUL, idxSSLT, idxOCPHO, idxBCPHO, idxOCPHI, idxBCPHI, &
5329 !    idxDUSTfirst, numDUST, idxVOLC, naer_all
5330 !  use aer_optics, only: nrh, ndstsz, ksul, wsul, gsul, &
5331 !    ksslt, wsslt, gsslt, kcphil, wcphil, gcphil, kcphob, wcphob, gcphob, &
5332 !    kcb, wcb, gcb, kdst, wdst, gdst, kbg, wbg, gbg, kvolc, wvolc, gvolc
5333 !  use abortutils, only: endrun
5334
5335    implicit none
5336
5337    integer nspint            ! Num of spctrl intervals across solar spectrum
5338    integer naer_groups       ! Num of aerosol groups for optical diagnostics
5339
5340    parameter ( nspint = 19 )
5341    parameter ( naer_groups = 7 )    ! current groupings are sul, sslt, all carbons, all dust, and all aerosols
5342 !-----------------------Constants for new band (640-700 nm)-------------
5343    real(r8) v_raytau_35
5344    real(r8) v_raytau_64
5345    real(r8) v_abo3_35
5346    real(r8) v_abo3_64
5347    parameter( &
5348         v_raytau_35 = 0.155208, &
5349         v_raytau_64 = 0.0392, &
5350         v_abo3_35 = 2.4058030e+01, &
5351         v_abo3_64 = 2.210e+01 &
5352         )
5353
5354
5355 !-------------Parameters for accelerating max-random solution-------------
5356 !
5357 ! The solution time scales like prod(j:1->N) (1 + n_j) where
5358 ! N   = number of max-overlap regions (nmxrgn)
5359 ! n_j = number of unique cloud amounts in region j
5360 !
5361 ! Therefore the solution cost can be reduced by decreasing n_j.
5362 ! cldmin reduces n_j by treating cloud amounts < cldmin as clear sky.
5363 ! cldeps reduces n_j by treating cloud amounts identical to log(1/cldeps)
5364 ! decimal places as identical
5365 !
5366 ! areamin reduces the cost by dropping configurations that occupy
5367 ! a surface area < areamin of the model grid box.  The surface area
5368 ! for a configuration C(j,k_j), where j is the region number and k_j is the
5369 ! index for a unique cloud amount (in descending order from biggest to
5370 ! smallest clouds) in region j, is
5371 !
5372 ! A = prod(j:1->N) [C(j,k_j) - C(j,k_j+1)]
5373 !
5374 ! where C(j,0) = 1.0 and C(j,n_j+1) = 0.0.
5375 !
5376 ! nconfgmax reduces the cost and improves load balancing by setting an upper
5377 ! bound on the number of cloud configurations in the solution.  If the number
5378 ! of configurations exceeds nconfgmax, the nconfgmax configurations with the
5379 ! largest area are retained, and the fluxes are normalized by the total area
5380 ! of these nconfgmax configurations.  For the current max/random overlap
5381 ! assumption (see subroutine cldovrlap), 30 levels, and cloud-amount
5382 ! parameterization, the mean and RMS number of configurations are
5383 ! both roughly 5.  nconfgmax has been set to the mean+2*RMS number, or 15.
5384 !
5385 ! Minimum cloud amount (as a fraction of the grid-box area) to
5386 ! distinguish from clear sky
5387 !
5388    real(r8) cldmin
5389    parameter (cldmin = 1.0e-80_r8)
5390 !
5391 ! Minimimum horizontal area (as a fraction of the grid-box area) to retain
5392 ! for a unique cloud configuration in the max-random solution
5393 !
5394    real(r8) areamin
5395    parameter (areamin = 0.01_r8)
5396 !
5397 ! Decimal precision of cloud amount (0 -> preserve full resolution;
5398 ! 10^-n -> preserve n digits of cloud amount)
5399 !
5400    real(r8) cldeps
5401    parameter (cldeps = 0.0_r8)
5402 !
5403 ! Maximum number of configurations to include in solution
5404 !
5405    integer nconfgmax
5406    parameter (nconfgmax = 15)
5407 !------------------------------Commons----------------------------------
5408 !
5409 ! Input arguments
5410 !
5411    integer, intent(in) :: lchnk,jj             ! chunk identifier
5412    integer, intent(in) :: pcols, pver, pverp
5413    integer, intent(in) :: ncol              ! number of atmospheric columns
5414
5415    real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure
5416    real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
5417    real(r8), intent(in) :: h2ommr(pcols,pver) ! Specific humidity (h2o mass mix ratio)
5418    real(r8), intent(in) :: o3mmr(pcols,pver) ! Ozone mass mixing ratio
5419    real(r8), intent(in) :: aermmr(pcols,pver,naer_all) ! Aerosol mass mixing ratio
5420    real(r8), intent(in) :: rh(pcols,pver)   ! Relative humidity (fraction)
5421 !
5422    real(r8), intent(in) :: cld(pcols,pver)  ! Fractional cloud cover
5423    real(r8), intent(in) :: cicewp(pcols,pver) ! in-cloud cloud ice water path
5424    real(r8), intent(in) :: cliqwp(pcols,pver) ! in-cloud cloud liquid water path
5425    real(r8), intent(in) :: rel(pcols,pver)  ! Liquid effective drop size (microns)
5426    real(r8), intent(in) :: rei(pcols,pver)  ! Ice effective drop size (microns)
5427 !
5428    real(r8), intent(in) :: eccf             ! Eccentricity factor (1./earth-sun dist^2)
5429    real, intent(in) :: solcon           ! solar constant with eccentricity factor
5430    real(r8), intent(in) :: coszrs(pcols)    ! Cosine solar zenith angle
5431    real(r8), intent(in) :: asdir(pcols)     ! 0.2-0.7 micro-meter srfc alb: direct rad
5432    real(r8), intent(in) :: aldir(pcols)     ! 0.7-5.0 micro-meter srfc alb: direct rad
5433    real(r8), intent(in) :: asdif(pcols)     ! 0.2-0.7 micro-meter srfc alb: diffuse rad
5434    real(r8), intent(in) :: aldif(pcols)     ! 0.7-5.0 micro-meter srfc alb: diffuse rad
5435
5436    real(r8), intent(in) :: scon             ! solar constant
5437 !
5438 ! IN/OUT arguments
5439 !
5440    real(r8), intent(inout) :: pmxrgn(pcols,pverp) ! Maximum values of pressure for each
5441 !                                                 !    maximally overlapped region.
5442 !                                                 !    0->pmxrgn(i,1) is range of pressure for
5443 !                                                 !    1st region,pmxrgn(i,1)->pmxrgn(i,2) for
5444 !                                                 !    2nd region, etc
5445    integer, intent(inout) ::  nmxrgn(pcols)    ! Number of maximally overlapped regions
5446 !
5447 ! Output arguments
5448 !
5449
5450    real(r8), intent(out) :: solin(pcols)     ! Incident solar flux
5451    real(r8), intent(out) :: qrs(pcols,pver)  ! Solar heating rate
5452    real(r8), intent(out) :: fsns(pcols)      ! Surface absorbed solar flux
5453    real(r8), intent(out) :: fsnt(pcols)      ! Total column absorbed solar flux
5454    real(r8), intent(out) :: fsntoa(pcols)    ! Net solar flux at TOA
5455    real(r8), intent(out) :: fsds(pcols)      ! Flux shortwave downwelling surface
5456 !
5457    real(r8), intent(out) :: fsnsc(pcols)     ! Clear sky surface absorbed solar flux
5458    real(r8), intent(out) :: fsdsc(pcols)     ! Clear sky surface downwelling solar flux
5459    real(r8), intent(out) :: fsntc(pcols)     ! Clear sky total column absorbed solar flx
5460    real(r8), intent(out) :: fsntoac(pcols)   ! Clear sky net solar flx at TOA
5461    real(r8), intent(out) :: sols(pcols)      ! Direct solar rad on surface (< 0.7)
5462    real(r8), intent(out) :: soll(pcols)      ! Direct solar rad on surface (>= 0.7)
5463    real(r8), intent(out) :: solsd(pcols)     ! Diffuse solar rad on surface (< 0.7)
5464    real(r8), intent(out) :: solld(pcols)     ! Diffuse solar rad on surface (>= 0.7)
5465    real(r8), intent(out) :: fsnirtoa(pcols)  ! Near-IR flux absorbed at toa
5466    real(r8), intent(out) :: fsnrtoac(pcols)  ! Clear sky near-IR flux absorbed at toa
5467    real(r8), intent(out) :: fsnrtoaq(pcols)  ! Net near-IR flux at toa >= 0.7 microns
5468    real(r8), intent(out) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
5469    real(r8), intent(out) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
5470
5471 ! Added downward/upward total and clear sky fluxes
5472    real(r8), intent(out) :: fsup(pcols,pverp)      ! Total sky upward solar flux (spectrally summed)
5473    real(r8), intent(out) :: fsupc(pcols,pverp)     ! Clear sky upward solar flux (spectrally summed)
5474    real(r8), intent(out) :: fsdn(pcols,pverp)      ! Total sky downward solar flux (spectrally summed)
5475    real(r8), intent(out) :: fsdnc(pcols,pverp)     ! Clear sky downward solar flux (spectrally summed)
5476 !
5477    real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns
5478    real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
5479    real(r8) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
5480    real(r8) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
5481    real(r8) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
5482 !  real(r8), intent(out) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth
5483 !  real(r8), intent(out) :: aerssa(pcols,nspint,naer_groups) ! Aerosol column averaged single scattering albedo
5484 !  real(r8), intent(out) :: aerasm(pcols,nspint,naer_groups) ! Aerosol column averaged asymmetry parameter
5485 !  real(r8), intent(out) :: aerfwd(pcols,nspint,naer_groups) ! Aerosol column averaged forward scattering
5486 !
5487 !---------------------------Local variables-----------------------------
5488 !
5489 ! Max/random overlap variables
5490 !
5491    real(r8) asort(pverp)     ! 1 - cloud amounts to be sorted for max ovrlp.
5492    real(r8) atmp             ! Temporary storage for sort when nxs = 2
5493    real(r8) cld0             ! 1 - (cld amt) used to make wstr, cstr, nstr
5494    real(r8) totwgt           ! Total of xwgts = total fractional area of
5495 !   grid-box covered by cloud configurations
5496 !   included in solution to fluxes
5497
5498    real(r8) wgtv(nconfgmax)  ! Weights for fluxes
5499 !   1st index is configuration number
5500    real(r8) wstr(pverp,pverp) ! area weighting factors for streams
5501 !   1st index is for stream #,
5502 !   2nd index is for region #
5503
5504    real(r8) xexpt            ! solar direct beam trans. for layer above
5505    real(r8) xrdnd            ! diffuse reflectivity for layer above
5506    real(r8) xrupd            ! diffuse reflectivity for layer below
5507    real(r8) xrups            ! direct-beam reflectivity for layer below
5508    real(r8) xtdnt            ! total trans for layers above
5509
5510    real(r8) xwgt             ! product of cloud amounts
5511
5512    real(r8) yexpt            ! solar direct beam trans. for layer above
5513    real(r8) yrdnd            ! diffuse reflectivity for layer above
5514    real(r8) yrupd            ! diffuse reflectivity for layer below
5515    real(r8) ytdnd            ! dif-beam transmission for layers above
5516    real(r8) ytupd            ! dif-beam transmission for layers below
5517
5518    real(r8) zexpt            ! solar direct beam trans. for layer above
5519    real(r8) zrdnd            ! diffuse reflectivity for layer above
5520    real(r8) zrupd            ! diffuse reflectivity for layer below
5521    real(r8) zrups            ! direct-beam reflectivity for layer below
5522    real(r8) ztdnt            ! total trans for layers above
5523
5524    logical new_term          ! Flag for configurations to include in fluxes
5525    logical region_found      ! flag for identifying regions
5526
5527    integer ccon(0:pverp,nconfgmax)
5528 ! flags for presence of clouds
5529 !   1st index is for level # (including
5530 !    layer above top of model and at surface)
5531 !   2nd index is for configuration #
5532    integer cstr(0:pverp,pverp)
5533 ! flags for presence of clouds
5534 !   1st index is for level # (including
5535 !    layer above top of model and at surface)
5536 !   2nd index is for stream #
5537    integer icond(0:pverp,nconfgmax)
5538 ! Indices for copying rad. properties from
5539 !     one identical downward cld config.
5540 !     to another in adding method (step 2)
5541 !   1st index is for interface # (including
5542 !     layer above top of model and at surface)
5543 !   2nd index is for configuration # range
5544    integer iconu(0:pverp,nconfgmax)
5545 ! Indices for copying rad. properties from
5546 !     one identical upward configuration
5547 !     to another in adding method (step 2)
5548 !   1st index is for interface # (including
5549 !     layer above top of model and at surface)
5550 !   2nd index is for configuration # range
5551    integer iconfig           ! Counter for random-ovrlap configurations
5552    integer irgn              ! Index for max-overlap regions
5553    integer is0               ! Lower end of stream index range
5554    integer is1               ! Upper end of stream index range
5555    integer isn               ! Stream index
5556    integer istr(pverp+1)     ! index for stream #s during flux calculation
5557    integer istrtd(0:pverp,0:nconfgmax+1)
5558 ! indices into icond
5559 !   1st index is for interface # (including
5560 !     layer above top of model and at surface)
5561 !   2nd index is for configuration # range
5562    integer istrtu(0:pverp,0:nconfgmax+1)
5563 ! indices into iconu
5564 !   1st index is for interface # (including
5565 !     layer above top of model and at surface)
5566 !   2nd index is for configuration # range
5567    integer j                 ! Configuration index
5568    integer k1                ! Level index
5569    integer k2                ! Level index
5570    integer ksort(pverp)      ! Level indices of cloud amounts to be sorted
5571    integer ktmp              ! Temporary storage for sort when nxs = 2
5572    integer kx1(0:pverp)      ! Level index for top of max-overlap region
5573    integer kx2(0:pverp)      ! Level index for bottom of max-overlap region
5574    integer l                 ! Index
5575    integer l0                ! Index
5576    integer mrgn              ! Counter for nrgn
5577    integer mstr              ! Counter for nstr
5578    integer n0                ! Number of configurations with ccon(k,:)==0
5579    integer n1                ! Number of configurations with ccon(k,:)==1
5580    integer nconfig           ! Number of random-ovrlap configurations
5581    integer nconfigm          ! Value of config before testing for areamin,
5582 !    nconfgmax
5583    integer npasses           ! number of passes over the indexing loop
5584    integer nrgn              ! Number of max overlap regions at current
5585 !    longitude
5586    integer nstr(pverp)       ! Number of unique cloud configurations
5587 !   ("streams") in a max-overlapped region
5588 !   1st index is for region #
5589    integer nuniq             ! # of unique cloud configurations
5590    integer nuniqd(0:pverp)   ! # of unique cloud configurations: TOA
5591 !   to level k
5592    integer nuniqu(0:pverp)   ! # of unique cloud configurations: surface
5593 !   to level k
5594    integer nxs               ! Number of cloudy layers between k1 and k2
5595    integer ptr0(nconfgmax)   ! Indices of configurations with ccon(k,:)==0
5596    integer ptr1(nconfgmax)   ! Indices of configurations with ccon(k,:)==1
5597    integer ptrc(nconfgmax)   ! Pointer for configurations sorted by wgtv
5598 !  integer findvalue         ! Function for finding kth smallest element
5599 !   in a vector
5600 !  external findvalue
5601
5602 !
5603 ! Other
5604 !
5605    integer ns                ! Spectral loop index
5606    integer i                 ! Longitude loop index
5607    integer k                 ! Level loop index
5608    integer km1               ! k - 1
5609    integer kp1               ! k + 1
5610    integer n                 ! Loop index for daylight
5611    integer ndayc             ! Number of daylight columns
5612    integer idayc(pcols)      ! Daytime column indices
5613    integer indxsl            ! Index for cloud particle properties
5614    integer ksz               ! dust size bin index
5615    integer krh               ! relative humidity bin index
5616    integer kaer              ! aerosol group index
5617    real(r8) wrh              ! weight for linear interpolation between lut points
5618    real(r8) :: rhtrunc       ! rh, truncated for the purposes of extrapolating
5619                              ! aerosol optical properties
5620 !
5621 ! A. Slingo's data for cloud particle radiative properties (from 'A GCM
5622 ! Parameterization for the Shortwave Properties of Water Clouds' JAS
5623 ! vol. 46 may 1989 pp 1419-1427)
5624 !
5625    real(r8) abarl(4)         ! A coefficient for extinction optical depth
5626    real(r8) bbarl(4)         ! B coefficient for extinction optical depth
5627    real(r8) cbarl(4)         ! C coefficient for single scat albedo
5628    real(r8) dbarl(4)         ! D coefficient for single  scat albedo
5629    real(r8) ebarl(4)         ! E coefficient for asymmetry parameter
5630    real(r8) fbarl(4)         ! F coefficient for asymmetry parameter
5631
5632    save abarl, bbarl, cbarl, dbarl, ebarl, fbarl
5633
5634    data abarl/ 2.817e-02, 2.682e-02,2.264e-02,1.281e-02/
5635    data bbarl/ 1.305    , 1.346    ,1.454    ,1.641    /
5636    data cbarl/-5.62e-08 ,-6.94e-06 ,4.64e-04 ,0.201    /
5637    data dbarl/ 1.63e-07 , 2.35e-05 ,1.24e-03 ,7.56e-03 /
5638    data ebarl/ 0.829    , 0.794    ,0.754    ,0.826    /
5639    data fbarl/ 2.482e-03, 4.226e-03,6.560e-03,4.353e-03/
5640
5641    real(r8) abarli           ! A coefficient for current spectral band
5642    real(r8) bbarli           ! B coefficient for current spectral band
5643    real(r8) cbarli           ! C coefficient for current spectral band
5644    real(r8) dbarli           ! D coefficient for current spectral band
5645    real(r8) ebarli           ! E coefficient for current spectral band
5646    real(r8) fbarli           ! F coefficient for current spectral band
5647 !
5648 ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor
5649 ! greater than 20 micro-meters
5650 !
5651 ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836)
5652 !
5653    real(r8) abari(4)         ! a coefficient for extinction optical depth
5654    real(r8) bbari(4)         ! b coefficient for extinction optical depth
5655    real(r8) cbari(4)         ! c coefficient for single scat albedo
5656    real(r8) dbari(4)         ! d coefficient for single scat albedo
5657    real(r8) ebari(4)         ! e coefficient for asymmetry parameter
5658    real(r8) fbari(4)         ! f coefficient for asymmetry parameter
5659
5660    save abari, bbari, cbari, dbari, ebari, fbari
5661
5662    data abari/ 3.448e-03, 3.448e-03,3.448e-03,3.448e-03/
5663    data bbari/ 2.431    , 2.431    ,2.431    ,2.431    /
5664    data cbari/ 1.00e-05 , 1.10e-04 ,1.861e-02,.46658   /
5665    data dbari/ 0.0      , 1.405e-05,8.328e-04,2.05e-05 /
5666    data ebari/ 0.7661   , 0.7730   ,0.794    ,0.9595   /
5667    data fbari/ 5.851e-04, 5.665e-04,7.267e-04,1.076e-04/
5668
5669    real(r8) abarii           ! A coefficient for current spectral band
5670    real(r8) bbarii           ! B coefficient for current spectral band
5671    real(r8) cbarii           ! C coefficient for current spectral band
5672    real(r8) dbarii           ! D coefficient for current spectral band
5673    real(r8) ebarii           ! E coefficient for current spectral band
5674    real(r8) fbarii           ! F coefficient for current spectral band
5675 !
5676    real(r8) delta            ! Pressure (in atm) for stratos. h2o limit
5677    real(r8) o2mmr            ! O2 mass mixing ratio:
5678
5679    save delta, o2mmr
5680
5681 !
5682 ! UPDATE TO H2O NEAR-IR: Delta optimized for Hitran 2K and CKD 2.4
5683 !
5684    data delta / 0.0014257179260883 /
5685 !
5686 ! END UPDATE
5687 !
5688    data o2mmr / .23143 /
5689
5690    real(r8) albdir(pcols,nspint) ! Current spc intrvl srf alb to direct rad
5691    real(r8) albdif(pcols,nspint) ! Current spc intrvl srf alb to diffuse rad
5692 !
5693 ! Next series depends on spectral interval
5694 !
5695    real(r8) frcsol(nspint)   ! Fraction of solar flux in spectral interval
5696    real(r8) wavmin(nspint)   ! Min wavelength (micro-meters) of interval
5697    real(r8) wavmax(nspint)   ! Max wavelength (micro-meters) of interval
5698    real(r8) raytau(nspint)   ! Rayleigh scattering optical depth
5699    real(r8) abh2o(nspint)    ! Absorption coefficiant for h2o (cm2/g)
5700    real(r8) abo3 (nspint)    ! Absorption coefficiant for o3  (cm2/g)
5701    real(r8) abco2(nspint)    ! Absorption coefficiant for co2 (cm2/g)
5702    real(r8) abo2 (nspint)    ! Absorption coefficiant for o2  (cm2/g)
5703    real(r8) ph2o(nspint)     ! Weight of h2o in spectral interval
5704    real(r8) pco2(nspint)     ! Weight of co2 in spectral interval
5705    real(r8) po2 (nspint)     ! Weight of o2  in spectral interval
5706    real(r8) nirwgt(nspint)   ! Spectral Weights to simulate Nimbus-7 filter
5707    real(r8) wgtint           ! Weight for specific spectral interval
5708
5709    save frcsol ,wavmin ,wavmax ,raytau ,abh2o ,abo3 , &
5710         abco2  ,abo2   ,ph2o   ,pco2   ,po2   ,nirwgt
5711
5712    data frcsol / .001488, .001389, .001290, .001686, .002877, &
5713                  .003869, .026336, .360739, .065392, .526861, &
5714                  .526861, .526861, .526861, .526861, .526861, &
5715                  .526861, .006239, .001834, .001834/
5716 !
5717 ! weight for 0.64 - 0.7 microns  appropriate to clear skies over oceans
5718 !
5719    data nirwgt /  0.0,   0.0,   0.0,      0.0,   0.0, &
5720                   0.0,   0.0,   0.0, 0.320518,   1.0,  1.0, &
5721                   1.0,   1.0,   1.0,      1.0,   1.0, &
5722                   1.0,   1.0,   1.0 /
5723
5724    data wavmin / .200,  .245,  .265,  .275,  .285, &
5725                  .295,  .305,  .350,  .640,  .700,  .701, &
5726                  .701,  .701,  .701,  .702,  .702, &
5727                  2.630, 4.160, 4.160/
5728
5729    data wavmax / .245,  .265,  .275,  .285,  .295, &
5730                  .305,  .350,  .640,  .700, 5.000, 5.000, &
5731                  5.000, 5.000, 5.000, 5.000, 5.000, &
5732                  2.860, 4.550, 4.550/
5733
5734 !
5735 ! UPDATE TO H2O NEAR-IR: Rayleigh scattering optimized for Hitran 2K & CKD 2.4
5736 !
5737    data raytau / 4.020, 2.180, 1.700, 1.450, 1.250, &
5738                   1.085, 0.730, v_raytau_35, v_raytau_64, &
5739                   0.02899756, 0.01356763, 0.00537341, &
5740                   0.00228515, 0.00105028, 0.00046631, &
5741                   0.00025734, &
5742                  .0001, .0001, .0001/
5743 !
5744 ! END UPDATE
5745 !
5746
5747 !
5748 ! Absorption coefficients
5749 !
5750 !
5751 ! UPDATE TO H2O NEAR-IR: abh2o optimized for Hitran 2K and CKD 2.4
5752 !
5753    data abh2o /    .000,     .000,    .000,    .000,    .000, &
5754                    .000,     .000,    .000,    .000,    &
5755                    0.00256608,  0.06310504,   0.42287445, 2.45397941, &
5756                   11.20070807, 47.66091389, 240.19010243, &
5757                    .000,    .000,    .000/
5758 !
5759 ! END UPDATE
5760 !
5761
5762    data abo3  /5.370e+04, 13.080e+04,  9.292e+04, 4.530e+04, 1.616e+04, &
5763                4.441e+03,  1.775e+02, v_abo3_35, v_abo3_64,      .000, &
5764                .000,   .000    ,   .000   ,   .000   ,      .000, &
5765                .000,   .000    ,   .000   ,   .000    /
5766
5767    data abco2  /   .000,     .000,    .000,    .000,    .000, &
5768                    .000,     .000,    .000,    .000,    .000, &
5769                    .000,     .000,    .000,    .000,    .000, &
5770                    .000,     .094,    .196,   1.963/
5771
5772    data abo2  /    .000,     .000,    .000,    .000,    .000, &
5773                    .000,     .000,    .000,1.11e-05,6.69e-05, &
5774                    .000,     .000,    .000,    .000,    .000, &
5775                    .000,     .000,    .000,    .000/
5776 !
5777 ! Spectral interval weights
5778 !
5779    data ph2o  /    .000,     .000,    .000,    .000,    .000, &
5780         .000,     .000,    .000,    .000,    .505,     &
5781         .210,     .120,    .070,    .048,    .029,     &
5782         .018,     .000,    .000,    .000/
5783
5784    data pco2  /    .000,     .000,    .000,    .000,    .000, &
5785         .000,     .000,    .000,    .000,    .000,     &
5786         .000,     .000,    .000,    .000,    .000,     &
5787         .000,    1.000,    .640,    .360/
5788
5789    data po2   /    .000,     .000,    .000,    .000,    .000, &
5790         .000,     .000,    .000,   1.000,   1.000,     &
5791         .000,     .000,    .000,    .000,    .000,     &
5792         .000,     .000,    .000,    .000/
5793 !
5794 ! Diagnostic and accumulation arrays; note that sfltot, fswup, and
5795 ! fswdn are not used in the computation,but are retained for future use.
5796 !
5797    real(r8) solflx           ! Solar flux in current interval
5798    real(r8) sfltot           ! Spectrally summed total solar flux
5799    real(r8) totfld(0:pver)   ! Spectrally summed flux divergence
5800    real(r8) fswup(0:pverp)   ! Spectrally summed up flux
5801    real(r8) fswdn(0:pverp)   ! Spectrally summed down flux
5802    real(r8) fswupc(0:pverp)  ! Spectrally summed up clear sky flux
5803    real(r8) fswdnc(0:pverp)  ! Spectrally summed down clear sky flux
5804 !
5805 ! Cloud radiative property arrays
5806 !
5807 !  real(r8) tauxcl(pcols,0:pver) ! water cloud extinction optical depth
5808 !  real(r8) tauxci(pcols,0:pver) ! ice cloud extinction optical depth
5809    real(r8) wcl(pcols,0:pver) ! liquid cloud single scattering albedo
5810    real(r8) gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
5811    real(r8) fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
5812    real(r8) wci(pcols,0:pver) ! ice cloud single scattering albedo
5813    real(r8) gci(pcols,0:pver) ! ice cloud asymmetry parameter
5814    real(r8) fci(pcols,0:pver) ! ice cloud forward scattered fraction
5815 !
5816 ! Aerosol mass paths by species
5817 !
5818   real(r8) usul(pcols,pver)   ! sulfate (SO4)
5819   real(r8) ubg(pcols,pver)    ! background aerosol
5820   real(r8) usslt(pcols,pver)  ! sea-salt (SSLT)
5821   real(r8) ucphil(pcols,pver) ! hydrophilic organic carbon (OCPHI)
5822   real(r8) ucphob(pcols,pver) ! hydrophobic organic carbon (OCPHO)
5823   real(r8) ucb(pcols,pver)    ! black carbon (BCPHI + BCPHO)
5824   real(r8) uvolc(pcols,pver) ! volcanic mass
5825   real(r8) udst(ndstsz,pcols,pver) ! dust
5826
5827 !
5828 ! local variables used for the external mixing of aerosol species
5829 !
5830   real(r8) tau_sul             ! optical depth, sulfate
5831   real(r8) tau_bg              ! optical depth, background aerosol
5832   real(r8) tau_sslt            ! optical depth, sea-salt
5833   real(r8) tau_cphil           ! optical depth, hydrophilic carbon
5834   real(r8) tau_cphob           ! optical depth, hydrophobic carbon
5835   real(r8) tau_cb              ! optical depth, black carbon
5836   real(r8) tau_volc            ! optical depth, volcanic
5837   real(r8) tau_dst(ndstsz)     ! optical depth, dust, by size category
5838   real(r8) tau_dst_tot         ! optical depth, total dust
5839   real(r8) tau_tot             ! optical depth, total aerosol
5840
5841   real(r8) tau_w_sul           ! optical depth * single scattering albedo, sulfate
5842   real(r8) tau_w_bg            ! optical depth * single scattering albedo, background aerosol
5843   real(r8) tau_w_sslt          ! optical depth * single scattering albedo, sea-salt
5844   real(r8) tau_w_cphil         ! optical depth * single scattering albedo, hydrophilic carbon
5845   real(r8) tau_w_cphob         ! optical depth * single scattering albedo, hydrophobic carbon
5846   real(r8) tau_w_cb            ! optical depth * single scattering albedo, black carbon
5847   real(r8) tau_w_volc          ! optical depth * single scattering albedo, volcanic
5848   real(r8) tau_w_dst(ndstsz)   ! optical depth * single scattering albedo, dust, by size
5849   real(r8) tau_w_dst_tot       ! optical depth * single scattering albedo, total dust
5850   real(r8) tau_w_tot           ! optical depth * single scattering albedo, total aerosol
5851
5852   real(r8) tau_w_g_sul         ! optical depth * single scattering albedo * asymmetry parameter, sulfate
5853   real(r8) tau_w_g_bg          ! optical depth * single scattering albedo * asymmetry parameter, background aerosol
5854   real(r8) tau_w_g_sslt        ! optical depth * single scattering albedo * asymmetry parameter, sea-salt
5855   real(r8) tau_w_g_cphil       ! optical depth * single scattering albedo * asymmetry parameter, hydrophilic carbon
5856   real(r8) tau_w_g_cphob       ! optical depth * single scattering albedo * asymmetry parameter, hydrophobic carbon
5857   real(r8) tau_w_g_cb          ! optical depth * single scattering albedo * asymmetry parameter, black carbon
5858   real(r8) tau_w_g_volc        ! optical depth * single scattering albedo * asymmetry parameter, volcanic
5859   real(r8) tau_w_g_dst(ndstsz) ! optical depth * single scattering albedo * asymmetry parameter, dust, by size
5860   real(r8) tau_w_g_dst_tot     ! optical depth * single scattering albedo * asymmetry parameter, total dust
5861   real(r8) tau_w_g_tot         ! optical depth * single scattering albedo * asymmetry parameter, total aerosol
5862
5863   real(r8) f_sul               ! forward scattering fraction, sulfate
5864   real(r8) f_bg                ! forward scattering fraction, background aerosol
5865   real(r8) f_sslt              ! forward scattering fraction, sea-salt
5866   real(r8) f_cphil             ! forward scattering fraction, hydrophilic carbon
5867   real(r8) f_cphob             ! forward scattering fraction, hydrophobic carbon
5868   real(r8) f_cb                ! forward scattering fraction, black carbon
5869   real(r8) f_volc              ! forward scattering fraction, volcanic
5870   real(r8) f_dst(ndstsz)       ! forward scattering fraction, dust, by size
5871   real(r8) f_dst_tot           ! forward scattering fraction, total dust
5872   real(r8) f_tot               ! forward scattering fraction, total aerosol
5873
5874   real(r8) tau_w_f_sul         ! optical depth * forward scattering fraction * single scattering albedo, sulfate
5875   real(r8) tau_w_f_bg          ! optical depth * forward scattering fraction * single scattering albedo, background
5876   real(r8) tau_w_f_sslt        ! optical depth * forward scattering fraction * single scattering albedo, sea-salt
5877   real(r8) tau_w_f_cphil       ! optical depth * forward scattering fraction * single scattering albedo, hydrophilic C
5878   real(r8) tau_w_f_cphob       ! optical depth * forward scattering fraction * single scattering albedo, hydrophobic C
5879   real(r8) tau_w_f_cb          ! optical depth * forward scattering fraction * single scattering albedo, black C
5880   real(r8) tau_w_f_volc        ! optical depth * forward scattering fraction * single scattering albedo, volcanic
5881   real(r8) tau_w_f_dst(ndstsz) ! optical depth * forward scattering fraction * single scattering albedo, dust, by size
5882   real(r8) tau_w_f_dst_tot     ! optical depth * forward scattering fraction * single scattering albedo, total dust
5883   real(r8) tau_w_f_tot         ! optical depth * forward scattering fraction * single scattering albedo, total aerosol
5884   real(r8) w_dst_tot           ! single scattering albedo, total dust
5885   real(r8) w_tot               ! single scattering albedo, total aerosol
5886   real(r8) g_dst_tot           ! asymmetry parameter, total dust
5887   real(r8) g_tot               ! asymmetry parameter, total aerosol
5888   real(r8) ksuli               ! specific extinction interpolated between rh look-up-table points, sulfate
5889   real(r8) ksslti              ! specific extinction interpolated between rh look-up-table points, sea-salt
5890   real(r8) kcphili             ! specific extinction interpolated between rh look-up-table points, hydrophilic carbon
5891   real(r8) wsuli               ! single scattering albedo interpolated between rh look-up-table points, sulfate
5892   real(r8) wsslti              ! single scattering albedo interpolated between rh look-up-table points, sea-salt
5893   real(r8) wcphili             ! single scattering albedo interpolated between rh look-up-table points, hydrophilic carbon
5894   real(r8) gsuli               ! asymmetry parameter interpolated between rh look-up-table points, sulfate
5895   real(r8) gsslti              ! asymmetry parameter interpolated between rh look-up-table points, sea-salt
5896   real(r8) gcphili             ! asymmetry parameter interpolated between rh look-up-table points, hydrophilic carbon
5897 !
5898 ! Aerosol radiative property arrays
5899 !
5900    real(r8) tauxar(pcols,0:pver) ! aerosol extinction optical depth
5901    real(r8) wa(pcols,0:pver) ! aerosol single scattering albedo
5902    real(r8) ga(pcols,0:pver) ! aerosol assymetry parameter
5903    real(r8) fa(pcols,0:pver) ! aerosol forward scattered fraction
5904
5905 !
5906 ! Various arrays and other constants:
5907 !
5908    real(r8) pflx(pcols,0:pverp) ! Interface press, including extra layer
5909    real(r8) zenfac(pcols)    ! Square root of cos solar zenith angle
5910    real(r8) sqrco2           ! Square root of the co2 mass mixg ratio
5911    real(r8) tmp1             ! Temporary constant array
5912    real(r8) tmp2             ! Temporary constant array
5913    real(r8) pdel             ! Pressure difference across layer
5914    real(r8) path             ! Mass path of layer
5915    real(r8) ptop             ! Lower interface pressure of extra layer
5916    real(r8) ptho2            ! Used to compute mass path of o2
5917    real(r8) ptho3            ! Used to compute mass path of o3
5918    real(r8) pthco2           ! Used to compute mass path of co2
5919    real(r8) pthh2o           ! Used to compute mass path of h2o
5920    real(r8) h2ostr           ! Inverse sq. root h2o mass mixing ratio
5921    real(r8) wavmid(nspint)   ! Spectral interval middle wavelength
5922    real(r8) trayoslp         ! Rayleigh optical depth/standard pressure
5923    real(r8) tmp1l            ! Temporary constant array
5924    real(r8) tmp2l            ! Temporary constant array
5925    real(r8) tmp3l            ! Temporary constant array
5926    real(r8) tmp1i            ! Temporary constant array
5927    real(r8) tmp2i            ! Temporary constant array
5928    real(r8) tmp3i            ! Temporary constant array
5929    real(r8) rdenom           ! Multiple scattering term
5930    real(r8) rdirexp          ! layer direct ref times exp transmission
5931    real(r8) tdnmexp          ! total transmission - exp transmission
5932    real(r8) psf(nspint)      ! Frac of solar flux in spect interval
5933 !
5934 ! Layer absorber amounts; note that 0 refers to the extra layer added
5935 ! above the top model layer
5936 !
5937    real(r8) uh2o(pcols,0:pver) ! Layer absorber amount of h2o
5938    real(r8) uo3(pcols,0:pver) ! Layer absorber amount of  o3
5939    real(r8) uco2(pcols,0:pver) ! Layer absorber amount of co2
5940    real(r8) uo2(pcols,0:pver) ! Layer absorber amount of  o2
5941    real(r8) uaer(pcols,0:pver) ! Layer aerosol amount
5942 !
5943 ! Total column absorber amounts:
5944 !
5945    real(r8) uth2o(pcols)     ! Total column  absorber amount of  h2o
5946    real(r8) uto3(pcols)      ! Total column  absorber amount of  o3
5947    real(r8) utco2(pcols)     ! Total column  absorber amount of  co2
5948    real(r8) uto2(pcols)      ! Total column  absorber amount of  o2
5949 !
5950 ! These arrays are defined for pver model layers; 0 refers to the extra
5951 ! layer on top:
5952 !
5953    real(r8) rdir(nspint,pcols,0:pver) ! Layer reflectivity to direct rad
5954    real(r8) rdif(nspint,pcols,0:pver) ! Layer reflectivity to diffuse rad
5955    real(r8) tdir(nspint,pcols,0:pver) ! Layer transmission to direct rad
5956    real(r8) tdif(nspint,pcols,0:pver) ! Layer transmission to diffuse rad
5957    real(r8) explay(nspint,pcols,0:pver) ! Solar beam exp trans. for layer
5958
5959    real(r8) rdirc(nspint,pcols,0:pver) ! Clear Layer reflec. to direct rad
5960    real(r8) rdifc(nspint,pcols,0:pver) ! Clear Layer reflec. to diffuse rad
5961    real(r8) tdirc(nspint,pcols,0:pver) ! Clear Layer trans. to direct rad
5962    real(r8) tdifc(nspint,pcols,0:pver) ! Clear Layer trans. to diffuse rad
5963    real(r8) explayc(nspint,pcols,0:pver) ! Solar beam exp trans. clear layer
5964
5965    real(r8) flxdiv           ! Flux divergence for layer
5966 !
5967 !
5968 ! Radiative Properties:
5969 !
5970 ! There are 1 classes of properties:
5971 ! (1. All-sky bulk properties
5972 ! (2. Clear-sky properties
5973 !
5974 ! The first set of properties are generated during step 2 of the solution.
5975 !
5976 ! These arrays are defined at model interfaces; in 1st index (for level #),
5977 ! 0 is the top of the extra layer above the model top, and
5978 ! pverp is the earth surface.  2nd index is for cloud configuration
5979 ! defined over a whole column.
5980 !
5981    real(r8) exptdn(0:pverp,nconfgmax) ! Sol. beam trans from layers above
5982    real(r8) rdndif(0:pverp,nconfgmax) ! Ref to dif rad for layers above
5983    real(r8) rupdif(0:pverp,nconfgmax) ! Ref to dif rad for layers below
5984    real(r8) rupdir(0:pverp,nconfgmax) ! Ref to dir rad for layers below
5985    real(r8) tdntot(0:pverp,nconfgmax) ! Total trans for layers above
5986 !
5987 ! Bulk properties used during the clear-sky calculation.
5988 !
5989    real(r8) exptdnc(0:pverp) ! clr: Sol. beam trans from layers above
5990    real(r8) rdndifc(0:pverp) ! clr: Ref to dif rad for layers above
5991    real(r8) rupdifc(0:pverp) ! clr: Ref to dif rad for layers below
5992    real(r8) rupdirc(0:pverp) ! clr: Ref to dir rad for layers below
5993    real(r8) tdntotc(0:pverp) ! clr: Total trans for layers above
5994
5995    real(r8) fluxup(0:pverp)  ! Up   flux at model interface
5996    real(r8) fluxdn(0:pverp)  ! Down flux at model interface
5997    real(r8) wexptdn          ! Direct solar beam trans. to surface
5998
5999 !
6000 !-----------------------------------------------------------------------
6001 ! START OF CALCULATION
6002 !-----------------------------------------------------------------------
6003 !
6004 !  write (6, '(a, x, i3)') 'radcswmx : chunk identifier', lchnk
6005
6006    do i=1, ncol
6007 !
6008 ! Initialize output fields:
6009 !
6010       fsds(i)     = 0.0_r8
6011
6012       fsnirtoa(i) = 0.0_r8
6013       fsnrtoac(i) = 0.0_r8
6014       fsnrtoaq(i) = 0.0_r8
6015
6016       fsns(i)     = 0.0_r8
6017       fsnsc(i)    = 0.0_r8
6018       fsdsc(i)    = 0.0_r8
6019
6020       fsnt(i)     = 0.0_r8
6021       fsntc(i)    = 0.0_r8
6022       fsntoa(i)   = 0.0_r8
6023       fsntoac(i)  = 0.0_r8
6024
6025       solin(i)    = 0.0_r8
6026
6027       sols(i)     = 0.0_r8
6028       soll(i)     = 0.0_r8
6029       solsd(i)    = 0.0_r8
6030       solld(i)    = 0.0_r8
6031
6032 ! initialize added downward/upward total and clear sky fluxes
6033
6034          do k=1,pverp
6035             fsup(i,k)  = 0.0_r8
6036             fsupc(i,k) = 0.0_r8
6037             fsdn(i,k)  = 0.0_r8
6038             fsdnc(i,k) = 0.0_r8
6039             tauxcl(i,k-1) = 0.0_r8
6040             tauxci(i,k-1) = 0.0_r8
6041          end do
6042
6043       do k=1, pver
6044          qrs(i,k) = 0.0_r8
6045       end do
6046
6047       ! initialize aerosol diagnostic fields to 0.0
6048       ! Average can be obtained by dividing <aerod>/<frc_day>
6049       do kaer = 1, naer_groups
6050          do ns = 1, nspint
6051             frc_day(i) = 0.0_r8
6052             aertau(i,ns,kaer) = 0.0_r8
6053             aerssa(i,ns,kaer) = 0.0_r8
6054             aerasm(i,ns,kaer) = 0.0_r8
6055             aerfwd(i,ns,kaer) = 0.0_r8
6056          end do
6057       end do
6058
6059    end do
6060 !
6061 ! Compute starting, ending daytime loop indices:
6062 !  *** Note this logic assumes day and night points are contiguous so
6063 !  *** will not work in general with chunked data structure.
6064 !
6065    ndayc = 0
6066    do i=1,ncol
6067       if (coszrs(i) > 0.0_r8) then
6068          ndayc = ndayc + 1
6069          idayc(ndayc) = i
6070       end if
6071    end do
6072 !
6073 ! If night everywhere, return:
6074 !
6075    if (ndayc == 0) return
6076 !
6077 ! Perform other initializations
6078 !
6079    tmp1   = 0.5_r8/(gravit*sslp)
6080    tmp2   = delta/gravit
6081    sqrco2 = sqrt(co2mmr)
6082
6083    do n=1,ndayc
6084       i=idayc(n)
6085 !
6086 ! Define solar incident radiation and interface pressures:
6087 !
6088 !        solin(i)  = scon*eccf*coszrs(i)
6089 !WRF use SOLCON (MKS) calculated outside
6090          solin(i)  = solcon*coszrs(i)*1000.
6091          pflx(i,0) = 0._r8
6092          do k=1,pverp
6093             pflx(i,k) = pint(i,k)
6094          end do
6095 !
6096 ! Compute optical paths:
6097 !
6098          ptop      = pflx(i,1)
6099          ptho2     = o2mmr * ptop / gravit
6100          ptho3     = o3mmr(i,1) * ptop / gravit
6101          pthco2    = sqrco2 * (ptop / gravit)
6102          h2ostr    = sqrt( 1._r8 / h2ommr(i,1) )
6103          zenfac(i) = sqrt(coszrs(i))
6104          pthh2o    = ptop**2*tmp1 + (ptop*rga)* &
6105                     (h2ostr*zenfac(i)*delta)
6106          uh2o(i,0) = h2ommr(i,1)*pthh2o
6107          uco2(i,0) = zenfac(i)*pthco2
6108          uo2 (i,0) = zenfac(i)*ptho2
6109          uo3 (i,0) = ptho3
6110          uaer(i,0) = 0.0_r8
6111          do k=1,pver
6112             pdel      = pflx(i,k+1) - pflx(i,k)
6113             path      = pdel / gravit
6114             ptho2     = o2mmr * path
6115             ptho3     = o3mmr(i,k) * path
6116             pthco2    = sqrco2 * path
6117             h2ostr    = sqrt(1.0_r8/h2ommr(i,k))
6118             pthh2o    = (pflx(i,k+1)**2 - pflx(i,k)**2)*tmp1 + pdel*h2ostr*zenfac(i)*tmp2
6119             uh2o(i,k) = h2ommr(i,k)*pthh2o
6120             uco2(i,k) = zenfac(i)*pthco2
6121             uo2 (i,k) = zenfac(i)*ptho2
6122             uo3 (i,k) = ptho3
6123             usul(i,k) = aermmr(i,k,idxSUL) * path
6124             ubg(i,k) = aermmr(i,k,idxBG) * path
6125             usslt(i,k) = aermmr(i,k,idxSSLT) * path
6126             if (usslt(i,k) .lt. 0.0) then  ! usslt is sometimes small and negative, will be fixed
6127               usslt(i,k) = 0.0
6128             end if
6129             ucphil(i,k) = aermmr(i,k,idxOCPHI) * path
6130             ucphob(i,k) = aermmr(i,k,idxOCPHO) * path
6131             ucb(i,k) = ( aermmr(i,k,idxBCPHO) + aermmr(i,k,idxBCPHI) ) * path
6132             uvolc(i,k) =  aermmr(i,k,idxVOLC)
6133             do ksz = 1, ndstsz
6134               udst(ksz,i,k) = aermmr(i,k,idxDUSTfirst-1+ksz) * path
6135             end do
6136          end do
6137 !
6138 ! Compute column absorber amounts for the clear sky computation:
6139 !
6140          uth2o(i) = 0.0_r8
6141          uto3(i)  = 0.0_r8
6142          utco2(i) = 0.0_r8
6143          uto2(i)  = 0.0_r8
6144
6145          do k=1,pver
6146             uth2o(i) = uth2o(i) + uh2o(i,k)
6147             uto3(i)  = uto3(i)  + uo3(i,k)
6148             utco2(i) = utco2(i) + uco2(i,k)
6149             uto2(i)  = uto2(i)  + uo2(i,k)
6150          end do
6151 !
6152 ! Set cloud properties for top (0) layer; so long as tauxcl is zero,
6153 ! there is no cloud above top of model; the other cloud properties
6154 ! are arbitrary:
6155 !
6156          tauxcl(i,0)  = 0._r8
6157          wcl(i,0)     = 0.999999_r8
6158          gcl(i,0)     = 0.85_r8
6159          fcl(i,0)     = 0.725_r8
6160          tauxci(i,0)  = 0._r8
6161          wci(i,0)     = 0.999999_r8
6162          gci(i,0)     = 0.85_r8
6163          fci(i,0)     = 0.725_r8
6164 !
6165 ! Aerosol
6166 !
6167          tauxar(i,0)  = 0._r8
6168          wa(i,0)      = 0.925_r8
6169          ga(i,0)      = 0.850_r8
6170          fa(i,0)      = 0.7225_r8
6171 !
6172 ! End  do n=1,ndayc
6173 !
6174    end do
6175 !
6176 ! Begin spectral loop
6177 !
6178    do ns=1,nspint
6179 !
6180 ! Set index for cloud particle properties based on the wavelength,
6181 ! according to A. Slingo (1989) equations 1-3:
6182 ! Use index 1 (0.25 to 0.69 micrometers) for visible
6183 ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared
6184 ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared
6185 ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared
6186 !
6187 ! Note that the minimum wavelength is encoded (with .001, .002, .003)
6188 ! in order to specify the index appropriate for the near-infrared
6189 ! cloud absorption properties
6190 !
6191       if(wavmax(ns) <= 0.7_r8) then
6192          indxsl = 1
6193       else if(wavmin(ns) == 0.700_r8) then
6194          indxsl = 2
6195       else if(wavmin(ns) == 0.701_r8) then
6196          indxsl = 3
6197       else if(wavmin(ns) == 0.702_r8 .or. wavmin(ns) > 2.38_r8) then
6198          indxsl = 4
6199       end if
6200 !
6201 ! Set cloud extinction optical depth, single scatter albedo,
6202 ! asymmetry parameter, and forward scattered fraction:
6203 !
6204       abarli = abarl(indxsl)
6205       bbarli = bbarl(indxsl)
6206       cbarli = cbarl(indxsl)
6207       dbarli = dbarl(indxsl)
6208       ebarli = ebarl(indxsl)
6209       fbarli = fbarl(indxsl)
6210 !
6211       abarii = abari(indxsl)
6212       bbarii = bbari(indxsl)
6213       cbarii = cbari(indxsl)
6214       dbarii = dbari(indxsl)
6215       ebarii = ebari(indxsl)
6216       fbarii = fbari(indxsl)
6217 !
6218 ! adjustfraction within spectral interval to allow for the possibility of
6219 ! sub-divisions within a particular interval:
6220 !
6221       psf(ns) = 1.0_r8
6222       if(ph2o(ns)/=0._r8) psf(ns) = psf(ns)*ph2o(ns)
6223       if(pco2(ns)/=0._r8) psf(ns) = psf(ns)*pco2(ns)
6224       if(po2 (ns)/=0._r8) psf(ns) = psf(ns)*po2 (ns)
6225
6226       do n=1,ndayc
6227          i=idayc(n)
6228
6229          frc_day(i) = 1.0_r8
6230          do kaer = 1, naer_groups
6231             aertau(i,ns,kaer) = 0.0
6232             aerssa(i,ns,kaer) = 0.0
6233             aerasm(i,ns,kaer) = 0.0
6234             aerfwd(i,ns,kaer) = 0.0
6235          end do
6236
6237             do k=1,pver
6238 !
6239 ! liquid
6240 !
6241                tmp1l = abarli + bbarli/rel(i,k)
6242                tmp2l = 1._r8 - cbarli - dbarli*rel(i,k)
6243                tmp3l = fbarli*rel(i,k)
6244 !
6245 ! ice
6246 !
6247                tmp1i = abarii + bbarii/rei(i,k)
6248                tmp2i = 1._r8 - cbarii - dbarii*rei(i,k)
6249                tmp3i = fbarii*rei(i,k)
6250
6251                if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
6252                   tauxcl(i,k) = cliqwp(i,k)*tmp1l
6253                   tauxci(i,k) = cicewp(i,k)*tmp1i
6254                else
6255                   tauxcl(i,k) = 0.0
6256                   tauxci(i,k) = 0.0
6257                endif
6258 !
6259 ! Do not let single scatter albedo be 1.  Delta-eddington solution
6260 ! for non-conservative case has different analytic form from solution
6261 ! for conservative case, and raddedmx is written for non-conservative case.
6262 !
6263                wcl(i,k) = min(tmp2l,.999999_r8)
6264                gcl(i,k) = ebarli + tmp3l
6265                fcl(i,k) = gcl(i,k)*gcl(i,k)
6266 !
6267                wci(i,k) = min(tmp2i,.999999_r8)
6268                gci(i,k) = ebarii + tmp3i
6269                fci(i,k) = gci(i,k)*gci(i,k)
6270 !
6271 ! Set aerosol properties
6272 ! Conversion factor to adjust aerosol extinction (m2/g)
6273 !
6274                rhtrunc = rh(i,k)
6275                rhtrunc = min(rh(i,k),1._r8)
6276 !              if(rhtrunc.lt.0._r8) call endrun ('RADCSWMX')
6277                krh = min(floor( rhtrunc * nrh ) + 1, nrh - 1)
6278                wrh = rhtrunc * nrh - krh
6279
6280                ! linear interpolation of optical properties between rh table points
6281                ksuli = ksul(krh + 1, ns) * (wrh + 1) - ksul(krh, ns) * wrh
6282                ksslti = ksslt(krh + 1, ns) * (wrh + 1) - ksslt(krh, ns) * wrh
6283                kcphili = kcphil(krh + 1, ns) * (wrh + 1) - kcphil(krh, ns) * wrh
6284                wsuli = wsul(krh + 1, ns) * (wrh + 1) - wsul(krh, ns) * wrh
6285                wsslti = wsslt(krh + 1, ns) * (wrh + 1) - wsslt(krh, ns) * wrh
6286                wcphili = wcphil(krh + 1, ns) * (wrh + 1) - wcphil(krh, ns) * wrh
6287                gsuli = gsul(krh + 1, ns) * (wrh + 1) - gsul(krh, ns) * wrh
6288                gsslti = gsslt(krh + 1, ns) * (wrh + 1) - gsslt(krh, ns) * wrh
6289                gcphili = gcphil(krh + 1, ns) * (wrh + 1) - gcphil(krh, ns) * wrh
6290
6291                tau_sul = 1.e4 * ksuli * usul(i,k)
6292                tau_sslt = 1.e4 * ksslti * usslt(i,k)
6293                tau_cphil = 1.e4 * kcphili * ucphil(i,k)
6294                tau_cphob = 1.e4 * kcphob(ns) * ucphob(i,k)
6295                tau_cb = 1.e4 * kcb(ns) * ucb(i,k)
6296                tau_volc = 1.e3 * kvolc(ns) * uvolc(i,k)
6297                tau_dst(:) = 1.e4 * kdst(:,ns) * udst(:,i,k)
6298                tau_bg = 1.e4 * kbg(ns) * ubg(i,k)
6299
6300                tau_w_sul = tau_sul * wsuli
6301                tau_w_sslt = tau_sslt * wsslti
6302                tau_w_cphil = tau_cphil * wcphili
6303                tau_w_cphob = tau_cphob * wcphob(ns)
6304                tau_w_cb = tau_cb * wcb(ns)
6305                tau_w_volc = tau_volc * wvolc(ns)
6306                tau_w_dst(:) = tau_dst(:) * wdst(:,ns)
6307                tau_w_bg = tau_bg * wbg(ns)
6308
6309                tau_w_g_sul = tau_w_sul * gsuli
6310                tau_w_g_sslt = tau_w_sslt * gsslti
6311                tau_w_g_cphil = tau_w_cphil * gcphili
6312                tau_w_g_cphob = tau_w_cphob * gcphob(ns)
6313                tau_w_g_cb = tau_w_cb * gcb(ns)
6314                tau_w_g_volc = tau_w_volc * gvolc(ns)
6315                tau_w_g_dst(:) = tau_w_dst(:) * gdst(:,ns)
6316                tau_w_g_bg = tau_w_bg * gbg(ns)
6317
6318                f_sul = gsuli * gsuli
6319                f_sslt = gsslti * gsslti
6320                f_cphil = gcphili * gcphili
6321                f_cphob = gcphob(ns) * gcphob(ns)
6322                f_cb = gcb(ns) * gcb(ns)
6323                f_volc = gvolc(ns) * gvolc(ns)
6324                f_dst(:) = gdst(:,ns) * gdst(:,ns)
6325                f_bg = gbg(ns) * gbg(ns)
6326
6327                tau_w_f_sul = tau_w_sul * f_sul
6328                tau_w_f_bg = tau_w_bg * f_bg
6329                tau_w_f_sslt = tau_w_sslt * f_sslt
6330                tau_w_f_cphil = tau_w_cphil * f_cphil
6331                tau_w_f_cphob = tau_w_cphob * f_cphob
6332                tau_w_f_cb = tau_w_cb * f_cb
6333                tau_w_f_volc = tau_w_volc * f_volc
6334                tau_w_f_dst(:) = tau_w_dst(:) * f_dst(:)
6335 !
6336 ! mix dust aerosol size bins
6337 !   w_dst_tot, g_dst_tot, w_dst_tot are currently not used anywhere
6338 !   but calculate them anyway for future use
6339 !
6340                tau_dst_tot = sum(tau_dst)
6341                tau_w_dst_tot = sum(tau_w_dst)
6342                tau_w_g_dst_tot = sum(tau_w_g_dst)
6343                tau_w_f_dst_tot = sum(tau_w_f_dst)
6344
6345                if (tau_dst_tot .gt. 0.0) then
6346                  w_dst_tot = tau_w_dst_tot / tau_dst_tot
6347                else
6348                  w_dst_tot = 0.0
6349                endif
6350
6351                if (tau_w_dst_tot .gt. 0.0) then
6352                  g_dst_tot = tau_w_g_dst_tot / tau_w_dst_tot
6353                  f_dst_tot = tau_w_f_dst_tot / tau_w_dst_tot
6354                else
6355                  g_dst_tot = 0.0
6356                  f_dst_tot = 0.0
6357                endif
6358 !
6359 ! mix aerosols
6360 !
6361                tau_tot     = tau_sul + tau_sslt &
6362                            + tau_cphil + tau_cphob + tau_cb + tau_dst_tot
6363                tau_tot     = tau_tot + tau_bg + tau_volc
6364
6365                tau_w_tot   = tau_w_sul + tau_w_sslt &
6366                            + tau_w_cphil + tau_w_cphob + tau_w_cb + tau_w_dst_tot
6367                tau_w_tot   = tau_w_tot + tau_w_bg + tau_w_volc
6368
6369                tau_w_g_tot = tau_w_g_sul + tau_w_g_sslt &
6370                            + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb + tau_w_g_dst_tot
6371                tau_w_g_tot = tau_w_g_tot + tau_w_g_bg + tau_w_g_volc
6372
6373                tau_w_f_tot = tau_w_f_sul + tau_w_f_sslt &
6374                            + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb + tau_w_f_dst_tot
6375                tau_w_f_tot = tau_w_f_tot + tau_w_f_bg  + tau_w_f_volc
6376
6377                if (tau_tot .gt. 0.0) then
6378                  w_tot = tau_w_tot / tau_tot
6379                else
6380                  w_tot = 0.0
6381                endif
6382
6383                if (tau_w_tot .gt. 0.0) then
6384                  g_tot = tau_w_g_tot / tau_w_tot
6385                  f_tot = tau_w_f_tot / tau_w_tot
6386                else
6387                  g_tot = 0.0
6388                  f_tot = 0.0
6389                endif
6390
6391                tauxar(i,k) = tau_tot
6392                wa(i,k)     = min(w_tot, 0.999999_r8)
6393                if (g_tot.gt.1._r8) write(6,*) "g_tot > 1"
6394                if (g_tot.lt.-1._r8) write(6,*) "g_tot < -1"
6395 !              if (g_tot.gt.1._r8) call endrun ('RADCSWMX')
6396 !              if (g_tot.lt.-1._r8) call endrun ('RADCSWMX')
6397                ga(i,k)     = g_tot
6398                if (f_tot.gt.1._r8) write(6,*)"f_tot > 1"
6399                if (f_tot.lt.0._r8) write(6,*)"f_tot < 0"
6400 !              if (f_tot.gt.1._r8) call endrun ('RADCSWMX')
6401 !              if (f_tot.lt.0._r8) call endrun ('RADCSWMX')
6402                fa(i,k)     = f_tot
6403
6404                aertau(i,ns,1) = aertau(i,ns,1) + tau_sul
6405                aertau(i,ns,2) = aertau(i,ns,2) + tau_sslt
6406                aertau(i,ns,3) = aertau(i,ns,3) + tau_cphil + tau_cphob + tau_cb
6407                aertau(i,ns,4) = aertau(i,ns,4) + tau_dst_tot
6408                aertau(i,ns,5) = aertau(i,ns,5) + tau_bg
6409                aertau(i,ns,6) = aertau(i,ns,6) + tau_volc
6410                aertau(i,ns,7) = aertau(i,ns,7) + tau_tot
6411
6412                aerssa(i,ns,1) = aerssa(i,ns,1) + tau_w_sul
6413                aerssa(i,ns,2) = aerssa(i,ns,2) + tau_w_sslt
6414                aerssa(i,ns,3) = aerssa(i,ns,3) + tau_w_cphil + tau_w_cphob + tau_w_cb
6415                aerssa(i,ns,4) = aerssa(i,ns,4) + tau_w_dst_tot
6416                aerssa(i,ns,5) = aerssa(i,ns,5) + tau_w_bg
6417                aerssa(i,ns,6) = aerssa(i,ns,6) + tau_w_volc
6418                aerssa(i,ns,7) = aerssa(i,ns,7) + tau_w_tot
6419
6420                aerasm(i,ns,1) = aerasm(i,ns,1) + tau_w_g_sul
6421                aerasm(i,ns,2) = aerasm(i,ns,2) + tau_w_g_sslt
6422                aerasm(i,ns,3) = aerasm(i,ns,3) + tau_w_g_cphil + tau_w_g_cphob + tau_w_g_cb
6423                aerasm(i,ns,4) = aerasm(i,ns,4) + tau_w_g_dst_tot
6424                aerasm(i,ns,5) = aerasm(i,ns,5) + tau_w_g_bg
6425                aerasm(i,ns,6) = aerasm(i,ns,6) + tau_w_g_volc
6426                aerasm(i,ns,7) = aerasm(i,ns,7) + tau_w_g_tot
6427
6428                aerfwd(i,ns,1) = aerfwd(i,ns,1) + tau_w_f_sul
6429                aerfwd(i,ns,2) = aerfwd(i,ns,2) + tau_w_f_sslt
6430                aerfwd(i,ns,3) = aerfwd(i,ns,3) + tau_w_f_cphil + tau_w_f_cphob + tau_w_f_cb
6431                aerfwd(i,ns,4) = aerfwd(i,ns,4) + tau_w_f_dst_tot
6432                aerfwd(i,ns,5) = aerfwd(i,ns,5) + tau_w_f_bg
6433                aerfwd(i,ns,6) = aerfwd(i,ns,6) + tau_w_f_volc
6434                aerfwd(i,ns,7) = aerfwd(i,ns,7) + tau_w_f_tot
6435
6436 !
6437 ! End do k=1,pver
6438 !
6439             end do
6440
6441             ! normalize aerosol optical diagnostic fields
6442             do kaer = 1, naer_groups
6443
6444                if (aerssa(i,ns,kaer) .gt. 0.0) then   ! aerssa currently holds product of tau and ssa
6445                   aerasm(i,ns,kaer) = aerasm(i,ns,kaer) / aerssa(i,ns,kaer)
6446                   aerfwd(i,ns,kaer) = aerfwd(i,ns,kaer) / aerssa(i,ns,kaer)
6447                else
6448                   aerasm(i,ns,kaer) = 0.0_r8
6449                   aerfwd(i,ns,kaer) = 0.0_r8
6450                end if
6451
6452                if (aertau(i,ns,kaer) .gt. 0.0) then
6453                   aerssa(i,ns,kaer) = aerssa(i,ns,kaer) / aertau(i,ns,kaer)
6454                else
6455                   aerssa(i,ns,kaer) = 0.0_r8
6456                end if
6457
6458             end do
6459
6460
6461 !
6462 ! End do n=1,ndayc
6463 !
6464       end do
6465
6466 !
6467 ! Set reflectivities for surface based on mid-point wavelength
6468 !
6469       wavmid(ns) = 0.5_r8*(wavmin(ns) + wavmax(ns))
6470 !
6471 ! Wavelength less  than 0.7 micro-meter
6472 !
6473       if (wavmid(ns) < 0.7_r8 ) then
6474          do n=1,ndayc
6475             i=idayc(n)
6476                albdir(i,ns) = asdir(i)
6477                albdif(i,ns) = asdif(i)
6478          end do
6479 !
6480 ! Wavelength greater than 0.7 micro-meter
6481 !
6482       else
6483          do n=1,ndayc
6484             i=idayc(n)
6485                albdir(i,ns) = aldir(i)
6486                albdif(i,ns) = aldif(i)
6487          end do
6488       end if
6489       trayoslp = raytau(ns)/sslp
6490 !
6491 ! Layer input properties now completely specified; compute the
6492 ! delta-Eddington solution reflectivities and transmissivities
6493 ! for each layer
6494 !
6495       call raddedmx(pver, pverp, pcols, coszrs   ,ndayc    ,idayc   , &
6496               abh2o(ns),abo3(ns) ,abco2(ns),abo2(ns) , &
6497               uh2o     ,uo3      ,uco2     ,uo2      , &
6498               trayoslp ,pflx     ,ns       , &
6499               tauxcl   ,wcl      ,gcl      ,fcl      , &
6500               tauxci   ,wci      ,gci      ,fci      , &
6501               tauxar   ,wa       ,ga       ,fa       , &
6502               rdir     ,rdif     ,tdir     ,tdif     ,explay  , &
6503               rdirc    ,rdifc    ,tdirc    ,tdifc    ,explayc )
6504 !
6505 ! End spectral loop
6506 !
6507    end do
6508 !
6509 !----------------------------------------------------------------------
6510 !
6511 ! Solution for max/random cloud overlap.
6512 !
6513 ! Steps:
6514 ! (1. delta-Eddington solution for each layer (called above)
6515 !
6516 ! (2. The adding method is used to
6517 ! compute the reflectivity and transmissivity to direct and diffuse
6518 ! radiation from the top and bottom of the atmosphere for each
6519 ! cloud configuration.  This calculation is based upon the
6520 ! max-random overlap assumption.
6521 !
6522 ! (3. to solve for the fluxes, combine the
6523 ! bulk properties of the atmosphere above/below the region.
6524 !
6525 ! Index calculations for steps 2-3 are performed outside spectral
6526 ! loop to avoid redundant calculations.  Index calculations (with
6527 ! application of areamin & nconfgmax conditions) are performed
6528 ! first to identify the minimum subset of terms for the configurations
6529 ! satisfying the areamin & nconfgmax conditions. This minimum set is
6530 ! used to identify the corresponding minimum subset of terms in
6531 ! steps 2 and 3.
6532 !
6533
6534    do n=1,ndayc
6535       i=idayc(n)
6536
6537 !----------------------------------------------------------------------
6538 ! INDEX CALCULATIONS FOR MAX OVERLAP
6539 !
6540 ! The column is divided into sets of adjacent layers, called regions,
6541 ! in which the clouds are maximally overlapped.  The clouds are
6542 ! randomly overlapped between different regions.  The number of
6543 ! regions in a column is set by nmxrgn, and the range of pressures
6544 ! included in each region is set by pmxrgn.
6545 !
6546 ! The following calculations determine the number of unique cloud
6547 ! configurations (assuming maximum overlap), called "streams",
6548 ! within each region. Each stream consists of a vector of binary
6549 ! clouds (either 0 or 100% cloud cover).  Over the depth of the region,
6550 ! each stream requires a separate calculation of radiative properties. These
6551 ! properties are generated using the adding method from
6552 ! the radiative properties for each layer calculated by raddedmx.
6553 !
6554 ! The upward and downward-propagating streams are treated
6555 ! separately.
6556 !
6557 ! We will refer to a particular configuration of binary clouds
6558 ! within a single max-overlapped region as a "stream".  We will
6559 ! refer to a particular arrangement of binary clouds over the entire column
6560 ! as a "configuration".
6561 !
6562 ! This section of the code generates the following information:
6563 ! (1. nrgn    : the true number of max-overlap regions (need not = nmxrgn)
6564 ! (2. nstr    : the number of streams in a region (>=1)
6565 ! (3. cstr    : flags for presence of clouds at each layer in each stream
6566 ! (4. wstr    : the fractional horizontal area of a grid box covered
6567 ! by each stream
6568 ! (5. kx1,2   : level indices for top/bottom of each region
6569 !
6570 ! The max-overlap calculation proceeds in 3 stages:
6571 ! (1. compute layer radiative properties in raddedmx.
6572 ! (2. combine these properties between layers
6573 ! (3. combine properties to compute fluxes at each interface.
6574 !
6575 ! Most of the indexing information calculated here is used in steps 2-3
6576 ! after the call to raddedmx.
6577 !
6578 ! Initialize indices for layers to be max-overlapped
6579 !
6580 ! Loop to handle fix in totwgt=0. For original overlap config
6581 ! from npasses = 0.
6582 !
6583          npasses = 0
6584          do
6585             do irgn = 0, nmxrgn(i)
6586                kx2(irgn) = 0
6587             end do
6588             mrgn = 0
6589 !
6590 ! Outermost loop over regions (sets of adjacent layers) to be max overlapped
6591 !
6592             do irgn = 1, nmxrgn(i)
6593 !
6594 ! Calculate min/max layer indices inside region.
6595 !
6596                region_found = .false.
6597                if (kx2(irgn-1) < pver) then
6598                   k1 = kx2(irgn-1)+1
6599                   kx1(irgn) = k1
6600                   kx2(irgn) = k1-1
6601                   do k2 = pver, k1, -1
6602                      if (pmid(i,k2) <= pmxrgn(i,irgn)) then
6603                         kx2(irgn) = k2
6604                         mrgn = mrgn+1
6605                         region_found = .true.
6606                         exit
6607                      end if
6608                   end do
6609                else
6610                   exit
6611                endif
6612
6613                if (region_found) then
6614 !
6615 ! Sort cloud areas and corresponding level indices.
6616 !
6617                   nxs = 0
6618                   if (cldeps > 0) then
6619                      do k = k1,k2
6620                         if (cld(i,k) >= cldmin .and. cld(i,k) >= cldeps) then
6621                            nxs = nxs+1
6622                            ksort(nxs) = k
6623 !
6624 ! We need indices for clouds in order of largest to smallest, so
6625 ! sort 1-cld in ascending order
6626 !
6627                            asort(nxs) = 1.0_r8-(floor(cld(i,k)/cldeps)*cldeps)
6628                         end if
6629                      end do
6630                   else
6631                      do k = k1,k2
6632                         if (cld(i,k) >= cldmin) then
6633                            nxs = nxs+1
6634                            ksort(nxs) = k
6635 !
6636 ! We need indices for clouds in order of largest to smallest, so
6637 ! sort 1-cld in ascending order
6638 !
6639                            asort(nxs) = 1.0_r8-cld(i,k)
6640                         end if
6641                      end do
6642                   endif
6643 !
6644 ! If nxs eq 1, no need to sort.
6645 ! If nxs eq 2, sort by swapping if necessary
6646 ! If nxs ge 3, sort using local sort routine
6647 !
6648                   if (nxs == 2) then
6649                      if (asort(2) < asort(1)) then
6650                         ktmp = ksort(1)
6651                         ksort(1) = ksort(2)
6652                         ksort(2) = ktmp
6653
6654                         atmp = asort(1)
6655                         asort(1) = asort(2)
6656                         asort(2) = atmp
6657                      endif
6658                   else if (nxs >= 3) then
6659                      call sortarray(nxs,asort,ksort)
6660                   endif
6661 !
6662 ! Construct wstr, cstr, nstr for this region
6663 !
6664                   cstr(k1:k2,1:nxs+1) = 0
6665                   mstr = 1
6666                   cld0 = 0.0_r8
6667                   do l = 1, nxs
6668                      if (asort(l) /= cld0) then
6669                         wstr(mstr,mrgn) = asort(l) - cld0
6670                         cld0 = asort(l)
6671                         mstr = mstr + 1
6672                      endif
6673                      cstr(ksort(l),mstr:nxs+1) = 1
6674                   end do
6675                   nstr(mrgn) = mstr
6676                   wstr(mstr,mrgn) = 1.0_r8 - cld0
6677 !
6678 ! End test of region_found = true
6679 !
6680                endif
6681 !
6682 ! End loop over regions irgn for max-overlap
6683 !
6684             end do
6685             nrgn = mrgn
6686 !
6687 ! Finish construction of cstr for additional top layer
6688 !
6689             cstr(0,1:nstr(1)) = 0
6690 !
6691 ! INDEX COMPUTATIONS FOR STEP 2-3
6692 ! This section of the code generates the following information:
6693 ! (1. totwgt     step 3     total frac. area of configurations satisfying
6694 ! areamin & nconfgmax criteria
6695 ! (2. wgtv       step 3     frac. area of configurations
6696 ! (3. ccon       step 2     binary flag for clouds in each configuration
6697 ! (4. nconfig    steps 2-3  number of configurations
6698 ! (5. nuniqu/d   step 2     Number of unique cloud configurations for
6699 ! up/downwelling rad. between surface/TOA
6700 ! and level k
6701 ! (6. istrtu/d   step 2     Indices into iconu/d
6702 ! (7. iconu/d    step 2     Cloud configurations which are identical
6703 ! for up/downwelling rad. between surface/TOA
6704 ! and level k
6705 !
6706 ! Number of configurations (all permutations of streams in each region)
6707 !
6708             nconfigm = product(nstr(1: nrgn))
6709 !
6710 ! Construction of totwgt, wgtv, ccon, nconfig
6711 !
6712             istr(1: nrgn) = 1
6713             nconfig = 0
6714             totwgt = 0.0_r8
6715             new_term = .true.
6716             do iconfig = 1, nconfigm
6717                xwgt = 1.0_r8
6718                do mrgn = 1,  nrgn
6719                   xwgt = xwgt * wstr(istr(mrgn),mrgn)
6720                end do
6721                if (xwgt >= areamin) then
6722                   nconfig = nconfig + 1
6723                   if (nconfig <= nconfgmax) then
6724                      j = nconfig
6725                      ptrc(nconfig) = nconfig
6726                   else
6727                      nconfig = nconfgmax
6728                      if (new_term) then
6729                         j = findvalue(1,nconfig,wgtv,ptrc)
6730                      endif
6731                      if (wgtv(j) < xwgt) then
6732                         totwgt = totwgt - wgtv(j)
6733                         new_term = .true.
6734                      else
6735                         new_term = .false.
6736                      endif
6737                   endif
6738                   if (new_term) then
6739                      wgtv(j) = xwgt
6740                      totwgt = totwgt + xwgt
6741                      do mrgn = 1, nrgn
6742                         ccon(kx1(mrgn):kx2(mrgn),j) = cstr(kx1(mrgn):kx2(mrgn),istr(mrgn))
6743                      end do
6744                   endif
6745                endif
6746
6747                mrgn =  nrgn
6748                istr(mrgn) = istr(mrgn) + 1
6749                do while (istr(mrgn) > nstr(mrgn) .and. mrgn > 1)
6750                   istr(mrgn) = 1
6751                   mrgn = mrgn - 1
6752                   istr(mrgn) = istr(mrgn) + 1
6753                end do
6754 !
6755 ! End do iconfig = 1, nconfigm
6756 !
6757             end do
6758 !
6759 ! If totwgt = 0 implement maximum overlap and make another pass
6760 ! if totwgt = 0 on this second pass then terminate.
6761 !
6762             if (totwgt > 0.) then
6763                exit
6764             else
6765                npasses = npasses + 1
6766                if (npasses >= 2 ) then
6767                   write(6,*)'RADCSWMX: Maximum overlap of column ','failed'
6768 !                 call endrun
6769                endif
6770                nmxrgn(i)=1
6771                pmxrgn(i,1)=1.0e30
6772             end if
6773 !
6774 ! End npasses = 0, do
6775 !
6776          end do
6777 !
6778 !
6779 ! Finish construction of ccon
6780 !
6781          ccon(0,:) = 0
6782          ccon(pverp,:) = 0
6783 !
6784 ! Construction of nuniqu/d, istrtu/d, iconu/d using binary tree
6785 !
6786          nuniqd(0) = 1
6787          nuniqu(pverp) = 1
6788
6789          istrtd(0,1) = 1
6790          istrtu(pverp,1) = 1
6791
6792          do j = 1, nconfig
6793             icond(0,j)=j
6794             iconu(pverp,j)=j
6795          end do
6796
6797          istrtd(0,2) = nconfig+1
6798          istrtu(pverp,2) = nconfig+1
6799
6800          do k = 1, pverp
6801             km1 = k-1
6802             nuniq = 0
6803             istrtd(k,1) = 1
6804             do l0 = 1, nuniqd(km1)
6805                is0 = istrtd(km1,l0)
6806                is1 = istrtd(km1,l0+1)-1
6807                n0 = 0
6808                n1 = 0
6809                do isn = is0, is1
6810                   j = icond(km1,isn)
6811                   if (ccon(k,j) == 0) then
6812                      n0 = n0 + 1
6813                      ptr0(n0) = j
6814                   endif
6815                   if (ccon(k,j) == 1) then
6816                      n1 = n1 + 1
6817                      ptr1(n1) = j
6818                   endif
6819                end do
6820                if (n0 > 0) then
6821                   nuniq = nuniq + 1
6822                   istrtd(k,nuniq+1) = istrtd(k,nuniq)+n0
6823                   icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) =  ptr0(1:n0)
6824                endif
6825                if (n1 > 0) then
6826                   nuniq = nuniq + 1
6827                   istrtd(k,nuniq+1) = istrtd(k,nuniq)+n1
6828                   icond(k,istrtd(k,nuniq):istrtd(k,nuniq+1)-1) =  ptr1(1:n1)
6829                endif
6830             end do
6831             nuniqd(k) = nuniq
6832          end do
6833
6834          do k = pver, 0, -1
6835             kp1 = k+1
6836             nuniq = 0
6837             istrtu(k,1) = 1
6838             do l0 = 1, nuniqu(kp1)
6839                is0 = istrtu(kp1,l0)
6840                is1 = istrtu(kp1,l0+1)-1
6841                n0 = 0
6842                n1 = 0
6843                do isn = is0, is1
6844                   j = iconu(kp1,isn)
6845                   if (ccon(k,j) == 0) then
6846                      n0 = n0 + 1
6847                      ptr0(n0) = j
6848                   endif
6849                   if (ccon(k,j) == 1) then
6850                      n1 = n1 + 1
6851                      ptr1(n1) = j
6852                   endif
6853                end do
6854                if (n0 > 0) then
6855                   nuniq = nuniq + 1
6856                   istrtu(k,nuniq+1) = istrtu(k,nuniq)+n0
6857                   iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) =  ptr0(1:n0)
6858                endif
6859                if (n1 > 0) then
6860                   nuniq = nuniq + 1
6861                   istrtu(k,nuniq+1) = istrtu(k,nuniq)+n1
6862                   iconu(k,istrtu(k,nuniq):istrtu(k,nuniq+1)-1) = ptr1(1:n1)
6863                endif
6864             end do
6865             nuniqu(k) = nuniq
6866          end do
6867 !
6868 !----------------------------------------------------------------------
6869 ! End of index calculations
6870 !----------------------------------------------------------------------
6871
6872
6873 !----------------------------------------------------------------------
6874 ! Start of flux calculations
6875 !----------------------------------------------------------------------
6876 !
6877 ! Initialize spectrally integrated totals:
6878 !
6879          do k=0,pver
6880             totfld(k) = 0.0_r8
6881             fswup (k) = 0.0_r8
6882             fswdn (k) = 0.0_r8
6883             fswupc (k) = 0.0_r8
6884             fswdnc (k) = 0.0_r8
6885          end do
6886
6887          sfltot        = 0.0_r8
6888          fswup (pverp) = 0.0_r8
6889          fswdn (pverp) = 0.0_r8
6890          fswupc (pverp) = 0.0_r8
6891          fswdnc (pverp) = 0.0_r8
6892 !
6893 ! Start spectral interval
6894 !
6895          do ns = 1,nspint
6896             wgtint = nirwgt(ns)
6897 !----------------------------------------------------------------------
6898 ! STEP 2
6899 !
6900 !
6901 ! Apply adding method to solve for radiative properties
6902 !
6903 ! First initialize the bulk properties at TOA
6904 !
6905             rdndif(0,1:nconfig) = 0.0_r8
6906             exptdn(0,1:nconfig) = 1.0_r8
6907             tdntot(0,1:nconfig) = 1.0_r8
6908 !
6909 ! Solve for properties involving downward propagation of radiation.
6910 ! The bulk properties are:
6911 !
6912 ! (1. exptdn   Sol. beam dwn. trans from layers above
6913 ! (2. rdndif   Ref to dif rad for layers above
6914 ! (3. tdntot   Total trans for layers above
6915 !
6916             do k = 1, pverp
6917                km1 = k - 1
6918                do l0 = 1, nuniqd(km1)
6919                   is0 = istrtd(km1,l0)
6920                   is1 = istrtd(km1,l0+1)-1
6921
6922                   j = icond(km1,is0)
6923
6924                   xexpt   = exptdn(km1,j)
6925                   xrdnd   = rdndif(km1,j)
6926                   tdnmexp = tdntot(km1,j) - xexpt
6927
6928                   if (ccon(km1,j) == 1) then
6929 !
6930 ! If cloud in layer, use cloudy layer radiative properties
6931 !
6932                      ytdnd = tdif(ns,i,km1)
6933                      yrdnd = rdif(ns,i,km1)
6934
6935                      rdenom  = 1._r8/(1._r8-yrdnd*xrdnd)
6936                      rdirexp = rdir(ns,i,km1)*xexpt
6937
6938                      zexpt = xexpt * explay(ns,i,km1)
6939                      zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
6940                      ztdnt = xexpt*tdir(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)*rdenom
6941                   else
6942 !
6943 ! If clear layer, use clear-sky layer radiative properties
6944 !
6945                      ytdnd = tdifc(ns,i,km1)
6946                      yrdnd = rdifc(ns,i,km1)
6947
6948                      rdenom  = 1._r8/(1._r8-yrdnd*xrdnd)
6949                      rdirexp = rdirc(ns,i,km1)*xexpt
6950
6951                      zexpt = xexpt * explayc(ns,i,km1)
6952                      zrdnd = yrdnd + xrdnd*(ytdnd**2)*rdenom
6953                      ztdnt = xexpt*tdirc(ns,i,km1) + ytdnd* &
6954                                             (tdnmexp + xrdnd*rdirexp)*rdenom
6955                   endif
6956
6957 !
6958 ! If 2 or more configurations share identical properties at a given level k,
6959 ! the properties (at level k) are computed once and copied to
6960 ! all the configurations for efficiency.
6961 !
6962                   do isn = is0, is1
6963                      j = icond(km1,isn)
6964                      exptdn(k,j) = zexpt
6965                      rdndif(k,j) = zrdnd
6966                      tdntot(k,j) = ztdnt
6967                   end do
6968 !
6969 ! end do l0 = 1, nuniqd(k)
6970 !
6971                end do
6972 !
6973 ! end do k = 1, pverp
6974 !
6975             end do
6976 !
6977 ! Solve for properties involving upward propagation of radiation.
6978 ! The bulk properties are:
6979 !
6980 ! (1. rupdif   Ref to dif rad for layers below
6981 ! (2. rupdir   Ref to dir rad for layers below
6982 !
6983 ! Specify surface boundary conditions (surface albedos)
6984 !
6985             rupdir(pverp,1:nconfig) = albdir(i,ns)
6986             rupdif(pverp,1:nconfig) = albdif(i,ns)
6987
6988             do k = pver, 0, -1
6989                do l0 = 1, nuniqu(k)
6990                   is0 = istrtu(k,l0)
6991                   is1 = istrtu(k,l0+1)-1
6992
6993                   j = iconu(k,is0)
6994
6995                   xrupd = rupdif(k+1,j)
6996                   xrups = rupdir(k+1,j)
6997
6998                   if (ccon(k,j) == 1) then
6999 !
7000 ! If cloud in layer, use cloudy layer radiative properties
7001 !
7002                      yexpt = explay(ns,i,k)
7003                      yrupd = rdif(ns,i,k)
7004                      ytupd = tdif(ns,i,k)
7005
7006                      rdenom  = 1._r8/( 1._r8 - yrupd*xrupd)
7007                      tdnmexp = (tdir(ns,i,k)-yexpt)
7008                      rdirexp = xrups*yexpt
7009
7010                      zrupd = yrupd + xrupd*(ytupd**2)*rdenom
7011                      zrups = rdir(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
7012                   else
7013 !
7014 ! If clear layer, use clear-sky layer radiative properties
7015 !
7016                      yexpt = explayc(ns,i,k)
7017                      yrupd = rdifc(ns,i,k)
7018                      ytupd = tdifc(ns,i,k)
7019
7020                      rdenom  = 1._r8/( 1._r8 - yrupd*xrupd)
7021                      tdnmexp = (tdirc(ns,i,k)-yexpt)
7022                      rdirexp = xrups*yexpt
7023
7024                      zrupd = yrupd + xrupd*(ytupd**2)*rdenom
7025                      zrups = rdirc(ns,i,k) + ytupd*(rdirexp + xrupd*tdnmexp)*rdenom
7026                   endif
7027
7028 !
7029 ! If 2 or more configurations share identical properties at a given level k,
7030 ! the properties (at level k) are computed once and copied to
7031 ! all the configurations for efficiency.
7032 !
7033                   do isn = is0, is1
7034                      j = iconu(k,isn)
7035                      rupdif(k,j) = zrupd
7036                      rupdir(k,j) = zrups
7037                   end do
7038 !
7039 ! end do l0 = 1, nuniqu(k)
7040 !
7041                end do
7042 !
7043 ! end do k = pver,0,-1
7044 !
7045             end do
7046 !
7047 !----------------------------------------------------------------------
7048 !
7049 ! STEP 3
7050 !
7051 ! Compute up and down fluxes for each interface k.  This requires
7052 ! adding up the contributions from all possible permutations
7053 ! of streams in all max-overlap regions, weighted by the
7054 ! product of the fractional areas of the streams in each region
7055 ! (the random overlap assumption).  The adding principle has been
7056 ! used in step 2 to combine the bulk radiative properties
7057 ! above and below the interface.
7058 !
7059             do k = 0,pverp
7060 !
7061 ! Initialize the fluxes
7062 !
7063                fluxup(k)=0.0_r8
7064                fluxdn(k)=0.0_r8
7065
7066                do iconfig = 1, nconfig
7067                   xwgt = wgtv(iconfig)
7068                   xexpt = exptdn(k,iconfig)
7069                   xtdnt = tdntot(k,iconfig)
7070                   xrdnd = rdndif(k,iconfig)
7071                   xrupd = rupdif(k,iconfig)
7072                   xrups = rupdir(k,iconfig)
7073 !
7074 ! Flux computation
7075 !
7076                   rdenom = 1._r8/(1._r8 - xrdnd * xrupd)
7077
7078                   fluxup(k) = fluxup(k) + xwgt *  &
7079                               ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom)
7080                   fluxdn(k) = fluxdn(k) + xwgt *  &
7081                               (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom)
7082 !
7083 ! End do iconfig = 1, nconfig
7084 !
7085                end do
7086 !
7087 ! Normalize by total area covered by cloud configurations included
7088 ! in solution
7089 !
7090                fluxup(k)=fluxup(k) / totwgt
7091                fluxdn(k)=fluxdn(k) / totwgt
7092 !
7093 ! End do k = 0,pverp
7094 !
7095             end do
7096 !
7097 ! Initialize the direct-beam flux at surface
7098 !
7099             wexptdn = 0.0_r8
7100
7101             do iconfig = 1, nconfig
7102                wexptdn =  wexptdn + wgtv(iconfig) * exptdn(pverp,iconfig)
7103             end do
7104
7105             wexptdn = wexptdn / totwgt
7106 !
7107 ! Monochromatic computation completed; accumulate in totals
7108 !
7109             solflx   = solin(i)*frcsol(ns)*psf(ns)
7110             fsnt(i)  = fsnt(i) + solflx*(fluxdn(1) - fluxup(1))
7111             fsntoa(i)= fsntoa(i) + solflx*(fluxdn(0) - fluxup(0))
7112             fsns(i)  = fsns(i) + solflx*(fluxdn(pverp)-fluxup(pverp))
7113             sfltot   = sfltot + solflx
7114             fswup(0) = fswup(0) + solflx*fluxup(0)
7115             fswdn(0) = fswdn(0) + solflx*fluxdn(0)
7116 !
7117 ! Down spectral fluxes need to be in mks; thus the .001 conversion factors
7118 !
7119             if (wavmid(ns) < 0.7_r8) then
7120                sols(i)  = sols(i) + wexptdn*solflx*0.001_r8
7121                solsd(i) = solsd(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
7122             else
7123                soll(i)  = soll(i) + wexptdn*solflx*0.001_r8
7124                solld(i) = solld(i)+(fluxdn(pverp)-wexptdn)*solflx*0.001_r8
7125                fsnrtoaq(i) = fsnrtoaq(i) + solflx*(fluxdn(0) - fluxup(0))
7126             end if
7127             fsnirtoa(i) = fsnirtoa(i) + wgtint*solflx*(fluxdn(0) - fluxup(0))
7128
7129             do k=0,pver
7130 !
7131 ! Compute flux divergence in each layer using the interface up and down
7132 ! fluxes:
7133 !
7134                kp1 = k+1
7135                flxdiv = (fluxdn(k  ) - fluxdn(kp1)) + (fluxup(kp1) - fluxup(k  ))
7136                totfld(k)  = totfld(k)  + solflx*flxdiv
7137                fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1)
7138                fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1)
7139             end do
7140 !
7141 ! Perform clear-sky calculation
7142 !
7143             exptdnc(0) =   1.0_r8
7144             rdndifc(0) =   0.0_r8
7145             tdntotc(0) =   1.0_r8
7146             rupdirc(pverp) = albdir(i,ns)
7147             rupdifc(pverp) = albdif(i,ns)
7148
7149             do k = 1, pverp
7150                km1 = k - 1
7151                xexpt = exptdnc(km1)
7152                xrdnd = rdndifc(km1)
7153                yrdnd = rdifc(ns,i,km1)
7154                ytdnd = tdifc(ns,i,km1)
7155
7156                exptdnc(k) = xexpt*explayc(ns,i,km1)
7157
7158                rdenom  = 1._r8/(1._r8 - yrdnd*xrdnd)
7159                rdirexp = rdirc(ns,i,km1)*xexpt
7160                tdnmexp = tdntotc(km1) - xexpt
7161
7162                tdntotc(k) = xexpt*tdirc(ns,i,km1) + ytdnd*(tdnmexp + xrdnd*rdirexp)* &
7163                                 rdenom
7164                rdndifc(k) = yrdnd + xrdnd*(ytdnd**2)*rdenom
7165             end do
7166
7167             do k=pver,0,-1
7168                xrupd = rupdifc(k+1)
7169                yexpt = explayc(ns,i,k)
7170                yrupd = rdifc(ns,i,k)
7171                ytupd = tdifc(ns,i,k)
7172
7173                rdenom = 1._r8/( 1._r8 - yrupd*xrupd)
7174
7175                rupdirc(k) = rdirc(ns,i,k) + ytupd*(rupdirc(k+1)*yexpt + &
7176                             xrupd*(tdirc(ns,i,k)-yexpt))*rdenom
7177                rupdifc(k) = yrupd + xrupd*ytupd**2*rdenom
7178             end do
7179
7180             do k=0,1
7181                rdenom    = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
7182                fluxup(k) = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
7183                            rdenom
7184                fluxdn(k) = exptdnc(k) + &
7185                            (tdntotc(k) - exptdnc(k) + exptdnc(k)*rupdirc(k)*rdndifc(k))* &
7186                            rdenom
7187                fswupc(k) = fswupc(k) + solflx*fluxup(k)
7188                fswdnc(k) = fswdnc(k) + solflx*fluxdn(k)
7189             end do
7190 !           k = pverp
7191             do k=2,pverp
7192             rdenom      = 1._r8/(1._r8 - rdndifc(k)*rupdifc(k))
7193             fluxup(k)   = (exptdnc(k)*rupdirc(k) + (tdntotc(k)-exptdnc(k))*rupdifc(k))* &
7194                            rdenom
7195             fluxdn(k)   = exptdnc(k) + (tdntotc(k) - exptdnc(k) + &
7196                           exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom
7197             fswupc(k)   = fswupc(k) + solflx*fluxup(k)
7198             fswdnc(k)   = fswdnc(k) + solflx*fluxdn(k)
7199             end do
7200
7201             fsntc(i)    = fsntc(i)+solflx*(fluxdn(1)-fluxup(1))
7202             fsntoac(i)  = fsntoac(i)+solflx*(fluxdn(0)-fluxup(0))
7203             fsnsc(i)    = fsnsc(i)+solflx*(fluxdn(pverp)-fluxup(pverp))
7204             fsdsc(i)    = fsdsc(i)+solflx*(fluxdn(pverp))
7205             fsnrtoac(i) = fsnrtoac(i)+wgtint*solflx*(fluxdn(0)-fluxup(0))
7206 !
7207 ! End of clear sky calculation
7208 !
7209
7210 !
7211 ! End of spectral interval loop
7212 !
7213          end do
7214 !
7215 ! Compute solar heating rate (J/kg/s)
7216 !
7217          do k=1,pver
7218             qrs(i,k) = -1.E-4*gravit*totfld(k)/(pint(i,k) - pint(i,k+1))
7219          end do
7220
7221 ! Added downward/upward total and clear sky fluxes
7222
7223          do k=1,pverp
7224             fsup(i,k)  = fswup(k)
7225             fsupc(i,k) = fswupc(k)
7226             fsdn(i,k)  = fswdn(k)
7227             fsdnc(i,k) = fswdnc(k)
7228          end do
7229 !
7230 ! Set the downwelling flux at the surface
7231 !
7232          fsds(i) = fswdn(pverp)
7233 !
7234 ! End do n=1,ndayc
7235 !
7236    end do
7237
7238 !  write (6, '(a, x, i3)') 'radcswmx : exiting, chunk identifier', lchnk
7239
7240    return
7241 end subroutine radcswmx
7242
7243 subroutine raddedmx(pver, pverp, pcols, coszrs  ,ndayc   ,idayc   ,abh2o   , &
7244                     abo3    ,abco2   ,abo2    ,uh2o    ,uo3     , &
7245                     uco2    ,uo2     ,trayoslp,pflx    ,ns      , &
7246                     tauxcl  ,wcl     ,gcl     ,fcl     ,tauxci  , &
7247                     wci     ,gci     ,fci     ,tauxar  ,wa      , &
7248                     ga      ,fa      ,rdir    ,rdif    ,tdir    , &
7249                     tdif    ,explay  ,rdirc   ,rdifc   ,tdirc   , &
7250                     tdifc   ,explayc )
7251 !-----------------------------------------------------------------------
7252 !
7253 ! Purpose:
7254 ! Computes layer reflectivities and transmissivities, from the top down
7255 ! to the surface using the delta-Eddington solutions for each layer
7256 !
7257 ! Method:
7258 ! For more details , see Briegleb, Bruce P., 1992: Delta-Eddington
7259 ! Approximation for Solar Radiation in the NCAR Community Climate Model,
7260 ! Journal of Geophysical Research, Vol 97, D7, pp7603-7612).
7261 !
7262 ! Modified for maximum/random cloud overlap by Bill Collins and John
7263 !    Truesdale
7264 !
7265 ! Author: Bill Collins
7266 !
7267 !-----------------------------------------------------------------------
7268 !  use shr_kind_mod, only: r8 => shr_kind_r8
7269 !  use ppgrid
7270
7271    implicit none
7272
7273    integer nspint           ! Num of spctrl intervals across solar spectrum
7274
7275    parameter ( nspint = 19 )
7276 !
7277 ! Minimum total transmission below which no layer computation are done:
7278 !
7279    real(r8) trmin                ! Minimum total transmission allowed
7280    real(r8) wray                 ! Rayleigh single scatter albedo
7281    real(r8) gray                 ! Rayleigh asymetry parameter
7282    real(r8) fray                 ! Rayleigh forward scattered fraction
7283
7284    parameter (trmin = 1.e-3)
7285    parameter (wray = 0.999999)
7286    parameter (gray = 0.0)
7287    parameter (fray = 0.1)
7288 !
7289 !------------------------------Arguments--------------------------------
7290 !
7291 ! Input arguments
7292 !
7293    integer, intent(in) :: pver, pverp, pcols
7294    real(r8), intent(in) :: coszrs(pcols)        ! Cosine zenith angle
7295    real(r8), intent(in) :: trayoslp             ! Tray/sslp
7296    real(r8), intent(in) :: pflx(pcols,0:pverp)  ! Interface pressure
7297    real(r8), intent(in) :: abh2o                ! Absorption coefficiant for h2o
7298    real(r8), intent(in) :: abo3                 ! Absorption coefficiant for o3
7299    real(r8), intent(in) :: abco2                ! Absorption coefficiant for co2
7300    real(r8), intent(in) :: abo2                 ! Absorption coefficiant for o2
7301    real(r8), intent(in) :: uh2o(pcols,0:pver)   ! Layer absorber amount of h2o
7302    real(r8), intent(in) :: uo3(pcols,0:pver)    ! Layer absorber amount of  o3
7303    real(r8), intent(in) :: uco2(pcols,0:pver)   ! Layer absorber amount of co2
7304    real(r8), intent(in) :: uo2(pcols,0:pver)    ! Layer absorber amount of  o2
7305    real(r8), intent(in) :: tauxcl(pcols,0:pver) ! Cloud extinction optical depth (liquid)
7306    real(r8), intent(in) :: wcl(pcols,0:pver)    ! Cloud single scattering albedo (liquid)
7307    real(r8), intent(in) :: gcl(pcols,0:pver)    ! Cloud asymmetry parameter (liquid)
7308    real(r8), intent(in) :: fcl(pcols,0:pver)    ! Cloud forward scattered fraction (liquid)
7309    real(r8), intent(in) :: tauxci(pcols,0:pver) ! Cloud extinction optical depth (ice)
7310    real(r8), intent(in) :: wci(pcols,0:pver)    ! Cloud single scattering albedo (ice)
7311    real(r8), intent(in) :: gci(pcols,0:pver)    ! Cloud asymmetry parameter (ice)
7312    real(r8), intent(in) :: fci(pcols,0:pver)    ! Cloud forward scattered fraction (ice)
7313    real(r8), intent(in) :: tauxar(pcols,0:pver) ! Aerosol extinction optical depth
7314    real(r8), intent(in) :: wa(pcols,0:pver)     ! Aerosol single scattering albedo
7315    real(r8), intent(in) :: ga(pcols,0:pver)     ! Aerosol asymmetry parameter
7316    real(r8), intent(in) :: fa(pcols,0:pver)     ! Aerosol forward scattered fraction
7317
7318    integer, intent(in) :: ndayc                 ! Number of daylight columns
7319    integer, intent(in) :: idayc(pcols)          ! Daylight column indices
7320    integer, intent(in) :: ns                    ! Index of spectral interval
7321 !
7322 ! Input/Output arguments
7323 !
7324 ! Following variables are defined for each layer; 0 refers to extra
7325 ! layer above top of model:
7326 !
7327    real(r8), intent(inout) :: rdir(nspint,pcols,0:pver)   ! Layer reflectivity to direct rad
7328    real(r8), intent(inout) :: rdif(nspint,pcols,0:pver)   ! Layer reflectivity to diffuse rad
7329    real(r8), intent(inout) :: tdir(nspint,pcols,0:pver)   ! Layer transmission to direct rad
7330    real(r8), intent(inout) :: tdif(nspint,pcols,0:pver)   ! Layer transmission to diffuse rad
7331    real(r8), intent(inout) :: explay(nspint,pcols,0:pver) ! Solar beam exp transm for layer
7332 !
7333 ! Corresponding quantities for clear-skies
7334 !
7335    real(r8), intent(inout) :: rdirc(nspint,pcols,0:pver)  ! Clear layer reflec. to direct rad
7336    real(r8), intent(inout) :: rdifc(nspint,pcols,0:pver)  ! Clear layer reflec. to diffuse rad
7337    real(r8), intent(inout) :: tdirc(nspint,pcols,0:pver)  ! Clear layer trans. to direct rad
7338    real(r8), intent(inout) :: tdifc(nspint,pcols,0:pver)  ! Clear layer trans. to diffuse rad
7339    real(r8), intent(inout) :: explayc(nspint,pcols,0:pver)! Solar beam exp transm clear layer
7340 !
7341 !---------------------------Local variables-----------------------------
7342 !
7343    integer i                 ! Column indices
7344    integer k                 ! Level index
7345    integer nn                ! Index of column loops (max=ndayc)
7346
7347    real(r8) taugab(pcols)        ! Layer total gas absorption optical depth
7348    real(r8) tauray(pcols)        ! Layer rayleigh optical depth
7349    real(r8) taucsc               ! Layer cloud scattering optical depth
7350    real(r8) tautot               ! Total layer optical depth
7351    real(r8) wtot                 ! Total layer single scatter albedo
7352    real(r8) gtot                 ! Total layer asymmetry parameter
7353    real(r8) ftot                 ! Total layer forward scatter fraction
7354    real(r8) wtau                 !  rayleigh layer scattering optical depth
7355    real(r8) wt                   !  layer total single scattering albedo
7356    real(r8) ts                   !  layer scaled extinction optical depth
7357    real(r8) ws                   !  layer scaled single scattering albedo
7358    real(r8) gs                   !  layer scaled asymmetry parameter
7359 !
7360 !---------------------------Statement functions-------------------------
7361 !
7362 ! Statement functions and other local variables
7363 !
7364    real(r8) alpha                ! Term in direct reflect and transmissivity
7365    real(r8) gamma                ! Term in direct reflect and transmissivity
7366    real(r8) el                   ! Term in alpha,gamma,n,u
7367    real(r8) taus                 ! Scaled extinction optical depth
7368    real(r8) omgs                 ! Scaled single particle scattering albedo
7369    real(r8) asys                 ! Scaled asymmetry parameter
7370    real(r8) u                    ! Term in diffuse reflect and
7371 !    transmissivity
7372    real(r8) n                    ! Term in diffuse reflect and
7373 !    transmissivity
7374    real(r8) lm                   ! Temporary for el
7375    real(r8) ne                   ! Temporary for n
7376    real(r8) w                    ! Dummy argument for statement function
7377    real(r8) uu                   ! Dummy argument for statement function
7378    real(r8) g                    ! Dummy argument for statement function
7379    real(r8) e                    ! Dummy argument for statement function
7380    real(r8) f                    ! Dummy argument for statement function
7381    real(r8) t                    ! Dummy argument for statement function
7382    real(r8) et                   ! Dummy argument for statement function
7383 !
7384 ! Intermediate terms for delta-eddington solution
7385 !
7386    real(r8) alp                  ! Temporary for alpha
7387    real(r8) gam                  ! Temporary for gamma
7388    real(r8) ue                   ! Temporary for u
7389    real(r8) arg                  ! Exponential argument
7390    real(r8) extins               ! Extinction
7391    real(r8) amg                  ! Alp - gam
7392    real(r8) apg                  ! Alp + gam
7393 !
7394    alpha(w,uu,g,e) = .75_r8*w*uu*((1._r8 + g*(1._r8-w))/(1._r8 - e*e*uu*uu))
7395    gamma(w,uu,g,e) = .50_r8*w*((3._r8*g*(1._r8-w)*uu*uu + 1._r8)/(1._r8-e*e*uu*uu))
7396    el(w,g)         = sqrt(3._r8*(1._r8-w)*(1._r8 - w*g))
7397    taus(w,f,t)     = (1._r8 - w*f)*t
7398    omgs(w,f)       = (1._r8 - f)*w/(1._r8 - w*f)
7399    asys(g,f)       = (g - f)/(1._r8 - f)
7400    u(w,g,e)        = 1.5_r8*(1._r8 - w*g)/e
7401    n(uu,et)        = ((uu+1._r8)*(uu+1._r8)/et ) - ((uu-1._r8)*(uu-1._r8)*et)
7402 !
7403 !-----------------------------------------------------------------------
7404 !
7405 ! Compute layer radiative properties
7406 !
7407 ! Compute radiative properties (reflectivity and transmissivity for
7408 !    direct and diffuse radiation incident from above, under clear
7409 !    and cloudy conditions) and transmission of direct radiation
7410 !    (under clear and cloudy conditions) for each layer.
7411 !
7412    do k=0,pver
7413       do nn=1,ndayc
7414          i=idayc(nn)
7415             tauray(i) = trayoslp*(pflx(i,k+1)-pflx(i,k))
7416             taugab(i) = abh2o*uh2o(i,k) + abo3*uo3(i,k) + abco2*uco2(i,k) + abo2*uo2(i,k)
7417             tautot = tauxcl(i,k) + tauxci(i,k) + tauray(i) + taugab(i) + tauxar(i,k)
7418             taucsc = tauxcl(i,k)*wcl(i,k) + tauxci(i,k)*wci(i,k) + tauxar(i,k)*wa(i,k)
7419             wtau   = wray*tauray(i)
7420             wt     = wtau + taucsc
7421             wtot   = wt/tautot
7422             gtot   = (wtau*gray + gcl(i,k)*wcl(i,k)*tauxcl(i,k) &
7423                      + gci(i,k)*wci(i,k)*tauxci(i,k) + ga(i,k) *wa(i,k) *tauxar(i,k))/wt
7424             ftot   = (wtau*fray + fcl(i,k)*wcl(i,k)*tauxcl(i,k) &
7425                      + fci(i,k)*wci(i,k)*tauxci(i,k) + fa(i,k) *wa(i,k) *tauxar(i,k))/wt
7426             ts   = taus(wtot,ftot,tautot)
7427             ws   = omgs(wtot,ftot)
7428             gs   = asys(gtot,ftot)
7429             lm   = el(ws,gs)
7430             alp  = alpha(ws,coszrs(i),gs,lm)
7431             gam  = gamma(ws,coszrs(i),gs,lm)
7432             ue   = u(ws,gs,lm)
7433 !
7434 !     Limit argument of exponential to 25, in case lm very large:
7435 !
7436             arg  = min(lm*ts,25._r8)
7437             extins = exp(-arg)
7438             ne = n(ue,extins)
7439             rdif(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
7440             tdif(ns,i,k)   =   4._r8*ue/ne
7441 !
7442 !     Limit argument of exponential to 25, in case coszrs is very small:
7443 !
7444             arg       = min(ts/coszrs(i),25._r8)
7445             explay(ns,i,k) = exp(-arg)
7446             apg = alp + gam
7447             amg = alp - gam
7448             rdir(ns,i,k) = amg*(tdif(ns,i,k)*explay(ns,i,k)-1._r8) + apg*rdif(ns,i,k)
7449             tdir(ns,i,k) = apg*tdif(ns,i,k) + (amg*rdif(ns,i,k)-(apg-1._r8))*explay(ns,i,k)
7450 !
7451 !     Under rare conditions, reflectivies and transmissivities can be
7452 !     negative; zero out any negative values
7453 !
7454             rdir(ns,i,k) = max(rdir(ns,i,k),0.0_r8)
7455             tdir(ns,i,k) = max(tdir(ns,i,k),0.0_r8)
7456             rdif(ns,i,k) = max(rdif(ns,i,k),0.0_r8)
7457             tdif(ns,i,k) = max(tdif(ns,i,k),0.0_r8)
7458 !
7459 !     Clear-sky calculation
7460 !
7461             if (tauxcl(i,k) == 0.0_r8 .and. tauxci(i,k) == 0.0_r8) then
7462
7463                rdirc(ns,i,k) = rdir(ns,i,k)
7464                tdirc(ns,i,k) = tdir(ns,i,k)
7465                rdifc(ns,i,k) = rdif(ns,i,k)
7466                tdifc(ns,i,k) = tdif(ns,i,k)
7467                explayc(ns,i,k) = explay(ns,i,k)
7468             else
7469                tautot = tauray(i) + taugab(i) + tauxar(i,k)
7470                taucsc = tauxar(i,k)*wa(i,k)
7471 !
7472 ! wtau already computed for all-sky
7473 !
7474                wt     = wtau + taucsc
7475                wtot   = wt/tautot
7476                gtot   = (wtau*gray + ga(i,k)*wa(i,k)*tauxar(i,k))/wt
7477                ftot   = (wtau*fray + fa(i,k)*wa(i,k)*tauxar(i,k))/wt
7478                ts   = taus(wtot,ftot,tautot)
7479                ws   = omgs(wtot,ftot)
7480                gs   = asys(gtot,ftot)
7481                lm   = el(ws,gs)
7482                alp  = alpha(ws,coszrs(i),gs,lm)
7483                gam  = gamma(ws,coszrs(i),gs,lm)
7484                ue   = u(ws,gs,lm)
7485 !
7486 !     Limit argument of exponential to 25, in case lm very large:
7487 !
7488                arg  = min(lm*ts,25._r8)
7489                extins = exp(-arg)
7490                ne = n(ue,extins)
7491                rdifc(ns,i,k) = (ue+1._r8)*(ue-1._r8)*(1._r8/extins - extins)/ne
7492                tdifc(ns,i,k)   =   4._r8*ue/ne
7493 !
7494 !     Limit argument of exponential to 25, in case coszrs is very small:
7495 !
7496                arg       = min(ts/coszrs(i),25._r8)
7497                explayc(ns,i,k) = exp(-arg)
7498                apg = alp + gam
7499                amg = alp - gam
7500                rdirc(ns,i,k) = amg*(tdifc(ns,i,k)*explayc(ns,i,k)-1._r8)+ &
7501                                apg*rdifc(ns,i,k)
7502                tdirc(ns,i,k) = apg*tdifc(ns,i,k) + (amg*rdifc(ns,i,k) - (apg-1._r8))* &
7503                                explayc(ns,i,k)
7504 !
7505 !     Under rare conditions, reflectivies and transmissivities can be
7506 !     negative; zero out any negative values
7507 !
7508                rdirc(ns,i,k) = max(rdirc(ns,i,k),0.0_r8)
7509                tdirc(ns,i,k) = max(tdirc(ns,i,k),0.0_r8)
7510                rdifc(ns,i,k) = max(rdifc(ns,i,k),0.0_r8)
7511                tdifc(ns,i,k) = max(tdifc(ns,i,k),0.0_r8)
7512             end if
7513          end do
7514    end do
7515
7516    return
7517 end subroutine raddedmx
7518
7519 subroutine radinp(lchnk   ,ncol    , pcols, pver, pverp,     &
7520                   pmid    ,pint    ,o3vmr   , pmidrd  ,&
7521                   pintrd  ,eccf    ,o3mmr   )
7522 !-----------------------------------------------------------------------
7523 !
7524 ! Purpose:
7525 ! Set latitude and time dependent arrays for input to solar
7526 ! and longwave radiation.
7527 ! Convert model pressures to cgs, and compute ozone mixing ratio, needed for
7528 ! the solar radiation.
7529 !
7530 ! Method:
7531 ! <Describe the algorithm(s) used in the routine.>
7532 ! <Also include any applicable external references.>
7533 !
7534 ! Author: CCM1, CMS Contact J. Kiehl
7535 !
7536 !-----------------------------------------------------------------------
7537 !  use shr_kind_mod, only: r8 => shr_kind_r8
7538 !  use ppgrid
7539 !  use time_manager, only: get_curr_calday
7540
7541    implicit none
7542
7543 !------------------------------Arguments--------------------------------
7544 !
7545 ! Input arguments
7546 !
7547    integer, intent(in) :: lchnk                ! chunk identifier
7548    integer, intent(in) :: pcols, pver, pverp
7549    integer, intent(in) :: ncol                 ! number of atmospheric columns
7550
7551    real(r8), intent(in) :: pmid(pcols,pver)    ! Pressure at model mid-levels (pascals)
7552    real(r8), intent(in) :: pint(pcols,pverp)   ! Pressure at model interfaces (pascals)
7553    real(r8), intent(in) :: o3vmr(pcols,pver)   ! ozone volume mixing ratio
7554 !
7555 ! Output arguments
7556 !
7557    real(r8), intent(out) :: pmidrd(pcols,pver)  ! Pressure at mid-levels (dynes/cm*2)
7558    real(r8), intent(out) :: pintrd(pcols,pverp) ! Pressure at interfaces (dynes/cm*2)
7559    real(r8), intent(out) :: eccf                ! Earth-sun distance factor
7560    real(r8), intent(out) :: o3mmr(pcols,pver)   ! Ozone mass mixing ratio
7561
7562 !
7563 !---------------------------Local variables-----------------------------
7564 !
7565    integer i                ! Longitude loop index
7566    integer k                ! Vertical loop index
7567
7568    real(r8) :: calday           ! current calendar day
7569    real(r8) amd                 ! Effective molecular weight of dry air (g/mol)
7570    real(r8) amo                 ! Molecular weight of ozone (g/mol)
7571    real(r8) vmmr                ! Ozone volume mixing ratio
7572    real(r8) delta               ! Solar declination angle
7573
7574    save     amd   ,amo
7575
7576    data amd   /  28.9644   /
7577    data amo   /  48.0000   /
7578 !
7579 !-----------------------------------------------------------------------
7580 !
7581 !  calday = get_curr_calday()
7582    eccf = 1. ! declared intent(out) so fill a value (not used in WRF)
7583 !  call shr_orb_decl (calday  ,eccen     ,mvelpp  ,lambm0  ,obliqr  , &
7584 !                     delta   ,eccf)
7585
7586 !
7587 ! Convert pressure from pascals to dynes/cm2
7588 !
7589    do k=1,pver
7590       do i=1,ncol
7591          pmidrd(i,k) = pmid(i,k)*10.0
7592          pintrd(i,k) = pint(i,k)*10.0
7593       end do
7594    end do
7595    do i=1,ncol
7596       pintrd(i,pverp) = pint(i,pverp)*10.0
7597    end do
7598 !
7599 ! Convert ozone volume mixing ratio to mass mixing ratio:
7600 !
7601    vmmr = amo/amd
7602    do k=1,pver
7603       do i=1,ncol
7604          o3mmr(i,k) = vmmr*o3vmr(i,k)
7605       end do
7606    end do
7607 !
7608    return
7609 end subroutine radinp
7610 subroutine radoz2(lchnk   ,ncol    ,pcols, pver, pverp, o3vmr   ,pint    ,plol    ,plos, ntoplw    )
7611 !-----------------------------------------------------------------------
7612 !
7613 ! Purpose:
7614 ! Computes the path length integrals to the model interfaces given the
7615 ! ozone volume mixing ratio
7616 !
7617 ! Method:
7618 ! <Describe the algorithm(s) used in the routine.>
7619 ! <Also include any applicable external references.>
7620 !
7621 ! Author: CCM1, CMS Contact J. Kiehl
7622 !
7623 !-----------------------------------------------------------------------
7624 !  use shr_kind_mod, only: r8 => shr_kind_r8
7625 !  use ppgrid
7626 !  use comozp
7627
7628    implicit none
7629 !------------------------------Input arguments--------------------------
7630 !
7631    integer, intent(in) :: lchnk                ! chunk identifier
7632    integer, intent(in) :: ncol                 ! number of atmospheric columns
7633    integer, intent(in) :: pcols, pver, pverp
7634
7635    real(r8), intent(in) :: o3vmr(pcols,pver)   ! ozone volume mixing ratio
7636    real(r8), intent(in) :: pint(pcols,pverp)   ! Model interface pressures
7637
7638    integer, intent(in) :: ntoplw               ! topmost level/layer longwave is solved for
7639
7640 !
7641 !----------------------------Output arguments---------------------------
7642 !
7643    real(r8), intent(out) :: plol(pcols,pverp)   ! Ozone prs weighted path length (cm)
7644    real(r8), intent(out) :: plos(pcols,pverp)   ! Ozone path length (cm)
7645
7646 !
7647 !---------------------------Local workspace-----------------------------
7648 !
7649    integer i                ! longitude index
7650    integer k                ! level index
7651 !
7652 !-----------------------------------------------------------------------
7653 !
7654 ! Evaluate the ozone path length integrals to interfaces;
7655 ! factors of .1 and .01 to convert pressures from cgs to mks:
7656 !
7657    do i=1,ncol
7658       plos(i,ntoplw) = 0.1 *cplos*o3vmr(i,ntoplw)*pint(i,ntoplw)
7659       plol(i,ntoplw) = 0.01*cplol*o3vmr(i,ntoplw)*pint(i,ntoplw)*pint(i,ntoplw)
7660    end do
7661    do k=ntoplw+1,pverp
7662       do i=1,ncol
7663          plos(i,k) = plos(i,k-1) + 0.1*cplos*o3vmr(i,k-1)*(pint(i,k) - pint(i,k-1))
7664          plol(i,k) = plol(i,k-1) + 0.01*cplol*o3vmr(i,k-1)* &
7665                     (pint(i,k)*pint(i,k) - pint(i,k-1)*pint(i,k-1))
7666       end do
7667    end do
7668 !
7669    return
7670 end subroutine radoz2
7671
7672
7673 subroutine radozn (lchnk, ncol, pcols, pver,pmid, pin, levsiz, ozmix, o3vmr)
7674 !-----------------------------------------------------------------------
7675 !
7676 ! Purpose: Interpolate ozone from current time-interpolated values to model levels
7677 !
7678 ! Method: Use pressure values to determine interpolation levels
7679 !
7680 ! Author: Bruce Briegleb
7681 !
7682 !--------------------------------------------------------------------------
7683 !  use shr_kind_mod, only: r8 => shr_kind_r8
7684 !  use ppgrid
7685 !  use phys_grid,     only: get_lat_all_p, get_lon_all_p
7686 !  use comozp
7687 !  use abortutils, only: endrun
7688 !--------------------------------------------------------------------------
7689    implicit none
7690 !--------------------------------------------------------------------------
7691 !
7692 ! Arguments
7693 !
7694    integer, intent(in) :: lchnk               ! chunk identifier
7695    integer, intent(in) :: pcols, pver
7696    integer, intent(in) :: ncol                ! number of atmospheric columns
7697    integer, intent(in) :: levsiz              ! number of ozone layers
7698
7699    real(r8), intent(in) :: pmid(pcols,pver)   ! level pressures (mks)
7700    real(r8), intent(in) :: pin(levsiz)        ! ozone data level pressures (mks)
7701    real(r8), intent(in) :: ozmix(pcols,levsiz) ! ozone mixing ratio
7702
7703    real(r8), intent(out) :: o3vmr(pcols,pver) ! ozone volume mixing ratio
7704 !
7705 ! local storage
7706 !
7707    integer i                   ! longitude index
7708    integer k, kk, kkstart      ! level indices
7709    integer kupper(pcols)       ! Level indices for interpolation
7710    integer kount               ! Counter
7711    integer lats(pcols)         ! latitude indices
7712    integer lons(pcols)         ! latitude indices
7713
7714    real(r8) dpu                ! upper level pressure difference
7715    real(r8) dpl                ! lower level pressure difference
7716 !
7717 ! Initialize latitude indices
7718 !
7719 !  call get_lat_all_p(lchnk, ncol, lats)
7720 !  call get_lon_all_p(lchnk, ncol, lons)
7721 !
7722 ! Initialize index array
7723 !
7724    do i=1,ncol
7725       kupper(i) = 1
7726    end do
7727
7728    do k=1,pver
7729 !
7730 ! Top level we need to start looking is the top level for the previous k
7731 ! for all longitude points
7732 !
7733       kkstart = levsiz
7734       do i=1,ncol
7735          kkstart = min0(kkstart,kupper(i))
7736       end do
7737       kount = 0
7738 !
7739 ! Store level indices for interpolation
7740 !
7741       do kk=kkstart,levsiz-1
7742          do i=1,ncol
7743             if (pin(kk).lt.pmid(i,k) .and. pmid(i,k).le.pin(kk+1)) then
7744                kupper(i) = kk
7745                kount = kount + 1
7746             end if
7747          end do
7748 !
7749 ! If all indices for this level have been found, do the interpolation and
7750 ! go to the next level
7751 !
7752          if (kount.eq.ncol) then
7753             do i=1,ncol
7754                dpu = pmid(i,k) - pin(kupper(i))
7755                dpl = pin(kupper(i)+1) - pmid(i,k)
7756                o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
7757                              ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
7758             end do
7759             goto 35
7760          end if
7761       end do
7762 !
7763 ! If we've fallen through the kk=1,levsiz-1 loop, we cannot interpolate and
7764 ! must extrapolate from the bottom or top ozone data level for at least some
7765 ! of the longitude points.
7766 !
7767       do i=1,ncol
7768          if (pmid(i,k) .lt. pin(1)) then
7769             o3vmr(i,k) = ozmix(i,1)*pmid(i,k)/pin(1)
7770          else if (pmid(i,k) .gt. pin(levsiz)) then
7771             o3vmr(i,k) = ozmix(i,levsiz)
7772          else
7773             dpu = pmid(i,k) - pin(kupper(i))
7774             dpl = pin(kupper(i)+1) - pmid(i,k)
7775             o3vmr(i,k) = (ozmix(i,kupper(i))*dpl + &
7776                           ozmix(i,kupper(i)+1)*dpu)/(dpl + dpu)
7777          end if
7778       end do
7779
7780       if (kount.gt.ncol) then
7781 !        call endrun ('RADOZN: Bad ozone data: non-monotonicity suspected')
7782       end if
7783 35    continue
7784    end do
7785
7786    return
7787 end subroutine radozn
7788
7789
7790 #endif
7791
7792 end MODULE module_ra_cam