Changeset 1992 for LMDZ5/trunk/libf/phylmd/radiation_AR4.F90
- Timestamp:
- Mar 5, 2014, 2:19:12 PM (10 years ago)
- File:
-
- 1 moved
-
LMDZ5/trunk/libf/phylmd/radiation_AR4.F90 (moved) (moved from LMDZ5/trunk/libf/phylmd/radiation_AR4.F) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ5/trunk/libf/phylmd/radiation_AR4.F90
r1988 r1992 1 cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 2 SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC, 3 S PPMB, PDP, 4 S PPSOL, PALBD, PALBP, 5 S PTAVE, PWV, PQS, POZON, PAER, 6 S PCLDSW, PTAU, POMEGA, PCG, 7 S PHEAT, PHEAT0, 8 S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0, 9 S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0, 10 S tauae, pizae, cgae, 11 s PTAUA, POMEGAA, 12 S PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI, 13 J ok_ade, ok_aie ) 14 USE dimphy 15 IMPLICIT none 16 17 cym#include "dimensions.h" 18 cym#include "dimphy.h" 19 cym#include "raddim.h" 20 #include "YOMCST.h" 21 #include "iniprint.h" 22 C 23 C ------------------------------------------------------------------ 24 C 25 C PURPOSE. 26 C -------- 27 C 28 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO 29 C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). 30 C 31 C METHOD. 32 C ------- 33 C 34 C 1. COMPUTES ABSORBER AMOUNTS (SWU) 35 C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) 36 C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) 37 C 38 C REFERENCE. 39 C ---------- 40 C 41 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 42 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 43 C 44 C AUTHOR. 45 C ------- 46 C JEAN-JACQUES MORCRETTE *ECMWF* 47 C 48 C MODIFICATIONS. 49 C -------------- 50 C ORIGINAL : 89-07-14 51 C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo 52 c 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) 53 C ------------------------------------------------------------------ 54 C 55 C* ARGUMENTS: 56 C 57 REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370) 58 cIM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97) 59 #include "clesphys.h" 60 C 61 REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA) 62 REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA) 63 REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) 64 C 65 REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE 66 REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee 67 C 68 REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) 69 REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG) 70 REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG) 71 REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG) 72 REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS 73 C 74 REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse) 75 REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele) 76 C 77 REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION 78 REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS 79 REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR 80 REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO 81 C 82 REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY) 83 REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky 84 REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO 85 REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A. 86 REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE 87 REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) 88 REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) 89 C 90 C* LOCAL VARIABLES: 91 C 92 real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 93 94 REAL(KIND=8) ZOZ(KDLON,KFLEV) 95 ! column-density of ozone in layer, in kilo-Dobsons 96 97 REAL(KIND=8) ZAKI(KDLON,2) 98 REAL(KIND=8) ZCLD(KDLON,KFLEV) 99 REAL(KIND=8) ZCLEAR(KDLON) 100 REAL(KIND=8) ZDSIG(KDLON,KFLEV) 101 REAL(KIND=8) ZFACT(KDLON) 102 REAL(KIND=8) ZFD(KDLON,KFLEV+1) 103 REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1) 104 REAL(KIND=8) ZFU(KDLON,KFLEV+1) 105 REAL(KIND=8) ZFUP(KDLON,KFLEV+1) 106 REAL(KIND=8) ZRMU(KDLON) 107 REAL(KIND=8) ZSEC(KDLON) 108 REAL(KIND=8) ZUD(KDLON,5,KFLEV+1) 109 REAL(KIND=8) ZCLDSW0(KDLON,KFLEV) 110 c 111 REAL(KIND=8) ZFSUP(KDLON,KFLEV+1) 112 REAL(KIND=8) ZFSDN(KDLON,KFLEV+1) 113 REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1) 114 REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1) 115 C 116 INTEGER inu, jl, jk, i, k, kpl1 117 c 118 INTEGER swpas ! Every swpas steps, sw is calculated 119 PARAMETER(swpas=1) 120 c 121 INTEGER itapsw 122 LOGICAL appel1er 123 DATA itapsw /0/ 124 DATA appel1er /.TRUE./ 125 SAVE itapsw,appel1er 126 c$OMP THREADPRIVATE(appel1er) 127 c$OMP THREADPRIVATE(itapsw) 128 cjq-Introduced for aerosol forcings 129 real(kind=8) flag_aer 130 logical ok_ade, ok_aie ! use aerosol forcings or not? 131 real(kind=8) tauae(kdlon,kflev,2) ! aerosol optical properties 132 real(kind=8) pizae(kdlon,kflev,2) ! (see aeropt.F) 133 real(kind=8) cgae(kdlon,kflev,2) ! -"- 134 REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value) 135 REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO 136 REAL(KIND=8) PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) 137 REAL(KIND=8) PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) 138 REAL(KIND=8) PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) 139 REAL(KIND=8) PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) 140 cjq - Fluxes including aerosol effects 141 REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:) 142 c$OMP THREADPRIVATE(ZFSUPAD) 143 REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:) 144 c$OMP THREADPRIVATE(ZFSDNAD) 145 REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:) 146 c$OMP THREADPRIVATE(ZFSUPAI) 147 REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:) 148 c$OMP THREADPRIVATE(ZFSDNAI) 149 logical initialized 150 cym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes 151 !rv 152 save flag_aer 153 c$OMP THREADPRIVATE(flag_aer) 154 data initialized/.false./ 155 save initialized 156 c$OMP THREADPRIVATE(initialized) 157 cjq-end 158 REAL tmp_ 159 if(.not.initialized) then 160 flag_aer=0. 161 initialized=.TRUE. 162 allocate(ZFSUPAD(KDLON,KFLEV+1)) 163 allocate(ZFSDNAD(KDLON,KFLEV+1)) 164 allocate(ZFSUPAI(KDLON,KFLEV+1)) 165 allocate(ZFSDNAI(KDLON,KFLEV+1)) 166 167 ZFSUPAD(:,:)=0. 168 ZFSDNAD(:,:)=0. 169 ZFSUPAI(:,:)=0. 170 ZFSDNAI(:,:)=0. 171 endif 172 173 IF (appel1er) THEN 174 WRITE(lunout,*) 'SW calling frequency : ', swpas 175 WRITE(lunout,*) " In general, it should be 1" 176 appel1er = .FALSE. 177 ENDIF 178 C ------------------------------------------------------------------ 179 IF (MOD(itapsw,swpas).EQ.0) THEN 180 c 181 tmp_ = 1./( dobson_u * 1e3 * RG) 182 !cdir collapse 183 DO JK = 1 , KFLEV 184 DO JL = 1, KDLON 185 ZCLDSW0(JL,JK) = 0.0 186 ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK) 187 ENDDO 188 ENDDO 189 C 190 C 191 c clear-sky: 192 cIM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, 193 CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL, 194 S PRMU0,PFRAC,PTAVE,PWV, 195 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) 196 INU = 1 197 CALL SW1S_LMDAR4(INU, 198 S PAER, flag_aer, tauae, pizae, cgae, 199 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, 200 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 201 S ZFD, ZFU) 202 INU = 2 203 CALL SW2S_LMDAR4(INU, 204 S PAER, flag_aer, tauae, pizae, cgae, 205 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0, 206 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 207 S PWV, PQS, 208 S ZFDOWN, ZFUP) 209 DO JK = 1 , KFLEV+1 210 DO JL = 1, KDLON 211 ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) 212 ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 213 ENDDO 214 ENDDO 215 216 flag_aer=0.0 217 CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, 218 S PRMU0,PFRAC,PTAVE,PWV, 219 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) 220 INU = 1 221 CALL SW1S_LMDAR4(INU, 222 S PAER, flag_aer, tauae, pizae, cgae, 223 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 224 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 225 S ZFD, ZFU) 226 INU = 2 227 CALL SW2S_LMDAR4(INU, 228 S PAER, flag_aer, tauae, pizae, cgae, 229 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 230 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 231 S PWV, PQS, 232 S ZFDOWN, ZFUP) 233 234 c cloudy-sky: 235 236 DO JK = 1 , KFLEV+1 237 DO JL = 1, KDLON 238 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) 239 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 240 ENDDO 241 ENDDO 242 243 c 244 IF (ok_ade) THEN 245 c 246 c cloudy-sky + aerosol dir OB 247 flag_aer=1.0 248 CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, 249 S PRMU0,PFRAC,PTAVE,PWV, 250 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) 251 INU = 1 252 CALL SW1S_LMDAR4(INU, 253 S PAER, flag_aer, tauae, pizae, cgae, 254 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 255 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 256 S ZFD, ZFU) 257 INU = 2 258 CALL SW2S_LMDAR4(INU, 259 S PAER, flag_aer, tauae, pizae, cgae, 260 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 261 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD, 262 S PWV, PQS, 263 S ZFDOWN, ZFUP) 264 DO JK = 1 , KFLEV+1 265 DO JL = 1, KDLON 266 ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 267 ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 268 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) 269 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 270 ENDDO 271 ENDDO 272 273 ENDIF ! ok_ade 274 275 IF (ok_aie) THEN 276 277 cjq cloudy-sky + aerosol direct + aerosol indirect 278 flag_aer=1.0 279 CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL, 280 S PRMU0,PFRAC,PTAVE,PWV, 281 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD) 282 INU = 1 283 CALL SW1S_LMDAR4(INU, 284 S PAER, flag_aer, tauae, pizae, cgae, 285 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 286 S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, 287 S ZFD, ZFU) 288 INU = 2 289 CALL SW2S_LMDAR4(INU, 290 S PAER, flag_aer, tauae, pizae, cgae, 291 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW, 292 S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD, 293 S PWV, PQS, 294 S ZFDOWN, ZFUP) 295 DO JK = 1 , KFLEV+1 296 DO JL = 1, KDLON 297 ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 298 ZFSDNAI(JL,JK) = ZFSDN(JL,JK) 299 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL) 300 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 301 ENDDO 302 ENDDO 303 ENDIF ! ok_aie 304 cjq -end 305 306 itapsw = 0 307 ENDIF 308 itapsw = itapsw + 1 309 C 310 DO k = 1, KFLEV 311 kpl1 = k+1 312 DO i = 1, KDLON 313 PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k)) 314 . -(ZFSDN(i,k)-ZFSDN(i,kpl1)) 315 PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k) 316 PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k)) 317 . -(ZFSDN0(i,k)-ZFSDN0(i,kpl1)) 318 PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k) 319 ENDDO 320 ENDDO 321 DO i = 1, KDLON 322 PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20) 323 c 324 PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1) 325 PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1) 326 c 327 PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1) 328 PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1) 329 c-OB 330 PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1) 331 PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1) 332 c 333 PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1) 334 PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1) 335 c-fin 336 ENDDO 337 C 338 RETURN 339 END 340 c 341 cIM ctes ds clesphys.h SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, 342 SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, 343 S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT, 344 S PRMU,PSEC,PUD) 345 USE dimphy 346 USE radiation_AR4_param, only : 347 S ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG 348 IMPLICIT none 349 cym#include "dimensions.h" 350 cym#include "dimphy.h" 351 cym#include "raddim.h" 352 #include "radepsi.h" 353 #include "radopt.h" 354 #include "YOMCST.h" 355 C 356 C* ARGUMENTS: 357 C 358 REAL(KIND=8) PSCT 359 cIM ctes ds clesphys.h REAL(KIND=8) RCO2 360 #include "clesphys.h" 361 REAL(KIND=8) PCLDSW(KDLON,KFLEV) 362 REAL(KIND=8) PPMB(KDLON,KFLEV+1) 363 REAL(KIND=8) PPSOL(KDLON) 364 REAL(KIND=8) PRMU0(KDLON) 365 REAL(KIND=8) PFRAC(KDLON) 366 REAL(KIND=8) PTAVE(KDLON,KFLEV) 367 REAL(KIND=8) PWV(KDLON,KFLEV) 368 C 369 REAL(KIND=8) PAKI(KDLON,2) 370 REAL(KIND=8) PCLD(KDLON,KFLEV) 371 REAL(KIND=8) PCLEAR(KDLON) 372 REAL(KIND=8) PDSIG(KDLON,KFLEV) 373 REAL(KIND=8) PFACT(KDLON) 374 REAL(KIND=8) PRMU(KDLON) 375 REAL(KIND=8) PSEC(KDLON) 376 REAL(KIND=8) PUD(KDLON,5,KFLEV+1) 377 C 378 C* LOCAL VARIABLES: 379 C 380 INTEGER IIND(2) 381 REAL(KIND=8) ZC1J(KDLON,KFLEV+1) 382 REAL(KIND=8) ZCLEAR(KDLON) 383 REAL(KIND=8) ZCLOUD(KDLON) 384 REAL(KIND=8) ZN175(KDLON) 385 REAL(KIND=8) ZN190(KDLON) 386 REAL(KIND=8) ZO175(KDLON) 387 REAL(KIND=8) ZO190(KDLON) 388 REAL(KIND=8) ZSIGN(KDLON) 389 REAL(KIND=8) ZR(KDLON,2) 390 REAL(KIND=8) ZSIGO(KDLON) 391 REAL(KIND=8) ZUD(KDLON,2) 392 REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW 393 INTEGER jl, jk, jkp1, jkl, jklp1, ja 394 C 395 C ------------------------------------------------------------------ 396 C 397 C* 1. COMPUTES AMOUNTS OF ABSORBERS 398 C ----------------------------- 399 C 400 100 CONTINUE 401 C 402 IIND(1)=1 403 IIND(2)=2 404 C 405 C 406 C* 1.1 INITIALIZES QUANTITIES 407 C ---------------------- 408 C 409 110 CONTINUE 410 C 411 DO 111 JL = 1, KDLON 412 PUD(JL,1,KFLEV+1)=0. 413 PUD(JL,2,KFLEV+1)=0. 414 PUD(JL,3,KFLEV+1)=0. 415 PUD(JL,4,KFLEV+1)=0. 416 PUD(JL,5,KFLEV+1)=0. 417 PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT 418 PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35. 419 PSEC(JL)=1./PRMU(JL) 420 ZC1J(JL,KFLEV+1)=0. 421 111 CONTINUE 422 C 423 C* 1.3 AMOUNTS OF ABSORBERS 424 C -------------------- 425 C 426 130 CONTINUE 427 C 428 DO 131 JL= 1, KDLON 429 ZUD(JL,1) = 0. 430 ZUD(JL,2) = 0. 431 ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.) 432 ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.) 433 ZSIGO(JL) = PPSOL(JL) 434 ZCLEAR(JL)=1. 435 ZCLOUD(JL)=0. 436 131 CONTINUE 437 C 438 DO 133 JK = 1 , KFLEV 439 JKP1 = JK + 1 440 JKL = KFLEV+1 - JK 441 JKLP1 = JKL+1 442 DO 132 JL = 1, KDLON 443 ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O 444 ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG 445 ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ ) 446 ZSIGN(JL) = 100. * PPMB(JL,JKP1) 447 PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL) 448 ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.) 449 ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.) 450 ZDSCO2 = ZO175(JL) - ZN175(JL) 451 ZDSH2O = ZO190(JL) - ZN190(JL) 452 PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O) 453 . * ZDSH2O * ZWH2O * ZRTH 454 PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG) 455 . * ZDSCO2 * RCO2 * ZRTU 456 ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O) 457 PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW 458 PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW) 459 ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK) 460 ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK) 461 ZSIGO(JL) = ZSIGN(JL) 462 ZO175(JL) = ZN175(JL) 463 ZO190(JL) = ZN190(JL) 464 C 465 IF (NOVLP.EQ.1) THEN 466 ZCLEAR(JL)=ZCLEAR(JL) 467 S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL))) 468 S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC)) 469 ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL) 470 ZCLOUD(JL) = PCLDSW(JL,JKL) 471 ELSE IF (NOVLP.EQ.2) THEN 472 ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL)) 473 ZC1J(JL,JKL) = ZCLOUD(JL) 474 ELSE IF (NOVLP.EQ.3) THEN 475 ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL)) 476 ZCLOUD(JL) = 1.0 - ZCLEAR(JL) 477 ZC1J(JL,JKL) = ZCLOUD(JL) 1 ! IM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 2 SUBROUTINE sw_lmdar4(psct, prmu0, pfrac, ppmb, pdp, ppsol, palbd, palbp, & 3 ptave, pwv, pqs, pozon, paer, pcldsw, ptau, pomega, pcg, pheat, pheat0, & 4 palbpla, ptopsw, psolsw, ptopsw0, psolsw0, zfsup, zfsdn, zfsup0, zfsdn0, & 5 tauae, pizae, cgae, ptaua, pomegaa, ptopswad, psolswad, ptopswai, & 6 psolswai, ok_ade, ok_aie) 7 USE dimphy 8 IMPLICIT NONE 9 10 ! ym#include "dimensions.h" 11 ! ym#include "dimphy.h" 12 ! ym#include "raddim.h" 13 include "YOMCST.h" 14 include "iniprint.h" 15 16 ! ------------------------------------------------------------------ 17 18 ! PURPOSE. 19 ! -------- 20 21 ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO 22 ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). 23 24 ! METHOD. 25 ! ------- 26 27 ! 1. COMPUTES ABSORBER AMOUNTS (SWU) 28 ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S) 29 ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S) 30 31 ! REFERENCE. 32 ! ---------- 33 34 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 35 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 36 37 ! AUTHOR. 38 ! ------- 39 ! JEAN-JACQUES MORCRETTE *ECMWF* 40 41 ! MODIFICATIONS. 42 ! -------------- 43 ! ORIGINAL : 89-07-14 44 ! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo 45 ! 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER) 46 ! ------------------------------------------------------------------ 47 48 ! * ARGUMENTS: 49 50 REAL (KIND=8) psct ! constante solaire (valeur conseillee: 1370) 51 ! IM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: 52 ! 353.E-06*44.011/28.97) 53 include "clesphys.h" 54 55 REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (PA) 56 REAL (KIND=8) pdp(kdlon, kflev) ! LAYER THICKNESS (PA) 57 REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB) 58 59 REAL (KIND=8) prmu0(kdlon) ! COSINE OF ZENITHAL ANGLE 60 REAL (KIND=8) pfrac(kdlon) ! fraction de la journee 61 62 REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K) 63 REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (KG/KG) 64 REAL (KIND=8) pqs(kdlon, kflev) ! SATURATED WATER VAPOUR (KG/KG) 65 REAL (KIND=8) pozon(kdlon, kflev) ! OZONE CONCENTRATION (KG/KG) 66 REAL (KIND=8) paer(kdlon, kflev, 5) ! AEROSOLS' OPTICAL THICKNESS 67 68 REAL (KIND=8) palbd(kdlon, 2) ! albedo du sol (lumiere diffuse) 69 REAL (KIND=8) palbp(kdlon, 2) ! albedo du sol (lumiere parallele) 70 71 REAL (KIND=8) pcldsw(kdlon, kflev) ! CLOUD FRACTION 72 REAL (KIND=8) ptau(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS 73 REAL (KIND=8) pcg(kdlon, 2, kflev) ! ASYMETRY FACTOR 74 REAL (KIND=8) pomega(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO 75 76 REAL (KIND=8) pheat(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) 77 REAL (KIND=8) pheat0(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) clear-sky 78 REAL (KIND=8) palbpla(kdlon) ! PLANETARY ALBEDO 79 REAL (KIND=8) ptopsw(kdlon) ! SHORTWAVE FLUX AT T.O.A. 80 REAL (KIND=8) psolsw(kdlon) ! SHORTWAVE FLUX AT SURFACE 81 REAL (KIND=8) ptopsw0(kdlon) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY) 82 REAL (KIND=8) psolsw0(kdlon) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY) 83 84 ! * LOCAL VARIABLES: 85 86 REAL, PARAMETER :: dobson_u = 2.1415E-05 ! Dobson unit, in kg m-2 87 88 REAL (KIND=8) zoz(kdlon, kflev) 89 ! column-density of ozone in layer, in kilo-Dobsons 90 91 REAL (KIND=8) zaki(kdlon, 2) 92 REAL (KIND=8) zcld(kdlon, kflev) 93 REAL (KIND=8) zclear(kdlon) 94 REAL (KIND=8) zdsig(kdlon, kflev) 95 REAL (KIND=8) zfact(kdlon) 96 REAL (KIND=8) zfd(kdlon, kflev+1) 97 REAL (KIND=8) zfdown(kdlon, kflev+1) 98 REAL (KIND=8) zfu(kdlon, kflev+1) 99 REAL (KIND=8) zfup(kdlon, kflev+1) 100 REAL (KIND=8) zrmu(kdlon) 101 REAL (KIND=8) zsec(kdlon) 102 REAL (KIND=8) zud(kdlon, 5, kflev+1) 103 REAL (KIND=8) zcldsw0(kdlon, kflev) 104 105 REAL (KIND=8) zfsup(kdlon, kflev+1) 106 REAL (KIND=8) zfsdn(kdlon, kflev+1) 107 REAL (KIND=8) zfsup0(kdlon, kflev+1) 108 REAL (KIND=8) zfsdn0(kdlon, kflev+1) 109 110 INTEGER inu, jl, jk, i, k, kpl1 111 112 INTEGER swpas ! Every swpas steps, sw is calculated 113 PARAMETER (swpas=1) 114 115 INTEGER itapsw 116 LOGICAL appel1er 117 DATA itapsw/0/ 118 DATA appel1er/.TRUE./ 119 SAVE itapsw, appel1er 120 !$OMP THREADPRIVATE(appel1er) 121 !$OMP THREADPRIVATE(itapsw) 122 ! jq-Introduced for aerosol forcings 123 REAL (KIND=8) flag_aer 124 LOGICAL ok_ade, ok_aie ! use aerosol forcings or not? 125 REAL (KIND=8) tauae(kdlon, kflev, 2) ! aerosol optical properties 126 REAL (KIND=8) pizae(kdlon, kflev, 2) ! (see aeropt.F) 127 REAL (KIND=8) cgae(kdlon, kflev, 2) ! -"- 128 REAL (KIND=8) ptaua(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS (pre-industrial value) 129 REAL (KIND=8) pomegaa(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO 130 REAL (KIND=8) ptopswad(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR) 131 REAL (KIND=8) psolswad(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR) 132 REAL (KIND=8) ptopswai(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND) 133 REAL (KIND=8) psolswai(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND) 134 ! jq - Fluxes including aerosol effects 135 REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupad(:, :) 136 !$OMP THREADPRIVATE(ZFSUPAD) 137 REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnad(:, :) 138 !$OMP THREADPRIVATE(ZFSDNAD) 139 REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupai(:, :) 140 !$OMP THREADPRIVATE(ZFSUPAI) 141 REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnai(:, :) 142 !$OMP THREADPRIVATE(ZFSDNAI) 143 LOGICAL initialized 144 ! ym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes 145 ! rv 146 SAVE flag_aer 147 !$OMP THREADPRIVATE(flag_aer) 148 DATA initialized/.FALSE./ 149 SAVE initialized 150 !$OMP THREADPRIVATE(initialized) 151 ! jq-end 152 REAL tmp_ 153 154 IF (.NOT. initialized) THEN 155 flag_aer = 0. 156 initialized = .TRUE. 157 ALLOCATE (zfsupad(kdlon,kflev+1)) 158 ALLOCATE (zfsdnad(kdlon,kflev+1)) 159 ALLOCATE (zfsupai(kdlon,kflev+1)) 160 ALLOCATE (zfsdnai(kdlon,kflev+1)) 161 162 zfsupad(:, :) = 0. 163 zfsdnad(:, :) = 0. 164 zfsupai(:, :) = 0. 165 zfsdnai(:, :) = 0. 166 END IF 167 168 IF (appel1er) THEN 169 WRITE (lunout, *) 'SW calling frequency : ', swpas 170 WRITE (lunout, *) ' In general, it should be 1' 171 appel1er = .FALSE. 172 END IF 173 ! ------------------------------------------------------------------ 174 IF (mod(itapsw,swpas)==0) THEN 175 176 tmp_ = 1./(dobson_u*1E3*rg) 177 ! cdir collapse 178 DO jk = 1, kflev 179 DO jl = 1, kdlon 180 zcldsw0(jl, jk) = 0.0 181 zoz(jl, jk) = pozon(jl, jk)*tmp_*pdp(jl, jk) 182 END DO 183 END DO 184 185 186 ! clear-sky: 187 ! IM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL, 188 CALL swu_lmdar4(psct, zcldsw0, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & 189 zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) 190 inu = 1 191 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & 192 pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & 193 zfd, zfu) 194 inu = 2 195 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & 196 palbp, pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, & 197 ptau, zud, pwv, pqs, zfdown, zfup) 198 DO jk = 1, kflev + 1 199 DO jl = 1, kdlon 200 zfsup0(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) 201 zfsdn0(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) 202 END DO 203 END DO 204 205 flag_aer = 0.0 206 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & 207 zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) 208 inu = 1 209 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & 210 pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & 211 zfd, zfu) 212 inu = 2 213 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & 214 palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, & 215 zud, pwv, pqs, zfdown, zfup) 216 217 ! cloudy-sky: 218 219 DO jk = 1, kflev + 1 220 DO jl = 1, kdlon 221 zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) 222 zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) 223 END DO 224 END DO 225 226 227 IF (ok_ade) THEN 228 229 ! cloudy-sky + aerosol dir OB 230 flag_aer = 1.0 231 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & 232 zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) 233 inu = 1 234 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & 235 pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, & 236 zfd, zfu) 237 inu = 2 238 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & 239 palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, & 240 ptau, zud, pwv, pqs, zfdown, zfup) 241 DO jk = 1, kflev + 1 242 DO jl = 1, kdlon 243 zfsupad(jl, jk) = zfsup(jl, jk) 244 zfsdnad(jl, jk) = zfsdn(jl, jk) 245 zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) 246 zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) 247 END DO 248 END DO 249 250 END IF ! ok_ade 251 252 IF (ok_aie) THEN 253 254 ! jq cloudy-sky + aerosol direct + aerosol indirect 255 flag_aer = 1.0 256 CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & 257 zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud) 258 inu = 1 259 CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & 260 pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, ptaua, & 261 zud, zfd, zfu) 262 inu = 2 263 CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, & 264 palbp, pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, & 265 ptaua, zud, pwv, pqs, zfdown, zfup) 266 DO jk = 1, kflev + 1 267 DO jl = 1, kdlon 268 zfsupai(jl, jk) = zfsup(jl, jk) 269 zfsdnai(jl, jk) = zfsdn(jl, jk) 270 zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl) 271 zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl) 272 END DO 273 END DO 274 END IF ! ok_aie 275 ! jq -end 276 277 itapsw = 0 278 END IF 279 itapsw = itapsw + 1 280 281 DO k = 1, kflev 282 kpl1 = k + 1 283 DO i = 1, kdlon 284 pheat(i, k) = -(zfsup(i,kpl1)-zfsup(i,k)) - (zfsdn(i,k)-zfsdn(i,kpl1)) 285 pheat(i, k) = pheat(i, k)*rday*rg/rcpd/pdp(i, k) 286 pheat0(i, k) = -(zfsup0(i,kpl1)-zfsup0(i,k)) - & 287 (zfsdn0(i,k)-zfsdn0(i,kpl1)) 288 pheat0(i, k) = pheat0(i, k)*rday*rg/rcpd/pdp(i, k) 289 END DO 290 END DO 291 DO i = 1, kdlon 292 palbpla(i) = zfsup(i, kflev+1)/(zfsdn(i,kflev+1)+1.0E-20) 293 294 psolsw(i) = zfsdn(i, 1) - zfsup(i, 1) 295 ptopsw(i) = zfsdn(i, kflev+1) - zfsup(i, kflev+1) 296 297 psolsw0(i) = zfsdn0(i, 1) - zfsup0(i, 1) 298 ptopsw0(i) = zfsdn0(i, kflev+1) - zfsup0(i, kflev+1) 299 ! -OB 300 psolswad(i) = zfsdnad(i, 1) - zfsupad(i, 1) 301 ptopswad(i) = zfsdnad(i, kflev+1) - zfsupad(i, kflev+1) 302 303 psolswai(i) = zfsdnai(i, 1) - zfsupai(i, 1) 304 ptopswai(i) = zfsdnai(i, kflev+1) - zfsupai(i, kflev+1) 305 ! -fin 306 END DO 307 308 RETURN 309 END SUBROUTINE sw_lmdar4 310 311 ! IM ctes ds clesphys.h SUBROUTINE SWU 312 ! (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC, 313 SUBROUTINE swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, & 314 paki, pcld, pclear, pdsig, pfact, prmu, psec, pud) 315 USE dimphy 316 USE radiation_ar4_param, ONLY: zpdh2o, zpdumg, zprh2o, zprumg, rtdh2o, & 317 rtdumg, rth2o, rtumg 318 IMPLICIT NONE 319 ! ym#include "dimensions.h" 320 ! ym#include "dimphy.h" 321 ! ym#include "raddim.h" 322 include "radepsi.h" 323 include "radopt.h" 324 include "YOMCST.h" 325 326 ! * ARGUMENTS: 327 328 REAL (KIND=8) psct 329 ! IM ctes ds clesphys.h REAL(KIND=8) RCO2 330 include "clesphys.h" 331 REAL (KIND=8) pcldsw(kdlon, kflev) 332 REAL (KIND=8) ppmb(kdlon, kflev+1) 333 REAL (KIND=8) ppsol(kdlon) 334 REAL (KIND=8) prmu0(kdlon) 335 REAL (KIND=8) pfrac(kdlon) 336 REAL (KIND=8) ptave(kdlon, kflev) 337 REAL (KIND=8) pwv(kdlon, kflev) 338 339 REAL (KIND=8) paki(kdlon, 2) 340 REAL (KIND=8) pcld(kdlon, kflev) 341 REAL (KIND=8) pclear(kdlon) 342 REAL (KIND=8) pdsig(kdlon, kflev) 343 REAL (KIND=8) pfact(kdlon) 344 REAL (KIND=8) prmu(kdlon) 345 REAL (KIND=8) psec(kdlon) 346 REAL (KIND=8) pud(kdlon, 5, kflev+1) 347 348 ! * LOCAL VARIABLES: 349 350 INTEGER iind(2) 351 REAL (KIND=8) zc1j(kdlon, kflev+1) 352 REAL (KIND=8) zclear(kdlon) 353 REAL (KIND=8) zcloud(kdlon) 354 REAL (KIND=8) zn175(kdlon) 355 REAL (KIND=8) zn190(kdlon) 356 REAL (KIND=8) zo175(kdlon) 357 REAL (KIND=8) zo190(kdlon) 358 REAL (KIND=8) zsign(kdlon) 359 REAL (KIND=8) zr(kdlon, 2) 360 REAL (KIND=8) zsigo(kdlon) 361 REAL (KIND=8) zud(kdlon, 2) 362 REAL (KIND=8) zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw 363 INTEGER jl, jk, jkp1, jkl, jklp1, ja 364 365 ! ------------------------------------------------------------------ 366 367 ! * 1. COMPUTES AMOUNTS OF ABSORBERS 368 ! ----------------------------- 369 370 371 iind(1) = 1 372 iind(2) = 2 373 374 ! * 1.1 INITIALIZES QUANTITIES 375 ! ---------------------- 376 377 378 DO jl = 1, kdlon 379 pud(jl, 1, kflev+1) = 0. 380 pud(jl, 2, kflev+1) = 0. 381 pud(jl, 3, kflev+1) = 0. 382 pud(jl, 4, kflev+1) = 0. 383 pud(jl, 5, kflev+1) = 0. 384 pfact(jl) = prmu0(jl)*pfrac(jl)*psct 385 prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35. 386 psec(jl) = 1./prmu(jl) 387 zc1j(jl, kflev+1) = 0. 388 END DO 389 390 ! * 1.3 AMOUNTS OF ABSORBERS 391 ! -------------------- 392 393 394 DO jl = 1, kdlon 395 zud(jl, 1) = 0. 396 zud(jl, 2) = 0. 397 zo175(jl) = ppsol(jl)**(zpdumg+1.) 398 zo190(jl) = ppsol(jl)**(zpdh2o+1.) 399 zsigo(jl) = ppsol(jl) 400 zclear(jl) = 1. 401 zcloud(jl) = 0. 402 END DO 403 404 DO jk = 1, kflev 405 jkp1 = jk + 1 406 jkl = kflev + 1 - jk 407 jklp1 = jkl + 1 408 DO jl = 1, kdlon 409 zrth = (rth2o/ptave(jl,jk))**rtdh2o 410 zrtu = (rtumg/ptave(jl,jk))**rtdumg 411 zwh2o = max(pwv(jl,jk), zepscq) 412 zsign(jl) = 100.*ppmb(jl, jkp1) 413 pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl) 414 zn175(jl) = zsign(jl)**(zpdumg+1.) 415 zn190(jl) = zsign(jl)**(zpdh2o+1.) 416 zdsco2 = zo175(jl) - zn175(jl) 417 zdsh2o = zo190(jl) - zn190(jl) 418 pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* & 419 zrth 420 pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* & 421 zrtu 422 zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o) 423 pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw 424 pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw) 425 zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk) 426 zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk) 427 zsigo(jl) = zsign(jl) 428 zo175(jl) = zn175(jl) 429 zo190(jl) = zn190(jl) 430 431 IF (novlp==1) THEN 432 zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( & 433 zcloud(jl),1.-zepsec)) 434 zc1j(jl, jkl) = 1.0 - zclear(jl) 435 zcloud(jl) = pcldsw(jl, jkl) 436 ELSE IF (novlp==2) THEN 437 zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl)) 438 zc1j(jl, jkl) = zcloud(jl) 439 ELSE IF (novlp==3) THEN 440 zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl)) 441 zcloud(jl) = 1.0 - zclear(jl) 442 zc1j(jl, jkl) = zcloud(jl) 478 443 END IF 479 132 CONTINUE480 133 CONTINUE481 DO 134 JL=1, KDLON482 PCLEAR(JL)=1.-ZC1J(JL,1)483 134 CONTINUE484 DO 136 JK=1,KFLEV485 DO 135 JL=1, KDLON486 IF ( PCLEAR(JL).LT.1.) THEN487 PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))444 END DO 445 END DO 446 DO jl = 1, kdlon 447 pclear(jl) = 1. - zc1j(jl, 1) 448 END DO 449 DO jk = 1, kflev 450 DO jl = 1, kdlon 451 IF (pclear(jl)<1.) THEN 452 pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl)) 488 453 ELSE 489 PCLD(JL,JK)=0.454 pcld(jl, jk) = 0. 490 455 END IF 491 135 CONTINUE 492 136 CONTINUE 493 C 494 C 495 C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS 496 C ----------------------------------------------- 497 C 498 140 CONTINUE 499 C 500 DO 142 JA = 1,2 501 DO 141 JL = 1, KDLON 502 ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL) 503 141 CONTINUE 504 142 CONTINUE 505 C 506 CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR) 507 C 508 DO 144 JA = 1,2 509 DO 143 JL = 1, KDLON 510 PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA) 511 143 CONTINUE 512 144 CONTINUE 513 C 514 C 515 C ------------------------------------------------------------------ 516 C 517 RETURN 518 END 519 SUBROUTINE SW1S_LMDAR4 ( KNU 520 S , PAER , flag_aer, tauae, pizae, cgae 521 S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW 522 S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD 523 S , PFD , PFU) 524 USE dimphy 525 USE radiation_AR4_param, only : RSUN, RRAY 526 USE infotrac, ONLY : type_trac 456 END DO 457 END DO 458 459 ! * 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS 460 ! ----------------------------------------------- 461 462 463 DO ja = 1, 2 464 DO jl = 1, kdlon 465 zud(jl, ja) = zud(jl, ja)*psec(jl) 466 END DO 467 END DO 468 469 CALL swtt1_lmdar4(2, 2, iind, zud, zr) 470 471 DO ja = 1, 2 472 DO jl = 1, kdlon 473 paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja) 474 END DO 475 END DO 476 477 478 ! ------------------------------------------------------------------ 479 480 RETURN 481 END SUBROUTINE swu_lmdar4 482 SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, & 483 pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, & 484 pfd, pfu) 485 USE dimphy 486 USE radiation_ar4_param, ONLY: rsun, rray 487 USE infotrac, ONLY: type_trac 527 488 #ifdef REPROBUS 528 USE CHEM_REP, ONLY : RSUNTIME, ok_SUNTIME489 USE chem_rep, ONLY: rsuntime, ok_suntime 529 490 #endif 530 491 531 IMPLICIT none532 cym#include "dimensions.h"533 cym#include "dimphy.h"534 cym#include "raddim.h"i535 #include "iniprint.h"536 C 537 C------------------------------------------------------------------538 CPURPOSE.539 C--------540 C 541 CTHIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO542 CSPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).543 C 544 CMETHOD.545 C-------546 C 547 C1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO548 CCONTINUUM SCATTERING549 C2. MULTIPLY BY OZONE TRANSMISSION FUNCTION550 C 551 CREFERENCE.552 C----------553 C 554 CSEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT555 CDOCUMENTATION, AND FOUQUART AND BONNEL (1980)556 C 557 CAUTHOR.558 C-------559 CJEAN-JACQUES MORCRETTE *ECMWF*560 C 561 CMODIFICATIONS.562 C--------------563 CORIGINAL : 89-07-14564 C94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO565 C------------------------------------------------------------------566 C 567 C* ARGUMENTS:568 C 569 INTEGER KNU570 c-OB571 real(kind=8) flag_aer572 real(kind=8) tauae(kdlon,kflev,2)573 real(kind=8) pizae(kdlon,kflev,2)574 real(kind=8) cgae(kdlon,kflev,2)575 REAL(KIND=8) PAER(KDLON,KFLEV,5)576 REAL(KIND=8) PALBD(KDLON,2)577 REAL(KIND=8) PALBP(KDLON,2)578 REAL(KIND=8) PCG(KDLON,2,KFLEV)579 REAL(KIND=8) PCLD(KDLON,KFLEV)580 REAL(KIND=8) PCLDSW(KDLON,KFLEV)581 REAL(KIND=8) PCLEAR(KDLON)582 REAL(KIND=8) PDSIG(KDLON,KFLEV)583 REAL(KIND=8) POMEGA(KDLON,2,KFLEV)584 REAL(KIND=8) POZ(KDLON,KFLEV)585 REAL(KIND=8) PRMU(KDLON)586 REAL(KIND=8) PSEC(KDLON)587 REAL(KIND=8) PTAU(KDLON,2,KFLEV)588 REAL(KIND=8) PUD(KDLON,5,KFLEV+1)589 C 590 REAL(KIND=8) PFD(KDLON,KFLEV+1)591 REAL(KIND=8) PFU(KDLON,KFLEV+1)592 C 593 C* LOCAL VARIABLES:594 C 595 INTEGER IIND(4)596 C 597 REAL(KIND=8) ZCGAZ(KDLON,KFLEV)598 REAL(KIND=8) ZDIFF(KDLON)599 REAL(KIND=8) ZDIRF(KDLON)600 REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)601 REAL(KIND=8) ZRAYL(KDLON)602 REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)603 REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)604 REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)605 REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)606 REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)607 REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)608 REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)609 REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)610 REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)611 REAL(KIND=8) ZR(KDLON,4)612 REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)613 REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)614 REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)615 REAL(KIND=8) ZW(KDLON,4)616 C 617 618 619 C If running with Reporbus, overwrite default values of RSUN. 620 C Otherwise keep default values from radiation_AR4_param module. 621 IF (type_trac =='repr') THEN492 IMPLICIT NONE 493 ! ym#include "dimensions.h" 494 ! ym#include "dimphy.h" 495 ! ym#include "raddim.h"i 496 include "iniprint.h" 497 498 ! ------------------------------------------------------------------ 499 ! PURPOSE. 500 ! -------- 501 502 ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO 503 ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980). 504 505 ! METHOD. 506 ! ------- 507 508 ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO 509 ! CONTINUUM SCATTERING 510 ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION 511 512 ! REFERENCE. 513 ! ---------- 514 515 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 516 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 517 518 ! AUTHOR. 519 ! ------- 520 ! JEAN-JACQUES MORCRETTE *ECMWF* 521 522 ! MODIFICATIONS. 523 ! -------------- 524 ! ORIGINAL : 89-07-14 525 ! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO 526 ! ------------------------------------------------------------------ 527 528 ! * ARGUMENTS: 529 530 INTEGER knu 531 ! -OB 532 REAL (KIND=8) flag_aer 533 REAL (KIND=8) tauae(kdlon, kflev, 2) 534 REAL (KIND=8) pizae(kdlon, kflev, 2) 535 REAL (KIND=8) cgae(kdlon, kflev, 2) 536 REAL (KIND=8) paer(kdlon, kflev, 5) 537 REAL (KIND=8) palbd(kdlon, 2) 538 REAL (KIND=8) palbp(kdlon, 2) 539 REAL (KIND=8) pcg(kdlon, 2, kflev) 540 REAL (KIND=8) pcld(kdlon, kflev) 541 REAL (KIND=8) pcldsw(kdlon, kflev) 542 REAL (KIND=8) pclear(kdlon) 543 REAL (KIND=8) pdsig(kdlon, kflev) 544 REAL (KIND=8) pomega(kdlon, 2, kflev) 545 REAL (KIND=8) poz(kdlon, kflev) 546 REAL (KIND=8) prmu(kdlon) 547 REAL (KIND=8) psec(kdlon) 548 REAL (KIND=8) ptau(kdlon, 2, kflev) 549 REAL (KIND=8) pud(kdlon, 5, kflev+1) 550 551 REAL (KIND=8) pfd(kdlon, kflev+1) 552 REAL (KIND=8) pfu(kdlon, kflev+1) 553 554 ! * LOCAL VARIABLES: 555 556 INTEGER iind(4) 557 558 REAL (KIND=8) zcgaz(kdlon, kflev) 559 REAL (KIND=8) zdiff(kdlon) 560 REAL (KIND=8) zdirf(kdlon) 561 REAL (KIND=8) zpizaz(kdlon, kflev) 562 REAL (KIND=8) zrayl(kdlon) 563 REAL (KIND=8) zray1(kdlon, kflev+1) 564 REAL (KIND=8) zray2(kdlon, kflev+1) 565 REAL (KIND=8) zrefz(kdlon, 2, kflev+1) 566 REAL (KIND=8) zrj(kdlon, 6, kflev+1) 567 REAL (KIND=8) zrj0(kdlon, 6, kflev+1) 568 REAL (KIND=8) zrk(kdlon, 6, kflev+1) 569 REAL (KIND=8) zrk0(kdlon, 6, kflev+1) 570 REAL (KIND=8) zrmue(kdlon, kflev+1) 571 REAL (KIND=8) zrmu0(kdlon, kflev+1) 572 REAL (KIND=8) zr(kdlon, 4) 573 REAL (KIND=8) ztauaz(kdlon, kflev) 574 REAL (KIND=8) ztra1(kdlon, kflev+1) 575 REAL (KIND=8) ztra2(kdlon, kflev+1) 576 REAL (KIND=8) zw(kdlon, 4) 577 578 INTEGER jl, jk, k, jaj, ikm1, ikl 579 580 ! If running with Reporbus, overwrite default values of RSUN. 581 ! Otherwise keep default values from radiation_AR4_param module. 582 IF (type_trac=='repr') THEN 622 583 #ifdef REPROBUS 623 IF (ok_SUNTIME) THEN624 RSUN(1) = RSUNTIME(1)625 RSUN(2) = RSUNTIME(2)626 ENDIF627 WRITE(lunout,*)'RSUN(1): ',RSUN(1)584 IF (ok_suntime) THEN 585 rsun(1) = rsuntime(1) 586 rsun(2) = rsuntime(2) 587 END IF 588 WRITE (lunout, *) 'RSUN(1): ', rsun(1) 628 589 #endif 590 END IF 591 592 ! ------------------------------------------------------------------ 593 594 ! * 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) 595 ! ----------------------- ------------------ 596 597 598 599 ! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING 600 ! ----------------------------------------- 601 602 603 DO jl = 1, kdlon 604 zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, & 605 3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6))))) 606 END DO 607 608 609 ! ------------------------------------------------------------------ 610 611 ! * 2. CONTINUUM SCATTERING CALCULATIONS 612 ! --------------------------------- 613 614 615 ! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN 616 ! -------------------------------- 617 618 619 CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, & 620 zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, & 621 ztauaz, ztra1, ztra2) 622 623 ! * 2.2 CLOUDY FRACTION OF THE COLUMN 624 ! ----------------------------- 625 626 627 CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, & 628 zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, & 629 ztra2) 630 631 ! ------------------------------------------------------------------ 632 633 ! * 3. OZONE ABSORPTION 634 ! ---------------- 635 636 637 iind(1) = 1 638 iind(2) = 3 639 iind(3) = 1 640 iind(4) = 3 641 642 ! * 3.1 DOWNWARD FLUXES 643 ! --------------- 644 645 646 jaj = 2 647 648 DO jl = 1, kdlon 649 zw(jl, 1) = 0. 650 zw(jl, 2) = 0. 651 zw(jl, 3) = 0. 652 zw(jl, 4) = 0. 653 pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( & 654 jl,jaj,kflev+1))*rsun(knu) 655 END DO 656 DO jk = 1, kflev 657 ikl = kflev + 1 - jk 658 DO jl = 1, kdlon 659 zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl) 660 zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl) 661 zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl) 662 zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl) 663 END DO 664 665 CALL swtt1_lmdar4(knu, 4, iind, zw, zr) 666 667 DO jl = 1, kdlon 668 zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl) 669 zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl) 670 pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* & 671 rsun(knu) 672 END DO 673 END DO 674 675 ! * 3.2 UPWARD FLUXES 676 ! ------------- 677 678 679 DO jl = 1, kdlon 680 pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl & 681 )*palbp(jl,knu))*rsun(knu) 682 END DO 683 684 DO jk = 2, kflev + 1 685 ikm1 = jk - 1 686 DO jl = 1, kdlon 687 zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66 688 zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66 689 zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66 690 zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66 691 END DO 692 693 CALL swtt1_lmdar4(knu, 4, iind, zw, zr) 694 695 DO jl = 1, kdlon 696 zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk) 697 zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk) 698 pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* & 699 rsun(knu) 700 END DO 701 END DO 702 703 ! ------------------------------------------------------------------ 704 705 RETURN 706 END SUBROUTINE sw1s_lmdar4 707 SUBROUTINE sw2s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, & 708 palbp, pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, & 709 pud, pwv, pqs, pfdown, pfup) 710 USE dimphy 711 USE radiation_ar4_param, ONLY: rsun, rray 712 USE infotrac, ONLY: type_trac 713 #ifdef REPROBUS 714 USE chem_rep, ONLY: rsuntime, ok_suntime 715 #endif 716 717 IMPLICIT NONE 718 ! ym#include "dimensions.h" 719 ! ym#include "dimphy.h" 720 ! ym#include "raddim.h" 721 include "radepsi.h" 722 723 ! ------------------------------------------------------------------ 724 ! PURPOSE. 725 ! -------- 726 727 ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE 728 ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). 729 730 ! METHOD. 731 ! ------- 732 733 ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO 734 ! CONTINUUM SCATTERING 735 ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR 736 ! A GREY MOLECULAR ABSORPTION 737 ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS 738 ! OF ABSORBERS 739 ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS 740 ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION 741 742 ! REFERENCE. 743 ! ---------- 744 745 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 746 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 747 748 ! AUTHOR. 749 ! ------- 750 ! JEAN-JACQUES MORCRETTE *ECMWF* 751 752 ! MODIFICATIONS. 753 ! -------------- 754 ! ORIGINAL : 89-07-14 755 ! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO 756 ! ------------------------------------------------------------------ 757 ! * ARGUMENTS: 758 759 INTEGER knu 760 ! -OB 761 REAL (KIND=8) flag_aer 762 REAL (KIND=8) tauae(kdlon, kflev, 2) 763 REAL (KIND=8) pizae(kdlon, kflev, 2) 764 REAL (KIND=8) cgae(kdlon, kflev, 2) 765 REAL (KIND=8) paer(kdlon, kflev, 5) 766 REAL (KIND=8) paki(kdlon, 2) 767 REAL (KIND=8) palbd(kdlon, 2) 768 REAL (KIND=8) palbp(kdlon, 2) 769 REAL (KIND=8) pcg(kdlon, 2, kflev) 770 REAL (KIND=8) pcld(kdlon, kflev) 771 REAL (KIND=8) pcldsw(kdlon, kflev) 772 REAL (KIND=8) pclear(kdlon) 773 REAL (KIND=8) pdsig(kdlon, kflev) 774 REAL (KIND=8) pomega(kdlon, 2, kflev) 775 REAL (KIND=8) poz(kdlon, kflev) 776 REAL (KIND=8) pqs(kdlon, kflev) 777 REAL (KIND=8) prmu(kdlon) 778 REAL (KIND=8) psec(kdlon) 779 REAL (KIND=8) ptau(kdlon, 2, kflev) 780 REAL (KIND=8) pud(kdlon, 5, kflev+1) 781 REAL (KIND=8) pwv(kdlon, kflev) 782 783 REAL (KIND=8) pfdown(kdlon, kflev+1) 784 REAL (KIND=8) pfup(kdlon, kflev+1) 785 786 ! * LOCAL VARIABLES: 787 788 INTEGER iind2(2), iind3(3) 789 REAL (KIND=8) zcgaz(kdlon, kflev) 790 REAL (KIND=8) zfd(kdlon, kflev+1) 791 REAL (KIND=8) zfu(kdlon, kflev+1) 792 REAL (KIND=8) zg(kdlon) 793 REAL (KIND=8) zgg(kdlon) 794 REAL (KIND=8) zpizaz(kdlon, kflev) 795 REAL (KIND=8) zrayl(kdlon) 796 REAL (KIND=8) zray1(kdlon, kflev+1) 797 REAL (KIND=8) zray2(kdlon, kflev+1) 798 REAL (KIND=8) zref(kdlon) 799 REAL (KIND=8) zrefz(kdlon, 2, kflev+1) 800 REAL (KIND=8) zre1(kdlon) 801 REAL (KIND=8) zre2(kdlon) 802 REAL (KIND=8) zrj(kdlon, 6, kflev+1) 803 REAL (KIND=8) zrj0(kdlon, 6, kflev+1) 804 REAL (KIND=8) zrk(kdlon, 6, kflev+1) 805 REAL (KIND=8) zrk0(kdlon, 6, kflev+1) 806 REAL (KIND=8) zrl(kdlon, 8) 807 REAL (KIND=8) zrmue(kdlon, kflev+1) 808 REAL (KIND=8) zrmu0(kdlon, kflev+1) 809 REAL (KIND=8) zrmuz(kdlon) 810 REAL (KIND=8) zrneb(kdlon) 811 REAL (KIND=8) zruef(kdlon, 8) 812 REAL (KIND=8) zr1(kdlon) 813 REAL (KIND=8) zr2(kdlon, 2) 814 REAL (KIND=8) zr3(kdlon, 3) 815 REAL (KIND=8) zr4(kdlon) 816 REAL (KIND=8) zr21(kdlon) 817 REAL (KIND=8) zr22(kdlon) 818 REAL (KIND=8) zs(kdlon) 819 REAL (KIND=8) ztauaz(kdlon, kflev) 820 REAL (KIND=8) zto1(kdlon) 821 REAL (KIND=8) ztr(kdlon, 2, kflev+1) 822 REAL (KIND=8) ztra1(kdlon, kflev+1) 823 REAL (KIND=8) ztra2(kdlon, kflev+1) 824 REAL (KIND=8) ztr1(kdlon) 825 REAL (KIND=8) ztr2(kdlon) 826 REAL (KIND=8) zw(kdlon) 827 REAL (KIND=8) zw1(kdlon) 828 REAL (KIND=8) zw2(kdlon, 2) 829 REAL (KIND=8) zw3(kdlon, 3) 830 REAL (KIND=8) zw4(kdlon) 831 REAL (KIND=8) zw5(kdlon) 832 833 INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 834 INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs 835 REAL (KIND=8) zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11 836 837 ! If running with Reporbus, overwrite default values of RSUN. 838 ! Otherwise keep default values from radiation_AR4_param module. 839 IF (type_trac=='repr') THEN 840 #ifdef REPROBUS 841 IF (ok_suntime) THEN 842 rsun(1) = rsuntime(1) 843 rsun(2) = rsuntime(2) 844 END IF 845 #endif 846 END IF 847 848 ! ------------------------------------------------------------------ 849 850 ! * 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) 851 ! ------------------------------------------- 852 853 854 855 ! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING 856 ! ----------------------------------------- 857 858 859 DO jl = 1, kdlon 860 zrmum1 = 1. - prmu(jl) 861 zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, & 862 3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6))))) 863 END DO 864 865 ! ------------------------------------------------------------------ 866 867 ! * 2. CONTINUUM SCATTERING CALCULATIONS 868 ! --------------------------------- 869 870 871 ! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN 872 ! -------------------------------- 873 874 875 CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, & 876 zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, & 877 ztauaz, ztra1, ztra2) 878 879 ! * 2.2 CLOUDY FRACTION OF THE COLUMN 880 ! ----------------------------- 881 882 883 CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, & 884 zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, & 885 ztra2) 886 887 ! ------------------------------------------------------------------ 888 889 ! * 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION 890 ! ------------------------------------------------------ 891 892 893 jn = 2 894 895 DO jabs = 1, 2 896 ! * 3.1 SURFACE CONDITIONS 897 ! ------------------ 898 899 900 DO jl = 1, kdlon 901 zrefz(jl, 2, 1) = palbd(jl, knu) 902 zrefz(jl, 1, 1) = palbd(jl, knu) 903 END DO 904 905 ! * 3.2 INTRODUCING CLOUD EFFECTS 906 ! ------------------------- 907 908 909 DO jk = 2, kflev + 1 910 jkm1 = jk - 1 911 ikl = kflev + 1 - jkm1 912 DO jl = 1, kdlon 913 zrneb(jl) = pcld(jl, jkm1) 914 IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN 915 zwh2o = max(pwv(jl,jkm1), zeelog) 916 zcneb = max(zeelog, min(zrneb(jl),1.-zeelog)) 917 zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o 918 zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog) 919 ELSE 920 zaa = pud(jl, jabs, jkm1) 921 zbb = zaa 922 END IF 923 zrki = paki(jl, jabs) 924 zs(jl) = exp(-zrki*zaa*1.66) 925 zg(jl) = exp(-zrki*zaa/zrmue(jl,jk)) 926 ztr1(jl) = 0. 927 zre1(jl) = 0. 928 ztr2(jl) = 0. 929 zre2(jl) = 0. 930 931 zw(jl) = pomega(jl, knu, jkm1) 932 zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, & 933 jkm1) + zbb*zrki 934 935 zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1) 936 zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl) 937 zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*zcgaz(jl, jkm1) 938 zw(jl) = zr21(jl)/zto1(jl) 939 zref(jl) = zrefz(jl, 1, jkm1) 940 zrmuz(jl) = zrmue(jl, jk) 941 END DO 942 943 CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2) 944 945 DO jl = 1, kdlon 946 947 zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* & 948 ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl) 949 950 ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- & 951 zrneb(jl)) 952 953 zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* & 954 ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, & 955 jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl) 956 957 ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, & 958 jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl)) 959 960 END DO 961 END DO 962 963 ! * 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 964 ! ------------------------------------------------- 965 966 967 DO jref = 1, 2 968 969 jn = jn + 1 970 971 DO jl = 1, kdlon 972 zrj(jl, jn, kflev+1) = 1. 973 zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1) 974 END DO 975 976 DO jk = 1, kflev 977 jkl = kflev + 1 - jk 978 jklp1 = jkl + 1 979 DO jl = 1, kdlon 980 zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl) 981 zrj(jl, jn, jkl) = zre11 982 zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl) 983 END DO 984 END DO 985 END DO 986 END DO 987 988 ! ------------------------------------------------------------------ 989 990 ! * 4. INVERT GREY AND CONTINUUM FLUXES 991 ! -------------------------------- 992 993 994 995 ! * 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES 996 ! --------------------------------------------- 997 998 999 DO jk = 1, kflev + 1 1000 DO jaj = 1, 5, 2 1001 jajp = jaj + 1 1002 DO jl = 1, kdlon 1003 zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk) 1004 zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk) 1005 zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog) 1006 zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog) 1007 END DO 1008 END DO 1009 END DO 1010 1011 DO jk = 1, kflev + 1 1012 DO jaj = 2, 6, 2 1013 DO jl = 1, kdlon 1014 zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog) 1015 zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog) 1016 END DO 1017 END DO 1018 END DO 1019 1020 ! * 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE 1021 ! --------------------------------------------- 1022 1023 1024 DO jk = 1, kflev + 1 1025 jkki = 1 1026 DO jaj = 1, 2 1027 iind2(1) = jaj 1028 iind2(2) = jaj 1029 DO jn = 1, 2 1030 jn2j = jn + 2*jaj 1031 jkkp4 = jkki + 4 1032 1033 ! * 4.2.1 EFFECTIVE ABSORBER AMOUNTS 1034 ! -------------------------- 1035 1036 1037 DO jl = 1, kdlon 1038 zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj) 1039 zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj) 1040 END DO 1041 1042 ! * 4.2.2 TRANSMISSION FUNCTION 1043 ! --------------------- 1044 1045 1046 CALL swtt1_lmdar4(knu, 2, iind2, zw2, zr2) 1047 1048 DO jl = 1, kdlon 1049 zrl(jl, jkki) = zr2(jl, 1) 1050 zruef(jl, jkki) = zw2(jl, 1) 1051 zrl(jl, jkkp4) = zr2(jl, 2) 1052 zruef(jl, jkkp4) = zw2(jl, 2) 1053 END DO 1054 1055 jkki = jkki + 1 1056 END DO 1057 END DO 1058 1059 ! * 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION 1060 ! ------------------------------------------------------ 1061 1062 1063 DO jl = 1, kdlon 1064 pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + & 1065 zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4) 1066 pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + & 1067 zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8) 1068 END DO 1069 END DO 1070 1071 ! ------------------------------------------------------------------ 1072 1073 ! * 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES 1074 ! ---------------------------------------- 1075 1076 1077 1078 ! * 5.1 DOWNWARD FLUXES 1079 ! --------------- 1080 1081 1082 jaj = 2 1083 iind3(1) = 1 1084 iind3(2) = 2 1085 iind3(3) = 3 1086 1087 DO jl = 1, kdlon 1088 zw3(jl, 1) = 0. 1089 zw3(jl, 2) = 0. 1090 zw3(jl, 3) = 0. 1091 zw4(jl) = 0. 1092 zw5(jl) = 0. 1093 zr4(jl) = 1. 1094 zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1) 1095 END DO 1096 DO jk = 1, kflev 1097 ikl = kflev + 1 - jk 1098 DO jl = 1, kdlon 1099 zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl) 1100 zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl) 1101 zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl) 1102 zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl) 1103 zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl) 1104 END DO 1105 1106 CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3) 1107 1108 DO jl = 1, kdlon 1109 ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1110 zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* & 1111 zrj0(jl, jaj, ikl) 1112 END DO 1113 END DO 1114 1115 ! * 5.2 UPWARD FLUXES 1116 ! ------------- 1117 1118 1119 DO jl = 1, kdlon 1120 zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu) 1121 END DO 1122 1123 DO jk = 2, kflev + 1 1124 ikm1 = jk - 1 1125 DO jl = 1, kdlon 1126 zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66 1127 zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66 1128 zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66 1129 zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66 1130 zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66 1131 END DO 1132 1133 CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3) 1134 1135 DO jl = 1, kdlon 1136 ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1137 zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* & 1138 zrk0(jl, jaj, jk) 1139 END DO 1140 END DO 1141 1142 ! ------------------------------------------------------------------ 1143 1144 ! * 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION 1145 ! -------------------------------------------------- 1146 1147 iabs = 3 1148 1149 ! * 6.1 DOWNWARD FLUXES 1150 ! --------------- 1151 1152 DO jl = 1, kdlon 1153 zw1(jl) = 0. 1154 zw4(jl) = 0. 1155 zw5(jl) = 0. 1156 zr1(jl) = 0. 1157 pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( & 1158 jl,kflev+1))*rsun(knu) 1159 END DO 1160 1161 DO jk = 1, kflev 1162 ikl = kflev + 1 - jk 1163 DO jl = 1, kdlon 1164 zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl) 1165 zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl) 1166 zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl) 1167 ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1168 END DO 1169 1170 CALL swtt_lmdar4(knu, iabs, zw1, zr1) 1171 1172 DO jl = 1, kdlon 1173 pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ & 1174 pclear(jl)*zfd(jl,ikl))*rsun(knu) 1175 END DO 1176 END DO 1177 1178 ! * 6.2 UPWARD FLUXES 1179 ! ------------- 1180 1181 DO jl = 1, kdlon 1182 pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( & 1183 jl,1))*rsun(knu) 1184 END DO 1185 1186 DO jk = 2, kflev + 1 1187 ikm1 = jk - 1 1188 DO jl = 1, kdlon 1189 zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66 1190 zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66 1191 zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66 1192 ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1193 END DO 1194 1195 CALL swtt_lmdar4(knu, iabs, zw1, zr1) 1196 1197 DO jl = 1, kdlon 1198 pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* & 1199 zfu(jl,jk))*rsun(knu) 1200 END DO 1201 END DO 1202 1203 ! ------------------------------------------------------------------ 1204 1205 RETURN 1206 END SUBROUTINE sw2s_lmdar4 1207 SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, & 1208 pdsig, prayl, psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, & 1209 ptauaz, ptra1, ptra2) 1210 USE dimphy 1211 USE radiation_ar4_param, ONLY: taua, rpiza, rcga 1212 IMPLICIT NONE 1213 ! ym#include "dimensions.h" 1214 ! ym#include "dimphy.h" 1215 ! ym#include "raddim.h" 1216 include "radepsi.h" 1217 include "radopt.h" 1218 1219 ! ------------------------------------------------------------------ 1220 ! PURPOSE. 1221 ! -------- 1222 ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF 1223 ! CLEAR-SKY COLUMN 1224 1225 ! REFERENCE. 1226 ! ---------- 1227 1228 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 1229 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 1230 1231 ! AUTHOR. 1232 ! ------- 1233 ! JEAN-JACQUES MORCRETTE *ECMWF* 1234 1235 ! MODIFICATIONS. 1236 ! -------------- 1237 ! ORIGINAL : 94-11-15 1238 ! ------------------------------------------------------------------ 1239 ! * ARGUMENTS: 1240 1241 INTEGER knu 1242 ! -OB 1243 REAL (KIND=8) flag_aer 1244 REAL (KIND=8) tauae(kdlon, kflev, 2) 1245 REAL (KIND=8) pizae(kdlon, kflev, 2) 1246 REAL (KIND=8) cgae(kdlon, kflev, 2) 1247 REAL (KIND=8) paer(kdlon, kflev, 5) 1248 REAL (KIND=8) palbp(kdlon, 2) 1249 REAL (KIND=8) pdsig(kdlon, kflev) 1250 REAL (KIND=8) prayl(kdlon) 1251 REAL (KIND=8) psec(kdlon) 1252 1253 REAL (KIND=8) pcgaz(kdlon, kflev) 1254 REAL (KIND=8) ppizaz(kdlon, kflev) 1255 REAL (KIND=8) pray1(kdlon, kflev+1) 1256 REAL (KIND=8) pray2(kdlon, kflev+1) 1257 REAL (KIND=8) prefz(kdlon, 2, kflev+1) 1258 REAL (KIND=8) prj(kdlon, 6, kflev+1) 1259 REAL (KIND=8) prk(kdlon, 6, kflev+1) 1260 REAL (KIND=8) prmu0(kdlon, kflev+1) 1261 REAL (KIND=8) ptauaz(kdlon, kflev) 1262 REAL (KIND=8) ptra1(kdlon, kflev+1) 1263 REAL (KIND=8) ptra2(kdlon, kflev+1) 1264 1265 ! * LOCAL VARIABLES: 1266 1267 REAL (KIND=8) zc0i(kdlon, kflev+1) 1268 REAL (KIND=8) zcle0(kdlon, kflev) 1269 REAL (KIND=8) zclear(kdlon) 1270 REAL (KIND=8) zr21(kdlon) 1271 REAL (KIND=8) zr23(kdlon) 1272 REAL (KIND=8) zss0(kdlon) 1273 REAL (KIND=8) zscat(kdlon) 1274 REAL (KIND=8) ztr(kdlon, 2, kflev+1) 1275 1276 INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in 1277 REAL (KIND=8) ztray, zgar, zratio, zff, zfacoa, zcorae 1278 REAL (KIND=8) zmue, zgap, zww, zto, zden, zmu1, zden1 1279 REAL (KIND=8) zbmu0, zbmu1, zre11 1280 1281 ! ------------------------------------------------------------------ 1282 1283 ! * 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH 1284 ! -------------------------------------------- 1285 1286 1287 ! cdir collapse 1288 DO jk = 1, kflev + 1 1289 DO ja = 1, 6 1290 DO jl = 1, kdlon 1291 prj(jl, ja, jk) = 0. 1292 prk(jl, ja, jk) = 0. 1293 END DO 1294 END DO 1295 END DO 1296 1297 DO jk = 1, kflev 1298 ! -OB 1299 ! DO 104 JL = 1, KDLON 1300 ! PCGAZ(JL,JK) = 0. 1301 ! PPIZAZ(JL,JK) = 0. 1302 ! PTAUAZ(JL,JK) = 0. 1303 ! 104 CONTINUE 1304 ! -OB 1305 ! DO 106 JAE=1,5 1306 ! DO 105 JL = 1, KDLON 1307 ! PTAUAZ(JL,JK)=PTAUAZ(JL,JK) 1308 ! S +PAER(JL,JK,JAE)*TAUA(KNU,JAE) 1309 ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE) 1310 ! S * TAUA(KNU,JAE)*RPIZA(KNU,JAE) 1311 ! PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) 1312 ! S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) 1313 ! 105 CONTINUE 1314 ! 106 CONTINUE 1315 ! -OB 1316 DO jl = 1, kdlon 1317 ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu) 1318 ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu) 1319 pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu) 1320 END DO 1321 1322 IF (flag_aer>0) THEN 1323 ! -OB 1324 DO jl = 1, kdlon 1325 ! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK) 1326 ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK) 1327 ztray = prayl(jl)*pdsig(jl, jk) 1328 zratio = ztray/(ztray+ptauaz(jl,jk)) 1329 zgar = pcgaz(jl, jk) 1330 zff = zgar*zgar 1331 ptauaz(jl, jk) = ztray + ptauaz(jl, jk)*(1.-ppizaz(jl,jk)*zff) 1332 pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar) 1333 ppizaz(jl, jk) = zratio + (1.-zratio)*ppizaz(jl, jk)*(1.-zff)/(1.- & 1334 ppizaz(jl,jk)*zff) 1335 END DO 1336 ELSE 1337 DO jl = 1, kdlon 1338 ztray = prayl(jl)*pdsig(jl, jk) 1339 ptauaz(jl, jk) = ztray 1340 pcgaz(jl, jk) = 0. 1341 ppizaz(jl, jk) = 1. - repsct 1342 END DO 1343 END IF ! check flag_aer 1344 ! 107 CONTINUE 1345 ! PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) 1346 ! $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) 1347 ! 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) 1348 1349 END DO 1350 1351 ! ------------------------------------------------------------------ 1352 1353 ! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL 1354 ! ---------------------------------------------- 1355 1356 1357 DO jl = 1, kdlon 1358 zr23(jl) = 0. 1359 zc0i(jl, kflev+1) = 0. 1360 zclear(jl) = 1. 1361 zscat(jl) = 0. 1362 END DO 1363 1364 jk = 1 1365 jkl = kflev + 1 - jk 1366 jklp1 = jkl + 1 1367 DO jl = 1, kdlon 1368 zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) 1369 zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl) 1370 zr21(jl) = exp(-zcorae) 1371 zss0(jl) = 1. - zr21(jl) 1372 zcle0(jl, jkl) = zss0(jl) 1373 1374 IF (novlp==1) THEN 1375 ! * maximum-random 1376 zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ & 1377 (1.0-min(zscat(jl),1.-zepsec)) 1378 zc0i(jl, jkl) = 1.0 - zclear(jl) 1379 zscat(jl) = zss0(jl) 1380 ELSE IF (novlp==2) THEN 1381 ! * maximum 1382 zscat(jl) = max(zss0(jl), zscat(jl)) 1383 zc0i(jl, jkl) = zscat(jl) 1384 ELSE IF (novlp==3) THEN 1385 ! * random 1386 zclear(jl) = zclear(jl)*(1.0-zss0(jl)) 1387 zscat(jl) = 1.0 - zclear(jl) 1388 zc0i(jl, jkl) = zscat(jl) 1389 END IF 1390 END DO 1391 1392 DO jk = 2, kflev 1393 jkl = kflev + 1 - jk 1394 jklp1 = jkl + 1 1395 DO jl = 1, kdlon 1396 zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) 1397 zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl) 1398 zr21(jl) = exp(-zcorae) 1399 zss0(jl) = 1. - zr21(jl) 1400 zcle0(jl, jkl) = zss0(jl) 1401 1402 IF (novlp==1) THEN 1403 ! * maximum-random 1404 zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ & 1405 (1.0-min(zscat(jl),1.-zepsec)) 1406 zc0i(jl, jkl) = 1.0 - zclear(jl) 1407 zscat(jl) = zss0(jl) 1408 ELSE IF (novlp==2) THEN 1409 ! * maximum 1410 zscat(jl) = max(zss0(jl), zscat(jl)) 1411 zc0i(jl, jkl) = zscat(jl) 1412 ELSE IF (novlp==3) THEN 1413 ! * random 1414 zclear(jl) = zclear(jl)*(1.0-zss0(jl)) 1415 zscat(jl) = 1.0 - zclear(jl) 1416 zc0i(jl, jkl) = zscat(jl) 629 1417 END IF 630 631 C ------------------------------------------------------------------ 632 C 633 C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON) 634 C ----------------------- ------------------ 635 C 636 100 CONTINUE 637 C 638 C 639 C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING 640 C ----------------------------------------- 641 C 642 110 CONTINUE 643 C 644 DO 111 JL = 1, KDLON 645 ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL) 646 S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL) 647 S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) )))) 648 111 CONTINUE 649 C 650 C 651 C ------------------------------------------------------------------ 652 C 653 C* 2. CONTINUUM SCATTERING CALCULATIONS 654 C --------------------------------- 655 C 656 200 CONTINUE 657 C 658 C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN 659 C -------------------------------- 660 C 661 210 CONTINUE 662 C 663 CALL SWCLR_LMDAR4 ( KNU 664 S , PAER , flag_aer, tauae, pizae, cgae 665 S , PALBP , PDSIG , ZRAYL, PSEC 666 S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 667 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) 668 C 669 C 670 C* 2.2 CLOUDY FRACTION OF THE COLUMN 671 C ----------------------------- 672 C 673 220 CONTINUE 674 C 675 CALL SWR_LMDAR4 ( KNU 676 S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL 677 S , PSEC ,PTAU 678 S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE 679 S , ZTAUAZ,ZTRA1 ,ZTRA2) 680 C 681 C 682 C ------------------------------------------------------------------ 683 C 684 C* 3. OZONE ABSORPTION 685 C ---------------- 686 C 687 300 CONTINUE 688 C 689 IIND(1)=1 690 IIND(2)=3 691 IIND(3)=1 692 IIND(4)=3 693 C 694 C 695 C* 3.1 DOWNWARD FLUXES 696 C --------------- 697 C 698 310 CONTINUE 699 C 700 JAJ = 2 701 C 702 DO 311 JL = 1, KDLON 703 ZW(JL,1)=0. 704 ZW(JL,2)=0. 705 ZW(JL,3)=0. 706 ZW(JL,4)=0. 707 PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1) 708 S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU) 709 311 CONTINUE 710 DO 314 JK = 1 , KFLEV 711 IKL = KFLEV+1-JK 712 DO 312 JL = 1, KDLON 713 ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL) 714 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL) 715 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) 716 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL) 717 312 CONTINUE 718 C 719 CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) 720 C 721 DO 313 JL = 1, KDLON 722 ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL) 723 ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL) 724 PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL) 725 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) 726 313 CONTINUE 727 314 CONTINUE 728 C 729 C 730 C* 3.2 UPWARD FLUXES 731 C ------------- 732 C 733 320 CONTINUE 734 C 735 DO 325 JL = 1, KDLON 736 PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU) 737 S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU)) 738 S * RSUN(KNU) 739 325 CONTINUE 740 C 741 DO 328 JK = 2 , KFLEV+1 742 IKM1=JK-1 743 DO 326 JL = 1, KDLON 744 ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66 745 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66 746 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66 747 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66 748 326 CONTINUE 749 C 750 CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR) 751 C 752 DO 327 JL = 1, KDLON 753 ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK) 754 ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK) 755 PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL) 756 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) 757 327 CONTINUE 758 328 CONTINUE 759 C 760 C ------------------------------------------------------------------ 761 C 762 RETURN 763 END 764 SUBROUTINE SW2S_LMDAR4 ( KNU 765 S , PAER , flag_aer, tauae, pizae, cgae 766 S , PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW 767 S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU 768 S , PUD ,PWV , PQS 769 S , PFDOWN,PFUP ) 770 USE dimphy 771 USE radiation_AR4_param, only : RSUN, RRAY 772 USE infotrac, ONLY : type_trac 1418 END DO 1419 END DO 1420 1421 ! ------------------------------------------------------------------ 1422 1423 ! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING 1424 ! ----------------------------------------------- 1425 1426 1427 DO jl = 1, kdlon 1428 pray1(jl, kflev+1) = 0. 1429 pray2(jl, kflev+1) = 0. 1430 prefz(jl, 2, 1) = palbp(jl, knu) 1431 prefz(jl, 1, 1) = palbp(jl, knu) 1432 ptra1(jl, kflev+1) = 1. 1433 ptra2(jl, kflev+1) = 1. 1434 END DO 1435 1436 DO jk = 2, kflev + 1 1437 jkm1 = jk - 1 1438 DO jl = 1, kdlon 1439 1440 ! ------------------------------------------------------------------ 1441 1442 ! * 3.1 EQUIVALENT ZENITH ANGLE 1443 ! ----------------------- 1444 1445 1446 zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66 1447 prmu0(jl, jk) = 1./zmue 1448 1449 ! ------------------------------------------------------------------ 1450 1451 ! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS 1452 ! ---------------------------------------------------- 1453 1454 1455 zgap = pcgaz(jl, jkm1) 1456 zbmu0 = 0.5 - 0.75*zgap/zmue 1457 zww = ppizaz(jl, jkm1) 1458 zto = ptauaz(jl, jkm1) 1459 zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) & 1460 *zto*zto*zmue*zmue 1461 pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden 1462 ptra1(jl, jkm1) = 1./zden 1463 1464 zmu1 = 0.5 1465 zbmu1 = 0.5 - 0.75*zgap*zmu1 1466 zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww & 1467 )*zto*zto/zmu1/zmu1 1468 pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1 1469 ptra2(jl, jkm1) = 1./zden1 1470 1471 1472 1473 prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* & 1474 ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1))) 1475 1476 ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, & 1477 jkm1))) 1478 1479 prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* & 1480 ptra2(jl,jkm1)) 1481 1482 ztr(jl, 2, jkm1) = ptra1(jl, jkm1) 1483 1484 END DO 1485 END DO 1486 DO jl = 1, kdlon 1487 zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66 1488 prmu0(jl, 1) = 1./zmue 1489 END DO 1490 1491 ! ------------------------------------------------------------------ 1492 1493 ! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 1494 ! ------------------------------------------------- 1495 1496 1497 IF (knu==1) THEN 1498 jaj = 2 1499 DO jl = 1, kdlon 1500 prj(jl, jaj, kflev+1) = 1. 1501 prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1) 1502 END DO 1503 1504 DO jk = 1, kflev 1505 jkl = kflev + 1 - jk 1506 jklp1 = jkl + 1 1507 DO jl = 1, kdlon 1508 zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl) 1509 prj(jl, jaj, jkl) = zre11 1510 prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl) 1511 END DO 1512 END DO 1513 1514 ELSE 1515 1516 DO jaj = 1, 2 1517 DO jl = 1, kdlon 1518 prj(jl, jaj, kflev+1) = 1. 1519 prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1) 1520 END DO 1521 1522 DO jk = 1, kflev 1523 jkl = kflev + 1 - jk 1524 jklp1 = jkl + 1 1525 DO jl = 1, kdlon 1526 zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl) 1527 prj(jl, jaj, jkl) = zre11 1528 prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl) 1529 END DO 1530 END DO 1531 END DO 1532 1533 END IF 1534 1535 ! ------------------------------------------------------------------ 1536 1537 RETURN 1538 END SUBROUTINE swclr_lmdar4 1539 SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, & 1540 ptau, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, & 1541 ptra2) 1542 USE dimphy 1543 IMPLICIT NONE 1544 ! ym#include "dimensions.h" 1545 ! ym#include "dimphy.h" 1546 ! ym#include "raddim.h" 1547 include "radepsi.h" 1548 include "radopt.h" 1549 1550 ! ------------------------------------------------------------------ 1551 ! PURPOSE. 1552 ! -------- 1553 ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF 1554 ! CONTINUUM SCATTERING 1555 1556 ! METHOD. 1557 ! ------- 1558 1559 ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL 1560 ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) 1561 1562 ! REFERENCE. 1563 ! ---------- 1564 1565 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 1566 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 1567 1568 ! AUTHOR. 1569 ! ------- 1570 ! JEAN-JACQUES MORCRETTE *ECMWF* 1571 1572 ! MODIFICATIONS. 1573 ! -------------- 1574 ! ORIGINAL : 89-07-14 1575 ! ------------------------------------------------------------------ 1576 ! * ARGUMENTS: 1577 1578 INTEGER knu 1579 REAL (KIND=8) palbd(kdlon, 2) 1580 REAL (KIND=8) pcg(kdlon, 2, kflev) 1581 REAL (KIND=8) pcld(kdlon, kflev) 1582 REAL (KIND=8) pdsig(kdlon, kflev) 1583 REAL (KIND=8) pomega(kdlon, 2, kflev) 1584 REAL (KIND=8) prayl(kdlon) 1585 REAL (KIND=8) psec(kdlon) 1586 REAL (KIND=8) ptau(kdlon, 2, kflev) 1587 1588 REAL (KIND=8) pray1(kdlon, kflev+1) 1589 REAL (KIND=8) pray2(kdlon, kflev+1) 1590 REAL (KIND=8) prefz(kdlon, 2, kflev+1) 1591 REAL (KIND=8) prj(kdlon, 6, kflev+1) 1592 REAL (KIND=8) prk(kdlon, 6, kflev+1) 1593 REAL (KIND=8) prmue(kdlon, kflev+1) 1594 REAL (KIND=8) pcgaz(kdlon, kflev) 1595 REAL (KIND=8) ppizaz(kdlon, kflev) 1596 REAL (KIND=8) ptauaz(kdlon, kflev) 1597 REAL (KIND=8) ptra1(kdlon, kflev+1) 1598 REAL (KIND=8) ptra2(kdlon, kflev+1) 1599 1600 ! * LOCAL VARIABLES: 1601 1602 REAL (KIND=8) zc1i(kdlon, kflev+1) 1603 REAL (KIND=8) zcleq(kdlon, kflev) 1604 REAL (KIND=8) zclear(kdlon) 1605 REAL (KIND=8) zcloud(kdlon) 1606 REAL (KIND=8) zgg(kdlon) 1607 REAL (KIND=8) zref(kdlon) 1608 REAL (KIND=8) zre1(kdlon) 1609 REAL (KIND=8) zre2(kdlon) 1610 REAL (KIND=8) zrmuz(kdlon) 1611 REAL (KIND=8) zrneb(kdlon) 1612 REAL (KIND=8) zr21(kdlon) 1613 REAL (KIND=8) zr22(kdlon) 1614 REAL (KIND=8) zr23(kdlon) 1615 REAL (KIND=8) zss1(kdlon) 1616 REAL (KIND=8) zto1(kdlon) 1617 REAL (KIND=8) ztr(kdlon, 2, kflev+1) 1618 REAL (KIND=8) ztr1(kdlon) 1619 REAL (KIND=8) ztr2(kdlon) 1620 REAL (KIND=8) zw(kdlon) 1621 1622 INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj 1623 REAL (KIND=8) zfacoa, zfacoc, zcorae, zcorcd 1624 REAL (KIND=8) zmue, zgap, zww, zto, zden, zden1 1625 REAL (KIND=8) zmu1, zre11, zbmu0, zbmu1 1626 1627 ! ------------------------------------------------------------------ 1628 1629 ! * 1. INITIALIZATION 1630 ! -------------- 1631 1632 1633 DO jk = 1, kflev + 1 1634 DO ja = 1, 6 1635 DO jl = 1, kdlon 1636 prj(jl, ja, jk) = 0. 1637 prk(jl, ja, jk) = 0. 1638 END DO 1639 END DO 1640 END DO 1641 1642 ! ------------------------------------------------------------------ 1643 1644 ! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL 1645 ! ---------------------------------------------- 1646 1647 1648 DO jl = 1, kdlon 1649 zr23(jl) = 0. 1650 zc1i(jl, kflev+1) = 0. 1651 zclear(jl) = 1. 1652 zcloud(jl) = 0. 1653 END DO 1654 1655 jk = 1 1656 jkl = kflev + 1 - jk 1657 jklp1 = jkl + 1 1658 DO jl = 1, kdlon 1659 zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) 1660 zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl) 1661 zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl) 1662 zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl) 1663 zr21(jl) = exp(-zcorae) 1664 zr22(jl) = exp(-zcorcd) 1665 zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + & 1666 (1.0-pcld(jl,jkl))*(1.0-zr21(jl)) 1667 zcleq(jl, jkl) = zss1(jl) 1668 1669 IF (novlp==1) THEN 1670 ! * maximum-random 1671 zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ & 1672 (1.0-min(zcloud(jl),1.-zepsec)) 1673 zc1i(jl, jkl) = 1.0 - zclear(jl) 1674 zcloud(jl) = zss1(jl) 1675 ELSE IF (novlp==2) THEN 1676 ! * maximum 1677 zcloud(jl) = max(zss1(jl), zcloud(jl)) 1678 zc1i(jl, jkl) = zcloud(jl) 1679 ELSE IF (novlp==3) THEN 1680 ! * random 1681 zclear(jl) = zclear(jl)*(1.0-zss1(jl)) 1682 zcloud(jl) = 1.0 - zclear(jl) 1683 zc1i(jl, jkl) = zcloud(jl) 1684 END IF 1685 END DO 1686 1687 DO jk = 2, kflev 1688 jkl = kflev + 1 - jk 1689 jklp1 = jkl + 1 1690 DO jl = 1, kdlon 1691 zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl) 1692 zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl) 1693 zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl) 1694 zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl) 1695 zr21(jl) = exp(-zcorae) 1696 zr22(jl) = exp(-zcorcd) 1697 zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + & 1698 (1.0-pcld(jl,jkl))*(1.0-zr21(jl)) 1699 zcleq(jl, jkl) = zss1(jl) 1700 1701 IF (novlp==1) THEN 1702 ! * maximum-random 1703 zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ & 1704 (1.0-min(zcloud(jl),1.-zepsec)) 1705 zc1i(jl, jkl) = 1.0 - zclear(jl) 1706 zcloud(jl) = zss1(jl) 1707 ELSE IF (novlp==2) THEN 1708 ! * maximum 1709 zcloud(jl) = max(zss1(jl), zcloud(jl)) 1710 zc1i(jl, jkl) = zcloud(jl) 1711 ELSE IF (novlp==3) THEN 1712 ! * random 1713 zclear(jl) = zclear(jl)*(1.0-zss1(jl)) 1714 zcloud(jl) = 1.0 - zclear(jl) 1715 zc1i(jl, jkl) = zcloud(jl) 1716 END IF 1717 END DO 1718 END DO 1719 1720 ! ------------------------------------------------------------------ 1721 1722 ! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING 1723 ! ----------------------------------------------- 1724 1725 1726 DO jl = 1, kdlon 1727 pray1(jl, kflev+1) = 0. 1728 pray2(jl, kflev+1) = 0. 1729 prefz(jl, 2, 1) = palbd(jl, knu) 1730 prefz(jl, 1, 1) = palbd(jl, knu) 1731 ptra1(jl, kflev+1) = 1. 1732 ptra2(jl, kflev+1) = 1. 1733 END DO 1734 1735 DO jk = 2, kflev + 1 1736 jkm1 = jk - 1 1737 DO jl = 1, kdlon 1738 zrneb(jl) = pcld(jl, jkm1) 1739 zre1(jl) = 0. 1740 ztr1(jl) = 0. 1741 zre2(jl) = 0. 1742 ztr2(jl) = 0. 1743 1744 ! ------------------------------------------------------------------ 1745 1746 ! * 3.1 EQUIVALENT ZENITH ANGLE 1747 ! ----------------------- 1748 1749 1750 zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66 1751 prmue(jl, jk) = 1./zmue 1752 1753 ! ------------------------------------------------------------------ 1754 1755 ! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS 1756 ! ---------------------------------------------------- 1757 1758 1759 zgap = pcgaz(jl, jkm1) 1760 zbmu0 = 0.5 - 0.75*zgap/zmue 1761 zww = ppizaz(jl, jkm1) 1762 zto = ptauaz(jl, jkm1) 1763 zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) & 1764 *zto*zto*zmue*zmue 1765 pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden 1766 ptra1(jl, jkm1) = 1./zden 1767 ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) 1768 1769 zmu1 = 0.5 1770 zbmu1 = 0.5 - 0.75*zgap*zmu1 1771 zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww & 1772 )*zto*zto/zmu1/zmu1 1773 pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1 1774 ptra2(jl, jkm1) = 1./zden1 1775 1776 ! ------------------------------------------------------------------ 1777 1778 ! * 3.3 EFFECT OF CLOUD LAYER 1779 ! --------------------- 1780 1781 1782 zw(jl) = pomega(jl, knu, jkm1) 1783 zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, & 1784 jkm1) 1785 zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1) 1786 zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl) 1787 zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*pcgaz(jl, jkm1) 1788 ! Modif PhD - JJM 19/03/96 pour erreurs arrondis 1789 ! machine 1790 ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) 1791 IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN 1792 zw(jl) = 1. 1793 ELSE 1794 zw(jl) = zr21(jl)/zto1(jl) 1795 END IF 1796 zref(jl) = prefz(jl, 1, jkm1) 1797 zrmuz(jl) = prmue(jl, jk) 1798 END DO 1799 1800 CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2) 1801 1802 DO jl = 1, kdlon 1803 1804 prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* & 1805 ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, & 1806 jkm1))) + zrneb(jl)*zre2(jl) 1807 1808 ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, & 1809 jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl)) 1810 1811 prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* & 1812 ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl) 1813 1814 ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl)) 1815 1816 END DO 1817 END DO 1818 DO jl = 1, kdlon 1819 zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66 1820 prmue(jl, 1) = 1./zmue 1821 END DO 1822 1823 ! ------------------------------------------------------------------ 1824 1825 ! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 1826 ! ------------------------------------------------- 1827 1828 1829 IF (knu==1) THEN 1830 jaj = 2 1831 DO jl = 1, kdlon 1832 prj(jl, jaj, kflev+1) = 1. 1833 prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1) 1834 END DO 1835 1836 DO jk = 1, kflev 1837 jkl = kflev + 1 - jk 1838 jklp1 = jkl + 1 1839 DO jl = 1, kdlon 1840 zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl) 1841 prj(jl, jaj, jkl) = zre11 1842 prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl) 1843 END DO 1844 END DO 1845 1846 ELSE 1847 1848 DO jaj = 1, 2 1849 DO jl = 1, kdlon 1850 prj(jl, jaj, kflev+1) = 1. 1851 prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1) 1852 END DO 1853 1854 DO jk = 1, kflev 1855 jkl = kflev + 1 - jk 1856 jklp1 = jkl + 1 1857 DO jl = 1, kdlon 1858 zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl) 1859 prj(jl, jaj, jkl) = zre11 1860 prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl) 1861 END DO 1862 END DO 1863 END DO 1864 1865 END IF 1866 1867 ! ------------------------------------------------------------------ 1868 1869 RETURN 1870 END SUBROUTINE swr_lmdar4 1871 SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2) 1872 USE dimphy 1873 IMPLICIT NONE 1874 ! ym#include "dimensions.h" 1875 ! ym#include "dimphy.h" 1876 ! ym#include "raddim.h" 1877 1878 ! ------------------------------------------------------------------ 1879 ! PURPOSE. 1880 ! -------- 1881 ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY 1882 ! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. 1883 1884 ! METHOD. 1885 ! ------- 1886 1887 ! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. 1888 1889 ! REFERENCE. 1890 ! ---------- 1891 1892 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 1893 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 1894 1895 ! AUTHOR. 1896 ! ------- 1897 ! JEAN-JACQUES MORCRETTE *ECMWF* 1898 1899 ! MODIFICATIONS. 1900 ! -------------- 1901 ! ORIGINAL : 88-12-15 1902 ! ------------------------------------------------------------------ 1903 ! * ARGUMENTS: 1904 1905 REAL (KIND=8) pgg(kdlon) ! ASSYMETRY FACTOR 1906 REAL (KIND=8) pref(kdlon) ! REFLECTIVITY OF THE UNDERLYING LAYER 1907 REAL (KIND=8) prmuz(kdlon) ! COSINE OF SOLAR ZENITH ANGLE 1908 REAL (KIND=8) pto1(kdlon) ! OPTICAL THICKNESS 1909 REAL (KIND=8) pw(kdlon) ! SINGLE SCATTERING ALBEDO 1910 REAL (KIND=8) pre1(kdlon) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) 1911 REAL (KIND=8) pre2(kdlon) ! LAYER REFLECTIVITY 1912 REAL (KIND=8) ptr1(kdlon) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) 1913 REAL (KIND=8) ptr2(kdlon) ! LAYER TRANSMISSIVITY 1914 1915 ! * LOCAL VARIABLES: 1916 1917 INTEGER jl 1918 REAL (KIND=8) zff, zgp, ztop, zwcp, zdt, zx1, zwm 1919 REAL (KIND=8) zrm2, zrk, zx2, zrp, zalpha, zbeta, zarg 1920 REAL (KIND=8) zexmu0, zarg2, zexkp, zexkm, zxp2p, zxm2p, zap2b, zam2b 1921 REAL (KIND=8) za11, za12, za13, za21, za22, za23 1922 REAL (KIND=8) zdena, zc1a, zc2a, zri0a, zri1a 1923 REAL (KIND=8) zri0b, zri1b 1924 REAL (KIND=8) zb21, zb22, zb23, zdenb, zc1b, zc2b 1925 REAL (KIND=8) zri0c, zri1c, zri0d, zri1d 1926 1927 ! ------------------------------------------------------------------ 1928 1929 ! * 1. DELTA-EDDINGTON CALCULATIONS 1930 1931 1932 DO jl = 1, kdlon 1933 ! * 1.1 SET UP THE DELTA-MODIFIED PARAMETERS 1934 1935 1936 zff = pgg(jl)*pgg(jl) 1937 zgp = pgg(jl)/(1.+pgg(jl)) 1938 ztop = (1.-pw(jl)*zff)*pto1(jl) 1939 zwcp = (1-zff)*pw(jl)/(1.-pw(jl)*zff) 1940 zdt = 2./3. 1941 zx1 = 1. - zwcp*zgp 1942 zwm = 1. - zwcp 1943 zrm2 = prmuz(jl)*prmuz(jl) 1944 zrk = sqrt(3.*zwm*zx1) 1945 zx2 = 4.*(1.-zrk*zrk*zrm2) 1946 zrp = zrk/zx1 1947 zalpha = 3.*zwcp*zrm2*(1.+zgp*zwm)/zx2 1948 zbeta = 3.*zwcp*prmuz(jl)*(1.+3.*zgp*zrm2*zwm)/zx2 1949 zarg = min(ztop/prmuz(jl), 200._8) 1950 zexmu0 = exp(-zarg) 1951 zarg2 = min(zrk*ztop, 200._8) 1952 zexkp = exp(zarg2) 1953 zexkm = 1./zexkp 1954 zxp2p = 1. + zdt*zrp 1955 zxm2p = 1. - zdt*zrp 1956 zap2b = zalpha + zdt*zbeta 1957 zam2b = zalpha - zdt*zbeta 1958 1959 ! * 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER 1960 1961 1962 za11 = zxp2p 1963 za12 = zxm2p 1964 za13 = zap2b 1965 za22 = zxp2p*zexkp 1966 za21 = zxm2p*zexkm 1967 za23 = zam2b*zexmu0 1968 zdena = za11*za22 - za21*za12 1969 zc1a = (za22*za13-za12*za23)/zdena 1970 zc2a = (za11*za23-za21*za13)/zdena 1971 zri0a = zc1a + zc2a - zalpha 1972 zri1a = zrp*(zc1a-zc2a) - zbeta 1973 pre1(jl) = (zri0a-zdt*zri1a)/prmuz(jl) 1974 zri0b = zc1a*zexkm + zc2a*zexkp - zalpha*zexmu0 1975 zri1b = zrp*(zc1a*zexkm-zc2a*zexkp) - zbeta*zexmu0 1976 ptr1(jl) = zexmu0 + (zri0b+zdt*zri1b)/prmuz(jl) 1977 1978 ! * 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER 1979 1980 1981 zb21 = za21 - pref(jl)*zxp2p*zexkm 1982 zb22 = za22 - pref(jl)*zxm2p*zexkp 1983 zb23 = za23 - pref(jl)*zexmu0*(zap2b-prmuz(jl)) 1984 zdenb = za11*zb22 - zb21*za12 1985 zc1b = (zb22*za13-za12*zb23)/zdenb 1986 zc2b = (za11*zb23-zb21*za13)/zdenb 1987 zri0c = zc1b + zc2b - zalpha 1988 zri1c = zrp*(zc1b-zc2b) - zbeta 1989 pre2(jl) = (zri0c-zdt*zri1c)/prmuz(jl) 1990 zri0d = zc1b*zexkm + zc2b*zexkp - zalpha*zexmu0 1991 zri1d = zrp*(zc1b*zexkm-zc2b*zexkp) - zbeta*zexmu0 1992 ptr2(jl) = zexmu0 + (zri0d+zdt*zri1d)/prmuz(jl) 1993 1994 END DO 1995 RETURN 1996 END SUBROUTINE swde_lmdar4 1997 SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr) 1998 USE dimphy 1999 USE radiation_ar4_param, ONLY: apad, bpad, d 2000 IMPLICIT NONE 2001 ! ym#include "dimensions.h" 2002 ! ym#include "dimphy.h" 2003 ! ym#include "raddim.h" 2004 2005 ! ----------------------------------------------------------------------- 2006 ! PURPOSE. 2007 ! -------- 2008 ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 2009 ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL 2010 ! INTERVALS. 2011 2012 ! METHOD. 2013 ! ------- 2014 2015 ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS 2016 ! AND HORNER'S ALGORITHM. 2017 2018 ! REFERENCE. 2019 ! ---------- 2020 2021 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2022 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2023 2024 ! AUTHOR. 2025 ! ------- 2026 ! JEAN-JACQUES MORCRETTE *ECMWF* 2027 2028 ! MODIFICATIONS. 2029 ! -------------- 2030 ! ORIGINAL : 88-12-15 2031 ! ----------------------------------------------------------------------- 2032 2033 ! * ARGUMENTS 2034 2035 INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL 2036 INTEGER ka ! INDEX OF THE ABSORBER 2037 REAL (KIND=8) pu(kdlon) ! ABSORBER AMOUNT 2038 2039 REAL (KIND=8) ptr(kdlon) ! TRANSMISSION FUNCTION 2040 2041 ! * LOCAL VARIABLES: 2042 2043 REAL (KIND=8) zr1(kdlon), zr2(kdlon) 2044 INTEGER jl, i, j 2045 2046 ! ----------------------------------------------------------------------- 2047 2048 ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION 2049 2050 2051 DO jl = 1, kdlon 2052 zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, & 2053 3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) & 2054 +pu(jl)*(apad(knu,ka,7))))))) 2055 2056 zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, & 2057 3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) & 2058 +pu(jl)*(bpad(knu,ka,7))))))) 2059 2060 ! * 2. ADD THE BACKGROUND TRANSMISSION 2061 2062 2063 2064 ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka) 2065 END DO 2066 2067 RETURN 2068 END SUBROUTINE swtt_lmdar4 2069 SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr) 2070 USE dimphy 2071 USE radiation_ar4_param, ONLY: apad, bpad, d 2072 IMPLICIT NONE 2073 ! ym#include "dimensions.h" 2074 ! ym#include "dimphy.h" 2075 ! ym#include "raddim.h" 2076 2077 ! ----------------------------------------------------------------------- 2078 ! PURPOSE. 2079 ! -------- 2080 ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 2081 ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL 2082 ! INTERVALS. 2083 2084 ! METHOD. 2085 ! ------- 2086 2087 ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS 2088 ! AND HORNER'S ALGORITHM. 2089 2090 ! REFERENCE. 2091 ! ---------- 2092 2093 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2094 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2095 2096 ! AUTHOR. 2097 ! ------- 2098 ! JEAN-JACQUES MORCRETTE *ECMWF* 2099 2100 ! MODIFICATIONS. 2101 ! -------------- 2102 ! ORIGINAL : 95-01-20 2103 ! ----------------------------------------------------------------------- 2104 ! * ARGUMENTS: 2105 2106 INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL 2107 INTEGER kabs ! NUMBER OF ABSORBERS 2108 INTEGER kind(kabs) ! INDICES OF THE ABSORBERS 2109 REAL (KIND=8) pu(kdlon, kabs) ! ABSORBER AMOUNT 2110 2111 REAL (KIND=8) ptr(kdlon, kabs) ! TRANSMISSION FUNCTION 2112 2113 ! * LOCAL VARIABLES: 2114 2115 REAL (KIND=8) zr1(kdlon) 2116 REAL (KIND=8) zr2(kdlon) 2117 REAL (KIND=8) zu(kdlon) 2118 INTEGER jl, ja, i, j, ia 2119 2120 ! ----------------------------------------------------------------------- 2121 2122 ! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION 2123 2124 2125 DO ja = 1, kabs 2126 ia = kind(ja) 2127 DO jl = 1, kdlon 2128 zu(jl) = pu(jl, ja) 2129 zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, & 2130 ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, & 2131 ia,6)+zu(jl)*(apad(knu,ia,7))))))) 2132 2133 zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, & 2134 ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, & 2135 ia,6)+zu(jl)*(bpad(knu,ia,7))))))) 2136 2137 ! * 2. ADD THE BACKGROUND TRANSMISSION 2138 2139 2140 ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia) 2141 END DO 2142 END DO 2143 2144 RETURN 2145 END SUBROUTINE swtt1_lmdar4 2146 ! IM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, 2147 SUBROUTINE lw_lmdar4(ppmb, pdp, ppsol, pdt0, pemis, ptl, ptave, pwv, pozon, & 2148 paer, pcldld, pcldlu, pview, pcolr, pcolr0, ptoplw, psollw, ptoplw0, & 2149 psollw0, psollwdown, & ! IM . 2150 ! psollwdown,psollwdownclr, 2151 ! IM . ptoplwdown,ptoplwdownclr) 2152 plwup, plwdn, plwup0, plwdn0) 2153 USE dimphy 2154 IMPLICIT NONE 2155 ! ym#include "dimensions.h" 2156 ! ym#include "dimphy.h" 2157 ! ym#include "raddim.h" 2158 include "raddimlw.h" 2159 include "YOMCST.h" 2160 include "iniprint.h" 2161 2162 ! ----------------------------------------------------------------------- 2163 ! METHOD. 2164 ! ------- 2165 2166 ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF 2167 ! ABSORBERS. 2168 ! 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE 2169 ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. 2170 ! 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- 2171 ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE 2172 ! BOUNDARIES. 2173 ! 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. 2174 ! 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. 2175 2176 2177 ! REFERENCE. 2178 ! ---------- 2179 2180 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2181 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2182 2183 ! AUTHOR. 2184 ! ------- 2185 ! JEAN-JACQUES MORCRETTE *ECMWF* 2186 2187 ! MODIFICATIONS. 2188 ! -------------- 2189 ! ORIGINAL : 89-07-14 2190 ! ----------------------------------------------------------------------- 2191 ! IM ctes ds clesphys.h 2192 ! REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) 2193 ! REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) 2194 ! REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) 2195 ! REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 2196 ! 137.3686/28.97) 2197 ! REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 2198 ! 120.9140/28.97) 2199 include "clesphys.h" 2200 REAL (KIND=8) pcldld(kdlon, kflev) ! DOWNWARD EFFECTIVE CLOUD COVER 2201 REAL (KIND=8) pcldlu(kdlon, kflev) ! UPWARD EFFECTIVE CLOUD COVER 2202 REAL (KIND=8) pdp(kdlon, kflev) ! LAYER PRESSURE THICKNESS (Pa) 2203 REAL (KIND=8) pdt0(kdlon) ! SURFACE TEMPERATURE DISCONTINUITY (K) 2204 REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY 2205 REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF LEVEL PRESSURE (mb) 2206 REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (Pa) 2207 REAL (KIND=8) pozon(kdlon, kflev) ! O3 mass fraction 2208 REAL (KIND=8) ptl(kdlon, kflev+1) ! HALF LEVEL TEMPERATURE (K) 2209 REAL (KIND=8) paer(kdlon, kflev, 5) ! OPTICAL THICKNESS OF THE AEROSOLS 2210 REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K) 2211 REAL (KIND=8) pview(kdlon) ! COSECANT OF VIEWING ANGLE 2212 REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (kg/kg) 2213 2214 REAL (KIND=8) pcolr(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) 2215 REAL (KIND=8) pcolr0(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) clear-sky 2216 REAL (KIND=8) ptoplw(kdlon) ! LONGWAVE FLUX AT T.O.A. 2217 REAL (KIND=8) psollw(kdlon) ! LONGWAVE FLUX AT SURFACE 2218 REAL (KIND=8) ptoplw0(kdlon) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) 2219 REAL (KIND=8) psollw0(kdlon) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) 2220 ! Rajout LF 2221 REAL (KIND=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface 2222 ! Rajout IM 2223 ! IM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at 2224 ! surface 2225 ! IM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at 2226 ! T.O.A. 2227 ! IM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at 2228 ! T.O.A. 2229 ! IM 2230 REAL (KIND=8) plwup(kdlon, kflev+1) ! LW up total sky 2231 REAL (KIND=8) plwup0(kdlon, kflev+1) ! LW up clear sky 2232 REAL (KIND=8) plwdn(kdlon, kflev+1) ! LW down total sky 2233 REAL (KIND=8) plwdn0(kdlon, kflev+1) ! LW down clear sky 2234 ! ------------------------------------------------------------------------- 2235 REAL (KIND=8) zabcu(kdlon, nua, 3*kflev+1) 2236 2237 REAL (KIND=8) zoz(kdlon, kflev) 2238 ! equivalent pressure of ozone in a layer, in Pa 2239 2240 ! ym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2241 ! 2:down) 2242 ! ym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES 2243 ! ym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate 2244 ! variable 2245 ! ym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate 2246 ! variable 2247 ! ym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate 2248 ! variable 2249 ! ym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate 2250 ! variable 2251 ! ym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB 2252 REAL (KIND=8), ALLOCATABLE, SAVE :: zflux(:, :, :) ! RADIATIVE FLUXES (1:up; 2:down) 2253 REAL (KIND=8), ALLOCATABLE, SAVE :: zfluc(:, :, :) ! CLEAR-SKY RADIATIVE FLUXES 2254 REAL (KIND=8), ALLOCATABLE, SAVE :: zbint(:, :) ! Intermediate variable 2255 REAL (KIND=8), ALLOCATABLE, SAVE :: zbsui(:) ! Intermediate variable 2256 REAL (KIND=8), ALLOCATABLE, SAVE :: zcts(:, :) ! Intermediate variable 2257 REAL (KIND=8), ALLOCATABLE, SAVE :: zcntrb(:, :, :) ! Intermediate variable 2258 !$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB) 2259 2260 INTEGER ilim, i, k, kpl1 2261 2262 INTEGER lw0pas ! Every lw0pas steps, clear-sky is done 2263 PARAMETER (lw0pas=1) 2264 INTEGER lwpas ! Every lwpas steps, cloudy-sky is done 2265 PARAMETER (lwpas=1) 2266 2267 INTEGER itaplw0, itaplw 2268 LOGICAL appel1er 2269 SAVE appel1er, itaplw0, itaplw 2270 !$OMP THREADPRIVATE(appel1er, itaplw0, itaplw) 2271 DATA appel1er/.TRUE./ 2272 DATA itaplw0, itaplw/0, 0/ 2273 2274 ! ------------------------------------------------------------------ 2275 IF (appel1er) THEN 2276 WRITE (lunout, *) 'LW clear-sky calling frequency: ', lw0pas 2277 WRITE (lunout, *) 'LW cloudy-sky calling frequency: ', lwpas 2278 WRITE (lunout, *) ' In general, they should be 1' 2279 ! ym 2280 ALLOCATE (zflux(kdlon,2,kflev+1)) 2281 ALLOCATE (zfluc(kdlon,2,kflev+1)) 2282 ALLOCATE (zbint(kdlon,kflev+1)) 2283 ALLOCATE (zbsui(kdlon)) 2284 ALLOCATE (zcts(kdlon,kflev)) 2285 ALLOCATE (zcntrb(kdlon,kflev+1,kflev+1)) 2286 appel1er = .FALSE. 2287 END IF 2288 2289 IF (mod(itaplw0,lw0pas)==0) THEN 2290 ! Compute equivalent pressure of ozone from mass fraction: 2291 DO k = 1, kflev 2292 DO i = 1, kdlon 2293 zoz(i, k) = pozon(i, k)*pdp(i, k) 2294 END DO 2295 END DO 2296 ! IM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, 2297 CALL lwu_lmdar4(paer, pdp, ppmb, ppsol, zoz, ptave, pview, pwv, zabcu) 2298 CALL lwbv_lmdar4(ilim, pdp, pdt0, pemis, ppmb, ptl, ptave, zabcu, zfluc, & 2299 zbint, zbsui, zcts, zcntrb) 2300 itaplw0 = 0 2301 END IF 2302 itaplw0 = itaplw0 + 1 2303 2304 IF (mod(itaplw,lwpas)==0) THEN 2305 CALL lwc_lmdar4(ilim, pcldld, pcldlu, pemis, zfluc, zbint, zbsui, zcts, & 2306 zcntrb, zflux) 2307 itaplw = 0 2308 END IF 2309 itaplw = itaplw + 1 2310 2311 DO k = 1, kflev 2312 kpl1 = k + 1 2313 DO i = 1, kdlon 2314 pcolr(i, k) = zflux(i, 1, kpl1) + zflux(i, 2, kpl1) - zflux(i, 1, k) - & 2315 zflux(i, 2, k) 2316 pcolr(i, k) = pcolr(i, k)*rday*rg/rcpd/pdp(i, k) 2317 pcolr0(i, k) = zfluc(i, 1, kpl1) + zfluc(i, 2, kpl1) - zfluc(i, 1, k) - & 2318 zfluc(i, 2, k) 2319 pcolr0(i, k) = pcolr0(i, k)*rday*rg/rcpd/pdp(i, k) 2320 END DO 2321 END DO 2322 DO i = 1, kdlon 2323 psollw(i) = -zflux(i, 1, 1) - zflux(i, 2, 1) 2324 ptoplw(i) = zflux(i, 1, kflev+1) + zflux(i, 2, kflev+1) 2325 2326 psollw0(i) = -zfluc(i, 1, 1) - zfluc(i, 2, 1) 2327 ptoplw0(i) = zfluc(i, 1, kflev+1) + zfluc(i, 2, kflev+1) 2328 psollwdown(i) = -zflux(i, 2, 1) 2329 2330 ! IM attention aux signes !; LWtop >0, LWdn < 0 2331 DO k = 1, kflev + 1 2332 plwup(i, k) = zflux(i, 1, k) 2333 plwup0(i, k) = zfluc(i, 1, k) 2334 plwdn(i, k) = zflux(i, 2, k) 2335 plwdn0(i, k) = zfluc(i, 2, k) 2336 END DO 2337 END DO 2338 ! ------------------------------------------------------------------ 2339 RETURN 2340 END SUBROUTINE lw_lmdar4 2341 ! IM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, 2342 SUBROUTINE lwu_lmdar4(paer, pdp, ppmb, ppsol, poz, ptave, pview, pwv, pabcu) 2343 USE dimphy 2344 USE radiation_ar4_param, ONLY: tref, rt1, raer, at, bt, oct 2345 USE infotrac, ONLY: type_trac 773 2346 #ifdef REPROBUS 774 use CHEM_REP, only : RSUNTIME, ok_SUNTIME2347 USE chem_rep, ONLY: rch42d, rn2o2d, rcfc112d, rcfc122d, ok_rtime2d 775 2348 #endif 776 2349 777 IMPLICIT none 778 cym#include "dimensions.h" 779 cym#include "dimphy.h" 780 cym#include "raddim.h" 781 #include "radepsi.h" 782 C 783 C ------------------------------------------------------------------ 784 C PURPOSE. 785 C -------- 786 C 787 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE 788 C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980). 789 C 790 C METHOD. 791 C ------- 792 C 793 C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO 794 C CONTINUUM SCATTERING 795 C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR 796 C A GREY MOLECULAR ABSORPTION 797 C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS 798 C OF ABSORBERS 799 C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS 800 C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION 801 C 802 C REFERENCE. 803 C ---------- 804 C 805 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 806 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 807 C 808 C AUTHOR. 809 C ------- 810 C JEAN-JACQUES MORCRETTE *ECMWF* 811 C 812 C MODIFICATIONS. 813 C -------------- 814 C ORIGINAL : 89-07-14 815 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO 816 C ------------------------------------------------------------------ 817 C* ARGUMENTS: 818 C 819 INTEGER KNU 820 c-OB 821 real(kind=8) flag_aer 822 real(kind=8) tauae(kdlon,kflev,2) 823 real(kind=8) pizae(kdlon,kflev,2) 824 real(kind=8) cgae(kdlon,kflev,2) 825 REAL(KIND=8) PAER(KDLON,KFLEV,5) 826 REAL(KIND=8) PAKI(KDLON,2) 827 REAL(KIND=8) PALBD(KDLON,2) 828 REAL(KIND=8) PALBP(KDLON,2) 829 REAL(KIND=8) PCG(KDLON,2,KFLEV) 830 REAL(KIND=8) PCLD(KDLON,KFLEV) 831 REAL(KIND=8) PCLDSW(KDLON,KFLEV) 832 REAL(KIND=8) PCLEAR(KDLON) 833 REAL(KIND=8) PDSIG(KDLON,KFLEV) 834 REAL(KIND=8) POMEGA(KDLON,2,KFLEV) 835 REAL(KIND=8) POZ(KDLON,KFLEV) 836 REAL(KIND=8) PQS(KDLON,KFLEV) 837 REAL(KIND=8) PRMU(KDLON) 838 REAL(KIND=8) PSEC(KDLON) 839 REAL(KIND=8) PTAU(KDLON,2,KFLEV) 840 REAL(KIND=8) PUD(KDLON,5,KFLEV+1) 841 REAL(KIND=8) PWV(KDLON,KFLEV) 842 C 843 REAL(KIND=8) PFDOWN(KDLON,KFLEV+1) 844 REAL(KIND=8) PFUP(KDLON,KFLEV+1) 845 C 846 C* LOCAL VARIABLES: 847 C 848 INTEGER IIND2(2), IIND3(3) 849 REAL(KIND=8) ZCGAZ(KDLON,KFLEV) 850 REAL(KIND=8) ZFD(KDLON,KFLEV+1) 851 REAL(KIND=8) ZFU(KDLON,KFLEV+1) 852 REAL(KIND=8) ZG(KDLON) 853 REAL(KIND=8) ZGG(KDLON) 854 REAL(KIND=8) ZPIZAZ(KDLON,KFLEV) 855 REAL(KIND=8) ZRAYL(KDLON) 856 REAL(KIND=8) ZRAY1(KDLON,KFLEV+1) 857 REAL(KIND=8) ZRAY2(KDLON,KFLEV+1) 858 REAL(KIND=8) ZREF(KDLON) 859 REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1) 860 REAL(KIND=8) ZRE1(KDLON) 861 REAL(KIND=8) ZRE2(KDLON) 862 REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1) 863 REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1) 864 REAL(KIND=8) ZRK(KDLON,6,KFLEV+1) 865 REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1) 866 REAL(KIND=8) ZRL(KDLON,8) 867 REAL(KIND=8) ZRMUE(KDLON,KFLEV+1) 868 REAL(KIND=8) ZRMU0(KDLON,KFLEV+1) 869 REAL(KIND=8) ZRMUZ(KDLON) 870 REAL(KIND=8) ZRNEB(KDLON) 871 REAL(KIND=8) ZRUEF(KDLON,8) 872 REAL(KIND=8) ZR1(KDLON) 873 REAL(KIND=8) ZR2(KDLON,2) 874 REAL(KIND=8) ZR3(KDLON,3) 875 REAL(KIND=8) ZR4(KDLON) 876 REAL(KIND=8) ZR21(KDLON) 877 REAL(KIND=8) ZR22(KDLON) 878 REAL(KIND=8) ZS(KDLON) 879 REAL(KIND=8) ZTAUAZ(KDLON,KFLEV) 880 REAL(KIND=8) ZTO1(KDLON) 881 REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) 882 REAL(KIND=8) ZTRA1(KDLON,KFLEV+1) 883 REAL(KIND=8) ZTRA2(KDLON,KFLEV+1) 884 REAL(KIND=8) ZTR1(KDLON) 885 REAL(KIND=8) ZTR2(KDLON) 886 REAL(KIND=8) ZW(KDLON) 887 REAL(KIND=8) ZW1(KDLON) 888 REAL(KIND=8) ZW2(KDLON,2) 889 REAL(KIND=8) ZW3(KDLON,3) 890 REAL(KIND=8) ZW4(KDLON) 891 REAL(KIND=8) ZW5(KDLON) 892 C 893 INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1 894 INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs 895 REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11 896 897 C If running with Reporbus, overwrite default values of RSUN. 898 C Otherwise keep default values from radiation_AR4_param module. 899 IF (type_trac == 'repr') THEN 2350 IMPLICIT NONE 2351 ! ym#include "dimensions.h" 2352 ! ym#include "dimphy.h" 2353 ! ym#include "raddim.h" 2354 include "raddimlw.h" 2355 include "YOMCST.h" 2356 include "radepsi.h" 2357 include "radopt.h" 2358 2359 ! PURPOSE. 2360 ! -------- 2361 ! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND 2362 ! TEMPERATURE EFFECTS 2363 2364 ! METHOD. 2365 ! ------- 2366 2367 ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF 2368 ! ABSORBERS. 2369 2370 2371 ! REFERENCE. 2372 ! ---------- 2373 2374 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2375 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2376 2377 ! AUTHOR. 2378 ! ------- 2379 ! JEAN-JACQUES MORCRETTE *ECMWF* 2380 2381 ! MODIFICATIONS. 2382 ! -------------- 2383 ! ORIGINAL : 89-07-14 2384 ! Voigt lines (loop 404 modified) - JJM & PhD - 01/96 2385 ! ----------------------------------------------------------------------- 2386 ! * ARGUMENTS: 2387 ! IM ctes ds clesphys.h 2388 ! REAL(KIND=8) RCO2 2389 ! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 2390 include "clesphys.h" 2391 REAL (KIND=8) paer(kdlon, kflev, 5) 2392 REAL (KIND=8) pdp(kdlon, kflev) 2393 REAL (KIND=8) ppmb(kdlon, kflev+1) 2394 REAL (KIND=8) ppsol(kdlon) 2395 REAL (KIND=8) poz(kdlon, kflev) 2396 REAL (KIND=8) ptave(kdlon, kflev) 2397 REAL (KIND=8) pview(kdlon) 2398 REAL (KIND=8) pwv(kdlon, kflev) 2399 2400 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS 2401 2402 ! ----------------------------------------------------------------------- 2403 ! * LOCAL VARIABLES: 2404 REAL (KIND=8) zably(kdlon, nua, 3*kflev+1) 2405 REAL (KIND=8) zduc(kdlon, 3*kflev+1) 2406 REAL (KIND=8) zphio(kdlon) 2407 REAL (KIND=8) zpsc2(kdlon) 2408 REAL (KIND=8) zpsc3(kdlon) 2409 REAL (KIND=8) zpsh1(kdlon) 2410 REAL (KIND=8) zpsh2(kdlon) 2411 REAL (KIND=8) zpsh3(kdlon) 2412 REAL (KIND=8) zpsh4(kdlon) 2413 REAL (KIND=8) zpsh5(kdlon) 2414 REAL (KIND=8) zpsh6(kdlon) 2415 REAL (KIND=8) zpsio(kdlon) 2416 REAL (KIND=8) ztcon(kdlon) 2417 REAL (KIND=8) zphm6(kdlon) 2418 REAL (KIND=8) zpsm6(kdlon) 2419 REAL (KIND=8) zphn6(kdlon) 2420 REAL (KIND=8) zpsn6(kdlon) 2421 REAL (KIND=8) zssig(kdlon, 3*kflev+1) 2422 REAL (KIND=8) ztavi(kdlon) 2423 REAL (KIND=8) zuaer(kdlon, ninter) 2424 REAL (KIND=8) zxoz(kdlon) 2425 REAL (KIND=8) zxwv(kdlon) 2426 2427 INTEGER jl, jk, jkj, jkjr, jkjp, ig1 2428 INTEGER jki, jkip1, ja, jj 2429 INTEGER jkl, jkp1, jkk, jkjpn 2430 INTEGER jae1, jae2, jae3, jae, jjpn 2431 INTEGER ir, jc, jcp1 2432 REAL (KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup 2433 REAL (KIND=8) zfppw, ztx, ztx2, zzably 2434 REAL (KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 2435 REAL (KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 2436 REAL (KIND=8) zcac8, zcbc8 2437 REAL (KIND=8) zalup, zdiff 2438 2439 REAL (KIND=8) pvgco2, pvgh2o, pvgo3 2440 2441 REAL (KIND=8) r10e ! DECIMAL/NATURAL LOG.FACTOR 2442 PARAMETER (r10e=0.4342945) 2443 2444 ! ----------------------------------------------------------------------- 2445 2446 IF (levoigt) THEN 2447 pvgco2 = 60. 2448 pvgh2o = 30. 2449 pvgo3 = 400. 2450 ELSE 2451 pvgco2 = 0. 2452 pvgh2o = 0. 2453 pvgo3 = 0. 2454 END IF 2455 2456 ! * 2. PRESSURE OVER GAUSS SUB-LEVELS 2457 ! ------------------------------ 2458 2459 2460 DO jl = 1, kdlon 2461 zssig(jl, 1) = ppmb(jl, 1)*100. 2462 END DO 2463 2464 DO jk = 1, kflev 2465 jkj = (jk-1)*ng1p1 + 1 2466 jkjr = jkj 2467 jkjp = jkj + ng1p1 2468 DO jl = 1, kdlon 2469 zssig(jl, jkjp) = ppmb(jl, jk+1)*100. 2470 END DO 2471 DO ig1 = 1, ng1 2472 jkj = jkj + 1 2473 DO jl = 1, kdlon 2474 zssig(jl, jkj) = (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5 + & 2475 rt1(ig1)*(zssig(jl,jkjp)-zssig(jl,jkjr))*0.5 2476 END DO 2477 END DO 2478 END DO 2479 2480 ! ----------------------------------------------------------------------- 2481 2482 2483 ! * 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS 2484 ! -------------------------------------------------- 2485 2486 2487 DO jki = 1, 3*kflev 2488 jkip1 = jki + 1 2489 DO jl = 1, kdlon 2490 zably(jl, 5, jki) = (zssig(jl,jki)+zssig(jl,jkip1))*0.5 2491 zably(jl, 3, jki) = (zssig(jl,jki)-zssig(jl,jkip1))/(10.*rg) 2492 END DO 2493 END DO 2494 2495 DO jk = 1, kflev 2496 jkp1 = jk + 1 2497 jkl = kflev + 1 - jk 2498 DO jl = 1, kdlon 2499 zxwv(jl) = max(pwv(jl,jk), zepscq) 2500 zxoz(jl) = max(poz(jl,jk)/pdp(jl,jk), zepsco) 2501 END DO 2502 jkj = (jk-1)*ng1p1 + 1 2503 jkjpn = jkj + ng1 2504 DO jkk = jkj, jkjpn 2505 DO jl = 1, kdlon 2506 zdpm = zably(jl, 3, jkk) 2507 zupm = zably(jl, 5, jkk)*zdpm/101325. 2508 zupmco2 = (zably(jl,5,jkk)+pvgco2)*zdpm/101325. 2509 zupmh2o = (zably(jl,5,jkk)+pvgh2o)*zdpm/101325. 2510 zupmo3 = (zably(jl,5,jkk)+pvgo3)*zdpm/101325. 2511 zduc(jl, jkk) = zdpm 2512 zably(jl, 12, jkk) = zxoz(jl)*zdpm 2513 zably(jl, 13, jkk) = zxoz(jl)*zupmo3 2514 zu6 = zxwv(jl)*zupm 2515 zfppw = 1.6078*zxwv(jl)/(1.+0.608*zxwv(jl)) 2516 zably(jl, 6, jkk) = zxwv(jl)*zupmh2o 2517 zably(jl, 11, jkk) = zu6*zfppw 2518 zably(jl, 10, jkk) = zu6*(1.-zfppw) 2519 zably(jl, 9, jkk) = rco2*zupmco2 2520 zably(jl, 8, jkk) = rco2*zdpm 2521 END DO 2522 END DO 2523 END DO 2524 2525 ! ----------------------------------------------------------------------- 2526 2527 2528 ! * 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE 2529 ! -------------------------------------------------- 2530 2531 2532 DO ja = 1, nua 2533 DO jl = 1, kdlon 2534 pabcu(jl, ja, 3*kflev+1) = 0. 2535 END DO 2536 END DO 2537 2538 DO jk = 1, kflev 2539 jj = (jk-1)*ng1p1 + 1 2540 jjpn = jj + ng1 2541 jkl = kflev + 1 - jk 2542 2543 ! * 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE 2544 ! -------------------------------------------------- 2545 2546 2547 jae1 = 3*kflev + 1 - jj 2548 jae2 = 3*kflev + 1 - (jj+1) 2549 jae3 = 3*kflev + 1 - jjpn 2550 DO jae = 1, 5 2551 DO jl = 1, kdlon 2552 zuaer(jl, jae) = (raer(jae,1)*paer(jl,jkl,1)+raer(jae,2)*paer(jl,jkl, & 2553 2)+raer(jae,3)*paer(jl,jkl,3)+raer(jae,4)*paer(jl,jkl,4)+ & 2554 raer(jae,5)*paer(jl,jkl,5))/(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl, & 2555 jae3)) 2556 END DO 2557 END DO 2558 2559 ! * 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS 2560 ! -------------------------------------------------- 2561 2562 2563 DO jl = 1, kdlon 2564 ztavi(jl) = ptave(jl, jkl) 2565 ztcon(jl) = exp(6.08*(296./ztavi(jl)-1.)) 2566 ztx = ztavi(jl) - tref 2567 ztx2 = ztx*ztx 2568 zzably = zably(jl, 6, jae1) + zably(jl, 6, jae2) + zably(jl, 6, jae3) 2569 zup = min(max(0.5*r10e*log(zzably)+5.,0._8), 6._8) 2570 zcah1 = at(1, 1) + zup*(at(1,2)+zup*(at(1,3))) 2571 zcbh1 = bt(1, 1) + zup*(bt(1,2)+zup*(bt(1,3))) 2572 zpsh1(jl) = exp(zcah1*ztx+zcbh1*ztx2) 2573 zcah2 = at(2, 1) + zup*(at(2,2)+zup*(at(2,3))) 2574 zcbh2 = bt(2, 1) + zup*(bt(2,2)+zup*(bt(2,3))) 2575 zpsh2(jl) = exp(zcah2*ztx+zcbh2*ztx2) 2576 zcah3 = at(3, 1) + zup*(at(3,2)+zup*(at(3,3))) 2577 zcbh3 = bt(3, 1) + zup*(bt(3,2)+zup*(bt(3,3))) 2578 zpsh3(jl) = exp(zcah3*ztx+zcbh3*ztx2) 2579 zcah4 = at(4, 1) + zup*(at(4,2)+zup*(at(4,3))) 2580 zcbh4 = bt(4, 1) + zup*(bt(4,2)+zup*(bt(4,3))) 2581 zpsh4(jl) = exp(zcah4*ztx+zcbh4*ztx2) 2582 zcah5 = at(5, 1) + zup*(at(5,2)+zup*(at(5,3))) 2583 zcbh5 = bt(5, 1) + zup*(bt(5,2)+zup*(bt(5,3))) 2584 zpsh5(jl) = exp(zcah5*ztx+zcbh5*ztx2) 2585 zcah6 = at(6, 1) + zup*(at(6,2)+zup*(at(6,3))) 2586 zcbh6 = bt(6, 1) + zup*(bt(6,2)+zup*(bt(6,3))) 2587 zpsh6(jl) = exp(zcah6*ztx+zcbh6*ztx2) 2588 zphm6(jl) = exp(-5.81E-4*ztx-1.13E-6*ztx2) 2589 zpsm6(jl) = exp(-5.57E-4*ztx-3.30E-6*ztx2) 2590 zphn6(jl) = exp(-3.46E-5*ztx+2.05E-7*ztx2) 2591 zpsn6(jl) = exp(3.70E-3*ztx-2.30E-6*ztx2) 2592 END DO 2593 2594 DO jl = 1, kdlon 2595 ztavi(jl) = ptave(jl, jkl) 2596 ztx = ztavi(jl) - tref 2597 ztx2 = ztx*ztx 2598 zzably = zably(jl, 9, jae1) + zably(jl, 9, jae2) + zably(jl, 9, jae3) 2599 zalup = r10e*log(zzably) 2600 zup = max(0._8, 5.0+0.5*zalup) 2601 zpsc2(jl) = (ztavi(jl)/tref)**zup 2602 zcac8 = at(8, 1) + zup*(at(8,2)+zup*(at(8,3))) 2603 zcbc8 = bt(8, 1) + zup*(bt(8,2)+zup*(bt(8,3))) 2604 zpsc3(jl) = exp(zcac8*ztx+zcbc8*ztx2) 2605 zphio(jl) = exp(oct(1)*ztx+oct(2)*ztx2) 2606 zpsio(jl) = exp(2.*(oct(3)*ztx+oct(4)*ztx2)) 2607 END DO 2608 2609 DO jkk = jj, jjpn 2610 jc = 3*kflev + 1 - jkk 2611 jcp1 = jc + 1 2612 DO jl = 1, kdlon 2613 zdiff = pview(jl) 2614 pabcu(jl, 10, jc) = pabcu(jl, 10, jcp1) + zably(jl, 10, jc)*zdiff 2615 pabcu(jl, 11, jc) = pabcu(jl, 11, jcp1) + zably(jl, 11, jc)*ztcon(jl) & 2616 *zdiff 2617 2618 pabcu(jl, 12, jc) = pabcu(jl, 12, jcp1) + zably(jl, 12, jc)*zphio(jl) & 2619 *zdiff 2620 pabcu(jl, 13, jc) = pabcu(jl, 13, jcp1) + zably(jl, 13, jc)*zpsio(jl) & 2621 *zdiff 2622 2623 pabcu(jl, 7, jc) = pabcu(jl, 7, jcp1) + zably(jl, 9, jc)*zpsc2(jl)* & 2624 zdiff 2625 pabcu(jl, 8, jc) = pabcu(jl, 8, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* & 2626 zdiff 2627 pabcu(jl, 9, jc) = pabcu(jl, 9, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* & 2628 zdiff 2629 2630 pabcu(jl, 1, jc) = pabcu(jl, 1, jcp1) + zably(jl, 6, jc)*zpsh1(jl)* & 2631 zdiff 2632 pabcu(jl, 2, jc) = pabcu(jl, 2, jcp1) + zably(jl, 6, jc)*zpsh2(jl)* & 2633 zdiff 2634 pabcu(jl, 3, jc) = pabcu(jl, 3, jcp1) + zably(jl, 6, jc)*zpsh5(jl)* & 2635 zdiff 2636 pabcu(jl, 4, jc) = pabcu(jl, 4, jcp1) + zably(jl, 6, jc)*zpsh3(jl)* & 2637 zdiff 2638 pabcu(jl, 5, jc) = pabcu(jl, 5, jcp1) + zably(jl, 6, jc)*zpsh4(jl)* & 2639 zdiff 2640 pabcu(jl, 6, jc) = pabcu(jl, 6, jcp1) + zably(jl, 6, jc)*zpsh6(jl)* & 2641 zdiff 2642 2643 pabcu(jl, 14, jc) = pabcu(jl, 14, jcp1) + zuaer(jl, 1)*zduc(jl, jc)* & 2644 zdiff 2645 pabcu(jl, 15, jc) = pabcu(jl, 15, jcp1) + zuaer(jl, 2)*zduc(jl, jc)* & 2646 zdiff 2647 pabcu(jl, 16, jc) = pabcu(jl, 16, jcp1) + zuaer(jl, 3)*zduc(jl, jc)* & 2648 zdiff 2649 pabcu(jl, 17, jc) = pabcu(jl, 17, jcp1) + zuaer(jl, 4)*zduc(jl, jc)* & 2650 zdiff 2651 pabcu(jl, 18, jc) = pabcu(jl, 18, jcp1) + zuaer(jl, 5)*zduc(jl, jc)* & 2652 zdiff 2653 2654 2655 2656 IF (type_trac=='repr') THEN 900 2657 #ifdef REPROBUS 901 IF (ok_SUNTIME) THEN 902 RSUN(1)=RSUNTIME(1) 903 RSUN(2)=RSUNTIME(2) 904 END IF 2658 IF (ok_rtime2d) THEN 2659 pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & 2660 zably(jl, 8, jc)*rch42d(jl, jc)/rco2*zphm6(jl)*zdiff 2661 pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & 2662 zably(jl, 9, jc)*rch42d(jl, jc)/rco2*zpsm6(jl)*zdiff 2663 pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & 2664 zably(jl, 8, jc)*rn2o2d(jl, jc)/rco2*zphn6(jl)*zdiff 2665 pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & 2666 zably(jl, 9, jc)*rn2o2d(jl, jc)/rco2*zpsn6(jl)*zdiff 2667 2668 pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & 2669 zably(jl, 8, jc)*rcfc112d(jl, jc)/rco2*zdiff 2670 pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & 2671 zably(jl, 8, jc)*rcfc122d(jl, jc)/rco2*zdiff 2672 ELSE 2673 ! Same calculation as for type_trac /= repr 2674 pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & 2675 zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff 2676 pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & 2677 zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff 2678 pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & 2679 zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff 2680 pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & 2681 zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff 2682 2683 pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & 2684 zably(jl, 8, jc)*rcfc11/rco2*zdiff 2685 pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & 2686 zably(jl, 8, jc)*rcfc12/rco2*zdiff 2687 END IF 905 2688 #endif 2689 ELSE 2690 pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + & 2691 zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff 2692 pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + & 2693 zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff 2694 pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + & 2695 zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff 2696 pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + & 2697 zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff 2698 2699 pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + & 2700 zably(jl, 8, jc)*rcfc11/rco2*zdiff 2701 pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + & 2702 zably(jl, 8, jc)*rcfc12/rco2*zdiff 2703 END IF 2704 2705 END DO 2706 END DO 2707 2708 END DO 2709 2710 2711 RETURN 2712 END SUBROUTINE lwu_lmdar4 2713 SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, & 2714 pfluc, pbint, pbsui, pcts, pcntrb) 2715 USE dimphy 2716 IMPLICIT NONE 2717 ! ym#include "dimensions.h" 2718 ! ym#include "dimphy.h" 2719 ! ym#include "raddim.h" 2720 include "raddimlw.h" 2721 include "YOMCST.h" 2722 2723 ! PURPOSE. 2724 ! -------- 2725 ! TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE 2726 ! VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY 2727 ! SAVING 2728 2729 ! METHOD. 2730 ! ------- 2731 2732 ! 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE 2733 ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. 2734 ! 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- 2735 ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE 2736 ! BOUNDARIES. 2737 ! 3. COMPUTES THE CLEAR-SKY COOLING RATES. 2738 2739 ! REFERENCE. 2740 ! ---------- 2741 2742 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2743 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2744 2745 ! AUTHOR. 2746 ! ------- 2747 ! JEAN-JACQUES MORCRETTE *ECMWF* 2748 2749 ! MODIFICATIONS. 2750 ! -------------- 2751 ! ORIGINAL : 89-07-14 2752 ! MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE 2753 ! MEMORY) 2754 ! ----------------------------------------------------------------------- 2755 ! * ARGUMENTS: 2756 INTEGER klim 2757 2758 REAL (KIND=8) pdp(kdlon, kflev) 2759 REAL (KIND=8) pdt0(kdlon) 2760 REAL (KIND=8) pemis(kdlon) 2761 REAL (KIND=8) ppmb(kdlon, kflev+1) 2762 REAL (KIND=8) ptl(kdlon, kflev+1) 2763 REAL (KIND=8) ptave(kdlon, kflev) 2764 2765 REAL (KIND=8) pfluc(kdlon, 2, kflev+1) 2766 2767 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) 2768 REAL (KIND=8) pbint(kdlon, kflev+1) 2769 REAL (KIND=8) pbsui(kdlon) 2770 REAL (KIND=8) pcts(kdlon, kflev) 2771 REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) 2772 2773 ! ------------------------------------------------------------------------- 2774 2775 ! * LOCAL VARIABLES: 2776 REAL (KIND=8) zb(kdlon, ninter, kflev+1) 2777 REAL (KIND=8) zbsur(kdlon, ninter) 2778 REAL (KIND=8) zbtop(kdlon, ninter) 2779 REAL (KIND=8) zdbsl(kdlon, ninter, kflev*2) 2780 REAL (KIND=8) zga(kdlon, 8, 2, kflev) 2781 REAL (KIND=8) zgb(kdlon, 8, 2, kflev) 2782 REAL (KIND=8) zgasur(kdlon, 8, 2) 2783 REAL (KIND=8) zgbsur(kdlon, 8, 2) 2784 REAL (KIND=8) zgatop(kdlon, 8, 2) 2785 REAL (KIND=8) zgbtop(kdlon, 8, 2) 2786 2787 INTEGER nuaer, ntraer 2788 ! ------------------------------------------------------------------ 2789 ! * COMPUTES PLANCK FUNCTIONS: 2790 CALL lwb_lmdar4(pdt0, ptave, ptl, zb, pbint, pbsui, zbsur, zbtop, zdbsl, & 2791 zga, zgb, zgasur, zgbsur, zgatop, zgbtop) 2792 ! ------------------------------------------------------------------ 2793 ! * PERFORMS THE VERTICAL INTEGRATION: 2794 nuaer = nua 2795 ntraer = ntra 2796 CALL lwv_lmdar4(nuaer, ntraer, klim, pabcu, zb, pbint, pbsui, zbsur, zbtop, & 2797 zdbsl, pemis, ppmb, ptave, zga, zgb, zgasur, zgbsur, zgatop, zgbtop, & 2798 pcntrb, pcts, pfluc) 2799 ! ------------------------------------------------------------------ 2800 RETURN 2801 END SUBROUTINE lwbv_lmdar4 2802 SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, & 2803 pcts, pcntrb, pflux) 2804 USE dimphy 2805 IMPLICIT NONE 2806 ! ym#include "dimensions.h" 2807 ! ym#include "dimphy.h" 2808 ! ym#include "raddim.h" 2809 include "radepsi.h" 2810 include "radopt.h" 2811 2812 ! PURPOSE. 2813 ! -------- 2814 ! INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR 2815 ! RADIANCES 2816 2817 ! EXPLICIT ARGUMENTS : 2818 ! -------------------- 2819 ! ==== INPUTS === 2820 ! PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION 2821 ! PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION 2822 ! PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION 2823 ! PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION 2824 ! PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE 2825 ! PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE 2826 ! PEMIS : (KDLON) ; SURFACE EMISSIVITY 2827 ! PFLUC 2828 ! ==== OUTPUTS === 2829 ! PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : 2830 ! 1 ==> UPWARD FLUX TOTAL 2831 ! 2 ==> DOWNWARD FLUX TOTAL 2832 2833 ! METHOD. 2834 ! ------- 2835 2836 ! 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES 2837 ! 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER 2838 ! 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED 2839 ! CLOUDS 2840 2841 ! REFERENCE. 2842 ! ---------- 2843 2844 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2845 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2846 2847 ! AUTHOR. 2848 ! ------- 2849 ! JEAN-JACQUES MORCRETTE *ECMWF* 2850 2851 ! MODIFICATIONS. 2852 ! -------------- 2853 ! ORIGINAL : 89-07-14 2854 ! Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 2855 ! ----------------------------------------------------------------------- 2856 ! * ARGUMENTS: 2857 INTEGER klim 2858 REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES 2859 REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION 2860 REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION 2861 REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) !CLEAR-SKY ENERGY EXCHANGE 2862 REAL (KIND=8) pcts(kdlon, kflev) ! CLEAR-SKY LAYER COOLING-TO-SPACE 2863 2864 REAL (KIND=8) pcldld(kdlon, kflev) 2865 REAL (KIND=8) pcldlu(kdlon, kflev) 2866 REAL (KIND=8) pemis(kdlon) 2867 2868 REAL (KIND=8) pflux(kdlon, 2, kflev+1) 2869 ! ----------------------------------------------------------------------- 2870 ! * LOCAL VARIABLES: 2871 INTEGER imx(kdlon), imxp(kdlon) 2872 2873 REAL (KIND=8) zclear(kdlon), zcloud(kdlon), zdnf(kdlon, kflev+1, kflev+1), & 2874 zfd(kdlon), zfn10(kdlon), zfu(kdlon), zupf(kdlon, kflev+1, kflev+1) 2875 REAL (KIND=8) zclm(kdlon, kflev+1, kflev+1) 2876 2877 INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 2878 INTEGER jk1, jk2, jkc, jkcp1, jcloud 2879 INTEGER imxm1, imxp1 2880 REAL (KIND=8) zcfrac 2881 2882 ! ------------------------------------------------------------------ 2883 2884 ! * 1. INITIALIZATION 2885 ! -------------- 2886 2887 2888 imaxc = 0 2889 2890 DO jl = 1, kdlon 2891 imx(jl) = 0 2892 imxp(jl) = 0 2893 zcloud(jl) = 0. 2894 END DO 2895 2896 ! * 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD 2897 ! ------------------------------------------- 2898 2899 2900 DO jk = 1, kflev 2901 DO jl = 1, kdlon 2902 imx1 = imx(jl) 2903 imx2 = jk 2904 IF (pcldlu(jl,jk)>zepsc) THEN 2905 imxp(jl) = imx2 2906 ELSE 2907 imxp(jl) = imx1 906 2908 END IF 907 908 C 909 910 C 911 C ------------------------------------------------------------------ 912 C 913 C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON) 914 C ------------------------------------------- 915 C 916 100 CONTINUE 917 C 918 C 919 C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING 920 C ----------------------------------------- 921 C 922 110 CONTINUE 923 C 924 DO 111 JL = 1, KDLON 925 ZRMUM1 = 1. - PRMU(JL) 926 ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1 927 S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1 928 S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) )))) 929 111 CONTINUE 930 C 931 C 932 C ------------------------------------------------------------------ 933 C 934 C* 2. CONTINUUM SCATTERING CALCULATIONS 935 C --------------------------------- 936 C 937 200 CONTINUE 938 C 939 C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN 940 C -------------------------------- 941 C 942 210 CONTINUE 943 C 944 CALL SWCLR_LMDAR4 ( KNU 945 S , PAER , flag_aer, tauae, pizae, cgae 946 S , PALBP , PDSIG , ZRAYL, PSEC 947 S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0 948 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2) 949 C 950 C 951 C* 2.2 CLOUDY FRACTION OF THE COLUMN 952 C ----------------------------- 953 C 954 220 CONTINUE 955 C 956 CALL SWR_LMDAR4 ( KNU 957 S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL 958 S , PSEC , PTAU 959 S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE 960 S , ZTAUAZ, ZTRA1 , ZTRA2) 961 C 962 C 963 C ------------------------------------------------------------------ 964 C 965 C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION 966 C ------------------------------------------------------ 967 C 968 300 CONTINUE 969 C 970 JN = 2 971 C 972 DO 361 JABS=1,2 973 C 974 C 975 C* 3.1 SURFACE CONDITIONS 976 C ------------------ 977 C 978 310 CONTINUE 979 C 980 DO 311 JL = 1, KDLON 981 ZREFZ(JL,2,1) = PALBD(JL,KNU) 982 ZREFZ(JL,1,1) = PALBD(JL,KNU) 983 311 CONTINUE 984 C 985 C 986 C* 3.2 INTRODUCING CLOUD EFFECTS 987 C ------------------------- 988 C 989 320 CONTINUE 990 C 991 DO 324 JK = 2 , KFLEV+1 992 JKM1 = JK - 1 993 IKL=KFLEV+1-JKM1 994 DO 322 JL = 1, KDLON 995 ZRNEB(JL) = PCLD(JL,JKM1) 996 IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN 997 ZWH2O=MAX(PWV(JL,JKM1),ZEELOG) 998 ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG)) 999 ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O 1000 ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG) 2909 imaxc = max(imxp(jl), imaxc) 2910 imx(jl) = imxp(jl) 2911 END DO 2912 END DO 2913 ! GM******* 2914 imaxc = kflev 2915 ! GM******* 2916 2917 DO jk = 1, kflev + 1 2918 DO jl = 1, kdlon 2919 pflux(jl, 1, jk) = pfluc(jl, 1, jk) 2920 pflux(jl, 2, jk) = pfluc(jl, 2, jk) 2921 END DO 2922 END DO 2923 2924 ! ------------------------------------------------------------------ 2925 2926 ! * 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES 2927 ! --------------------------------------- 2928 2929 IF (imaxc>0) THEN 2930 2931 imxp1 = imaxc + 1 2932 imxm1 = imaxc - 1 2933 2934 ! * 2.0 INITIALIZE TO CLEAR-SKY FLUXES 2935 ! ------------------------------ 2936 2937 2938 DO jk1 = 1, kflev + 1 2939 DO jk2 = 1, kflev + 1 2940 DO jl = 1, kdlon 2941 zupf(jl, jk2, jk1) = pfluc(jl, 1, jk1) 2942 zdnf(jl, jk2, jk1) = pfluc(jl, 2, jk1) 2943 END DO 2944 END DO 2945 END DO 2946 2947 ! * 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD 2948 ! ---------------------------------------------- 2949 2950 2951 DO jkc = 1, imaxc 2952 jcloud = jkc 2953 jkcp1 = jcloud + 1 2954 2955 ! * 2.1.1 ABOVE THE CLOUD 2956 ! --------------- 2957 2958 2959 DO jk = jkcp1, kflev + 1 2960 jkm1 = jk - 1 2961 DO jl = 1, kdlon 2962 zfu(jl) = 0. 2963 END DO 2964 IF (jk>jkcp1) THEN 2965 DO jkj = jkcp1, jkm1 2966 DO jl = 1, kdlon 2967 zfu(jl) = zfu(jl) + pcntrb(jl, jk, jkj) 2968 END DO 2969 END DO 2970 END IF 2971 2972 DO jl = 1, kdlon 2973 zupf(jl, jkcp1, jk) = pbint(jl, jk) - zfu(jl) 2974 END DO 2975 END DO 2976 2977 ! * 2.1.2 BELOW THE CLOUD 2978 ! --------------- 2979 2980 2981 DO jk = 1, jcloud 2982 jkp1 = jk + 1 2983 DO jl = 1, kdlon 2984 zfd(jl) = 0. 2985 END DO 2986 2987 IF (jk<jcloud) THEN 2988 DO jkj = jkp1, jcloud 2989 DO jl = 1, kdlon 2990 zfd(jl) = zfd(jl) + pcntrb(jl, jk, jkj) 2991 END DO 2992 END DO 2993 END IF 2994 DO jl = 1, kdlon 2995 zdnf(jl, jkcp1, jk) = -pbint(jl, jk) - zfd(jl) 2996 END DO 2997 END DO 2998 2999 END DO 3000 3001 ! * 2.2 CLOUD COVER MATRIX 3002 ! ------------------ 3003 3004 ! * ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN 3005 ! HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1 3006 3007 3008 DO jk1 = 1, kflev + 1 3009 DO jk2 = 1, kflev + 1 3010 DO jl = 1, kdlon 3011 zclm(jl, jk1, jk2) = 0. 3012 END DO 3013 END DO 3014 END DO 3015 3016 ! * 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION 3017 ! ------------------------------------------ 3018 3019 3020 DO jk1 = 2, kflev + 1 3021 DO jl = 1, kdlon 3022 zclear(jl) = 1. 3023 zcloud(jl) = 0. 3024 END DO 3025 DO jk = jk1 - 1, 1, -1 3026 DO jl = 1, kdlon 3027 IF (novlp==1) THEN 3028 ! * maximum-random 3029 zclear(jl) = zclear(jl)*(1.0-max(pcldlu(jl, & 3030 jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec)) 3031 zclm(jl, jk1, jk) = 1.0 - zclear(jl) 3032 zcloud(jl) = pcldlu(jl, jk) 3033 ELSE IF (novlp==2) THEN 3034 ! * maximum 3035 zcloud(jl) = max(zcloud(jl), pcldlu(jl,jk)) 3036 zclm(jl, jk1, jk) = zcloud(jl) 3037 ELSE IF (novlp==3) THEN 3038 ! * random 3039 zclear(jl) = zclear(jl)*(1.0-pcldlu(jl,jk)) 3040 zcloud(jl) = 1.0 - zclear(jl) 3041 zclm(jl, jk1, jk) = zcloud(jl) 3042 END IF 3043 END DO 3044 END DO 3045 END DO 3046 3047 ! * 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION 3048 ! ------------------------------------------ 3049 3050 3051 DO jk1 = 1, kflev 3052 DO jl = 1, kdlon 3053 zclear(jl) = 1. 3054 zcloud(jl) = 0. 3055 END DO 3056 DO jk = jk1, kflev 3057 DO jl = 1, kdlon 3058 IF (novlp==1) THEN 3059 ! * maximum-random 3060 zclear(jl) = zclear(jl)*(1.0-max(pcldld(jl, & 3061 jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec)) 3062 zclm(jl, jk1, jk) = 1.0 - zclear(jl) 3063 zcloud(jl) = pcldld(jl, jk) 3064 ELSE IF (novlp==2) THEN 3065 ! * maximum 3066 zcloud(jl) = max(zcloud(jl), pcldld(jl,jk)) 3067 zclm(jl, jk1, jk) = zcloud(jl) 3068 ELSE IF (novlp==3) THEN 3069 ! * random 3070 zclear(jl) = zclear(jl)*(1.0-pcldld(jl,jk)) 3071 zcloud(jl) = 1.0 - zclear(jl) 3072 zclm(jl, jk1, jk) = zcloud(jl) 3073 END IF 3074 END DO 3075 END DO 3076 END DO 3077 3078 ! * 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS 3079 ! ---------------------------------------------- 3080 3081 3082 ! * 3.1 DOWNWARD FLUXES 3083 ! --------------- 3084 3085 3086 DO jl = 1, kdlon 3087 pflux(jl, 2, kflev+1) = 0. 3088 END DO 3089 3090 DO jk1 = kflev, 1, -1 3091 3092 ! * CONTRIBUTION FROM CLEAR-SKY FRACTION 3093 3094 DO jl = 1, kdlon 3095 zfd(jl) = (1.-zclm(jl,jk1,kflev))*zdnf(jl, 1, jk1) 3096 END DO 3097 3098 ! * CONTRIBUTION FROM ADJACENT CLOUD 3099 3100 DO jl = 1, kdlon 3101 zfd(jl) = zfd(jl) + zclm(jl, jk1, jk1)*zdnf(jl, jk1+1, jk1) 3102 END DO 3103 3104 ! * CONTRIBUTION FROM OTHER CLOUDY FRACTIONS 3105 3106 DO jk = kflev - 1, jk1, -1 3107 DO jl = 1, kdlon 3108 zcfrac = zclm(jl, jk1, jk+1) - zclm(jl, jk1, jk) 3109 zfd(jl) = zfd(jl) + zcfrac*zdnf(jl, jk+2, jk1) 3110 END DO 3111 END DO 3112 3113 DO jl = 1, kdlon 3114 pflux(jl, 2, jk1) = zfd(jl) 3115 END DO 3116 3117 END DO 3118 3119 ! * 3.2 UPWARD FLUX AT THE SURFACE 3120 ! -------------------------- 3121 3122 3123 DO jl = 1, kdlon 3124 pflux(jl, 1, 1) = pemis(jl)*pbsuin(jl) - (1.-pemis(jl))*pflux(jl, 2, 1) 3125 END DO 3126 3127 ! * 3.3 UPWARD FLUXES 3128 ! ------------- 3129 3130 3131 DO jk1 = 2, kflev + 1 3132 3133 ! * CONTRIBUTION FROM CLEAR-SKY FRACTION 3134 3135 DO jl = 1, kdlon 3136 zfu(jl) = (1.-zclm(jl,jk1,1))*zupf(jl, 1, jk1) 3137 END DO 3138 3139 ! * CONTRIBUTION FROM ADJACENT CLOUD 3140 3141 DO jl = 1, kdlon 3142 zfu(jl) = zfu(jl) + zclm(jl, jk1, jk1-1)*zupf(jl, jk1, jk1) 3143 END DO 3144 3145 ! * CONTRIBUTION FROM OTHER CLOUDY FRACTIONS 3146 3147 DO jk = 2, jk1 - 1 3148 DO jl = 1, kdlon 3149 zcfrac = zclm(jl, jk1, jk-1) - zclm(jl, jk1, jk) 3150 zfu(jl) = zfu(jl) + zcfrac*zupf(jl, jk, jk1) 3151 END DO 3152 END DO 3153 3154 DO jl = 1, kdlon 3155 pflux(jl, 1, jk1) = zfu(jl) 3156 END DO 3157 3158 END DO 3159 3160 3161 END IF 3162 3163 ! * 2.3 END OF CLOUD EFFECT COMPUTATIONS 3164 3165 3166 IF (.NOT. levoigt) THEN 3167 DO jl = 1, kdlon 3168 zfn10(jl) = pflux(jl, 1, klim) + pflux(jl, 2, klim) 3169 END DO 3170 DO jk = klim + 1, kflev + 1 3171 DO jl = 1, kdlon 3172 zfn10(jl) = zfn10(jl) + pcts(jl, jk-1) 3173 pflux(jl, 1, jk) = zfn10(jl) 3174 pflux(jl, 2, jk) = 0.0 3175 END DO 3176 END DO 3177 END IF 3178 3179 RETURN 3180 END SUBROUTINE lwc_lmdar4 3181 SUBROUTINE lwb_lmdar4(pdt0, ptave, ptl, pb, pbint, pbsuin, pbsur, pbtop, & 3182 pdbsl, pga, pgb, pgasur, pgbsur, pgatop, pgbtop) 3183 USE dimphy 3184 USE radiation_ar4_param, ONLY: tintp, xp, ga, gb 3185 IMPLICIT NONE 3186 ! ym#include "dimensions.h" 3187 ! ym#include "dimphy.h" 3188 ! ym#include "raddim.h" 3189 include "raddimlw.h" 3190 3191 ! ----------------------------------------------------------------------- 3192 ! PURPOSE. 3193 ! -------- 3194 ! COMPUTES PLANCK FUNCTIONS 3195 3196 ! EXPLICIT ARGUMENTS : 3197 ! -------------------- 3198 ! ==== INPUTS === 3199 ! PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY 3200 ! PTAVE : (KDLON,KFLEV) ; TEMPERATURE 3201 ! PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE 3202 ! ==== OUTPUTS === 3203 ! PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION 3204 ! PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION 3205 ! PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION 3206 ! PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION 3207 ! PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION 3208 ! PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT 3209 ! PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS 3210 ! PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS 3211 ! PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS 3212 ! PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS 3213 3214 ! IMPLICIT ARGUMENTS : NONE 3215 ! -------------------- 3216 3217 ! METHOD. 3218 ! ------- 3219 3220 ! 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS 3221 ! FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION 3222 3223 ! REFERENCE. 3224 ! ---------- 3225 3226 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 3227 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS " 3228 3229 ! AUTHOR. 3230 ! ------- 3231 ! JEAN-JACQUES MORCRETTE *ECMWF* 3232 3233 ! MODIFICATIONS. 3234 ! -------------- 3235 ! ORIGINAL : 89-07-14 3236 3237 ! ----------------------------------------------------------------------- 3238 3239 ! ARGUMENTS: 3240 3241 REAL (KIND=8) pdt0(kdlon) 3242 REAL (KIND=8) ptave(kdlon, kflev) 3243 REAL (KIND=8) ptl(kdlon, kflev+1) 3244 3245 REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION 3246 REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION 3247 REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION 3248 REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION 3249 REAL (KIND=8) pbtop(kdlon, ninter) ! TOP SPECTRAL PLANCK FUNCTION 3250 REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 3251 REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS 3252 REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS 3253 REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS 3254 REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS 3255 REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS 3256 REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS 3257 3258 ! ------------------------------------------------------------------------- 3259 ! * LOCAL VARIABLES: 3260 INTEGER indb(kdlon), inds(kdlon) 3261 REAL (KIND=8) zblay(kdlon, kflev), zblev(kdlon, kflev+1) 3262 REAL (KIND=8) zres(kdlon), zres2(kdlon), zti(kdlon), zti2(kdlon) 3263 3264 INTEGER jk, jl, ic, jnu, jf, jg 3265 INTEGER jk1, jk2 3266 INTEGER k, j, ixtox, indto, ixtx, indt 3267 INTEGER indsu, indtp 3268 REAL (KIND=8) zdsto1, zdstox, zdst1, zdstx 3269 3270 ! * Quelques parametres: 3271 REAL (KIND=8) tstand 3272 PARAMETER (tstand=250.0) 3273 REAL (KIND=8) tstp 3274 PARAMETER (tstp=12.5) 3275 INTEGER mxixt 3276 PARAMETER (mxixt=10) 3277 3278 ! * Used Data Block: 3279 ! REAL*8 TINTP(11) 3280 ! SAVE TINTP 3281 ! c$OMP THREADPRIVATE(TINTP) 3282 ! REAL*8 GA(11,16,3), GB(11,16,3) 3283 ! SAVE GA, GB 3284 ! c$OMP THREADPRIVATE(GA, GB) 3285 ! REAL*8 XP(6,6) 3286 ! SAVE XP 3287 ! c$OMP THREADPRIVATE(XP) 3288 3289 ! DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., 3290 ! S 262.5, 275., 287.5, 300., 312.5 / 3291 ! ----------------------------------------------------------------------- 3292 ! -- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ---------------- 3293 3294 3295 3296 3297 ! -- R.D. -- G = - 0.2 SLA 3298 3299 3300 ! ----- INTERVAL = 1 ----- T = 187.5 3301 3302 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3303 ! DATA (GA( 1, 1,IC),IC=1,3) / 3304 ! S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ 3305 ! DATA (GB( 1, 1,IC),IC=1,3) / 3306 ! S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ 3307 ! DATA (GA( 1, 2,IC),IC=1,3) / 3308 ! S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ 3309 ! DATA (GB( 1, 2,IC),IC=1,3) / 3310 ! S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/ 3311 3312 ! ----- INTERVAL = 1 ----- T = 200.0 3313 3314 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3315 ! DATA (GA( 2, 1,IC),IC=1,3) / 3316 ! S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ 3317 ! DATA (GB( 2, 1,IC),IC=1,3) / 3318 ! S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ 3319 ! DATA (GA( 2, 2,IC),IC=1,3) / 3320 ! S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ 3321 ! DATA (GB( 2, 2,IC),IC=1,3) / 3322 ! S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/ 3323 3324 ! ----- INTERVAL = 1 ----- T = 212.5 3325 3326 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3327 ! DATA (GA( 3, 1,IC),IC=1,3) / 3328 ! S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ 3329 ! DATA (GB( 3, 1,IC),IC=1,3) / 3330 ! S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ 3331 ! DATA (GA( 3, 2,IC),IC=1,3) / 3332 ! S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ 3333 ! DATA (GB( 3, 2,IC),IC=1,3) / 3334 ! S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/ 3335 3336 ! ----- INTERVAL = 1 ----- T = 225.0 3337 3338 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3339 ! DATA (GA( 4, 1,IC),IC=1,3) / 3340 ! S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ 3341 ! DATA (GB( 4, 1,IC),IC=1,3) / 3342 ! S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ 3343 ! DATA (GA( 4, 2,IC),IC=1,3) / 3344 ! S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ 3345 ! DATA (GB( 4, 2,IC),IC=1,3) / 3346 ! S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/ 3347 3348 ! ----- INTERVAL = 1 ----- T = 237.5 3349 3350 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3351 ! DATA (GA( 5, 1,IC),IC=1,3) / 3352 ! S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ 3353 ! DATA (GB( 5, 1,IC),IC=1,3) / 3354 ! S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ 3355 ! DATA (GA( 5, 2,IC),IC=1,3) / 3356 ! S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ 3357 ! DATA (GB( 5, 2,IC),IC=1,3) / 3358 ! S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/ 3359 3360 ! ----- INTERVAL = 1 ----- T = 250.0 3361 3362 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3363 ! DATA (GA( 6, 1,IC),IC=1,3) / 3364 ! S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ 3365 ! DATA (GB( 6, 1,IC),IC=1,3) / 3366 ! S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ 3367 ! DATA (GA( 6, 2,IC),IC=1,3) / 3368 ! S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ 3369 ! DATA (GB( 6, 2,IC),IC=1,3) / 3370 ! S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/ 3371 3372 ! ----- INTERVAL = 1 ----- T = 262.5 3373 3374 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3375 ! DATA (GA( 7, 1,IC),IC=1,3) / 3376 ! S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ 3377 ! DATA (GB( 7, 1,IC),IC=1,3) / 3378 ! S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ 3379 ! DATA (GA( 7, 2,IC),IC=1,3) / 3380 ! S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ 3381 ! DATA (GB( 7, 2,IC),IC=1,3) / 3382 ! S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/ 3383 3384 ! ----- INTERVAL = 1 ----- T = 275.0 3385 3386 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3387 ! DATA (GA( 8, 1,IC),IC=1,3) / 3388 ! S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ 3389 ! DATA (GB( 8, 1,IC),IC=1,3) / 3390 ! S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ 3391 ! DATA (GA( 8, 2,IC),IC=1,3) / 3392 ! S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ 3393 ! DATA (GB( 8, 2,IC),IC=1,3) / 3394 ! S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/ 3395 3396 ! ----- INTERVAL = 1 ----- T = 287.5 3397 3398 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3399 ! DATA (GA( 9, 1,IC),IC=1,3) / 3400 ! S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ 3401 ! DATA (GB( 9, 1,IC),IC=1,3) / 3402 ! S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ 3403 ! DATA (GA( 9, 2,IC),IC=1,3) / 3404 ! S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ 3405 ! DATA (GB( 9, 2,IC),IC=1,3) / 3406 ! S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/ 3407 3408 ! ----- INTERVAL = 1 ----- T = 300.0 3409 3410 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3411 ! DATA (GA(10, 1,IC),IC=1,3) / 3412 ! S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ 3413 ! DATA (GB(10, 1,IC),IC=1,3) / 3414 ! S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ 3415 ! DATA (GA(10, 2,IC),IC=1,3) / 3416 ! S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ 3417 ! DATA (GB(10, 2,IC),IC=1,3) / 3418 ! S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/ 3419 3420 ! ----- INTERVAL = 1 ----- T = 312.5 3421 3422 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 3423 ! DATA (GA(11, 1,IC),IC=1,3) / 3424 ! S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ 3425 ! DATA (GB(11, 1,IC),IC=1,3) / 3426 ! S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ 3427 ! DATA (GA(11, 2,IC),IC=1,3) / 3428 ! S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ 3429 ! DATA (GB(11, 2,IC),IC=1,3) / 3430 ! S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/ 3431 3432 3433 3434 ! --- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 --------- 3435 3436 3437 3438 3439 ! --- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U ) 3440 3441 3442 ! ----- INTERVAL = 2 ----- T = 187.5 3443 3444 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3445 ! DATA (GA( 1, 3,IC),IC=1,3) / 3446 ! S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ 3447 ! DATA (GB( 1, 3,IC),IC=1,3) / 3448 ! S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ 3449 ! DATA (GA( 1, 4,IC),IC=1,3) / 3450 ! S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ 3451 ! DATA (GB( 1, 4,IC),IC=1,3) / 3452 ! S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/ 3453 3454 ! ----- INTERVAL = 2 ----- T = 200.0 3455 3456 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3457 ! DATA (GA( 2, 3,IC),IC=1,3) / 3458 ! S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ 3459 ! DATA (GB( 2, 3,IC),IC=1,3) / 3460 ! S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ 3461 ! DATA (GA( 2, 4,IC),IC=1,3) / 3462 ! S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ 3463 ! DATA (GB( 2, 4,IC),IC=1,3) / 3464 ! S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/ 3465 3466 ! ----- INTERVAL = 2 ----- T = 212.5 3467 3468 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3469 ! DATA (GA( 3, 3,IC),IC=1,3) / 3470 ! S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ 3471 ! DATA (GB( 3, 3,IC),IC=1,3) / 3472 ! S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ 3473 ! DATA (GA( 3, 4,IC),IC=1,3) / 3474 ! S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ 3475 ! DATA (GB( 3, 4,IC),IC=1,3) / 3476 ! S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/ 3477 3478 ! ----- INTERVAL = 2 ----- T = 225.0 3479 3480 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3481 ! DATA (GA( 4, 3,IC),IC=1,3) / 3482 ! S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ 3483 ! DATA (GB( 4, 3,IC),IC=1,3) / 3484 ! S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ 3485 ! DATA (GA( 4, 4,IC),IC=1,3) / 3486 ! S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ 3487 ! DATA (GB( 4, 4,IC),IC=1,3) / 3488 ! S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/ 3489 3490 ! ----- INTERVAL = 2 ----- T = 237.5 3491 3492 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3493 ! DATA (GA( 5, 3,IC),IC=1,3) / 3494 ! S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ 3495 ! DATA (GB( 5, 3,IC),IC=1,3) / 3496 ! S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ 3497 ! DATA (GA( 5, 4,IC),IC=1,3) / 3498 ! S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ 3499 ! DATA (GB( 5, 4,IC),IC=1,3) / 3500 ! S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/ 3501 3502 ! ----- INTERVAL = 2 ----- T = 250.0 3503 3504 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3505 ! DATA (GA( 6, 3,IC),IC=1,3) / 3506 ! S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ 3507 ! DATA (GB( 6, 3,IC),IC=1,3) / 3508 ! S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ 3509 ! DATA (GA( 6, 4,IC),IC=1,3) / 3510 ! S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ 3511 ! DATA (GB( 6, 4,IC),IC=1,3) / 3512 ! S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/ 3513 3514 ! ----- INTERVAL = 2 ----- T = 262.5 3515 3516 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3517 ! DATA (GA( 7, 3,IC),IC=1,3) / 3518 ! S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ 3519 ! DATA (GB( 7, 3,IC),IC=1,3) / 3520 ! S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ 3521 ! DATA (GA( 7, 4,IC),IC=1,3) / 3522 ! S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ 3523 ! DATA (GB( 7, 4,IC),IC=1,3) / 3524 ! S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/ 3525 3526 ! ----- INTERVAL = 2 ----- T = 275.0 3527 3528 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3529 ! DATA (GA( 8, 3,IC),IC=1,3) / 3530 ! S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ 3531 ! DATA (GB( 8, 3,IC),IC=1,3) / 3532 ! S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ 3533 ! DATA (GA( 8, 4,IC),IC=1,3) / 3534 ! S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ 3535 ! DATA (GB( 8, 4,IC),IC=1,3) / 3536 ! S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/ 3537 3538 ! ----- INTERVAL = 2 ----- T = 287.5 3539 3540 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3541 ! DATA (GA( 9, 3,IC),IC=1,3) / 3542 ! S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ 3543 ! DATA (GB( 9, 3,IC),IC=1,3) / 3544 ! S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ 3545 ! DATA (GA( 9, 4,IC),IC=1,3) / 3546 ! S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ 3547 ! DATA (GB( 9, 4,IC),IC=1,3) / 3548 ! S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/ 3549 3550 ! ----- INTERVAL = 2 ----- T = 300.0 3551 3552 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3553 ! DATA (GA(10, 3,IC),IC=1,3) / 3554 ! S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ 3555 ! DATA (GB(10, 3,IC),IC=1,3) / 3556 ! S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ 3557 ! DATA (GA(10, 4,IC),IC=1,3) / 3558 ! S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ 3559 ! DATA (GB(10, 4,IC),IC=1,3) / 3560 ! S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/ 3561 3562 ! ----- INTERVAL = 2 ----- T = 312.5 3563 3564 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3565 ! DATA (GA(11, 3,IC),IC=1,3) / 3566 ! S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ 3567 ! DATA (GB(11, 3,IC),IC=1,3) / 3568 ! S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ 3569 ! DATA (GA(11, 4,IC),IC=1,3) / 3570 ! S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ 3571 ! DATA (GB(11, 4,IC),IC=1,3) / 3572 ! S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/ 3573 3574 3575 3576 3577 3578 3579 ! - WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS - 3580 3581 3582 ! -- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1) 3583 3584 3585 3586 ! --- G = 3.875E-03 --------------- 3587 3588 ! ----- INTERVAL = 3 ----- T = 187.5 3589 3590 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3591 ! DATA (GA( 1, 7,IC),IC=1,3) / 3592 ! S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ 3593 ! DATA (GB( 1, 7,IC),IC=1,3) / 3594 ! S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ 3595 ! DATA (GA( 1, 8,IC),IC=1,3) / 3596 ! S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ 3597 ! DATA (GB( 1, 8,IC),IC=1,3) / 3598 ! S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/ 3599 3600 ! ----- INTERVAL = 3 ----- T = 200.0 3601 3602 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3603 ! DATA (GA( 2, 7,IC),IC=1,3) / 3604 ! S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ 3605 ! DATA (GB( 2, 7,IC),IC=1,3) / 3606 ! S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ 3607 ! DATA (GA( 2, 8,IC),IC=1,3) / 3608 ! S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ 3609 ! DATA (GB( 2, 8,IC),IC=1,3) / 3610 ! S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/ 3611 3612 ! ----- INTERVAL = 3 ----- T = 212.5 3613 3614 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3615 ! DATA (GA( 3, 7,IC),IC=1,3) / 3616 ! S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ 3617 ! DATA (GB( 3, 7,IC),IC=1,3) / 3618 ! S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ 3619 ! DATA (GA( 3, 8,IC),IC=1,3) / 3620 ! S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ 3621 ! DATA (GB( 3, 8,IC),IC=1,3) / 3622 ! S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/ 3623 3624 ! ----- INTERVAL = 3 ----- T = 225.0 3625 3626 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3627 ! DATA (GA( 4, 7,IC),IC=1,3) / 3628 ! S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ 3629 ! DATA (GB( 4, 7,IC),IC=1,3) / 3630 ! S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ 3631 ! DATA (GA( 4, 8,IC),IC=1,3) / 3632 ! S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ 3633 ! DATA (GB( 4, 8,IC),IC=1,3) / 3634 ! S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/ 3635 3636 ! ----- INTERVAL = 3 ----- T = 237.5 3637 3638 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3639 ! DATA (GA( 5, 7,IC),IC=1,3) / 3640 ! S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ 3641 ! DATA (GB( 5, 7,IC),IC=1,3) / 3642 ! S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ 3643 ! DATA (GA( 5, 8,IC),IC=1,3) / 3644 ! S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ 3645 ! DATA (GB( 5, 8,IC),IC=1,3) / 3646 ! S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/ 3647 3648 ! ----- INTERVAL = 3 ----- T = 250.0 3649 3650 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3651 ! DATA (GA( 6, 7,IC),IC=1,3) / 3652 ! S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ 3653 ! DATA (GB( 6, 7,IC),IC=1,3) / 3654 ! S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ 3655 ! DATA (GA( 6, 8,IC),IC=1,3) / 3656 ! S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ 3657 ! DATA (GB( 6, 8,IC),IC=1,3) / 3658 ! S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/ 3659 3660 ! ----- INTERVAL = 3 ----- T = 262.5 3661 3662 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3663 ! DATA (GA( 7, 7,IC),IC=1,3) / 3664 ! S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ 3665 ! DATA (GB( 7, 7,IC),IC=1,3) / 3666 ! S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ 3667 ! DATA (GA( 7, 8,IC),IC=1,3) / 3668 ! S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ 3669 ! DATA (GB( 7, 8,IC),IC=1,3) / 3670 ! S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/ 3671 3672 ! ----- INTERVAL = 3 ----- T = 275.0 3673 3674 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3675 ! DATA (GA( 8, 7,IC),IC=1,3) / 3676 ! S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ 3677 ! DATA (GB( 8, 7,IC),IC=1,3) / 3678 ! S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ 3679 ! DATA (GA( 8, 8,IC),IC=1,3) / 3680 ! S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ 3681 ! DATA (GB( 8, 8,IC),IC=1,3) / 3682 ! S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/ 3683 3684 ! ----- INTERVAL = 3 ----- T = 287.5 3685 3686 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3687 ! DATA (GA( 9, 7,IC),IC=1,3) / 3688 ! S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ 3689 ! DATA (GB( 9, 7,IC),IC=1,3) / 3690 ! S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ 3691 ! DATA (GA( 9, 8,IC),IC=1,3) / 3692 ! S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ 3693 ! DATA (GB( 9, 8,IC),IC=1,3) / 3694 ! S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/ 3695 3696 ! ----- INTERVAL = 3 ----- T = 300.0 3697 3698 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3699 ! DATA (GA(10, 7,IC),IC=1,3) / 3700 ! S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ 3701 ! DATA (GB(10, 7,IC),IC=1,3) / 3702 ! S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ 3703 ! DATA (GA(10, 8,IC),IC=1,3) / 3704 ! S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ 3705 ! DATA (GB(10, 8,IC),IC=1,3) / 3706 ! S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/ 3707 3708 ! ----- INTERVAL = 3 ----- T = 312.5 3709 3710 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3711 ! DATA (GA(11, 7,IC),IC=1,3) / 3712 ! S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ 3713 ! DATA (GB(11, 7,IC),IC=1,3) / 3714 ! S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ 3715 ! DATA (GA(11, 8,IC),IC=1,3) / 3716 ! S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ 3717 ! DATA (GB(11, 8,IC),IC=1,3) / 3718 ! S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/ 3719 3720 3721 ! -- WATER VAPOR -- 970-1110 CM-1 ---------------------------------------- 3722 3723 ! -- G = 3.6E-03 3724 3725 ! ----- INTERVAL = 4 ----- T = 187.5 3726 3727 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3728 ! DATA (GA( 1, 9,IC),IC=1,3) / 3729 ! S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ 3730 ! DATA (GB( 1, 9,IC),IC=1,3) / 3731 ! S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ 3732 ! DATA (GA( 1,10,IC),IC=1,3) / 3733 ! S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ 3734 ! DATA (GB( 1,10,IC),IC=1,3) / 3735 ! S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/ 3736 3737 ! ----- INTERVAL = 4 ----- T = 200.0 3738 3739 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3740 ! DATA (GA( 2, 9,IC),IC=1,3) / 3741 ! S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ 3742 ! DATA (GB( 2, 9,IC),IC=1,3) / 3743 ! S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ 3744 ! DATA (GA( 2,10,IC),IC=1,3) / 3745 ! S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ 3746 ! DATA (GB( 2,10,IC),IC=1,3) / 3747 ! S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/ 3748 3749 ! ----- INTERVAL = 4 ----- T = 212.5 3750 3751 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3752 ! DATA (GA( 3, 9,IC),IC=1,3) / 3753 ! S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ 3754 ! DATA (GB( 3, 9,IC),IC=1,3) / 3755 ! S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ 3756 ! DATA (GA( 3,10,IC),IC=1,3) / 3757 ! S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ 3758 ! DATA (GB( 3,10,IC),IC=1,3) / 3759 ! S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/ 3760 3761 ! ----- INTERVAL = 4 ----- T = 225.0 3762 3763 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3764 ! DATA (GA( 4, 9,IC),IC=1,3) / 3765 ! S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ 3766 ! DATA (GB( 4, 9,IC),IC=1,3) / 3767 ! S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ 3768 ! DATA (GA( 4,10,IC),IC=1,3) / 3769 ! S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ 3770 ! DATA (GB( 4,10,IC),IC=1,3) / 3771 ! S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/ 3772 3773 ! ----- INTERVAL = 4 ----- T = 237.5 3774 3775 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3776 ! DATA (GA( 5, 9,IC),IC=1,3) / 3777 ! S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ 3778 ! DATA (GB( 5, 9,IC),IC=1,3) / 3779 ! S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ 3780 ! DATA (GA( 5,10,IC),IC=1,3) / 3781 ! S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ 3782 ! DATA (GB( 5,10,IC),IC=1,3) / 3783 ! S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/ 3784 3785 ! ----- INTERVAL = 4 ----- T = 250.0 3786 3787 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3788 ! DATA (GA( 6, 9,IC),IC=1,3) / 3789 ! S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ 3790 ! DATA (GB( 6, 9,IC),IC=1,3) / 3791 ! S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ 3792 ! DATA (GA( 6,10,IC),IC=1,3) / 3793 ! S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ 3794 ! DATA (GB( 6,10,IC),IC=1,3) / 3795 ! S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/ 3796 3797 ! ----- INTERVAL = 4 ----- T = 262.5 3798 3799 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3800 ! DATA (GA( 7, 9,IC),IC=1,3) / 3801 ! S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ 3802 ! DATA (GB( 7, 9,IC),IC=1,3) / 3803 ! S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ 3804 ! DATA (GA( 7,10,IC),IC=1,3) / 3805 ! S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ 3806 ! DATA (GB( 7,10,IC),IC=1,3) / 3807 ! S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/ 3808 3809 ! ----- INTERVAL = 4 ----- T = 275.0 3810 3811 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3812 ! DATA (GA( 8, 9,IC),IC=1,3) / 3813 ! S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ 3814 ! DATA (GB( 8, 9,IC),IC=1,3) / 3815 ! S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ 3816 ! DATA (GA( 8,10,IC),IC=1,3) / 3817 ! S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ 3818 ! DATA (GB( 8,10,IC),IC=1,3) / 3819 ! S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/ 3820 3821 ! ----- INTERVAL = 4 ----- T = 287.5 3822 3823 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3824 ! DATA (GA( 9, 9,IC),IC=1,3) / 3825 ! S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ 3826 ! DATA (GB( 9, 9,IC),IC=1,3) / 3827 ! S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ 3828 ! DATA (GA( 9,10,IC),IC=1,3) / 3829 ! S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ 3830 ! DATA (GB( 9,10,IC),IC=1,3) / 3831 ! S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/ 3832 3833 ! ----- INTERVAL = 4 ----- T = 300.0 3834 3835 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3836 ! DATA (GA(10, 9,IC),IC=1,3) / 3837 ! S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ 3838 ! DATA (GB(10, 9,IC),IC=1,3) / 3839 ! S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ 3840 ! DATA (GA(10,10,IC),IC=1,3) / 3841 ! S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ 3842 ! DATA (GB(10,10,IC),IC=1,3) / 3843 ! S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/ 3844 3845 ! ----- INTERVAL = 4 ----- T = 312.5 3846 3847 ! -- INDICES FOR PADE APPROXIMATION 1 28 37 45 3848 ! DATA (GA(11, 9,IC),IC=1,3) / 3849 ! S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ 3850 ! DATA (GB(11, 9,IC),IC=1,3) / 3851 ! S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ 3852 ! DATA (GA(11,10,IC),IC=1,3) / 3853 ! S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ 3854 ! DATA (GB(11,10,IC),IC=1,3) / 3855 ! S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/ 3856 3857 3858 3859 ! -- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ---- 3860 3861 ! -- WATER VAPOR --- 350 - 500 CM-1 3862 3863 ! -- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U) 3864 3865 ! ----- INTERVAL = 5 ----- T = 187.5 3866 3867 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3868 ! DATA (GA( 1, 5,IC),IC=1,3) / 3869 ! S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ 3870 ! DATA (GB( 1, 5,IC),IC=1,3) / 3871 ! S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ 3872 ! DATA (GA( 1, 6,IC),IC=1,3) / 3873 ! S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ 3874 ! DATA (GB( 1, 6,IC),IC=1,3) / 3875 ! S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/ 3876 3877 ! ----- INTERVAL = 5 ----- T = 200.0 3878 3879 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3880 ! DATA (GA( 2, 5,IC),IC=1,3) / 3881 ! S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ 3882 ! DATA (GB( 2, 5,IC),IC=1,3) / 3883 ! S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ 3884 ! DATA (GA( 2, 6,IC),IC=1,3) / 3885 ! S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ 3886 ! DATA (GB( 2, 6,IC),IC=1,3) / 3887 ! S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/ 3888 3889 ! ----- INTERVAL = 5 ----- T = 212.5 3890 3891 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3892 ! DATA (GA( 3, 5,IC),IC=1,3) / 3893 ! S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ 3894 ! DATA (GB( 3, 5,IC),IC=1,3) / 3895 ! S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ 3896 ! DATA (GA( 3, 6,IC),IC=1,3) / 3897 ! S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ 3898 ! DATA (GB( 3, 6,IC),IC=1,3) / 3899 ! S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/ 3900 3901 ! ----- INTERVAL = 5 ----- T = 225.0 3902 3903 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3904 ! DATA (GA( 4, 5,IC),IC=1,3) / 3905 ! S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ 3906 ! DATA (GB( 4, 5,IC),IC=1,3) / 3907 ! S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ 3908 ! DATA (GA( 4, 6,IC),IC=1,3) / 3909 ! S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ 3910 ! DATA (GB( 4, 6,IC),IC=1,3) / 3911 ! S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/ 3912 3913 ! ----- INTERVAL = 5 ----- T = 237.5 3914 3915 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3916 ! DATA (GA( 5, 5,IC),IC=1,3) / 3917 ! S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ 3918 ! DATA (GB( 5, 5,IC),IC=1,3) / 3919 ! S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ 3920 ! DATA (GA( 5, 6,IC),IC=1,3) / 3921 ! S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ 3922 ! DATA (GB( 5, 6,IC),IC=1,3) / 3923 ! S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/ 3924 3925 ! ----- INTERVAL = 5 ----- T = 250.0 3926 3927 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3928 ! DATA (GA( 6, 5,IC),IC=1,3) / 3929 ! S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ 3930 ! DATA (GB( 6, 5,IC),IC=1,3) / 3931 ! S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ 3932 ! DATA (GA( 6, 6,IC),IC=1,3) / 3933 ! S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ 3934 ! DATA (GB( 6, 6,IC),IC=1,3) / 3935 ! S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/ 3936 3937 ! ----- INTERVAL = 5 ----- T = 262.5 3938 3939 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3940 ! DATA (GA( 7, 5,IC),IC=1,3) / 3941 ! S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ 3942 ! DATA (GB( 7, 5,IC),IC=1,3) / 3943 ! S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ 3944 ! DATA (GA( 7, 6,IC),IC=1,3) / 3945 ! S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ 3946 ! DATA (GB( 7, 6,IC),IC=1,3) / 3947 ! S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/ 3948 3949 ! ----- INTERVAL = 5 ----- T = 275.0 3950 3951 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3952 ! DATA (GA( 8, 5,IC),IC=1,3) / 3953 ! S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ 3954 ! DATA (GB( 8, 5,IC),IC=1,3) / 3955 ! S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ 3956 ! DATA (GA( 8, 6,IC),IC=1,3) / 3957 ! S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ 3958 ! DATA (GB( 8, 6,IC),IC=1,3) / 3959 ! S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/ 3960 3961 ! ----- INTERVAL = 5 ----- T = 287.5 3962 3963 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3964 ! DATA (GA( 9, 5,IC),IC=1,3) / 3965 ! S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ 3966 ! DATA (GB( 9, 5,IC),IC=1,3) / 3967 ! S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ 3968 ! DATA (GA( 9, 6,IC),IC=1,3) / 3969 ! S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ 3970 ! DATA (GB( 9, 6,IC),IC=1,3) / 3971 ! S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/ 3972 3973 ! ----- INTERVAL = 5 ----- T = 300.0 3974 3975 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3976 ! DATA (GA(10, 5,IC),IC=1,3) / 3977 ! S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ 3978 ! DATA (GB(10, 5,IC),IC=1,3) / 3979 ! S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ 3980 ! DATA (GA(10, 6,IC),IC=1,3) / 3981 ! S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ 3982 ! DATA (GB(10, 6,IC),IC=1,3) / 3983 ! S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/ 3984 3985 ! ----- INTERVAL = 5 ----- T = 312.5 3986 3987 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 3988 ! DATA (GA(11, 5,IC),IC=1,3) / 3989 ! S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ 3990 ! DATA (GB(11, 5,IC),IC=1,3) / 3991 ! S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ 3992 ! DATA (GA(11, 6,IC),IC=1,3) / 3993 ! S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ 3994 ! DATA (GB(11, 6,IC),IC=1,3) / 3995 ! S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/ 3996 3997 3998 3999 4000 ! - WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 - 4001 ! --- G = 0.0 4002 4003 4004 ! ----- INTERVAL = 6 ----- T = 187.5 4005 4006 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4007 ! DATA (GA( 1,11,IC),IC=1,3) / 4008 ! S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ 4009 ! DATA (GB( 1,11,IC),IC=1,3) / 4010 ! S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ 4011 ! DATA (GA( 1,12,IC),IC=1,3) / 4012 ! S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ 4013 ! DATA (GB( 1,12,IC),IC=1,3) / 4014 ! S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/ 4015 4016 ! ----- INTERVAL = 6 ----- T = 200.0 4017 4018 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4019 ! DATA (GA( 2,11,IC),IC=1,3) / 4020 ! S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ 4021 ! DATA (GB( 2,11,IC),IC=1,3) / 4022 ! S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ 4023 ! DATA (GA( 2,12,IC),IC=1,3) / 4024 ! S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ 4025 ! DATA (GB( 2,12,IC),IC=1,3) / 4026 ! S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/ 4027 4028 ! ----- INTERVAL = 6 ----- T = 212.5 4029 4030 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4031 ! DATA (GA( 3,11,IC),IC=1,3) / 4032 ! S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ 4033 ! DATA (GB( 3,11,IC),IC=1,3) / 4034 ! S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ 4035 ! DATA (GA( 3,12,IC),IC=1,3) / 4036 ! S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ 4037 ! DATA (GB( 3,12,IC),IC=1,3) / 4038 ! S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/ 4039 4040 ! ----- INTERVAL = 6 ----- T = 225.0 4041 4042 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4043 ! DATA (GA( 4,11,IC),IC=1,3) / 4044 ! S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ 4045 ! DATA (GB( 4,11,IC),IC=1,3) / 4046 ! S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ 4047 ! DATA (GA( 4,12,IC),IC=1,3) / 4048 ! S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ 4049 ! DATA (GB( 4,12,IC),IC=1,3) / 4050 ! S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/ 4051 4052 ! ----- INTERVAL = 6 ----- T = 237.5 4053 4054 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4055 ! DATA (GA( 5,11,IC),IC=1,3) / 4056 ! S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ 4057 ! DATA (GB( 5,11,IC),IC=1,3) / 4058 ! S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ 4059 ! DATA (GA( 5,12,IC),IC=1,3) / 4060 ! S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ 4061 ! DATA (GB( 5,12,IC),IC=1,3) / 4062 ! S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/ 4063 4064 ! ----- INTERVAL = 6 ----- T = 250.0 4065 4066 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4067 ! DATA (GA( 6,11,IC),IC=1,3) / 4068 ! S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ 4069 ! DATA (GB( 6,11,IC),IC=1,3) / 4070 ! S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ 4071 ! DATA (GA( 6,12,IC),IC=1,3) / 4072 ! S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ 4073 ! DATA (GB( 6,12,IC),IC=1,3) / 4074 ! S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/ 4075 4076 ! ----- INTERVAL = 6 ----- T = 262.5 4077 4078 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4079 ! DATA (GA( 7,11,IC),IC=1,3) / 4080 ! S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ 4081 ! DATA (GB( 7,11,IC),IC=1,3) / 4082 ! S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ 4083 ! DATA (GA( 7,12,IC),IC=1,3) / 4084 ! S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ 4085 ! DATA (GB( 7,12,IC),IC=1,3) / 4086 ! S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/ 4087 4088 ! ----- INTERVAL = 6 ----- T = 275.0 4089 4090 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4091 ! DATA (GA( 8,11,IC),IC=1,3) / 4092 ! S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ 4093 ! DATA (GB( 8,11,IC),IC=1,3) / 4094 ! S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ 4095 ! DATA (GA( 8,12,IC),IC=1,3) / 4096 ! S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ 4097 ! DATA (GB( 8,12,IC),IC=1,3) / 4098 ! S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/ 4099 4100 ! ----- INTERVAL = 6 ----- T = 287.5 4101 4102 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4103 ! DATA (GA( 9,11,IC),IC=1,3) / 4104 ! S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ 4105 ! DATA (GB( 9,11,IC),IC=1,3) / 4106 ! S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ 4107 ! DATA (GA( 9,12,IC),IC=1,3) / 4108 ! S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ 4109 ! DATA (GB( 9,12,IC),IC=1,3) / 4110 ! S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/ 4111 4112 ! ----- INTERVAL = 6 ----- T = 300.0 4113 4114 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4115 ! DATA (GA(10,11,IC),IC=1,3) / 4116 ! S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ 4117 ! DATA (GB(10,11,IC),IC=1,3) / 4118 ! S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ 4119 ! DATA (GA(10,12,IC),IC=1,3) / 4120 ! S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ 4121 ! DATA (GB(10,12,IC),IC=1,3) / 4122 ! S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/ 4123 4124 ! ----- INTERVAL = 6 ----- T = 312.5 4125 4126 ! -- INDICES FOR PADE APPROXIMATION 1 35 40 45 4127 ! DATA (GA(11,11,IC),IC=1,3) / 4128 ! S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ 4129 ! DATA (GB(11,11,IC),IC=1,3) / 4130 ! S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ 4131 ! DATA (GA(11,12,IC),IC=1,3) / 4132 ! S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ 4133 ! DATA (GB(11,12,IC),IC=1,3) / 4134 ! S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/ 4135 4136 4137 4138 4139 4140 ! -- END WATER VAPOR 4141 4142 4143 ! -- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ---------------------- 4144 4145 4146 4147 ! -- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9 4148 4149 ! ----- INTERVAL = 2 ----- T = 187.5 4150 4151 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4152 ! DATA (GA( 1,13,IC),IC=1,3) / 4153 ! S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ 4154 ! DATA (GB( 1,13,IC),IC=1,3) / 4155 ! S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ 4156 ! DATA (GA( 1,14,IC),IC=1,3) / 4157 ! S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ 4158 ! DATA (GB( 1,14,IC),IC=1,3) / 4159 ! S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/ 4160 4161 ! ----- INTERVAL = 2 ----- T = 200.0 4162 4163 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4164 ! DATA (GA( 2,13,IC),IC=1,3) / 4165 ! S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ 4166 ! DATA (GB( 2,13,IC),IC=1,3) / 4167 ! S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ 4168 ! DATA (GA( 2,14,IC),IC=1,3) / 4169 ! S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ 4170 ! DATA (GB( 2,14,IC),IC=1,3) / 4171 ! S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/ 4172 4173 ! ----- INTERVAL = 2 ----- T = 212.5 4174 4175 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4176 ! DATA (GA( 3,13,IC),IC=1,3) / 4177 ! S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ 4178 ! DATA (GB( 3,13,IC),IC=1,3) / 4179 ! S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ 4180 ! DATA (GA( 3,14,IC),IC=1,3) / 4181 ! S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ 4182 ! DATA (GB( 3,14,IC),IC=1,3) / 4183 ! S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/ 4184 4185 ! ----- INTERVAL = 2 ----- T = 225.0 4186 4187 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4188 ! DATA (GA( 4,13,IC),IC=1,3) / 4189 ! S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ 4190 ! DATA (GB( 4,13,IC),IC=1,3) / 4191 ! S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ 4192 ! DATA (GA( 4,14,IC),IC=1,3) / 4193 ! S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ 4194 ! DATA (GB( 4,14,IC),IC=1,3) / 4195 ! S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/ 4196 4197 ! ----- INTERVAL = 2 ----- T = 237.5 4198 4199 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4200 ! DATA (GA( 5,13,IC),IC=1,3) / 4201 ! S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ 4202 ! DATA (GB( 5,13,IC),IC=1,3) / 4203 ! S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ 4204 ! DATA (GA( 5,14,IC),IC=1,3) / 4205 ! S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ 4206 ! DATA (GB( 5,14,IC),IC=1,3) / 4207 ! S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/ 4208 4209 ! ----- INTERVAL = 2 ----- T = 250.0 4210 4211 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4212 ! DATA (GA( 6,13,IC),IC=1,3) / 4213 ! S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ 4214 ! DATA (GB( 6,13,IC),IC=1,3) / 4215 ! S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ 4216 ! DATA (GA( 6,14,IC),IC=1,3) / 4217 ! S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ 4218 ! DATA (GB( 6,14,IC),IC=1,3) / 4219 ! S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/ 4220 4221 ! ----- INTERVAL = 2 ----- T = 262.5 4222 4223 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4224 ! DATA (GA( 7,13,IC),IC=1,3) / 4225 ! S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ 4226 ! DATA (GB( 7,13,IC),IC=1,3) / 4227 ! S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ 4228 ! DATA (GA( 7,14,IC),IC=1,3) / 4229 ! S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ 4230 ! DATA (GB( 7,14,IC),IC=1,3) / 4231 ! S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/ 4232 4233 ! ----- INTERVAL = 2 ----- T = 275.0 4234 4235 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4236 ! DATA (GA( 8,13,IC),IC=1,3) / 4237 ! S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ 4238 ! DATA (GB( 8,13,IC),IC=1,3) / 4239 ! S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ 4240 ! DATA (GA( 8,14,IC),IC=1,3) / 4241 ! S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ 4242 ! DATA (GB( 8,14,IC),IC=1,3) / 4243 ! S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/ 4244 4245 ! ----- INTERVAL = 2 ----- T = 287.5 4246 4247 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4248 ! DATA (GA( 9,13,IC),IC=1,3) / 4249 ! S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ 4250 ! DATA (GB( 9,13,IC),IC=1,3) / 4251 ! S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ 4252 ! DATA (GA( 9,14,IC),IC=1,3) / 4253 ! S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ 4254 ! DATA (GB( 9,14,IC),IC=1,3) / 4255 ! S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/ 4256 4257 ! ----- INTERVAL = 2 ----- T = 300.0 4258 4259 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4260 ! DATA (GA(10,13,IC),IC=1,3) / 4261 ! S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ 4262 ! DATA (GB(10,13,IC),IC=1,3) / 4263 ! S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ 4264 ! DATA (GA(10,14,IC),IC=1,3) / 4265 ! S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ 4266 ! DATA (GB(10,14,IC),IC=1,3) / 4267 ! S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/ 4268 4269 ! ----- INTERVAL = 2 ----- T = 312.5 4270 4271 ! -- INDICES FOR PADE APPROXIMATION 1 30 38 45 4272 ! DATA (GA(11,13,IC),IC=1,3) / 4273 ! S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ 4274 ! DATA (GB(11,13,IC),IC=1,3) / 4275 ! S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ 4276 ! DATA (GA(11,14,IC),IC=1,3) / 4277 ! S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ 4278 ! DATA (GB(11,14,IC),IC=1,3) / 4279 ! S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/ 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 ! -- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1) 4291 4292 4293 ! -- G = 0.0 4294 4295 4296 ! ----- INTERVAL = 4 ----- T = 187.5 4297 4298 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4299 ! DATA (GA( 1,15,IC),IC=1,3) / 4300 ! S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ 4301 ! DATA (GB( 1,15,IC),IC=1,3) / 4302 ! S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ 4303 ! DATA (GA( 1,16,IC),IC=1,3) / 4304 ! S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ 4305 ! DATA (GB( 1,16,IC),IC=1,3) / 4306 ! S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/ 4307 4308 ! ----- INTERVAL = 4 ----- T = 200.0 4309 4310 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4311 ! DATA (GA( 2,15,IC),IC=1,3) / 4312 ! S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ 4313 ! DATA (GB( 2,15,IC),IC=1,3) / 4314 ! S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ 4315 ! DATA (GA( 2,16,IC),IC=1,3) / 4316 ! S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ 4317 ! DATA (GB( 2,16,IC),IC=1,3) / 4318 ! S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/ 4319 4320 ! ----- INTERVAL = 4 ----- T = 212.5 4321 4322 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4323 ! DATA (GA( 3,15,IC),IC=1,3) / 4324 ! S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ 4325 ! DATA (GB( 3,15,IC),IC=1,3) / 4326 ! S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ 4327 ! DATA (GA( 3,16,IC),IC=1,3) / 4328 ! S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ 4329 ! DATA (GB( 3,16,IC),IC=1,3) / 4330 ! S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/ 4331 4332 ! ----- INTERVAL = 4 ----- T = 225.0 4333 4334 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4335 ! DATA (GA( 4,15,IC),IC=1,3) / 4336 ! S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ 4337 ! DATA (GB( 4,15,IC),IC=1,3) / 4338 ! S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ 4339 ! DATA (GA( 4,16,IC),IC=1,3) / 4340 ! S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ 4341 ! DATA (GB( 4,16,IC),IC=1,3) / 4342 ! S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/ 4343 4344 ! ----- INTERVAL = 4 ----- T = 237.5 4345 4346 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4347 ! DATA (GA( 5,15,IC),IC=1,3) / 4348 ! S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ 4349 ! DATA (GB( 5,15,IC),IC=1,3) / 4350 ! S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ 4351 ! DATA (GA( 5,16,IC),IC=1,3) / 4352 ! S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ 4353 ! DATA (GB( 5,16,IC),IC=1,3) / 4354 ! S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/ 4355 4356 ! ----- INTERVAL = 4 ----- T = 250.0 4357 4358 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4359 ! DATA (GA( 6,15,IC),IC=1,3) / 4360 ! S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ 4361 ! DATA (GB( 6,15,IC),IC=1,3) / 4362 ! S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ 4363 ! DATA (GA( 6,16,IC),IC=1,3) / 4364 ! S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ 4365 ! DATA (GB( 6,16,IC),IC=1,3) / 4366 ! S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/ 4367 4368 ! ----- INTERVAL = 4 ----- T = 262.5 4369 4370 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4371 ! DATA (GA( 7,15,IC),IC=1,3) / 4372 ! S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ 4373 ! DATA (GB( 7,15,IC),IC=1,3) / 4374 ! S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ 4375 ! DATA (GA( 7,16,IC),IC=1,3) / 4376 ! S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ 4377 ! DATA (GB( 7,16,IC),IC=1,3) / 4378 ! S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/ 4379 4380 ! ----- INTERVAL = 4 ----- T = 275.0 4381 4382 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4383 ! DATA (GA( 8,15,IC),IC=1,3) / 4384 ! S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ 4385 ! DATA (GB( 8,15,IC),IC=1,3) / 4386 ! S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ 4387 ! DATA (GA( 8,16,IC),IC=1,3) / 4388 ! S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ 4389 ! DATA (GB( 8,16,IC),IC=1,3) / 4390 ! S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/ 4391 4392 ! ----- INTERVAL = 4 ----- T = 287.5 4393 4394 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4395 ! DATA (GA( 9,15,IC),IC=1,3) / 4396 ! S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ 4397 ! DATA (GB( 9,15,IC),IC=1,3) / 4398 ! S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ 4399 ! DATA (GA( 9,16,IC),IC=1,3) / 4400 ! S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ 4401 ! DATA (GB( 9,16,IC),IC=1,3) / 4402 ! S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/ 4403 4404 ! ----- INTERVAL = 4 ----- T = 300.0 4405 4406 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4407 ! DATA (GA(10,15,IC),IC=1,3) / 4408 ! S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ 4409 ! DATA (GB(10,15,IC),IC=1,3) / 4410 ! S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ 4411 ! DATA (GA(10,16,IC),IC=1,3) / 4412 ! S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ 4413 ! DATA (GB(10,16,IC),IC=1,3) / 4414 ! S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/ 4415 4416 ! ----- INTERVAL = 4 ----- T = 312.5 4417 4418 ! -- INDICES FOR PADE APPROXIMATION 1 15 29 45 4419 ! DATA (GA(11,15,IC),IC=1,3) / 4420 ! S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ 4421 ! DATA (GB(11,15,IC),IC=1,3) / 4422 ! S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ 4423 ! DATA (GA(11,16,IC),IC=1,3) / 4424 ! S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ 4425 ! DATA (GB(11,16,IC),IC=1,3) / 4426 ! S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ 4427 4428 ! ------------------------------------------------------------------ 4429 ! DATA (( XP( J,K),J=1,6), K=1,6) / 4430 ! S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, 4431 ! S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, 4432 ! S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, 4433 ! S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, 4434 ! S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, 4435 ! S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, 4436 ! S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, 4437 ! S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, 4438 ! S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, 4439 ! S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, 4440 ! S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, 4441 ! S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / 4442 4443 4444 4445 ! * 1.0 PLANCK FUNCTIONS AND GRADIENTS 4446 ! ------------------------------ 4447 4448 4449 ! cdir collapse 4450 DO jk = 1, kflev + 1 4451 DO jl = 1, kdlon 4452 pbint(jl, jk) = 0. 4453 END DO 4454 END DO 4455 DO jl = 1, kdlon 4456 pbsuin(jl) = 0. 4457 END DO 4458 4459 DO jnu = 1, ninter 4460 4461 ! * 1.1 LEVELS FROM SURFACE TO KFLEV 4462 ! ---------------------------- 4463 4464 4465 DO jk = 1, kflev 4466 DO jl = 1, kdlon 4467 zti(jl) = (ptl(jl,jk)-tstand)/tstand 4468 zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, & 4469 jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu)))))) 4470 pbint(jl, jk) = pbint(jl, jk) + zres(jl) 4471 pb(jl, jnu, jk) = zres(jl) 4472 zblev(jl, jk) = zres(jl) 4473 zti2(jl) = (ptave(jl,jk)-tstand)/tstand 4474 zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, & 4475 jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu)))) & 4476 )) 4477 zblay(jl, jk) = zres2(jl) 4478 END DO 4479 END DO 4480 4481 ! * 1.2 TOP OF THE ATMOSPHERE AND SURFACE 4482 ! --------------------------------- 4483 4484 4485 DO jl = 1, kdlon 4486 zti(jl) = (ptl(jl,kflev+1)-tstand)/tstand 4487 zti2(jl) = (ptl(jl,1)+pdt0(jl)-tstand)/tstand 4488 zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, & 4489 jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu)))))) 4490 zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, & 4491 jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu)))))) 4492 pbint(jl, kflev+1) = pbint(jl, kflev+1) + zres(jl) 4493 pb(jl, jnu, kflev+1) = zres(jl) 4494 zblev(jl, kflev+1) = zres(jl) 4495 pbtop(jl, jnu) = zres(jl) 4496 pbsur(jl, jnu) = zres2(jl) 4497 pbsuin(jl) = pbsuin(jl) + zres2(jl) 4498 END DO 4499 4500 ! * 1.3 GRADIENTS IN SUB-LAYERS 4501 ! ----------------------- 4502 4503 4504 DO jk = 1, kflev 4505 jk2 = 2*jk 4506 jk1 = jk2 - 1 4507 DO jl = 1, kdlon 4508 pdbsl(jl, jnu, jk1) = zblay(jl, jk) - zblev(jl, jk) 4509 pdbsl(jl, jnu, jk2) = zblev(jl, jk+1) - zblay(jl, jk) 4510 END DO 4511 END DO 4512 4513 END DO 4514 4515 ! * 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS 4516 ! --------------------------------------------- 4517 4518 4519 4520 4521 DO jl = 1, kdlon 4522 zdsto1 = (ptl(jl,kflev+1)-tintp(1))/tstp 4523 ixtox = max(1, min(mxixt,int(zdsto1+1.))) 4524 zdstox = (ptl(jl,kflev+1)-tintp(ixtox))/tstp 4525 IF (zdstox<0.5) THEN 4526 indto = ixtox 4527 ELSE 4528 indto = ixtox + 1 4529 END IF 4530 indb(jl) = indto 4531 zdst1 = (ptl(jl,1)-tintp(1))/tstp 4532 ixtx = max(1, min(mxixt,int(zdst1+1.))) 4533 zdstx = (ptl(jl,1)-tintp(ixtx))/tstp 4534 IF (zdstx<0.5) THEN 4535 indt = ixtx 4536 ELSE 4537 indt = ixtx + 1 4538 END IF 4539 inds(jl) = indt 4540 END DO 4541 4542 DO jf = 1, 2 4543 DO jg = 1, 8 4544 DO jl = 1, kdlon 4545 indsu = inds(jl) 4546 pgasur(jl, jg, jf) = ga(indsu, 2*jg-1, jf) 4547 pgbsur(jl, jg, jf) = gb(indsu, 2*jg-1, jf) 4548 indtp = indb(jl) 4549 pgatop(jl, jg, jf) = ga(indtp, 2*jg-1, jf) 4550 pgbtop(jl, jg, jf) = gb(indtp, 2*jg-1, jf) 4551 END DO 4552 END DO 4553 END DO 4554 4555 DO jk = 1, kflev 4556 DO jl = 1, kdlon 4557 zdst1 = (ptave(jl,jk)-tintp(1))/tstp 4558 ixtx = max(1, min(mxixt,int(zdst1+1.))) 4559 zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp 4560 IF (zdstx<0.5) THEN 4561 indt = ixtx 1001 4562 ELSE 1002 ZAA=PUD(JL,JABS,JKM1) 1003 ZBB=ZAA 4563 indt = ixtx + 1 1004 4564 END IF 1005 ZRKI = PAKI(JL,JABS) 1006 ZS(JL) = EXP(-ZRKI * ZAA * 1.66) 1007 ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK)) 1008 ZTR1(JL) = 0. 1009 ZRE1(JL) = 0. 1010 ZTR2(JL) = 0. 1011 ZRE2(JL) = 0. 1012 C 1013 ZW(JL)= POMEGA(JL,KNU,JKM1) 1014 ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL) 1015 S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1) 1016 S + ZBB * ZRKI 1017 1018 ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1) 1019 ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) 1020 ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) 1021 S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1) 1022 ZW(JL) = ZR21(JL) / ZTO1(JL) 1023 ZREF(JL) = ZREFZ(JL,1,JKM1) 1024 ZRMUZ(JL) = ZRMUE(JL,JK) 1025 322 CONTINUE 1026 C 1027 CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW, 1028 S ZRE1, ZRE2, ZTR1, ZTR2) 1029 C 1030 DO 323 JL = 1, KDLON 1031 C 1032 ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1) 1033 S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1) 1034 S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL) 1035 S + ZRNEB(JL) * ZRE1(JL) 1036 C 1037 ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL) 1038 S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL)) 1039 C 1040 ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1) 1041 S +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1) 1042 S /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL) 1043 S + ZRNEB(JL) * ZRE2(JL) 1044 C 1045 ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL) 1046 S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1) 1047 S * ZREFZ(JL,1,JKM1))) 1048 S * ZG(JL) * (1. -ZRNEB(JL)) 1049 C 1050 323 CONTINUE 1051 324 CONTINUE 1052 C 1053 C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 1054 C ------------------------------------------------- 1055 C 1056 330 CONTINUE 1057 C 1058 DO 351 JREF=1,2 1059 C 1060 JN = JN + 1 1061 C 1062 DO 331 JL = 1, KDLON 1063 ZRJ(JL,JN,KFLEV+1) = 1. 1064 ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1) 1065 331 CONTINUE 1066 C 1067 DO 333 JK = 1 , KFLEV 1068 JKL = KFLEV+1 - JK 1069 JKLP1 = JKL + 1 1070 DO 332 JL = 1, KDLON 1071 ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL) 1072 ZRJ(JL,JN,JKL) = ZRE11 1073 ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL) 1074 332 CONTINUE 1075 333 CONTINUE 1076 351 CONTINUE 1077 361 CONTINUE 1078 C 1079 C 1080 C ------------------------------------------------------------------ 1081 C 1082 C* 4. INVERT GREY AND CONTINUUM FLUXES 1083 C -------------------------------- 1084 C 1085 400 CONTINUE 1086 C 1087 C 1088 C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES 1089 C --------------------------------------------- 1090 C 1091 410 CONTINUE 1092 C 1093 DO 414 JK = 1 , KFLEV+1 1094 DO 413 JAJ = 1 , 5 , 2 1095 JAJP = JAJ + 1 1096 DO 412 JL = 1, KDLON 1097 ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK) 1098 ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK) 1099 ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) 1100 ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) 1101 412 CONTINUE 1102 413 CONTINUE 1103 414 CONTINUE 1104 C 1105 DO 417 JK = 1 , KFLEV+1 1106 DO 416 JAJ = 2 , 6 , 2 1107 DO 415 JL = 1, KDLON 1108 ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG ) 1109 ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG ) 1110 415 CONTINUE 1111 416 CONTINUE 1112 417 CONTINUE 1113 C 1114 C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE 1115 C --------------------------------------------- 1116 C 1117 420 CONTINUE 1118 C 1119 DO 437 JK = 1 , KFLEV+1 1120 JKKI = 1 1121 DO 425 JAJ = 1 , 2 1122 IIND2(1)=JAJ 1123 IIND2(2)=JAJ 1124 DO 424 JN = 1 , 2 1125 JN2J = JN + 2 * JAJ 1126 JKKP4 = JKKI + 4 1127 C 1128 C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS 1129 C -------------------------- 1130 C 1131 4210 CONTINUE 1132 C 1133 DO 4211 JL = 1, KDLON 1134 ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK)) 1135 S / PAKI(JL,JAJ) 1136 ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK)) 1137 S / PAKI(JL,JAJ) 1138 4211 CONTINUE 1139 C 1140 C* 4.2.2 TRANSMISSION FUNCTION 1141 C --------------------- 1142 C 1143 4220 CONTINUE 1144 C 1145 CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2) 1146 C 1147 DO 4221 JL = 1, KDLON 1148 ZRL(JL,JKKI) = ZR2(JL,1) 1149 ZRUEF(JL,JKKI) = ZW2(JL,1) 1150 ZRL(JL,JKKP4) = ZR2(JL,2) 1151 ZRUEF(JL,JKKP4) = ZW2(JL,2) 1152 4221 CONTINUE 1153 C 1154 JKKI=JKKI+1 1155 424 CONTINUE 1156 425 CONTINUE 1157 C 1158 C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION 1159 C ------------------------------------------------------ 1160 C 1161 430 CONTINUE 1162 C 1163 DO 431 JL = 1, KDLON 1164 PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3) 1165 S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4) 1166 PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7) 1167 S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8) 1168 431 CONTINUE 1169 437 CONTINUE 1170 C 1171 C 1172 C ------------------------------------------------------------------ 1173 C 1174 C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES 1175 C ---------------------------------------- 1176 C 1177 500 CONTINUE 1178 C 1179 C 1180 C* 5.1 DOWNWARD FLUXES 1181 C --------------- 1182 C 1183 510 CONTINUE 1184 C 1185 JAJ = 2 1186 IIND3(1)=1 1187 IIND3(2)=2 1188 IIND3(3)=3 1189 C 1190 DO 511 JL = 1, KDLON 1191 ZW3(JL,1)=0. 1192 ZW3(JL,2)=0. 1193 ZW3(JL,3)=0. 1194 ZW4(JL) =0. 1195 ZW5(JL) =0. 1196 ZR4(JL) =1. 1197 ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1) 1198 511 CONTINUE 1199 DO 514 JK = 1 , KFLEV 1200 IKL = KFLEV+1-JK 1201 DO 512 JL = 1, KDLON 1202 ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL) 1203 ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL) 1204 ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL) 1205 ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL) 1206 ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL) 1207 512 CONTINUE 1208 C 1209 CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) 1210 C 1211 DO 513 JL = 1, KDLON 1212 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1213 ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) 1214 S * ZRJ0(JL,JAJ,IKL) 1215 513 CONTINUE 1216 514 CONTINUE 1217 C 1218 C 1219 C* 5.2 UPWARD FLUXES 1220 C ------------- 1221 C 1222 520 CONTINUE 1223 C 1224 DO 525 JL = 1, KDLON 1225 ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU) 1226 525 CONTINUE 1227 C 1228 DO 528 JK = 2 , KFLEV+1 1229 IKM1=JK-1 1230 DO 526 JL = 1, KDLON 1231 ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66 1232 ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66 1233 ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66 1234 ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66 1235 ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66 1236 526 CONTINUE 1237 C 1238 CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3) 1239 C 1240 DO 527 JL = 1, KDLON 1241 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1242 ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL) 1243 S * ZRK0(JL,JAJ,JK) 1244 527 CONTINUE 1245 528 CONTINUE 1246 C 1247 C 1248 C ------------------------------------------------------------------ 1249 C 1250 C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION 1251 C -------------------------------------------------- 1252 C 1253 600 CONTINUE 1254 IABS=3 1255 C 1256 C* 6.1 DOWNWARD FLUXES 1257 C --------------- 1258 C 1259 610 CONTINUE 1260 DO 611 JL = 1, KDLON 1261 ZW1(JL)=0. 1262 ZW4(JL)=0. 1263 ZW5(JL)=0. 1264 ZR1(JL)=0. 1265 PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1) 1266 S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU) 1267 611 CONTINUE 1268 C 1269 DO 614 JK = 1 , KFLEV 1270 IKL=KFLEV+1-JK 1271 DO 612 JL = 1, KDLON 1272 ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL) 1273 ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL) 1274 ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL) 1275 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1276 612 CONTINUE 1277 C 1278 CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) 1279 C 1280 DO 613 JL = 1, KDLON 1281 PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL) 1282 S +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU) 1283 613 CONTINUE 1284 614 CONTINUE 1285 C 1286 C 1287 C* 6.2 UPWARD FLUXES 1288 C ------------- 1289 C 1290 620 CONTINUE 1291 DO 621 JL = 1, KDLON 1292 PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1) 1293 S +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU) 1294 621 CONTINUE 1295 C 1296 DO 624 JK = 2 , KFLEV+1 1297 IKM1=JK-1 1298 DO 622 JL = 1, KDLON 1299 ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66 1300 ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66 1301 ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66 1302 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL)) 1303 622 CONTINUE 1304 C 1305 CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1) 1306 C 1307 DO 623 JL = 1, KDLON 1308 PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK) 1309 S +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU) 1310 623 CONTINUE 1311 624 CONTINUE 1312 C 1313 C ------------------------------------------------------------------ 1314 C 1315 RETURN 1316 END 1317 SUBROUTINE SWCLR_LMDAR4 ( KNU 1318 S , PAER , flag_aer, tauae, pizae, cgae 1319 S , PALBP , PDSIG , PRAYL , PSEC 1320 S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ 1321 S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 ) 1322 USE dimphy 1323 USE radiation_AR4_param, only : TAUA, RPIZA, RCGA 1324 IMPLICIT none 1325 cym#include "dimensions.h" 1326 cym#include "dimphy.h" 1327 cym#include "raddim.h" 1328 #include "radepsi.h" 1329 #include "radopt.h" 1330 C 1331 C ------------------------------------------------------------------ 1332 C PURPOSE. 1333 C -------- 1334 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF 1335 C CLEAR-SKY COLUMN 1336 C 1337 C REFERENCE. 1338 C ---------- 1339 C 1340 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 1341 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 1342 C 1343 C AUTHOR. 1344 C ------- 1345 C JEAN-JACQUES MORCRETTE *ECMWF* 1346 C 1347 C MODIFICATIONS. 1348 C -------------- 1349 C ORIGINAL : 94-11-15 1350 C ------------------------------------------------------------------ 1351 C* ARGUMENTS: 1352 C 1353 INTEGER KNU 1354 c-OB 1355 real(kind=8) flag_aer 1356 real(kind=8) tauae(kdlon,kflev,2) 1357 real(kind=8) pizae(kdlon,kflev,2) 1358 real(kind=8) cgae(kdlon,kflev,2) 1359 REAL(KIND=8) PAER(KDLON,KFLEV,5) 1360 REAL(KIND=8) PALBP(KDLON,2) 1361 REAL(KIND=8) PDSIG(KDLON,KFLEV) 1362 REAL(KIND=8) PRAYL(KDLON) 1363 REAL(KIND=8) PSEC(KDLON) 1364 C 1365 REAL(KIND=8) PCGAZ(KDLON,KFLEV) 1366 REAL(KIND=8) PPIZAZ(KDLON,KFLEV) 1367 REAL(KIND=8) PRAY1(KDLON,KFLEV+1) 1368 REAL(KIND=8) PRAY2(KDLON,KFLEV+1) 1369 REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) 1370 REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) 1371 REAL(KIND=8) PRK(KDLON,6,KFLEV+1) 1372 REAL(KIND=8) PRMU0(KDLON,KFLEV+1) 1373 REAL(KIND=8) PTAUAZ(KDLON,KFLEV) 1374 REAL(KIND=8) PTRA1(KDLON,KFLEV+1) 1375 REAL(KIND=8) PTRA2(KDLON,KFLEV+1) 1376 C 1377 C* LOCAL VARIABLES: 1378 C 1379 REAL(KIND=8) ZC0I(KDLON,KFLEV+1) 1380 REAL(KIND=8) ZCLE0(KDLON,KFLEV) 1381 REAL(KIND=8) ZCLEAR(KDLON) 1382 REAL(KIND=8) ZR21(KDLON) 1383 REAL(KIND=8) ZR23(KDLON) 1384 REAL(KIND=8) ZSS0(KDLON) 1385 REAL(KIND=8) ZSCAT(KDLON) 1386 REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) 1387 C 1388 INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in 1389 REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE 1390 REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1 1391 REAL(KIND=8) ZBMU0, ZBMU1, ZRE11 1392 C 1393 1394 C ------------------------------------------------------------------ 1395 C 1396 C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH 1397 C -------------------------------------------- 1398 C 1399 100 CONTINUE 1400 C 1401 !cdir collapse 1402 DO 103 JK = 1 , KFLEV+1 1403 DO 102 JA = 1 , 6 1404 DO 101 JL = 1, KDLON 1405 PRJ(JL,JA,JK) = 0. 1406 PRK(JL,JA,JK) = 0. 1407 101 CONTINUE 1408 102 CONTINUE 1409 103 CONTINUE 1410 C 1411 DO 108 JK = 1 , KFLEV 1412 c-OB 1413 c DO 104 JL = 1, KDLON 1414 c PCGAZ(JL,JK) = 0. 1415 c PPIZAZ(JL,JK) = 0. 1416 c PTAUAZ(JL,JK) = 0. 1417 c 104 CONTINUE 1418 c-OB 1419 c DO 106 JAE=1,5 1420 c DO 105 JL = 1, KDLON 1421 c PTAUAZ(JL,JK)=PTAUAZ(JL,JK) 1422 c S +PAER(JL,JK,JAE)*TAUA(KNU,JAE) 1423 c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE) 1424 c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE) 1425 c PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE) 1426 c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE) 1427 c 105 CONTINUE 1428 c 106 CONTINUE 1429 c-OB 1430 DO 105 JL = 1, KDLON 1431 PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU) 1432 PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU) 1433 PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU) 1434 105 CONTINUE 1435 C 1436 IF (flag_aer.GT.0) THEN 1437 c-OB 1438 DO 107 JL = 1, KDLON 1439 c PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK) 1440 c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK) 1441 ZTRAY = PRAYL(JL) * PDSIG(JL,JK) 1442 ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK)) 1443 ZGAR = PCGAZ(JL,JK) 1444 ZFF = ZGAR * ZGAR 1445 PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF) 1446 PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR) 1447 PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF) 1448 S / (1. - PPIZAZ(JL,JK) * ZFF) 1449 107 CONTINUE 4565 indb(jl) = indt 4566 END DO 4567 4568 DO jf = 1, 2 4569 DO jg = 1, 8 4570 DO jl = 1, kdlon 4571 indt = indb(jl) 4572 pga(jl, jg, jf, jk) = ga(indt, 2*jg, jf) 4573 pgb(jl, jg, jf, jk) = gb(indt, 2*jg, jf) 4574 END DO 4575 END DO 4576 END DO 4577 END DO 4578 4579 ! ------------------------------------------------------------------ 4580 4581 RETURN 4582 END SUBROUTINE lwb_lmdar4 4583 SUBROUTINE lwv_lmdar4(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, & 4584 pbtop, pdbsl, pemis, ppmb, ptave, pga, pgb, pgasur, pgbsur, pgatop, & 4585 pgbtop, pcntrb, pcts, pfluc) 4586 USE dimphy 4587 IMPLICIT NONE 4588 ! ym#include "dimensions.h" 4589 ! ym#include "dimphy.h" 4590 ! ym#include "raddim.h" 4591 include "raddimlw.h" 4592 include "YOMCST.h" 4593 4594 ! ----------------------------------------------------------------------- 4595 ! PURPOSE. 4596 ! -------- 4597 ! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE 4598 ! FLUXES OR RADIANCES 4599 4600 ! METHOD. 4601 ! ------- 4602 4603 ! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN 4604 ! CONTRIBUTIONS BY - THE NEARBY LAYERS 4605 ! - THE DISTANT LAYERS 4606 ! - THE BOUNDARY TERMS 4607 ! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. 4608 4609 ! REFERENCE. 4610 ! ---------- 4611 4612 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 4613 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 4614 4615 ! AUTHOR. 4616 ! ------- 4617 ! JEAN-JACQUES MORCRETTE *ECMWF* 4618 4619 ! MODIFICATIONS. 4620 ! -------------- 4621 ! ORIGINAL : 89-07-14 4622 ! ----------------------------------------------------------------------- 4623 4624 ! * ARGUMENTS: 4625 INTEGER kuaer, ktraer, klim 4626 4627 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS 4628 REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS 4629 REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS 4630 REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION 4631 REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION 4632 REAL (KIND=8) pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION 4633 REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 4634 REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY 4635 REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB) 4636 REAL (KIND=8) ptave(kdlon, kflev) ! TEMPERATURE 4637 REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 4638 REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 4639 REAL (KIND=8) pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS 4640 REAL (KIND=8) pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS 4641 REAL (KIND=8) pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS 4642 REAL (KIND=8) pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS 4643 4644 REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX 4645 REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM 4646 REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES 4647 ! ----------------------------------------------------------------------- 4648 ! LOCAL VARIABLES: 4649 REAL (KIND=8) zadjd(kdlon, kflev+1) 4650 REAL (KIND=8) zadju(kdlon, kflev+1) 4651 REAL (KIND=8) zdbdt(kdlon, ninter, kflev) 4652 REAL (KIND=8) zdisd(kdlon, kflev+1) 4653 REAL (KIND=8) zdisu(kdlon, kflev+1) 4654 4655 INTEGER jk, jl 4656 ! ----------------------------------------------------------------------- 4657 4658 DO jk = 1, kflev + 1 4659 DO jl = 1, kdlon 4660 zadjd(jl, jk) = 0. 4661 zadju(jl, jk) = 0. 4662 zdisd(jl, jk) = 0. 4663 zdisu(jl, jk) = 0. 4664 END DO 4665 END DO 4666 4667 DO jk = 1, kflev 4668 DO jl = 1, kdlon 4669 pcts(jl, jk) = 0. 4670 END DO 4671 END DO 4672 4673 ! * CONTRIBUTION FROM ADJACENT LAYERS 4674 4675 CALL lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, & 4676 pcntrb, zdbdt) 4677 ! * CONTRIBUTION FROM DISTANT LAYERS 4678 4679 CALL lwvd_lmdar4(kuaer, ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, & 4680 zdisu) 4681 4682 ! * EXCHANGE WITH THE BOUNDARIES 4683 4684 CALL lwvb_lmdar4(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, & 4685 pbsuin, pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, & 4686 pgbsur, pgatop, pgbtop, pcts, pfluc) 4687 4688 4689 RETURN 4690 END SUBROUTINE lwv_lmdar4 4691 SUBROUTINE lwvb_lmdar4(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, & 4692 pbsui, pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, & 4693 pgatop, pgbtop, pcts, pfluc) 4694 USE dimphy 4695 IMPLICIT NONE 4696 ! ym#include "dimensions.h" 4697 ! ym#include "dimphy.h" 4698 ! ym#include "raddim.h" 4699 include "raddimlw.h" 4700 include "radopt.h" 4701 4702 ! ----------------------------------------------------------------------- 4703 ! PURPOSE. 4704 ! -------- 4705 ! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL 4706 ! INTEGRATION 4707 4708 ! METHOD. 4709 ! ------- 4710 4711 ! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE 4712 ! ATMOSPHERE 4713 ! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND 4714 ! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA 4715 ! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES 4716 4717 ! REFERENCE. 4718 ! ---------- 4719 4720 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 4721 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 4722 4723 ! AUTHOR. 4724 ! ------- 4725 ! JEAN-JACQUES MORCRETTE *ECMWF* 4726 4727 ! MODIFICATIONS. 4728 ! -------------- 4729 ! ORIGINAL : 89-07-14 4730 ! Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 4731 ! ----------------------------------------------------------------------- 4732 4733 ! * 0.1 ARGUMENTS 4734 ! --------- 4735 4736 INTEGER kuaer, ktraer, klim 4737 4738 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS 4739 REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS 4740 REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS 4741 REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS 4742 REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS 4743 REAL (KIND=8) pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION 4744 REAL (KIND=8) pbsui(kdlon) ! SURFACE PLANCK FUNCTION 4745 REAL (KIND=8) pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION 4746 REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS 4747 REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS 4748 REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY 4749 REAL (KIND=8) ppmb(kdlon, kflev+1) ! PRESSURE MB 4750 REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 4751 REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 4752 REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS 4753 REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS 4754 REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS 4755 REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS 4756 4757 REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES 4758 REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM 4759 4760 ! * LOCAL VARIABLES: 4761 4762 REAL (KIND=8) zbgnd(kdlon) 4763 REAL (KIND=8) zfd(kdlon) 4764 REAL (KIND=8) zfn10(kdlon) 4765 REAL (KIND=8) zfu(kdlon) 4766 REAL (KIND=8) ztt(kdlon, ntra) 4767 REAL (KIND=8) ztt1(kdlon, ntra) 4768 REAL (KIND=8) ztt2(kdlon, ntra) 4769 REAL (KIND=8) zuu(kdlon, nua) 4770 REAL (KIND=8) zcnsol(kdlon) 4771 REAL (KIND=8) zcntop(kdlon) 4772 4773 INTEGER jk, jl, ja 4774 INTEGER jstra, jstru 4775 INTEGER ind1, ind2, ind3, ind4, in, jlim 4776 REAL (KIND=8) zctstr 4777 4778 ! ----------------------------------------------------------------------- 4779 4780 ! * 1. INITIALIZATION 4781 ! -------------- 4782 4783 4784 4785 ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS 4786 ! --------------------------------- 4787 4788 4789 DO ja = 1, ntra 4790 DO jl = 1, kdlon 4791 ztt(jl, ja) = 1.0 4792 ztt1(jl, ja) = 1.0 4793 ztt2(jl, ja) = 1.0 4794 END DO 4795 END DO 4796 4797 DO ja = 1, nua 4798 DO jl = 1, kdlon 4799 zuu(jl, ja) = 1.0 4800 END DO 4801 END DO 4802 4803 ! ------------------------------------------------------------------ 4804 4805 ! * 2. VERTICAL INTEGRATION 4806 ! -------------------- 4807 4808 4809 ind1 = 0 4810 ind3 = 0 4811 ind4 = 1 4812 ind2 = 1 4813 4814 ! * 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE 4815 ! ----------------------------------- 4816 4817 4818 DO jk = 1, kflev 4819 in = (jk-1)*ng1p1 + 1 4820 4821 DO ja = 1, kuaer 4822 DO jl = 1, kdlon 4823 zuu(jl, ja) = pabcu(jl, ja, in) 4824 END DO 4825 END DO 4826 4827 4828 CALL lwtt_lmdar4(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt) 4829 4830 DO jl = 1, kdlon 4831 zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + & 4832 pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 4833 pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 4834 pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 4835 pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, & 4836 15) 4837 zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk) 4838 pfluc(jl, 2, jk) = zfd(jl) 4839 END DO 4840 4841 END DO 4842 4843 jk = kflev + 1 4844 in = (jk-1)*ng1p1 + 1 4845 4846 DO jl = 1, kdlon 4847 zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + & 4848 pbtop(jl, 5) + pbtop(jl, 6) 4849 zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk) 4850 pfluc(jl, 2, jk) = zfd(jl) 4851 END DO 4852 4853 ! * 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA 4854 ! --------------------------------------- 4855 4856 4857 4858 ! * 2.4.1 INITIALIZATION 4859 ! -------------- 4860 4861 4862 jlim = kflev 4863 4864 IF (.NOT. levoigt) THEN 4865 DO jk = kflev, 1, -1 4866 IF (ppmb(1,jk)<10.0) THEN 4867 jlim = jk 4868 END IF 4869 END DO 4870 END IF 4871 klim = jlim 4872 4873 IF (.NOT. levoigt) THEN 4874 DO ja = 1, ktraer 4875 DO jl = 1, kdlon 4876 ztt1(jl, ja) = 1.0 4877 END DO 4878 END DO 4879 4880 ! * 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA 4881 ! ----------------------------- 4882 4883 4884 DO jstra = kflev, jlim, -1 4885 jstru = (jstra-1)*ng1p1 + 1 4886 4887 DO ja = 1, kuaer 4888 DO jl = 1, kdlon 4889 zuu(jl, ja) = pabcu(jl, ja, jstru) 4890 END DO 4891 END DO 4892 4893 4894 CALL lwtt_lmdar4(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt) 4895 4896 DO jl = 1, kdlon 4897 zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* & 4898 (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + & 4899 (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 & 4900 )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 & 4901 ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 & 4902 )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( & 4903 jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, & 4904 jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + & 4905 (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) & 4906 *ztt(jl,15)) 4907 pcts(jl, jstra) = zctstr*0.5 4908 END DO 4909 DO ja = 1, ktraer 4910 DO jl = 1, kdlon 4911 ztt1(jl, ja) = ztt(jl, ja) 4912 END DO 4913 END DO 4914 END DO 4915 END IF 4916 ! Mise a zero de securite pour PCTS en cas de LEVOIGT 4917 IF (levoigt) THEN 4918 DO jstra = 1, kflev 4919 DO jl = 1, kdlon 4920 pcts(jl, jstra) = 0. 4921 END DO 4922 END DO 4923 END IF 4924 4925 ! * 2.5 EXCHANGE WITH LOWER LIMIT 4926 ! ------------------------- 4927 4928 4929 DO jl = 1, kdlon 4930 zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - & 4931 pbint(jl, 1) 4932 END DO 4933 4934 jk = 1 4935 in = (jk-1)*ng1p1 + 1 4936 4937 DO jl = 1, kdlon 4938 zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + & 4939 pbsur(jl, 5) + pbsur(jl, 6) 4940 zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl) 4941 zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk) 4942 pfluc(jl, 1, jk) = zfu(jl) 4943 END DO 4944 4945 DO jk = 2, kflev + 1 4946 in = (jk-1)*ng1p1 + 1 4947 4948 4949 DO ja = 1, kuaer 4950 DO jl = 1, kdlon 4951 zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in) 4952 END DO 4953 END DO 4954 4955 4956 CALL lwtt_lmdar4(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt) 4957 4958 DO jl = 1, kdlon 4959 zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + & 4960 pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 4961 pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 4962 pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 4963 pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, & 4964 15) 4965 zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl) 4966 zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk) 4967 pfluc(jl, 1, jk) = zfu(jl) 4968 END DO 4969 4970 4971 END DO 4972 4973 ! * 2.7 CLEAR-SKY FLUXES 4974 ! ---------------- 4975 4976 4977 IF (.NOT. levoigt) THEN 4978 DO jl = 1, kdlon 4979 zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim) 4980 END DO 4981 DO jk = jlim + 1, kflev + 1 4982 DO jl = 1, kdlon 4983 zfn10(jl) = zfn10(jl) + pcts(jl, jk-1) 4984 pfluc(jl, 1, jk) = zfn10(jl) 4985 pfluc(jl, 2, jk) = 0. 4986 END DO 4987 END DO 4988 END IF 4989 4990 ! ------------------------------------------------------------------ 4991 4992 RETURN 4993 END SUBROUTINE lwvb_lmdar4 4994 SUBROUTINE lwvd_lmdar4(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, & 4995 pdisu) 4996 USE dimphy 4997 IMPLICIT NONE 4998 ! ym#include "dimensions.h" 4999 ! ym#include "dimphy.h" 5000 ! ym#include "raddim.h" 5001 include "raddimlw.h" 5002 5003 ! ----------------------------------------------------------------------- 5004 ! PURPOSE. 5005 ! -------- 5006 ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS 5007 5008 ! METHOD. 5009 ! ------- 5010 5011 ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE 5012 ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE 5013 5014 ! REFERENCE. 5015 ! ---------- 5016 5017 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5018 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5019 5020 ! AUTHOR. 5021 ! ------- 5022 ! JEAN-JACQUES MORCRETTE *ECMWF* 5023 5024 ! MODIFICATIONS. 5025 ! -------------- 5026 ! ORIGINAL : 89-07-14 5027 ! ----------------------------------------------------------------------- 5028 ! * ARGUMENTS: 5029 5030 INTEGER kuaer, ktraer 5031 5032 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS 5033 REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT 5034 REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 5035 REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 5036 5037 REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX 5038 REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS 5039 REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS 5040 5041 ! * LOCAL VARIABLES: 5042 5043 REAL (KIND=8) zglayd(kdlon) 5044 REAL (KIND=8) zglayu(kdlon) 5045 REAL (KIND=8) ztt(kdlon, ntra) 5046 REAL (KIND=8) ztt1(kdlon, ntra) 5047 REAL (KIND=8) ztt2(kdlon, ntra) 5048 5049 INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2 5050 INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2 5051 INTEGER ind1, ind2, ind3, ind4, itt 5052 REAL (KIND=8) zww, zdzxdg, zdzxmg 5053 5054 ! * 1. INITIALIZATION 5055 ! -------------- 5056 5057 5058 ! * 1.1 INITIALIZE LAYER CONTRIBUTIONS 5059 ! ------------------------------ 5060 5061 5062 DO jk = 1, kflev + 1 5063 DO jl = 1, kdlon 5064 pdisd(jl, jk) = 0. 5065 pdisu(jl, jk) = 0. 5066 END DO 5067 END DO 5068 5069 ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS 5070 ! --------------------------------- 5071 5072 5073 5074 DO ja = 1, ntra 5075 DO jl = 1, kdlon 5076 ztt(jl, ja) = 1.0 5077 ztt1(jl, ja) = 1.0 5078 ztt2(jl, ja) = 1.0 5079 END DO 5080 END DO 5081 5082 ! ------------------------------------------------------------------ 5083 5084 ! * 2. VERTICAL INTEGRATION 5085 ! -------------------- 5086 5087 5088 ind1 = 0 5089 ind3 = 0 5090 ind4 = 1 5091 ind2 = 1 5092 5093 ! * 2.2 CONTRIBUTION FROM DISTANT LAYERS 5094 ! --------------------------------- 5095 5096 5097 5098 ! * 2.2.1 DISTANT AND ABOVE LAYERS 5099 ! ------------------------ 5100 5101 5102 5103 5104 ! * 2.2.2 FIRST UPPER LEVEL 5105 ! ----------------- 5106 5107 5108 DO jk = 1, kflev - 1 5109 ikp1 = jk + 1 5110 ikn = (jk-1)*ng1p1 + 1 5111 ikd1 = jk*ng1p1 + 1 5112 5113 CALL lwttm_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), & 5114 pabcu(1,1,ikd1), ztt1) 5115 5116 ! * 2.2.3 HIGHER UP 5117 ! --------- 5118 5119 5120 itt = 1 5121 DO jkj = ikp1, kflev 5122 IF (itt==1) THEN 5123 itt = 2 1450 5124 ELSE 1451 DO JL = 1, KDLON 1452 ZTRAY = PRAYL(JL) * PDSIG(JL,JK) 1453 PTAUAZ(JL,JK) = ZTRAY 1454 PCGAZ(JL,JK) = 0. 1455 PPIZAZ(JL,JK) = 1.-REPSCT 1456 END DO 1457 END IF ! check flag_aer 1458 c 107 CONTINUE 1459 c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5) 1460 c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON) 1461 c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5) 1462 C 1463 108 CONTINUE 1464 C 1465 C ------------------------------------------------------------------ 1466 C 1467 C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL 1468 C ---------------------------------------------- 1469 C 1470 200 CONTINUE 1471 C 1472 DO 201 JL = 1, KDLON 1473 ZR23(JL) = 0. 1474 ZC0I(JL,KFLEV+1) = 0. 1475 ZCLEAR(JL) = 1. 1476 ZSCAT(JL) = 0. 1477 201 CONTINUE 1478 C 1479 JK = 1 1480 JKL = KFLEV+1 - JK 1481 JKLP1 = JKL + 1 1482 DO 202 JL = 1, KDLON 1483 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) 1484 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) 1485 ZR21(JL) = EXP(-ZCORAE ) 1486 ZSS0(JL) = 1.-ZR21(JL) 1487 ZCLE0(JL,JKL) = ZSS0(JL) 1488 C 1489 IF (NOVLP.EQ.1) THEN 1490 c* maximum-random 1491 ZCLEAR(JL) = ZCLEAR(JL) 1492 S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) 1493 S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) 1494 ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) 1495 ZSCAT(JL) = ZSS0(JL) 1496 ELSE IF (NOVLP.EQ.2) THEN 1497 C* maximum 1498 ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) 1499 ZC0I(JL,JKL) = ZSCAT(JL) 1500 ELSE IF (NOVLP.EQ.3) THEN 1501 c* random 1502 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) 1503 ZSCAT(JL) = 1.0 - ZCLEAR(JL) 1504 ZC0I(JL,JKL) = ZSCAT(JL) 5125 itt = 1 1505 5126 END IF 1506 202 CONTINUE 1507 C 1508 DO 205 JK = 2 , KFLEV 1509 JKL = KFLEV+1 - JK 1510 JKLP1 = JKL + 1 1511 DO 204 JL = 1, KDLON 1512 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) 1513 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) 1514 ZR21(JL) = EXP(-ZCORAE ) 1515 ZSS0(JL) = 1.-ZR21(JL) 1516 ZCLE0(JL,JKL) = ZSS0(JL) 1517 c 1518 IF (NOVLP.EQ.1) THEN 1519 c* maximum-random 1520 ZCLEAR(JL) = ZCLEAR(JL) 1521 S *(1.0-MAX(ZSS0(JL),ZSCAT(JL))) 1522 S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC)) 1523 ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL) 1524 ZSCAT(JL) = ZSS0(JL) 1525 ELSE IF (NOVLP.EQ.2) THEN 1526 C* maximum 1527 ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) ) 1528 ZC0I(JL,JKL) = ZSCAT(JL) 1529 ELSE IF (NOVLP.EQ.3) THEN 1530 c* random 1531 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL)) 1532 ZSCAT(JL) = 1.0 - ZCLEAR(JL) 1533 ZC0I(JL,JKL) = ZSCAT(JL) 1534 END IF 1535 204 CONTINUE 1536 205 CONTINUE 1537 C 1538 C ------------------------------------------------------------------ 1539 C 1540 C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING 1541 C ----------------------------------------------- 1542 C 1543 300 CONTINUE 1544 C 1545 DO 301 JL = 1, KDLON 1546 PRAY1(JL,KFLEV+1) = 0. 1547 PRAY2(JL,KFLEV+1) = 0. 1548 PREFZ(JL,2,1) = PALBP(JL,KNU) 1549 PREFZ(JL,1,1) = PALBP(JL,KNU) 1550 PTRA1(JL,KFLEV+1) = 1. 1551 PTRA2(JL,KFLEV+1) = 1. 1552 301 CONTINUE 1553 C 1554 DO 346 JK = 2 , KFLEV+1 1555 JKM1 = JK-1 1556 DO 342 JL = 1, KDLON 1557 C 1558 C 1559 C ------------------------------------------------------------------ 1560 C 1561 C* 3.1 EQUIVALENT ZENITH ANGLE 1562 C ----------------------- 1563 C 1564 310 CONTINUE 1565 C 1566 ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL) 1567 S + ZC0I(JL,JK) * 1.66 1568 PRMU0(JL,JK) = 1./ZMUE 1569 C 1570 C 1571 C ------------------------------------------------------------------ 1572 C 1573 C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS 1574 C ---------------------------------------------------- 1575 C 1576 320 CONTINUE 1577 C 1578 ZGAP = PCGAZ(JL,JKM1) 1579 ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE 1580 ZWW = PPIZAZ(JL,JKM1) 1581 ZTO = PTAUAZ(JL,JKM1) 1582 ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE 1583 S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE 1584 PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN 1585 PTRA1(JL,JKM1) = 1. / ZDEN 1586 C 1587 ZMU1 = 0.5 1588 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 1589 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 1590 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 1591 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 1592 PTRA2(JL,JKM1) = 1. / ZDEN1 1593 C 1594 C 1595 C 1596 PREFZ(JL,1,JK) = (PRAY1(JL,JKM1) 1597 S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) 1598 S * PTRA2(JL,JKM1) 1599 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) 1600 C 1601 ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1) 1602 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) 1603 C 1604 PREFZ(JL,2,JK) = (PRAY1(JL,JKM1) 1605 S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) 1606 S * PTRA2(JL,JKM1) ) 1607 C 1608 ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 1609 C 1610 342 CONTINUE 1611 346 CONTINUE 1612 DO 347 JL = 1, KDLON 1613 ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66 1614 PRMU0(JL,1)=1./ZMUE 1615 347 CONTINUE 1616 C 1617 C 1618 C ------------------------------------------------------------------ 1619 C 1620 C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 1621 C ------------------------------------------------- 1622 C 1623 350 CONTINUE 1624 C 1625 IF (KNU.EQ.1) THEN 1626 JAJ = 2 1627 DO 351 JL = 1, KDLON 1628 PRJ(JL,JAJ,KFLEV+1) = 1. 1629 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) 1630 351 CONTINUE 1631 C 1632 DO 353 JK = 1 , KFLEV 1633 JKL = KFLEV+1 - JK 1634 JKLP1 = JKL + 1 1635 DO 352 JL = 1, KDLON 1636 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) 1637 PRJ(JL,JAJ,JKL) = ZRE11 1638 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) 1639 352 CONTINUE 1640 353 CONTINUE 1641 354 CONTINUE 1642 C 5127 ikjp1 = jkj + 1 5128 ikd2 = jkj*ng1p1 + 1 5129 5130 IF (itt==1) THEN 5131 CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), & 5132 pabcu(1,1,ikd2), ztt1) 1643 5133 ELSE 1644 C 1645 DO 358 JAJ = 1 , 2 1646 DO 355 JL = 1, KDLON 1647 PRJ(JL,JAJ,KFLEV+1) = 1. 1648 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) 1649 355 CONTINUE 1650 C 1651 DO 357 JK = 1 , KFLEV 1652 JKL = KFLEV+1 - JK 1653 JKLP1 = JKL + 1 1654 DO 356 JL = 1, KDLON 1655 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) 1656 PRJ(JL,JAJ,JKL) = ZRE11 1657 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) 1658 356 CONTINUE 1659 357 CONTINUE 1660 358 CONTINUE 1661 C 5134 CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), & 5135 pabcu(1,1,ikd2), ztt2) 1662 5136 END IF 1663 C 1664 C ------------------------------------------------------------------ 1665 C 1666 RETURN 1667 END 1668 SUBROUTINE SWR_LMDAR4 ( KNU 1669 S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL 1670 S , PSEC , PTAU 1671 S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE 1672 S , PTAUAZ, PTRA1 , PTRA2 ) 1673 USE dimphy 1674 IMPLICIT none 1675 cym#include "dimensions.h" 1676 cym#include "dimphy.h" 1677 cym#include "raddim.h" 1678 #include "radepsi.h" 1679 #include "radopt.h" 1680 C 1681 C ------------------------------------------------------------------ 1682 C PURPOSE. 1683 C -------- 1684 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF 1685 C CONTINUUM SCATTERING 1686 C 1687 C METHOD. 1688 C ------- 1689 C 1690 C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL 1691 C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION) 1692 C 1693 C REFERENCE. 1694 C ---------- 1695 C 1696 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT 1697 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980) 1698 C 1699 C AUTHOR. 1700 C ------- 1701 C JEAN-JACQUES MORCRETTE *ECMWF* 1702 C 1703 C MODIFICATIONS. 1704 C -------------- 1705 C ORIGINAL : 89-07-14 1706 C ------------------------------------------------------------------ 1707 C* ARGUMENTS: 1708 C 1709 INTEGER KNU 1710 REAL(KIND=8) PALBD(KDLON,2) 1711 REAL(KIND=8) PCG(KDLON,2,KFLEV) 1712 REAL(KIND=8) PCLD(KDLON,KFLEV) 1713 REAL(KIND=8) PDSIG(KDLON,KFLEV) 1714 REAL(KIND=8) POMEGA(KDLON,2,KFLEV) 1715 REAL(KIND=8) PRAYL(KDLON) 1716 REAL(KIND=8) PSEC(KDLON) 1717 REAL(KIND=8) PTAU(KDLON,2,KFLEV) 1718 C 1719 REAL(KIND=8) PRAY1(KDLON,KFLEV+1) 1720 REAL(KIND=8) PRAY2(KDLON,KFLEV+1) 1721 REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1) 1722 REAL(KIND=8) PRJ(KDLON,6,KFLEV+1) 1723 REAL(KIND=8) PRK(KDLON,6,KFLEV+1) 1724 REAL(KIND=8) PRMUE(KDLON,KFLEV+1) 1725 REAL(KIND=8) PCGAZ(KDLON,KFLEV) 1726 REAL(KIND=8) PPIZAZ(KDLON,KFLEV) 1727 REAL(KIND=8) PTAUAZ(KDLON,KFLEV) 1728 REAL(KIND=8) PTRA1(KDLON,KFLEV+1) 1729 REAL(KIND=8) PTRA2(KDLON,KFLEV+1) 1730 C 1731 C* LOCAL VARIABLES: 1732 C 1733 REAL(KIND=8) ZC1I(KDLON,KFLEV+1) 1734 REAL(KIND=8) ZCLEQ(KDLON,KFLEV) 1735 REAL(KIND=8) ZCLEAR(KDLON) 1736 REAL(KIND=8) ZCLOUD(KDLON) 1737 REAL(KIND=8) ZGG(KDLON) 1738 REAL(KIND=8) ZREF(KDLON) 1739 REAL(KIND=8) ZRE1(KDLON) 1740 REAL(KIND=8) ZRE2(KDLON) 1741 REAL(KIND=8) ZRMUZ(KDLON) 1742 REAL(KIND=8) ZRNEB(KDLON) 1743 REAL(KIND=8) ZR21(KDLON) 1744 REAL(KIND=8) ZR22(KDLON) 1745 REAL(KIND=8) ZR23(KDLON) 1746 REAL(KIND=8) ZSS1(KDLON) 1747 REAL(KIND=8) ZTO1(KDLON) 1748 REAL(KIND=8) ZTR(KDLON,2,KFLEV+1) 1749 REAL(KIND=8) ZTR1(KDLON) 1750 REAL(KIND=8) ZTR2(KDLON) 1751 REAL(KIND=8) ZW(KDLON) 1752 C 1753 INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj 1754 REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD 1755 REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1 1756 REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1 1757 C 1758 C ------------------------------------------------------------------ 1759 C 1760 C* 1. INITIALIZATION 1761 C -------------- 1762 C 1763 100 CONTINUE 1764 C 1765 DO 103 JK = 1 , KFLEV+1 1766 DO 102 JA = 1 , 6 1767 DO 101 JL = 1, KDLON 1768 PRJ(JL,JA,JK) = 0. 1769 PRK(JL,JA,JK) = 0. 1770 101 CONTINUE 1771 102 CONTINUE 1772 103 CONTINUE 1773 C 1774 C 1775 C ------------------------------------------------------------------ 1776 C 1777 C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL 1778 C ---------------------------------------------- 1779 C 1780 200 CONTINUE 1781 C 1782 DO 201 JL = 1, KDLON 1783 ZR23(JL) = 0. 1784 ZC1I(JL,KFLEV+1) = 0. 1785 ZCLEAR(JL) = 1. 1786 ZCLOUD(JL) = 0. 1787 201 CONTINUE 1788 C 1789 JK = 1 1790 JKL = KFLEV+1 - JK 1791 JKLP1 = JKL + 1 1792 DO 202 JL = 1, KDLON 1793 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) 1794 ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) 1795 S * PCG(JL,KNU,JKL) 1796 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) 1797 ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) 1798 ZR21(JL) = EXP(-ZCORAE ) 1799 ZR22(JL) = EXP(-ZCORCD ) 1800 ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) 1801 S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) 1802 ZCLEQ(JL,JKL) = ZSS1(JL) 1803 C 1804 IF (NOVLP.EQ.1) THEN 1805 c* maximum-random 1806 ZCLEAR(JL) = ZCLEAR(JL) 1807 S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) 1808 S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) 1809 ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) 1810 ZCLOUD(JL) = ZSS1(JL) 1811 ELSE IF (NOVLP.EQ.2) THEN 1812 C* maximum 1813 ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) 1814 ZC1I(JL,JKL) = ZCLOUD(JL) 1815 ELSE IF (NOVLP.EQ.3) THEN 1816 c* random 1817 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) 1818 ZCLOUD(JL) = 1.0 - ZCLEAR(JL) 1819 ZC1I(JL,JKL) = ZCLOUD(JL) 5137 5138 DO ja = 1, ktraer 5139 DO jl = 1, kdlon 5140 ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5 5141 END DO 5142 END DO 5143 5144 DO jl = 1, kdlon 5145 zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + & 5146 pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 5147 pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 5148 pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 5149 pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + & 5150 pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15) 5151 zglayd(jl) = zww 5152 zdzxdg = zglayd(jl) 5153 pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg 5154 pcntrb(jl, jk, ikjp1) = zdzxdg 5155 END DO 5156 5157 5158 END DO 5159 END DO 5160 5161 ! * 2.2.4 DISTANT AND BELOW LAYERS 5162 ! ------------------------ 5163 5164 5165 5166 5167 ! * 2.2.5 FIRST LOWER LEVEL 5168 ! ----------------- 5169 5170 5171 DO jk = 3, kflev + 1 5172 ikn = (jk-1)*ng1p1 + 1 5173 ikm1 = jk - 1 5174 ikj = jk - 2 5175 iku1 = ikj*ng1p1 + 1 5176 5177 5178 CALL lwttm_lmdar4(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), & 5179 pabcu(1,1,ikn), ztt1) 5180 5181 ! * 2.2.6 DOWN BELOW 5182 ! ---------- 5183 5184 5185 itt = 1 5186 DO jlk = 1, ikj 5187 IF (itt==1) THEN 5188 itt = 2 5189 ELSE 5190 itt = 1 1820 5191 END IF 1821 202 CONTINUE 1822 C 1823 DO 205 JK = 2 , KFLEV 1824 JKL = KFLEV+1 - JK 1825 JKLP1 = JKL + 1 1826 DO 204 JL = 1, KDLON 1827 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL) 1828 ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL) 1829 S * PCG(JL,KNU,JKL) 1830 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL) 1831 ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL) 1832 ZR21(JL) = EXP(-ZCORAE ) 1833 ZR22(JL) = EXP(-ZCORCD ) 1834 ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL)) 1835 S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL)) 1836 ZCLEQ(JL,JKL) = ZSS1(JL) 1837 c 1838 IF (NOVLP.EQ.1) THEN 1839 c* maximum-random 1840 ZCLEAR(JL) = ZCLEAR(JL) 1841 S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL))) 1842 S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) 1843 ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL) 1844 ZCLOUD(JL) = ZSS1(JL) 1845 ELSE IF (NOVLP.EQ.2) THEN 1846 C* maximum 1847 ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) ) 1848 ZC1I(JL,JKL) = ZCLOUD(JL) 1849 ELSE IF (NOVLP.EQ.3) THEN 1850 c* random 1851 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL)) 1852 ZCLOUD(JL) = 1.0 - ZCLEAR(JL) 1853 ZC1I(JL,JKL) = ZCLOUD(JL) 5192 ijkl = ikm1 - jlk 5193 iku2 = (ijkl-1)*ng1p1 + 1 5194 5195 5196 IF (itt==1) THEN 5197 CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), & 5198 pabcu(1,1,ikn), ztt1) 5199 ELSE 5200 CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), & 5201 pabcu(1,1,ikn), ztt2) 1854 5202 END IF 1855 204 CONTINUE 1856 205 CONTINUE 1857 C 1858 C ------------------------------------------------------------------ 1859 C 1860 C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING 1861 C ----------------------------------------------- 1862 C 1863 300 CONTINUE 1864 C 1865 DO 301 JL = 1, KDLON 1866 PRAY1(JL,KFLEV+1) = 0. 1867 PRAY2(JL,KFLEV+1) = 0. 1868 PREFZ(JL,2,1) = PALBD(JL,KNU) 1869 PREFZ(JL,1,1) = PALBD(JL,KNU) 1870 PTRA1(JL,KFLEV+1) = 1. 1871 PTRA2(JL,KFLEV+1) = 1. 1872 301 CONTINUE 1873 C 1874 DO 346 JK = 2 , KFLEV+1 1875 JKM1 = JK-1 1876 DO 342 JL = 1, KDLON 1877 ZRNEB(JL)= PCLD(JL,JKM1) 1878 ZRE1(JL)=0. 1879 ZTR1(JL)=0. 1880 ZRE2(JL)=0. 1881 ZTR2(JL)=0. 1882 C 1883 C 1884 C ------------------------------------------------------------------ 1885 C 1886 C* 3.1 EQUIVALENT ZENITH ANGLE 1887 C ----------------------- 1888 C 1889 310 CONTINUE 1890 C 1891 ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL) 1892 S + ZC1I(JL,JK) * 1.66 1893 PRMUE(JL,JK) = 1./ZMUE 1894 C 1895 C 1896 C ------------------------------------------------------------------ 1897 C 1898 C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS 1899 C ---------------------------------------------------- 1900 C 1901 320 CONTINUE 1902 C 1903 ZGAP = PCGAZ(JL,JKM1) 1904 ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE 1905 ZWW = PPIZAZ(JL,JKM1) 1906 ZTO = PTAUAZ(JL,JKM1) 1907 ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE 1908 S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE 1909 PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN 1910 PTRA1(JL,JKM1) = 1. / ZDEN 1911 c PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1) 1912 C 1913 ZMU1 = 0.5 1914 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1 1915 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 1916 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1 1917 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1 1918 PTRA2(JL,JKM1) = 1. / ZDEN1 1919 C 1920 C 1921 C ------------------------------------------------------------------ 1922 C 1923 C* 3.3 EFFECT OF CLOUD LAYER 1924 C --------------------- 1925 C 1926 330 CONTINUE 1927 C 1928 ZW(JL) = POMEGA(JL,KNU,JKM1) 1929 ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL) 1930 S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1) 1931 ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1) 1932 ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL) 1933 ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1) 1934 S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1) 1935 C Modif PhD - JJM 19/03/96 pour erreurs arrondis 1936 C machine 1937 C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL) 1938 IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN 1939 ZW(JL)=1. 1940 ELSE 1941 ZW(JL) = ZR21(JL) / ZTO1(JL) 1942 END IF 1943 ZREF(JL) = PREFZ(JL,1,JKM1) 1944 ZRMUZ(JL) = PRMUE(JL,JK) 1945 342 CONTINUE 1946 C 1947 CALL SWDE_LMDAR4(ZGG , ZREF , ZRMUZ , ZTO1 , ZW, 1948 S ZRE1 , ZRE2 , ZTR1 , ZTR2) 1949 C 1950 DO 345 JL = 1, KDLON 1951 C 1952 PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) 1953 S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1) 1954 S * PTRA2(JL,JKM1) 1955 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) 1956 S + ZRNEB(JL) * ZRE2(JL) 1957 C 1958 ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1) 1959 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1))) 1960 S * (1.-ZRNEB(JL)) 1961 C 1962 PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1) 1963 S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1) 1964 S * PTRA2(JL,JKM1) ) 1965 S + ZRNEB(JL) * ZRE1(JL) 1966 C 1967 ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL) 1968 S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL)) 1969 C 1970 345 CONTINUE 1971 346 CONTINUE 1972 DO 347 JL = 1, KDLON 1973 ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66 1974 PRMUE(JL,1)=1./ZMUE 1975 347 CONTINUE 1976 C 1977 C 1978 C ------------------------------------------------------------------ 1979 C 1980 C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL 1981 C ------------------------------------------------- 1982 C 1983 350 CONTINUE 1984 C 1985 IF (KNU.EQ.1) THEN 1986 JAJ = 2 1987 DO 351 JL = 1, KDLON 1988 PRJ(JL,JAJ,KFLEV+1) = 1. 1989 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1) 1990 351 CONTINUE 1991 C 1992 DO 353 JK = 1 , KFLEV 1993 JKL = KFLEV+1 - JK 1994 JKLP1 = JKL + 1 1995 DO 352 JL = 1, KDLON 1996 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL) 1997 PRJ(JL,JAJ,JKL) = ZRE11 1998 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL) 1999 352 CONTINUE 2000 353 CONTINUE 2001 354 CONTINUE 2002 C 2003 ELSE 2004 C 2005 DO 358 JAJ = 1 , 2 2006 DO 355 JL = 1, KDLON 2007 PRJ(JL,JAJ,KFLEV+1) = 1. 2008 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1) 2009 355 CONTINUE 2010 C 2011 DO 357 JK = 1 , KFLEV 2012 JKL = KFLEV+1 - JK 2013 JKLP1 = JKL + 1 2014 DO 356 JL = 1, KDLON 2015 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL) 2016 PRJ(JL,JAJ,JKL) = ZRE11 2017 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL) 2018 356 CONTINUE 2019 357 CONTINUE 2020 358 CONTINUE 2021 C 2022 END IF 2023 C 2024 C ------------------------------------------------------------------ 2025 C 2026 RETURN 2027 END 2028 SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW, 2029 S PRE1,PRE2,PTR1,PTR2) 2030 USE dimphy 2031 IMPLICIT none 2032 cym#include "dimensions.h" 2033 cym#include "dimphy.h" 2034 cym#include "raddim.h" 2035 C 2036 C ------------------------------------------------------------------ 2037 C PURPOSE. 2038 C -------- 2039 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY 2040 C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION. 2041 C 2042 C METHOD. 2043 C ------- 2044 C 2045 C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS. 2046 C 2047 C REFERENCE. 2048 C ---------- 2049 C 2050 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2051 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2052 C 2053 C AUTHOR. 2054 C ------- 2055 C JEAN-JACQUES MORCRETTE *ECMWF* 2056 C 2057 C MODIFICATIONS. 2058 C -------------- 2059 C ORIGINAL : 88-12-15 2060 C ------------------------------------------------------------------ 2061 C* ARGUMENTS: 2062 C 2063 REAL(KIND=8) PGG(KDLON) ! ASSYMETRY FACTOR 2064 REAL(KIND=8) PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER 2065 REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE 2066 REAL(KIND=8) PTO1(KDLON) ! OPTICAL THICKNESS 2067 REAL(KIND=8) PW(KDLON) ! SINGLE SCATTERING ALBEDO 2068 REAL(KIND=8) PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION) 2069 REAL(KIND=8) PRE2(KDLON) ! LAYER REFLECTIVITY 2070 REAL(KIND=8) PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION) 2071 REAL(KIND=8) PTR2(KDLON) ! LAYER TRANSMISSIVITY 2072 C 2073 C* LOCAL VARIABLES: 2074 C 2075 INTEGER jl 2076 REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM 2077 REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG 2078 REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, 2079 $ ZAM2B 2080 REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23 2081 REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A 2082 REAL(KIND=8) ZRI0B, ZRI1B 2083 REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B 2084 REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D 2085 C ------------------------------------------------------------------ 2086 C 2087 C* 1. DELTA-EDDINGTON CALCULATIONS 2088 C 2089 100 CONTINUE 2090 C 2091 DO 131 JL = 1, KDLON 2092 C 2093 C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS 2094 C 2095 110 CONTINUE 2096 C 2097 ZFF = PGG(JL)*PGG(JL) 2098 ZGP = PGG(JL)/(1.+PGG(JL)) 2099 ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL) 2100 ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF) 2101 ZDT = 2./3. 2102 ZX1 = 1.-ZWCP*ZGP 2103 ZWM = 1.-ZWCP 2104 ZRM2 = PRMUZ(JL) * PRMUZ(JL) 2105 ZRK = SQRT(3.*ZWM*ZX1) 2106 ZX2 = 4.*(1.-ZRK*ZRK*ZRM2) 2107 ZRP=ZRK/ZX1 2108 ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2 2109 ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2 2110 ZARG=MIN(ZTOP/PRMUZ(JL),200._8) 2111 ZEXMU0=EXP(-ZARG) 2112 ZARG2=MIN(ZRK*ZTOP,200._8) 2113 ZEXKP=EXP(ZARG2) 2114 ZEXKM = 1./ZEXKP 2115 ZXP2P = 1.+ZDT*ZRP 2116 ZXM2P = 1.-ZDT*ZRP 2117 ZAP2B = ZALPHA+ZDT*ZBETA 2118 ZAM2B = ZALPHA-ZDT*ZBETA 2119 C 2120 C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER 2121 C 2122 120 CONTINUE 2123 C 2124 ZA11 = ZXP2P 2125 ZA12 = ZXM2P 2126 ZA13 = ZAP2B 2127 ZA22 = ZXP2P*ZEXKP 2128 ZA21 = ZXM2P*ZEXKM 2129 ZA23 = ZAM2B*ZEXMU0 2130 ZDENA = ZA11 * ZA22 - ZA21 * ZA12 2131 ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA 2132 ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA 2133 ZRI0A = ZC1A+ZC2A-ZALPHA 2134 ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA 2135 PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL) 2136 ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0 2137 ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0 2138 PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL) 2139 C 2140 C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER 2141 C 2142 130 CONTINUE 2143 C 2144 ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM 2145 ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP 2146 ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) ) 2147 ZDENB = ZA11 * ZB22 - ZB21 * ZA12 2148 ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB 2149 ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB 2150 ZRI0C = ZC1B+ZC2B-ZALPHA 2151 ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA 2152 PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL) 2153 ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0 2154 ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0 2155 PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL) 2156 C 2157 131 CONTINUE 2158 RETURN 2159 END 2160 SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR) 2161 USE dimphy 2162 USE radiation_AR4_param, only : APAD, BPAD, D 2163 IMPLICIT none 2164 cym#include "dimensions.h" 2165 cym#include "dimphy.h" 2166 cym#include "raddim.h" 2167 C 2168 C----------------------------------------------------------------------- 2169 C PURPOSE. 2170 C -------- 2171 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 2172 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL 2173 C INTERVALS. 2174 C 2175 C METHOD. 2176 C ------- 2177 C 2178 C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS 2179 C AND HORNER'S ALGORITHM. 2180 C 2181 C REFERENCE. 2182 C ---------- 2183 C 2184 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2185 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2186 C 2187 C AUTHOR. 2188 C ------- 2189 C JEAN-JACQUES MORCRETTE *ECMWF* 2190 C 2191 C MODIFICATIONS. 2192 C -------------- 2193 C ORIGINAL : 88-12-15 2194 C----------------------------------------------------------------------- 2195 C 2196 C* ARGUMENTS 2197 C 2198 INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL 2199 INTEGER KA ! INDEX OF THE ABSORBER 2200 REAL(KIND=8) PU(KDLON) ! ABSORBER AMOUNT 2201 C 2202 REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION 2203 C 2204 C* LOCAL VARIABLES: 2205 C 2206 REAL(KIND=8) ZR1(KDLON), ZR2(KDLON) 2207 INTEGER jl, i,j 2208 C 2209 2210 C 2211 C----------------------------------------------------------------------- 2212 C 2213 C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION 2214 C 2215 100 CONTINUE 2216 C 2217 DO 201 JL = 1, KDLON 2218 ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL) 2219 S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL) 2220 S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL) 2221 S * ( APAD(KNU,KA,7) )))))) 2222 C 2223 ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL) 2224 S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL) 2225 S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL) 2226 S * ( BPAD(KNU,KA,7) )))))) 2227 C 2228 C 2229 C* 2. ADD THE BACKGROUND TRANSMISSION 2230 C 2231 200 CONTINUE 2232 C 2233 C 2234 PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA) 2235 201 CONTINUE 2236 C 2237 RETURN 2238 END 2239 SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR) 2240 USE dimphy 2241 USE radiation_AR4_param, only : APAD, BPAD, D 2242 IMPLICIT none 2243 cym#include "dimensions.h" 2244 cym#include "dimphy.h" 2245 cym#include "raddim.h" 2246 C 2247 C----------------------------------------------------------------------- 2248 C PURPOSE. 2249 C -------- 2250 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 2251 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL 2252 C INTERVALS. 2253 C 2254 C METHOD. 2255 C ------- 2256 C 2257 C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS 2258 C AND HORNER'S ALGORITHM. 2259 C 2260 C REFERENCE. 2261 C ---------- 2262 C 2263 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2264 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2265 C 2266 C AUTHOR. 2267 C ------- 2268 C JEAN-JACQUES MORCRETTE *ECMWF* 2269 C 2270 C MODIFICATIONS. 2271 C -------------- 2272 C ORIGINAL : 95-01-20 2273 C----------------------------------------------------------------------- 2274 C* ARGUMENTS: 2275 C 2276 INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL 2277 INTEGER KABS ! NUMBER OF ABSORBERS 2278 INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS 2279 REAL(KIND=8) PU(KDLON,KABS) ! ABSORBER AMOUNT 2280 C 2281 REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION 2282 C 2283 C* LOCAL VARIABLES: 2284 C 2285 REAL(KIND=8) ZR1(KDLON) 2286 REAL(KIND=8) ZR2(KDLON) 2287 REAL(KIND=8) ZU(KDLON) 2288 INTEGER jl, ja, i, j, ia 2289 C 2290 2291 C----------------------------------------------------------------------- 2292 C 2293 C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION 2294 C 2295 100 CONTINUE 2296 C 2297 DO 202 JA = 1,KABS 2298 IA=KIND(JA) 2299 DO 201 JL = 1, KDLON 2300 ZU(JL) = PU(JL,JA) 2301 ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL) 2302 S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL) 2303 S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL) 2304 S * ( APAD(KNU,IA,7) )))))) 2305 C 2306 ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL) 2307 S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL) 2308 S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL) 2309 S * ( BPAD(KNU,IA,7) )))))) 2310 C 2311 C 2312 C* 2. ADD THE BACKGROUND TRANSMISSION 2313 C 2314 200 CONTINUE 2315 C 2316 PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 2317 201 CONTINUE 2318 202 CONTINUE 2319 C 2320 RETURN 2321 END 2322 cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12, 2323 SUBROUTINE LW_LMDAR4( 2324 . PPMB, PDP, 2325 . PPSOL,PDT0,PEMIS, 2326 . PTL, PTAVE, PWV, POZON, PAER, 2327 . PCLDLD,PCLDLU, 2328 . PVIEW, 2329 . PCOLR, PCOLR0, 2330 . PTOPLW,PSOLLW,PTOPLW0,PSOLLW0, 2331 . psollwdown, 2332 cIM . psollwdown,psollwdownclr, 2333 cIM . ptoplwdown,ptoplwdownclr) 2334 . plwup, plwdn, plwup0, plwdn0) 2335 USE dimphy 2336 IMPLICIT none 2337 cym#include "dimensions.h" 2338 cym#include "dimphy.h" 2339 cym#include "raddim.h" 2340 #include "raddimlw.h" 2341 #include "YOMCST.h" 2342 #include "iniprint.h" 2343 C 2344 C----------------------------------------------------------------------- 2345 C METHOD. 2346 C ------- 2347 C 2348 C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF 2349 C ABSORBERS. 2350 C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE 2351 C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. 2352 C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- 2353 C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE 2354 C BOUNDARIES. 2355 C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. 2356 C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES. 2357 C 2358 C 2359 C REFERENCE. 2360 C ---------- 2361 C 2362 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2363 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2364 C 2365 C AUTHOR. 2366 C ------- 2367 C JEAN-JACQUES MORCRETTE *ECMWF* 2368 C 2369 C MODIFICATIONS. 2370 C -------------- 2371 C ORIGINAL : 89-07-14 2372 C----------------------------------------------------------------------- 2373 cIM ctes ds clesphys.h 2374 c REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97) 2375 c REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97) 2376 c REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97) 2377 c REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97) 2378 c REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97) 2379 #include "clesphys.h" 2380 REAL(KIND=8) PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER 2381 REAL(KIND=8) PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER 2382 REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa) 2383 REAL(KIND=8) PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K) 2384 REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY 2385 REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb) 2386 REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (Pa) 2387 REAL(KIND=8) POZON(KDLON,KFLEV) ! O3 mass fraction 2388 REAL(KIND=8) PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K) 2389 REAL(KIND=8) PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS 2390 REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K) 2391 REAL(KIND=8) PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE 2392 REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg) 2393 C 2394 REAL(KIND=8) PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) 2395 REAL(KIND=8) PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky 2396 REAL(KIND=8) PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A. 2397 REAL(KIND=8) PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE 2398 REAL(KIND=8) PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY) 2399 REAL(KIND=8) PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY) 2400 c Rajout LF 2401 real(kind=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface 2402 c Rajout IM 2403 cIM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface 2404 cIM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A. 2405 cIM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A. 2406 cIM 2407 REAL(KIND=8) plwup(KDLON,KFLEV+1) ! LW up total sky 2408 REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky 2409 REAL(KIND=8) plwdn(KDLON,KFLEV+1) ! LW down total sky 2410 REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky 2411 C------------------------------------------------------------------------- 2412 REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1) 2413 2414 REAL(KIND=8) ZOZ(KDLON,KFLEV) 2415 ! equivalent pressure of ozone in a layer, in Pa 2416 2417 cym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down) 2418 cym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES 2419 cym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate variable 2420 cym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate variable 2421 cym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate variable 2422 cym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable 2423 cym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB 2424 REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down) 2425 REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES 2426 REAL(KIND=8),allocatable,save :: ZBINT(:,:) ! Intermediate variable 2427 REAL(KIND=8),allocatable,save :: ZBSUI(:) ! Intermediate variable 2428 REAL(KIND=8),allocatable,save :: ZCTS(:,:) ! Intermediate variable 2429 REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:) ! Intermediate variable 2430 c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB) 2431 c 2432 INTEGER ilim, i, k, kpl1 2433 C 2434 INTEGER lw0pas ! Every lw0pas steps, clear-sky is done 2435 PARAMETER (lw0pas=1) 2436 INTEGER lwpas ! Every lwpas steps, cloudy-sky is done 2437 PARAMETER (lwpas=1) 2438 c 2439 INTEGER itaplw0, itaplw 2440 LOGICAL appel1er 2441 SAVE appel1er, itaplw0, itaplw 2442 c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw) 2443 DATA appel1er /.TRUE./ 2444 DATA itaplw0,itaplw /0,0/ 2445 2446 C ------------------------------------------------------------------ 2447 IF (appel1er) THEN 2448 WRITE(lunout,*) "LW clear-sky calling frequency: ", lw0pas 2449 WRITE(lunout,*) "LW cloudy-sky calling frequency: ", lwpas 2450 WRITE(lunout,*) " In general, they should be 1" 2451 cym 2452 allocate(ZFLUX(KDLON,2,KFLEV+1) ) 2453 allocate(ZFLUC(KDLON,2,KFLEV+1) ) 2454 allocate(ZBINT(KDLON,KFLEV+1)) 2455 allocate(ZBSUI(KDLON)) 2456 allocate(ZCTS(KDLON,KFLEV)) 2457 allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1)) 2458 appel1er=.FALSE. 2459 ENDIF 2460 C 2461 IF (MOD(itaplw0,lw0pas).EQ.0) THEN 2462 c Compute equivalent pressure of ozone from mass fraction: 2463 DO k = 1, KFLEV 2464 DO i = 1, KDLON 2465 ZOZ(i,k) = POZON(i,k)*PDP(i,k) 2466 ENDDO 2467 ENDDO 2468 cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12, 2469 CALL LWU_LMDAR4( 2470 S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU) 2471 CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU, 2472 S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB) 2473 itaplw0 = 0 2474 ENDIF 2475 itaplw0 = itaplw0 + 1 2476 C 2477 IF (MOD(itaplw,lwpas).EQ.0) THEN 2478 CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS, 2479 S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB, 2480 S ZFLUX) 2481 itaplw = 0 2482 ENDIF 2483 itaplw = itaplw + 1 2484 C 2485 DO k = 1, KFLEV 2486 kpl1 = k+1 2487 DO i = 1, KDLON 2488 PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1) 2489 . - ZFLUX(i,1,k)- ZFLUX(i,2,k) 2490 PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k) 2491 PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1) 2492 . - ZFLUC(i,1,k)- ZFLUC(i,2,k) 2493 PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k) 2494 ENDDO 2495 ENDDO 2496 DO i = 1, KDLON 2497 PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1) 2498 PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1) 2499 c 2500 PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1) 2501 PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1) 2502 psollwdown(i) = -ZFLUX(i,2,1) 2503 c 2504 cIM attention aux signes !; LWtop >0, LWdn < 0 2505 DO k = 1, KFLEV+1 2506 plwup(i,k) = ZFLUX(i,1,k) 2507 plwup0(i,k) = ZFLUC(i,1,k) 2508 plwdn(i,k) = ZFLUX(i,2,k) 2509 plwdn0(i,k) = ZFLUC(i,2,k) 2510 ENDDO 2511 ENDDO 2512 C ------------------------------------------------------------------ 2513 RETURN 2514 END 2515 cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12, 2516 SUBROUTINE LWU_LMDAR4( 2517 S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV, 2518 S PABCU) 2519 USE dimphy 2520 USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT 2521 USE infotrac, ONLY : type_trac 2522 #ifdef REPROBUS 2523 USE CHEM_REP, ONLY: RCH42D, 2524 $ RN2O2D, 2525 $ RCFC112D, 2526 $ RCFC122D, 2527 $ ok_Rtime2D 2528 #endif 2529 2530 IMPLICIT none 2531 cym#include "dimensions.h" 2532 cym#include "dimphy.h" 2533 cym#include "raddim.h" 2534 #include "raddimlw.h" 2535 #include "YOMCST.h" 2536 #include "radepsi.h" 2537 #include "radopt.h" 2538 C 2539 C PURPOSE. 2540 C -------- 2541 C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND 2542 C TEMPERATURE EFFECTS 2543 C 2544 C METHOD. 2545 C ------- 2546 C 2547 C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF 2548 C ABSORBERS. 2549 C 2550 C 2551 C REFERENCE. 2552 C ---------- 2553 C 2554 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2555 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2556 C 2557 C AUTHOR. 2558 C ------- 2559 C JEAN-JACQUES MORCRETTE *ECMWF* 2560 C 2561 C MODIFICATIONS. 2562 C -------------- 2563 C ORIGINAL : 89-07-14 2564 C Voigt lines (loop 404 modified) - JJM & PhD - 01/96 2565 C----------------------------------------------------------------------- 2566 C* ARGUMENTS: 2567 cIM ctes ds clesphys.h 2568 c REAL(KIND=8) RCO2 2569 c REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12 2570 #include "clesphys.h" 2571 REAL(KIND=8) PAER(KDLON,KFLEV,5) 2572 REAL(KIND=8) PDP(KDLON,KFLEV) 2573 REAL(KIND=8) PPMB(KDLON,KFLEV+1) 2574 REAL(KIND=8) PPSOL(KDLON) 2575 REAL(KIND=8) POZ(KDLON,KFLEV) 2576 REAL(KIND=8) PTAVE(KDLON,KFLEV) 2577 REAL(KIND=8) PVIEW(KDLON) 2578 REAL(KIND=8) PWV(KDLON,KFLEV) 2579 C 2580 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS 2581 C 2582 C----------------------------------------------------------------------- 2583 C* LOCAL VARIABLES: 2584 REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1) 2585 REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1) 2586 REAL(KIND=8) ZPHIO(KDLON) 2587 REAL(KIND=8) ZPSC2(KDLON) 2588 REAL(KIND=8) ZPSC3(KDLON) 2589 REAL(KIND=8) ZPSH1(KDLON) 2590 REAL(KIND=8) ZPSH2(KDLON) 2591 REAL(KIND=8) ZPSH3(KDLON) 2592 REAL(KIND=8) ZPSH4(KDLON) 2593 REAL(KIND=8) ZPSH5(KDLON) 2594 REAL(KIND=8) ZPSH6(KDLON) 2595 REAL(KIND=8) ZPSIO(KDLON) 2596 REAL(KIND=8) ZTCON(KDLON) 2597 REAL(KIND=8) ZPHM6(KDLON) 2598 REAL(KIND=8) ZPSM6(KDLON) 2599 REAL(KIND=8) ZPHN6(KDLON) 2600 REAL(KIND=8) ZPSN6(KDLON) 2601 REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1) 2602 REAL(KIND=8) ZTAVI(KDLON) 2603 REAL(KIND=8) ZUAER(KDLON,Ninter) 2604 REAL(KIND=8) ZXOZ(KDLON) 2605 REAL(KIND=8) ZXWV(KDLON) 2606 C 2607 INTEGER jl, jk, jkj, jkjr, jkjp, ig1 2608 INTEGER jki, jkip1, ja, jj 2609 INTEGER jkl, jkp1, jkk, jkjpn 2610 INTEGER jae1, jae2, jae3, jae, jjpn 2611 INTEGER ir, jc, jcp1 2612 REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup 2613 REAL(KIND=8) zfppw, ztx, ztx2, zzably 2614 REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3 2615 REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6 2616 REAL(KIND=8) zcac8, zcbc8 2617 REAL(KIND=8) zalup, zdiff 2618 c 2619 REAL(KIND=8) PVGCO2, PVGH2O, PVGO3 2620 C 2621 REAL(KIND=8) R10E ! DECIMAL/NATURAL LOG.FACTOR 2622 PARAMETER (R10E=0.4342945) 2623 2624 C----------------------------------------------------------------------- 2625 c 2626 IF (LEVOIGT) THEN 2627 PVGCO2= 60. 2628 PVGH2O= 30. 2629 PVGO3 =400. 2630 ELSE 2631 PVGCO2= 0. 2632 PVGH2O= 0. 2633 PVGO3 = 0. 2634 ENDIF 2635 C 2636 C 2637 C* 2. PRESSURE OVER GAUSS SUB-LEVELS 2638 C ------------------------------ 2639 C 2640 200 CONTINUE 2641 C 2642 DO 201 JL = 1, KDLON 2643 ZSSIG(JL, 1 ) = PPMB(JL,1) * 100. 2644 201 CONTINUE 2645 C 2646 DO 206 JK = 1 , KFLEV 2647 JKJ=(JK-1)*NG1P1+1 2648 JKJR = JKJ 2649 JKJP = JKJ + NG1P1 2650 DO 203 JL = 1, KDLON 2651 ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100. 2652 203 CONTINUE 2653 DO 205 IG1=1,NG1 2654 JKJ=JKJ+1 2655 DO 204 JL = 1, KDLON 2656 ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5 2657 S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5 2658 204 CONTINUE 2659 205 CONTINUE 2660 206 CONTINUE 2661 C 2662 C----------------------------------------------------------------------- 2663 C 2664 C 2665 C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS 2666 C -------------------------------------------------- 2667 C 2668 400 CONTINUE 2669 C 2670 DO 402 JKI=1,3*KFLEV 2671 JKIP1=JKI+1 2672 DO 401 JL = 1, KDLON 2673 ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5 2674 ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1)) 2675 S /(10.*RG) 2676 401 CONTINUE 2677 402 CONTINUE 2678 C 2679 DO 406 JK = 1 , KFLEV 2680 JKP1=JK+1 2681 JKL = KFLEV+1 - JK 2682 DO 403 JL = 1, KDLON 2683 ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ ) 2684 ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO ) 2685 403 CONTINUE 2686 JKJ=(JK-1)*NG1P1+1 2687 JKJPN=JKJ+NG1 2688 DO 405 JKK=JKJ,JKJPN 2689 DO 404 JL = 1, KDLON 2690 ZDPM = ZABLY(JL,3,JKK) 2691 ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325. 2692 ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325. 2693 ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325. 2694 ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325. 2695 ZDUC(JL,JKK) = ZDPM 2696 ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM 2697 ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3 2698 ZU6 = ZXWV(JL) * ZUPM 2699 ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL)) 2700 ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O 2701 ZABLY(JL,11,JKK) = ZU6 * ZFPPW 2702 ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW) 2703 ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2 2704 ZABLY(JL,8,JKK) = RCO2 * ZDPM 2705 404 CONTINUE 2706 405 CONTINUE 2707 406 CONTINUE 2708 C 2709 C----------------------------------------------------------------------- 2710 C 2711 C 2712 C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE 2713 C -------------------------------------------------- 2714 C 2715 500 CONTINUE 2716 C 2717 DO 502 JA = 1, NUA 2718 DO 501 JL = 1, KDLON 2719 PABCU(JL,JA,3*KFLEV+1) = 0. 2720 501 CONTINUE 2721 502 CONTINUE 2722 C 2723 DO 529 JK = 1 , KFLEV 2724 JJ=(JK-1)*NG1P1+1 2725 JJPN=JJ+NG1 2726 JKL=KFLEV+1-JK 2727 C 2728 C 2729 C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE 2730 C -------------------------------------------------- 2731 C 2732 510 CONTINUE 2733 C 2734 JAE1=3*KFLEV+1-JJ 2735 JAE2=3*KFLEV+1-(JJ+1) 2736 JAE3=3*KFLEV+1-JJPN 2737 DO 512 JAE=1,5 2738 DO 511 JL = 1, KDLON 2739 ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1) 2740 S +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3) 2741 S +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5)) 2742 S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3)) 2743 511 CONTINUE 2744 512 CONTINUE 2745 C 2746 C 2747 C 2748 C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS 2749 C -------------------------------------------------- 2750 C 2751 520 CONTINUE 2752 C 2753 DO 521 JL = 1, KDLON 2754 ZTAVI(JL)=PTAVE(JL,JKL) 2755 ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.)) 2756 ZTX=ZTAVI(JL)-TREF 2757 ZTX2=ZTX*ZTX 2758 ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3) 2759 ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8) 2760 ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3))) 2761 ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3))) 2762 ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 ) 2763 ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3))) 2764 ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3))) 2765 ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 ) 2766 ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3))) 2767 ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3))) 2768 ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 ) 2769 ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3))) 2770 ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3))) 2771 ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 ) 2772 ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3))) 2773 ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3))) 2774 ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 ) 2775 ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3))) 2776 ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3))) 2777 ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 ) 2778 ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 ) 2779 ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 ) 2780 ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 ) 2781 ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 ) 2782 521 CONTINUE 2783 C 2784 DO 522 JL = 1, KDLON 2785 ZTAVI(JL)=PTAVE(JL,JKL) 2786 ZTX=ZTAVI(JL)-TREF 2787 ZTX2=ZTX*ZTX 2788 ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3) 2789 ZALUP = R10E * LOG ( ZZABLY ) 2790 ZUP = MAX( 0._8, 5.0 + 0.5 * ZALUP ) 2791 ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP 2792 ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3))) 2793 ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3))) 2794 ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 ) 2795 ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2) 2796 ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2)) 2797 522 CONTINUE 2798 C 2799 DO 524 JKK=JJ,JJPN 2800 JC=3*KFLEV+1-JKK 2801 JCP1=JC+1 2802 DO 523 JL = 1, KDLON 2803 ZDIFF = PVIEW(JL) 2804 PABCU(JL,10,JC)=PABCU(JL,10,JCP1) 2805 S +ZABLY(JL,10,JC) *ZDIFF 2806 PABCU(JL,11,JC)=PABCU(JL,11,JCP1) 2807 S +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF 2808 C 2809 PABCU(JL,12,JC)=PABCU(JL,12,JCP1) 2810 S +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF 2811 PABCU(JL,13,JC)=PABCU(JL,13,JCP1) 2812 S +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF 2813 C 2814 PABCU(JL,7,JC)=PABCU(JL,7,JCP1) 2815 S +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF 2816 PABCU(JL,8,JC)=PABCU(JL,8,JCP1) 2817 S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF 2818 PABCU(JL,9,JC)=PABCU(JL,9,JCP1) 2819 S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF 2820 C 2821 PABCU(JL,1,JC)=PABCU(JL,1,JCP1) 2822 S +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF 2823 PABCU(JL,2,JC)=PABCU(JL,2,JCP1) 2824 S +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF 2825 PABCU(JL,3,JC)=PABCU(JL,3,JCP1) 2826 S +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF 2827 PABCU(JL,4,JC)=PABCU(JL,4,JCP1) 2828 S +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF 2829 PABCU(JL,5,JC)=PABCU(JL,5,JCP1) 2830 S +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF 2831 PABCU(JL,6,JC)=PABCU(JL,6,JCP1) 2832 S +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF 2833 C 2834 PABCU(JL,14,JC)=PABCU(JL,14,JCP1) 2835 S +ZUAER(JL,1) *ZDUC(JL,JC)*ZDIFF 2836 PABCU(JL,15,JC)=PABCU(JL,15,JCP1) 2837 S +ZUAER(JL,2) *ZDUC(JL,JC)*ZDIFF 2838 PABCU(JL,16,JC)=PABCU(JL,16,JCP1) 2839 S +ZUAER(JL,3) *ZDUC(JL,JC)*ZDIFF 2840 PABCU(JL,17,JC)=PABCU(JL,17,JCP1) 2841 S +ZUAER(JL,4) *ZDUC(JL,JC)*ZDIFF 2842 PABCU(JL,18,JC)=PABCU(JL,18,JCP1) 2843 S +ZUAER(JL,5) *ZDUC(JL,JC)*ZDIFF 2844 C 2845 C 2846 2847 IF (type_trac == 'repr') THEN 2848 #ifdef REPROBUS 2849 IF (ok_Rtime2D) THEN 2850 PABCU(JL,19,JC)=PABCU(JL,19,JCP1) 2851 S +ZABLY(JL,8,JC)*RCH42D(JL,JC)/RCO2*ZPHM6(JL)*ZDIFF 2852 PABCU(JL,20,JC)=PABCU(JL,20,JCP1) 2853 S +ZABLY(JL,9,JC)*RCH42D(JL,JC)/RCO2*ZPSM6(JL)*ZDIFF 2854 PABCU(JL,21,JC)=PABCU(JL,21,JCP1) 2855 S +ZABLY(JL,8,JC)*RN2O2D(JL,JC)/RCO2*ZPHN6(JL)*ZDIFF 2856 PABCU(JL,22,JC)=PABCU(JL,22,JCP1) 2857 S +ZABLY(JL,9,JC)*RN2O2D(JL,JC)/RCO2*ZPSN6(JL)*ZDIFF 2858 C 2859 PABCU(JL,23,JC)=PABCU(JL,23,JCP1) 2860 S +ZABLY(JL,8,JC)*RCFC112D(JL,JC)/RCO2 *ZDIFF 2861 PABCU(JL,24,JC)=PABCU(JL,24,JCP1) 2862 S +ZABLY(JL,8,JC)*RCFC122D(JL,JC)/RCO2 *ZDIFF 2863 ELSE 2864 ! Same calculation as for type_trac /= repr 2865 PABCU(JL,19,JC)=PABCU(JL,19,JCP1) 2866 S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF 2867 PABCU(JL,20,JC)=PABCU(JL,20,JCP1) 2868 S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF 2869 PABCU(JL,21,JC)=PABCU(JL,21,JCP1) 2870 S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF 2871 PABCU(JL,22,JC)=PABCU(JL,22,JCP1) 2872 S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF 2873 C 2874 PABCU(JL,23,JC)=PABCU(JL,23,JCP1) 2875 S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF 2876 PABCU(JL,24,JC)=PABCU(JL,24,JCP1) 2877 S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF 2878 END IF 2879 #endif 2880 ELSE 2881 PABCU(JL,19,JC)=PABCU(JL,19,JCP1) 2882 S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF 2883 PABCU(JL,20,JC)=PABCU(JL,20,JCP1) 2884 S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF 2885 PABCU(JL,21,JC)=PABCU(JL,21,JCP1) 2886 S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF 2887 PABCU(JL,22,JC)=PABCU(JL,22,JCP1) 2888 S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF 2889 C 2890 PABCU(JL,23,JC)=PABCU(JL,23,JCP1) 2891 S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF 2892 PABCU(JL,24,JC)=PABCU(JL,24,JCP1) 2893 S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF 2894 END IF 2895 2896 523 CONTINUE 2897 524 CONTINUE 2898 C 2899 529 CONTINUE 2900 C 2901 C 2902 RETURN 2903 END 2904 SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU, 2905 S PFLUC,PBINT,PBSUI,PCTS,PCNTRB) 2906 USE dimphy 2907 IMPLICIT none 2908 cym#include "dimensions.h" 2909 cym#include "dimphy.h" 2910 cym#include "raddim.h" 2911 #include "raddimlw.h" 2912 #include "YOMCST.h" 2913 C 2914 C PURPOSE. 2915 C -------- 2916 C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE 2917 C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY 2918 C SAVING 2919 C 2920 C METHOD. 2921 C ------- 2922 C 2923 C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE 2924 C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS. 2925 C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON- 2926 C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE 2927 C BOUNDARIES. 2928 C 3. COMPUTES THE CLEAR-SKY COOLING RATES. 2929 C 2930 C REFERENCE. 2931 C ---------- 2932 C 2933 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 2934 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 2935 C 2936 C AUTHOR. 2937 C ------- 2938 C JEAN-JACQUES MORCRETTE *ECMWF* 2939 C 2940 C MODIFICATIONS. 2941 C -------------- 2942 C ORIGINAL : 89-07-14 2943 C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE 2944 C MEMORY) 2945 C----------------------------------------------------------------------- 2946 C* ARGUMENTS: 2947 INTEGER KLIM 2948 C 2949 REAL(KIND=8) PDP(KDLON,KFLEV) 2950 REAL(KIND=8) PDT0(KDLON) 2951 REAL(KIND=8) PEMIS(KDLON) 2952 REAL(KIND=8) PPMB(KDLON,KFLEV+1) 2953 REAL(KIND=8) PTL(KDLON,KFLEV+1) 2954 REAL(KIND=8) PTAVE(KDLON,KFLEV) 2955 C 2956 REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) 2957 C 2958 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) 2959 REAL(KIND=8) PBINT(KDLON,KFLEV+1) 2960 REAL(KIND=8) PBSUI(KDLON) 2961 REAL(KIND=8) PCTS(KDLON,KFLEV) 2962 REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) 2963 C 2964 C------------------------------------------------------------------------- 2965 C 2966 C* LOCAL VARIABLES: 2967 REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1) 2968 REAL(KIND=8) ZBSUR(KDLON,Ninter) 2969 REAL(KIND=8) ZBTOP(KDLON,Ninter) 2970 REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2) 2971 REAL(KIND=8) ZGA(KDLON,8,2,KFLEV) 2972 REAL(KIND=8) ZGB(KDLON,8,2,KFLEV) 2973 REAL(KIND=8) ZGASUR(KDLON,8,2) 2974 REAL(KIND=8) ZGBSUR(KDLON,8,2) 2975 REAL(KIND=8) ZGATOP(KDLON,8,2) 2976 REAL(KIND=8) ZGBTOP(KDLON,8,2) 2977 C 2978 INTEGER nuaer, ntraer 2979 C ------------------------------------------------------------------ 2980 C* COMPUTES PLANCK FUNCTIONS: 2981 CALL LWB_LMDAR4(PDT0,PTAVE,PTL, 2982 S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL, 2983 S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP) 2984 C ------------------------------------------------------------------ 2985 C* PERFORMS THE VERTICAL INTEGRATION: 2986 NUAER = NUA 2987 NTRAER = NTRA 2988 CALL LWV_LMDAR4(NUAER,NTRAER, KLIM 2989 R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE 2990 R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP 2991 S , PCNTRB,PCTS,PFLUC) 2992 C ------------------------------------------------------------------ 2993 RETURN 2994 END 2995 SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC, 2996 R PBINT,PBSUIN,PCTS,PCNTRB, 2997 S PFLUX) 2998 USE dimphy 2999 IMPLICIT none 3000 cym#include "dimensions.h" 3001 cym#include "dimphy.h" 3002 cym#include "raddim.h" 3003 #include "radepsi.h" 3004 #include "radopt.h" 3005 C 3006 C PURPOSE. 3007 C -------- 3008 C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR 3009 C RADIANCES 3010 C 3011 C EXPLICIT ARGUMENTS : 3012 C -------------------- 3013 C ==== INPUTS === 3014 C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION 3015 C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION 3016 C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION 3017 C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION 3018 C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE 3019 C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE 3020 C PEMIS : (KDLON) ; SURFACE EMISSIVITY 3021 C PFLUC 3022 C ==== OUTPUTS === 3023 C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES : 3024 C 1 ==> UPWARD FLUX TOTAL 3025 C 2 ==> DOWNWARD FLUX TOTAL 3026 C 3027 C METHOD. 3028 C ------- 3029 C 3030 C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES 3031 C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER 3032 C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED 3033 C CLOUDS 3034 C 3035 C REFERENCE. 3036 C ---------- 3037 C 3038 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 3039 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 3040 C 3041 C AUTHOR. 3042 C ------- 3043 C JEAN-JACQUES MORCRETTE *ECMWF* 3044 C 3045 C MODIFICATIONS. 3046 C -------------- 3047 C ORIGINAL : 89-07-14 3048 C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96 3049 C----------------------------------------------------------------------- 3050 C* ARGUMENTS: 3051 INTEGER klim 3052 REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES 3053 REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION 3054 REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION 3055 REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE 3056 REAL(KIND=8) PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE 3057 c 3058 REAL(KIND=8) PCLDLD(KDLON,KFLEV) 3059 REAL(KIND=8) PCLDLU(KDLON,KFLEV) 3060 REAL(KIND=8) PEMIS(KDLON) 3061 C 3062 REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1) 3063 C----------------------------------------------------------------------- 3064 C* LOCAL VARIABLES: 3065 INTEGER IMX(KDLON), IMXP(KDLON) 3066 C 3067 REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON), 3068 $ ZDNF(KDLON,KFLEV+1,KFLEV+1) 3069 S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON) 3070 S , ZUPF(KDLON,KFLEV+1,KFLEV+1) 3071 REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1) 3072 C 3073 INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1 3074 INTEGER jk1, jk2, jkc, jkcp1, jcloud 3075 INTEGER imxm1, imxp1 3076 REAL(KIND=8) zcfrac 3077 C ------------------------------------------------------------------ 3078 C 3079 C* 1. INITIALIZATION 3080 C -------------- 3081 C 3082 100 CONTINUE 3083 C 3084 IMAXC = 0 3085 C 3086 DO 101 JL = 1, KDLON 3087 IMX(JL)=0 3088 IMXP(JL)=0 3089 ZCLOUD(JL) = 0. 3090 101 CONTINUE 3091 C 3092 C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD 3093 C ------------------------------------------- 3094 C 3095 110 CONTINUE 3096 C 3097 DO 112 JK = 1 , KFLEV 3098 DO 111 JL = 1, KDLON 3099 IMX1=IMX(JL) 3100 IMX2=JK 3101 IF (PCLDLU(JL,JK).GT.ZEPSC) THEN 3102 IMXP(JL)=IMX2 3103 ELSE 3104 IMXP(JL)=IMX1 3105 END IF 3106 IMAXC=MAX(IMXP(JL),IMAXC) 3107 IMX(JL)=IMXP(JL) 3108 111 CONTINUE 3109 112 CONTINUE 3110 CGM******* 3111 IMAXC=KFLEV 3112 CGM******* 3113 C 3114 DO 114 JK = 1 , KFLEV+1 3115 DO 113 JL = 1, KDLON 3116 PFLUX(JL,1,JK) = PFLUC(JL,1,JK) 3117 PFLUX(JL,2,JK) = PFLUC(JL,2,JK) 3118 113 CONTINUE 3119 114 CONTINUE 3120 C 3121 C ------------------------------------------------------------------ 3122 C 3123 C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES 3124 C --------------------------------------- 3125 C 3126 IF (IMAXC.GT.0) THEN 3127 C 3128 IMXP1 = IMAXC + 1 3129 IMXM1 = IMAXC - 1 3130 C 3131 C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES 3132 C ------------------------------ 3133 C 3134 200 CONTINUE 3135 C 3136 DO 203 JK1=1,KFLEV+1 3137 DO 202 JK2=1,KFLEV+1 3138 DO 201 JL = 1, KDLON 3139 ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1) 3140 ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1) 3141 201 CONTINUE 3142 202 CONTINUE 3143 203 CONTINUE 3144 C 3145 C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD 3146 C ---------------------------------------------- 3147 C 3148 210 CONTINUE 3149 C 3150 DO 213 JKC = 1 , IMAXC 3151 JCLOUD=JKC 3152 JKCP1=JCLOUD+1 3153 C 3154 C* 2.1.1 ABOVE THE CLOUD 3155 C --------------- 3156 C 3157 2110 CONTINUE 3158 C 3159 DO 2115 JK=JKCP1,KFLEV+1 3160 JKM1=JK-1 3161 DO 2111 JL = 1, KDLON 3162 ZFU(JL)=0. 3163 2111 CONTINUE 3164 IF (JK .GT. JKCP1) THEN 3165 DO 2113 JKJ=JKCP1,JKM1 3166 DO 2112 JL = 1, KDLON 3167 ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ) 3168 2112 CONTINUE 3169 2113 CONTINUE 3170 END IF 3171 C 3172 DO 2114 JL = 1, KDLON 3173 ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL) 3174 2114 CONTINUE 3175 2115 CONTINUE 3176 C 3177 C* 2.1.2 BELOW THE CLOUD 3178 C --------------- 3179 C 3180 2120 CONTINUE 3181 C 3182 DO 2125 JK=1,JCLOUD 3183 JKP1=JK+1 3184 DO 2121 JL = 1, KDLON 3185 ZFD(JL)=0. 3186 2121 CONTINUE 3187 C 3188 IF (JK .LT. JCLOUD) THEN 3189 DO 2123 JKJ=JKP1,JCLOUD 3190 DO 2122 JL = 1, KDLON 3191 ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ) 3192 2122 CONTINUE 3193 2123 CONTINUE 3194 END IF 3195 DO 2124 JL = 1, KDLON 3196 ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL) 3197 2124 CONTINUE 3198 2125 CONTINUE 3199 C 3200 213 CONTINUE 3201 C 3202 C 3203 C* 2.2 CLOUD COVER MATRIX 3204 C ------------------ 3205 C 3206 C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN 3207 C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1 3208 C 3209 220 CONTINUE 3210 C 3211 DO 223 JK1 = 1 , KFLEV+1 3212 DO 222 JK2 = 1 , KFLEV+1 3213 DO 221 JL = 1, KDLON 3214 ZCLM(JL,JK1,JK2) = 0. 3215 221 CONTINUE 3216 222 CONTINUE 3217 223 CONTINUE 3218 C 3219 C 3220 C 3221 C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION 3222 C ------------------------------------------ 3223 C 3224 240 CONTINUE 3225 C 3226 DO 244 JK1 = 2 , KFLEV+1 3227 DO 241 JL = 1, KDLON 3228 ZCLEAR(JL)=1. 3229 ZCLOUD(JL)=0. 3230 241 CONTINUE 3231 DO 243 JK = JK1 - 1 , 1 , -1 3232 DO 242 JL = 1, KDLON 3233 IF (NOVLP.EQ.1) THEN 3234 c* maximum-random 3235 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL))) 3236 * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) 3237 ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) 3238 ZCLOUD(JL) = PCLDLU(JL,JK) 3239 ELSE IF (NOVLP.EQ.2) THEN 3240 c* maximum 3241 ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK)) 3242 ZCLM(JL,JK1,JK) = ZCLOUD(JL) 3243 ELSE IF (NOVLP.EQ.3) THEN 3244 c* random 3245 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK)) 3246 ZCLOUD(JL) = 1.0 - ZCLEAR(JL) 3247 ZCLM(JL,JK1,JK) = ZCLOUD(JL) 3248 END IF 3249 242 CONTINUE 3250 243 CONTINUE 3251 244 CONTINUE 3252 C 3253 C 3254 C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION 3255 C ------------------------------------------ 3256 C 3257 250 CONTINUE 3258 C 3259 DO 254 JK1 = 1 , KFLEV 3260 DO 251 JL = 1, KDLON 3261 ZCLEAR(JL)=1. 3262 ZCLOUD(JL)=0. 3263 251 CONTINUE 3264 DO 253 JK = JK1 , KFLEV 3265 DO 252 JL = 1, KDLON 3266 IF (NOVLP.EQ.1) THEN 3267 c* maximum-random 3268 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL))) 3269 * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC)) 3270 ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL) 3271 ZCLOUD(JL) = PCLDLD(JL,JK) 3272 ELSE IF (NOVLP.EQ.2) THEN 3273 c* maximum 3274 ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK)) 3275 ZCLM(JL,JK1,JK) = ZCLOUD(JL) 3276 ELSE IF (NOVLP.EQ.3) THEN 3277 c* random 3278 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK)) 3279 ZCLOUD(JL) = 1.0 - ZCLEAR(JL) 3280 ZCLM(JL,JK1,JK) = ZCLOUD(JL) 3281 END IF 3282 252 CONTINUE 3283 253 CONTINUE 3284 254 CONTINUE 3285 C 3286 C 3287 C 3288 C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS 3289 C ---------------------------------------------- 3290 C 3291 300 CONTINUE 3292 C 3293 C* 3.1 DOWNWARD FLUXES 3294 C --------------- 3295 C 3296 310 CONTINUE 3297 C 3298 DO 311 JL = 1, KDLON 3299 PFLUX(JL,2,KFLEV+1) = 0. 3300 311 CONTINUE 3301 C 3302 DO 317 JK1 = KFLEV , 1 , -1 3303 C 3304 C* CONTRIBUTION FROM CLEAR-SKY FRACTION 3305 C 3306 DO 312 JL = 1, KDLON 3307 ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1) 3308 312 CONTINUE 3309 C 3310 C* CONTRIBUTION FROM ADJACENT CLOUD 3311 C 3312 DO 313 JL = 1, KDLON 3313 ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1) 3314 313 CONTINUE 3315 C 3316 C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS 3317 C 3318 DO 315 JK = KFLEV-1 , JK1 , -1 3319 DO 314 JL = 1, KDLON 3320 ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK) 3321 ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1) 3322 314 CONTINUE 3323 315 CONTINUE 3324 C 3325 DO 316 JL = 1, KDLON 3326 PFLUX(JL,2,JK1) = ZFD (JL) 3327 316 CONTINUE 3328 C 3329 317 CONTINUE 3330 C 3331 C 3332 C 3333 C 3334 C* 3.2 UPWARD FLUX AT THE SURFACE 3335 C -------------------------- 3336 C 3337 320 CONTINUE 3338 C 3339 DO 321 JL = 1, KDLON 3340 PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1) 3341 321 CONTINUE 3342 C 3343 C 3344 C 3345 C* 3.3 UPWARD FLUXES 3346 C ------------- 3347 C 3348 330 CONTINUE 3349 C 3350 DO 337 JK1 = 2 , KFLEV+1 3351 C 3352 C* CONTRIBUTION FROM CLEAR-SKY FRACTION 3353 C 3354 DO 332 JL = 1, KDLON 3355 ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1) 3356 332 CONTINUE 3357 C 3358 C* CONTRIBUTION FROM ADJACENT CLOUD 3359 C 3360 DO 333 JL = 1, KDLON 3361 ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1) 3362 333 CONTINUE 3363 C 3364 C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS 3365 C 3366 DO 335 JK = 2 , JK1-1 3367 DO 334 JL = 1, KDLON 3368 ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK) 3369 ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1) 3370 334 CONTINUE 3371 335 CONTINUE 3372 C 3373 DO 336 JL = 1, KDLON 3374 PFLUX(JL,1,JK1) = ZFU (JL) 3375 336 CONTINUE 3376 C 3377 337 CONTINUE 3378 C 3379 C 3380 END IF 3381 C 3382 C 3383 C* 2.3 END OF CLOUD EFFECT COMPUTATIONS 3384 C 3385 230 CONTINUE 3386 C 3387 IF (.NOT.LEVOIGT) THEN 3388 DO 231 JL = 1, KDLON 3389 ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM) 3390 231 CONTINUE 3391 DO 233 JK = KLIM+1 , KFLEV+1 3392 DO 232 JL = 1, KDLON 3393 ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) 3394 PFLUX(JL,1,JK) = ZFN10(JL) 3395 PFLUX(JL,2,JK) = 0.0 3396 232 CONTINUE 3397 233 CONTINUE 3398 ENDIF 3399 C 3400 RETURN 3401 END 3402 SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL 3403 S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL 3404 S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP) 3405 USE dimphy 3406 USE radiation_AR4_param, only : TINTP, XP, GA, GB 3407 IMPLICIT none 3408 cym#include "dimensions.h" 3409 cym#include "dimphy.h" 3410 cym#include "raddim.h" 3411 #include "raddimlw.h" 3412 C 3413 C----------------------------------------------------------------------- 3414 C PURPOSE. 3415 C -------- 3416 C COMPUTES PLANCK FUNCTIONS 3417 C 3418 C EXPLICIT ARGUMENTS : 3419 C -------------------- 3420 C ==== INPUTS === 3421 C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY 3422 C PTAVE : (KDLON,KFLEV) ; TEMPERATURE 3423 C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE 3424 C ==== OUTPUTS === 3425 C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION 3426 C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION 3427 C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION 3428 C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION 3429 C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION 3430 C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT 3431 C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS 3432 C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS 3433 C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS 3434 C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS 3435 C 3436 C IMPLICIT ARGUMENTS : NONE 3437 C -------------------- 3438 C 3439 C METHOD. 3440 C ------- 3441 C 3442 C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS 3443 C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION 3444 C 3445 C REFERENCE. 3446 C ---------- 3447 C 3448 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 3449 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS " 3450 C 3451 C AUTHOR. 3452 C ------- 3453 C JEAN-JACQUES MORCRETTE *ECMWF* 3454 C 3455 C MODIFICATIONS. 3456 C -------------- 3457 C ORIGINAL : 89-07-14 3458 C 3459 C----------------------------------------------------------------------- 3460 C 3461 C ARGUMENTS: 3462 C 3463 REAL(KIND=8) PDT0(KDLON) 3464 REAL(KIND=8) PTAVE(KDLON,KFLEV) 3465 REAL(KIND=8) PTL(KDLON,KFLEV+1) 3466 C 3467 REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION 3468 REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION 3469 REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION 3470 REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION 3471 REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION 3472 REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 3473 REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS 3474 REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS 3475 REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS 3476 REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS 3477 REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS 3478 REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS 3479 C 3480 C------------------------------------------------------------------------- 3481 C* LOCAL VARIABLES: 3482 INTEGER INDB(KDLON),INDS(KDLON) 3483 REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1) 3484 REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON) 3485 c 3486 INTEGER jk, jl, ic, jnu, jf, jg 3487 INTEGER jk1, jk2 3488 INTEGER k, j, ixtox, indto, ixtx, indt 3489 INTEGER indsu, indtp 3490 REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx 3491 c 3492 C* Quelques parametres: 3493 REAL(KIND=8) TSTAND 3494 PARAMETER (TSTAND=250.0) 3495 REAL(KIND=8) TSTP 3496 PARAMETER (TSTP=12.5) 3497 INTEGER MXIXT 3498 PARAMETER (MXIXT=10) 3499 C 3500 C* Used Data Block: 3501 c REAL*8 TINTP(11) 3502 c SAVE TINTP 3503 cc$OMP THREADPRIVATE(TINTP) 3504 c REAL*8 GA(11,16,3), GB(11,16,3) 3505 c SAVE GA, GB 3506 cc$OMP THREADPRIVATE(GA, GB) 3507 c REAL*8 XP(6,6) 3508 c SAVE XP 3509 cc$OMP THREADPRIVATE(XP) 3510 c 3511 c DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250., 3512 c S 262.5, 275., 287.5, 300., 312.5 / 3513 C----------------------------------------------------------------------- 3514 C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ---------------- 3515 C 3516 C 3517 C 3518 C 3519 C-- R.D. -- G = - 0.2 SLA 3520 C 3521 C 3522 C----- INTERVAL = 1 ----- T = 187.5 3523 C 3524 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3525 C DATA (GA( 1, 1,IC),IC=1,3) / 3526 C S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/ 3527 C DATA (GB( 1, 1,IC),IC=1,3) / 3528 C S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/ 3529 C DATA (GA( 1, 2,IC),IC=1,3) / 3530 C S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/ 3531 C DATA (GB( 1, 2,IC),IC=1,3) / 3532 C S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/ 3533 C 3534 C----- INTERVAL = 1 ----- T = 200.0 3535 C 3536 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3537 C DATA (GA( 2, 1,IC),IC=1,3) / 3538 C S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/ 3539 C DATA (GB( 2, 1,IC),IC=1,3) / 3540 C S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/ 3541 C DATA (GA( 2, 2,IC),IC=1,3) / 3542 C S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/ 3543 C DATA (GB( 2, 2,IC),IC=1,3) / 3544 C S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/ 3545 C 3546 C----- INTERVAL = 1 ----- T = 212.5 3547 C 3548 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3549 C DATA (GA( 3, 1,IC),IC=1,3) / 3550 C S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/ 3551 C DATA (GB( 3, 1,IC),IC=1,3) / 3552 C S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/ 3553 C DATA (GA( 3, 2,IC),IC=1,3) / 3554 C S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/ 3555 C DATA (GB( 3, 2,IC),IC=1,3) / 3556 C S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/ 3557 C 3558 C----- INTERVAL = 1 ----- T = 225.0 3559 C 3560 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3561 C DATA (GA( 4, 1,IC),IC=1,3) / 3562 C S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/ 3563 C DATA (GB( 4, 1,IC),IC=1,3) / 3564 C S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/ 3565 C DATA (GA( 4, 2,IC),IC=1,3) / 3566 C S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/ 3567 C DATA (GB( 4, 2,IC),IC=1,3) / 3568 C S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/ 3569 C 3570 C----- INTERVAL = 1 ----- T = 237.5 3571 C 3572 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3573 C DATA (GA( 5, 1,IC),IC=1,3) / 3574 C S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/ 3575 C DATA (GB( 5, 1,IC),IC=1,3) / 3576 C S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/ 3577 C DATA (GA( 5, 2,IC),IC=1,3) / 3578 C S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/ 3579 C DATA (GB( 5, 2,IC),IC=1,3) / 3580 C S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/ 3581 C 3582 C----- INTERVAL = 1 ----- T = 250.0 3583 C 3584 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3585 C DATA (GA( 6, 1,IC),IC=1,3) / 3586 C S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/ 3587 C DATA (GB( 6, 1,IC),IC=1,3) / 3588 C S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/ 3589 C DATA (GA( 6, 2,IC),IC=1,3) / 3590 C S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/ 3591 C DATA (GB( 6, 2,IC),IC=1,3) / 3592 C S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/ 3593 C 3594 C----- INTERVAL = 1 ----- T = 262.5 3595 C 3596 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3597 C DATA (GA( 7, 1,IC),IC=1,3) / 3598 C S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/ 3599 C DATA (GB( 7, 1,IC),IC=1,3) / 3600 C S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/ 3601 C DATA (GA( 7, 2,IC),IC=1,3) / 3602 C S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/ 3603 C DATA (GB( 7, 2,IC),IC=1,3) / 3604 C S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/ 3605 C 3606 C----- INTERVAL = 1 ----- T = 275.0 3607 C 3608 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3609 C DATA (GA( 8, 1,IC),IC=1,3) / 3610 C S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/ 3611 C DATA (GB( 8, 1,IC),IC=1,3) / 3612 C S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/ 3613 C DATA (GA( 8, 2,IC),IC=1,3) / 3614 C S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/ 3615 C DATA (GB( 8, 2,IC),IC=1,3) / 3616 C S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/ 3617 C 3618 C----- INTERVAL = 1 ----- T = 287.5 3619 C 3620 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3621 C DATA (GA( 9, 1,IC),IC=1,3) / 3622 C S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/ 3623 C DATA (GB( 9, 1,IC),IC=1,3) / 3624 C S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/ 3625 C DATA (GA( 9, 2,IC),IC=1,3) / 3626 C S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/ 3627 C DATA (GB( 9, 2,IC),IC=1,3) / 3628 C S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/ 3629 C 3630 C----- INTERVAL = 1 ----- T = 300.0 3631 C 3632 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3633 C DATA (GA(10, 1,IC),IC=1,3) / 3634 C S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/ 3635 C DATA (GB(10, 1,IC),IC=1,3) / 3636 C S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/ 3637 C DATA (GA(10, 2,IC),IC=1,3) / 3638 C S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/ 3639 C DATA (GB(10, 2,IC),IC=1,3) / 3640 C S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/ 3641 C 3642 C----- INTERVAL = 1 ----- T = 312.5 3643 C 3644 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 3645 C DATA (GA(11, 1,IC),IC=1,3) / 3646 C S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/ 3647 C DATA (GB(11, 1,IC),IC=1,3) / 3648 C S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/ 3649 C DATA (GA(11, 2,IC),IC=1,3) / 3650 C S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/ 3651 C DATA (GB(11, 2,IC),IC=1,3) / 3652 C S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/ 3653 C 3654 C 3655 C 3656 C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 --------- 3657 C 3658 C 3659 C 3660 C 3661 C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U ) 3662 C 3663 C 3664 C----- INTERVAL = 2 ----- T = 187.5 3665 C 3666 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3667 C DATA (GA( 1, 3,IC),IC=1,3) / 3668 C S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/ 3669 C DATA (GB( 1, 3,IC),IC=1,3) / 3670 C S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/ 3671 C DATA (GA( 1, 4,IC),IC=1,3) / 3672 C S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/ 3673 C DATA (GB( 1, 4,IC),IC=1,3) / 3674 C S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/ 3675 C 3676 C----- INTERVAL = 2 ----- T = 200.0 3677 C 3678 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3679 C DATA (GA( 2, 3,IC),IC=1,3) / 3680 C S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/ 3681 C DATA (GB( 2, 3,IC),IC=1,3) / 3682 C S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/ 3683 C DATA (GA( 2, 4,IC),IC=1,3) / 3684 C S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/ 3685 C DATA (GB( 2, 4,IC),IC=1,3) / 3686 C S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/ 3687 C 3688 C----- INTERVAL = 2 ----- T = 212.5 3689 C 3690 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3691 C DATA (GA( 3, 3,IC),IC=1,3) / 3692 C S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/ 3693 C DATA (GB( 3, 3,IC),IC=1,3) / 3694 C S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/ 3695 C DATA (GA( 3, 4,IC),IC=1,3) / 3696 C S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/ 3697 C DATA (GB( 3, 4,IC),IC=1,3) / 3698 C S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/ 3699 C 3700 C----- INTERVAL = 2 ----- T = 225.0 3701 C 3702 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3703 C DATA (GA( 4, 3,IC),IC=1,3) / 3704 C S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/ 3705 C DATA (GB( 4, 3,IC),IC=1,3) / 3706 C S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/ 3707 C DATA (GA( 4, 4,IC),IC=1,3) / 3708 C S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/ 3709 C DATA (GB( 4, 4,IC),IC=1,3) / 3710 C S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/ 3711 C 3712 C----- INTERVAL = 2 ----- T = 237.5 3713 C 3714 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3715 C DATA (GA( 5, 3,IC),IC=1,3) / 3716 C S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/ 3717 C DATA (GB( 5, 3,IC),IC=1,3) / 3718 C S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/ 3719 C DATA (GA( 5, 4,IC),IC=1,3) / 3720 C S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/ 3721 C DATA (GB( 5, 4,IC),IC=1,3) / 3722 C S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/ 3723 C 3724 C----- INTERVAL = 2 ----- T = 250.0 3725 C 3726 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3727 C DATA (GA( 6, 3,IC),IC=1,3) / 3728 C S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/ 3729 C DATA (GB( 6, 3,IC),IC=1,3) / 3730 C S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/ 3731 C DATA (GA( 6, 4,IC),IC=1,3) / 3732 C S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/ 3733 C DATA (GB( 6, 4,IC),IC=1,3) / 3734 C S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/ 3735 C 3736 C----- INTERVAL = 2 ----- T = 262.5 3737 C 3738 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3739 C DATA (GA( 7, 3,IC),IC=1,3) / 3740 C S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/ 3741 C DATA (GB( 7, 3,IC),IC=1,3) / 3742 C S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/ 3743 C DATA (GA( 7, 4,IC),IC=1,3) / 3744 C S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/ 3745 C DATA (GB( 7, 4,IC),IC=1,3) / 3746 C S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/ 3747 C 3748 C----- INTERVAL = 2 ----- T = 275.0 3749 C 3750 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3751 C DATA (GA( 8, 3,IC),IC=1,3) / 3752 C S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/ 3753 C DATA (GB( 8, 3,IC),IC=1,3) / 3754 C S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/ 3755 C DATA (GA( 8, 4,IC),IC=1,3) / 3756 C S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/ 3757 C DATA (GB( 8, 4,IC),IC=1,3) / 3758 C S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/ 3759 C 3760 C----- INTERVAL = 2 ----- T = 287.5 3761 C 3762 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3763 C DATA (GA( 9, 3,IC),IC=1,3) / 3764 C S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/ 3765 C DATA (GB( 9, 3,IC),IC=1,3) / 3766 C S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/ 3767 C DATA (GA( 9, 4,IC),IC=1,3) / 3768 C S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/ 3769 C DATA (GB( 9, 4,IC),IC=1,3) / 3770 C S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/ 3771 C 3772 C----- INTERVAL = 2 ----- T = 300.0 3773 C 3774 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3775 C DATA (GA(10, 3,IC),IC=1,3) / 3776 C S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/ 3777 C DATA (GB(10, 3,IC),IC=1,3) / 3778 C S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/ 3779 C DATA (GA(10, 4,IC),IC=1,3) / 3780 C S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/ 3781 C DATA (GB(10, 4,IC),IC=1,3) / 3782 C S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/ 3783 C 3784 C----- INTERVAL = 2 ----- T = 312.5 3785 C 3786 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3787 C DATA (GA(11, 3,IC),IC=1,3) / 3788 C S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/ 3789 C DATA (GB(11, 3,IC),IC=1,3) / 3790 C S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/ 3791 C DATA (GA(11, 4,IC),IC=1,3) / 3792 C S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/ 3793 C DATA (GB(11, 4,IC),IC=1,3) / 3794 C S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/ 3795 C 3796 C 3797 C 3798 C 3799 C 3800 C 3801 C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS - 3802 C 3803 C 3804 C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1) 3805 C 3806 C 3807 C 3808 C--- G = 3.875E-03 --------------- 3809 C 3810 C----- INTERVAL = 3 ----- T = 187.5 3811 C 3812 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3813 C DATA (GA( 1, 7,IC),IC=1,3) / 3814 C S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/ 3815 C DATA (GB( 1, 7,IC),IC=1,3) / 3816 C S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/ 3817 C DATA (GA( 1, 8,IC),IC=1,3) / 3818 C S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/ 3819 C DATA (GB( 1, 8,IC),IC=1,3) / 3820 C S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/ 3821 C 3822 C----- INTERVAL = 3 ----- T = 200.0 3823 C 3824 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3825 C DATA (GA( 2, 7,IC),IC=1,3) / 3826 C S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/ 3827 C DATA (GB( 2, 7,IC),IC=1,3) / 3828 C S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/ 3829 C DATA (GA( 2, 8,IC),IC=1,3) / 3830 C S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/ 3831 C DATA (GB( 2, 8,IC),IC=1,3) / 3832 C S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/ 3833 C 3834 C----- INTERVAL = 3 ----- T = 212.5 3835 C 3836 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3837 C DATA (GA( 3, 7,IC),IC=1,3) / 3838 C S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/ 3839 C DATA (GB( 3, 7,IC),IC=1,3) / 3840 C S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/ 3841 C DATA (GA( 3, 8,IC),IC=1,3) / 3842 C S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/ 3843 C DATA (GB( 3, 8,IC),IC=1,3) / 3844 C S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/ 3845 C 3846 C----- INTERVAL = 3 ----- T = 225.0 3847 C 3848 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3849 C DATA (GA( 4, 7,IC),IC=1,3) / 3850 C S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/ 3851 C DATA (GB( 4, 7,IC),IC=1,3) / 3852 C S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/ 3853 C DATA (GA( 4, 8,IC),IC=1,3) / 3854 C S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/ 3855 C DATA (GB( 4, 8,IC),IC=1,3) / 3856 C S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/ 3857 C 3858 C----- INTERVAL = 3 ----- T = 237.5 3859 C 3860 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3861 C DATA (GA( 5, 7,IC),IC=1,3) / 3862 C S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/ 3863 C DATA (GB( 5, 7,IC),IC=1,3) / 3864 C S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/ 3865 C DATA (GA( 5, 8,IC),IC=1,3) / 3866 C S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/ 3867 C DATA (GB( 5, 8,IC),IC=1,3) / 3868 C S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/ 3869 C 3870 C----- INTERVAL = 3 ----- T = 250.0 3871 C 3872 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3873 C DATA (GA( 6, 7,IC),IC=1,3) / 3874 C S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/ 3875 C DATA (GB( 6, 7,IC),IC=1,3) / 3876 C S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/ 3877 C DATA (GA( 6, 8,IC),IC=1,3) / 3878 C S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/ 3879 C DATA (GB( 6, 8,IC),IC=1,3) / 3880 C S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/ 3881 C 3882 C----- INTERVAL = 3 ----- T = 262.5 3883 C 3884 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3885 C DATA (GA( 7, 7,IC),IC=1,3) / 3886 C S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/ 3887 C DATA (GB( 7, 7,IC),IC=1,3) / 3888 C S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/ 3889 C DATA (GA( 7, 8,IC),IC=1,3) / 3890 C S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/ 3891 C DATA (GB( 7, 8,IC),IC=1,3) / 3892 C S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/ 3893 C 3894 C----- INTERVAL = 3 ----- T = 275.0 3895 C 3896 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3897 C DATA (GA( 8, 7,IC),IC=1,3) / 3898 C S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/ 3899 C DATA (GB( 8, 7,IC),IC=1,3) / 3900 C S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/ 3901 C DATA (GA( 8, 8,IC),IC=1,3) / 3902 C S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/ 3903 C DATA (GB( 8, 8,IC),IC=1,3) / 3904 C S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/ 3905 C 3906 C----- INTERVAL = 3 ----- T = 287.5 3907 C 3908 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3909 C DATA (GA( 9, 7,IC),IC=1,3) / 3910 C S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/ 3911 C DATA (GB( 9, 7,IC),IC=1,3) / 3912 C S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/ 3913 C DATA (GA( 9, 8,IC),IC=1,3) / 3914 C S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/ 3915 C DATA (GB( 9, 8,IC),IC=1,3) / 3916 C S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/ 3917 C 3918 C----- INTERVAL = 3 ----- T = 300.0 3919 C 3920 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3921 C DATA (GA(10, 7,IC),IC=1,3) / 3922 C S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/ 3923 C DATA (GB(10, 7,IC),IC=1,3) / 3924 C S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/ 3925 C DATA (GA(10, 8,IC),IC=1,3) / 3926 C S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/ 3927 C DATA (GB(10, 8,IC),IC=1,3) / 3928 C S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/ 3929 C 3930 C----- INTERVAL = 3 ----- T = 312.5 3931 C 3932 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3933 C DATA (GA(11, 7,IC),IC=1,3) / 3934 C S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/ 3935 C DATA (GB(11, 7,IC),IC=1,3) / 3936 C S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/ 3937 C DATA (GA(11, 8,IC),IC=1,3) / 3938 C S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/ 3939 C DATA (GB(11, 8,IC),IC=1,3) / 3940 C S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/ 3941 C 3942 C 3943 C-- WATER VAPOR -- 970-1110 CM-1 ---------------------------------------- 3944 C 3945 C-- G = 3.6E-03 3946 C 3947 C----- INTERVAL = 4 ----- T = 187.5 3948 C 3949 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3950 C DATA (GA( 1, 9,IC),IC=1,3) / 3951 C S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/ 3952 C DATA (GB( 1, 9,IC),IC=1,3) / 3953 C S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/ 3954 C DATA (GA( 1,10,IC),IC=1,3) / 3955 C S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/ 3956 C DATA (GB( 1,10,IC),IC=1,3) / 3957 C S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/ 3958 C 3959 C----- INTERVAL = 4 ----- T = 200.0 3960 C 3961 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3962 C DATA (GA( 2, 9,IC),IC=1,3) / 3963 C S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/ 3964 C DATA (GB( 2, 9,IC),IC=1,3) / 3965 C S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/ 3966 C DATA (GA( 2,10,IC),IC=1,3) / 3967 C S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/ 3968 C DATA (GB( 2,10,IC),IC=1,3) / 3969 C S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/ 3970 C 3971 C----- INTERVAL = 4 ----- T = 212.5 3972 C 3973 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3974 C DATA (GA( 3, 9,IC),IC=1,3) / 3975 C S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/ 3976 C DATA (GB( 3, 9,IC),IC=1,3) / 3977 C S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/ 3978 C DATA (GA( 3,10,IC),IC=1,3) / 3979 C S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/ 3980 C DATA (GB( 3,10,IC),IC=1,3) / 3981 C S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/ 3982 C 3983 C----- INTERVAL = 4 ----- T = 225.0 3984 C 3985 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3986 C DATA (GA( 4, 9,IC),IC=1,3) / 3987 C S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/ 3988 C DATA (GB( 4, 9,IC),IC=1,3) / 3989 C S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/ 3990 C DATA (GA( 4,10,IC),IC=1,3) / 3991 C S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/ 3992 C DATA (GB( 4,10,IC),IC=1,3) / 3993 C S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/ 3994 C 3995 C----- INTERVAL = 4 ----- T = 237.5 3996 C 3997 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 3998 C DATA (GA( 5, 9,IC),IC=1,3) / 3999 C S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/ 4000 C DATA (GB( 5, 9,IC),IC=1,3) / 4001 C S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/ 4002 C DATA (GA( 5,10,IC),IC=1,3) / 4003 C S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/ 4004 C DATA (GB( 5,10,IC),IC=1,3) / 4005 C S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/ 4006 C 4007 C----- INTERVAL = 4 ----- T = 250.0 4008 C 4009 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4010 C DATA (GA( 6, 9,IC),IC=1,3) / 4011 C S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/ 4012 C DATA (GB( 6, 9,IC),IC=1,3) / 4013 C S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/ 4014 C DATA (GA( 6,10,IC),IC=1,3) / 4015 C S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/ 4016 C DATA (GB( 6,10,IC),IC=1,3) / 4017 C S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/ 4018 C 4019 C----- INTERVAL = 4 ----- T = 262.5 4020 C 4021 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4022 C DATA (GA( 7, 9,IC),IC=1,3) / 4023 C S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/ 4024 C DATA (GB( 7, 9,IC),IC=1,3) / 4025 C S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/ 4026 C DATA (GA( 7,10,IC),IC=1,3) / 4027 C S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/ 4028 C DATA (GB( 7,10,IC),IC=1,3) / 4029 C S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/ 4030 C 4031 C----- INTERVAL = 4 ----- T = 275.0 4032 C 4033 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4034 C DATA (GA( 8, 9,IC),IC=1,3) / 4035 C S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/ 4036 C DATA (GB( 8, 9,IC),IC=1,3) / 4037 C S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/ 4038 C DATA (GA( 8,10,IC),IC=1,3) / 4039 C S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/ 4040 C DATA (GB( 8,10,IC),IC=1,3) / 4041 C S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/ 4042 C 4043 C----- INTERVAL = 4 ----- T = 287.5 4044 C 4045 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4046 C DATA (GA( 9, 9,IC),IC=1,3) / 4047 C S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/ 4048 C DATA (GB( 9, 9,IC),IC=1,3) / 4049 C S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/ 4050 C DATA (GA( 9,10,IC),IC=1,3) / 4051 C S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/ 4052 C DATA (GB( 9,10,IC),IC=1,3) / 4053 C S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/ 4054 C 4055 C----- INTERVAL = 4 ----- T = 300.0 4056 C 4057 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4058 C DATA (GA(10, 9,IC),IC=1,3) / 4059 C S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/ 4060 C DATA (GB(10, 9,IC),IC=1,3) / 4061 C S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/ 4062 C DATA (GA(10,10,IC),IC=1,3) / 4063 C S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/ 4064 C DATA (GB(10,10,IC),IC=1,3) / 4065 C S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/ 4066 C 4067 C----- INTERVAL = 4 ----- T = 312.5 4068 C 4069 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45 4070 C DATA (GA(11, 9,IC),IC=1,3) / 4071 C S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/ 4072 C DATA (GB(11, 9,IC),IC=1,3) / 4073 C S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/ 4074 C DATA (GA(11,10,IC),IC=1,3) / 4075 C S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/ 4076 C DATA (GB(11,10,IC),IC=1,3) / 4077 C S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/ 4078 C 4079 C 4080 C 4081 C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ---- 4082 C 4083 C-- WATER VAPOR --- 350 - 500 CM-1 4084 C 4085 C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U) 4086 C 4087 C----- INTERVAL = 5 ----- T = 187.5 4088 C 4089 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4090 C DATA (GA( 1, 5,IC),IC=1,3) / 4091 C S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/ 4092 C DATA (GB( 1, 5,IC),IC=1,3) / 4093 C S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/ 4094 C DATA (GA( 1, 6,IC),IC=1,3) / 4095 C S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/ 4096 C DATA (GB( 1, 6,IC),IC=1,3) / 4097 C S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/ 4098 C 4099 C----- INTERVAL = 5 ----- T = 200.0 4100 C 4101 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4102 C DATA (GA( 2, 5,IC),IC=1,3) / 4103 C S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/ 4104 C DATA (GB( 2, 5,IC),IC=1,3) / 4105 C S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/ 4106 C DATA (GA( 2, 6,IC),IC=1,3) / 4107 C S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/ 4108 C DATA (GB( 2, 6,IC),IC=1,3) / 4109 C S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/ 4110 C 4111 C----- INTERVAL = 5 ----- T = 212.5 4112 C 4113 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4114 C DATA (GA( 3, 5,IC),IC=1,3) / 4115 C S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/ 4116 C DATA (GB( 3, 5,IC),IC=1,3) / 4117 C S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/ 4118 C DATA (GA( 3, 6,IC),IC=1,3) / 4119 C S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/ 4120 C DATA (GB( 3, 6,IC),IC=1,3) / 4121 C S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/ 4122 C 4123 C----- INTERVAL = 5 ----- T = 225.0 4124 C 4125 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4126 C DATA (GA( 4, 5,IC),IC=1,3) / 4127 C S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/ 4128 C DATA (GB( 4, 5,IC),IC=1,3) / 4129 C S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/ 4130 C DATA (GA( 4, 6,IC),IC=1,3) / 4131 C S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/ 4132 C DATA (GB( 4, 6,IC),IC=1,3) / 4133 C S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/ 4134 C 4135 C----- INTERVAL = 5 ----- T = 237.5 4136 C 4137 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4138 C DATA (GA( 5, 5,IC),IC=1,3) / 4139 C S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/ 4140 C DATA (GB( 5, 5,IC),IC=1,3) / 4141 C S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/ 4142 C DATA (GA( 5, 6,IC),IC=1,3) / 4143 C S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/ 4144 C DATA (GB( 5, 6,IC),IC=1,3) / 4145 C S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/ 4146 C 4147 C----- INTERVAL = 5 ----- T = 250.0 4148 C 4149 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4150 C DATA (GA( 6, 5,IC),IC=1,3) / 4151 C S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/ 4152 C DATA (GB( 6, 5,IC),IC=1,3) / 4153 C S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/ 4154 C DATA (GA( 6, 6,IC),IC=1,3) / 4155 C S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/ 4156 C DATA (GB( 6, 6,IC),IC=1,3) / 4157 C S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/ 4158 C 4159 C----- INTERVAL = 5 ----- T = 262.5 4160 C 4161 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4162 C DATA (GA( 7, 5,IC),IC=1,3) / 4163 C S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/ 4164 C DATA (GB( 7, 5,IC),IC=1,3) / 4165 C S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/ 4166 C DATA (GA( 7, 6,IC),IC=1,3) / 4167 C S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/ 4168 C DATA (GB( 7, 6,IC),IC=1,3) / 4169 C S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/ 4170 C 4171 C----- INTERVAL = 5 ----- T = 275.0 4172 C 4173 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4174 C DATA (GA( 8, 5,IC),IC=1,3) / 4175 C S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/ 4176 C DATA (GB( 8, 5,IC),IC=1,3) / 4177 C S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/ 4178 C DATA (GA( 8, 6,IC),IC=1,3) / 4179 C S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/ 4180 C DATA (GB( 8, 6,IC),IC=1,3) / 4181 C S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/ 4182 C 4183 C----- INTERVAL = 5 ----- T = 287.5 4184 C 4185 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4186 C DATA (GA( 9, 5,IC),IC=1,3) / 4187 C S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/ 4188 C DATA (GB( 9, 5,IC),IC=1,3) / 4189 C S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/ 4190 C DATA (GA( 9, 6,IC),IC=1,3) / 4191 C S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/ 4192 C DATA (GB( 9, 6,IC),IC=1,3) / 4193 C S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/ 4194 C 4195 C----- INTERVAL = 5 ----- T = 300.0 4196 C 4197 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4198 C DATA (GA(10, 5,IC),IC=1,3) / 4199 C S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/ 4200 C DATA (GB(10, 5,IC),IC=1,3) / 4201 C S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/ 4202 C DATA (GA(10, 6,IC),IC=1,3) / 4203 C S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/ 4204 C DATA (GB(10, 6,IC),IC=1,3) / 4205 C S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/ 4206 C 4207 C----- INTERVAL = 5 ----- T = 312.5 4208 C 4209 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4210 C DATA (GA(11, 5,IC),IC=1,3) / 4211 C S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/ 4212 C DATA (GB(11, 5,IC),IC=1,3) / 4213 C S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/ 4214 C DATA (GA(11, 6,IC),IC=1,3) / 4215 C S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/ 4216 C DATA (GB(11, 6,IC),IC=1,3) / 4217 C S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/ 4218 C 4219 C 4220 C 4221 C 4222 C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 - 4223 C--- G = 0.0 4224 C 4225 C 4226 C----- INTERVAL = 6 ----- T = 187.5 4227 C 4228 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4229 C DATA (GA( 1,11,IC),IC=1,3) / 4230 C S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/ 4231 C DATA (GB( 1,11,IC),IC=1,3) / 4232 C S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/ 4233 C DATA (GA( 1,12,IC),IC=1,3) / 4234 C S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/ 4235 C DATA (GB( 1,12,IC),IC=1,3) / 4236 C S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/ 4237 C 4238 C----- INTERVAL = 6 ----- T = 200.0 4239 C 4240 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4241 C DATA (GA( 2,11,IC),IC=1,3) / 4242 C S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/ 4243 C DATA (GB( 2,11,IC),IC=1,3) / 4244 C S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/ 4245 C DATA (GA( 2,12,IC),IC=1,3) / 4246 C S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/ 4247 C DATA (GB( 2,12,IC),IC=1,3) / 4248 C S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/ 4249 C 4250 C----- INTERVAL = 6 ----- T = 212.5 4251 C 4252 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4253 C DATA (GA( 3,11,IC),IC=1,3) / 4254 C S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/ 4255 C DATA (GB( 3,11,IC),IC=1,3) / 4256 C S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/ 4257 C DATA (GA( 3,12,IC),IC=1,3) / 4258 C S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/ 4259 C DATA (GB( 3,12,IC),IC=1,3) / 4260 C S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/ 4261 C 4262 C----- INTERVAL = 6 ----- T = 225.0 4263 C 4264 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4265 C DATA (GA( 4,11,IC),IC=1,3) / 4266 C S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/ 4267 C DATA (GB( 4,11,IC),IC=1,3) / 4268 C S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/ 4269 C DATA (GA( 4,12,IC),IC=1,3) / 4270 C S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/ 4271 C DATA (GB( 4,12,IC),IC=1,3) / 4272 C S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/ 4273 C 4274 C----- INTERVAL = 6 ----- T = 237.5 4275 C 4276 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4277 C DATA (GA( 5,11,IC),IC=1,3) / 4278 C S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/ 4279 C DATA (GB( 5,11,IC),IC=1,3) / 4280 C S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/ 4281 C DATA (GA( 5,12,IC),IC=1,3) / 4282 C S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/ 4283 C DATA (GB( 5,12,IC),IC=1,3) / 4284 C S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/ 4285 C 4286 C----- INTERVAL = 6 ----- T = 250.0 4287 C 4288 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4289 C DATA (GA( 6,11,IC),IC=1,3) / 4290 C S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/ 4291 C DATA (GB( 6,11,IC),IC=1,3) / 4292 C S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/ 4293 C DATA (GA( 6,12,IC),IC=1,3) / 4294 C S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/ 4295 C DATA (GB( 6,12,IC),IC=1,3) / 4296 C S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/ 4297 C 4298 C----- INTERVAL = 6 ----- T = 262.5 4299 C 4300 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4301 C DATA (GA( 7,11,IC),IC=1,3) / 4302 C S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/ 4303 C DATA (GB( 7,11,IC),IC=1,3) / 4304 C S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/ 4305 C DATA (GA( 7,12,IC),IC=1,3) / 4306 C S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/ 4307 C DATA (GB( 7,12,IC),IC=1,3) / 4308 C S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/ 4309 C 4310 C----- INTERVAL = 6 ----- T = 275.0 4311 C 4312 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4313 C DATA (GA( 8,11,IC),IC=1,3) / 4314 C S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/ 4315 C DATA (GB( 8,11,IC),IC=1,3) / 4316 C S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/ 4317 C DATA (GA( 8,12,IC),IC=1,3) / 4318 C S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/ 4319 C DATA (GB( 8,12,IC),IC=1,3) / 4320 C S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/ 4321 C 4322 C----- INTERVAL = 6 ----- T = 287.5 4323 C 4324 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4325 C DATA (GA( 9,11,IC),IC=1,3) / 4326 C S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/ 4327 C DATA (GB( 9,11,IC),IC=1,3) / 4328 C S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/ 4329 C DATA (GA( 9,12,IC),IC=1,3) / 4330 C S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/ 4331 C DATA (GB( 9,12,IC),IC=1,3) / 4332 C S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/ 4333 C 4334 C----- INTERVAL = 6 ----- T = 300.0 4335 C 4336 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4337 C DATA (GA(10,11,IC),IC=1,3) / 4338 C S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/ 4339 C DATA (GB(10,11,IC),IC=1,3) / 4340 C S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/ 4341 C DATA (GA(10,12,IC),IC=1,3) / 4342 C S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/ 4343 C DATA (GB(10,12,IC),IC=1,3) / 4344 C S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/ 4345 C 4346 C----- INTERVAL = 6 ----- T = 312.5 4347 C 4348 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45 4349 C DATA (GA(11,11,IC),IC=1,3) / 4350 C S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/ 4351 C DATA (GB(11,11,IC),IC=1,3) / 4352 C S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/ 4353 C DATA (GA(11,12,IC),IC=1,3) / 4354 C S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/ 4355 C DATA (GB(11,12,IC),IC=1,3) / 4356 C S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/ 4357 C 4358 C 4359 C 4360 C 4361 C 4362 C-- END WATER VAPOR 4363 C 4364 C 4365 C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ---------------------- 4366 C 4367 C 4368 C 4369 C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9 4370 C 4371 C----- INTERVAL = 2 ----- T = 187.5 4372 C 4373 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4374 C DATA (GA( 1,13,IC),IC=1,3) / 4375 C S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/ 4376 C DATA (GB( 1,13,IC),IC=1,3) / 4377 C S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/ 4378 C DATA (GA( 1,14,IC),IC=1,3) / 4379 C S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/ 4380 C DATA (GB( 1,14,IC),IC=1,3) / 4381 C S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/ 4382 C 4383 C----- INTERVAL = 2 ----- T = 200.0 4384 C 4385 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4386 C DATA (GA( 2,13,IC),IC=1,3) / 4387 C S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/ 4388 C DATA (GB( 2,13,IC),IC=1,3) / 4389 C S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/ 4390 C DATA (GA( 2,14,IC),IC=1,3) / 4391 C S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/ 4392 C DATA (GB( 2,14,IC),IC=1,3) / 4393 C S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/ 4394 C 4395 C----- INTERVAL = 2 ----- T = 212.5 4396 C 4397 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4398 C DATA (GA( 3,13,IC),IC=1,3) / 4399 C S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/ 4400 C DATA (GB( 3,13,IC),IC=1,3) / 4401 C S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/ 4402 C DATA (GA( 3,14,IC),IC=1,3) / 4403 C S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/ 4404 C DATA (GB( 3,14,IC),IC=1,3) / 4405 C S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/ 4406 C 4407 C----- INTERVAL = 2 ----- T = 225.0 4408 C 4409 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4410 C DATA (GA( 4,13,IC),IC=1,3) / 4411 C S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/ 4412 C DATA (GB( 4,13,IC),IC=1,3) / 4413 C S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/ 4414 C DATA (GA( 4,14,IC),IC=1,3) / 4415 C S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/ 4416 C DATA (GB( 4,14,IC),IC=1,3) / 4417 C S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/ 4418 C 4419 C----- INTERVAL = 2 ----- T = 237.5 4420 C 4421 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4422 C DATA (GA( 5,13,IC),IC=1,3) / 4423 C S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/ 4424 C DATA (GB( 5,13,IC),IC=1,3) / 4425 C S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/ 4426 C DATA (GA( 5,14,IC),IC=1,3) / 4427 C S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/ 4428 C DATA (GB( 5,14,IC),IC=1,3) / 4429 C S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/ 4430 C 4431 C----- INTERVAL = 2 ----- T = 250.0 4432 C 4433 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4434 C DATA (GA( 6,13,IC),IC=1,3) / 4435 C S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/ 4436 C DATA (GB( 6,13,IC),IC=1,3) / 4437 C S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/ 4438 C DATA (GA( 6,14,IC),IC=1,3) / 4439 C S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/ 4440 C DATA (GB( 6,14,IC),IC=1,3) / 4441 C S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/ 4442 C 4443 C----- INTERVAL = 2 ----- T = 262.5 4444 C 4445 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4446 C DATA (GA( 7,13,IC),IC=1,3) / 4447 C S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/ 4448 C DATA (GB( 7,13,IC),IC=1,3) / 4449 C S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/ 4450 C DATA (GA( 7,14,IC),IC=1,3) / 4451 C S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/ 4452 C DATA (GB( 7,14,IC),IC=1,3) / 4453 C S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/ 4454 C 4455 C----- INTERVAL = 2 ----- T = 275.0 4456 C 4457 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4458 C DATA (GA( 8,13,IC),IC=1,3) / 4459 C S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/ 4460 C DATA (GB( 8,13,IC),IC=1,3) / 4461 C S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/ 4462 C DATA (GA( 8,14,IC),IC=1,3) / 4463 C S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/ 4464 C DATA (GB( 8,14,IC),IC=1,3) / 4465 C S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/ 4466 C 4467 C----- INTERVAL = 2 ----- T = 287.5 4468 C 4469 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4470 C DATA (GA( 9,13,IC),IC=1,3) / 4471 C S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/ 4472 C DATA (GB( 9,13,IC),IC=1,3) / 4473 C S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/ 4474 C DATA (GA( 9,14,IC),IC=1,3) / 4475 C S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/ 4476 C DATA (GB( 9,14,IC),IC=1,3) / 4477 C S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/ 4478 C 4479 C----- INTERVAL = 2 ----- T = 300.0 4480 C 4481 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4482 C DATA (GA(10,13,IC),IC=1,3) / 4483 C S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/ 4484 C DATA (GB(10,13,IC),IC=1,3) / 4485 C S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/ 4486 C DATA (GA(10,14,IC),IC=1,3) / 4487 C S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/ 4488 C DATA (GB(10,14,IC),IC=1,3) / 4489 C S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/ 4490 C 4491 C----- INTERVAL = 2 ----- T = 312.5 4492 C 4493 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45 4494 C DATA (GA(11,13,IC),IC=1,3) / 4495 C S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/ 4496 C DATA (GB(11,13,IC),IC=1,3) / 4497 C S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/ 4498 C DATA (GA(11,14,IC),IC=1,3) / 4499 C S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/ 4500 C DATA (GB(11,14,IC),IC=1,3) / 4501 C S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/ 4502 C 4503 C 4504 C 4505 C 4506 C 4507 C 4508 C 4509 C 4510 C 4511 C 4512 C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1) 4513 C 4514 C 4515 C-- G = 0.0 4516 C 4517 C 4518 C----- INTERVAL = 4 ----- T = 187.5 4519 C 4520 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4521 C DATA (GA( 1,15,IC),IC=1,3) / 4522 C S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/ 4523 C DATA (GB( 1,15,IC),IC=1,3) / 4524 C S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/ 4525 C DATA (GA( 1,16,IC),IC=1,3) / 4526 C S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/ 4527 C DATA (GB( 1,16,IC),IC=1,3) / 4528 C S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/ 4529 C 4530 C----- INTERVAL = 4 ----- T = 200.0 4531 C 4532 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4533 C DATA (GA( 2,15,IC),IC=1,3) / 4534 C S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/ 4535 C DATA (GB( 2,15,IC),IC=1,3) / 4536 C S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/ 4537 C DATA (GA( 2,16,IC),IC=1,3) / 4538 C S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/ 4539 C DATA (GB( 2,16,IC),IC=1,3) / 4540 C S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/ 4541 C 4542 C----- INTERVAL = 4 ----- T = 212.5 4543 C 4544 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4545 C DATA (GA( 3,15,IC),IC=1,3) / 4546 C S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/ 4547 C DATA (GB( 3,15,IC),IC=1,3) / 4548 C S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/ 4549 C DATA (GA( 3,16,IC),IC=1,3) / 4550 C S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/ 4551 C DATA (GB( 3,16,IC),IC=1,3) / 4552 C S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/ 4553 C 4554 C----- INTERVAL = 4 ----- T = 225.0 4555 C 4556 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4557 C DATA (GA( 4,15,IC),IC=1,3) / 4558 C S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/ 4559 C DATA (GB( 4,15,IC),IC=1,3) / 4560 C S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/ 4561 C DATA (GA( 4,16,IC),IC=1,3) / 4562 C S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/ 4563 C DATA (GB( 4,16,IC),IC=1,3) / 4564 C S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/ 4565 C 4566 C----- INTERVAL = 4 ----- T = 237.5 4567 C 4568 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4569 C DATA (GA( 5,15,IC),IC=1,3) / 4570 C S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/ 4571 C DATA (GB( 5,15,IC),IC=1,3) / 4572 C S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/ 4573 C DATA (GA( 5,16,IC),IC=1,3) / 4574 C S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/ 4575 C DATA (GB( 5,16,IC),IC=1,3) / 4576 C S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/ 4577 C 4578 C----- INTERVAL = 4 ----- T = 250.0 4579 C 4580 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4581 C DATA (GA( 6,15,IC),IC=1,3) / 4582 C S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/ 4583 C DATA (GB( 6,15,IC),IC=1,3) / 4584 C S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/ 4585 C DATA (GA( 6,16,IC),IC=1,3) / 4586 C S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/ 4587 C DATA (GB( 6,16,IC),IC=1,3) / 4588 C S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/ 4589 C 4590 C----- INTERVAL = 4 ----- T = 262.5 4591 C 4592 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4593 C DATA (GA( 7,15,IC),IC=1,3) / 4594 C S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/ 4595 C DATA (GB( 7,15,IC),IC=1,3) / 4596 C S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/ 4597 C DATA (GA( 7,16,IC),IC=1,3) / 4598 C S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/ 4599 C DATA (GB( 7,16,IC),IC=1,3) / 4600 C S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/ 4601 C 4602 C----- INTERVAL = 4 ----- T = 275.0 4603 C 4604 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4605 C DATA (GA( 8,15,IC),IC=1,3) / 4606 C S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/ 4607 C DATA (GB( 8,15,IC),IC=1,3) / 4608 C S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/ 4609 C DATA (GA( 8,16,IC),IC=1,3) / 4610 C S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/ 4611 C DATA (GB( 8,16,IC),IC=1,3) / 4612 C S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/ 4613 C 4614 C----- INTERVAL = 4 ----- T = 287.5 4615 C 4616 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4617 C DATA (GA( 9,15,IC),IC=1,3) / 4618 C S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/ 4619 C DATA (GB( 9,15,IC),IC=1,3) / 4620 C S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/ 4621 C DATA (GA( 9,16,IC),IC=1,3) / 4622 C S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/ 4623 C DATA (GB( 9,16,IC),IC=1,3) / 4624 C S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/ 4625 C 4626 C----- INTERVAL = 4 ----- T = 300.0 4627 C 4628 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4629 C DATA (GA(10,15,IC),IC=1,3) / 4630 C S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/ 4631 C DATA (GB(10,15,IC),IC=1,3) / 4632 C S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/ 4633 C DATA (GA(10,16,IC),IC=1,3) / 4634 C S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/ 4635 C DATA (GB(10,16,IC),IC=1,3) / 4636 C S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/ 4637 C 4638 C----- INTERVAL = 4 ----- T = 312.5 4639 C 4640 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45 4641 C DATA (GA(11,15,IC),IC=1,3) / 4642 C S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/ 4643 C DATA (GB(11,15,IC),IC=1,3) / 4644 C S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/ 4645 C DATA (GA(11,16,IC),IC=1,3) / 4646 C S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/ 4647 C DATA (GB(11,16,IC),IC=1,3) / 4648 C S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/ 4649 C 4650 C ------------------------------------------------------------------ 4651 C DATA (( XP( J,K),J=1,6), K=1,6) / 4652 C S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03, 4653 C S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03, 4654 C S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03, 4655 C S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02, 4656 C S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03, 4657 C S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02, 4658 C S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03, 4659 C S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02, 4660 C S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02, 4661 C S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01, 4662 C S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03, 4663 C S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 / 4664 4665 C 4666 C 4667 C* 1.0 PLANCK FUNCTIONS AND GRADIENTS 4668 C ------------------------------ 4669 C 4670 100 CONTINUE 4671 C 4672 !cdir collapse 4673 DO 102 JK = 1 , KFLEV+1 4674 DO 101 JL = 1, KDLON 4675 PBINT(JL,JK) = 0. 4676 101 CONTINUE 4677 102 CONTINUE 4678 DO 103 JL = 1, KDLON 4679 PBSUIN(JL) = 0. 4680 103 CONTINUE 4681 C 4682 DO 141 JNU=1,Ninter 4683 C 4684 C 4685 C* 1.1 LEVELS FROM SURFACE TO KFLEV 4686 C ---------------------------- 4687 C 4688 110 CONTINUE 4689 C 4690 DO 112 JK = 1 , KFLEV 4691 DO 111 JL = 1, KDLON 4692 ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND 4693 ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) 4694 S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) 4695 S ))))) 4696 PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL) 4697 PB(JL,JNU,JK)= ZRES(JL) 4698 ZBLEV(JL,JK) = ZRES(JL) 4699 ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND 4700 ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) 4701 S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) 4702 S ))))) 4703 ZBLAY(JL,JK) = ZRES2(JL) 4704 111 CONTINUE 4705 112 CONTINUE 4706 C 4707 C 4708 C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE 4709 C --------------------------------- 4710 C 4711 120 CONTINUE 4712 C 4713 DO 121 JL = 1, KDLON 4714 ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND 4715 ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND 4716 ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU) 4717 S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU) 4718 S ))))) 4719 ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU) 4720 S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU) 4721 S ))))) 4722 PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL) 4723 PB(JL,JNU,KFLEV+1)= ZRES(JL) 4724 ZBLEV(JL,KFLEV+1) = ZRES(JL) 4725 PBTOP(JL,JNU) = ZRES(JL) 4726 PBSUR(JL,JNU) = ZRES2(JL) 4727 PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL) 4728 121 CONTINUE 4729 C 4730 C 4731 C* 1.3 GRADIENTS IN SUB-LAYERS 4732 C ----------------------- 4733 C 4734 130 CONTINUE 4735 C 4736 DO 132 JK = 1 , KFLEV 4737 JK2 = 2 * JK 4738 JK1 = JK2 - 1 4739 DO 131 JL = 1, KDLON 4740 PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK) 4741 PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK) 4742 131 CONTINUE 4743 132 CONTINUE 4744 C 4745 141 CONTINUE 4746 C 4747 C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS 4748 C --------------------------------------------- 4749 C 4750 200 CONTINUE 4751 C 4752 C 4753 210 CONTINUE 4754 C 4755 DO 211 JL=1, KDLON 4756 ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP 4757 IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) ) 4758 ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP 4759 IF (ZDSTOX.LT.0.5) THEN 4760 INDTO=IXTOX 4761 ELSE 4762 INDTO=IXTOX+1 4763 END IF 4764 INDB(JL)=INDTO 4765 ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP 4766 IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) 4767 ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP 4768 IF (ZDSTX.LT.0.5) THEN 4769 INDT=IXTX 4770 ELSE 4771 INDT=IXTX+1 4772 END IF 4773 INDS(JL)=INDT 4774 211 CONTINUE 4775 C 4776 DO 214 JF=1,2 4777 DO 213 JG=1, 8 4778 DO 212 JL=1, KDLON 4779 INDSU=INDS(JL) 4780 PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF) 4781 PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF) 4782 INDTP=INDB(JL) 4783 PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF) 4784 PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF) 4785 212 CONTINUE 4786 213 CONTINUE 4787 214 CONTINUE 4788 C 4789 220 CONTINUE 4790 C 4791 DO 225 JK=1,KFLEV 4792 DO 221 JL=1, KDLON 4793 ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP 4794 IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) ) 4795 ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP 4796 IF (ZDSTX.LT.0.5) THEN 4797 INDT=IXTX 4798 ELSE 4799 INDT=IXTX+1 4800 END IF 4801 INDB(JL)=INDT 4802 221 CONTINUE 4803 C 4804 DO 224 JF=1,2 4805 DO 223 JG=1, 8 4806 DO 222 JL=1, KDLON 4807 INDT=INDB(JL) 4808 PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF) 4809 PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF) 4810 222 CONTINUE 4811 223 CONTINUE 4812 224 CONTINUE 4813 225 CONTINUE 4814 C 4815 C ------------------------------------------------------------------ 4816 C 4817 RETURN 4818 END 4819 SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM 4820 R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE 4821 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP 4822 S , PCNTRB,PCTS,PFLUC) 4823 USE dimphy 4824 IMPLICIT none 4825 cym#include "dimensions.h" 4826 cym#include "dimphy.h" 4827 cym#include "raddim.h" 4828 #include "raddimlw.h" 4829 #include "YOMCST.h" 4830 C 4831 C----------------------------------------------------------------------- 4832 C PURPOSE. 4833 C -------- 4834 C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE 4835 C FLUXES OR RADIANCES 4836 C 4837 C METHOD. 4838 C ------- 4839 C 4840 C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN 4841 C CONTRIBUTIONS BY - THE NEARBY LAYERS 4842 C - THE DISTANT LAYERS 4843 C - THE BOUNDARY TERMS 4844 C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. 4845 C 4846 C REFERENCE. 4847 C ---------- 4848 C 4849 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 4850 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 4851 C 4852 C AUTHOR. 4853 C ------- 4854 C JEAN-JACQUES MORCRETTE *ECMWF* 4855 C 4856 C MODIFICATIONS. 4857 C -------------- 4858 C ORIGINAL : 89-07-14 4859 C----------------------------------------------------------------------- 4860 C 4861 C* ARGUMENTS: 4862 INTEGER KUAER,KTRAER, KLIM 4863 C 4864 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS 4865 REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS 4866 REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS 4867 REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION 4868 REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION 4869 REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION 4870 REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 4871 REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY 4872 REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB) 4873 REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE 4874 REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 4875 REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 4876 REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS 4877 REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS 4878 REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS 4879 REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS 4880 C 4881 REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX 4882 REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM 4883 REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES 4884 C----------------------------------------------------------------------- 4885 C LOCAL VARIABLES: 4886 REAL(KIND=8) ZADJD(KDLON,KFLEV+1) 4887 REAL(KIND=8) ZADJU(KDLON,KFLEV+1) 4888 REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV) 4889 REAL(KIND=8) ZDISD(KDLON,KFLEV+1) 4890 REAL(KIND=8) ZDISU(KDLON,KFLEV+1) 4891 C 4892 INTEGER jk, jl 4893 C----------------------------------------------------------------------- 4894 C 4895 DO 112 JK=1,KFLEV+1 4896 DO 111 JL=1, KDLON 4897 ZADJD(JL,JK)=0. 4898 ZADJU(JL,JK)=0. 4899 ZDISD(JL,JK)=0. 4900 ZDISU(JL,JK)=0. 4901 111 CONTINUE 4902 112 CONTINUE 4903 C 4904 DO 114 JK=1,KFLEV 4905 DO 113 JL=1, KDLON 4906 PCTS(JL,JK)=0. 4907 113 CONTINUE 4908 114 CONTINUE 4909 C 4910 C* CONTRIBUTION FROM ADJACENT LAYERS 4911 C 4912 CALL LWVN_LMDAR4(KUAER,KTRAER 4913 R , PABCU,PDBSL,PGA,PGB 4914 S , ZADJD,ZADJU,PCNTRB,ZDBDT) 4915 C* CONTRIBUTION FROM DISTANT LAYERS 4916 C 4917 CALL LWVD_LMDAR4(KUAER,KTRAER 4918 R , PABCU,ZDBDT,PGA,PGB 4919 S , PCNTRB,ZDISD,ZDISU) 4920 C 4921 C* EXCHANGE WITH THE BOUNDARIES 4922 C 4923 CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM 4924 R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP 4925 R , ZDISD,ZDISU,PEMIS,PPMB 4926 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP 4927 S , PCTS,PFLUC) 4928 C 4929 C 4930 RETURN 4931 END 4932 SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM 4933 R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP 4934 R , PDISD,PDISU,PEMIS,PPMB 4935 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP 4936 S , PCTS,PFLUC) 4937 USE dimphy 4938 IMPLICIT none 4939 cym#include "dimensions.h" 4940 cym#include "dimphy.h" 4941 cym#include "raddim.h" 4942 #include "raddimlw.h" 4943 #include "radopt.h" 4944 C 4945 C----------------------------------------------------------------------- 4946 C PURPOSE. 4947 C -------- 4948 C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL 4949 C INTEGRATION 4950 C 4951 C METHOD. 4952 C ------- 4953 C 4954 C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE 4955 C ATMOSPHERE 4956 C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND 4957 C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA 4958 C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES 4959 C 4960 C REFERENCE. 4961 C ---------- 4962 C 4963 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 4964 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 4965 C 4966 C AUTHOR. 4967 C ------- 4968 C JEAN-JACQUES MORCRETTE *ECMWF* 4969 C 4970 C MODIFICATIONS. 4971 C -------------- 4972 C ORIGINAL : 89-07-14 4973 C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96 4974 C----------------------------------------------------------------------- 4975 C 4976 C* 0.1 ARGUMENTS 4977 C --------- 4978 C 4979 INTEGER KUAER,KTRAER, KLIM 4980 C 4981 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS 4982 REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS 4983 REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS 4984 REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS 4985 REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS 4986 REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION 4987 REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION 4988 REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION 4989 REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS 4990 REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS 4991 REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY 4992 REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB 4993 REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 4994 REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 4995 REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS 4996 REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS 4997 REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS 4998 REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS 4999 C 5000 REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES 5001 REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM 5002 C 5003 C* LOCAL VARIABLES: 5004 C 5005 REAL(KIND=8) ZBGND(KDLON) 5006 REAL(KIND=8) ZFD(KDLON) 5007 REAL(KIND=8) ZFN10(KDLON) 5008 REAL(KIND=8) ZFU(KDLON) 5009 REAL(KIND=8) ZTT(KDLON,NTRA) 5010 REAL(KIND=8) ZTT1(KDLON,NTRA) 5011 REAL(KIND=8) ZTT2(KDLON,NTRA) 5012 REAL(KIND=8) ZUU(KDLON,NUA) 5013 REAL(KIND=8) ZCNSOL(KDLON) 5014 REAL(KIND=8) ZCNTOP(KDLON) 5015 C 5016 INTEGER jk, jl, ja 5017 INTEGER jstra, jstru 5018 INTEGER ind1, ind2, ind3, ind4, in, jlim 5019 REAL(KIND=8) zctstr 5020 C----------------------------------------------------------------------- 5021 C 5022 C* 1. INITIALIZATION 5023 C -------------- 5024 C 5025 100 CONTINUE 5026 C 5027 C 5028 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS 5029 C --------------------------------- 5030 C 5031 120 CONTINUE 5032 C 5033 DO 122 JA=1,NTRA 5034 DO 121 JL=1, KDLON 5035 ZTT (JL,JA)=1.0 5036 ZTT1(JL,JA)=1.0 5037 ZTT2(JL,JA)=1.0 5038 121 CONTINUE 5039 122 CONTINUE 5040 C 5041 DO 124 JA=1,NUA 5042 DO 123 JL=1, KDLON 5043 ZUU(JL,JA)=1.0 5044 123 CONTINUE 5045 124 CONTINUE 5046 C 5047 C ------------------------------------------------------------------ 5048 C 5049 C* 2. VERTICAL INTEGRATION 5050 C -------------------- 5051 C 5052 200 CONTINUE 5053 C 5054 IND1=0 5055 IND3=0 5056 IND4=1 5057 IND2=1 5058 C 5059 C 5060 C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE 5061 C ----------------------------------- 5062 C 5063 230 CONTINUE 5064 C 5065 DO 235 JK = 1 , KFLEV 5066 IN=(JK-1)*NG1P1+1 5067 C 5068 DO 232 JA=1,KUAER 5069 DO 231 JL=1, KDLON 5070 ZUU(JL,JA)=PABCU(JL,JA,IN) 5071 231 CONTINUE 5072 232 CONTINUE 5073 C 5074 C 5075 CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT) 5076 C 5077 DO 234 JL = 1, KDLON 5078 ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10) 5079 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5080 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5081 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5082 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14) 5083 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15) 5084 ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) 5085 PFLUC(JL,2,JK)=ZFD(JL) 5086 234 CONTINUE 5087 C 5088 235 CONTINUE 5089 C 5090 JK = KFLEV+1 5091 IN=(JK-1)*NG1P1+1 5092 C 5093 DO 236 JL = 1, KDLON 5094 ZCNTOP(JL)= PBTOP(JL,1) 5095 1 + PBTOP(JL,2) 5096 2 + PBTOP(JL,3) 5097 3 + PBTOP(JL,4) 5098 4 + PBTOP(JL,5) 5099 5 + PBTOP(JL,6) 5100 ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK) 5101 PFLUC(JL,2,JK)=ZFD(JL) 5102 236 CONTINUE 5103 C 5104 C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA 5105 C --------------------------------------- 5106 C 5107 240 CONTINUE 5108 C 5109 C 5110 C* 2.4.1 INITIALIZATION 5111 C -------------- 5112 C 5113 2410 CONTINUE 5114 C 5115 JLIM = KFLEV 5116 C 5117 IF (.NOT.LEVOIGT) THEN 5118 DO 2412 JK = KFLEV,1,-1 5119 IF(PPMB(1,JK).LT.10.0) THEN 5120 JLIM=JK 5121 ENDIF 5122 2412 CONTINUE 5123 ENDIF 5124 KLIM=JLIM 5125 C 5126 IF (.NOT.LEVOIGT) THEN 5127 DO 2414 JA=1,KTRAER 5128 DO 2413 JL=1, KDLON 5129 ZTT1(JL,JA)=1.0 5130 2413 CONTINUE 5131 2414 CONTINUE 5132 C 5133 C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA 5134 C ----------------------------- 5135 C 5136 2420 CONTINUE 5137 C 5138 DO 2427 JSTRA = KFLEV,JLIM,-1 5139 JSTRU=(JSTRA-1)*NG1P1+1 5140 C 5141 DO 2423 JA=1,KUAER 5142 DO 2422 JL=1, KDLON 5143 ZUU(JL,JA)=PABCU(JL,JA,JSTRU) 5144 2422 CONTINUE 5145 2423 CONTINUE 5146 C 5147 C 5148 CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT) 5149 C 5150 DO 2424 JL = 1, KDLON 5151 ZCTSTR = 5152 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1)) 5153 1 *(ZTT1(JL,1) *ZTT1(JL,10) 5154 1 - ZTT (JL,1) *ZTT (JL,10)) 5155 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1)) 5156 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11) 5157 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11)) 5158 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1)) 5159 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12) 5160 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12)) 5161 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1)) 5162 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13) 5163 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13)) 5164 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1)) 5165 5 *(ZTT1(JL,3) *ZTT1(JL,14) 5166 5 - ZTT (JL,3) *ZTT (JL,14)) 5167 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1)) 5168 6 *(ZTT1(JL,6) *ZTT1(JL,15) 5169 6 - ZTT (JL,6) *ZTT (JL,15)) 5170 PCTS(JL,JSTRA)=ZCTSTR*0.5 5171 2424 CONTINUE 5172 DO 2426 JA=1,KTRAER 5173 DO 2425 JL=1, KDLON 5174 ZTT1(JL,JA)=ZTT(JL,JA) 5175 2425 CONTINUE 5176 2426 CONTINUE 5177 2427 CONTINUE 5178 ENDIF 5179 C Mise a zero de securite pour PCTS en cas de LEVOIGT 5180 IF(LEVOIGT)THEN 5181 DO 2429 JSTRA = 1,KFLEV 5182 DO 2428 JL = 1, KDLON 5183 PCTS(JL,JSTRA)=0. 5184 2428 CONTINUE 5185 2429 CONTINUE 5186 ENDIF 5187 C 5188 C 5189 C* 2.5 EXCHANGE WITH LOWER LIMIT 5190 C ------------------------- 5191 C 5192 250 CONTINUE 5193 C 5194 DO 251 JL = 1, KDLON 5195 ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL)) 5196 S *PFLUC(JL,2,1)-PBINT(JL,1) 5197 251 CONTINUE 5198 C 5199 JK = 1 5200 IN=(JK-1)*NG1P1+1 5201 C 5202 DO 252 JL = 1, KDLON 5203 ZCNSOL(JL)=PBSUR(JL,1) 5204 1 +PBSUR(JL,2) 5205 2 +PBSUR(JL,3) 5206 3 +PBSUR(JL,4) 5207 4 +PBSUR(JL,5) 5208 5 +PBSUR(JL,6) 5209 ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) 5210 ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) 5211 PFLUC(JL,1,JK)=ZFU(JL) 5212 252 CONTINUE 5213 C 5214 DO 257 JK = 2 , KFLEV+1 5215 IN=(JK-1)*NG1P1+1 5216 C 5217 C 5218 DO 255 JA=1,KUAER 5219 DO 254 JL=1, KDLON 5220 ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN) 5221 254 CONTINUE 5222 255 CONTINUE 5223 C 5224 C 5225 CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT) 5226 C 5227 DO 256 JL = 1, KDLON 5228 ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10) 5229 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5230 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5231 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5232 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14) 5233 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15) 5234 ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL) 5235 ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK) 5236 PFLUC(JL,1,JK)=ZFU(JL) 5237 256 CONTINUE 5238 C 5239 C 5240 257 CONTINUE 5241 C 5242 C 5243 C 5244 C* 2.7 CLEAR-SKY FLUXES 5245 C ---------------- 5246 C 5247 270 CONTINUE 5248 C 5249 IF (.NOT.LEVOIGT) THEN 5250 DO 271 JL = 1, KDLON 5251 ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM) 5252 271 CONTINUE 5253 DO 273 JK = JLIM+1,KFLEV+1 5254 DO 272 JL = 1, KDLON 5255 ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1) 5256 PFLUC(JL,1,JK) = ZFN10(JL) 5257 PFLUC(JL,2,JK) = 0. 5258 272 CONTINUE 5259 273 CONTINUE 5260 ENDIF 5261 C 5262 C ------------------------------------------------------------------ 5263 C 5264 RETURN 5265 END 5266 SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER 5267 S , PABCU,PDBDT 5268 R , PGA,PGB 5269 S , PCNTRB,PDISD,PDISU) 5270 USE dimphy 5271 IMPLICIT none 5272 cym#include "dimensions.h" 5273 cym#include "dimphy.h" 5274 cym#include "raddim.h" 5275 #include "raddimlw.h" 5276 C 5277 C----------------------------------------------------------------------- 5278 C PURPOSE. 5279 C -------- 5280 C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS 5281 C 5282 C METHOD. 5283 C ------- 5284 C 5285 C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE 5286 C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE 5287 C 5288 C REFERENCE. 5289 C ---------- 5290 C 5291 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5292 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5293 C 5294 C AUTHOR. 5295 C ------- 5296 C JEAN-JACQUES MORCRETTE *ECMWF* 5297 C 5298 C MODIFICATIONS. 5299 C -------------- 5300 C ORIGINAL : 89-07-14 5301 C----------------------------------------------------------------------- 5302 C* ARGUMENTS: 5303 C 5304 INTEGER KUAER,KTRAER 5305 C 5306 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS 5307 REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT 5308 REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 5309 REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 5310 C 5311 REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX 5312 REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS 5313 REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS 5314 C 5315 C* LOCAL VARIABLES: 5316 C 5317 REAL(KIND=8) ZGLAYD(KDLON) 5318 REAL(KIND=8) ZGLAYU(KDLON) 5319 REAL(KIND=8) ZTT(KDLON,NTRA) 5320 REAL(KIND=8) ZTT1(KDLON,NTRA) 5321 REAL(KIND=8) ZTT2(KDLON,NTRA) 5322 C 5323 INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2 5324 INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2 5325 INTEGER ind1, ind2, ind3, ind4, itt 5326 REAL(KIND=8) zww, zdzxdg, zdzxmg 5327 C 5328 C* 1. INITIALIZATION 5329 C -------------- 5330 C 5331 100 CONTINUE 5332 C 5333 C* 1.1 INITIALIZE LAYER CONTRIBUTIONS 5334 C ------------------------------ 5335 C 5336 110 CONTINUE 5337 C 5338 DO 112 JK = 1, KFLEV+1 5339 DO 111 JL = 1, KDLON 5340 PDISD(JL,JK) = 0. 5341 PDISU(JL,JK) = 0. 5342 111 CONTINUE 5343 112 CONTINUE 5344 C 5345 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS 5346 C --------------------------------- 5347 C 5348 120 CONTINUE 5349 C 5350 C 5351 DO 122 JA = 1, NTRA 5352 DO 121 JL = 1, KDLON 5353 ZTT (JL,JA) = 1.0 5354 ZTT1(JL,JA) = 1.0 5355 ZTT2(JL,JA) = 1.0 5356 121 CONTINUE 5357 122 CONTINUE 5358 C 5359 C ------------------------------------------------------------------ 5360 C 5361 C* 2. VERTICAL INTEGRATION 5362 C -------------------- 5363 C 5364 200 CONTINUE 5365 C 5366 IND1=0 5367 IND3=0 5368 IND4=1 5369 IND2=1 5370 C 5371 C 5372 C* 2.2 CONTRIBUTION FROM DISTANT LAYERS 5373 C --------------------------------- 5374 C 5375 220 CONTINUE 5376 C 5377 C 5378 C* 2.2.1 DISTANT AND ABOVE LAYERS 5379 C ------------------------ 5380 C 5381 2210 CONTINUE 5382 C 5383 C 5384 C 5385 C* 2.2.2 FIRST UPPER LEVEL 5386 C ----------------- 5387 C 5388 2220 CONTINUE 5389 C 5390 DO 225 JK = 1 , KFLEV-1 5391 IKP1=JK+1 5392 IKN=(JK-1)*NG1P1+1 5393 IKD1= JK *NG1P1+1 5394 C 5395 CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK) 5396 2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1) 5397 C 5398 C 5399 C 5400 C* 2.2.3 HIGHER UP 5401 C --------- 5402 C 5403 2230 CONTINUE 5404 C 5405 ITT=1 5406 DO 224 JKJ=IKP1,KFLEV 5407 IF(ITT.EQ.1) THEN 5408 ITT=2 5409 ELSE 5410 ITT=1 5411 ENDIF 5412 IKJP1=JKJ+1 5413 IKD2= JKJ *NG1P1+1 5414 C 5415 IF(ITT.EQ.1) THEN 5416 CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) 5417 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1) 5418 ELSE 5419 CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ) 5420 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2) 5421 ENDIF 5422 C 5423 DO 2235 JA = 1, KTRAER 5424 DO 2234 JL = 1, KDLON 5425 ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 5426 2234 CONTINUE 5427 2235 CONTINUE 5428 C 5429 DO 2236 JL = 1, KDLON 5430 ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) 5431 S +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5432 S +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5433 S +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5434 S +PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) 5435 S +PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) 5436 ZGLAYD(JL)=ZWW 5437 ZDZXDG=ZGLAYD(JL) 5438 PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG 5439 PCNTRB(JL,JK,IKJP1)=ZDZXDG 5440 2236 CONTINUE 5441 C 5442 C 5443 224 CONTINUE 5444 225 CONTINUE 5445 C 5446 C 5447 C* 2.2.4 DISTANT AND BELOW LAYERS 5448 C ------------------------ 5449 C 5450 2240 CONTINUE 5451 C 5452 C 5453 C 5454 C* 2.2.5 FIRST LOWER LEVEL 5455 C ----------------- 5456 C 5457 2250 CONTINUE 5458 C 5459 DO 228 JK=3,KFLEV+1 5460 IKN=(JK-1)*NG1P1+1 5461 IKM1=JK-1 5462 IKJ=JK-2 5463 IKU1= IKJ *NG1P1+1 5464 C 5465 C 5466 CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ) 5467 2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1) 5468 C 5469 C 5470 C 5471 C* 2.2.6 DOWN BELOW 5472 C ---------- 5473 C 5474 2260 CONTINUE 5475 C 5476 ITT=1 5477 DO 227 JLK=1,IKJ 5478 IF(ITT.EQ.1) THEN 5479 ITT=2 5480 ELSE 5481 ITT=1 5482 ENDIF 5483 IJKL=IKM1-JLK 5484 IKU2=(IJKL-1)*NG1P1+1 5485 C 5486 C 5487 IF(ITT.EQ.1) THEN 5488 CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) 5489 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1) 5490 ELSE 5491 CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL) 5492 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2) 5493 ENDIF 5494 C 5495 DO 2265 JA = 1, KTRAER 5496 DO 2264 JL = 1, KDLON 5497 ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5 5498 2264 CONTINUE 5499 2265 CONTINUE 5500 C 5501 DO 2266 JL = 1, KDLON 5502 ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10) 5503 S +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5504 S +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5505 S +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5506 S +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14) 5507 S +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) 5508 ZGLAYU(JL)=ZWW 5509 ZDZXMG=ZGLAYU(JL) 5510 PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG 5511 PCNTRB(JL,JK,IJKL)=ZDZXMG 5512 2266 CONTINUE 5513 C 5514 C 5515 227 CONTINUE 5516 228 CONTINUE 5517 C 5518 RETURN 5519 END 5520 SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER 5521 R , PABCU,PDBSL,PGA,PGB 5522 S , PADJD,PADJU,PCNTRB,PDBDT) 5523 USE dimphy 5524 USE radiation_AR4_param, only : WG1 5525 IMPLICIT none 5526 cym#include "dimensions.h" 5527 cym#include "dimphy.h" 5528 cym#include "raddim.h" 5529 #include "raddimlw.h" 5530 C 5531 C----------------------------------------------------------------------- 5532 C PURPOSE. 5533 C -------- 5534 C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS 5535 C TO GIVE LONGWAVE FLUXES OR RADIANCES 5536 C 5537 C METHOD. 5538 C ------- 5539 C 5540 C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE 5541 C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE 5542 C 5543 C REFERENCE. 5544 C ---------- 5545 C 5546 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5547 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5548 C 5549 C AUTHOR. 5550 C ------- 5551 C JEAN-JACQUES MORCRETTE *ECMWF* 5552 C 5553 C MODIFICATIONS. 5554 C -------------- 5555 C ORIGINAL : 89-07-14 5556 C----------------------------------------------------------------------- 5557 C 5558 C* ARGUMENTS: 5559 C 5560 INTEGER KUAER,KTRAER 5561 C 5562 REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS 5563 REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 5564 REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 5565 REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS 5566 C 5567 REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS 5568 REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS 5569 REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX 5570 REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT 5571 C 5572 C* LOCAL ARRAYS: 5573 C 5574 REAL(KIND=8) ZGLAYD(KDLON) 5575 REAL(KIND=8) ZGLAYU(KDLON) 5576 REAL(KIND=8) ZTT(KDLON,NTRA) 5577 REAL(KIND=8) ZTT1(KDLON,NTRA) 5578 REAL(KIND=8) ZTT2(KDLON,NTRA) 5579 REAL(KIND=8) ZUU(KDLON,NUA) 5580 C 5581 INTEGER jk, jl, ja, im12, ind, inu, ixu, jg 5582 INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu 5583 REAL(KIND=8) zwtr 5584 c 5585 5586 C----------------------------------------------------------------------- 5587 C 5588 C* 1. INITIALIZATION 5589 C -------------- 5590 C 5591 100 CONTINUE 5592 C 5593 C* 1.1 INITIALIZE LAYER CONTRIBUTIONS 5594 C ------------------------------ 5595 C 5596 110 CONTINUE 5597 C 5598 DO 112 JK = 1 , KFLEV+1 5599 DO 111 JL = 1, KDLON 5600 PADJD(JL,JK) = 0. 5601 PADJU(JL,JK) = 0. 5602 111 CONTINUE 5603 112 CONTINUE 5604 C 5605 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS 5606 C --------------------------------- 5607 C 5608 120 CONTINUE 5609 C 5610 DO 122 JA = 1 , NTRA 5611 DO 121 JL = 1, KDLON 5612 ZTT (JL,JA) = 1.0 5613 ZTT1(JL,JA) = 1.0 5614 ZTT2(JL,JA) = 1.0 5615 121 CONTINUE 5616 122 CONTINUE 5617 C 5618 DO 124 JA = 1 , NUA 5619 DO 123 JL = 1, KDLON 5620 ZUU(JL,JA) = 0. 5621 123 CONTINUE 5622 124 CONTINUE 5623 C 5624 C ------------------------------------------------------------------ 5625 C 5626 C* 2. VERTICAL INTEGRATION 5627 C -------------------- 5628 C 5629 200 CONTINUE 5630 C 5631 C 5632 C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS 5633 C --------------------------------- 5634 C 5635 210 CONTINUE 5636 C 5637 DO 215 JK = 1 , KFLEV 5638 C 5639 C* 2.1.1 DOWNWARD LAYERS 5640 C --------------- 5641 C 5642 2110 CONTINUE 5643 C 5644 IM12 = 2 * (JK - 1) 5645 IND = (JK - 1) * NG1P1 + 1 5646 IXD = IND 5647 INU = JK * NG1P1 + 1 5648 IXU = IND 5649 C 5650 DO 2111 JL = 1, KDLON 5651 ZGLAYD(JL) = 0. 5652 ZGLAYU(JL) = 0. 5653 2111 CONTINUE 5654 C 5655 DO 213 JG = 1 , NG1 5656 IBS = IM12 + JG 5657 IDD = IXD + JG 5658 DO 2113 JA = 1 , KUAER 5659 DO 2112 JL = 1, KDLON 5660 ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD) 5661 2112 CONTINUE 5662 2113 CONTINUE 5663 C 5664 C 5665 CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) 5666 C 5667 DO 2114 JL = 1, KDLON 5668 ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) 5669 S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5670 S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5671 S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5672 S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) 5673 S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) 5674 ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG) 5675 2114 CONTINUE 5676 C 5677 C* 2.1.2 DOWNWARD LAYERS 5678 C --------------- 5679 C 5680 2120 CONTINUE 5681 C 5682 IMU = IXU + JG 5683 DO 2122 JA = 1 , KUAER 5684 DO 2121 JL = 1, KDLON 5685 ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU) 5686 2121 CONTINUE 5687 2122 CONTINUE 5688 C 5689 C 5690 CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT) 5691 C 5692 DO 2123 JL = 1, KDLON 5693 ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10) 5694 S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) 5695 S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) 5696 S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) 5697 S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14) 5698 S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15) 5699 ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG) 5700 2123 CONTINUE 5701 C 5702 213 CONTINUE 5703 C 5704 DO 214 JL = 1, KDLON 5705 PADJD(JL,JK) = ZGLAYD(JL) 5706 PCNTRB(JL,JK,JK+1) = ZGLAYD(JL) 5707 PADJU(JL,JK+1) = ZGLAYU(JL) 5708 PCNTRB(JL,JK+1,JK) = ZGLAYU(JL) 5709 PCNTRB(JL,JK ,JK) = 0.0 5710 214 CONTINUE 5711 C 5712 215 CONTINUE 5713 C 5714 DO 218 JK = 1 , KFLEV 5715 JK2 = 2 * JK 5716 JK1 = JK2 - 1 5717 DO 217 JNU = 1 , Ninter 5718 DO 216 JL = 1, KDLON 5719 PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2) 5720 216 CONTINUE 5721 217 CONTINUE 5722 218 CONTINUE 5723 C 5724 RETURN 5725 C 5726 END 5727 SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT) 5728 USE dimphy 5729 IMPLICIT none 5730 cym#include "dimensions.h" 5731 cym#include "dimphy.h" 5732 cym#include "raddim.h" 5733 #include "raddimlw.h" 5734 C 5735 C----------------------------------------------------------------------- 5736 C PURPOSE. 5737 C -------- 5738 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 5739 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL 5740 C INTERVALS. 5741 C 5742 C METHOD. 5743 C ------- 5744 C 5745 C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE 5746 C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. 5747 C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. 5748 C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN 5749 C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. 5750 C 5751 C REFERENCE. 5752 C ---------- 5753 C 5754 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5755 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5756 C 5757 C AUTHOR. 5758 C ------- 5759 C JEAN-JACQUES MORCRETTE *ECMWF* 5760 C 5761 C MODIFICATIONS. 5762 C -------------- 5763 C ORIGINAL : 88-12-15 5764 C 5765 C----------------------------------------------------------------------- 5766 REAL(KIND=8) O1H, O2H 5767 PARAMETER (O1H=2230.) 5768 PARAMETER (O2H=100.) 5769 REAL(KIND=8) RPIALF0 5770 PARAMETER (RPIALF0=2.0) 5771 C 5772 C* ARGUMENTS: 5773 C 5774 REAL(KIND=8) PUU(KDLON,NUA) 5775 REAL(KIND=8) PTT(KDLON,NTRA) 5776 REAL(KIND=8) PGA(KDLON,8,2) 5777 REAL(KIND=8) PGB(KDLON,8,2) 5778 C 5779 C* LOCAL VARIABLES: 5780 C 5781 REAL(KIND=8) zz, zxd, zxn 5782 REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 5783 REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 5784 REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy 5785 REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o 5786 REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42 5787 REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 5788 REAL(KIND=8) zuu11, zuu12, za11, za12 5789 INTEGER jl, ja 5790 C ------------------------------------------------------------------ 5791 C 5792 C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION 5793 C ----------------------------------------------- 5794 C 5795 100 CONTINUE 5796 C 5797 C 5798 !cdir collapse 5799 DO 130 JA = 1 , 8 5800 DO 120 JL = 1, KDLON 5801 ZZ =SQRT(PUU(JL,JA)) 5802 c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1)) 5803 c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) ) 5804 c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1) 5805 ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) 5806 ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) 5807 PTT(JL,JA)=ZXN /ZXD 5808 120 CONTINUE 5809 130 CONTINUE 5810 C 5811 C ------------------------------------------------------------------ 5812 C 5813 C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS 5814 C --------------------------------------------------- 5815 C 5816 200 CONTINUE 5817 C 5818 DO 201 JL = 1, KDLON 5819 PTT(JL, 9) = PTT(JL, 8) 5820 C 5821 C- CONTINUUM ABSORPTION: E- AND P-TYPE 5822 C 5823 ZPU = 0.002 * PUU(JL,10) 5824 ZPU10 = 112. * ZPU 5825 ZPU11 = 6.25 * ZPU 5826 ZPU12 = 5.00 * ZPU 5827 ZPU13 = 80.0 * ZPU 5828 ZEU = PUU(JL,11) 5829 ZEU10 = 12. * ZEU 5830 ZEU11 = 6.25 * ZEU 5831 ZEU12 = 5.00 * ZEU 5832 ZEU13 = 80.0 * ZEU 5833 C 5834 C- OZONE ABSORPTION 5835 C 5836 ZX = PUU(JL,12) 5837 ZY = PUU(JL,13) 5838 ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) 5839 ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. 5840 ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. 5841 ZVXY = RPIALF0 * ZY / (2. * ZX) 5842 ZAERCN = PUU(JL,17) + ZEU12 + ZPU12 5843 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) 5844 ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) 5845 C 5846 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) 5847 C 5848 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 5849 C 5850 c NEXOTIC=1 5851 c IF (NEXOTIC.EQ.1) THEN 5852 ZXCH4 = PUU(JL,19) 5853 ZYCH4 = PUU(JL,20) 5854 ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) 5855 ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. 5856 ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) 5857 ZODH41 = ZVXY * ZSQH41 5858 C 5859 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 5860 C 5861 ZXN2O = PUU(JL,21) 5862 ZYN2O = PUU(JL,22) 5863 ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) 5864 ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. 5865 ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) 5866 ZODN21 = ZVXY * ZSQN21 5867 C 5868 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 5869 C 5870 ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) 5871 ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. 5872 ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) 5873 ZODH42 = ZVXY * ZSQH42 5874 C 5875 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 5876 C 5877 ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) 5878 ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. 5879 ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) 5880 ZODN22 = ZVXY * ZSQN22 5881 C 5882 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 5883 C 5884 ZA11 = 2. * PUU(JL,23) * 4.404E+05 5885 ZTTF11 = 1. - ZA11 * 0.003225 5886 C 5887 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 5888 C 5889 ZA12 = 2. * PUU(JL,24) * 6.7435E+05 5890 ZTTF12 = 1. - ZA12 * 0.003225 5891 C 5892 ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10 5893 ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21 5894 PTT(JL,10) = EXP( - PUU(JL,14) ) 5895 PTT(JL,11) = EXP( ZUU11 ) 5896 PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 5897 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 5898 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) 5899 PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 ) 5900 201 CONTINUE 5901 C 5902 RETURN 5903 END 5904 SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT) 5905 USE dimphy 5906 IMPLICIT none 5907 cym#include "dimensions.h" 5908 cym#include "dimphy.h" 5909 cym#include "raddim.h" 5910 #include "raddimlw.h" 5911 C 5912 C ------------------------------------------------------------------ 5913 C PURPOSE. 5914 C -------- 5915 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 5916 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL 5917 C INTERVALS. 5918 C 5919 C METHOD. 5920 C ------- 5921 C 5922 C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE 5923 C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. 5924 C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. 5925 C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN 5926 C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. 5927 C 5928 C REFERENCE. 5929 C ---------- 5930 C 5931 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5932 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5933 C 5934 C AUTHOR. 5935 C ------- 5936 C JEAN-JACQUES MORCRETTE *ECMWF* 5937 C 5938 C MODIFICATIONS. 5939 C -------------- 5940 C ORIGINAL : 88-12-15 5941 C 5942 C----------------------------------------------------------------------- 5943 REAL(KIND=8) O1H, O2H 5944 PARAMETER (O1H=2230.) 5945 PARAMETER (O2H=100.) 5946 REAL(KIND=8) RPIALF0 5947 PARAMETER (RPIALF0=2.0) 5948 C 5949 C* ARGUMENTS: 5950 C 5951 REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS 5952 REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS 5953 REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 5954 REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 5955 REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS 5956 C 5957 C* LOCAL VARIABLES: 5958 C 5959 INTEGER ja, jl 5960 REAL(KIND=8) zz, zxd, zxn 5961 REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 5962 REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 5963 REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 5964 REAL(KIND=8) zxch4, zych4, zsqh41, zodh41 5965 REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 5966 REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12 5967 REAL(KIND=8) zuu11, zuu12 5968 C ------------------------------------------------------------------ 5969 C 5970 C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION 5971 C ----------------------------------------------- 5972 C 5973 100 CONTINUE 5974 C 5975 C 5976 5977 !CDIR ON_ADB(PUU1) 5978 !CDIR ON_ADB(PUU2) 5979 !CDIR COLLAPSE 5980 DO 130 JA = 1 , 8 5981 DO 120 JL = 1, KDLON 5982 ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA)) 5983 ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ ) 5984 ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) ) 5985 PTT(JL,JA)=ZXN /ZXD 5986 120 CONTINUE 5987 130 CONTINUE 5988 C 5989 C ------------------------------------------------------------------ 5990 C 5991 C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS 5992 C --------------------------------------------------- 5993 C 5994 200 CONTINUE 5995 C 5996 DO 201 JL = 1, KDLON 5997 PTT(JL, 9) = PTT(JL, 8) 5998 C 5999 C- CONTINUUM ABSORPTION: E- AND P-TYPE 6000 C 6001 ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10)) 6002 ZPU10 = 112. * ZPU 6003 ZPU11 = 6.25 * ZPU 6004 ZPU12 = 5.00 * ZPU 6005 ZPU13 = 80.0 * ZPU 6006 ZEU = (PUU1(JL,11) - PUU2(JL,11)) 6007 ZEU10 = 12. * ZEU 6008 ZEU11 = 6.25 * ZEU 6009 ZEU12 = 5.00 * ZEU 6010 ZEU13 = 80.0 * ZEU 6011 C 6012 C- OZONE ABSORPTION 6013 C 6014 ZX = (PUU1(JL,12) - PUU2(JL,12)) 6015 ZY = (PUU1(JL,13) - PUU2(JL,13)) 6016 ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY) 6017 ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1. 6018 ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1. 6019 ZVXY = RPIALF0 * ZY / (2. * ZX) 6020 ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12 6021 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN ) 6022 ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN ) 6023 C 6024 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12) 6025 C 6026 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 6027 C 6028 ZXCH4 = (PUU1(JL,19) - PUU2(JL,19)) 6029 ZYCH4 = (PUU1(JL,20) - PUU2(JL,20)) 6030 ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4) 6031 ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1. 6032 ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4) 6033 ZODH41 = ZVXY * ZSQH41 6034 C 6035 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1 6036 C 6037 ZXN2O = (PUU1(JL,21) - PUU2(JL,21)) 6038 ZYN2O = (PUU1(JL,22) - PUU2(JL,22)) 6039 ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O) 6040 ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1. 6041 ZVXY = 0.416 * ZYN2O / (2. * ZXN2O) 6042 ZODN21 = ZVXY * ZSQN21 6043 C 6044 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 6045 C 6046 ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4) 6047 ZSQH42 = SQRT(1. + 400. * ZUXY) - 1. 6048 ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4) 6049 ZODH42 = ZVXY * ZSQH42 6050 C 6051 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 6052 C 6053 ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O) 6054 ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1. 6055 ZVXY = 0.197 * ZYN2O / (2. * ZXN2O) 6056 ZODN22 = ZVXY * ZSQN22 6057 C 6058 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 6059 C 6060 ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05 6061 ZTTF11 = 1. - ZA11 * 0.003225 6062 C 6063 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 6064 C 6065 ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05 6066 ZTTF12 = 1. - ZA12 * 0.003225 6067 C 6068 ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10 6069 ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 - 6070 S ZODH41 - ZODN21 6071 PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) ) 6072 PTT(JL,11) = EXP( ZUU11 ) 6073 PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12 6074 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2 6075 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 ) 6076 PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 ) 6077 201 CONTINUE 6078 C 6079 RETURN 6080 END 5203 5204 DO ja = 1, ktraer 5205 DO jl = 1, kdlon 5206 ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5 5207 END DO 5208 END DO 5209 5210 DO jl = 1, kdlon 5211 zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + & 5212 pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 5213 pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 5214 pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 5215 pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + & 5216 pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15) 5217 zglayu(jl) = zww 5218 zdzxmg = zglayu(jl) 5219 pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg 5220 pcntrb(jl, jk, ijkl) = zdzxmg 5221 END DO 5222 5223 5224 END DO 5225 END DO 5226 5227 RETURN 5228 END SUBROUTINE lwvd_lmdar4 5229 SUBROUTINE lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, & 5230 pcntrb, pdbdt) 5231 USE dimphy 5232 USE radiation_ar4_param, ONLY: wg1 5233 IMPLICIT NONE 5234 ! ym#include "dimensions.h" 5235 ! ym#include "dimphy.h" 5236 ! ym#include "raddim.h" 5237 include "raddimlw.h" 5238 5239 ! ----------------------------------------------------------------------- 5240 ! PURPOSE. 5241 ! -------- 5242 ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS 5243 ! TO GIVE LONGWAVE FLUXES OR RADIANCES 5244 5245 ! METHOD. 5246 ! ------- 5247 5248 ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE 5249 ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE 5250 5251 ! REFERENCE. 5252 ! ---------- 5253 5254 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5255 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5256 5257 ! AUTHOR. 5258 ! ------- 5259 ! JEAN-JACQUES MORCRETTE *ECMWF* 5260 5261 ! MODIFICATIONS. 5262 ! -------------- 5263 ! ORIGINAL : 89-07-14 5264 ! ----------------------------------------------------------------------- 5265 5266 ! * ARGUMENTS: 5267 5268 INTEGER kuaer, ktraer 5269 5270 REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS 5271 REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT 5272 REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 5273 REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS 5274 5275 REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS 5276 REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS 5277 REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX 5278 REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT 5279 5280 ! * LOCAL ARRAYS: 5281 5282 REAL (KIND=8) zglayd(kdlon) 5283 REAL (KIND=8) zglayu(kdlon) 5284 REAL (KIND=8) ztt(kdlon, ntra) 5285 REAL (KIND=8) ztt1(kdlon, ntra) 5286 REAL (KIND=8) ztt2(kdlon, ntra) 5287 REAL (KIND=8) zuu(kdlon, nua) 5288 5289 INTEGER jk, jl, ja, im12, ind, inu, ixu, jg 5290 INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu 5291 REAL (KIND=8) zwtr 5292 5293 ! ----------------------------------------------------------------------- 5294 5295 ! * 1. INITIALIZATION 5296 ! -------------- 5297 5298 5299 ! * 1.1 INITIALIZE LAYER CONTRIBUTIONS 5300 ! ------------------------------ 5301 5302 5303 DO jk = 1, kflev + 1 5304 DO jl = 1, kdlon 5305 padjd(jl, jk) = 0. 5306 padju(jl, jk) = 0. 5307 END DO 5308 END DO 5309 5310 ! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS 5311 ! --------------------------------- 5312 5313 5314 DO ja = 1, ntra 5315 DO jl = 1, kdlon 5316 ztt(jl, ja) = 1.0 5317 ztt1(jl, ja) = 1.0 5318 ztt2(jl, ja) = 1.0 5319 END DO 5320 END DO 5321 5322 DO ja = 1, nua 5323 DO jl = 1, kdlon 5324 zuu(jl, ja) = 0. 5325 END DO 5326 END DO 5327 5328 ! ------------------------------------------------------------------ 5329 5330 ! * 2. VERTICAL INTEGRATION 5331 ! -------------------- 5332 5333 5334 5335 ! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS 5336 ! --------------------------------- 5337 5338 5339 DO jk = 1, kflev 5340 ! * 2.1.1 DOWNWARD LAYERS 5341 ! --------------- 5342 5343 5344 im12 = 2*(jk-1) 5345 ind = (jk-1)*ng1p1 + 1 5346 ixd = ind 5347 inu = jk*ng1p1 + 1 5348 ixu = ind 5349 5350 DO jl = 1, kdlon 5351 zglayd(jl) = 0. 5352 zglayu(jl) = 0. 5353 END DO 5354 5355 DO jg = 1, ng1 5356 ibs = im12 + jg 5357 idd = ixd + jg 5358 DO ja = 1, kuaer 5359 DO jl = 1, kdlon 5360 zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd) 5361 END DO 5362 END DO 5363 5364 5365 CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt) 5366 5367 DO jl = 1, kdlon 5368 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + & 5369 pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 5370 pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 5371 pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 5372 pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + & 5373 pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15) 5374 zglayd(jl) = zglayd(jl) + zwtr*wg1(jg) 5375 END DO 5376 5377 ! * 2.1.2 DOWNWARD LAYERS 5378 ! --------------- 5379 5380 5381 imu = ixu + jg 5382 DO ja = 1, kuaer 5383 DO jl = 1, kdlon 5384 zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu) 5385 END DO 5386 END DO 5387 5388 5389 CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt) 5390 5391 DO jl = 1, kdlon 5392 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + & 5393 pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + & 5394 pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + & 5395 pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + & 5396 pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + & 5397 pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15) 5398 zglayu(jl) = zglayu(jl) + zwtr*wg1(jg) 5399 END DO 5400 5401 END DO 5402 5403 DO jl = 1, kdlon 5404 padjd(jl, jk) = zglayd(jl) 5405 pcntrb(jl, jk, jk+1) = zglayd(jl) 5406 padju(jl, jk+1) = zglayu(jl) 5407 pcntrb(jl, jk+1, jk) = zglayu(jl) 5408 pcntrb(jl, jk, jk) = 0.0 5409 END DO 5410 5411 END DO 5412 5413 DO jk = 1, kflev 5414 jk2 = 2*jk 5415 jk1 = jk2 - 1 5416 DO jnu = 1, ninter 5417 DO jl = 1, kdlon 5418 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2) 5419 END DO 5420 END DO 5421 END DO 5422 5423 RETURN 5424 5425 END SUBROUTINE lwvn_lmdar4 5426 SUBROUTINE lwtt_lmdar4(pga, pgb, puu, ptt) 5427 USE dimphy 5428 IMPLICIT NONE 5429 ! ym#include "dimensions.h" 5430 ! ym#include "dimphy.h" 5431 ! ym#include "raddim.h" 5432 include "raddimlw.h" 5433 5434 ! ----------------------------------------------------------------------- 5435 ! PURPOSE. 5436 ! -------- 5437 ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 5438 ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL 5439 ! INTERVALS. 5440 5441 ! METHOD. 5442 ! ------- 5443 5444 ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE 5445 ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. 5446 ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. 5447 ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN 5448 ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. 5449 5450 ! REFERENCE. 5451 ! ---------- 5452 5453 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5454 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5455 5456 ! AUTHOR. 5457 ! ------- 5458 ! JEAN-JACQUES MORCRETTE *ECMWF* 5459 5460 ! MODIFICATIONS. 5461 ! -------------- 5462 ! ORIGINAL : 88-12-15 5463 5464 ! ----------------------------------------------------------------------- 5465 REAL (KIND=8) o1h, o2h 5466 PARAMETER (o1h=2230.) 5467 PARAMETER (o2h=100.) 5468 REAL (KIND=8) rpialf0 5469 PARAMETER (rpialf0=2.0) 5470 5471 ! * ARGUMENTS: 5472 5473 REAL (KIND=8) puu(kdlon, nua) 5474 REAL (KIND=8) ptt(kdlon, ntra) 5475 REAL (KIND=8) pga(kdlon, 8, 2) 5476 REAL (KIND=8) pgb(kdlon, 8, 2) 5477 5478 ! * LOCAL VARIABLES: 5479 5480 REAL (KIND=8) zz, zxd, zxn 5481 REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 5482 REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 5483 REAL (KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy 5484 REAL (KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o 5485 REAL (KIND=8) zsqn21, zodn21, zsqh42, zodh42 5486 REAL (KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12 5487 REAL (KIND=8) zuu11, zuu12, za11, za12 5488 INTEGER jl, ja 5489 5490 ! ------------------------------------------------------------------ 5491 5492 ! * 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION 5493 ! ----------------------------------------------- 5494 5495 5496 5497 ! cdir collapse 5498 DO ja = 1, 8 5499 DO jl = 1, kdlon 5500 zz = sqrt(puu(jl,ja)) 5501 ! ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1)) 5502 ! ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) ) 5503 ! PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1) 5504 zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz) 5505 zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2)) 5506 ptt(jl, ja) = zxn/zxd 5507 END DO 5508 END DO 5509 5510 ! ------------------------------------------------------------------ 5511 5512 ! * 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS 5513 ! --------------------------------------------------- 5514 5515 5516 DO jl = 1, kdlon 5517 ptt(jl, 9) = ptt(jl, 8) 5518 5519 ! - CONTINUUM ABSORPTION: E- AND P-TYPE 5520 5521 zpu = 0.002*puu(jl, 10) 5522 zpu10 = 112.*zpu 5523 zpu11 = 6.25*zpu 5524 zpu12 = 5.00*zpu 5525 zpu13 = 80.0*zpu 5526 zeu = puu(jl, 11) 5527 zeu10 = 12.*zeu 5528 zeu11 = 6.25*zeu 5529 zeu12 = 5.00*zeu 5530 zeu13 = 80.0*zeu 5531 5532 ! - OZONE ABSORPTION 5533 5534 zx = puu(jl, 12) 5535 zy = puu(jl, 13) 5536 zuxy = 4.*zx*zx/(rpialf0*zy) 5537 zsq1 = sqrt(1.+o1h*zuxy) - 1. 5538 zsq2 = sqrt(1.+o2h*zuxy) - 1. 5539 zvxy = rpialf0*zy/(2.*zx) 5540 zaercn = puu(jl, 17) + zeu12 + zpu12 5541 zto1 = exp(-zvxy*zsq1-zaercn) 5542 zto2 = exp(-zvxy*zsq2-zaercn) 5543 5544 ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12) 5545 5546 ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 5547 5548 ! NEXOTIC=1 5549 ! IF (NEXOTIC.EQ.1) THEN 5550 zxch4 = puu(jl, 19) 5551 zych4 = puu(jl, 20) 5552 zuxy = 4.*zxch4*zxch4/(0.103*zych4) 5553 zsqh41 = sqrt(1.+33.7*zuxy) - 1. 5554 zvxy = 0.103*zych4/(2.*zxch4) 5555 zodh41 = zvxy*zsqh41 5556 5557 ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1 5558 5559 zxn2o = puu(jl, 21) 5560 zyn2o = puu(jl, 22) 5561 zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o) 5562 zsqn21 = sqrt(1.+21.3*zuxy) - 1. 5563 zvxy = 0.416*zyn2o/(2.*zxn2o) 5564 zodn21 = zvxy*zsqn21 5565 5566 ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 5567 5568 zuxy = 4.*zxch4*zxch4/(0.113*zych4) 5569 zsqh42 = sqrt(1.+400.*zuxy) - 1. 5570 zvxy = 0.113*zych4/(2.*zxch4) 5571 zodh42 = zvxy*zsqh42 5572 5573 ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 5574 5575 zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o) 5576 zsqn22 = sqrt(1.+2000.*zuxy) - 1. 5577 zvxy = 0.197*zyn2o/(2.*zxn2o) 5578 zodn22 = zvxy*zsqn22 5579 5580 ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 5581 5582 za11 = 2.*puu(jl, 23)*4.404E+05 5583 zttf11 = 1. - za11*0.003225 5584 5585 ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 5586 5587 za12 = 2.*puu(jl, 24)*6.7435E+05 5588 zttf12 = 1. - za12*0.003225 5589 5590 zuu11 = -puu(jl, 15) - zeu10 - zpu10 5591 zuu12 = -puu(jl, 16) - zeu11 - zpu11 - zodh41 - zodn21 5592 ptt(jl, 10) = exp(-puu(jl,14)) 5593 ptt(jl, 11) = exp(zuu11) 5594 ptt(jl, 12) = exp(zuu12)*zttf11*zttf12 5595 ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2 5596 ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13) 5597 ptt(jl, 15) = exp(-puu(jl,14)-zodh42-zodn22) 5598 END DO 5599 5600 RETURN 5601 END SUBROUTINE lwtt_lmdar4 5602 SUBROUTINE lwttm_lmdar4(pga, pgb, puu1, puu2, ptt) 5603 USE dimphy 5604 IMPLICIT NONE 5605 ! ym#include "dimensions.h" 5606 ! ym#include "dimphy.h" 5607 ! ym#include "raddim.h" 5608 include "raddimlw.h" 5609 5610 ! ------------------------------------------------------------------ 5611 ! PURPOSE. 5612 ! -------- 5613 ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE 5614 ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL 5615 ! INTERVALS. 5616 5617 ! METHOD. 5618 ! ------- 5619 5620 ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE 5621 ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM. 5622 ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL. 5623 ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN 5624 ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT. 5625 5626 ! REFERENCE. 5627 ! ---------- 5628 5629 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND 5630 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS 5631 5632 ! AUTHOR. 5633 ! ------- 5634 ! JEAN-JACQUES MORCRETTE *ECMWF* 5635 5636 ! MODIFICATIONS. 5637 ! -------------- 5638 ! ORIGINAL : 88-12-15 5639 5640 ! ----------------------------------------------------------------------- 5641 REAL (KIND=8) o1h, o2h 5642 PARAMETER (o1h=2230.) 5643 PARAMETER (o2h=100.) 5644 REAL (KIND=8) rpialf0 5645 PARAMETER (rpialf0=2.0) 5646 5647 ! * ARGUMENTS: 5648 5649 REAL (KIND=8) pga(kdlon, 8, 2) ! PADE APPROXIMANTS 5650 REAL (KIND=8) pgb(kdlon, 8, 2) ! PADE APPROXIMANTS 5651 REAL (KIND=8) puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1 5652 REAL (KIND=8) puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2 5653 REAL (KIND=8) ptt(kdlon, ntra) ! TRANSMISSION FUNCTIONS 5654 5655 ! * LOCAL VARIABLES: 5656 5657 INTEGER ja, jl 5658 REAL (KIND=8) zz, zxd, zxn 5659 REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13 5660 REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13 5661 REAL (KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2 5662 REAL (KIND=8) zxch4, zych4, zsqh41, zodh41 5663 REAL (KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42 5664 REAL (KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12 5665 REAL (KIND=8) zuu11, zuu12 5666 5667 ! ------------------------------------------------------------------ 5668 5669 ! * 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION 5670 ! ----------------------------------------------- 5671 5672 5673 5674 5675 ! CDIR ON_ADB(PUU1) 5676 ! CDIR ON_ADB(PUU2) 5677 ! CDIR COLLAPSE 5678 DO ja = 1, 8 5679 DO jl = 1, kdlon 5680 zz = sqrt(puu1(jl,ja)-puu2(jl,ja)) 5681 zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz) 5682 zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2)) 5683 ptt(jl, ja) = zxn/zxd 5684 END DO 5685 END DO 5686 5687 ! ------------------------------------------------------------------ 5688 5689 ! * 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS 5690 ! --------------------------------------------------- 5691 5692 5693 DO jl = 1, kdlon 5694 ptt(jl, 9) = ptt(jl, 8) 5695 5696 ! - CONTINUUM ABSORPTION: E- AND P-TYPE 5697 5698 zpu = 0.002*(puu1(jl,10)-puu2(jl,10)) 5699 zpu10 = 112.*zpu 5700 zpu11 = 6.25*zpu 5701 zpu12 = 5.00*zpu 5702 zpu13 = 80.0*zpu 5703 zeu = (puu1(jl,11)-puu2(jl,11)) 5704 zeu10 = 12.*zeu 5705 zeu11 = 6.25*zeu 5706 zeu12 = 5.00*zeu 5707 zeu13 = 80.0*zeu 5708 5709 ! - OZONE ABSORPTION 5710 5711 zx = (puu1(jl,12)-puu2(jl,12)) 5712 zy = (puu1(jl,13)-puu2(jl,13)) 5713 zuxy = 4.*zx*zx/(rpialf0*zy) 5714 zsq1 = sqrt(1.+o1h*zuxy) - 1. 5715 zsq2 = sqrt(1.+o2h*zuxy) - 1. 5716 zvxy = rpialf0*zy/(2.*zx) 5717 zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12 5718 zto1 = exp(-zvxy*zsq1-zaercn) 5719 zto2 = exp(-zvxy*zsq2-zaercn) 5720 5721 ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12) 5722 5723 ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1 5724 5725 zxch4 = (puu1(jl,19)-puu2(jl,19)) 5726 zych4 = (puu1(jl,20)-puu2(jl,20)) 5727 zuxy = 4.*zxch4*zxch4/(0.103*zych4) 5728 zsqh41 = sqrt(1.+33.7*zuxy) - 1. 5729 zvxy = 0.103*zych4/(2.*zxch4) 5730 zodh41 = zvxy*zsqh41 5731 5732 ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1 5733 5734 zxn2o = (puu1(jl,21)-puu2(jl,21)) 5735 zyn2o = (puu1(jl,22)-puu2(jl,22)) 5736 zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o) 5737 zsqn21 = sqrt(1.+21.3*zuxy) - 1. 5738 zvxy = 0.416*zyn2o/(2.*zxn2o) 5739 zodn21 = zvxy*zsqn21 5740 5741 ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1 5742 5743 zuxy = 4.*zxch4*zxch4/(0.113*zych4) 5744 zsqh42 = sqrt(1.+400.*zuxy) - 1. 5745 zvxy = 0.113*zych4/(2.*zxch4) 5746 zodh42 = zvxy*zsqh42 5747 5748 ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1 5749 5750 zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o) 5751 zsqn22 = sqrt(1.+2000.*zuxy) - 1. 5752 zvxy = 0.197*zyn2o/(2.*zxn2o) 5753 zodn22 = zvxy*zsqn22 5754 5755 ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1 5756 5757 za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05 5758 zttf11 = 1. - za11*0.003225 5759 5760 ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1 5761 5762 za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05 5763 zttf12 = 1. - za12*0.003225 5764 5765 zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10 5766 zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21 5767 ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14))) 5768 ptt(jl, 11) = exp(zuu11) 5769 ptt(jl, 12) = exp(zuu12)*zttf11*zttf12 5770 ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2 5771 ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13) 5772 ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22) 5773 END DO 5774 5775 RETURN 5776 END SUBROUTINE lwttm_lmdar4
Note: See TracChangeset
for help on using the changeset viewer.
