| [3990] | 1 | SUBROUTINE SW & |
|---|
| 2 | &( KIDIA, KFDIA , KLON , KLEV , KAER & |
|---|
| 3 | &, PSCT , PCARDI, PPSOL , PALBD, PALBP , PWV, PQS & |
|---|
| 4 | &, PRMU0, PCG , PCLDSW, PDP , POMEGA, POZ, PPMB & |
|---|
| 5 | &, PTAU , PTAVE , PAER & |
|---|
| 6 | &, PHEAT, PFDOWN, PFUP & |
|---|
| 7 | &, PCEAT, PCDOWN, PCUP & |
|---|
| 8 | &, PFDNN, PFDNV , PFUPN, PFUPV & |
|---|
| 9 | &, PCDNN, PCDNV , PCUPN, PCUPV & |
|---|
| 10 | &, PSUDU, PUVDF , PPARF & |
|---|
| 11 | &) |
|---|
| 12 | |
|---|
| 13 | !**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES. |
|---|
| 14 | |
|---|
| 15 | ! PURPOSE. |
|---|
| 16 | ! -------- |
|---|
| 17 | |
|---|
| 18 | ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO |
|---|
| 19 | ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). |
|---|
| 20 | |
|---|
| 21 | !** INTERFACE. |
|---|
| 22 | ! ---------- |
|---|
| 23 | |
|---|
| 24 | ! *SW* IS CALLED FROM *RADLSW* |
|---|
| 25 | |
|---|
| 26 | |
|---|
| 27 | ! IMPLICIT ARGUMENTS : |
|---|
| 28 | ! -------------------- |
|---|
| 29 | |
|---|
| 30 | ! ==== INPUTS === |
|---|
| 31 | ! ==== OUTPUTS === |
|---|
| 32 | |
|---|
| 33 | ! METHOD. |
|---|
| 34 | ! ------- |
|---|
| 35 | |
|---|
| 36 | ! 1. COMPUTES ABSORBER AMOUNTS (SWU) |
|---|
| 37 | ! 2. COMPUTES FLUXES IN U.V./VISIBLE SPECTRAL INTERVAL (SW1S) |
|---|
| 38 | ! 3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI) |
|---|
| 39 | |
|---|
| 40 | ! EXTERNALS. |
|---|
| 41 | ! ---------- |
|---|
| 42 | |
|---|
| 43 | ! *SWU*, *SW1S*, *SWNI* |
|---|
| 44 | |
|---|
| 45 | ! REFERENCE. |
|---|
| 46 | ! ---------- |
|---|
| 47 | |
|---|
| 48 | ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT |
|---|
| 49 | ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) |
|---|
| 50 | |
|---|
| 51 | ! AUTHOR. |
|---|
| 52 | ! ------- |
|---|
| 53 | ! JEAN-JACQUES MORCRETTE *ECMWF* |
|---|
| 54 | |
|---|
| 55 | ! MODIFICATIONS. |
|---|
| 56 | ! -------------- |
|---|
| 57 | ! ORIGINAL : 89-07-14 |
|---|
| 58 | ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo |
|---|
| 59 | ! 95-12-07 J.-J. MORCRETTE Near-Infrared in nsw-1 Intervals |
|---|
| 60 | ! 990128 JJMorcrette sunshine duration |
|---|
| 61 | ! 99-05-25 JJMorcrette Revised aerosols |
|---|
| 62 | ! 00-12-18 JJMorcrette 6 spectral intervals |
|---|
| 63 | |
|---|
| 64 | ! ------------------------------------------------------------------ |
|---|
| 65 | |
|---|
| 66 | |
|---|
| 67 | #include "tsmbkind.h" |
|---|
| 68 | |
|---|
| 69 | USE YOERAD , ONLY : NSW |
|---|
| 70 | USE YOERDU , ONLY : RCDAY |
|---|
| 71 | |
|---|
| 72 | |
|---|
| 73 | IMPLICIT NONE |
|---|
| 74 | |
|---|
| 75 | |
|---|
| 76 | ! DUMMY INTEGER SCALARS |
|---|
| 77 | INTEGER_M :: KAER |
|---|
| 78 | INTEGER_M :: KFDIA |
|---|
| 79 | INTEGER_M :: KIDIA |
|---|
| 80 | INTEGER_M :: KLEV |
|---|
| 81 | INTEGER_M :: KLON |
|---|
| 82 | |
|---|
| 83 | ! DUMMY REAL SCALARS |
|---|
| 84 | REAL_B :: PCARDI |
|---|
| 85 | REAL_B :: PSCT |
|---|
| 86 | |
|---|
| 87 | |
|---|
| 88 | |
|---|
| 89 | ! ------------------------------------------------------------------ |
|---|
| 90 | |
|---|
| 91 | !* 0.1 ARGUMENTS |
|---|
| 92 | ! --------- |
|---|
| 93 | |
|---|
| 94 | REAL_B :: PPSOL(KLON), PAER(KLON,6,KLEV),PRMU0(KLON)& |
|---|
| 95 | &, PWV(KLON,KLEV),PQS(KLON,KLEV) |
|---|
| 96 | |
|---|
| 97 | REAL_B :: PALBD(KLON,NSW) , PALBP(KLON,NSW)& |
|---|
| 98 | &, PCG(KLON,NSW,KLEV) , PCLDSW(KLON,KLEV)& |
|---|
| 99 | &, PDP(KLON,KLEV) & |
|---|
| 100 | &, POMEGA(KLON,NSW,KLEV), POZ(KLON,KLEV)& |
|---|
| 101 | &, PPMB(KLON,KLEV+1)& |
|---|
| 102 | &, PTAU(KLON,NSW,KLEV) , PTAVE(KLON,KLEV) |
|---|
| 103 | |
|---|
| 104 | REAL_B :: PHEAT(KLON,KLEV), PFDOWN(KLON,KLEV+1), PFUP(KLON,KLEV+1),& |
|---|
| 105 | &PFUPV(KLON), PFUPN(KLON), PFDNV(KLON), PFDNN(KLON)& |
|---|
| 106 | &, PCEAT(KLON,KLEV), PCDOWN(KLON,KLEV+1), PCUP(KLON,KLEV+1)& |
|---|
| 107 | &, PCUPV(KLON), PCUPN(KLON), PCDNV(KLON), PCDNN(KLON)& |
|---|
| 108 | &, PSUDU(KLON), PUVDF(KLON), PPARF(KLON) |
|---|
| 109 | |
|---|
| 110 | ! ------------------------------------------------------------------ |
|---|
| 111 | |
|---|
| 112 | !* 0.2 LOCAL ARRAYS |
|---|
| 113 | ! ------------ |
|---|
| 114 | |
|---|
| 115 | REAL_B :: ZAKI(KLON,2,NSW)& |
|---|
| 116 | &, ZCLD(KLON,KLEV) , ZCLEAR(KLON) & |
|---|
| 117 | &, ZDSIG(KLON,KLEV) , ZFACT(KLON)& |
|---|
| 118 | &, ZFD(KLON,KLEV+1) , ZCD(KLON,KLEV+1)& |
|---|
| 119 | &, ZCDOWN(KLON,KLEV+1), ZCDNIR(KLON,KLEV+1), ZCDUVS(KLON,KLEV+1)& |
|---|
| 120 | &, ZFDOWN(KLON,KLEV+1), ZFDNIR(KLON,KLEV+1), ZFDUVS(KLON,KLEV+1)& |
|---|
| 121 | &, ZFU(KLON,KLEV+1) , ZCU(KLON,KLEV+1)& |
|---|
| 122 | &, ZCUP(KLON,KLEV+1) , ZCUNIR(KLON,KLEV+1), ZCUUVS(KLON,KLEV+1)& |
|---|
| 123 | &, ZFUP(KLON,KLEV+1) , ZFUNIR(KLON,KLEV+1), ZFUUVS(KLON,KLEV+1)& |
|---|
| 124 | &, ZRMU(KLON) , ZSEC(KLON) & |
|---|
| 125 | &, ZSUDU1(KLON) , ZSUDU2(KLON) & |
|---|
| 126 | &, ZSUDU1T(KLON) , ZSUDU2T(KLON) & |
|---|
| 127 | &, ZUD(KLON,5,KLEV+1) |
|---|
| 128 | |
|---|
| 129 | ! LOCAL INTEGER SCALARS |
|---|
| 130 | INTEGER_M :: INU, JK, JKL, JL, JNU, INUVS, INUIR |
|---|
| 131 | |
|---|
| 132 | ! LOCAL REAL SCALARS |
|---|
| 133 | REAL_B :: ZDCNET, ZDFNET |
|---|
| 134 | |
|---|
| 135 | |
|---|
| 136 | ! ------------------------------------------------------------------ |
|---|
| 137 | |
|---|
| 138 | !* 1. ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES |
|---|
| 139 | ! -------------------------------------------- |
|---|
| 140 | |
|---|
| 141 | CALL SWU ( KIDIA,KFDIA ,KLON ,KLEV & |
|---|
| 142 | &, PSCT ,PCARDI,PCLDSW,PPMB ,PPSOL & |
|---|
| 143 | &, PRMU0,PTAVE ,PWV & |
|---|
| 144 | &, ZAKI ,ZCLD ,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD ) |
|---|
| 145 | |
|---|
| 146 | !print *,'After SWU' |
|---|
| 147 | |
|---|
| 148 | ! ------------------------------------------------------------------ |
|---|
| 149 | |
|---|
| 150 | !* 2. INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE |
|---|
| 151 | ! --------------------------------------------------- |
|---|
| 152 | |
|---|
| 153 | IF (NSW.LE.4) THEN |
|---|
| 154 | INUVS=1 |
|---|
| 155 | INUIR=2 |
|---|
| 156 | ELSE IF (NSW.EQ.6) THEN |
|---|
| 157 | INUVS=1 |
|---|
| 158 | INUIR=4 |
|---|
| 159 | END IF |
|---|
| 160 | |
|---|
| 161 | DO JK = 1 , KLEV+1 |
|---|
| 162 | DO JL = KIDIA,KFDIA |
|---|
| 163 | ZFD(JL,JK) =_ZERO_ |
|---|
| 164 | ZFU(JL,JK) =_ZERO_ |
|---|
| 165 | ZCD(JL,JK) =_ZERO_ |
|---|
| 166 | ZCU(JL,JK) =_ZERO_ |
|---|
| 167 | ZSUDU1T(JL)=_ZERO_ |
|---|
| 168 | PUVDF(JL) =_ZERO_ |
|---|
| 169 | PPARF(JL) =_ZERO_ |
|---|
| 170 | ENDDO |
|---|
| 171 | ENDDO |
|---|
| 172 | |
|---|
| 173 | DO JNU = INUVS , INUIR-1 |
|---|
| 174 | |
|---|
| 175 | CALL SW1S & |
|---|
| 176 | &( KIDIA , KFDIA, KLON , KLEV , KAER , JNU & |
|---|
| 177 | &, PAER , PALBD , PALBP, PCG , ZCLD , ZCLEAR & |
|---|
| 178 | &, ZDSIG, POMEGA, POZ , ZRMU , ZSEC , PTAU , ZUD & |
|---|
| 179 | &, ZFDUVS,ZFUUVS, ZCDUVS,ZCUUVS, ZSUDU1 & |
|---|
| 180 | &) |
|---|
| 181 | |
|---|
| 182 | DO JK = 1 , KLEV+1 |
|---|
| 183 | DO JL = KIDIA,KFDIA |
|---|
| 184 | ZFD(JL,JK)=ZFD(JL,JK)+ZFDUVS(JL,JK) |
|---|
| 185 | ZFU(JL,JK)=ZFU(JL,JK)+ZFUUVS(JL,JK) |
|---|
| 186 | ZCD(JL,JK)=ZCD(JL,JK)+ZCDUVS(JL,JK) |
|---|
| 187 | ZCU(JL,JK)=ZCU(JL,JK)+ZCUUVS(JL,JK) |
|---|
| 188 | ENDDO |
|---|
| 189 | ENDDO |
|---|
| 190 | DO JL = KIDIA,KFDIA |
|---|
| 191 | ZSUDU1T(JL)=ZSUDU1T(JL)+ZSUDU1(JL) |
|---|
| 192 | ENDDO |
|---|
| 193 | |
|---|
| 194 | IF (NSW.EQ.6) THEN |
|---|
| 195 | IF (JNU.LT.INUIR-1) THEN |
|---|
| 196 | DO JL=KIDIA,KFDIA |
|---|
| 197 | PUVDF(JL)=PUVDF(JL)+ZFDUVS(JL,1) |
|---|
| 198 | END DO |
|---|
| 199 | ELSE |
|---|
| 200 | DO JL=KIDIA,KFDIA |
|---|
| 201 | PPARF(JL)=PPARF(JL)+ZFDUVS(JL,1) |
|---|
| 202 | END DO |
|---|
| 203 | END IF |
|---|
| 204 | END IF |
|---|
| 205 | |
|---|
| 206 | ENDDO |
|---|
| 207 | !print *,'After SW1S' |
|---|
| 208 | ! ------------------------------------------------------------------ |
|---|
| 209 | |
|---|
| 210 | !* 3. INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED |
|---|
| 211 | ! ------------------------------------------ |
|---|
| 212 | |
|---|
| 213 | |
|---|
| 214 | DO JK = 1 , KLEV+1 |
|---|
| 215 | DO JL = KIDIA,KFDIA |
|---|
| 216 | ZFDOWN(JL,JK)=_ZERO_ |
|---|
| 217 | ZFUP (JL,JK)=_ZERO_ |
|---|
| 218 | ZCDOWN(JL,JK)=_ZERO_ |
|---|
| 219 | ZCUP (JL,JK)=_ZERO_ |
|---|
| 220 | ZSUDU2T(JL) =_ZERO_ |
|---|
| 221 | ENDDO |
|---|
| 222 | ENDDO |
|---|
| 223 | |
|---|
| 224 | DO JNU = INUIR , NSW |
|---|
| 225 | |
|---|
| 226 | CALL SWNI & |
|---|
| 227 | &( KIDIA ,KFDIA , KLON , KLEV , KAER , JNU & |
|---|
| 228 | &, PAER ,ZAKI , PALBD, PALBP, PCG , ZCLD, ZCLEAR & |
|---|
| 229 | &, ZDSIG ,POMEGA, POZ , ZRMU , ZSEC , PTAU, ZUD & |
|---|
| 230 | &, PWV ,PQS & |
|---|
| 231 | &, ZFDNIR,ZFUNIR,ZCDNIR,ZCUNIR,ZSUDU2 & |
|---|
| 232 | &) |
|---|
| 233 | |
|---|
| 234 | DO JK = 1 , KLEV+1 |
|---|
| 235 | DO JL = KIDIA,KFDIA |
|---|
| 236 | ZFDOWN(JL,JK)=ZFDOWN(JL,JK)+ZFDNIR(JL,JK) |
|---|
| 237 | ZFUP (JL,JK)=ZFUP (JL,JK)+ZFUNIR(JL,JK) |
|---|
| 238 | ZCDOWN(JL,JK)=ZCDOWN(JL,JK)+ZCDNIR(JL,JK) |
|---|
| 239 | ZCUP (JL,JK)=ZCUP (JL,JK)+ZCUNIR(JL,JK) |
|---|
| 240 | ENDDO |
|---|
| 241 | ENDDO |
|---|
| 242 | DO JL = KIDIA,KFDIA |
|---|
| 243 | ZSUDU2T(JL)=ZSUDU2T(JL)+ZSUDU2(JL) |
|---|
| 244 | ENDDO |
|---|
| 245 | ENDDO |
|---|
| 246 | |
|---|
| 247 | ! ------------------------------------------------------------------ |
|---|
| 248 | |
|---|
| 249 | !* 4. FILL THE DIAGNOSTIC ARRAYS |
|---|
| 250 | ! -------------------------- |
|---|
| 251 | |
|---|
| 252 | |
|---|
| 253 | DO JL = KIDIA,KFDIA |
|---|
| 254 | PFDNN(JL)=ZFDOWN(JL,1)*ZFACT(JL) |
|---|
| 255 | PFDNV(JL)=ZFD(JL,1)*ZFACT(JL) |
|---|
| 256 | PFUPN(JL)=ZFUP(JL,KLEV+1)*ZFACT(JL) |
|---|
| 257 | PFUPV(JL)=ZFU(JL,KLEV+1)*ZFACT(JL) |
|---|
| 258 | |
|---|
| 259 | PCDNN(JL)=ZCDOWN(JL,1)*ZFACT(JL) |
|---|
| 260 | PCDNV(JL)=ZCD(JL,1)*ZFACT(JL) |
|---|
| 261 | PCUPN(JL)=ZCUP(JL,KLEV+1)*ZFACT(JL) |
|---|
| 262 | PCUPV(JL)=ZCU(JL,KLEV+1)*ZFACT(JL) |
|---|
| 263 | |
|---|
| 264 | PSUDU(JL)=(ZSUDU1T(JL)+ZSUDU2T(JL))*ZFACT(JL) |
|---|
| 265 | PUVDF(JL)=PUVDF(JL)*ZFACT(JL) |
|---|
| 266 | PPARF(JL)=PPARF(JL)*ZFACT(JL) |
|---|
| 267 | ENDDO |
|---|
| 268 | |
|---|
| 269 | DO JK = 1 , KLEV+1 |
|---|
| 270 | DO JL = KIDIA,KFDIA |
|---|
| 271 | PFUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) |
|---|
| 272 | PFDOWN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) |
|---|
| 273 | PCUP(JL,JK) = (ZCUP(JL,JK) + ZCU(JL,JK)) * ZFACT(JL) |
|---|
| 274 | PCDOWN(JL,JK) = (ZCDOWN(JL,JK) + ZCD(JL,JK)) * ZFACT(JL) |
|---|
| 275 | ENDDO |
|---|
| 276 | ENDDO |
|---|
| 277 | |
|---|
| 278 | DO JKL = 1 , KLEV |
|---|
| 279 | JK = KLEV+1 - JKL |
|---|
| 280 | DO JL = KIDIA,KFDIA |
|---|
| 281 | ZDFNET = PFUP(JL,JK+1) - PFDOWN(JL,JK+1)-PFUP(JL,JK ) + PFDOWN(JL,JK ) |
|---|
| 282 | PHEAT(JL,JK) = RCDAY * ZDFNET / PDP(JL,JKL) |
|---|
| 283 | ZDCNET = PCUP(JL,JK+1) - PCDOWN(JL,JK+1)-PCUP(JL,JK ) + PCDOWN(JL,JK ) |
|---|
| 284 | PCEAT(JL,JK) = RCDAY * ZDCNET / PDP(JL,JKL) |
|---|
| 285 | ENDDO |
|---|
| 286 | ENDDO |
|---|
| 287 | |
|---|
| 288 | ! ------------------------------------------------------------------ |
|---|
| 289 | |
|---|
| 290 | RETURN |
|---|
| 291 | END SUBROUTINE SW |
|---|
