[3880] | 1 | #ifdef RS6K |
---|
| 2 | @PROCESS HOT(NOVECTOR) NOSTRICT |
---|
| 3 | #endif |
---|
| 4 | SUBROUTINE SRTM_SPCVRT_MCICA & |
---|
| 5 | & ( KIDIA , KFDIA , KLEV , KSW , KCOLS , PONEMINUS, & |
---|
| 6 | & PALBD , PALBP, & |
---|
| 7 | & PFRCL , PTAUC , PASYC , POMGC , PTAUA , PASYA , POMGA , PRMU0, & |
---|
| 8 | & KLAYTROP,& |
---|
| 9 | & PCOLCH4 , PCOLCO2 , PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 10 | & PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,& |
---|
| 11 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 12 | & KJP , KJT , KJT1 ,& |
---|
| 13 | !-- output arrays |
---|
| 14 | & PBBFD , PBBFU , PBBCD, PBBCU, PFUVF, PFUVC, PPARF, PPARCF, PSUDU, & |
---|
| 15 | & PBBFDIR , PBBCDIR , PSwDiffuseBand , PSwDirectBand ) |
---|
| 16 | |
---|
| 17 | |
---|
| 18 | !**** *SRTM_SPCVRT* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES. |
---|
| 19 | |
---|
| 20 | ! PURPOSE. |
---|
| 21 | ! -------- |
---|
| 22 | |
---|
| 23 | ! THIS ROUTINE COMPUTES THE TWO-STREAM METHOD OF BARKER |
---|
| 24 | |
---|
| 25 | !** INTERFACE. |
---|
| 26 | ! ---------- |
---|
| 27 | |
---|
| 28 | ! *SRTM_SPCVRT_MCICA* IS CALLED FROM *SRTM_SRTM_224GP* |
---|
| 29 | |
---|
| 30 | ! IMPLICIT ARGUMENTS : |
---|
| 31 | ! -------------------- |
---|
| 32 | |
---|
| 33 | ! ==== INPUTS === |
---|
| 34 | ! ==== OUTPUTS === |
---|
| 35 | |
---|
| 36 | ! METHOD. |
---|
| 37 | ! ------- |
---|
| 38 | |
---|
| 39 | ! EXTERNALS. |
---|
| 40 | ! ---------- |
---|
| 41 | |
---|
| 42 | ! *SWVRTQDR* |
---|
| 43 | |
---|
| 44 | ! REFERENCE. |
---|
| 45 | ! ---------- |
---|
| 46 | |
---|
| 47 | ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT |
---|
| 48 | ! DOCUMENTATION |
---|
| 49 | ! AUTHOR. |
---|
| 50 | ! ------- |
---|
| 51 | ! from Howard Barker |
---|
| 52 | ! JEAN-JACQUES MORCRETTE *ECMWF* |
---|
| 53 | |
---|
| 54 | ! MODIFICATIONS. |
---|
| 55 | ! -------------- |
---|
| 56 | ! ORIGINAL : 03-02-27 |
---|
| 57 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning |
---|
| 58 | ! JJMorcrette 20050110 McICA version |
---|
| 59 | ! JJMorcrette 20070614 bug-fix for solar duration |
---|
| 60 | ! JJMorcrette 20070831 UV-B surface flux |
---|
| 61 | ! D.Salmond 31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC |
---|
| 62 | ! JJMorcrette/MJIacono 20080724 Look-up table replacing exponential |
---|
| 63 | ! JJMorcrette 20091201 Total and clear-sky downward direct flux |
---|
| 64 | ! RJHogan 20140627 Store downwelling surface fluxes in each band |
---|
| 65 | ! ------------------------------------------------------------------ |
---|
| 66 | |
---|
| 67 | USE PARKIND1 , ONLY : JPIM, JPRB |
---|
| 68 | USE YOMHOOK , ONLY : LHOOK, DR_HOOK |
---|
| 69 | USE PARSRTM , ONLY : JPB1, JPB2 |
---|
| 70 | USE YOESRTM , ONLY : JPGPT |
---|
| 71 | USE YOESRTWN , ONLY : NGC, NMPSRTM |
---|
| 72 | USE YOERDI , ONLY : REPCLC |
---|
| 73 | USE YOESRTAB , ONLY : BPADE, TRANS, RODLOW, RTBLINT |
---|
| 74 | USE YOERAD , ONLY : NSW, LApproxSwUpdate |
---|
| 75 | |
---|
| 76 | IMPLICIT NONE |
---|
| 77 | |
---|
| 78 | ! ------------------------------------------------------------------ |
---|
| 79 | |
---|
| 80 | !* 0.1 ARGUMENTS |
---|
| 81 | ! --------- |
---|
| 82 | |
---|
| 83 | INTEGER(KIND=JPIM),INTENT(IN) :: KSW |
---|
| 84 | INTEGER(KIND=JPIM),INTENT(IN) :: KCOLS |
---|
| 85 | INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA, KFDIA |
---|
| 86 | INTEGER(KIND=JPIM),INTENT(IN) :: KLEV |
---|
| 87 | REAL(KIND=JPRB) ,INTENT(IN) :: PONEMINUS(KIDIA:KFDIA) |
---|
| 88 | REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(KIDIA:KFDIA,KSW) |
---|
| 89 | REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(KIDIA:KFDIA,KSW) |
---|
| 90 | REAL(KIND=JPRB) ,INTENT(IN) :: PFRCL(KIDIA:KFDIA,KCOLS,KLEV) ! bottom to top |
---|
| 91 | REAL(KIND=JPRB) ,INTENT(IN) :: PTAUC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top |
---|
| 92 | REAL(KIND=JPRB) ,INTENT(IN) :: PASYC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top |
---|
| 93 | REAL(KIND=JPRB) ,INTENT(IN) :: POMGC(KIDIA:KFDIA,KLEV,KCOLS) ! bottom to top |
---|
| 94 | REAL(KIND=JPRB) ,INTENT(IN) :: PTAUA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top |
---|
| 95 | REAL(KIND=JPRB) ,INTENT(IN) :: PASYA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top |
---|
| 96 | REAL(KIND=JPRB) ,INTENT(IN) :: POMGA(KIDIA:KFDIA,KLEV,KSW) ! bottom to top |
---|
| 97 | REAL(KIND=JPRB) ,INTENT(IN) :: PRMU0(KIDIA:KFDIA) |
---|
| 98 | INTEGER(KIND=JPIM),INTENT(IN) :: KLAYTROP(KIDIA:KFDIA) |
---|
| 99 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCH4(KIDIA:KFDIA,KLEV) |
---|
| 100 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLCO2(KIDIA:KFDIA,KLEV) |
---|
| 101 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLH2O(KIDIA:KFDIA,KLEV) |
---|
| 102 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLMOL(KIDIA:KFDIA,KLEV) |
---|
| 103 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO2(KIDIA:KFDIA,KLEV) |
---|
| 104 | REAL(KIND=JPRB) ,INTENT(IN) :: PCOLO3(KIDIA:KFDIA,KLEV) |
---|
| 105 | REAL(KIND=JPRB) ,INTENT(IN) :: PFORFAC(KIDIA:KFDIA,KLEV) |
---|
| 106 | REAL(KIND=JPRB) ,INTENT(IN) :: PFORFRAC(KIDIA:KFDIA,KLEV) |
---|
| 107 | INTEGER(KIND=JPIM),INTENT(IN) :: KINDFOR(KIDIA:KFDIA,KLEV) |
---|
| 108 | REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFAC(KIDIA:KFDIA,KLEV) |
---|
| 109 | REAL(KIND=JPRB) ,INTENT(IN) :: PSELFFRAC(KIDIA:KFDIA,KLEV) |
---|
| 110 | INTEGER(KIND=JPIM),INTENT(IN) :: KINDSELF(KIDIA:KFDIA,KLEV) |
---|
| 111 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC00(KIDIA:KFDIA,KLEV) |
---|
| 112 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC01(KIDIA:KFDIA,KLEV) |
---|
| 113 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC10(KIDIA:KFDIA,KLEV) |
---|
| 114 | REAL(KIND=JPRB) ,INTENT(IN) :: PFAC11(KIDIA:KFDIA,KLEV) |
---|
| 115 | INTEGER(KIND=JPIM),INTENT(IN) :: KJP(KIDIA:KFDIA,KLEV) |
---|
| 116 | INTEGER(KIND=JPIM),INTENT(IN) :: KJT(KIDIA:KFDIA,KLEV) |
---|
| 117 | INTEGER(KIND=JPIM),INTENT(IN) :: KJT1(KIDIA:KFDIA,KLEV) |
---|
| 118 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFD(KIDIA:KFDIA,KLEV+1) |
---|
| 119 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFU(KIDIA:KFDIA,KLEV+1) |
---|
| 120 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCD(KIDIA:KFDIA,KLEV+1) |
---|
| 121 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCU(KIDIA:KFDIA,KLEV+1) |
---|
| 122 | REAL(KIND=JPRB) ,INTENT(OUT) :: PFUVF(KIDIA:KFDIA), PFUVC(KIDIA:KFDIA) |
---|
| 123 | REAL(KIND=JPRB) ,INTENT(OUT) :: PPARF(KIDIA:KFDIA), PPARCF(KIDIA:KFDIA) |
---|
| 124 | REAL(KIND=JPRB) ,INTENT(OUT) :: PSUDU(KIDIA:KFDIA) |
---|
| 125 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFDIR(KIDIA:KFDIA,KLEV+1) |
---|
| 126 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCDIR(KIDIA:KFDIA,KLEV+1) |
---|
| 127 | |
---|
| 128 | ! Surface diffuse and direct downwelling shortwave flux in each |
---|
| 129 | ! shortwave albedo band, used in RADINTG to update the surface fluxes |
---|
| 130 | ! accounting for high-resolution albedo information |
---|
| 131 | REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDiffuseBand(KIDIA:KFDIA,NSW) |
---|
| 132 | REAL(KIND=JPRB) ,INTENT(OUT) :: PSwDirectBand(KIDIA:KFDIA,NSW) |
---|
| 133 | |
---|
| 134 | ! ------------------------------------------------------------------ |
---|
| 135 | |
---|
| 136 | ! ------------ |
---|
| 137 | |
---|
| 138 | LOGICAL :: LLRTCHK(KIDIA:KFDIA,KLEV) |
---|
| 139 | |
---|
| 140 | REAL(KIND=JPRB) :: & |
---|
| 141 | & ZCLEAR(KIDIA:KFDIA) , ZCLOUD(KIDIA:KFDIA) & |
---|
| 142 | & , ZDBT(KIDIA:KFDIA,KLEV+1) & |
---|
| 143 | & , ZGCC(KIDIA:KFDIA,KLEV) , ZGCO(KIDIA:KFDIA,KLEV) & |
---|
| 144 | & , ZOMCC(KIDIA:KFDIA,KLEV) , ZOMCO(KIDIA:KFDIA,KLEV) & |
---|
| 145 | & , ZRDND(KIDIA:KFDIA,KLEV+1), ZRDNDC(KIDIA:KFDIA,KLEV+1)& |
---|
| 146 | & , ZREF(KIDIA:KFDIA,KLEV+1) , ZREFC(KIDIA:KFDIA,KLEV+1) , ZREFO(KIDIA:KFDIA,KLEV+1) & |
---|
| 147 | & , ZREFD(KIDIA:KFDIA,KLEV+1), ZREFDC(KIDIA:KFDIA,KLEV+1), ZREFDO(KIDIA:KFDIA,KLEV+1) & |
---|
| 148 | & , ZRUP(KIDIA:KFDIA,KLEV+1) , ZRUPD(KIDIA:KFDIA,KLEV+1) & |
---|
| 149 | & , ZRUPC(KIDIA:KFDIA,KLEV+1), ZRUPDC(KIDIA:KFDIA,KLEV+1)& |
---|
| 150 | & , ZTAUC(KIDIA:KFDIA,KLEV) , ZTAUO(KIDIA:KFDIA,KLEV) & |
---|
| 151 | & , ZTDBT(KIDIA:KFDIA,KLEV+1) & |
---|
| 152 | & , ZTRA(KIDIA:KFDIA,KLEV+1) , ZTRAC(KIDIA:KFDIA,KLEV+1) , ZTRAO(KIDIA:KFDIA,KLEV+1) & |
---|
| 153 | & , ZTRAD(KIDIA:KFDIA,KLEV+1), ZTRADC(KIDIA:KFDIA,KLEV+1), ZTRADO(KIDIA:KFDIA,KLEV+1) |
---|
| 154 | REAL(KIND=JPRB) :: & |
---|
| 155 | & ZDBTC(KIDIA:KFDIA,KLEV+1), ZTDBTC(KIDIA:KFDIA,KLEV+1), ZINCFLX(KIDIA:KFDIA,JPGPT) & |
---|
| 156 | & , ZINCF14(KIDIA:KFDIA,14) , ZINCTOT(KIDIA:KFDIA) |
---|
| 157 | |
---|
| 158 | INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW(KIDIA:KFDIA), JB, JG, JK, I_KMODTS, JL, IC, ICOUNT |
---|
| 159 | |
---|
| 160 | ! An index for the 6 bands used in the original albedo data rather |
---|
| 161 | ! than the 14 RRTM bands |
---|
| 162 | INTEGER(KIND=JPIM) :: JB_ALBEDO |
---|
| 163 | |
---|
| 164 | INTEGER(KIND=JPIM) :: INDEX(KIDIA:KFDIA) |
---|
| 165 | |
---|
| 166 | REAL(KIND=JPRB) :: ZDBTMC(KIDIA:KFDIA), ZDBTMO(KIDIA:KFDIA), ZF(KIDIA:KFDIA) |
---|
| 167 | ! REAL(KIND=JPRB) :: ZARG1(KIDIA:KFDIA), ZARG2(KIDIA:KFDIA) |
---|
| 168 | REAL(KIND=JPRB) :: ZINCFLUX(KIDIA:KFDIA), ZWF(KIDIA:KFDIA) |
---|
| 169 | REAL(KIND=JPRB) :: ZCOEFVS |
---|
| 170 | |
---|
| 171 | !-- Output of SRTM_TAUMOLn routines |
---|
| 172 | |
---|
| 173 | REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16), ZTAUR(KIDIA:KFDIA,KLEV,16), ZSFLXZEN(KIDIA:KFDIA,16) |
---|
| 174 | |
---|
| 175 | !-- Output of SRTM_VRTQDR routine |
---|
| 176 | REAL(KIND=JPRB) :: & |
---|
| 177 | & ZCD(KIDIA:KFDIA,KLEV+1,JPGPT), ZCU(KIDIA:KFDIA,KLEV+1,JPGPT) & |
---|
| 178 | & , ZFD(KIDIA:KFDIA,KLEV+1,JPGPT), ZFU(KIDIA:KFDIA,KLEV+1,JPGPT) |
---|
| 179 | |
---|
| 180 | REAL(KIND=JPRB) :: ZTAU, ZPAO, ZPTO |
---|
| 181 | REAL(KIND=JPRB) :: ZPAOJ(KIDIA:KFDIA,KLEV) |
---|
| 182 | REAL(KIND=JPRB) :: ZPTOJ(KIDIA:KFDIA,KLEV) |
---|
| 183 | REAL(KIND=JPRB) :: ZRMU0D(KIDIA:KFDIA) |
---|
| 184 | |
---|
| 185 | !-- Use of exponential look-up table |
---|
| 186 | REAL(KIND=JPRB) :: ZE1, ZE2, ZTBLIND |
---|
| 187 | INTEGER(KIND=JPIM) :: ITIND |
---|
| 188 | |
---|
| 189 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
---|
| 190 | |
---|
| 191 | |
---|
| 192 | #include "srtm_taumol16.intfb.h" |
---|
| 193 | #include "srtm_taumol17.intfb.h" |
---|
| 194 | #include "srtm_taumol18.intfb.h" |
---|
| 195 | #include "srtm_taumol19.intfb.h" |
---|
| 196 | #include "srtm_taumol20.intfb.h" |
---|
| 197 | #include "srtm_taumol21.intfb.h" |
---|
| 198 | #include "srtm_taumol22.intfb.h" |
---|
| 199 | #include "srtm_taumol23.intfb.h" |
---|
| 200 | #include "srtm_taumol24.intfb.h" |
---|
| 201 | #include "srtm_taumol25.intfb.h" |
---|
| 202 | #include "srtm_taumol26.intfb.h" |
---|
| 203 | #include "srtm_taumol27.intfb.h" |
---|
| 204 | #include "srtm_taumol28.intfb.h" |
---|
| 205 | #include "srtm_taumol29.intfb.h" |
---|
| 206 | #include "srtm_reftra.intfb.h" |
---|
| 207 | #include "srtm_vrtqdr.intfb.h" |
---|
| 208 | ! ------------------------------------------------------------------ |
---|
| 209 | ASSOCIATE(NFLEVG=>KLEV) |
---|
| 210 | IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',0,ZHOOK_HANDLE) |
---|
| 211 | |
---|
| 212 | !-- Two-stream model 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discrete ordinates |
---|
| 213 | |
---|
| 214 | IB1=JPB1 |
---|
| 215 | IB2=JPB2 |
---|
| 216 | |
---|
| 217 | IC=0 |
---|
| 218 | DO JL = KIDIA, KFDIA |
---|
| 219 | IF (PRMU0(JL) > 0.0_JPRB) THEN |
---|
| 220 | IC=IC+1 |
---|
| 221 | INDEX(IC)=JL |
---|
| 222 | IW(JL)=0 |
---|
| 223 | ZINCFLUX(JL)=0.0_JPRB |
---|
| 224 | ZINCTOT(JL)=0.0_JPRB |
---|
| 225 | PFUVF(JL) = 0.0_JPRB |
---|
| 226 | PFUVC(JL) = 0.0_JPRB |
---|
| 227 | PPARF(JL) = 0.0_JPRB |
---|
| 228 | PPARCF(JL)= 0.0_JPRB |
---|
| 229 | ENDIF |
---|
| 230 | ENDDO |
---|
| 231 | ICOUNT=IC |
---|
| 232 | IF(ICOUNT==0)THEN |
---|
| 233 | IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE) |
---|
| 234 | RETURN |
---|
| 235 | ENDIF |
---|
| 236 | |
---|
| 237 | ! Since the stored shortwave downwelling fluxes in bands are |
---|
| 238 | ! accumulated over the g-points within that band, they need to be |
---|
| 239 | ! initialized here |
---|
| 240 | IF (LApproxSwUpdate) THEN |
---|
| 241 | DO JB_ALBEDO = 1,NSW |
---|
| 242 | DO JL = KIDIA, KFDIA |
---|
| 243 | PSwDiffuseBand(JL,JB_ALBEDO) = 0.0_JPRB |
---|
| 244 | PSwDirectBand (JL,JB_ALBEDO) = 0.0_JPRB |
---|
| 245 | ENDDO |
---|
| 246 | ENDDO |
---|
| 247 | ENDIF |
---|
| 248 | |
---|
| 249 | |
---|
| 250 | !-- fraction of visible (to 0.69 um) in interval 0.6250-0.7782 um |
---|
| 251 | ZCOEFVS = 0.42425_JPRB |
---|
| 252 | |
---|
| 253 | JB=IB1-1 |
---|
| 254 | DO JB = IB1, IB2 |
---|
| 255 | DO IC=1,ICOUNT |
---|
| 256 | JL=INDEX(IC) |
---|
| 257 | IBM = JB-15 |
---|
| 258 | IGT = NGC(IBM) |
---|
| 259 | ZINCF14(JL,IBM)=0.0_JPRB |
---|
| 260 | ENDDO |
---|
| 261 | |
---|
| 262 | !-- for each band, computes the gaseous and Rayleigh optical thickness |
---|
| 263 | ! for all g-points within the band |
---|
| 264 | |
---|
| 265 | IF (JB == 16) THEN |
---|
| 266 | CALL SRTM_TAUMOL16 & |
---|
| 267 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 268 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 269 | & KJP , KJT , KJT1 , PONEMINUS,& |
---|
| 270 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 271 | & KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC , PFORFRAC, KINDFOR ,& |
---|
| 272 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 273 | & ) |
---|
| 274 | |
---|
| 275 | ELSEIF (JB == 17) THEN |
---|
| 276 | CALL SRTM_TAUMOL17 & |
---|
| 277 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 278 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 279 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 280 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 281 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 282 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 283 | & ) |
---|
| 284 | |
---|
| 285 | ELSEIF (JB == 18) THEN |
---|
| 286 | CALL SRTM_TAUMOL18 & |
---|
| 287 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 288 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 289 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 290 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 291 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 292 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 293 | & ) |
---|
| 294 | |
---|
| 295 | ELSEIF (JB == 19) THEN |
---|
| 296 | CALL SRTM_TAUMOL19 & |
---|
| 297 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 298 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 299 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 300 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 301 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 302 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 303 | & ) |
---|
| 304 | |
---|
| 305 | ELSEIF (JB == 20) THEN |
---|
| 306 | CALL SRTM_TAUMOL20 & |
---|
| 307 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 308 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 309 | & KJP , KJT , KJT1 ,& |
---|
| 310 | & PCOLH2O , PCOLCH4 , PCOLMOL ,& |
---|
| 311 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 312 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 313 | & ) |
---|
| 314 | |
---|
| 315 | ELSEIF (JB == 21) THEN |
---|
| 316 | CALL SRTM_TAUMOL21 & |
---|
| 317 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 318 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 319 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 320 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 321 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 322 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 323 | & ) |
---|
| 324 | |
---|
| 325 | ELSEIF (JB == 22) THEN |
---|
| 326 | CALL SRTM_TAUMOL22 & |
---|
| 327 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 328 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 329 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 330 | & PCOLH2O , PCOLMOL , PCOLO2 ,& |
---|
| 331 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 332 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 333 | & ) |
---|
| 334 | |
---|
| 335 | ELSEIF (JB == 23) THEN |
---|
| 336 | CALL SRTM_TAUMOL23 & |
---|
| 337 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 338 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 339 | & KJP , KJT , KJT1 ,& |
---|
| 340 | & PCOLH2O , PCOLMOL ,& |
---|
| 341 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 342 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 343 | & ) |
---|
| 344 | |
---|
| 345 | ELSEIF (JB == 24) THEN |
---|
| 346 | CALL SRTM_TAUMOL24 & |
---|
| 347 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 348 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 349 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 350 | & PCOLH2O , PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 351 | & KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 352 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 353 | & ) |
---|
| 354 | |
---|
| 355 | ELSEIF (JB == 25) THEN |
---|
| 356 | !--- visible 16000-22650 cm-1 0.4415 - 0.6250 um |
---|
| 357 | CALL SRTM_TAUMOL25 & |
---|
| 358 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 359 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 360 | & KJP , KJT , KJT1 ,& |
---|
| 361 | & PCOLH2O , PCOLMOL , PCOLO3 ,& |
---|
| 362 | & KLAYTROP ,& |
---|
| 363 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 364 | & ) |
---|
| 365 | |
---|
| 366 | ELSEIF (JB == 26) THEN |
---|
| 367 | !--- UV-A 22650-29000 cm-1 0.3448 - 0.4415 um |
---|
| 368 | CALL SRTM_TAUMOL26 & |
---|
| 369 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 370 | & PCOLMOL ,KLAYTROP,& |
---|
| 371 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 372 | & ) |
---|
| 373 | |
---|
| 374 | ELSEIF (JB == 27) THEN |
---|
| 375 | !--- UV-B 29000-38000 cm-1 0.2632 - 0.3448 um |
---|
| 376 | CALL SRTM_TAUMOL27 & |
---|
| 377 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 378 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 379 | & KJP , KJT , KJT1 ,& |
---|
| 380 | & PCOLMOL , PCOLO3 ,& |
---|
| 381 | & KLAYTROP ,& |
---|
| 382 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 383 | & ) |
---|
| 384 | |
---|
| 385 | ELSEIF (JB == 28) THEN |
---|
| 386 | !--- UV-C 38000-50000 cm-1 0.2000 - 0.2632 um |
---|
| 387 | CALL SRTM_TAUMOL28 & |
---|
| 388 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 389 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 390 | & KJP , KJT , KJT1 , PONEMINUS ,& |
---|
| 391 | & PCOLMOL , PCOLO2 , PCOLO3 ,& |
---|
| 392 | & KLAYTROP ,& |
---|
| 393 | & ZSFLXZEN, ZTAUG , ZTAUR , PRMU0 & |
---|
| 394 | & ) |
---|
| 395 | |
---|
| 396 | ELSEIF (JB == 29) THEN |
---|
| 397 | CALL SRTM_TAUMOL29 & |
---|
| 398 | & ( KIDIA , KFDIA , KLEV ,& |
---|
| 399 | & PFAC00 , PFAC01 , PFAC10 , PFAC11 ,& |
---|
| 400 | & KJP , KJT , KJT1 ,& |
---|
| 401 | & PCOLH2O , PCOLCO2 , PCOLMOL ,& |
---|
| 402 | & KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF , PFORFAC, PFORFRAC, KINDFOR ,& |
---|
| 403 | & ZSFLXZEN , ZTAUG , ZTAUR , PRMU0 & |
---|
| 404 | & ) |
---|
| 405 | |
---|
| 406 | ENDIF |
---|
| 407 | |
---|
| 408 | !J---Start--- |
---|
| 409 | DO JK=1,KLEV |
---|
| 410 | IKL=KLEV+1-JK |
---|
| 411 | DO IC=1,ICOUNT |
---|
| 412 | JL=INDEX(IC) |
---|
| 413 | ZPAOJ(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) |
---|
| 414 | ZPTOJ(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) |
---|
| 415 | ENDDO |
---|
| 416 | ENDDO |
---|
| 417 | !J---End--- |
---|
| 418 | |
---|
| 419 | DO JG=1,IGT |
---|
| 420 | DO IC=1,ICOUNT |
---|
| 421 | JL=INDEX(IC) |
---|
| 422 | IW(JL)=IW(JL)+1 |
---|
| 423 | |
---|
| 424 | ZINCFLX(JL,IW(JL)) =ZSFLXZEN(JL,JG)*PRMU0(JL) |
---|
| 425 | ZINCFLUX(JL) =ZINCFLUX(JL)+ZSFLXZEN(JL,JG)*PRMU0(JL) |
---|
| 426 | ZINCTOT(JL) =ZINCTOT(JL)+ZSFLXZEN(JL,JG) |
---|
| 427 | ZINCF14(JL,IBM)=ZINCF14(JL,IBM)+ZSFLXZEN(JL,JG) |
---|
| 428 | |
---|
| 429 | !-- CALL to compute layer reflectances and transmittances for direct |
---|
| 430 | ! and diffuse sources, first clear then cloudy. |
---|
| 431 | ! Use direct/parallel albedo for direct radiation and diffuse albedo |
---|
| 432 | ! otherwise. |
---|
| 433 | |
---|
| 434 | ! ZREFC(JK) direct albedo for clear |
---|
| 435 | ! ZREFO(JK) direct albedo for cloud |
---|
| 436 | ! ZREFDC(JK) diffuse albedo for clear |
---|
| 437 | ! ZREFDO(JK) diffuse albedo for cloud |
---|
| 438 | ! ZTRAC(JK) direct transmittance for clear |
---|
| 439 | ! ZTRAO(JK) direct transmittance for cloudy |
---|
| 440 | ! ZTRADC(JK) diffuse transmittance for clear |
---|
| 441 | ! ZTRADO(JK) diffuse transmittance for cloudy |
---|
| 442 | |
---|
| 443 | ! ZREF(JK) direct reflectance |
---|
| 444 | ! ZREFD(JK) diffuse reflectance |
---|
| 445 | ! ZTRA(JK) direct transmittance |
---|
| 446 | ! ZTRAD(JK) diffuse transmittance |
---|
| 447 | |
---|
| 448 | ! ZDBTC(JK) clear direct beam transmittance |
---|
| 449 | ! ZDBTO(JK) cloudy direct beam transmittance |
---|
| 450 | ! ZDBT(JK) layer mean direct beam transmittance |
---|
| 451 | ! ZTDBT(JK) total direct beam transmittance at levels |
---|
| 452 | |
---|
| 453 | !-- clear-sky |
---|
| 454 | !----- TOA direct beam |
---|
| 455 | ZTDBTC(JL,1)=1._JPRB |
---|
| 456 | !----- surface values |
---|
| 457 | ZDBTC(JL,KLEV+1) =0.0_JPRB |
---|
| 458 | ZTRAC(JL,KLEV+1) =0.0_JPRB |
---|
| 459 | ZTRADC(JL,KLEV+1)=0.0_JPRB |
---|
| 460 | ZREFC(JL,KLEV+1) =PALBP(JL,IBM) |
---|
| 461 | ZREFDC(JL,KLEV+1)=PALBD(JL,IBM) |
---|
| 462 | ZRUPC(JL,KLEV+1) =PALBP(JL,IBM) |
---|
| 463 | ZRUPDC(JL,KLEV+1)=PALBD(JL,IBM) |
---|
| 464 | |
---|
| 465 | !-- total sky |
---|
| 466 | !----- TOA direct beam |
---|
| 467 | ZTDBT(JL,1)=1._JPRB |
---|
| 468 | !----- surface values |
---|
| 469 | ZDBT(JL,KLEV+1) =0.0_JPRB |
---|
| 470 | ZTRA(JL,KLEV+1) =0.0_JPRB |
---|
| 471 | ZTRAD(JL,KLEV+1)=0.0_JPRB |
---|
| 472 | ZREF(JL,KLEV+1) =PALBP(JL,IBM) |
---|
| 473 | ZREFD(JL,KLEV+1)=PALBD(JL,IBM) |
---|
| 474 | ZRUP(JL,KLEV+1) =PALBP(JL,IBM) |
---|
| 475 | ZRUPD(JL,KLEV+1)=PALBD(JL,IBM) |
---|
| 476 | ENDDO |
---|
| 477 | |
---|
| 478 | |
---|
| 479 | !-- NB: a two-stream calculations from top to bottom, but RRTM_SW quantities |
---|
| 480 | ! are given bottom to top (argh!) |
---|
| 481 | ! Inputs for clouds and aerosols are bottom to top as inputs |
---|
| 482 | |
---|
| 483 | ! DO JK=1,KLEV |
---|
| 484 | ! IKL=KLEV+1-JK |
---|
| 485 | ! WRITE(NULOUT,8001) IBM,JG,IKL,(PTAUA(INDEX(IC),IKL,IBM),IC=1,ICOUNT) |
---|
| 486 | 8001 format(1X,'McICA_SW',3I5,30E12.5) |
---|
| 487 | ! ENDDO |
---|
| 488 | |
---|
| 489 | |
---|
| 490 | |
---|
| 491 | DO JK=1,KLEV |
---|
| 492 | IKL=KLEV+1-JK |
---|
| 493 | DO IC=1,ICOUNT |
---|
| 494 | JL=INDEX(IC) |
---|
| 495 | !-- clear-sky optical parameters |
---|
| 496 | LLRTCHK(JL,JK)=.TRUE. |
---|
| 497 | !-- clear-sky optical parameters including aerosols |
---|
| 498 | !J ZTAUC(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM) |
---|
| 499 | !J ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG)*1.0_JPRB + PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) |
---|
| 500 | !J ZGCC(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK) |
---|
| 501 | !J ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK) |
---|
| 502 | !J ENDDO |
---|
| 503 | !J ENDDO |
---|
| 504 | !J DO JK=1,KLEV |
---|
| 505 | !J IKL=KLEV+1-JK |
---|
| 506 | !J DO IC=1,ICOUNT |
---|
| 507 | !J JL=INDEX(IC) |
---|
| 508 | !J !-- total sky optical parameters |
---|
| 509 | !J ZTAUO(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL)) |
---|
| 510 | !J ZOMCO(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) & |
---|
| 511 | !J & + ZTAUR(JL,IKL,JG)*1.0_JPRB |
---|
| 512 | !J ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL)) & |
---|
| 513 | !J & + PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PASYA(JL,IKL,IBM)) & |
---|
| 514 | !J & / ZOMCO(JL,JK) |
---|
| 515 | !J ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK) |
---|
| 516 | |
---|
| 517 | ZTAU = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) |
---|
| 518 | ! ZPAO = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) |
---|
| 519 | ! ZPTO = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) |
---|
| 520 | ZPAO = ZPAOJ(JL,JK) |
---|
| 521 | ZPTO = ZPTOJ(JL,JK) |
---|
| 522 | ZTAUC(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM) |
---|
| 523 | ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG) + ZPTO |
---|
| 524 | ZGCC(JL,JK) = ZPAO*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK) |
---|
| 525 | ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK) |
---|
| 526 | !-- total sky optical parameters |
---|
| 527 | ZTAUO(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL)) |
---|
| 528 | ZOMCO(JL,JK) = ZPTO + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) + ZTAUR(JL,IKL,JG) |
---|
| 529 | ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL)) & |
---|
| 530 | & + PTAUA(JL,IKL,IBM)*ZPAO) / ZOMCO(JL,JK) |
---|
| 531 | ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK) |
---|
| 532 | ENDDO |
---|
| 533 | ENDDO |
---|
| 534 | |
---|
| 535 | !-- Delta scaling for clear-sky / aerosol optical quantities |
---|
| 536 | DO JK=1,KLEV |
---|
| 537 | DO IC=1,ICOUNT |
---|
| 538 | JL=INDEX(IC) |
---|
| 539 | ZF(JL)=ZGCC(JL,JK)*ZGCC(JL,JK) |
---|
| 540 | ZWF(JL)=ZOMCC(JL,JK)*ZF(JL) |
---|
| 541 | ZTAUC(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUC(JL,JK) |
---|
| 542 | ZOMCC(JL,JK)=(ZOMCC(JL,JK)-ZWF(JL))/(1.0_JPRB-ZWF(JL)) |
---|
| 543 | ZGCC(JL,JK)=(ZGCC(JL,JK)-ZF(JL))/(1.0_JPRB-ZF(JL)) |
---|
| 544 | ENDDO |
---|
| 545 | ENDDO |
---|
| 546 | |
---|
| 547 | CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,& |
---|
| 548 | & LLRTCHK, ZGCC , PRMU0, ZTAUC , ZOMCC ,& |
---|
| 549 | & ZREFC , ZREFDC, ZTRAC, ZTRADC ) |
---|
| 550 | |
---|
| 551 | !-- Delta scaling for cloudy quantities |
---|
| 552 | DO JK=1,KLEV |
---|
| 553 | IKL=KLEV+1-JK |
---|
| 554 | DO IC=1,ICOUNT |
---|
| 555 | JL=INDEX(IC) |
---|
| 556 | LLRTCHK(JL,JK)=.FALSE. |
---|
| 557 | ZF(JL)=ZGCO(JL,JK)*ZGCO(JL,JK) |
---|
| 558 | ZWF(JL)=ZOMCO(JL,JK)*ZF(JL) |
---|
| 559 | ZTAUO(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUO(JL,JK) |
---|
| 560 | ZOMCO(JL,JK)=(ZOMCO(JL,JK)-ZWF(JL))/(1._JPRB-ZWF(JL)) |
---|
| 561 | ZGCO(JL,JK)=(ZGCO(JL,JK)-ZF(JL))/(1._JPRB-ZF(JL)) |
---|
| 562 | LLRTCHK(JL,JK)=(PFRCL(JL,IW(JL),IKL) > REPCLC) |
---|
| 563 | ENDDO |
---|
| 564 | ENDDO |
---|
| 565 | |
---|
| 566 | CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,& |
---|
| 567 | & LLRTCHK, ZGCO , PRMU0, ZTAUO , ZOMCO ,& |
---|
| 568 | & ZREFO , ZREFDO, ZTRAO, ZTRADO ) |
---|
| 569 | |
---|
| 570 | !J---Start--- |
---|
| 571 | DO IC=1,ICOUNT |
---|
| 572 | JL=INDEX(IC) |
---|
| 573 | ZRMU0D(JL)=1.0_JPRB/PRMU0(JL) |
---|
| 574 | ENDDO |
---|
| 575 | !J---End--- |
---|
| 576 | |
---|
| 577 | DO JK=1,KLEV |
---|
| 578 | IKL=KLEV+1-JK |
---|
| 579 | DO IC=1,ICOUNT |
---|
| 580 | JL=INDEX(IC) |
---|
| 581 | !-- combine clear and cloudy contributions for total sky |
---|
| 582 | |
---|
| 583 | ZCLEAR(JL) = 1.0_JPRB - PFRCL(JL,IW(JL),IKL) |
---|
| 584 | ZCLOUD(JL) = PFRCL(JL,IW(JL),IKL) |
---|
| 585 | |
---|
| 586 | ZREF(JL,JK) = ZCLEAR(JL)*ZREFC(JL,JK) + ZCLOUD(JL)*ZREFO(JL,JK) |
---|
| 587 | ZREFD(JL,JK)= ZCLEAR(JL)*ZREFDC(JL,JK)+ ZCLOUD(JL)*ZREFDO(JL,JK) |
---|
| 588 | ZTRA(JL,JK) = ZCLEAR(JL)*ZTRAC(JL,JK) + ZCLOUD(JL)*ZTRAO(JL,JK) |
---|
| 589 | ZTRAD(JL,JK)= ZCLEAR(JL)*ZTRADC(JL,JK)+ ZCLOUD(JL)*ZTRADO(JL,JK) |
---|
| 590 | |
---|
| 591 | !-- direct beam transmittance |
---|
| 592 | ! ZARG1(JL) = MIN( 200._JPRB, ZTAUC(JL,JK)/PRMU0(JL) ) |
---|
| 593 | ! ZARG2(JL) = MIN( 200._JPRB, ZTAUO(JL,JK)/PRMU0(JL) ) |
---|
| 594 | ! ZDBTMC(JL) = EXP(-ZARG1(JL) ) |
---|
| 595 | ! ZDBTMO(JL) = EXP(-ZARG2(JL) ) |
---|
| 596 | |
---|
| 597 | !-- Use exponential look-up table for transmittance, or expansion of exponential for |
---|
| 598 | ! low optical thickness |
---|
| 599 | !J ZE1 = ZTAUC(JL,JK)/PRMU0(JL) |
---|
| 600 | ZE1 = ZTAUC(JL,JK)*ZRMU0D(JL) |
---|
| 601 | IF (ZE1 <= RODLOW) THEN |
---|
| 602 | ZDBTMC(JL) = 1._JPRB - ZE1 + 0.5_JPRB*ZE1*ZE1 |
---|
| 603 | ELSE |
---|
| 604 | ZTBLIND = ZE1 / (BPADE+ZE1) |
---|
| 605 | ITIND = RTBLINT * ZTBLIND + 0.5_JPRB |
---|
| 606 | ZDBTMC(JL) = TRANS(ITIND) |
---|
| 607 | ENDIF |
---|
| 608 | |
---|
| 609 | !J ZE2 = ZTAUO(JL,JK)/PRMU0(JL) |
---|
| 610 | ZE2 = ZTAUO(JL,JK)*ZRMU0D(JL) |
---|
| 611 | IF (ZE2 <= RODLOW) THEN |
---|
| 612 | ZDBTMO(JL) = 1._JPRB - ZE2 + 0.5_JPRB*ZE2*ZE2 |
---|
| 613 | ELSE |
---|
| 614 | ZTBLIND = ZE2 / (BPADE+ZE2) |
---|
| 615 | ITIND = RTBLINT * ZTBLIND + 0.5_JPRB |
---|
| 616 | ZDBTMO(JL) = TRANS(ITIND) |
---|
| 617 | ENDIF |
---|
| 618 | !--- |
---|
| 619 | |
---|
| 620 | ZDBT(JL,JK) = ZCLEAR(JL)*ZDBTMC(JL)+ZCLOUD(JL)*ZDBTMO(JL) |
---|
| 621 | ZTDBT(JL,JK+1)= ZDBT(JL,JK)*ZTDBT(JL,JK) |
---|
| 622 | |
---|
| 623 | !-- clear-sky |
---|
| 624 | ZDBTC(JL,JK) =ZDBTMC(JL) |
---|
| 625 | ZTDBTC(JL,JK+1)=ZDBTC(JL,JK)*ZTDBTC(JL,JK) |
---|
| 626 | |
---|
| 627 | ENDDO |
---|
| 628 | ENDDO |
---|
| 629 | |
---|
| 630 | !-- vertical quadrature producing clear-sky fluxes |
---|
| 631 | |
---|
| 632 | ! print *,'SRTM_SPCVRT after 3 before SRTM_VRTQDR clear' |
---|
| 633 | |
---|
| 634 | CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,& |
---|
| 635 | & ZREFC, ZREFDC, ZTRAC , ZTRADC ,& |
---|
| 636 | & ZDBTC, ZRDNDC, ZRUPC , ZRUPDC, ZTDBTC ,& |
---|
| 637 | & ZCD , ZCU , PRMU0 ) |
---|
| 638 | |
---|
| 639 | !-- vertical quadrature producing cloudy fluxes |
---|
| 640 | |
---|
| 641 | CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,& |
---|
| 642 | & ZREF , ZREFD , ZTRA , ZTRAD ,& |
---|
| 643 | & ZDBT , ZRDND , ZRUP , ZRUPD , ZTDBT ,& |
---|
| 644 | & ZFD , ZFU , PRMU0) |
---|
| 645 | |
---|
| 646 | !-- up and down-welling fluxes at levels |
---|
| 647 | DO JK=1,KLEV+1 |
---|
| 648 | DO IC=1,ICOUNT |
---|
| 649 | JL=INDEX(IC) |
---|
| 650 | !-- accumulation of spectral fluxes |
---|
| 651 | PBBFU(JL,JK) = PBBFU(JL,JK) + ZINCFLX(JL,IW(JL))*ZFU(JL,JK,IW(JL)) |
---|
| 652 | PBBFD(JL,JK) = PBBFD(JL,JK) + ZINCFLX(JL,IW(JL))*ZFD(JL,JK,IW(JL)) |
---|
| 653 | PBBCU(JL,JK) = PBBCU(JL,JK) + ZINCFLX(JL,IW(JL))*ZCU(JL,JK,IW(JL)) |
---|
| 654 | PBBCD(JL,JK) = PBBCD(JL,JK) + ZINCFLX(JL,IW(JL))*ZCD(JL,JK,IW(JL)) |
---|
| 655 | |
---|
| 656 | PBBFDIR(JL,JK)=PBBFDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBT (JL,JK) |
---|
| 657 | PBBCDIR(JL,JK)=PBBCDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBTC(JL,JK) |
---|
| 658 | |
---|
| 659 | ENDDO |
---|
| 660 | ENDDO |
---|
| 661 | DO IC=1,ICOUNT |
---|
| 662 | JL=INDEX(IC) |
---|
| 663 | IF ( JB >= 26 .AND. JB <= 28 ) THEN |
---|
| 664 | PFUVF(JL) = PFUVF(JL) + ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL)) |
---|
| 665 | PFUVC(JL) = PFUVC(JL) + ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL)) |
---|
| 666 | ENDIF |
---|
| 667 | IF ( JB == 23) THEN |
---|
| 668 | PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL))*ZCOEFVS |
---|
| 669 | PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL))*ZCOEFVS |
---|
| 670 | ENDIF |
---|
| 671 | IF ( JB == 24) THEN |
---|
| 672 | PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL)) |
---|
| 673 | PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL)) |
---|
| 674 | ENDIF |
---|
| 675 | PSUDU(JL) = PSUDU(JL) + ZINCFLX(JL,IW(JL))*ZTDBT(JL,KLEV+1) |
---|
| 676 | ENDDO |
---|
| 677 | |
---|
| 678 | ! Store the shortwave downwelling fluxes in each band |
---|
| 679 | IF (LApproxSwUpdate) THEN |
---|
| 680 | JB_ALBEDO = NMPSRTM(JB-IB1+1) |
---|
| 681 | DO IC = 1,ICOUNT |
---|
| 682 | JL = INDEX(IC) |
---|
| 683 | PSwDiffuseBand(JL,JB_ALBEDO)= PSwDiffuseBand(JL,JB_ALBEDO) & |
---|
| 684 | & + ZINCFLX(JL,IW(JL)) * (ZFD(JL, KLEV+1, IW(JL))-ZTDBT(JL,KLEV+1)) |
---|
| 685 | PSwDirectBand(JL,JB_ALBEDO) = PSwDirectBand(JL,JB_ALBEDO) & |
---|
| 686 | & + ZINCFLX(JL,IW(JL)) * ZTDBT(JL,KLEV+1) |
---|
| 687 | ENDDO |
---|
| 688 | ENDIF |
---|
| 689 | |
---|
| 690 | ENDDO |
---|
| 691 | !-- end loop on JG |
---|
| 692 | |
---|
| 693 | ENDDO |
---|
| 694 | !-- end loop on JB |
---|
| 695 | |
---|
| 696 | ! ------------------------------------------------------------------ |
---|
| 697 | IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE) |
---|
| 698 | END ASSOCIATE |
---|
| 699 | END SUBROUTINE SRTM_SPCVRT_MCICA |
---|