1 2! KGEN-generated Fortran source file 3! 4! Filename : mo_lrtm_gas_optics.f90 5! Generated at: 2015-02-19 15:30:40 6! KGEN version: 0.4.4 7 8 9 10 MODULE mo_lrtm_gas_optics 11 ! -------------------------------------------------------------------------- 12 ! | | 13 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | 14 ! | This software may be used, copied, or redistributed as long as it is | 15 ! | not sold and this copyright notice is reproduced on each copy made. | 16 ! | This model is provided as is without any express or implied warranties. | 17 ! | (http://www.rtweb.aer.com/) | 18 ! | | 19 ! -------------------------------------------------------------------------- 20 ! ------- Modules ------- 21 USE mo_kind, ONLY: wp 22 USE mo_exception, ONLY: finish 23 USE mo_lrtm_setup, ONLY: ngb 24 USE mo_lrtm_setup, ONLY: ngs 25 USE mo_lrtm_setup, ONLY: nspa 26 USE mo_lrtm_setup, ONLY: nspb 27 USE mo_lrtm_setup, ONLY: ngc 28 USE rrlw_planck, ONLY: chi_mls 29 IMPLICIT NONE 30 REAL(KIND=wp), parameter :: oneminus = 1.0_wp - 1.0e-06_wp 31 CONTAINS 32 33 ! read subroutines 34 !---------------------------------------------------------------------------- 35 36 SUBROUTINE gas_optics_lw(nlayers, igg, pavel, wx, coldry, laytrop, jp, jt, jt1, colh2o, colco2, colo3, coln2o, colco, & 37 colch4, colo2, colbrd, fac00, fac01, fac10, fac11, rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, rat_h2on2o, & 38 rat_h2on2o_1, rat_h2och4, rat_h2och4_1, rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, selffac, selffrac, indself, & 39 forfac, forfrac, indfor, minorfrac, scaleminor, scaleminorn2, indminor, fracs, taug) 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: Karen Cady-Pereira, Patrick D. Brown, * 66 ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * 67 ! * * 68 ! ******************************************************************************* 69 ! * * 70 ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * 71 ! * * 72 ! ******************************************************************************* 73 ! * TAUMOL * 74 ! * * 75 ! * This file contains the subroutines TAUGBn (where n goes from * 76 ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * 77 ! * per g-value and layer for band n. * 78 ! * * 79 ! * Output: optical depths (unitless) * 80 ! * fractions needed to compute Planck functions at every layer * 81 ! * and g-value * 82 ! * * 83 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * 84 ! * COMMON /PLANKG/ FRACS(MXLAY,MG) * 85 ! * * 86 ! * Input * 87 ! * * 88 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * 89 ! * COMMON /PRECISE/ ONEMINUS * 90 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * 91 ! * & PZ(0:MXLAY),TZ(0:MXLAY) * 92 ! * COMMON /PROFDATA/ LAYTROP, * 93 ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * 94 ! * & COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY), * 95 ! * & COLO2(MXLAY) 96 ! * COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * 97 ! * & FAC10(MXLAY),FAC11(MXLAY) * 98 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * 99 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * 100 ! * * 101 ! * Description: * 102 ! * NG(IBAND) - number of g-values in band IBAND * 103 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference * 104 ! * atmospheres that are stored for band IBAND per * 105 ! * pressure level and temperature. Each of these * 106 ! * atmospheres has different relative amounts of the * 107 ! * key species for the band (i.e. different binary * 108 ! * species parameters). * 109 ! * NSPB(IBAND) - same for upper atmosphere * 110 ! * ONEMINUS - since problems are caused in some cases by interpolation * 111 ! * parameters equal to or greater than 1, for these cases * 112 ! * these parameters are set to this value, slightly < 1. * 113 ! * PAVEL - layer pressures (mb) * 114 ! * TAVEL - layer temperatures (degrees K) * 115 ! * PZ - level pressures (mb) * 116 ! * TZ - level temperatures (degrees K) * 117 ! * LAYTROP - layer at which switch is made from one combination of * 118 ! * key species to another * 119 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * 120 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * 121 ! * respectively (molecules/cm**2) * 122 ! * FACij(LAY) - for layer LAY, these are factors that are needed to * 123 ! * compute the interpolation factors that multiply the * 124 ! * appropriate reference k-values. A value of 0 (1) for * 125 ! * i,j indicates that the corresponding factor multiplies * 126 ! * reference k-value for the lower (higher) of the two * 127 ! * appropriate temperatures, and altitudes, respectively. * 128 ! * JP - the index of the lower (in altitude) of the two appropriate * 129 ! * reference pressure levels needed for interpolation * 130 ! * JT, JT1 - the indices of the lower of the two appropriate reference * 131 ! * temperatures needed for interpolation (for pressure * 132 ! * levels JP and JP+1, respectively) * 133 ! * SELFFAC - scale factor needed for water vapor self-continuum, equals * 134 ! * (water vapor density)/(atmospheric density at 296K and * 135 ! * 1013 mb) * 136 ! * SELFFRAC - factor needed for temperature interpolation of reference * 137 ! * water vapor self-continuum data * 138 ! * INDSELF - index of the lower of the two appropriate reference * 139 ! * temperatures needed for the self-continuum interpolation * 140 ! * FORFAC - scale factor needed for water vapor foreign-continuum. * 141 ! * FORFRAC - factor needed for temperature interpolation of reference * 142 ! * water vapor foreign-continuum data * 143 ! * INDFOR - index of the lower of the two appropriate reference * 144 ! * temperatures needed for the foreign-continuum interpolation * 145 ! * * 146 ! * Data input * 147 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* 148 ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * 149 ! * (note: n is the band number,'MGAS' is the species name of the minor * 150 ! * gas) * 151 ! * * 152 ! * Description: * 153 ! * KA - k-values for low reference atmospheres (key-species only) * 154 ! * (units: cm**2/molecule) * 155 ! * KB - k-values for high reference atmospheres (key-species only) * 156 ! * (units: cm**2/molecule) * 157 ! * KA_M'MGAS' - k-values for low reference atmosphere minor species * 158 ! * (units: cm**2/molecule) * 159 ! * KB_M'MGAS' - k-values for high reference atmosphere minor species * 160 ! * (units: cm**2/molecule) * 161 ! * SELFREF - k-values for water vapor self-continuum for reference * 162 ! * atmospheres (used below LAYTROP) * 163 ! * (units: cm**2/molecule) * 164 ! * FORREF - k-values for water vapor foreign-continuum for reference * 165 ! * atmospheres (used below/above LAYTROP) * 166 ! * (units: cm**2/molecule) * 167 ! * * 168 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * 169 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * 170 ! * * 171 !******************************************************************************* 172 ! ------- Declarations ------- 173 ! ----- Input ----- 174 INTEGER, intent(in) :: igg ! g-point to process 175 INTEGER, intent(in) :: nlayers ! total number of layers 176 REAL(KIND=wp), intent(in) :: pavel(:) ! layer pressures (mb) 177 ! Dimensions: (nlayers) 178 REAL(KIND=wp), intent(in) :: wx(:,:) ! cross-section amounts (mol/cm2) 179 ! Dimensions: (maxxsec,nlayers) 180 REAL(KIND=wp), intent(in) :: coldry(:) ! column amount (dry air) 181 ! Dimensions: (nlayers) 182 INTEGER, intent(in) :: laytrop ! tropopause layer index 183 INTEGER, intent(in) :: jp(:) ! 184 ! Dimensions: (nlayers) 185 INTEGER, intent(in) :: jt(:) ! 186 ! Dimensions: (nlayers) 187 INTEGER, intent(in) :: jt1(:) ! 188 ! Dimensions: (nlayers) 189 REAL(KIND=wp), intent(in) :: colh2o(:) ! column amount (h2o) 190 ! Dimensions: (nlayers) 191 REAL(KIND=wp), intent(in) :: colco2(:) ! column amount (co2) 192 ! Dimensions: (nlayers) 193 REAL(KIND=wp), intent(in) :: colo3(:) ! column amount (o3) 194 ! Dimensions: (nlayers) 195 REAL(KIND=wp), intent(in) :: coln2o(:) ! column amount (n2o) 196 ! Dimensions: (nlayers) 197 REAL(KIND=wp), intent(in) :: colco(:) ! column amount (co) 198 ! Dimensions: (nlayers) 199 REAL(KIND=wp), intent(in) :: colch4(:) ! column amount (ch4) 200 ! Dimensions: (nlayers) 201 REAL(KIND=wp), intent(in) :: colo2(:) ! column amount (o2) 202 ! Dimensions: (nlayers) 203 REAL(KIND=wp), intent(in) :: colbrd(:) ! column amount (broadening gases) 204 ! Dimensions: (nlayers) 205 INTEGER, intent(in) :: indself(:) 206 ! Dimensions: (nlayers) 207 INTEGER, intent(in) :: indfor(:) 208 ! Dimensions: (nlayers) 209 REAL(KIND=wp), intent(in) :: selffac(:) 210 ! Dimensions: (nlayers) 211 REAL(KIND=wp), intent(in) :: selffrac(:) 212 ! Dimensions: (nlayers) 213 REAL(KIND=wp), intent(in) :: forfac(:) 214 ! Dimensions: (nlayers) 215 REAL(KIND=wp), intent(in) :: forfrac(:) 216 ! Dimensions: (nlayers) 217 INTEGER, intent(in) :: indminor(:) 218 ! Dimensions: (nlayers) 219 REAL(KIND=wp), intent(in) :: minorfrac(:) 220 ! Dimensions: (nlayers) 221 REAL(KIND=wp), intent(in) :: scaleminor(:) 222 ! Dimensions: (nlayers) 223 REAL(KIND=wp), intent(in) :: scaleminorn2(:) 224 ! Dimensions: (nlayers) 225 REAL(KIND=wp), intent(in) :: fac11(:) 226 REAL(KIND=wp), intent(in) :: fac01(:) 227 REAL(KIND=wp), intent(in) :: fac00(:) 228 REAL(KIND=wp), intent(in) :: fac10(:) ! 229 ! Dimensions: (nlayers) 230 REAL(KIND=wp), intent(in) :: rat_h2oco2(:) 231 REAL(KIND=wp), intent(in) :: rat_h2oco2_1(:) 232 REAL(KIND=wp), intent(in) :: rat_o3co2(:) 233 REAL(KIND=wp), intent(in) :: rat_o3co2_1(:) 234 REAL(KIND=wp), intent(in) :: rat_h2oo3(:) 235 REAL(KIND=wp), intent(in) :: rat_h2oo3_1(:) 236 REAL(KIND=wp), intent(in) :: rat_h2och4(:) 237 REAL(KIND=wp), intent(in) :: rat_h2och4_1(:) 238 REAL(KIND=wp), intent(in) :: rat_h2on2o(:) 239 REAL(KIND=wp), intent(in) :: rat_h2on2o_1(:) 240 REAL(KIND=wp), intent(in) :: rat_n2oco2(:) 241 REAL(KIND=wp), intent(in) :: rat_n2oco2_1(:) ! 242 ! Dimensions: (nlayers) 243 ! ----- Output ----- 244 REAL(KIND=wp), intent(out) :: fracs(:) ! planck fractions 245 ! Dimensions: (nlayers) 246 REAL(KIND=wp), intent(out) :: taug(:) ! gaseous optical depth 247 ! Dimensions: (nlayers) 248 INTEGER :: ig 249 ! Calculate gaseous optical depth and planck fractions for each spectral band. 250 ! Local (within band) g-point 251 IF (ngb(igg) == 1) THEN 252 ig = igg 253 ELSE 254 ig = igg - ngs(ngb(igg) - 1) 255 END IF 256 SELECT CASE ( ngb(igg) ) 257 CASE ( 1 ) 258 CALL taumol01 259 CASE ( 2 ) 260 CALL taumol02 261 CASE ( 3 ) 262 CALL taumol03 263 CASE ( 4 ) 264 CALL taumol04 265 CASE ( 5 ) 266 CALL taumol05 267 CASE ( 6 ) 268 CALL taumol06 269 CASE ( 7 ) 270 CALL taumol07 271 CASE ( 8 ) 272 CALL taumol08 273 CASE ( 9 ) 274 CALL taumol09 275 CASE ( 10 ) 276 CALL taumol10 277 CASE ( 11 ) 278 CALL taumol11 279 CASE ( 12 ) 280 CALL taumol12 281 CASE ( 13 ) 282 CALL taumol13 283 CASE ( 14 ) 284 CALL taumol14 285 CASE ( 15 ) 286 CALL taumol15 287 CASE ( 16 ) 288 CALL taumol16 289 CASE DEFAULT 290 CALL finish('gas_optics_sw', 'Chosen band out of range') 291 END SELECT 292 CONTAINS 293 !---------------------------------------------------------------------------- 294 295 SUBROUTINE taumol01() 296 !---------------------------------------------------------------------------- 297 ! ------- Modifications ------- 298 ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. 299 ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. 300 ! 301 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) 302 ! (high key - h2o; high minor - n2) 303 ! 304 ! note: previous versions of rrtm band 1: 305 ! 10-250 cm-1 (low - h2o; high - h2o) 306 !---------------------------------------------------------------------------- 307 ! ------- Modules ------- 308 USE rrlw_kg01, ONLY: selfref 309 USE rrlw_kg01, ONLY: forref 310 USE rrlw_kg01, ONLY: ka_mn2 311 USE rrlw_kg01, ONLY: absa 312 USE rrlw_kg01, ONLY: fracrefa 313 USE rrlw_kg01, ONLY: kb_mn2 314 USE rrlw_kg01, ONLY: absb 315 USE rrlw_kg01, ONLY: fracrefb 316 ! ------- Declarations ------- 317 ! Local 318 INTEGER :: lay 319 INTEGER :: ind0 320 INTEGER :: ind1 321 INTEGER :: inds 322 INTEGER :: indf 323 INTEGER :: indm 324 REAL(KIND=wp) :: pp 325 REAL(KIND=wp) :: corradj 326 REAL(KIND=wp) :: scalen2 327 REAL(KIND=wp) :: tauself 328 REAL(KIND=wp) :: taufor 329 REAL(KIND=wp) :: taun2 330 ! Minor gas mapping levels: 331 ! lower - n2, p = 142.5490 mbar, t = 215.70 k 332 ! upper - n2, p = 142.5490 mbar, t = 215.70 k 333 ! Compute the optical depth by interpolating in ln(pressure) and 334 ! temperature. Below laytrop, the water vapor self-continuum and 335 ! foreign continuum is interpolated (in temperature) separately. 336 ! Lower atmosphere loop 337 DO lay = 1, laytrop 338 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(1) + 1 339 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(1) + 1 340 inds = indself(lay) 341 indf = indfor(lay) 342 indm = indminor(lay) 343 pp = pavel(lay) 344 corradj = 1. 345 IF (pp .lt. 250._wp) THEN 346 corradj = 1._wp - 0.15_wp * (250._wp-pp) / 154.4_wp 347 END IF 348 scalen2 = colbrd(lay) * scaleminorn2(lay) 349 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 350 selfref(inds,ig))) 351 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - & 352 forref(indf,ig))) 353 taun2 = scalen2*(ka_mn2(indm,ig) + minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,& 354 ig))) 355 taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 356 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 357 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + taun2) 358 fracs(lay) = fracrefa(ig) 359 END DO 360 ! Upper atmosphere loop 361 DO lay = laytrop+1, nlayers 362 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(1) + 1 363 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(1) + 1 364 indf = indfor(lay) 365 indm = indminor(lay) 366 pp = pavel(lay) 367 corradj = 1._wp - 0.15_wp * (pp / 95.6_wp) 368 scalen2 = colbrd(lay) * scaleminorn2(lay) 369 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 370 indf,ig))) 371 taun2 = scalen2*(kb_mn2(indm,ig) + minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,& 372 ig))) 373 taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & 374 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 375 fac11(lay) * absb(ind1+1,ig)) + taufor + taun2) 376 fracs(lay) = fracrefb(ig) 377 END DO 378 END SUBROUTINE taumol01 379 !---------------------------------------------------------------------------- 380 381 SUBROUTINE taumol02() 382 !---------------------------------------------------------------------------- 383 ! 384 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) 385 ! 386 ! note: previous version of rrtm band 2: 387 ! 250 - 500 cm-1 (low - h2o; high - h2o) 388 !---------------------------------------------------------------------------- 389 ! ------- Modules ------- 390 USE rrlw_kg02, ONLY: selfref 391 USE rrlw_kg02, ONLY: forref 392 USE rrlw_kg02, ONLY: absa 393 USE rrlw_kg02, ONLY: fracrefa 394 USE rrlw_kg02, ONLY: absb 395 USE rrlw_kg02, ONLY: fracrefb 396 ! ------- Declarations ------- 397 ! Local 398 INTEGER :: lay 399 INTEGER :: ind0 400 INTEGER :: ind1 401 INTEGER :: inds 402 INTEGER :: indf 403 REAL(KIND=wp) :: pp 404 REAL(KIND=wp) :: corradj 405 REAL(KIND=wp) :: tauself 406 REAL(KIND=wp) :: taufor 407 ! Compute the optical depth by interpolating in ln(pressure) and 408 ! temperature. Below laytrop, the water vapor self-continuum and 409 ! foreign continuum is interpolated (in temperature) separately. 410 ! Lower atmosphere loop 411 DO lay = 1, laytrop 412 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1 413 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1 414 inds = indself(lay) 415 indf = indfor(lay) 416 pp = pavel(lay) 417 corradj = 1._wp - .05_wp * (pp - 100._wp) / 900._wp 418 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 419 selfref(inds,ig))) 420 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 421 indf,ig))) 422 taug(lay) = corradj * (colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 423 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 424 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor) 425 fracs(lay) = fracrefa(ig) 426 END DO 427 ! Upper atmosphere loop 428 DO lay = laytrop+1, nlayers 429 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1 430 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1 431 indf = indfor(lay) 432 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 433 indf,ig))) 434 taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & 435 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 436 fac11(lay) * absb(ind1+1,ig)) + taufor 437 fracs(lay) = fracrefb(ig) 438 END DO 439 END SUBROUTINE taumol02 440 !---------------------------------------------------------------------------- 441 442 SUBROUTINE taumol03() 443 !---------------------------------------------------------------------------- 444 ! 445 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) 446 ! (high key - h2o,co2; high minor - n2o) 447 !---------------------------------------------------------------------------- 448 ! ------- Modules ------- 449 USE rrlw_kg03, ONLY: selfref 450 USE rrlw_kg03, ONLY: forref 451 USE rrlw_kg03, ONLY: ka_mn2o 452 USE rrlw_kg03, ONLY: absa 453 USE rrlw_kg03, ONLY: fracrefa 454 USE rrlw_kg03, ONLY: kb_mn2o 455 USE rrlw_kg03, ONLY: absb 456 USE rrlw_kg03, ONLY: fracrefb 457 ! ------- Declarations ------- 458 ! Local 459 INTEGER :: lay 460 INTEGER :: ind0 461 INTEGER :: ind1 462 INTEGER :: inds 463 INTEGER :: indf 464 INTEGER :: indm 465 INTEGER :: js 466 INTEGER :: js1 467 INTEGER :: jmn2o 468 INTEGER :: jpl 469 REAL(KIND=wp) :: speccomb 470 REAL(KIND=wp) :: specparm 471 REAL(KIND=wp) :: specmult 472 REAL(KIND=wp) :: fs 473 REAL(KIND=wp) :: speccomb1 474 REAL(KIND=wp) :: specparm1 475 REAL(KIND=wp) :: specmult1 476 REAL(KIND=wp) :: fs1 477 REAL(KIND=wp) :: speccomb_mn2o 478 REAL(KIND=wp) :: specparm_mn2o 479 REAL(KIND=wp) :: specmult_mn2o 480 REAL(KIND=wp) :: fmn2o 481 REAL(KIND=wp) :: fmn2omf 482 REAL(KIND=wp) :: chi_n2o 483 REAL(KIND=wp) :: ratn2o 484 REAL(KIND=wp) :: adjfac 485 REAL(KIND=wp) :: adjcoln2o 486 REAL(KIND=wp) :: speccomb_planck 487 REAL(KIND=wp) :: specparm_planck 488 REAL(KIND=wp) :: specmult_planck 489 REAL(KIND=wp) :: fpl 490 REAL(KIND=wp) :: p 491 REAL(KIND=wp) :: p4 492 REAL(KIND=wp) :: fk0 493 REAL(KIND=wp) :: fk1 494 REAL(KIND=wp) :: fk2 495 REAL(KIND=wp) :: fac000 496 REAL(KIND=wp) :: fac100 497 REAL(KIND=wp) :: fac200 498 REAL(KIND=wp) :: fac010 499 REAL(KIND=wp) :: fac110 500 REAL(KIND=wp) :: fac210 501 REAL(KIND=wp) :: fac001 502 REAL(KIND=wp) :: fac101 503 REAL(KIND=wp) :: fac201 504 REAL(KIND=wp) :: fac011 505 REAL(KIND=wp) :: fac111 506 REAL(KIND=wp) :: fac211 507 REAL(KIND=wp) :: tauself 508 REAL(KIND=wp) :: taufor 509 REAL(KIND=wp) :: n2om1 510 REAL(KIND=wp) :: n2om2 511 REAL(KIND=wp) :: absn2o 512 REAL(KIND=wp) :: refrat_planck_a 513 REAL(KIND=wp) :: refrat_planck_b 514 REAL(KIND=wp) :: refrat_m_a 515 REAL(KIND=wp) :: refrat_m_b 516 REAL(KIND=wp) :: tau_major 517 REAL(KIND=wp) :: tau_major1 518 INTEGER :: rrpk_counter=0 519 ! Minor gas mapping levels: 520 ! lower - n2o, p = 706.272 mbar, t = 278.94 k 521 ! upper - n2o, p = 95.58 mbar, t = 215.7 k 522 ! P = 212.725 mb 523 refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) 524 ! P = 95.58 mb 525 refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) 526 ! P = 706.270mb 527 refrat_m_a = chi_mls(1,3)/chi_mls(2,3) 528 ! P = 95.58 mb 529 refrat_m_b = chi_mls(1,13)/chi_mls(2,13) 530 ! Compute the optical depth by interpolating in ln(pressure) and 531 ! temperature, and appropriate species. Below laytrop, the water vapor 532 ! self-continuum and foreign continuum is interpolated (in temperature) 533 ! separately. 534 ! Lower atmosphere loop 535 DO lay = 1, laytrop 536 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) 537 specparm = colh2o(lay)/speccomb 538 IF (specparm .ge. oneminus) specparm = oneminus 539 specmult = 8._wp*(specparm) 540 js = 1 + int(specmult) 541 fs = mod(specmult,1.0_wp) 542 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) 543 specparm1 = colh2o(lay)/speccomb1 544 IF (specparm1 .ge. oneminus) specparm1 = oneminus 545 specmult1 = 8._wp*(specparm1) 546 js1 = 1 + int(specmult1) 547 fs1 = mod(specmult1,1.0_wp) 548 speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay) 549 specparm_mn2o = colh2o(lay)/speccomb_mn2o 550 IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus 551 specmult_mn2o = 8._wp*specparm_mn2o 552 jmn2o = 1 + int(specmult_mn2o) 553 fmn2o = mod(specmult_mn2o,1.0_wp) 554 fmn2omf = minorfrac(lay)*fmn2o 555 ! In atmospheres where the amount of N2O is too great to be considered 556 ! a minor species, adjust the column amount of N2O by an empirical factor 557 ! to obtain the proper contribution. 558 chi_n2o = coln2o(lay)/coldry(lay) 559 ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) 560 IF (ratn2o .gt. 1.5_wp) THEN 561 adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp 562 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp 563 ELSE 564 adjcoln2o = coln2o(lay) 565 END IF 566 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) 567 specparm_planck = colh2o(lay)/speccomb_planck 568 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 569 specmult_planck = 8._wp*specparm_planck 570 jpl = 1 + int(specmult_planck) 571 fpl = mod(specmult_planck,1.0_wp) 572 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js 573 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1 574 inds = indself(lay) 575 indf = indfor(lay) 576 indm = indminor(lay) 577 IF (specparm .lt. 0.125_wp) THEN 578 p = fs - 1 579 p4 = p**4 580 fk0 = p4 581 fk1 = 1 - p - 2.0_wp*p4 582 fk2 = p + p4 583 fac000 = fk0*fac00(lay) 584 fac100 = fk1*fac00(lay) 585 fac200 = fk2*fac00(lay) 586 fac010 = fk0*fac10(lay) 587 fac110 = fk1*fac10(lay) 588 fac210 = fk2*fac10(lay) 589 ELSE IF (specparm .gt. 0.875_wp) THEN 590 p = -fs 591 p4 = p**4 592 fk0 = p4 593 fk1 = 1 - p - 2.0_wp*p4 594 fk2 = p + p4 595 fac000 = fk0*fac00(lay) 596 fac100 = fk1*fac00(lay) 597 fac200 = fk2*fac00(lay) 598 fac010 = fk0*fac10(lay) 599 fac110 = fk1*fac10(lay) 600 fac210 = fk2*fac10(lay) 601 ELSE 602 fac000 = (1._wp - fs) * fac00(lay) 603 fac010 = (1._wp - fs) * fac10(lay) 604 fac100 = fs * fac00(lay) 605 fac110 = fs * fac10(lay) 606 END IF 607 IF (specparm1 .lt. 0.125_wp) THEN 608 p = fs1 - 1 609 p4 = p**4 610 fk0 = p4 611 fk1 = 1 - p - 2.0_wp*p4 612 fk2 = p + p4 613 fac001 = fk0*fac01(lay) 614 fac101 = fk1*fac01(lay) 615 fac201 = fk2*fac01(lay) 616 fac011 = fk0*fac11(lay) 617 fac111 = fk1*fac11(lay) 618 fac211 = fk2*fac11(lay) 619 ELSE IF (specparm1 .gt. 0.875_wp) THEN 620 p = -fs1 621 p4 = p**4 622 fk0 = p4 623 fk1 = 1 - p - 2.0_wp*p4 624 fk2 = p + p4 625 fac001 = fk0*fac01(lay) 626 fac101 = fk1*fac01(lay) 627 fac201 = fk2*fac01(lay) 628 fac011 = fk0*fac11(lay) 629 fac111 = fk1*fac11(lay) 630 fac211 = fk2*fac11(lay) 631 ELSE 632 fac001 = (1._wp - fs1) * fac01(lay) 633 fac011 = (1._wp - fs1) * fac11(lay) 634 fac101 = fs1 * fac01(lay) 635 fac111 = fs1 * fac11(lay) 636 END IF 637 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 638 selfref(inds,ig))) 639 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 640 indf,ig))) 641 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& 642 indm,ig)) 643 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& 644 jmn2o,indm+1,ig)) 645 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) 646 IF (specparm .lt. 0.125_wp) THEN 647 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 648 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 649 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 650 fac210 * absa(ind0+11,ig)) 651 ELSE IF (specparm .gt. 0.875_wp) THEN 652 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 653 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 654 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 655 fac010 * absa(ind0+10,ig)) 656 ELSE 657 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 658 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 659 fac110 * absa(ind0+10,ig)) 660 END IF 661 IF (specparm1 .lt. 0.125_wp) THEN 662 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 663 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 664 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 665 fac211 * absa(ind1+11,ig)) 666 ELSE IF (specparm1 .gt. 0.875_wp) THEN 667 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 668 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 669 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 670 fac011 * absa(ind1+10,ig)) 671 ELSE 672 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 673 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 674 fac111 * absa(ind1+10,ig)) 675 END IF 676 taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o 677 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 678 rrpk_counter=rrpk_counter+1 679 END DO 680 ! Upper atmosphere loop 681 DO lay = laytrop+1, nlayers 682 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) 683 specparm = colh2o(lay)/speccomb 684 IF (specparm .ge. oneminus) specparm = oneminus 685 specmult = 4._wp*(specparm) 686 js = 1 + int(specmult) 687 fs = mod(specmult,1.0_wp) 688 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) 689 specparm1 = colh2o(lay)/speccomb1 690 IF (specparm1 .ge. oneminus) specparm1 = oneminus 691 specmult1 = 4._wp*(specparm1) 692 js1 = 1 + int(specmult1) 693 fs1 = mod(specmult1,1.0_wp) 694 fac000 = (1._wp - fs) * fac00(lay) 695 fac010 = (1._wp - fs) * fac10(lay) 696 fac100 = fs * fac00(lay) 697 fac110 = fs * fac10(lay) 698 fac001 = (1._wp - fs1) * fac01(lay) 699 fac011 = (1._wp - fs1) * fac11(lay) 700 fac101 = fs1 * fac01(lay) 701 fac111 = fs1 * fac11(lay) 702 speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay) 703 specparm_mn2o = colh2o(lay)/speccomb_mn2o 704 IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus 705 specmult_mn2o = 4._wp*specparm_mn2o 706 jmn2o = 1 + int(specmult_mn2o) 707 fmn2o = mod(specmult_mn2o,1.0_wp) 708 fmn2omf = minorfrac(lay)*fmn2o 709 ! In atmospheres where the amount of N2O is too great to be considered 710 ! a minor species, adjust the column amount of N2O by an empirical factor 711 ! to obtain the proper contribution. 712 chi_n2o = coln2o(lay)/coldry(lay) 713 ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1) 714 IF (ratn2o .gt. 1.5_wp) THEN 715 adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp 716 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp 717 ELSE 718 adjcoln2o = coln2o(lay) 719 END IF 720 speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay) 721 specparm_planck = colh2o(lay)/speccomb_planck 722 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 723 specmult_planck = 4._wp*specparm_planck 724 jpl = 1 + int(specmult_planck) 725 fpl = mod(specmult_planck,1.0_wp) 726 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js 727 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1 728 indf = indfor(lay) 729 indm = indminor(lay) 730 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 731 indf,ig))) 732 n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,& 733 indm,ig)) 734 n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,& 735 indm+1,ig)) 736 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) 737 taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & 738 absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& 739 ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & 740 fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & 741 fac111 * absb(ind1+6,ig)) + taufor + adjcoln2o*absn2o 742 fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) 743 END DO 744 END SUBROUTINE taumol03 745 !---------------------------------------------------------------------------- 746 747 SUBROUTINE taumol04() 748 !---------------------------------------------------------------------------- 749 ! 750 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) 751 !---------------------------------------------------------------------------- 752 ! ------- Modules ------- 753 USE rrlw_kg04, ONLY: selfref 754 USE rrlw_kg04, ONLY: forref 755 USE rrlw_kg04, ONLY: absa 756 USE rrlw_kg04, ONLY: fracrefa 757 USE rrlw_kg04, ONLY: absb 758 USE rrlw_kg04, ONLY: fracrefb 759 ! ------- Declarations ------- 760 ! Local 761 INTEGER :: lay 762 INTEGER :: ind0 763 INTEGER :: ind1 764 INTEGER :: inds 765 INTEGER :: indf 766 INTEGER :: js 767 INTEGER :: js1 768 INTEGER :: jpl 769 REAL(KIND=wp) :: speccomb 770 REAL(KIND=wp) :: specparm 771 REAL(KIND=wp) :: specmult 772 REAL(KIND=wp) :: fs 773 REAL(KIND=wp) :: speccomb1 774 REAL(KIND=wp) :: specparm1 775 REAL(KIND=wp) :: specmult1 776 REAL(KIND=wp) :: fs1 777 REAL(KIND=wp) :: speccomb_planck 778 REAL(KIND=wp) :: specparm_planck 779 REAL(KIND=wp) :: specmult_planck 780 REAL(KIND=wp) :: fpl 781 REAL(KIND=wp) :: p 782 REAL(KIND=wp) :: p4 783 REAL(KIND=wp) :: fk0 784 REAL(KIND=wp) :: fk1 785 REAL(KIND=wp) :: fk2 786 REAL(KIND=wp) :: fac000 787 REAL(KIND=wp) :: fac100 788 REAL(KIND=wp) :: fac200 789 REAL(KIND=wp) :: fac010 790 REAL(KIND=wp) :: fac110 791 REAL(KIND=wp) :: fac210 792 REAL(KIND=wp) :: fac001 793 REAL(KIND=wp) :: fac101 794 REAL(KIND=wp) :: fac201 795 REAL(KIND=wp) :: fac011 796 REAL(KIND=wp) :: fac111 797 REAL(KIND=wp) :: fac211 798 REAL(KIND=wp) :: tauself 799 REAL(KIND=wp) :: taufor 800 REAL(KIND=wp) :: refrat_planck_a 801 REAL(KIND=wp) :: refrat_planck_b 802 REAL(KIND=wp) :: tau_major 803 REAL(KIND=wp) :: tau_major1 804 REAL(KIND=wp), dimension(ngc(4)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, & 805 .99, .88, .943 /) 806 ! P = 142.5940 mb 807 refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) 808 ! P = 95.58350 mb 809 refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) 810 ! Compute the optical depth by interpolating in ln(pressure) and 811 ! temperature, and appropriate species. Below laytrop, the water 812 ! vapor self-continuum and foreign continuum is interpolated (in temperature) 813 ! separately. 814 ! Lower atmosphere loop 815 DO lay = 1, laytrop 816 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) 817 specparm = colh2o(lay)/speccomb 818 IF (specparm .ge. oneminus) specparm = oneminus 819 specmult = 8._wp*(specparm) 820 js = 1 + int(specmult) 821 fs = mod(specmult,1.0_wp) 822 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) 823 specparm1 = colh2o(lay)/speccomb1 824 IF (specparm1 .ge. oneminus) specparm1 = oneminus 825 specmult1 = 8._wp*(specparm1) 826 js1 = 1 + int(specmult1) 827 fs1 = mod(specmult1,1.0_wp) 828 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) 829 specparm_planck = colh2o(lay)/speccomb_planck 830 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 831 specmult_planck = 8._wp*specparm_planck 832 jpl = 1 + int(specmult_planck) 833 fpl = mod(specmult_planck,1.0_wp) 834 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js 835 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1 836 inds = indself(lay) 837 indf = indfor(lay) 838 IF (specparm .lt. 0.125_wp) THEN 839 p = fs - 1 840 p4 = p**4 841 fk0 = p4 842 fk1 = 1 - p - 2.0_wp*p4 843 fk2 = p + p4 844 fac000 = fk0*fac00(lay) 845 fac100 = fk1*fac00(lay) 846 fac200 = fk2*fac00(lay) 847 fac010 = fk0*fac10(lay) 848 fac110 = fk1*fac10(lay) 849 fac210 = fk2*fac10(lay) 850 ELSE IF (specparm .gt. 0.875_wp) THEN 851 p = -fs 852 p4 = p**4 853 fk0 = p4 854 fk1 = 1 - p - 2.0_wp*p4 855 fk2 = p + p4 856 fac000 = fk0*fac00(lay) 857 fac100 = fk1*fac00(lay) 858 fac200 = fk2*fac00(lay) 859 fac010 = fk0*fac10(lay) 860 fac110 = fk1*fac10(lay) 861 fac210 = fk2*fac10(lay) 862 ELSE 863 fac000 = (1._wp - fs) * fac00(lay) 864 fac010 = (1._wp - fs) * fac10(lay) 865 fac100 = fs * fac00(lay) 866 fac110 = fs * fac10(lay) 867 END IF 868 IF (specparm1 .lt. 0.125_wp) THEN 869 p = fs1 - 1 870 p4 = p**4 871 fk0 = p4 872 fk1 = 1 - p - 2.0_wp*p4 873 fk2 = p + p4 874 fac001 = fk0*fac01(lay) 875 fac101 = fk1*fac01(lay) 876 fac201 = fk2*fac01(lay) 877 fac011 = fk0*fac11(lay) 878 fac111 = fk1*fac11(lay) 879 fac211 = fk2*fac11(lay) 880 ELSE IF (specparm1 .gt. 0.875_wp) THEN 881 p = -fs1 882 p4 = p**4 883 fk0 = p4 884 fk1 = 1 - p - 2.0_wp*p4 885 fk2 = p + p4 886 fac001 = fk0*fac01(lay) 887 fac101 = fk1*fac01(lay) 888 fac201 = fk2*fac01(lay) 889 fac011 = fk0*fac11(lay) 890 fac111 = fk1*fac11(lay) 891 fac211 = fk2*fac11(lay) 892 ELSE 893 fac001 = (1._wp - fs1) * fac01(lay) 894 fac011 = (1._wp - fs1) * fac11(lay) 895 fac101 = fs1 * fac01(lay) 896 fac111 = fs1 * fac11(lay) 897 END IF 898 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 899 selfref(inds,ig))) 900 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 901 indf,ig))) 902 IF (specparm .lt. 0.125_wp) THEN 903 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 904 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 905 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 906 fac210 * absa(ind0+11,ig)) 907 ELSE IF (specparm .gt. 0.875_wp) THEN 908 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 909 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 910 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 911 fac010 * absa(ind0+10,ig)) 912 ELSE 913 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 914 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 915 fac110 * absa(ind0+10,ig)) 916 END IF 917 IF (specparm1 .lt. 0.125_wp) THEN 918 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 919 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 920 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 921 fac211 * absa(ind1+11,ig)) 922 ELSE IF (specparm1 .gt. 0.875_wp) THEN 923 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 924 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 925 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 926 fac011 * absa(ind1+10,ig)) 927 ELSE 928 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 929 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 930 fac111 * absa(ind1+10,ig)) 931 END IF 932 taug(lay) = tau_major + tau_major1 + tauself + taufor 933 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 934 END DO 935 ! Upper atmosphere loop 936 DO lay = laytrop+1, nlayers 937 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) 938 specparm = colo3(lay)/speccomb 939 IF (specparm .ge. oneminus) specparm = oneminus 940 specmult = 4._wp*(specparm) 941 js = 1 + int(specmult) 942 fs = mod(specmult,1.0_wp) 943 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) 944 specparm1 = colo3(lay)/speccomb1 945 IF (specparm1 .ge. oneminus) specparm1 = oneminus 946 specmult1 = 4._wp*(specparm1) 947 js1 = 1 + int(specmult1) 948 fs1 = mod(specmult1,1.0_wp) 949 fac000 = (1._wp - fs) * fac00(lay) 950 fac010 = (1._wp - fs) * fac10(lay) 951 fac100 = fs * fac00(lay) 952 fac110 = fs * fac10(lay) 953 fac001 = (1._wp - fs1) * fac01(lay) 954 fac011 = (1._wp - fs1) * fac11(lay) 955 fac101 = fs1 * fac01(lay) 956 fac111 = fs1 * fac11(lay) 957 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) 958 specparm_planck = colo3(lay)/speccomb_planck 959 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 960 specmult_planck = 4._wp*specparm_planck 961 jpl = 1 + int(specmult_planck) 962 fpl = mod(specmult_planck,1.0_wp) 963 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js 964 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1 965 taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & 966 absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& 967 ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & 968 fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & 969 fac111 * absb(ind1+6,ig)) 970 fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) 971 ! Empirical modification to code to improve stratospheric cooling rates 972 ! for co2. Revised to apply weighting for g-point reduction in this band. 973 ! taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92 974 ! taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88 975 ! taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07 976 ! taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1 977 ! taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99 978 ! taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88 979 ! taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943 980 END DO 981 taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) 982 END SUBROUTINE taumol04 983 !---------------------------------------------------------------------------- 984 985 SUBROUTINE taumol05() 986 !---------------------------------------------------------------------------- 987 ! 988 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) 989 ! (high key - o3,co2) 990 !---------------------------------------------------------------------------- 991 ! ------- Modules ------- 992 USE rrlw_kg05, ONLY: selfref 993 USE rrlw_kg05, ONLY: forref 994 USE rrlw_kg05, ONLY: ka_mo3 995 USE rrlw_kg05, ONLY: absa 996 USE rrlw_kg05, ONLY: ccl4 997 USE rrlw_kg05, ONLY: fracrefa 998 USE rrlw_kg05, ONLY: absb 999 USE rrlw_kg05, ONLY: fracrefb 1000 ! ------- Declarations ------- 1001 ! Local 1002 INTEGER :: lay 1003 INTEGER :: ind0 1004 INTEGER :: ind1 1005 INTEGER :: inds 1006 INTEGER :: indf 1007 INTEGER :: indm 1008 INTEGER :: js 1009 INTEGER :: js1 1010 INTEGER :: jmo3 1011 INTEGER :: jpl 1012 REAL(KIND=wp) :: speccomb 1013 REAL(KIND=wp) :: specparm 1014 REAL(KIND=wp) :: specmult 1015 REAL(KIND=wp) :: fs 1016 REAL(KIND=wp) :: speccomb1 1017 REAL(KIND=wp) :: specparm1 1018 REAL(KIND=wp) :: specmult1 1019 REAL(KIND=wp) :: fs1 1020 REAL(KIND=wp) :: speccomb_mo3 1021 REAL(KIND=wp) :: specparm_mo3 1022 REAL(KIND=wp) :: specmult_mo3 1023 REAL(KIND=wp) :: fmo3 1024 REAL(KIND=wp) :: speccomb_planck 1025 REAL(KIND=wp) :: specparm_planck 1026 REAL(KIND=wp) :: specmult_planck 1027 REAL(KIND=wp) :: fpl 1028 REAL(KIND=wp) :: p 1029 REAL(KIND=wp) :: p4 1030 REAL(KIND=wp) :: fk0 1031 REAL(KIND=wp) :: fk1 1032 REAL(KIND=wp) :: fk2 1033 REAL(KIND=wp) :: fac000 1034 REAL(KIND=wp) :: fac100 1035 REAL(KIND=wp) :: fac200 1036 REAL(KIND=wp) :: fac010 1037 REAL(KIND=wp) :: fac110 1038 REAL(KIND=wp) :: fac210 1039 REAL(KIND=wp) :: fac001 1040 REAL(KIND=wp) :: fac101 1041 REAL(KIND=wp) :: fac201 1042 REAL(KIND=wp) :: fac011 1043 REAL(KIND=wp) :: fac111 1044 REAL(KIND=wp) :: fac211 1045 REAL(KIND=wp) :: tauself 1046 REAL(KIND=wp) :: taufor 1047 REAL(KIND=wp) :: o3m1 1048 REAL(KIND=wp) :: o3m2 1049 REAL(KIND=wp) :: abso3 1050 REAL(KIND=wp) :: refrat_planck_a 1051 REAL(KIND=wp) :: refrat_planck_b 1052 REAL(KIND=wp) :: refrat_m_a 1053 REAL(KIND=wp) :: tau_major 1054 REAL(KIND=wp) :: tau_major1 1055 ! Minor gas mapping level : 1056 ! lower - o3, p = 317.34 mbar, t = 240.77 k 1057 ! lower - ccl4 1058 ! Calculate reference ratio to be used in calculation of Planck 1059 ! fraction in lower/upper atmosphere. 1060 ! P = 473.420 mb 1061 refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) 1062 ! P = 0.2369 mb 1063 refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) 1064 ! P = 317.3480 1065 refrat_m_a = chi_mls(1,7)/chi_mls(2,7) 1066 ! Compute the optical depth by interpolating in ln(pressure) and 1067 ! temperature, and appropriate species. Below laytrop, the 1068 ! water vapor self-continuum and foreign continuum is 1069 ! interpolated (in temperature) separately. 1070 ! Lower atmosphere loop 1071 DO lay = 1, laytrop 1072 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) 1073 specparm = colh2o(lay)/speccomb 1074 IF (specparm .ge. oneminus) specparm = oneminus 1075 specmult = 8._wp*(specparm) 1076 js = 1 + int(specmult) 1077 fs = mod(specmult,1.0_wp) 1078 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) 1079 specparm1 = colh2o(lay)/speccomb1 1080 IF (specparm1 .ge. oneminus) specparm1 = oneminus 1081 specmult1 = 8._wp*(specparm1) 1082 js1 = 1 + int(specmult1) 1083 fs1 = mod(specmult1,1.0_wp) 1084 speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay) 1085 specparm_mo3 = colh2o(lay)/speccomb_mo3 1086 IF (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus 1087 specmult_mo3 = 8._wp*specparm_mo3 1088 jmo3 = 1 + int(specmult_mo3) 1089 fmo3 = mod(specmult_mo3,1.0_wp) 1090 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) 1091 specparm_planck = colh2o(lay)/speccomb_planck 1092 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 1093 specmult_planck = 8._wp*specparm_planck 1094 jpl = 1 + int(specmult_planck) 1095 fpl = mod(specmult_planck,1.0_wp) 1096 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js 1097 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1 1098 inds = indself(lay) 1099 indf = indfor(lay) 1100 indm = indminor(lay) 1101 IF (specparm .lt. 0.125_wp) THEN 1102 p = fs - 1 1103 p4 = p**4 1104 fk0 = p4 1105 fk1 = 1 - p - 2.0_wp*p4 1106 fk2 = p + p4 1107 fac000 = fk0*fac00(lay) 1108 fac100 = fk1*fac00(lay) 1109 fac200 = fk2*fac00(lay) 1110 fac010 = fk0*fac10(lay) 1111 fac110 = fk1*fac10(lay) 1112 fac210 = fk2*fac10(lay) 1113 ELSE IF (specparm .gt. 0.875_wp) THEN 1114 p = -fs 1115 p4 = p**4 1116 fk0 = p4 1117 fk1 = 1 - p - 2.0_wp*p4 1118 fk2 = p + p4 1119 fac000 = fk0*fac00(lay) 1120 fac100 = fk1*fac00(lay) 1121 fac200 = fk2*fac00(lay) 1122 fac010 = fk0*fac10(lay) 1123 fac110 = fk1*fac10(lay) 1124 fac210 = fk2*fac10(lay) 1125 ELSE 1126 fac000 = (1._wp - fs) * fac00(lay) 1127 fac010 = (1._wp - fs) * fac10(lay) 1128 fac100 = fs * fac00(lay) 1129 fac110 = fs * fac10(lay) 1130 END IF 1131 IF (specparm1 .lt. 0.125_wp) THEN 1132 p = fs1 - 1 1133 p4 = p**4 1134 fk0 = p4 1135 fk1 = 1 - p - 2.0_wp*p4 1136 fk2 = p + p4 1137 fac001 = fk0*fac01(lay) 1138 fac101 = fk1*fac01(lay) 1139 fac201 = fk2*fac01(lay) 1140 fac011 = fk0*fac11(lay) 1141 fac111 = fk1*fac11(lay) 1142 fac211 = fk2*fac11(lay) 1143 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1144 p = -fs1 1145 p4 = p**4 1146 fk0 = p4 1147 fk1 = 1 - p - 2.0_wp*p4 1148 fk2 = p + p4 1149 fac001 = fk0*fac01(lay) 1150 fac101 = fk1*fac01(lay) 1151 fac201 = fk2*fac01(lay) 1152 fac011 = fk0*fac11(lay) 1153 fac111 = fk1*fac11(lay) 1154 fac211 = fk2*fac11(lay) 1155 ELSE 1156 fac001 = (1._wp - fs1) * fac01(lay) 1157 fac011 = (1._wp - fs1) * fac11(lay) 1158 fac101 = fs1 * fac01(lay) 1159 fac111 = fs1 * fac11(lay) 1160 END IF 1161 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1162 selfref(inds,ig))) 1163 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1164 indf,ig))) 1165 o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig)) 1166 o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,& 1167 ig)) 1168 abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1) 1169 IF (specparm .lt. 0.125_wp) THEN 1170 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1171 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 1172 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 1173 fac210 * absa(ind0+11,ig)) 1174 ELSE IF (specparm .gt. 0.875_wp) THEN 1175 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 1176 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 1177 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 1178 fac010 * absa(ind0+10,ig)) 1179 ELSE 1180 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1181 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 1182 fac110 * absa(ind0+10,ig)) 1183 END IF 1184 IF (specparm1 .lt. 0.125_wp) THEN 1185 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1186 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 1187 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 1188 fac211 * absa(ind1+11,ig)) 1189 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1190 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 1191 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 1192 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 1193 fac011 * absa(ind1+10,ig)) 1194 ELSE 1195 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1196 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 1197 fac111 * absa(ind1+10,ig)) 1198 END IF 1199 taug(lay) = tau_major + tau_major1 + tauself + taufor + & 1200 abso3*colo3(lay) + wx(1,lay) * ccl4(ig) 1201 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 1202 END DO 1203 ! Upper atmosphere loop 1204 DO lay = laytrop+1, nlayers 1205 speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay) 1206 specparm = colo3(lay)/speccomb 1207 IF (specparm .ge. oneminus) specparm = oneminus 1208 specmult = 4._wp*(specparm) 1209 js = 1 + int(specmult) 1210 fs = mod(specmult,1.0_wp) 1211 speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay) 1212 specparm1 = colo3(lay)/speccomb1 1213 IF (specparm1 .ge. oneminus) specparm1 = oneminus 1214 specmult1 = 4._wp*(specparm1) 1215 js1 = 1 + int(specmult1) 1216 fs1 = mod(specmult1,1.0_wp) 1217 fac000 = (1._wp - fs) * fac00(lay) 1218 fac010 = (1._wp - fs) * fac10(lay) 1219 fac100 = fs * fac00(lay) 1220 fac110 = fs * fac10(lay) 1221 fac001 = (1._wp - fs1) * fac01(lay) 1222 fac011 = (1._wp - fs1) * fac11(lay) 1223 fac101 = fs1 * fac01(lay) 1224 fac111 = fs1 * fac11(lay) 1225 speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay) 1226 specparm_planck = colo3(lay)/speccomb_planck 1227 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 1228 specmult_planck = 4._wp*specparm_planck 1229 jpl = 1 + int(specmult_planck) 1230 fpl = mod(specmult_planck,1.0_wp) 1231 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js 1232 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1 1233 taug(lay) = speccomb * (fac000 * absb(ind0,ig) + fac100 * & 1234 absb(ind0+1,ig) + fac010 * absb(ind0+5,ig) + fac110 * absb(& 1235 ind0+6,ig)) + speccomb1 * (fac001 * absb(ind1,ig) + & 1236 fac101 * absb(ind1+1,ig) + fac011 * absb(ind1+5,ig) + & 1237 fac111 * absb(ind1+6,ig)) + wx(1,lay) * ccl4(ig) 1238 fracs(lay) = fracrefb(ig,jpl) + fpl * (fracrefb(ig,jpl+1)-fracrefb(ig,jpl)) 1239 END DO 1240 END SUBROUTINE taumol05 1241 !---------------------------------------------------------------------------- 1242 1243 SUBROUTINE taumol06() 1244 !---------------------------------------------------------------------------- 1245 ! 1246 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) 1247 ! (high key - nothing; high minor - cfc11, cfc12) 1248 !---------------------------------------------------------------------------- 1249 ! ------- Modules ------- 1250 USE rrlw_kg06, ONLY: selfref 1251 USE rrlw_kg06, ONLY: forref 1252 USE rrlw_kg06, ONLY: ka_mco2 1253 USE rrlw_kg06, ONLY: cfc12 1254 USE rrlw_kg06, ONLY: absa 1255 USE rrlw_kg06, ONLY: cfc11adj 1256 USE rrlw_kg06, ONLY: fracrefa 1257 ! ------- Declarations ------- 1258 ! Local 1259 INTEGER :: lay 1260 INTEGER :: ind0 1261 INTEGER :: ind1 1262 INTEGER :: inds 1263 INTEGER :: indf 1264 INTEGER :: indm 1265 REAL(KIND=wp) :: chi_co2 1266 REAL(KIND=wp) :: ratco2 1267 REAL(KIND=wp) :: adjfac 1268 REAL(KIND=wp) :: adjcolco2 1269 REAL(KIND=wp) :: tauself 1270 REAL(KIND=wp) :: taufor 1271 REAL(KIND=wp) :: absco2 1272 ! Minor gas mapping level: 1273 ! lower - co2, p = 706.2720 mb, t = 294.2 k 1274 ! upper - cfc11, cfc12 1275 ! Compute the optical depth by interpolating in ln(pressure) and 1276 ! temperature. The water vapor self-continuum and foreign continuum 1277 ! is interpolated (in temperature) separately. 1278 ! Lower atmosphere loop 1279 DO lay = 1, laytrop 1280 ! In atmospheres where the amount of CO2 is too great to be considered 1281 ! a minor species, adjust the column amount of CO2 by an empirical factor 1282 ! to obtain the proper contribution. 1283 chi_co2 = colco2(lay)/(coldry(lay)) 1284 ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) 1285 IF (ratco2 .gt. 3.0_wp) THEN 1286 adjfac = 2.0_wp+(ratco2-2.0_wp)**0.77_wp 1287 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp 1288 ELSE 1289 adjcolco2 = colco2(lay) 1290 END IF 1291 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1 1292 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1 1293 inds = indself(lay) 1294 indf = indfor(lay) 1295 indm = indminor(lay) 1296 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1297 selfref(inds,ig))) 1298 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1299 indf,ig))) 1300 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& 1301 ) 1302 taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 1303 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 1304 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & 1305 adjcolco2 * absco2 + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & 1306 cfc12(ig) 1307 fracs(lay) = fracrefa(ig) 1308 END DO 1309 ! Upper atmosphere loop 1310 ! Nothing important goes on above laytrop in this band. 1311 DO lay = laytrop+1, nlayers 1312 taug(lay) = 0.0_wp + wx(2,lay) * cfc11adj(ig) + wx(3,lay) * & 1313 cfc12(ig) 1314 fracs(lay) = fracrefa(ig) 1315 END DO 1316 END SUBROUTINE taumol06 1317 !---------------------------------------------------------------------------- 1318 1319 SUBROUTINE taumol07() 1320 !---------------------------------------------------------------------------- 1321 ! 1322 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) 1323 ! (high key - o3; high minor - co2) 1324 !---------------------------------------------------------------------------- 1325 ! ------- Modules ------- 1326 USE rrlw_kg07, ONLY: selfref 1327 USE rrlw_kg07, ONLY: forref 1328 USE rrlw_kg07, ONLY: ka_mco2 1329 USE rrlw_kg07, ONLY: absa 1330 USE rrlw_kg07, ONLY: fracrefa 1331 USE rrlw_kg07, ONLY: kb_mco2 1332 USE rrlw_kg07, ONLY: absb 1333 USE rrlw_kg07, ONLY: fracrefb 1334 ! ------- Declarations ------- 1335 ! Local 1336 INTEGER :: lay 1337 INTEGER :: ind0 1338 INTEGER :: ind1 1339 INTEGER :: inds 1340 INTEGER :: indf 1341 INTEGER :: indm 1342 INTEGER :: js 1343 INTEGER :: js1 1344 INTEGER :: jmco2 1345 INTEGER :: jpl 1346 REAL(KIND=wp) :: speccomb 1347 REAL(KIND=wp) :: specparm 1348 REAL(KIND=wp) :: specmult 1349 REAL(KIND=wp) :: fs 1350 REAL(KIND=wp) :: speccomb1 1351 REAL(KIND=wp) :: specparm1 1352 REAL(KIND=wp) :: specmult1 1353 REAL(KIND=wp) :: fs1 1354 REAL(KIND=wp) :: speccomb_mco2 1355 REAL(KIND=wp) :: specparm_mco2 1356 REAL(KIND=wp) :: specmult_mco2 1357 REAL(KIND=wp) :: fmco2 1358 REAL(KIND=wp) :: speccomb_planck 1359 REAL(KIND=wp) :: specparm_planck 1360 REAL(KIND=wp) :: specmult_planck 1361 REAL(KIND=wp) :: fpl 1362 REAL(KIND=wp) :: p 1363 REAL(KIND=wp) :: p4 1364 REAL(KIND=wp) :: fk0 1365 REAL(KIND=wp) :: fk1 1366 REAL(KIND=wp) :: fk2 1367 REAL(KIND=wp) :: fac000 1368 REAL(KIND=wp) :: fac100 1369 REAL(KIND=wp) :: fac200 1370 REAL(KIND=wp) :: fac010 1371 REAL(KIND=wp) :: fac110 1372 REAL(KIND=wp) :: fac210 1373 REAL(KIND=wp) :: fac001 1374 REAL(KIND=wp) :: fac101 1375 REAL(KIND=wp) :: fac201 1376 REAL(KIND=wp) :: fac011 1377 REAL(KIND=wp) :: fac111 1378 REAL(KIND=wp) :: fac211 1379 REAL(KIND=wp) :: tauself 1380 REAL(KIND=wp) :: taufor 1381 REAL(KIND=wp) :: co2m1 1382 REAL(KIND=wp) :: co2m2 1383 REAL(KIND=wp) :: absco2 1384 REAL(KIND=wp) :: chi_co2 1385 REAL(KIND=wp) :: ratco2 1386 REAL(KIND=wp) :: adjfac 1387 REAL(KIND=wp) :: adjcolco2 1388 REAL(KIND=wp) :: refrat_planck_a 1389 REAL(KIND=wp) :: refrat_m_a 1390 REAL(KIND=wp) :: tau_major 1391 REAL(KIND=wp) :: tau_major1 1392 REAL(KIND=wp), dimension(ngc(7)), parameter :: stratcorrect = (/ 1., 1., 1., 1., 1., .92, .88, 1.07, 1.1, .99, & 1393 .855, 1. /) 1394 ! Minor gas mapping level : 1395 ! lower - co2, p = 706.2620 mbar, t= 278.94 k 1396 ! upper - co2, p = 12.9350 mbar, t = 234.01 k 1397 ! Calculate reference ratio to be used in calculation of Planck 1398 ! fraction in lower atmosphere. 1399 ! P = 706.2620 mb 1400 refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) 1401 ! P = 706.2720 mb 1402 refrat_m_a = chi_mls(1,3)/chi_mls(3,3) 1403 ! Compute the optical depth by interpolating in ln(pressure), 1404 ! temperature, and appropriate species. Below laytrop, the water 1405 ! vapor self-continuum and foreign continuum is interpolated 1406 ! (in temperature) separately. 1407 ! Lower atmosphere loop 1408 DO lay = 1, laytrop 1409 speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay) 1410 specparm = colh2o(lay)/speccomb 1411 IF (specparm .ge. oneminus) specparm = oneminus 1412 specmult = 8._wp*(specparm) 1413 js = 1 + int(specmult) 1414 fs = mod(specmult,1.0_wp) 1415 speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay) 1416 specparm1 = colh2o(lay)/speccomb1 1417 IF (specparm1 .ge. oneminus) specparm1 = oneminus 1418 specmult1 = 8._wp*(specparm1) 1419 js1 = 1 + int(specmult1) 1420 fs1 = mod(specmult1,1.0_wp) 1421 speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay) 1422 specparm_mco2 = colh2o(lay)/speccomb_mco2 1423 IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus 1424 specmult_mco2 = 8._wp*specparm_mco2 1425 jmco2 = 1 + int(specmult_mco2) 1426 fmco2 = mod(specmult_mco2,1.0_wp) 1427 ! In atmospheres where the amount of CO2 is too great to be considered 1428 ! a minor species, adjust the column amount of CO2 by an empirical factor 1429 ! to obtain the proper contribution. 1430 chi_co2 = colco2(lay)/(coldry(lay)) 1431 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) 1432 IF (ratco2 .gt. 3.0_wp) THEN 1433 adjfac = 3.0_wp+(ratco2-3.0_wp)**0.79_wp 1434 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp 1435 ELSE 1436 adjcolco2 = colco2(lay) 1437 END IF 1438 speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay) 1439 specparm_planck = colh2o(lay)/speccomb_planck 1440 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 1441 specmult_planck = 8._wp*specparm_planck 1442 jpl = 1 + int(specmult_planck) 1443 fpl = mod(specmult_planck,1.0_wp) 1444 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js 1445 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1 1446 inds = indself(lay) 1447 indf = indfor(lay) 1448 indm = indminor(lay) 1449 IF (specparm .lt. 0.125_wp) THEN 1450 p = fs - 1 1451 p4 = p**4 1452 fk0 = p4 1453 fk1 = 1 - p - 2.0_wp*p4 1454 fk2 = p + p4 1455 fac000 = fk0*fac00(lay) 1456 fac100 = fk1*fac00(lay) 1457 fac200 = fk2*fac00(lay) 1458 fac010 = fk0*fac10(lay) 1459 fac110 = fk1*fac10(lay) 1460 fac210 = fk2*fac10(lay) 1461 ELSE IF (specparm .gt. 0.875_wp) THEN 1462 p = -fs 1463 p4 = p**4 1464 fk0 = p4 1465 fk1 = 1 - p - 2.0_wp*p4 1466 fk2 = p + p4 1467 fac000 = fk0*fac00(lay) 1468 fac100 = fk1*fac00(lay) 1469 fac200 = fk2*fac00(lay) 1470 fac010 = fk0*fac10(lay) 1471 fac110 = fk1*fac10(lay) 1472 fac210 = fk2*fac10(lay) 1473 ELSE 1474 fac000 = (1._wp - fs) * fac00(lay) 1475 fac010 = (1._wp - fs) * fac10(lay) 1476 fac100 = fs * fac00(lay) 1477 fac110 = fs * fac10(lay) 1478 END IF 1479 IF (specparm1 .lt. 0.125_wp) THEN 1480 p = fs1 - 1 1481 p4 = p**4 1482 fk0 = p4 1483 fk1 = 1 - p - 2.0_wp*p4 1484 fk2 = p + p4 1485 fac001 = fk0*fac01(lay) 1486 fac101 = fk1*fac01(lay) 1487 fac201 = fk2*fac01(lay) 1488 fac011 = fk0*fac11(lay) 1489 fac111 = fk1*fac11(lay) 1490 fac211 = fk2*fac11(lay) 1491 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1492 p = -fs1 1493 p4 = p**4 1494 fk0 = p4 1495 fk1 = 1 - p - 2.0_wp*p4 1496 fk2 = p + p4 1497 fac001 = fk0*fac01(lay) 1498 fac101 = fk1*fac01(lay) 1499 fac201 = fk2*fac01(lay) 1500 fac011 = fk0*fac11(lay) 1501 fac111 = fk1*fac11(lay) 1502 fac211 = fk2*fac11(lay) 1503 ELSE 1504 fac001 = (1._wp - fs1) * fac01(lay) 1505 fac011 = (1._wp - fs1) * fac11(lay) 1506 fac101 = fs1 * fac01(lay) 1507 fac111 = fs1 * fac11(lay) 1508 END IF 1509 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1510 selfref(inds,ig))) 1511 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1512 indf,ig))) 1513 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& 1514 indm,ig)) 1515 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& 1516 jmco2,indm+1,ig)) 1517 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) 1518 IF (specparm .lt. 0.125_wp) THEN 1519 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1520 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 1521 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 1522 fac210 * absa(ind0+11,ig)) 1523 ELSE IF (specparm .gt. 0.875_wp) THEN 1524 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 1525 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 1526 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 1527 fac010 * absa(ind0+10,ig)) 1528 ELSE 1529 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1530 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 1531 fac110 * absa(ind0+10,ig)) 1532 END IF 1533 IF (specparm1 .lt. 0.125_wp) THEN 1534 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1535 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 1536 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 1537 fac211 * absa(ind1+11,ig)) 1538 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1539 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 1540 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 1541 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 1542 fac011 * absa(ind1+10,ig)) 1543 ELSE 1544 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1545 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 1546 fac111 * absa(ind1+10,ig)) 1547 END IF 1548 taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcolco2*absco2 1549 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 1550 END DO 1551 ! Upper atmosphere loop 1552 DO lay = laytrop+1, nlayers 1553 ! In atmospheres where the amount of CO2 is too great to be considered 1554 ! a minor species, adjust the column amount of CO2 by an empirical factor 1555 ! to obtain the proper contribution. 1556 chi_co2 = colco2(lay)/(coldry(lay)) 1557 ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1) 1558 IF (ratco2 .gt. 3.0_wp) THEN 1559 adjfac = 2.0_wp+(ratco2-2.0_wp)**0.79_wp 1560 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp 1561 ELSE 1562 adjcolco2 = colco2(lay) 1563 END IF 1564 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1 1565 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1 1566 indm = indminor(lay) 1567 absco2 = kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)) 1568 taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & 1569 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 1570 fac11(lay) * absb(ind1+1,ig)) + adjcolco2 * absco2 1571 fracs(lay) = fracrefb(ig) 1572 ! Empirical modification to code to improve stratospheric cooling rates 1573 ! for o3. Revised to apply weighting for g-point reduction in this band. 1574 ! taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_wp 1575 ! taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_wp 1576 ! taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_wp 1577 ! taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_wp 1578 ! taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_wp 1579 ! taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_wp 1580 END DO 1581 taug(laytrop+1:nlayers) = taug(laytrop+1:nlayers) * stratcorrect(ig) 1582 END SUBROUTINE taumol07 1583 !---------------------------------------------------------------------------- 1584 1585 SUBROUTINE taumol08() 1586 !---------------------------------------------------------------------------- 1587 ! 1588 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) 1589 ! (high key - o3; high minor - co2, n2o) 1590 !---------------------------------------------------------------------------- 1591 ! ------- Modules ------- 1592 USE rrlw_kg08, ONLY: selfref 1593 USE rrlw_kg08, ONLY: forref 1594 USE rrlw_kg08, ONLY: ka_mco2 1595 USE rrlw_kg08, ONLY: ka_mo3 1596 USE rrlw_kg08, ONLY: ka_mn2o 1597 USE rrlw_kg08, ONLY: absa 1598 USE rrlw_kg08, ONLY: cfc22adj 1599 USE rrlw_kg08, ONLY: cfc12 1600 USE rrlw_kg08, ONLY: fracrefa 1601 USE rrlw_kg08, ONLY: kb_mco2 1602 USE rrlw_kg08, ONLY: kb_mn2o 1603 USE rrlw_kg08, ONLY: absb 1604 USE rrlw_kg08, ONLY: fracrefb 1605 ! ------- Declarations ------- 1606 ! Local 1607 INTEGER :: lay 1608 INTEGER :: ind0 1609 INTEGER :: ind1 1610 INTEGER :: inds 1611 INTEGER :: indf 1612 INTEGER :: indm 1613 REAL(KIND=wp) :: tauself 1614 REAL(KIND=wp) :: taufor 1615 REAL(KIND=wp) :: absco2 1616 REAL(KIND=wp) :: abso3 1617 REAL(KIND=wp) :: absn2o 1618 REAL(KIND=wp) :: chi_co2 1619 REAL(KIND=wp) :: ratco2 1620 REAL(KIND=wp) :: adjfac 1621 REAL(KIND=wp) :: adjcolco2 1622 ! Minor gas mapping level: 1623 ! lower - co2, p = 1053.63 mb, t = 294.2 k 1624 ! lower - o3, p = 317.348 mb, t = 240.77 k 1625 ! lower - n2o, p = 706.2720 mb, t= 278.94 k 1626 ! lower - cfc12,cfc11 1627 ! upper - co2, p = 35.1632 mb, t = 223.28 k 1628 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k 1629 ! Compute the optical depth by interpolating in ln(pressure) and 1630 ! temperature, and appropriate species. Below laytrop, the water vapor 1631 ! self-continuum and foreign continuum is interpolated (in temperature) 1632 ! separately. 1633 ! Lower atmosphere loop 1634 DO lay = 1, laytrop 1635 ! In atmospheres where the amount of CO2 is too great to be considered 1636 ! a minor species, adjust the column amount of CO2 by an empirical factor 1637 ! to obtain the proper contribution. 1638 chi_co2 = colco2(lay)/(coldry(lay)) 1639 ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) 1640 IF (ratco2 .gt. 3.0_wp) THEN 1641 adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp 1642 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_wp 1643 ELSE 1644 adjcolco2 = colco2(lay) 1645 END IF 1646 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1 1647 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1 1648 inds = indself(lay) 1649 indf = indfor(lay) 1650 indm = indminor(lay) 1651 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1652 selfref(inds,ig))) 1653 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1654 indf,ig))) 1655 absco2 = (ka_mco2(indm,ig) + minorfrac(lay) * (ka_mco2(indm+1,ig) - ka_mco2(indm,ig))& 1656 ) 1657 abso3 = (ka_mo3(indm,ig) + minorfrac(lay) * (ka_mo3(indm+1,ig) - ka_mo3(indm,ig))) 1658 absn2o = (ka_mn2o(indm,ig) + minorfrac(lay) * (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig))& 1659 ) 1660 taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 1661 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 1662 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + & 1663 adjcolco2*absco2 + colo3(lay) * abso3 + coln2o(lay) * & 1664 absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(ig) 1665 fracs(lay) = fracrefa(ig) 1666 END DO 1667 ! Upper atmosphere loop 1668 DO lay = laytrop+1, nlayers 1669 ! In atmospheres where the amount of CO2 is too great to be considered 1670 ! a minor species, adjust the column amount of CO2 by an empirical factor 1671 ! to obtain the proper contribution. 1672 chi_co2 = colco2(lay)/coldry(lay) 1673 ratco2 = 1.e20_wp*chi_co2/chi_mls(2,jp(lay)+1) 1674 IF (ratco2 .gt. 3.0_wp) THEN 1675 adjfac = 2.0_wp+(ratco2-2.0_wp)**0.65_wp 1676 adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_wp 1677 ELSE 1678 adjcolco2 = colco2(lay) 1679 END IF 1680 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1 1681 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1 1682 indm = indminor(lay) 1683 absco2 = (kb_mco2(indm,ig) + minorfrac(lay) * (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))& 1684 ) 1685 absn2o = (kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))& 1686 ) 1687 taug(lay) = colo3(lay) * (fac00(lay) * absb(ind0,ig) + & 1688 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 1689 fac11(lay) * absb(ind1+1,ig)) + adjcolco2*absco2 + coln2o(& 1690 lay)*absn2o + wx(3,lay) * cfc12(ig) + wx(4,lay) * cfc22adj(& 1691 ig) 1692 fracs(lay) = fracrefb(ig) 1693 END DO 1694 END SUBROUTINE taumol08 1695 !---------------------------------------------------------------------------- 1696 1697 SUBROUTINE taumol09() 1698 !---------------------------------------------------------------------------- 1699 ! 1700 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) 1701 ! (high key - ch4; high minor - n2o) 1702 !---------------------------------------------------------------------------- 1703 ! ------- Modules ------- 1704 USE rrlw_kg09, ONLY: selfref 1705 USE rrlw_kg09, ONLY: forref 1706 USE rrlw_kg09, ONLY: ka_mn2o 1707 USE rrlw_kg09, ONLY: absa 1708 USE rrlw_kg09, ONLY: fracrefa 1709 USE rrlw_kg09, ONLY: kb_mn2o 1710 USE rrlw_kg09, ONLY: absb 1711 USE rrlw_kg09, ONLY: fracrefb 1712 ! ------- Declarations ------- 1713 ! Local 1714 INTEGER :: lay 1715 INTEGER :: ind0 1716 INTEGER :: ind1 1717 INTEGER :: inds 1718 INTEGER :: indf 1719 INTEGER :: indm 1720 INTEGER :: js 1721 INTEGER :: js1 1722 INTEGER :: jmn2o 1723 INTEGER :: jpl 1724 REAL(KIND=wp) :: speccomb 1725 REAL(KIND=wp) :: specparm 1726 REAL(KIND=wp) :: specmult 1727 REAL(KIND=wp) :: fs 1728 REAL(KIND=wp) :: speccomb1 1729 REAL(KIND=wp) :: specparm1 1730 REAL(KIND=wp) :: specmult1 1731 REAL(KIND=wp) :: fs1 1732 REAL(KIND=wp) :: speccomb_mn2o 1733 REAL(KIND=wp) :: specparm_mn2o 1734 REAL(KIND=wp) :: specmult_mn2o 1735 REAL(KIND=wp) :: fmn2o 1736 REAL(KIND=wp) :: speccomb_planck 1737 REAL(KIND=wp) :: specparm_planck 1738 REAL(KIND=wp) :: specmult_planck 1739 REAL(KIND=wp) :: fpl 1740 REAL(KIND=wp) :: p 1741 REAL(KIND=wp) :: p4 1742 REAL(KIND=wp) :: fk0 1743 REAL(KIND=wp) :: fk1 1744 REAL(KIND=wp) :: fk2 1745 REAL(KIND=wp) :: fac000 1746 REAL(KIND=wp) :: fac100 1747 REAL(KIND=wp) :: fac200 1748 REAL(KIND=wp) :: fac010 1749 REAL(KIND=wp) :: fac110 1750 REAL(KIND=wp) :: fac210 1751 REAL(KIND=wp) :: fac001 1752 REAL(KIND=wp) :: fac101 1753 REAL(KIND=wp) :: fac201 1754 REAL(KIND=wp) :: fac011 1755 REAL(KIND=wp) :: fac111 1756 REAL(KIND=wp) :: fac211 1757 REAL(KIND=wp) :: tauself 1758 REAL(KIND=wp) :: taufor 1759 REAL(KIND=wp) :: n2om1 1760 REAL(KIND=wp) :: n2om2 1761 REAL(KIND=wp) :: absn2o 1762 REAL(KIND=wp) :: chi_n2o 1763 REAL(KIND=wp) :: ratn2o 1764 REAL(KIND=wp) :: adjfac 1765 REAL(KIND=wp) :: adjcoln2o 1766 REAL(KIND=wp) :: refrat_planck_a 1767 REAL(KIND=wp) :: refrat_m_a 1768 REAL(KIND=wp) :: tau_major 1769 REAL(KIND=wp) :: tau_major1 1770 ! Minor gas mapping level : 1771 ! lower - n2o, p = 706.272 mbar, t = 278.94 k 1772 ! upper - n2o, p = 95.58 mbar, t = 215.7 k 1773 ! Calculate reference ratio to be used in calculation of Planck 1774 ! fraction in lower/upper atmosphere. 1775 ! P = 212 mb 1776 refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) 1777 ! P = 706.272 mb 1778 refrat_m_a = chi_mls(1,3)/chi_mls(6,3) 1779 ! Compute the optical depth by interpolating in ln(pressure), 1780 ! temperature, and appropriate species. Below laytrop, the water 1781 ! vapor self-continuum and foreign continuum is interpolated 1782 ! (in temperature) separately. 1783 ! Lower atmosphere loop 1784 DO lay = 1, laytrop 1785 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) 1786 specparm = colh2o(lay)/speccomb 1787 IF (specparm .ge. oneminus) specparm = oneminus 1788 specmult = 8._wp*(specparm) 1789 js = 1 + int(specmult) 1790 fs = mod(specmult,1.0_wp) 1791 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) 1792 specparm1 = colh2o(lay)/speccomb1 1793 IF (specparm1 .ge. oneminus) specparm1 = oneminus 1794 specmult1 = 8._wp*(specparm1) 1795 js1 = 1 + int(specmult1) 1796 fs1 = mod(specmult1,1.0_wp) 1797 speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay) 1798 specparm_mn2o = colh2o(lay)/speccomb_mn2o 1799 IF (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus 1800 specmult_mn2o = 8._wp*specparm_mn2o 1801 jmn2o = 1 + int(specmult_mn2o) 1802 fmn2o = mod(specmult_mn2o,1.0_wp) 1803 ! In atmospheres where the amount of N2O is too great to be considered 1804 ! a minor species, adjust the column amount of N2O by an empirical factor 1805 ! to obtain the proper contribution. 1806 chi_n2o = coln2o(lay)/(coldry(lay)) 1807 ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) 1808 IF (ratn2o .gt. 1.5_wp) THEN 1809 adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp 1810 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp 1811 ELSE 1812 adjcoln2o = coln2o(lay) 1813 END IF 1814 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) 1815 specparm_planck = colh2o(lay)/speccomb_planck 1816 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 1817 specmult_planck = 8._wp*specparm_planck 1818 jpl = 1 + int(specmult_planck) 1819 fpl = mod(specmult_planck,1.0_wp) 1820 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js 1821 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1 1822 inds = indself(lay) 1823 indf = indfor(lay) 1824 indm = indminor(lay) 1825 IF (specparm .lt. 0.125_wp) THEN 1826 p = fs - 1 1827 p4 = p**4 1828 fk0 = p4 1829 fk1 = 1 - p - 2.0_wp*p4 1830 fk2 = p + p4 1831 fac000 = fk0*fac00(lay) 1832 fac100 = fk1*fac00(lay) 1833 fac200 = fk2*fac00(lay) 1834 fac010 = fk0*fac10(lay) 1835 fac110 = fk1*fac10(lay) 1836 fac210 = fk2*fac10(lay) 1837 ELSE IF (specparm .gt. 0.875_wp) THEN 1838 p = -fs 1839 p4 = p**4 1840 fk0 = p4 1841 fk1 = 1 - p - 2.0_wp*p4 1842 fk2 = p + p4 1843 fac000 = fk0*fac00(lay) 1844 fac100 = fk1*fac00(lay) 1845 fac200 = fk2*fac00(lay) 1846 fac010 = fk0*fac10(lay) 1847 fac110 = fk1*fac10(lay) 1848 fac210 = fk2*fac10(lay) 1849 ELSE 1850 fac000 = (1._wp - fs) * fac00(lay) 1851 fac010 = (1._wp - fs) * fac10(lay) 1852 fac100 = fs * fac00(lay) 1853 fac110 = fs * fac10(lay) 1854 END IF 1855 IF (specparm1 .lt. 0.125_wp) THEN 1856 p = fs1 - 1 1857 p4 = p**4 1858 fk0 = p4 1859 fk1 = 1 - p - 2.0_wp*p4 1860 fk2 = p + p4 1861 fac001 = fk0*fac01(lay) 1862 fac101 = fk1*fac01(lay) 1863 fac201 = fk2*fac01(lay) 1864 fac011 = fk0*fac11(lay) 1865 fac111 = fk1*fac11(lay) 1866 fac211 = fk2*fac11(lay) 1867 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1868 p = -fs1 1869 p4 = p**4 1870 fk0 = p4 1871 fk1 = 1 - p - 2.0_wp*p4 1872 fk2 = p + p4 1873 fac001 = fk0*fac01(lay) 1874 fac101 = fk1*fac01(lay) 1875 fac201 = fk2*fac01(lay) 1876 fac011 = fk0*fac11(lay) 1877 fac111 = fk1*fac11(lay) 1878 fac211 = fk2*fac11(lay) 1879 ELSE 1880 fac001 = (1._wp - fs1) * fac01(lay) 1881 fac011 = (1._wp - fs1) * fac11(lay) 1882 fac101 = fs1 * fac01(lay) 1883 fac111 = fs1 * fac11(lay) 1884 END IF 1885 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1886 selfref(inds,ig))) 1887 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1888 indf,ig))) 1889 n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,& 1890 indm,ig)) 1891 n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(& 1892 jmn2o,indm+1,ig)) 1893 absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1) 1894 IF (specparm .lt. 0.125_wp) THEN 1895 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1896 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 1897 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 1898 fac210 * absa(ind0+11,ig)) 1899 ELSE IF (specparm .gt. 0.875_wp) THEN 1900 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 1901 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 1902 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 1903 fac010 * absa(ind0+10,ig)) 1904 ELSE 1905 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 1906 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 1907 fac110 * absa(ind0+10,ig)) 1908 END IF 1909 IF (specparm1 .lt. 0.125_wp) THEN 1910 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1911 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 1912 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 1913 fac211 * absa(ind1+11,ig)) 1914 ELSE IF (specparm1 .gt. 0.875_wp) THEN 1915 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 1916 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 1917 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 1918 fac011 * absa(ind1+10,ig)) 1919 ELSE 1920 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 1921 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 1922 fac111 * absa(ind1+10,ig)) 1923 END IF 1924 taug(lay) = tau_major + tau_major1 + tauself + taufor + adjcoln2o*absn2o 1925 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 1926 END DO 1927 ! Upper atmosphere loop 1928 DO lay = laytrop+1, nlayers 1929 ! In atmospheres where the amount of N2O is too great to be considered 1930 ! a minor species, adjust the column amount of N2O by an empirical factor 1931 ! to obtain the proper contribution. 1932 chi_n2o = coln2o(lay)/(coldry(lay)) 1933 ratn2o = 1.e20_wp*chi_n2o/chi_mls(4,jp(lay)+1) 1934 IF (ratn2o .gt. 1.5_wp) THEN 1935 adjfac = 0.5_wp+(ratn2o-0.5_wp)**0.65_wp 1936 adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_wp 1937 ELSE 1938 adjcoln2o = coln2o(lay) 1939 END IF 1940 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1 1941 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1 1942 indm = indminor(lay) 1943 absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)) 1944 taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & 1945 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 1946 fac11(lay) * absb(ind1+1,ig)) + adjcoln2o*absn2o 1947 fracs(lay) = fracrefb(ig) 1948 END DO 1949 END SUBROUTINE taumol09 1950 !---------------------------------------------------------------------------- 1951 1952 SUBROUTINE taumol10() 1953 !---------------------------------------------------------------------------- 1954 ! 1955 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) 1956 !---------------------------------------------------------------------------- 1957 ! ------- Modules ------- 1958 USE rrlw_kg10, ONLY: selfref 1959 USE rrlw_kg10, ONLY: forref 1960 USE rrlw_kg10, ONLY: absa 1961 USE rrlw_kg10, ONLY: fracrefa 1962 USE rrlw_kg10, ONLY: absb 1963 USE rrlw_kg10, ONLY: fracrefb 1964 ! ------- Declarations ------- 1965 ! Local 1966 INTEGER :: lay 1967 INTEGER :: ind0 1968 INTEGER :: ind1 1969 INTEGER :: inds 1970 INTEGER :: indf 1971 REAL(KIND=wp) :: tauself 1972 REAL(KIND=wp) :: taufor 1973 ! Compute the optical depth by interpolating in ln(pressure) and 1974 ! temperature. Below laytrop, the water vapor self-continuum and 1975 ! foreign continuum is interpolated (in temperature) separately. 1976 ! Lower atmosphere loop 1977 DO lay = 1, laytrop 1978 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1 1979 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1 1980 inds = indself(lay) 1981 indf = indfor(lay) 1982 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 1983 selfref(inds,ig))) 1984 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1985 indf,ig))) 1986 taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 1987 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 1988 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor 1989 fracs(lay) = fracrefa(ig) 1990 END DO 1991 ! Upper atmosphere loop 1992 DO lay = laytrop+1, nlayers 1993 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(10) + 1 1994 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(10) + 1 1995 indf = indfor(lay) 1996 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 1997 indf,ig))) 1998 taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & 1999 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 2000 fac11(lay) * absb(ind1+1,ig)) + taufor 2001 fracs(lay) = fracrefb(ig) 2002 END DO 2003 END SUBROUTINE taumol10 2004 !---------------------------------------------------------------------------- 2005 2006 SUBROUTINE taumol11() 2007 !---------------------------------------------------------------------------- 2008 ! 2009 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) 2010 ! (high key - h2o; high minor - o2) 2011 !---------------------------------------------------------------------------- 2012 ! ------- Modules ------- 2013 USE rrlw_kg11, ONLY: selfref 2014 USE rrlw_kg11, ONLY: forref 2015 USE rrlw_kg11, ONLY: ka_mo2 2016 USE rrlw_kg11, ONLY: absa 2017 USE rrlw_kg11, ONLY: fracrefa 2018 USE rrlw_kg11, ONLY: kb_mo2 2019 USE rrlw_kg11, ONLY: absb 2020 USE rrlw_kg11, ONLY: fracrefb 2021 ! ------- Declarations ------- 2022 ! Local 2023 INTEGER :: lay 2024 INTEGER :: ind0 2025 INTEGER :: ind1 2026 INTEGER :: inds 2027 INTEGER :: indf 2028 INTEGER :: indm 2029 REAL(KIND=wp) :: scaleo2 2030 REAL(KIND=wp) :: tauself 2031 REAL(KIND=wp) :: taufor 2032 REAL(KIND=wp) :: tauo2 2033 ! Minor gas mapping level : 2034 ! lower - o2, p = 706.2720 mbar, t = 278.94 k 2035 ! upper - o2, p = 4.758820 mbarm t = 250.85 k 2036 ! Compute the optical depth by interpolating in ln(pressure) and 2037 ! temperature. Below laytrop, the water vapor self-continuum and 2038 ! foreign continuum is interpolated (in temperature) separately. 2039 ! Lower atmosphere loop 2040 DO lay = 1, laytrop 2041 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(11) + 1 2042 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(11) + 1 2043 inds = indself(lay) 2044 indf = indfor(lay) 2045 indm = indminor(lay) 2046 scaleo2 = colo2(lay)*scaleminor(lay) 2047 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2048 selfref(inds,ig))) 2049 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2050 indf,ig))) 2051 tauo2 = scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * (ka_mo2(indm+1,ig) - ka_mo2(& 2052 indm,ig))) 2053 taug(lay) = colh2o(lay) * (fac00(lay) * absa(ind0,ig) + & 2054 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 2055 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor + tauo2 2056 fracs(lay) = fracrefa(ig) 2057 END DO 2058 ! Upper atmosphere loop 2059 DO lay = laytrop+1, nlayers 2060 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(11) + 1 2061 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(11) + 1 2062 indf = indfor(lay) 2063 indm = indminor(lay) 2064 scaleo2 = colo2(lay)*scaleminor(lay) 2065 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2066 indf,ig))) 2067 tauo2 = scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * (kb_mo2(indm+1,ig) - kb_mo2(& 2068 indm,ig))) 2069 taug(lay) = colh2o(lay) * (fac00(lay) * absb(ind0,ig) + & 2070 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 2071 fac11(lay) * absb(ind1+1,ig)) + taufor + tauo2 2072 fracs(lay) = fracrefb(ig) 2073 END DO 2074 END SUBROUTINE taumol11 2075 !---------------------------------------------------------------------------- 2076 2077 SUBROUTINE taumol12() 2078 !---------------------------------------------------------------------------- 2079 ! 2080 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) 2081 !---------------------------------------------------------------------------- 2082 ! ------- Modules ------- 2083 USE rrlw_kg12, ONLY: selfref 2084 USE rrlw_kg12, ONLY: forref 2085 USE rrlw_kg12, ONLY: absa 2086 USE rrlw_kg12, ONLY: fracrefa 2087 ! ------- Declarations ------- 2088 ! Local 2089 INTEGER :: lay 2090 INTEGER :: ind0 2091 INTEGER :: ind1 2092 INTEGER :: inds 2093 INTEGER :: indf 2094 INTEGER :: js 2095 INTEGER :: js1 2096 INTEGER :: jpl 2097 REAL(KIND=wp) :: speccomb 2098 REAL(KIND=wp) :: specparm 2099 REAL(KIND=wp) :: specmult 2100 REAL(KIND=wp) :: fs 2101 REAL(KIND=wp) :: speccomb1 2102 REAL(KIND=wp) :: specparm1 2103 REAL(KIND=wp) :: specmult1 2104 REAL(KIND=wp) :: fs1 2105 REAL(KIND=wp) :: speccomb_planck 2106 REAL(KIND=wp) :: specparm_planck 2107 REAL(KIND=wp) :: specmult_planck 2108 REAL(KIND=wp) :: fpl 2109 REAL(KIND=wp) :: p 2110 REAL(KIND=wp) :: p4 2111 REAL(KIND=wp) :: fk0 2112 REAL(KIND=wp) :: fk1 2113 REAL(KIND=wp) :: fk2 2114 REAL(KIND=wp) :: fac000 2115 REAL(KIND=wp) :: fac100 2116 REAL(KIND=wp) :: fac200 2117 REAL(KIND=wp) :: fac010 2118 REAL(KIND=wp) :: fac110 2119 REAL(KIND=wp) :: fac210 2120 REAL(KIND=wp) :: fac001 2121 REAL(KIND=wp) :: fac101 2122 REAL(KIND=wp) :: fac201 2123 REAL(KIND=wp) :: fac011 2124 REAL(KIND=wp) :: fac111 2125 REAL(KIND=wp) :: fac211 2126 REAL(KIND=wp) :: tauself 2127 REAL(KIND=wp) :: taufor 2128 REAL(KIND=wp) :: refrat_planck_a 2129 REAL(KIND=wp) :: tau_major 2130 REAL(KIND=wp) :: tau_major1 2131 ! Calculate reference ratio to be used in calculation of Planck 2132 ! fraction in lower/upper atmosphere. 2133 ! P = 174.164 mb 2134 refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) 2135 ! Compute the optical depth by interpolating in ln(pressure), 2136 ! temperature, and appropriate species. Below laytrop, the water 2137 ! vapor self-continuum adn foreign continuum is interpolated 2138 ! (in temperature) separately. 2139 ! Lower atmosphere loop 2140 DO lay = 1, laytrop 2141 speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay) 2142 specparm = colh2o(lay)/speccomb 2143 IF (specparm .ge. oneminus) specparm = oneminus 2144 specmult = 8._wp*(specparm) 2145 js = 1 + int(specmult) 2146 fs = mod(specmult,1.0_wp) 2147 speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay) 2148 specparm1 = colh2o(lay)/speccomb1 2149 IF (specparm1 .ge. oneminus) specparm1 = oneminus 2150 specmult1 = 8._wp*(specparm1) 2151 js1 = 1 + int(specmult1) 2152 fs1 = mod(specmult1,1.0_wp) 2153 speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay) 2154 specparm_planck = colh2o(lay)/speccomb_planck 2155 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 2156 specmult_planck = 8._wp*specparm_planck 2157 jpl = 1 + int(specmult_planck) 2158 fpl = mod(specmult_planck,1.0_wp) 2159 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js 2160 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1 2161 inds = indself(lay) 2162 indf = indfor(lay) 2163 IF (specparm .lt. 0.125_wp) THEN 2164 p = fs - 1 2165 p4 = p**4 2166 fk0 = p4 2167 fk1 = 1 - p - 2.0_wp*p4 2168 fk2 = p + p4 2169 fac000 = fk0*fac00(lay) 2170 fac100 = fk1*fac00(lay) 2171 fac200 = fk2*fac00(lay) 2172 fac010 = fk0*fac10(lay) 2173 fac110 = fk1*fac10(lay) 2174 fac210 = fk2*fac10(lay) 2175 ELSE IF (specparm .gt. 0.875_wp) THEN 2176 p = -fs 2177 p4 = p**4 2178 fk0 = p4 2179 fk1 = 1 - p - 2.0_wp*p4 2180 fk2 = p + p4 2181 fac000 = fk0*fac00(lay) 2182 fac100 = fk1*fac00(lay) 2183 fac200 = fk2*fac00(lay) 2184 fac010 = fk0*fac10(lay) 2185 fac110 = fk1*fac10(lay) 2186 fac210 = fk2*fac10(lay) 2187 ELSE 2188 fac000 = (1._wp - fs) * fac00(lay) 2189 fac010 = (1._wp - fs) * fac10(lay) 2190 fac100 = fs * fac00(lay) 2191 fac110 = fs * fac10(lay) 2192 END IF 2193 IF (specparm1 .lt. 0.125_wp) THEN 2194 p = fs1 - 1 2195 p4 = p**4 2196 fk0 = p4 2197 fk1 = 1 - p - 2.0_wp*p4 2198 fk2 = p + p4 2199 fac001 = fk0*fac01(lay) 2200 fac101 = fk1*fac01(lay) 2201 fac201 = fk2*fac01(lay) 2202 fac011 = fk0*fac11(lay) 2203 fac111 = fk1*fac11(lay) 2204 fac211 = fk2*fac11(lay) 2205 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2206 p = -fs1 2207 p4 = p**4 2208 fk0 = p4 2209 fk1 = 1 - p - 2.0_wp*p4 2210 fk2 = p + p4 2211 fac001 = fk0*fac01(lay) 2212 fac101 = fk1*fac01(lay) 2213 fac201 = fk2*fac01(lay) 2214 fac011 = fk0*fac11(lay) 2215 fac111 = fk1*fac11(lay) 2216 fac211 = fk2*fac11(lay) 2217 ELSE 2218 fac001 = (1._wp - fs1) * fac01(lay) 2219 fac011 = (1._wp - fs1) * fac11(lay) 2220 fac101 = fs1 * fac01(lay) 2221 fac111 = fs1 * fac11(lay) 2222 END IF 2223 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2224 selfref(inds,ig))) 2225 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2226 indf,ig))) 2227 IF (specparm .lt. 0.125_wp) THEN 2228 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2229 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 2230 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 2231 fac210 * absa(ind0+11,ig)) 2232 ELSE IF (specparm .gt. 0.875_wp) THEN 2233 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 2234 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 2235 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 2236 fac010 * absa(ind0+10,ig)) 2237 ELSE 2238 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2239 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 2240 fac110 * absa(ind0+10,ig)) 2241 END IF 2242 IF (specparm1 .lt. 0.125_wp) THEN 2243 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2244 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 2245 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 2246 fac211 * absa(ind1+11,ig)) 2247 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2248 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 2249 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 2250 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 2251 fac011 * absa(ind1+10,ig)) 2252 ELSE 2253 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2254 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 2255 fac111 * absa(ind1+10,ig)) 2256 END IF 2257 taug(lay) = tau_major + tau_major1 + tauself + taufor 2258 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 2259 END DO 2260 ! Upper atmosphere loop 2261 DO lay = laytrop+1, nlayers 2262 taug(lay) = 0.0_wp 2263 fracs(lay) = 0.0_wp 2264 END DO 2265 END SUBROUTINE taumol12 2266 !---------------------------------------------------------------------------- 2267 2268 SUBROUTINE taumol13() 2269 !---------------------------------------------------------------------------- 2270 ! 2271 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) 2272 !---------------------------------------------------------------------------- 2273 ! ------- Modules ------- 2274 USE rrlw_kg13, ONLY: selfref 2275 USE rrlw_kg13, ONLY: forref 2276 USE rrlw_kg13, ONLY: ka_mco2 2277 USE rrlw_kg13, ONLY: ka_mco 2278 USE rrlw_kg13, ONLY: absa 2279 USE rrlw_kg13, ONLY: fracrefa 2280 USE rrlw_kg13, ONLY: kb_mo3 2281 USE rrlw_kg13, ONLY: fracrefb 2282 ! ------- Declarations ------- 2283 ! Local 2284 INTEGER :: lay 2285 INTEGER :: ind0 2286 INTEGER :: ind1 2287 INTEGER :: inds 2288 INTEGER :: indf 2289 INTEGER :: indm 2290 INTEGER :: js 2291 INTEGER :: js1 2292 INTEGER :: jmco2 2293 INTEGER :: jmco 2294 INTEGER :: jpl 2295 REAL(KIND=wp) :: speccomb 2296 REAL(KIND=wp) :: specparm 2297 REAL(KIND=wp) :: specmult 2298 REAL(KIND=wp) :: fs 2299 REAL(KIND=wp) :: speccomb1 2300 REAL(KIND=wp) :: specparm1 2301 REAL(KIND=wp) :: specmult1 2302 REAL(KIND=wp) :: fs1 2303 REAL(KIND=wp) :: speccomb_mco2 2304 REAL(KIND=wp) :: specparm_mco2 2305 REAL(KIND=wp) :: specmult_mco2 2306 REAL(KIND=wp) :: fmco2 2307 REAL(KIND=wp) :: speccomb_mco 2308 REAL(KIND=wp) :: specparm_mco 2309 REAL(KIND=wp) :: specmult_mco 2310 REAL(KIND=wp) :: fmco 2311 REAL(KIND=wp) :: speccomb_planck 2312 REAL(KIND=wp) :: specparm_planck 2313 REAL(KIND=wp) :: specmult_planck 2314 REAL(KIND=wp) :: fpl 2315 REAL(KIND=wp) :: p 2316 REAL(KIND=wp) :: p4 2317 REAL(KIND=wp) :: fk0 2318 REAL(KIND=wp) :: fk1 2319 REAL(KIND=wp) :: fk2 2320 REAL(KIND=wp) :: fac000 2321 REAL(KIND=wp) :: fac100 2322 REAL(KIND=wp) :: fac200 2323 REAL(KIND=wp) :: fac010 2324 REAL(KIND=wp) :: fac110 2325 REAL(KIND=wp) :: fac210 2326 REAL(KIND=wp) :: fac001 2327 REAL(KIND=wp) :: fac101 2328 REAL(KIND=wp) :: fac201 2329 REAL(KIND=wp) :: fac011 2330 REAL(KIND=wp) :: fac111 2331 REAL(KIND=wp) :: fac211 2332 REAL(KIND=wp) :: tauself 2333 REAL(KIND=wp) :: taufor 2334 REAL(KIND=wp) :: co2m1 2335 REAL(KIND=wp) :: co2m2 2336 REAL(KIND=wp) :: absco2 2337 REAL(KIND=wp) :: com1 2338 REAL(KIND=wp) :: com2 2339 REAL(KIND=wp) :: absco 2340 REAL(KIND=wp) :: abso3 2341 REAL(KIND=wp) :: chi_co2 2342 REAL(KIND=wp) :: ratco2 2343 REAL(KIND=wp) :: adjfac 2344 REAL(KIND=wp) :: adjcolco2 2345 REAL(KIND=wp) :: refrat_planck_a 2346 REAL(KIND=wp) :: refrat_m_a 2347 REAL(KIND=wp) :: refrat_m_a3 2348 REAL(KIND=wp) :: tau_major 2349 REAL(KIND=wp) :: tau_major1 2350 ! Minor gas mapping levels : 2351 ! lower - co2, p = 1053.63 mb, t = 294.2 k 2352 ! lower - co, p = 706 mb, t = 278.94 k 2353 ! upper - o3, p = 95.5835 mb, t = 215.7 k 2354 ! Calculate reference ratio to be used in calculation of Planck 2355 ! fraction in lower/upper atmosphere. 2356 ! P = 473.420 mb (Level 5) 2357 refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) 2358 ! P = 1053. (Level 1) 2359 refrat_m_a = chi_mls(1,1)/chi_mls(4,1) 2360 ! P = 706. (Level 3) 2361 refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) 2362 ! Compute the optical depth by interpolating in ln(pressure), 2363 ! temperature, and appropriate species. Below laytrop, the water 2364 ! vapor self-continuum and foreign continuum is interpolated 2365 ! (in temperature) separately. 2366 ! Lower atmosphere loop 2367 DO lay = 1, laytrop 2368 speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay) 2369 specparm = colh2o(lay)/speccomb 2370 IF (specparm .ge. oneminus) specparm = oneminus 2371 specmult = 8._wp*(specparm) 2372 js = 1 + int(specmult) 2373 fs = mod(specmult,1.0_wp) 2374 speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay) 2375 specparm1 = colh2o(lay)/speccomb1 2376 IF (specparm1 .ge. oneminus) specparm1 = oneminus 2377 specmult1 = 8._wp*(specparm1) 2378 js1 = 1 + int(specmult1) 2379 fs1 = mod(specmult1,1.0_wp) 2380 speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay) 2381 specparm_mco2 = colh2o(lay)/speccomb_mco2 2382 IF (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus 2383 specmult_mco2 = 8._wp*specparm_mco2 2384 jmco2 = 1 + int(specmult_mco2) 2385 fmco2 = mod(specmult_mco2,1.0_wp) 2386 ! In atmospheres where the amount of CO2 is too great to be considered 2387 ! a minor species, adjust the column amount of CO2 by an empirical factor 2388 ! to obtain the proper contribution. 2389 chi_co2 = colco2(lay)/(coldry(lay)) 2390 ratco2 = 1.e20_wp*chi_co2/3.55e-4_wp 2391 IF (ratco2 .gt. 3.0_wp) THEN 2392 adjfac = 2.0_wp+(ratco2-2.0_wp)**0.68_wp 2393 adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_wp 2394 ELSE 2395 adjcolco2 = colco2(lay) 2396 END IF 2397 speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay) 2398 specparm_mco = colh2o(lay)/speccomb_mco 2399 IF (specparm_mco .ge. oneminus) specparm_mco = oneminus 2400 specmult_mco = 8._wp*specparm_mco 2401 jmco = 1 + int(specmult_mco) 2402 fmco = mod(specmult_mco,1.0_wp) 2403 speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay) 2404 specparm_planck = colh2o(lay)/speccomb_planck 2405 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 2406 specmult_planck = 8._wp*specparm_planck 2407 jpl = 1 + int(specmult_planck) 2408 fpl = mod(specmult_planck,1.0_wp) 2409 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js 2410 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1 2411 inds = indself(lay) 2412 indf = indfor(lay) 2413 indm = indminor(lay) 2414 IF (specparm .lt. 0.125_wp) THEN 2415 p = fs - 1 2416 p4 = p**4 2417 fk0 = p4 2418 fk1 = 1 - p - 2.0_wp*p4 2419 fk2 = p + p4 2420 fac000 = fk0*fac00(lay) 2421 fac100 = fk1*fac00(lay) 2422 fac200 = fk2*fac00(lay) 2423 fac010 = fk0*fac10(lay) 2424 fac110 = fk1*fac10(lay) 2425 fac210 = fk2*fac10(lay) 2426 ELSE IF (specparm .gt. 0.875_wp) THEN 2427 p = -fs 2428 p4 = p**4 2429 fk0 = p4 2430 fk1 = 1 - p - 2.0_wp*p4 2431 fk2 = p + p4 2432 fac000 = fk0*fac00(lay) 2433 fac100 = fk1*fac00(lay) 2434 fac200 = fk2*fac00(lay) 2435 fac010 = fk0*fac10(lay) 2436 fac110 = fk1*fac10(lay) 2437 fac210 = fk2*fac10(lay) 2438 ELSE 2439 fac000 = (1._wp - fs) * fac00(lay) 2440 fac010 = (1._wp - fs) * fac10(lay) 2441 fac100 = fs * fac00(lay) 2442 fac110 = fs * fac10(lay) 2443 END IF 2444 IF (specparm1 .lt. 0.125_wp) THEN 2445 p = fs1 - 1 2446 p4 = p**4 2447 fk0 = p4 2448 fk1 = 1 - p - 2.0_wp*p4 2449 fk2 = p + p4 2450 fac001 = fk0*fac01(lay) 2451 fac101 = fk1*fac01(lay) 2452 fac201 = fk2*fac01(lay) 2453 fac011 = fk0*fac11(lay) 2454 fac111 = fk1*fac11(lay) 2455 fac211 = fk2*fac11(lay) 2456 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2457 p = -fs1 2458 p4 = p**4 2459 fk0 = p4 2460 fk1 = 1 - p - 2.0_wp*p4 2461 fk2 = p + p4 2462 fac001 = fk0*fac01(lay) 2463 fac101 = fk1*fac01(lay) 2464 fac201 = fk2*fac01(lay) 2465 fac011 = fk0*fac11(lay) 2466 fac111 = fk1*fac11(lay) 2467 fac211 = fk2*fac11(lay) 2468 ELSE 2469 fac001 = (1._wp - fs1) * fac01(lay) 2470 fac011 = (1._wp - fs1) * fac11(lay) 2471 fac101 = fs1 * fac01(lay) 2472 fac111 = fs1 * fac11(lay) 2473 END IF 2474 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2475 selfref(inds,ig))) 2476 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2477 indf,ig))) 2478 co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,& 2479 indm,ig)) 2480 co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(& 2481 jmco2,indm+1,ig)) 2482 absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1) 2483 com1 = ka_mco(jmco,indm,ig) + fmco * (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig)) 2484 com2 = ka_mco(jmco,indm+1,ig) + fmco * (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,& 2485 indm+1,ig)) 2486 absco = com1 + minorfrac(lay) * (com2 - com1) 2487 IF (specparm .lt. 0.125_wp) THEN 2488 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2489 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 2490 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 2491 fac210 * absa(ind0+11,ig)) 2492 ELSE IF (specparm .gt. 0.875_wp) THEN 2493 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 2494 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 2495 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 2496 fac010 * absa(ind0+10,ig)) 2497 ELSE 2498 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2499 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 2500 fac110 * absa(ind0+10,ig)) 2501 END IF 2502 IF (specparm1 .lt. 0.125_wp) THEN 2503 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2504 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 2505 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 2506 fac211 * absa(ind1+11,ig)) 2507 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2508 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 2509 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 2510 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 2511 fac011 * absa(ind1+10,ig)) 2512 ELSE 2513 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2514 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 2515 fac111 * absa(ind1+10,ig)) 2516 END IF 2517 taug(lay) = tau_major + tau_major1 + tauself + taufor + & 2518 adjcolco2*absco2 + colco(lay)*absco 2519 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 2520 END DO 2521 ! Upper atmosphere loop 2522 DO lay = laytrop+1, nlayers 2523 indm = indminor(lay) 2524 abso3 = kb_mo3(indm,ig) + minorfrac(lay) * (kb_mo3(indm+1,ig) - kb_mo3(indm,ig)) 2525 taug(lay) = colo3(lay)*abso3 2526 fracs(lay) = fracrefb(ig) 2527 END DO 2528 END SUBROUTINE taumol13 2529 !---------------------------------------------------------------------------- 2530 2531 SUBROUTINE taumol14() 2532 !---------------------------------------------------------------------------- 2533 ! 2534 ! band 14: 2250-2380 cm-1 (low - co2; high - co2) 2535 !---------------------------------------------------------------------------- 2536 ! ------- Modules ------- 2537 USE rrlw_kg14, ONLY: selfref 2538 USE rrlw_kg14, ONLY: forref 2539 USE rrlw_kg14, ONLY: absa 2540 USE rrlw_kg14, ONLY: fracrefa 2541 USE rrlw_kg14, ONLY: absb 2542 USE rrlw_kg14, ONLY: fracrefb 2543 ! ------- Declarations ------- 2544 ! Local 2545 INTEGER :: lay 2546 INTEGER :: ind0 2547 INTEGER :: ind1 2548 INTEGER :: inds 2549 INTEGER :: indf 2550 REAL(KIND=wp) :: tauself 2551 REAL(KIND=wp) :: taufor 2552 ! Compute the optical depth by interpolating in ln(pressure) and 2553 ! temperature. Below laytrop, the water vapor self-continuum 2554 ! and foreign continuum is interpolated (in temperature) separately. 2555 ! Lower atmosphere loop 2556 DO lay = 1, laytrop 2557 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(14) + 1 2558 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(14) + 1 2559 inds = indself(lay) 2560 indf = indfor(lay) 2561 tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2562 selfref(inds,ig))) 2563 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2564 indf,ig))) 2565 taug(lay) = colco2(lay) * (fac00(lay) * absa(ind0,ig) + & 2566 fac10(lay) * absa(ind0+1,ig) + fac01(lay) * absa(ind1,ig) + & 2567 fac11(lay) * absa(ind1+1,ig)) + tauself + taufor 2568 fracs(lay) = fracrefa(ig) 2569 END DO 2570 ! Upper atmosphere loop 2571 DO lay = laytrop+1, nlayers 2572 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(14) + 1 2573 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(14) + 1 2574 taug(lay) = colco2(lay) * (fac00(lay) * absb(ind0,ig) + & 2575 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 2576 fac11(lay) * absb(ind1+1,ig)) 2577 fracs(lay) = fracrefb(ig) 2578 END DO 2579 END SUBROUTINE taumol14 2580 !---------------------------------------------------------------------------- 2581 2582 SUBROUTINE taumol15() 2583 !---------------------------------------------------------------------------- 2584 ! 2585 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) 2586 ! (high - nothing) 2587 !---------------------------------------------------------------------------- 2588 ! ------- Modules ------- 2589 USE rrlw_kg15, ONLY: selfref 2590 USE rrlw_kg15, ONLY: forref 2591 USE rrlw_kg15, ONLY: ka_mn2 2592 USE rrlw_kg15, ONLY: absa 2593 USE rrlw_kg15, ONLY: fracrefa 2594 ! ------- Declarations ------- 2595 ! Local 2596 INTEGER :: lay 2597 INTEGER :: ind0 2598 INTEGER :: ind1 2599 INTEGER :: inds 2600 INTEGER :: indf 2601 INTEGER :: indm 2602 INTEGER :: js 2603 INTEGER :: js1 2604 INTEGER :: jmn2 2605 INTEGER :: jpl 2606 REAL(KIND=wp) :: speccomb 2607 REAL(KIND=wp) :: specparm 2608 REAL(KIND=wp) :: specmult 2609 REAL(KIND=wp) :: fs 2610 REAL(KIND=wp) :: speccomb1 2611 REAL(KIND=wp) :: specparm1 2612 REAL(KIND=wp) :: specmult1 2613 REAL(KIND=wp) :: fs1 2614 REAL(KIND=wp) :: speccomb_mn2 2615 REAL(KIND=wp) :: specparm_mn2 2616 REAL(KIND=wp) :: specmult_mn2 2617 REAL(KIND=wp) :: fmn2 2618 REAL(KIND=wp) :: speccomb_planck 2619 REAL(KIND=wp) :: specparm_planck 2620 REAL(KIND=wp) :: specmult_planck 2621 REAL(KIND=wp) :: fpl 2622 REAL(KIND=wp) :: p 2623 REAL(KIND=wp) :: p4 2624 REAL(KIND=wp) :: fk0 2625 REAL(KIND=wp) :: fk1 2626 REAL(KIND=wp) :: fk2 2627 REAL(KIND=wp) :: fac000 2628 REAL(KIND=wp) :: fac100 2629 REAL(KIND=wp) :: fac200 2630 REAL(KIND=wp) :: fac010 2631 REAL(KIND=wp) :: fac110 2632 REAL(KIND=wp) :: fac210 2633 REAL(KIND=wp) :: fac001 2634 REAL(KIND=wp) :: fac101 2635 REAL(KIND=wp) :: fac201 2636 REAL(KIND=wp) :: fac011 2637 REAL(KIND=wp) :: fac111 2638 REAL(KIND=wp) :: fac211 2639 REAL(KIND=wp) :: scalen2 2640 REAL(KIND=wp) :: tauself 2641 REAL(KIND=wp) :: taufor 2642 REAL(KIND=wp) :: n2m1 2643 REAL(KIND=wp) :: n2m2 2644 REAL(KIND=wp) :: taun2 2645 REAL(KIND=wp) :: refrat_planck_a 2646 REAL(KIND=wp) :: refrat_m_a 2647 REAL(KIND=wp) :: tau_major 2648 REAL(KIND=wp) :: tau_major1 2649 ! Minor gas mapping level : 2650 ! Lower - Nitrogen Continuum, P = 1053., T = 294. 2651 ! Calculate reference ratio to be used in calculation of Planck 2652 ! fraction in lower atmosphere. 2653 ! P = 1053. mb (Level 1) 2654 refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) 2655 ! P = 1053. 2656 refrat_m_a = chi_mls(4,1)/chi_mls(2,1) 2657 ! Compute the optical depth by interpolating in ln(pressure), 2658 ! temperature, and appropriate species. Below laytrop, the water 2659 ! vapor self-continuum and foreign continuum is interpolated 2660 ! (in temperature) separately. 2661 ! Lower atmosphere loop 2662 DO lay = 1, laytrop 2663 speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay) 2664 specparm = coln2o(lay)/speccomb 2665 IF (specparm .ge. oneminus) specparm = oneminus 2666 specmult = 8._wp*(specparm) 2667 js = 1 + int(specmult) 2668 fs = mod(specmult,1.0_wp) 2669 speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay) 2670 specparm1 = coln2o(lay)/speccomb1 2671 IF (specparm1 .ge. oneminus) specparm1 = oneminus 2672 specmult1 = 8._wp*(specparm1) 2673 js1 = 1 + int(specmult1) 2674 fs1 = mod(specmult1,1.0_wp) 2675 speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay) 2676 specparm_mn2 = coln2o(lay)/speccomb_mn2 2677 IF (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus 2678 specmult_mn2 = 8._wp*specparm_mn2 2679 jmn2 = 1 + int(specmult_mn2) 2680 fmn2 = mod(specmult_mn2,1.0_wp) 2681 speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay) 2682 specparm_planck = coln2o(lay)/speccomb_planck 2683 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 2684 specmult_planck = 8._wp*specparm_planck 2685 jpl = 1 + int(specmult_planck) 2686 fpl = mod(specmult_planck,1.0_wp) 2687 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js 2688 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1 2689 inds = indself(lay) 2690 indf = indfor(lay) 2691 indm = indminor(lay) 2692 scalen2 = colbrd(lay)*scaleminor(lay) 2693 IF (specparm .lt. 0.125_wp) THEN 2694 p = fs - 1 2695 p4 = p**4 2696 fk0 = p4 2697 fk1 = 1 - p - 2.0_wp*p4 2698 fk2 = p + p4 2699 fac000 = fk0*fac00(lay) 2700 fac100 = fk1*fac00(lay) 2701 fac200 = fk2*fac00(lay) 2702 fac010 = fk0*fac10(lay) 2703 fac110 = fk1*fac10(lay) 2704 fac210 = fk2*fac10(lay) 2705 ELSE IF (specparm .gt. 0.875_wp) THEN 2706 p = -fs 2707 p4 = p**4 2708 fk0 = p4 2709 fk1 = 1 - p - 2.0_wp*p4 2710 fk2 = p + p4 2711 fac000 = fk0*fac00(lay) 2712 fac100 = fk1*fac00(lay) 2713 fac200 = fk2*fac00(lay) 2714 fac010 = fk0*fac10(lay) 2715 fac110 = fk1*fac10(lay) 2716 fac210 = fk2*fac10(lay) 2717 ELSE 2718 fac000 = (1._wp - fs) * fac00(lay) 2719 fac010 = (1._wp - fs) * fac10(lay) 2720 fac100 = fs * fac00(lay) 2721 fac110 = fs * fac10(lay) 2722 END IF 2723 IF (specparm1 .lt. 0.125_wp) THEN 2724 p = fs1 - 1 2725 p4 = p**4 2726 fk0 = p4 2727 fk1 = 1 - p - 2.0_wp*p4 2728 fk2 = p + p4 2729 fac001 = fk0*fac01(lay) 2730 fac101 = fk1*fac01(lay) 2731 fac201 = fk2*fac01(lay) 2732 fac011 = fk0*fac11(lay) 2733 fac111 = fk1*fac11(lay) 2734 fac211 = fk2*fac11(lay) 2735 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2736 p = -fs1 2737 p4 = p**4 2738 fk0 = p4 2739 fk1 = 1 - p - 2.0_wp*p4 2740 fk2 = p + p4 2741 fac001 = fk0*fac01(lay) 2742 fac101 = fk1*fac01(lay) 2743 fac201 = fk2*fac01(lay) 2744 fac011 = fk0*fac11(lay) 2745 fac111 = fk1*fac11(lay) 2746 fac211 = fk2*fac11(lay) 2747 ELSE 2748 fac001 = (1._wp - fs1) * fac01(lay) 2749 fac011 = (1._wp - fs1) * fac11(lay) 2750 fac101 = fs1 * fac01(lay) 2751 fac111 = fs1 * fac11(lay) 2752 END IF 2753 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2754 selfref(inds,ig))) 2755 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2756 indf,ig))) 2757 n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig)) 2758 n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,& 2759 indm+1,ig)) 2760 taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1)) 2761 IF (specparm .lt. 0.125_wp) THEN 2762 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2763 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 2764 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 2765 fac210 * absa(ind0+11,ig)) 2766 ELSE IF (specparm .gt. 0.875_wp) THEN 2767 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 2768 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 2769 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 2770 fac010 * absa(ind0+10,ig)) 2771 ELSE 2772 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2773 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 2774 fac110 * absa(ind0+10,ig)) 2775 END IF 2776 IF (specparm1 .lt. 0.125_wp) THEN 2777 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2778 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 2779 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 2780 fac211 * absa(ind1+11,ig)) 2781 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2782 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 2783 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 2784 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 2785 fac011 * absa(ind1+10,ig)) 2786 ELSE 2787 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2788 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 2789 fac111 * absa(ind1+10,ig)) 2790 END IF 2791 taug(lay) = tau_major + tau_major1 + tauself + taufor + taun2 2792 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 2793 END DO 2794 ! Upper atmosphere loop 2795 DO lay = laytrop+1, nlayers 2796 taug(lay) = 0.0_wp 2797 fracs(lay) = 0.0_wp 2798 END DO 2799 END SUBROUTINE taumol15 2800 !---------------------------------------------------------------------------- 2801 2802 SUBROUTINE taumol16() 2803 !---------------------------------------------------------------------------- 2804 ! 2805 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) 2806 !---------------------------------------------------------------------------- 2807 ! ------- Modules ------- 2808 USE rrlw_kg16, ONLY: selfref 2809 USE rrlw_kg16, ONLY: forref 2810 USE rrlw_kg16, ONLY: absa 2811 USE rrlw_kg16, ONLY: fracrefa 2812 USE rrlw_kg16, ONLY: absb 2813 USE rrlw_kg16, ONLY: fracrefb 2814 ! ------- Declarations ------- 2815 ! Local 2816 INTEGER :: lay 2817 INTEGER :: ind0 2818 INTEGER :: ind1 2819 INTEGER :: inds 2820 INTEGER :: indf 2821 INTEGER :: js 2822 INTEGER :: js1 2823 INTEGER :: jpl 2824 REAL(KIND=wp) :: speccomb 2825 REAL(KIND=wp) :: specparm 2826 REAL(KIND=wp) :: specmult 2827 REAL(KIND=wp) :: fs 2828 REAL(KIND=wp) :: speccomb1 2829 REAL(KIND=wp) :: specparm1 2830 REAL(KIND=wp) :: specmult1 2831 REAL(KIND=wp) :: fs1 2832 REAL(KIND=wp) :: speccomb_planck 2833 REAL(KIND=wp) :: specparm_planck 2834 REAL(KIND=wp) :: specmult_planck 2835 REAL(KIND=wp) :: fpl 2836 REAL(KIND=wp) :: p 2837 REAL(KIND=wp) :: p4 2838 REAL(KIND=wp) :: fk0 2839 REAL(KIND=wp) :: fk1 2840 REAL(KIND=wp) :: fk2 2841 REAL(KIND=wp) :: fac000 2842 REAL(KIND=wp) :: fac100 2843 REAL(KIND=wp) :: fac200 2844 REAL(KIND=wp) :: fac010 2845 REAL(KIND=wp) :: fac110 2846 REAL(KIND=wp) :: fac210 2847 REAL(KIND=wp) :: fac001 2848 REAL(KIND=wp) :: fac101 2849 REAL(KIND=wp) :: fac201 2850 REAL(KIND=wp) :: fac011 2851 REAL(KIND=wp) :: fac111 2852 REAL(KIND=wp) :: fac211 2853 REAL(KIND=wp) :: tauself 2854 REAL(KIND=wp) :: taufor 2855 REAL(KIND=wp) :: refrat_planck_a 2856 REAL(KIND=wp) :: tau_major 2857 REAL(KIND=wp) :: tau_major1 2858 ! Calculate reference ratio to be used in calculation of Planck 2859 ! fraction in lower atmosphere. 2860 ! P = 387. mb (Level 6) 2861 refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) 2862 ! Compute the optical depth by interpolating in ln(pressure), 2863 ! temperature,and appropriate species. Below laytrop, the water 2864 ! vapor self-continuum and foreign continuum is interpolated 2865 ! (in temperature) separately. 2866 ! Lower atmosphere loop 2867 DO lay = 1, laytrop 2868 speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay) 2869 specparm = colh2o(lay)/speccomb 2870 IF (specparm .ge. oneminus) specparm = oneminus 2871 specmult = 8._wp*(specparm) 2872 js = 1 + int(specmult) 2873 fs = mod(specmult,1.0_wp) 2874 speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay) 2875 specparm1 = colh2o(lay)/speccomb1 2876 IF (specparm1 .ge. oneminus) specparm1 = oneminus 2877 specmult1 = 8._wp*(specparm1) 2878 js1 = 1 + int(specmult1) 2879 fs1 = mod(specmult1,1.0_wp) 2880 speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay) 2881 specparm_planck = colh2o(lay)/speccomb_planck 2882 IF (specparm_planck .ge. oneminus) specparm_planck = oneminus 2883 specmult_planck = 8._wp*specparm_planck 2884 jpl = 1 + int(specmult_planck) 2885 fpl = mod(specmult_planck,1.0_wp) 2886 ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js 2887 ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1 2888 inds = indself(lay) 2889 indf = indfor(lay) 2890 IF (specparm .lt. 0.125_wp) THEN 2891 p = fs - 1 2892 p4 = p**4 2893 fk0 = p4 2894 fk1 = 1 - p - 2.0_wp*p4 2895 fk2 = p + p4 2896 fac000 = fk0*fac00(lay) 2897 fac100 = fk1*fac00(lay) 2898 fac200 = fk2*fac00(lay) 2899 fac010 = fk0*fac10(lay) 2900 fac110 = fk1*fac10(lay) 2901 fac210 = fk2*fac10(lay) 2902 ELSE IF (specparm .gt. 0.875_wp) THEN 2903 p = -fs 2904 p4 = p**4 2905 fk0 = p4 2906 fk1 = 1 - p - 2.0_wp*p4 2907 fk2 = p + p4 2908 fac000 = fk0*fac00(lay) 2909 fac100 = fk1*fac00(lay) 2910 fac200 = fk2*fac00(lay) 2911 fac010 = fk0*fac10(lay) 2912 fac110 = fk1*fac10(lay) 2913 fac210 = fk2*fac10(lay) 2914 ELSE 2915 fac000 = (1._wp - fs) * fac00(lay) 2916 fac010 = (1._wp - fs) * fac10(lay) 2917 fac100 = fs * fac00(lay) 2918 fac110 = fs * fac10(lay) 2919 END IF 2920 IF (specparm1 .lt. 0.125_wp) THEN 2921 p = fs1 - 1 2922 p4 = p**4 2923 fk0 = p4 2924 fk1 = 1 - p - 2.0_wp*p4 2925 fk2 = p + p4 2926 fac001 = fk0*fac01(lay) 2927 fac101 = fk1*fac01(lay) 2928 fac201 = fk2*fac01(lay) 2929 fac011 = fk0*fac11(lay) 2930 fac111 = fk1*fac11(lay) 2931 fac211 = fk2*fac11(lay) 2932 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2933 p = -fs1 2934 p4 = p**4 2935 fk0 = p4 2936 fk1 = 1 - p - 2.0_wp*p4 2937 fk2 = p + p4 2938 fac001 = fk0*fac01(lay) 2939 fac101 = fk1*fac01(lay) 2940 fac201 = fk2*fac01(lay) 2941 fac011 = fk0*fac11(lay) 2942 fac111 = fk1*fac11(lay) 2943 fac211 = fk2*fac11(lay) 2944 ELSE 2945 fac001 = (1._wp - fs1) * fac01(lay) 2946 fac011 = (1._wp - fs1) * fac11(lay) 2947 fac101 = fs1 * fac01(lay) 2948 fac111 = fs1 * fac11(lay) 2949 END IF 2950 tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * (selfref(inds+1,ig) - & 2951 selfref(inds,ig))) 2952 taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * (forref(indf+1,ig) - forref(& 2953 indf,ig))) 2954 IF (specparm .lt. 0.125_wp) THEN 2955 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2956 fac100 * absa(ind0+1,ig) + fac200 * absa(ind0+2,ig) + & 2957 fac010 * absa(ind0+9,ig) + fac110 * absa(ind0+10,ig) + & 2958 fac210 * absa(ind0+11,ig)) 2959 ELSE IF (specparm .gt. 0.875_wp) THEN 2960 tau_major = speccomb * (fac200 * absa(ind0-1,ig) + & 2961 fac100 * absa(ind0,ig) + fac000 * absa(ind0+1,ig) + & 2962 fac210 * absa(ind0+8,ig) + fac110 * absa(ind0+9,ig) + & 2963 fac010 * absa(ind0+10,ig)) 2964 ELSE 2965 tau_major = speccomb * (fac000 * absa(ind0,ig) + & 2966 fac100 * absa(ind0+1,ig) + fac010 * absa(ind0+9,ig) + & 2967 fac110 * absa(ind0+10,ig)) 2968 END IF 2969 IF (specparm1 .lt. 0.125_wp) THEN 2970 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2971 fac101 * absa(ind1+1,ig) + fac201 * absa(ind1+2,ig) + & 2972 fac011 * absa(ind1+9,ig) + fac111 * absa(ind1+10,ig) + & 2973 fac211 * absa(ind1+11,ig)) 2974 ELSE IF (specparm1 .gt. 0.875_wp) THEN 2975 tau_major1 = speccomb1 * (fac201 * absa(ind1-1,ig) + & 2976 fac101 * absa(ind1,ig) + fac001 * absa(ind1+1,ig) + & 2977 fac211 * absa(ind1+8,ig) + fac111 * absa(ind1+9,ig) + & 2978 fac011 * absa(ind1+10,ig)) 2979 ELSE 2980 tau_major1 = speccomb1 * (fac001 * absa(ind1,ig) + & 2981 fac101 * absa(ind1+1,ig) + fac011 * absa(ind1+9,ig) + & 2982 fac111 * absa(ind1+10,ig)) 2983 END IF 2984 taug(lay) = tau_major + tau_major1 + tauself + taufor 2985 fracs(lay) = fracrefa(ig,jpl) + fpl * (fracrefa(ig,jpl+1)-fracrefa(ig,jpl)) 2986 END DO 2987 ! Upper atmosphere loop 2988 DO lay = laytrop+1, nlayers 2989 ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1 2990 ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1 2991 taug(lay) = colch4(lay) * (fac00(lay) * absb(ind0,ig) + & 2992 fac10(lay) * absb(ind0+1,ig) + fac01(lay) * absb(ind1,ig) + & 2993 fac11(lay) * absb(ind1+1,ig)) 2994 fracs(lay) = fracrefb(ig) 2995 END DO 2996 END SUBROUTINE taumol16 2997 END SUBROUTINE gas_optics_lw 2998 END MODULE mo_lrtm_gas_optics 2999