[3908] | 1 | #ifdef RS6K |
---|
| 2 | @PROCESS HOT(NOVECTOR) NOSTRICT |
---|
| 3 | #endif |
---|
| 4 | SUBROUTINE SRTM_GAS_OPTICAL_DEPTH & |
---|
| 5 | & ( KIDIA , KFDIA , KLEV , PONEMINUS, & |
---|
| 6 | & PRMU0, & |
---|
| 7 | & KLAYTROP,& |
---|
| 8 | & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 9 | & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& |
---|
| 10 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 11 | & KJP , KJT , KJT1 ,& |
---|
| 12 | !-- output arrays |
---|
| 13 | & POD, PSSA, PINCSOL) |
---|
| 14 | |
---|
| 15 | |
---|
| 16 | !**** *SRTM_GAS_OPTICAL_DEPTH* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES. |
---|
| 17 | |
---|
| 18 | ! PURPOSE. |
---|
| 19 | ! -------- |
---|
| 20 | |
---|
| 21 | ! COMPUTE THE GAS OPTICAL DEPTH AT EACH SHORTWAVE G POINT |
---|
| 22 | |
---|
| 23 | !** INTERFACE. |
---|
| 24 | ! ---------- |
---|
| 25 | |
---|
| 26 | ! *SRTM_GAS_OPTICAL_DEPTH* IS CALLED FROM THE NEW RADIATION SCHEME |
---|
| 27 | |
---|
| 28 | ! IMPLICIT ARGUMENTS : |
---|
| 29 | ! -------------------- |
---|
| 30 | |
---|
| 31 | ! ==== INPUTS === |
---|
| 32 | ! ==== OUTPUTS === |
---|
| 33 | |
---|
| 34 | ! METHOD. |
---|
| 35 | ! ------- |
---|
| 36 | |
---|
| 37 | ! EXTERNALS. |
---|
| 38 | ! ---------- |
---|
| 39 | |
---|
| 40 | ! REFERENCE. |
---|
| 41 | ! ---------- |
---|
| 42 | |
---|
| 43 | ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT |
---|
| 44 | ! DOCUMENTATION |
---|
| 45 | ! AUTHOR. |
---|
| 46 | ! ------- |
---|
| 47 | ! ADAPTED FROM SRTM_SPCVRT_MCICA (BY JEAN-JACQUES MORCRETTE) BY |
---|
| 48 | ! ROBIN HOGAN |
---|
| 49 | ! |
---|
| 50 | ! MODIFICATIONS. |
---|
| 51 | ! -------------- |
---|
| 52 | ! ORIGINAL : 2015-07-16 |
---|
| 53 | |
---|
| 54 | ! ------------------------------------------------------------------ |
---|
| 55 | |
---|
| 56 | USE PARKIND1 , ONLY : JPIM, JPRB |
---|
| 57 | USE YOMHOOK , ONLY : LHOOK, DR_HOOK |
---|
| 58 | USE PARSRTM , ONLY : JPB1, JPB2 |
---|
| 59 | USE YOESRTM , ONLY : JPGPT |
---|
| 60 | USE YOESRTWN , ONLY : NGC |
---|
| 61 | |
---|
| 62 | IMPLICIT NONE |
---|
| 63 | |
---|
| 64 | ! ------------------------------------------------------------------ |
---|
| 65 | |
---|
| 66 | !* 0.1 ARGUMENTS |
---|
| 67 | ! --------- |
---|
| 68 | |
---|
| 69 | INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA |
---|
| 70 | INTEGER(KIND=JPIM),INTENT(IN) :: KLEV |
---|
| 71 | REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS(KIDIA:KFDIA) |
---|
| 72 | REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) |
---|
| 73 | INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) |
---|
| 74 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) |
---|
| 75 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) |
---|
| 76 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) |
---|
| 77 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLMOL(KIDIA:KFDIA,KLEV) |
---|
| 78 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) |
---|
| 79 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) |
---|
| 80 | REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) |
---|
| 81 | REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) |
---|
| 82 | INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) |
---|
| 83 | REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) |
---|
| 84 | REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) |
---|
| 85 | INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) |
---|
| 86 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) |
---|
| 87 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) |
---|
| 88 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) |
---|
| 89 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) |
---|
| 90 | INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) |
---|
| 91 | INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) |
---|
| 92 | INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) |
---|
| 93 | |
---|
| 94 | REAL(KIND=JPRB) ,INTENT(OUT) :: POD(KIDIA:KFDIA,KLEV,JPGPT) ! Optical depth |
---|
| 95 | REAL(KIND=JPRB) ,INTENT(OUT) :: PSSA(KIDIA:KFDIA,KLEV,JPGPT) ! Single scattering albedo |
---|
| 96 | REAL(KIND=JPRB) ,INTENT(OUT) :: PINCSOL(KIDIA:KFDIA,JPGPT) ! Incoming solar flux |
---|
| 97 | |
---|
| 98 | |
---|
| 99 | ! ------------------------------------------------------------------ |
---|
| 100 | |
---|
| 101 | INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IW(KIDIA:KFDIA), JB, JG, JK, JL, IC, ICOUNT |
---|
| 102 | |
---|
| 103 | INTEGER(KIND=JPIM) :: IND(KFDIA-KIDIA+1) |
---|
| 104 | |
---|
| 105 | |
---|
| 106 | !-- Output of SRTM_TAUMOLn routines |
---|
| 107 | REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16) ! Absorption optical depth |
---|
| 108 | REAL(KIND=JPRB) :: ZTAUR(KIDIA:KFDIA,KLEV,16) ! Rayleigh optical depth |
---|
| 109 | REAL(KIND=JPRB) :: ZSFLXZEN(KIDIA:KFDIA,16) ! Incoming solar flux |
---|
| 110 | |
---|
| 111 | |
---|
| 112 | REAL(KIND=JPRB) :: ZTAU, ZPAO, ZPTO |
---|
| 113 | REAL(KIND=JPRB) :: ZPAOJ(KIDIA:KFDIA,KLEV) |
---|
| 114 | REAL(KIND=JPRB) :: ZPTOJ(KIDIA:KFDIA,KLEV) |
---|
| 115 | REAL(KIND=JPRB) :: ZRMU0D(KIDIA:KFDIA) |
---|
| 116 | |
---|
| 117 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
---|
| 118 | |
---|
| 119 | |
---|
| 120 | #include "srtm_taumol16.intfb.h" |
---|
| 121 | #include "srtm_taumol17.intfb.h" |
---|
| 122 | #include "srtm_taumol18.intfb.h" |
---|
| 123 | #include "srtm_taumol19.intfb.h" |
---|
| 124 | #include "srtm_taumol20.intfb.h" |
---|
| 125 | #include "srtm_taumol21.intfb.h" |
---|
| 126 | #include "srtm_taumol22.intfb.h" |
---|
| 127 | #include "srtm_taumol23.intfb.h" |
---|
| 128 | #include "srtm_taumol24.intfb.h" |
---|
| 129 | #include "srtm_taumol25.intfb.h" |
---|
| 130 | #include "srtm_taumol26.intfb.h" |
---|
| 131 | #include "srtm_taumol27.intfb.h" |
---|
| 132 | #include "srtm_taumol28.intfb.h" |
---|
| 133 | #include "srtm_taumol29.intfb.h" |
---|
| 134 | |
---|
| 135 | ! ------------------------------------------------------------------ |
---|
| 136 | ASSOCIATE(NFLEVG=>KLEV) |
---|
| 137 | IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',0,ZHOOK_HANDLE) |
---|
| 138 | |
---|
| 139 | IB1=JPB1 |
---|
| 140 | IB2=JPB2 |
---|
| 141 | |
---|
| 142 | IC=0 |
---|
| 143 | DO JL = KIDIA, KFDIA |
---|
| 144 | IF (PRMU0(JL) > 0.0_JPRB) THEN |
---|
| 145 | IC=IC+1 |
---|
| 146 | IND(IC)=JL |
---|
| 147 | IW(JL)=0 |
---|
| 148 | ENDIF |
---|
| 149 | ENDDO |
---|
| 150 | ICOUNT=IC |
---|
| 151 | IF(ICOUNT==0)THEN |
---|
| 152 | IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE) |
---|
| 153 | RETURN |
---|
| 154 | ENDIF |
---|
| 155 | |
---|
| 156 | JB=IB1-1 |
---|
| 157 | DO JB = IB1, IB2 |
---|
| 158 | DO IC=1,ICOUNT |
---|
| 159 | JL=IND(IC) |
---|
| 160 | IBM = JB-15 |
---|
| 161 | IGT = NGC(IBM) |
---|
| 162 | ENDDO |
---|
| 163 | |
---|
| 164 | !-- for each band, computes the gaseous and Rayleigh optical thickness |
---|
| 165 | ! for all g-points within the band |
---|
| 166 | |
---|
| 167 | IF (JB == 16) THEN |
---|
| 168 | CALL SRTM_TAUMOL16 & |
---|
| 169 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 170 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 171 | & KJP , KJT , KJT1 , PONEMINUS,& |
---|
| 172 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 173 | & KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC , PFORFRAC, KINDFOR ,& |
---|
| 174 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 175 | & ) |
---|
| 176 | |
---|
| 177 | ELSEIF (JB == 17) THEN |
---|
| 178 | CALL SRTM_TAUMOL17 & |
---|
| 179 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 180 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 181 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 182 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 183 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 184 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 185 | & ) |
---|
| 186 | |
---|
| 187 | ELSEIF (JB == 18) THEN |
---|
| 188 | CALL SRTM_TAUMOL18 & |
---|
| 189 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 190 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 191 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 192 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 193 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 194 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 195 | & ) |
---|
| 196 | |
---|
| 197 | ELSEIF (JB == 19) THEN |
---|
| 198 | CALL SRTM_TAUMOL19 & |
---|
| 199 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 200 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 201 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 202 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 203 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 204 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 205 | & ) |
---|
| 206 | |
---|
| 207 | ELSEIF (JB == 20) THEN |
---|
| 208 | CALL SRTM_TAUMOL20 & |
---|
| 209 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 210 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 211 | & KJP , KJT , KJT1 ,& |
---|
| 212 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 213 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 214 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 215 | & ) |
---|
| 216 | |
---|
| 217 | ELSEIF (JB == 21) THEN |
---|
| 218 | CALL SRTM_TAUMOL21 & |
---|
| 219 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 220 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 221 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 222 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 223 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 224 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 225 | & ) |
---|
| 226 | |
---|
| 227 | ELSEIF (JB == 22) THEN |
---|
| 228 | CALL SRTM_TAUMOL22 & |
---|
| 229 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 230 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 231 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 232 | & PCOLH2O , PCOLMOL , PCOLO2 ,& |
---|
| 233 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 234 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 235 | & ) |
---|
| 236 | |
---|
| 237 | ELSEIF (JB == 23) THEN |
---|
| 238 | CALL SRTM_TAUMOL23 & |
---|
| 239 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 240 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 241 | & KJP , KJT , KJT1 ,& |
---|
| 242 | & PCOLH2O , PCOLMOL ,& |
---|
| 243 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 244 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 245 | & ) |
---|
| 246 | |
---|
| 247 | ELSEIF (JB == 24) THEN |
---|
| 248 | CALL SRTM_TAUMOL24 & |
---|
| 249 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 250 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 251 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 252 | & PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 253 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 254 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 255 | & ) |
---|
| 256 | |
---|
| 257 | ELSEIF (JB == 25) THEN |
---|
| 258 | !--- visible 16000-22650 cm-1 0.4415 - 0.6250 um |
---|
| 259 | CALL SRTM_TAUMOL25 & |
---|
| 260 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 261 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 262 | & KJP , KJT , KJT1 ,& |
---|
| 263 | & PCOLH2O , PCOLMOL , PCOLO3 ,& |
---|
| 264 | & KLAYTROP ,& |
---|
| 265 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 266 | & ) |
---|
| 267 | |
---|
| 268 | ELSEIF (JB == 26) THEN |
---|
| 269 | !--- UV-A 22650-29000 cm-1 0.3448 - 0.4415 um |
---|
| 270 | CALL SRTM_TAUMOL26 & |
---|
| 271 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 272 | & PCOLMOL ,KLAYTROP,& |
---|
| 273 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 274 | & ) |
---|
| 275 | |
---|
| 276 | ELSEIF (JB == 27) THEN |
---|
| 277 | !--- UV-B 29000-38000 cm-1 0.2632 - 0.3448 um |
---|
| 278 | CALL SRTM_TAUMOL27 & |
---|
| 279 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 280 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 281 | & KJP , KJT , KJT1 ,& |
---|
| 282 | & PCOLMOL , PCOLO3 ,& |
---|
| 283 | & KLAYTROP ,& |
---|
| 284 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 285 | & ) |
---|
| 286 | |
---|
| 287 | ELSEIF (JB == 28) THEN |
---|
| 288 | !--- UV-C 38000-50000 cm-1 0.2000 - 0.2632 um |
---|
| 289 | CALL SRTM_TAUMOL28 & |
---|
| 290 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 291 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 292 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 293 | & PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 294 | & KLAYTROP ,& |
---|
| 295 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 296 | & ) |
---|
| 297 | |
---|
| 298 | ELSEIF (JB == 29) THEN |
---|
| 299 | CALL SRTM_TAUMOL29 & |
---|
| 300 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 301 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 302 | & KJP , KJT , KJT1 ,& |
---|
| 303 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 304 | & KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 305 | & ZSFLXZEN , ZTAUG , ZTAUR , PRMU0 & |
---|
| 306 | & ) |
---|
| 307 | |
---|
| 308 | ENDIF |
---|
| 309 | |
---|
| 310 | DO JG=1,IGT |
---|
| 311 | DO IC=1,ICOUNT |
---|
| 312 | JL=IND(IC) |
---|
| 313 | IW(JL)=IW(JL)+1 |
---|
| 314 | |
---|
| 315 | ! Incoming solar flux into plane perp to incoming radiation |
---|
| 316 | PINCSOL(JL,IW(JL)) = ZSFLXZEN(JL,JG) |
---|
| 317 | ENDDO |
---|
| 318 | |
---|
| 319 | DO JK=1,KLEV |
---|
| 320 | DO IC=1,ICOUNT |
---|
| 321 | JL=IND(IC) |
---|
| 322 | POD (JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) + ZTAUG(JL,JK,JG) |
---|
| 323 | PSSA(JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) / POD(JL,JK,IW(JL)) |
---|
| 324 | ENDDO |
---|
| 325 | ENDDO |
---|
| 326 | |
---|
| 327 | ENDDO !-- end loop on JG (g point) |
---|
| 328 | |
---|
| 329 | ENDDO !-- end loop on JB (band) |
---|
| 330 | |
---|
| 331 | ! ------------------------------------------------------------------ |
---|
| 332 | IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',1,ZHOOK_HANDLE) |
---|
| 333 | END ASSOCIATE |
---|
| 334 | END SUBROUTINE SRTM_GAS_OPTICAL_DEPTH |
---|