| 1 | SUBROUTINE RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,P_TAU,PAVEL,& |
|---|
| 2 | & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& |
|---|
| 3 | & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,P_MINORFRAC,K_INDMINOR,PSCALEMINORN2,PCOLBRD) |
|---|
| 4 | |
|---|
| 5 | !****************************************************************************** |
|---|
| 6 | ! * |
|---|
| 7 | ! Optical depths developed for the * |
|---|
| 8 | ! * |
|---|
| 9 | ! RAPID RADIATIVE TRANSFER MODEL (RRTM) * |
|---|
| 10 | ! * |
|---|
| 11 | ! ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * |
|---|
| 12 | ! 840 MEMORIAL DRIVE * |
|---|
| 13 | ! CAMBRIDGE, MA 02139 * |
|---|
| 14 | ! * |
|---|
| 15 | ! ELI J. MLAWER * |
|---|
| 16 | ! STEVEN J. TAUBMAN * |
|---|
| 17 | ! SHEPARD A. CLOUGH * |
|---|
| 18 | ! * |
|---|
| 19 | ! email: mlawer@aer.com * |
|---|
| 20 | ! * |
|---|
| 21 | ! The authors wish to acknowledge the contributions of the * |
|---|
| 22 | ! following people: Patrick D. Brown, Michael J. Iacono, * |
|---|
| 23 | ! Ronald E. Farren, Luke Chen, Robert Bergstrom. * |
|---|
| 24 | ! * |
|---|
| 25 | !****************************************************************************** |
|---|
| 26 | ! TAUMOL * |
|---|
| 27 | ! * |
|---|
| 28 | ! This file contains the subroutines TAUGBn (where n goes from * |
|---|
| 29 | ! 1 to 16). TAUGBn calculates the optical depths and Planck fractions * |
|---|
| 30 | ! per g-value and layer for band n. * |
|---|
| 31 | ! * |
|---|
| 32 | ! Output: optical depths (unitless) * |
|---|
| 33 | ! fractions needed to compute Planck functions at every layer * |
|---|
| 34 | ! and g-value * |
|---|
| 35 | ! * |
|---|
| 36 | ! COMMON /TAUGCOM/ TAUG(MXLAY,MG) * |
|---|
| 37 | ! COMMON /PLANKG/ FRACS(MXLAY,MG) * |
|---|
| 38 | ! * |
|---|
| 39 | ! Input * |
|---|
| 40 | ! * |
|---|
| 41 | ! COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * |
|---|
| 42 | ! COMMON /PRECISE/ ONEMINUS * |
|---|
| 43 | ! COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * |
|---|
| 44 | ! & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * |
|---|
| 45 | ! COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * |
|---|
| 46 | ! & COLH2O(MXLAY),COLCO2(MXLAY), * |
|---|
| 47 | ! & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * |
|---|
| 48 | ! & COLO2(MXLAY),CO2MULT(MXLAY) * |
|---|
| 49 | ! COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * |
|---|
| 50 | ! & FAC10(MXLAY),FAC11(MXLAY) * |
|---|
| 51 | ! COMMON /INTIND/ JP(MXLAY),JT(KIDIA:KFDIA,MXLAY),JT1(KIDIA:KFDIA,MXLAY) * |
|---|
| 52 | ! COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(KIDIA:KFDIA,MXLAY) * |
|---|
| 53 | ! * |
|---|
| 54 | ! Description: * |
|---|
| 55 | ! NG(IBAND) - number of g-values in band IBAND * |
|---|
| 56 | ! NSPA(IBAND) - for the lower atmosphere, the number of reference * |
|---|
| 57 | ! atmospheres that are stored for band IBAND per * |
|---|
| 58 | ! pressure level and temperature. Each of these * |
|---|
| 59 | ! atmospheres has different relative amounts of the * |
|---|
| 60 | ! key species for the band (i.e. different binary * |
|---|
| 61 | ! species parameters). * |
|---|
| 62 | ! NSPB(IBAND) - same for upper atmosphere * |
|---|
| 63 | ! ONEMINUS - since problems are caused in some cases by interpolation * |
|---|
| 64 | ! parameters equal to or greater than 1, for these cases * |
|---|
| 65 | ! these parameters are set to this value, slightly < 1. * |
|---|
| 66 | ! PAVEL - layer pressures (mb) * |
|---|
| 67 | ! TAVEL - layer temperatures (degrees K) * |
|---|
| 68 | ! PZ - level pressures (mb) * |
|---|
| 69 | ! TZ - level temperatures (degrees K) * |
|---|
| 70 | ! LAYTROP - layer at which switch is made from one combination of * |
|---|
| 71 | ! key species to another * |
|---|
| 72 | ! COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * |
|---|
| 73 | ! vapor,carbon dioxide, ozone, nitrous ozide, methane, * |
|---|
| 74 | ! respectively (molecules/cm**2) * |
|---|
| 75 | ! CO2MULT - for bands in which carbon dioxide is implemented as a * |
|---|
| 76 | ! trace species, this is the factor used to multiply the * |
|---|
| 77 | ! band's average CO2 absorption coefficient to get the added * |
|---|
| 78 | ! contribution to the optical depth relative to 355 ppm. * |
|---|
| 79 | ! FACij(JLAY) - for layer JLAY, these are factors that are needed to * |
|---|
| 80 | ! compute the interpolation factors that multiply the * |
|---|
| 81 | ! appropriate reference k-values. A value of 0 (1) for * |
|---|
| 82 | ! i,j indicates that the corresponding factor multiplies * |
|---|
| 83 | ! reference k-value for the lower (higher) of the two * |
|---|
| 84 | ! appropriate temperatures, and altitudes, respectively. * |
|---|
| 85 | ! JP - the index of the lower (in altitude) of the two appropriate * |
|---|
| 86 | ! reference pressure levels needed for interpolation * |
|---|
| 87 | ! JT, JT1 - the indices of the lower of the two appropriate reference * |
|---|
| 88 | ! temperatures needed for interpolation (for pressure * |
|---|
| 89 | ! levels JP and JP+1, respectively) * |
|---|
| 90 | ! SELFFAC - scale factor needed to water vapor self-continuum, equals * |
|---|
| 91 | ! (water vapor density)/(atmospheric density at 296K and * |
|---|
| 92 | ! 1013 mb) * |
|---|
| 93 | ! SELFFRAC - factor needed for temperature interpolation of reference * |
|---|
| 94 | ! water vapor self-continuum data * |
|---|
| 95 | ! INDSELF - index of the lower of the two appropriate reference * |
|---|
| 96 | ! temperatures needed for the self-continuum interpolation * |
|---|
| 97 | ! * |
|---|
| 98 | ! Data input * |
|---|
| 99 | ! COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * |
|---|
| 100 | ! (note: n is the band number) * |
|---|
| 101 | ! * |
|---|
| 102 | ! Description: * |
|---|
| 103 | ! KA - k-values for low reference atmospheres (no water vapor * |
|---|
| 104 | ! self-continuum) (units: cm**2/molecule) * |
|---|
| 105 | ! KB - k-values for high reference atmospheres (all sources) * |
|---|
| 106 | ! (units: cm**2/molecule) * |
|---|
| 107 | ! SELFREF - k-values for water vapor self-continuum for reference * |
|---|
| 108 | ! atmospheres (used below LAYTROP) * |
|---|
| 109 | ! (units: cm**2/molecule) * |
|---|
| 110 | ! * |
|---|
| 111 | ! DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * |
|---|
| 112 | ! EQUIVALENCE (KA,ABSA),(KB,ABSB) * |
|---|
| 113 | ! * |
|---|
| 114 | !****************************************************************************** |
|---|
| 115 | |
|---|
| 116 | ! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) |
|---|
| 117 | |
|---|
| 118 | ! AUTHOR. |
|---|
| 119 | ! ------- |
|---|
| 120 | ! JJMorcrette, ECMWF, from |
|---|
| 121 | ! Eli J. Mlawer, Atmospheric & Environmental Research. |
|---|
| 122 | ! (Revised by Michael J. Iacono, Atmospheric & Environmental Research.) |
|---|
| 123 | |
|---|
| 124 | ! MODIFICATIONS. |
|---|
| 125 | ! -------------- |
|---|
| 126 | ! D Salmond 2000-05-15 speed-up |
|---|
| 127 | ! JJMorcrette 2000-05-17 speed-up |
|---|
| 128 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning |
|---|
| 129 | ! NEC 25-Oct-2007 Optimisations |
|---|
| 130 | ! JJMorcrette 20110613 flexible number of g-points |
|---|
| 131 | ! ABozzo 200130517 updated to rrtmg_lw_v4.85: |
|---|
| 132 | !********* |
|---|
| 133 | ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) |
|---|
| 134 | ! (high key - h2o; high minor - n2) |
|---|
| 135 | ! |
|---|
| 136 | ! note: previous versions of rrtm band 1: |
|---|
| 137 | ! 10-250 cm-1 (low - h2o; high - h2o) |
|---|
| 138 | ! --------------------------------------------------------------------------- |
|---|
| 139 | |
|---|
| 140 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
|---|
| 141 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK, JPHOOK |
|---|
| 142 | |
|---|
| 143 | USE PARRRTM , ONLY : JPBAND |
|---|
| 144 | USE YOERRTM , ONLY : JPGPT ,NG1 |
|---|
| 145 | USE YOERRTWN , ONLY : NSPA ,NSPB |
|---|
| 146 | USE YOERRTA1 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,& |
|---|
| 147 | & FORREF ,SELFREF, KA_MN2, KB_MN2 |
|---|
| 148 | |
|---|
| 149 | IMPLICIT NONE |
|---|
| 150 | |
|---|
| 151 | INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA |
|---|
| 152 | INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA |
|---|
| 153 | INTEGER(KIND=JPIM),INTENT(IN) :: KLEV |
|---|
| 154 | REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (hPa) |
|---|
| 155 | REAL(KIND=JPRB) ,INTENT(OUT) :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV) |
|---|
| 156 | REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND) |
|---|
| 157 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(KIDIA:KFDIA,KLEV) |
|---|
| 158 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(KIDIA:KFDIA,KLEV) |
|---|
| 159 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(KIDIA:KFDIA,KLEV) |
|---|
| 160 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(KIDIA:KFDIA,KLEV) |
|---|
| 161 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(KIDIA:KFDIA,KLEV) |
|---|
| 162 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFRAC(KIDIA:KFDIA,KLEV) |
|---|
| 163 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(KIDIA:KFDIA,KLEV) |
|---|
| 164 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(KIDIA:KFDIA,KLEV) |
|---|
| 165 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(KIDIA:KFDIA,KLEV) |
|---|
| 166 | REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(KIDIA:KFDIA,KLEV) |
|---|
| 167 | INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP(KIDIA:KFDIA) |
|---|
| 168 | REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(KIDIA:KFDIA,KLEV) |
|---|
| 169 | REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) |
|---|
| 170 | REAL(KIND=JPRB) ,INTENT(IN) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) |
|---|
| 171 | INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(KIDIA:KFDIA,KLEV) |
|---|
| 172 | REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV) |
|---|
| 173 | |
|---|
| 174 | INTEGER(KIND=JPIM),INTENT(IN) :: K_INDFOR(KIDIA:KFDIA,KLEV) |
|---|
| 175 | INTEGER(KIND=JPIM),INTENT(IN) :: K_INDMINOR(KIDIA:KFDIA,KLEV) |
|---|
| 176 | REAL(KIND=JPRB) ,INTENT(IN) :: PSCALEMINORN2(KIDIA:KFDIA,KLEV) |
|---|
| 177 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLBRD(KIDIA:KFDIA,KLEV) |
|---|
| 178 | ! --------------------------------------------------------------------------- |
|---|
| 179 | |
|---|
| 180 | INTEGER(KIND=JPIM) :: IND0(KLEV),IND1(KLEV),INDS(KLEV) |
|---|
| 181 | INTEGER(KIND=JPIM) :: INDF(KLEV),INDM(KLEV) |
|---|
| 182 | |
|---|
| 183 | INTEGER(KIND=JPIM) :: IG, JLAY |
|---|
| 184 | INTEGER(KIND=JPIM) :: JLON |
|---|
| 185 | REAL(KIND=JPRB) :: ZTAUFOR,ZTAUSELF,ZTAUN2,ZCORRADJ,ZPP,ZSCALEN2 |
|---|
| 186 | REAL(KIND=JPHOOK) :: ZHOOK_HANDLE |
|---|
| 187 | |
|---|
| 188 | ! Minor gas mapping levels: |
|---|
| 189 | ! lower - n2, p = 142.5490 mbar, t = 215.70 k |
|---|
| 190 | ! upper - n2, p = 142.5490 mbar, t = 215.70 k |
|---|
| 191 | |
|---|
| 192 | ! Compute the optical depth by interpolating in ln(pressure) and |
|---|
| 193 | ! temperature. Below LAYTROP, the water vapor self-continuum and |
|---|
| 194 | ! foreign continuum is interpolated (in temperature) separately. |
|---|
| 195 | |
|---|
| 196 | ASSOCIATE(NFLEVG=>KLEV) |
|---|
| 197 | IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',0,ZHOOK_HANDLE) |
|---|
| 198 | |
|---|
| 199 | DO JLAY = 1, KLEV |
|---|
| 200 | DO JLON = KIDIA, KFDIA |
|---|
| 201 | IF (JLAY <= K_LAYTROP(JLON)) THEN |
|---|
| 202 | IND0(JLAY) = ((K_JP(JLON,JLAY)-1)*5+(K_JT(JLON,JLAY)-1))*NSPA(1) + 1 |
|---|
| 203 | IND1(JLAY) = (K_JP(JLON,JLAY)*5+(K_JT1(JLON,JLAY)-1))*NSPA(1) + 1 |
|---|
| 204 | INDS(JLAY) = K_INDSELF(JLON,JLAY) |
|---|
| 205 | INDF(JLAY) = K_INDFOR(JLON,JLAY) |
|---|
| 206 | INDM(JLAY) = K_INDMINOR(JLON,JLAY) |
|---|
| 207 | ZPP = PAVEL(JLON,JLAY) !hPa(mb) |
|---|
| 208 | ZCORRADJ = 1. |
|---|
| 209 | IF (ZPP < 250._JPRB) THEN |
|---|
| 210 | ZCORRADJ = 1._JPRB - 0.15_JPRB * (250._JPRB-ZPP) / 154.4_JPRB |
|---|
| 211 | ENDIF |
|---|
| 212 | |
|---|
| 213 | ZSCALEN2 = PCOLBRD(JLON,JLAY) * PSCALEMINORN2(JLON,JLAY) |
|---|
| 214 | |
|---|
| 215 | !CDIR UNROLL=NG1 |
|---|
| 216 | DO IG = 1, NG1 |
|---|
| 217 | !-- DS_000515 |
|---|
| 218 | ZTAUSELF = P_SELFFAC(JLON,JLAY) * (SELFREF(INDS(JLAY),IG) + & |
|---|
| 219 | & P_SELFFRAC(JLON,JLAY) * & |
|---|
| 220 | & (SELFREF(INDS(JLAY)+1,IG) - SELFREF(INDS(JLAY),IG))) |
|---|
| 221 | |
|---|
| 222 | ZTAUFOR = P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + & |
|---|
| 223 | & P_FORFRAC(JLON,JLAY) * (FORREF(INDF(JLAY)+1,IG) - & |
|---|
| 224 | & FORREF(INDF(JLAY),IG))) |
|---|
| 225 | |
|---|
| 226 | ZTAUN2 = ZSCALEN2*(KA_MN2(INDM(JLAY),IG) + & |
|---|
| 227 | & P_MINORFRAC(JLON,JLAY) * & |
|---|
| 228 | & (KA_MN2(INDM(JLAY)+1,IG) - KA_MN2(INDM(JLAY),IG))) |
|---|
| 229 | |
|---|
| 230 | P_TAU(JLON,IG,JLAY) = ZCORRADJ * (P_COLH2O(JLON,JLAY) * & |
|---|
| 231 | & (P_FAC00(JLON,JLAY) * ABSA(IND0(JLAY),IG) + & |
|---|
| 232 | & P_FAC10(JLON,JLAY) * ABSA(IND0(JLAY)+1,IG) + & |
|---|
| 233 | & P_FAC01(JLON,JLAY) * ABSA(IND1(JLAY),IG) + & |
|---|
| 234 | & P_FAC11(JLON,JLAY) * ABSA(IND1(JLAY)+1,IG)) & |
|---|
| 235 | & + ZTAUSELF + ZTAUFOR & |
|---|
| 236 | & + ZTAUN2) + P_TAUAERL(JLON,JLAY,1) |
|---|
| 237 | |
|---|
| 238 | PFRAC(JLON,IG,JLAY) = FRACREFA(IG) |
|---|
| 239 | |
|---|
| 240 | ENDDO |
|---|
| 241 | ENDIF |
|---|
| 242 | |
|---|
| 243 | IF (JLAY > K_LAYTROP(JLON)) THEN |
|---|
| 244 | IND0(JLAY) = ((K_JP(JLON,JLAY)-13)*5+(K_JT(JLON,JLAY)-1))*NSPB(1) + 1 |
|---|
| 245 | IND1(JLAY) = ((K_JP(JLON,JLAY)-12)*5+(K_JT1(JLON,JLAY)-1))*NSPB(1) + 1 |
|---|
| 246 | INDF(JLAY) = K_INDFOR(JLON,JLAY) |
|---|
| 247 | INDM(JLAY) = K_INDMINOR(JLON,JLAY) |
|---|
| 248 | ZPP = PAVEL(JLON,JLAY) !hPa(mb) |
|---|
| 249 | ZCORRADJ = 1._JPRB - 0.15_JPRB * (ZPP / 95.6_JPRB) |
|---|
| 250 | |
|---|
| 251 | ZSCALEN2 = PCOLBRD(JLON,JLAY) * PSCALEMINORN2(JLON,JLAY) |
|---|
| 252 | |
|---|
| 253 | !-- JJM000517 |
|---|
| 254 | !CDIR UNROLL=NG1 |
|---|
| 255 | DO IG = 1, NG1 |
|---|
| 256 | !-- JJM000517 |
|---|
| 257 | ZTAUFOR = P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + & |
|---|
| 258 | & P_FORFRAC(JLON,JLAY) * & |
|---|
| 259 | & (FORREF(INDF(JLAY)+1,IG) - FORREF(INDF(JLAY),IG))) |
|---|
| 260 | |
|---|
| 261 | ZTAUN2 = ZSCALEN2*(KB_MN2(INDM(JLAY),IG) + & |
|---|
| 262 | & P_MINORFRAC(JLON,JLAY) * & |
|---|
| 263 | & (KB_MN2(INDM(JLAY)+1,IG) - KB_MN2(INDM(JLAY),IG))) |
|---|
| 264 | |
|---|
| 265 | P_TAU(JLON,IG,JLAY) = ZCORRADJ * (P_COLH2O(JLON,JLAY) * & |
|---|
| 266 | & (P_FAC00(JLON,JLAY) * ABSB(IND0(JLAY),IG) + & |
|---|
| 267 | & P_FAC10(JLON,JLAY) * ABSB(IND0(JLAY)+1,IG) + & |
|---|
| 268 | & P_FAC01(JLON,JLAY) * ABSB(IND1(JLAY),IG) + & |
|---|
| 269 | & P_FAC11(JLON,JLAY) * ABSB(IND1(JLAY)+1,IG)) & |
|---|
| 270 | & + ZTAUFOR & |
|---|
| 271 | & + ZTAUN2)+ P_TAUAERL(JLON,JLAY,1) |
|---|
| 272 | PFRAC(JLON,IG,JLAY) = FRACREFB(IG) |
|---|
| 273 | |
|---|
| 274 | |
|---|
| 275 | ENDDO |
|---|
| 276 | ENDIF |
|---|
| 277 | ENDDO |
|---|
| 278 | ENDDO |
|---|
| 279 | |
|---|
| 280 | IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',1,ZHOOK_HANDLE) |
|---|
| 281 | |
|---|
| 282 | END ASSOCIATE |
|---|
| 283 | END SUBROUTINE RRTM_TAUMOL1 |
|---|
