| Directory: | ./ |
|---|---|
| File: | rad/rrtm_taumol1.f90 |
| Date: | 2022-01-11 19:19:34 |
| Exec | Total | Coverage | |
|---|---|---|---|
| Lines: | 20 | 22 | 90.9% |
| Branches: | 15 | 18 | 83.3% |
| Line | Branch | Exec | Source |
|---|---|---|---|
| 1 | !****************************************************************************** | ||
| 2 | ! * | ||
| 3 | ! Optical depths developed for the * | ||
| 4 | ! * | ||
| 5 | ! RAPID RADIATIVE TRANSFER MODEL (RRTM) * | ||
| 6 | ! * | ||
| 7 | ! ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * | ||
| 8 | ! 840 MEMORIAL DRIVE * | ||
| 9 | ! CAMBRIDGE, MA 02139 * | ||
| 10 | ! * | ||
| 11 | ! ELI J. MLAWER * | ||
| 12 | ! STEVEN J. TAUBMAN * | ||
| 13 | ! SHEPARD A. CLOUGH * | ||
| 14 | ! * | ||
| 15 | ! email: mlawer@aer.com * | ||
| 16 | ! * | ||
| 17 | ! The authors wish to acknowledge the contributions of the * | ||
| 18 | ! following people: Patrick D. Brown, Michael J. Iacono, * | ||
| 19 | ! Ronald E. Farren, Luke Chen, Robert Bergstrom. * | ||
| 20 | ! * | ||
| 21 | !****************************************************************************** | ||
| 22 | ! Modified by: * | ||
| 23 | ! JJ Morcrette 980714 ECMWF for use on ECMWF's Fujitsu VPP770 * | ||
| 24 | ! Reformatted for F90 by JJMorcrette, ECMWF * | ||
| 25 | ! - replacing COMMONs by MODULEs * | ||
| 26 | ! - changing labelled to unlabelled DO loops * | ||
| 27 | ! - creating set-up routines for all block data statements * | ||
| 28 | ! - reorganizing the parameter statements * | ||
| 29 | ! - passing KLEV as argument * | ||
| 30 | ! - suppressing some equivalencing * | ||
| 31 | ! * | ||
| 32 | ! D Salmond 9907 ECMWF Speed-up modifications * | ||
| 33 | ! D Salmond 000515 ECMWF Speed-up modifications * | ||
| 34 | !****************************************************************************** | ||
| 35 | ! TAUMOL * | ||
| 36 | ! * | ||
| 37 | ! This file contains the subroutines TAUGBn (where n goes from * | ||
| 38 | ! 1 to 16). TAUGBn calculates the optical depths and Planck fractions * | ||
| 39 | ! per g-value and layer for band n. * | ||
| 40 | ! * | ||
| 41 | ! Output: optical depths (unitless) * | ||
| 42 | ! fractions needed to compute Planck functions at every layer * | ||
| 43 | ! and g-value * | ||
| 44 | ! * | ||
| 45 | ! COMMON /TAUGCOM/ TAUG(MXLAY,MG) * | ||
| 46 | ! COMMON /PLANKG/ FRACS(MXLAY,MG) * | ||
| 47 | ! * | ||
| 48 | ! Input * | ||
| 49 | ! * | ||
| 50 | ! COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * | ||
| 51 | ! COMMON /PRECISE/ ONEMINUS * | ||
| 52 | ! COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * | ||
| 53 | ! & PZ(0:MXLAY),TZ(0:MXLAY),TBOUND * | ||
| 54 | ! COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW, * | ||
| 55 | ! & COLH2O(MXLAY),COLCO2(MXLAY), * | ||
| 56 | ! & COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY), * | ||
| 57 | ! & COLO2(MXLAY),CO2MULT(MXLAY) * | ||
| 58 | ! COMMON /INTFAC/ FAC00(MXLAY),FAC01(MXLAY), * | ||
| 59 | ! & FAC10(MXLAY),FAC11(MXLAY) * | ||
| 60 | ! COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * | ||
| 61 | ! COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * | ||
| 62 | ! * | ||
| 63 | ! Description: * | ||
| 64 | ! NG(IBAND) - number of g-values in band IBAND * | ||
| 65 | ! NSPA(IBAND) - for the lower atmosphere, the number of reference * | ||
| 66 | ! atmospheres that are stored for band IBAND per * | ||
| 67 | ! pressure level and temperature. Each of these * | ||
| 68 | ! atmospheres has different relative amounts of the * | ||
| 69 | ! key species for the band (i.e. different binary * | ||
| 70 | ! species parameters). * | ||
| 71 | ! NSPB(IBAND) - same for upper atmosphere * | ||
| 72 | ! ONEMINUS - since problems are caused in some cases by interpolation * | ||
| 73 | ! parameters equal to or greater than 1, for these cases * | ||
| 74 | ! these parameters are set to this value, slightly < 1. * | ||
| 75 | ! PAVEL - layer pressures (mb) * | ||
| 76 | ! TAVEL - layer temperatures (degrees K) * | ||
| 77 | ! PZ - level pressures (mb) * | ||
| 78 | ! TZ - level temperatures (degrees K) * | ||
| 79 | ! LAYTROP - layer at which switch is made from one combination of * | ||
| 80 | ! key species to another * | ||
| 81 | ! COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * | ||
| 82 | ! vapor,carbon dioxide, ozone, nitrous ozide, methane, * | ||
| 83 | ! respectively (molecules/cm**2) * | ||
| 84 | ! CO2MULT - for bands in which carbon dioxide is implemented as a * | ||
| 85 | ! trace species, this is the factor used to multiply the * | ||
| 86 | ! band's average CO2 absorption coefficient to get the added * | ||
| 87 | ! contribution to the optical depth relative to 355 ppm. * | ||
| 88 | ! FACij(LAY) - for layer LAY, these are factors that are needed to * | ||
| 89 | ! compute the interpolation factors that multiply the * | ||
| 90 | ! appropriate reference k-values. A value of 0 (1) for * | ||
| 91 | ! i,j indicates that the corresponding factor multiplies * | ||
| 92 | ! reference k-value for the lower (higher) of the two * | ||
| 93 | ! appropriate temperatures, and altitudes, respectively. * | ||
| 94 | ! JP - the index of the lower (in altitude) of the two appropriate * | ||
| 95 | ! reference pressure levels needed for interpolation * | ||
| 96 | ! JT, JT1 - the indices of the lower of the two appropriate reference * | ||
| 97 | ! temperatures needed for interpolation (for pressure * | ||
| 98 | ! levels JP and JP+1, respectively) * | ||
| 99 | ! SELFFAC - scale factor needed to water vapor self-continuum, equals * | ||
| 100 | ! (water vapor density)/(atmospheric density at 296K and * | ||
| 101 | ! 1013 mb) * | ||
| 102 | ! SELFFRAC - factor needed for temperature interpolation of reference * | ||
| 103 | ! water vapor self-continuum data * | ||
| 104 | ! INDSELF - index of the lower of the two appropriate reference * | ||
| 105 | ! temperatures needed for the self-continuum interpolation * | ||
| 106 | ! * | ||
| 107 | ! Data input * | ||
| 108 | ! COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) * | ||
| 109 | ! (note: n is the band number) * | ||
| 110 | ! * | ||
| 111 | ! Description: * | ||
| 112 | ! KA - k-values for low reference atmospheres (no water vapor * | ||
| 113 | ! self-continuum) (units: cm**2/molecule) * | ||
| 114 | ! KB - k-values for high reference atmospheres (all sources) * | ||
| 115 | ! (units: cm**2/molecule) * | ||
| 116 | ! SELFREF - k-values for water vapor self-continuum for reference * | ||
| 117 | ! atmospheres (used below LAYTROP) * | ||
| 118 | ! (units: cm**2/molecule) * | ||
| 119 | ! * | ||
| 120 | ! DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * | ||
| 121 | ! EQUIVALENCE (KA,ABSA),(KB,ABSB) * | ||
| 122 | ! * | ||
| 123 | !****************************************************************************** | ||
| 124 | |||
| 125 | 119280 | SUBROUTINE RRTM_TAUMOL1 (KLEV,P_TAU,& | |
| 126 | & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,K_JP,K_JT,K_JT1,& | ||
| 127 | & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) | ||
| 128 | |||
| 129 | ! Written by Eli J. Mlawer, Atmospheric & Environmental Research. | ||
| 130 | ! Revised by Michael J. Iacono, Atmospheric & Environmental Research. | ||
| 131 | |||
| 132 | ! BAND 1: 10-250 cm-1 (low - H2O; high - H2O) | ||
| 133 | |||
| 134 | ! Modifications | ||
| 135 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning | ||
| 136 | |||
| 137 | ! D Salmond 2000-05-15 speed-up | ||
| 138 | ! JJMorcrette 2000-05-17 speed-up | ||
| 139 | |||
| 140 | USE PARKIND1 ,ONLY : JPIM ,JPRB | ||
| 141 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK | ||
| 142 | |||
| 143 | USE PARRRTM , ONLY : JPLAY ,JPBAND ,JPGPT ,NG1 | ||
| 144 | USE YOERRTWN , ONLY : NSPA ,NSPB | ||
| 145 | USE YOERRTA1 , ONLY : ABSA ,ABSB ,FRACREFA, FRACREFB,& | ||
| 146 | & FORREF ,SELFREF | ||
| 147 | |||
| 148 | !#include "yoeratm.h" | ||
| 149 | |||
| 150 | ! REAL TAUAER(JPLAY) | ||
| 151 | |||
| 152 | IMPLICIT NONE | ||
| 153 | |||
| 154 | ! Output | ||
| 155 | INTEGER(KIND=JPIM),INTENT(IN) :: KLEV | ||
| 156 | REAL(KIND=JPRB) ,INTENT(OUT) :: P_TAU(JPGPT,JPLAY) | ||
| 157 | REAL(KIND=JPRB) ,INTENT(IN) :: P_TAUAERL(JPLAY,JPBAND) | ||
| 158 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC00(JPLAY) | ||
| 159 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC01(JPLAY) | ||
| 160 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC10(JPLAY) | ||
| 161 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FAC11(JPLAY) | ||
| 162 | REAL(KIND=JPRB) ,INTENT(IN) :: P_FORFAC(JPLAY) | ||
| 163 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JP(JPLAY) | ||
| 164 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JT(JPLAY) | ||
| 165 | INTEGER(KIND=JPIM),INTENT(IN) :: K_JT1(JPLAY) | ||
| 166 | REAL(KIND=JPRB) ,INTENT(IN) :: P_COLH2O(JPLAY) | ||
| 167 | INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP | ||
| 168 | REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFAC(JPLAY) | ||
| 169 | REAL(KIND=JPRB) ,INTENT(IN) :: P_SELFFRAC(JPLAY) | ||
| 170 | INTEGER(KIND=JPIM),INTENT(IN) :: K_INDSELF(JPLAY) | ||
| 171 | REAL(KIND=JPRB) ,INTENT(OUT) :: PFRAC(JPGPT,JPLAY) | ||
| 172 | !- from AER | ||
| 173 | !- from INTFAC | ||
| 174 | !- from INTIND | ||
| 175 | !- from PRECISE | ||
| 176 | !- from PROFDATA | ||
| 177 | !- from SELF | ||
| 178 | !- from SP | ||
| 179 | INTEGER(KIND=JPIM) :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY) | ||
| 180 | |||
| 181 | INTEGER(KIND=JPIM) :: IG, I_LAY | ||
| 182 | REAL(KIND=JPRB) :: ZHOOK_HANDLE | ||
| 183 | |||
| 184 | ! EQUIVALENCE (TAUAERL(1,1),TAUAER) | ||
| 185 | |||
| 186 | ! Compute the optical depth by interpolating in ln(pressure) and | ||
| 187 | ! temperature. Below LAYTROP, the water vapor self-continuum | ||
| 188 | ! is interpolated (in temperature) separately. | ||
| 189 | |||
| 190 |
1/2✓ Branch 0 taken 119280 times.
✗ Branch 1 not taken.
|
119280 | IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',0,ZHOOK_HANDLE) |
| 191 | !--ajout OB | ||
| 192 |
1/2✓ Branch 0 taken 119280 times.
✗ Branch 1 not taken.
|
119280 | IF (K_LAYTROP.GT.100) THEN |
| 193 | ✗ | PRINT *,'ATTENTION KLAY_TROP > 100 PROBLEME ARRAY DANS RRTM ON ARRETE' | |
| 194 | ✗ | STOP | |
| 195 | !--fin ajout OB | ||
| 196 | ENDIF | ||
| 197 |
2/2✓ Branch 0 taken 119280 times.
✓ Branch 1 taken 2504880 times.
|
2624160 | DO I_LAY = 1, K_LAYTROP |
| 198 | 2504880 | IND0(I_LAY) = ((K_JP(I_LAY)-1)*5+(K_JT(I_LAY)-1))*NSPA(1) + 1 | |
| 199 | 2504880 | IND1(I_LAY) = (K_JP(I_LAY)*5+(K_JT1(I_LAY)-1))*NSPA(1) + 1 | |
| 200 | 2624160 | INDS(I_LAY) = K_INDSELF(I_LAY) | |
| 201 | ENDDO | ||
| 202 | |||
| 203 |
2/2✓ Branch 0 taken 954240 times.
✓ Branch 1 taken 119280 times.
|
1073520 | DO IG = 1, NG1 |
| 204 |
2/2✓ Branch 0 taken 20039040 times.
✓ Branch 1 taken 954240 times.
|
21112560 | DO I_LAY = 1, K_LAYTROP |
| 205 | !-- DS_000515 | ||
| 206 | P_TAU (IG,I_LAY) = P_COLH2O(I_LAY) *& | ||
| 207 | & (P_FAC00(I_LAY) * ABSA(IND0(I_LAY) ,IG) +& | ||
| 208 | & P_FAC10(I_LAY) * ABSA(IND0(I_LAY)+1,IG) +& | ||
| 209 | & P_FAC01(I_LAY) * ABSA(IND1(I_LAY) ,IG) +& | ||
| 210 | & P_FAC11(I_LAY) * ABSA(IND1(I_LAY)+1,IG) +& | ||
| 211 | & P_SELFFAC(I_LAY) * (SELFREF(INDS(I_LAY),IG) + & | ||
| 212 | & P_SELFFRAC(I_LAY) *& | ||
| 213 | & (SELFREF(INDS(I_LAY)+1,IG) - SELFREF(INDS(I_LAY),IG)))& | ||
| 214 | & + P_FORFAC(I_LAY) * FORREF(IG) ) & | ||
| 215 | 20039040 | & + P_TAUAERL(I_LAY,1) | |
| 216 | 20993280 | PFRAC(IG,I_LAY) = FRACREFA(IG) | |
| 217 | ENDDO | ||
| 218 | ENDDO | ||
| 219 | |||
| 220 |
2/2✓ Branch 0 taken 119280 times.
✓ Branch 1 taken 2147040 times.
|
2266320 | DO I_LAY = K_LAYTROP+1, KLEV |
| 221 | 2147040 | IND0(I_LAY) = ((K_JP(I_LAY)-13)*5+(K_JT(I_LAY)-1))*NSPB(1) + 1 | |
| 222 | 2266320 | IND1(I_LAY) = ((K_JP(I_LAY)-12)*5+(K_JT1(I_LAY)-1))*NSPB(1) + 1 | |
| 223 | ENDDO | ||
| 224 | |||
| 225 | !-- JJM000517 | ||
| 226 |
2/2✓ Branch 0 taken 954240 times.
✓ Branch 1 taken 119280 times.
|
1073520 | DO IG = 1, NG1 |
| 227 |
2/2✓ Branch 0 taken 17176320 times.
✓ Branch 1 taken 954240 times.
|
18249840 | DO I_LAY = K_LAYTROP+1, KLEV |
| 228 | !-- JJM000517 | ||
| 229 | P_TAU (IG,I_LAY) = P_COLH2O(I_LAY) *& | ||
| 230 | & (P_FAC00(I_LAY) * ABSB(IND0(I_LAY) ,IG) +& | ||
| 231 | & P_FAC10(I_LAY) * ABSB(IND0(I_LAY)+1,IG) +& | ||
| 232 | & P_FAC01(I_LAY) * ABSB(IND1(I_LAY) ,IG) +& | ||
| 233 | & P_FAC11(I_LAY) * ABSB(IND1(I_LAY)+1,IG)& | ||
| 234 | & + P_FORFAC(I_LAY) * FORREF(IG) ) & | ||
| 235 | 17176320 | & + P_TAUAERL(I_LAY,1) | |
| 236 | 18130560 | PFRAC(IG,I_LAY) = FRACREFB(IG) | |
| 237 | ENDDO | ||
| 238 | ENDDO | ||
| 239 | |||
| 240 |
1/2✓ Branch 0 taken 119280 times.
✗ Branch 1 not taken.
|
119280 | IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',1,ZHOOK_HANDLE) |
| 241 | 119280 | END SUBROUTINE RRTM_TAUMOL1 | |
| 242 |