1 2! KGEN-generated Fortran source file 3! 4! Filename : rrtmg_sw_taumol.f90 5! Generated at: 2015-07-07 00:48:24 6! KGEN version: 0.4.13 7 8 9 10 MODULE rrtmg_sw_taumol 11 USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check 12 ! -------------------------------------------------------------------------- 13 ! | | 14 ! | Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | 15 ! | This software may be used, copied, or redistributed as long as it is | 16 ! | not sold and this copyright notice is reproduced on each copy made. | 17 ! | This model is provided as is without any express or implied warranties. | 18 ! | (http://www.rtweb.aer.com/) | 19 ! | | 20 ! -------------------------------------------------------------------------- 21 ! ------- Modules ------- 22 USE shr_kind_mod, ONLY: r8 => shr_kind_r8 23 ! use parkind, only : jpim, jprb 24 ! use parrrsw, only : mg, jpband, nbndsw, ngptsw 25 USE rrsw_con, ONLY: oneminus 26 USE rrsw_wvn, ONLY: nspa 27 USE rrsw_wvn, ONLY: nspb 28 USE rrsw_vsn, ONLY: hvrtau 29 USE parrrsw, ONLY: ngptsw 30 IMPLICIT NONE 31 CONTAINS 32 33 ! write subroutines 34 ! No subroutines 35 ! No module extern variables 36 !---------------------------------------------------------------------------- 37 38 SUBROUTINE taumol_sw(ncol,nlayers, colh2o, colco2, colch4, colo2, colo3, colmol, laytrop, jp, jt, jt1, fac00, fac01, fac10, & 39 fac11, selffac, selffrac, indself, forfac, forfrac, indfor, sfluxzen, taug, taur) 40 !---------------------------------------------------------------------------- 41 ! ****************************************************************************** 42 ! * * 43 ! * Optical depths developed for the * 44 ! * * 45 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * 46 ! * * 47 ! * * 48 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * 49 ! * 131 HARTWELL AVENUE * 50 ! * LEXINGTON, MA 02421 * 51 ! * * 52 ! * * 53 ! * ELI J. MLAWER * 54 ! * JENNIFER DELAMERE * 55 ! * STEVEN J. TAUBMAN * 56 ! * SHEPARD A. CLOUGH * 57 ! * * 58 ! * * 59 ! * * 60 ! * * 61 ! * email: mlawer@aer.com * 62 ! * email: jdelamer@aer.com * 63 ! * * 64 ! * The authors wish to acknowledge the contributions of the * 65 ! * following people: Patrick D. Brown, Michael J. Iacono, * 66 ! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * 67 ! * * 68 ! ****************************************************************************** 69 ! * TAUMOL * 70 ! * * 71 ! * This file contains the subroutines TAUGBn (where n goes from * 72 ! * 1 to 28). TAUGBn calculates the optical depths and Planck fractions * 73 ! * per g-value and layer for band n. * 74 ! * * 75 ! * Output: optical depths (unitless) * 76 ! * fractions needed to compute Planck functions at every layer * 77 ! * and g-value * 78 ! * * 79 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * 80 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * 81 ! * * 82 ! * Input * 83 ! * * 84 ! * PARAMETER (MG=16, MXLAY=203, NBANDS=14) * 85 ! * * 86 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * 87 ! * COMMON /PRECISE/ ONEMINUS * 88 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * 89 ! * & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * 90 ! * COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * 91 ! * & COLH2O(MXLAY),COLCO2(MXLAY), * 92 ! * & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * 93 ! * & COLO2(MXLAY),CO2MULT(MXLAY) * 94 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * 95 ! * & FAC10(MXLAY),FAC11(MXLAY) * 96 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * 97 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * 98 ! * * 99 ! * Description: * 100 ! * NG(IBAND) - number of g-values in band IBAND * 101 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * 102 ! * atmospheres that are stored for band IBAND per * 103 ! * pressure level and temperature. Each of these * 104 ! * atmospheres has different relative amounts of the * 105 ! * key species for the band (i.e. different binary * 106 ! * species parameters). * 107 ! * NSPB(IBAND) - same for upper atmosphere * 108 ! * ONEMINUS - since problems are caused in some cases by interpolation * 109 ! * parameters equal to or greater than 1, for these cases * 110 ! * these parameters are set to this value, slightly < 1. * 111 ! * PAVEL - layer pressures (mb) * 112 ! * TAVEL - layer temperatures (degrees K) * 113 ! * PZ - level pressures (mb) * 114 ! * TZ - level temperatures (degrees K) * 115 ! * LAYTROP - layer at which switch is made from one combination of * 116 ! * key species to another * 117 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * 118 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * 119 ! * respectively (molecules/cm**2) * 120 ! * CO2MULT - for bands in which carbon dioxide is implemented as a * 121 ! * trace species, this is the factor used to multiply the * 122 ! * band's average CO2 absorption coefficient to get the added * 123 ! * contribution to the optical depth relative to 355 ppm. * 124 ! * FACij(LAY) - for layer LAY, these are factors that are needed to * 125 ! * compute the interpolation factors that multiply the * 126 ! * appropriate reference k-values. A value of 0 (1) for * 127 ! * i,j indicates that the corresponding factor multiplies * 128 ! * reference k-value for the lower (higher) of the two * 129 ! * appropriate temperatures, and altitudes, respectively. * 130 ! * JP - the index of the lower (in altitude) of the two appropriate * 131 ! * reference pressure levels needed for interpolation * 132 ! * JT, JT1 - the indices of the lower of the two appropriate reference * 133 ! * temperatures needed for interpolation (for pressure * 134 ! * levels JP and JP+1, respectively) * 135 ! * SELFFAC - scale factor needed to water vapor self-continuum, equals * 136 ! * (water vapor density)/(atmospheric density at 296K and * 137 ! * 1013 mb) * 138 ! * SELFFRAC - factor needed for temperature interpolation of reference * 139 ! * water vapor self-continuum data * 140 ! * INDSELF - index of the lower of the two appropriate reference * 141 ! * temperatures needed for the self-continuum interpolation * 142 ! * * 143 ! * Data input * 144 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * 145 ! * (note: n is the band number) * 146 ! * * 147 ! * Description: * 148 ! * KA - k-values for low reference atmospheres (no water vapor * 149 ! * self-continuum) (units: cm**2/molecule) * 150 ! * KB - k-values for high reference atmospheres (all sources) * 151 ! * (units: cm**2/molecule) * 152 ! * SELFREF - k-values for water vapor self-continuum for reference * 153 ! * atmospheres (used below LAYTROP) * 154 ! * (units: cm**2/molecule) * 155 ! * * 156 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * 157 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * 158 ! * * 159 ! ***************************************************************************** 160 ! 161 ! Modifications 162 ! 163 ! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003 164 ! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003 165 ! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 166 ! 167 ! ------- Declarations ------- 168 ! ----- Input ----- 169 INTEGER, intent(in) :: nlayers ! total number of layers 170 INTEGER, intent(in) :: ncol ! total number of layers 171 INTEGER, intent(in) :: laytrop(ncol) ! tropopause layer index 172 INTEGER, intent(in) :: jp(ncol,nlayers) ! 173 !INTEGER, intent(in) :: nlayers ! total number of layers 174 ! Dimensions: (nlayers) 175 INTEGER, intent(in) :: jt(ncol,nlayers) ! 176 ! Dimensions: (nlayers) 177 INTEGER, intent(in) :: jt1(ncol,nlayers) ! 178 ! Dimensions: (nlayers) 179 REAL(KIND=r8), intent(in) :: colh2o(ncol,nlayers) ! column amount (h2o) 180 ! Dimensions: (nlayers) 181 REAL(KIND=r8), intent(in) :: colco2(ncol,nlayers) ! column amount (co2) 182 ! Dimensions: (nlayers) 183 REAL(KIND=r8), intent(in) :: colo3(ncol,nlayers) ! column amount (o3) 184 ! Dimensions: (nlayers) 185 REAL(KIND=r8), intent(in) :: colch4(ncol,nlayers) ! column amount (ch4) 186 ! Dimensions: (nlayers) 187 ! Dimensions: (nlayers) 188 REAL(KIND=r8), intent(in) :: colo2(ncol,nlayers) ! column amount (o2) 189 ! Dimensions: (nlayers) 190 REAL(KIND=r8), intent(in) :: colmol(ncol,nlayers) ! 191 ! Dimensions: (nlayers) 192 INTEGER, intent(in) :: indself(ncol,nlayers) 193 ! Dimensions: (nlayers) 194 INTEGER, intent(in) :: indfor(ncol,nlayers) 195 ! Dimensions: (nlayers) 196 REAL(KIND=r8), intent(in) :: selffac(ncol,nlayers) 197 ! Dimensions: (nlayers) 198 REAL(KIND=r8), intent(in) :: selffrac(ncol,nlayers) 199 ! Dimensions: (nlayers) 200 REAL(KIND=r8), intent(in) :: forfac(ncol,nlayers) 201 ! Dimensions: (nlayers) 202 REAL(KIND=r8), intent(in) :: forfrac(ncol,nlayers) 203 ! Dimensions: (nlayers) 204 REAL(KIND=r8), intent(in) :: fac01(ncol,nlayers) 205 REAL(KIND=r8), intent(in) :: fac10(ncol,nlayers) 206 REAL(KIND=r8), intent(in) :: fac11(ncol,nlayers) 207 REAL(KIND=r8), intent(in) :: fac00(ncol,nlayers) ! 208 ! Dimensions: (nlayers) 209 ! ----- Output ----- 210 REAL(KIND=r8), intent(out) :: sfluxzen(ncol,ngptsw) ! solar source function 211 ! Dimensions: (ngptsw) 212 REAL(KIND=r8), intent(out) :: taug(ncol,nlayers,ngptsw) ! gaseous optical depth 213 ! Dimensions: (nlayers,ngptsw) 214 REAL(KIND=r8), intent(out) :: taur(ncol,nlayers,ngptsw) ! Rayleigh 215 INTEGER :: icol 216 ! Dimensions: (nlayers,ngptsw) 217 ! real(kind=r8), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) 218 ! Dimensions: (nlayers,ngptsw) 219 do icol=1,ncol 220 hvrtau = '$Revision: 1.2 $' 221 !print*,"ncol :::",ncol 222 ! Calculate gaseous optical depth and planck fractions for each spectral band. 223 call taumol16() 224 !print *,'end of taumol 16' 225 call taumol17 226 !print *,'end of taumol 17' 227 call taumol18 228 !print *,'end of taumol 18' 229 call taumol19 230 !print *,'end of taumol 19' 231 call taumol20 232 !print *,'end of taumol 20' 233 call taumol21 234 !print *,'end of taumol 21' 235 call taumol22 236 !print *,'end of taumol 22' 237 call taumol23 238 !print *,'end of taumol 23' 239 call taumol24 240 !print *,'end of taumol 24' 241 call taumol25 242 !print *,'end of taumol 25' 243 call taumol26 244 !print *,'end of taumol 26' 245 call taumol27 246 !print *,'end of taumol 27' 247 call taumol28 248 !print *,'end of taumol 28' 249 call taumol29 250 !print *,'end of taumol 29' 251 end do 252 !------------- 253 CONTAINS 254 !------------- 255 !---------------------------------------------------------------------------- 256 257 SUBROUTINE taumol16() 258 !---------------------------------------------------------------------------- 259 ! 260 ! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) 261 ! 262 !---------------------------------------------------------------------------- 263 ! ------- Modules ------- 264 USE parrrsw, ONLY: ng16 265 USE rrsw_kg16, ONLY: strrat1 266 USE rrsw_kg16, ONLY: rayl 267 USE rrsw_kg16, ONLY: forref 268 USE rrsw_kg16, ONLY: absa 269 USE rrsw_kg16, ONLY: selfref 270 USE rrsw_kg16, ONLY: layreffr 271 USE rrsw_kg16, ONLY: absb 272 USE rrsw_kg16, ONLY: sfluxref 273 ! ------- Declarations ------- 274 !INTEGER, intent(in) ::ncol ! total number of layers 275 ! Local 276 INTEGER :: lay 277 INTEGER :: js 278 INTEGER :: ind0 279 INTEGER :: ind1 280 INTEGER :: inds 281 INTEGER :: indf 282 INTEGER :: ig 283 INTEGER :: laysolfr 284 REAL(KIND=r8) :: speccomb 285 REAL(KIND=r8) :: specparm 286 REAL(KIND=r8) :: specmult 287 REAL(KIND=r8) :: fs 288 REAL(KIND=r8) :: fac000 289 REAL(KIND=r8) :: fac010 290 REAL(KIND=r8) :: fac100 291 REAL(KIND=r8) :: fac110 292 REAL(KIND=r8) :: fac001 293 REAL(KIND=r8) :: fac011 294 REAL(KIND=r8) :: fac101 295 REAL(KIND=r8) :: fac111 296 REAL(KIND=r8) :: tauray 297 ! Compute the optical depth by interpolating in ln(pressure), 298 ! temperature, and appropriate species. Below LAYTROP, the water 299 ! vapor self-continuum is interpolated (in temperature) separately. 300 ! Lower atmosphere loop 301 !print*,"taumol 16 :: before lay loop" 302 ! do icol=1,ncol 303 !print*,"icol ::",icol,ncol 304 !print*,"laytrop",laytrop 305 do lay = 1, laytrop(icol) 306 !print*,'inside lay loop' 307 speccomb = colh2o(icol,lay) + strrat1*colch4(icol,lay) 308 specparm = colh2o(icol,lay)/speccomb 309 if (specparm .ge. oneminus) specparm = oneminus 310 specmult = 8._r8*(specparm) 311 js = 1 + int(specmult) 312 fs = mod(specmult, 1._r8 ) 313 fac000 = (1._r8 - fs) * fac00(icol,lay) 314 fac010 = (1._r8 - fs) * fac10(icol,lay) 315 fac100 = fs * fac00(icol,lay) 316 fac110 = fs * fac10(icol,lay) 317 fac001 = (1._r8 - fs) * fac01(icol,lay) 318 fac011 = (1._r8 - fs) * fac11(icol,lay) 319 fac101 = fs * fac01(icol,lay) 320 fac111 = fs * fac11(icol,lay) 321 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(16) + js 322 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(16) + js 323 inds = indself(icol,lay) 324 indf = indfor(icol,lay) 325 tauray = colmol(icol,lay) * rayl 326 do ig = 1, ng16 327 taug(icol,lay,ig) = speccomb * & 328 (fac000 * absa(ind0 ,ig) + & 329 fac100 * absa(ind0 +1,ig) + & 330 fac010 * absa(ind0 +9,ig) + & 331 fac110 * absa(ind0+10,ig) + & 332 fac001 * absa(ind1 ,ig) + & 333 fac101 * absa(ind1 +1,ig) + & 334 fac011 * absa(ind1 +9,ig) + & 335 fac111 * absa(ind1+10,ig)) + & 336 colh2o(icol,lay) * & 337 (selffac(icol,lay) * (selfref(inds,ig) + & 338 selffrac(icol,lay) * & 339 (selfref(inds+1,ig) - selfref(inds,ig))) + & 340 forfac(icol,lay) * (forref(indf,ig) + & 341 forfrac(icol,lay) * & 342 (forref(indf+1,ig) - forref(indf,ig)))) 343 ! ssa(lay,ig) = tauray/taug(lay,ig) 344 taur(icol,lay,ig) = tauray 345 enddo 346 enddo 347 laysolfr = nlayers 348 ! Upper atmosphere loop 349 do lay = laytrop(icol)+1, nlayers 350 if (jp(icol,(lay-1)) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & 351 laysolfr = lay 352 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(16) + 1 353 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(16) + 1 354 tauray = colmol(icol,lay) * rayl 355 do ig = 1, ng16 356 taug(icol,lay,ig) = colch4(icol,lay) * & 357 (fac00(icol,lay) * absb(ind0 ,ig) + & 358 fac10(icol,lay) * absb(ind0+1,ig) + & 359 fac01(icol,lay) * absb(ind1 ,ig) + & 360 fac11(icol,lay) * absb(ind1+1,ig)) 361 ! ssa(lay,ig) = tauray/taug(lay,ig) 362 if (lay .eq. laysolfr) sfluxzen(icol,ig) = sfluxref(ig) 363 taur(icol,lay,ig) = tauray 364 enddo 365 enddo 366!end do 367 END SUBROUTINE taumol16 368 !---------------------------------------------------------------------------- 369 370 SUBROUTINE taumol17() 371 !---------------------------------------------------------------------------- 372 ! 373 ! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) 374 ! 375 !---------------------------------------------------------------------------- 376 ! ------- Modules ------- 377 USE parrrsw, ONLY: ng17 378 USE parrrsw, ONLY: ngs16 379 USE rrsw_kg17, ONLY: strrat 380 USE rrsw_kg17, ONLY: rayl 381 USE rrsw_kg17, ONLY: absa 382 USE rrsw_kg17, ONLY: selfref 383 USE rrsw_kg17, ONLY: forref 384 USE rrsw_kg17, ONLY: layreffr 385 USE rrsw_kg17, ONLY: absb 386 USE rrsw_kg17, ONLY: sfluxref 387 ! ------- Declarations ------- 388 ! Local 389 INTEGER :: lay 390 INTEGER :: js 391 INTEGER :: ind0 392 INTEGER :: ind1 393 INTEGER :: inds 394 INTEGER :: indf 395 INTEGER :: ig 396 INTEGER :: laysolfr 397 REAL(KIND=r8) :: speccomb 398 REAL(KIND=r8) :: specparm 399 REAL(KIND=r8) :: specmult 400 REAL(KIND=r8) :: fs 401 REAL(KIND=r8) :: fac000 402 REAL(KIND=r8) :: fac010 403 REAL(KIND=r8) :: fac100 404 REAL(KIND=r8) :: fac110 405 REAL(KIND=r8) :: fac001 406 REAL(KIND=r8) :: fac011 407 REAL(KIND=r8) :: fac101 408 REAL(KIND=r8) :: fac111 409 REAL(KIND=r8) :: tauray 410 ! Compute the optical depth by interpolating in ln(pressure), 411 ! temperature, and appropriate species. Below LAYTROP, the water 412 ! vapor self-continuum is interpolated (in temperature) separately. 413 ! Lower atmosphere loop 414 do lay = 1, laytrop(icol) 415 speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) 416 specparm = colh2o(icol,lay)/speccomb 417 if (specparm .ge. oneminus) specparm = oneminus 418 specmult = 8._r8*(specparm) 419 js = 1 + int(specmult) 420 fs = mod(specmult, 1._r8 ) 421 fac000 = (1._r8 - fs) * fac00(icol,lay) 422 fac010 = (1._r8 - fs) * fac10(icol,lay) 423 fac100 = fs * fac00(icol,lay) 424 fac110 = fs * fac10(icol,lay) 425 fac001 = (1._r8 - fs) * fac01(icol,lay) 426 fac011 = (1._r8 - fs) * fac11(icol,lay) 427 fac101 = fs * fac01(icol,lay) 428 fac111 = fs * fac11(icol,lay) 429 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(17) + js 430 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(17) + js 431 inds = indself(icol,lay) 432 indf = indfor(icol,lay) 433 tauray = colmol(icol,lay) * rayl 434 do ig = 1, ng17 435 taug(icol,lay,ngs16+ig) = speccomb * & 436 (fac000 * absa(ind0,ig) + & 437 fac100 * absa(ind0+1,ig) + & 438 fac010 * absa(ind0+9,ig) + & 439 fac110 * absa(ind0+10,ig) + & 440 fac001 * absa(ind1,ig) + & 441 fac101 * absa(ind1+1,ig) + & 442 fac011 * absa(ind1+9,ig) + & 443 fac111 * absa(ind1+10,ig)) + & 444 colh2o(icol,lay) * & 445 (selffac(icol,lay) * (selfref(inds,ig) + & 446 selffrac(icol,lay) * & 447 (selfref(inds+1,ig) - selfref(inds,ig))) + & 448 forfac(icol,lay) * (forref(indf,ig) + & 449 forfrac(icol,lay) * & 450 (forref(indf+1,ig) - forref(indf,ig)))) 451 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) 452 taur(icol,lay,ngs16+ig) = tauray 453 enddo 454 enddo 455 laysolfr = nlayers 456 ! Upper atmosphere loop 457 do lay = laytrop(icol)+1, nlayers 458 if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & 459 laysolfr = lay 460 speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) 461 specparm = colh2o(icol,lay)/speccomb 462 if (specparm .ge. oneminus) specparm = oneminus 463 specmult = 4._r8*(specparm) 464 js = 1 + int(specmult) 465 fs = mod(specmult, 1._r8 ) 466 fac000 = (1._r8 - fs) * fac00(icol,lay) 467 fac010 = (1._r8 - fs) * fac10(icol,lay) 468 fac100 = fs * fac00(icol,lay) 469 fac110 = fs * fac10(icol,lay) 470 fac001 = (1._r8 - fs) * fac01(icol,lay) 471 fac011 = (1._r8 - fs) * fac11(icol,lay) 472 fac101 = fs * fac01(icol,lay) 473 fac111 = fs * fac11(icol,lay) 474 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(17) + js 475 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(17) + js 476 indf = indfor(icol,lay) 477 tauray = colmol(icol,lay) * rayl 478 do ig = 1, ng17 479 taug(icol,lay,ngs16+ig) = speccomb * & 480 (fac000 * absb(ind0,ig) + & 481 fac100 * absb(ind0+1,ig) + & 482 fac010 * absb(ind0+5,ig) + & 483 fac110 * absb(ind0+6,ig) + & 484 fac001 * absb(ind1,ig) + & 485 fac101 * absb(ind1+1,ig) + & 486 fac011 * absb(ind1+5,ig) + & 487 fac111 * absb(ind1+6,ig)) + & 488 colh2o(icol,lay) * & 489 forfac(icol,lay) * (forref(indf,ig) + & 490 forfrac(icol,lay) * & 491 (forref(indf+1,ig) - forref(indf,ig))) 492 ! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) 493 if (lay .eq. laysolfr) sfluxzen(icol,ngs16+ig) = sfluxref(ig,js) & 494 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 495 taur(icol,lay,ngs16+ig) = tauray 496 enddo 497 enddo 498 END SUBROUTINE taumol17 499 !---------------------------------------------------------------------------- 500 501 SUBROUTINE taumol18() 502 !---------------------------------------------------------------------------- 503 ! 504 ! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) 505 ! 506 !---------------------------------------------------------------------------- 507 ! ------- Modules ------- 508 USE parrrsw, ONLY: ng18 509 USE parrrsw, ONLY: ngs17 510 USE rrsw_kg18, ONLY: layreffr 511 USE rrsw_kg18, ONLY: strrat 512 USE rrsw_kg18, ONLY: rayl 513 USE rrsw_kg18, ONLY: forref 514 USE rrsw_kg18, ONLY: absa 515 USE rrsw_kg18, ONLY: selfref 516 USE rrsw_kg18, ONLY: sfluxref 517 USE rrsw_kg18, ONLY: absb 518 ! ------- Declarations ------- 519 ! Local 520 INTEGER :: laysolfr 521 INTEGER :: lay 522 INTEGER :: js 523 INTEGER :: ind0 524 INTEGER :: ind1 525 INTEGER :: inds 526 INTEGER :: indf 527 INTEGER :: ig 528 REAL(KIND=r8) :: speccomb 529 REAL(KIND=r8) :: specparm 530 REAL(KIND=r8) :: specmult 531 REAL(KIND=r8) :: fs 532 REAL(KIND=r8) :: fac000 533 REAL(KIND=r8) :: fac010 534 REAL(KIND=r8) :: fac100 535 REAL(KIND=r8) :: fac110 536 REAL(KIND=r8) :: fac001 537 REAL(KIND=r8) :: fac011 538 REAL(KIND=r8) :: fac101 539 REAL(KIND=r8) :: fac111 540 REAL(KIND=r8) :: tauray 541 ! Compute the optical depth by interpolating in ln(pressure), 542 ! temperature, and appropriate species. Below LAYTROP, the water 543 ! vapor self-continuum is interpolated (in temperature) separately. 544 laysolfr = laytrop(icol) 545 ! Lower atmosphere loop 546 do lay = 1, laytrop(icol) 547 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 548 laysolfr = min(lay+1,laytrop(icol)) 549 speccomb = colh2o(icol,lay) + strrat*colch4(icol,lay) 550 specparm = colh2o(icol,lay)/speccomb 551 if (specparm .ge. oneminus) specparm = oneminus 552 specmult = 8._r8*(specparm) 553 js = 1 + int(specmult) 554 fs = mod(specmult, 1._r8 ) 555 fac000 = (1._r8 - fs) * fac00(icol,lay) 556 fac010 = (1._r8 - fs) * fac10(icol,lay) 557 fac100 = fs * fac00(icol,lay) 558 fac110 = fs * fac10(icol,lay) 559 fac001 = (1._r8 - fs) * fac01(icol,lay) 560 fac011 = (1._r8 - fs) * fac11(icol,lay) 561 fac101 = fs * fac01(icol,lay) 562 fac111 = fs * fac11(icol,lay) 563 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(18) + js 564 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(18) + js 565 inds = indself(icol,lay) 566 indf = indfor(icol,lay) 567 tauray = colmol(icol,lay) * rayl 568 do ig = 1, ng18 569 taug(icol,lay,ngs17+ig) = speccomb * & 570 (fac000 * absa(ind0,ig) + & 571 fac100 * absa(ind0+1,ig) + & 572 fac010 * absa(ind0+9,ig) + & 573 fac110 * absa(ind0+10,ig) + & 574 fac001 * absa(ind1,ig) + & 575 fac101 * absa(ind1+1,ig) + & 576 fac011 * absa(ind1+9,ig) + & 577 fac111 * absa(ind1+10,ig)) + & 578 colh2o(icol,lay) * & 579 (selffac(icol,lay) * (selfref(inds,ig) + & 580 selffrac(icol,lay) * & 581 (selfref(inds+1,ig) - selfref(inds,ig))) + & 582 forfac(icol,lay) * (forref(indf,ig) + & 583 forfrac(icol,lay) * & 584 (forref(indf+1,ig) - forref(indf,ig)))) 585 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) 586 if (lay .eq. laysolfr) sfluxzen(icol,ngs17+ig) = sfluxref(ig,js) & 587 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 588 taur(icol,lay,ngs17+ig) = tauray 589 enddo 590 enddo 591 ! Upper atmosphere loop 592 do lay = laytrop(icol)+1, nlayers 593 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(18) + 1 594 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(18) + 1 595 tauray = colmol(icol,lay) * rayl 596 do ig = 1, ng18 597 taug(icol,lay,ngs17+ig) = colch4(icol,lay) * & 598 (fac00(icol,lay) * absb(ind0,ig) + & 599 fac10(icol,lay) * absb(ind0+1,ig) + & 600 fac01(icol,lay) * absb(ind1,ig) + & 601 fac11(icol,lay) * absb(ind1+1,ig)) 602 ! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) 603 taur(icol,lay,ngs17+ig) = tauray 604 enddo 605 enddo 606 END SUBROUTINE taumol18 607 !---------------------------------------------------------------------------- 608 609 SUBROUTINE taumol19() 610 !---------------------------------------------------------------------------- 611 ! 612 ! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) 613 ! 614 !---------------------------------------------------------------------------- 615 ! ------- Modules ------- 616 USE parrrsw, ONLY: ng19 617 USE parrrsw, ONLY: ngs18 618 USE rrsw_kg19, ONLY: layreffr 619 USE rrsw_kg19, ONLY: strrat 620 USE rrsw_kg19, ONLY: rayl 621 USE rrsw_kg19, ONLY: selfref 622 USE rrsw_kg19, ONLY: absa 623 USE rrsw_kg19, ONLY: forref 624 USE rrsw_kg19, ONLY: sfluxref 625 USE rrsw_kg19, ONLY: absb 626 ! ------- Declarations ------- 627 ! Local 628 INTEGER :: laysolfr 629 INTEGER :: lay 630 INTEGER :: js 631 INTEGER :: ind0 632 INTEGER :: ind1 633 INTEGER :: inds 634 INTEGER :: indf 635 INTEGER :: ig 636 REAL(KIND=r8) :: speccomb 637 REAL(KIND=r8) :: specparm 638 REAL(KIND=r8) :: specmult 639 REAL(KIND=r8) :: fs 640 REAL(KIND=r8) :: fac000 641 REAL(KIND=r8) :: fac010 642 REAL(KIND=r8) :: fac100 643 REAL(KIND=r8) :: fac110 644 REAL(KIND=r8) :: fac001 645 REAL(KIND=r8) :: fac011 646 REAL(KIND=r8) :: fac101 647 REAL(KIND=r8) :: fac111 648 REAL(KIND=r8) :: tauray 649 ! Compute the optical depth by interpolating in ln(pressure), 650 ! temperature, and appropriate species. Below LAYTROP, the water 651 ! vapor self-continuum is interpolated (in temperature) separately. 652 laysolfr = laytrop(icol) 653 ! Lower atmosphere loop 654 do lay = 1, laytrop(icol) 655 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 656 laysolfr = min(lay+1,laytrop(icol)) 657 speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) 658 specparm = colh2o(icol,lay)/speccomb 659 if (specparm .ge. oneminus) specparm = oneminus 660 specmult = 8._r8*(specparm) 661 js = 1 + int(specmult) 662 fs = mod(specmult, 1._r8 ) 663 fac000 = (1._r8 - fs) * fac00(icol,lay) 664 fac010 = (1._r8 - fs) * fac10(icol,lay) 665 fac100 = fs * fac00(icol,lay) 666 fac110 = fs * fac10(icol,lay) 667 fac001 = (1._r8 - fs) * fac01(icol,lay) 668 fac011 = (1._r8 - fs) * fac11(icol,lay) 669 fac101 = fs * fac01(icol,lay) 670 fac111 = fs * fac11(icol,lay) 671 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(19) + js 672 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(19) + js 673 inds = indself(icol,lay) 674 indf = indfor(icol,lay) 675 tauray = colmol(icol,lay) * rayl 676 do ig = 1 , ng19 677 taug(icol,lay,ngs18+ig) = speccomb * & 678 (fac000 * absa(ind0,ig) + & 679 fac100 * absa(ind0+1,ig) + & 680 fac010 * absa(ind0+9,ig) + & 681 fac110 * absa(ind0+10,ig) + & 682 fac001 * absa(ind1,ig) + & 683 fac101 * absa(ind1+1,ig) + & 684 fac011 * absa(ind1+9,ig) + & 685 fac111 * absa(ind1+10,ig)) + & 686 colh2o(icol,lay) * & 687 (selffac(icol,lay) * (selfref(inds,ig) + & 688 selffrac(icol,lay) * & 689 (selfref(inds+1,ig) - selfref(inds,ig))) + & 690 forfac(icol,lay) * (forref(indf,ig) + & 691 forfrac(icol,lay) * & 692 (forref(indf+1,ig) - forref(indf,ig)))) 693 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) 694 if (lay .eq. laysolfr) sfluxzen(icol,ngs18+ig) = sfluxref(ig,js) & 695 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 696 taur(icol,lay,ngs18+ig) = tauray 697 enddo 698 enddo 699 ! Upper atmosphere loop 700 do lay = laytrop(icol)+1, nlayers 701 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(19) + 1 702 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(19) + 1 703 tauray = colmol(icol,lay) * rayl 704 do ig = 1 , ng19 705 taug(icol,lay,ngs18+ig) = colco2(icol,lay) * & 706 (fac00(icol,lay) * absb(ind0,ig) + & 707 fac10(icol,lay) * absb(ind0+1,ig) + & 708 fac01(icol,lay) * absb(ind1,ig) + & 709 fac11(icol,lay) * absb(ind1+1,ig)) 710 ! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) 711 taur(icol,lay,ngs18+ig) = tauray 712 enddo 713 enddo 714 END SUBROUTINE taumol19 715 !---------------------------------------------------------------------------- 716 717 SUBROUTINE taumol20() 718 !---------------------------------------------------------------------------- 719 ! 720 ! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) 721 ! 722 !---------------------------------------------------------------------------- 723 ! ------- Modules ------- 724 USE parrrsw, ONLY: ng20 725 USE parrrsw, ONLY: ngs19 726 USE rrsw_kg20, ONLY: layreffr 727 USE rrsw_kg20, ONLY: rayl 728 USE rrsw_kg20, ONLY: absch4 729 USE rrsw_kg20, ONLY: forref 730 USE rrsw_kg20, ONLY: absa 731 USE rrsw_kg20, ONLY: selfref 732 USE rrsw_kg20, ONLY: sfluxref 733 USE rrsw_kg20, ONLY: absb 734 IMPLICIT NONE 735 ! ------- Declarations ------- 736 ! Local 737 INTEGER :: laysolfr 738 INTEGER :: lay 739 INTEGER :: ind0 740 INTEGER :: ind1 741 INTEGER :: inds 742 INTEGER :: indf 743 INTEGER :: ig 744 REAL(KIND=r8) :: tauray 745 ! Compute the optical depth by interpolating in ln(pressure), 746 ! temperature, and appropriate species. Below LAYTROP, the water 747 ! vapor self-continuum is interpolated (in temperature) separately. 748 laysolfr = laytrop(icol) 749 ! Lower atmosphere loop 750 do lay = 1, laytrop(icol) 751 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 752 laysolfr = min(lay+1,laytrop(icol)) 753 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(20) + 1 754 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(20) + 1 755 inds = indself(icol,lay) 756 indf = indfor(icol,lay) 757 tauray = colmol(icol,lay) * rayl 758 do ig = 1, ng20 759 taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & 760 ((fac00(icol,lay) * absa(ind0,ig) + & 761 fac10(icol,lay) * absa(ind0+1,ig) + & 762 fac01(icol,lay) * absa(ind1,ig) + & 763 fac11(icol,lay) * absa(ind1+1,ig)) + & 764 selffac(icol,lay) * (selfref(inds,ig) + & 765 selffrac(icol,lay) * & 766 (selfref(inds+1,ig) - selfref(inds,ig))) + & 767 forfac(icol,lay) * (forref(indf,ig) + & 768 forfrac(icol,lay) * & 769 (forref(indf+1,ig) - forref(indf,ig)))) & 770 + colch4(icol,lay) * absch4(ig) 771 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) 772 taur(icol,lay,ngs19+ig) = tauray 773 if (lay .eq. laysolfr) sfluxzen(icol,ngs19+ig) = sfluxref(ig) 774 enddo 775 enddo 776 ! Upper atmosphere loop 777 do lay = laytrop(icol)+1, nlayers 778 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(20) + 1 779 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(20) + 1 780 indf = indfor(icol,lay) 781 tauray = colmol(icol,lay) * rayl 782 do ig = 1, ng20 783 taug(icol,lay,ngs19+ig) = colh2o(icol,lay) * & 784 (fac00(icol,lay) * absb(ind0,ig) + & 785 fac10(icol,lay) * absb(ind0+1,ig) + & 786 fac01(icol,lay) * absb(ind1,ig) + & 787 fac11(icol,lay) * absb(ind1+1,ig) + & 788 forfac(icol,lay) * (forref(indf,ig) + & 789 forfrac(icol,lay) * & 790 (forref(indf+1,ig) - forref(indf,ig)))) + & 791 colch4(icol,lay) * absch4(ig) 792 ! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) 793 taur(icol,lay,ngs19+ig) = tauray 794 enddo 795 enddo 796 END SUBROUTINE taumol20 797 !---------------------------------------------------------------------------- 798 799 SUBROUTINE taumol21() 800 !---------------------------------------------------------------------------- 801 ! 802 ! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) 803 ! 804 !---------------------------------------------------------------------------- 805 ! ------- Modules ------- 806 USE parrrsw, ONLY: ng21 807 USE parrrsw, ONLY: ngs20 808 USE rrsw_kg21, ONLY: layreffr 809 USE rrsw_kg21, ONLY: strrat 810 USE rrsw_kg21, ONLY: rayl 811 USE rrsw_kg21, ONLY: forref 812 USE rrsw_kg21, ONLY: absa 813 USE rrsw_kg21, ONLY: selfref 814 USE rrsw_kg21, ONLY: sfluxref 815 USE rrsw_kg21, ONLY: absb 816 ! ------- Declarations ------- 817 ! Local 818 INTEGER :: laysolfr 819 INTEGER :: lay 820 INTEGER :: js 821 INTEGER :: ind0 822 INTEGER :: ind1 823 INTEGER :: inds 824 INTEGER :: indf 825 INTEGER :: ig 826 REAL(KIND=r8) :: speccomb 827 REAL(KIND=r8) :: specparm 828 REAL(KIND=r8) :: specmult 829 REAL(KIND=r8) :: fs 830 REAL(KIND=r8) :: fac000 831 REAL(KIND=r8) :: fac010 832 REAL(KIND=r8) :: fac100 833 REAL(KIND=r8) :: fac110 834 REAL(KIND=r8) :: fac001 835 REAL(KIND=r8) :: fac011 836 REAL(KIND=r8) :: fac101 837 REAL(KIND=r8) :: fac111 838 REAL(KIND=r8) :: tauray 839 ! Compute the optical depth by interpolating in ln(pressure), 840 ! temperature, and appropriate species. Below LAYTROP, the water 841 ! vapor self-continuum is interpolated (in temperature) separately. 842 laysolfr = laytrop(icol) 843 ! Lower atmosphere loop 844 do lay = 1, laytrop(icol) 845 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 846 laysolfr = min(lay+1,laytrop(icol)) 847 speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) 848 specparm = colh2o(icol,lay)/speccomb 849 if (specparm .ge. oneminus) specparm = oneminus 850 specmult = 8._r8*(specparm) 851 js = 1 + int(specmult) 852 fs = mod(specmult, 1._r8 ) 853 fac000 = (1._r8 - fs) * fac00(icol,lay) 854 fac010 = (1._r8 - fs) * fac10(icol,lay) 855 fac100 = fs * fac00(icol,lay) 856 fac110 = fs * fac10(icol,lay) 857 fac001 = (1._r8 - fs) * fac01(icol,lay) 858 fac011 = (1._r8 - fs) * fac11(icol,lay) 859 fac101 = fs * fac01(icol,lay) 860 fac111 = fs * fac11(icol,lay) 861 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(21) + js 862 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(21) + js 863 inds = indself(icol,lay) 864 indf = indfor(icol,lay) 865 tauray = colmol(icol,lay) * rayl 866 do ig = 1, ng21 867 taug(icol,lay,ngs20+ig) = speccomb * & 868 (fac000 * absa(ind0,ig) + & 869 fac100 * absa(ind0+1,ig) + & 870 fac010 * absa(ind0+9,ig) + & 871 fac110 * absa(ind0+10,ig) + & 872 fac001 * absa(ind1,ig) + & 873 fac101 * absa(ind1+1,ig) + & 874 fac011 * absa(ind1+9,ig) + & 875 fac111 * absa(ind1+10,ig)) + & 876 colh2o(icol,lay) * & 877 (selffac(icol,lay) * (selfref(inds,ig) + & 878 selffrac(icol,lay) * & 879 (selfref(inds+1,ig) - selfref(inds,ig))) + & 880 forfac(icol,lay) * (forref(indf,ig) + & 881 forfrac(icol,lay) * & 882 (forref(indf+1,ig) - forref(indf,ig)))) 883 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) 884 if (lay .eq. laysolfr) sfluxzen(icol,ngs20+ig) = sfluxref(ig,js) & 885 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 886 taur(icol,lay,ngs20+ig) = tauray 887 enddo 888 enddo 889 ! Upper atmosphere loop 890 do lay = laytrop(icol)+1, nlayers 891 speccomb = colh2o(icol,lay) + strrat*colco2(icol,lay) 892 specparm = colh2o(icol,lay)/speccomb 893 if (specparm .ge. oneminus) specparm = oneminus 894 specmult = 4._r8*(specparm) 895 js = 1 + int(specmult) 896 fs = mod(specmult, 1._r8 ) 897 fac000 = (1._r8 - fs) * fac00(icol,lay) 898 fac010 = (1._r8 - fs) * fac10(icol,lay) 899 fac100 = fs * fac00(icol,lay) 900 fac110 = fs * fac10(icol,lay) 901 fac001 = (1._r8 - fs) * fac01(icol,lay) 902 fac011 = (1._r8 - fs) * fac11(icol,lay) 903 fac101 = fs * fac01(icol,lay) 904 fac111 = fs * fac11(icol,lay) 905 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(21) + js 906 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(21) + js 907 indf = indfor(icol,lay) 908 tauray = colmol(icol,lay) * rayl 909 do ig = 1, ng21 910 taug(icol,lay,ngs20+ig) = speccomb * & 911 (fac000 * absb(ind0,ig) + & 912 fac100 * absb(ind0+1,ig) + & 913 fac010 * absb(ind0+5,ig) + & 914 fac110 * absb(ind0+6,ig) + & 915 fac001 * absb(ind1,ig) + & 916 fac101 * absb(ind1+1,ig) + & 917 fac011 * absb(ind1+5,ig) + & 918 fac111 * absb(ind1+6,ig)) + & 919 colh2o(icol,lay) * & 920 forfac(icol,lay) * (forref(indf,ig) + & 921 forfrac(icol,lay) * & 922 (forref(indf+1,ig) - forref(indf,ig))) 923 ! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) 924 taur(icol,lay,ngs20+ig) = tauray 925 enddo 926 enddo 927 END SUBROUTINE taumol21 928 !---------------------------------------------------------------------------- 929 930 SUBROUTINE taumol22() 931 !---------------------------------------------------------------------------- 932 ! 933 ! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) 934 ! 935 !---------------------------------------------------------------------------- 936 ! ------- Modules ------- 937 USE parrrsw, ONLY: ng22 938 USE parrrsw, ONLY: ngs21 939 USE rrsw_kg22, ONLY: layreffr 940 USE rrsw_kg22, ONLY: strrat 941 USE rrsw_kg22, ONLY: rayl 942 USE rrsw_kg22, ONLY: forref 943 USE rrsw_kg22, ONLY: absa 944 USE rrsw_kg22, ONLY: selfref 945 USE rrsw_kg22, ONLY: sfluxref 946 USE rrsw_kg22, ONLY: absb 947 ! ------- Declarations ------- 948 ! Local 949 INTEGER :: laysolfr 950 INTEGER :: lay 951 INTEGER :: js 952 INTEGER :: ind0 953 INTEGER :: ind1 954 INTEGER :: inds 955 INTEGER :: indf 956 INTEGER :: ig 957 REAL(KIND=r8) :: o2adj 958 REAL(KIND=r8) :: o2cont 959 REAL(KIND=r8) :: speccomb 960 REAL(KIND=r8) :: specparm 961 REAL(KIND=r8) :: specmult 962 REAL(KIND=r8) :: fs 963 REAL(KIND=r8) :: fac000 964 REAL(KIND=r8) :: fac010 965 REAL(KIND=r8) :: fac100 966 REAL(KIND=r8) :: fac110 967 REAL(KIND=r8) :: fac001 968 REAL(KIND=r8) :: fac011 969 REAL(KIND=r8) :: fac101 970 REAL(KIND=r8) :: fac111 971 REAL(KIND=r8) :: tauray 972 ! The following factor is the ratio of total O2 band intensity (lines 973 ! and Mate continuum) to O2 band intensity (line only). It is needed 974 ! to adjust the optical depths since the k's include only lines. 975 o2adj = 1.6_r8 976 ! Compute the optical depth by interpolating in ln(pressure), 977 ! temperature, and appropriate species. Below LAYTROP, the water 978 ! vapor self-continuum is interpolated (in temperature) separately. 979 laysolfr = laytrop(icol) 980 ! Lower atmosphere loop 981 do lay = 1, laytrop(icol) 982 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 983 laysolfr = min(lay+1,laytrop(icol)) 984 o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) 985 speccomb = colh2o(icol,lay) + o2adj*strrat*colo2(icol,lay) 986 specparm = colh2o(icol,lay)/speccomb 987 if (specparm .ge. oneminus) specparm = oneminus 988 specmult = 8._r8*(specparm) 989 ! odadj = specparm + o2adj * (1._r8 - specparm) 990 js = 1 + int(specmult) 991 fs = mod(specmult, 1._r8 ) 992 fac000 = (1._r8 - fs) * fac00(icol,lay) 993 fac010 = (1._r8 - fs) * fac10(icol,lay) 994 fac100 = fs * fac00(icol,lay) 995 fac110 = fs * fac10(icol,lay) 996 fac001 = (1._r8 - fs) * fac01(icol,lay) 997 fac011 = (1._r8 - fs) * fac11(icol,lay) 998 fac101 = fs * fac01(icol,lay) 999 fac111 = fs * fac11(icol,lay) 1000 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(22) + js 1001 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(22) + js 1002 inds = indself(icol,lay) 1003 indf = indfor(icol,lay) 1004 tauray = colmol(icol,lay) * rayl 1005 do ig = 1, ng22 1006 taug(icol,lay,ngs21+ig) = speccomb * & 1007 (fac000 * absa(ind0,ig) + & 1008 fac100 * absa(ind0+1,ig) + & 1009 fac010 * absa(ind0+9,ig) + & 1010 fac110 * absa(ind0+10,ig) + & 1011 fac001 * absa(ind1,ig) + & 1012 fac101 * absa(ind1+1,ig) + & 1013 fac011 * absa(ind1+9,ig) + & 1014 fac111 * absa(ind1+10,ig)) + & 1015 colh2o(icol,lay) * & 1016 (selffac(icol,lay) * (selfref(inds,ig) + & 1017 selffrac(icol,lay) * & 1018 (selfref(inds+1,ig) - selfref(inds,ig))) + & 1019 forfac(icol,lay) * (forref(indf,ig) + & 1020 forfrac(icol,lay) * & 1021 (forref(indf+1,ig) - forref(indf,ig)))) & 1022 + o2cont 1023 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) 1024 if (lay .eq. laysolfr) sfluxzen(icol,ngs21+ig) = sfluxref(ig,js) & 1025 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 1026 taur(icol,lay,ngs21+ig) = tauray 1027 enddo 1028 enddo 1029 ! Upper atmosphere loop 1030 do lay = laytrop(icol)+1, nlayers 1031 o2cont = 4.35e-4_r8*colo2(icol,lay)/(350.0_r8*2.0_r8) 1032 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(22) + 1 1033 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(22) + 1 1034 tauray = colmol(icol,lay) * rayl 1035 do ig = 1, ng22 1036 taug(icol,lay,ngs21+ig) = colo2(icol,lay) * o2adj * & 1037 (fac00(icol,lay) * absb(ind0,ig) + & 1038 fac10(icol,lay) * absb(ind0+1,ig) + & 1039 fac01(icol,lay) * absb(ind1,ig) + & 1040 fac11(icol,lay) * absb(ind1+1,ig)) + & 1041 o2cont 1042 ! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) 1043 taur(icol,lay,ngs21+ig) = tauray 1044 enddo 1045 enddo 1046 END SUBROUTINE taumol22 1047 !---------------------------------------------------------------------------- 1048 1049 SUBROUTINE taumol23() 1050 !---------------------------------------------------------------------------- 1051 ! 1052 ! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) 1053 ! 1054 !---------------------------------------------------------------------------- 1055 ! ------- Modules ------- 1056 USE parrrsw, ONLY: ng23 1057 USE parrrsw, ONLY: ngs22 1058 USE rrsw_kg23, ONLY: layreffr 1059 USE rrsw_kg23, ONLY: rayl 1060 USE rrsw_kg23, ONLY: absa 1061 USE rrsw_kg23, ONLY: givfac 1062 USE rrsw_kg23, ONLY: forref 1063 USE rrsw_kg23, ONLY: selfref 1064 USE rrsw_kg23, ONLY: sfluxref 1065 ! ------- Declarations ------- 1066 ! Local 1067 INTEGER :: laysolfr 1068 INTEGER :: lay 1069 INTEGER :: ind0 1070 INTEGER :: ind1 1071 INTEGER :: inds 1072 INTEGER :: indf 1073 INTEGER :: ig 1074 REAL(KIND=r8) :: tauray 1075 ! Compute the optical depth by interpolating in ln(pressure), 1076 ! temperature, and appropriate species. Below LAYTROP, the water 1077 ! vapor self-continuum is interpolated (in temperature) separately. 1078 laysolfr = laytrop(icol) 1079 ! Lower atmosphere loop 1080 do lay = 1, laytrop(icol) 1081 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 1082 laysolfr = min(lay+1,laytrop(icol)) 1083 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(23) + 1 1084 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(23) + 1 1085 inds = indself(icol,lay) 1086 indf = indfor(icol,lay) 1087 do ig = 1, ng23 1088 tauray = colmol(icol,lay) * rayl(ig) 1089 taug(icol,lay,ngs22+ig) = colh2o(icol,lay) * & 1090 (givfac * (fac00(icol,lay) * absa(ind0,ig) + & 1091 fac10(icol,lay) * absa(ind0+1,ig) + & 1092 fac01(icol,lay) * absa(ind1,ig) + & 1093 fac11(icol,lay) * absa(ind1+1,ig)) + & 1094 selffac(icol,lay) * (selfref(inds,ig) + & 1095 selffrac(icol,lay) * & 1096 (selfref(inds+1,ig) - selfref(inds,ig))) + & 1097 forfac(icol,lay) * (forref(indf,ig) + & 1098 forfrac(icol,lay) * & 1099 (forref(indf+1,ig) - forref(indf,ig)))) 1100 ! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) 1101 if (lay .eq. laysolfr) sfluxzen(icol,ngs22+ig) = sfluxref(ig) 1102 taur(icol,lay,ngs22+ig) = tauray 1103 enddo 1104 enddo 1105 ! Upper atmosphere loop 1106 do lay = laytrop(icol)+1, nlayers 1107 do ig = 1, ng23 1108 ! taug(lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) 1109 ! ssa(lay,ngs22+ig) = 1.0_r8 1110 taug(icol,lay,ngs22+ig) = 0._r8 1111 taur(icol,lay,ngs22+ig) = colmol(icol,lay) * rayl(ig) 1112 enddo 1113 enddo 1114 END SUBROUTINE taumol23 1115 !---------------------------------------------------------------------------- 1116 1117 SUBROUTINE taumol24() 1118 !---------------------------------------------------------------------------- 1119 ! 1120 ! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) 1121 ! 1122 !---------------------------------------------------------------------------- 1123 ! ------- Modules ------- 1124 USE parrrsw, ONLY: ng24 1125 USE parrrsw, ONLY: ngs23 1126 USE rrsw_kg24, ONLY: layreffr 1127 USE rrsw_kg24, ONLY: strrat 1128 USE rrsw_kg24, ONLY: rayla 1129 USE rrsw_kg24, ONLY: absa 1130 USE rrsw_kg24, ONLY: forref 1131 USE rrsw_kg24, ONLY: selfref 1132 USE rrsw_kg24, ONLY: abso3a 1133 USE rrsw_kg24, ONLY: sfluxref 1134 USE rrsw_kg24, ONLY: raylb 1135 USE rrsw_kg24, ONLY: absb 1136 USE rrsw_kg24, ONLY: abso3b 1137 ! ------- Declarations ------- 1138 ! Local 1139 INTEGER :: laysolfr 1140 INTEGER :: lay 1141 INTEGER :: js 1142 INTEGER :: ind0 1143 INTEGER :: ind1 1144 INTEGER :: inds 1145 INTEGER :: indf 1146 INTEGER :: ig 1147 REAL(KIND=r8) :: speccomb 1148 REAL(KIND=r8) :: specparm 1149 REAL(KIND=r8) :: specmult 1150 REAL(KIND=r8) :: fs 1151 REAL(KIND=r8) :: fac000 1152 REAL(KIND=r8) :: fac010 1153 REAL(KIND=r8) :: fac100 1154 REAL(KIND=r8) :: fac110 1155 REAL(KIND=r8) :: fac001 1156 REAL(KIND=r8) :: fac011 1157 REAL(KIND=r8) :: fac101 1158 REAL(KIND=r8) :: fac111 1159 REAL(KIND=r8) :: tauray 1160 ! Compute the optical depth by interpolating in ln(pressure), 1161 ! temperature, and appropriate species. Below LAYTROP, the water 1162 ! vapor self-continuum is interpolated (in temperature) separately. 1163 laysolfr = laytrop(icol) 1164 ! Lower atmosphere loop 1165 do lay = 1, laytrop(icol) 1166 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 1167 laysolfr = min(lay+1,laytrop(icol)) 1168 speccomb = colh2o(icol,lay) + strrat*colo2(icol,lay) 1169 specparm = colh2o(icol,lay)/speccomb 1170 if (specparm .ge. oneminus) specparm = oneminus 1171 specmult = 8._r8*(specparm) 1172 js = 1 + int(specmult) 1173 fs = mod(specmult, 1._r8 ) 1174 fac000 = (1._r8 - fs) * fac00(icol,lay) 1175 fac010 = (1._r8 - fs) * fac10(icol,lay) 1176 fac100 = fs * fac00(icol,lay) 1177 fac110 = fs * fac10(icol,lay) 1178 fac001 = (1._r8 - fs) * fac01(icol,lay) 1179 fac011 = (1._r8 - fs) * fac11(icol,lay) 1180 fac101 = fs * fac01(icol,lay) 1181 fac111 = fs * fac11(icol,lay) 1182 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(24) + js 1183 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(24) + js 1184 inds = indself(icol,lay) 1185 indf = indfor(icol,lay) 1186 do ig = 1, ng24 1187 tauray = colmol(icol,lay) * (rayla(ig,js) + & 1188 fs * (rayla(ig,js+1) - rayla(ig,js))) 1189 taug(icol,lay,ngs23+ig) = speccomb * & 1190 (fac000 * absa(ind0,ig) + & 1191 fac100 * absa(ind0+1,ig) + & 1192 fac010 * absa(ind0+9,ig) + & 1193 fac110 * absa(ind0+10,ig) + & 1194 fac001 * absa(ind1,ig) + & 1195 fac101 * absa(ind1+1,ig) + & 1196 fac011 * absa(ind1+9,ig) + & 1197 fac111 * absa(ind1+10,ig)) + & 1198 colo3(icol,lay) * abso3a(ig) + & 1199 colh2o(icol,lay) * & 1200 (selffac(icol,lay) * (selfref(inds,ig) + & 1201 selffrac(icol,lay) * & 1202 (selfref(inds+1,ig) - selfref(inds,ig))) + & 1203 forfac(icol,lay) * (forref(indf,ig) + & 1204 forfrac(icol,lay) * & 1205 (forref(indf+1,ig) - forref(indf,ig)))) 1206 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) 1207 if (lay .eq. laysolfr) sfluxzen(icol,ngs23+ig) = sfluxref(ig,js) & 1208 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 1209 taur(icol,lay,ngs23+ig) = tauray 1210 enddo 1211 enddo 1212 ! Upper atmosphere loop 1213 do lay = laytrop(icol)+1, nlayers 1214 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(24) + 1 1215 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(24) + 1 1216 do ig = 1, ng24 1217 tauray = colmol(icol,lay) * raylb(ig) 1218 taug(icol,lay,ngs23+ig) = colo2(icol,lay) * & 1219 (fac00(icol,lay) * absb(ind0,ig) + & 1220 fac10(icol,lay) * absb(ind0+1,ig) + & 1221 fac01(icol,lay) * absb(ind1,ig) + & 1222 fac11(icol,lay) * absb(ind1+1,ig)) + & 1223 colo3(icol,lay) * abso3b(ig) 1224 ! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) 1225 taur(icol,lay,ngs23+ig) = tauray 1226 enddo 1227 enddo 1228 END SUBROUTINE taumol24 1229 !---------------------------------------------------------------------------- 1230 1231 SUBROUTINE taumol25() 1232 !---------------------------------------------------------------------------- 1233 ! 1234 ! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) 1235 ! 1236 !---------------------------------------------------------------------------- 1237 ! ------- Modules ------- 1238 USE parrrsw, ONLY: ng25 1239 USE parrrsw, ONLY: ngs24 1240 USE rrsw_kg25, ONLY: layreffr 1241 USE rrsw_kg25, ONLY: rayl 1242 USE rrsw_kg25, ONLY: abso3a 1243 USE rrsw_kg25, ONLY: absa 1244 USE rrsw_kg25, ONLY: sfluxref 1245 USE rrsw_kg25, ONLY: abso3b 1246 ! ------- Declarations ------- 1247 ! Local 1248 INTEGER :: laysolfr 1249 INTEGER :: lay 1250 INTEGER :: ind0 1251 INTEGER :: ind1 1252 INTEGER :: ig 1253 REAL(KIND=r8) :: tauray 1254 ! Compute the optical depth by interpolating in ln(pressure), 1255 ! temperature, and appropriate species. Below LAYTROP, the water 1256 ! vapor self-continuum is interpolated (in temperature) separately. 1257 laysolfr = laytrop(icol) 1258 ! Lower atmosphere loop 1259 do lay = 1, laytrop(icol) 1260 if (jp(icol,lay) .lt. layreffr .and. jp(icol,lay+1) .ge. layreffr) & 1261 laysolfr = min(lay+1,laytrop(icol)) 1262 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(25) + 1 1263 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(25) + 1 1264 do ig = 1, ng25 1265 tauray = colmol(icol,lay) * rayl(ig) 1266 taug(icol,lay,ngs24+ig) = colh2o(icol,lay) * & 1267 (fac00(icol,lay) * absa(ind0,ig) + & 1268 fac10(icol,lay) * absa(ind0+1,ig) + & 1269 fac01(icol,lay) * absa(ind1,ig) + & 1270 fac11(icol,lay) * absa(ind1+1,ig)) + & 1271 colo3(icol,lay) * abso3a(ig) 1272 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) 1273 if (lay .eq. laysolfr) sfluxzen(icol,ngs24+ig) = sfluxref(ig) 1274 taur(icol,lay,ngs24+ig) = tauray 1275 enddo 1276 enddo 1277 ! Upper atmosphere loop 1278 do lay = laytrop(icol)+1, nlayers 1279 do ig = 1, ng25 1280 tauray = colmol(icol,lay) * rayl(ig) 1281 taug(icol,lay,ngs24+ig) = colo3(icol,lay) * abso3b(ig) 1282 ! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) 1283 taur(icol,lay,ngs24+ig) = tauray 1284 enddo 1285 enddo 1286 END SUBROUTINE taumol25 1287 !---------------------------------------------------------------------------- 1288 1289 SUBROUTINE taumol26() 1290 !---------------------------------------------------------------------------- 1291 ! 1292 ! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) 1293 ! 1294 !---------------------------------------------------------------------------- 1295 ! ------- Modules ------- 1296 USE parrrsw, ONLY: ng26 1297 USE parrrsw, ONLY: ngs25 1298 USE rrsw_kg26, ONLY: sfluxref 1299 USE rrsw_kg26, ONLY: rayl 1300 ! ------- Declarations ------- 1301 ! Local 1302 INTEGER :: laysolfr 1303 INTEGER :: lay 1304 INTEGER :: ig 1305 ! Compute the optical depth by interpolating in ln(pressure), 1306 ! temperature, and appropriate species. Below LAYTROP, the water 1307 ! vapor self-continuum is interpolated (in temperature) separately. 1308 laysolfr = laytrop(icol) 1309 ! Lower atmosphere loop 1310 do lay = 1, laytrop(icol) 1311 do ig = 1, ng26 1312 ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) 1313 ! ssa(lay,ngs25+ig) = 1.0_r8 1314 if (lay .eq. laysolfr) sfluxzen(icol,ngs25+ig) = sfluxref(ig) 1315 taug(icol,lay,ngs25+ig) = 0._r8 1316 taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) 1317 enddo 1318 enddo 1319 ! Upper atmosphere loop 1320 do lay = laytrop(icol)+1, nlayers 1321 do ig = 1, ng26 1322 ! taug(lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) 1323 ! ssa(lay,ngs25+ig) = 1.0_r8 1324 taug(icol,lay,ngs25+ig) = 0._r8 1325 taur(icol,lay,ngs25+ig) = colmol(icol,lay) * rayl(ig) 1326 enddo 1327 enddo 1328 END SUBROUTINE taumol26 1329 !---------------------------------------------------------------------------- 1330 1331 SUBROUTINE taumol27() 1332 !---------------------------------------------------------------------------- 1333 ! 1334 ! band 27: 29000-38000 cm-1 (low - o3; high - o3) 1335 ! 1336 !---------------------------------------------------------------------------- 1337 ! ------- Modules ------- 1338 USE parrrsw, ONLY: ng27 1339 USE parrrsw, ONLY: ngs26 1340 USE rrsw_kg27, ONLY: rayl 1341 USE rrsw_kg27, ONLY: absa 1342 USE rrsw_kg27, ONLY: layreffr 1343 USE rrsw_kg27, ONLY: absb 1344 USE rrsw_kg27, ONLY: scalekur 1345 USE rrsw_kg27, ONLY: sfluxref 1346 ! ------- Declarations ------- 1347 ! Local 1348 INTEGER :: lay 1349 INTEGER :: ind0 1350 INTEGER :: ind1 1351 INTEGER :: ig 1352 INTEGER :: laysolfr 1353 REAL(KIND=r8) :: tauray 1354 ! Compute the optical depth by interpolating in ln(pressure), 1355 ! temperature, and appropriate species. Below LAYTROP, the water 1356 ! vapor self-continuum is interpolated (in temperature) separately. 1357 ! Lower atmosphere loop 1358 do lay = 1, laytrop(icol) 1359 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(27) + 1 1360 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(27) + 1 1361 do ig = 1, ng27 1362 tauray = colmol(icol,lay) * rayl(ig) 1363 taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & 1364 (fac00(icol,lay) * absa(ind0,ig) + & 1365 fac10(icol,lay) * absa(ind0+1,ig) + & 1366 fac01(icol,lay) * absa(ind1,ig) + & 1367 fac11(icol,lay) * absa(ind1+1,ig)) 1368 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) 1369 taur(icol,lay,ngs26+ig) = tauray 1370 enddo 1371 enddo 1372 laysolfr = nlayers 1373 ! Upper atmosphere loop 1374 do lay = laytrop(icol)+1, nlayers 1375 if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & 1376 laysolfr = lay 1377 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(27) + 1 1378 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(27) + 1 1379 do ig = 1, ng27 1380 tauray = colmol(icol,lay) * rayl(ig) 1381 taug(icol,lay,ngs26+ig) = colo3(icol,lay) * & 1382 (fac00(icol,lay) * absb(ind0,ig) + & 1383 fac10(icol,lay) * absb(ind0+1,ig) + & 1384 fac01(icol,lay) * absb(ind1,ig) + & 1385 fac11(icol,lay) * absb(ind1+1,ig)) 1386 ! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) 1387 if (lay.eq.laysolfr) sfluxzen(icol,ngs26+ig) = scalekur * sfluxref(ig) 1388 taur(icol,lay,ngs26+ig) = tauray 1389 enddo 1390 enddo 1391 END SUBROUTINE taumol27 1392 !---------------------------------------------------------------------------- 1393 1394 SUBROUTINE taumol28() 1395 !---------------------------------------------------------------------------- 1396 ! 1397 ! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) 1398 ! 1399 !---------------------------------------------------------------------------- 1400 ! ------- Modules ------- 1401 USE parrrsw, ONLY: ng28 1402 USE parrrsw, ONLY: ngs27 1403 USE rrsw_kg28, ONLY: strrat 1404 USE rrsw_kg28, ONLY: rayl 1405 USE rrsw_kg28, ONLY: absa 1406 USE rrsw_kg28, ONLY: layreffr 1407 USE rrsw_kg28, ONLY: absb 1408 USE rrsw_kg28, ONLY: sfluxref 1409 ! ------- Declarations ------- 1410 ! Local 1411 INTEGER :: lay 1412 INTEGER :: js 1413 INTEGER :: ind0 1414 INTEGER :: ind1 1415 INTEGER :: ig 1416 INTEGER :: laysolfr 1417 REAL(KIND=r8) :: speccomb 1418 REAL(KIND=r8) :: specparm 1419 REAL(KIND=r8) :: specmult 1420 REAL(KIND=r8) :: fs 1421 REAL(KIND=r8) :: fac000 1422 REAL(KIND=r8) :: fac010 1423 REAL(KIND=r8) :: fac100 1424 REAL(KIND=r8) :: fac110 1425 REAL(KIND=r8) :: fac001 1426 REAL(KIND=r8) :: fac011 1427 REAL(KIND=r8) :: fac101 1428 REAL(KIND=r8) :: fac111 1429 REAL(KIND=r8) :: tauray 1430 ! Compute the optical depth by interpolating in ln(pressure), 1431 ! temperature, and appropriate species. Below LAYTROP, the water 1432 ! vapor self-continuum is interpolated (in temperature) separately. 1433 ! Lower atmosphere loop 1434 do lay = 1, laytrop(icol) 1435 speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) 1436 specparm = colo3(icol,lay)/speccomb 1437 if (specparm .ge. oneminus) specparm = oneminus 1438 specmult = 8._r8*(specparm) 1439 js = 1 + int(specmult) 1440 fs = mod(specmult, 1._r8 ) 1441 fac000 = (1._r8 - fs) * fac00(icol,lay) 1442 fac010 = (1._r8 - fs) * fac10(icol,lay) 1443 fac100 = fs * fac00(icol,lay) 1444 fac110 = fs * fac10(icol,lay) 1445 fac001 = (1._r8 - fs) * fac01(icol,lay) 1446 fac011 = (1._r8 - fs) * fac11(icol,lay) 1447 fac101 = fs * fac01(icol,lay) 1448 fac111 = fs * fac11(icol,lay) 1449 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(28) + js 1450 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(28) + js 1451 tauray = colmol(icol,lay) * rayl 1452 do ig = 1, ng28 1453 taug(icol,lay,ngs27+ig) = speccomb * & 1454 (fac000 * absa(ind0,ig) + & 1455 fac100 * absa(ind0+1,ig) + & 1456 fac010 * absa(ind0+9,ig) + & 1457 fac110 * absa(ind0+10,ig) + & 1458 fac001 * absa(ind1,ig) + & 1459 fac101 * absa(ind1+1,ig) + & 1460 fac011 * absa(ind1+9,ig) + & 1461 fac111 * absa(ind1+10,ig)) 1462 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) 1463 taur(icol,lay,ngs27+ig) = tauray 1464 enddo 1465 enddo 1466 laysolfr = nlayers 1467 ! Upper atmosphere loop 1468 do lay = laytrop(icol)+1, nlayers 1469 if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & 1470 laysolfr = lay 1471 speccomb = colo3(icol,lay) + strrat*colo2(icol,lay) 1472 specparm = colo3(icol,lay)/speccomb 1473 if (specparm .ge. oneminus) specparm = oneminus 1474 specmult = 4._r8*(specparm) 1475 js = 1 + int(specmult) 1476 fs = mod(specmult, 1._r8 ) 1477 fac000 = (1._r8 - fs) * fac00(icol,lay) 1478 fac010 = (1._r8 - fs) * fac10(icol,lay) 1479 fac100 = fs * fac00(icol,lay) 1480 fac110 = fs * fac10(icol,lay) 1481 fac001 = (1._r8 - fs) * fac01(icol,lay) 1482 fac011 = (1._r8 - fs) * fac11(icol,lay) 1483 fac101 = fs * fac01(icol,lay) 1484 fac111 = fs * fac11(icol,lay) 1485 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(28) + js 1486 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(28) + js 1487 tauray = colmol(icol,lay) * rayl 1488 do ig = 1, ng28 1489 taug(icol,lay,ngs27+ig) = speccomb * & 1490 (fac000 * absb(ind0,ig) + & 1491 fac100 * absb(ind0+1,ig) + & 1492 fac010 * absb(ind0+5,ig) + & 1493 fac110 * absb(ind0+6,ig) + & 1494 fac001 * absb(ind1,ig) + & 1495 fac101 * absb(ind1+1,ig) + & 1496 fac011 * absb(ind1+5,ig) + & 1497 fac111 * absb(ind1+6,ig)) 1498 ! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) 1499 if (lay .eq. laysolfr) sfluxzen(icol,ngs27+ig) = sfluxref(ig,js) & 1500 + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) 1501 taur(icol,lay,ngs27+ig) = tauray 1502 enddo 1503 enddo 1504 END SUBROUTINE taumol28 1505 !---------------------------------------------------------------------------- 1506 1507 SUBROUTINE taumol29() 1508 !---------------------------------------------------------------------------- 1509 ! 1510 ! band 29: 820-2600 cm-1 (low - h2o; high - co2) 1511 ! 1512 !---------------------------------------------------------------------------- 1513 ! ------- Modules ------- 1514 USE parrrsw, ONLY: ng29 1515 USE parrrsw, ONLY: ngs28 1516 USE rrsw_kg29, ONLY: rayl 1517 USE rrsw_kg29, ONLY: forref 1518 USE rrsw_kg29, ONLY: absa 1519 USE rrsw_kg29, ONLY: absco2 1520 USE rrsw_kg29, ONLY: selfref 1521 USE rrsw_kg29, ONLY: layreffr 1522 USE rrsw_kg29, ONLY: absh2o 1523 USE rrsw_kg29, ONLY: absb 1524 USE rrsw_kg29, ONLY: sfluxref 1525 ! ------- Declarations ------- 1526 ! Local 1527 INTEGER :: lay 1528 INTEGER :: ind0 1529 INTEGER :: ind1 1530 INTEGER :: inds 1531 INTEGER :: indf 1532 INTEGER :: ig 1533 INTEGER :: laysolfr 1534 REAL(KIND=r8) :: tauray 1535 ! Compute the optical depth by interpolating in ln(pressure), 1536 ! temperature, and appropriate species. Below LAYTROP, the water 1537 ! vapor self-continuum is interpolated (in temperature) separately. 1538 ! Lower atmosphere loop 1539 do lay = 1, laytrop(icol) 1540 ind0 = ((jp(icol,lay)-1)*5+(jt(icol,lay)-1))*nspa(29) + 1 1541 ind1 = (jp(icol,lay)*5+(jt1(icol,lay)-1))*nspa(29) + 1 1542 inds = indself(icol,lay) 1543 indf = indfor(icol,lay) 1544 tauray = colmol(icol,lay) * rayl 1545 do ig = 1, ng29 1546 taug(icol,lay,ngs28+ig) = colh2o(icol,lay) * & 1547 ((fac00(icol,lay) * absa(ind0,ig) + & 1548 fac10(icol,lay) * absa(ind0+1,ig) + & 1549 fac01(icol,lay) * absa(ind1,ig) + & 1550 fac11(icol,lay) * absa(ind1+1,ig)) + & 1551 selffac(icol,lay) * (selfref(inds,ig) + & 1552 selffrac(icol,lay) * & 1553 (selfref(inds+1,ig) - selfref(inds,ig))) + & 1554 forfac(icol,lay) * (forref(indf,ig) + & 1555 forfrac(icol,lay) * & 1556 (forref(indf+1,ig) - forref(indf,ig)))) & 1557 + colco2(icol,lay) * absco2(ig) 1558 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) 1559 taur(icol,lay,ngs28+ig) = tauray 1560 enddo 1561 enddo 1562 laysolfr = nlayers 1563 ! Upper atmosphere loop 1564 do lay = laytrop(icol)+1, nlayers 1565 if (jp(icol,lay-1) .lt. layreffr .and. jp(icol,lay) .ge. layreffr) & 1566 laysolfr = lay 1567 ind0 = ((jp(icol,lay)-13)*5+(jt(icol,lay)-1))*nspb(29) + 1 1568 ind1 = ((jp(icol,lay)-12)*5+(jt1(icol,lay)-1))*nspb(29) + 1 1569 tauray = colmol(icol,lay) * rayl 1570 do ig = 1, ng29 1571 taug(icol,lay,ngs28+ig) = colco2(icol,lay) * & 1572 (fac00(icol,lay) * absb(ind0,ig) + & 1573 fac10(icol,lay) * absb(ind0+1,ig) + & 1574 fac01(icol,lay) * absb(ind1,ig) + & 1575 fac11(icol,lay) * absb(ind1+1,ig)) & 1576 + colh2o(icol,lay) * absh2o(ig) 1577 ! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) 1578 if (lay .eq. laysolfr) sfluxzen(icol,ngs28+ig) = sfluxref(ig) 1579 taur(icol,lay,ngs28+ig) = tauray 1580 enddo 1581 enddo 1582 END SUBROUTINE taumol29 1583 END SUBROUTINE taumol_sw 1584 END MODULE rrtmg_sw_taumol 1585